diff --git a/Math/KMeans.hs b/Math/KMeans.hs --- a/Math/KMeans.hs +++ b/Math/KMeans.hs @@ -1,64 +1,89 @@ -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BangPatterns, ScopedTypeVariables #-} {- | Module : Math.KMeans -Copyright : (c) Alp Mestanogullari, 2011 +Copyright : (c) Alp Mestanogullari, Ville Tirronen, 2011-2012 License : BSD3 -Maintainer : alpmestan@gmail.com +Maintainer : Alp Mestanogullari Stability : experimental An implementation of the k-means clustering algorithm based on the efficient vector package. -} -module Math.KMeans (kmeans) where +module Math.KMeans (kmeans, Point, Cluster(..), computeClusters) where import qualified Data.Vector.Unboxed as V +import qualified Data.Vector as G import qualified Data.List as L import Data.Function (on) -import Debug.Trace --- * K-Means clustering algorithm -type Vec = V.Vector Double +-- | Type holding an object of any type and its associated feature vector +type Point a = (V.Vector Double, a) + +-- | Type representing a cluster (group) of vectors by its center and an id data Cluster = Cluster { cid :: !Int, - center :: !Vec - } + center :: !(V.Vector Double) + } -- deriving (Show,Eq) -distance :: Vec -> Vec -> Double -distance u v = V.sum $ V.zipWith (\a b -> (a - b)^2) u v +-- genVec = V.fromList `fmap` vectorOf 3 arbitrary +-- genPts = (flip zip) [0..] `fmap` replicateM 10 genVec +-- genClusters = do +-- cs <- replicateM 5 genVec +-- return (zipWith Cluster [0.. ] cs) +-- +-- prop_regroup = forAll genClusters $ \c -> +-- forAll genPts $ \v -> +-- s (regroupPoints c v) == s (regroupPoints' c v) +-- where +-- same xs = length (L.nub xs) == length xs +-- s = map L.sort -partitionPoints :: Int -> [Vec] -> [[Vec]] -partitionPoints k vs = go vs + +{-#INLINE distance#-} +distance :: Point a -> V.Vector Double -> Double +distance (u,_) v = V.sum $ V.zipWith (\a b -> (a - b)^2) u v + +partition :: Int -> [a] -> [[a]] +partition k vs = go vs where go vs = case L.splitAt n vs of (vs', []) -> [vs'] (vs', vss) -> vs' : go vss n = (length vs + k - 1) `div` k - -computeClusters :: [[Vec]] -> [Cluster] + +{-#INLINE computeClusters#-} +computeClusters :: [[V.Vector Double]] -> [Cluster] computeClusters = zipWith Cluster [0..] . map f where f (x:xs) = let (n, v) = L.foldl' (\(k, s) v' -> (k+1, V.zipWith (+) s v')) (1, x) xs in V.map (\x -> x / (fromIntegral n)) v -regroupPoints :: [Cluster] -> [Vec] -> [[Vec]] -regroupPoints clusters points = go points +{-#INLINE regroupPoints#-} +regroupPoints :: forall a. [Cluster] -> [Point a] -> [[Point a]] +regroupPoints clusters points = L.filter (not.null) . G.toList . G.accum (flip (:)) (G.replicate (length clusters) []) . map closest $ points + where + closest p = (cid (L.minimumBy (compare `on` (distance p . center)) clusters),p) + +regroupPoints' :: forall a. [Cluster] -> [Point a] -> [[Point a]] +regroupPoints' clusters points = go points where go points = map (map snd) . L.groupBy ((==) `on` fst) . L.sortBy (compare `on` fst) $ map (\p -> (closest p, p)) points closest p = cid $ L.minimumBy (compare `on` (distance p . center)) clusters - -kmeansStep :: [Vec] -> [[Vec]] -> [[Vec]] -kmeansStep points pgroups = regroupPoints (computeClusters pgroups) points -kmeansAux :: [Vec] -> [[Vec]] -> [[Vec]] +kmeansStep :: [Point a] -> [[Point a]] -> [[Point a]] +kmeansStep points pgroups = regroupPoints (computeClusters . map (map fst) $ pgroups) points + +kmeansAux :: [Point a] -> [[Point a]] -> [[Point a]] kmeansAux points pgroups = let pss = kmeansStep points pgroups in - case pss == pgroups of + case map (map fst) pss == map (map fst) pgroups of True -> pgroups - False -> kmeansAux points pss + False -> kmeansAux points pss -- | Performs the k-means clustering algorithm -- using trying to use 'k' clusters on the given list of points -kmeans :: Int -> [V.Vector Double] -> [[V.Vector Double]] +kmeans :: Int -> [Point a] -> [[Point a]] kmeans k points = kmeansAux points pgroups - where pgroups = partitionPoints k points + where pgroups = partition k points diff --git a/kmeans-vector.cabal b/kmeans-vector.cabal --- a/kmeans-vector.cabal +++ b/kmeans-vector.cabal @@ -1,30 +1,25 @@ Name: kmeans-vector -Version: 0.1.1 +Version: 0.2 Synopsis: An implementation of the kmeans clustering algorithm based on the vector package -Description: Provides a simple (but efficient) implementation of the k-means clustering algorithm. The goal of this algorithm is to, given a list of n-dimensional points, regroup them in k groups, such that each point gets to be in the group to which it is the closest to (using the 'center' of the group). - . - Sample output (after some gnuplot hackery -- see the tests dir in the repository): - . - Expect some improvements on the initial clustering, thus resulting in a better clustering, for future versions. +Description: Provides a simple (but efficient) implementation of the k-means clustering algorithm. The goal of this algorithm is to, given a list of n-dimensional points, regroup them in k groups, such that each point gets to be in the group to which it is the closest to (using the 'center' of the group). + . + CHANGELOG + . + kmeans-vector-0.2 supports having feature vectors associated to objects, and thus computing kmeans on these vectors, letting you recover the initial objects. --- URL for the project homepage or repository. Homepage: http://github.com/alpmestan/kmeans-vector + Bug-reports: https://github.com/alpmestan/kmeans-vector/issues --- The license under which the package is released. + License: BSD3 --- The file containing the license text. License-file: LICENSE --- The package author(s). -Author: Alp Mestanogullari +Author: Alp Mestanogullari , Ville Tirronen --- An email address to which users can send suggestions, bug reports, --- and patches. Maintainer: Alp Mestanogullari --- A copyright notice. -Copyright: 2011 Alp Mestanogullari +Copyright: 2011-2012 Alp Mestanogullari Stability: Experimental @@ -32,29 +27,14 @@ Build-type: Simple --- Extra files to be distributed with the package, such as examples or --- a README. --- Extra-source-files: - --- Constraint on the version of Cabal needed to build this package. Cabal-version: >=1.6 - Library - -- Modules exported by the library. Exposed-modules: Math.KMeans - - -- Packages needed in order to build this package. Build-depends: base >= 4 && < 5, vector >= 0.7 ghc-prof-options: -prof -auto-all ghc-options: -O2 -funbox-strict-fields - - -- Modules not exported by this package. - -- Other-modules: - - -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. - -- Build-tools: - + source-repository head type: git location: http://github.com/alpmestan/kmeans-vector.git