Portability : POSIX
-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE FlexibleInstances #-}
module Gargantext.Viz.Phylo.PhyloExport where
import Data.Map (Map, fromList, empty, fromListWith, insert, (!), elems, unionWith, findWithDefault, toList)
-import Data.List ((++), sort, nub, concat, sortOn, reverse, groupBy, union, (\\), (!!), init, partition, unwords, nubBy, inits)
+import Data.List ((++), sort, nub, concat, sortOn, reverse, groupBy, union, (\\), (!!), init, partition, unwords, nubBy, inits, elemIndex)
import Data.Vector (Vector)
import Prelude (writeFile)
import Gargantext.Prelude
import Gargantext.Viz.AdaptativePhylo
-import Gargantext.Viz.Phylo.PhyloTools
+import Gargantext.Viz.Phylo.PhyloTools
import Control.Lens
import Data.GraphViz hiding (DotGraph, Order)
import System.FilePath
import Debug.Trace (trace)
+import qualified Data.Map as Map
import qualified Data.Text as Text
import qualified Data.Vector as Vector
import qualified Data.Text.Lazy as Lazy
<> (pack $ show (getGroupId g)))]]
--------------------------------------
-branchToDotNode :: PhyloBranch -> Dot DotId
-branchToDotNode b =
+branchToDotNode :: PhyloBranch -> Int -> Dot DotId
+branchToDotNode b bId =
node (branchIdToDotId $ b ^. branch_id)
([FillColor [toWColor CornSilk], FontName "Arial", FontSize 40, Shape Egg, Style [SItem Bold []], Label (toDotLabel $ b ^. branch_label)]
<> (metaToAttr $ b ^. branch_meta)
<> [ toAttr "nodeType" "branch"
+ , toAttr "bId" (pack $ show bId)
, toAttr "branchId" (pack $ unwords (map show $ snd $ b ^. branch_id))
, toAttr "branch_x" (fromStrict $ Text.pack $ (show $ b ^. branch_x))
, toAttr "branch_y" (fromStrict $ Text.pack $ (show $ b ^. branch_y))
, toAttr "to" (fromStrict $ Text.pack $ (show $ snd prd))])
-groupToDotNode :: Vector Ngrams -> PhyloGroup -> Dot DotId
-groupToDotNode fdt g =
+groupToDotNode :: Vector Ngrams -> PhyloGroup -> Int -> Dot DotId
+groupToDotNode fdt g bId =
node (groupIdToDotId $ getGroupId g)
([FontName "Arial", Shape Square, penWidth 4, toLabel (groupToTable fdt g)]
<> [ toAttr "nodeType" "group"
, toAttr "from" (pack $ show (fst $ g ^. phylo_groupPeriod))
, toAttr "to" (pack $ show (snd $ g ^. phylo_groupPeriod))
, toAttr "branchId" (pack $ unwords (init $ map show $ snd $ g ^. phylo_groupBranchId))
+ , toAttr "bId" (pack $ show bId)
, toAttr "support" (pack $ show (g ^. phylo_groupSupport))])
toDotEdge source target lbl edgeType = edge source target
(case edgeType of
GroupToGroup -> [ Width 3, penWidth 4, Color [toWColor Black], Constraint True
- , Label (StrLabel $ fromStrict lbl)]
+ , Label (StrLabel $ fromStrict lbl)] <> [toAttr "edgeType" "link" ]
BranchToGroup -> [ Width 3, Color [toWColor Black], ArrowHead (AType [(ArrMod FilledArrow RightSide,DotArrow)])
- , Label (StrLabel $ fromStrict lbl)]
+ , Label (StrLabel $ fromStrict lbl)] <> [toAttr "edgeType" "branchLink" ]
BranchToBranch -> [ Width 2, Color [toWColor Black], Style [SItem Dashed []], ArrowHead (AType [(ArrMod FilledArrow BothSides,DotArrow)])
, Label (StrLabel $ fromStrict lbl)]
PeriodToPeriod -> [ Width 5, Color [toWColor Black]])
in unionWith (\w w' -> max w w') toChilds toParents
+toBid :: PhyloGroup -> [PhyloBranch] -> Int
+toBid g bs =
+ let b' = head' "toBid" (filter (\b -> b ^. branch_id == g ^. phylo_groupBranchId) bs)
+ in fromJust $ elemIndex b' bs
+
exportToDot :: Phylo -> PhyloExport -> DotGraph DotId
exportToDot phylo export =
trace ("\n-- | Convert " <> show(length $ export ^. export_branches) <> " branches and "
<> "##########################") $
digraph ((Str . fromStrict) $ (phyloName $ getConfig phylo)) $ do
- -- | 1) init the dot graph
+ {- 1) init the dot graph -}
graphAttrs ( [ Label (toDotLabel $ (phyloName $ getConfig phylo))]
<> [ FontSize 30, LabelLoc VTop, NodeSep 1, RankSep [1], Rank SameRank, Splines SplineEdges, Overlap ScaleOverlaps
, Ratio FillRatio
, Style [SItem Filled []],Color [toWColor White]]
- -- | home made attributes
+ {-- home made attributes -}
<> [(toAttr (fromStrict "phyloFoundations") $ pack $ show (length $ Vector.toList $ getRoots phylo))
,(toAttr (fromStrict "phyloTerms") $ pack $ show (length $ nub $ concat $ map (\g -> g ^. phylo_groupNgrams) $ export ^. export_groups))
,(toAttr (fromStrict "phyloDocs") $ pack $ show (sum $ elems $ phylo ^. phylo_timeDocs))
,(toAttr (fromStrict "phyloGroups") $ pack $ show (length $ export ^. export_groups))
])
-
+{-
-- toAttr (fromStrict k) $ (pack . unwords) $ map show v
- -- | 2) create a layer for the branches labels
+ -- 2) create a layer for the branches labels -}
subgraph (Str "Branches peaks") $ do
graphAttrs [Rank SameRank]
-
- -- | 3) group the branches by hierarchy
+{-
+ -- 3) group the branches by hierarchy
-- mapM (\branches ->
-- subgraph (Str "Branches clade") $ do
-- graphAttrs [Rank SameRank]
- -- -- | 4) create a node for each branch
+ -- -- 4) create a node for each branch
-- mapM branchToDotNode branches
-- ) $ elems $ fromListWith (++) $ map (\b -> ((init . snd) $ b ^. branch_id,[b])) $ export ^. export_branches
+-}
+ mapM (\b -> branchToDotNode b (fromJust $ elemIndex b (export ^. export_branches))) $ export ^. export_branches
- mapM branchToDotNode $ export ^. export_branches
-
- -- | 5) create a layer for each period
+ {-- 5) create a layer for each period -}
_ <- mapM (\period ->
subgraph ((Str . fromStrict . Text.pack) $ ("Period" <> show (fst period) <> show (snd period))) $ do
graphAttrs [Rank SameRank]
periodToDotNode period
- -- | 6) create a node for each group
- mapM (\g -> groupToDotNode (getRoots phylo) g) (filter (\g -> g ^. phylo_groupPeriod == period) $ export ^. export_groups)
+ {-- 6) create a node for each group -}
+ mapM (\g -> groupToDotNode (getRoots phylo) g (toBid g (export ^. export_branches))) (filter (\g -> g ^. phylo_groupPeriod == period) $ export ^. export_groups)
) $ getPeriodIds phylo
- -- | 7) create the edges between a branch and its first groups
+ {-- 7) create the edges between a branch and its first groups -}
_ <- mapM (\(bId,groups) ->
mapM (\g -> toDotEdge (branchIdToDotId bId) (groupIdToDotId $ getGroupId g) "" BranchToGroup) groups
)
$ sortOn (fst . _phylo_groupPeriod) groups)
$ fromListWith (++) $ map (\g -> (g ^. phylo_groupBranchId,[g])) $ export ^. export_groups
- -- | 8) create the edges between the groups
+ {- 8) create the edges between the groups -}
_ <- mapM (\((k,k'),_) ->
toDotEdge (groupIdToDotId k) (groupIdToDotId k') "" GroupToGroup
) $ (toList . mergePointers) $ export ^. export_groups
- -- | 7) create the edges between the periods
+ {- 7) create the edges between the periods -}
_ <- mapM (\(prd,prd') ->
toDotEdge (periodIdToDotId prd) (periodIdToDotId prd') "" PeriodToPeriod
) $ nubBy (\combi combi' -> fst combi == fst combi') $ listToCombi' $ getPeriodIds phylo
- -- | 8) create the edges between the branches
+ {- 8) create the edges between the branches
-- _ <- mapM (\(bId,bId') ->
-- toDotEdge (branchIdToDotId bId) (branchIdToDotId bId')
-- (Text.pack $ show(branchIdsToProximity bId bId'
-- (getThresholdInit $ phyloProximity $ getConfig phylo)
-- (getThresholdStep $ phyloProximity $ getConfig phylo))) BranchToBranch
-- ) $ nubBy (\combi combi' -> fst combi == fst combi') $ listToCombi' $ map _branch_id $ export ^. export_branches
+ -}
graphAttrs [Rank SameRank]
-
-
-
----------------
-- | Filter | --
----------------
-- | Sort | --
--------------
+branchToIso :: [PhyloBranch] -> [PhyloBranch]
+branchToIso branches =
+ let steps = map sum
+ $ inits
+ $ map (\(b,x) -> b ^. branch_y + 0.05 - x)
+ $ zip branches
+ $ ([0] ++ (map (\(b,b') ->
+ let idx = length $ commonPrefix (b ^. branch_canonId) (b' ^. branch_canonId) []
+ in (b' ^. branch_seaLevel) !! (idx - 1)
+ ) $ listToSeq branches))
+ in map (\(x,b) -> b & branch_x .~ x)
+ $ zip steps branches
+
+
sortByHierarchy :: Int -> [PhyloBranch] -> [PhyloBranch]
sortByHierarchy depth branches =
if (length branches == 1)
- then branches
- else concat
+ then branchToIso branches
+ else branchToIso $ concat
$ map (\branches' ->
let partitions = partition (\b -> depth + 1 == ((length . snd) $ b ^. branch_id)) branches'
in (sortOn (\b -> (b ^. branch_meta) ! "birth") (fst partitions))
let prd = g ^. phylo_groupPeriod
end = last' "dynamics" (sort $ map snd $ elems m)
in if (((snd prd) == (snd $ m ! n)) && (snd prd /= end))
- -- | decrease
+ {- decrease -}
then 2
else if ((fst prd) == (fst $ m ! n))
- -- | recombination
+ {- recombination -}
then 0
else if isNew
- -- | emergence
+ {- emergence -}
then 1
else 3
where
$ (g ^. phylo_groupNgrams))) [] groups
+-----------------
+-- | horizon | --
+-----------------
+
+horizonToAncestors :: Double -> Phylo -> [PhyloAncestor]
+horizonToAncestors delta phylo =
+ let horizon = Map.toList $ Map.filter (\v -> v > delta) $ phylo ^. phylo_horizon
+ ct0 = fromList $ map (\g -> (getGroupId g, g)) $ getGroupsFromLevelPeriods 1 (take 1 (getPeriodIds phylo)) phylo
+ aDelta = toRelatedComponents
+ (elems ct0)
+ (map (\((g,g'),v) -> ((ct0 ! g,ct0 ! g'),v)) horizon)
+ in map (\(id,groups) -> toAncestor id groups) $ zip [1..] aDelta
+ where
+ -- | note : possible bug if we sync clus more than once
+ -- | horizon is calculated at level 1, ancestors have to be related to the last level
+ toAncestor :: Int -> [PhyloGroup] -> PhyloAncestor
+ toAncestor id groups = PhyloAncestor id
+ (foldl' (\acc g -> union acc (g ^. phylo_groupNgrams)) [] groups)
+ (concat $ map (\g -> map fst (g ^. phylo_groupLevelParents)) groups)
+
+
---------------------
-- | phyloExport | --
---------------------
-
toPhyloExport :: Phylo -> DotGraph DotId
toPhyloExport phylo = exportToDot phylo
$ processFilters (exportFilter $ getConfig phylo) (phyloQuality $ getConfig phylo)
$ processMetrics export
where
export :: PhyloExport
- export = PhyloExport groups
- $ map (\(x,b) -> b & branch_x .~ x)
- $ zip branchesGaps branches
- --------------------------------------
- branchesGaps :: [Double]
- branchesGaps = map sum
- $ inits
- $ map (\(b,x) -> b ^. branch_y + 0.05 - x)
- $ zip branches
- $ ([0] ++ (map (\(b,b') ->
- let idx = length $ commonPrefix (b ^. branch_canonId) (b' ^. branch_canonId) []
- in (b' ^. branch_seaLevel) !! (idx - 1)
- ) $ listToSeq branches))
+ export = PhyloExport groups branches (horizonToAncestors 0 phylo)
--------------------------------------
branches :: [PhyloBranch]
branches = map (\g ->
let seaLvl = (g ^. phylo_groupMeta) ! "seaLevels"
breaks = (g ^. phylo_groupMeta) ! "breaks"
canonId = take (round $ (last' "export" breaks) + 2) (snd $ g ^. phylo_groupBranchId)
- in trace (show(canonId)) $ PhyloBranch (g ^. phylo_groupBranchId)
+ in PhyloBranch (g ^. phylo_groupBranchId)
canonId
seaLvl
0
(last' "export" (take (round $ (last' "export" breaks) + 1) seaLvl))
+ 0
+ 0
"" empty)
$ map (\gs -> head' "export" gs)
$ groupBy (\g g' -> g ^. phylo_groupBranchId == g' ^. phylo_groupBranchId)