[FEAT] InducedGraph.

louvain.cabal

@@ -15,7 +15,10 @@ cabal-version:       >=1.10
 
 library
   hs-source-dirs:      src
-  exposed-modules:     Data.Louvain, Data.GexfParser
+  exposed-modules:     Data.Louvain
+                     , Data.Utils
+                     , Data.Example
+                     , Data.GexfParser
   build-depends:       base >= 4.7 && < 5
                        , fgl
                        , hxt

src/Data/Example.hs

+module Data.Example where
+
+import Data.Utils
+import Data.GexfParser
+import Data.Graph.Inductive
+
+
+karate :: IO (Gr () Double)
+karate =  mkGraph' <$> importGraphFromGexf "Data/karate.gexf"
+
+eU :: [LEdge Double]
+eU = [
+     (2,1,1)
+    ,(1,2,1)
+    
+    ,(1,4,1)
+    ,(4,1,1)
+    
+    ,(2,3,1)
+    ,(3,2,1)
+    
+    ,(3,4,1)
+    ,(4,3,1)
+    
+    ,(4,5,1)
+    ,(5,4,1)
+    ]
+
+eD :: [LEdge Double]
+eD = [
+     (2,1,1)
+    
+    ,(1,4,1)
+    
+    ,(2,3,1)
+    
+    ,(3,4,1)
+    
+    ,(4,5,1)
+    ]
+
+gU :: Gr () Double
+gU = mkGraph' eU
+
+-- > prettyPrint gU
+-- 1:()->[(1,2),(1,4)]
+-- 2:()->[(1,1),(1,3)]
+-- 3:()->[(1,2),(1,4)]
+-- 4:()->[(1,1),(1,3),(1,5)]
+-- 5:()->[(1,4)]
+
+-- Visual representation:
+-- 
+--    2
+--   / \
+--  1   3
+--   \ /
+--    4
+--    |
+--    5
+-- 
+-- 
+
+gD :: Gr () Double
+gD = mkGraph' eD
+
+eD' :: [LEdge Double]
+eD' = [
+     (2,1,1)
+    
+    ,(1,4,1)
+    
+    ,(2,3,1)
+    
+    ,(3,4,1)
+    
+    ,(4,5,1)
+    ,(5,6,1)
+    ,(5,7,1)
+    ,(6,7,1)
+    ]
+gD' :: Gr () Double
+gD' = mkGraph' eD'

src/Data/Louvain.hs

 module Data.Louvain where
 
+import Data.Utils
 import Data.List (maximumBy)
 import Data.Graph.Inductive
-import qualified Data.Set as S
 
+type Modularity = Double
 
