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