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)
  21 import Data.Map         (Map,elems,adjust,unionWith,intersectionWith)
  22 import Data.Set         (Set)
  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
  29 import qualified Data.List   as List
  30 import qualified Data.Map    as Map
  31 import qualified Data.Set    as Set
  32
  33
  34 -- | To apply the related components method to a PhyloGraph
  35 -- curr = the current PhyloGroup
  36 -- (nodes,edges) = the initial PhyloGraph minus the current PhyloGroup
  37 -- next = the next PhyloGroups to be added in the cluster
  38 -- memo = the memory of the allready created clusters
  39 relatedComp :: Int -> PhyloGroup -> PhyloGraph -> [PhyloGroup] -> [[PhyloGroup]] -> [[PhyloGroup]]
  40 relatedComp idx curr (nodes,edges) next memo
  41   | null nodes' && null next' = memo'
  42   | (not . null) next'        = relatedComp idx (head next') (nodes',edges) (tail next') memo'
  43   | otherwise                 = relatedComp (idx + 1) (head nodes') (tail nodes',edges) [] memo'
  44   where
  45     --------------------------------------
  46     memo' :: [[PhyloGroup]]
  47     memo'
  48       | null memo                  = [[curr]]
  49       | idx == ((length memo) - 1) = (init memo) ++ [(last memo) ++ [curr]]
  50       | otherwise                  = memo ++ [[curr]]
  51     --------------------------------------
  52     next' :: [PhyloGroup]
  53     next' = filter (\x -> not $ elem x $ concat memo) $ nub $ next ++ (getNeighbours False curr edges)
  54     --------------------------------------
  55     nodes' :: [PhyloGroup]
  56     nodes' = filter (\x -> not $ elem x next') nodes
  57     --------------------------------------