]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/Database/Metrics/NgramsByNode.hs
Merge branch 'dev-phylo' of ssh://gitlab.iscpif.fr:20022/gargantext/haskell-gargantex...
[gargantext.git] / src / Gargantext / Database / Metrics / NgramsByNode.hs
1 {-|
2 Module : Gargantext.Database.Metrics.NgramsByNode
3 Description : Ngrams by Node user and master
4 Copyright : (c) CNRS, 2017-Present
5 License : AGPL + CECILL v3
6 Maintainer : team@gargantext.org
7 Stability : experimental
8 Portability : POSIX
9
10 Ngrams by node enable contextual metrics.
11
12 -}
13
14 {-# LANGUAGE QuasiQuotes #-}
15 {-# LANGUAGE NoImplicitPrelude #-}
16 {-# LANGUAGE OverloadedStrings #-}
17 {-# LANGUAGE RankNTypes #-}
18
19 module Gargantext.Database.Metrics.NgramsByNode
20 where
21
22 import Debug.Trace (trace)
23 import Data.Map.Strict (Map, fromListWith, elems, toList, fromList)
24 import Data.Map.Strict.Patch (PatchMap, Replace, diff)
25 import Data.Set (Set)
26 import Data.Text (Text)
27 import Data.Tuple.Extra (second, swap)
28 import Database.PostgreSQL.Simple.SqlQQ (sql)
29 import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
30 import Gargantext.Core (Lang(..))
31 import Gargantext.Database.Config (nodeTypeId)
32 import Gargantext.Database.Schema.Ngrams (ngramsTypeId, NgramsType(..))
33 import Gargantext.Database.Types.Node -- (ListId, CorpusId, NodeId)
34 import Gargantext.Database.Utils (Cmd, runPGSQuery)
35 import Gargantext.Prelude
36 import Gargantext.Text.Metrics.TFICF
37 import Gargantext.Text.Terms.Mono.Stem (stem)
38 import qualified Data.List as List
39 import qualified Data.Map.Strict as Map
40 import qualified Data.Set as Set
41 import qualified Data.Text as Text
42 import qualified Database.PostgreSQL.Simple as DPS
43
44 -- | TODO: group with 2 terms only can be
45 -- discussed. Main purpose of this is offering
46 -- a first grouping option to user and get some
47 -- enriched data to better learn and improve that algo
48 ngramsGroup :: Lang -> Int -> Int -> Text -> Text
49 ngramsGroup l _m _n = Text.intercalate " "
50 . map (stem l)
51 -- . take n
52 . List.sort
53 -- . (List.filter (\t -> Text.length t > m))
54 . Text.splitOn " "
55 . Text.replace "-" " "
56
57
58 sortTficf :: (Map Text (Double, Set Text))
59 -> [ (Text,(Double, Set Text))]
60 sortTficf = List.sortOn (fst . snd) . toList
61
62
63 getTficf' :: UserCorpusId -> MasterCorpusId -> NgramsType -> (Text -> Text)
64 -> Cmd err (Map Text (Double, Set Text))
65 getTficf' u m nt f = do
66 u' <- getNodesByNgramsUser u nt
67 m' <- getNodesByNgramsMaster u m
68
69 pure $ toTficfData (countNodesByNgramsWith f u')
70 (countNodesByNgramsWith f m')
71
72 getTficfWith :: UserCorpusId -> MasterCorpusId -> [ListId]
73 -> NgramsType -> Map Text (Maybe Text)
74 -> Cmd err (Map Text (Double, Set Text))
75 getTficfWith u m ls nt mtxt = do
76 u' <- getNodesByNgramsOnlyUser u ls nt (Map.keys mtxt)
77 m' <- getNodesByNgramsMaster u m
78
79 let f x = case Map.lookup x mtxt of
80 Nothing -> x
81 Just x' -> maybe x identity x'
82
83 pure $ toTficfData (countNodesByNgramsWith f u')
84 (countNodesByNgramsWith f m')
85
86
87 type Context = (Double, Map Text (Double, Set Text))
88 type Supra = Context
89 type Infra = Context
90
91 toTficfData :: Infra -> Supra
92 -> Map Text (Double, Set Text)
93 toTficfData (ti, mi) (ts, ms) =
94 fromList [ (t, ( tficf (TficfInfra (Count n )(Total ti))
95 (TficfSupra (Count $ maybe 0 fst $ Map.lookup t ms)(Total ts))
96 , ns
97 )
98 )
99 | (t, (n,ns)) <- toList mi
100 ]
101
102
103 -- | fst is size of Supra Corpus
104 -- snd is Texts and size of Occurrences (different docs)
105 countNodesByNgramsWith :: (Text -> Text)
106 -> Map Text (Set NodeId)
107 -> (Double, Map Text (Double, Set Text))
108 countNodesByNgramsWith f m = (total, m')
109 where
110 total = fromIntegral $ Set.size $ Set.unions $ elems m
111 m' = Map.map ( swap . second (fromIntegral . Set.size))
112 $ groupNodesByNgramsWith f m
113
114
115 groupNodesByNgramsWith :: (Text -> Text)
116 -> Map Text (Set NodeId)
117 -> Map Text (Set Text, Set NodeId)
118 groupNodesByNgramsWith f m =
119 fromListWith (<>) $ map (\(t,ns) -> (f t, (Set.singleton t, ns)))
120 $ toList m
121
122 ------------------------------------------------------------------------
123 getNodesByNgramsUser :: CorpusId
124 -> NgramsType
125 -> Cmd err (Map Text (Set NodeId))
126 getNodesByNgramsUser cId nt =
127 fromListWith (<>) <$> map (\(n,t) -> (t, Set.singleton n))
128 <$> selectNgramsByNodeUser cId nt
129 where
130
131 selectNgramsByNodeUser :: CorpusId -> NgramsType
132 -> Cmd err [(NodeId, Text)]
133 selectNgramsByNodeUser cId' nt' =
134 runPGSQuery queryNgramsByNodeUser
135 ( cId'
136 , nodeTypeId NodeDocument
137 , ngramsTypeId nt'
138 -- , 100 :: Int -- limit
139 -- , 0 :: Int -- offset
140 )
141
142 queryNgramsByNodeUser :: DPS.Query
143 queryNgramsByNodeUser = [sql|
144 SELECT nng.node2_id, ng.terms FROM node_node_ngrams nng
145 JOIN ngrams ng ON nng.ngrams_id = ng.id
146 JOIN nodes_nodes nn ON nn.node2_id = nng.node2_id
147 JOIN nodes n ON nn.node2_id = n.id
148 WHERE nn.node1_id = ? -- CorpusId
149 AND n.typename = ? -- NodeTypeId
150 AND nng.ngrams_type = ? -- NgramsTypeId
151 AND nn.category > 0
152 GROUP BY nng.node2_id, ng.terms
153 ORDER BY (nng.node2_id, ng.terms) DESC
154 -- LIMIT ?
155 -- OFFSET ?
156 |]
157 ------------------------------------------------------------------------
158 -- TODO add groups
159 getOccByNgramsOnlyFast :: CorpusId
160 -> NgramsType
161 -> [Text]
162 -> Cmd err (Map Text Int)
163 getOccByNgramsOnlyFast cId nt ngs =
164 fromListWith (+) <$> selectNgramsOccurrencesOnlyByNodeUser cId nt ngs
165
166
167 getOccByNgramsOnlyFast' :: CorpusId
168 -> ListId
169 -> NgramsType
170 -> [Text]
171 -> Cmd err (Map Text Int)
172 getOccByNgramsOnlyFast' cId lId nt tms = trace (show (cId, lId)) $
173 fromListWith (+) <$> map (second round) <$> run cId lId nt tms
174
175 where
176 fields = [QualifiedIdentifier Nothing "text"]
177
178 run :: CorpusId
179 -> ListId
180 -> NgramsType
181 -> [Text]
182 -> Cmd err [(Text, Double)]
183 run cId' lId' _nt' tms' = runPGSQuery query
184 ( Values fields (DPS.Only <$> tms')
185 , cId'
186 , lId'
187 -- , ngramsTypeId nt'
188 )
189
190 query :: DPS.Query
191 query = [sql|
192 WITH input_rows(terms) AS (?)
193 SELECT ng.terms, nng.weight FROM node_node_ngrams nng
194 JOIN ngrams ng ON nng.ngrams_id = ng.id
195 JOIN input_rows ir ON ir.terms = ng.terms
196 WHERE nng.node1_id = ? -- CorpusId
197 AND nng.node2_id = ?
198 -- AND nng.ngrams_type = ? -- NgramsTypeId
199 -- AND nn.category > 0
200 GROUP BY ng.terms, nng.weight
201 |]
202
203
204
205
206 -- just slower than getOccByNgramsOnlyFast
207 getOccByNgramsOnlySlow :: NodeType
208 -> CorpusId
209 -> [ListId]
210 -> NgramsType
211 -> [Text]
212 -> Cmd err (Map Text Int)
213 getOccByNgramsOnlySlow t cId ls nt ngs =
214 Map.map Set.size <$> getScore' t cId ls nt ngs
215 where
216 getScore' NodeCorpus = getNodesByNgramsOnlyUser
217 getScore' NodeDocument = getNgramsByDocOnlyUser
218 getScore' _ = getNodesByNgramsOnlyUser
219
220 getOccByNgramsOnlySafe :: CorpusId
221 -> [ListId]
222 -> NgramsType
223 -> [Text]
224 -> Cmd err (Map Text Int)
225 getOccByNgramsOnlySafe cId ls nt ngs = do
226 printDebug "getOccByNgramsOnlySafe" (cId, nt, length ngs)
227 fast <- getOccByNgramsOnlyFast cId nt ngs
228 slow <- getOccByNgramsOnlySlow NodeCorpus cId ls nt ngs
229 when (fast /= slow) $
230 printDebug "getOccByNgramsOnlySafe: difference" (diff slow fast :: PatchMap Text (Replace (Maybe Int)))
231 pure slow
232
233
234 selectNgramsOccurrencesOnlyByNodeUser :: CorpusId -> NgramsType -> [Text]
235 -> Cmd err [(Text, Int)]
236 selectNgramsOccurrencesOnlyByNodeUser cId nt tms =
237 runPGSQuery queryNgramsOccurrencesOnlyByNodeUser
238 ( Values fields (DPS.Only <$> tms)
239 , cId
240 , nodeTypeId NodeDocument
241 , ngramsTypeId nt
242 )
243 where
244 fields = [QualifiedIdentifier Nothing "text"]
245
246 -- same as queryNgramsOnlyByNodeUser but using COUNT on the node ids.
247 -- Question: with the grouping is the result exactly the same (since Set NodeId for
248 -- equivalent ngrams intersections are not empty)
249 queryNgramsOccurrencesOnlyByNodeUser :: DPS.Query
250 queryNgramsOccurrencesOnlyByNodeUser = [sql|
251 WITH input_rows(terms) AS (?)
252 SELECT ng.terms, COUNT(nng.node2_id) FROM node_node_ngrams nng
253 JOIN ngrams ng ON nng.ngrams_id = ng.id
254 JOIN input_rows ir ON ir.terms = ng.terms
255 JOIN nodes_nodes nn ON nn.node2_id = nng.node2_id
256 JOIN nodes n ON nn.node2_id = n.id
257 WHERE nn.node1_id = ? -- CorpusId
258 AND n.typename = ? -- NodeTypeId
259 AND nng.ngrams_type = ? -- NgramsTypeId
260 AND nn.category > 0
261 GROUP BY nng.node2_id, ng.terms
262 |]
263
264
265
266 queryNgramsOccurrencesOnlyByNodeUser' :: DPS.Query
267 queryNgramsOccurrencesOnlyByNodeUser' = [sql|
268 WITH input_rows(terms) AS (?)
269 SELECT ng.terms, COUNT(nng.node2_id) FROM node_node_ngrams nng
270 JOIN ngrams ng ON nng.ngrams_id = ng.id
271 JOIN input_rows ir ON ir.terms = ng.terms
272 JOIN nodes_nodes nn ON nn.node2_id = nng.node2_id
273 JOIN nodes n ON nn.node2_id = n.id
274 WHERE nn.node1_id = ? -- CorpusId
275 AND n.typename = ? -- NodeTypeId
276 AND nng.ngrams_type = ? -- NgramsTypeId
277 AND nn.category > 0
278 GROUP BY nng.node2_id, ng.terms
279 |]
280
281
282 getNodesByNgramsOnlyUser :: NodeId -> [ListId] -> NgramsType -> [Text]
283 -> Cmd err (Map Text (Set NodeId))
284 getNodesByNgramsOnlyUser cId ls nt ngs =
285 Map.unionsWith (<>)
286 . map (fromListWith (<>) . map (second Set.singleton))
287 <$> mapM (selectNgramsOnlyByNodeUser cId ls nt)
288 (splitEvery 1000 ngs)
289
290 selectNgramsOnlyByNodeUser :: CorpusId -> [ListId] -> NgramsType -> [Text]
291 -> Cmd err [(Text, NodeId)]
292 selectNgramsOnlyByNodeUser cId ls nt tms =
293 runPGSQuery queryNgramsOnlyByNodeUser
294 ( Values fields (DPS.Only <$> tms)
295 , Values [QualifiedIdentifier Nothing "int4"] (DPS.Only <$> (map (\(NodeId n) -> n) ls))
296 , cId
297 , nodeTypeId NodeDocument
298 , ngramsTypeId nt
299 )
300 where
301 fields = [QualifiedIdentifier Nothing "text"]
302
303 queryNgramsOnlyByNodeUser :: DPS.Query
304 queryNgramsOnlyByNodeUser = [sql|
305 WITH input_rows(terms) AS (?),
306 input_list(id) AS (?)
307 SELECT ng.terms, nng.node2_id FROM node_node_ngrams nng
308 JOIN ngrams ng ON nng.ngrams_id = ng.id
309 JOIN input_rows ir ON ir.terms = ng.terms
310 JOIN input_list il ON il.id = nng.node1_id
311 JOIN nodes_nodes nn ON nn.node2_id = nng.node2_id
312 JOIN nodes n ON nn.node2_id = n.id
313 WHERE nn.node1_id = ? -- CorpusId
314 AND n.typename = ? -- NodeTypeId
315 AND nng.ngrams_type = ? -- NgramsTypeId
316 AND nn.category > 0
317 GROUP BY ng.terms, nng.node2_id
318 |]
319
320
321
322
323 selectNgramsOnlyByNodeUser' :: CorpusId -> [ListId] -> NgramsType -> [Text]
324 -> Cmd err [(Text, Int)]
325 selectNgramsOnlyByNodeUser' cId ls nt tms =
326 runPGSQuery queryNgramsOnlyByNodeUser
327 ( Values fields (DPS.Only <$> tms)
328 , Values [QualifiedIdentifier Nothing "int4"] (DPS.Only <$> (map (\(NodeId n) -> n) ls))
329 , cId
330 , nodeTypeId NodeDocument
331 , ngramsTypeId nt
332 )
333 where
334 fields = [QualifiedIdentifier Nothing "text"]
335
336 queryNgramsOnlyByNodeUser' :: DPS.Query
337 queryNgramsOnlyByNodeUser' = [sql|
338 WITH input_rows(terms) AS (?),
339 input_list(id) AS (?)
340 SELECT ng.terms, nng.weight FROM node_node_ngrams nng
341 JOIN ngrams ng ON nng.ngrams_id = ng.id
342 JOIN input_rows ir ON ir.terms = ng.terms
343 JOIN input_list il ON il.id = nng.node2_id
344 WHERE nng.node1_id = ? -- CorpusId
345 AND nng.ngrams_type = ? -- NgramsTypeId
346 -- AND nn.category > 0
347 GROUP BY ng.terms, nng.weight
348 |]
349
350
351
352
353 getNgramsByDocOnlyUser :: NodeId -> [ListId] -> NgramsType -> [Text]
354 -> Cmd err (Map Text (Set NodeId))
355 getNgramsByDocOnlyUser cId ls nt ngs =
356 Map.unionsWith (<>)
357 . map (fromListWith (<>) . map (second Set.singleton))
358 <$> mapM (selectNgramsOnlyByDocUser cId ls nt) (splitEvery 1000 ngs)
359
360
361 selectNgramsOnlyByDocUser :: DocId -> [ListId] -> NgramsType -> [Text]
362 -> Cmd err [(Text, NodeId)]
363 selectNgramsOnlyByDocUser dId ls nt tms =
364 runPGSQuery queryNgramsOnlyByDocUser
365 ( Values fields (DPS.Only <$> tms)
366 , Values [QualifiedIdentifier Nothing "int4"] (DPS.Only <$> (map (\(NodeId n) -> n) ls))
367 , dId
368 , ngramsTypeId nt
369 )
370 where
371 fields = [QualifiedIdentifier Nothing "text"]
372
373 queryNgramsOnlyByDocUser :: DPS.Query
374 queryNgramsOnlyByDocUser = [sql|
375 WITH input_rows(terms) AS (?),
376 input_list(id) AS (?)
377 SELECT ng.terms, nng.node2_id FROM node_node_ngrams nng
378 JOIN ngrams ng ON nng.ngrams_id = ng.id
379 JOIN input_rows ir ON ir.terms = ng.terms
380 JOIN input_list il ON il.id = nng.node1_id
381 WHERE nng.node2_id = ? -- DocId
382 AND nng.ngrams_type = ? -- NgramsTypeId
383 GROUP BY ng.terms, nng.node2_id
384 |]
385
386 ------------------------------------------------------------------------
387 -- | TODO filter by language, database, any social field
388 getNodesByNgramsMaster :: UserCorpusId -> MasterCorpusId -> Cmd err (Map Text (Set NodeId))
389 getNodesByNgramsMaster ucId mcId = Map.unionsWith (<>)
390 . map (fromListWith (<>) . map (\(n,t) -> (t, Set.singleton n)))
391 -- . takeWhile (not . List.null)
392 -- . takeWhile (\l -> List.length l > 3)
393 <$> mapM (selectNgramsByNodeMaster 1000 ucId mcId) [0,500..10000]
394
395
396 selectNgramsByNodeMaster :: Int -> UserCorpusId -> MasterCorpusId -> Int -> Cmd err [(NodeId, Text)]
397 selectNgramsByNodeMaster n ucId mcId p = runPGSQuery
398 queryNgramsByNodeMaster'
399 ( ucId
400 , ngramsTypeId NgramsTerms
401 , nodeTypeId NodeDocument
402 , p
403 , nodeTypeId NodeDocument
404 , p
405 , n
406 , mcId
407 , nodeTypeId NodeDocument
408 , ngramsTypeId NgramsTerms
409 )
410
411 -- | TODO fix node_node_ngrams relation
412 queryNgramsByNodeMaster' :: DPS.Query
413 queryNgramsByNodeMaster' = [sql|
414 WITH nodesByNgramsUser AS (
415
416 SELECT n.id, ng.terms FROM nodes n
417 JOIN nodes_nodes nn ON n.id = nn.node2_id
418 JOIN node_node_ngrams nng ON nng.node2_id = n.id
419 JOIN ngrams ng ON nng.ngrams_id = ng.id
420 WHERE nn.node1_id = ? -- UserCorpusId
421 -- AND n.typename = ? -- NodeTypeId
422 AND nng.ngrams_type = ? -- NgramsTypeId
423 AND nn.category > 0
424 AND node_pos(n.id,?) >= ?
425 AND node_pos(n.id,?) < ?
426 GROUP BY n.id, ng.terms
427
428 ),
429
430 nodesByNgramsMaster AS (
431
432 SELECT n.id, ng.terms FROM nodes n TABLESAMPLE SYSTEM_ROWS(?)
433 JOIN node_node_ngrams nng ON n.id = nng.node2_id
434 JOIN ngrams ng ON ng.id = nng.ngrams_id
435
436 WHERE n.parent_id = ? -- Master Corpus NodeTypeId
437 AND n.typename = ? -- NodeTypeId
438 AND nng.ngrams_type = ? -- NgramsTypeId
439 GROUP BY n.id, ng.terms
440 )
441
442 SELECT m.id, m.terms FROM nodesByNgramsMaster m
443 RIGHT JOIN nodesByNgramsUser u ON u.id = m.id
444 |]
445
446