]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/Core/Viz/Phylo/View/Export.hs
Merge branch 'dev-phylo' of https://gitlab.iscpif.fr/gargantext/haskell-gargantext...
[gargantext.git] / src / Gargantext / Core / Viz / Phylo / View / Export.hs
1 {-|
2 Module : Gargantext.Core.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
14 module Gargantext.Core.Viz.Phylo.View.Export
15 where
16
17 import Control.Lens hiding (Level)
18 import Control.Monad
19 import Data.GraphViz hiding (DotGraph)
20 import Data.GraphViz.Attributes.Complete hiding (EdgeType)
21 import Data.GraphViz.Types.Generalised (DotGraph)
22 import Data.GraphViz.Types.Monadic
23 import Data.List ((++),unwords,concat,sortOn,nub)
24 import Data.Map (Map,toList,(!))
25 import Data.Maybe (isNothing)
26 import Data.Text.Lazy (fromStrict, pack, unpack)
27
28 import qualified Data.Text as T
29 import qualified Data.Text.Lazy as T'
30 import qualified Data.GraphViz.Attributes.HTML as H
31
32 import Gargantext.Prelude
33 import Gargantext.Core.Viz.Phylo hiding (Dot)
34 import Gargantext.Core.Viz.Phylo.Tools
35
36 -- import Debug.Trace (trace)
37
38
39 import Prelude (writeFile)
40 import System.FilePath
41
42 type DotId = T'.Text
43
44
45 ---------------------
46 -- | Dot to File | --
47 ---------------------
48
49 dotToFile :: FilePath -> DotGraph DotId -> IO ()
50 dotToFile filePath dotG = writeFile filePath $ dotToString dotG
51
52 dotToString :: DotGraph DotId -> [Char]
53 dotToString dotG = unpack (printDotGraph dotG)
54
55
56 --------------------------
57 -- | PhyloView to DOT | --
58 --------------------------
59
60 -- | From http://haroldcarr.com/posts/2014-02-28-using-graphviz-via-haskell.html & https://hackage.haskell.org/package/graphviz
61
62
63 -- | To create a custom Graphviz's Attribute
64 setAttr :: AttributeName -> T'.Text -> CustomAttribute
65 setAttr k v = customAttribute k v
66
67
68 -- | To create customs Graphviz's Attributes out of some Metrics
69 setAttrFromMetrics :: Map T.Text [Double] -> [CustomAttribute]
70 setAttrFromMetrics a = map (\(k,v) -> setAttr (fromStrict k)
71 $ (pack . unwords)
72 $ map show v) $ toList a
73
74
75 -- | To transform a PhyloBranchId into a DotId
76 toBranchDotId :: PhyloBranchId -> DotId
77 toBranchDotId (lvl,idx) = fromStrict $ T.pack $ (show lvl) ++ (show idx)
78
79
80 -- | To transform a PhyloGroupId into a DotId
81 toNodeDotId :: PhyloGroupId -> DotId
82 toNodeDotId (((d,d'),lvl),idx) = fromStrict $ T.pack $ (show d) ++ (show d') ++ (show lvl) ++ (show idx)
83
84
85 -- | To transform a PhyloPeriodId into a DotId
86 toPeriodDotId :: PhyloPeriodId -> DotId
87 toPeriodDotId (d,d') = fromStrict $ T.pack $ (show d) ++ (show d')
88
89
90 -- | To transform a PhyloPeriodId into a Graphviz's label
91 toPeriodDotLabel ::PhyloPeriodId -> Label
92 toPeriodDotLabel (d,d') = toDotLabel $ T.pack $ (show d) ++ " " ++ (show d')
93
94
95 -- | To get all the Phyloperiods covered by a PhyloView
96 getViewPeriods :: PhyloView -> [PhyloPeriodId]
97 getViewPeriods pv = sortOn fst $ nub $ map (\pn -> (fst . fst) $ pn ^. pn_id) $ pv ^. pv_nodes
98
99
100 -- | To get for each PhyloBranch, their corresponding oldest PhyloNodes
101 getFirstNodes :: Level -> PhyloView -> [(PhyloBranchId,PhyloGroupId)]
102 getFirstNodes lvl pv = concat
103 $ map (\bId -> map (\pn -> (bId,pn ^. pn_id))
104 $ filterNodesByFirstPeriod
105 $ filterNodesByBranch bId
106 $ filterNodesByLevel lvl
107 $ pv ^. pv_nodes) bIds
108 where
109 --------------------------------------
110 bIds :: [PhyloBranchId]
111 bIds = map getBranchId $ filterBranchesByLevel lvl pv
112 --------------------------------------
113
114
115 -- | To transform a Text into a Graphviz's Label
116 toDotLabel :: T.Text -> Label
117 toDotLabel lbl = StrLabel $ fromStrict lbl
118
119
120 -- | To set a Peak Node
121 setPeakDotNode :: PhyloBranch -> Dot DotId
122 setPeakDotNode pb = node (toBranchDotId $ pb ^. pb_id)
123 ([FillColor [toWColor CornSilk], FontName "Arial", FontSize 40, Shape Egg, Style [SItem Bold []], Label (toDotLabel $ pb ^. pb_peak)]
124 <> (setAttrFromMetrics $ pb ^. pb_metrics)
125 <> [ setAttr "nodeType" "peak"
126 , setAttr "branchId" ((pack $ show (fst $ getBranchId pb)) <> (pack $ show (snd $ getBranchId pb)))
127 ])
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 LightCoral)
138 | d == 1 = H.BGColor (toColor Khaki)
139 | d == 2 = H.BGColor (toColor SkyBlue)
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 <> [ setAttr "nodeType" "group"
191 , setAttr "from" (pack $ show (fst $ getNodePeriod pn))
192 , setAttr "to" (pack $ show (fst $ getNodePeriod pn))
193 , setAttr "branchId" ((pack $ show (fst $ getNodeBranchId pn)) <> (pack $ show (snd $ getNodeBranchId pn)))
194 ])
195
196
197 -- | To set an Edge
198 setDotEdge :: PhyloEdge -> Dot DotId
199 setDotEdge pe
200 | pe ^. pe_weight == 100 = edge (toNodeDotId $ pe ^. pe_source) (toNodeDotId $ pe ^. pe_target) [Width 2, Color [toWColor Red]]
201 | otherwise = edge (toNodeDotId $ pe ^. pe_source) (toNodeDotId $ pe ^. pe_target) [Width 2, Color [toWColor Black], Constraint True]
202
203
204 -- | To set a Period Edge
205 setDotPeriodEdge :: (PhyloPeriodId,PhyloPeriodId) -> Dot DotId
206 setDotPeriodEdge (prd,prd') = edge (toPeriodDotId prd) (toPeriodDotId prd') [Width 5, Color [toWColor Black]]
207
208
209 -- | To transform a given PhyloView into the corresponding GraphViz Graph (ie: Dot format)
210 viewToDot :: PhyloView -> DotGraph DotId
211 viewToDot pv = digraph ((Str . fromStrict) $ pv ^. pv_title)
212
213 $ do
214
215 -- set the global graph attributes
216
217 graphAttrs ( [Label (toDotLabel $ pv ^. pv_title)]
218 <> [setAttr "description" $ fromStrict $ pv ^. pv_description]
219 <> [setAttr "filiation" $ (pack . show) $ pv ^. pv_filiation]
220 <> (setAttrFromMetrics $ pv ^. pv_metrics)
221 <> [FontSize 30, LabelLoc VTop, NodeSep 1, RankSep [1], Rank SameRank, Splines SplineEdges, Overlap ScaleOverlaps
222 , Ratio FillRatio
223 , Style [SItem Filled []],Color [toWColor White]])
224
225 -- set the peaks
226
227 subgraph (Str "Peaks") $ do
228
229 graphAttrs [Rank SameRank]
230
231 mapM setPeakDotNode $ filterBranchesByLevel (pv ^. pv_level) pv
232
233 -- set the nodes, period by period
234
235 _ <- mapM (\prd ->
236 subgraph (Str $ fromStrict $ T.pack $ "subGraph " ++ (show $ (fst prd)) ++ (show $ (snd prd)))
237
238 $ do
239
240 graphAttrs [Rank SameRank]
241
242 -- set the period label
243
244 node (toPeriodDotId prd) ([Shape Square, FontSize 50, Label (toPeriodDotLabel prd)]
245 <> [setAttr "nodeType" "period",
246 setAttr "from" (fromStrict $ T.pack $ (show $ fst prd)),
247 setAttr "to" (fromStrict $ T.pack $ (show $ snd prd))])
248
249 mapM setDotNode $ filterNodesByPeriod prd $ filterNodesByLevel (pv ^. pv_level) (pv ^.pv_nodes)
250
251 ) $ (pv ^. pv_periods)
252
253 -- set the edges : from peaks to nodes, from nodes to nodes, from periods to periods
254
255 _ <- mapM (\(bId,nId) -> setPeakDotEdge (toBranchDotId bId) (toNodeDotId nId)) $ getFirstNodes (pv ^. pv_level) pv
256
257 _ <- mapM setDotEdge $ filterEdgesByLevel (pv ^. pv_level) $ filterEdgesByType PeriodEdge (pv ^. pv_edges)
258
259 mapM setDotPeriodEdge $ listToSequentialCombi $ (pv ^. pv_periods)
260
261
262
263
264
265
266
267
268
269