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