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