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