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