Merge branch 'flouvain' of ssh://gitlab.iscpif.fr:20022/gargantext/clustering-louvain into flouvain

clustering-louvain.cabal

@@ -45,6 +45,7 @@ library
     , hxt
     , parsec
     , protolude
+    , simple-reflect
     , text
     , turtle
     , vector

package.yaml

@@ -52,6 +52,7 @@ library:
     - parsec
     - turtle
     - foldl
+    - simple-reflect
 
 executables:
   run-example:

src/Data/Graph/Clustering/FLouvain.hs

 {-|
 Module      : Data.Graph.Clustering.FLouvain
 Description : Purely functional (Inductive) Louvain clustering
-Copyright   : (c) Alexandre Delanoë, CNRS, 2020-Present
+Copyright   : (c) CNRS, 2020-Present
 License     : AGPL + CECILL v3
-Maintainer  : alexandre.delanoe+louvain@iscpif.fr
+Maintainer  : contact@gargantext.org
 Stability   : experimental
 Portability : POSIX
 

src/Data/Graph/Clustering/HLouvain.hs

@@ -103,7 +103,7 @@ toDendo :: DynGraph gr
         -> Dendogram
 toDendo g n = Dendogram [Gram n] s
   where
-    s = modularity g (Set.singleton n)
+    s = hmodularity g (Set.singleton n)
 
 toDendoD :: DynGraph gr
          => gr n e
@@ -151,11 +151,11 @@ nodesD (Gram n)         = Set.singleton n
 nodesD (Dendogram [] _) = Set.empty
 nodesD (Dendogram s  _) = Set.unions $ map nodesD s
 
-deg :: Graph gr => gr a b -> Dendogram -> Int
-deg g d = Set.size (neighbors g d)
+hdeg :: Graph gr => gr a b -> Dendogram -> Int
+hdeg g d = Set.size (hneighbors g d)
 
-neighbors :: Graph gr => gr a b -> Dendogram -> Set Node
-neighbors g d = exclusion inNodes ouNodes
+hneighbors :: Graph gr => gr a b -> Dendogram -> Set Node
+hneighbors g d = exclusion inNodes ouNodes
   where
     inNodes :: Set Node
     inNodes = nodesD d
@@ -173,35 +173,41 @@ class HasScore a
 instance HasScore Dendogram
   where
     hasScore :: DynGraph gr => gr a b -> Dendogram -> Double
-    hasScore g m = modularity g (nodesD m)
+    hasScore g m = hmodularity g (nodesD m)
 
 instance HasScore [Dendogram]
   where
-    hasScore g ds = modularity g (Set.unions $ map nodesD ds)
+    hasScore g ds = hmodularity g (Set.unions $ map nodesD ds)
 
 modulare :: DynGraph gr => gr a b -> Set Node -> Double
-modulare = modularity
+modulare = hmodularity
 
-modularity :: DynGraph gr => gr a b -> Set Node -> Double
-modularity gr ns = coverage - edgeDensity
+hmodularity :: DynGraph gr => gr a b -> Set Node -> Double
+hmodularity g ns = coverage - edgeDensity
   where
     coverage :: Double
-    coverage  = sizeSubGraph / sizeAllGraph 
-      where
-          sizeSubGraph :: Double
-          sizeSubGraph = fromIntegral ( G.size $ subgraph' ns gr )
+    coverage  = -- trace ("coverage" :: Text) $
+      sizeSubGraph / sizeAllGraph
+        where
+            sizeSubGraph :: Double
+            sizeSubGraph = -- trace ("sizeSubGraph" :: Text) $
+              fromIntegral ( G.size $ subgraph' ns g )
 
-          sizeAllGraph :: Double
-          sizeAllGraph = fromIntegral (G.size gr)
+            sizeAllGraph :: Double
+            sizeAllGraph = -- trace ("sizeAllGraph" :: Text) $
+              fromIntegral (G.size g)
 
     edgeDensity :: Double
-    edgeDensity = (sum (Set.map (\node -> (degree node) / links ) ns)) ** 2
-      where
-          degree :: Node -> Double
-          degree node = fromIntegral (G.deg gr node)
-
-          links :: Double
-          links       = fromIntegral (2 * (G.size gr))
+    edgeDensity = -- trace ("edgeDensity" :: Text) $
+      (sum (Set.map (\node -> (degree node) / links ) ns)) ** 2
+        where
+            degree :: Node -> Double
+            degree node = -- trace ("degree" :: Text) $
+              fromIntegral (G.deg g node)
+
+            links :: Double
+            links  = -- trace ("links" :: Text) $
+              fromIntegral (2 * (G.size g))
 
 subgraph' :: DynGraph gr => Set Node -> gr a b -> gr a b
 subgraph' ns = G.subgraph (Set.toList ns)

src/Data/Graph/Clustering/ILouvain.hs

@@ -7,44 +7,144 @@ Maintainer  : alexandre.delanoe+louvain@iscpif.fr
 Stability   : experimental
 Portability : POSIX
 
-ILouvain: really inductive Graph
+ILouvain: really inductive Graph clustering with destructives updates
 
 -}
 
 module Data.Graph.Clustering.ILouvain
   where
 
+import Debug.SimpleReflect
 import Data.Set (fromList)
-import Data.Maybe (catMaybes)
-import Data.List (zip, cycle)
+import qualified Data.Set as Set
+import Data.Maybe (catMaybes, maybe)
+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
 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)
 
-hnodes :: HyperGraph a b -> Node -> [Node]
-hnodes g n = case match n g of
-  (Nothing, _) -> []
-  (Just (p, n, l, s), _) -> n : nodes l
+isFlat :: HyperGraph a b -> Bool
+isFlat g = all (isEmpty . snd) (labNodes g)
+
+------------------------------------------------------------------------
+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)
+
+iLouvain' :: (Eq a, Show a)
+          => NodePath
+          -> HyperGraph a a
+          -> HyperGraph a a
+          -> HyperGraph a a
+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
+      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
+           -> [Node]
+           -> HyperGraph a a
+iLouvain'' g g' [ ] = g'
+iLouvain'' g g' ns  = foldl' (\g1 n -> step g g1 n $ ineighbors g1 n ) g' ns
+
+-- | ineihbors 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
+
+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 [n1]
+    s2 = -- trace ("step:mod2" :: Text) $
+      imodularity g [n1,n2]
 
