]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/Core/Viz/Phylo/Tools.hs
Merge branch 'dev-cbor' into dev
[gargantext.git] / src / Gargantext / Core / Viz / Phylo / Tools.hs
1 {-|
2 Module : Gargantext.Core.Viz.Phylo.Tools
3 Description : Phylomemy Tools to build/manage it
4 Copyright : (c) CNRS, 2017-Present
5 License : AGPL + CECILL v3
6 Maintainer : team@gargantext.org
7 Stability : experimental
8 Portability : POSIX
9
10
11 -}
12
13 {-# LANGUAGE ViewPatterns #-}
14
15 module Gargantext.Core.Viz.Phylo.Tools
16 where
17
18 import Control.Lens hiding (both, Level, Empty)
19 import Data.List (filter, intersect, (++), sort, null, tail, last, tails, delete, nub, sortOn, nubBy, concat)
20 import Data.Maybe (mapMaybe,fromMaybe)
21 import Data.Map (Map, mapKeys, member, (!), restrictKeys, elems, empty, filterWithKey, unionWith)
22 import Data.Set (Set)
23 import Data.Text (Text,toLower,unwords)
24 import Data.Tuple.Extra
25 import Data.Vector (Vector,elemIndex)
26 import Gargantext.Prelude
27 import Gargantext.Core.Viz.Phylo
28 import qualified Data.Map as Map
29 import qualified Data.Set as Set
30 import qualified Data.Vector as Vector
31
32
33 --------------
34 -- | Misc | --
35 --------------
36
37
38 -- | Define a default value
39 def :: a -> Maybe a -> a
40 def = fromMaybe
41
42
43 -- | Does a List of Sets contains at least one Set of an other List
44 doesAnySetContains :: Eq a => Set a -> [Set a] -> [Set a] -> Bool
45 doesAnySetContains h l l' = any (\c -> doesContains (Set.toList c) (Set.toList h)) (l' ++ l)
46
47
48 -- | Does a list of A contains an other list of A
49 doesContains :: Eq a => [a] -> [a] -> Bool
50 doesContains l l'
51 | null l' = True
52 | length l' > length l = False
53 | elem (head' "doesContains" l') l = doesContains l (tail l')
54 | otherwise = False
55
56
57 -- | Does a list of ordered A contains an other list of ordered A
58 doesContainsOrd :: Eq a => Ord a => [a] -> [a] -> Bool
59 doesContainsOrd l l'
60 | null l' = False
61 | last l < (head' "doesContainsOrd" l') = False
62 | (head' "doesContainsOrd" l') `elem` l = True
63 | otherwise = doesContainsOrd l (tail l')
64
65
66 -- | To filter nested Sets of a
67 filterNestedSets :: Eq a => Set a -> [Set a] -> [Set a] -> [Set a]
68 filterNestedSets h l l'
69 | null l = if doesAnySetContains h l l'
70 then l'
71 else h : l'
72 | doesAnySetContains h l l' = filterNestedSets (head' "filterNestedSets1" l) (tail l) l'
73 | otherwise = filterNestedSets (head' "filterNestedSets2" l) (tail l) (h : l')
74
75
76
77 -- | To get the good pair of keys (x,y) or (y,x) in a given Map (a,b) c
78 getKeyPair :: (Int,Int) -> Map (Int,Int) a -> (Int,Int)
79 getKeyPair (x,y) m = case findPair (x,y) m of
80 Nothing -> panic "[ERR][Viz.Phylo.Example.getKeyPair] Nothing"
81 Just i -> i
82 where
83 --------------------------------------
84 findPair :: (Int,Int) -> Map (Int,Int) a -> Maybe (Int,Int)
85 findPair (x',y') m'
86 | member (x',y') m' = Just (x',y')
87 | member (y',x') m' = Just (y',x')
88 | otherwise = Nothing
89 --------------------------------------
90
91
92 -- | To filter Fis with small Support but by keeping non empty Periods
93 keepFilled :: (Int -> [a] -> [a]) -> Int -> [a] -> [a]
94 keepFilled f thr l = if (null $ f thr l) && (not $ null l)
95 then keepFilled f (thr - 1) l
96 else f thr l
97
98
99 -- | To get all combinations of a list
100 listToFullCombi :: Eq a => [a] -> [(a,a)]
101 listToFullCombi l = [(x,y) | x <- l, y <- l]
102
103
104 -- | To get all combinations of a list
105 listToDirectedCombi :: Eq a => [a] -> [(a,a)]
106 listToDirectedCombi l = [(x,y) | x <- l, y <- l, x /= y]
107
108
109 listToEqualCombi :: Eq a => [a] -> [(a,a)]
110 listToEqualCombi l = [(x,y) | x <- l, y <- l, x == y]
111
112 listToPairs :: Eq a => [a] -> [(a,a)]
113 listToPairs l = (listToEqualCombi l) ++ (listToUnDirectedCombi l)
114
115 -- | To get all combinations of a list and apply a function to the resulting list of pairs
116 listToDirectedCombiWith :: Eq a => forall b. (a -> b) -> [a] -> [(b,b)]
117 listToDirectedCombiWith f l = [(f x,f y) | x <- l, y <- l, x /= y]
118
119
120 -- | To get the sequential combinations of an order list
121 listToSequentialCombi :: Eq a => [a] -> [(a,a)]
122 listToSequentialCombi l = nubBy (\x y -> fst x == fst y) $ listToUnDirectedCombi l
123
124
125 -- | To get all combinations of a list with no repetition
126 listToUnDirectedCombi :: [a] -> [(a,a)]
127 listToUnDirectedCombi l = [ (x,y) | (x:rest) <- tails l, y <- rest ]
128
129
130 -- | To get all combinations of a list with no repetition and apply a function to the resulting list of pairs
131 listToUnDirectedCombiWith :: forall a b. (a -> b) -> [a] -> [(b,b)]
132 listToUnDirectedCombiWith f l = [ (f x, f y) | (x:rest) <- tails l, y <- rest ]
133
134
135 -- | To transform a list of Ngrams Indexes into a Label
136 ngramsToLabel :: Vector Ngrams -> [Int] -> Text
137 ngramsToLabel ngrams l = unwords $ tail' "ngramsToLabel" $ concat $ map (\n -> ["|",n]) $ ngramsToText ngrams l
138
139
140 -- | To transform a list of Ngrams Indexes into a list of Text
141 ngramsToText :: Vector Ngrams -> [Int] -> [Text]
142 ngramsToText ngrams l = map (\idx -> ngrams Vector.! idx) l
143
144
145 -- | To transform a list of ngrams into a list of indexes
146 ngramsToIdx :: [Ngrams] -> Vector Ngrams -> [Int]
147 ngramsToIdx ns v = sort $ map (\n -> getIdxInVector n v) ns
148
149
150 -- | To unify the keys (x,y) that Map 1 share with Map 2 such as: (x,y) <=> (y,x)
151 unifySharedKeys :: Eq a => Ord a => Map (a,a) b -> Map (a,a) b -> Map (a,a) b
152 unifySharedKeys m1 m2 = mapKeys (\(x,y) -> if member (y,x) m2
153 then (y,x)
154 else (x,y) ) m1
155
156
157 ---------------
158 -- | Phylo | --
159 ---------------
160
161 -- | An analyzer ingests a Ngrams and generates a modified version of it
162 phyloAnalyzer :: Ngrams -> Ngrams
163 phyloAnalyzer n = toLower n
164
165 -- | To init the foundation roots of the Phylo as a Vector of Ngrams
166 initFoundationsRoots :: [Ngrams] -> Vector Ngrams
167 initFoundationsRoots l = Vector.fromList $ map phyloAnalyzer l
168
169 -- | To init the base of a Phylo from a List of Periods and Foundations
170 initPhyloBase :: [(Date, Date)] -> PhyloFoundations -> Map Date Double -> Map Date (Map (Int,Int) Double) -> Map (Date,Date) [PhyloFis] -> PhyloParam -> Phylo
171 initPhyloBase pds fds nbDocs cooc fis prm = Phylo ((fst . (head' "initPhyloBase")) pds, (snd . last) pds) fds (map (\pd -> initPhyloPeriod pd []) pds) nbDocs cooc fis prm
172
173 -- | To init the param of a Phylo
174 initPhyloParam :: Maybe Text -> Maybe Software -> Maybe PhyloQueryBuild -> PhyloParam
175 initPhyloParam (def defaultPhyloVersion -> v) (def defaultSoftware -> s) (def defaultQueryBuild -> q) = PhyloParam v s q
176
177 -- | To get the last computed Level in a Phylo
178 getLastLevel :: Phylo -> Level
179 getLastLevel p = (last . sort)
180 $ map (snd . getPhyloLevelId)
181 $ view ( phylo_periods
182 . traverse
183 . phylo_periodLevels ) p
184
185 -- | To get all the coocurency matrix of a phylo
186 getPhyloCooc :: Phylo -> Map Date (Map (Int,Int) Double)
187 getPhyloCooc p = p ^. phylo_cooc
188
189
190 -- | To get the PhyloParam of a Phylo
191 getPhyloParams :: Phylo -> PhyloParam
192 getPhyloParams = _phylo_param
193
194 -- | To get the title of a Phylo
195 getPhyloTitle :: Phylo -> Text
196 getPhyloTitle p = _q_phyloTitle $ _phyloParam_query $ getPhyloParams p
197
198 -- | To get the desc of a Phylo
199 getPhyloDescription :: Phylo -> Text
200 getPhyloDescription p = _q_phyloTitle $ _phyloParam_query $ getPhyloParams p
201
202 getPhyloMatchingFrame :: Phylo -> Int
203 getPhyloMatchingFrame p = _q_interTemporalMatchingFrame $ _phyloParam_query $ getPhyloParams p
204
205 getPhyloMatchingFrameTh :: Phylo -> Double
206 getPhyloMatchingFrameTh p = _q_interTemporalMatchingFrameTh $ _phyloParam_query $ getPhyloParams p
207
208 getPhyloProximity :: Phylo -> Proximity
209 getPhyloProximity p = _q_interTemporalMatching $ _phyloParam_query $ getPhyloParams p
210
211 getPhyloReBranchThr :: Phylo -> Double
212 getPhyloReBranchThr p = _q_reBranchThr $ _phyloParam_query $ getPhyloParams p
213
214 getPhyloReBranchNth :: Phylo -> Int
215 getPhyloReBranchNth p = _q_reBranchNth $ _phyloParam_query $ getPhyloParams p
216
217 getPhyloFis :: Phylo -> Map (Date,Date) [PhyloFis]
218 getPhyloFis = _phylo_fis
219
220
221 --------------------
222 -- | PhyloRoots | --
223 --------------------
224
225 -- | To get the foundations of a Phylo
226 getFoundations :: Phylo -> PhyloFoundations
227 getFoundations = _phylo_foundations
228
229 -- | To get the foundations roots of a Phylo
230 getFoundationsRoots :: Phylo -> Vector Ngrams
231 getFoundationsRoots p = (getFoundations p) ^. phylo_foundationsRoots
232
233 -- | To get the Index of a Ngrams in the foundationsRoots of a Phylo
234 getIdxInRoots :: Ngrams -> Phylo -> Int
235 getIdxInRoots n p = case (elemIndex n (getFoundationsRoots p)) of
236 Nothing -> panic $ "[ERR][Viz.Phylo.Tools.getIdxInRoots] Ngrams not in foundationsRoots: " <> cs n
237 Just idx -> idx
238
239 getIdxInRoots' :: Ngrams -> Vector Ngrams -> Int
240 getIdxInRoots' n root = case (elemIndex n root) of
241 Nothing -> panic $ "[ERR][Viz.Phylo.Tools.getIdxInRoots] Ngrams not in foundationsRoots: " <> cs n
242 Just idx -> idx
243
244 getIdxInVector :: Ngrams -> Vector Ngrams -> Int
245 getIdxInVector n ns = case (elemIndex n ns) of
246 Nothing -> panic $ "[ERR][Viz.Phylo.Tools.getIdxInVector] Ngrams not in foundationsRoots: " <> cs n
247 Just idx -> idx
248
249 --------------------
250 -- | PhyloGroup | --
251 --------------------
252
253 -- | To alter a PhyloGroup matching a given Level
254 alterGroupWithLevel :: (PhyloGroup -> PhyloGroup) -> Level -> Phylo -> Phylo
255 alterGroupWithLevel f lvl p = over ( phylo_periods
256 . traverse
257 . phylo_periodLevels
258 . traverse
259 . phylo_levelGroups
260 . traverse
261 ) (\g -> if getGroupLevel g == lvl
262 then f g
263 else g ) p
264
265
266 -- | To alter each list of PhyloGroups following a given function
267 alterPhyloGroups :: ([PhyloGroup] -> [PhyloGroup]) -> Phylo -> Phylo
268 alterPhyloGroups f p = over ( phylo_periods
269 . traverse
270 . phylo_periodLevels
271 . traverse
272 . phylo_levelGroups
273 ) f p
274
275
276 -- | To filter the PhyloGroup of a Phylo according to a function and a value
277 filterGroups :: Eq a => (PhyloGroup -> a) -> a -> [PhyloGroup] -> [PhyloGroup]
278 filterGroups f x l = filter (\g -> (f g) == x) l
279
280
281 -- | To maybe get the PhyloBranchId of a PhyloGroup
282 getGroupBranchId :: PhyloGroup -> Maybe PhyloBranchId
283 getGroupBranchId = _phylo_groupBranchId
284
285
286 -- | To get the PhyloGroups Childs of a PhyloGroup
287 getGroupChilds :: PhyloGroup -> Phylo -> [PhyloGroup]
288 getGroupChilds g p = getGroupsFromIds (getGroupPeriodChildsId g) p
289
290
291 -- | To get the id of a PhyloGroup
292 getGroupId :: PhyloGroup -> PhyloGroupId
293 getGroupId = _phylo_groupId
294
295
296 getGroupCooc :: PhyloGroup -> Map (Int,Int) Double
297 getGroupCooc = _phylo_groupCooc
298
299
300 -- | To get the level out of the id of a PhyloGroup
301 getGroupLevel :: PhyloGroup -> Int
302 getGroupLevel = snd . fst . getGroupId
303
304
305 -- | To get the level child pointers of a PhyloGroup
306 getGroupLevelChilds :: PhyloGroup -> [Pointer]
307 getGroupLevelChilds = _phylo_groupLevelChilds
308
309
310 -- | To get the PhyloGroups Level Childs Ids of a PhyloGroup
311 getGroupLevelChildsId :: PhyloGroup -> [PhyloGroupId]
312 getGroupLevelChildsId g = map fst $ getGroupLevelChilds g
313
314
315 -- | To get the level parent pointers of a PhyloGroup
316 getGroupLevelParents :: PhyloGroup -> [Pointer]
317 getGroupLevelParents = _phylo_groupLevelParents
318
319
320 -- | To get the PhyloGroups Level Parents Ids of a PhyloGroup
321 getGroupLevelParentsId :: PhyloGroup -> [PhyloGroupId]
322 getGroupLevelParentsId g = map fst $ getGroupLevelParents g
323
324
325 -- | To get the PhyloGroups Level Parents Ids of a PhyloGroup
326 getGroupLevelParentId :: PhyloGroup -> PhyloGroupId
327 getGroupLevelParentId g = (head' "getGroupLevelParentId") $ getGroupLevelParentsId g
328
329 -- | To get the Meta value of a PhyloGroup
330 getGroupMeta :: Text -> PhyloGroup -> Double
331 getGroupMeta k g = (g ^. phylo_groupMeta) ! k
332
333
334 -- | To get the Ngrams of a PhyloGroup
335 getGroupNgrams :: PhyloGroup -> [Int]
336 getGroupNgrams = _phylo_groupNgrams
337
338
339 -- | To get the list of pairs (Childs & Parents) of a PhyloGroup
340 getGroupPairs :: PhyloGroup -> Phylo -> [PhyloGroup]
341 getGroupPairs g p = (getGroupChilds g p) ++ (getGroupParents g p)
342
343
344 -- | To get the PhyloGroups Parents of a PhyloGroup
345 getGroupParents :: PhyloGroup -> Phylo -> [PhyloGroup]
346 getGroupParents g p = getGroupsFromIds (getGroupPeriodParentsId g) p
347
348
349 -- | To get the period out of the id of a PhyloGroup
350 getGroupPeriod :: PhyloGroup -> (Date,Date)
351 getGroupPeriod = fst . fst . getGroupId
352
353
354 -- | To get the period child pointers of a PhyloGroup
355 getGroupPeriodChilds :: PhyloGroup -> [Pointer]
356 getGroupPeriodChilds = _phylo_groupPeriodChilds
357
358
359 -- | To get the PhyloGroups Period Parents Ids of a PhyloGroup
360 getGroupPeriodChildsId :: PhyloGroup -> [PhyloGroupId]
361 getGroupPeriodChildsId g = map fst $ getGroupPeriodChilds g
362
363
364 -- | To get the period parent pointers of a PhyloGroup
365 getGroupPeriodParents :: PhyloGroup -> [Pointer]
366 getGroupPeriodParents = _phylo_groupPeriodParents
367
368
369 -- | To get the PhyloGroups Period Parents Ids of a PhyloGroup
370 getGroupPeriodParentsId :: PhyloGroup -> [PhyloGroupId]
371 getGroupPeriodParentsId g = map fst $ getGroupPeriodParents g
372
373
374 -- | To get the pointers of a given Phylogroup
375 getGroupPointers :: EdgeType -> Filiation -> PhyloGroup -> [Pointer]
376 getGroupPointers t f g = case t of
377 PeriodEdge -> case f of
378 Ascendant -> getGroupPeriodParents g
379 Descendant -> getGroupPeriodChilds g
380 _ -> panic "[ERR][Viz.Phylo.Tools.getGroupPointers] wrong filiation"
381 LevelEdge -> case f of
382 Ascendant -> getGroupLevelParents g
383 Descendant -> getGroupLevelChilds g
384 _ -> panic "[ERR][Viz.Phylo.Tools.getGroupPointers] wrong filiation"
385
386
387 -- | To get the roots labels of a list of group ngrams
388 getGroupText :: PhyloGroup -> Phylo -> [Text]
389 getGroupText g p = ngramsToText (getFoundationsRoots p) (getGroupNgrams g)
390
391
392 -- | To get all the PhyloGroup of a Phylo
393 getGroups :: Phylo -> [PhyloGroup]
394 getGroups = view ( phylo_periods
395 . traverse
396 . phylo_periodLevels
397 . traverse
398 . phylo_levelGroups
399 )
400
401
402 -- | To get all PhyloGroups matching a list of PhyloGoupIds in a Phylo
403 -- getGroupsFromIds :: [PhyloGroupId] -> Phylo -> [PhyloGroup]
404 -- getGroupsFromIds ids p = filter (\g -> elem (getGroupId g) ids) $ getGroups p
405
406 getGroupFromId :: PhyloGroupId -> Phylo -> PhyloGroup
407 getGroupFromId id p =
408 let groups = Map.fromList $ map (\g -> (getGroupId g, g)) $ getGroups p
409 in groups ! id
410
411 getGroupsFromIds :: [PhyloGroupId] -> Phylo -> [PhyloGroup]
412 getGroupsFromIds ids p =
413 let groups = Map.fromList $ map (\g -> (getGroupId g, g)) $ getGroups p
414 in elems $ restrictKeys groups (Set.fromList ids)
415
416
417 -- | To get the corresponding list of PhyloGroups from a list of PhyloNodes
418 getGroupsFromNodes :: [PhyloNode] -> Phylo -> [PhyloGroup]
419 getGroupsFromNodes ns p = getGroupsFromIds (map getNodeId ns) p
420
421
422 -- | To get all the PhyloGroup of a Phylo with a given level and period
423 getGroupsWithFilters :: Int -> (Date,Date) -> Phylo -> [PhyloGroup]
424 getGroupsWithFilters lvl prd p = (getGroupsWithLevel lvl p)
425 `intersect`
426 (getGroupsWithPeriod prd p)
427
428
429 -- | To get all the PhyloGroup of a Phylo with a given Level
430 getGroupsWithLevel :: Int -> Phylo -> [PhyloGroup]
431 getGroupsWithLevel lvl p = filterGroups getGroupLevel lvl (getGroups p)
432
433
434 -- | To get all the PhyloGroup of a Phylo with a given Period
435 getGroupsWithPeriod :: (Date,Date) -> Phylo -> [PhyloGroup]
436 getGroupsWithPeriod prd p = filterGroups getGroupPeriod prd (getGroups p)
437
438
439 -- | To create a PhyloGroup in a Phylo out of a list of Ngrams and a set of parameters
440 initGroup :: [Ngrams] -> Text -> Int -> Int -> Int -> Int -> Phylo -> PhyloGroup
441 initGroup ngrams lbl idx lvl from' to' p = PhyloGroup
442 (((from', to'), lvl), idx)
443 lbl
444 idxs
445 (Map.empty)
446 (Map.empty)
447 Nothing
448 (getMiniCooc (listToFullCombi idxs) (periodsToYears [(from', to')]) (getPhyloCooc p))
449 [] [] [] []
450 where
451 idxs = sort $ map (\x -> getIdxInRoots x p) ngrams
452
453
454 -- | To sum two coocurency Matrix
455 sumCooc :: Map (Int, Int) Double -> Map (Int, Int) Double -> Map (Int, Int) Double
456 sumCooc m m' = unionWith (+) m m'
457
458 -- | To build the mini cooc matrix of each group
459 getMiniCooc :: [(Int,Int)] -> Set Date -> Map Date (Map (Int,Int) Double) -> Map (Int,Int) Double
460 getMiniCooc pairs years cooc = filterWithKey (\(n,n') _ -> elem (n,n') pairs) cooc'
461 where
462 --------------------------------------
463 cooc' :: Map (Int,Int) Double
464 cooc' = foldl (\m m' -> sumCooc m m') empty
465 $ elems
466 $ restrictKeys cooc years
467 --------------------------------------
468
469
470 ---------------------
471 -- | PhyloPeriod | --
472 ---------------------
473
474
475 -- | To alter each PhyloPeriod of a Phylo following a given function
476 alterPhyloPeriods :: (PhyloPeriod -> PhyloPeriod) -> Phylo -> Phylo
477 alterPhyloPeriods f p = over ( phylo_periods
478 . traverse) f p
479
480
481 -- | To append a list of PhyloPeriod to a Phylo
482 appendToPhyloPeriods :: [PhyloPeriod] -> Phylo -> Phylo
483 appendToPhyloPeriods l p = over (phylo_periods) (++ l) p
484
485
486 -- | To get all the PhyloPeriodIds of a Phylo
487 getPhyloPeriods :: Phylo -> [PhyloPeriodId]
488 getPhyloPeriods p = map _phylo_periodId
489 $ view (phylo_periods) p
490
491
492 -- | To get the id of a given PhyloPeriod
493 getPhyloPeriodId :: PhyloPeriod -> PhyloPeriodId
494 getPhyloPeriodId prd = _phylo_periodId prd
495
496
497 -- | To create a PhyloPeriod
498 initPhyloPeriod :: PhyloPeriodId -> [PhyloLevel] -> PhyloPeriod
499 initPhyloPeriod id l = PhyloPeriod id l
500
501
502 -- | To transform a list of periods into a set of Dates
503 periodsToYears :: [(Date,Date)] -> Set Date
504 periodsToYears periods = (Set.fromList . sort . concat)
505 $ map (\(d,d') -> [d..d']) periods
506
507
508 --------------------
509 -- | PhyloLevel | --
510 --------------------
511
512
513 -- | To alter a list of PhyloLevels following a given function
514 alterPhyloLevels :: ([PhyloLevel] -> [PhyloLevel]) -> Phylo -> Phylo
515 alterPhyloLevels f p = over ( phylo_periods
516 . traverse
517 . phylo_periodLevels) f p
518
519
520 -- | To get the PhylolevelId of a given PhyloLevel
521 getPhyloLevelId :: PhyloLevel -> PhyloLevelId
522 getPhyloLevelId = _phylo_levelId
523
524
525 -- | To get all the Phylolevels of a given PhyloPeriod
526 getPhyloLevels :: PhyloPeriod -> [PhyloLevel]
527 getPhyloLevels = view (phylo_periodLevels)
528
529
530 -- | To create a PhyloLevel
531 initPhyloLevel :: PhyloLevelId -> [PhyloGroup] -> PhyloLevel
532 initPhyloLevel id groups = PhyloLevel id groups
533
534
535 -- | To set the LevelId of a PhyloLevel and of all its PhyloGroups
536 setPhyloLevelId :: Int -> PhyloLevel -> PhyloLevel
537 setPhyloLevelId lvl' (PhyloLevel (id, _lvl) groups)
538 = PhyloLevel (id, lvl') groups'
539 where
540 groups' = over (traverse . phylo_groupId)
541 (\((period, _lvl), idx) -> ((period, lvl'), idx))
542 groups
543
544
545 ------------------
546 -- | PhyloFis | --
547 ------------------
548
549
550 -- | To get the clique of a PhyloFis
551 getClique :: PhyloFis -> Clique
552 getClique = _phyloFis_clique
553
554 -- | To get the support of a PhyloFis
555 getSupport :: PhyloFis -> Support
556 getSupport = _phyloFis_support
557
558 -- | To get the period of a PhyloFis
559 getFisPeriod :: PhyloFis -> (Date,Date)
560 getFisPeriod = _phyloFis_period
561
562
563 ----------------------------
564 -- | PhyloNodes & Edges | --
565 ----------------------------
566
567
568 -- | To alter a PhyloNode
569 alterPhyloNode :: (PhyloNode -> PhyloNode) -> PhyloView -> PhyloView
570 alterPhyloNode f v = over ( pv_nodes
571 . traverse
572 ) (\pn -> f pn ) v
573
574
575 -- | To filter some GroupEdges with a given threshold
576 filterGroupEdges :: Double -> [GroupEdge] -> [GroupEdge]
577 filterGroupEdges thr edges = filter (\((_s,_t),w) -> w > thr) edges
578
579
580 -- | To get the neighbours (directed/undirected) of a PhyloGroup from a list of GroupEdges
581 getNeighbours :: Bool -> PhyloGroup -> [GroupEdge] -> [PhyloGroup]
582 getNeighbours directed g e = case directed of
583 True -> map (\((_s,t),_w) -> t)
584 $ filter (\((s,_t),_w) -> s == g) e
585 False -> map (\((s,t),_w) -> (head' "getNeighbours") $ delete g $ nub [s,t,g])
586 $ filter (\((s,t),_w) -> s == g || t == g) e
587
588
589 -- | To get the PhyloBranchId of PhyloNode if it exists
590 getNodeBranchId :: PhyloNode -> PhyloBranchId
591 getNodeBranchId n = case n ^. pn_bid of
592 Nothing -> panic "[ERR][Viz.Phylo.Tools.getNodeBranchId] branchId not found"
593 Just i -> i
594
595
596 -- | To get the PhyloGroupId of a PhyloNode
597 getNodeId :: PhyloNode -> PhyloGroupId
598 getNodeId n = n ^. pn_id
599
600
601 getNodePeriod :: PhyloNode -> (Date,Date)
602 getNodePeriod n = fst $ fst $ getNodeId n
603
604
605 -- | To get the Level of a PhyloNode
606 getNodeLevel :: PhyloNode -> Level
607 getNodeLevel n = (snd . fst) $ getNodeId n
608
609
610 -- | To get the Parent Node of a PhyloNode in a PhyloView
611 getNodeParent :: PhyloNode -> PhyloView -> [PhyloNode]
612 getNodeParent n v = filter (\n' -> elem (getNodeId n') (getNodeParentsId n))
613 $ v ^. pv_nodes
614
615
616 -- | To get the Parent Node id of a PhyloNode if it exists
617 getNodeParentsId :: PhyloNode -> [PhyloGroupId]
618 getNodeParentsId n = case n ^. pn_parents of
619 Nothing -> panic "[ERR][Viz.Phylo.Tools.getNodeParentsId] node parent not found"
620 Just ids -> ids
621
622
623 -- | To get a list of PhyloNodes grouped by PhyloBranch in a PhyloView
624 getNodesByBranches :: PhyloView -> [(PhyloBranchId,[PhyloNode])]
625 getNodesByBranches v = zip bIds $ map (\id -> filter (\n -> (getNodeBranchId n) == id)
626 $ getNodesInBranches v ) bIds
627 where
628 --------------------------------------
629 bIds :: [PhyloBranchId]
630 bIds = getViewBranchIds v
631 --------------------------------------
632
633
634 -- | To get a list of PhyloNodes owned by any PhyloBranches in a PhyloView
635 getNodesInBranches :: PhyloView -> [PhyloNode]
636 getNodesInBranches v = filter (\n -> isJust $ n ^. pn_bid)
637 $ v ^. pv_nodes
638
639
640 -- | To get the PhyloGroupId of the Source of a PhyloEdge
641 getSourceId :: PhyloEdge -> PhyloGroupId
642 getSourceId e = e ^. pe_source
643
644
645 -- | To get the PhyloGroupId of the Target of a PhyloEdge
646 getTargetId :: PhyloEdge -> PhyloGroupId
647 getTargetId e = e ^. pe_target
648
649
650 ---------------------
651 -- | PhyloBranch | --
652 ---------------------
653
654
655 -- | To get the PhyloBranchId of a PhyloBranch
656 getBranchId :: PhyloBranch -> PhyloBranchId
657 getBranchId b = b ^. pb_id
658
659 -- | To get a list of PhyloBranchIds
660 getBranchIds :: Phylo -> [PhyloBranchId]
661 getBranchIds p = sortOn snd
662 $ nub
663 $ mapMaybe getGroupBranchId
664 $ getGroups p
665
666
667 -- | To get a list of PhyloBranchIds given a Level in a Phylo
668 getBranchIdsWith :: Level -> Phylo -> [PhyloBranchId]
669 getBranchIdsWith lvl p = sortOn snd
670 $ mapMaybe getGroupBranchId
671 $ getGroupsWithLevel lvl p
672
673
674 -- | To get the Meta value of a PhyloBranch
675 getBranchMeta :: Text -> PhyloBranch -> [Double]
676 getBranchMeta k b = (b ^. pb_metrics) ! k
677
678
679 -- | To get all the PhyloBranchIds of a PhyloView
680 getViewBranchIds :: PhyloView -> [PhyloBranchId]
681 getViewBranchIds v = map getBranchId $ v ^. pv_branches
682
683
684 -- | To get a list of PhyloGroup sharing the same PhyloBranchId
685 getGroupsByBranches :: Phylo -> [(PhyloBranchId,[PhyloGroup])]
686 getGroupsByBranches p = zip (getBranchIds p)
687 $ map (\id -> filter (\g -> (fromJust $ getGroupBranchId g) == id)
688 $ getGroupsInBranches p)
689 $ getBranchIds p
690
691
692 -- | To get the sublist of all the PhyloGroups linked to a branch
693 getGroupsInBranches :: Phylo -> [PhyloGroup]
694 getGroupsInBranches p = filter (\g -> isJust $ g ^. phylo_groupBranchId)
695 $ getGroups p
696
697
698 --------------------------------
699 -- | PhyloQuery & QueryView | --
700 --------------------------------
701
702
703 -- | To filter PhyloView's Branches by level
704 filterBranchesByLevel :: Level -> PhyloView -> [PhyloBranch]
705 filterBranchesByLevel lvl pv = filter (\pb -> lvl == (fst $ pb ^. pb_id))
706 $ pv ^. pv_branches
707
708
709 -- | To filter PhyloView's Edges by level
710 filterEdgesByLevel :: Level -> [PhyloEdge] -> [PhyloEdge]
711 filterEdgesByLevel lvl pes = filter (\pe -> (lvl == ((snd . fst) $ pe ^. pe_source))
712 && (lvl == ((snd . fst) $ pe ^. pe_target))) pes
713
714
715 -- | To filter PhyloView's Edges by type
716 filterEdgesByType :: EdgeType -> [PhyloEdge] -> [PhyloEdge]
717 filterEdgesByType t pes = filter (\pe -> t == (pe ^. pe_type)) pes
718
719
720 -- | To filter PhyloView's Nodes by the oldest Period
721 filterNodesByFirstPeriod :: [PhyloNode] -> [PhyloNode]
722 filterNodesByFirstPeriod pns = filter (\pn -> fstPrd == ((fst . fst) $ pn ^. pn_id)) pns
723 where
724 --------------------------------------
725 fstPrd :: (Date,Date)
726 fstPrd = (head' "filterNodesByFirstPeriod")
727 $ sortOn fst
728 $ map (\pn -> (fst . fst) $ pn ^. pn_id) pns
729 --------------------------------------
730
731
732 -- | To filter PhyloView's Nodes by Branch
733 filterNodesByBranch :: PhyloBranchId -> [PhyloNode] -> [PhyloNode]
734 filterNodesByBranch bId pns = filter (\pn -> if isJust $ pn ^. pn_bid
735 then if bId == (fromJust $ pn ^. pn_bid)
736 then True
737 else False
738 else False ) pns
739
740
741 -- | To filter PhyloView's Nodes by level
742 filterNodesByLevel :: Level -> [PhyloNode] -> [PhyloNode]
743 filterNodesByLevel lvl pns = filter (\pn -> lvl == ((snd . fst) $ pn ^. pn_id)) pns
744
745
746 -- | To filter PhyloView's Nodes by Period
747 filterNodesByPeriod :: PhyloPeriodId -> [PhyloNode] -> [PhyloNode]
748 filterNodesByPeriod prd pns = filter (\pn -> prd == ((fst . fst) $ pn ^. pn_id)) pns
749
750
751 -- | To get the first clustering method to apply to get the contextual units of a Phylo
752 getContextualUnit :: PhyloQueryBuild -> Cluster
753 getContextualUnit q = q ^. q_contextualUnit
754
755
756 -- | To get the metrics to apply to contextual units
757 getContextualUnitMetrics :: PhyloQueryBuild -> [Metric]
758 getContextualUnitMetrics q = q ^. q_contextualUnitMetrics
759
760
761 -- | To get the filters to apply to contextual units
762 getContextualUnitFilters :: PhyloQueryBuild -> [Filter]
763 getContextualUnitFilters q = q ^. q_contextualUnitFilters
764
765
766 -- | To get the cluster methods to apply to the Nths levels of a Phylo
767 getNthCluster :: PhyloQueryBuild -> Cluster
768 getNthCluster q = q ^. q_nthCluster
769
770
771 -- | To get the Sup Level of a reconstruction of a Phylo from a PhyloQuery
772 getNthLevel :: PhyloQueryBuild -> Level
773 getNthLevel q = q ^. q_nthLevel
774
775
776 -- | To get the Grain of the PhyloPeriods from a PhyloQuery
777 getPeriodGrain :: PhyloQueryBuild -> Int
778 getPeriodGrain q = q ^. q_periodGrain
779
780
781 -- | To get the intertemporal matching strategy to apply to a Phylo from a PhyloQuery
782 getInterTemporalMatching :: PhyloQueryBuild -> Proximity
783 getInterTemporalMatching q = q ^. q_interTemporalMatching
784
785
786 -- | To get the Steps of the PhyloPeriods from a PhyloQuery
787 getPeriodSteps :: PhyloQueryBuild -> Int
788 getPeriodSteps q = q ^. q_periodSteps
789
790
791 --------------------------------------------------
792 -- | PhyloQueryBuild & PhyloQueryView Constructors | --
793 --------------------------------------------------
794
795 -- | To get the threshold of a Proximity
796 getThreshold :: Proximity -> Double
797 getThreshold prox = case prox of
798 WeightedLogJaccard (WLJParams thr _) -> thr
799 Hamming (HammingParams thr) -> thr
800 Filiation -> panic "[ERR][Viz.Phylo.Tools.getThreshold] Filiation"
801
802
803 -- | To get the Proximity associated to a given Clustering method
804 getProximity :: Cluster -> Proximity
805 getProximity cluster = case cluster of
806 Louvain (LouvainParams proxi) -> proxi
807 RelatedComponents (RCParams proxi) -> proxi
808 _ -> panic "[ERR][Viz.Phylo.Tools.getProximity] this cluster has no associated Proximity"
809
810
811 -- | To initialize all the Cluster / Proximity with their default parameters
812 initFis :: Maybe Bool -> Maybe Support -> Maybe Int -> FisParams
813 initFis (def True -> kmf) (def 0 -> min') (def 0 -> thr) = FisParams kmf min' thr
814
815 initHamming :: Maybe Double -> HammingParams
816 initHamming (def 0.01 -> sens) = HammingParams sens
817
818 initLonelyBranch :: Maybe Int -> Maybe Int -> Maybe Int -> LBParams
819 initLonelyBranch (def 2 -> periodsInf) (def 2 -> periodsSup) (def 1 -> minNodes) = LBParams periodsInf periodsSup minNodes
820
821 initSizeBranch :: Maybe Int -> SBParams
822 initSizeBranch (def 1 -> minSize) = SBParams minSize
823
824 initLonelyBranch' :: Maybe Int -> Maybe Int -> Maybe Int -> LBParams
825 initLonelyBranch' (def 0 -> periodsInf) (def 0 -> periodsSup) (def 1 -> minNodes) = LBParams periodsInf periodsSup minNodes
826
827 initLouvain :: Maybe Proximity -> LouvainParams
828 initLouvain (def defaultWeightedLogJaccard -> proxi) = LouvainParams proxi
829
830 initRelatedComponents :: Maybe Proximity -> RCParams
831 initRelatedComponents (def defaultWeightedLogJaccard -> proxi) = RCParams proxi
832
833 -- | TODO user param in main function
834 initWeightedLogJaccard :: Maybe Double -> Maybe Double -> WLJParams
835 initWeightedLogJaccard (def 0.3 -> thr) (def 20.0 -> sens) = WLJParams thr sens
836
837
838 -- | To initialize a PhyloQueryBuild from given and default parameters
839 initPhyloQueryBuild :: Text -> Text -> Maybe Int
840 -> Maybe Int -> Maybe Cluster -> Maybe [Metric]
841 -> Maybe [Filter]-> Maybe Proximity -> Maybe Int
842 -> Maybe Double -> Maybe Double -> Maybe Int
843 -> Maybe Level -> Maybe Cluster -> PhyloQueryBuild
844 initPhyloQueryBuild name desc (def 5 -> grain)
845 (def 1 -> steps) (def defaultFis -> cluster) (def [] -> metrics)
846 (def [] -> filters) (def defaultWeightedLogJaccard -> matching') (def 5 -> frame)
847 (def 0.8 -> frameThr) (def 0.5 -> reBranchThr) (def 4 -> reBranchNth)
848 (def 2 -> nthLevel) (def defaultRelatedComponents -> nthCluster) =
849 PhyloQueryBuild name desc grain
850 steps cluster metrics filters matching' frame frameThr reBranchThr reBranchNth nthLevel nthCluster
851
852
853 -- | To initialize a PhyloQueryView default parameters
854 initPhyloQueryView :: Maybe Level -> Maybe Filiation -> Maybe Bool -> Maybe Level -> Maybe [Metric] -> Maybe [Filter] -> Maybe [Tagger] -> Maybe (Sort, Order) -> Maybe ExportMode -> Maybe DisplayMode -> Maybe Bool -> PhyloQueryView
855 initPhyloQueryView (def 2 -> lvl) (def Descendant -> f) (def False -> c) (def 1 -> d) (def [] -> ms) (def [] -> fs) (def [] -> ts) s (def Json -> em) (def Flat -> dm) (def True -> v) =
856 PhyloQueryView lvl f c d ms fs ts s em dm v
857
858
859 -- | To define some obvious boolean getters
860 shouldKeepMinorFis :: FisParams -> Bool
861 shouldKeepMinorFis = _fis_keepMinorFis
862
863 ----------------------------
864 -- | Default ressources | --
865 ----------------------------
866
867 -- Clusters
868
869 defaultFis :: Cluster
870 defaultFis = Fis (initFis Nothing Nothing Nothing)
871
872 defaultLouvain :: Cluster
873 defaultLouvain = Louvain (initLouvain Nothing)
874
875 defaultRelatedComponents :: Cluster
876 defaultRelatedComponents = RelatedComponents (initRelatedComponents Nothing)
877
878 -- Filters
879
880 defaultLonelyBranch :: Filter
881 defaultLonelyBranch = LonelyBranch (initLonelyBranch Nothing Nothing Nothing)
882
883 defaultSizeBranch :: Filter
884 defaultSizeBranch = SizeBranch (initSizeBranch Nothing)
885
886 -- Params
887
888 defaultPhyloParam :: PhyloParam
889 defaultPhyloParam = initPhyloParam Nothing Nothing Nothing
890
891 -- Proximities
892
893 defaultHamming :: Proximity
894 defaultHamming = Hamming (initHamming Nothing)
895
896 defaultWeightedLogJaccard :: Proximity
897 defaultWeightedLogJaccard = WeightedLogJaccard (initWeightedLogJaccard Nothing Nothing)
898
899 -- Queries
900 type Title = Text
901 type Desc = Text
902
903 defaultQueryBuild :: PhyloQueryBuild
904 defaultQueryBuild = defaultQueryBuild'
905 "Cesar et Cleôpatre"
906 "An example of Phylomemy (french without accent)"
907
908 defaultQueryBuild' :: Title -> Desc -> PhyloQueryBuild
909 defaultQueryBuild' t d = initPhyloQueryBuild t d
910 Nothing Nothing Nothing
911 Nothing Nothing Nothing
912 Nothing Nothing Nothing
913 Nothing Nothing Nothing
914
915 defaultQueryView :: PhyloQueryView
916 defaultQueryView = initPhyloQueryView
917 Nothing Nothing Nothing
918 Nothing Nothing Nothing
919 Nothing Nothing Nothing
920 Nothing Nothing
921
922 -- Software
923
924 defaultSoftware :: Software
925 defaultSoftware = Software "Gargantext" "v4"
926
927 -- Version
928
929 defaultPhyloVersion :: Text
930 defaultPhyloVersion = "v1"
931