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.Map (Map)
  40 import Data.Text (Text)
  41 import Data.Traversable
  42 import GHC.Base (String)
  43 import GHC.Generics (Generic)
  44 import qualified Data.List as List
  45 import qualified Data.Map as Map
  46 import qualified Data.Set  as Set
  47 import qualified Data.Text as Text
  48 import qualified Gargantext.Data.HashMap.Strict.Utils as HashMap
  49
  50 import Gargantext.Core
  51 import Gargantext.Core.Flow.Types
  52 import Gargantext.Core.Text (sentences, HasText(..))
  53 import Gargantext.Core.Text.Terms.Eleve (mainEleveWith, Tries, Token, buildTries, toToken)
  54 import Gargantext.Core.Text.Terms.Mono  (monoTerms)
  55 import Gargantext.Core.Text.Terms.Mono.Stem (stem)
  56 import Gargantext.Core.Text.Terms.Mono.Token.En (tokenize)
  57 import Gargantext.Core.Text.Terms.Multi (multiterms)
  58 import Gargantext.Core.Types
  59 import Gargantext.Database.Prelude (Cmd)
  60 import Gargantext.Database.Schema.Ngrams (Ngrams(..), NgramsType(..), ngramsTerms, text2ngrams)
  61 import Gargantext.Prelude
  62
  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 class ExtractNgramsT h
 115   where
 116     extractNgramsT :: HasText h
 117                    => TermType Lang
 118                    -> h
 119                    -> Cmd err (HashMap Ngrams (Map NgramsType Int))
 120
 121
 122
 123 filterNgrams :: Int -> HashMap Ngrams (Map NgramsType Int)
 124                     -> HashMap Ngrams (Map NgramsType Int)
 125 filterNgrams s = HashMap.mapKeys filter
 126   where
 127     filter ng
 128       | Text.length (ng ^. ngramsTerms) < s = ng
 129       | otherwise                           = text2ngrams (Text.take s (ng ^. ngramsTerms))
 130
 131
 132 -- =======================================================
 133
 134 -- | Terms from Text
 135 -- Mono : mono terms
 136 -- Multi : multi terms
 137 -- MonoMulti : mono and multi
 138 -- TODO : multi terms should exclude mono (intersection is not empty yet)
 139 terms :: TermType Lang -> Text -> IO [Terms]
 140 terms (Mono      lang) txt = pure $ monoTerms lang txt
 141 terms (Multi     lang) txt = multiterms lang txt
 142 terms (MonoMulti lang) txt = terms (Multi lang) txt
 143 terms (Unsupervised lang n s m) txt = termsUnsupervised (Unsupervised lang n s (Just m')) txt
 144   where
 145     m' = maybe (newTries n txt) identity m
 146 -- terms (WithList  list) txt = pure . concat $ extractTermsWithList list txt
 147
 148
 149 ------------------------------------------------------------------------
 150
 151 text2term :: Lang -> [Text] -> Terms
 152 text2term _ [] = Terms [] Set.empty
 153 text2term lang txt = Terms txt (Set.fromList $ map (stem lang) txt)
 154
 155 isPunctuation :: Text -> Bool
 156 isPunctuation x = List.elem x $  (Text.pack . pure)
 157                              <$> ("!?(),;." :: String)
 158
 159 -- | Unsupervised ngrams extraction
 160 -- language agnostic extraction
 161 -- TODO: remove IO
 162 -- TODO: newtype BlockText
 163
 164 type WindowSize = Int
 165 type MinNgramSize = Int
 166
 167 termsUnsupervised :: TermType Lang -> Text -> IO [Terms]
 168 termsUnsupervised (Unsupervised l n s m) =
 169                pure
 170              . map (text2term l)
 171              . List.nub
 172              . (List.filter (\l' -> List.length l' >= s))
 173              . List.concat
 174              . mainEleveWith (maybe (panic "no model") identity m) n
 175              . uniText
 176 termsUnsupervised _ = undefined
 177
 178 newTries :: Int -> Text -> Tries Token ()
 179 newTries n t = buildTries n (fmap toToken $ uniText t)
 180
 181 -- | TODO removing long terms > 24
 182 uniText :: Text -> [[Text]]
 183 uniText = map (List.filter (not . isPunctuation))
 184         . map tokenize
 185         . sentences       -- TODO get sentences according to lang
 186         . Text.toLower
 187