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

.gitignore

+.DS_Store
+.stack-work
+.idea
+*.log
+tmp/
+
+

clustering-louvain.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 0eb2bbc80a3d9343540c4d5c0c2ff6adee085a9a75364b8f5344890891c5b781
+-- hash: 9d2b00c4d3d099b31d6b9db84cd1172e0464481bc132080e2694e02b5587b29b
 
 name:           clustering-louvain
 version:        0.1.0.0
@@ -42,5 +42,6 @@ library
       Data.Graph.Clustering.Example
       Data.Graph.Clustering.FLouvain
       Data.Graph.Clustering.HLouvain
+      Data.Graph.Clustering.ILouvain
       Paths_clustering_louvain
   default-language: Haskell2010

src/Data/Graph/Clustering/FLouvain.hs

@@ -111,6 +111,10 @@ newtype DeltaQ = DeltaQ { unDeltaQ :: Double }
 newtype Community = Community { unCommunity ::  ([Node], InWeightSum, TotWeightSum) }
 comNodes :: Community -> [Node]
 comNodes (Community (ns, _, _)) = ns
+comInWeightSum :: Community -> InWeightSum
+comInWeightSum (Community (_, inWeightSum, _)) = inWeightSum
+comTotWeightSum :: Community -> TotWeightSum
+comTotWeightSum (Community (_, _, totWeightSum)) = totWeightSum
 
 type CGrNode = Node
 type CGrEdge = (InWeightSum, TotWeightSum)
@@ -129,10 +133,20 @@ graphWeight gr = GraphWeightSum $ ufold weight' 0 gr
 modularity :: Gr a b -> CGr -> Double
 modularity gr cgr = 0.0
 
-type Delta a b = Community -> NodeWeightSum -> NodeComWeightSum -> GraphWeightSum -> DeltaQ
+type Delta = Community -> NodeWeightSum -> NodeComWeightSum -> GraphWeightSum -> DeltaQ
 -- | Delta Q function from Louvain paper (2).
-delta :: Delta a b
-delta com nws ncws gws = DeltaQ 0.0
+delta :: Delta
+delta com ki kin m = DeltaQ $ acc - dec
+  where
+    inWeightSum = comInWeightSum com
+    totWeightSum = comTotWeightSum com
+    acc = accL - accR*accR
+    accL = 0.5 * (unInWeightSum inWeightSum + 2.0 * (unNodeComWeightSum kin)) / (unGraphWeightSum m)
+    accR = 0.5 * (unTotWeightSum totWeightSum + unNodeWeightSum ki) / (unGraphWeightSum m)
+    dec = decL - decM * decM - decR * decR
+    decL = 0.5 * (unInWeightSum inWeightSum) / (unGraphWeightSum m)
+    decM = 0.5 * (unTotWeightSum totWeightSum) / (unGraphWeightSum m)
+    decR = 0.5 * (unNodeWeightSum ki) / (unGraphWeightSum m)
 
 -- | One iteration step takes the graph and existing communities as a graph and
 -- computes new community graph
@@ -165,7 +179,7 @@ step gw (p, v, l, s) cgr = cgr
     moves = case mNc of
       Nothing -> Nothing
       Just nc -> Just ( makeMove OutOf nc
-                      , makeMove Into <$> ncs )
+                      , map (makeMove Into) ncs )
 
     makeMove :: Direction -> LNode Community -> LNode Community
     makeMove direction (cn, c) = (cn, moveNodeWithNeighbours (p <> s) v direction c)

src/Data/Graph/Clustering/HLouvain.hs

@@ -194,7 +194,7 @@ modularity gr ns = coverage - edgeDensity
     coverage  = sizeSubGraph / sizeAllGraph 
       where
           sizeSubGraph :: Double
