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