]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/Viz/Phylo/View/Export.hs
Merge remote-tracking branch 'home/dev' into dev-merge
[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
129
130 -- | To set a Peak Edge
131 setPeakDotEdge :: DotId -> DotId -> Dot DotId
132 setPeakDotEdge bId nId = edge bId nId [Width 3, Color [toWColor Black], ArrowHead (AType [(ArrMod FilledArrow RightSide,DotArrow)])]
133
134
135 colorFromDynamics :: Double -> H.Attribute
136 colorFromDynamics d
137 | d == 0 = H.BGColor (toColor PaleGreen)
138 | d == 1 = H.BGColor (toColor SkyBlue)
139 | d == 2 = H.BGColor (toColor LightPink)
140 | otherwise = H.Color (toColor Black)
141
142
143 getGroupDynamic :: [Double] -> H.Attribute
144 getGroupDynamic dy
145 | elem 0 dy = colorFromDynamics 0
146 | elem 1 dy = colorFromDynamics 1
147 | elem 2 dy = colorFromDynamics 2
148 | otherwise = colorFromDynamics 3
149
150
151 -- | To set an HTML table
152 setHtmlTable :: PhyloNode -> H.Label
153 setHtmlTable pn = H.Table H.HTable
154 { H.tableFontAttrs = Just [H.PointSize 14, H.Align H.HLeft]
155 , H.tableAttrs = [H.Border 0, H.CellBorder 0, H.BGColor (toColor White)]
156 , H.tableRows = [header]
157 <> [H.Cells [H.LabelCell [H.Height 10] $ H.Text [H.Str $ fromStrict ""]]]
158 <> (if isNothing $ pn ^. pn_ngrams
159 then []
160 else map ngramsToRow $ splitEvery 4
161 $ reverse $ sortOn (snd . snd)
162 $ zip (fromJust $ pn ^. pn_ngrams) $ zip dynamics inclusion) }
163 where
164 --------------------------------------
165 ngramsToRow :: [(Ngrams,(Double,Double))] -> H.Row
166 ngramsToRow ns = H.Cells $ map (\(n,(d,_)) -> H.LabelCell [H.Align H.HLeft,colorFromDynamics d]
167 $ H.Text [H.Str $ fromStrict n]) ns
168 --------------------------------------
169 inclusion :: [Double]
170 inclusion = (pn ^. pn_metrics) ! "inclusion"
171 --------------------------------------
172 dynamics :: [Double]
173 dynamics = (pn ^. pn_metrics) ! "dynamics"
174 --------------------------------------
175 header :: H.Row
176 header = H.Cells [H.LabelCell [getGroupDynamic dynamics]
177 $ H.Text [H.Str $ (((fromStrict . T.toUpper) $ pn ^. pn_label)
178 <> (fromStrict " ( ")
179 <> (pack $ show (fst $ getNodePeriod pn))
180 <> (fromStrict " , ")
181 <> (pack $ show (snd $ getNodePeriod pn))
182 <> (fromStrict " ) "))]]
183 --------------------------------------
184
185
186 -- | To set a Node
187 setDotNode :: PhyloNode -> Dot DotId
188 setDotNode pn = node (toNodeDotId $ pn ^. pn_id)
189 ([FontName "Arial", Shape Square, toLabel (setHtmlTable pn)])
190
191
192 -- | To set an Edge
193 setDotEdge :: PhyloEdge -> Dot DotId
194 setDotEdge pe
195 | pe ^. pe_weight == 100 = edge (toNodeDotId $ pe ^. pe_source) (toNodeDotId $ pe ^. pe_target) [Width 2, Color [toWColor Red]]
196 | otherwise = edge (toNodeDotId $ pe ^. pe_source) (toNodeDotId $ pe ^. pe_target) [Width 2, Color [toWColor Black]]
197
198
199 -- | To set a Period Edge
200 setDotPeriodEdge :: (PhyloPeriodId,PhyloPeriodId) -> Dot DotId
201 setDotPeriodEdge (prd,prd') = edge (toPeriodDotId prd) (toPeriodDotId prd') [Width 5, Color [toWColor Black]]
202
203
204 -- | To transform a given PhyloView into the corresponding GraphViz Graph (ie: Dot format)
205 viewToDot :: PhyloView -> DotGraph DotId
206 viewToDot pv = digraph ((Str . fromStrict) $ pv ^. pv_title)
207
208 $ do
209
210 -- set the global graph attributes
211
212 graphAttrs ( [Label (toDotLabel $ pv ^. pv_title)]
213 <> [setAttr "description" $ fromStrict $ pv ^. pv_description]
214 <> [setAttr "filiation" $ (pack . show) $ pv ^. pv_filiation]
215 <> (setAttrFromMetrics $ pv ^. pv_metrics)
216 <> [FontSize 30, LabelLoc VTop, Splines SplineEdges, Overlap ScaleOverlaps,
217 Ratio AutoRatio, Style [SItem Filled []],Color [toWColor White]])
218
219 -- set the peaks
220
221 subgraph (Str "Peaks") $ do
222
223 graphAttrs [Rank SameRank]
224
225 mapM setPeakDotNode $ filterBranchesByLevel (pv ^. pv_level) pv
226
227 -- set the nodes, period by period
228
229 _ <- mapM (\prd ->
230 subgraph (Str $ fromStrict $ T.pack $ "subGraph " ++ (show $ (fst prd)) ++ (show $ (snd prd)))
231
232 $ do
233
234 graphAttrs [Rank SameRank]
235
236 -- set the period label
237
238 node (toPeriodDotId prd) [Shape Square, FontSize 50, Label (toPeriodDotLabel prd)]
239
240 mapM setDotNode $ filterNodesByPeriod prd $ filterNodesByLevel (pv ^. pv_level) (pv ^.pv_nodes)
241
242 ) $ (pv ^. pv_periods)
243
244 -- set the edges : from peaks to nodes, from nodes to nodes, from periods to periods
245
246 _ <- mapM (\(bId,nId) -> setPeakDotEdge (toBranchDotId bId) (toNodeDotId nId)) $ getFirstNodes (pv ^. pv_level) pv
247
248 _ <- mapM setDotEdge $ filterEdgesByLevel (pv ^. pv_level) $ filterEdgesByType PeriodEdge (pv ^. pv_edges)
249
250 mapM setDotPeriodEdge $ listToSequentialCombi $ (pv ^. pv_periods)
251
252
253
254
255
256
257
258
259
260