Commit 9b4b5bcb authored by Przemyslaw Kaminski's avatar Przemyslaw Kaminski

[FLouvain] add modularity + runIterations in example

parent 7be98c49
module Data.Graph.Clustering.Example where module Data.Graph.Clustering.Example where
import Control.Monad (foldM_)
import Data.List (sort) import Data.List (sort)
import Data.Graph.Clustering.Louvain.Utils import Data.Graph.Clustering.Louvain.Utils
import Data.Graph.Inductive import Data.Graph.Inductive
...@@ -26,6 +27,26 @@ iterateOnce gr = iteration fgr cgr ...@@ -26,6 +27,26 @@ iterateOnce gr = iteration fgr cgr
fgr = exampleRemap gr fgr = exampleRemap gr
cgr = initialCGr fgr 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 :: Gr () Double
-- karate = mkGraph' <$> importGraphFromGexf "src/Data/karate.gexf" -- 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)] 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)]
......
...@@ -126,6 +126,8 @@ newtype TotWeightSum = TotWeightSum { unTotWeightSum :: Double } ...@@ -126,6 +126,8 @@ newtype TotWeightSum = TotWeightSum { unTotWeightSum :: Double }
-- | Computed Delta_Q value in (2) -- | Computed Delta_Q value in (2)
newtype DeltaQ = DeltaQ { unDeltaQ :: Double } newtype DeltaQ = DeltaQ { unDeltaQ :: Double }
deriving (Show, Eq, Ord) deriving (Show, Eq, Ord)
newtype Modularity = Modularity { unModularity :: Double }
deriving (Show, Eq, Ord)
-- | Type for the clusters we will be creating. -- | Type for the clusters we will be creating.
newtype Community = Community { unCommunity :: ([Node], InWeightSum, TotWeightSum) } newtype Community = Community { unCommunity :: ([Node], InWeightSum, TotWeightSum) }
...@@ -170,8 +172,23 @@ initialCGr gr = gmap singletonCom gr ...@@ -170,8 +172,23 @@ initialCGr gr = gmap singletonCom gr
-- ALGORITHM -- ALGORITHM
-- | Q function from Louvain paper (1). -- | Q function from Louvain paper (1).
modularity :: Gr a b -> CGr -> Double -- We just fold over the communities (this is because of the delta(c_i, c_j)
modularity gr cgr = 0.0 -- 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 type Delta = Community -> NodeWeightSum -> NodeComWeightSum -> GraphWeightSum -> DeltaQ
-- | Delta Q function from Louvain paper (2). -- | Delta Q function from Louvain paper (2).
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment