[ILouvain] HyperGraph funs before clean.

src/Data/Graph/Clustering/ILouvain.hs

@@ -7,7 +7,7 @@ Maintainer  : alexandre.delanoe+louvain@iscpif.fr
 Stability   : experimental
 Portability : POSIX
 
-ILouvain: really inductive Graph clustering with destructives updates
+ILouvain: inductive Graph clustering with destructives updates
 
 metagraph (plural metagraphs) (mathematics) A representation of a set of nodes and the morphisms relating them
 https://en.wiktionary.org/wiki/metagraph
@@ -37,10 +37,11 @@ data NodePath = AllNodes | DfsNodes
 -- MetaGraph (x,y) where x is space (hyper structure of labels), y is
 -- time like (stream structure)
 -- (Below LabGraph definition)
-type HyperGraph'  a b c = Gr (HyperGraph a b) c
+type HyperGraph'   a b c = Gr (HyperGraph a b) c
+type HyperContext' a b c = Context (HyperGraph a b) c
 
-type HyperGraph   a b   = Gr (Gr () a) b
-type HyperContext a b   = Context (Gr () a) b
+type HyperGraph    a b   = Gr (Gr () a) b
+type HyperContext  a b   = Context (Gr () a) b
 
 -- TODO: EdgeGraph (StreamGraph)
 -- type StreamGraph  a b = Gr a (Gr () b)
@@ -49,6 +50,10 @@ type HyperContext a b   = Context (Gr () a) b
 type MaxIterations = Int
 type MaxSize       = Int
 
+type Start a = HyperGraph' a a a
+type Trans a = HyperGraph' a a a
+type Final a = HyperGraph' a a a
+------------------------------------------------------------------------
 iLouvain :: (Eq a, Show a)
          => MaxIterations
          -> MaxSize
@@ -62,6 +67,18 @@ iLouvain n s p g
     where
       g' = iLouvain (n-1) s p g
 
+iLouvainH :: (Eq a, Show a)
+         => MaxIterations
+         -> MaxSize
+         -> NodePath
+         -> Start a
+         -> Final a
+iLouvainH 0 s p g = g
+iLouvainH n s p g
+  | length (toNodes' g') <= s = g'
+  | otherwise                = iLouvainH' p g g'
+    where
+      g' = iLouvainH (n-1) s p g
 ------------------------------------------------------------------------
 iLouvain' :: (Eq a, Show a)
           => NodePath
@@ -78,6 +95,23 @@ iLouvain' p g g' =   -- trace (show ps :: Text)
                      DfsNodes -> path' g
               else sortOn (length . hnodes g') (nodes g')
 
