src/Gargantext/Viz/Phylo/BranchMaker.hs

   1 {-|
   2 Module      : Gargantext.Viz.Phylo.Tools
   3 Description : Phylomemy Tools to build/manage it
   4 Copyright   : (c) CNRS, 2017-Present
   5 License     : AGPL + CECILL v3
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9
  10
  11 -}
  12
  13 {-# LANGUAGE NoImplicitPrelude #-}
  14 {-# LANGUAGE FlexibleContexts  #-}
  15 {-# LANGUAGE OverloadedStrings #-}
  16
  17 module Gargantext.Viz.Phylo.BranchMaker
  18   where
  19
  20 import Control.Lens     hiding (both, Level)
  21 import Data.List        (concat,nub,(++),tail)
  22 import Data.Tuple       (fst, snd)
  23 import Gargantext.Prelude
  24 import Gargantext.Viz.Phylo
  25 import Gargantext.Viz.Phylo.Metrics.Clustering
  26 import Gargantext.Viz.Phylo.Tools
  27 -- import Debug.Trace (trace)
  28
  29
  30 -- | To transform a PhyloGraph into a list of PhyloBranches by using the relatedComp clustering
  31 graphToBranches :: Level -> GroupGraph -> Phylo -> [(Int,PhyloGroupId)]
  32 graphToBranches _lvl (nodes,edges) _p = concat
  33                                     $ map (\(idx,gs) -> map (\g -> (idx,getGroupId g)) gs)
  34                                     $ zip [1..]
  35                                     $ relatedComp 0 (head' "branchMaker" nodes) (tail nodes,edges) [] []
  36
  37
  38
  39 -- | To build a graph using the parents and childs pointers
  40 makeGraph :: [PhyloGroup] -> Phylo -> GroupGraph
  41 makeGraph gs p = (gs,edges)
  42   where
  43     edges :: [GroupEdge]
  44     edges = (nub . concat)
  45           $ map (\g -> (map (\g' -> ((g',g),1)) $ getGroupParents g p)
  46                        ++
  47                        (map (\g' -> ((g,g'),1)) $ getGroupChilds g p)) gs
  48
  49
  50 -- | To set all the PhyloBranches for a given Level in a Phylo
  51 setPhyloBranches :: Level -> Phylo -> Phylo
  52 setPhyloBranches lvl p = alterGroupWithLevel (\g -> let bIdx = (fst $ head' "branchMaker" $ filter (\b -> snd b == getGroupId g) bs)
  53                                                      in over (phylo_groupBranchId) (\_ -> Just (lvl,bIdx)) g) lvl p
  54   where
  55     --------------------------------------
  56     bs :: [(Int,PhyloGroupId)]
  57     bs = graphToBranches lvl graph p
  58     --------------------------------------
  59     graph :: GroupGraph
  60     graph = makeGraph (getGroupsWithLevel lvl p) p
  61     --------------------------------------