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