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
  22 import Data.List        (head,concat,nub,(++),tail,(!!))
  23 import Data.Tuple       (fst, snd)
  24
  25 import Gargantext.Prelude             hiding (head)
  26 import Gargantext.Viz.Phylo
  27 import Gargantext.Viz.Phylo.Tools
  28 import Gargantext.Viz.Phylo.Metrics.Proximity
  29 import Gargantext.Viz.Phylo.Metrics.Clustering
  30
  31
  32
  33 -- | To transform a PhyloGraph into a list of PhyloBranches by using the relatedComp clustering
  34 graphToBranches :: Level -> PhyloGraph -> Phylo -> [(Int,PhyloGroupId)]
  35 graphToBranches _lvl (nodes,edges) _p = concat
  36                                     $ map (\(idx,gs) -> map (\g -> (idx,getGroupId g)) gs)
  37                                     $ zip [1..]
  38                                     $ relatedComp 0 (head nodes) (tail nodes,edges) [] []
  39
  40
  41 -- | To transform a list of PhyloGroups into a PhyloGraph by using a given Proximity mesure
  42 groupsToGraph :: (Proximity,[Double]) -> [PhyloGroup] -> Phylo -> PhyloGraph
  43 groupsToGraph (prox,param) groups p = (groups,edges)
  44   where
  45     edges :: PhyloEdges
  46     edges = case prox of
  47       FromPairs          -> (nub . concat) $ map (\g -> (map (\g' -> ((g',g),1)) $ getGroupParents g p)
  48                                                         ++
  49                                                         (map (\g' -> ((g,g'),1)) $ getGroupChilds g p)) groups
  50       WeightedLogJaccard -> filter (\edge -> snd edge >= (param !! 0))
  51                           $ map (\(x,y) -> ((x,y), weightedLogJaccard
  52                                 (param !! 1) (getGroupCooc x)
  53                                 (unifySharedKeys (getGroupCooc x) (getGroupCooc y)))) $ listToDirectedCombi groups
  54       Hamming            -> filter (\edge -> snd edge <= (param !! 0))
  55                           $ map (\(x,y) -> ((x,y), hamming (getGroupCooc x)
  56                                 (unifySharedKeys (getGroupCooc x) (getGroupCooc y)))) $ listToDirectedCombi groups
  57       --_                  -> undefined
  58
  59
  60 -- | To set all the PhyloBranches for a given Level in a Phylo
  61 setPhyloBranches :: Level -> Phylo -> Phylo
  62 setPhyloBranches lvl p = alterGroupWithLevel (\g -> let bIdx = (fst . head) $ filter (\b -> snd b == getGroupId g) bs
  63                                                      in over (phylo_groupBranchId) (\_ -> Just (lvl,bIdx)) g) lvl p
  64   where
  65     --------------------------------------
  66     bs :: [(Int,PhyloGroupId)]
  67     bs = graphToBranches lvl graph p
  68     --------------------------------------
  69     graph :: PhyloGraph
  70     graph = groupsToGraph (FromPairs,[]) (getGroupsWithLevel lvl p) p
  71     --------------------------------------