src/Gargantext/Viz/Phylo/Metrics/Clustering.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.Metrics.Clustering
  18   where
  19
  20 import Data.List        (last,head,union,concat,null,nub,(++),init,tail,elemIndex,groupBy,(!!))
  21 import Data.Map         (Map,elems,adjust,unionWith,intersectionWith,fromList,mapKeys)
  22 import Data.Set         (Set)
  23 import Data.Tuple       (fst, snd)
  24
  25 import Data.Graph.Clustering.Louvain.CplusPlus
  26
  27 import Gargantext.Prelude             hiding (head)
  28 import Gargantext.Viz.Phylo
  29 import Gargantext.Viz.Phylo.Tools
  30
  31 import qualified Data.List   as List
  32 import qualified Data.Map    as Map
  33 import qualified Data.Set    as Set
  34
  35
  36 -- | To apply the related components method to a PhyloGraph
  37 -- curr = the current PhyloGroup
  38 -- (nodes,edges) = the initial PhyloGraph minus the current PhyloGroup
  39 -- next = the next PhyloGroups to be added in the cluster
  40 -- memo = the memory of the allready created clusters
  41 relatedComp :: Int -> PhyloGroup -> PhyloGraph -> [PhyloGroup] -> [[PhyloGroup]] -> [[PhyloGroup]]
  42 relatedComp idx curr (nodes,edges) next memo
  43   | null nodes' && null next' = memo'
  44   | (not . null) next'        = relatedComp idx (head next') (nodes',edges) (tail next') memo'
  45   | otherwise                 = relatedComp (idx + 1) (head nodes') (tail nodes',edges) [] memo'
  46   where
  47     --------------------------------------
  48     memo' :: [[PhyloGroup]]
  49     memo'
  50       | null memo                  = [[curr]]
  51       | idx == ((length memo) - 1) = (init memo) ++ [(last memo) ++ [curr]]
  52       | otherwise                  = memo ++ [[curr]]
  53     --------------------------------------
  54     next' :: [PhyloGroup]
  55     next' = filter (\x -> not $ elem x $ concat memo) $ nub $ next ++ (getNeighbours False curr edges)
  56     --------------------------------------
  57     nodes' :: [PhyloGroup]
  58     nodes' = filter (\x -> not $ elem x next') nodes
  59     --------------------------------------
  60
  61
  62 louvain :: (PhyloNodes,PhyloEdges) -> IO [[PhyloGroup]]
  63 louvain (nodes,edges) = map (\community -> map (\node -> nodes !! (l_node_id node)) community)
  64                       <$> groupBy (\a b -> (l_community_id a) == (l_community_id b))
  65                       <$> (cLouvain $ mapKeys (\(x,y) -> (idx x, idx y)) $ fromList edges)
  66   where
  67     --------------------------------------
  68     idx :: PhyloGroup -> Int
  69     idx e = case elemIndex e nodes of
  70       Nothing -> panic "[ERR][Gargantext.Viz.Phylo.Metrics.Clustering] a node is missing"
  71       Just i  -> i
  72     --------------------------------------