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
  50 import Gargantext.Core
  51 import Gargantext.Core.Text (sentences, HasText(..))
  52 import Gargantext.Core.Text.Terms.Eleve (mainEleveWith, Tries, Token, buildTries, toToken)
  53 import Gargantext.Core.Text.Terms.Mono  (monoTerms)
  54 import Gargantext.Core.Text.Terms.Mono.Stem (stem)
  55 import Gargantext.Core.Text.Terms.Mono.Token.En (tokenize)
  56 import Gargantext.Core.Text.Terms.Multi (multiterms)
  57 import Gargantext.Core.Types
  58 import Gargantext.Database.Prelude (Cmd)
  59 import Gargantext.Database.Query.Table.Ngrams (insertNgrams)
  60 import Gargantext.Database.Query.Table.NgramsPostag (NgramsPostag(..), insertNgramsPostag, np_form, np_lem)
  61 import Gargantext.Database.Schema.Ngrams (Ngrams(..), NgramsType(..), ngramsTerms, text2ngrams, NgramsId)
  62 import Gargantext.Prelude
  63
  64 data TermType lang
  65   = Mono      { _tt_lang :: !lang }
  66   | Multi     { _tt_lang :: !lang }
  67   | MonoMulti { _tt_lang :: !lang }
  68   | Unsupervised { _tt_lang       :: !lang
  69                  , _tt_windowSize :: !Int
  70                  , _tt_ngramsSize :: !Int
  71                  , _tt_model      :: !(Maybe (Tries Token ()))
  72                  }
  73   deriving Generic
  74
  75 makeLenses ''TermType
  76 --group :: [Text] -> [Text]
  77 --group = undefined
  78
  79 -- remove Stop Words
  80 -- map (filter (\t -> not . elem t)) $
  81 ------------------------------------------------------------------------
  82 -- | Sugar to extract terms from text (hiddeng mapM from end user).
  83 --extractTerms :: Traversable t => TermType Lang -> t Text -> IO (t [Terms])
  84 extractTerms :: TermType Lang -> [Text] -> IO [[Terms]]
  85
  86 extractTerms (Unsupervised l n s m) xs = mapM (terms (Unsupervised l n s (Just m'))) xs
  87   where
  88     m' = case m of
  89       Just m''-> m''
  90       Nothing -> newTries n (Text.intercalate " " xs)
  91
  92 extractTerms termTypeLang xs = mapM (terms termTypeLang) xs
  93
  94
  95 ------------------------------------------------------------------------
  96 withLang :: (Foldable t, Functor t, HasText h)
  97          => TermType Lang
  98          -> t h
  99          -> TermType Lang
 100 withLang (Unsupervised l n s m) ns = Unsupervised l n s m'
 101   where
 102     m' = case m of
 103       Nothing -> -- trace ("buildTries here" :: String)
 104                Just $ buildTries n ( fmap toToken
 105                                    $ uniText
 106                                    $ Text.intercalate " . "
 107                                    $ List.concat
 108                                    $ map hasText ns
 109                                    )
 110       just_m -> just_m
 111 withLang l _ = l
 112
 113 ------------------------------------------------------------------------
 114 data ExtractedNgrams = SimpleNgrams   { unSimpleNgrams   :: Ngrams       }
 115                      | EnrichedNgrams { unEnrichedNgrams :: NgramsPostag }
 116   deriving (Eq, Ord, Generic, Show)
 117
 118 instance Hashable ExtractedNgrams
 119
 120 class ExtractNgramsT h
 121   where
 122     extractNgramsT :: HasText h
 123                    => TermType Lang
 124                    -> h
 125                    -> Cmd err (HashMap ExtractedNgrams (Map NgramsType Int))
 126 ------------------------------------------------------------------------
 127 enrichedTerms :: Lang -> PosTagAlgo -> POS -> Terms -> NgramsPostag
 128 enrichedTerms l pa po (Terms ng1 ng2) =
 129   NgramsPostag l pa po form lem
 130     where
 131       form = text2ngrams $ Text.intercalate " " ng1
 132       lem  = text2ngrams $ Text.intercalate " " $ Set.toList ng2
 133
 134 ------------------------------------------------------------------------
 135 cleanNgrams :: Int -> Ngrams -> Ngrams
 136 cleanNgrams s ng
 137       | Text.length (ng ^. ngramsTerms) < s = ng
 138       | otherwise                           = text2ngrams (Text.take s (ng ^. ngramsTerms))
 139
 140 cleanExtractedNgrams :: Int -> ExtractedNgrams -> ExtractedNgrams
 141 cleanExtractedNgrams s (SimpleNgrams   ng) = SimpleNgrams $ (cleanNgrams s) ng
 142 cleanExtractedNgrams s (EnrichedNgrams ng) = EnrichedNgrams $ over np_form (cleanNgrams s)
 143                                                             $ over np_lem  (cleanNgrams s) ng
 144
 145 extracted2ngrams :: ExtractedNgrams -> Ngrams
 146 extracted2ngrams (SimpleNgrams   ng) = ng
 147 extracted2ngrams (EnrichedNgrams ng) = view np_form ng
 148
 149
 150 ---------------------------
 151 insertExtractedNgrams :: [ ExtractedNgrams ] -> Cmd err (HashMap Text NgramsId)
 152 insertExtractedNgrams ngs = do
 153   let (s, e) = List.partition isSimpleNgrams ngs
 154   m1 <- if List.null s
 155            then pure HashMap.empty
 156            else insertNgrams       (map unSimpleNgrams   s)
 157   m2 <- if List.null e
 158            then pure HashMap.empty
 159            else insertNgramsPostag (map unEnrichedNgrams e)
 160   pure $ m1 <> m2
 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