Louvain ok (verified with karate club and igraph example:...

Louvain ok (verified with karate club and igraph example: http://ptrckprry.com/course/ssd/lecture/community.html)

src/Data/Louvain.hs

 module Data.Louvain where
 
-import Data.List (maximumBy,nub)
+import Data.List (minimum, maximumBy,nub, intersect, foldl', reverse)
 import Data.Graph.Inductive
+import Data.Example
 
 type Modularity = Double
+type Community = [Node] 
 
--- | 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)) ( nub $ concat $ Prelude.map (lsuc gr') b )
+startcom :: DynGraph gr => gr a b -> [[Node]]
+startcom gr = Prelude.map (\x -> [] ++ [x]) ( nodes gr )
 
--- | TODO exducedGraph (inverse for tests with quickCheck)
-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
+stepscom :: DynGraph gr => gr a1 b -> Int -> [[Node]]
+stepscom gr n = foldl' (\xs n' -> stepcom gr (smallCom xs) xs) (startcom gr) [1..n]
+    where
+        smallCom xs = head $ filter (\x -> length x == minimum (Prelude.map length xs)) (reverse xs)
 
-neighbors'' :: DynGraph gr => gr a b -> [Node] -> [Node]
-neighbors'' gr ns = nub $ concat (Prelude.map (neighbors gr) ns)
+stepcom gr n ns = bestModularities gr $ [ns] ++ Prelude.map (\x -> x ++ neighout) (addcom n neighin)
+    where
+        ns' = filter (/= n) ns
+        neighin    = filter (\c ->  (intersect (neighcom gr n) c) /= [] ) ns'
+        neighout   = filter (\c ->  (intersect (neighcom gr n) c) == [] ) ns'
 
-neighcom :: DynGraph gr => gr a b -> Node -> [[Node]]
-neighcom gr n = scanl (\x y -> take 1 x ++ [y]) [n] (neighbors gr n)
+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''
+            where
+                com'   = concat $ [com] ++ (take 1 coms)
+                coms'' = drop 1 coms
 
-neighcom' :: DynGraph gr => gr a b -> [Node] -> [[Node]]
-neighcom' gr ns = scanl (\x y -> take 1 x ++ [y]) ns (neighbors'' gr ns)
+neighcom :: DynGraph gr => gr a b -> [Node] -> [Node]
+neighcom gr ns = ( nub . filter (not . (`elem` ns)) . concat ) ns'
+    where ns' = Prelude.map (neighbors gr) ns
 
 rotate :: Int -> [a] -> [a]
 rotate _ [] = []
 rotate n xs = zipWith const (drop n (cycle xs)) xs
 
-takeDrop :: Int -> [a] -> [[a]]
-takeDrop n xs = [ (take n xs), drop n xs]
-
--- http://stackoverflow.com/questions/35388734/list-partitioning-implemented-recursively
-separate :: [a] -> [[[a]]]
-separate [] = [[]]
-separate (x:xs) = let recur = separate xs
-                      split = do
-                        partition <- recur
-                        return $ [x] : partition
-                      noSplit = do
-                        (y:ys) <- recur
-                        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)     ]
-               ]
-
-
-gpartition :: DynGraph gr => gr a b -> [[[Node]]]
-gpartition gr = separate (nodes gr)
-
 modularities :: DynGraph gr => gr a b -> [[Node]] -> Double
 modularities gr xs = sum $ Prelude.map (\y -> modularity gr y) xs
 
@@ -64,8 +47,9 @@ compareModularities gr xs ys
     | modularities gr xs > modularities gr ys = GT
     | otherwise = EQ
 
-bestPartition :: DynGraph gr => gr a b -> [[Node]]
-bestPartition gr = maximumBy (compareModularities gr) $ gpartition gr
+
+bestModularities :: DynGraph gr => gr a b -> [[[Node]]] -> [[Node]]
+bestModularities gr ns = maximumBy (compareModularities gr) ns
 
 modularity :: DynGraph gr => gr a b -> [Node] -> Double
 modularity gr ns = coverage - edgeDensity
@@ -88,3 +72,44 @@ 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:
+----------------------------------------------------------
+
+takeDrop :: Int -> [a] -> [[a]]
+takeDrop n xs = [ (take n xs), drop n xs]
+
+-- http://stackoverflow.com/questions/35388734/list-partitioning-implemented-recursively
+separate :: [a] -> [[[a]]]
+separate [] = [[]]
+separate (x:xs) = let recur = separate xs
+                      split = do
+                        partition <- recur
+                        return $ [x] : partition
+                      noSplit = do
+                        (y:ys) <- recur
+                        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)     ]
+               ]
+
+
+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
+----------------------------------------------------------
+
+