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 {..}) xs = mapM (terms (Unsupervised { _tt_model = Just m', .. })) xs
  86   where
  87     m' = case _tt_model of
  88       Just m''-> m''
  89       Nothing -> newTries _tt_windowSize (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 {..}) ns = Unsupervised { _tt_model = m', .. }
 100   where
 101     m' = case _tt_model of
 102       Nothing -> -- trace ("buildTries here" :: String)
 103                Just $ buildTries _tt_ngramsSize
 104                     $ fmap toToken
 105                     $ uniText
 106                     $ Text.intercalate " . "
 107                     $ List.concat
 108                     $ map hasText ns
 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 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 { .. }) txt = termsUnsupervised (Unsupervised { _tt_model = Just m', .. }) txt
 176   where
 177     m' = maybe (newTries _tt_ngramsSize txt) identity _tt_model
 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