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