[ILouvain] ok, to be qualitatively tested

src/Data/Graph/Clustering/ILouvain.hs

@@ -9,13 +9,17 @@ Portability : POSIX
 
 ILouvain: really inductive Graph clustering with destructives updates
 
+todo FGL improvements:
+- deg should have return type Maybe Int
+- match should be Maybe (Context, Graph)
+
 -}
 
 module Data.Graph.Clustering.ILouvain
   where
 
 import Debug.SimpleReflect
-import Data.Set (fromList)
+import Data.Set (fromList, Set)
 import qualified Data.Set as Set
 import Data.Maybe (catMaybes, maybe)
 import Data.List (zip, cycle, null)
@@ -40,18 +44,29 @@ isFlat :: HyperGraph a b -> Bool
 isFlat g = all (isEmpty . snd) (labNodes g)
 
 ------------------------------------------------------------------------
+type MaxIterations = Int
+type MaxSize       = Int
+
 iLouvain :: (Eq a, Show a)
-         => Int -> NodePath -> HyperGraph a a -> HyperGraph a a
-iLouvain 0 p g = g
-iLouvain n p g = trace (show $ toNodes g :: Text) $
-  iLouvain' p g (iLouvain (n-1) p g)
+         => MaxIterations
+         -> MaxSize
+         -> NodePath
+         -> HyperGraph a a
+         -> HyperGraph a a
+iLouvain 0 s p g = g
+iLouvain n s p g
+  | length (toNodes g') <= s = g'
+  | otherwise    = iLouvain' p g g'
+    where
+      g' = iLouvain (n-1) s p g
 
+------------------------------------------------------------------------
 iLouvain' :: (Eq a, Show a)
           => NodePath
           -> HyperGraph a a
           -> HyperGraph a a
           -> HyperGraph a a
-iLouvain' p g g' = trace (show ps :: Text)
+iLouvain' p g g' = -- trace (show ps :: Text)
   iLouvain'' g g' ps -- $ filter (\n -> elem n (nodes g)) ps
     where
       -- quick trick to filter path but path of HyperGraph can be different
@@ -67,19 +82,25 @@ iLouvain'' :: Show a
            -> [Node]
            -> HyperGraph a a
 iLouvain'' g g' [ ] = g'
-iLouvain'' g g' ns  = foldl' (\g1 n -> step g g1 n $ ineighbors g1 n ) g' ns
+iLouvain'' g g' ns  = foldl' (\g1 n -> step g g1 n $ neighborhood g g1 n ) g' ns
 
--- | ineihbors Definition
+-- | Neighborhood definition
 -- TODO optim sort by jackard
-ineighbors :: HyperGraph a a -> Node -> [Node]
-ineighbors g n = case isEmpty g of
-  True  -> neighbors g n
-  False -> filter (\m -> Set.null (Set.intersection (fromList $ hnodes g m) n')
-                        && m /= n) (nodes g)
-    where
-      n'         = H.exclusion candidates (fromList ns)
-      candidates = fromList $ concat $ map (neighbors g) ns
-      ns         = hnodes g n
+-- TODO remove first Graph
+-- TODO Tests
+neighborhood :: HyperGraph a a -> HyperGraph a a -> Node -> [Node]
+neighborhood g g' n = case isFlat g' of
+  True  -> neighbors g' n
+  False -> filter (\m -> m /= n
+                      && (not . Set.null) (Set.intersection (fromList $ hnodes g m) (hood g g' n))
+                  ) (nodes g')
+
+hood :: HyperGraph a a -> HyperGraph a a -> Node -> Set Node
+hood g g' n = H.exclusion (fromList ns) candidates
+  where
+    candidates = fromList $ concat $ map (neighbors g) ns
+    ns         = hnodes g' n
+
 
 step :: Show a
      => HyperGraph a b
@@ -102,15 +123,15 @@ step' :: Show a
 step' g g' n1 n2 = -- trace ("step " <> show n1 <> " " <> show n2 :: Text) $
   if s2 > 0 && s2 >= s1
   -- if s2 >= s1
-    then trace ("step:mv " <> show n1 <> " " <> show n2 :: Text) $
+    then -- trace ("step:mv " <> show n1 <> " " <> show n2 :: Text) $
       mv g' [n1] [n2]
     else -- trace ("step:else" :: Text) $
       g'
   where
     s1 = -- trace ("step:mod1" :: Text) $
-      imodularity g [n1]
+      imodularity g g' [n1]
     s2 = -- trace ("step:mod2" :: Text) $
-      imodularity g [n1,n2]
+      imodularity g g' [n1,n2]
 
 stepMax :: Show a
      => HyperGraph a b
@@ -119,28 +140,28 @@ stepMax :: Show a
      -> [Node]
      -> HyperGraph a a
 stepMax g g' n ns = snd
-  $ maximumBy (\(n1,g1) (n2,g2) -> compare (imodularity g [n1]) (imodularity g [n2])) gs
+  $ maximumBy (\(n1,g1) (n2,g2) -> compare (imodularity g g1 [n1]) (imodularity g g2 [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
   (Nothing          , _) -> []
   (Just (p, n, l, s), _) -> n : nodes l
+
 {-
 hdeg :: Graph gr => gr a b -> Node -> Maybe Int
 hdeg = undefined
 -}
 ------------------------------------------------------------------------
 -- TODO go depth in HyperGraph (modularity at level/depth)
-imodularity :: HyperGraph a b -> [Node] -> Double
-imodularity g ns = -- trace ("imodul" :: Text) $
+imodularity :: HyperGraph a b -> HyperGraph a a -> [Node] -> Double
+imodularity g g' ns = -- trace ("imodul" :: Text) $
                    H.hmodularity g
                  $ fromList
                  $ concat
-                 $ map (hnodes g) ns
+                 $ map (hnodes g') ns
 
 ------------------------------------------------------------------------
 toHyperGraph :: Gr () Double -> HyperGraph Double Double