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