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