Refactoring, default extensions added to stack, tests added

clustering-louvain.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 1f5db6daebbb99eb2ce71fb2a61120a7128c45b5152b0e6defa3a811c85aef62
+-- hash: 77a387aa4e98e27142bd5c5045e96b48f1108c72aefe2509cb74c5e47f5674cc
 
 name:           clustering-louvain
 version:        0.1.0.0
@@ -19,8 +19,21 @@ license-file:   LICENSE
 build-type:     Simple
 
 library
+  exposed-modules:
+      Data.Graph.Clustering.FLouvain
+      Data.Graph.Clustering.Louvain
+      Data.Graph.Clustering.Louvain.Utils
+      Data.Graph.Clustering.Louvain.IO.Gexf
+      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
   hs-source-dirs:
       src
+  default-extensions: ConstrainedClassMethods FlexibleInstances InstanceSigs NoImplicitPrelude OverloadedStrings ScopedTypeVariables TupleSections
   ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wmissing-signatures -Wunused-binds -Wunused-imports
   build-depends:
       base >=4.7 && <5
@@ -34,15 +47,27 @@ library
     , text
     , turtle
     , vector
-  exposed-modules:
-      Data.Graph.Clustering.Louvain
-      Data.Graph.Clustering.Louvain.Utils
-      Data.Graph.Clustering.Louvain.IO.Gexf
-      Data.Graph.Clustering.Louvain.CplusPlus
+  default-language: Haskell2010
+
+test-suite louvain-test
+  type: exitcode-stdio-1.0
+  main-is: Spec.hs
   other-modules:
-      Data.Graph.Clustering.Example
-      Data.Graph.Clustering.FLouvain
-      Data.Graph.Clustering.HLouvain
-      Data.Graph.Clustering.ILouvain
+      FLouvainSpec
       Paths_clustering_louvain
+  hs-source-dirs:
+      test
+  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
+    , hspec
+    , hspec-discover
+    , protolude
+    , text
+    , vector
   default-language: Haskell2010

package.yaml

@@ -18,6 +18,14 @@ dependencies:
 - protolude
   #- union-find
   #- mtl
+default-extensions:
+  - ConstrainedClassMethods
+  - FlexibleInstances
+  - InstanceSigs
+  - NoImplicitPrelude
+  - OverloadedStrings
+  - ScopedTypeVariables
+  - TupleSections
 library:
   source-dirs: src
   ghc-options:
@@ -28,10 +36,12 @@ library:
   - -Wunused-binds
   - -Wunused-imports
   exposed-modules:
+  - Data.Graph.Clustering.FLouvain
   - Data.Graph.Clustering.Louvain
   - Data.Graph.Clustering.Louvain.Utils
   - Data.Graph.Clustering.Louvain.IO.Gexf
   - Data.Graph.Clustering.Louvain.CplusPlus
+  - Data.Graph.FGL
   dependencies:
     - base >= 4.7 && < 5
     - fgl
@@ -39,17 +49,22 @@ library:
     - parsec
     - turtle
     - foldl
-#tests:
-#  louvain-test:
-#    main: Spec.hs
-#    source-dirs: src-test
-#    ghc-options:
-#    - -threaded
-#    - -rtsopts
-#    - -with-rtsopts=-N
-#    dependencies:
-#    - base
-#    - louvain
+tests:
+  louvain-test:
+    main: Spec.hs
+    source-dirs: test
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    dependencies:
+    - base
+    - clustering-louvain
+    - fgl
+    - hspec
+    - hspec-discover
+    - protolude
+
 #  louvain-doctest:
 #    main: Main.hs
 #    source-dirs: src-doctest

src/Data/Graph/Clustering/Example.hs

-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE TupleSections     #-}
-
 module Data.Graph.Clustering.Example where
 
 import Protolude
@@ -8,6 +5,7 @@ import Protolude
 import Control.Monad (foldM_)
 import Data.List (nub, sort)
 import Data.Graph.Clustering.Louvain.Utils
+import Data.Graph.FGL
 import Data.Graph.Inductive
 import Data.Graph.Clustering.FLouvain
 import qualified Data.Text as T
@@ -15,17 +13,6 @@ import qualified Text.ParserCombinators.Parsec as P
 import Text.Parsec.Language (haskellStyle)
 import qualified Text.Parsec.Token as PT
 
