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