src/Gargantext/Viz/Phylo/LinkMaker.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 NoImplicitPrelude #-}
  14 {-# LANGUAGE FlexibleContexts  #-}
  15 {-# LANGUAGE OverloadedStrings #-}
  16
  17 module Gargantext.Viz.Phylo.LinkMaker
  18   where
  19
  20 import Control.Lens                 hiding (both, Level)
  21 import Data.List                    ((++), nub, sortOn, head, null, tail, splitAt, elem)
  22 import Data.Tuple.Extra
  23 import Gargantext.Prelude           hiding (head)
  24 import Gargantext.Viz.Phylo
  25 import Gargantext.Viz.Phylo.Tools
  26 import Gargantext.Viz.Phylo.Metrics.Proximity
  27 import qualified Data.List  as List
  28 import qualified Data.Maybe as Maybe
  29
  30
  31 ------------------------------------------------------------------------
  32 -- | Make links from Level to Level
  33
  34
  35 -- | To choose a LevelLink strategy based an a given Level
  36 shouldLink :: (Level,Level) -> PhyloGroup -> PhyloGroup -> Bool
  37 shouldLink (lvl,_lvl) g g'
  38   | lvl <= 1  = doesContainsOrd (getGroupNgrams g) (getGroupNgrams g')
  39   | lvl >  1  = elem (getGroupId g) (getGroupLevelChildsId g')
  40   | otherwise = panic ("[ERR][Viz.Phylo.LinkMaker.shouldLink] Level not defined")
  41
  42
  43 -- | To set the LevelLinks between a given PhyloGroup and a list of childs/parents PhyloGroups
  44 linkGroupToGroups :: (Level,Level) -> PhyloGroup -> [PhyloGroup] -> PhyloGroup
  45 linkGroupToGroups (lvl,lvl') current targets
  46   | lvl < lvl' = setLevelParents current
  47   | lvl > lvl' = setLevelChilds current
  48   | otherwise = current
  49   where
  50     --------------------------------------
  51     setLevelChilds :: PhyloGroup -> PhyloGroup
  52     setLevelChilds =  over (phylo_groupLevelChilds) addPointers
  53     --------------------------------------
  54     setLevelParents :: PhyloGroup -> PhyloGroup
  55     setLevelParents =  over (phylo_groupLevelParents) addPointers
  56     --------------------------------------
  57     addPointers :: [Pointer] -> [Pointer]
  58     addPointers lp = lp ++ Maybe.mapMaybe (\target ->
  59                                             if shouldLink (lvl,lvl') current target
  60                                             then Just ((getGroupId target),1)
  61                                             else Nothing) targets
  62     --------------------------------------
  63
  64
  65 -- | To set the LevelLinks between two lists of PhyloGroups
  66 linkGroupsByLevel :: (Level,Level) -> Phylo -> [PhyloGroup] -> [PhyloGroup]
  67 linkGroupsByLevel (lvl,lvl') p groups  = map (\group ->
  68                                               if getGroupLevel group == lvl
  69                                               then linkGroupToGroups (lvl,lvl') group (getGroupsWithFilters lvl' (getGroupPeriod group) p)
  70                                               else group) groups
  71
  72
  73 -- | To set the LevelLink of all the PhyloGroups of a Phylo
  74 setLevelLinks :: (Level,Level) -> Phylo -> Phylo
  75 setLevelLinks (lvl,lvl') p = alterPhyloGroups (linkGroupsByLevel (lvl,lvl') p) p
  76
  77
  78 ------------------------------------------------------------------------
  79 -- | Make links from Period to Period
  80
  81
  82 -- | To apply the corresponding proximity function based on a given Proximity
  83 applyProximity :: Proximity -> PhyloGroup -> PhyloGroup -> (PhyloGroupId, Double)
  84 applyProximity prox g1 g2 = case prox of
  85   WeightedLogJaccard (WLJParams _ s) -> ((getGroupId g2),weightedLogJaccard s (getGroupCooc g1) (unifySharedKeys (getGroupCooc g2) (getGroupCooc g1)))
  86   Hamming (HammingParams _)          -> ((getGroupId g2),hamming (getGroupCooc g1) (unifySharedKeys (getGroupCooc g2) (getGroupCooc g1)))
  87   _                                  -> panic ("[ERR][Viz.Phylo.Example.applyProximity] Proximity function not defined")
  88
  89
  90 -- | To get the next or previous PhyloPeriod based on a given PhyloPeriodId
  91 getNextPeriods :: Filiation -> PhyloPeriodId -> [PhyloPeriodId] -> [PhyloPeriodId]
  92 getNextPeriods to' id l = case to' of
  93     Descendant -> unNested id ((tail . snd) next)
  94     Ascendant  -> unNested id ((reverse . fst) next)
  95     _          -> panic ("[ERR][Viz.Phylo.Example.getNextPeriods] Filiation type not defined")
  96     where
  97       --------------------------------------
  98       next :: ([PhyloPeriodId], [PhyloPeriodId])
  99       next = splitAt idx l
 100       --------------------------------------
 101       idx :: Int
 102       idx = case (List.elemIndex id l) of
 103         Nothing -> panic ("[ERR][Viz.Phylo.Example.getNextPeriods] PhyloPeriodId not defined")
 104         Just i  -> i
 105       --------------------------------------
 106       -- | To have an non-overlapping next period
 107       unNested :: PhyloPeriodId -> [PhyloPeriodId] -> [PhyloPeriodId]
 108       unNested x l'
 109         | null l'                  = []
 110         | nested (fst $ head l') x = unNested x (tail l')
 111         | nested (snd $ head l') x = unNested x (tail l')
 112         | otherwise                = l
 113       --------------------------------------
 114       nested :: Date -> PhyloPeriodId -> Bool
 115       nested d prd = d >= fst prd && d <= snd prd
 116       --------------------------------------
 117
 118
 119 -- | To find the best set (max = 2) of Childs/Parents candidates based on a given Proximity mesure until a maximum depth (max = Period + 5 units )
 120 findBestCandidates :: Filiation -> Int -> Int -> Proximity -> PhyloGroup -> Phylo -> [(PhyloGroupId, Double)]
 121 findBestCandidates to' depth max' prox group p
 122   | depth > max' || null next = []
 123   | (not . null) best = take 2 best
 124   | otherwise = findBestCandidates to' (depth + 1) max' prox group p
 125   where
 126     --------------------------------------
 127     next :: [PhyloPeriodId]
 128     next = getNextPeriods to' (getGroupPeriod group) (getPhyloPeriods p)
 129     --------------------------------------
 130     candidates :: [PhyloGroup]
 131     candidates = getGroupsWithFilters (getGroupLevel group) (head next) p
 132     --------------------------------------
 133     scores :: [(PhyloGroupId, Double)]
 134     scores = map (\group' -> applyProximity prox group group') candidates
 135     --------------------------------------
 136     best :: [(PhyloGroupId, Double)]
 137     best = reverse
 138          $ sortOn snd
 139          $ filter (\(_id,score) -> case prox of
 140             WeightedLogJaccard (WLJParams thr _) -> score >= thr
 141             Hamming (HammingParams thr)          -> score <= thr
 142             Filiation                            -> panic "[ERR][Viz.Phylo.LinkMaker.findBestCandidates] Filiation"
 143             ) scores
 144     --------------------------------------
 145
 146
 147 -- | To add a new list of Pointers into an existing Childs/Parents list of Pointers
 148 makePair :: Filiation -> PhyloGroup -> [(PhyloGroupId, Double)] -> PhyloGroup
 149 makePair to' group ids = case to' of
 150     Descendant  -> over (phylo_groupPeriodChilds) addPointers group
 151     Ascendant   -> over (phylo_groupPeriodParents) addPointers group
 152     _           -> panic ("[ERR][Viz.Phylo.Example.makePair] Filiation type not defined")
 153     where
 154       --------------------------------------
 155       addPointers :: [Pointer] -> [Pointer]
 156       addPointers l = nub $ (l ++ ids)
 157       --------------------------------------
 158
 159
 160 -- | To pair all the Phylogroups of given PhyloLevel to their best Parents or Childs
 161 interTempoMatching :: Filiation -> Level -> Proximity -> Phylo -> Phylo
 162 interTempoMatching to' lvl prox p = alterPhyloGroups
 163                                     (\groups ->
 164                                       map (\group ->
 165                                             if (getGroupLevel group) == lvl
 166                                             then
 167                                               let
 168                                                 --------------------------------------
 169                                                 candidates :: [(PhyloGroupId, Double)]
 170                                                 candidates = findBestCandidates to' 1 5 prox group p
 171                                                 --------------------------------------
 172                                               in
 173                                                 makePair to' group candidates
 174                                             else
 175                                               group ) groups) p