Some functions need to be factorized. But Ok, need some benchmarks (quality of...

Some functions need to be factorized. But Ok, need some benchmarks (quality of partitions) with networkx or igraph.

Setup.hs

-import Distribution.Simple
-main = defaultMain

app/Main.hs

 module Main where
 
-import Lib
+import System.Environment (getArgs)
+import Data.Louvain
+import Data.Utils
+import Data.GexfParser
+
 
 main :: IO ()
-main = someFunc
+main = do
+    [file] <- getArgs
+    graph <- mkGraph' <$> importGraphFromGexf file
+    print $ bestpartition True graph
+
+

louvain.cabal

@@ -24,23 +24,25 @@ library
                        , hxt
   default-language:    Haskell2010
 
--- executable louvain-exe
---   hs-source-dirs:      app
---   main-is:             Main.hs
---   ghc-options:         -threaded -rtsopts -with-rtsopts=-N
---   build-depends:       base
---                      , louvain
---   default-language:    Haskell2010
--- 
--- test-suite louvain-test
---   type:                exitcode-stdio-1.0
---   hs-source-dirs:      test
---   main-is:             Spec.hs
---   build-depends:       base
---                      , louvain
---   ghc-options:         -threaded -rtsopts -with-rtsopts=-N
---   default-language:    Haskell2010
+executable louvain
+   hs-source-dirs:      app
+   main-is:             Main.hs
+   ghc-options:         -threaded -rtsopts -with-rtsopts=-N -O2
+   build-depends:       base >= 4.7 && < 5
+                       , fgl
+                       , hxt
+                       , louvain
+   default-language:    Haskell2010
 -- 
+test-suite louvain-test
+   type:                exitcode-stdio-1.0
+   hs-source-dirs:      test
+   main-is:             Spec.hs
+   build-depends:       base
+                        , louvain
+   ghc-options:         -threaded -rtsopts -with-rtsopts=-N
+   default-language:    Haskell2010
+
 -- source-repository head
 --   type:     git
 --   location: https://github.com/adelanoe/louvain

src/Data/Example.hs

 module Data.Example where
 
+import Data.List (sort)
 import Data.Utils
 import Data.GexfParser
 import Data.Graph.Inductive
 
 
 karate :: IO (Gr () Double)
-karate =  mkGraph' <$> importGraphFromGexf "Data/karate.gexf"
+karate =  mkGraph' <$> importGraphFromGexf "src/Data/karate.gexf"
+
+karate2com :: [[Node]]
+karate2com = sort $ Prelude.map (sort) [[10, 29, 32, 25, 28, 26, 24, 30, 27, 34, 31, 33, 23, 15, 16, 21, 19], [3, 9, 8, 4, 14, 20, 2, 13, 22, 1, 18, 12, 5, 7, 6, 17]]
+
 
 eU :: [LEdge Double]
 eU = [

src/Data/GexfParser.hs

@@ -4,7 +4,7 @@ module Data.GexfParser (importGraphFromGexf)
  where
 
 import Text.XML.HXT.Core
-import qualified Data.Graph as DataGraph
+-- import qualified Data.Graph as DataGraph
 import qualified Data.Graph.Inductive as FGL
 import System.Environment (getArgs)
 
@@ -42,27 +42,27 @@ getTargets :: String -> Graph -> [String]
 getTargets source graph = map snd $ filter ((==source).fst) $ edges graph
 
 -- Convert a graph node into a Data.Graph-usable
-getDataGraphNode :: Graph -> String -> (String, String, [String])
-getDataGraphNode graph node = (node, node, getTargets node graph)
-
-
-getDataGraphNode' :: Graph -> String -> (Int, [Int])
-getDataGraphNode' graph node = (read node, Prelude.map read (getTargets node graph))
-
--- Convert a Graph instance into a Data.Graph list of (node, nodeid, edge) tuples
-getDataGraphNodeList :: Graph -> [(String, String, [String])]
-getDataGraphNodeList graph = map (getDataGraphNode graph) (nodes graph)
-
-getDataGraphNodeList' :: Graph -> [(Int, [Int])]
-getDataGraphNodeList' graph = map (getDataGraphNode' graph) (nodes graph)
-
---  Convert Graph structure to Data.Graph-importable tuple list
-importGraph :: FilePath -> IO [(Int, [Int])]
-importGraph file = do
-    graphs <- runX (readDocument [withValidate no] file >>> parseGraph)
-    let graphEdges = getDataGraphNodeList' $ head graphs
-    return graphEdges
-
+-- getDataGraphNode :: Graph -> String -> (String, String, [String])
+-- getDataGraphNode graph node = (node, node, getTargets node graph)
+-- 
+-- 
+-- getDataGraphNode' :: Graph -> String -> (Int, [Int])
+-- getDataGraphNode' graph node = (read node, Prelude.map read (getTargets node graph))
+-- 
+-- -- Convert a Graph instance into a Data.Graph list of (node, nodeid, edge) tuples
+-- getDataGraphNodeList :: Graph -> [(String, String, [String])]
+-- getDataGraphNodeList graph = map (getDataGraphNode graph) (nodes graph)
+-- 
+-- getDataGraphNodeList' :: Graph -> [(Int, [Int])]
+-- getDataGraphNodeList' graph = map (getDataGraphNode' graph) (nodes graph)
+-- 
+-- --  Convert Graph structure to Data.Graph-importable tuple list
+-- importGraph :: FilePath -> IO [(Int, [Int])]
+-- importGraph file = do
+--     graphs <- runX (readDocument [withValidate no] file >>> parseGraph)
+--     let graphEdges = getDataGraphNodeList' $ head graphs
+--     return graphEdges
+-- 
 --importGraph' :: FilePath -> IO [(Int, [Int])]
 importGraph' file = runX (readDocument [withValidate no] file >>> parseGraph)
 
