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, null, tail, splitAt, elem)
  22 import Data.Tuple.Extra
  23 import Gargantext.Prelude
  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' "getNextPeriods1" l') x = unNested x (tail l')
 111         | nested (snd $ head' "getNextPeriods2" 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' "findBestCandidates" 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