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