diff --git a/src/Gargantext/Viz/Phylo.hs b/src/Gargantext/Viz/Phylo.hs
index f72a67c90193f4b5ba1ee00add0b4dfc6c1e8321..83ba59a24c33a0cc8ae817d26396d2b4519ec289 100644
--- a/src/Gargantext/Viz/Phylo.hs
+++ b/src/Gargantext/Viz/Phylo.hs
@@ -350,8 +350,8 @@ data PhyloQueryBuild = PhyloQueryBuild
} deriving (Generic, Show, Eq)
-- | To choose the Phylo edge you want to export : --> <-- <--> <=>
-data Filiation = Ascendant | Descendant | Merge | Complete deriving (Generic, Show, Read)
-data EdgeType = PeriodEdge | LevelEdge deriving (Generic, Show)
+data Filiation = Ascendant | Descendant | Merge | Complete deriving (Generic, Show)
+data EdgeType = PeriodEdge | LevelEdge deriving (Generic, Show, Eq)
-------------------
-- | PhyloView | --
diff --git a/src/Gargantext/Viz/Phylo/Tools.hs b/src/Gargantext/Viz/Phylo/Tools.hs
index a406b0ecc9de3847e99cb15c59526f784d0b87c3..ddedd3cb2e63b5596a623418212b5b1e44bee251 100644
--- a/src/Gargantext/Viz/Phylo/Tools.hs
+++ b/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 ]
diff --git a/src/Gargantext/Viz/Phylo/View/Export.hs b/src/Gargantext/Viz/Phylo/View/Export.hs
index 9ad8aff5d25b76b61a3569e49fc097b01f74d1f2..bc9703b7af3810dacf26e89b3d159a7a40b03f6d 100644
--- a/src/Gargantext/Viz/Phylo/View/Export.hs
+++ b/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