src/Gargantext/Core/Text/Terms.hs

   1 {-|
   2 Module      : Gargantext.Core.Text.Ngrams
   3 Description : Ngrams definition and tools
   4 Copyright   : (c) CNRS, 2017 - present
   5 License     : AGPL + CECILL v3
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9
  10 An @n-gram@ is a contiguous sequence of n items from a given sample of
  11 text. In Gargantext application the items are words, n is a non negative
  12 integer.
  13
  14 Using Latin numerical prefixes, an n-gram of size 1 is referred to as a
  15 "unigram"; size 2 is a "bigram" (or, less commonly, a "digram"); size
  16 3 is a "trigram". English cardinal numbers are sometimes used, e.g.,
  17 "four-gram", "five-gram", and so on.
  18
  19 Source: https://en.wikipedia.org/wiki/Ngrams
  20
  21 TODO
  22 group Ngrams -> Tree
  23 compute occ by node of Tree
  24 group occs according groups
  25
  26 compute cooccurrences
  27 compute graph
  28
  29 -}
  30
  31 {-# LANGUAGE TemplateHaskell   #-}
  32 {-# LANGUAGE ConstrainedClassMethods #-}
  33
  34 module Gargantext.Core.Text.Terms
  35   where
  36
  37 import Control.Lens
  38 import Data.HashMap.Strict (HashMap)
  39 import Data.Hashable (Hashable)
  40 import Data.Map (Map)
  41 import Data.Text (Text)
  42 import Data.Traversable
  43 import GHC.Base (String)
  44 import GHC.Generics (Generic)
  45 import qualified Data.List           as List
  46 import qualified Data.Set            as Set
  47 import qualified Data.Text           as Text
  48 import qualified Data.HashMap.Strict as HashMap
  49 import Gargantext.Core
  50 import Gargantext.Core.Text (sentences, HasText(..))
  51 import Gargantext.Core.Text.Terms.Eleve (mainEleveWith, Tries, Token, buildTries, toToken)
  52 import Gargantext.Core.Text.Terms.Mono  (monoTerms)
  53 import Gargantext.Core.Text.Terms.Mono.Stem (stem)
  54 import Gargantext.Core.Text.Terms.Mono.Token.En (tokenize)
  55 import Gargantext.Core.Text.Terms.Multi (multiterms)
  56 import Gargantext.Core.Types
  57 import Gargantext.Database.Prelude (Cmd)
  58 import Gargantext.Database.Query.Table.Ngrams (insertNgrams)
  59 import Gargantext.Database.Query.Table.NgramsPostag (NgramsPostag(..), insertNgramsPostag, np_form, np_lem)
  60 import Gargantext.Database.Schema.Ngrams (Ngrams(..), NgramsType(..), ngramsTerms, text2ngrams, NgramsId)
  61 import Gargantext.Prelude
  62
  63 data TermType lang
  64   = Mono      { _tt_lang :: !lang }
  65   | Multi     { _tt_lang :: !lang }
  66   | MonoMulti { _tt_lang :: !lang }
  67   | Unsupervised { _tt_lang       :: !lang
  68                  , _tt_windowSize :: !Int
  69                  , _tt_ngramsSize :: !Int
  70                  , _tt_model      :: !(Maybe (Tries Token ()))
  71                  }
  72   deriving Generic
  73
  74 makeLenses ''TermType
  75 --group :: [Text] -> [Text]
  76 --group = undefined
  77
  78 -- remove Stop Words
  79 -- map (filter (\t -> not . elem t)) $
  80 ------------------------------------------------------------------------
  81 -- | Sugar to extract terms from text (hiddeng mapM from end user).
  82 --extractTerms :: Traversable t => TermType Lang -> t Text -> IO (t [Terms])
  83 extractTerms :: TermType Lang -> [Text] -> IO [[Terms]]
  84
  85 extractTerms (Unsupervised l n s m) xs = mapM (terms (Unsupervised l n s (Just m'))) xs
  86   where
  87     m' = case m of
  88       Just m''-> m''
  89       Nothing -> newTries n (Text.intercalate " " xs)
  90
  91 extractTerms termTypeLang xs = mapM (terms termTypeLang) xs
  92
  93
  94 ------------------------------------------------------------------------
  95 withLang :: (Foldable t, Functor t, HasText h)
  96          => TermType Lang
  97          -> t h
  98          -> TermType Lang
  99 withLang (Unsupervised l n s m) ns = Unsupervised l n s m'
 100   where
 101     m' = case m of
 102       Nothing -> -- trace ("buildTries here" :: String)
 103                Just $ buildTries n $ fmap toToken
 104                                    $ uniText
 105                                    $ Text.intercalate " . "
 106                                    $ List.concat
 107                                    $ map hasText ns
 108       just_m -> just_m
 109 withLang l _ = l
 110
 111 ------------------------------------------------------------------------
 112 data ExtractedNgrams = SimpleNgrams   { unSimpleNgrams   :: Ngrams       }
 113                      | EnrichedNgrams { unEnrichedNgrams :: NgramsPostag }
 114   deriving (Eq, Ord, Generic, Show)
 115
 116 instance Hashable ExtractedNgrams
 117
 118 class ExtractNgramsT h
 119   where
 120     extractNgramsT :: HasText h
 121                    => TermType Lang
 122                    -> h
 123                    -> Cmd err (HashMap ExtractedNgrams (Map NgramsType Int))
 124 ------------------------------------------------------------------------
 125 enrichedTerms :: Lang -> PosTagAlgo -> POS -> Terms -> NgramsPostag
 126 enrichedTerms l pa po (Terms ng1 ng2) =
 127   NgramsPostag l pa po form lem
 128     where
 129       form = text2ngrams $ Text.intercalate " " ng1
 130       lem  = text2ngrams $ Text.intercalate " " $ Set.toList ng2
 131
 132 ------------------------------------------------------------------------
 133 cleanNgrams :: Int -> Ngrams -> Ngrams
 134 cleanNgrams s ng
 135       | Text.length (ng ^. ngramsTerms) < s = ng
 136       | otherwise                           = text2ngrams (Text.take s (ng ^. ngramsTerms))
 137
 138 cleanExtractedNgrams :: Int -> ExtractedNgrams -> ExtractedNgrams
 139 cleanExtractedNgrams s (SimpleNgrams   ng) = SimpleNgrams $ (cleanNgrams s) ng
 140 cleanExtractedNgrams s (EnrichedNgrams ng) = EnrichedNgrams $ over np_form (cleanNgrams s)
 141                                                             $ over np_lem  (cleanNgrams s) ng
 142
 143 extracted2ngrams :: ExtractedNgrams -> Ngrams
 144 extracted2ngrams (SimpleNgrams   ng) = ng
 145 extracted2ngrams (EnrichedNgrams ng) = view np_form ng
 146
 147
 148 ---------------------------
 149 insertExtractedNgrams :: [ ExtractedNgrams ] -> Cmd err (HashMap Text NgramsId)
 150 insertExtractedNgrams ngs = do
 151   let (s, e) = List.partition isSimpleNgrams ngs
 152   m1 <- insertNgrams       (map unSimpleNgrams   s)
 153   --printDebug "others" m1
 154
 155   m2 <- insertNgramsPostag (map unEnrichedNgrams e)
 156   --printDebug "terms" m2
 157
 158   let result = HashMap.union m1 m2
 159   pure result
 160
 161 isSimpleNgrams :: ExtractedNgrams -> Bool
 162 isSimpleNgrams (SimpleNgrams _) = True
 163 isSimpleNgrams _                = False
 164
 165 ------------------------------------------------------------------------
 166 -- | Terms from Text
 167 -- Mono : mono terms
 168 -- Multi : multi terms
 169 -- MonoMulti : mono and multi
 170 -- TODO : multi terms should exclude mono (intersection is not empty yet)
 171 terms :: TermType Lang -> Text -> IO [Terms]
 172 terms (Mono      lang) txt = pure $ monoTerms lang txt
 173 terms (Multi     lang) txt = multiterms lang txt
 174 terms (MonoMulti lang) txt = terms (Multi lang) txt
 175 terms (Unsupervised lang n s m) txt = termsUnsupervised (Unsupervised lang n s (Just m')) txt
 176   where
 177     m' = maybe (newTries n txt) identity m
 178 -- terms (WithList  list) txt = pure . concat $ extractTermsWithList list txt
 179
 180
 181 ------------------------------------------------------------------------
 182 -- | Unsupervised ngrams extraction
 183 -- language agnostic extraction
 184 -- TODO: remove IO
 185 -- TODO: newtype BlockText
 186
 187 type WindowSize = Int
 188 type MinNgramSize = Int
 189
 190 termsUnsupervised :: TermType Lang -> Text -> IO [Terms]
 191 termsUnsupervised (Unsupervised l n s m) =
 192                pure
 193              . map (text2term l)
 194              . List.nub
 195              . (List.filter (\l' -> List.length l' >= s))
 196              . List.concat
 197              . mainEleveWith (maybe (panic "no model") identity m) n
 198              . uniText
 199 termsUnsupervised _ = undefined
 200
 201
 202
 203 newTries :: Int -> Text -> Tries Token ()
 204 newTries n t = buildTries n (fmap toToken $ uniText t)
 205
 206 -- | TODO removing long terms > 24
 207 uniText :: Text -> [[Text]]
 208 uniText = map (List.filter (not . isPunctuation))
 209         . map tokenize
 210         . sentences       -- TODO get sentences according to lang
 211         . Text.toLower
 212
 213 text2term :: Lang -> [Text] -> Terms
 214 text2term _ [] = Terms [] Set.empty
 215 text2term lang txt = Terms txt (Set.fromList $ map (stem lang) txt)
 216
 217 isPunctuation :: Text -> Bool
 218 isPunctuation x = List.elem x $  (Text.pack . pure)
 219                              <$> ("!?(),;." :: String)
 220
 221