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 ViewPatterns      #-}
  14
  15 module Gargantext.Viz.Phylo.Tools
  16   where
  17
  18 import Control.Lens         hiding (both, Level, Empty)
  19 import Data.List            (filter, intersect, (++), sort, null, tail, last, tails, delete, nub, sortOn, nubBy, concat)
  20 import Data.Maybe           (mapMaybe,fromMaybe)
  21 import Data.Map             (Map, mapKeys, member, (!), restrictKeys, elems, empty, filterWithKey, unionWith)
  22 import Data.Set             (Set)
  23 import Data.Text            (Text,toLower,unwords)
  24 import Data.Tuple.Extra
  25 import Data.Vector          (Vector,elemIndex)
  26 import Gargantext.Prelude
  27 import Gargantext.Viz.Phylo
  28 import qualified Data.Map    as Map
  29 import qualified Data.Set    as Set
  30 import qualified Data.Vector as Vector
  31
  32
  33 --------------
  34 -- | Misc | --
  35 --------------
  36
  37
  38 -- | Define a default value
  39 def :: a -> Maybe a -> a
  40 def = fromMaybe
  41
  42
  43 -- | Does a List of Sets contains at least one Set of an other List
  44 doesAnySetContains :: Eq a =>  Set a -> [Set a] -> [Set a] -> Bool
  45 doesAnySetContains h l l' = any (\c -> doesContains (Set.toList c) (Set.toList h)) (l' ++ l)
  46
  47
  48 -- | Does a list of A contains an other list of A
  49 doesContains :: Eq a => [a] -> [a] -> Bool
  50 doesContains l l'
  51   | null l'               = True
  52   | length l' > length l  = False
  53   | elem (head' "doesContains" l') l      = doesContains l (tail l')
  54   | otherwise             = False
  55
  56
  57 -- | Does a list of ordered A contains an other list of ordered A
  58 doesContainsOrd :: Eq a => Ord a => [a] -> [a] -> Bool
  59 doesContainsOrd l l'
  60   | null l'          = False
  61   | last l < (head' "doesContainsOrd" l') = False
  62   | (head' "doesContainsOrd" l') `elem` l = True
  63   | otherwise        = doesContainsOrd l (tail l')
  64
  65
  66 -- | To filter nested Sets of a
  67 filterNestedSets :: Eq a => Set a -> [Set a] -> [Set a] -> [Set a]
  68 filterNestedSets h l l'
  69   | null l                 = if doesAnySetContains h l l'
  70                              then l'
  71                              else h : l'
  72   | doesAnySetContains h l l' = filterNestedSets (head' "filterNestedSets1" l) (tail l) l'
  73   | otherwise              = filterNestedSets (head' "filterNestedSets2" l) (tail l) (h : l')
  74
  75
  76
  77 -- | To get the good pair of keys (x,y) or (y,x) in a given Map (a,b) c
  78 getKeyPair :: (Int,Int) -> Map (Int,Int) a -> (Int,Int)
  79 getKeyPair (x,y) m = case findPair (x,y) m of
  80                       Nothing -> panic "[ERR][Viz.Phylo.Example.getKeyPair] Nothing"
  81                       Just i  -> i
  82                      where
  83                       --------------------------------------
  84                       findPair :: (Int,Int) -> Map (Int,Int) a -> Maybe (Int,Int)
  85                       findPair (x',y') m'
  86                         | member (x',y') m' = Just (x',y')
  87                         | member (y',x') m' = Just (y',x')
  88                         | otherwise      = Nothing
  89                       --------------------------------------
  90
  91
  92 -- | To filter Fis with small Support but by keeping non empty Periods
  93 keepFilled :: (Int -> [a] -> [a]) -> Int -> [a] -> [a]
  94 keepFilled f thr l = if (null $ f thr l) && (not $ null l)
  95                      then keepFilled f (thr - 1) l
  96                      else f thr l
  97
  98
  99 -- | To get all combinations of a list
 100 listToFullCombi :: Eq a => [a] -> [(a,a)]
 101 listToFullCombi l = [(x,y) | x <- l, y <- l]
 102
 103
 104 -- | To get all combinations of a list
 105 listToDirectedCombi :: Eq a => [a] -> [(a,a)]
 106 listToDirectedCombi l = [(x,y) | x <- l, y <- l, x /= y]
 107
 108
 109 listToEqualCombi :: Eq a => [a] -> [(a,a)]
 110 listToEqualCombi l = [(x,y) | x <- l, y <- l, x == y]
 111
 112 listToPairs :: Eq a => [a] -> [(a,a)]
 113 listToPairs l = (listToEqualCombi l) ++ (listToUnDirectedCombi l)
 114
 115
 116 -- | To get all combinations of a list and apply a function to the resulting list of pairs
 117 listToDirectedCombiWith :: Eq a => forall b. (a -> b) -> [a] -> [(b,b)]
 118 listToDirectedCombiWith f l = [(f x,f y) | x <- l, y <- l, x /= y]
 119
 120
 121 -- | To get the sequential combinations of an order list
 122 listToSequentialCombi :: Eq a => [a] -> [(a,a)]
 123 listToSequentialCombi l = nubBy (\x y -> fst x == fst y) $ listToUnDirectedCombi l
 124
 125
 126 -- | To get all combinations of a list with no repetition
 127 listToUnDirectedCombi :: [a] -> [(a,a)]
 128 listToUnDirectedCombi l = [ (x,y) | (x:rest) <- tails l,  y <- rest ]
 129
 130
 131 -- | To get all combinations of a list with no repetition and apply a function to the resulting list of pairs
 132 listToUnDirectedCombiWith :: forall a b. (a -> b) -> [a] -> [(b,b)]
 133 listToUnDirectedCombiWith f l = [ (f x, f y) | (x:rest) <- tails l,  y <- rest ]
 134
 135
 136 -- | To transform a list of Ngrams Indexes into a Label
 137 ngramsToLabel :: Vector Ngrams -> [Int] -> Text
 138 ngramsToLabel ngrams l = unwords $ tail' "ngramsToLabel" $ concat $ map (\n -> ["|",n]) $ ngramsToText ngrams l
 139
 140
 141 -- | To transform a list of Ngrams Indexes into a list of Text
 142 ngramsToText :: Vector Ngrams -> [Int] -> [Text]
 143 ngramsToText ngrams l = map (\idx -> ngrams Vector.! idx) l
 144
 145
 146 -- | To transform a list of ngrams into a list of indexes
 147 ngramsToIdx :: [Ngrams] -> Vector Ngrams -> [Int]
 148 ngramsToIdx ns v = sort $ map (\n -> getIdxInVector n v) ns
 149
 150
 151 -- | To unify the keys (x,y) that Map 1 share with Map 2 such as: (x,y) <=> (y,x)
 152 unifySharedKeys :: Eq a => Ord a => Map (a,a) b -> Map (a,a) b -> Map (a,a) b
 153 unifySharedKeys m1 m2 = mapKeys (\(x,y) -> if member (y,x) m2
 154                                            then (y,x)
 155                                            else (x,y) ) m1
 156
 157
 158 ---------------
 159 -- | Phylo | --
 160 ---------------
 161
 162 -- | An analyzer ingests a Ngrams and generates a modified version of it
 163 phyloAnalyzer :: Ngrams -> Ngrams
 164 phyloAnalyzer n = toLower n
 165
 166 -- | To init the foundation roots of the Phylo as a Vector of Ngrams
 167 initFoundationsRoots :: [Ngrams] -> Vector Ngrams
 168 initFoundationsRoots l = Vector.fromList $ map phyloAnalyzer l
 169
 170 -- | To init the base of a Phylo from a List of Periods and Foundations
 171 initPhyloBase :: [(Date, Date)] -> PhyloFoundations -> Map Date Double  -> Map Date (Map (Int,Int) Double) -> Map (Date,Date) [PhyloFis] -> PhyloParam -> Phylo
 172 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
 173
 174 -- | To init the param of a Phylo
 175 initPhyloParam :: Maybe Text -> Maybe Software -> Maybe PhyloQueryBuild -> PhyloParam
 176 initPhyloParam (def defaultPhyloVersion -> v) (def defaultSoftware -> s) (def defaultQueryBuild -> q) = PhyloParam v s q
 177
 178 -- | To get the last computed Level in a Phylo
 179 getLastLevel :: Phylo -> Level
 180 getLastLevel p = (last . sort)
 181                $ map (snd . getPhyloLevelId)
 182                $ view ( phylo_periods
 183                       .  traverse
 184                       . phylo_periodLevels ) p
 185
 186 -- | To get all the coocurency matrix of a phylo
 187 getPhyloCooc :: Phylo -> Map Date (Map (Int,Int) Double)
 188 getPhyloCooc p = p ^. phylo_cooc
 189
 190
 191 -- | To get the PhyloParam of a Phylo
 192 getPhyloParams :: Phylo -> PhyloParam
 193 getPhyloParams = _phylo_param
 194
 195 -- | To get the title of a Phylo
 196 getPhyloTitle :: Phylo -> Text
 197 getPhyloTitle p = _q_phyloTitle $ _phyloParam_query $ getPhyloParams p
 198
 199 -- | To get the desc of a Phylo
 200 getPhyloDescription :: Phylo -> Text
 201 getPhyloDescription p = _q_phyloTitle $ _phyloParam_query $ getPhyloParams p
 202
 203 getPhyloMatchingFrame :: Phylo -> Int
 204 getPhyloMatchingFrame p = _q_interTemporalMatchingFrame $ _phyloParam_query $ getPhyloParams p
 205
 206 getPhyloMatchingFrameTh :: Phylo -> Double
 207 getPhyloMatchingFrameTh p = _q_interTemporalMatchingFrameTh $ _phyloParam_query $ getPhyloParams p
 208
 209 getPhyloProximity :: Phylo -> Proximity
 210 getPhyloProximity p = _q_interTemporalMatching $ _phyloParam_query $ getPhyloParams p
 211
 212 getPhyloReBranchThr :: Phylo -> Double
 213 getPhyloReBranchThr p = _q_reBranchThr $ _phyloParam_query $ getPhyloParams p
 214
 215 getPhyloReBranchNth :: Phylo -> Int
 216 getPhyloReBranchNth p = _q_reBranchNth $ _phyloParam_query $ getPhyloParams p
 217
 218 getPhyloFis :: Phylo -> Map (Date,Date) [PhyloFis]
 219 getPhyloFis = _phylo_fis
 220
 221
 222 --------------------
 223 -- | PhyloRoots | --
 224 --------------------
 225
 226 -- | To get the foundations of a Phylo
 227 getFoundations :: Phylo -> PhyloFoundations
 228 getFoundations = _phylo_foundations
 229
 230 -- | To get the foundations roots of a Phylo
 231 getFoundationsRoots :: Phylo -> Vector Ngrams
 232 getFoundationsRoots p = (getFoundations p) ^. phylo_foundationsRoots
 233
 234 -- | To get the Index of a Ngrams in the foundationsRoots of a Phylo
 235 getIdxInRoots :: Ngrams -> Phylo -> Int
 236 getIdxInRoots n p = case (elemIndex n (getFoundationsRoots p)) of
 237     Nothing  -> panic $ "[ERR][Viz.Phylo.Tools.getIdxInRoots] Ngrams not in foundationsRoots: " <> cs n
 238     Just idx -> idx
 239
 240 getIdxInRoots' :: Ngrams -> Vector Ngrams -> Int
 241 getIdxInRoots' n root = case (elemIndex n root) of
 242     Nothing  -> panic $ "[ERR][Viz.Phylo.Tools.getIdxInRoots] Ngrams not in foundationsRoots: " <> cs n
 243     Just idx -> idx
 244
 245 getIdxInVector :: Ngrams -> Vector Ngrams -> Int
 246 getIdxInVector n ns = case (elemIndex n ns) of
 247   Nothing  -> panic $ "[ERR][Viz.Phylo.Tools.getIdxInVector] Ngrams not in foundationsRoots: " <> cs n
 248   Just idx -> idx
 249
 250 --------------------
 251 -- | PhyloGroup | --
 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 alter a PhyloNode
 570 alterPhyloNode :: (PhyloNode -> PhyloNode) -> PhyloView -> PhyloView
 571 alterPhyloNode f v = over ( pv_nodes
 572                           .  traverse
 573                           ) (\pn ->  f pn ) v
 574
 575
 576 -- | To filter some GroupEdges with a given threshold
 577 filterGroupEdges :: Double -> [GroupEdge] -> [GroupEdge]
 578 filterGroupEdges thr edges = filter (\((_s,_t),w) -> w > thr) edges
 579
 580
 581 -- | To get the neighbours (directed/undirected) of a PhyloGroup from a list of GroupEdges
 582 getNeighbours :: Bool -> PhyloGroup -> [GroupEdge] -> [PhyloGroup]
 583 getNeighbours directed g e = case directed of
 584   True  -> map (\((_s,t),_w) -> t)
 585              $ filter (\((s,_t),_w) -> s == g) e
 586   False -> map (\((s,t),_w) -> (head' "getNeighbours") $ delete g $ nub [s,t,g])
 587              $ filter (\((s,t),_w) -> s == g || t == g) e
 588
 589
 590 -- | To get the PhyloBranchId of PhyloNode if it exists
 591 getNodeBranchId :: PhyloNode -> PhyloBranchId
 592 getNodeBranchId n = case n ^. pn_bid of
 593                      Nothing -> panic "[ERR][Viz.Phylo.Tools.getNodeBranchId] branchId not found"
 594                      Just i  -> i
 595
 596
 597 -- | To get the PhyloGroupId of a PhyloNode
 598 getNodeId :: PhyloNode -> PhyloGroupId
 599 getNodeId n = n ^. pn_id
 600
 601
 602 getNodePeriod :: PhyloNode -> (Date,Date)
 603 getNodePeriod n = fst $ fst $ getNodeId n
 604
 605
 606 -- | To get the Level of a PhyloNode
 607 getNodeLevel :: PhyloNode -> Level
 608 getNodeLevel n = (snd . fst) $ getNodeId n
 609
 610
 611 -- | To get the Parent Node of a PhyloNode in a PhyloView
 612 getNodeParent :: PhyloNode -> PhyloView -> [PhyloNode]
 613 getNodeParent n v = filter (\n' -> elem (getNodeId n') (getNodeParentsId n))
 614                   $ v ^. pv_nodes
 615
 616
 617 -- | To get the Parent Node id of a PhyloNode if it exists
 618 getNodeParentsId :: PhyloNode -> [PhyloGroupId]
 619 getNodeParentsId n = case n ^. pn_parents of
 620                     Nothing  -> panic "[ERR][Viz.Phylo.Tools.getNodeParentsId] node parent not found"
 621                     Just ids -> ids
 622
 623
 624 -- | To get a list of PhyloNodes grouped by PhyloBranch in a PhyloView
 625 getNodesByBranches :: PhyloView -> [(PhyloBranchId,[PhyloNode])]
 626 getNodesByBranches v = zip bIds $ map (\id -> filter (\n -> (getNodeBranchId n) == id)
 627                                             $ getNodesInBranches v ) bIds
 628   where
 629     --------------------------------------
 630     bIds :: [PhyloBranchId]
 631     bIds = getViewBranchIds v
 632     --------------------------------------
 633
 634
 635 -- | To get a list of PhyloNodes owned by any PhyloBranches in a PhyloView
 636 getNodesInBranches :: PhyloView -> [PhyloNode]
 637 getNodesInBranches v = filter (\n -> isJust $ n ^. pn_bid)
 638                      $ v ^. pv_nodes
 639
 640
 641 -- | To get the PhyloGroupId of the Source of a PhyloEdge
 642 getSourceId :: PhyloEdge -> PhyloGroupId
 643 getSourceId e = e ^. pe_source
 644
 645
 646 -- | To get the PhyloGroupId of the Target of a PhyloEdge
 647 getTargetId :: PhyloEdge -> PhyloGroupId
 648 getTargetId e = e ^. pe_target
 649
 650
 651 ---------------------
 652 -- | PhyloBranch | --
 653 ---------------------
 654
 655
 656 -- | To get the PhyloBranchId of a PhyloBranch
 657 getBranchId :: PhyloBranch -> PhyloBranchId
 658 getBranchId b = b ^. pb_id
 659
 660 -- | To get a list of PhyloBranchIds
 661 getBranchIds :: Phylo -> [PhyloBranchId]
 662 getBranchIds p = sortOn snd
 663                $ nub
 664                $ mapMaybe getGroupBranchId
 665                $ getGroups p
 666
 667
 668 -- | To get a list of PhyloBranchIds given a Level in a Phylo
 669 getBranchIdsWith :: Level -> Phylo -> [PhyloBranchId]
 670 getBranchIdsWith lvl p = sortOn snd
 671                        $ mapMaybe getGroupBranchId
 672                        $ getGroupsWithLevel lvl p
 673
 674
 675 -- | To get the Meta value of a PhyloBranch
 676 getBranchMeta :: Text -> PhyloBranch -> [Double]
 677 getBranchMeta k b = (b ^. pb_metrics) ! k
 678
 679
 680 -- | To get all the PhyloBranchIds of a PhyloView
 681 getViewBranchIds :: PhyloView -> [PhyloBranchId]
 682 getViewBranchIds v = map getBranchId $ v ^. pv_branches
 683
 684
 685 -- | To get a list of PhyloGroup sharing the same PhyloBranchId
 686 getGroupsByBranches :: Phylo -> [(PhyloBranchId,[PhyloGroup])]
 687 getGroupsByBranches p = zip (getBranchIds p)
 688                       $ map (\id -> filter (\g -> (fromJust $ getGroupBranchId g) == id)
 689                                     $ getGroupsInBranches p)
 690                       $ getBranchIds p
 691
 692
 693 -- | To get the sublist of all the PhyloGroups linked to a branch
 694 getGroupsInBranches :: Phylo -> [PhyloGroup]
 695 getGroupsInBranches p = filter (\g -> isJust $ g ^. phylo_groupBranchId)
 696                       $ getGroups p
 697
 698
 699 --------------------------------
 700 -- | PhyloQuery & QueryView | --
 701 --------------------------------
 702
 703
 704 -- | To filter PhyloView's Branches by level
 705 filterBranchesByLevel :: Level -> PhyloView -> [PhyloBranch]
 706 filterBranchesByLevel lvl pv = filter (\pb -> lvl == (fst $ pb ^. pb_id))
 707                           $ pv ^. pv_branches
 708
 709
 710 -- | To filter PhyloView's Edges by level
 711 filterEdgesByLevel :: Level -> [PhyloEdge] -> [PhyloEdge]
 712 filterEdgesByLevel lvl pes = filter (\pe -> (lvl == ((snd . fst) $ pe ^. pe_source))
 713                                          && (lvl == ((snd . fst) $ pe ^. pe_target))) pes
 714
 715
 716 -- | To filter PhyloView's Edges by type
 717 filterEdgesByType :: EdgeType -> [PhyloEdge] -> [PhyloEdge]
 718 filterEdgesByType t pes = filter (\pe -> t == (pe ^. pe_type)) pes
 719
 720
 721 -- | To filter PhyloView's Nodes by the oldest Period
 722 filterNodesByFirstPeriod :: [PhyloNode] -> [PhyloNode]
 723 filterNodesByFirstPeriod pns = filter (\pn -> fstPrd == ((fst . fst) $ pn ^. pn_id)) pns
 724     where
 725         --------------------------------------
 726         fstPrd :: (Date,Date)
 727         fstPrd = (head' "filterNodesByFirstPeriod")
 728                $ sortOn fst
 729                $ map (\pn -> (fst . fst) $ pn ^. pn_id) pns
 730         --------------------------------------
 731
 732
 733 -- | To filter PhyloView's Nodes by Branch
 734 filterNodesByBranch :: PhyloBranchId -> [PhyloNode] -> [PhyloNode]
 735 filterNodesByBranch bId pns = filter (\pn -> if isJust $ pn ^. pn_bid
 736                                              then if bId == (fromJust $ pn ^. pn_bid)
 737                                                   then True
 738                                                   else False
 739                                              else False ) pns
 740
 741
 742 -- | To filter PhyloView's Nodes by level
 743 filterNodesByLevel :: Level -> [PhyloNode] -> [PhyloNode]
 744 filterNodesByLevel lvl pns = filter (\pn -> lvl == ((snd . fst) $ pn ^. pn_id)) pns
 745
 746
 747 -- | To filter PhyloView's Nodes by Period
 748 filterNodesByPeriod :: PhyloPeriodId -> [PhyloNode] -> [PhyloNode]
 749 filterNodesByPeriod prd pns = filter (\pn -> prd == ((fst . fst) $ pn ^. pn_id)) pns
 750
 751
 752 -- | To get the first clustering method to apply to get the contextual units of a Phylo
 753 getContextualUnit :: PhyloQueryBuild -> Cluster
 754 getContextualUnit q = q ^. q_contextualUnit
 755
 756
 757 -- | To get the metrics to apply to contextual units
 758 getContextualUnitMetrics :: PhyloQueryBuild -> [Metric]
 759 getContextualUnitMetrics q = q ^. q_contextualUnitMetrics
 760
 761
 762 -- | To get the filters to apply to contextual units
 763 getContextualUnitFilters :: PhyloQueryBuild -> [Filter]
 764 getContextualUnitFilters q = q ^. q_contextualUnitFilters
 765
 766
 767 -- | To get the cluster methods to apply to the Nths levels of a Phylo
 768 getNthCluster :: PhyloQueryBuild -> Cluster
 769 getNthCluster q = q ^. q_nthCluster
 770
 771
 772 -- | To get the Sup Level of a reconstruction of a Phylo from a PhyloQuery
 773 getNthLevel :: PhyloQueryBuild -> Level
 774 getNthLevel q = q ^. q_nthLevel
 775
 776
 777 -- | To get the Grain of the PhyloPeriods from a PhyloQuery
 778 getPeriodGrain :: PhyloQueryBuild -> Int
 779 getPeriodGrain q = q ^. q_periodGrain
 780
 781
 782 -- | To get the intertemporal matching strategy to apply to a Phylo from a PhyloQuery
 783 getInterTemporalMatching :: PhyloQueryBuild -> Proximity
 784 getInterTemporalMatching q = q ^. q_interTemporalMatching
 785
 786
 787 -- | To get the Steps of the PhyloPeriods from a PhyloQuery
 788 getPeriodSteps :: PhyloQueryBuild -> Int
 789 getPeriodSteps q = q ^. q_periodSteps
 790
 791
 792 --------------------------------------------------
 793 -- | PhyloQueryBuild & PhyloQueryView Constructors | --
 794 --------------------------------------------------
 795
 796 -- | To get the threshold of a Proximity
 797 getThreshold :: Proximity -> Double
 798 getThreshold prox = case prox of
 799   WeightedLogJaccard (WLJParams thr _) -> thr
 800   Hamming (HammingParams thr)          -> thr
 801   Filiation                            -> panic "[ERR][Viz.Phylo.Tools.getThreshold] Filiation"
 802
 803
 804 -- | To get the Proximity associated to a given Clustering method
 805 getProximity :: Cluster -> Proximity
 806 getProximity cluster = case cluster of
 807   Louvain (LouvainParams proxi)      -> proxi
 808   RelatedComponents (RCParams proxi) -> proxi
 809   _   -> panic "[ERR][Viz.Phylo.Tools.getProximity] this cluster has no associated Proximity"
 810
 811
 812 -- | To initialize all the Cluster / Proximity with their default parameters
 813 initFis :: Maybe Bool -> Maybe Support -> Maybe Int -> FisParams
 814 initFis (def True -> kmf) (def 0 -> min') (def 0 -> thr) = FisParams kmf min' thr
 815
 816 initHamming :: Maybe Double -> HammingParams
 817 initHamming (def 0.01 -> sens) = HammingParams sens
 818
 819 initLonelyBranch :: Maybe Int -> Maybe Int -> Maybe Int -> LBParams
 820 initLonelyBranch (def 2 -> periodsInf) (def 2 -> periodsSup) (def 1 -> minNodes) = LBParams periodsInf periodsSup minNodes
 821
 822 initSizeBranch :: Maybe Int -> SBParams
 823 initSizeBranch (def 1 -> minSize) = SBParams minSize
 824
 825 initLonelyBranch' :: Maybe Int -> Maybe Int -> Maybe Int -> LBParams
 826 initLonelyBranch' (def 0 -> periodsInf) (def 0 -> periodsSup) (def 1 -> minNodes) = LBParams periodsInf periodsSup minNodes
 827
 828 initLouvain :: Maybe Proximity -> LouvainParams
 829 initLouvain (def defaultWeightedLogJaccard -> proxi) = LouvainParams proxi
 830
 831 initRelatedComponents :: Maybe Proximity -> RCParams
 832 initRelatedComponents (def defaultWeightedLogJaccard -> proxi) = RCParams proxi
 833
 834 -- | TODO user param in main function
 835 initWeightedLogJaccard :: Maybe Double -> Maybe Double -> WLJParams
 836 initWeightedLogJaccard (def 0.3 -> thr) (def 20.0 -> sens) = WLJParams thr sens
 837
 838
 839 -- | To initialize a PhyloQueryBuild from given and default parameters
 840 initPhyloQueryBuild :: Text          -> Text            -> Maybe Int
 841                     -> Maybe Int     -> Maybe Cluster   -> Maybe [Metric]
 842                     -> Maybe [Filter]-> Maybe Proximity -> Maybe Int
 843                     -> Maybe Double  -> Maybe Double    -> Maybe Int
 844                     -> Maybe Level   -> Maybe Cluster   -> PhyloQueryBuild
 845 initPhyloQueryBuild name desc (def 5 -> grain)
 846                     (def 1 -> steps)      (def defaultFis -> cluster) (def [] -> metrics)
 847                     (def [] -> filters)   (def defaultWeightedLogJaccard -> matching') (def 5 -> frame)
 848                     (def 0.8 -> frameThr) (def 0.5 -> reBranchThr) (def 4 -> reBranchNth)
 849                     (def 2 -> nthLevel)   (def defaultRelatedComponents -> nthCluster) =
 850     PhyloQueryBuild name  desc    grain
 851                     steps cluster metrics filters matching' frame frameThr reBranchThr reBranchNth nthLevel nthCluster
 852
 853
 854 -- | To initialize a PhyloQueryView default parameters
 855 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
 856 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) =
 857   PhyloQueryView lvl f c d ms fs ts s em dm v
 858
 859
 860 -- | To define some obvious boolean getters
 861 shouldKeepMinorFis :: FisParams -> Bool
 862 shouldKeepMinorFis = _fis_keepMinorFis
 863
 864 ----------------------------
 865 -- | Default ressources | --
 866 ----------------------------
 867
 868 -- Clusters
 869
 870 defaultFis :: Cluster
 871 defaultFis = Fis (initFis Nothing Nothing Nothing)
 872
 873 defaultLouvain :: Cluster
 874 defaultLouvain = Louvain (initLouvain Nothing)
 875
 876 defaultRelatedComponents :: Cluster
 877 defaultRelatedComponents = RelatedComponents (initRelatedComponents Nothing)
 878
 879 -- Filters
 880
 881 defaultLonelyBranch :: Filter
 882 defaultLonelyBranch = LonelyBranch (initLonelyBranch Nothing Nothing Nothing)
 883
 884 defaultSizeBranch :: Filter
 885 defaultSizeBranch = SizeBranch (initSizeBranch Nothing)
 886
 887 -- Params
 888
 889 defaultPhyloParam :: PhyloParam
 890 defaultPhyloParam = initPhyloParam Nothing Nothing Nothing
 891
 892 -- Proximities
 893
 894 defaultHamming :: Proximity
 895 defaultHamming = Hamming (initHamming Nothing)
 896
 897 defaultWeightedLogJaccard :: Proximity
 898 defaultWeightedLogJaccard = WeightedLogJaccard (initWeightedLogJaccard Nothing Nothing)
 899
 900 -- Queries
 901 type Title = Text
 902 type Desc  = Text
 903
 904 defaultQueryBuild :: PhyloQueryBuild
 905 defaultQueryBuild = defaultQueryBuild'
 906   "Cesar et Cleôpatre"
 907   "An example of Phylomemy (french without accent)"
 908
 909 defaultQueryBuild' :: Title -> Desc -> PhyloQueryBuild
 910 defaultQueryBuild' t d = initPhyloQueryBuild t d
 911                               Nothing Nothing Nothing
 912                               Nothing Nothing Nothing
 913                               Nothing Nothing Nothing
 914                               Nothing Nothing Nothing
 915
 916 defaultQueryView :: PhyloQueryView
 917 defaultQueryView = initPhyloQueryView
 918     Nothing Nothing Nothing
 919     Nothing Nothing Nothing
 920     Nothing Nothing Nothing
 921     Nothing Nothing
 922
 923 -- Software
 924
 925 defaultSoftware :: Software
 926 defaultSoftware = Software "Gargantext" "v4"
 927
 928 -- Version
 929
 930 defaultPhyloVersion :: Text
 931 defaultPhyloVersion = "v1"
 932