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