[FEAT] adding HLouvain glustering.

clustering-louvain.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: ac125dcd62ed660802d411f36f51aa061b920436175667d9972e2390e02b60e0
+-- hash: 85a89537835f3546235aaf6eea2ef007ef1dd0406a6c9afc4bf6119d2f8239f0
 
 name:           clustering-louvain
 version:        0.1.0.0
@@ -37,5 +37,6 @@ library
       Data.Graph.Clustering.Louvain.IO.Gexf
       Data.Graph.Clustering.Louvain.CplusPlus
   other-modules:
+      Data.Graph.Clustering.HLouvain
       Paths_clustering_louvain
   default-language: Haskell2010

src/Data/Graph/Clustering/HLouvain.hs

+{-|
+Module      : Data.Graph.Clustering.HLouvain
+Description : Purely functional (Inductive) Louvain clustering
+Copyright   : (c) CNRS, 2020-Present
+License     : AGPL + CECILL v3
+Maintainer  : alexandre.delanoe+louvain@iscpif.fr
+Stability   : experimental
+Portability : POSIX
+
+
+Main Reference:
+ * Blondel, Vincent D; Guillaume, Jean-Loup; Lambiotte, Renaud; Lefebvre, Etienne (9 October 2008). "Fast unfolding of communities in large networks". Journal of Statistical Mechanics: Theory and Experiment. 2008 (10): P10008. arXiv:0803.0476 Freely accessible. doi:10.1088/1742-5468/2008/10/P10008.
+ * Louvain_Modularity https://en.wikipedia.org/wiki/Louvain_Modularity
+-}
+
+
+module Data.Graph.Clustering.HLouvain 
+  where
+
+import Data.Ord (Down(..))
+import Data.List (sortOn)
+import Data.Graph.Inductive
+-- import Data.Graph.Clustering.Louvain
+
+------------------------------------------------------------------------
+-- | Main Tools
+------------------------------------------------------------------------
+
+glustering :: DynGraph gr
+           => gr a b
+           -> [Module]
+glustering = undefined
+
+------------------------------------------------------------------------
+-- | Definitions
+------------------------------------------------------------------------
+
+data Module = Module { node    :: Node
+                     , modules :: [Module]
+                     , score   :: Double
+                     }
+
+modulare :: DynGraph gr
+         => gr a b
+         ->  Module
+         -> [Module]
+         -> [Module]
+modulare _ m []  = [m]
+modulare _ m [n] = sortOn (Down . score) [m,n]
+modulare g m0@(Module n ms0 _) m1@(m@(Module n1 _ _):ms)
+  | score1 > score2 = [Module n1 (modulare g m0 ms0) score1] ++ ms
+  | otherwise       = [m]  ++ (modulare g m0 ms)
+    where
+      score1 = sum $ map (modularity g) [m0, m]
+      score2 = sum $ map (modularity g) ([m0]++ms)
+
+flat :: Module -> [Node]
+flat (Module n [] _) = [n]
+flat (Module n ns _) = [n] ++ (concat $ map flat ns)
+
+-- | TODO Sum or Union -> QuickCheck
+modularity :: DynGraph gr => gr a b -> Module -> Double
+modularity g m = modularity' g (flat m)
+  where
+    modularity' :: DynGraph gr => gr a b -> [Node] -> Double
+    modularity' gr ns = coverage - edgeDensity
+        where
+            coverage :: Double
+            coverage  = sizeSubGraph / sizeAllGraph
+                where
+                    sizeSubGraph :: Double
+                    sizeSubGraph = fromIntegral ( size $ subgraph ns gr )
+
+                    sizeAllGraph :: Double
+                    sizeAllGraph = fromIntegral (size gr)
+
+            edgeDensity :: Double
+            edgeDensity = (sum (Prelude.map (\node -> (degree node) / links ) ns)) ** 2
+                where
+                    degree :: Node -> Double
+                    degree node = fromIntegral (deg gr node)
+
+                    links :: Double
+                    links       = fromIntegral (2 * (size gr))
+

src/Data/Graph/Clustering/Louvain.hs

@@ -18,31 +18,48 @@ References:
 module Data.Graph.Clustering.Louvain 
   where
 