-          sizeSubGraph = fromIntegral ( G.size $ subgraph ns gr )
+          sizeSubGraph = fromIntegral ( G.size $ subgraph' ns gr )
 
           sizeAllGraph :: Double
           sizeAllGraph = fromIntegral (G.size gr)
@@ -208,8 +208,8 @@ modularity gr ns = coverage - edgeDensity
           links :: Double
           links       = fromIntegral (2 * (G.size gr))
 
-subgraph :: DynGraph gr => Set Node -> gr a b -> gr a b
-subgraph ns = G.subgraph (Set.toList ns)
+subgraph' :: DynGraph gr => Set Node -> gr a b -> gr a b
+subgraph' ns = G.subgraph (Set.toList ns)
 
 exclusion :: Ord a => Set a -> Set a -> Set a
 exclusion a b = (Set.\\) b a

src/Data/Graph/Clustering/ILouvain.hs

+{-|
+Module      : Data.Graph.Clustering.ILouvain
+Description : Purely functional (Inductive) Louvain clustering
+Copyright   : (c) Alexandre Delanoë, CNRS, 2020-Present
+License     : AGPL + CECILL v3
+Maintainer  : alexandre.delanoe+louvain@iscpif.fr
+Stability   : experimental
+Portability : POSIX
+
+ILouvain: really inductive Graph
+
+-}
+
+{-# LANGUAGE ConstrainedClassMethods #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE InstanceSigs      #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Data.Graph.Clustering.ILouvain
+  where
+
+import Data.Maybe (catMaybes)
+import Data.List (zip, cycle)
+import Protolude hiding (empty, (&))
+import Data.Graph.Inductive
+
+------------------------------------------------------------------------
+-- 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)
+------------------------------------------------------------------------
+-- Spoon Graph
+--    1
+--   / \
+--  2   3
+--   \ /
+--    4
+--    |
+--    5
+
+spoon :: HyperGraph Double Double
+spoon = mkGraph ns es
+  where
+    ns :: [LNode (Gr () Double)]
+    ns = zip [1..6] (cycle [empty])
+
+    es :: [LEdge Double]
+    es = [ (1, 2, 1.0)
+         , (1, 3, 1.0)
+         , (2, 4, 1.0)
+         , (3, 4, 1.0)
+         , (4, 5, 1.0)
+         ]
+
+-- | Needed functions (WIP)
+-- mv: a Node elsewhere in the HyperGraph
+
+-- Move Properties:
+-- mv Node into another Node and remove it again should be equal to
+-- identity
+
+-- property test:
+-- mv (mv g [a] [b]) [b,a] [] = identity
+-- mv g [a] [] == g
+-- mv g [a,b] [] /= g
+-- mv (mv spoon [1] [4]) [4,1] [] = identity
+
+-- Move target type
+mv' :: HyperGraph a a
+   -> [Node] -> [Node]
+   -> HyperGraph a a
+mv' g []  [] = g
+mv' g [_] [] = g
+mv' g (x:xs) [] = undefined
+
+-- | Start simple (without path)
+mv :: HyperGraph a a
+   -> Node -> Node
+   -> HyperGraph a a
+mv g n1 n2 =  delNode n1 g
+-- buildGr $ catMaybes [c1, c2]
+  where
+    (c1, g1) = match n1 g
+
+
+
+{-
+insertContext :: HyperContext a b
+              -> HyperContext a b
+              -> HyperContext a b
+insertContext (a1,n,l,a2) (a1',n',l',a2') = (a1,n,l&l',a2)
+
+--}
+
+------------------------------------------------------------------------
+-- | 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
+-- Directed graph strategy
+path_dir :: Graph gr => gr a b -> [[Node]]
+path_dir g = map (\xs -> dfs xs g ) (components g)
+
+-- UnDirected graph strategy
+path :: (DynGraph gr, Eq b) => gr a b -> [[Node]]
+path g' = map sortNodes cs
+  where
+    sortNodes ns = case head $ sortOn (Down . (deg g)) ns of
+      Nothing -> []
+      Just  n -> dfs [n] g  -- dfs for glustering, bfs for klustering
+    cs = components g
+    g  = undir g'
+------------------------------------------------------------------------
+------------------------------------------------------------------------

stack.yaml

@@ -18,7 +18,7 @@
 #
 # resolver: ./custom-snapshot.yaml
 # resolver: https://example.com/snapshots/2018-01-01.yaml
-resolver: lts-11.10
+resolver: lts-14.27
 
 # User packages to be built.
 # Various formats can be used as shown in the example below.
@@ -62,4 +62,4 @@ packages:
 # extra-lib-dirs: [/path/to/dir]
 #
 # Allow a newer minor version of GHC than the snapshot specifies
-# compiler-check: newer-minor
\ No newline at end of file
+# compiler-check: newer-minor