[FLouvain] add modularity + runIterations in example

src/Data/Graph/Clustering/Example.hs

 module Data.Graph.Clustering.Example where
 
+import Control.Monad (foldM_)
 import Data.List (sort)
 import Data.Graph.Clustering.Louvain.Utils
 import Data.Graph.Inductive
@@ -26,6 +27,26 @@ iterateOnce gr = iteration fgr cgr
     fgr = exampleRemap gr
     cgr = initialCGr fgr
 
+runIterations :: Int -> Gr () Double -> IO ()
+runIterations n gr = do
+  let fgr = exampleRemap gr
+  let fgrWeight = graphWeight fgr
+  let initCgr = initialCGr fgr
+
+  putStrLn "Initial modularity: "
+  putStrLn $ show $ modularity fgr initCgr fgrWeight
+
+  foldM_ (runIteration fgr fgrWeight) initCgr [0..n]
+
+  where
+    runIteration fgr fgrWeight iterCgr i = do
+      let iterNextCgr = iteration fgr iterCgr
+      putStrLn $ "----- ITERATION " <> show i
+      putStrLn $ prettify iterNextCgr
+      putStrLn $ show i <> " iteration modularity: "
+      putStrLn $ show $ modularity fgr iterNextCgr fgrWeight
+      return iterNextCgr
+
 karate :: Gr () Double
 -- karate =  mkGraph' <$> importGraphFromGexf "src/Data/karate.gexf"
 karate = mkGraph [(1,()),(2,()),(3,()),(4,()),(5,()),(6,()),(7,()),(8,()),(9,()),(10,()),(11,()),(12,()),(13,()),(14,()),(15,()),(16,()),(17,()),(18,()),(19,()),(20,()),(21,()),(22,()),(23,()),(24,()),(25,()),(26,()),(27,()),(28,()),(29,()),(30,()),(31,()),(32,()),(33,()),(34,())] [(1,2,1.0),(1,3,1.0),(1,4,1.0),(1,5,1.0),(1,6,1.0),(1,7,1.0),(1,8,1.0),(1,9,1.0),(1,11,1.0),(1,12,1.0),(1,13,1.0),(1,14,1.0),(1,18,1.0),(1,20,1.0),(1,22,1.0),(1,32,1.0),(2,3,1.0),(2,4,1.0),(2,8,1.0),(2,14,1.0),(2,18,1.0),(2,20,1.0),(2,22,1.0),(2,31,1.0),(3,4,1.0),(3,8,1.0),(3,9,1.0),(3,10,1.0),(3,14,1.0),(3,28,1.0),(3,29,1.0),(3,33,1.0),(4,8,1.0),(4,13,1.0),(4,14,1.0),(5,7,1.0),(5,11,1.0),(6,7,1.0),(6,11,1.0),(6,17,1.0),(7,17,1.0),(9,31,1.0),(9,33,1.0),(9,34,1.0),(10,34,1.0),(14,34,1.0),(15,33,1.0),(15,34,1.0),(16,33,1.0),(16,34,1.0),(19,33,1.0),(19,34,1.0),(20,34,1.0),(21,33,1.0),(21,34,1.0),(23,33,1.0),(23,34,1.0),(24,26,1.0),(24,28,1.0),(24,30,1.0),(24,33,1.0),(24,34,1.0),(25,26,1.0),(25,28,1.0),(25,32,1.0),(26,32,1.0),(27,30,1.0),(27,34,1.0),(28,34,1.0),(29,32,1.0),(29,34,1.0),(30,33,1.0),(30,34,1.0),(31,33,1.0),(31,34,1.0),(32,33,1.0),(32,34,1.0),(33,34,1.0)]

src/Data/Graph/Clustering/FLouvain.hs

@@ -126,6 +126,8 @@ newtype TotWeightSum = TotWeightSum { unTotWeightSum :: Double }
 -- | Computed Delta_Q value in (2)
 newtype DeltaQ = DeltaQ { unDeltaQ :: Double }
   deriving (Show, Eq, Ord)
+newtype Modularity = Modularity { unModularity :: Double }
+  deriving (Show, Eq, Ord)
 
 -- | Type for the clusters we will be creating.
 newtype Community = Community { unCommunity ::  ([Node], InWeightSum, TotWeightSum) }
@@ -170,8 +172,23 @@ initialCGr gr = gmap singletonCom gr
 -- ALGORITHM
 
 -- | Q function from Louvain paper (1).
-modularity :: Gr a b -> CGr -> Double
-modularity gr cgr = 0.0
+-- We just fold over the communities (this is because of the delta(c_i, c_j)
+-- param)
+modularity :: FGraph a b -> CGr -> GraphWeightSum -> Modularity
+modularity gr cgr m = Modularity $ 0.5 * ( ufold modularity' 0.0 cgr ) / (unGraphWeightSum m)
+  where
+    -- sum over nodes in community
+    -- \Sum A_ij is just the InWeightSum
+    modularity' (_, _, com, _) acc = acc + component
+      where
+        component = (unInWeightSum $ comInWeightSum com) - weightsMul
+        weightsMul = 0.5 * ( sum $ map weightsMul' $ comNodes com ) / (unGraphWeightSum m)
+        weightsMul' n = (ki n) * (sum $ map ki $ comNodes com)
+        -- k_i variable in formula (1)
+        ki :: Node -> Double
+        ki n = sumEdgeWeights $ p <> s
+          where
+            (p, _, _, s) = context gr n
 
 type Delta = Community -> NodeWeightSum -> NodeComWeightSum -> GraphWeightSum -> DeltaQ
 -- | Delta Q function from Louvain paper (2).