[flouvain] more work on the louvain algorithm

src/Data/Graph/Clustering/FLouvain.hs

@@ -39,6 +39,8 @@ module Data.Graph.Clustering.FLouvain
 
 import Protolude
 import Data.Graph.Inductive
+import qualified Data.List as DL
+import Data.Tuple.Extra (fst3)
 
 --  "glue" : function to gather/merge communities
 --  "klue" : function to split communities
@@ -70,29 +72,52 @@ xdfsFoldWith d f acc (v:vs) g = case match v g of
                                  (Nothing, g') -> xdfsFoldWith d f acc vs g'
 
 
--- This is the \Sum_in in formula (2) of Louvain paper
-type WeightSum = Double
-newtype Community = Community { unCommunity ::  ([Node], WeightSum) }
+-- Our basic graph. Nodes have custom labels. Edges have weight assigned to them.
+type FEdge = Double
+type FGraph a = Gr a FEdge
+
+-- | This is the \Sum_in in formula (2) of Louvain paper
+type InWeightSum = Double
+-- | This is the \Sum_tot in formula (2) of Louvain paper
+type TotWeightSum = Double
+newtype Community = Community { unCommunity ::  ([Node], InWeightSum, TotWeightSum) }
 
 type CGrNode = Node
-type CGrEdge = Double
+type CGrEdge = (InWeightSum, TotWeightSum)
 
 type CGr = Gr Community CGrEdge
 
 
 -- ALGORITHM
 
+type Delta a b = Gr a b -> Node -> Community -> Double
+-- | Delta Q function from Louvain paper (2).
+delta :: Delta a b
+delta gr n (Community (ns, inWeightSum, totWeightSum)) = 0.0
+
 -- | One iteration step takes the graph and existing communities as a graph and
 -- computes new community graph
-iteration :: (Graph gr) => gr a b -> CGr -> CGr
+iteration :: FGraph a -> CGr -> CGr
 iteration gr cs = xdfsFoldWith suc' step cs (nodes gr) gr
 
 -- TODO Remember to filter out empty Communities
-step :: CFunFold a b CGr
+-- | 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 :: CFunFold a FEdge CGr
 step (p, v, l, s) cgr = cgr
   where
-    nc  = nodeCommunity v cgr
+    mNc  = nodeCommunity v cgr
     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 )
+
+    makeMove :: Direction -> LNode Community -> LNode Community
+    makeMove direction (cn, c) = (cn, moveNodeWithNeighbours (p <> s) v direction c)
+
     -- TODO Compute \Delta Q (gain of moving node v into Community C) which consists of:
     -- - Community WeightSum
     -- - sum of weights of links incident to nodes in C
@@ -105,17 +130,104 @@ step (p, v, l, s) cgr = cgr
 
 -- COMMUNITY GRAPH FUNCTIONS
 
+-- | 'Direction' when moving node 'Into'/'OutOf' community
+data Direction = Into | OutOf
+
 -- | Given 'Node' and 'Community' graph, find the 'LNode' of 'Community' which
 -- contains the node
 nodeCommunity :: Node -> CGr -> Maybe (LNode Community)
 nodeCommunity n cgr = head (filter f $ labNodes cgr)
   where
     f :: (a, Community) -> Bool
-    f (_, Community ns) = n `elem` fst ns
+    f (_, Community com) = n `elem` fst3 com
 
--- | Find 'LNodes' of 'Community' graph neighbouring a given node
+-- | Find 'LNode's of 'Community' graph neighbouring a given node
 nodeNeighbours :: Node -> CGr -> [LNode Community]
 nodeNeighbours n cgr =
   case nodeCommunity n cgr of
     Nothing        -> []
