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