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, (!!))
  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) -> [Int] -> [Int] -> Bool
  42 shouldLink (lvl,lvl') l l'
  43   | lvl <= 1  = doesContainsOrd l l'
  44   | lvl >  1  = undefined
  45   | otherwise = panic ("[ERR][Viz.Phylo.Tools.shouldLink] LevelLink 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')
  65                                                           (_phylo_groupNgrams current)
  66                                                           (_phylo_groupNgrams target )
  67                                             then Just ((getGroupId target),1)
  68                                             else Nothing) targets
  69     --------------------------------------
  70
  71
  72 -- | To set the LevelLinks between two lists of PhyloGroups
  73 linkGroupsByLevel :: (Level,Level) -> Phylo -> [PhyloGroup] -> [PhyloGroup]
  74 linkGroupsByLevel (lvl,lvl') p groups  = map (\group ->
  75                                               if getGroupLevel group == lvl
  76                                               then linkGroupToGroups (lvl,lvl') group (getGroupsWithFilters lvl' (getGroupPeriod group) p)
  77                                               else group) groups
  78
  79
  80 -- | To set the LevelLink of all the PhyloGroups of a Phylo
  81 setLevelLinks :: (Level,Level) -> Phylo -> Phylo
  82 setLevelLinks (lvl,lvl') p = alterPhyloGroups (linkGroupsByLevel (lvl,lvl') p) p
  83
  84
  85 ------------------------------------------------------------------------
  86 -- | Make links from Period to Period
  87
  88
  89 -- | To apply the corresponding proximity function based on a given Proximity
  90 getProximity :: (Proximity,[Double]) -> PhyloGroup -> PhyloGroup -> (PhyloGroupId, Double)
  91 getProximity (prox,param) g1 g2 = case prox of
  92   WeightedLogJaccard -> ((getGroupId g2),weightedLogJaccard (param !! 0) (getGroupCooc g1) (unifySharedKeys (getGroupCooc g2) (getGroupCooc g1)))
  93   _                  -> panic ("[ERR][Viz.Phylo.Example.getProximity] Proximity function not defined")
  94
  95
  96 -- | To get the next or previous PhyloPeriod based on a given PhyloPeriodId
  97 getNextPeriods :: PairTo -> PhyloPeriodId -> [PhyloPeriodId] -> [PhyloPeriodId]
  98 getNextPeriods to id l = case to of
  99     Childs  -> unNested id ((tail . snd) next)
 100     Parents -> unNested id ((reverse . fst) next)
 101     _       -> panic ("[ERR][Viz.Phylo.Example.getNextPeriods] PairTo 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       -- | To have an non-overlapping next period
 113       unNested :: PhyloPeriodId -> [PhyloPeriodId] -> [PhyloPeriodId]
 114       unNested x l
 115         | null l                  = []
 116         | nested (fst $ head l) x = unNested x (tail l)
 117         | nested (snd $ head l) x = unNested x (tail l)
 118         | otherwise               = l
 119       --------------------------------------
 120       nested :: Date -> PhyloPeriodId -> Bool
 121       nested d prd = d >= fst prd && d <= snd prd
 122       --------------------------------------
 123
 124
 125 -- | 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 )
 126 findBestCandidates :: PairTo -> Int -> Int -> Double -> (Proximity,[Double]) -> PhyloGroup -> Phylo -> [(PhyloGroupId, Double)]
 127 findBestCandidates to depth max thr (prox,param) group p
 128   | depth > max || null next = []
 129   | (not . null) best = take 2 best
 130   | otherwise = findBestCandidates to (depth + 1) max thr (prox,param) group p
 131   where
 132     --------------------------------------
 133     next :: [PhyloPeriodId]
 134     next = getNextPeriods to (getGroupPeriod group) (getPhyloPeriods p)
 135     --------------------------------------
 136     candidates :: [PhyloGroup]
 137     candidates = getGroupsWithFilters (getGroupLevel group) (head next) p
 138     --------------------------------------
 139     scores :: [(PhyloGroupId, Double)]
 140     scores = map (\group' -> getProximity (prox,param) group group') candidates
 141     --------------------------------------
 142     best :: [(PhyloGroupId, Double)]
 143     best = reverse
 144          $ sortOn snd
 145          $ filter (\(id,score) -> score >= thr) scores
 146     --------------------------------------
 147
 148
 149 -- | To add a new list of Pointers into an existing Childs/Parents list of Pointers
 150 makePair :: PairTo -> PhyloGroup -> [(PhyloGroupId, Double)] -> PhyloGroup
 151 makePair to group ids = case to of
 152     Childs  -> over (phylo_groupPeriodChilds) addPointers group
 153     Parents -> over (phylo_groupPeriodParents) addPointers group
 154     _       -> panic ("[ERR][Viz.Phylo.Example.makePair] PairTo type not defined")
 155     where
 156       --------------------------------------
 157       addPointers :: [Pointer] -> [Pointer]
 158       addPointers l = nub $ (l ++ ids)
 159       --------------------------------------
 160
 161
 162 -- | To pair all the Phylogroups of given PhyloLevel to their best Parents or Childs
 163 pairGroupsToGroups :: PairTo -> Level -> Double -> (Proximity,[Double]) -> Phylo -> Phylo
 164 pairGroupsToGroups to lvl thr (prox,param) p = alterPhyloGroups
 165                                     (\groups ->
 166                                       map (\group ->
 167                                             if (getGroupLevel group) == lvl
 168                                             then
 169                                               let
 170                                                 --------------------------------------
 171                                                 candidates :: [(PhyloGroupId, Double)]
 172                                                 candidates = findBestCandidates to 1 5 thr (prox,param) group p
 173                                                 --------------------------------------
 174                                               in
 175                                                 makePair to group candidates
 176                                             else
 177                                               group ) groups) p