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