@@ -71,10 +71,10 @@ importGraphFromGexf file = Prelude.map (\(a,b) -> (read a, read b, 1)) <$> edges
 
 
 --main :: IO()
-main = do
-    [file] <- getArgs
-    importGraph file >>= print
-
+-- main = do
+--     [file] <- getArgs
+--     importGraph file >>= print
+-- 
     -- Convert to a Data.Graph
     -- let (graph, vertexMap) = DataGraph.graphFromEdges' graphEdges
     -- Example of what to do with the Graph: Print vertices

src/Data/Louvain.hs

 module Data.Louvain where
 
-import Data.List (minimum, maximumBy,nub, intersect, foldl', reverse)
+import Data.List (maximumBy,nub, intersect, scanl', foldl')
 import Data.Graph.Inductive
-import Data.Example
 
+------------------------------------------------------------------------
+-- | Definitions
+------------------------------------------------------------------------
 type Modularity = Double
 type Community = [Node] 
+type Partition = [Community]
 
-startcom :: DynGraph gr => gr a b -> [[Node]]
-startcom gr = Prelude.map (\x -> [] ++ [x]) ( nodes gr )
+type Reverse = Bool
 
-stepscom :: DynGraph gr => gr a1 b -> Int -> [[Node]]
-stepscom gr n = foldl' (\xs n' -> stepcom gr (smallCom xs) xs) (startcom gr) [1..n]
+------------------------------------------------------------------------
+-- | Partitionning the graph
+------------------------------------------------------------------------
+bestpartition :: (Eq b, DynGraph gr) => Reverse -> gr a b -> [[Node]]
+bestpartition r gr = converge gr (start gr r)
+
+converge :: (Eq b, DynGraph gr) => gr a1 b -> [[Node]] -> [[Node]]
+converge gr ns = case stepscom gr (length ns) ns of
+            ns' | ns == ns' -> ns
+                | otherwise -> stepscom gr (length ns') ns'
+------------------------------------------------------------------------
+
+dendogram :: (Eq b, DynGraph gr) => gr a b -> Int -> Reverse -> [[Node]]
+dendogram gr n r = stepscom gr n (start gr r)
+
+start :: DynGraph gr => gr a b -> Reverse -> [[Node]]
+start gr r = order $ Prelude.map (\x -> [] ++ [x]) ( nodes gr )
+    where
+        order = case r of
+                  True  -> reverse
+                  False -> id
+
+------------------------------------------------------------------------
+------------------------------------------------------------------------
+stepscom :: (DynGraph gr, Eq b) => gr a1 b -> Int -> [[Node]] -> [[Node]]
+stepscom gr n ns = foldl' (\xs _ -> stepcom gr' (smallCom xs) xs) ns [1..n]
+    where
+        gr' = undir gr
+        smallCom xs = head $ filter (\x -> length x == minimum (Prelude.map length xs)) (reverse xs)
+
+stepscom' :: (DynGraph gr, Eq b) => gr a1 b -> Int -> [[Node]] -> [[Node]]
+stepscom' gr n ns = foldl' (\xs _ -> stepcom' gr' (smallCom xs) xs) ns [1..n]
     where
