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