[FIX] TFICF condition (better implemented definition)
[gargantext.git] / src / Gargantext / Viz / Phylo / View / Export.hs
index 861a3f4c66dee4345854ba20da67048f12d927e2..decd160315d57808d5e4b03978ba9278f79d61b8 100644 (file)
@@ -10,9 +10,6 @@ Portability : POSIX
 
 -}
 
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE FlexibleContexts  #-}
-{-# LANGUAGE OverloadedStrings #-}
 
 module Gargantext.Viz.Phylo.View.Export
   where
@@ -20,33 +17,40 @@ module Gargantext.Viz.Phylo.View.Export
 import Control.Lens  hiding (Level)   
 import Control.Monad
 import Data.GraphViz   hiding (DotGraph)
-import Data.GraphViz.Attributes.Complete hiding (EdgeType)
-import Data.GraphViz.Types 
+import Data.GraphViz.Attributes.Complete hiding (EdgeType) 
 import Data.GraphViz.Types.Generalised (DotGraph)
 import Data.GraphViz.Types.Monadic
-import Data.List       ((++),unwords,concat,sortOn,nub,nubBy)
-import Data.Map        (Map,mapWithKey,elems,toList)
-import Data.Maybe      (isJust,isNothing,fromJust)
-import Data.Text       (Text)
-import Data.Text.Lazy  (Text, fromStrict, pack)
-import GHC.TypeLits    (KnownNat)
+import Data.List        ((++),unwords,concat,sortOn,nub)
+import Data.Map         (Map,toList,(!))
+import Data.Maybe       (isNothing,fromJust)
+import Data.Text.Lazy   (fromStrict, pack, unpack)
 
 import qualified Data.Text as T
 import qualified Data.Text.Lazy as T'
 import qualified Data.GraphViz.Attributes.HTML as H
 
 import Gargantext.Prelude
-import Gargantext.Viz.Phylo
+import Gargantext.Viz.Phylo hiding (Dot)
 import Gargantext.Viz.Phylo.Tools
 
+-- import Debug.Trace (trace)
+
+
+import Prelude (writeFile)
+import System.FilePath
+
 type DotId = T'.Text
 
---------------------------
--- | PhyloView to SVG | --
---------------------------
 
+---------------------
+-- | Dot to File | --
+---------------------
+
+dotToFile :: FilePath -> DotGraph DotId -> IO ()
+dotToFile filePath dotG = writeFile filePath $ dotToString dotG
 
-viewToSvg v = undefined
+dotToString :: DotGraph DotId  -> [Char]
+dotToString dotG = unpack (printDotGraph dotG)
 
 
 --------------------------
@@ -63,9 +67,9 @@ setAttr k v = customAttribute k v
 
 -- | To create customs Graphviz's Attributes out of some Metrics
 setAttrFromMetrics :: Map T.Text [Double] -> [CustomAttribute]
-setAttrFromMetrics attrs = map (\(k,v) -> setAttr (fromStrict k) 
-                                                $ (pack . unwords) 
-                                                $ map show v) $ toList attrs
+setAttrFromMetrics a = map (\(k,v) -> setAttr (fromStrict k) 
+                                    $ (pack . unwords) 
+                                    $ map show v) $ toList a
 
 
 -- | To transform a PhyloBranchId into a DotId
@@ -116,8 +120,11 @@ toDotLabel lbl = StrLabel $ fromStrict lbl
 -- | To set a Peak Node
 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_label)]
-                       <> (setAttrFromMetrics $ pb ^. pb_metrics))
+                      ([FillColor [toWColor CornSilk], FontName "Arial", FontSize 40, Shape Egg, Style [SItem Bold []], Label (toDotLabel $ pb ^. pb_peak)]
+                       <> (setAttrFromMetrics $ pb ^. pb_metrics)
+                       <> [ setAttr "nodeType" "peak"
+                          , setAttr "branchId" ((pack $ show (fst $ getBranchId pb)) <> (pack $ show (snd $ getBranchId pb)))
+                          ])
 
 
 -- | To set a Peak Edge
@@ -125,34 +132,73 @@ setPeakDotEdge ::  DotId -> DotId -> Dot DotId
 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
@@ -172,8 +218,9 @@ viewToDot pv = digraph ((Str . fromStrict) $ pv ^. pv_title)
                           <> [setAttr "description" $ fromStrict $ pv ^. pv_description]
                           <> [setAttr "filiation"   $ (pack . show) $ pv ^. pv_filiation]
                           <> (setAttrFromMetrics $ pv ^. pv_metrics)
-                          <> [FontSize (fromIntegral 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
 
@@ -185,7 +232,7 @@ viewToDot pv = digraph ((Str . fromStrict) $ pv ^. pv_title)
 
                 -- set the nodes, period by period
 
-                mapM (\prd ->
+                _ <- mapM (\prd ->
                         subgraph (Str $ fromStrict $ T.pack $ "subGraph " ++ (show $ (fst prd)) ++ (show $ (snd prd))) 
 
                         $ do
@@ -194,19 +241,22 @@ viewToDot pv = digraph ((Str . fromStrict) $ pv ^. pv_title)
 
                             -- 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)
                           
-                     ) $ getViewPeriods pv
+                     ) $ (pv ^. pv_periods)
 
                 -- set the edges : from peaks to nodes, from nodes to nodes, from periods to periods 
 
-                mapM (\(bId,nId) -> setPeakDotEdge (toBranchDotId bId) (toNodeDotId nId)) $ getFirstNodes (pv ^. pv_level) pv
+                _ <- mapM (\(bId,nId) -> setPeakDotEdge (toBranchDotId bId) (toNodeDotId nId)) $ getFirstNodes (pv ^. pv_level) pv
 
-                mapM setDotEdge $ filterEdgesByLevel (pv ^. pv_level) $ filterEdgesByType PeriodEdge (pv ^. pv_edges)
+                _ <- mapM setDotEdge $ filterEdgesByLevel (pv ^. pv_level) $ filterEdgesByType PeriodEdge (pv ^. pv_edges)
 
-                mapM setDotPeriodEdge $ listToSequentialCombi $ getViewPeriods pv
+                mapM setDotPeriodEdge $ listToSequentialCombi $ (pv ^. pv_periods)