-    Just c@(cn, _) -> [c] <> mapMaybe (lnode cgr) (neighbors cgr cn)
+    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
+
+-- | Moves 'Node' in the 'Direction' of 'Community' and recomputes 'Community''s weights
+moveNode :: FGraph a -> Node -> Direction -> Community -> Community
+moveNode gr n direction c = moveNodeWithNeighbours lnNeighbors n direction c
+  where
+    lnNeighbors :: Adj FEdge
+    lnNeighbors = lneighbors gr n
+
+-- | Same asa 'moveNode' above but with only node neighbours, not whole graph
+moveNodeWithNeighbours :: Adj FEdge -> Node -> Direction -> Community -> Community
+moveNodeWithNeighbours lnNeighbors n direction (Community (ns, inwsum, totwsum)) = Community (newNs, newInWsum, newTotWsum)
+  where
+    newNs = case direction of
+      Into  -> n:ns
+      OutOf -> DL.delete n ns
+    comNeighbors :: Adj FEdge
+    comNeighbors = filter (\ln -> snd ln `elem` ns) lnNeighbors
+    nonComNeighbors :: Adj FEdge
+    nonComNeighbors = filter (\ln -> snd ln `notElem` ns) lnNeighbors
+    -- Update InWeightSum with connections between node and the community
+    sumN :: InWeightSum
+    sumN = sum $ map fst comNeighbors
+    -- Update TotWeightSum, subtracting connections between node and community
+    -- and adding connections of node to non-community
+    sumNonCom :: TotWeightSum
+    sumNonCom = sum $ map fst nonComNeighbors
+    directionN = case direction of
+      Into -> 1
+      OutOf -> -1
+    newInWsum = inwsum + directionN * sumN
+    newTotWsum = totwsum + directionN * (sumN - sumNonCom)
+
+
+
+{-
+-- | Moves 'Node' between two 'Community'ies, recomputing their weights
+moveNode' :: FGraph a -> Node -> (Community, Community) -> (Community, Community)
+moveNode' gr n cFromTo = moveNodeWithNeighbours' lnNeighbors n cFromTo
+  where
+    lnNeighbors :: Adj FEdge
+    lnNeighbors = lneighbors gr n
+
+-- | Same as 'moveNode' but with direct neighbours list
+moveNodeWithNeighbours' :: Adj FEdge -> Node -> (Community, Community) -> (Community, Community)
+moveNodeWithNeighbours' lnNeighbors n ((Community (fromNs, fromInWSum, fromTotWSum)), (Community (toNs, toInWSum, toTotWSum))) =
+  (newFrom, newTo)
+  where
+    newFrom = Community (DL.delete n fromNs, newFromInWSum, newFromTotWSum)
+    newTo = Community (n:toNs, newToInWSum, newToTotWSum)
+
+    -- Node is removed, so we reduce the internal weight sum
+    newFromInWSum = fromInWSum - sumFromN
+    newFromTotWSum = fromTotWSum + sumFromN - sumFromNonN
+
+    -- Node is added, so we increase the internal weight sum
+    newToInWSum = toInWSum + sumToN
+    newToTotWSum = toTotWSum + sumToN - sumToNonN
+
+    sumFromN :: InWeightSum
+    sumFromN = sum $ map fst fromComNeighbors
+    sumFromNonN :: TotWeightSum
+    sumFromNonN = sum $ map fst fromNonComNeighbors
+
+    sumToN :: InWeightSum
+    sumToN = sum $ map fst toComNeighbors
+    sumToNonN :: TotWeightSum
+    sumToNonN = sum $ map fst toNonComNeighbors
+
+    fromComNeighbors :: Adj FEdge
+    fromComNeighbors = filter (\ln -> snd ln `elem` fromNs) lnNeighbors
+    fromNonComNeighbors :: Adj FEdge
+    fromNonComNeighbors = filter (\ln -> snd ln `notElem` fromNs) lnNeighbors
+    toComNeighbors :: Adj FEdge
+    toComNeighbors = filter (\ln -> snd ln `elem` toNs) lnNeighbors
+    toNonComNeighbors :: Adj FEdge
+    toNonComNeighbors = filter (\ln -> snd ln `notElem` toNs) lnNeighbors
+-}