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