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
13 {-# LANGUAGE NoImplicitPrelude #-}
14 {-# LANGUAGE FlexibleContexts #-}
15 {-# LANGUAGE OverloadedStrings #-}
17 module Gargantext.Viz.Phylo.LevelMaker
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)
24 import Data.Text (Text, words)
25 import Data.Tuple.Extra
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
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
42 -- | A typeClass for polymorphic PhyloLevel functions
43 class PhyloLevelMaker aggregate
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]
51 instance PhyloLevelMaker Cluster
53 --------------------------------------
54 -- | Level -> Map (Date,Date) [Cluster] -> Phylo -> Phylo
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 --------------------------------------
64 instance PhyloLevelMaker Fis
66 --------------------------------------
67 -- | Level -> Map (Date,Date) [Fis] -> Phylo -> Phylo
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 --------------------------------------
77 instance PhyloLevelMaker Document
79 --------------------------------------
80 -- | Level -> Map (Date,Date) [Document] -> Phylo -> Phylo
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)
89 $ map (Text.words . text) l
90 --------------------------------------
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 Nothing [] [] [] (map (\g -> (getGroupId g, 1)) groups)
98 --------------------------------------
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)
106 $ getGroupsWithFilters 1 prd p
107 --------------------------------------
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 Nothing [] [] [] []
115 --------------------------------------
117 ngrams = sort $ map (\x -> getIdxInFoundations x p)
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 --------------------------------------
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 Nothing [] [] [] []
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)
139 let groups = toPhyloGroups lvl pId (m ! pId) m p
140 in phyloLevels ++ [PhyloLevel (pId, lvl) groups]
144 initPhylo :: Grain -> Step -> [(Date,Text)] -> [Ngrams] -> (Ngrams -> Ngrams) -> Phylo
145 initPhylo g s c a f = addPhyloLevel 0 (corpusToDocs f c base) base
147 --------------------------------------
149 base = initPhyloBase (initPeriods g s $ both fst (head c,last c)) (initFoundations a)
150 --------------------------------------
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
157 | otherwise = toNthLevel lvlMax (prox,param1) (clus,param2) (prox',param3)
158 $ setPhyloBranches (lvl + 1)
159 $ interTempoMatching Childs (lvl + 1) (prox',param3)
160 $ interTempoMatching Parents (lvl + 1) (prox',param3)
161 $ setLevelLinks (lvl, lvl + 1)
162 $ addPhyloLevel (lvl + 1)
163 (phyloToClusters lvl (prox,param1) (clus,param2) p) p
165 --------------------------------------
168 --------------------------------------