]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/Viz/Phylo/View/ViewMaker.hs
merge with dev
[gargantext.git] / src / Gargantext / Viz / Phylo / View / ViewMaker.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.View.ViewMaker
18 where
19
20 import Control.Lens hiding (makeLenses, both, Level)
21 import Data.List (concat,nub,(++),sort)
22 import Data.Text (Text)
23 import Data.Map (Map, empty, elems, unionWithKey, fromList)
24 import Data.Tuple (fst, snd)
25 import Data.Vector (Vector)
26 import Gargantext.Prelude
27 import Gargantext.Viz.Phylo
28 import Gargantext.Viz.Phylo.Tools
29 import Gargantext.Viz.Phylo.Metrics
30 import Gargantext.Viz.Phylo.View.Display
31 import Gargantext.Viz.Phylo.View.Filters
32 import Gargantext.Viz.Phylo.View.Metrics
33 import Gargantext.Viz.Phylo.View.Sort
34 import Gargantext.Viz.Phylo.View.Taggers
35
36 import qualified Data.Vector.Storable as VS
37 import Debug.Trace (trace)
38 import Numeric.Statistics (percentile)
39
40 -- | To init a PhyloBranch
41 initPhyloBranch :: PhyloBranchId -> Text -> PhyloBranch
42 initPhyloBranch id lbl = PhyloBranch id lbl empty
43
44
45 -- | To init a PhyloEdge
46 initPhyloEdge :: PhyloGroupId -> [Pointer] -> EdgeType -> [PhyloEdge]
47 initPhyloEdge id pts et = map (\pt -> PhyloEdge id (fst pt) et (snd pt)) pts
48
49
50 -- | To init a PhyloView
51 initPhyloView :: Level -> Text -> Text -> Filiation -> Bool -> Phylo -> PhyloView
52 initPhyloView lvl lbl dsc fl vb p = PhyloView (getPhyloParams p) lbl dsc fl lvl
53 (getPhyloPeriods p)
54 empty
55 ([] ++ (phyloToBranches lvl p))
56 ([] ++ (groupsToNodes True vb (getFoundationsRoots p) gs))
57 ([] ++ (groupsToEdges fl PeriodEdge gs))
58 where
59 --------------------------------------
60 gs :: [PhyloGroup]
61 gs = getGroupsWithLevel lvl p
62 --------------------------------------
63
64
65 -- | To transform a list of PhyloGroups into a list of PhyloNodes
66 groupsToNodes :: Bool -> Bool -> Vector Ngrams -> [PhyloGroup] -> [PhyloNode]
67 groupsToNodes isR isV ns gs = map (\g -> let idxs = getGroupNgrams g
68 in PhyloNode
69 (getGroupId g)
70 (getGroupBranchId g)
71 "" idxs
72 (if isV
73 then Just (ngramsToText ns idxs)
74 else Nothing)
75 (g ^. phylo_groupNgramsMeta)
76 (g ^. phylo_groupCooc)
77 (if (not isR)
78 then Just (getGroupLevelParentsId g)
79 else Nothing)
80 []
81 ) gs
82
83
84 -- | To merge edges by keeping the maximum weight
85 mergeEdges :: [PhyloEdge] -> [PhyloEdge] -> [PhyloEdge]
86 mergeEdges lAsc lDes = elems
87 $ unionWithKey (\_k vAsc vDes -> vDes & pe_weight .~ (max (vAsc ^. pe_weight) (vDes ^. pe_weight))) mAsc mDes
88 where
89 --------------------------------------
90 mAsc :: Map (PhyloGroupId,PhyloGroupId) PhyloEdge
91 mAsc = fromList
92 $ map (\(k,e) -> (k, e & pe_source .~ fst k
93 & pe_target .~ snd k))
94 $ zip (map (\e -> (e ^. pe_target,e ^. pe_source)) lAsc) lAsc
95 --------------------------------------
96 mDes :: Map (PhyloGroupId,PhyloGroupId) PhyloEdge
97 mDes = fromList
98 $ zip (map (\e -> (e ^. pe_source,e ^. pe_target)) lDes) lDes
99 --------------------------------------
100
101
102 -- | To transform a list of PhyloGroups into a list of PhyloEdges
103 groupsToEdges :: Filiation -> EdgeType -> [PhyloGroup] -> [PhyloEdge]
104 groupsToEdges fl et gs = case fl of
105 Complete -> (groupsToEdges Ascendant et gs) ++ (groupsToEdges Descendant et gs)
106 Merge -> mergeEdges (groupsToEdges Ascendant et gs) (groupsToEdges Descendant et gs)
107 _ -> concat
108 $ map (\g -> case fl of
109 Ascendant -> case et of
110 PeriodEdge -> initPhyloEdge (getGroupId g) (getGroupPeriodParents g) et
111 LevelEdge -> initPhyloEdge (getGroupId g) (getGroupLevelParents g) et
112 Descendant -> case et of
113 PeriodEdge -> initPhyloEdge (getGroupId g) (getGroupPeriodChilds g) et
114 LevelEdge -> initPhyloEdge (getGroupId g) (getGroupLevelChilds g) et
115 _Type -> panic "[ERR][Viz.Phylo.View.ViewMaker.groupsToEdges] not implemented"
116 ) gs
117
118
119 -- | To transform a Phylo into a list of PhyloBranch for a given Level
120 phyloToBranches :: Level -> Phylo -> [PhyloBranch]
121 phyloToBranches lvl p = map (\id -> initPhyloBranch id "") $ nub $ getBranchIdsWith lvl p
122
123
124 -- | To add recursively a list of PhyloNodes and Edges to PhyloView from a given Level and Depth
125 addChildNodes :: Bool -> Level -> Level -> Bool -> Filiation -> Phylo -> PhyloView -> PhyloView
126 addChildNodes shouldDo lvl lvlMin vb fl p v =
127 if (not shouldDo) || (lvl == lvlMin)
128 then v
129 else addChildNodes shouldDo (lvl - 1) lvlMin vb fl p
130 $ v & pv_branches %~ (++ (phyloToBranches (lvl - 1) p))
131 & pv_nodes %~ (++ (groupsToNodes False vb (getFoundationsRoots p) gs'))
132 & pv_edges %~ (++ (groupsToEdges fl PeriodEdge gs'))
133 & pv_edges %~ (++ (groupsToEdges Descendant LevelEdge gs ))
134 & pv_edges %~ (++ (groupsToEdges Ascendant LevelEdge gs'))
135 where
136 --------------------------------------
137 gs :: [PhyloGroup]
138 gs = getGroupsWithLevel lvl p
139 --------------------------------------
140 gs' :: [PhyloGroup]
141 gs' = getGroupsWithLevel (lvl - 1) p
142 --------------------------------------
143
144
145 -- | To transform a PhyloQuery into a PhyloView
146 toPhyloView :: PhyloQueryView -> Phylo -> PhyloView
147 toPhyloView q p = traceView
148 $ processDisplay (q ^. qv_display) (q ^. qv_export)
149 $ processSort (q ^. qv_sort ) p
150 $ processTaggers (q ^. qv_taggers) p
151 $ processDynamics
152 $ processFilters (q ^. qv_filters) p
153 $ processMetrics (q ^. qv_metrics) p
154 $ addChildNodes (q ^. qv_levelChilds) (q ^. qv_lvl) (q ^. qv_levelChildsDepth) (q ^. qv_verbose) (q ^. qv_filiation) p
155 $ initPhyloView (q ^. qv_lvl) (getPhyloTitle p) (getPhyloDescription p) (q ^. qv_filiation) (q ^. qv_verbose) p
156
157
158
159 -----------------
160 -- | Taggers | --
161 -----------------
162
163
164 traceView :: PhyloView -> PhyloView
165 traceView pv = trace ("------------\n--| View |--\n------------\n\n"
166 <> "view level : " <> show (pv ^. pv_level) <> "\n"
167 <> show (length $ pv ^. pv_branches) <> " exported branches with " <> show (length $ pv ^. pv_nodes) <> " groups\n"
168 <> "groups by branches : " <> show (percentile 25 (VS.fromList lst)) <> " (25%) "
169 <> show (percentile 50 (VS.fromList lst)) <> " (50%) "
170 <> show (percentile 75 (VS.fromList lst)) <> " (75%) "
171 <> show (percentile 90 (VS.fromList lst)) <> " (90%)\n") pv
172 where
173 lst = sort $ map (fromIntegral . length . snd) $ getNodesByBranches pv