src/Gargantext/Viz/Phylo/LevelMaker.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.LevelMaker
  18   where
  19
  20 import Control.Lens                 hiding (both, Level)
  21 import Data.List                    ((++), sort, concat, nub, words, zip)
  22 import Data.Map                     (Map, (!), empty, restrictKeys, filterWithKey, singleton, union)
  23 import Data.Set                     (Set)
  24 import Data.Text                    (Text, words)
  25 import Data.Tuple.Extra
  26
  27 import Gargantext.Prelude                   hiding (head)
  28 import Gargantext.Viz.Phylo.Aggregates.Cluster
  29 import Gargantext.Viz.Phylo.Aggregates.Cooc
  30 import Gargantext.Viz.Phylo
  31 import Gargantext.Viz.Phylo.Tools
  32 import Gargantext.Viz.Phylo.LinkMaker
  33 import Gargantext.Viz.Phylo.BranchMaker
  34
  35 import qualified Data.List   as List
  36 import qualified Data.Map    as Map
  37 import qualified Data.Set    as Set
  38 import qualified Data.Text   as Text
  39
  40
  41 -- | A typeClass for polymorphic PhyloLevel functions
  42 class PhyloLevelMaker aggregate
  43     where
  44         -- | To add a new Level of PhyloGroups to a Phylo based on a list of Aggregates
  45         addPhyloLevel :: Level -> Map (Date,Date) [aggregate] -> Phylo -> Phylo
  46         -- | To create a list of PhyloGroups based on a list of aggregates a
  47         toPhyloGroups :: Level -> (Date,Date)  -> [aggregate] -> Map (Date,Date) [aggregate] -> Phylo -> [PhyloGroup]
  48
  49
  50 instance PhyloLevelMaker Cluster
  51   where
  52     --------------------------------------
  53     -- | Level -> Map (Date,Date) [Cluster] -> Phylo -> Phylo
  54     addPhyloLevel lvl m p
  55       | lvl > 1   = toPhyloLevel lvl m p
  56       | otherwise = panic ("[ERR][Viz.Phylo.Example.addPhyloLevel] No process declared for adding Clusters at level < 2")
  57     --------------------------------------
  58     -- | Level -> (Date,Date) -> [Cluster] -> Map (Date,Date) [Cluster] -> Phylo -> [PhyloGroup]
  59     toPhyloGroups lvl (d,d') l m p = map (\(idx,cluster) -> clusterToGroup (d,d') lvl idx "" cluster m p) $ zip [1..] l
  60     --------------------------------------
  61
  62
  63 instance PhyloLevelMaker Fis
  64   where
  65     --------------------------------------
  66     -- | Level -> Map (Date,Date) [Fis] -> Phylo -> Phylo
  67     addPhyloLevel lvl m p
  68       | lvl == 1  = toPhyloLevel lvl m p
  69       | otherwise = panic ("[ERR][Viz.Phylo.Example.addPhyloLevel] No process declared for adding Fis at level <> 1")
  70     --------------------------------------
  71     -- | Level -> (Date,Date) -> [Fis] -> Map (Date,Date) [Fis] -> Phylo -> [PhyloGroup]
  72     toPhyloGroups lvl (d,d') l m p = map (\(idx,fis) -> cliqueToGroup (d,d') lvl idx "" fis m p) $ zip [1..] l
  73     --------------------------------------
  74
  75
  76 instance PhyloLevelMaker Document
  77   where
  78     --------------------------------------
  79     -- | Level -> Map (Date,Date) [Document] -> Phylo -> Phylo
  80     addPhyloLevel lvl m p
  81       | lvl < 0 = toPhyloLevel lvl m p
  82       | otherwise = panic ("[ERR][Viz.Phylo.Example.addPhyloLevel] No process declared for adding Documents at level <> -1")
  83     --------------------------------------
  84     -- | Level -> (Date,Date) -> [Document] -> Map (Date,Date) [Fis] -> Phylo -> [PhyloGroup]
  85     toPhyloGroups lvl (d,d') l m p = map (\(idx,ngram) -> ngramsToGroup (d,d') lvl idx ngram [ngram] p)
  86                                           $ zip [1..]
  87                                           $ (nub . concat)
  88                                           $ map (Text.words . text) l
  89     --------------------------------------
  90
  91
  92 -- | To transform a Cluster into a Phylogroup
  93 clusterToGroup :: PhyloPeriodId -> Level -> Int -> Text -> Cluster -> Map (Date,Date) [Cluster] -> Phylo -> PhyloGroup
  94 clusterToGroup prd lvl idx lbl groups m p =
  95     PhyloGroup ((prd, lvl), idx) lbl ngrams empty cooc [] [] [] (map (\g -> (getGroupId g, 1)) groups)
  96       where
  97         --------------------------------------
  98         ngrams :: [Int]
  99         ngrams = (sort . nub . concat) $ map getGroupNgrams groups
 100         --------------------------------------
 101         cooc :: Map (Int, Int) Double
 102         cooc = filterWithKey (\k _ -> elem (fst k) ngrams && elem (snd k) ngrams)
 103               $ foldl union empty
 104               $ map getGroupCooc
 105               $ getGroupsWithFilters 1 prd p
 106         --------------------------------------
 107
 108
 109 -- | To transform a Clique into a PhyloGroup
 110 cliqueToGroup :: PhyloPeriodId -> Level -> Int -> Text -> (Clique,Support) -> Map (Date, Date) [Fis] -> Phylo -> PhyloGroup
 111 cliqueToGroup prd lvl idx lbl fis m p =
 112     PhyloGroup ((prd, lvl), idx) lbl ngrams (singleton "support" (fromIntegral $ snd fis)) cooc [] [] [] []
 113       where
 114         --------------------------------------
 115         ngrams :: [Int]
 116         ngrams = sort $ map (\x -> ngramsToIdx x p)
 117                       $ Set.toList
 118                       $ fst fis
 119         --------------------------------------
 120         cooc :: Map (Int, Int) Double
 121         cooc =  filterWithKey (\k _ -> elem (fst k) ngrams && elem (snd k) ngrams)
 122                                      $ fisToCooc (restrictKeys m $ Set.fromList [prd]) p
 123         --------------------------------------
 124
 125
 126 -- | To transform a list of Ngrams into a PhyloGroup
 127 ngramsToGroup ::  PhyloPeriodId -> Level -> Int -> Text -> [Ngrams] -> Phylo -> PhyloGroup
 128 ngramsToGroup prd lvl idx lbl ngrams p =
 129     PhyloGroup ((prd, lvl), idx) lbl (sort $ map (\x -> ngramsToIdx x p) ngrams) empty empty [] [] [] []
 130
 131
 132 -- | To traverse a Phylo and add a new PhyloLevel linked to a new list of PhyloGroups
 133 toPhyloLevel :: PhyloLevelMaker a => Level -> Map (Date, Date) [a] -> Phylo -> Phylo
 134 toPhyloLevel lvl m p = alterPhyloPeriods
 135                         (\period -> let pId = _phylo_periodId period
 136                                     in  over (phylo_periodLevels)
 137                                         (\phyloLevels ->
 138                                           let groups = toPhyloGroups lvl pId (m ! pId) m p
 139                                           in  phyloLevels ++ [PhyloLevel (pId, lvl) groups]
 140                                         ) period) p
 141
 142
 143 -- | To incrementally add new Levels to a Phylo by making all the linking and aggregation tasks
 144 toNthLevel :: Level -> (Proximity,[Double]) -> (Clustering,[Double]) -> (Proximity,[Double]) -> Phylo -> Phylo
 145 toNthLevel lvlMax (prox,param1) (clus,param2) (prox',param3) p
 146   | lvl >= lvlMax = p
 147   | otherwise     = toNthLevel lvlMax (prox,param1) (clus,param2) (prox',param3)
 148                   $ pairGroupsToGroups Childs  (lvl + 1) (prox',param3)
 149                   $ pairGroupsToGroups Parents (lvl + 1) (prox',param3)
 150                   $ setPhyloBranches (lvl + 1)
 151                   $ setLevelLinks (lvl, lvl + 1)
 152                   $ addPhyloLevel (lvl + 1)
 153                     (phyloToClusters lvl (prox,param1) (clus,param2) p) p
 154   where
 155     --------------------------------------
 156     lvl :: Level
 157     lvl = getLastLevel p
 158     --------------------------------------