-hedges :: HyperGraph a b -> Node -> [Edge]
-hedges = undefined
+stepMax :: Show a
+     => HyperGraph a b
+     -> HyperGraph a a
+     -> Node
+     -> [Node]
+     -> HyperGraph a a
+stepMax 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
 
-hneighbors :: HyperGraph a b -> Node -> [Node]
-hneighbors = undefined
 
 ------------------------------------------------------------------------
-modularity :: HyperGraph a b -> [Node] -> Double
-modularity g ns = H.modularity g (fromList 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) $
+                   H.hmodularity g
+                 $ fromList
+                 $ concat
+                 $ map (hnodes g) ns
 
+------------------------------------------------------------------------
+toHyperGraph :: Gr () Double -> HyperGraph Double Double
+toHyperGraph g = nmap (\_ -> empty) g
 ------------------------------------------------------------------------
 -- Spoon Graph
 --    1
@@ -68,7 +168,7 @@ spoon = mkGraph ns es
          , (4, 5, 1.0)
          ]
 
--- | Needed functions (WIP)
+-- | Needed function
 -- mv: a Node elsewhere in the HyperGraph
 
 -- Move Properties:
@@ -83,7 +183,7 @@ spoon = mkGraph ns es
 
 -- Move target type
 -- let's start simple: path lenght <= 2 max
-mv :: HyperGraph a a
+mv :: Show a => HyperGraph a a
    -> [Node] -> [Node]
    -> HyperGraph a a
 mv g [ ] [ ] = g
@@ -94,7 +194,7 @@ mv g [a] [b] = case a == b of
   True  -> panic "mv, impossible: moved node is same as destination"
   False -> mv' g a b
 mv g [a,b] [ ] = case match a g of
-  (Nothing,  _) -> panic "mv: fst Node of Path does not exist"
+  (Nothing,  _) -> panic $ "mv: fst Node of Path does not exist: " <> show a
   (Just (p, n, l, s), g1) -> case match b l of
     (Just (p',n',l',s'), g2)  -> (p', n', g2, s')
                                & ((p , n , delNode b l , s )
@@ -106,13 +206,14 @@ mv g (x:xs) (y:ys) = panic "mv: path too long"
                   ----------------------------
 
 -- | Start simple (without path)
-mv' :: HyperGraph a a
+mv' :: Show a => HyperGraph a a
     -> Node -> Node
     -> HyperGraph a a
-mv' g n1 n2 =  (mvMContext c1 c2) & g2
-  where
-    (c1, g1) = match n1 g
-    (c2, g2) = match n2 g1
+mv' g n1 n2 = -- trace (show (c1,c2) :: Text) $ 
+  (mvMContext c1 c2) & g2
+    where
+      (c1, g1) = match n1 g
+      (c2, g2) = match n2 g1
 
 mvMContext :: Maybe (HyperContext a a)
            -> Maybe (HyperContext a a)
@@ -131,19 +232,8 @@ merge :: (Graph gr, DynGraph gr)
 merge = ufold (&)
 
 ------------------------------------------------------------------------
-test_mv :: Ord a => HyperGraph a a -> Node -> Node -> Bool
+test_mv :: (Ord a, Show a) => HyperGraph a a -> Node -> Node -> Bool
 test_mv g a b = (mv (mv g [a] [b]) [b,a] []) == g
-------------------------------------------------------------------------
--- | Recursive Node of Graph
-{-
-rnodes :: RGraph -> [Node]
-rnodes Empty = []
-rnodes g     = concat $ map (\(x1, x2) -> [x1] <> rnodes x2) $ labNodes g
-
-rlabNodes :: Graph' a b -> [LNode a]
-rlabNodes Empty' = []
-rlabNodes g      = labNodes g
--}
 
 ------------------------------------------------------------------------
 -- Paths in the Graph to be tested
@@ -160,5 +250,9 @@ path g' = map sortNodes cs
       Just  n -> dfs [n] g  -- dfs for glustering, bfs for klustering
     cs = components g
     g  = undir g'
+
+path' :: (DynGraph gr, Eq b) => gr a b -> [Node]
+path' = maybe [] identity  . head . path
+
 ------------------------------------------------------------------------
 ------------------------------------------------------------------------