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