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