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 insertExtractedNgrams :: [ ExtractedNgrams ] -> Cmd err (HashMap Text NgramsId)
 149 insertExtractedNgrams ngs = do
 150   let (s, e) = List.partition isSimpleNgrams ngs
 151   m1 <- insertNgrams       (map unSimpleNgrams   s)
 152   --printDebug "others" m1
 153
 154   m2 <- insertNgramsPostag (map unEnrichedNgrams e)
 155   --printDebug "terms" m2
 156
 157   let result = HashMap.union m1 m2
 158   pure result
 159
 160 isSimpleNgrams :: ExtractedNgrams -> Bool
 161 isSimpleNgrams (SimpleNgrams _) = True
 162 isSimpleNgrams _                = False
 163
 164 ------------------------------------------------------------------------
 165 -- | Terms from Text
 166 -- Mono : mono terms
 167 -- Multi : multi terms
 168 -- MonoMulti : mono and multi
 169 -- TODO : multi terms should exclude mono (intersection is not empty yet)
 170 terms :: TermType Lang -> Text -> IO [Terms]
 171 terms (Mono      lang) txt = pure $ monoTerms lang txt
 172 terms (Multi     lang) txt = multiterms lang txt
 173 terms (MonoMulti lang) txt = terms (Multi lang) txt
 174 terms (Unsupervised lang n s m) txt = termsUnsupervised (Unsupervised lang n s (Just m')) txt
 175   where
 176     m' = maybe (newTries n txt) identity m
 177 -- terms (WithList  list) txt = pure . concat $ extractTermsWithList list txt
 178
 179
 180 ------------------------------------------------------------------------
 181 -- | Unsupervised ngrams extraction
 182 -- language agnostic extraction
 183 -- TODO: remove IO
 184 -- TODO: newtype BlockText
 185
 186 type WindowSize = Int
 187 type MinNgramSize = Int
 188
 189 termsUnsupervised :: TermType Lang -> Text -> IO [Terms]
 190 termsUnsupervised (Unsupervised l n s m) =
 191                pure
 192              . map (text2term l)
 193              . List.nub
 194              . (List.filter (\l' -> List.length l' >= s))
 195              . List.concat
 196              . mainEleveWith (maybe (panic "no model") identity m) n
 197              . uniText
 198 termsUnsupervised _ = undefined
 199
 200
 201
 202 newTries :: Int -> Text -> Tries Token ()
 203 newTries n t = buildTries n (fmap toToken $ uniText t)
 204
 205 -- | TODO removing long terms > 24
 206 uniText :: Text -> [[Text]]
 207 uniText = map (List.filter (not . isPunctuation))
 208         . map tokenize
 209         . sentences       -- TODO get sentences according to lang
 210         . Text.toLower
 211
 212 text2term :: Lang -> [Text] -> Terms
 213 text2term _ [] = Terms [] Set.empty
 214 text2term lang txt = Terms txt (Set.fromList $ map (stem lang) txt)
 215
 216 isPunctuation :: Text -> Bool
 217 isPunctuation x = List.elem x $  (Text.pack . pure)
 218                              <$> ("!?(),;.:" :: String)
 219
 220