[FLouvain] pushed tests to nail down the foldr error

clustering-louvain.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: e6499237b0dc8ea9c12e2947a7c59bbd3dcc7a327e44c0d2d4ee5fff351e6ac6
+-- hash: d5768235cb674d3617c860c0be6df203e51373bd36995a8e7df1f612778cdeee
 
 name:           clustering-louvain
 version:        0.1.0.0
@@ -20,6 +20,7 @@ build-type:     Simple
 
 library
   exposed-modules:
+      Data.Graph.Clustering.Example
       Data.Graph.Clustering.FLouvain
       Data.Graph.Clustering.Louvain
       Data.Graph.Clustering.Louvain.Utils
@@ -28,7 +29,6 @@ library
       Data.Graph.Clustering.Louvain.CplusPlus
       Data.Graph.FGL
   other-modules:
-      Data.Graph.Clustering.Example
       Data.Graph.Clustering.HLouvain
       Data.Graph.Clustering.ILouvain
       Paths_clustering_louvain
@@ -50,6 +50,25 @@ library
     , vector
   default-language: Haskell2010
 
+executable run-example
+  main-is: Main.hs
+  other-modules:
+      Paths_clustering_louvain
+  hs-source-dirs:
+      app/run-example
+  default-extensions: ConstrainedClassMethods FlexibleInstances InstanceSigs NoImplicitPrelude OverloadedStrings ScopedTypeVariables TupleSections
+  ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
+  build-depends:
+      base
+    , clustering-louvain
+    , containers
+    , extra
+    , fgl
+    , protolude
+    , text
+    , vector
+  default-language: Haskell2010
+
 test-suite louvain-test
   type: exitcode-stdio-1.0
   main-is: Spec.hs

package.yaml

@@ -26,6 +26,7 @@ default-extensions:
   - OverloadedStrings
   - ScopedTypeVariables
   - TupleSections
+
 library:
   source-dirs: src
   ghc-options:
@@ -36,6 +37,7 @@ library:
   - -Wunused-binds
   - -Wunused-imports
   exposed-modules:
+  - Data.Graph.Clustering.Example
   - Data.Graph.Clustering.FLouvain
   - Data.Graph.Clustering.Louvain
   - Data.Graph.Clustering.Louvain.Utils
@@ -50,6 +52,20 @@ library:
     - parsec
     - turtle
     - foldl
+
+executables:
+  run-example:
+    source-dirs: app/run-example
+    main: Main.hs
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    dependencies:
+    - base
+    - clustering-louvain
+    - fgl
+
 tests:
   louvain-test:
     main: Spec.hs
@@ -65,7 +81,6 @@ tests:
     - hspec
     - hspec-discover
     - HUnit-approx
-    - protolude
 
 #  louvain-doctest:
 #    main: Main.hs

src/Data/Graph/Clustering/Example.hs

@@ -19,7 +19,7 @@ import Data.Graph.Clustering.FLouvain
 -- Example call:
 -- putStrLn $ prettify $ iterateOnce cuiller
 -- Prelude.map (fst3 . unCommunity . snd) $ labNodes $ iterateOnce karate
-iterateOnce :: Gr a Double -> CGr a
+iterateOnce :: Show a => Gr a Double -> CGr a
 iterateOnce gr = iteration fgr cgr
   where
     fgr = toFGraph    gr
@@ -28,11 +28,14 @@ iterateOnce gr = iteration fgr cgr
 runFLouvain :: (Show a, Eq a) => Int -> Int -> FGraph a () -> IO ()
 runFLouvain 0 _ fgr = return ()
 runFLouvain cycles n fgr = do
+  putStrLn ("-----------------" :: Text)
+  putStrLn ("Cycle: " <> show cycles :: Text)
   cgr <- runFIterations n fgr
   let fgrNext = louvainSecondStep fgr cgr
   putStrLn ("-----------------" :: Text)
   putStrLn ("New FGraph:" :: Text)
-  putStrLn $ prettify fgrNext
+  --putStrLn $ prettify fgrNext
+  putStrLn (show fgrNext :: Text)
   runFLouvain (cycles - 1) n fgrNext
 
 runIterations :: Show a => Int -> Gr a Double -> IO (CGr a)
@@ -61,12 +64,13 @@ runFIterations n fgr = do
     runIteration fgr fgrWeight iterCgr i = do
       let iterNextCgr = iteration fgr iterCgr
       putStrLn ("----- ITERATION " <> show i :: Text)
-      putStrLn $ prettify iterNextCgr
+      --putStrLn $ prettify iterNextCgr
+      putStrLn (show iterNextCgr :: Text)
       putStrLn (show i <> " iteration modularity: " :: Text)
       putStrLn $ T.unpack $ show $ modularity fgr iterNextCgr fgrWeight
       return iterNextCgr
 
-runLouvainFirstStepIterate :: Int -> Gr a Double -> (Modularity, CGr a)
+runLouvainFirstStepIterate :: Show a => Int -> Gr a Double -> (Modularity, CGr a)
 runLouvainFirstStepIterate n gr = (modularity fgr cgr m, cgr)
   where
     fgr = toFGraph gr

src/Data/Graph/Clustering/FLouvain.hs

@@ -63,9 +63,9 @@ louvainSecondStep gr cgr = mkFGraph nodes edges
     --nodes = filter (\(_, com) -> length (comNodes com) > 0) $ labNodes cgr
     nodes = labNodes cgr
     edges :: [(Node, Node, Double)]
-    edges = concatMap comEdges $ labNodes cgr
+    edges = concatMap comEdges nodes
     comEdges :: LNode (Community c) -> [(Node, Node, Double)]
-    comEdges lnCom = mapMaybe (comToComEdge lnCom) $ labNodes cgr
+    comEdges lnCom = mapMaybe (comToComEdge lnCom) nodes
     comToComEdge :: LNode (Community c) -> LNode (Community c) -> Maybe (Node, Node, Double)
     -- No self-edges
     comToComEdge lnCom1 lnCom2 | lnCom1 == lnCom2            = Nothing
@@ -113,7 +113,7 @@ initialCGr gr = gmap singletonCom gr
 modularity :: FGraph a b -> CGr c -> GraphWeightSum -> Modularity
 modularity gr cgr m = Modularity $ coeff * ( ufold modularity' 0.0 cgr )
   where
-    coeff = 0.5 / (unGraphWeightSum m)
+    coeff = if (unGraphWeightSum m == 0.0) then 0.0 else 0.5 / (unGraphWeightSum m)
     -- Sum over nodes in community
     -- \Sum A_ij is just the InWeightSum (in formula (1) it is sum of weights
     -- between nodes i and j both in the same community, as enforced by the

test/FLouvainSpec.hs

@@ -91,6 +91,17 @@ spec = do
                         mMod
                         (unModularity mod)
 
+    it "tests that single community has modularity 0" $ do
+      let cgr = mkGraph [
+            (1, Community(nodes simpleGraph, InWeightSum $ sumEdgeWeights $ edges simpleGraph, TotWeightSum 0.0, ()))
+            ] []
+          m = graphWeight simpleGraph
+          mod = modularity simpleGraph cgr m
+      assertApproxEqual "modularities don't match"
+                        0.000001
+                        0.0
+                        (unModularity mod)
+
     it "nodeCommunity works correctly" $ do
       let cgr = initialCGr simpleGraph
           communities = lnodes cgr