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