src/Gargantext/Core/Viz/Phylo/Tools.hs

   1 {-|
   2 Module      : Gargantext.Core.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.Core.Viz.Phylo.Tools
  16   where
  17
  18 import Control.Lens         hiding (both, Level, Empty)
  19 import Data.List            (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.Core.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 -- | To get all combinations of a list and apply a function to the resulting list of pairs
 116 listToDirectedCombiWith :: Eq a => forall b. (a -> b) -> [a] -> [(b,b)]
 117 listToDirectedCombiWith f l = [(f x,f y) | x <- l, y <- l, x /= y]
 118
 119
 120 -- | To get the sequential combinations of an order list
 121 listToSequentialCombi :: Eq a => [a] -> [(a,a)]
 122 listToSequentialCombi l = nubBy (\x y -> fst x == fst y) $ listToUnDirectedCombi l
 123
 124
 125 -- | To get all combinations of a list with no repetition
 126 listToUnDirectedCombi :: [a] -> [(a,a)]
 127 listToUnDirectedCombi l = [ (x,y) | (x:rest) <- tails l,  y <- rest ]
 128
 129
 130 -- | To get all combinations of a list with no repetition and apply a function to the resulting list of pairs
 131 listToUnDirectedCombiWith :: forall a b. (a -> b) -> [a] -> [(b,b)]
 132 listToUnDirectedCombiWith f l = [ (f x, f y) | (x:rest) <- tails l,  y <- rest ]
 133
 134
 135 -- | To transform a list of Ngrams Indexes into a Label
 136 ngramsToLabel :: Vector Ngrams -> [Int] -> Text
 137 ngramsToLabel ngrams l = unwords $ tail' "ngramsToLabel" $ concat $ map (\n -> ["|",n]) $ ngramsToText ngrams l
 138
 139
 140 -- | To transform a list of Ngrams Indexes into a list of Text
 141 ngramsToText :: Vector Ngrams -> [Int] -> [Text]
 142 ngramsToText ngrams l = map (\idx -> ngrams Vector.! idx) l
 143
 144
 145 -- | To transform a list of ngrams into a list of indexes
 146 ngramsToIdx :: [Ngrams] -> Vector Ngrams -> [Int]
 147 ngramsToIdx ns v = sort $ map (\n -> getIdxInVector n v) ns
 148
 149
 150 -- | To unify the keys (x,y) that Map 1 share with Map 2 such as: (x,y) <=> (y,x)
 151 unifySharedKeys :: Eq a => Ord a => Map (a,a) b -> Map (a,a) b -> Map (a,a) b
 152 unifySharedKeys m1 m2 = mapKeys (\(x,y) -> if member (y,x) m2
 153                                            then (y,x)
 154                                            else (x,y) ) m1
 155
 156
 157 ---------------
 158 -- | Phylo | --
 159 ---------------
 160
 161 -- | An analyzer ingests a Ngrams and generates a modified version of it
 162 phyloAnalyzer :: Ngrams -> Ngrams
 163 phyloAnalyzer n = toLower n
 164
 165 -- | To init the foundation roots of the Phylo as a Vector of Ngrams
 166 initFoundationsRoots :: [Ngrams] -> Vector Ngrams
 167 initFoundationsRoots l = Vector.fromList $ map phyloAnalyzer l
 168
 169 -- | To init the base of a Phylo from a List of Periods and Foundations
 170 initPhyloBase :: [(Date, Date)] -> PhyloFoundations -> Map Date Double  -> Map Date (Map (Int,Int) Double) -> Map (Date,Date) [PhyloFis] -> PhyloParam -> Phylo
 171 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
 172
 173 -- | To init the param of a Phylo
 174 initPhyloParam :: Maybe Text -> Maybe Software -> Maybe PhyloQueryBuild -> PhyloParam
 175 initPhyloParam (def defaultPhyloVersion -> v) (def defaultSoftware -> s) (def defaultQueryBuild -> q) = PhyloParam v s q
 176
 177 -- | To get the last computed Level in a Phylo
 178 getLastLevel :: Phylo -> Level
 179 getLastLevel p = (last . sort)
 180                $ map (snd . getPhyloLevelId)
 181                $ view ( phylo_periods
 182                       .  traverse
 183                       . phylo_periodLevels ) p
 184
 185 -- | To get all the coocurency matrix of a phylo
 186 getPhyloCooc :: Phylo -> Map Date (Map (Int,Int) Double)
 187 getPhyloCooc p = p ^. phylo_cooc
 188
 189
 190 -- | To get the PhyloParam of a Phylo
 191 getPhyloParams :: Phylo -> PhyloParam
 192 getPhyloParams = _phylo_param
 193
 194 -- | To get the title of a Phylo
 195 getPhyloTitle :: Phylo -> Text
 196 getPhyloTitle p = _q_phyloTitle $ _phyloParam_query $ getPhyloParams p
 197
 198 -- | To get the desc of a Phylo
 199 getPhyloDescription :: Phylo -> Text
 200 getPhyloDescription p = _q_phyloTitle $ _phyloParam_query $ getPhyloParams p
 201
 202 getPhyloMatchingFrame :: Phylo -> Int
 203 getPhyloMatchingFrame p = _q_interTemporalMatchingFrame $ _phyloParam_query $ getPhyloParams p
 204
 205 getPhyloMatchingFrameTh :: Phylo -> Double
 206 getPhyloMatchingFrameTh p = _q_interTemporalMatchingFrameTh $ _phyloParam_query $ getPhyloParams p
 207
 208 getPhyloProximity :: Phylo -> Proximity
 209 getPhyloProximity p = _q_interTemporalMatching $ _phyloParam_query $ getPhyloParams p
 210
 211 getPhyloReBranchThr :: Phylo -> Double
 212 getPhyloReBranchThr p = _q_reBranchThr $ _phyloParam_query $ getPhyloParams p
 213
 214 getPhyloReBranchNth :: Phylo -> Int
 215 getPhyloReBranchNth p = _q_reBranchNth $ _phyloParam_query $ getPhyloParams p
 216
 217 getPhyloFis :: Phylo -> Map (Date,Date) [PhyloFis]
 218 getPhyloFis = _phylo_fis
 219
 220
 221 --------------------
 222 -- | PhyloRoots | --
 223 --------------------
 224
 225 -- | To get the foundations of a Phylo
 226 getFoundations :: Phylo -> PhyloFoundations
 227 getFoundations = _phylo_foundations
 228
 229 -- | To get the foundations roots of a Phylo
 230 getFoundationsRoots :: Phylo -> Vector Ngrams
 231 getFoundationsRoots p = (getFoundations p) ^. phylo_foundationsRoots
 232
 233 -- | To get the Index of a Ngrams in the foundationsRoots of a Phylo
 234 getIdxInRoots :: Ngrams -> Phylo -> Int
 235 getIdxInRoots n p = case (elemIndex n (getFoundationsRoots p)) of
 236     Nothing  -> panic $ "[ERR][Viz.Phylo.Tools.getIdxInRoots] Ngrams not in foundationsRoots: " <> cs n
 237     Just idx -> idx
 238
 239 getIdxInRoots' :: Ngrams -> Vector Ngrams -> Int
 240 getIdxInRoots' n root = case (elemIndex n root) 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 alter a PhyloNode
 569 alterPhyloNode :: (PhyloNode -> PhyloNode) -> PhyloView -> PhyloView
 570 alterPhyloNode f v = over ( pv_nodes
 571                           .  traverse
 572                           ) (\pn ->  f pn ) v
 573
 574
 575 -- | To filter some GroupEdges with a given threshold
 576 filterGroupEdges :: Double -> [GroupEdge] -> [GroupEdge]
 577 filterGroupEdges thr edges = filter (\((_s,_t),w) -> w > thr) edges
 578
 579
 580 -- | To get the neighbours (directed/undirected) of a PhyloGroup from a list of GroupEdges
 581 getNeighbours :: Bool -> PhyloGroup -> [GroupEdge] -> [PhyloGroup]
 582 getNeighbours directed g e = case directed of
 583   True  -> map (\((_s,t),_w) -> t)
 584              $ filter (\((s,_t),_w) -> s == g) e
 585   False -> map (\((s,t),_w) -> (head' "getNeighbours") $ delete g $ nub [s,t,g])
 586              $ filter (\((s,t),_w) -> s == g || t == g) e
 587
 588
 589 -- | To get the PhyloBranchId of PhyloNode if it exists
 590 getNodeBranchId :: PhyloNode -> PhyloBranchId
 591 getNodeBranchId n = case n ^. pn_bid of
 592                      Nothing -> panic "[ERR][Viz.Phylo.Tools.getNodeBranchId] branchId not found"
 593                      Just i  -> i
 594
 595
 596 -- | To get the PhyloGroupId of a PhyloNode
 597 getNodeId :: PhyloNode -> PhyloGroupId
 598 getNodeId n = n ^. pn_id
 599
 600
 601 getNodePeriod :: PhyloNode -> (Date,Date)
 602 getNodePeriod n = fst $ fst $ getNodeId n
 603
 604
 605 -- | To get the Level of a PhyloNode
 606 getNodeLevel :: PhyloNode -> Level
 607 getNodeLevel n = (snd . fst) $ getNodeId n
 608
 609
 610 -- | To get the Parent Node of a PhyloNode in a PhyloView
 611 getNodeParent :: PhyloNode -> PhyloView -> [PhyloNode]
 612 getNodeParent n v = filter (\n' -> elem (getNodeId n') (getNodeParentsId n))
 613                   $ v ^. pv_nodes
 614
 615
 616 -- | To get the Parent Node id of a PhyloNode if it exists
 617 getNodeParentsId :: PhyloNode -> [PhyloGroupId]
 618 getNodeParentsId n = case n ^. pn_parents of
 619                     Nothing  -> panic "[ERR][Viz.Phylo.Tools.getNodeParentsId] node parent not found"
 620                     Just ids -> ids
 621
 622
 623 -- | To get a list of PhyloNodes grouped by PhyloBranch in a PhyloView
 624 getNodesByBranches :: PhyloView -> [(PhyloBranchId,[PhyloNode])]
 625 getNodesByBranches v = zip bIds $ map (\id -> filter (\n -> (getNodeBranchId n) == id)
 626                                             $ getNodesInBranches v ) bIds
 627   where
 628     --------------------------------------
 629     bIds :: [PhyloBranchId]
 630     bIds = getViewBranchIds v
 631     --------------------------------------
 632
 633
 634 -- | To get a list of PhyloNodes owned by any PhyloBranches in a PhyloView
 635 getNodesInBranches :: PhyloView -> [PhyloNode]
 636 getNodesInBranches v = filter (\n -> isJust $ n ^. pn_bid)
 637                      $ v ^. pv_nodes
 638
 639
 640 -- | To get the PhyloGroupId of the Source of a PhyloEdge
 641 getSourceId :: PhyloEdge -> PhyloGroupId
 642 getSourceId e = e ^. pe_source
 643
 644
 645 -- | To get the PhyloGroupId of the Target of a PhyloEdge
 646 getTargetId :: PhyloEdge -> PhyloGroupId
 647 getTargetId e = e ^. pe_target
 648
 649
 650 ---------------------
 651 -- | PhyloBranch | --
 652 ---------------------
 653
 654
 655 -- | To get the PhyloBranchId of a PhyloBranch
 656 getBranchId :: PhyloBranch -> PhyloBranchId
 657 getBranchId b = b ^. pb_id
 658
 659 -- | To get a list of PhyloBranchIds
 660 getBranchIds :: Phylo -> [PhyloBranchId]
 661 getBranchIds p = sortOn snd
 662                $ nub
 663                $ mapMaybe getGroupBranchId
 664                $ getGroups p
 665
 666
 667 -- | To get a list of PhyloBranchIds given a Level in a Phylo
 668 getBranchIdsWith :: Level -> Phylo -> [PhyloBranchId]
 669 getBranchIdsWith lvl p = sortOn snd
 670                        $ mapMaybe getGroupBranchId
 671                        $ getGroupsWithLevel lvl p
 672
 673
 674 -- | To get the Meta value of a PhyloBranch
 675 getBranchMeta :: Text -> PhyloBranch -> [Double]
 676 getBranchMeta k b = (b ^. pb_metrics) ! k
 677
 678
 679 -- | To get all the PhyloBranchIds of a PhyloView
 680 getViewBranchIds :: PhyloView -> [PhyloBranchId]
 681 getViewBranchIds v = map getBranchId $ v ^. pv_branches
 682
 683
 684 -- | To get a list of PhyloGroup sharing the same PhyloBranchId
 685 getGroupsByBranches :: Phylo -> [(PhyloBranchId,[PhyloGroup])]
 686 getGroupsByBranches p = zip (getBranchIds p)
 687                       $ map (\id -> filter (\g -> (fromJust $ getGroupBranchId g) == id)
 688                                     $ getGroupsInBranches p)
 689                       $ getBranchIds p
 690
 691
 692 -- | To get the sublist of all the PhyloGroups linked to a branch
 693 getGroupsInBranches :: Phylo -> [PhyloGroup]
 694 getGroupsInBranches p = filter (\g -> isJust $ g ^. phylo_groupBranchId)
 695                       $ getGroups p
 696
 697
 698 --------------------------------
 699 -- | PhyloQuery & QueryView | --
 700 --------------------------------
 701
 702
 703 -- | To filter PhyloView's Branches by level
 704 filterBranchesByLevel :: Level -> PhyloView -> [PhyloBranch]
 705 filterBranchesByLevel lvl pv = filter (\pb -> lvl == (fst $ pb ^. pb_id))
 706                           $ pv ^. pv_branches
 707
 708
 709 -- | To filter PhyloView's Edges by level
 710 filterEdgesByLevel :: Level -> [PhyloEdge] -> [PhyloEdge]
 711 filterEdgesByLevel lvl pes = filter (\pe -> (lvl == ((snd . fst) $ pe ^. pe_source))
 712                                          && (lvl == ((snd . fst) $ pe ^. pe_target))) pes
 713
 714
 715 -- | To filter PhyloView's Edges by type
 716 filterEdgesByType :: EdgeType -> [PhyloEdge] -> [PhyloEdge]
 717 filterEdgesByType t pes = filter (\pe -> t == (pe ^. pe_type)) pes
 718
 719
 720 -- | To filter PhyloView's Nodes by the oldest Period
 721 filterNodesByFirstPeriod :: [PhyloNode] -> [PhyloNode]
 722 filterNodesByFirstPeriod pns = filter (\pn -> fstPrd == ((fst . fst) $ pn ^. pn_id)) pns
 723     where
 724         --------------------------------------
 725         fstPrd :: (Date,Date)
 726         fstPrd = (head' "filterNodesByFirstPeriod")
 727                $ sortOn fst
 728                $ map (\pn -> (fst . fst) $ pn ^. pn_id) pns
 729         --------------------------------------
 730
 731
 732 -- | To filter PhyloView's Nodes by Branch
 733 filterNodesByBranch :: PhyloBranchId -> [PhyloNode] -> [PhyloNode]
 734 filterNodesByBranch bId pns = filter (\pn -> if isJust $ pn ^. pn_bid
 735                                              then if bId == (fromJust $ pn ^. pn_bid)
 736                                                   then True
 737                                                   else False
 738                                              else False ) pns
 739
 740
 741 -- | To filter PhyloView's Nodes by level
 742 filterNodesByLevel :: Level -> [PhyloNode] -> [PhyloNode]
 743 filterNodesByLevel lvl pns = filter (\pn -> lvl == ((snd . fst) $ pn ^. pn_id)) pns
 744
 745
 746 -- | To filter PhyloView's Nodes by Period
 747 filterNodesByPeriod :: PhyloPeriodId -> [PhyloNode] -> [PhyloNode]
 748 filterNodesByPeriod prd pns = filter (\pn -> prd == ((fst . fst) $ pn ^. pn_id)) pns
 749
 750
 751 -- | To get the first clustering method to apply to get the contextual units of a Phylo
 752 getContextualUnit :: PhyloQueryBuild -> Cluster
 753 getContextualUnit q = q ^. q_contextualUnit
 754
 755
 756 -- | To get the metrics to apply to contextual units
 757 getContextualUnitMetrics :: PhyloQueryBuild -> [Metric]
 758 getContextualUnitMetrics q = q ^. q_contextualUnitMetrics
 759
 760
 761 -- | To get the filters to apply to contextual units
 762 getContextualUnitFilters :: PhyloQueryBuild -> [Filter]
 763 getContextualUnitFilters q = q ^. q_contextualUnitFilters
 764
 765
 766 -- | To get the cluster methods to apply to the Nths levels of a Phylo
 767 getNthCluster :: PhyloQueryBuild -> Cluster
 768 getNthCluster q = q ^. q_nthCluster
 769
 770
 771 -- | To get the Sup Level of a reconstruction of a Phylo from a PhyloQuery
 772 getNthLevel :: PhyloQueryBuild -> Level
 773 getNthLevel q = q ^. q_nthLevel
 774
 775
 776 -- | To get the Grain of the PhyloPeriods from a PhyloQuery
 777 getPeriodGrain :: PhyloQueryBuild -> Int
 778 getPeriodGrain q = q ^. q_periodGrain
 779
 780
 781 -- | To get the intertemporal matching strategy to apply to a Phylo from a PhyloQuery
 782 getInterTemporalMatching :: PhyloQueryBuild -> Proximity
 783 getInterTemporalMatching q = q ^. q_interTemporalMatching
 784
 785
 786 -- | To get the Steps of the PhyloPeriods from a PhyloQuery
 787 getPeriodSteps :: PhyloQueryBuild -> Int
 788 getPeriodSteps q = q ^. q_periodSteps
 789
 790
 791 --------------------------------------------------
 792 -- | PhyloQueryBuild & PhyloQueryView Constructors | --
 793 --------------------------------------------------
 794
 795 -- | To get the threshold of a Proximity
 796 getThreshold :: Proximity -> Double
 797 getThreshold prox = case prox of
 798   WeightedLogJaccard (WLJParams thr _) -> thr
 799   WeightedLogSim (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 initWeightedLogSim :: Maybe Double -> Maybe Double -> WLJParams
 839 initWeightedLogSim (def 0.3 -> thr) (def 20.0 -> sens) = WLJParams thr sens
 840
 841 -- | To initialize a PhyloQueryBuild from given and default parameters
 842 initPhyloQueryBuild :: Text          -> Text            -> Maybe Int
 843                     -> Maybe Int     -> Maybe Cluster   -> Maybe [Metric]
 844                     -> Maybe [Filter]-> Maybe Proximity -> Maybe Int
 845                     -> Maybe Double  -> Maybe Double    -> Maybe Int
 846                     -> Maybe Level   -> Maybe Cluster   -> PhyloQueryBuild
 847 initPhyloQueryBuild name desc (def 5 -> grain)
 848                     (def 1 -> steps)      (def defaultFis -> cluster) (def [] -> metrics)
 849                     (def [] -> filters)   (def defaultWeightedLogJaccard -> matching') (def 5 -> frame)
 850                     (def 0.8 -> frameThr) (def 0.5 -> reBranchThr) (def 4 -> reBranchNth)
 851                     (def 2 -> nthLevel)   (def defaultRelatedComponents -> nthCluster) =
 852     PhyloQueryBuild name  desc    grain
 853                     steps cluster metrics filters matching' frame frameThr reBranchThr reBranchNth nthLevel nthCluster
 854
 855
 856 -- | To initialize a PhyloQueryView default parameters
 857 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
 858 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) =
 859   PhyloQueryView lvl f c d ms fs ts s em dm v
 860
 861
 862 -- | To define some obvious boolean getters
 863 shouldKeepMinorFis :: FisParams -> Bool
 864 shouldKeepMinorFis = _fis_keepMinorFis
 865
 866 ----------------------------
 867 -- | Default ressources | --
 868 ----------------------------
 869
 870 -- Clusters
 871
 872 defaultFis :: Cluster
 873 defaultFis = Fis (initFis Nothing Nothing Nothing)
 874
 875 defaultLouvain :: Cluster
 876 defaultLouvain = Louvain (initLouvain Nothing)
 877
 878 defaultRelatedComponents :: Cluster
 879 defaultRelatedComponents = RelatedComponents (initRelatedComponents Nothing)
 880
 881 -- Filters
 882
 883 defaultLonelyBranch :: Filter
 884 defaultLonelyBranch = LonelyBranch (initLonelyBranch Nothing Nothing Nothing)
 885
 886 defaultSizeBranch :: Filter
 887 defaultSizeBranch = SizeBranch (initSizeBranch Nothing)
 888
 889 -- Params
 890
 891 defaultPhyloParam :: PhyloParam
 892 defaultPhyloParam = initPhyloParam Nothing Nothing Nothing
 893
 894 -- Proximities
 895
 896 defaultHamming :: Proximity
 897 defaultHamming = Hamming (initHamming Nothing)
 898
 899 defaultWeightedLogJaccard :: Proximity
 900 defaultWeightedLogJaccard = WeightedLogJaccard (initWeightedLogJaccard Nothing Nothing)
 901
 902 defaultWeightedLogSim :: Proximity
 903 defaultWeightedLogSim = WeightedLogSim (initWeightedLogSim Nothing Nothing)
 904
 905 -- Queries
 906 type Title = Text
 907 type Desc  = Text
 908
 909 defaultQueryBuild :: PhyloQueryBuild
 910 defaultQueryBuild = defaultQueryBuild'
 911   "Cesar et Cleôpatre"
 912   "An example of Phylomemy (french without accent)"
 913
 914 defaultQueryBuild' :: Title -> Desc -> PhyloQueryBuild
 915 defaultQueryBuild' t d = initPhyloQueryBuild t d
 916                               Nothing Nothing Nothing
 917                               Nothing Nothing Nothing
 918                               Nothing Nothing Nothing
 919                               Nothing Nothing Nothing
 920
 921 defaultQueryView :: PhyloQueryView
 922 defaultQueryView = initPhyloQueryView
 923     Nothing Nothing Nothing
 924     Nothing Nothing Nothing
 925     Nothing Nothing Nothing
 926     Nothing Nothing
 927
 928 -- Software
 929
 930 defaultSoftware :: Software
 931 defaultSoftware = Software "Gargantext" "v4"
 932
 933 -- Version
 934
 935 defaultPhyloVersion :: Text
 936 defaultPhyloVersion = "v1"
 937