src/Gargantext/Core/Viz/Phylo/View/Export.hs

   1 {-|
   2 Module      : Gargantext.Core.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
  14 module Gargantext.Core.Viz.Phylo.View.Export
  15   where
  16
  17 import Control.Lens  hiding (Level)
  18 import Control.Monad
  19 import Data.GraphViz   hiding (DotGraph)
  20 import Data.GraphViz.Attributes.Complete hiding (EdgeType)
  21 import Data.GraphViz.Types.Generalised (DotGraph)
  22 import Data.GraphViz.Types.Monadic
  23 import Data.List        ((++),unwords,concat,sortOn,nub)
  24 import Data.Map         (Map,toList,(!))
  25 import Data.Maybe       (isNothing,fromJust)
  26 import Data.Text.Lazy   (fromStrict, pack, unpack)
  27
  28 import qualified Data.Text as T
  29 import qualified Data.Text.Lazy as T'
  30 import qualified Data.GraphViz.Attributes.HTML as H
  31
  32 import Gargantext.Prelude
  33 import Gargantext.Core.Viz.Phylo hiding (Dot)
  34 import Gargantext.Core.Viz.Phylo.Tools
  35
  36 -- import Debug.Trace (trace)
  37
  38
  39 import Prelude (writeFile)
  40 import System.FilePath
  41
  42 type DotId = T'.Text
  43
  44
  45 ---------------------
  46 -- | Dot to File | --
  47 ---------------------
  48
  49 dotToFile :: FilePath -> DotGraph DotId -> IO ()
  50 dotToFile filePath dotG = writeFile filePath $ dotToString dotG
  51
  52 dotToString :: DotGraph DotId  -> [Char]
  53 dotToString dotG = unpack (printDotGraph dotG)
  54
  55
  56 --------------------------
  57 -- | PhyloView to DOT | --
  58 --------------------------
  59
  60 -- | From http://haroldcarr.com/posts/2014-02-28-using-graphviz-via-haskell.html & https://hackage.haskell.org/package/graphviz
  61
  62
  63 -- | To create a custom Graphviz's Attribute
  64 setAttr :: AttributeName -> T'.Text -> CustomAttribute
  65 setAttr k v = customAttribute k v
  66
  67
  68 -- | To create customs Graphviz's Attributes out of some Metrics
  69 setAttrFromMetrics :: Map T.Text [Double] -> [CustomAttribute]
  70 setAttrFromMetrics a = map (\(k,v) -> setAttr (fromStrict k)
  71                                     $ (pack . unwords)
  72                                     $ map show v) $ toList a
  73
  74
  75 -- | To transform a PhyloBranchId into a DotId
  76 toBranchDotId :: PhyloBranchId -> DotId
  77 toBranchDotId (lvl,idx) = fromStrict $ T.pack $ (show lvl) ++ (show idx)
  78
  79
  80 -- | To transform a PhyloGroupId into a DotId
  81 toNodeDotId :: PhyloGroupId -> DotId
  82 toNodeDotId (((d,d'),lvl),idx) = fromStrict $ T.pack $ (show d) ++ (show d') ++ (show lvl) ++ (show idx)
  83
  84
  85 -- | To transform a PhyloPeriodId into a DotId
  86 toPeriodDotId :: PhyloPeriodId -> DotId
  87 toPeriodDotId (d,d') = fromStrict $ T.pack $ (show d) ++ (show d')
  88
  89
  90 -- | To transform a PhyloPeriodId into a Graphviz's label
  91 toPeriodDotLabel ::PhyloPeriodId -> Label
  92 toPeriodDotLabel (d,d') = toDotLabel $ T.pack $ (show d) ++ " " ++ (show d')
  93
  94
  95 -- | To get all the Phyloperiods covered by a PhyloView
  96 getViewPeriods :: PhyloView -> [PhyloPeriodId]
  97 getViewPeriods pv = sortOn fst $ nub $ map (\pn -> (fst . fst) $ pn ^. pn_id) $ pv ^. pv_nodes
  98
  99
 100 -- | To get for each PhyloBranch, their corresponding oldest PhyloNodes
 101 getFirstNodes :: Level -> PhyloView -> [(PhyloBranchId,PhyloGroupId)]
 102 getFirstNodes lvl pv = concat
 103                      $ map (\bId -> map (\pn -> (bId,pn ^. pn_id))
 104                                   $ filterNodesByFirstPeriod
 105                                   $ filterNodesByBranch bId
 106                                   $ filterNodesByLevel lvl
 107                                   $ pv ^. pv_nodes) bIds
 108     where
 109         --------------------------------------
 110         bIds :: [PhyloBranchId]
 111         bIds = map getBranchId $ filterBranchesByLevel lvl pv
 112         --------------------------------------
 113
 114
 115 -- | To transform a Text into a Graphviz's Label
 116 toDotLabel :: T.Text -> Label
 117 toDotLabel lbl = StrLabel $ fromStrict lbl
 118
 119
 120 -- | To set a Peak Node
 121 setPeakDotNode :: PhyloBranch -> Dot DotId
 122 setPeakDotNode pb = node (toBranchDotId $ pb ^. pb_id)
 123                       ([FillColor [toWColor CornSilk], FontName "Arial", FontSize 40, Shape Egg, Style [SItem Bold []], Label (toDotLabel $ pb ^. pb_peak)]
 124                        <> (setAttrFromMetrics $ pb ^. pb_metrics)
 125                        <> [ setAttr "nodeType" "peak"
 126                           , setAttr "branchId" ((pack $ show (fst $ getBranchId pb)) <> (pack $ show (snd $ getBranchId pb)))
 127                           ])
 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 LightCoral)
 138   | d == 1    = H.BGColor (toColor Khaki)
 139   | d == 2    = H.BGColor (toColor SkyBlue)
 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                       <> [ setAttr "nodeType" "group"
 191                          , setAttr "from" (pack $ show (fst $ getNodePeriod pn))
 192                          , setAttr "to"   (pack $ show (fst $ getNodePeriod pn))
 193                          , setAttr "branchId" ((pack $ show (fst $ getNodeBranchId pn)) <> (pack $ show (snd $ getNodeBranchId pn)))
 194                          ])
 195
 196
 197 -- | To set an Edge
 198 setDotEdge :: PhyloEdge -> Dot DotId
 199 setDotEdge pe
 200   | pe ^. pe_weight == 100 = edge (toNodeDotId $ pe ^. pe_source) (toNodeDotId $ pe ^. pe_target)  [Width 2, Color [toWColor Red]]
 201   | otherwise = edge (toNodeDotId $ pe ^. pe_source) (toNodeDotId $ pe ^. pe_target)  [Width 2, Color [toWColor Black], Constraint True]
 202
 203
 204 -- | To set a Period Edge
 205 setDotPeriodEdge :: (PhyloPeriodId,PhyloPeriodId) -> Dot DotId
 206 setDotPeriodEdge (prd,prd') = edge (toPeriodDotId prd) (toPeriodDotId prd') [Width 5, Color [toWColor Black]]
 207
 208
 209 -- | To transform a given PhyloView into the corresponding GraphViz Graph (ie: Dot format)
 210 viewToDot :: PhyloView -> DotGraph DotId
 211 viewToDot pv = digraph ((Str . fromStrict) $ pv ^. pv_title)
 212
 213              $ do
 214
 215                 -- set the global graph attributes
 216
 217                 graphAttrs ( [Label (toDotLabel $ pv ^. pv_title)]
 218                           <> [setAttr "description" $ fromStrict $ pv ^. pv_description]
 219                           <> [setAttr "filiation"   $ (pack . show) $ pv ^. pv_filiation]
 220                           <> (setAttrFromMetrics $ pv ^. pv_metrics)
 221                           <> [FontSize 30, LabelLoc VTop, NodeSep 1, RankSep [1], Rank SameRank, Splines SplineEdges, Overlap ScaleOverlaps
 222                              , Ratio FillRatio
 223                              , Style [SItem Filled []],Color [toWColor White]])
 224
 225                 -- set the peaks
 226
 227                 subgraph (Str "Peaks") $ do
 228
 229                     graphAttrs [Rank SameRank]
 230
 231                     mapM setPeakDotNode $ filterBranchesByLevel (pv ^. pv_level) pv
 232
 233                 -- set the nodes, period by period
 234
 235                 _ <- mapM (\prd ->
 236                         subgraph (Str $ fromStrict $ T.pack $ "subGraph " ++ (show $ (fst prd)) ++ (show $ (snd prd)))
 237
 238                         $ do
 239
 240                             graphAttrs [Rank SameRank]
 241
 242                             -- set the period label
 243
 244                             node (toPeriodDotId prd) ([Shape Square, FontSize 50, Label (toPeriodDotLabel prd)]
 245                                                    <> [setAttr "nodeType" "period",
 246                                                        setAttr "from" (fromStrict $ T.pack $ (show $ fst prd)),
 247                                                        setAttr "to"   (fromStrict $ T.pack $ (show $ snd prd))])
 248
 249                             mapM setDotNode $ filterNodesByPeriod prd $ filterNodesByLevel (pv ^. pv_level) (pv ^.pv_nodes)
 250
 251                      ) $ (pv ^. pv_periods)
 252
 253                 -- set the edges : from peaks to nodes, from nodes to nodes, from periods to periods
 254
 255                 _ <- mapM (\(bId,nId) -> setPeakDotEdge (toBranchDotId bId) (toNodeDotId nId)) $ getFirstNodes (pv ^. pv_level) pv
 256
 257                 _ <- mapM setDotEdge $ filterEdgesByLevel (pv ^. pv_level) $ filterEdgesByType PeriodEdge (pv ^. pv_edges)
 258
 259                 mapM setDotPeriodEdge $ listToSequentialCombi $ (pv ^. pv_periods)
 260
 261
 262
 263
 264
 265
 266
 267
 268
 269