[FLouvain] second louvain step and runFLouvain cycle

clustering-louvain.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: e1e53adbd24148d990b70f078530a01370effd8531413470ea9947aa095bf247
+-- hash: 70b34ec62fea08353f69f29cc103940feb22097a32b1f061446843b348e5f727
 
 name:           clustering-louvain
 version:        0.1.0.0
@@ -30,6 +30,7 @@ library
       Data.Graph.Clustering.Example
       Data.Graph.Clustering.HLouvain
       Data.Graph.Clustering.ILouvain
+      Data.Graph.Clustering.Louvain.Types
       Paths_clustering_louvain
   hs-source-dirs:
       src

src/Data/Graph/Clustering/Example.hs

@@ -4,28 +4,42 @@ import Protolude
 
 import Control.Monad (foldM_)
 import Data.List (nub, sort)
-import Data.Graph.Clustering.Louvain.Utils
 import Data.Graph.FGL
 import Data.Graph.Inductive
-import Data.Graph.Clustering.FLouvain
 import qualified Data.Text as T
 import qualified Text.ParserCombinators.Parsec as P
 import Text.Parsec.Language (haskellStyle)
 import qualified Text.Parsec.Token as PT
 
+import Data.Graph.Clustering.Louvain.Utils
+import Data.Graph.Clustering.Louvain.Types
+import Data.Graph.Clustering.FLouvain
+
 -- | Run FLouvain.iterate on an example graph
 -- Example call:
 -- putStrLn $ prettify $ iterateOnce cuiller
 -- Prelude.map (fst3 . unCommunity . snd) $ labNodes $ iterateOnce karate
-iterateOnce :: Gr () Double -> CGr
+iterateOnce :: Gr a Double -> CGr a
 iterateOnce gr = iteration fgr cgr
   where
     fgr = toFGraph    gr
     cgr = initialCGr fgr
 
-runIterations :: Int -> Gr () Double -> IO ()
-runIterations n gr = do
-  let fgr       = toFGraph gr
+runFLouvain :: (Show a, Eq a) => Int -> Int -> FGraph a () -> IO ()
+runFLouvain 0 _ fgr = return ()
+runFLouvain cycles n fgr = do
+  cgr <- runFIterations n fgr
+  let fgrNext = louvainSecondStep fgr cgr
+  putStrLn ("-----------------" :: Text)
+  putStrLn ("New FGraph:" :: Text)
+  putStrLn $ prettify fgrNext
+  runFLouvain (cycles - 1) n fgrNext
+
+runIterations :: Show a => Int -> Gr a Double -> IO (CGr a)
+runIterations n gr = runFIterations n $ toFGraph gr
+
+runFIterations :: Show a => Int -> FGraph a () -> IO (CGr a)
+runFIterations n fgr = do
   let fgrWeight = graphWeight fgr
   let initCgr   = initialCGr fgr
 
@@ -41,6 +55,8 @@ runIterations n gr = do
   putStrLn ("Non-empty communities: " :: Text)
   mapM_ (\c -> putStrLn (show c :: Text)) coms
 
+  return lastCgr
+
   where
     runIteration fgr fgrWeight iterCgr i = do
       let iterNextCgr = iteration fgr iterCgr
@@ -50,7 +66,7 @@ runIterations n gr = do
       putStrLn $ T.unpack $ show $ modularity fgr iterNextCgr fgrWeight
       return iterNextCgr
 
-runLouvainFirstStepIterate :: Int -> Gr () Double -> (Modularity, CGr)
+runLouvainFirstStepIterate :: Int -> Gr a Double -> (Modularity, CGr a)
 runLouvainFirstStepIterate n gr = (modularity fgr cgr m, cgr)
   where
     fgr = toFGraph gr

src/Data/Graph/Clustering/Louvain.hs

@@ -19,11 +19,11 @@ References:
 module Data.Graph.Clustering.Louvain 
   where
 
