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