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, concat, sortOn, nubBy)
  24 import Data.Maybe           (mapMaybe,fromMaybe)
  25 import Data.Map             (Map, mapKeys, member, (!))
  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 listToDirectedCombi :: Eq a => [a] -> [(a,a)]
 105 listToDirectedCombi l = [(x,y) | x <- l, y <- l, x /= y]
 106
 107
 108 -- | To get all combinations of a list and apply a function to the resulting list of pairs
 109 listToDirectedCombiWith :: Eq a => forall b. (a -> b) -> [a] -> [(b,b)]
 110 listToDirectedCombiWith f l = [(f x,f y) | x <- l, y <- l, x /= y]
 111
 112
 113 -- | To get the sequential combinations of an order list
 114 listToSequentialCombi :: Eq a => [a] -> [(a,a)]
 115 listToSequentialCombi l = nubBy (\x y -> fst x == fst y) $ listToUnDirectedCombi l
 116
 117
 118 -- | To get all combinations of a list with no repetition
 119 listToUnDirectedCombi :: [a] -> [(a,a)]
 120 listToUnDirectedCombi l = [ (x,y) | (x:rest) <- tails l,  y <- rest ]
 121
 122
 123 -- | To get all combinations of a list with no repetition and apply a function to the resulting list of pairs
 124 listToUnDirectedCombiWith :: forall a b. (a -> b) -> [a] -> [(b,b)]
 125 listToUnDirectedCombiWith f l = [ (f x, f y) | (x:rest) <- tails l,  y <- rest ]
 126
 127
 128 -- | To transform a list of Ngrams Indexes into a Label
 129 ngramsToLabel :: Vector Ngrams -> [Int] -> Text
 130 ngramsToLabel ngrams l = unwords $ ngramsToText ngrams l
 131
 132
 133 -- | To transform a list of Ngrams Indexes into a list of Text
 134 ngramsToText :: Vector Ngrams -> [Int] -> [Text]
 135 ngramsToText ngrams l = map (\idx -> ngrams Vector.! idx) l
 136
 137
 138 -- | To unify the keys (x,y) that Map 1 share with Map 2 such as: (x,y) <=> (y,x)
 139 unifySharedKeys :: Eq a => Ord a => Map (a,a) b -> Map (a,a) b -> Map (a,a) b
 140 unifySharedKeys m1 m2 = mapKeys (\(x,y) -> if member (y,x) m2
 141                                            then (y,x)
 142                                            else (x,y) ) m1
 143
 144
 145 ---------------
 146 -- | Phylo | --
 147 ---------------
 148
 149 -- | An analyzer ingests a Ngrams and generates a modified version of it
 150 phyloAnalyzer :: Ngrams -> Ngrams
 151 phyloAnalyzer n = toLower n
 152
 153 -- | To init the foundation of the Phylo as a Vector of Ngrams
 154 initFoundations :: [Ngrams] -> Vector Ngrams
 155 initFoundations l = Vector.fromList $ map phyloAnalyzer l
 156
 157 -- | To init the base of a Phylo from a List of Periods and Foundations
 158 initPhyloBase :: [(Date, Date)] -> Vector Ngrams -> PhyloRoots -> PhyloParam -> Phylo
 159 initPhyloBase pds fds pks prm = Phylo ((fst . (head' "initPhyloBase")) pds, (snd . last) pds) fds pks (map (\pd -> initPhyloPeriod pd []) pds) prm
 160
 161 -- | To init the param of a Phylo
 162 initPhyloParam :: Maybe Text -> Maybe Software -> Maybe PhyloQueryBuild -> PhyloParam
 163 initPhyloParam (def defaultPhyloVersion -> v)
 164                (def defaultSoftware     -> s)
 165                (def defaultQueryBuild   -> q) = PhyloParam v s q
 166
 167 -- | To get the foundations of a Phylo
 168 getFoundations :: Phylo -> Vector Ngrams
 169 getFoundations = _phylo_foundations
 170
 171 -- | To get the Index of a Ngrams in the Foundations of a Phylo
 172 getIdxInFoundations :: Ngrams -> Phylo -> Int
 173 getIdxInFoundations n p = case (elemIndex n (getFoundations p)) of
 174     Nothing  -> panic "[ERR][Viz.Phylo.Tools.getIdxInFoundations] Ngrams not in Foundations"
 175     Just idx -> idx
 176
 177
 178 -- | To get the last computed Level in a Phylo
 179 getLastLevel :: Phylo -> Level
 180 getLastLevel p = (last . sort)
 181                $ map (snd . getPhyloLevelId)
 182                $ view ( phylo_periods
 183                       .  traverse
 184                       . phylo_periodLevels ) p
 185
 186
 187 --------------------
 188 -- | PhyloRoots | --
 189 --------------------
 190
 191 -- | To apply a fonction to each label of a Ngrams Tree
 192 alterLabels :: (Ngrams -> Ngrams) -> Tree Ngrams -> Tree Ngrams
 193 alterLabels f (Node lbl ns) = Node (f lbl) (map (\n -> alterLabels f n) ns)
 194 alterLabels _ Empty         = panic "[ERR][Viz.Phylo.Tools.alterLabels] Empty"
 195
 196 -- | To transform a forest of trees into a map (node,root)
 197 forestToMap :: [Tree Ngrams] -> Map Ngrams Ngrams
 198 forestToMap trees = Map.fromList $ concat $ map treeToTuples' trees
 199   where
 200     treeToTuples' (Node lbl ns) = treeToTuples (Node lbl ns) lbl
 201     treeToTuples' Empty         = panic "[ERR][Viz.Phylo.Tools.forestToMap] Empty"
 202
 203 -- | To get the foundationsRoots of a Phylo
 204 getRoots :: Phylo -> PhyloRoots
 205 getRoots = _phylo_foundationsRoots
 206
 207 -- | To get the RootsLabels of a Phylo
 208 getRootsLabels :: Phylo -> Vector Ngrams
 209 getRootsLabels p = (getRoots p) ^. phylo_rootsLabels
 210
 211 -- | To get the Index of a Ngrams in the foundationsRoots of a Phylo
 212 getIdxInRoots :: Ngrams -> Phylo -> Int
 213 getIdxInRoots n p = case (elemIndex n (getRootsLabels p)) of
 214     Nothing  -> panic "[ERR][Viz.Phylo.Tools.getIdxInRoots] Ngrams not in foundationsRoots"
 215     Just idx -> idx
 216
 217 -- | To init the PhyloRoots of a Phylo
 218 initRoots :: [Tree Ngrams] -> Vector Ngrams -> PhyloRoots
 219 initRoots trees ns = PhyloRoots labels trees
 220   where
 221     --------------------------------------
 222     labels :: Vector Ngrams
 223     labels = Vector.fromList
 224            $ nub
 225            $ Vector.toList
 226            $ map (\n -> if member n mTrees
 227                         then mTrees Map.! n
 228                         else n ) ns
 229     --------------------------------------
 230     mTrees :: Map Ngrams Ngrams
 231     mTrees = forestToMap trees
 232     --------------------------------------
 233
 234 -- | To transform a Ngrams Tree into a list of (node,root)
 235 treeToTuples :: Tree Ngrams -> Ngrams -> [(Ngrams,Ngrams)]
 236 treeToTuples (Node lbl ns) root = [(lbl,root)] ++ (concat $ map (\n -> treeToTuples n root) ns)
 237 treeToTuples Empty         _    = panic "[ERR][Viz.Phylo.Tools.treeToTuples] Empty"
 238
 239 --------------------
 240 -- | PhyloGroup | --
 241 --------------------
 242
 243
 244 -- | To alter a PhyloGroup matching a given Level
 245 alterGroupWithLevel :: (PhyloGroup -> PhyloGroup) -> Level -> Phylo -> Phylo
 246 alterGroupWithLevel f lvl p = over ( phylo_periods
 247                                    .  traverse
 248                                    . phylo_periodLevels
 249                                    .  traverse
 250                                    . phylo_levelGroups
 251                                    .  traverse
 252                                    ) (\g -> if getGroupLevel g == lvl
 253                                             then f g
 254                                             else g ) p
 255
 256
 257 -- | To alter each list of PhyloGroups following a given function
 258 alterPhyloGroups :: ([PhyloGroup] -> [PhyloGroup]) -> Phylo -> Phylo
 259 alterPhyloGroups f p = over ( phylo_periods
 260                             .  traverse
 261                             . phylo_periodLevels
 262                             .  traverse
 263                             . phylo_levelGroups
 264                             ) f p
 265
 266
 267 -- | To filter the PhyloGroup of a Phylo according to a function and a value
 268 filterGroups :: Eq a => (PhyloGroup -> a) -> a -> [PhyloGroup] -> [PhyloGroup]
 269 filterGroups f x l = filter (\g -> (f g) == x) l
 270
 271
 272 -- | To maybe get the PhyloBranchId of a PhyloGroup
 273 getGroupBranchId :: PhyloGroup -> Maybe PhyloBranchId
 274 getGroupBranchId = _phylo_groupBranchId
 275
 276
 277 -- | To get the PhyloGroups Childs of a PhyloGroup
 278 getGroupChilds :: PhyloGroup -> Phylo -> [PhyloGroup]
 279 getGroupChilds g p = getGroupsFromIds (getGroupPeriodChildsId g) p
 280
 281
 282 -- | To get the id of a PhyloGroup
 283 getGroupId :: PhyloGroup -> PhyloGroupId
 284 getGroupId = _phylo_groupId
 285
 286
 287 -- | To get the Cooc Matrix of a PhyloGroup
 288 getGroupCooc :: PhyloGroup -> Map (Int,Int) Double
 289 getGroupCooc = _phylo_groupCooc
 290
 291
 292 -- | To get the level out of the id of a PhyloGroup
 293 getGroupLevel :: PhyloGroup -> Int
 294 getGroupLevel = snd . fst . getGroupId
 295
 296
 297 -- | To get the level child pointers of a PhyloGroup
 298 getGroupLevelChilds :: PhyloGroup -> [Pointer]
 299 getGroupLevelChilds = _phylo_groupLevelChilds
 300
 301
 302 -- | To get the PhyloGroups Level Childs Ids of a PhyloGroup
 303 getGroupLevelChildsId :: PhyloGroup -> [PhyloGroupId]
 304 getGroupLevelChildsId g = map fst $ getGroupLevelChilds g
 305
 306
 307 -- | To get the level parent pointers of a PhyloGroup
 308 getGroupLevelParents :: PhyloGroup -> [Pointer]
 309 getGroupLevelParents = _phylo_groupLevelParents
 310
 311
 312 -- | To get the PhyloGroups Level Parents Ids of a PhyloGroup
 313 getGroupLevelParentsId :: PhyloGroup -> [PhyloGroupId]
 314 getGroupLevelParentsId g = map fst $ getGroupLevelParents g
 315
 316
 317 -- | To get the Ngrams of a PhyloGroup
 318 getGroupNgrams :: PhyloGroup -> [Int]
 319 getGroupNgrams =  _phylo_groupNgrams
 320
 321
 322 -- | To get the list of pairs (Childs & Parents) of a PhyloGroup
 323 getGroupPairs :: PhyloGroup -> Phylo -> [PhyloGroup]
 324 getGroupPairs g p = (getGroupChilds g p) ++ (getGroupParents g p)
 325
 326
 327 -- | To get the PhyloGroups Parents of a PhyloGroup
 328 getGroupParents :: PhyloGroup -> Phylo -> [PhyloGroup]
 329 getGroupParents g p = getGroupsFromIds (getGroupPeriodParentsId g) p
 330
 331
 332 -- | To get the period out of the id of a PhyloGroup
 333 getGroupPeriod :: PhyloGroup -> (Date,Date)
 334 getGroupPeriod = fst . fst . getGroupId
 335
 336
 337 -- | To get the period child pointers of a PhyloGroup
 338 getGroupPeriodChilds :: PhyloGroup -> [Pointer]
 339 getGroupPeriodChilds = _phylo_groupPeriodChilds
 340
 341
 342 -- | To get the PhyloGroups Period Parents Ids of a PhyloGroup
 343 getGroupPeriodChildsId :: PhyloGroup -> [PhyloGroupId]
 344 getGroupPeriodChildsId g = map fst $ getGroupPeriodChilds g
 345
 346
 347 -- | To get the period parent pointers of a PhyloGroup
 348 getGroupPeriodParents :: PhyloGroup -> [Pointer]
 349 getGroupPeriodParents = _phylo_groupPeriodParents
 350
 351
 352 -- | To get the PhyloGroups Period Parents Ids of a PhyloGroup
 353 getGroupPeriodParentsId :: PhyloGroup -> [PhyloGroupId]
 354 getGroupPeriodParentsId g = map fst $ getGroupPeriodParents g
 355
 356 -- | To get the roots labels of a list of group ngrams
 357 getGroupText :: PhyloGroup -> Phylo -> [Text]
 358 getGroupText g p = ngramsToText (getRootsLabels p) (getGroupNgrams g)
 359
 360
 361 -- | To get all the PhyloGroup of a Phylo
 362 getGroups :: Phylo -> [PhyloGroup]
 363 getGroups = view ( phylo_periods
 364                  .  traverse
 365                  . phylo_periodLevels
 366                  .  traverse
 367                  . phylo_levelGroups
 368                  )
 369
 370
 371 -- | To get all PhyloGroups matching a list of PhyloGroupIds in a Phylo
 372 getGroupsFromIds :: [PhyloGroupId] -> Phylo -> [PhyloGroup]
 373 getGroupsFromIds ids p = filter (\g -> elem (getGroupId g) ids) $ getGroups p
 374
 375
 376 -- | To get the corresponding list of PhyloGroups from a list of PhyloNodes
 377 getGroupsFromNodes :: [PhyloNode] -> Phylo -> [PhyloGroup]
 378 getGroupsFromNodes ns p = getGroupsFromIds (map getNodeId ns) p
 379
 380
 381 -- | To get all the PhyloGroup of a Phylo with a given level and period
 382 getGroupsWithFilters :: Int -> (Date,Date) -> Phylo -> [PhyloGroup]
 383 getGroupsWithFilters lvl prd p = (getGroupsWithLevel  lvl p)
 384                                  `intersect`
 385                                  (getGroupsWithPeriod prd p)
 386
 387
 388 -- | To get all the PhyloGroup of a Phylo with a given Level
 389 getGroupsWithLevel :: Int -> Phylo -> [PhyloGroup]
 390 getGroupsWithLevel lvl p = filterGroups getGroupLevel lvl (getGroups p)
 391
 392
 393 -- | To get all the PhyloGroup of a Phylo with a given Period
 394 getGroupsWithPeriod :: (Date,Date) -> Phylo -> [PhyloGroup]
 395 getGroupsWithPeriod prd p = filterGroups getGroupPeriod prd (getGroups p)
 396
 397
 398 -- | To create a PhyloGroup in a Phylo out of a list of Ngrams and a set of parameters
 399 initGroup :: [Ngrams] -> Text -> Int -> Int -> Int -> Int -> Phylo -> PhyloGroup
 400 initGroup ngrams lbl idx lvl from' to' p = PhyloGroup
 401   (((from', to'), lvl), idx)
 402   lbl
 403   (sort $ map (\x -> getIdxInRoots x p) ngrams)
 404   (Map.empty)
 405   (Map.empty)
 406   Nothing
 407   [] [] [] []
 408
 409
 410 ---------------------
 411 -- | PhyloPeriod | --
 412 ---------------------
 413
 414
 415 -- | To alter each PhyloPeriod of a Phylo following a given function
 416 alterPhyloPeriods :: (PhyloPeriod -> PhyloPeriod) -> Phylo -> Phylo
 417 alterPhyloPeriods f p = over ( phylo_periods
 418                              .  traverse) f p
 419
 420
 421 -- | To append a list of PhyloPeriod to a Phylo
 422 appendToPhyloPeriods :: [PhyloPeriod] -> Phylo -> Phylo
 423 appendToPhyloPeriods l p = over (phylo_periods) (++ l) p
 424
 425
 426 -- | To get all the PhyloPeriodIds of a Phylo
 427 getPhyloPeriods :: Phylo -> [PhyloPeriodId]
 428 getPhyloPeriods p = map _phylo_periodId
 429                   $ view (phylo_periods) p
 430
 431
 432 -- | To get the id of a given PhyloPeriod
 433 getPhyloPeriodId :: PhyloPeriod -> PhyloPeriodId
 434 getPhyloPeriodId prd = _phylo_periodId prd
 435
 436
 437 -- | To create a PhyloPeriod
 438 initPhyloPeriod :: PhyloPeriodId -> [PhyloLevel] -> PhyloPeriod
 439 initPhyloPeriod id l = PhyloPeriod id l
 440
 441
 442 --------------------
 443 -- | PhyloLevel | --
 444 --------------------
 445
 446
 447 -- | To alter a list of PhyloLevels following a given function
 448 alterPhyloLevels :: ([PhyloLevel] -> [PhyloLevel]) -> Phylo -> Phylo
 449 alterPhyloLevels f p = over ( phylo_periods
 450                             .  traverse
 451                             . phylo_periodLevels) f p
 452
 453
 454 -- | To get the PhylolevelId of a given PhyloLevel
 455 getPhyloLevelId :: PhyloLevel -> PhyloLevelId
 456 getPhyloLevelId = _phylo_levelId
 457
 458
 459 -- | To get all the Phylolevels of a given PhyloPeriod
 460 getPhyloLevels :: PhyloPeriod -> [PhyloLevel]
 461 getPhyloLevels = view (phylo_periodLevels)
 462
 463
 464 -- | To create a PhyloLevel
 465 initPhyloLevel :: PhyloLevelId -> [PhyloGroup] -> PhyloLevel
 466 initPhyloLevel id groups = PhyloLevel id groups
 467
 468
 469 -- | To set the LevelId of a PhyloLevel and of all its PhyloGroups
 470 setPhyloLevelId :: Int -> PhyloLevel -> PhyloLevel
 471 setPhyloLevelId lvl' (PhyloLevel (id, _lvl) groups)
 472     = PhyloLevel (id, lvl') groups'
 473         where
 474             groups' = over (traverse . phylo_groupId)
 475                            (\((period, _lvl), idx) -> ((period, lvl'), idx))
 476                            groups
 477
 478
 479 ------------------
 480 -- | PhyloFis | --
 481 ------------------
 482
 483
 484 -- | To get the clique of a PhyloFis
 485 getClique :: PhyloFis -> Clique
 486 getClique = _phyloFis_clique
 487
 488 -- | To get the metrics of a PhyloFis
 489 getFisMetrics :: PhyloFis -> Map (Int,Int) (Map Text [Double])
 490 getFisMetrics = _phyloFis_metrics
 491
 492 -- | To get the support of a PhyloFis
 493 getSupport :: PhyloFis -> Support
 494 getSupport = _phyloFis_support
 495
 496
 497 ----------------------------
 498 -- | PhyloNodes & Edges | --
 499 ----------------------------
 500
 501
 502 -- | To filter some GroupEdges with a given threshold
 503 filterGroupEdges :: Double -> GroupEdges -> GroupEdges
 504 filterGroupEdges thr edges = filter (\((_s,_t),w) -> w > thr) edges
 505
 506
 507 -- | To get the neighbours (directed/undirected) of a PhyloGroup from a list of GroupEdges
 508 getNeighbours :: Bool -> PhyloGroup -> GroupEdges -> [PhyloGroup]
 509 getNeighbours directed g e = case directed of
 510   True  -> map (\((_s,t),_w) -> t)
 511              $ filter (\((s,_t),_w) -> s == g) e
 512   False -> map (\((s,t),_w) -> (head' "getNeighbours") $ delete g $ nub [s,t,g])
 513              $ filter (\((s,t),_w) -> s == g || t == g) e
 514
 515
 516 -- | To get the PhyloBranchId of PhyloNode if it exists
 517 getNodeBranchId :: PhyloNode -> PhyloBranchId
 518 getNodeBranchId n = case n ^. pn_bid of
 519                      Nothing -> panic "[ERR][Viz.Phylo.Tools.getNodeBranchId] branchId not found"
 520                      Just i  -> i
 521
 522
 523 -- | To get the PhyloGroupId of a PhyloNode
 524 getNodeId :: PhyloNode -> PhyloGroupId
 525 getNodeId n = n ^. pn_id
 526
 527
 528 -- | To get the Level of a PhyloNode
 529 getNodeLevel :: PhyloNode -> Level
 530 getNodeLevel n = (snd . fst) $ getNodeId n
 531
 532
 533 -- | To get the Parent Node of a PhyloNode in a PhyloView
 534 getNodeParent :: PhyloNode -> PhyloView -> [PhyloNode]
 535 getNodeParent n v = filter (\n' -> elem (getNodeId n') (getNodeParentsId n))
 536                   $ v ^. pv_nodes
 537
 538
 539 -- | To get the Parent Node id of a PhyloNode if it exists
 540 getNodeParentsId :: PhyloNode -> [PhyloGroupId]
 541 getNodeParentsId n = case n ^. pn_parents of
 542                     Nothing  -> panic "[ERR][Viz.Phylo.Tools.getNodeParentsId] node parent not found"
 543                     Just ids -> ids
 544
 545
 546 -- | To get a list of PhyloNodes grouped by PhyloBranch in a PhyloView
 547 getNodesByBranches :: PhyloView -> [(PhyloBranchId,[PhyloNode])]
 548 getNodesByBranches v = zip bIds $ map (\id -> filter (\n -> (getNodeBranchId n) == id)
 549                                             $ getNodesInBranches v ) bIds
 550   where
 551     --------------------------------------
 552     bIds :: [PhyloBranchId]
 553     bIds = getViewBranchIds v
 554     --------------------------------------
 555
 556
 557 -- | To get a list of PhyloNodes owned by any PhyloBranches in a PhyloView
 558 getNodesInBranches :: PhyloView -> [PhyloNode]
 559 getNodesInBranches v = filter (\n -> isJust $ n ^. pn_bid)
 560                      $ v ^. pv_nodes
 561
 562
 563 -- | To get the PhyloGroupId of the Source of a PhyloEdge
 564 getSourceId :: PhyloEdge -> PhyloGroupId
 565 getSourceId e = e ^. pe_source
 566
 567
 568 -- | To get the PhyloGroupId of the Target of a PhyloEdge
 569 getTargetId :: PhyloEdge -> PhyloGroupId
 570 getTargetId e = e ^. pe_target
 571
 572
 573 ---------------------
 574 -- | PhyloBranch | --
 575 ---------------------
 576
 577
 578 -- | To get the PhyloBranchId of a PhyloBranch
 579 getBranchId :: PhyloBranch -> PhyloBranchId
 580 getBranchId b = b ^. pb_id
 581
 582
 583 -- | To get a list of PhyloBranchIds given a Level in a Phylo
 584 getBranchIdsWith :: Level -> Phylo -> [PhyloBranchId]
 585 getBranchIdsWith lvl p = sortOn snd
 586                        $ mapMaybe getGroupBranchId
 587                        $ getGroupsWithLevel lvl p
 588
 589
 590 -- | To get the Meta value of a PhyloBranch
 591 getBranchMeta :: Text -> PhyloBranch -> [Double]
 592 getBranchMeta k b = (b ^. pb_metrics) ! k
 593
 594
 595 -- | To get all the PhyloBranchIds of a PhyloView
 596 getViewBranchIds :: PhyloView -> [PhyloBranchId]
 597 getViewBranchIds v = map getBranchId $ v ^. pv_branches
 598
 599
 600 --------------------------------
 601 -- | PhyloQuery & QueryView | --
 602 --------------------------------
 603
 604
 605 -- | To filter PhyloView's Branches by level
 606 filterBranchesByLevel :: Level -> PhyloView -> [PhyloBranch]
 607 filterBranchesByLevel lvl pv = filter (\pb -> lvl == (fst $ pb ^. pb_id))
 608                           $ pv ^. pv_branches
 609
 610
 611 -- | To filter PhyloView's Edges by level
 612 filterEdgesByLevel :: Level -> [PhyloEdge] -> [PhyloEdge]
 613 filterEdgesByLevel lvl pes = filter (\pe -> (lvl == ((snd . fst) $ pe ^. pe_source))
 614                                          && (lvl == ((snd . fst) $ pe ^. pe_target))) pes
 615
 616
 617 -- | To filter PhyloView's Edges by type
 618 filterEdgesByType :: EdgeType -> [PhyloEdge] -> [PhyloEdge]
 619 filterEdgesByType t pes = filter (\pe -> t == (pe ^. pe_type)) pes
 620
 621
 622 -- | To filter PhyloView's Nodes by the oldest Period
 623 filterNodesByFirstPeriod :: [PhyloNode] -> [PhyloNode]
 624 filterNodesByFirstPeriod pns = filter (\pn -> fstPrd == ((fst . fst) $ pn ^. pn_id)) pns
 625     where
 626         --------------------------------------
 627         fstPrd :: (Date,Date)
 628         fstPrd = (head' "filterNodesByFirstPeriod")
 629                $ sortOn fst
 630                $ map (\pn -> (fst . fst) $ pn ^. pn_id) pns
 631         --------------------------------------
 632
 633
 634 -- | To filter PhyloView's Nodes by Branch
 635 filterNodesByBranch :: PhyloBranchId -> [PhyloNode] -> [PhyloNode]
 636 filterNodesByBranch bId pns = filter (\pn -> if isJust $ pn ^. pn_bid
 637                                              then if bId == (fromJust $ pn ^. pn_bid)
 638                                                   then True
 639                                                   else False
 640                                              else False ) pns
 641
 642
 643 -- | To filter PhyloView's Nodes by level
 644 filterNodesByLevel :: Level -> [PhyloNode] -> [PhyloNode]
 645 filterNodesByLevel lvl pns = filter (\pn -> lvl == ((snd . fst) $ pn ^. pn_id)) pns
 646
 647
 648 -- | To filter PhyloView's Nodes by Period
 649 filterNodesByPeriod :: PhyloPeriodId -> [PhyloNode] -> [PhyloNode]
 650 filterNodesByPeriod prd pns = filter (\pn -> prd == ((fst . fst) $ pn ^. pn_id)) pns
 651
 652
 653 -- | To get the first clustering method to apply to get the contextual units of a Phylo
 654 getContextualUnit :: PhyloQueryBuild -> Cluster
 655 getContextualUnit q = q ^. q_contextualUnit
 656
 657
 658 -- | To get the metrics to apply to contextual units
 659 getContextualUnitMetrics :: PhyloQueryBuild -> [Metric]
 660 getContextualUnitMetrics q = q ^. q_contextualUnitMetrics
 661
 662
 663 -- | To get the filters to apply to contextual units
 664 getContextualUnitFilters :: PhyloQueryBuild -> [Filter]
 665 getContextualUnitFilters q = q ^. q_contextualUnitFilters
 666
 667
 668 -- | To get the cluster methods to apply to the Nths levels of a Phylo
 669 getNthCluster :: PhyloQueryBuild -> Cluster
 670 getNthCluster q = q ^. q_nthCluster
 671
 672
 673 -- | To get the Sup Level of a reconstruction of a Phylo from a PhyloQuery
 674 getNthLevel :: PhyloQueryBuild -> Level
 675 getNthLevel q = q ^. q_nthLevel
 676
 677
 678 -- | To get the Grain of the PhyloPeriods from a PhyloQuery
 679 getPeriodGrain :: PhyloQueryBuild -> Int
 680 getPeriodGrain q = q ^. q_periodGrain
 681
 682
 683 -- | To get the intertemporal matching strategy to apply to a Phylo from a PhyloQuery
 684 getInterTemporalMatching :: PhyloQueryBuild -> Proximity
 685 getInterTemporalMatching q = q ^. q_interTemporalMatching
 686
 687
 688 -- | To get the Steps of the PhyloPeriods from a PhyloQuery
 689 getPeriodSteps :: PhyloQueryBuild -> Int
 690 getPeriodSteps q = q ^. q_periodSteps
 691
 692
 693 --------------------------------------------------
 694 -- | PhyloQueryBuild & PhyloQueryView Constructors | --
 695 --------------------------------------------------
 696
 697
 698 -- | To get the Proximity associated to a given Clustering method
 699 getProximity :: Cluster -> Proximity
 700 getProximity cluster = case cluster of
 701   Louvain (LouvainParams proxi)      -> proxi
 702   RelatedComponents (RCParams proxi) -> proxi
 703   _   -> panic "[ERR][Viz.Phylo.Tools.getProximity] this cluster has no associated Proximity"
 704
 705
 706 -- | To initialize all the Cluster / Proximity with their default parameters
 707 initFis :: Maybe Bool -> Maybe Support -> FisParams
 708 initFis (def True -> kmf) (def 1 -> min') = FisParams kmf min'
 709
 710 initHamming :: Maybe Double -> HammingParams
 711 initHamming (def 0.01 -> sens) = HammingParams sens
 712
 713 initSmallBranch :: Maybe Int -> Maybe Int -> Maybe Int -> SBParams
 714 initSmallBranch (def 2 -> periodsInf) (def 2 -> periodsSup) (def 1 -> minNodes) = SBParams periodsInf periodsSup minNodes
 715
 716 initLouvain :: Maybe Proximity -> LouvainParams
 717 initLouvain (def defaultWeightedLogJaccard -> proxi) = LouvainParams proxi
 718
 719 initRelatedComponents :: Maybe Proximity -> RCParams
 720 initRelatedComponents (def Filiation -> proxi) = RCParams proxi
 721
 722 initWeightedLogJaccard :: Maybe Double -> Maybe Double -> WLJParams
 723 initWeightedLogJaccard (def 0 -> thr) (def 0.01 -> sens) = WLJParams thr sens
 724
 725
 726 -- | To initialize a PhyloQueryBuild from given and default parameters
 727 initPhyloQueryBuild :: Text -> Text -> Maybe Int -> Maybe Int -> Maybe Cluster -> Maybe [Metric] -> Maybe [Filter] -> Maybe Proximity -> Maybe Level -> Maybe Cluster -> PhyloQueryBuild
 728 initPhyloQueryBuild name desc (def 5 -> grain) (def 3 -> steps) (def defaultFis -> cluster) (def [] -> metrics) (def [] -> filters)
 729   (def defaultWeightedLogJaccard -> matching') (def 2 -> nthLevel) (def defaultRelatedComponents -> nthCluster) =
 730     PhyloQueryBuild name desc grain steps cluster metrics filters matching' nthLevel nthCluster
 731
 732
 733
 734 -- | To initialize a PhyloQueryView default parameters
 735 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
 736 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) =
 737   PhyloQueryView lvl f c d ms fs ts s em dm v
 738
 739
 740 -- | To define some obvious boolean getters
 741 shouldKeepMinorFis :: FisParams -> Bool
 742 shouldKeepMinorFis = _fis_keepMinorFis
 743
 744 ----------------------------
 745 -- | Default ressources | --
 746 ----------------------------
 747
 748 -- Clusters
 749
 750 defaultFis :: Cluster
 751 defaultFis = Fis (initFis Nothing Nothing)
 752
 753 defaultLouvain :: Cluster
 754 defaultLouvain = Louvain (initLouvain Nothing)
 755
 756 defaultRelatedComponents :: Cluster
 757 defaultRelatedComponents = RelatedComponents (initRelatedComponents Nothing)
 758
 759 -- Filters
 760
 761 defaultSmallBranch :: Filter
 762 defaultSmallBranch = SmallBranch (initSmallBranch Nothing Nothing Nothing)
 763
 764 -- Params
 765
 766 defaultPhyloParam :: PhyloParam
 767 defaultPhyloParam = initPhyloParam Nothing Nothing Nothing
 768
 769 -- Proximities
 770
 771 defaultHamming :: Proximity
 772 defaultHamming = Hamming (initHamming Nothing)
 773
 774 defaultWeightedLogJaccard :: Proximity
 775 defaultWeightedLogJaccard = WeightedLogJaccard (initWeightedLogJaccard Nothing Nothing)
 776
 777 -- Queries
 778
 779 defaultQueryBuild :: PhyloQueryBuild
 780 defaultQueryBuild = initPhyloQueryBuild "Cesar et Cleôpatre" "An example of Phylomemy (french without accent)"
 781                               Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
 782
 783 defaultQueryView :: PhyloQueryView
 784 defaultQueryView = initPhyloQueryView Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
 785
 786 -- Software
 787
 788 defaultSoftware :: Software
 789 defaultSoftware = Software "Gargantext" "v4"
 790
 791 -- Version
 792
 793 defaultPhyloVersion :: Text
 794 defaultPhyloVersion = "v1"
 795