]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/Viz/Phylo/View/Export.hs
fix the diagonal issue
[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 -> DotGraph DotId -> IO ()
51 dotToFile filePath dotG = writeFile filePath $ 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
161 | pe ^. pe_weight == 100 = edge (toNodeDotId $ pe ^. pe_source) (toNodeDotId $ pe ^. pe_target) [Width 2, Color [toWColor Red]]
162 | otherwise = edge (toNodeDotId $ pe ^. pe_source) (toNodeDotId $ pe ^. pe_target) [Width 2, Color [toWColor Black]]
163
164
165 -- | To set a Period Edge
166 setDotPeriodEdge :: (PhyloPeriodId,PhyloPeriodId) -> Dot DotId
167 setDotPeriodEdge (prd,prd') = edge (toPeriodDotId prd) (toPeriodDotId prd') [Width 5, Color [toWColor Black]]
168
169
170 -- | To transform a given PhyloView into the corresponding GraphViz Graph (ie: Dot format)
171 viewToDot :: PhyloView -> DotGraph DotId
172 viewToDot pv = digraph ((Str . fromStrict) $ pv ^. pv_title)
173
174 $ do
175
176 -- set the global graph attributes
177
178 graphAttrs ( [Label (toDotLabel $ pv ^. pv_title)]
179 <> [setAttr "description" $ fromStrict $ pv ^. pv_description]
180 <> [setAttr "filiation" $ (pack . show) $ pv ^. pv_filiation]
181 <> (setAttrFromMetrics $ pv ^. pv_metrics)
182 <> [FontSize 30, LabelLoc VTop, Splines SplineEdges, Overlap ScaleOverlaps,
183 Ratio AutoRatio, Style [SItem Filled []],Color [toWColor White]])
184
185 -- set the peaks
186
187 subgraph (Str "Peaks") $ do
188
189 graphAttrs [Rank SameRank]
190
191 mapM setPeakDotNode $ filterBranchesByLevel (pv ^. pv_level) pv
192
193 -- set the nodes, period by period
194
195 _ <- mapM (\prd ->
196 subgraph (Str $ fromStrict $ T.pack $ "subGraph " ++ (show $ (fst prd)) ++ (show $ (snd prd)))
197
198 $ do
199
200 graphAttrs [Rank SameRank]
201
202 -- set the period label
203
204 node (toPeriodDotId prd) [Shape Square, FontSize 50, Label (toPeriodDotLabel prd)]
205
206 mapM setDotNode $ filterNodesByPeriod prd $ filterNodesByLevel (pv ^. pv_level) (pv ^.pv_nodes)
207
208 ) $ (pv ^. pv_periods)
209
210 -- set the edges : from peaks to nodes, from nodes to nodes, from periods to periods
211
212 _ <- mapM (\(bId,nId) -> setPeakDotEdge (toBranchDotId bId) (toNodeDotId nId)) $ getFirstNodes (pv ^. pv_level) pv
213
214 _ <- mapM setDotEdge $ filterEdgesByLevel (pv ^. pv_level) $ filterEdgesByType PeriodEdge (pv ^. pv_edges)
215
216 mapM setDotPeriodEdge $ listToSequentialCombi $ (pv ^. pv_periods)
217
218
219
220
221
222
223
224
225
226