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 -> (tail . snd) next
  94     Ascendant  -> (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
 107
 108 -- | 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 )
 109 findBestCandidates :: Filiation -> Int -> Int -> Proximity -> PhyloGroup -> Phylo -> [(PhyloGroupId, Double)]
 110 findBestCandidates to' depth max' prox group p
 111   | depth > max' || null next = []
 112   | (not . null) best = take 2 best
 113   | otherwise = findBestCandidates to' (depth + 1) max' prox group p
 114   where
 115     --------------------------------------
 116     next :: [PhyloPeriodId]
 117     next = getNextPeriods to' (getGroupPeriod group) (getPhyloPeriods p)
 118     --------------------------------------
 119     candidates :: [PhyloGroup]
 120     candidates = getGroupsWithFilters (getGroupLevel group) (head' "findBestCandidates" next) p
 121     --------------------------------------
 122     scores :: [(PhyloGroupId, Double)]
 123     scores = map (\group' -> applyProximity prox group group') candidates
 124     --------------------------------------
 125     best :: [(PhyloGroupId, Double)]
 126     best = reverse
 127          $ sortOn snd
 128          $ filter (\(_id,score) -> case prox of
 129             WeightedLogJaccard (WLJParams thr _) -> score >= thr
 130             Hamming (HammingParams thr)          -> score <= thr
 131             Filiation                            -> panic "[ERR][Viz.Phylo.LinkMaker.findBestCandidates] Filiation"
 132             ) scores
 133     --------------------------------------
 134
 135
 136 -- | To add a new list of Pointers into an existing Childs/Parents list of Pointers
 137 makePair :: Filiation -> PhyloGroup -> [(PhyloGroupId, Double)] -> PhyloGroup
 138 makePair to' group ids = case to' of
 139     Descendant  -> over (phylo_groupPeriodChilds) addPointers group
 140     Ascendant   -> over (phylo_groupPeriodParents) addPointers group
 141     _           -> panic ("[ERR][Viz.Phylo.Example.makePair] Filiation type not defined")
 142     where
 143       --------------------------------------
 144       addPointers :: [Pointer] -> [Pointer]
 145       addPointers l = nub $ (l ++ ids)
 146       --------------------------------------
 147
 148
 149 -- | To pair all the Phylogroups of given PhyloLevel to their best Parents or Childs
 150 interTempoMatching :: Filiation -> Level -> Proximity -> Phylo -> Phylo
 151 interTempoMatching to' lvl prox p = alterPhyloGroups
 152                                     (\groups ->
 153                                       map (\group ->
 154                                             if (getGroupLevel group) == lvl
 155                                             then
 156                                               let
 157                                                 --------------------------------------
 158                                                 candidates :: [(PhyloGroupId, Double)]
 159                                                 candidates = findBestCandidates to' 1 5 prox group p
 160                                                 --------------------------------------
 161                                               in
 162                                                 makePair to' group candidates
 163                                             else
 164                                               group ) groups) p