Add the dot export

src/Gargantext/Viz/Phylo.hs

@@ -349,7 +349,7 @@ data PhyloQueryBuild = PhyloQueryBuild
 
 -- | To choose the Phylo edge you want to export : --> <-- <--> <=>
 data Filiation = Ascendant | Descendant | Merge | Complete deriving (Generic, Show)
-data EdgeType  = PeriodEdge | LevelEdge deriving (Generic, Show)
+data EdgeType  = PeriodEdge | LevelEdge deriving (Generic, Show, Eq)
 
 -------------------
 -- | PhyloView | --

src/Gargantext/Viz/Phylo/Tools.hs

@@ -20,7 +20,7 @@ module Gargantext.Viz.Phylo.Tools
   where
 
 import Control.Lens         hiding (both, Level, Empty)
-import Data.List            (filter, intersect, (++), sort, null, tail, last, tails, delete, nub, concat, sortOn)
+import Data.List            (filter, intersect, (++), sort, null, tail, last, tails, delete, nub, concat, sortOn, nubBy)
 import Data.Maybe           (mapMaybe,fromMaybe)
 import Data.Map             (Map, mapKeys, member, (!))
 import Data.Set             (Set)
@@ -110,6 +110,11 @@ listToDirectedCombiWith :: Eq a => forall b. (a -> b) -> [a] -> [(b,b)]
 listToDirectedCombiWith f l = [(f x,f y) | x <- l, y <- l, x /= y]
 
 
+-- | To get the sequential combinations of an order list
+listToSequentialCombi :: Eq a => [a] -> [(a,a)]
+listToSequentialCombi l = nubBy (\x y -> fst x == fst y) $ listToUnDirectedCombi l
+
+
 -- | To get all combinations of a list with no repetition
 listToUnDirectedCombi :: [a] -> [(a,a)]
 listToUnDirectedCombi l = [ (x,y) | (x:rest) <- tails l,  y <- rest ]

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

@@ -18,21 +18,22 @@ 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 Control.Monad
+import Data.GraphViz   hiding (DotGraph)
+import Data.GraphViz.Attributes.Complete hiding (EdgeType)
 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 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 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
@@ -61,13 +62,25 @@ 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
+getBranchDotId (lvl,idx) = fromStrict $ T.pack $ (show lvl) ++ (show idx)
+
+getNodeDotId :: PhyloGroupId -> DotId
+getNodeDotId (((d,d'),lvl),idx) = fromStrict $ T.pack $ (show d) ++ (show d') ++ (show lvl) ++ (show idx)
+
+getPeriodDotId :: PhyloPeriodId -> DotId
+getPeriodDotId (d,d') = fromStrict $ T.pack $ (show d) ++ (show d')
+
+getPeriodDotLabel ::PhyloPeriodId -> Label
+getPeriodDotLabel (d,d') = toDotLabel $ T.pack $ (show d) ++ " " ++ (show d')
 
 getBranchesByLevel :: Level -> PhyloView -> [PhyloBranch]
 getBranchesByLevel lvl pv = filter (\pb -> lvl == (fst $ pb ^. pb_id)) 
                           $ pv ^. pv_branches
 
+filterNodesByPeriod :: PhyloPeriodId -> [PhyloNode] -> [PhyloNode]
+filterNodesByPeriod prd pns = filter (\pn -> prd == ((fst . fst) $ pn ^. pn_id)) pns
 
 filterNodesByLevel :: Level -> [PhyloNode] -> [PhyloNode]
 filterNodesByLevel lvl pns = filter (\pn -> lvl == ((snd . fst) $ pn ^. pn_id)) pns
@@ -78,7 +91,16 @@ filterNodesByBranch bId pns = filter (\pn -> if isJust $ pn ^. pn_bid
                                              then if bId == (fromJust $ pn ^. pn_bid)
                                                   then True
                                                   else False
-                                             else False ) pns    
+                                             else False ) pns   
+
+
+filterEdgesByType :: EdgeType -> [PhyloEdge] -> [PhyloEdge]
+filterEdgesByType t pes = filter (\pe -> t == (pe ^. pe_type)) pes
+
+filterEdgesByLevel :: Level -> [PhyloEdge] -> [PhyloEdge]
+filterEdgesByLevel lvl pes = filter (\pe -> (lvl == ((snd . fst) $ pe ^. pe_source))
+                                         && (lvl == ((snd . fst) $ pe ^. pe_target))) pes
+
 
 filterNodesByFirstPeriod :: [PhyloNode] -> [PhyloNode]
 filterNodesByFirstPeriod pns = filter (\pn -> fstPrd == ((fst . fst) $ pn ^. pn_id)) pns
@@ -91,12 +113,17 @@ filterNodesByFirstPeriod pns = filter (\pn -> fstPrd == ((fst . fst) $ pn ^. pn_
         --------------------------------------
 
 
-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
+getViewPeriods :: PhyloView -> [PhyloPeriodId]
+getViewPeriods pv = sortOn fst $ nub $ map (\pn -> (fst . fst) $ pn ^. pn_id) $ pv ^. pv_nodes
+
+
+getFirstNodes :: Level -> PhyloView -> [(PhyloBranchId,PhyloGroupId)]
+getFirstNodes lvl pv = concat
+                     $ map (\bId -> map (\pn -> (bId,pn ^. pn_id))
+                                  $ filterNodesByFirstPeriod 
+                                  $ filterNodesByBranch bId
+                                  $ filterNodesByLevel lvl 
+                                  $ pv ^. pv_nodes) bIds
     where
         --------------------------------------
         bIds :: [PhyloBranchId]
@@ -113,22 +140,45 @@ setPeakDotNode pb = node (getBranchDotId $ pb ^. pb_id)
                        <> (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)])]
