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