Skip to content

haskell-gargantext
haskell-gargantext
Commit e050b8b6 authored by Quentin Lobbé's avatar Quentin Lobbé
Browse files
Options

Add the dot export

parent 652421a0
Hide whitespace changes
Inline Side-by-side
Showing with 115 additions and 27 deletions
src/Gargantext/Viz/Phylo.hs
View file @ e050b8b6
......@@ -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 | --
......
src/Gargantext/Viz/Phylo/Tools.hs
View file @ e050b8b6
......@@ -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
View file @ e050b8b6
......@@ -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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment