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