]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/Core/Text/Terms.hs
[search] fix for plainto_tsquery for docs search
[gargantext.git] / 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