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