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