[FLouvain] deltaQ first working version, iterate example once

src/Data/Graph/Clustering/Example.hs

@@ -3,7 +3,27 @@ module Data.Graph.Clustering.Example where
 import Data.List (sort)
 import Data.Graph.Clustering.Louvain.Utils
 import Data.Graph.Inductive
+import Data.Graph.Clustering.FLouvain
 
+-- | Utility function to remap Gr () Double into FGraph () ()
+exampleRemap :: Gr () Double -> FGraph () ()
+exampleRemap gr = gmap remap gr
+  where
+    remap :: Context () Double -> Context () (Weight, ())
+    remap (p, v, l, s) = (p', v, l, s')
+      where
+      edgeMap (w, n) = ((Weight w, ()), n)
+      p' = map edgeMap p
+      s' = map edgeMap s
+
+-- | Run FLouvain.iterate on an example graph
+-- Example call:
+-- putStrLn $ prettify $ iterateOnce cuiller
+iterateOnce :: Gr () Double -> CGr
+iterateOnce gr = iteration fgr cgr
+  where
+    fgr = exampleRemap gr
+    cgr = initialCGr fgr
 
 karate :: Gr () Double
 -- karate =  mkGraph' <$> importGraphFromGexf "src/Data/karate.gexf"

src/Data/Graph/Clustering/FLouvain.hs

@@ -53,6 +53,17 @@ data ClusteringMethod = Glue | Klue
 ------------------------------------------------------------------------
 -- | Specific FGL needed functions
 
+-- | Get label of an 'LNode'
+llab :: LNode a -> a
+llab (_, a) = a
+
+-- | Given a 'DynGraph', replace a given 'LNode a' with new label (of type 'a')
+replaceLNode ::  (DynGraph gr) => gr a b -> LNode a -> gr a b
+replaceLNode gr (n, ln) = gmap replacer gr
+  where
+    replacer (p, v, l, s) =
+      if v == n then (p, v, ln, s) else (p, v, l, s)
+
 -- | 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
@@ -83,6 +94,7 @@ xdfsFoldWith d f acc (v:vs) g =
 
 -- Our basic graph. Nodes have custom labels. Edges have weight assigned to them.
 newtype Weight = Weight { unWeight :: Double }
+  deriving (Show, Eq, Ord)
 type FEdge b = (Weight, b)
 fedgeWeight :: FEdge b -> Double
 fedgeWeight = unWeight . fst
@@ -90,8 +102,10 @@ type FGraph a b = Gr a (FEdge b)
 
 -- Used for k_i in formula (2)
 newtype NodeWeightSum = NodeWeightSum { unNodeWeightSum :: Double }
+  deriving (Show, Eq, Ord)
 -- Used for k_i,in in formula (2)
 newtype NodeComWeightSum = NodeComWeightSum { unNodeComWeightSum :: Double }
+  deriving (Show, Eq, Ord)
 -- 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)
@@ -100,15 +114,20 @@ newtype NodeComWeightSum = NodeComWeightSum { unNodeComWeightSum :: Double }
 
 -- | 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
 newtype InWeightSum = InWeightSum { unInWeightSum :: Double }
+  deriving (Show, Eq, Ord)
 -- | This is the \Sum_tot in formula (2) of the Louvain paper
 newtype TotWeightSum = TotWeightSum { unTotWeightSum :: Double }
+  deriving (Show, Eq, Ord)
 -- | Computed Delta_Q value in (2)
 newtype DeltaQ = DeltaQ { unDeltaQ :: Double }
+  deriving (Show, Eq, Ord)
 
 -- | Type for the clusters we will be creating.
 newtype Community = Community { unCommunity ::  ([Node], InWeightSum, TotWeightSum) }
+  deriving (Show, Eq, Ord)
 comNodes :: Community -> [Node]
 comNodes (Community (ns, _, _)) = ns
 comInWeightSum :: Community -> InWeightSum
@@ -119,13 +138,32 @@ comTotWeightSum (Community (_, _, totWeightSum)) = totWeightSum
 type CGrNode = Node
 type CGrEdge = (InWeightSum, TotWeightSum)
 
-type CGr = Gr Community CGrEdge
+type CGr = Gr Community ()
 
 graphWeight :: FGraph a b -> GraphWeightSum
 graphWeight gr = GraphWeightSum $ ufold weight' 0 gr
   where
-    weight' (p, _, _, s) acc = acc + (sum $ map (fedgeWeight . fst) $ p <> s)
+    weight' (p, _, _, s) acc = acc + sum (map (fedgeWeight . fst) $ p <> s)
 
+-- | Compute initial 'CGr' for a given 'FGraph a b'. This means, put each node
+-- in a separate community.
+initialCGr :: FGraph a b -> CGr
+initialCGr gr = gmap singletonCom gr
+  where
+    -- A singleton community is given:
+    -- the same node id for a community
+    -- same incoming/outgoing edges
+    -- custom Community label
+    singletonCom (p, v, l, s) = (p', v, Community ([v], iws, tws), s')
+      where
+        p' = map edgeComRemap p
+        s' = map edgeComRemap s
+        edgeComRemap (_, n) = ((), n)
+        edges = lneighbors gr v
+        -- no internal links
+        iws = InWeightSum 0.0
+        -- just sum over the edges coming into/out of node v
+        tws = TotWeightSum $ sum $ map (fedgeWeight . fst) edges
 
 -- ALGORITHM
 