--- | Utility function to remap Gr () Double into FGraph () ()
-exampleRemap :: Gr () Double -> FGraph () ()
-exampleRemap gr = gmap remap gr
-  where
-    remap :: Context () Double -> Context () (Weight, ())
-    remap (p, v, l, s) = (p', v, l, s')
-      where
-      edgeMap (w, n) = ((Weight w, ()), n)
-      p' = map edgeMap p
-      s' = map edgeMap s
-
 -- | Run FLouvain.iterate on an example graph
 -- Example call:
 -- putStrLn $ prettify $ iterateOnce cuiller
@@ -42,7 +29,7 @@ runIterations n gr = do
   let fgrWeight = graphWeight fgr
   let initCgr = initialCGr fgr
 
-  putStrLn "Initial modularity: "
+  putStrLn ("Initial modularity: " :: Text)
   putStrLn $ T.unpack $ show $ modularity fgr initCgr fgrWeight
 
   lastCgr <- foldM (runIteration fgr fgrWeight) initCgr [0..n]
@@ -50,16 +37,16 @@ runIterations n gr = do
   -- at the end, just pretty-print communities
   let coms = filter (not . null . comNodes . llab) (labNodes lastCgr)
 
-  putStrLn "-------------"
-  putStrLn "Non-empty communities: "
-  mapM_ (putStrLn . T.pack . show) coms
+  putStrLn ("-------------" :: Text)
+  putStrLn ("Non-empty communities: " :: Text)
+  mapM_ (\c -> putStrLn (show c :: Text)) coms
 
   where
     runIteration fgr fgrWeight iterCgr i = do
       let iterNextCgr = iteration fgr iterCgr
-      putStrLn $ "----- ITERATION " <> show i
+      putStrLn ("----- ITERATION " <> show i :: Text)
       putStrLn $ prettify iterNextCgr
-      putStrLn $ show i <> " iteration modularity: "
+      putStrLn (show i <> " iteration modularity: " :: Text)
       putStrLn $ T.unpack $ show $ modularity fgr iterNextCgr fgrWeight
       return iterNextCgr
 

src/Data/Graph/Clustering/FLouvain.hs

@@ -32,12 +32,6 @@ doi:10.1088/1742-5468/2008/10/P10008.
 
 -}
 
