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