-import Data.Tuple.Extra (fst3)
 import Data.List (maximumBy, nub, intersect, foldl', zipWith, concat)
 import Data.Graph.Inductive
 import Data.Graph.Clustering.Louvain.Utils (LouvainNode(..), toFGraph)
-import Data.Graph.Clustering.FLouvain (louvainFirstStepIterate, Community(..), initialCGr)
+import Data.Graph.Clustering.FLouvain (louvainFirstStepIterate, initialCGr)
+import Data.Graph.Clustering.Louvain.Types (Community(..), comNodes)
 ------------------------------------------------------------------------
 -- | Definitions
 ------------------------------------------------------------------------
@@ -35,7 +35,7 @@ type Reverse = Bool
 
 ------------------------------------------------------------------------
 flouvain :: Int -> Gr () Double -> [[Node]]
-flouvain n g = map (fst3 . unCommunity . snd) $ labNodes g'
+flouvain n g = map (comNodes . snd) $ labNodes g'
   where
     g' = louvainFirstStepIterate n (toFGraph g)
 ------------------------------------------------------------------------

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

+module Data.Graph.Clustering.Louvain.Types where
+
+import Protolude
+
+import Data.Graph.Inductive
+
+
+--  "glue" : function to gather/merge communities
+--  "klue" : function to split communities
+data ClusteringMethod = Glue | Klue
+  deriving (Eq)
+
+newtype Weight = Weight { unWeight :: Double }
+  deriving (Show, Eq, Ord)
+type FEdge b = (Weight, b)
+fedgeWeight :: FEdge b -> Double
+fedgeWeight = unWeight . fst
+sumEdgeWeights :: Adj (FEdge b) -> Double
+sumEdgeWeights es = sum $ map (fedgeWeight . fst) es
+
+-- Our basic graph. Nodes have custom labels. Edges have weight assigned to them.
+type FGraph a b = Gr a (FEdge b)
+
+-- | Used for k_i in formula (2)
+-- (sum of the weights of the links incident to node i)
+newtype NodeWeightSum = NodeWeightSum { unNodeWeightSum :: Double }
+  deriving (Show, Eq, Ord)
+nodeWeightSum :: Context a (FEdge b) -> NodeWeightSum
+nodeWeightSum (p, _, _, s) = NodeWeightSum $ sumEdgeWeights $ p <> s
+
+-- | Used for k_i,in in formula (2)
+-- (Sum of weights of links from a given 'Node' to nodes in a given 'Community')
+newtype NodeComWeightSum = NodeComWeightSum { unNodeComWeightSum :: Double }
+  deriving (Show, Eq, Ord)
+nodeComWeightSum :: Community c -> Context a (FEdge b) -> NodeComWeightSum
+nodeComWeightSum com (p, _, _, s) =
+  NodeComWeightSum $ sumEdgeWeights $ filter (\(_, n) -> n `elem` comNodes com) $ p <> s
+
+newtype NodeNonComWeightSum = NodeNonComWeightSum { unNodeNonComWeightSum :: Double }
+  deriving (Show, Eq, Ord)
+nodeNonComWeightSum :: Community c -> Context a (FEdge b) -> NodeNonComWeightSum
+nodeNonComWeightSum com (p, _, _, s) =
+  NodeNonComWeightSum $ sumEdgeWeights $ filter (\(_, n) -> n `notElem` comNodes com) $ p <> s
+
+-- Probably this structure is better to reduce the number of computations
+-- (precompute sum of node weights, which is the k_i variable in formula (2)).
+-- type FNode a = (NodeWeightSum, a)
+-- fnodeWeightSum :: FNode a -> Double
+-- fnodeWeightSum = unNodeWeightSum . fst
+
+-- | This is the m variable in formula (2) of the Louvain paper
+newtype GraphWeightSum = GraphWeightSum { unGraphWeightSum :: Double }
+  deriving (Show, Eq, Ord)
+-- | This is the \Sum_in in formula (2) of the Louvain paper
+-- (sum of the weights of the links inside C)
+newtype InWeightSum = InWeightSum { unInWeightSum :: Double }
+  deriving (Show, Eq, Ord)
+-- | This is the \Sum_tot in formula (2) of the Louvain paper
+-- (sum of the weights of the links incident to nodes in C)
+newtype TotWeightSum = TotWeightSum { unTotWeightSum :: Double }
+  deriving (Show, Eq, Ord)
+-- | Computed Delta_Q value in (2)
+newtype DeltaQ = DeltaQ { unDeltaQ :: Double }
+  deriving (Show, Eq, Ord)
+-- | Computed modularity in (1)
+newtype Modularity = Modularity { unModularity :: Double }
+  deriving (Show, Eq, Ord)
+
+-- | Type for the clusters we will be creating.
+newtype Community a = Community { unCommunity ::  ([Node], InWeightSum, TotWeightSum, a) }
+  deriving (Show, Eq, Ord)
+comNodes :: Community c -> [Node]
+comNodes (Community (ns, _, _, _)) = ns
+comInWeightSum :: Community c -> InWeightSum
+comInWeightSum (Community (_, inWeightSum, _, _)) = inWeightSum
+comTotWeightSum :: Community c -> TotWeightSum
+comTotWeightSum (Community (_, _, totWeightSum, _)) = totWeightSum
+comLabel :: Community c -> c
+comLabel (Community (_, _, _, c)) = c
+
+type CGrNode = Node
+type CGrEdge = (InWeightSum, TotWeightSum)
+
+type CGr a = Gr (Community a) ()
+
+graphWeight :: FGraph a b -> GraphWeightSum
+graphWeight gr = GraphWeightSum $ 0.5 * ufold (\(_, n, _, _) -> weight' $ context gr n) 0 gr
+  where
+    weight' (p, _, _, s) acc = acc + (sumEdgeWeights $ p <> s)

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

@@ -19,7 +19,7 @@ import Data.Graph.Inductive
 import Data.List (lookup, nub)
 import qualified Data.Map.Strict as Map
 
-import Data.Graph.Clustering.FLouvain (FGraph, Weight(..))
+import Data.Graph.Clustering.Louvain.Types
 
 data LouvainNode = LouvainNode { l_node_id :: Int
                                , l_community_id :: Int
@@ -63,3 +63,17 @@ toFGraph gr = gmap remap gr
       edgeMap (w, n) = ((Weight w, ()), n)
       p' = map edgeMap p
       s' = map edgeMap s
+
+-- | Fixed point with at most n iterations
+-- 'Int' argument is the maximal number of iterations to make
+-- 'a -> a' is the iterator function
+-- 'a -> Bool' is the condition checking function ('True' continues looping, 'False' breaks it)
+-- 'a' is the initial value
+fixPt :: Int -> (a -> a) -> (a -> Bool) -> a -> a
+fixPt 0 iterator _ init = iterator init
+fixPt n iterator cond init =
+  if cond next
+     then fixPt (n - 1) iterator cond init
+     else next
+  where
+    next = iterator init

src/Data/Graph/FGL.hs

@@ -22,7 +22,7 @@ replaceLNode gr (n, ln) = gmap replacer gr
 
 -- | Find LNode of a node (i.e. a node with label)
 lnode :: (Graph gr) => gr a b -> Node -> Maybe (LNode a)
-lnode cgr n = case lab cgr n of
+lnode gr n = case lab gr n of
   Nothing -> Nothing
   Just l  -> Just (n, l)