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                        <> [ setAttr "nodeType" "peak"
 129                           , setAttr "branchId" ((pack $ show (fst $ getBranchId pb)) <> (pack $ show (snd $ getBranchId pb)))
 130                           ])
 131
 132
 133 -- | To set a Peak Edge
 134 setPeakDotEdge ::  DotId -> DotId -> Dot DotId
 135 setPeakDotEdge bId nId = edge bId nId [Width 3, Color [toWColor Black], ArrowHead (AType [(ArrMod FilledArrow RightSide,DotArrow)])]
 136
 137
 138 colorFromDynamics :: Double -> H.Attribute
 139 colorFromDynamics d
 140   | d == 0    = H.BGColor (toColor PaleGreen)
 141   | d == 1    = H.BGColor (toColor SkyBlue)
 142   | d == 2    = H.BGColor (toColor LightPink)
 143   | otherwise = H.Color (toColor Black)
 144
 145
 146 getGroupDynamic :: [Double] -> H.Attribute
 147 getGroupDynamic dy
 148   | elem 0 dy = colorFromDynamics 0
 149   | elem 1 dy = colorFromDynamics 1
 150   | elem 2 dy = colorFromDynamics 2
 151   | otherwise = colorFromDynamics 3
 152
 153
 154 -- | To set an HTML table
 155 setHtmlTable :: PhyloNode -> H.Label
 156 setHtmlTable pn = H.Table H.HTable
 157                     { H.tableFontAttrs = Just [H.PointSize 14, H.Align H.HLeft]
 158                     , H.tableAttrs = [H.Border 0, H.CellBorder 0, H.BGColor (toColor White)]
 159                     , H.tableRows = [header]
 160                                   <> [H.Cells [H.LabelCell [H.Height 10] $ H.Text [H.Str $ fromStrict ""]]]
 161                                   <> (if isNothing $ pn ^. pn_ngrams
 162                                       then []
 163                                       else map ngramsToRow $ splitEvery 4
 164                                          $ reverse $ sortOn (snd . snd)
 165                                          $ zip (fromJust $ pn ^. pn_ngrams) $ zip dynamics inclusion) }
 166     where
 167         --------------------------------------
 168         ngramsToRow :: [(Ngrams,(Double,Double))] -> H.Row
 169         ngramsToRow ns = H.Cells $ map (\(n,(d,_)) -> H.LabelCell [H.Align H.HLeft,colorFromDynamics d]
 170                                                 $ H.Text [H.Str $ fromStrict n]) ns
 171         --------------------------------------
 172         inclusion :: [Double]
 173         inclusion =  (pn ^. pn_metrics) ! "inclusion"
 174         --------------------------------------
 175         dynamics :: [Double]
 176         dynamics =  (pn ^. pn_metrics) ! "dynamics"
 177         --------------------------------------
 178         header :: H.Row
 179         header = H.Cells [H.LabelCell [getGroupDynamic dynamics]
 180                                       $ H.Text [H.Str $ (((fromStrict . T.toUpper) $ pn ^. pn_label)
 181                                                       <> (fromStrict " ( ")
 182                                                       <> (pack $ show (fst $ getNodePeriod pn))
 183                                                       <> (fromStrict " , ")
 184                                                       <> (pack $ show (snd $ getNodePeriod pn))
 185                                                       <> (fromStrict " ) "))]]
 186         --------------------------------------
 187
 188
 189 -- | To set a Node
 190 setDotNode :: PhyloNode -> Dot DotId
 191 setDotNode pn = node (toNodeDotId $ pn ^. pn_id)
 192                      ([FontName "Arial", Shape Square, toLabel (setHtmlTable pn)]
 193                       <> [ setAttr "nodeType" "group"
 194                          , setAttr "from" (pack $ show (fst $ getNodePeriod pn))
 195                          , setAttr "to"   (pack $ show (fst $ getNodePeriod pn))
 196                          , setAttr "branchId" ((pack $ show (fst $ getNodeBranchId pn)) <> (pack $ show (snd $ getNodeBranchId pn)))
 197                          ])
 198
 199
 200 -- | To set an Edge
 201 setDotEdge :: PhyloEdge -> Dot DotId
 202 setDotEdge pe
 203   | pe ^. pe_weight == 100 = edge (toNodeDotId $ pe ^. pe_source) (toNodeDotId $ pe ^. pe_target)  [Width 2, Color [toWColor Red]]
 204   | otherwise = edge (toNodeDotId $ pe ^. pe_source) (toNodeDotId $ pe ^. pe_target)  [Width 2, Color [toWColor Black], Constraint True]
 205
 206
 207 -- | To set a Period Edge
 208 setDotPeriodEdge :: (PhyloPeriodId,PhyloPeriodId) -> Dot DotId
 209 setDotPeriodEdge (prd,prd') = edge (toPeriodDotId prd) (toPeriodDotId prd') [Width 5, Color [toWColor Black]]
 210
 211
 212 -- | To transform a given PhyloView into the corresponding GraphViz Graph (ie: Dot format)
 213 viewToDot :: PhyloView -> DotGraph DotId
 214 viewToDot pv = digraph ((Str . fromStrict) $ pv ^. pv_title)
 215
 216              $ do
 217
 218                 -- set the global graph attributes
 219
 220                 graphAttrs ( [Label (toDotLabel $ pv ^. pv_title)]
 221                           <> [setAttr "description" $ fromStrict $ pv ^. pv_description]
 222                           <> [setAttr "filiation"   $ (pack . show) $ pv ^. pv_filiation]
 223                           <> (setAttrFromMetrics $ pv ^. pv_metrics)
 224                           <> [FontSize 30, LabelLoc VTop, NodeSep 1, RankSep [1], Rank SameRank, Splines SplineEdges, Overlap ScaleOverlaps
 225                              , Ratio FillRatio
 226                              , Style [SItem Filled []],Color [toWColor White]])
 227
 228                 -- set the peaks
 229
 230                 subgraph (Str "Peaks") $ do
 231
 232                     graphAttrs [Rank SameRank]
 233
 234                     mapM setPeakDotNode $ filterBranchesByLevel (pv ^. pv_level) pv
 235
 236                 -- set the nodes, period by period
 237
 238                 _ <- mapM (\prd ->
 239                         subgraph (Str $ fromStrict $ T.pack $ "subGraph " ++ (show $ (fst prd)) ++ (show $ (snd prd)))
 240
 241                         $ do
 242
 243                             graphAttrs [Rank SameRank]
 244
 245                             -- set the period label
 246
 247                             node (toPeriodDotId prd) ([Shape Square, FontSize 50, Label (toPeriodDotLabel prd)]
 248                                                    <> [setAttr "nodeType" "period",
 249                                                        setAttr "from" (fromStrict $ T.pack $ (show $ fst prd)),
 250                                                        setAttr "to"   (fromStrict $ T.pack $ (show $ snd prd))])
 251
 252                             mapM setDotNode $ filterNodesByPeriod prd $ filterNodesByLevel (pv ^. pv_level) (pv ^.pv_nodes)
 253
 254                      ) $ (pv ^. pv_periods)
 255
 256                 -- set the edges : from peaks to nodes, from nodes to nodes, from periods to periods
 257
 258                 _ <- mapM (\(bId,nId) -> setPeakDotEdge (toBranchDotId bId) (toNodeDotId nId)) $ getFirstNodes (pv ^. pv_level) pv
 259
 260                 _ <- mapM setDotEdge $ filterEdgesByLevel (pv ^. pv_level) $ filterEdgesByType PeriodEdge (pv ^. pv_edges)
 261
 262                 mapM setDotPeriodEdge $ listToSequentialCombi $ (pv ^. pv_periods)
 263
 264
 265
 266
 267
 268
 269
 270
 271
 272