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
  25 import Data.GraphViz.Types.Generalised (DotGraph)
  26 import Data.GraphViz.Types.Monadic
  27 import Data.List       ((++),unwords,concat,sortOn,nub,nubBy)
  28 import Data.Map        (Map,mapWithKey,elems,toList)
  29 import Data.Maybe      (isJust,isNothing,fromJust)
  30 import Data.Text       (Text)
  31 import Data.Text.Lazy  (Text, fromStrict, pack)
  32 import GHC.TypeLits    (KnownNat)
  33
  34 import qualified Data.Text as T
  35 import qualified Data.Text.Lazy as T'
  36 import qualified Data.GraphViz.Attributes.HTML as H
  37
  38 import Gargantext.Prelude
  39 import Gargantext.Viz.Phylo
  40 import Gargantext.Viz.Phylo.Tools
  41
  42 type DotId = T'.Text
  43
  44 --------------------------
  45 -- | PhyloView to SVG | --
  46 --------------------------
  47
  48
  49 viewToSvg v = undefined
  50
  51
  52 --------------------------
  53 -- | PhyloView to DOT | --
  54 --------------------------
  55
  56 -- From http://haroldcarr.com/posts/2014-02-28-using-graphviz-via-haskell.html
  57
  58 setAttr :: AttributeName -> T'.Text -> CustomAttribute
  59 setAttr k v = customAttribute k v
  60
  61 setAttrFromMetrics :: Map T.Text [Double] -> [CustomAttribute]
  62 setAttrFromMetrics attrs = map (\(k,v) -> setAttr (fromStrict k)
  63                                                 $ (pack . unwords)
  64                                                 $ map show v) $ toList attrs
  65
  66 getBranchDotId :: PhyloBranchId -> DotId
  67 getBranchDotId (lvl,idx) = fromStrict $ T.pack $ (show lvl) ++ (show idx)
  68
  69 getNodeDotId :: PhyloGroupId -> DotId
  70 getNodeDotId (((d,d'),lvl),idx) = fromStrict $ T.pack $ (show d) ++ (show d') ++ (show lvl) ++ (show idx)
  71
  72 getPeriodDotId :: PhyloPeriodId -> DotId
  73 getPeriodDotId (d,d') = fromStrict $ T.pack $ (show d) ++ (show d')
  74
  75 getPeriodDotLabel ::PhyloPeriodId -> Label
  76 getPeriodDotLabel (d,d') = toDotLabel $ T.pack $ (show d) ++ " " ++ (show d')
  77
  78 getBranchesByLevel :: Level -> PhyloView -> [PhyloBranch]
  79 getBranchesByLevel lvl pv = filter (\pb -> lvl == (fst $ pb ^. pb_id))
  80                           $ pv ^. pv_branches
  81
  82 filterNodesByPeriod :: PhyloPeriodId -> [PhyloNode] -> [PhyloNode]
  83 filterNodesByPeriod prd pns = filter (\pn -> prd == ((fst . fst) $ pn ^. pn_id)) pns
  84
  85 filterNodesByLevel :: Level -> [PhyloNode] -> [PhyloNode]
  86 filterNodesByLevel lvl pns = filter (\pn -> lvl == ((snd . fst) $ pn ^. pn_id)) pns
  87
  88
  89 filterNodesByBranch :: PhyloBranchId -> [PhyloNode] -> [PhyloNode]
  90 filterNodesByBranch bId pns = filter (\pn -> if isJust $ pn ^. pn_bid
  91                                              then if bId == (fromJust $ pn ^. pn_bid)
  92                                                   then True
  93                                                   else False
  94                                              else False ) pns
  95
  96
  97 filterEdgesByType :: EdgeType -> [PhyloEdge] -> [PhyloEdge]
  98 filterEdgesByType t pes = filter (\pe -> t == (pe ^. pe_type)) pes
  99
 100 filterEdgesByLevel :: Level -> [PhyloEdge] -> [PhyloEdge]
 101 filterEdgesByLevel lvl pes = filter (\pe -> (lvl == ((snd . fst) $ pe ^. pe_source))
 102                                          && (lvl == ((snd . fst) $ pe ^. pe_target))) pes
 103
 104
 105 filterNodesByFirstPeriod :: [PhyloNode] -> [PhyloNode]
 106 filterNodesByFirstPeriod pns = filter (\pn -> fstPrd == ((fst . fst) $ pn ^. pn_id)) pns
 107     where
 108         --------------------------------------
 109         fstPrd :: (Date,Date)
 110         fstPrd = (head' "filterNodesByFirstPeriod")
 111                $ sortOn fst
 112                $ map (\pn -> (fst . fst) $ pn ^. pn_id) pns
 113         --------------------------------------
 114
 115
 116 getViewPeriods :: PhyloView -> [PhyloPeriodId]
 117 getViewPeriods pv = sortOn fst $ nub $ map (\pn -> (fst . fst) $ pn ^. pn_id) $ pv ^. pv_nodes
 118
 119
 120 getFirstNodes :: Level -> PhyloView -> [(PhyloBranchId,PhyloGroupId)]
 121 getFirstNodes lvl pv = concat
 122                      $ map (\bId -> map (\pn -> (bId,pn ^. pn_id))
 123                                   $ filterNodesByFirstPeriod
 124                                   $ filterNodesByBranch bId
 125                                   $ filterNodesByLevel lvl
 126                                   $ pv ^. pv_nodes) bIds
 127     where
 128         --------------------------------------
 129         bIds :: [PhyloBranchId]
 130         bIds = map getBranchId $ getBranchesByLevel lvl pv
 131         --------------------------------------
 132
 133
 134 toDotLabel :: T.Text -> Label
 135 toDotLabel lbl = StrLabel $ fromStrict lbl
 136
 137 setPeakDotNode :: PhyloBranch -> Dot DotId
 138 setPeakDotNode pb = node (getBranchDotId $ pb ^. pb_id)
 139                       ([FillColor [toWColor CornSilk], FontName "Arial", FontSize 40, Shape Egg, Style [SItem Bold []], Label (toDotLabel $ pb ^. pb_label)]
 140                        <> (setAttrFromMetrics $ pb ^. pb_metrics))
 141
 142 setPeakDotEdge ::  DotId -> DotId -> Dot DotId
 143 setPeakDotEdge bId nId = edge bId nId [Width 3, Color [toWColor Black], ArrowHead (AType [(ArrMod FilledArrow RightSide,DotArrow)])]
 144
 145 setHtmlTable :: PhyloNode -> H.Label
 146 setHtmlTable pn = H.Table H.HTable
 147                     { H.tableFontAttrs = Just [H.PointSize 14, H.Align H.HLeft]
 148                     , H.tableAttrs = [H.Border 0, H.CellBorder 0, H.BGColor (toColor White)]
 149                     , H.tableRows = [header] <> (if isNothing $ pn ^. pn_ngrams
 150                                                  then []
 151                                                  else map ngramsToRow $ splitEvery 4 $ fromJust $ pn ^. pn_ngrams) }
 152     where
 153         --------------------------------------
 154         ngramsToRow :: [Ngrams] -> H.Row
 155         ngramsToRow ns = H.Cells $ map (\n -> H.LabelCell [H.BAlign H.HLeft] $ H.Text [H.Str $ fromStrict n]) ns
 156         --------------------------------------
 157         header :: H.Row
 158         header = H.Cells [H.LabelCell [H.Color (toColor Black), H.BGColor (toColor Chartreuse2)]
 159                                       $ H.Text [H.Str $ (fromStrict . T.toUpper) $ pn ^. pn_label]]
 160         --------------------------------------
 161
 162
 163 setDotNode :: PhyloNode -> Dot DotId
 164 setDotNode pn = node (getNodeDotId $ pn ^. pn_id)
 165                      ([FontName "Arial", Shape Square, toLabel (setHtmlTable pn)])
 166
 167
 168 setDotEdge :: PhyloEdge -> Dot DotId
 169 setDotEdge pe = edge (getNodeDotId $ pe ^. pe_source) (getNodeDotId $ pe ^. pe_target)  [Width 2, Color [toWColor Black]]
 170
 171 setDotPeriodEdge :: (PhyloPeriodId,PhyloPeriodId) -> Dot DotId
 172 setDotPeriodEdge (prd,prd') = edge (getPeriodDotId prd) (getPeriodDotId prd') [Width 5, Color [toWColor Black]]
 173
 174
 175 viewToDot :: PhyloView -> Level -> DotGraph DotId
 176 viewToDot pv lvl = digraph ((Str . fromStrict) $ pv ^. pv_title)
 177
 178                  $ do
 179
 180                     -- set the global graph attributes
 181
 182                     graphAttrs ( [Label (toDotLabel $ pv ^. pv_title)]
 183                               <> [setAttr "description" $ fromStrict $ pv ^. pv_description]
 184                               <> [setAttr "filiation"   $ (pack . show) $ pv ^. pv_filiation]
 185                               <> (setAttrFromMetrics $ pv ^. pv_metrics)
 186                               <> [FontSize (fromIntegral 30), LabelLoc VTop, Splines SplineEdges, Overlap ScaleOverlaps,
 187                                   Ratio AutoRatio, Style [SItem Filled []],Color [toWColor White]])
 188
 189                     -- set the peaks
 190
 191                     subgraph (Str "Peaks")
 192
 193                     $ do
 194
 195                         graphAttrs [Rank SameRank]
 196
 197                         mapM setPeakDotNode $ getBranchesByLevel lvl pv
 198
 199                     -- set the nodes, period by period
 200
 201                     mapM (\prd ->
 202                             subgraph (Str $ fromStrict $ T.pack $ "subGraph " ++ (show $ (fst prd)) ++ (show $ (snd prd)))
 203
 204                             $ do
 205
 206                                 graphAttrs [Rank SameRank]
 207
 208                                 -- set the period label
 209
 210                                 node (getPeriodDotId prd) [Shape Square, FontSize 50, Label (getPeriodDotLabel prd)]
 211
 212                                 mapM setDotNode $ filterNodesByPeriod prd $ filterNodesByLevel lvl (pv ^.pv_nodes)
 213
 214                          ) $ getViewPeriods pv
 215
 216                     -- set the edges : from peaks to nodes, from nodes to nodes, from periods to periods
 217
 218                     mapM (\(bId,nId) -> setPeakDotEdge (getBranchDotId bId) (getNodeDotId nId)) $ getFirstNodes lvl pv
 219
 220                     mapM setDotEdge $ filterEdgesByLevel lvl $ filterEdgesByType PeriodEdge (pv ^. pv_edges)
 221
 222                     mapM setDotPeriodEdge $ listToSequentialCombi $ getViewPeriods pv
 223
 224
 225
 226
 227
 228
 229
 230
 231