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 -> [GroupEdge] -> [GroupEdge]
 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 -> [GroupEdge] -> [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 -- | To get the threshold of a Proximity
 690 getThreshold :: Proximity -> Double
 691 getThreshold prox = case prox of
 692   WeightedLogJaccard (WLJParams thr _) -> thr
 693   Hamming (HammingParams thr)          -> thr
 694   Filiation                            -> panic "[ERR][Viz.Phylo.Tools.getThreshold] Filiation"
 695
 696
 697 -- | To get the Proximity associated to a given Clustering method
 698 getProximity :: Cluster -> Proximity
 699 getProximity cluster = case cluster of
 700   Louvain (LouvainParams proxi)      -> proxi
 701   RelatedComponents (RCParams proxi) -> proxi
 702   _   -> panic "[ERR][Viz.Phylo.Tools.getProximity] this cluster has no associated Proximity"
 703
 704
 705 -- | To initialize all the Cluster / Proximity with their default parameters
 706 initFis :: Maybe Bool -> Maybe Support -> Maybe Int -> FisParams
 707 initFis (def True -> kmf) (def 1 -> min') (def 1 -> thr) = FisParams kmf min' thr
 708
 709 initHamming :: Maybe Double -> HammingParams
 710 initHamming (def 0.01 -> sens) = HammingParams sens
 711
 712 initSmallBranch' :: Maybe Int -> Maybe Int -> Maybe Int -> SBParams
 713 initSmallBranch' (def 2 -> periodsInf) (def 2 -> periodsSup) (def 1 -> minNodes) = SBParams periodsInf periodsSup minNodes
 714
 715 initSmallBranch :: Maybe Int -> Maybe Int -> Maybe Int -> SBParams
 716 initSmallBranch (def 0 -> periodsInf) (def 0 -> periodsSup) (def 1 -> minNodes) = SBParams periodsInf periodsSup minNodes
 717
 718 initLouvain :: Maybe Proximity -> LouvainParams
 719 initLouvain (def defaultWeightedLogJaccard -> proxi) = LouvainParams proxi
 720
 721 initRelatedComponents :: Maybe Proximity -> RCParams
 722 initRelatedComponents (def Filiation -> proxi) = RCParams proxi
 723
 724 initWeightedLogJaccard :: Maybe Double -> Maybe Double -> WLJParams
 725 initWeightedLogJaccard (def 0 -> thr) (def 0.01 -> sens) = WLJParams thr sens
 726
 727
 728 -- | To initialize a PhyloQueryBuild from given and default parameters
 729 initPhyloQueryBuild :: Text -> Text -> Maybe Int -> Maybe Int -> Maybe Cluster -> Maybe [Metric] -> Maybe [Filter] -> Maybe Proximity -> Maybe Level -> Maybe Cluster -> PhyloQueryBuild
 730 initPhyloQueryBuild name desc (def 5 -> grain) (def 3 -> steps) (def defaultFis -> cluster) (def [] -> metrics) (def [] -> filters)
 731   (def defaultWeightedLogJaccard -> matching') (def 2 -> nthLevel) (def defaultRelatedComponents -> nthCluster) =
 732     PhyloQueryBuild name desc grain steps cluster metrics filters matching' nthLevel nthCluster
 733
 734
 735
 736 -- | To initialize a PhyloQueryView default parameters
 737 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
 738 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) =
 739   PhyloQueryView lvl f c d ms fs ts s em dm v
 740
 741
 742 -- | To define some obvious boolean getters
 743 shouldKeepMinorFis :: FisParams -> Bool
 744 shouldKeepMinorFis = _fis_keepMinorFis
 745
 746 ----------------------------
 747 -- | Default ressources | --
 748 ----------------------------
 749
 750 -- Clusters
 751
 752 defaultFis :: Cluster
 753 defaultFis = Fis (initFis Nothing Nothing Nothing)
 754
 755 defaultLouvain :: Cluster
 756 defaultLouvain = Louvain (initLouvain Nothing)
 757
 758 defaultRelatedComponents :: Cluster
 759 defaultRelatedComponents = RelatedComponents (initRelatedComponents Nothing)
 760
 761 -- Filters
 762
 763 defaultSmallBranch :: Filter
 764 defaultSmallBranch = SmallBranch (initSmallBranch Nothing Nothing Nothing)
 765
 766 -- Params
 767
 768 defaultPhyloParam :: PhyloParam
 769 defaultPhyloParam = initPhyloParam Nothing Nothing Nothing
 770
 771 -- Proximities
 772
 773 defaultHamming :: Proximity
 774 defaultHamming = Hamming (initHamming Nothing)
 775
 776 defaultWeightedLogJaccard :: Proximity
 777 defaultWeightedLogJaccard = WeightedLogJaccard (initWeightedLogJaccard Nothing Nothing)
 778
 779 -- Queries
 780
 781 defaultQueryBuild :: PhyloQueryBuild
 782 defaultQueryBuild = initPhyloQueryBuild "Cesar et Cleôpatre" "An example of Phylomemy (french without accent)"
 783                               Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
 784
 785 defaultQueryView :: PhyloQueryView
 786 defaultQueryView = initPhyloQueryView Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
 787
 788 -- Software
 789
 790 defaultSoftware :: Software
 791 defaultSoftware = Software "Gargantext" "v4"
 792
 793 -- Version
 794
 795 defaultPhyloVersion :: Text
 796 defaultPhyloVersion = "v1"
 797