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