]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/Viz/Phylo/LevelMaker.hs
Add new types for Cluster, Proximity, Filter, etc
[gargantext.git] / 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 import Data.Vector (Vector)
27
28 import Gargantext.Prelude hiding (head)
29 import Gargantext.Viz.Phylo.Aggregates.Cluster
30 import Gargantext.Viz.Phylo.Aggregates.Cooc
31 import Gargantext.Viz.Phylo.Aggregates.Document
32 import Gargantext.Viz.Phylo.Aggregates.Fis
33 import Gargantext.Viz.Phylo
34 import Gargantext.Viz.Phylo.Tools
35 import Gargantext.Viz.Phylo.LinkMaker
36 import Gargantext.Viz.Phylo.BranchMaker
37
38 import qualified Data.List as List
39 import qualified Data.Map as Map
40 import qualified Data.Set as Set
41 import qualified Data.Text as Text
42 import qualified Data.Vector as Vector
43
44
45 -- | A typeClass for polymorphic PhyloLevel functions
46 class PhyloLevelMaker aggregate
47 where
48 -- | To add a new Level of PhyloGroups to a Phylo based on a list of Aggregates
49 addPhyloLevel :: Level -> Map (Date,Date) [aggregate] -> Phylo -> Phylo
50 -- | To create a list of PhyloGroups based on a list of aggregates a
51 toPhyloGroups :: Level -> (Date,Date) -> [aggregate] -> Map (Date,Date) [aggregate] -> Phylo -> [PhyloGroup]
52
53
54 instance PhyloLevelMaker PhyloCluster
55 where
56 --------------------------------------
57 -- | Level -> Map (Date,Date) [Cluster] -> Phylo -> Phylo
58 addPhyloLevel lvl m p
59 | lvl > 1 = toPhyloLevel lvl m p
60 | otherwise = panic ("[ERR][Viz.Phylo.Example.addPhyloLevel] No process declared for adding Clusters at level < 2")
61 --------------------------------------
62 -- | Level -> (Date,Date) -> [Cluster] -> Map (Date,Date) [Cluster] -> Phylo -> [PhyloGroup]
63 toPhyloGroups lvl (d,d') l m p = map (\(idx,cluster) -> clusterToGroup (d,d') lvl idx "" cluster m p) $ zip [1..] l
64 --------------------------------------
65
66
67 instance PhyloLevelMaker PhyloFis
68 where
69 --------------------------------------
70 -- | Level -> Map (Date,Date) [Fis] -> Phylo -> Phylo
71 addPhyloLevel lvl m p
72 | lvl == 1 = toPhyloLevel lvl m p
73 | otherwise = panic ("[ERR][Viz.Phylo.Example.addPhyloLevel] No process declared for adding Fis at level <> 1")
74 --------------------------------------
75 -- | Level -> (Date,Date) -> [Fis] -> Map (Date,Date) [Fis] -> Phylo -> [PhyloGroup]
76 toPhyloGroups lvl (d,d') l m p = map (\(idx,fis) -> cliqueToGroup (d,d') lvl idx "" fis m p) $ zip [1..] l
77 --------------------------------------
78
79
80 instance PhyloLevelMaker Document
81 where
82 --------------------------------------
83 -- | Level -> Map (Date,Date) [Document] -> Phylo -> Phylo
84 addPhyloLevel lvl m p
85 | lvl == 0 = toPhyloLevel lvl m p
86 | otherwise = panic ("[ERR][Viz.Phylo.Example.addPhyloLevel] No process declared for adding Documents at level <> 0")
87 --------------------------------------
88 -- | Level -> (Date,Date) -> [Document] -> Map (Date,Date) [Fis] -> Phylo -> [PhyloGroup]
89 toPhyloGroups lvl (d,d') l m p = map (\(idx,ngram) -> ngramsToGroup (d,d') lvl idx ngram [ngram] p)
90 $ zip [1..]
91 $ (nub . concat)
92 $ map (Text.words . text) l
93 --------------------------------------
94
95
96 -- | To transform a Cluster into a Phylogroup
97 clusterToGroup :: PhyloPeriodId -> Level -> Int -> Text -> PhyloCluster -> Map (Date,Date) [PhyloCluster] -> Phylo -> PhyloGroup
98 clusterToGroup prd lvl idx lbl groups m p =
99 PhyloGroup ((prd, lvl), idx) lbl ngrams empty cooc Nothing [] [] [] (map (\g -> (getGroupId g, 1)) groups)
100 where
101 --------------------------------------
102 ngrams :: [Int]
103 ngrams = (sort . nub . concat) $ map getGroupNgrams groups
104 --------------------------------------
105 cooc :: Map (Int, Int) Double
106 cooc = filterWithKey (\k _ -> elem (fst k) ngrams && elem (snd k) ngrams)
107 $ foldl union empty
108 $ map getGroupCooc
109 $ getGroupsWithFilters 1 prd p
110 --------------------------------------
111
112
113 -- | To transform a Clique into a PhyloGroup
114 cliqueToGroup :: PhyloPeriodId -> Level -> Int -> Text -> (Clique,Support) -> Map (Date, Date) [PhyloFis] -> Phylo -> PhyloGroup
115 cliqueToGroup prd lvl idx lbl fis m p =
116 PhyloGroup ((prd, lvl), idx) lbl ngrams (singleton "support" (fromIntegral $ snd fis)) cooc Nothing [] [] [] []
117 where
118 --------------------------------------
119 ngrams :: [Int]
120 ngrams = sort $ map (\x -> getIdxInFoundations x p)
121 $ Set.toList
122 $ fst fis
123 --------------------------------------
124 cooc :: Map (Int, Int) Double
125 cooc = filterWithKey (\k _ -> elem (fst k) ngrams && elem (snd k) ngrams)
126 $ fisToCooc (restrictKeys m $ Set.fromList [prd]) p
127 --------------------------------------
128
129
130 -- | To transform a list of Ngrams into a PhyloGroup
131 ngramsToGroup :: PhyloPeriodId -> Level -> Int -> Text -> [Ngrams] -> Phylo -> PhyloGroup
132 ngramsToGroup prd lvl idx lbl ngrams p =
133 PhyloGroup ((prd, lvl), idx) lbl (sort $ map (\x -> getIdxInFoundations x p) ngrams) empty empty Nothing [] [] [] []
134
135
136 -- | To traverse a Phylo and add a new PhyloLevel linked to a new list of PhyloGroups
137 toPhyloLevel :: PhyloLevelMaker a => Level -> Map (Date, Date) [a] -> Phylo -> Phylo
138 toPhyloLevel lvl m p = alterPhyloPeriods
139 (\period -> let pId = _phylo_periodId period
140 in over (phylo_periodLevels)
141 (\phyloLevels ->
142 let groups = toPhyloGroups lvl pId (m ! pId) m p
143 in phyloLevels ++ [PhyloLevel (pId, lvl) groups]
144 ) period) p
145
146
147 -- | To init a Phylo
148 initPhylo :: Grain -> Step -> [(Date,Text)] -> [Ngrams] -> (Ngrams -> Ngrams) -> Phylo
149 initPhylo g s c a f = addPhyloLevel 0 (corpusToDocs f c base) base
150 where
151 --------------------------------------
152 base :: Phylo
153 base = initPhyloBase (initPeriods g s $ both fst (head c,last c)) (initFoundations a)
154 --------------------------------------
155
156
157 -- | To incrementally add new Levels to a Phylo by making all the linking and aggregation tasks
158 toNthLevel :: Level -> Proximity -> Cluster -> Phylo -> Phylo
159 toNthLevel lvlMax prox clus p
160 | lvl >= lvlMax = p
161 | otherwise = toNthLevel lvlMax prox clus
162 $ setPhyloBranches (lvl + 1)
163 $ interTempoMatching Descendant (lvl + 1) prox
164 $ interTempoMatching Ascendant (lvl + 1) prox
165 $ setLevelLinks (lvl, lvl + 1)
166 $ addPhyloLevel (lvl + 1)
167 (phyloToClusters lvl (getProximity clus) clus p) p
168 where
169 --------------------------------------
170 lvl :: Level
171 lvl = getLastLevel p
172 --------------------------------------
173
174
175 -- | To reconstruct the Level 1 of a Phylo based on a Clustering Method
176 toPhylo1 :: Cluster -> Proximity -> Map (Date, Date) [Document] -> Phylo -> Phylo
177 toPhylo1 clus prox d p = case clus of
178 Fis (FisParams f k s) -> setPhyloBranches 1
179 $ interTempoMatching Descendant 1 prox
180 $ interTempoMatching Ascendant 1 prox
181 $ setLevelLinks (0,1)
182 $ setLevelLinks (1,0)
183 $ addPhyloLevel 1 phyloFis p
184 where
185 --------------------------------------
186 phyloFis :: Map (Date, Date) [PhyloFis]
187 phyloFis = if f
188 then filterFisBySupport k s (filterFisByNested (docsToFis d))
189 else docsToFis d
190 --------------------------------------
191
192 _ -> panic "[ERR][Viz.Phylo.PhyloMaker.toPhylo1] fst clustering not recognized"
193
194
195 -- | To reconstruct the Level 0 of a Phylo
196 toPhylo0 :: Map (Date, Date) [Document] -> Phylo -> Phylo
197 toPhylo0 d p = addPhyloLevel 0 d p
198
199
200 -- | To reconstruct the Base of a Phylo
201 toPhyloBase :: PhyloQuery -> [(Date, Text)] -> [Ngrams] -> Phylo
202 toPhyloBase q c a = initPhyloBase periods foundations
203 where
204 --------------------------------------
205 periods :: [(Date,Date)]
206 periods = initPeriods (getPeriodGrain q) (getPeriodSteps q)
207 $ both fst (head c,last c)
208 --------------------------------------
209 foundations :: Vector Ngrams
210 foundations = initFoundations a
211 --------------------------------------
212
213
214 -- | To reconstruct a Phylomemy from a PhyloQuery, a Corpus and a list of actants
215 toPhylo :: PhyloQuery -> [(Date, Text)] -> [Ngrams] -> Phylo
216 toPhylo q c a = toNthLevel (getNthLevel q) (getInterTemporalMatching q) (getNthCluster q) phylo1
217 where
218 --------------------------------------
219 phylo1 :: Phylo
220 phylo1 = toPhylo1 (getFstCluster q) (getInterTemporalMatching q) phyloDocs phylo0
221 --------------------------------------
222 phylo0 :: Phylo
223 phylo0 = toPhylo0 phyloDocs phyloBase
224 --------------------------------------
225 phyloDocs :: Map (Date, Date) [Document]
226 phyloDocs = corpusToDocs groupNgramsWithTrees c phyloBase
227 --------------------------------------
228 phyloBase :: Phylo
229 phyloBase = toPhyloBase q c a
230 --------------------------------------