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