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.Metrics.Proximity
  27 import Gargantext.Viz.Phylo.Tools
  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 -- | To transform a list of PhyloGroups into a PhyloGraph by using a given Proximity mesure
  39 groupsToGraph :: Proximity -> [PhyloGroup] -> Phylo -> GroupGraph
  40 groupsToGraph prox groups p = (groups,edges)
  41   where
  42     edges :: GroupEdges
  43     edges = case prox of
  44       Filiation          -> (nub . concat) $ map (\g -> (map (\g' -> ((g',g),1)) $ getGroupParents g p)
  45                                                         ++
  46                                                         (map (\g' -> ((g,g'),1)) $ getGroupChilds g p)) groups
  47       WeightedLogJaccard (WLJParams thr sens) -> filter (\edge -> snd edge >= thr)
  48                                                $ map (\(x,y) -> ((x,y), weightedLogJaccard sens (getGroupCooc x) (unifySharedKeys (getGroupCooc x) (getGroupCooc y))))
  49                                                $ listToDirectedCombi groups
  50       Hamming (HammingParams thr) -> filter (\edge -> snd edge <= thr)
  51                                    $ map (\(x,y) -> ((x,y), hamming (getGroupCooc x) (unifySharedKeys (getGroupCooc x) (getGroupCooc y))))
  52                                    $ listToDirectedCombi groups
  53       --_                  -> undefined
  54
  55
  56 -- | To set all the PhyloBranches for a given Level in a Phylo
  57 setPhyloBranches :: Level -> Phylo -> Phylo
  58 setPhyloBranches lvl p = alterGroupWithLevel (\g -> let bIdx = (fst $ head' "branchMaker" $ filter (\b -> snd b == getGroupId g) bs)
  59                                                      in over (phylo_groupBranchId) (\_ -> Just (lvl,bIdx)) g) lvl p
  60   where
  61     --------------------------------------
  62     bs :: [(Int,PhyloGroupId)]
  63     bs = graphToBranches lvl graph p
  64     --------------------------------------
  65     graph :: GroupGraph
  66     graph = groupsToGraph Filiation (getGroupsWithLevel lvl p) p
  67     --------------------------------------