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