+setPeakDotEdge bId nId = edge bId nId [Width 3, Color [toWColor Black], ArrowHead (AType [(ArrMod FilledArrow RightSide,DotArrow)])]
+
+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) }
+    where
+        --------------------------------------
+        ngramsToRow :: [Ngrams] -> H.Row
+        ngramsToRow ns = H.Cells $ map (\n -> H.LabelCell [H.BAlign H.HLeft] $ H.Text [H.Str $ fromStrict n]) ns
+        --------------------------------------
+        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]]
+        --------------------------------------
+
 
 setDotNode :: PhyloNode -> Dot DotId
-setDotNode pn = undefined
+setDotNode pn = node (getNodeDotId $ pn ^. pn_id)
+                     ([FontName "Arial", Shape Square, toLabel (setHtmlTable pn)])
+
 
 setDotEdge :: PhyloEdge -> Dot DotId
-setDotEdge pe = undefined
+setDotEdge pe = edge (getNodeDotId $ pe ^. pe_source) (getNodeDotId $ pe ^. pe_target)  [Width 2, Color [toWColor Black]]
 
-setDotTime :: Date -> Date -> DotId
-setDotTime d d' = undefined
+setDotPeriodEdge :: (PhyloPeriodId,PhyloPeriodId) -> Dot DotId
+setDotPeriodEdge (prd,prd') = edge (getPeriodDotId prd) (getPeriodDotId prd') [Width 5, Color [toWColor Black]]
 
 
 viewToDot :: PhyloView -> Level -> DotGraph DotId
 viewToDot pv lvl = digraph ((Str . fromStrict) $ pv ^. pv_title) 
+                 
                  $ do
+
+                    -- set the global graph attributes
+
                     graphAttrs ( [Label (toDotLabel $ pv ^. pv_title)]
                               <> [setAttr "description" $ fromStrict $ pv ^. pv_description]
                               <> [setAttr "filiation"   $ (pack . show) $ pv ^. pv_filiation]
@@ -136,7 +186,40 @@ viewToDot pv lvl = digraph ((Str . fromStrict) $ pv ^. pv_title)
                               <> [FontSize (fromIntegral 30), LabelLoc VTop, Splines SplineEdges, Overlap ScaleOverlaps,
                                   Ratio AutoRatio, Style [SItem Filled []],Color [toWColor White]])
 
-                    mapM setPeakDotNode $ getBranchesByLevel lvl pv
+                    -- set the peaks
+
+                    subgraph (Str "Peaks") 
+
+                    $ do 
+
+                        graphAttrs [Rank SameRank]
+
+                        mapM setPeakDotNode $ getBranchesByLevel lvl pv
+
+                    -- set the nodes, period by period
+
+                    mapM (\prd ->
+                            subgraph (Str $ fromStrict $ T.pack $ "subGraph " ++ (show $ (fst prd)) ++ (show $ (snd prd))) 
+
+                            $ do
+                                
+                                graphAttrs [Rank SameRank]
+
+                                -- set the period label
+                                
+                                node (getPeriodDotId prd) [Shape Square, FontSize 50, Label (getPeriodDotLabel prd)]
+
+                                mapM setDotNode $ filterNodesByPeriod prd $ filterNodesByLevel lvl (pv ^.pv_nodes)
+                              
+                         ) $ getViewPeriods pv
+
+                    -- set the edges : from peaks to nodes, from nodes to nodes, from periods to periods 
+
+                    mapM (\(bId,nId) -> setPeakDotEdge (getBranchDotId bId) (getNodeDotId nId)) $ getFirstNodes lvl pv
+
+                    mapM setDotEdge $ filterEdgesByLevel lvl $ filterEdgesByType PeriodEdge (pv ^. pv_edges)
+
+                    mapM setDotPeriodEdge $ listToSequentialCombi $ getViewPeriods pv