-import Data.List (maximumBy, nub, intersect, foldl')
+import Data.List (maximumBy, nub, intersect, foldl', zipWith, concat)
 import Data.Graph.Inductive
+import Data.Graph.Clustering.Louvain.Utils (LouvainNode(..))
 
 ------------------------------------------------------------------------
 -- | Definitions
 ------------------------------------------------------------------------
 type Modularity = Double
-type Community = [Node] 
+type Community = [Node]
 -- type Community' = Community { nodes :: [Node], modularity :: Maybe Modularity}
 -- type Partition = [Community]
-
 type Reverse = Bool
 
+------------------------------------------------------------------------
+hLouvain :: (Eq b, DynGraph gr)
+         => Reverse
+         -> gr a b
+         -> [LouvainNode]
+hLouvain r g = concat $ toLouvainNode (bestpartition r g)
+  where
+    toLouvainNode :: [[Node]] -> [[LouvainNode]]
+    toLouvainNode ns = zipWith (\cId ns' -> map (\n -> LouvainNode n cId) ns')
+                               [1..] ns
+
 ------------------------------------------------------------------------
 -- | Partitionning the graph
 ------------------------------------------------------------------------
-bestpartition :: (Eq b, DynGraph gr) => Reverse -> gr a b -> [[Node]]
+bestpartition :: (Eq b, DynGraph gr)
+              => Reverse
+              -> gr a b
+              -> [[Node]]
 bestpartition r gr = converge gr (start gr r)
 
-converge :: (Eq b, DynGraph gr) => gr a1 b -> [[Node]] -> [[Node]]
+converge :: (Eq b, DynGraph gr)
+         => gr a1 b
+         -> [[Node]]
+         -> [[Node]]
 converge gr ns = case stepscom gr (length ns) ns of
             ns' | ns == ns' -> ns
                 | otherwise -> stepscom gr (length ns') ns'
-------------------------------------------------------------------------
 
+------------------------------------------------------------------------
 dendogram :: (Eq b, DynGraph gr) => gr a b -> Int -> Reverse -> [[Node]]
 dendogram gr n r = stepscom gr n (start gr r)
 
@@ -59,25 +76,10 @@ stepscom :: (DynGraph gr, Eq b) => gr a1 b -> Int -> [[Node]] -> [[Node]]
 stepscom gr n ns = foldl' (\xs _ -> stepcom gr' (smallCom xs) xs) ns [1..n]
     where
         gr' = undir gr
-        smallCom xs = head $ filter (\x -> length x == minimum (Prelude.map length xs)) (reverse xs)
-
-stepscom' :: (DynGraph gr, Eq b) => gr a1 b -> Int -> [[Node]] -> [[Node]]
-stepscom' gr n ns = foldl' (\xs _ -> stepcom' gr' (smallCom xs) xs) ns [1..n]
-    where
-        gr' = undir gr
-        smallCom xs = head $ filter (\x -> length x == minimum (Prelude.map length xs)) (reverse xs)
+        smallCom xs = head $ filter (\x -> length x == minimum (Prelude.map length xs))
+                                    (reverse xs)
 
 ------------------------------------------------------------------------
-
-stepcom' :: DynGraph gr => gr a b -> [Node] -> [[Node]] -> [[Node]]
-stepcom' gr n ns = bestModularities gr $ Prelude.map (\x -> x ++ neighout) (addcom n neighin)
-    where
-        -- | First remove the node (n) of the current partition (ns)
-        ns' = filter (/= n) ns
-        neighin    = filter (\c ->  (intersect (neighcom gr n) c) /= [] ) ns'
-        neighout   = filter (\c ->  (intersect (neighcom gr n) c) == [] ) ns'
-
-
 stepcom :: DynGraph gr => gr a b -> [Node] -> [[Node]] -> [[Node]]
 stepcom gr n ns = bestModularities gr $ [ns] ++ Prelude.map (\x -> x ++ neighout) (addcom n neighin)
     where
@@ -103,10 +105,18 @@ rotate :: Int -> [a] -> [a]
 rotate _ [] = []
 rotate n xs = zipWith const (drop n (cycle xs)) xs
 
+------------------------------------------------------------------------
+
+data Module = Node | Module { modules :: [Module]
+                            , score   :: Double
+                            }
+
+
+
+
 ------------------------------------------------------------------------
 -- | Computing modularity of the partition
 ------------------------------------------------------------------------
-
 modularities :: DynGraph gr => gr a b -> [[Node]] -> Double
 modularities gr xs = sum $ Prelude.map (\y -> modularity gr y) xs
 

src/Data/Graph/Clustering/Louvain/CplusPlus.hs

@@ -15,6 +15,9 @@ git clone https://gitlab.iscpif.fr/gargantext/clustering-louvain-cplusplus
 module Data.Graph.Clustering.Louvain.CplusPlus
   where
 
+import Data.Graph.Clustering.Louvain.Utils (LouvainNode(..))
+import Control.Monad.IO.Class (liftIO, MonadIO)
+import Control.Concurrent (newEmptyMVar, takeMVar, putMVar, forkIO)
 import Data.Map.Strict (Map, toList)
 import Data.Maybe (maybe)
 import Data.Monoid ((<>))
@@ -24,14 +27,11 @@ import System.IO
 import qualified Control.Foldl as Fold
 import qualified Data.List as L
 import qualified Data.Text    as T
+-- import qualified Data.ByteString as DB
 import qualified Data.Text.IO as T
 import qualified Turtle as TU
 
 
-data LouvainNode = LouvainNode { l_node_id :: Int
-                               , l_community_id :: Int
-                               } deriving (Show)
-
 
 cLouvain :: Text -> Map (Int, Int) Double -> IO [LouvainNode]
 cLouvain _params ms = do
@@ -46,16 +46,21 @@ cLouvain _params ms = do
   let hierarchy = "/usr/share/louvain/hierarchy"
 
   writeInput inFileD ms
+  putStrLn "cmdLouvain"
+
   let cmdLouvain   = louvain   <> " " <> inFileD <> " " <> inFileW <> " " <> outBin <> " " <> outTree
   -- let cmdLouvain   = louvain   <> " " <> inFileD <> " " <> unpack params <> " " <> inFileW <> " " <> outBin <> " " <> outTree
+  putStrLn "cmdHierarchy"
   let cmdHierarchy = hierarchy <> " " <> outTree <> " -l 1 > " <> outRes
   --pure cmdLouvain
-  shell (T.pack cmdLouvain)
-  shell (T.pack cmdHierarchy)
-  
-  myResult <- readOutput outRes
+  -- _ <- inMVarIO $ shell (T.pack cmdLouvain)
+  -- _ <- inMVarIO $ shell (T.pack cmdHierarchy)
+
+  putStrLn "myResult start"
+  myResult <- inMVarIO $ readOutput outRes
+  putStrLn "myResult end"
 
-  let clean = "rm" <> " " <> L.intercalate " " [inFileD, inFileW, outBin, outTree, outRes]
+  --let clean = "rm" <> " " <> L.intercalate " " [inFileD, inFileW, outBin, outTree, outRes]
   pure myResult
 
 
@@ -81,3 +86,19 @@ shell cmd = do
       TU.ExitSuccess   -> return TU.ExitSuccess
       TU.ExitFailure n -> TU.die (cmd <> " failed with exit code: " <> TU.repr n)
 
+
+
+inMVarIO :: MonadIO m => m b -> m b
+inMVarIO f = do
+  mVar <- liftIO newEmptyMVar
+  zVar <- f
+  _ <- liftIO $ forkIO $ putMVar mVar zVar
+  liftIO $ takeMVar mVar
+
+inMVar :: b -> IO b
+inMVar f = do
+  mVar <- newEmptyMVar 
+  let zVar = f
+  _ <- liftIO $ forkIO $ putMVar mVar zVar
+  liftIO $ takeMVar mVar
+

src/Data/Graph/Clustering/Louvain/Utils.hs

@@ -17,12 +17,16 @@ import Data.Graph.Inductive
 import Data.List (nub)
 import Data.Map.Strict (Map, toList)
 
+data LouvainNode = LouvainNode { l_node_id :: Int
+                               , l_community_id :: Int
+                               } deriving (Show)
+
 
 label' :: (Graph gr) => gr a b -> Edge -> Maybe b
 label' gr (u,v) = lookup v (lsuc gr u)
 
 shortest_path :: (Real b, Graph gr) => gr a b -> Node -> Node -> Maybe Path
-shortest_path graph node_1 node_2= sp node_1 node_2 graph
+shortest_path graph node_1 node_2 = sp node_1 node_2 graph
 
 mkGraph' :: [LEdge b] -> Gr () b
 mkGraph' es = mkGraph ns es