@@ -136,12 +174,12 @@ modularity gr cgr = 0.0
 type Delta = Community -> NodeWeightSum -> NodeComWeightSum -> GraphWeightSum -> DeltaQ
 -- | Delta Q function from Louvain paper (2).
 delta :: Delta
-delta com ki kin m = DeltaQ $ acc - dec
+delta com ki kiin m = DeltaQ $ acc - dec
   where
     inWeightSum = comInWeightSum com
     totWeightSum = comTotWeightSum com
     acc = accL - accR*accR
-    accL = 0.5 * (unInWeightSum inWeightSum + 2.0 * (unNodeComWeightSum kin)) / (unGraphWeightSum m)
+    accL = 0.5 * (unInWeightSum inWeightSum + 2.0 * (unNodeComWeightSum kiin)) / (unGraphWeightSum m)
     accR = 0.5 * (unTotWeightSum totWeightSum + unNodeWeightSum ki) / (unGraphWeightSum m)
     dec = decL - decM * decM - decR * decR
     decL = 0.5 * (unInWeightSum inWeightSum) / (unGraphWeightSum m)
@@ -168,18 +206,32 @@ iteration gr cs = xdfsFoldWith suc' (\(_, v, _, _) -> step gw $ context gr $ v)
 -- | Step for one node. We try re-assign it to a neighbouring community, where
 -- the increase of modularity for graph will be the largest
 step :: GraphWeightSum -> CFunFold a (FEdge b) CGr
-step gw (p, v, l, s) cgr = cgr
+step gw ctx@(p, v, l, s) cgr = newCgr
   where
+    newCgr = case mNc of
+      Nothing -> cgr
+      Just nc ->
+        if bestFitdq > 0.0 then
+          let newBestFitCom = makeMove Into bestFitCom
+              newNc = makeMove OutOf nc
+              in
+            replaceLNode (replaceLNode cgr newNc) newBestFitCom
+        else
+          cgr
+
+    (bestFitCom, DeltaQ bestFitdq) = maximumBy (\(_, deltaq1) (_, deltaq2) -> compare deltaq1 deltaq2) deltas
+
     mNc :: Maybe (LNode Community)
-    mNc = nodeCommunity  v cgr
+    mNc = nodeCommunity v cgr
     ncs :: [LNode Community]
     ncs = nodeNeighbours v cgr
+
     -- We move node from community nc into ncs
-    moves :: Maybe (LNode Community, [LNode Community])
-    moves = case mNc of
-      Nothing -> Nothing
-      Just nc -> Just ( makeMove OutOf nc
-                      , map (makeMove Into) ncs )
+    -- moves :: Maybe (LNode Community, [LNode Community])
+    -- moves = case mNc of
+    --   Nothing -> Nothing
+    --   Just nc -> Just ( makeMove OutOf nc
+    --                   , map (makeMove Into) ncs )
 
     makeMove :: Direction -> LNode Community -> LNode Community
     makeMove direction (cn, c) = (cn, moveNodeWithNeighbours (p <> s) v direction c)
@@ -188,14 +240,15 @@ step gw (p, v, l, s) cgr = cgr
     ki :: NodeWeightSum
     ki = NodeWeightSum $ sum $ map (fedgeWeight . fst) $ p <> s
 
-    -- k_i,in variable in formula (2)
-    kiin :: Maybe NodeComWeightSum
-    kiin = case mNc of
-      Nothing -> Nothing
-      Just (_, com) -> Just $
-          NodeComWeightSum $ sum $ map (fedgeWeight . fst) $ filter (\(l, n) -> n `elem` (comNodes com)) s
+    deltas :: [(LNode Community, DeltaQ)]
+    deltas = map (\c -> (c, delta' c)) ncs
 
-    --bestFit = maximumBy
+    delta' :: LNode Community -> DeltaQ
+    delta' com = delta (llab com) ki kiin gw
+      where
+        -- k_i,in variable in formula (2)
+        kiin :: NodeComWeightSum
+        kiin = nodeComWeightSum (llab com) ctx
 
     -- TODO Compute \Delta Q (gain of moving node v into Community C) which consists of:
     -- - Community InWeightSum
@@ -206,6 +259,9 @@ step gw (p, v, l, s) cgr = cgr
     -- So the Delta function takes as parameters:
     -- C, (edges from C in cgr), (edges from v in gr), (edges from v to C), (edges in gr)
 
+nodeComWeightSum :: Community -> Context a (FEdge b) -> NodeComWeightSum
+nodeComWeightSum com (_, _, _, s) =
+  NodeComWeightSum $ sum $ map (fedgeWeight . fst) $ filter (\(_, n) -> n `elem` comNodes com) s
 
 -- COMMUNITY GRAPH FUNCTIONS
 
@@ -228,11 +284,11 @@ nodeNeighbours n cgr =
     Just (cn, _) -> mapMaybe (lnode cgr) (neighbors cgr cn)
 
 -- | Find 'Ajd CGrEdge's of 'Community' graph neighbouring a given node
-nodeLNeighbours :: Node -> CGr -> Adj CGrEdge
-nodeLNeighbours n cgr =
-  case nodeCommunity n cgr of
-    Nothing        -> []
-    Just (cn, _) -> lneighbors cgr cn
+-- nodeLNeighbours :: Node -> CGr -> Adj CGrEdge
+-- nodeLNeighbours n cgr =
+--   case nodeCommunity n cgr of
+--     Nothing        -> []
+--     Just (cn, _) -> lneighbors cgr cn
 
 -- | Moves 'Node' in the 'Direction' of 'Community' and recomputes 'Community''s weights
 moveNode :: FGraph a b -> Node -> Direction -> Community -> Community