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                                    )
 109       just_m -> just_m
 110 withLang l _ = l
 111
 112 ------------------------------------------------------------------------
 113 data ExtractedNgrams = SimpleNgrams   { unSimpleNgrams   :: Ngrams       }
 114                      | EnrichedNgrams { unEnrichedNgrams :: NgramsPostag }
 115   deriving (Eq, Ord, Generic, Show)
 116
 117 instance Hashable ExtractedNgrams
 118
 119 class ExtractNgramsT h
 120   where
 121     extractNgramsT :: HasText h
 122                    => TermType Lang
 123                    -> h
 124                    -> Cmd err (HashMap ExtractedNgrams (Map NgramsType Int))
 125 ------------------------------------------------------------------------
 126 enrichedTerms :: Lang -> PosTagAlgo -> POS -> Terms -> NgramsPostag
 127 enrichedTerms l pa po (Terms ng1 ng2) =
 128   NgramsPostag l pa po form lem
 129     where
 130       form = text2ngrams $ Text.intercalate " " ng1
 131       lem  = text2ngrams $ Text.intercalate " " $ Set.toList ng2
 132
 133 ------------------------------------------------------------------------
 134 cleanNgrams :: Int -> Ngrams -> Ngrams
 135 cleanNgrams s ng
 136       | Text.length (ng ^. ngramsTerms) < s = ng
 137       | otherwise                           = text2ngrams (Text.take s (ng ^. ngramsTerms))
 138
 139 cleanExtractedNgrams :: Int -> ExtractedNgrams -> ExtractedNgrams
 140 cleanExtractedNgrams s (SimpleNgrams   ng) = SimpleNgrams $ (cleanNgrams s) ng
 141 cleanExtractedNgrams s (EnrichedNgrams ng) = EnrichedNgrams $ over np_form (cleanNgrams s)
 142                                                             $ over np_lem  (cleanNgrams s) ng
 143
 144 extracted2ngrams :: ExtractedNgrams -> Ngrams
 145 extracted2ngrams (SimpleNgrams   ng) = ng
 146 extracted2ngrams (EnrichedNgrams ng) = view np_form ng
 147
 148
 149 ---------------------------
 150 insertExtractedNgrams :: [ ExtractedNgrams ] -> Cmd err (HashMap Text NgramsId)
 151 insertExtractedNgrams ngs = do
 152   let (s, e) = List.partition isSimpleNgrams ngs
 153   m1 <- insertNgrams       (map unSimpleNgrams   s)
 154   --printDebug "others" m1
 155
 156   m2 <- insertNgramsPostag (map unEnrichedNgrams e)
 157   --printDebug "terms" m2
 158
 159   let result = HashMap.union m1 m2
 160   pure result
 161
 162 isSimpleNgrams :: ExtractedNgrams -> Bool
 163 isSimpleNgrams (SimpleNgrams _) = True
 164 isSimpleNgrams _                = False
 165
 166 ------------------------------------------------------------------------
 167 -- | Terms from Text
 168 -- Mono : mono terms
 169 -- Multi : multi terms
 170 -- MonoMulti : mono and multi
 171 -- TODO : multi terms should exclude mono (intersection is not empty yet)
 172 terms :: TermType Lang -> Text -> IO [Terms]
 173 terms (Mono      lang) txt = pure $ monoTerms lang txt
 174 terms (Multi     lang) txt = multiterms lang txt
 175 terms (MonoMulti lang) txt = terms (Multi lang) txt
 176 terms (Unsupervised lang n s m) txt = termsUnsupervised (Unsupervised lang n s (Just m')) txt
 177   where
 178     m' = maybe (newTries n txt) identity m
 179 -- terms (WithList  list) txt = pure . concat $ extractTermsWithList list txt
 180
 181
 182 ------------------------------------------------------------------------
 183 -- | Unsupervised ngrams extraction
 184 -- language agnostic extraction
 185 -- TODO: remove IO
 186 -- TODO: newtype BlockText
 187
 188 type WindowSize = Int
 189 type MinNgramSize = Int
 190
 191 termsUnsupervised :: TermType Lang -> Text -> IO [Terms]
 192 termsUnsupervised (Unsupervised l n s m) =
 193                pure
 194              . map (text2term l)
 195              . List.nub
 196              . (List.filter (\l' -> List.length l' >= s))
 197              . List.concat
 198              . mainEleveWith (maybe (panic "no model") identity m) n
 199              . uniText
 200 termsUnsupervised _ = undefined
 201
 202
 203
 204 newTries :: Int -> Text -> Tries Token ()
 205 newTries n t = buildTries n (fmap toToken $ uniText t)
 206
 207 -- | TODO removing long terms > 24
 208 uniText :: Text -> [[Text]]
 209 uniText = map (List.filter (not . isPunctuation))
 210         . map tokenize
 211         . sentences       -- TODO get sentences according to lang
 212         . Text.toLower
 213
 214 text2term :: Lang -> [Text] -> Terms
 215 text2term _ [] = Terms [] Set.empty
 216 text2term lang txt = Terms txt (Set.fromList $ map (stem lang) txt)
 217
 218 isPunctuation :: Text -> Bool
 219 isPunctuation x = List.elem x $  (Text.pack . pure)
 220                              <$> ("!?(),;." :: String)
 221
 222