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
  23 import Data.GraphViz hiding (DotGraph)
  24 import Data.GraphViz.Attributes.Complete
  25 import Data.GraphViz.Types
  26 import Data.GraphViz.Types.Generalised (DotGraph)
  27 import Data.GraphViz.Types.Monadic
  28 import Data.List      ((++),unwords,concat,sortOn)
  29 import Data.Map       (Map,mapWithKey,elems,toList)
  30 import Data.Maybe     (isJust,fromJust)
  31 import Data.Text      (Text)
  32 import Data.Text.Lazy (Text, fromStrict, pack)
  33
  34 import qualified Data.Text as T
  35 import qualified Data.Text.Lazy as T'
  36
  37 import Gargantext.Prelude
  38 import Gargantext.Viz.Phylo
  39 import Gargantext.Viz.Phylo.Tools
  40
  41 type DotId = T'.Text
  42
  43 --------------------------
  44 -- | PhyloView to SVG | --
  45 --------------------------
  46
  47
  48 viewToSvg v = undefined
  49
  50
  51 --------------------------
  52 -- | PhyloView to DOT | --
  53 --------------------------
  54
  55 -- From http://haroldcarr.com/posts/2014-02-28-using-graphviz-via-haskell.html
  56
  57 setAttr :: AttributeName -> T'.Text -> CustomAttribute
  58 setAttr k v = customAttribute k v
  59
  60 setAttrFromMetrics :: Map T.Text [Double] -> [CustomAttribute]
  61 setAttrFromMetrics attrs = map (\(k,v) -> setAttr (fromStrict k)
  62                                                 $ (pack . unwords)
  63                                                 $ map show v) $ toList attrs
  64 getBranchDotId :: PhyloBranchId -> DotId
  65 getBranchDotId (lvl,idx) = (pack . show) $ (idx + lvl * 1000) * 100000000
  66
  67 getBranchesByLevel :: Level -> PhyloView -> [PhyloBranch]
  68 getBranchesByLevel lvl pv = filter (\pb -> lvl == (fst $ pb ^. pb_id))
  69                           $ pv ^. pv_branches
  70
  71
  72 filterNodesByLevel :: Level -> [PhyloNode] -> [PhyloNode]
  73 filterNodesByLevel lvl pns = filter (\pn -> lvl == ((snd . fst) $ pn ^. pn_id)) pns
  74
  75
  76 filterNodesByBranch :: PhyloBranchId -> [PhyloNode] -> [PhyloNode]
  77 filterNodesByBranch bId pns = filter (\pn -> if isJust $ pn ^. pn_bid
  78                                              then if bId == (fromJust $ pn ^. pn_bid)
  79                                                   then True
  80                                                   else False
  81                                              else False ) pns
  82
  83 filterNodesByFirstPeriod :: [PhyloNode] -> [PhyloNode]
  84 filterNodesByFirstPeriod pns = filter (\pn -> fstPrd == ((fst . fst) $ pn ^. pn_id)) pns
  85     where
  86         --------------------------------------
  87         fstPrd :: (Date,Date)
  88         fstPrd = (head' "filterNodesByFirstPeriod")
  89                $ sortOn fst
  90                $ map (\pn -> (fst . fst) $ pn ^. pn_id) pns
  91         --------------------------------------
  92
  93
  94 getFirstNodes :: Level -> PhyloView -> [(PhyloBranchId,[PhyloGroupId])]
  95 getFirstNodes lvl pv = map (\bId -> (bId, map (\pn -> pn ^. pn_id)
  96                                         $ filterNodesByFirstPeriod
  97                                         $ filterNodesByBranch bId
  98                                         $ filterNodesByLevel lvl
  99                                         $ pv ^. pv_nodes)) bIds
 100     where
 101         --------------------------------------
 102         bIds :: [PhyloBranchId]
 103         bIds = map getBranchId $ getBranchesByLevel lvl pv
 104         --------------------------------------
 105
 106
 107 toDotLabel :: T.Text -> Label
 108 toDotLabel lbl = StrLabel $ fromStrict lbl
 109
 110 setPeakDotNode :: PhyloBranch -> Dot DotId
 111 setPeakDotNode pb = node (getBranchDotId $ pb ^. pb_id)
 112                       ([FillColor [toWColor CornSilk], FontName "Arial", FontSize 40, Shape Egg, Style [SItem Bold []], Label (toDotLabel $ pb ^. pb_label)]
 113                        <> (setAttrFromMetrics $ pb ^. pb_metrics))
 114
 115 setPeakDotEdge ::  DotId -> DotId -> Dot DotId
 116 setPeakDotEdge bId nId = edge bId nId
 117                               [Width 3, Color [toWColor Black], ArrowHead (AType [(ArrMod FilledArrow RightSide,DotArrow)])]
 118
 119 setDotNode :: PhyloNode -> Dot DotId
 120 setDotNode pn = undefined
 121
 122 setDotEdge :: PhyloEdge -> Dot DotId
 123 setDotEdge pe = undefined
 124
 125 setDotTime :: Date -> Date -> DotId
 126 setDotTime d d' = undefined
 127
 128
 129 viewToDot :: PhyloView -> Level -> DotGraph DotId
 130 viewToDot pv lvl = digraph ((Str . fromStrict) $ pv ^. pv_title)
 131                  $ do
 132                     graphAttrs ( [Label (toDotLabel $ pv ^. pv_title)]
 133                               <> [setAttr "description" $ fromStrict $ pv ^. pv_description]
 134                               <> [setAttr "filiation"   $ (pack . show) $ pv ^. pv_filiation]
 135                               <> (setAttrFromMetrics $ pv ^. pv_metrics)
 136                               <> [FontSize (fromIntegral 30), LabelLoc VTop, Splines SplineEdges, Overlap ScaleOverlaps,
 137                                   Ratio AutoRatio, Style [SItem Filled []],Color [toWColor White]])
 138
 139                     mapM setPeakDotNode $ getBranchesByLevel lvl pv
 140
 141
 142
 143
 144
 145
 146
 147
 148