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                    ((++), sortOn, null, tail, splitAt, elem, concat, sort, delete)
  22 import Data.Tuple.Extra
  23 import Data.Map                     (Map,(!))
  24 import Gargantext.Prelude
  25 import Gargantext.Viz.Phylo
  26 import Gargantext.Viz.Phylo.Tools
  27 import Gargantext.Viz.Phylo.Metrics.Proximity
  28 import qualified Data.List  as List
  29 import qualified Data.Maybe as Maybe
  30 import qualified Data.Map as Map
  31
  32 import qualified Data.Vector.Storable as VS
  33 import Debug.Trace (trace)
  34 import Numeric.Statistics (percentile)
  35
  36
  37 ------------------------------------------------------------------------
  38 -- | Make links from Level to Level
  39
  40
  41 -- | To choose a LevelLink strategy based an a given Level
  42 shouldLink :: (Level,Level) -> PhyloGroup -> PhyloGroup -> Bool
  43 shouldLink (lvl,_lvl) g g'
  44   | lvl <= 1  = doesContainsOrd (getGroupNgrams g) (getGroupNgrams g')
  45   | lvl >  1  = elem (getGroupId g) (getGroupLevelChildsId g')
  46   | otherwise = panic ("[ERR][Viz.Phylo.LinkMaker.shouldLink] Level not defined")
  47
  48
  49 -- | To set the LevelLinks between a given PhyloGroup and a list of childs/parents PhyloGroups
  50 linkGroupToGroups :: (Level,Level) -> PhyloGroup -> [PhyloGroup] -> PhyloGroup
  51 linkGroupToGroups (lvl,lvl') current targets
  52   | lvl < lvl' = setLevelParents current
  53   | lvl > lvl' = setLevelChilds current
  54   | otherwise = current
  55   where
  56     --------------------------------------
  57     setLevelChilds :: PhyloGroup -> PhyloGroup
  58     setLevelChilds =  over (phylo_groupLevelChilds) addPointers
  59     --------------------------------------
  60     setLevelParents :: PhyloGroup -> PhyloGroup
  61     setLevelParents =  over (phylo_groupLevelParents) addPointers
  62     --------------------------------------
  63     addPointers :: [Pointer] -> [Pointer]
  64     addPointers lp = lp ++ Maybe.mapMaybe (\target ->
  65                                             if shouldLink (lvl,lvl') current target
  66                                             then Just ((getGroupId target),1)
  67                                             else Nothing) targets
  68     --------------------------------------
  69
  70
  71 -- | To set the LevelLinks between two lists of PhyloGroups
  72 linkGroupsByLevel :: (Level,Level) -> Phylo -> [PhyloGroup] -> [PhyloGroup]
  73 linkGroupsByLevel (lvl,lvl') p groups  = map (\group ->
  74                                               if getGroupLevel group == lvl
  75                                               then linkGroupToGroups (lvl,lvl') group (getGroupsWithFilters lvl' (getGroupPeriod group) p)
  76                                               else group) groups
  77
  78
  79 -- | To set the LevelLink of all the PhyloGroups of a Phylo
  80 setLevelLinks :: (Level,Level) -> Phylo -> Phylo
  81 setLevelLinks (lvl,lvl') p = alterPhyloGroups (linkGroupsByLevel (lvl,lvl') p) p
  82
  83
  84 ------------------------------------------------------------------------
  85 -- | Make links from Period to Period
  86
  87
  88 -- | To apply the corresponding proximity function based on a given Proximity
  89 applyProximity :: Proximity -> PhyloGroup -> PhyloGroup -> (PhyloGroupId, Double)
  90 applyProximity prox g1 g2 = case prox of
  91   WeightedLogJaccard (WLJParams _ s) -> ((getGroupId g2),weightedLogJaccard s (getGroupCooc g1) (unifySharedKeys (getGroupCooc g2) (getGroupCooc g1)))
  92   Hamming (HammingParams _)          -> ((getGroupId g2),hamming (getGroupCooc g1) (unifySharedKeys (getGroupCooc g2) (getGroupCooc g1)))
  93   _                                  -> panic ("[ERR][Viz.Phylo.Example.applyProximity] Proximity function not defined")
  94
  95
  96 -- | To get the next or previous PhyloPeriod based on a given PhyloPeriodId
  97 getNextPeriods :: Filiation -> PhyloPeriodId -> [PhyloPeriodId] -> [PhyloPeriodId]
  98 getNextPeriods to' id l = case to' of
  99     Descendant -> (tail . snd) next
 100     Ascendant  -> (reverse . fst) next
 101     _          -> panic ("[ERR][Viz.Phylo.Example.getNextPeriods] Filiation type not defined")
 102     where
 103       --------------------------------------
 104       next :: ([PhyloPeriodId], [PhyloPeriodId])
 105       next = splitAt idx l
 106       --------------------------------------
 107       idx :: Int
 108       idx = case (List.elemIndex id l) of
 109         Nothing -> panic ("[ERR][Viz.Phylo.Example.getNextPeriods] PhyloPeriodId not defined")
 110         Just i  -> i
 111       --------------------------------------
 112
 113
 114 -- | To find the best candidates regarding a given proximity
 115 findBestCandidates' :: Filiation -> Int -> Int -> Proximity -> [PhyloPeriodId] -> [PhyloGroup] -> PhyloGroup -> ([Pointer],[Double])
 116 findBestCandidates' fil depth limit prox prds gs g
 117   | depth > limit || null next = ([],[])
 118   | (not . null) bestScores    = (take 2 bestScores, map snd scores)
 119   | otherwise                  = findBestCandidates' fil (depth + 1) limit prox prds gs g
 120   where
 121     --------------------------------------
 122     next :: [PhyloPeriodId]
 123     next = take depth prds
 124     --------------------------------------
 125     candidates :: [PhyloGroup]
 126     candidates = filter (\g' -> elem (getGroupPeriod g') next) gs
 127     --------------------------------------
 128     scores :: [(PhyloGroupId, Double)]
 129     scores = map (\g' -> applyProximity prox g g') candidates
 130     --------------------------------------
 131     bestScores :: [(PhyloGroupId, Double)]
 132     bestScores = reverse
 133                $ sortOn snd
 134                $ filter (\(_id,score) -> case prox of
 135                   WeightedLogJaccard (WLJParams thr _) -> score >= thr
 136                   Hamming (HammingParams thr)          -> score <= thr
 137                   Filiation                            -> panic "[ERR][Viz.Phylo.LinkMaker.findBestCandidates] Filiation"
 138                   ) scores
 139     --------------------------------------
 140
 141
 142 -- | To add some Pointer to a PhyloGroup
 143 addPointers' :: Filiation -> [Pointer] -> PhyloGroup -> PhyloGroup
 144 addPointers' fil pts g = g & case fil of
 145    Descendant -> phylo_groupPeriodChilds  %~ (++ pts)
 146    Ascendant  -> phylo_groupPeriodParents %~ (++ pts)
 147    _          -> panic ("[ERR][Viz.Phylo.LinkMaker.addPointers] Wrong type of filiation")
 148
 149
 150
 151 -- | To update a list of pkyloGroups with some Pointers
 152 updateGroups :: Filiation -> Level -> Map PhyloGroupId [Pointer] -> Phylo -> Phylo
 153 updateGroups fil lvl m p = alterPhyloGroups (\gs -> map (\g -> if (getGroupLevel g) == lvl
 154                                                                then addPointers' fil (m ! (getGroupId g)) g
 155                                                                 else g ) gs) p
 156
 157
 158
 159 -- | To apply the intertemporal matching to Phylo at a given level
 160 interTempoMatching :: Filiation -> Level -> Proximity -> Phylo -> Phylo
 161 interTempoMatching fil lvl prox p = traceMatching fil lvl scores
 162                                   $ updateGroups fil lvl pointers p
 163   where
 164     --------------------------------------
 165     pointers :: Map PhyloGroupId [Pointer]
 166     pointers = Map.fromList $ map (\(id,x) -> (id,fst x)) candidates
 167     --------------------------------------
 168     scores :: [Double]
 169     scores = sort $ concat $ map (snd . snd) candidates
 170     --------------------------------------
 171     candidates :: [(PhyloGroupId,([Pointer],[Double]))]
 172     candidates = map (\g -> ( getGroupId g, findBestCandidates' fil 1 5 prox (getNextPeriods fil (getGroupPeriod g) prds) (delete g gs) g)) gs
 173     --------------------------------------
 174     gs :: [PhyloGroup]
 175     gs = getGroupsWithLevel lvl p
 176     --------------------------------------
 177     prds :: [PhyloPeriodId]
 178     prds = getPhyloPeriods p
 179     --------------------------------------
 180
 181
 182 ----------------
 183 -- | Tracer | --
 184 ----------------
 185
 186
 187 traceMatching :: Filiation -> Level -> [Double] -> Phylo -> Phylo
 188 traceMatching fil lvl lst p = trace ( "----\n" <> show (fil) <> " unfiltered temporal Matching in Phylo" <> show (lvl) <> " :\n"
 189                                       <> "count : " <> show (length lst) <> " potential pointers\n"
 190                                       <> "similarity : " <> show (percentile 25 (VS.fromList lst)) <> " (25%) "
 191                                                          <> show (percentile 50 (VS.fromList lst)) <> " (50%) "
 192                                                          <> show (percentile 75 (VS.fromList lst)) <> " (75%) "
 193                                                          <> show (percentile 90 (VS.fromList lst)) <> " (90%)\n") p
 194