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 -> PhyloPeaks -> 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 -- | PhyloPeaks | --
 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 foundationsPeaks of a Phylo
 195 getPeaks :: Phylo -> PhyloPeaks
 196 getPeaks = _phylo_foundationsPeaks
 197
 198 -- | To get the peaksLabels of a Phylo
 199 getPeaksLabels :: Phylo -> Vector Ngrams
 200 getPeaksLabels p = (getPeaks p) ^. phylo_peaksLabels
 201
 202 -- | To get the Index of a Ngrams in the foundationsPeaks of a Phylo
 203 getIdxInPeaks :: Ngrams -> Phylo -> Int
 204 getIdxInPeaks n p = case (elemIndex n (getPeaksLabels p)) of
 205     Nothing  -> panic "[ERR][Viz.Phylo.Tools.getIdxInPeaks] Ngrams not in foundationsPeaks"
 206     Just idx -> idx
 207
 208 -- | To init the PhyloPeaks of a Phylo
 209 initPeaks :: [Tree Ngrams] -> Vector Ngrams -> PhyloPeaks
 210 initPeaks trees ns = PhyloPeaks 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 -> getIdxInPeaks 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 -- | To get the first clustering method to apply to get the contextual units of a Phylo
 592 getContextualUnit :: PhyloQueryBuild -> Cluster
 593 getContextualUnit q = q ^. q_contextualUnit
 594
 595
 596 -- | To get the metrics to apply to contextual units
 597 getContextualUnitMetrics :: PhyloQueryBuild -> [Metric]
 598 getContextualUnitMetrics q = q ^. q_contextualUnitMetrics
 599
 600
 601 -- | To get the filters to apply to contextual units
 602 getContextualUnitFilters :: PhyloQueryBuild -> [Filter]
 603 getContextualUnitFilters q = q ^. q_contextualUnitFilters
 604
 605
 606 -- | To get the cluster methods to apply to the Nths levels of a Phylo
 607 getNthCluster :: PhyloQueryBuild -> Cluster
 608 getNthCluster q = q ^. q_nthCluster
 609
 610
 611 -- | To get the Sup Level of a reconstruction of a Phylo from a PhyloQuery
 612 getNthLevel :: PhyloQueryBuild -> Level
 613 getNthLevel q = q ^. q_nthLevel
 614
 615
 616 -- | To get the Grain of the PhyloPeriods from a PhyloQuery
 617 getPeriodGrain :: PhyloQueryBuild -> Int
 618 getPeriodGrain q = q ^. q_periodGrain
 619
 620
 621 -- | To get the intertemporal matching strategy to apply to a Phylo from a PhyloQuery
 622 getInterTemporalMatching :: PhyloQueryBuild -> Proximity
 623 getInterTemporalMatching q = q ^. q_interTemporalMatching
 624
 625
 626 -- | To get the Steps of the PhyloPeriods from a PhyloQuery
 627 getPeriodSteps :: PhyloQueryBuild -> Int
 628 getPeriodSteps q = q ^. q_periodSteps
 629
 630
 631 --------------------------------------------------
 632 -- | PhyloQueryBuild & PhyloQueryView Constructors | --
 633 --------------------------------------------------
 634
 635
 636 -- | To get the Proximity associated to a given Clustering method
 637 getProximity :: Cluster -> Proximity
 638 getProximity cluster = case cluster of
 639   Louvain (LouvainParams proxi)      -> proxi
 640   RelatedComponents (RCParams proxi) -> proxi
 641   _   -> panic "[ERR][Viz.Phylo.Tools.getProximity] this cluster has no associated Proximity"
 642
 643
 644 -- | To initialize all the Cluster / Proximity with their default parameters
 645 initFis :: Maybe Bool -> Maybe Support -> FisParams
 646 initFis (def True -> kmf) (def 1 -> min') = FisParams kmf min'
 647
 648 initHamming :: Maybe Double -> HammingParams
 649 initHamming (def 0.01 -> sens) = HammingParams sens
 650
 651 initSmallBranch :: Maybe Int -> Maybe Int -> Maybe Int -> SBParams
 652 initSmallBranch (def 2 -> periodsInf) (def 2 -> periodsSup) (def 1 -> minNodes) = SBParams periodsInf periodsSup minNodes
 653
 654 initLouvain :: Maybe Proximity -> LouvainParams
 655 initLouvain (def defaultWeightedLogJaccard -> proxi) = LouvainParams proxi
 656
 657 initRelatedComponents :: Maybe Proximity -> RCParams
 658 initRelatedComponents (def Filiation -> proxi) = RCParams proxi
 659
 660 initWeightedLogJaccard :: Maybe Double -> Maybe Double -> WLJParams
 661 initWeightedLogJaccard (def 0 -> thr) (def 0.01 -> sens) = WLJParams thr sens
 662
 663
 664 -- | To initialize a PhyloQuery from given and default parameters
 665 initPhyloQueryBuild :: Maybe Text -> Maybe Text -> Maybe Int -> Maybe Int -> Maybe Cluster -> Maybe [Metric] -> Maybe [Filter] -> Maybe Proximity -> Maybe Level -> Maybe Cluster -> PhyloQueryBuild
 666 initPhyloQueryBuild name desc (def 5 -> grain) (def 3 -> steps) (def defaultFis -> cluster) (def [] -> metrics) (def [] -> filters)
 667   (def defaultWeightedLogJaccard -> matching') (def 2 -> nthLevel) (def defaultRelatedComponents -> nthCluster) =
 668     PhyloQueryBuild name' desc' grain steps cluster metrics filters matching' nthLevel nthCluster
 669       where
 670         name' = maybe "Phylo Title" identity name
 671         desc' = maybe "Phylo Desc"  identity desc
 672
 673
 674
 675 -- | To initialize a PhyloQueryView default parameters
 676 initPhyloQueryView :: Maybe Level -> Maybe Filiation -> Maybe Bool -> Maybe Level -> Maybe [Metric] -> Maybe [Filter] -> Maybe [Tagger] -> Maybe (Sort, Order) -> Maybe DisplayMode -> Maybe Bool -> PhyloQueryView
 677 initPhyloQueryView (def 2 -> lvl) (def Descendant -> f) (def False -> c) (def 1 -> d) (def [] -> ms) (def [] -> fs) (def [] -> ts) s (def Flat -> dm) (def True -> v) =
 678   PhyloQueryView lvl f c d ms fs ts s dm v
 679
 680
 681 -- | To define some obvious boolean getters
 682 shouldKeepMinorFis :: FisParams -> Bool
 683 shouldKeepMinorFis = _fis_keepMinorFis
 684
 685 ----------------------------
 686 -- | Default ressources | --
 687 ----------------------------
 688
 689 -- Clusters
 690
 691 defaultFis :: Cluster
 692 defaultFis = Fis (initFis Nothing Nothing)
 693
 694 defaultLouvain :: Cluster
 695 defaultLouvain = Louvain (initLouvain Nothing)
 696
 697 defaultRelatedComponents :: Cluster
 698 defaultRelatedComponents = RelatedComponents (initRelatedComponents Nothing)
 699
 700 -- Filters
 701
 702 defaultSmallBranch :: Filter
 703 defaultSmallBranch = SmallBranch (initSmallBranch Nothing Nothing Nothing)
 704
 705 -- Params
 706
 707 defaultPhyloParam :: PhyloParam
 708 defaultPhyloParam = initPhyloParam Nothing Nothing Nothing
 709
 710 -- Proximities
 711
 712 defaultHamming :: Proximity
 713 defaultHamming = Hamming (initHamming Nothing)
 714
 715 defaultWeightedLogJaccard :: Proximity
 716 defaultWeightedLogJaccard = WeightedLogJaccard (initWeightedLogJaccard Nothing Nothing)
 717
 718 -- Queries
 719
 720 defaultQueryBuild :: PhyloQueryBuild
 721 defaultQueryBuild = initPhyloQueryBuild (Just "Cesar et Cleôpatre")
 722                                    (Just "An example of Phylomemy (french without accent)")
 723                                     Nothing Nothing Nothing
 724                                     Nothing Nothing Nothing
 725                                     Nothing Nothing
 726
 727 defaultQueryView :: PhyloQueryView
 728 defaultQueryView = initPhyloQueryView Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
 729
 730 -- Software
 731
 732 defaultSoftware :: Software
 733 defaultSoftware = Software "Gargantext" "v4"
 734
 735 -- Version
 736
 737 defaultPhyloVersion :: Text
 738 defaultPhyloVersion = "v1"
 739