Working on dot export

package.yaml

@@ -107,6 +107,7 @@ library:
   - fast-logger
   - filelock
   - full-text-search
+  - graphviz
   - http-client
   - http-client-tls
   - http-conduit

src/Gargantext/Viz/Phylo.hs

@@ -393,7 +393,6 @@ data PhyloNode = PhyloNode
   , _pn_childs  :: [PhyloNode]
   } deriving (Generic, Show)
 
-
 ------------------------
 -- | PhyloQueryView | --
 ------------------------

src/Gargantext/Viz/Phylo/Example.hs

@@ -69,7 +69,7 @@ queryViewEx = "level=3"
 
 
 phyloQueryView :: PhyloQueryView
-phyloQueryView = PhyloQueryView 3 Merge False 1 [BranchAge] [defaultSmallBranch] [BranchLabelFreq,GroupLabelCooc] (Just (ByBranchAge,Asc)) Flat True
+phyloQueryView = PhyloQueryView 2 Merge False 1 [BranchAge] [defaultSmallBranch] [BranchLabelFreq,GroupLabelCooc] (Just (ByBranchAge,Asc)) Flat True
 
 
 --------------------------------------------------

src/Gargantext/Viz/Phylo/View/Export.hs

+{-|
+Module      : Gargantext.Viz.Phylo.Tools
+Description : Phylomemy Tools to build/manage it
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+
+
+-}
+
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Gargantext.Viz.Phylo.View.Export
+  where
+
+import Control.Lens  hiding (Level)   
+import Control.Monad 
+
+import Data.GraphViz hiding (DotGraph)
+import Data.GraphViz.Attributes.Complete
+import Data.GraphViz.Types 
+import Data.GraphViz.Types.Generalised (DotGraph)
+import Data.GraphViz.Types.Monadic
+import Data.List      ((++),unwords,concat,sortOn)
+import Data.Map       (Map,mapWithKey,elems,toList)
+import Data.Maybe     (isJust,fromJust)
+import Data.Text      (Text)
+import Data.Text.Lazy (Text, fromStrict, pack)
+
+import qualified Data.Text as T
+import qualified Data.Text.Lazy as T'
+
+import Gargantext.Prelude
+import Gargantext.Viz.Phylo
+import Gargantext.Viz.Phylo.Tools
+
+type DotId = T'.Text
+
+--------------------------
+-- | PhyloView to SVG | --
+--------------------------
+
+
+viewToSvg v = undefined
+
+
+--------------------------
+-- | PhyloView to DOT | --
+--------------------------
+
+-- From http://haroldcarr.com/posts/2014-02-28-using-graphviz-via-haskell.html
+
+setAttr :: AttributeName -> T'.Text -> CustomAttribute
+setAttr k v = customAttribute k v
+
+setAttrFromMetrics :: Map T.Text [Double] -> [CustomAttribute]
+setAttrFromMetrics attrs = map (\(k,v) -> setAttr (fromStrict k) 
+                                                $ (pack . unwords) 
+                                                $ map show v) $ toList attrs
+getBranchDotId :: PhyloBranchId -> DotId
+getBranchDotId (lvl,idx) = (pack . show) $ (idx + lvl * 1000) * 100000000
+
+getBranchesByLevel :: Level -> PhyloView -> [PhyloBranch]
+getBranchesByLevel lvl pv = filter (\pb -> lvl == (fst $ pb ^. pb_id)) 
+                          $ pv ^. pv_branches
+
+
+filterNodesByLevel :: Level -> [PhyloNode] -> [PhyloNode]
+filterNodesByLevel lvl pns = filter (\pn -> lvl == ((snd . fst) $ pn ^. pn_id)) pns
+
+
+filterNodesByBranch :: PhyloBranchId -> [PhyloNode] -> [PhyloNode]
+filterNodesByBranch bId pns = filter (\pn -> if isJust $ pn ^. pn_bid
+                                             then if bId == (fromJust $ pn ^. pn_bid)
+                                                  then True
+                                                  else False
+                                             else False ) pns    
+
+filterNodesByFirstPeriod :: [PhyloNode] -> [PhyloNode]
+filterNodesByFirstPeriod pns = filter (\pn -> fstPrd == ((fst . fst) $ pn ^. pn_id)) pns
+    where 
+        --------------------------------------
+        fstPrd :: (Date,Date)
+        fstPrd = (head' "filterNodesByFirstPeriod")
+               $ sortOn fst 
+               $ map (\pn -> (fst . fst) $ pn ^. pn_id) pns 
+        --------------------------------------
+
+
+getFirstNodes :: Level -> PhyloView -> [(PhyloBranchId,[PhyloGroupId])]
+getFirstNodes lvl pv = map (\bId -> (bId, map (\pn -> pn ^. pn_id)
+                                        $ filterNodesByFirstPeriod 
+                                        $ filterNodesByBranch bId
+                                        $ filterNodesByLevel lvl 
+                                        $ pv ^. pv_nodes)) bIds
+    where
+        --------------------------------------
+        bIds :: [PhyloBranchId]
+        bIds = map getBranchId $ getBranchesByLevel lvl pv
+        --------------------------------------
+
+
+toDotLabel :: T.Text -> Label
+toDotLabel lbl = StrLabel $ fromStrict lbl
+
+setPeakDotNode :: PhyloBranch -> Dot DotId
+setPeakDotNode pb = node (getBranchDotId $ pb ^. pb_id) 
+                      ([FillColor [toWColor CornSilk], FontName "Arial", FontSize 40, Shape Egg, Style [SItem Bold []], Label (toDotLabel $ pb ^. pb_label)]
+                       <> (setAttrFromMetrics $ pb ^. pb_metrics))
+
+setPeakDotEdge ::  DotId -> DotId -> Dot DotId
+setPeakDotEdge bId nId = edge bId nId 
+                              [Width 3, Color [toWColor Black], ArrowHead (AType [(ArrMod FilledArrow RightSide,DotArrow)])]
+
+setDotNode :: PhyloNode -> Dot DotId
+setDotNode pn = undefined
+
+setDotEdge :: PhyloEdge -> Dot DotId
+setDotEdge pe = undefined
+
+setDotTime :: Date -> Date -> DotId
+setDotTime d d' = undefined
+
+
+viewToDot :: PhyloView -> Level -> DotGraph DotId
+viewToDot pv lvl = digraph ((Str . fromStrict) $ pv ^. pv_title) 
+                 $ do
+                    graphAttrs ( [Label (toDotLabel $ 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]])
+
+                    mapM setPeakDotNode $ getBranchesByLevel lvl pv
+
+
+
+
+                
+
+
+
+

src/Gargantext/Viz/Phylo/View/ViewMaker.hs

@@ -27,6 +27,7 @@ import Gargantext.Prelude
 import Gargantext.Viz.Phylo
 import Gargantext.Viz.Phylo.Tools
 import Gargantext.Viz.Phylo.View.Display
+import Gargantext.Viz.Phylo.View.Export
 import Gargantext.Viz.Phylo.View.Filters
 import Gargantext.Viz.Phylo.View.Metrics
 import Gargantext.Viz.Phylo.View.Sort