[Community] Query search contact with text query on documents
[gargantext.git] / src / Gargantext / Viz / Phylo / View / Export.hs
index 72dac0c1da6e967b78e4fb3f4ed741732e5c26ef..decd160315d57808d5e4b03978ba9278f79d61b8 100644 (file)
@@ -10,9 +10,6 @@ Portability : POSIX
 
 -}
 
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE FlexibleContexts  #-}
-{-# LANGUAGE OverloadedStrings #-}
 
 module Gargantext.Viz.Phylo.View.Export
   where
@@ -24,7 +21,7 @@ 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)
-import Data.Map         (Map,toList)
+import Data.Map         (Map,toList,(!))
 import Data.Maybe       (isNothing,fromJust)
 import Data.Text.Lazy   (fromStrict, pack, unpack)
 
@@ -36,6 +33,8 @@ import Gargantext.Prelude
 import Gargantext.Viz.Phylo hiding (Dot)
 import Gargantext.Viz.Phylo.Tools
 
+-- import Debug.Trace (trace)
+
 
 import Prelude (writeFile)
 import System.FilePath
@@ -47,8 +46,11 @@ type DotId = T'.Text
 -- | 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)
 
 
 --------------------------
@@ -119,7 +121,10 @@ toDotLabel lbl = StrLabel $ fromStrict lbl
 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
@@ -127,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
@@ -174,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 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
 
@@ -196,7 +241,10 @@ 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)