]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/Viz/Phylo/LevelMaker.hs
Add the new branches definition
[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
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 Nothing [] [] [] (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 Nothing [] [] [] []
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 Nothing [] [] [] []
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 $ 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
164 where
165 --------------------------------------
166 lvl :: Level
167 lvl = getLastLevel p
168 --------------------------------------