-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE OverloadedStrings #-}
module Gargantext.Viz.Phylo.View.Export
where
import Data.GraphViz.Types.Generalised (DotGraph)
import Data.GraphViz.Types.Monadic
import Data.List ((++),unwords,concat,sortOn,nub)
-import Data.Map (Map,toList)
+import Data.Map (Map,toList,(!))
import Data.Maybe (isNothing,fromJust)
import Data.Text.Lazy (fromStrict, pack, unpack)
import Gargantext.Viz.Phylo hiding (Dot)
import Gargantext.Viz.Phylo.Tools
+-- import Debug.Trace (trace)
+
import Prelude (writeFile)
import System.FilePath
-- | Dot to File | --
---------------------
-dotToFile :: FilePath -> FilePath -> DotGraph DotId -> IO ()
-dotToFile filePath fileName dotG = writeFile (combine filePath fileName) $ unpack (printDotGraph dotG)
+dotToFile :: FilePath -> DotGraph DotId -> IO ()
+dotToFile filePath dotG = writeFile filePath $ dotToString dotG
+
+dotToString :: DotGraph DotId -> [Char]
+dotToString dotG = unpack (printDotGraph dotG)
--------------------------
setPeakDotNode :: PhyloBranch -> Dot DotId
setPeakDotNode pb = node (toBranchDotId $ pb ^. pb_id)
([FillColor [toWColor CornSilk], FontName "Arial", FontSize 40, Shape Egg, Style [SItem Bold []], Label (toDotLabel $ pb ^. pb_peak)]
- <> (setAttrFromMetrics $ pb ^. pb_metrics))
+ <> (setAttrFromMetrics $ pb ^. pb_metrics)
+ <> [ setAttr "nodeType" "peak"
+ , setAttr "branchId" ((pack $ show (fst $ getBranchId pb)) <> (pack $ show (snd $ getBranchId pb)))
+ ])
-- | To set a Peak Edge
setPeakDotEdge bId nId = edge bId nId [Width 3, Color [toWColor Black], ArrowHead (AType [(ArrMod FilledArrow RightSide,DotArrow)])]
+colorFromDynamics :: Double -> H.Attribute
+colorFromDynamics d
+ | d == 0 = H.BGColor (toColor LightCoral)
+ | d == 1 = H.BGColor (toColor Khaki)
+ | d == 2 = H.BGColor (toColor SkyBlue)
+ | otherwise = H.Color (toColor Black)
+
+
+getGroupDynamic :: [Double] -> H.Attribute
+getGroupDynamic dy
+ | elem 0 dy = colorFromDynamics 0
+ | elem 1 dy = colorFromDynamics 1
+ | elem 2 dy = colorFromDynamics 2
+ | otherwise = colorFromDynamics 3
+
+
-- | To set an HTML table
setHtmlTable :: PhyloNode -> H.Label
setHtmlTable pn = H.Table H.HTable
{ H.tableFontAttrs = Just [H.PointSize 14, H.Align H.HLeft]
, H.tableAttrs = [H.Border 0, H.CellBorder 0, H.BGColor (toColor White)]
- , H.tableRows = [header] <> (if isNothing $ pn ^. pn_ngrams
- then []
- else map ngramsToRow $ splitEvery 4 $ fromJust $ pn ^. pn_ngrams) }
+ , H.tableRows = [header]
+ <> [H.Cells [H.LabelCell [H.Height 10] $ H.Text [H.Str $ fromStrict ""]]]
+ <> (if isNothing $ pn ^. pn_ngrams
+ then []
+ else map ngramsToRow $ splitEvery 4
+ $ reverse $ sortOn (snd . snd)
+ $ zip (fromJust $ pn ^. pn_ngrams) $ zip dynamics inclusion) }
where
--------------------------------------
- ngramsToRow :: [Ngrams] -> H.Row
- ngramsToRow ns = H.Cells $ map (\n -> H.LabelCell [H.BAlign H.HLeft] $ H.Text [H.Str $ fromStrict n]) ns
+ ngramsToRow :: [(Ngrams,(Double,Double))] -> H.Row
+ ngramsToRow ns = H.Cells $ map (\(n,(d,_)) -> H.LabelCell [H.Align H.HLeft,colorFromDynamics d]
+ $ H.Text [H.Str $ fromStrict n]) ns
+ --------------------------------------
+ inclusion :: [Double]
+ inclusion = (pn ^. pn_metrics) ! "inclusion"
+ --------------------------------------
+ dynamics :: [Double]
+ dynamics = (pn ^. pn_metrics) ! "dynamics"
--------------------------------------
header :: H.Row
- header = H.Cells [H.LabelCell [H.Color (toColor Black), H.BGColor (toColor Chartreuse2)]
- $ H.Text [H.Str $ (fromStrict . T.toUpper) $ pn ^. pn_label]]
+ header = H.Cells [H.LabelCell [getGroupDynamic dynamics]
+ $ H.Text [H.Str $ (((fromStrict . T.toUpper) $ pn ^. pn_label)
+ <> (fromStrict " ( ")
+ <> (pack $ show (fst $ getNodePeriod pn))
+ <> (fromStrict " , ")
+ <> (pack $ show (snd $ getNodePeriod pn))
+ <> (fromStrict " ) "))]]
--------------------------------------
-- | To set a Node
setDotNode :: PhyloNode -> Dot DotId
setDotNode pn = node (toNodeDotId $ pn ^. pn_id)
- ([FontName "Arial", Shape Square, toLabel (setHtmlTable pn)])
+ ([FontName "Arial", Shape Square, toLabel (setHtmlTable pn)]
+ <> [ setAttr "nodeType" "group"
+ , setAttr "from" (pack $ show (fst $ getNodePeriod pn))
+ , setAttr "to" (pack $ show (fst $ getNodePeriod pn))
+ , setAttr "branchId" ((pack $ show (fst $ getNodeBranchId pn)) <> (pack $ show (snd $ getNodeBranchId pn)))
+ ])
-- | To set an Edge
setDotEdge :: PhyloEdge -> Dot DotId
-setDotEdge pe = edge (toNodeDotId $ pe ^. pe_source) (toNodeDotId $ pe ^. pe_target) [Width 2, Color [toWColor Black]]
+setDotEdge pe
+ | pe ^. pe_weight == 100 = edge (toNodeDotId $ pe ^. pe_source) (toNodeDotId $ pe ^. pe_target) [Width 2, Color [toWColor Red]]
+ | otherwise = edge (toNodeDotId $ pe ^. pe_source) (toNodeDotId $ pe ^. pe_target) [Width 2, Color [toWColor Black], Constraint True]
-- | To set a Period Edge
<> [setAttr "description" $ fromStrict $ pv ^. pv_description]
<> [setAttr "filiation" $ (pack . show) $ pv ^. pv_filiation]
<> (setAttrFromMetrics $ pv ^. pv_metrics)
- <> [FontSize 30, LabelLoc VTop, Splines SplineEdges, Overlap ScaleOverlaps,
- Ratio AutoRatio, Style [SItem Filled []],Color [toWColor White]])
+ <> [FontSize 30, LabelLoc VTop, NodeSep 1, RankSep [1], Rank SameRank, Splines SplineEdges, Overlap ScaleOverlaps
+ , Ratio FillRatio
+ , Style [SItem Filled []],Color [toWColor White]])
-- set the peaks
-- set the period label
- node (toPeriodDotId prd) [Shape Square, FontSize 50, Label (toPeriodDotLabel prd)]
+ node (toPeriodDotId prd) ([Shape Square, FontSize 50, Label (toPeriodDotLabel prd)]
+ <> [setAttr "nodeType" "period",
+ setAttr "from" (fromStrict $ T.pack $ (show $ fst prd)),
+ setAttr "to" (fromStrict $ T.pack $ (show $ snd prd))])
mapM setDotNode $ filterNodesByPeriod prd $ filterNodesByLevel (pv ^. pv_level) (pv ^.pv_nodes)