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