+iLouvainH' :: (Eq a, Show a)
+          => NodePath
+          -> Start a
+          -> Trans a
+          -> Final a
+iLouvainH' p g g' =   -- trace (show ps :: Text)
+  iLouvainH'' g g' ps -- $ filter (\n -> elem n (nodes g)) ps
+    where
+      -- quick trick to filter path but path of HyperGraph can be different
+      ps = if isFlat' g'
+              then case p of
+                     AllNodes -> nodes g
+                     DfsNodes -> path' g
+              else sortOn (length . hnodes' g') (nodes g')
+
+
+------------------------------------------------------------------------
 iLouvain'' :: Show a
            => HyperGraph a a
            -> HyperGraph a a
@@ -87,9 +121,19 @@ iLouvain'' g g' ns  = foldl' (\g1 n -> trace (show (n, toNodes g1) :: Text)
                              $ stepMax g g1 n
                              $ neighborhood g g1 n ) g' ns
 
+iLouvainH'' :: Show a
+           => Start a
+           -> Trans a
+           -> [Node]
+           -> Final a
+iLouvainH'' g g' ns  = foldl' (\g1 n -> trace (show (n, toNodes' g1) :: Text) 
+                             $ stepMax' g g1 n
+                             $ neighborhood' g g1 n ) g' ns
+
+
+------------------------------------------------------------------------
 -- | Neighborhood definition
 -- TODO optim sort by jackard
--- TODO remove first Graph
 -- TODO Tests
 neighborhood :: HyperGraph a a -> HyperGraph a a -> Node -> [Node]
 neighborhood g g' n = case isFlat g' of
@@ -98,45 +142,28 @@ neighborhood g g' n = case isFlat g' of
                       && (not . Set.null) (Set.intersection (fromList $ hnodes g m) (hood g g' n))
                   ) (nodes g')
 
+neighborhood' :: HyperGraph' a a a -> HyperGraph' a 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
-     -> HyperGraph a a
-     -> Node
-     -> [Node]
-     -> HyperGraph a a
-step g g' n ns = -- trace ("step'" :: Text) $
-  foldl' (\g1 n' -> case match n g1 of
-           (Nothing, _) -> g1
-           (Just _, _ ) -> step' g g1 n n'
-          ) g' ns
-
-step' :: Show a
-     => HyperGraph a b
-     -> HyperGraph a a
-     -> Node
-     -> Node
-     -> HyperGraph a 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) $
-      mv g' [n1] [n2]
-    else -- trace ("step:else" :: Text) $
-      g'
+hood' :: HyperGraph' a a a -> HyperGraph' a a a -> Node -> Set Node
+hood' g g' n = H.exclusion (fromList ns) candidates
   where
-    s1 = -- trace ("step:mod1" :: Text) $
-      imodularity g g' [n1]
-    s2 = -- trace ("step:mod2" :: Text) $
-      imodularity g g' [n1,n2]
+    candidates = fromList $ concat $ map (neighbors g) ns
+    ns         = hnodes' g' n
 
--- | Here we need more depth in the HyperGraph
+------------------------------------------------------------------------
+-- | Here we need more depth in the HyperGraph => HyperGraph'
 stepMax :: Show a
      => HyperGraph a b
      -> HyperGraph a a
@@ -152,24 +179,61 @@ stepMax g g' x xs =
                                           ) g'
                    $ zip (x:xs) xs
 
-------------------------------------------------------------------------
-class IsHyperGraph a where
-  toHyperGraph_ :: Gr () Double -> a
-  hnodes_       :: a -> Node -> [Node]
-  toNodes_      :: a -> [[Node]]
+-------------------------------------------------------------------------
+stepMax' :: Show a
+     => Start a
+     -> Trans a
+     -> Node
+     -> [Node]
+     -> Final a
+stepMax' g g' x xs =
+  maximumBy (\(g1) (g2) -> compare (gmodularity' g g1) (gmodularity' g g2))
+                   $ scanl (\g'' (p,n) -> trace (show (p,n) :: Text) $
+                                       if p == x
+                                          then mvH g'' [x]   [n]
+                                          else mvH g'' [p,x] [n]
+                                          ) g'
+                   $ zip (x:xs) xs
+
 
-  mv_           :: a -> [Node] -> [Node] -> a
 
+------------------------------------------------------------------------
+class IsHyperGraph gr where
+  toHyperGraph_ :: Gr () a -> gr a a
   -- flat is to HyperGraph what is empty to Graph
-  flat_         :: a
-  isFlat_       :: a -> Bool
+  isFlat_       :: gr a b -> Bool
+
+  hnodes_       :: gr a b -> Node -> [Node]
+  toNodes_      :: gr a b -> [[Node]]
+
+  imodularity_  :: gr a b -> gr a b -> [Node] -> Double
+  gmodularity_  :: gr a b -> gr a b -> Double
+
+  mv_           :: gr a b -> [Node] -> [Node] -> gr a b
+  -- hdeg_         :: a -> Node -> Maybe Int
+
+------------------------------------------------------------------------
+
+{-
+instance IsHyperGraph HyperGraph
+  where
+    toHyperGraph_ g = nmap (\_ -> empty) g
+    isFlat_ = isFlat
 
-  imodularity_  :: a -> a -> [Node] -> Double
-  gmodularity_  :: a -> a -> Double
+    hnodes_ g n = case match n g of
+      (Nothing          , _) -> []
+      (Just (p, n, l, s), _) -> n : nodes l
+
+    toNodes_ g = map (hnodes g) (nodes g)
+
+    imodularity_ = imodularity
+    gmodularity_ = gmodularity
+
+    mv_ = mv
+-}
 
-  hdeg_         :: a -> Node -> Maybe Int
-  
 ------------------------------------------------------------------------
+
 hnodes :: HyperGraph a b -> Node -> [Node]
 hnodes g n = case match n g of
   (Nothing          , _) -> []
@@ -288,7 +352,9 @@ mvH :: Show a
     => HyperGraph' a a a
     -> [Node] -> [Node]
     -> HyperGraph' a a a
-mvH = undefined
+mvH g [ ] [ ] = g
+mvH g [_] [ ] = g
+mvH g [ ] [_] = g
 
 
 
@@ -298,7 +364,6 @@ mv :: Show a => HyperGraph a a
 mv g [ ] [ ] = g
 mv g [_] [ ] = g
 mv g [ ] [_] = g
-
 mv g [a] [b] = case a == b of
   True  -> panic "mv, impossible: from node == dest node"
   False -> mv' g a b
@@ -309,7 +374,6 @@ mv g [a,b] [ ] = case match a g of
                                & ((p , n , delNode b l , s )
                                & g1)
     (Nothing, _) -> panic "mv: snd path does not exist"
-
 mv g [a,b] [c] = mv (mv g [a,b] []) [b] [c]
 mv g _ _  = panic "mv:todo long path"
 
@@ -319,7 +383,7 @@ mv g _ _  = panic "mv:todo long path"
 mv' :: Show a => HyperGraph a a
     -> Node -> Node
     -> HyperGraph a a
-mv' g n1 n2 = -- trace (show (c1,c2) :: Text) $ 
+mv' g n1 n2 = -- trace (show (c1,c2) :: Text) $
   (mvMContext c1 c2) & g2
     where
       (c1, g1) = match n1 g
@@ -332,14 +396,22 @@ mvMContext (Just (a1 ,n ,l ,a2 ))
            (Just (a1',n',l',a2')) = (a1',n', merge l' (c & l),a2')
             where
               c = (a1, n, (), a2)
-
 mvMContext _ (Just _) = panic "mvMContext: First Node  does not exist"
 mvMContext (Just _) _ = panic "mvMContext: Snd   Node  does not exist"
 mvMContext _ _        = panic "mvMContext: Both  Nodes do   not exist"
 
-merge :: (Graph gr, DynGraph gr)
-      => gr a b -> gr a b -> gr a b
-merge = ufold (&)
+{-
+mvMContext' :: Maybe (HyperContext' a a a)
+            -> Maybe (HyperContext' a a a)
+            -> HyperContext' a a a
+mvMContext' (Just (a1 ,n ,l ,a2 ))
+            (Just (a1',n',l',a2')) = (a1',n', (c & l'),a2')
+            where
+              c = (a1, n, labNodes l, a2)
+mvMContext' _ (Just _) = panic "mvMContext': First Node  does not exist"
+mvMContext' (Just _) _ = panic "mvMContext': Snd   Node  does not exist"
+mvMContext' _ _        = panic "mvMContext': Both  Nodes do   not exist"
+-}
 
 ------------------------------------------------------------------------
 test_mv :: (Ord a, Show a) => HyperGraph a a -> Node -> Node -> Bool
@@ -362,5 +434,47 @@ path g' = map sortNodes cs
 
 path' :: (DynGraph gr, Eq b) => gr a b -> [Node]
 path' = maybe [] identity  . head . path
+
+------------------------------------------------------------------------
+-- FGL specific functions
+merge :: (Graph gr, DynGraph gr)
+      => gr a b -> gr a b -> gr a b
+merge = ufold (&)
 ------------------------------------------------------------------------
 ------------------------------------------------------------------------
+------------------------------------------------------------------------
+-- TO DELETE
+
+step :: Show a
+     => HyperGraph a b
+     -> HyperGraph a a
+     -> Node
+     -> [Node]
+     -> HyperGraph a a
+step g g' n ns = -- trace ("step'" :: Text) $
+  foldl' (\g1 n' -> case match n g1 of
+           (Nothing, _) -> g1
+           (Just _, _ ) -> step' g g1 n n'
+          ) g' ns
+
+step' :: Show a
+     => HyperGraph a b
+     -> HyperGraph a a
+     -> Node
+     -> Node
+     -> HyperGraph a 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) $
+      mv g' [n1] [n2]
+    else -- trace ("step:else" :: Text) $
+      g'
+  where
+    s1 = -- trace ("step:mod1" :: Text) $
+      imodularity g g' [n1]
+    s2 = -- trace ("step:mod2" :: Text) $
+      imodularity g g' [n1,n2]
+
+
+