]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/Viz/Phylo/View/Export.hs
working on the adaptative matching
[gargantext.git] / src / Gargantext / Viz / Phylo / View / Export.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.Export
18 where
19
20 import Control.Lens hiding (Level)
21 import Control.Monad
22 import Data.GraphViz hiding (DotGraph)
23 import Data.GraphViz.Attributes.Complete hiding (EdgeType)
24 import Data.GraphViz.Types.Generalised (DotGraph)
25 import Data.GraphViz.Types.Monadic
26 import Data.List ((++),unwords,concat,sortOn,nub)
27 import Data.Map (Map,toList,(!))
28 import Data.Maybe (isNothing,fromJust)
29 import Data.Text.Lazy (fromStrict, pack, unpack)
30
31 import qualified Data.Text as T
32 import qualified Data.Text.Lazy as T'
33 import qualified Data.GraphViz.Attributes.HTML as H
34
35 import Gargantext.Prelude
36 import Gargantext.Viz.Phylo hiding (Dot)
37 import Gargantext.Viz.Phylo.Tools
38
39 -- import Debug.Trace (trace)
40
41
42 import Prelude (writeFile)
43 import System.FilePath
44
45 type DotId = T'.Text
46
47
48 ---------------------
49 -- | Dot to File | --
50 ---------------------
51
52 dotToFile :: FilePath -> DotGraph DotId -> IO ()
53 dotToFile filePath dotG = writeFile filePath $ dotToString dotG
54
55 dotToString :: DotGraph DotId -> [Char]
56 dotToString dotG = unpack (printDotGraph dotG)
57
58
59 --------------------------
60 -- | PhyloView to DOT | --
61 --------------------------
62
63 -- | From http://haroldcarr.com/posts/2014-02-28-using-graphviz-via-haskell.html & https://hackage.haskell.org/package/graphviz
64
65
66 -- | To create a custom Graphviz's Attribute
67 setAttr :: AttributeName -> T'.Text -> CustomAttribute
68 setAttr k v = customAttribute k v
69
70
71 -- | To create customs Graphviz's Attributes out of some Metrics
72 setAttrFromMetrics :: Map T.Text [Double] -> [CustomAttribute]
73 setAttrFromMetrics a = map (\(k,v) -> setAttr (fromStrict k)
74 $ (pack . unwords)
75 $ map show v) $ toList a
76
77
78 -- | To transform a PhyloBranchId into a DotId
79 toBranchDotId :: PhyloBranchId -> DotId
80 toBranchDotId (lvl,idx) = fromStrict $ T.pack $ (show lvl) ++ (show idx)
81
82
83 -- | To transform a PhyloGroupId into a DotId
84 toNodeDotId :: PhyloGroupId -> DotId
85 toNodeDotId (((d,d'),lvl),idx) = fromStrict $ T.pack $ (show d) ++ (show d') ++ (show lvl) ++ (show idx)
86
87
88 -- | To transform a PhyloPeriodId into a DotId
89 toPeriodDotId :: PhyloPeriodId -> DotId
90 toPeriodDotId (d,d') = fromStrict $ T.pack $ (show d) ++ (show d')
91
92
93 -- | To transform a PhyloPeriodId into a Graphviz's label
94 toPeriodDotLabel ::PhyloPeriodId -> Label
95 toPeriodDotLabel (d,d') = toDotLabel $ T.pack $ (show d) ++ " " ++ (show d')
96
97
98 -- | To get all the Phyloperiods covered by a PhyloView
99 getViewPeriods :: PhyloView -> [PhyloPeriodId]
100 getViewPeriods pv = sortOn fst $ nub $ map (\pn -> (fst . fst) $ pn ^. pn_id) $ pv ^. pv_nodes
101
102
103 -- | To get for each PhyloBranch, their corresponding oldest PhyloNodes
104 getFirstNodes :: Level -> PhyloView -> [(PhyloBranchId,PhyloGroupId)]
105 getFirstNodes lvl pv = concat
106 $ map (\bId -> map (\pn -> (bId,pn ^. pn_id))
107 $ filterNodesByFirstPeriod
108 $ filterNodesByBranch bId
109 $ filterNodesByLevel lvl
110 $ pv ^. pv_nodes) bIds
111 where
112 --------------------------------------
113 bIds :: [PhyloBranchId]
114 bIds = map getBranchId $ filterBranchesByLevel lvl pv
115 --------------------------------------
116
117
118 -- | To transform a Text into a Graphviz's Label
119 toDotLabel :: T.Text -> Label
120 toDotLabel lbl = StrLabel $ fromStrict lbl
121
122
123 -- | To set a Peak Node
124 setPeakDotNode :: PhyloBranch -> Dot DotId
125 setPeakDotNode pb = node (toBranchDotId $ pb ^. pb_id)
126 ([FillColor [toWColor CornSilk], FontName "Arial", FontSize 40, Shape Egg, Style [SItem Bold []], Label (toDotLabel $ pb ^. pb_peak)]
127 <> (setAttrFromMetrics $ pb ^. pb_metrics)
128 <> [ setAttr "nodeType" "peak"
129 , setAttr "branchId" ((pack $ show (fst $ getBranchId pb)) <> (pack $ show (snd $ getBranchId pb)))
130 ])
131
132
133 -- | To set a Peak Edge
134 setPeakDotEdge :: DotId -> DotId -> Dot DotId
135 setPeakDotEdge bId nId = edge bId nId [Width 3, Color [toWColor Black], ArrowHead (AType [(ArrMod FilledArrow RightSide,DotArrow)])]
136
137
138 colorFromDynamics :: Double -> H.Attribute
139 colorFromDynamics d
140 | d == 0 = H.BGColor (toColor PaleGreen)
141 | d == 1 = H.BGColor (toColor SkyBlue)
142 | d == 2 = H.BGColor (toColor LightPink)
143 | otherwise = H.Color (toColor Black)
144
145
146 getGroupDynamic :: [Double] -> H.Attribute
147 getGroupDynamic dy
148 | elem 0 dy = colorFromDynamics 0
149 | elem 1 dy = colorFromDynamics 1
150 | elem 2 dy = colorFromDynamics 2
151 | otherwise = colorFromDynamics 3
152
153
154 -- | To set an HTML table
155 setHtmlTable :: PhyloNode -> H.Label
156 setHtmlTable pn = H.Table H.HTable
157 { H.tableFontAttrs = Just [H.PointSize 14, H.Align H.HLeft]
158 , H.tableAttrs = [H.Border 0, H.CellBorder 0, H.BGColor (toColor White)]
159 , H.tableRows = [header]
160 <> [H.Cells [H.LabelCell [H.Height 10] $ H.Text [H.Str $ fromStrict ""]]]
161 <> (if isNothing $ pn ^. pn_ngrams
162 then []
163 else map ngramsToRow $ splitEvery 4
164 $ reverse $ sortOn (snd . snd)
165 $ zip (fromJust $ pn ^. pn_ngrams) $ zip dynamics inclusion) }
166 where
167 --------------------------------------
168 ngramsToRow :: [(Ngrams,(Double,Double))] -> H.Row
169 ngramsToRow ns = H.Cells $ map (\(n,(d,_)) -> H.LabelCell [H.Align H.HLeft,colorFromDynamics d]
170 $ H.Text [H.Str $ fromStrict n]) ns
171 --------------------------------------
172 inclusion :: [Double]
173 inclusion = (pn ^. pn_metrics) ! "inclusion"
174 --------------------------------------
175 dynamics :: [Double]
176 dynamics = (pn ^. pn_metrics) ! "dynamics"
177 --------------------------------------
178 header :: H.Row
179 header = H.Cells [H.LabelCell [getGroupDynamic dynamics]
180 $ H.Text [H.Str $ (((fromStrict . T.toUpper) $ pn ^. pn_label)
181 <> (fromStrict " ( ")
182 <> (pack $ show (fst $ getNodePeriod pn))
183 <> (fromStrict " , ")
184 <> (pack $ show (snd $ getNodePeriod pn))
185 <> (fromStrict " ) "))]]
186 --------------------------------------
187
188
189 -- | To set a Node
190 setDotNode :: PhyloNode -> Dot DotId
191 setDotNode pn = node (toNodeDotId $ pn ^. pn_id)
192 ([FontName "Arial", Shape Square, toLabel (setHtmlTable pn)]
193 <> [ setAttr "nodeType" "group"
194 , setAttr "from" (pack $ show (fst $ getNodePeriod pn))
195 , setAttr "to" (pack $ show (fst $ getNodePeriod pn))
196 , setAttr "branchId" ((pack $ show (fst $ getNodeBranchId pn)) <> (pack $ show (snd $ getNodeBranchId pn)))
197 ])
198
199
200 -- | To set an Edge
201 setDotEdge :: PhyloEdge -> Dot DotId
202 setDotEdge pe
203 | pe ^. pe_weight == 100 = edge (toNodeDotId $ pe ^. pe_source) (toNodeDotId $ pe ^. pe_target) [Width 2, Color [toWColor Red]]
204 | otherwise = edge (toNodeDotId $ pe ^. pe_source) (toNodeDotId $ pe ^. pe_target) [Width 2, Color [toWColor Black], Constraint True]
205
206
207 -- | To set a Period Edge
208 setDotPeriodEdge :: (PhyloPeriodId,PhyloPeriodId) -> Dot DotId
209 setDotPeriodEdge (prd,prd') = edge (toPeriodDotId prd) (toPeriodDotId prd') [Width 5, Color [toWColor Black]]
210
211
212 -- | To transform a given PhyloView into the corresponding GraphViz Graph (ie: Dot format)
213 viewToDot :: PhyloView -> DotGraph DotId
214 viewToDot pv = digraph ((Str . fromStrict) $ pv ^. pv_title)
215
216 $ do
217
218 -- set the global graph attributes
219
220 graphAttrs ( [Label (toDotLabel $ pv ^. pv_title)]
221 <> [setAttr "description" $ fromStrict $ pv ^. pv_description]
222 <> [setAttr "filiation" $ (pack . show) $ pv ^. pv_filiation]
223 <> (setAttrFromMetrics $ pv ^. pv_metrics)
224 <> [FontSize 30, LabelLoc VTop, NodeSep 1, RankSep [1], Rank SameRank, Splines SplineEdges, Overlap ScaleOverlaps
225 , Ratio FillRatio
226 , Style [SItem Filled []],Color [toWColor White]])
227
228 -- set the peaks
229
230 subgraph (Str "Peaks") $ do
231
232 graphAttrs [Rank SameRank]
233
234 mapM setPeakDotNode $ filterBranchesByLevel (pv ^. pv_level) pv
235
236 -- set the nodes, period by period
237
238 _ <- mapM (\prd ->
239 subgraph (Str $ fromStrict $ T.pack $ "subGraph " ++ (show $ (fst prd)) ++ (show $ (snd prd)))
240
241 $ do
242
243 graphAttrs [Rank SameRank]
244
245 -- set the period label
246
247 node (toPeriodDotId prd) ([Shape Square, FontSize 50, Label (toPeriodDotLabel prd)]
248 <> [setAttr "nodeType" "period",
249 setAttr "from" (fromStrict $ T.pack $ (show $ fst prd)),
250 setAttr "to" (fromStrict $ T.pack $ (show $ snd prd))])
251
252 mapM setDotNode $ filterNodesByPeriod prd $ filterNodesByLevel (pv ^. pv_level) (pv ^.pv_nodes)
253
254 ) $ (pv ^. pv_periods)
255
256 -- set the edges : from peaks to nodes, from nodes to nodes, from periods to periods
257
258 _ <- mapM (\(bId,nId) -> setPeakDotEdge (toBranchDotId bId) (toNodeDotId nId)) $ getFirstNodes (pv ^. pv_level) pv
259
260 _ <- mapM setDotEdge $ filterEdgesByLevel (pv ^. pv_level) $ filterEdgesByType PeriodEdge (pv ^. pv_edges)
261
262 mapM setDotPeriodEdge $ listToSequentialCombi $ (pv ^. pv_periods)
263
264
265
266
267
268
269
270
271
272