Strategies.lhs

> {-# LANGUAGE ViewPatterns #-}

A parallel implementation of Lloyd's algorithm for k-means clustering,
adapted from Marlow's _Parallel and Concurrent Programming in Haskell_.
Here we use Evaluation Strategies to parallelise the assignment of
points to clusters:

> module Algorithms.Lloyd.Strategies (
>   Point(..),
>   Cluster(..), 
>   ExpectDivergent(..),
>   Partitions(..),
>   kmeans,
>   step
> ) where
>
> import Prelude hiding (zipWith, foldr1, map)
> import Control.Parallel.Strategies (Strategy(..), parTraversable, using, rseq)
> import Data.Foldable (Foldable(foldr1))
> import Data.Functor.Extras ((..:))
> import Data.Metric (Metric(..))
> import Data.Semigroup (Semigroup(..))
> import Data.Vector (Vector(..), zipWith, map)
> import Data.Vector.Split (chunksOf)
> import Algorithms.Lloyd.Sequential (Cluster(..), Point(..), ExpectDivergent(..), PointSum(..), makeNewClusters, assignPS, assign)

We can combine two vectors of some same type $t$ provided we know how to
combine two $t$s:

> instance Semigroup a => Semigroup (Vector a) where
>   (<>) = zipWith (<>)

Step is modified to, given a partitioned list of points, perform
classification in parallel:

> step :: Metric a => (Vector Double -> a) -> Vector Cluster -> Vector (Vector Point) -> Vector Cluster
> step = makeNewClusters . foldr1 (<>) . with (parTraversable rseq) ..: fmap ..: assignPS
>
> with :: Strategy a -> a -> a
> with = flip using

This version of k-means takes an additional arguments -- the number of
partitions the set of points'll be divided into. This needn't equal the
number of processors: if there are more spark than cores, the runtime
can be trusted to schedule unallocated sparks so soon as a core becomes
available. That said: if there are too many work items, the overhead of
recombination may exceed the speed-up provided by parallellism; if there
are too few items, and those items vary in cost, some of our cores may
be unused for part of the computation.

> newtype Partitions = Partitions { partitions :: Int }
>
> computeClusters :: Metric a => ExpectDivergent -> (Vector Double -> a) -> Partitions -> Vector Point -> Vector Cluster -> Vector Cluster
> computeClusters (expectDivergent -> expectDivergent) metric = computeClusters' expectDivergent metric 0  ..: chunksOf . partitions
>
> computeClusters' :: Metric a => Int -> (Vector Double -> a) -> Int -> Vector (Vector Point) -> Vector Cluster -> Vector Cluster
> computeClusters' expectDivergent metric iterations points clusters 
>   | iterations >= expectDivergent = clusters
>   | clusters' == clusters         = clusters 
>   | otherwise                     = computeClusters' expectDivergent metric (succ iterations) points clusters'
>   where clusters' = step metric clusters points
>
> kmeans :: Metric a => ExpectDivergent -> (Vector Double -> a) -> Partitions -> Vector Point -> Vector Cluster -> Vector (Vector Point)
> kmeans expectDivergent metric chunks points initial = assign metric clusters points
>   where clusters = computeClusters expectDivergent metric chunks points initial