+        gr' = undir gr
         smallCom xs = head $ filter (\x -> length x == minimum (Prelude.map length xs)) (reverse xs)
 
+
+------------------------------------------------------------------------
+
+stepcom' :: DynGraph gr => gr a b -> [Node] -> [[Node]] -> [[Node]]
+stepcom' gr n ns = bestModularities gr $ Prelude.map (\x -> x ++ neighout) (addcom n neighin)
+    where
+        -- | First remove the node (n) of the current partition (ns)
+        ns' = filter (/= n) ns
+        neighin    = filter (\c ->  (intersect (neighcom gr n) c) /= [] ) ns'
+        neighout   = filter (\c ->  (intersect (neighcom gr n) c) == [] ) ns'
+
+
+stepcom :: DynGraph gr => gr a b -> [Node] -> [[Node]] -> [[Node]]
 stepcom gr n ns = bestModularities gr $ [ns] ++ Prelude.map (\x -> x ++ neighout) (addcom n neighin)
     where
+        -- | First remove the node (n) of the current partition (ns)
         ns' = filter (/= n) ns
         neighin    = filter (\c ->  (intersect (neighcom gr n) c) /= [] ) ns'
         neighout   = filter (\c ->  (intersect (neighcom gr n) c) == [] ) ns'
@@ -25,10 +72,10 @@ addcom :: [a] -> [[a]] -> [[[a]]]
 addcom com coms = Prelude.map (\n -> addcom' com (rotate n coms)) ns
     where
         ns = [0.. fromIntegral (length coms) ]
-        addcom' com coms = [com'] ++ coms''
+        addcom' c cs = [com'] ++ coms''
             where
-                com'   = concat $ [com] ++ (take 1 coms)
-                coms'' = drop 1 coms
+                com'   = concat $ [c] ++ (take 1 cs)
+                coms'' = drop 1 cs
 
 neighcom :: DynGraph gr => gr a b -> [Node] -> [Node]
 neighcom gr ns = ( nub . filter (not . (`elem` ns)) . concat ) ns'
@@ -38,6 +85,10 @@ rotate :: Int -> [a] -> [a]
 rotate _ [] = []
 rotate n xs = zipWith const (drop n (cycle xs)) xs
 
+------------------------------------------------------------------------
+-- | Computing modularity of the partition
+------------------------------------------------------------------------
+
 modularities :: DynGraph gr => gr a b -> [[Node]] -> Double
 modularities gr xs = sum $ Prelude.map (\y -> modularity gr y) xs
 
@@ -47,7 +98,6 @@ compareModularities gr xs ys
     | modularities gr xs > modularities gr ys = GT
     | otherwise = EQ
 
-
 bestModularities :: DynGraph gr => gr a b -> [[[Node]]] -> [[Node]]
 bestModularities gr ns = maximumBy (compareModularities gr) ns
 
@@ -72,12 +122,6 @@ modularity gr ns = coverage - edgeDensity
                 links :: Double
                 links       = fromIntegral (2 * (size gr))
 
-
-main = do
-    k <- karate
-    print $ stepscom k 35
-
-
 ----------------------------------------------------------
 -- | Discover what NP complete means:
 ----------------------------------------------------------
@@ -98,18 +142,18 @@ separate (x:xs) = let recur = separate xs
                   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)     ]
-               ]
+-- separate' :: forall a. [a] -> [[[a]]]
+-- separate' xs = [ takeDrop t (rotate r xs) 
+--                | t <- [1.. fromIntegral (length xs) - 1 ]
+--                , r <- [0.. fromIntegral (length xs)     ]
+--                ]
 
 
 gpartition :: DynGraph gr => gr a b -> [[[Node]]]
 gpartition gr = separate (nodes gr)
 
-bestPartition :: DynGraph gr => gr a b -> [[Node]]
-bestPartition gr = maximumBy (compareModularities gr) $ gpartition gr
+bestPartition' :: DynGraph gr => gr a b -> [[Node]]
+bestPartition' gr = maximumBy (compareModularities gr) $ gpartition gr
 ----------------------------------------------------------
 
 

test/Spec.hs

+import Data.List (sort)
+import Data.Example
+import Data.Louvain
+
+
+testKarate2com = do
+    p <- bestpartition True <$> karate
+    k <- karate
+    let result = (sort $ Prelude.map (sort) (stepscom' k 2 p))
+    print result
+    print karate2com
+    print $  result == karate2com
+
+
 main :: IO ()
-main = putStrLn "Test suite not yet implemented"
+main = testKarate2com