]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/Viz/Phylo/View/Export.hs
adapt Main to example
[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
40 import Prelude (writeFile)
41 import System.FilePath
42
43 type DotId = T'.Text
44
45
46 ---------------------
47 -- | Dot to File | --
48 ---------------------
49
50 dotToFile :: FilePath -> FilePath -> DotGraph DotId -> IO ()
51 dotToFile filePath fileName dotG = writeFile (combine filePath fileName) $ dotToString dotG
52
53 dotToString :: DotGraph DotId -> [Char]
54 dotToString dotG = unpack (printDotGraph dotG)
55
56
57 --------------------------
58 -- | PhyloView to DOT | --
59 --------------------------
60
61 -- | From http://haroldcarr.com/posts/2014-02-28-using-graphviz-via-haskell.html & https://hackage.haskell.org/package/graphviz
62
63
64 -- | To create a custom Graphviz's Attribute
65 setAttr :: AttributeName -> T'.Text -> CustomAttribute
66 setAttr k v = customAttribute k v
67
68
69 -- | To create customs Graphviz's Attributes out of some Metrics
70 setAttrFromMetrics :: Map T.Text [Double] -> [CustomAttribute]
71 setAttrFromMetrics a = map (\(k,v) -> setAttr (fromStrict k)
72 $ (pack . unwords)
73 $ map show v) $ toList a
74
75
76 -- | To transform a PhyloBranchId into a DotId
77 toBranchDotId :: PhyloBranchId -> DotId
78 toBranchDotId (lvl,idx) = fromStrict $ T.pack $ (show lvl) ++ (show idx)
79
80
81 -- | To transform a PhyloGroupId into a DotId
82 toNodeDotId :: PhyloGroupId -> DotId
83 toNodeDotId (((d,d'),lvl),idx) = fromStrict $ T.pack $ (show d) ++ (show d') ++ (show lvl) ++ (show idx)
84
85
86 -- | To transform a PhyloPeriodId into a DotId
87 toPeriodDotId :: PhyloPeriodId -> DotId
88 toPeriodDotId (d,d') = fromStrict $ T.pack $ (show d) ++ (show d')
89
90
91 -- | To transform a PhyloPeriodId into a Graphviz's label
92 toPeriodDotLabel ::PhyloPeriodId -> Label
93 toPeriodDotLabel (d,d') = toDotLabel $ T.pack $ (show d) ++ " " ++ (show d')
94
95
96 -- | To get all the Phyloperiods covered by a PhyloView
97 getViewPeriods :: PhyloView -> [PhyloPeriodId]
98 getViewPeriods pv = sortOn fst $ nub $ map (\pn -> (fst . fst) $ pn ^. pn_id) $ pv ^. pv_nodes
99
100
101 -- | To get for each PhyloBranch, their corresponding oldest PhyloNodes
102 getFirstNodes :: Level -> PhyloView -> [(PhyloBranchId,PhyloGroupId)]
103 getFirstNodes lvl pv = concat
104 $ map (\bId -> map (\pn -> (bId,pn ^. pn_id))
105 $ filterNodesByFirstPeriod
106 $ filterNodesByBranch bId
107 $ filterNodesByLevel lvl
108 $ pv ^. pv_nodes) bIds
109 where
110 --------------------------------------
111 bIds :: [PhyloBranchId]
112 bIds = map getBranchId $ filterBranchesByLevel lvl pv
113 --------------------------------------
114
115
116 -- | To transform a Text into a Graphviz's Label
117 toDotLabel :: T.Text -> Label
118 toDotLabel lbl = StrLabel $ fromStrict lbl
119
120
121 -- | To set a Peak Node
122 setPeakDotNode :: PhyloBranch -> Dot DotId
123 setPeakDotNode pb = node (toBranchDotId $ pb ^. pb_id)
124 ([FillColor [toWColor CornSilk], FontName "Arial", FontSize 40, Shape Egg, Style [SItem Bold []], Label (toDotLabel $ pb ^. pb_peak)]
125 <> (setAttrFromMetrics $ pb ^. pb_metrics))
126
127
128 -- | To set a Peak Edge
129 setPeakDotEdge :: DotId -> DotId -> Dot DotId
130 setPeakDotEdge bId nId = edge bId nId [Width 3, Color [toWColor Black], ArrowHead (AType [(ArrMod FilledArrow RightSide,DotArrow)])]
131
132
133 -- | To set an HTML table
134 setHtmlTable :: PhyloNode -> H.Label
135 setHtmlTable pn = H.Table H.HTable
136 { H.tableFontAttrs = Just [H.PointSize 14, H.Align H.HLeft]
137 , H.tableAttrs = [H.Border 0, H.CellBorder 0, H.BGColor (toColor White)]
138 , H.tableRows = [header] <> (if isNothing $ pn ^. pn_ngrams
139 then []
140 else map ngramsToRow $ splitEvery 4 $ fromJust $ pn ^. pn_ngrams) }
141 where
142 --------------------------------------
143 ngramsToRow :: [Ngrams] -> H.Row
144 ngramsToRow ns = H.Cells $ map (\n -> H.LabelCell [H.BAlign H.HLeft] $ H.Text [H.Str $ fromStrict n]) ns
145 --------------------------------------
146 header :: H.Row
147 header = H.Cells [H.LabelCell [H.Color (toColor Black), H.BGColor (toColor Chartreuse2)]
148 $ H.Text [H.Str $ (fromStrict . T.toUpper) $ pn ^. pn_label]]
149 --------------------------------------
150
151
152 -- | To set a Node
153 setDotNode :: PhyloNode -> Dot DotId
154 setDotNode pn = node (toNodeDotId $ pn ^. pn_id)
155 ([FontName "Arial", Shape Square, toLabel (setHtmlTable pn)])
156
157
158 -- | To set an Edge
159 setDotEdge :: PhyloEdge -> Dot DotId
160 setDotEdge pe = edge (toNodeDotId $ pe ^. pe_source) (toNodeDotId $ pe ^. pe_target) [Width 2, Color [toWColor Black]]
161
162
163 -- | To set a Period Edge
164 setDotPeriodEdge :: (PhyloPeriodId,PhyloPeriodId) -> Dot DotId
165 setDotPeriodEdge (prd,prd') = edge (toPeriodDotId prd) (toPeriodDotId prd') [Width 5, Color [toWColor Black]]
166
167
168 -- | To transform a given PhyloView into the corresponding GraphViz Graph (ie: Dot format)
169 viewToDot :: PhyloView -> DotGraph DotId
170 viewToDot pv = digraph ((Str . fromStrict) $ pv ^. pv_title)
171
172 $ do
173
174 -- set the global graph attributes
175
176 graphAttrs ( [Label (toDotLabel $ pv ^. pv_title)]
177 <> [setAttr "description" $ fromStrict $ pv ^. pv_description]
178 <> [setAttr "filiation" $ (pack . show) $ pv ^. pv_filiation]
179 <> (setAttrFromMetrics $ pv ^. pv_metrics)
180 <> [FontSize 30, LabelLoc VTop, Splines SplineEdges, Overlap ScaleOverlaps,
181 Ratio AutoRatio, Style [SItem Filled []],Color [toWColor White]])
182
183 -- set the peaks
184
185 subgraph (Str "Peaks") $ do
186
187 graphAttrs [Rank SameRank]
188
189 mapM setPeakDotNode $ filterBranchesByLevel (pv ^. pv_level) pv
190
191 -- set the nodes, period by period
192
193 _ <- mapM (\prd ->
194 subgraph (Str $ fromStrict $ T.pack $ "subGraph " ++ (show $ (fst prd)) ++ (show $ (snd prd)))
195
196 $ do
197
198 graphAttrs [Rank SameRank]
199
200 -- set the period label
201
202 node (toPeriodDotId prd) [Shape Square, FontSize 50, Label (toPeriodDotLabel prd)]
203
204 mapM setDotNode $ filterNodesByPeriod prd $ filterNodesByLevel (pv ^. pv_level) (pv ^.pv_nodes)
205
206 ) $ (pv ^. pv_periods)
207
208 -- set the edges : from peaks to nodes, from nodes to nodes, from periods to periods
209
210 _ <- mapM (\(bId,nId) -> setPeakDotEdge (toBranchDotId bId) (toNodeDotId nId)) $ getFirstNodes (pv ^. pv_level) pv
211
212 _ <- mapM setDotEdge $ filterEdgesByLevel (pv ^. pv_level) $ filterEdgesByType PeriodEdge (pv ^. pv_edges)
213
214 mapM setDotPeriodEdge $ listToSequentialCombi $ (pv ^. pv_periods)
215
216
217
218
219
220
221
222
223
224