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