[ILouvain] PathNodes + stepB

src/Data/Graph/Clustering/ILouvain.hs

@@ -17,11 +17,13 @@ module Data.Graph.Clustering.ILouvain
 import Debug.SimpleReflect
 import Data.Set (fromList)
 import Data.Maybe (catMaybes, maybe)
-import Data.List (zip, cycle)
+import Data.List (zip, cycle, null)
 import Protolude hiding (empty, (&))
 import Data.Graph.Inductive
 import qualified Data.Graph.Clustering.HLouvain as H
 
+data NodePath = AllNodes | DfsNodes
+
 ------------------------------------------------------------------------
 -- HyperGraph Definition
 type HyperGraph   a b = Gr (Gr () a) b
@@ -29,24 +31,34 @@ type HyperContext a b = Context (Gr () a) b
 -- TODO Later (hypothesis still)
 -- type StreamGraph  a b = Gr a (Gr () b)
 
+------------------------------------------------------------------------
 toNodes :: HyperGraph a a -> [[Node]]
 toNodes g = map (hnodes g) (nodes g)
 
+isFlat :: HyperGraph a b -> Bool
+isFlat g = all (isEmpty . snd) (labNodes g)
+
+------------------------------------------------------------------------
 iLouvain :: (Eq a, Show a)
-         => Int -> HyperGraph a a -> HyperGraph a a
-iLouvain 0 g = g
-iLouvain 1 g = (iLouvain' g g)
-iLouvain n g = iLouvain' g (iLouvain (n-1) g)
+         => Int -> NodePath -> HyperGraph a a -> HyperGraph a a
+iLouvain 0 p g = g
+iLouvain n p g = iLouvain' p g (iLouvain (n-1) p g)
 
 iLouvain' :: (Eq a, Show a)
-          => HyperGraph a a
+          => NodePath
           -> HyperGraph a a
           -> HyperGraph a a
-iLouvain' g0 g = iLouvain'' g0 $ filter (\n -> elem n (nodes g)) ps
+          -> HyperGraph a a
+iLouvain' p g g' = iLouvain'' g $ filter (\n -> elem n (nodes g)) ps
   where
     -- quick trick to filter path but path of HyperGraph can be different
-    ps = nodes g0
-    -- ps = path' g0
+    -- ps = nodes g0
+    ps = if isFlat g'
+            then case p of
+                   AllNodes -> nodes g
+                   DfsNodes -> path' g
+            else reverse $ sortOn (Down . length . hnodes g')
+                         $ nodes g
 
 iLouvain'' :: Show a
            => HyperGraph a a
@@ -54,7 +66,7 @@ iLouvain'' :: Show a
            -> HyperGraph a a
 iLouvain'' g [ ] = g
 iLouvain'' g [_] = g
-iLouvain'' g ns  = foldl' (\g1 n -> step' g g1 n
+iLouvain'' g ns  = foldl' (\g1 n -> step g g1 n
                           $ filter (\m -> elem m (nodes g1))
                           $ neighbors g n
                           ) g ns
@@ -62,37 +74,49 @@ iLouvain'' g ns  = foldl' (\g1 n -> step' g g1 n
 -- g1 has holes in network (case below):
 -- iLouvain'' g ns  = foldl' (\g1 n -> step' g g1 n $ neighbors g1 n) g ns
 
-step' :: Show a
+step :: Show a
      => HyperGraph a b
      -> HyperGraph a a
      -> Node
      -> [Node]
      -> HyperGraph a a
-step' g g' n ns = -- trace ("step'" :: Text) $
+step g g' n ns = -- trace ("step'" :: Text) $
   foldl' (\g1 n' -> case match n g1 of
            (Nothing, _) -> g1
-           (Just _, _ ) -> step g g1 n n'
+           (Just _, _ ) -> step' g g1 n n'
           ) g' ns
 
-step :: Show a
+step' :: Show a
      => HyperGraph a b
      -> HyperGraph a a
      -> Node
      -> Node
      -> HyperGraph a a
-step g g' n1 n2 = -- trace ("step" :: Text) $
-  if s2 > 0 && s2 >= s1
-  -- if s2 >= s1
+step' g g' n1 n2 = -- trace ("step" :: Text) $
+  -- if s2 > 0 && s2 >= s1
+  if s2 >= s1
     then -- trace ("step:mv" :: Text) $
       mv g' [n1] [n2]
     else -- trace ("step:else" :: Text) $
       g'
   where
-    s1 = -- trace ("mod1" :: Text) $
+    s1 = -- trace ("step:mod1" :: Text) $
       imodularity g [n1]
-    s2 = -- trace ("mod2" :: Text) $
+    s2 = -- trace ("step:mod2" :: Text) $
       imodularity g [n1,n2]
 
+stepB :: Show a
+     => HyperGraph a b
+     -> HyperGraph a a
+     -> Node
+     -> [Node]
+     -> HyperGraph a a
+stepB g g' n ns = snd
+  $ maximumBy (\(n1,g1) (n2,g2) -> compare (imodularity g [n1]) (imodularity g [n2])) gs
+    where
+      gs = (n, g') : map (\m -> (m, mv g' [n] [m])) ns
+
+
 ------------------------------------------------------------------------
 hnodes :: HyperGraph a b -> Node -> [Node]
 hnodes g n = case match n g of