diff --git a/hieraclus.cabal b/hieraclus.cabal --- a/hieraclus.cabal +++ b/hieraclus.cabal @@ -7,10 +7,10 @@ -- The package version. See the Haskell package versioning policy -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for -- standards guiding when and how versions should be incremented. -Version: 0.1.1.2 +Version: 0.1.2 -- A short (one-line) description of the package. -Synopsis: Automated clustering of arbitrary elements in Haskell +Synopsis: Automated clustering of arbitrary elements in Haskell. -- A longer description of the package. Description: Hieraclus is a library that supports clustering of arbitrary elements in haskell. The @@ -55,7 +55,7 @@ Exposed-modules: Numeric.Statistics.Clustering.Clustering, Numeric.Statistics.Clustering.VectorUtils -- Packages needed in order to build this package. - Build-depends: base >= 2 && <= 5, haskell98 -any, mtl -any, containers -any, multiset >= 0.2.1, hstats >= 0.3, HUnit >= 1 + Build-depends: base >= 2 && <= 5, haskell98 -any, mtl -any, containers -any, multiset >= 0.2.1, HUnit >= 1 -- Modules not exported by this package. -- Other-modules: Numeric.Statistics.Clustering.Main diff --git a/src/Numeric/Statistics/Clustering/Clustering.hs b/src/Numeric/Statistics/Clustering/Clustering.hs --- a/src/Numeric/Statistics/Clustering/Clustering.hs +++ b/src/Numeric/Statistics/Clustering/Clustering.hs @@ -58,7 +58,7 @@ -- * Abort Criterias noAbort, - maxAccum, + maxTotal, nCluster, nSteps, calinski, @@ -105,10 +105,10 @@ import qualified Data.MultiSet as MS import Control.Monad.State import Maybe (fromJust) -import Math.Statistics ( devsq, average) import Numeric.Statistics.Clustering.VectorUtils ( Vector(..), - meanSquareV + meanSquareV, + average ) import qualified Numeric.Statistics.Clustering.VectorUtils as VU @@ -216,8 +216,7 @@ -- Storage complexity is /O(n^2)/ type CombinationMap a = Map (Pair ID) a --- | the distance function calculates says how to determine the --- distance between two arbitrary elements of the same type +-- | a Cluster Function calculates the distance between two clusters type ClusterFunction a = (Cluster a -> Cluster a -> a) -- | the cluster state contains information about all relevant maps @@ -237,8 +236,8 @@ idents :: Map (Vector a) b, -- ^ holds the mapping from the representation vectors to its actual objects nElems :: Int, -- ^ the number of elements to be clustered cNew :: (Cluster a, [Cluster a]), -- ^ the new created cluster and the all other clusters - cResult :: a, -- ^ a quality factor of the current combining that indicates the \"costs\" of cNew - accumRes :: a, -- ^ the accmulated costs + costs :: a, -- ^ a quality factor of the current combining that indicates the \"costs\" of cNew + total :: a, -- ^ the accmulated costs cStep :: Int, -- ^ the current clustering step cHistory :: [a] -- ^ holds a history of all costs } deriving (Show) @@ -253,28 +252,28 @@ -- | An AbortCriterium is a constraint for the clustering process -- deciding how many cluster steps are to be done. After each cluster --- step the abort criterim is asked. +-- step the abort criterim is asked. /True/ means abortion of clustering. type AbortCriterium a b = ClusterInfo a b -> Bool -- | no abortion means that the cluster process is only limited by its -- maximum number of possible steps that is: /n/ - 1 where /n/ is the -- number of elements to be clustered noAbort :: AbortCriterium a b -noAbort cInfo = cStep cInfo >= nElems cInfo - 1 +noAbort cInfo = cStep cInfo >= nElems cInfo -- | defines the max. \"costs\" of a further combining of two clusters. -- This can be the increase of the euclidean distance e.g. as -- well as the varianceSum -maxAccum :: Ord a => a -> AbortCriterium a b -maxAccum n cInfo = accumRes cInfo > n +maxTotal :: Ord a => a -> AbortCriterium a b +maxTotal n cInfo = total cInfo > n -- | sets a max. number of clusters nCluster :: Int -> AbortCriterium a b -nCluster n cInfo = n >= (nElems cInfo - cStep cInfo) +nCluster n cInfo = n > (nElems cInfo - cStep cInfo) -- | sets a number of steps that has to be done nSteps :: Int -> AbortCriterium a b -nSteps n cInfo = cStep cInfo >= n +nSteps n cInfo = cStep cInfo > n -- | defines a tolerance for the homogeneity of the clusters -- that is the relation of the inner varianceSum of the recently @@ -297,12 +296,17 @@ -- at step k+1. The second parameter gives the max. allowed multiple of -- average inclination ellbow :: (Ord a, Num a, Floating a) => Int -> a -> AbortCriterium a b -ellbow minSteps factor cInfo = (cStep cInfo) >= minSteps && (cResult cInfo) > - factor * (histAvg $ cHistory cInfo) +ellbow minSteps factor cInfo = (cStep cInfo) > minSteps && + (not $ null history) && + currInc > factor * (histAvg oldIncls) where - histAvg [] = 0 + history = cHistory cInfo + (currInc:oldIncls) = inclinations history + inclinations [x] = [x] + inclinations xs = zipWith (-) xs (tail xs) + histAvg [] = currInc histAvg [x] = x - histAvg xs = average $ tail xs + histAvg xs = average xs @@ -310,11 +314,12 @@ Cluster Methods -----------------------------------------------------------------------------} --- | calulates the difference of two clusters by comparing each pair of vectors +-- | a distance function determines how to calculate the distance between two +-- vectors type DistanceFunction a = Vector a -> Vector a -> a -- | calculates the difference of two clusters by comparing them as a whole, --- e.g. the varianceSum of the clusters can be used +-- e.g. the sum of variances of the clusters can be used type SimilarityFunction a = [Vector a] -> a @@ -355,16 +360,19 @@ -----------------------------------------------------------------------------} -- | a cost function has to descide how the single results produced after each -- clustering step can be accumlated. +-- First tupel element gives the costs of the current step. The second element +-- gives the accumulated costs type CostFunction a = a -> a -> [[Vector a]] -> a -- the several costs of clustering may simply be added addition :: Num a => CostFunction a -addition accumRes dist _ = accumRes + dist +addition total dist _ = total + dist -- the determination of the costs are calculated by considering the -- overall varianceSum varianceSum :: Floating a => CostFunction a -varianceSum _ _ cs = sum $ map meanSquareV cs +varianceSum _ dist cs = sum $ map meanSquareV cs + {---------------------------------------------------------------------------- @@ -426,7 +434,7 @@ ClusterMap a -> State (ClusterState a b) (ClusterMap a) clustering n f cf ac xs = do - cinfo' <- return . cinfo =<< get + cinfo' <- (\ci -> return ci{cStep = n}) . cinfo =<< get -- check abort criterias from left to right until one states true if ((not $ null ac) && (or $ map (\a -> a cinfo') ac)) || noAbort cinfo' then return xs @@ -434,20 +442,22 @@ (dist,(k1,k2)) <- findMin -- O (log n) (newCluster,rest,xs') <- mergeClusters k1 k2 xs -- O (log n) let - dist' = cf (accumRes cinfo') dist (map vals $ IntMap.elems xs') - toUpdate = (k1,k2) : updatePairs (IntMap.keys xs') k1 k2 -- O(n) - adjustMaps xs' toUpdate f - modify $ \s -> s { cinfo = cinfo' { + total' = cf (total cinfo') dist (map vals $ IntMap.elems xs') + toUpdate = (k1,k2) : updatePairs (IntMap.keys xs') k1 k2 -- O(n) + cinfo'' = cinfo' { cNew = (newCluster, IntMap.elems rest), - cResult = dist, - accumRes = dist', - cStep = n, - cHistory = dist' : cHistory cinfo'} - } - clustering (n+1) f cf ac xs' + costs = dist, + total = total', + cHistory = total' : cHistory cinfo'} + if ((not $ null ac) && (or $ map (\a -> a cinfo'') ac)) || noAbort cinfo'' + then return xs + else do + adjustMaps xs' toUpdate f + modify $ \s -> s {cinfo = cinfo'' } + clustering (n+1) f cf ac xs' --- | updates the combination-, cluster-, and minimum map after each clustering step +-- | updates the combination- and minimum map after each clustering step adjustMaps :: (Num a, Ord a) => ClusterMap a -> [Pair ID] -> @@ -468,7 +478,8 @@ modify $ \s -> s{minmap = minmap'', combis = combis''} return () --- | caclulates the pairs of clusters that has to be updated by giving the +-- | /O(n)/ +-- caclulates the pairs of clusters that has to be updated by giving the -- the two recently combined cluster ids updatePairs :: [ID] -> ID -> ID -> [Pair ID] updatePairs xs a b = [ if x < y then (x,y) else (y,x) | @@ -549,7 +560,7 @@ mkError :: String -> a mkError = error . (++) "Clustering: " - + diff --git a/src/Numeric/Statistics/Clustering/VectorUtils.hs b/src/Numeric/Statistics/Clustering/VectorUtils.hs --- a/src/Numeric/Statistics/Clustering/VectorUtils.hs +++ b/src/Numeric/Statistics/Clustering/VectorUtils.hs @@ -36,13 +36,14 @@ euklideanDistance, qeuklideanDistance, norm, - meanSquareV - + meanSquareV, + -- * Mathematical Helper Functions + average, + devsq ) where -import Math.Statistics (devsq) - + {---------------------------------------------------------------------------- Datatypes -----------------------------------------------------------------------------} @@ -114,3 +115,18 @@ meanSquareV' res [] = res meanSquareV' res vs' = meanSquareV' (res + (devsq $ map head vs')) (filter (/= []) (map tail vs')) + +{---------------------------------------------------------------------------- + Mathematical Helper Functions +-----------------------------------------------------------------------------} + +-- calculates the average +average :: Floating a => [a] -> a +average xs = let l = length xs + in (sum xs) / (fromIntegral l) + +devsq :: Floating a => [a] -> a +devsq xs = let m = average xs + in sum $ map ((^2).(flip (-))m) xs + +