From 77f8447cc4cd6dd5cb499d310a8e8cbee78617ec Mon Sep 17 00:00:00 2001 From: tpajenka Date: Sun, 16 Mar 2014 18:26:45 +0100 Subject: [PATCH] changed calculation to only return maximum DCB (those that cannot be expanded), restricted DCB module export to reasonable functions --- src/DCB/DCB.hs | 30 ++++++++++++++++++++++-------- src/Main.hs | 6 ++++++ src/Util.hs | 12 ++++++++++++ 3 files changed, 40 insertions(+), 8 deletions(-) diff --git a/src/DCB/DCB.hs b/src/DCB/DCB.hs index ee42989..ab26a61 100644 --- a/src/DCB/DCB.hs +++ b/src/DCB/DCB.hs @@ -16,7 +16,7 @@ -- | --DCB.DCB--------------------------------------------------------------------------- -module DCB.DCB where +module DCB.DCB (preprocess, maxDCB, step, expand, addPoint, addablePoints, filterLayer) where import Util import DCB.Structures import DCB.IO @@ -42,7 +42,6 @@ import qualified Data.ByteString.Char8 as B - testAdj :: Adj testAdj = A.fromListUnboxed (ix2 10 10) [0,1,1,1,0,0,1,0,0,1,{----}1,0,0,0,1,0,1,1,0,0, 1,0,0,1,0,0,0,1,0,1,{----}1,0,1,0,1,1,1,0,0,0, @@ -74,7 +73,22 @@ instance (A.Shape sh, V.Unbox e) => NFData (Array A.U sh e) where rnf a = () {-# INLINE rnf #-} ---TODO: Do we have to filter? + +-- | Calculates all maximum DCB. A maximum DCB is a densely connected bicluster that cannot be +-- expanded by any additional node without breaking the constraints. +-- +-- This function does return the seed graphs themselves if they cannot be expanded. +maxDCB :: [Graph] -> Adj -> Attr -> Density -> MaxDivergence -> Int -> [Graph] +maxDCB [] _ _ _ _ _ = [] +maxDCB gs adj attr dens maxDiv minHit = + let next = L.map (expand adj attr dens maxDiv minHit) gs +|| (parBuffer 1000 rdeepseq) + (maximal, expandable) = part (\_ rem -> rem == []) (zip gs next) + expandable' = filterLayer $ concat expandable + -- Divide solutions into expandable solutions and maximum solutions. Expandable solutions + -- yield a result via the 'expand' function. + in maxDCB expandable' adj attr dens maxDiv minHit L.++ maximal + -- append maximum solutions of prospective function calls and maximum solutions of this iteration + -- | creates a step in iteration. -- Basically calls expand for every Graph left in our List of interesting Graphs @@ -83,6 +97,7 @@ step :: [Graph] -> Adj -> Attr -> Density -> MaxDivergence -> Int -> [Graph] step gs@((ind,_,_):_) a b c d e = traceEvent ("step from " P.++ show (A.extent ind) ) $ filterLayer $ concat $ map (expand a b c d e ) gs +|| (parBuffer 1000 rdeepseq) +-- TODO: remove @((ind,_,_):_) for exhaustive pattern @@ -90,9 +105,8 @@ step gs@((ind,_,_):_) a b c d e = traceEvent ("step from " P.++ show (A.extent i -- i.e. constraint a == Just Constraints for all returned Graphs expand :: Adj -> Attr -> Density -> MaxDivergence -> Int -> Graph -> [Graph] expand adj attr d div req g@(ind,_,_) = --trace ("expanding graph "P.++ B.unpack (outputGraph [g])) - catMaybes $ map - (addPoint adj attr d div req g) - (V.toList $ V.findIndices (==True) $ A.toUnboxed $ addablePoints adj g) + mapMaybe (addPoint adj attr d div req g) + (V.toList $ V.findIndices (==True) $ A.toUnboxed $ addablePoints adj g) -- | Creates an adjacency matrix from the given adjacency matrix where all -- edges are removed whose belonging nodes cannot fulfill the passed constraints. @@ -139,7 +153,7 @@ constraintInit :: Attr -> MaxDivergence -> Int -- ^ required number of consisten -> Maybe Constraints constraintInit ! attr ! div req i j = let - ! (Z:._:.nAttr) = A.extent attr + (Z:._:.nAttr) = A.extent attr fConstr (Z:.a:.c) = case c of 0 -> min (attr!(ix2 i a)) (attr!(ix2 j a)) @@ -198,7 +212,7 @@ updateDensity adj nodes newNode dens = let neighbourSlice = A.map (\n -> fromIntegral $adj!(A.ix2 newNode n)) nodes neighbours = A.foldAllS (+) (0::Int) ({- trace (show $ A.computeUnboxedS neighbourSlice)-} neighbourSlice) - ! (Z:.n') = A.extent nodes + (Z:.n') = A.extent nodes ! n = fromIntegral n' newdens = (dens * ((n)*(n-1)) / 2 + fromIntegral neighbours) * 2 / ((n+1)*(n)) in newdens diff --git a/src/Main.hs b/src/Main.hs index 4677126..569b657 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -158,12 +158,18 @@ doCalculation adj attr p = outputGraph $ L.sort $ doAll graph_ adj_ attr dens omega delta ] where + -- don't print out seeds + doAll [] _ _ _ _ _ = [] + doAll gs a b c d e = maxDCB (step gs a b c d e) a b c d e + + {-- commented out: all solutions, not only maximum DCB -- don't print out seeds doAll [] _ _ _ _ _ = [] doAll gs a b c d e = doAll' (step gs a b c d e) a b c d e -- but everything in the following recursive calls doAll' [] _ _ _ _ _ = [] doAll' gs a b c d e = gs ++ doAll' (step gs a b c d e) a b c d e + --} -- | gets the length of the 'Left a'. -- diff --git a/src/Util.hs b/src/Util.hs index b975f3c..f40697a 100644 --- a/src/Util.hs +++ b/src/Util.hs @@ -136,3 +136,15 @@ isLeft a = case a of Left _ -> True; _ -> False -- | Tests whether an 'Either' type is 'Right'. isRight :: Either a b -> Bool isRight = not . isLeft + +-- | The 'part' function takes a predicate and a list of tuples and returns +-- the pair of lists of left elements which do and right elements which do not satisfy the +-- predicate, respectively; i.e., +-- +-- > part (\a b -> elem a b) [(1, [1, 3]), (2, [3, 4]), (0, [0, 5])] == ([1, 0], [[3, 4]]) +part :: (a -> b -> Bool) -> [(a, b)] -> ([a], [b]) +part p xs = foldr (select p) ([], []) xs + where + select :: (a -> b -> Bool) -> (a, b) -> ([a], [b]) -> ([a], [b]) + select p (t,f) ~(ts,fs) | p t f = (t:ts,fs) + | otherwise = (ts, f:fs) \ No newline at end of file