-{-# LANGUAGE ConstrainedClassMethods #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE InstanceSigs      #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
 module Data.Graph.Clustering.FLouvain
   where
 
@@ -45,6 +39,8 @@ import Protolude
 import Data.Graph.Inductive
 import qualified Data.List as DL
 
+import Data.Graph.FGL
+
 --  "glue" : function to gather/merge communities
 --  "klue" : function to split communities
 data ClusteringMethod = Glue | Klue
@@ -71,46 +67,6 @@ louvainFirstStepIterate n gr = fixPt n iterator cond initCGr
     iterator cgr = iteration gr cgr
     cond cgr = (unModularity $ modularity gr cgr grWeight) < 0.1
 
-------------------------------------------------------------------------
--- | Specific FGL needed functions
-
--- | Get label of an 'LNode'
-llab :: LNode a -> a
-llab (_, a) = a
-
--- | Given a 'DynGraph', replace a given 'LNode a' with new label (of type 'a')
-replaceLNode ::  (DynGraph gr) => gr a b -> LNode a -> gr a b
-replaceLNode gr (n, ln) = gmap replacer gr
-  where
-    replacer (p, v, l, s) =
-      if v == n then (p, v, ln, s) else (p, v, l, s)
-
--- | Find LNode of a node (i.e. a node with label)
-lnode :: (Graph gr) => gr a b -> Node -> Maybe (LNode a)
-lnode cgr n = case lab cgr n of
-  Nothing -> Nothing
-  Just l  -> Just (n, l)
-
--- | Fold over graph definitions: type and function
-
--- | Fold over graph type
-type CFunFold a b c = Context a b -> c -> c
-
--- | Fold over graph function
-xdfsFoldWith :: (Graph gr)
-    => CFun     a b [Node]
-    -> CFunFold a b c
-    -> c
-    -> [Node]
-    -> gr a b
-    -> c
-xdfsFoldWith _ _ acc [] _            = acc
-xdfsFoldWith _ _ acc _ g | isEmpty g = acc
-xdfsFoldWith d f acc (v:vs) g =
-  case match v g of
-    (Just c, g')  -> xdfsFoldWith d f (f c acc) (d c++vs) g'
-    (Nothing, g') -> xdfsFoldWith d f acc vs g'
-
 ------------------------------------------------------------------------
 
 -- Our basic graph. Nodes have custom labels. Edges have weight assigned to them.
@@ -177,7 +133,7 @@ type CGrEdge = (InWeightSum, TotWeightSum)
 type CGr = Gr Community ()
 
 graphWeight :: FGraph a b -> GraphWeightSum
-graphWeight gr = GraphWeightSum $ 0.5 * ufold weight' 0 gr
+graphWeight gr = GraphWeightSum $ 0.5 * ufold (\(_, n, _, _) -> weight' $ context gr n) 0 gr
   where
     weight' (p, _, _, s) acc = acc + (sumEdgeWeights $ p <> s)
 
@@ -190,7 +146,7 @@ initialCGr gr = gmap singletonCom gr
     -- the same node id for a community
     -- same incoming/outgoing edges
     -- custom Community label
-    singletonCom (p, v, l, s) = (p', v, Community ([v], iws, tws), s')
+    singletonCom (p, v, _, s) = (p', v, Community ([v], iws, tws), s')
       where
         p' = map edgeComRemap p
         s' = map edgeComRemap s

src/Data/Graph/Clustering/HLouvain.hs

@@ -19,11 +19,6 @@ klustering: split       according to klue rules (top down)
 
 -}
 
-{-# LANGUAGE ConstrainedClassMethods #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE InstanceSigs      #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-
 module Data.Graph.Clustering.HLouvain
   where
 

src/Data/Graph/Clustering/ILouvain.hs

@@ -11,12 +11,6 @@ ILouvain: really inductive Graph
 
 -}
 
-{-# LANGUAGE ConstrainedClassMethods #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE InstanceSigs      #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-
 module Data.Graph.Clustering.ILouvain
   where
 

src/Data/Graph/Clustering/Louvain.hs

@@ -14,6 +14,7 @@ References:
  * Louvain_Modularity https://en.wikipedia.org/wiki/Louvain_Modularity
 -}
 
+{-# LANGUAGE ImplicitPrelude #-}
 
 module Data.Graph.Clustering.Louvain 
   where

src/Data/Graph/Clustering/Louvain/CplusPlus.hs

@@ -10,7 +10,7 @@ Portability : POSIX
 git clone https://gitlab.iscpif.fr/gargantext/clustering-louvain-cplusplus
 -}
 
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ImplicitPrelude #-}
 
 module Data.Graph.Clustering.Louvain.CplusPlus
   where

src/Data/Graph/Clustering/Louvain/IO/Gexf.hs

@@ -15,15 +15,20 @@ Tools to manage GEXF Format Graphs.
 module Data.Graph.Clustering.Louvain.IO.Gexf (readGexf)
  where
 
+import Protolude
+
+import Data.Text as T
+import Text.Read (readMaybe)
+
 import Text.XML.HXT.Core
 -- import qualified Data.Graph as DataGraph
 import qualified Data.Graph.Inductive as FGL
 import System.Environment (getArgs)
 
 data Graph = Graph
-  { graphId :: String,
-    nodes :: [String],
-    edges :: [(String, String)] -- (Source, target)
+  { graphId :: Text,
+    nodes :: [Text],
+    edges :: [(Text, Text)] -- (Source, target)
   }
   deriving (Show, Eq)
 
@@ -42,27 +47,30 @@ parseNodes = atTag "node" >>>
 
 parseGraph = atTag "graph" >>>
   proc g -> do
-      graphId <- getAttrValue "id" -< g
-      nodes <- listA parseNodes -< g
-      edges <- listA parseEdges -< g
+      graphId' <- getAttrValue "id" -< g
+      nodes' <- listA parseNodes -< g
+      edges' <- listA parseEdges -< g
+      let graphId = T.pack graphId'
+          nodes = Protolude.map T.pack nodes'
+          edges = Protolude.map (\(s, t) -> (T.pack s, T.pack t)) edges'
       returnA -< Graph graphId nodes edges
 
 getEdges = atTag "edge" >>> getAttrValue "source"
 
 -- Get targets for a single node in a Graph
-getTargets :: String -> Graph -> [String]
-getTargets source graph = map snd $ filter ((==source).fst) $ edges graph
+getTargets :: Text -> Graph -> [Text]
+getTargets source graph = Protolude.map snd $ Protolude.filter ((==source).fst) $ edges graph
 
 -- Convert a graph node into a Data.Graph-usable
--- getDataGraphNode :: Graph -> String -> (String, String, [String])
+-- getDataGraphNode :: Graph -> Text -> (Text, Text, [Text])
 -- getDataGraphNode graph node = (node, node, getTargets node graph)
 -- 
 -- 
--- getDataGraphNode' :: Graph -> String -> (Int, [Int])
+-- getDataGraphNode' :: Graph -> Text -> (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 -> [(Text, Text, [Text])]
 -- getDataGraphNodeList graph = map (getDataGraphNode graph) (nodes graph)
 -- 
 -- getDataGraphNodeList' :: Graph -> [(Int, [Int])]
@@ -75,11 +83,27 @@ getTargets source graph = map snd $ filter ((==source).fst) $ edges graph
 --     let graphEdges = getDataGraphNodeList' $ head graphs
 --     return graphEdges
 -- 
-importGraph' :: String -> IO [Graph]
+importGraph' :: FilePath -> IO [Graph]
 importGraph' file = runX (readDocument [withValidate no] file >>> parseGraph)
 
 readGexf :: FilePath -> IO [FGL.LEdge Double]
-readGexf file = Prelude.map (\(a,b) -> (read a, read b, 1)) <$> edges <$> head <$> importGraph' file
+readGexf file = do
+  imported <- importGraph' file
+  let mHead = Protolude.head imported
+  case mHead of
+    Nothing -> return []
+    Just head -> do
+      return $ Protolude.mapMaybe mapping $ edges head
+  where
+    mapping :: (Text, Text) -> Maybe (FGL.Node, FGL.Node, Double)
+    mapping (a, b) =
+      case (mReadA, mReadB) of
+        (Nothing, _) -> Nothing
+        (_, Nothing) -> Nothing
+        (Just readA, Just readB) -> Just (readA :: FGL.Node, readB :: FGL.Node, 1.0)
+      where
+        mReadA = readMaybe (T.unpack a) :: Maybe Int
+        mReadB = readMaybe (T.unpack b) :: Maybe Int
 
 
 --main :: IO()

src/Data/Graph/Clustering/Louvain/Utils.hs

@@ -13,16 +13,20 @@ Tools to manage Graphs.
 module Data.Graph.Clustering.Louvain.Utils
   where
 
+import Protolude
+
 import Data.Graph.Inductive
-import Data.List (nub)
-import Data.Map.Strict (Map, toList)
+import Data.List (lookup, nub)
+import qualified Data.Map.Strict as Map
+
+import Data.Graph.Clustering.FLouvain (FGraph, Weight(..))
 
 data LouvainNode = LouvainNode { l_node_id :: Int
                                , l_community_id :: Int
                                } deriving (Show)
 
 label' :: (Graph gr) => gr a b -> Edge -> Maybe b
-label' gr (u,v) = lookup v (lsuc gr u)
+label' gr (u, v) = lookup v (lsuc gr u)
 
 shortest_path :: (Real b, Graph gr) => gr a b -> Node -> Node -> Maybe Path
 shortest_path graph node_1 node_2 = sp node_1 node_2 graph
@@ -32,12 +36,30 @@ mkGraph' es = mkGraph ns es
     where
         ns :: [LNode ()]
         ns = zip [1.. (fromIntegral . length) ns'] (repeat ())
-            where ns' = nub $ concat (Prelude.map edge2nodes es)
+            where ns' = nub $ concat (Protolude.map edge2nodes es)
 
 edge2nodes :: LEdge b -> [Node]
 edge2nodes (a,b,_) = [a,b]
 
-map2graph :: Map (Node, Node) b -> Gr () b
-map2graph m = mkGraph' $ map (\((n1,n2), w) -> (n1,n2,w)) $ toList m
+map2graph :: Map.Map (Node, Node) b -> Gr () b
+map2graph m = mkGraph' $ map (\((n1,n2), w) -> (n1,n2,w)) $ Map.toList m
+
+
+mkFGraph :: [LNode a] -> [LEdge Double] -> FGraph a ()
+mkFGraph ns es = exampleRemap $ mkGraph ns es
 
 
+mkFGraph' :: [LEdge Double] -> FGraph () ()
+mkFGraph' = exampleRemap . mkGraph'
+
+
+-- | Utility function to remap Gr () Double into FGraph () ()
+exampleRemap :: forall a. Gr a Double -> FGraph a ()
+exampleRemap gr = gmap remap gr
+  where
+    remap :: Context a Double -> Context a (Weight, ())
+    remap (p, v, l, s) = (p', v, l, s')
+      where
+      edgeMap (w, n) = ((Weight w, ()), n)
+      p' = map edgeMap p
+      s' = map edgeMap s

src/Data/Graph/FGL.hs

+-- | Specific FGL needed functions
+
+module Data.Graph.FGL where
+
+import Protolude
+import Data.Graph.Inductive
+
+-- | Get label of an 'LNode'
+llab :: LNode a -> a
+llab (_, a) = a
+
+-- | Node labels
+lnodes :: (DynGraph gr) => gr a b -> [a]
+lnodes gr = mapMaybe (lab gr) $ nodes gr
+
+-- | Given a 'DynGraph', replace a given 'LNode a' with new label (of type 'a')
+replaceLNode ::  (DynGraph gr) => gr a b -> LNode a -> gr a b
+replaceLNode gr (n, ln) = gmap replacer gr
+  where
+    replacer (p, v, l, s) =
+      if v == n then (p, v, ln, s) else (p, v, l, s)
+
+-- | Find LNode of a node (i.e. a node with label)
+lnode :: (Graph gr) => gr a b -> Node -> Maybe (LNode a)
+lnode cgr n = case lab cgr n of
+  Nothing -> Nothing
+  Just l  -> Just (n, l)
+
+-- | Fold over graph definitions: type and function
+
+-- | Fold over graph type
+type CFunFold a b c = Context a b -> c -> c
+
+-- | Fold over graph function
+xdfsFoldWith :: (Graph gr)
+    => CFun     a b [Node]
+    -> CFunFold a b c
+    -> c
+    -> [Node]
+    -> gr a b
+    -> c
+xdfsFoldWith _ _ acc [] _            = acc
+xdfsFoldWith _ _ acc _ g | isEmpty g = acc
+xdfsFoldWith d f acc (v:vs) g =
+  case match v g of
+    (Just c, g')  -> xdfsFoldWith d f (f c acc) (d c++vs) g'
+    (Nothing, g') -> xdfsFoldWith d f acc vs g'

test/FLouvainSpec.hs

+module FLouvainSpec where
+
+import Test.Hspec
+
+import Protolude
+
+-- FGL
+import Data.Graph.Inductive
+
+import Data.Graph.Clustering.FLouvain
+import Data.Graph.Clustering.Louvain.Utils (mkFGraph, mkFGraph')
+import Data.Graph.FGL
+
+-- 1 -> 2 -> 3
+
+simpleGraph :: FGraph () ()
+simpleGraph = mkFGraph' [ (1, 2, 1.0)
+                        , (2, 3, 1.0)
+                        ]
+
+simpleLGraph :: FGraph Text ()
+simpleLGraph = mkFGraph [ (1, "one")
+                        , (2, "two")
+                        , (3, "three")]
+                        [ (1, 2, 1.0)
+                        , (2, 3, 1.0) ]
+
+spec :: Spec
+spec = do
+  describe "FLouvain tests" $ do
+    it "graphWeight computes correctly" $ do
+      graphWeight simpleGraph `shouldBe` GraphWeightSum 2.0
+
+    it "initialCgr computes correctly" $ do
+      let cgr = initialCGr simpleGraph
+          communities = lnodes cgr
+      nodes cgr `shouldBe` [1, 2, 3]
+      edges cgr `shouldBe` [ (1, 2)
+                           , (2, 3) ]
+      map comNodes communities `shouldBe` [[1], [2], [3]]
+
+    it "replaceLNode works correctly" $ do
+      let replaced = replaceLNode simpleLGraph (1, "ONE")
+      nodes replaced `shouldBe` [1, 2, 3]
+      lnodes replaced `shouldBe` ["ONE", "two", "three"]

test/Spec.hs

+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+
 --import Data.List (sort)
 ---- import Data.Example
 --import Data.Louvain
@@ -12,5 +14,5 @@
 --    print $  result == karate2com
 --
 
-main :: IO ()
-main = print "undefined" -- testKarate2com
+-- main :: IO ()
+-- main = print "undefined" -- testKarate2com