-label' :: (Graph gr) => gr a b -> Edge -> Maybe b
-label' gr (u,v) = lookup v (lsuc gr u)
+-- | group nodes and produce a new graph 
+inducedGraph :: (Eq b, Ord b, DynGraph gr) => gr a b -> (Node, [Node]) -> gr a b
+inducedGraph gr (a,b) = delNodes b (insEdges newEdges gr')
+    where
+        gr' = undir gr
+        newEdges = Prelude.map (\(n,l) -> (a,n,l)) ( uniq $ concat $ Prelude.map (lsuc gr') b )
 
-shortest_path :: (Real b, Graph gr) => gr a b -> Node -> Node -> Path
-shortest_path graph node_1 node_2= sp node_1 node_2 graph
+inducedGraph' :: (Ord b, DynGraph gr) => gr a b -> [(Node, [Node])] -> gr a b
+inducedGraph' gr ns = Prelude.foldl (\gr' n -> inducedGraph gr' n) gr ns
 
+neighbors'' :: DynGraph gr => gr a b -> [Node] -> [Node]
+neighbors'' gr ns = uniq $ concat (Prelude.map (neighbors gr) ns)
 
-mkGraph' :: [LEdge b] -> Gr () b
-mkGraph' es = mkGraph ns es
-    where
-        ns :: [LNode ()]
-        ns = zip [1.. (fromIntegral . length) ns'] (repeat ())
-            where ns' = S.toList . S.fromList $ concat (Prelude.map edge2nodes es)
-
-
-edge2nodes :: LEdge b -> [Node]
-edge2nodes (a,b,_) = [a,b]
-
-
-eU :: [LEdge Double]
-eU = [
-     (2,1,1)
-    ,(1,2,1)
-    
-    ,(1,4,1)
-    ,(4,1,1)
-    
-    ,(2,3,1)
-    ,(3,2,1)
-    
-    ,(3,4,1)
-    ,(4,3,1)
-    
-    ,(4,5,1)
-    ,(5,4,1)
-    ]
-
-eD :: [LEdge Double]
-eD = [
-     (2,1,1)
-    
-    ,(1,4,1)
-    
-    ,(2,3,1)
-    
-    ,(3,4,1)
-    
-    ,(4,5,1)
-    ]
-
-gU :: Gr () Double
-gU = mkGraph' eU
-
--- > prettyPrint gU
--- 1:()->[(1,2),(1,4)]
--- 2:()->[(1,1),(1,3)]
--- 3:()->[(1,2),(1,4)]
--- 4:()->[(1,1),(1,3),(1,5)]
--- 5:()->[(1,4)]
-
--- Visual representation:
--- 
---    2
---   / \
---  1   3
---   \ /
---    4
---    |
---    5
--- 
--- 
-
-gD :: Gr () Double
-gD = mkGraph' eD
-
-eD' :: [LEdge Double]
-eD' = [
-     (2,1,1)
-    
-    ,(1,4,1)
-    
-    ,(2,3,1)
-    
-    ,(3,4,1)
-    
-    ,(4,5,1)
-    ,(5,6,1)
-    ,(5,7,1)
-    ,(6,7,1)
-    ]
-gD' :: Gr () Double
-gD' = mkGraph' eD'
+neighcom :: DynGraph gr => gr a b -> Node -> [[Node]]
+neighcom gr n = scanl (\x y -> take 1 x ++ [y]) [n] (neighbors gr n)
 
-
-type Modularity = Double
+neighcom' :: DynGraph gr => gr a b -> [Node] -> [[Node]]
+neighcom' gr ns = scanl (\x y -> take 1 x ++ [y]) ns (neighbors'' gr ns)
 
 rotate :: Int -> [a] -> [a]
 rotate _ [] = []
@@ -120,6 +44,8 @@ separate (x:xs) = let recur = separate xs
                         return $ (x:y):ys
                   in split ++ noSplit
 
+
+separate' :: forall a. [a] -> [[[a]]]
 separate' xs = [ takeDrop t (rotate r xs) 
                | t <- [1.. fromIntegral (length xs) - 1 ]
                , r <- [0.. fromIntegral (length xs)     ]
@@ -127,22 +53,19 @@ separate' xs = [ takeDrop t (rotate r xs)
 
 
 gpartition :: DynGraph gr => gr a b -> [[[Node]]]
-gpartition gr = separate' (nodes gr)
+gpartition gr = separate (nodes gr)
 
 modularities :: DynGraph gr => gr a b -> [[Node]] -> Double
 modularities gr xs = sum $ Prelude.map (\y -> modularity gr y) xs
 
-
-compareModularity :: DynGraph gr => gr a b -> [[Node]] -> [[Node]] -> Ordering
-compareModularity gr xs ys
+compareModularities :: DynGraph gr => gr a b -> [[Node]] -> [[Node]] -> Ordering
+compareModularities gr xs ys
     | modularities gr xs < modularities gr ys = LT
     | modularities gr xs > modularities gr ys = GT
     | otherwise = EQ
 
-
 bestPartition :: DynGraph gr => gr a b -> [[Node]]
-bestPartition gr = maximumBy (compareModularity gr) $ gpartition gr
-
+bestPartition gr = maximumBy (compareModularities gr) $ gpartition gr
 
 modularity :: DynGraph gr => gr a b -> [Node] -> Double
 modularity gr ns = coverage - edgeDensity

src/Data/Utils.hs

+module Data.Utils where
+
+import Data.Graph.Inductive
+import Data.Set as S (toList, fromList)
+
+
+uniq :: Ord a => [a] -> [a]
+uniq = toList . fromList
+
+label' :: (Graph gr) => gr a b -> Edge -> Maybe b
+label' gr (u,v) = lookup v (lsuc gr u)
+
+shortest_path :: (Real b, Graph gr) => gr a b -> Node -> Node -> Path
+shortest_path graph node_1 node_2= sp node_1 node_2 graph
+
+
+mkGraph' :: [LEdge b] -> Gr () b
+mkGraph' es = mkGraph ns es
+    where
+        ns :: [LNode ()]
+        ns = zip [1.. (fromIntegral . length) ns'] (repeat ())
+            where ns' = uniq $ concat (Prelude.map edge2nodes es)
+
+
+edge2nodes :: LEdge b -> [Node]
+edge2nodes (a,b,_) = [a,b]
+
+
+