packages feed

roc-cluster (empty) → 0.1.0.0

raw patch · 7 files changed

+327/−0 lines, 7 filesdep +HUnitdep +basedep +hspecsetup-changed

Dependencies added: HUnit, base, hspec, roc-cluster, vector

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Hexresearch Team (c) 2017++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Hexresearch Team nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,3 @@+# roc-cluster++Inspired by [Improving the Robustness of ‘Online Agglomerative Clustering Method’ Based on Kernel-Induce Distance Measures](http://link.springer.com/article/10.1007/s11063-004-2793-y)
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ roc-cluster.cabal view
@@ -0,0 +1,48 @@+name:                roc-cluster+version:             0.1.0.0+synopsis:            ROC online clustering algorithm+description:         Provides generic implementation for ROC online clustering algorithm.+homepage:            https://github.com/hexresearch/roc-cluster#readme+license:             BSD3+license-file:        LICENSE+author:              Anton Gushcha+maintainer:          ncrashed@gmail.com+copyright:           2017 Hexresearch Team+category:            Data+build-type:          Simple+extra-source-files:  README.md+cabal-version:       >=1.10++library+  hs-source-dirs:      src+  exposed-modules:     Data.Cluster.ROC+  build-depends:+      base        >= 4.7    && < 5+    , vector      >= 0.11   && < 0.12+  default-language:    Haskell2010+  default-extensions:+    DeriveDataTypeable+    DeriveFunctor+    DeriveGeneric+    RecordWildCards+    ScopedTypeVariables++test-suite roc-cluster-test+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             Spec.hs+  other-modules:+    Data.Cluster.ROCSpec+  build-depends:+      base+    , roc-cluster+    , hspec+    , HUnit+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N+  default-language:    Haskell2010+  default-extensions:+    ScopedTypeVariables++source-repository head+  type:     git+  location: https://github.com/hexresearch/roc-cluster
+ src/Data/Cluster/ROC.hs view
@@ -0,0 +1,194 @@+module Data.Cluster.ROC(+  -- * Algorithm configuration+    ROCConfig+  , rocThreshold+  , rocMaxClusters+  , defaultROCConfig+  -- * Cluster definition+  , Prototype+  , newPrototype+  , prototypeValue+  , prototypeWeight+  -- * API+  , ClusterSpace(..)+  , ROCContext+  , emptyROCContext+  , loadROCContext+  , rocPrototypes+  , clusterize+  -- * Fine grain API+  , clusterizeAddMerge+  , clusterizeSingle+  , clusterizeMerge+  , clusterizeNewPrototype+  , clusterizePostprocess+  ) where++import Data.Data+import Data.Monoid+import Data.Ord+import Data.Vector (Vector)+import GHC.Generics++import qualified Data.Foldable as F+import qualified Data.Vector as V++-- | Configuration of ROC clusterization+data ROCConfig = ROCConfig {+  -- | If weight of prototype is less than the value, it is removed at final+  -- step.+  rocThreshold   :: !Double+  -- | Maximum count of clusters, could be less+, rocMaxClusters :: !Int+} deriving (Generic, Data)++-- | Default configuration:+-- @+-- ROCConfig {+--   rocThreshold = 0+-- , rocMaxClusters = 10+-- }+-- @+defaultROCConfig :: ROCConfig+defaultROCConfig = ROCConfig {+    rocThreshold = 0+  , rocMaxClusters = 10+  }++-- | Operations that value has to support to use in ROC clusterisation+class ClusterSpace a where+  -- | Zero point in space+  pointZero   :: a+  -- | Addition of vectors in space+  pointAdd    :: a -> a -> a+  -- | Scaling by a scalar+  pointScale  :: Double -> a -> a+  -- | Kernel function+  pointKernel :: a -> a -> Double+  -- | Square of distance between of points (defined via kernel) and exposed+  -- only for possible optimizations as for Gaussian kernel (2 - 2 * pointKernel x y)+  pointDistanceSquared :: a -> a -> Double+  pointDistanceSquared x y = pointKernel x x - 2 * pointKernel x y + pointKernel y y+  {-# INLINE pointDistanceSquared #-}++-- | Cluster information+data Prototype a = Prototype {+  prototypeValue  :: !a+, prototypeWeight :: !Double+} deriving (Eq, Show, Generic, Functor)++-- | Create prototype with given point as center and zero weight+newPrototype :: a -> Prototype a+newPrototype a = Prototype a 0++instance ClusterSpace a => Monoid (Prototype a) where+  mempty = Prototype pointZero 0+  mappend p1 p2 = Prototype pos w+    where+      w = prototypeWeight p1 + prototypeWeight p2+      pos = (1/w) `pointScale` ((prototypeWeight p1 `pointScale` prototypeValue p1) `pointAdd` (prototypeWeight p2 `pointScale` prototypeValue p2))+  {-# INLINE mempty #-}+  {-# INLINE mappend #-}++-- | Internal context of algorithm+data ROCContext a = ROCContext {+  cntxPrototypes :: !(Vector (Prototype a))+, cntxConfig     :: !ROCConfig+} deriving (Generic, Functor)++-- | Create new context for clusterization from scratch+emptyROCContext :: ROCConfig -> ROCContext a+emptyROCContext cfg = ROCContext {+    cntxPrototypes = mempty+  , cntxConfig     = cfg+  }++-- | Load context from set of prototypes+loadROCContext :: Foldable f => ROCConfig -> f (Prototype a) -> ROCContext a+loadROCContext cfg ps = (emptyROCContext cfg) { cntxPrototypes = V.fromList . F.toList $ ps }++-- | Get collection of prototypes from ROC context+rocPrototypes :: ROCContext a -> [Prototype a]+rocPrototypes = F.toList . cntxPrototypes++-- | Perform clusterization of next part of data+clusterize :: forall a f . (ClusterSpace a, Foldable f)+  => f a -- ^ Set of data that need to be added to clusters+  -> ROCContext a -- ^ Context with current prototypes+  -> ROCContext a -- ^ Updated context+clusterize xs cntx0 = clusterizePostprocess addAll+  where+    addAll = F.foldl' (flip clusterizeAddMerge) cntx0 xs++-- | Cluster a single value (step 2-6 in original paper). Moves existing clusters,+-- creates new clusters and merges close clusters.+clusterizeAddMerge :: forall a . (ClusterSpace a)+  => a -- ^ Single point+  -> ROCContext a -- ^ Context with current prototypes+  -> ROCContext a -- ^ Updated context+clusterizeAddMerge x cntx = clusterizeNewPrototype x $ if n >= nmax then clusterizeMerge cntx' else cntx'+  where+    cntx' = clusterizeSingle x cntx+    n = V.length . cntxPrototypes $ cntx'+    nmax = rocMaxClusters . cntxConfig $ cntx'+{-# INLINE clusterizeAddMerge #-}++-- | Cluster a single value (step 2 in original paper). This step updates only existing+-- clusters.+clusterizeSingle :: forall a . (ClusterSpace a)+  => a -- ^ Single point+  -> ROCContext a -- ^ Context with current prototypes+  -> ROCContext a -- ^ Updated context+clusterizeSingle x ctx@ROCContext{..}+  | V.null cntxPrototypes = ctx+  | otherwise             = ctx { cntxPrototypes = cntxPrototypes V.// [(winnerIndex, winner')] }+    where+    winnerIndex = V.minIndex . fmap (pointDistanceSquared x . prototypeValue) $ cntxPrototypes+    winner = cntxPrototypes V.! winnerIndex+    winner' = let+         Prototype{..} = winner+         сwinner = prototypeWeight + pointKernel x prototypeValue+         ywinner = prototypeValue `pointAdd` ( (1 / сwinner) `pointScale` (x `pointAdd` pointScale (-1) prototypeValue) )+      in Prototype ywinner сwinner++{-# INLINE clusterizeSingle #-}++-- | Merge the most closest clusters (step 4 in original paper).+clusterizeMerge :: forall a . (ClusterSpace a)+  => ROCContext a -- ^ Context with current prototypes+  -> ROCContext a -- ^ Updated context+clusterizeMerge ctx@ROCContext{..}+  | V.length cntxPrototypes <= 1 = ctx+  | otherwise = ctx { cntxPrototypes = cntxPrototypes' }+  where+    -- find two prototypes that have minimum distance (warning, Vector monad!)+    (minxi, minyi, _) = V.minimumBy (comparing $ \(_, _, a) -> a) $ do+      (xi, xv) <- V.indexed cntxPrototypes+      (yi, yv) <- V.take xi $ V.indexed cntxPrototypes+      pure (xi, yi, prototypeValue yv `pointDistanceSquared` prototypeValue xv)+    x = cntxPrototypes V.! minxi+    y = cntxPrototypes V.! minyi+    x' = x <> y+    removeAt i v = V.slice 0 i v <> V.slice (i+1) (V.length v - i - 1) v+    cntxPrototypes' = removeAt minyi $ cntxPrototypes V.// [(minxi, x')]+{-# INLINE clusterizeMerge #-}++-- | Form a new prototype from single point (step 5 in original paper)+clusterizeNewPrototype :: forall a . (ClusterSpace a)+  => a -- ^ Point+  -> ROCContext a -- ^ Context with current prototypes+  -> ROCContext a -- ^ Updated context+clusterizeNewPrototype a ctx@ROCContext{..} = ctx { cntxPrototypes = cntxPrototypes `V.snoc` newProto }+  where+    newProto = Prototype a 0+{-# INLINE clusterizeNewPrototype #-}++-- | Remove clusters that have negligible weights (step 6 in original paper)+clusterizePostprocess :: forall a . (ClusterSpace a)+  => ROCContext a -- ^ Context with current prototypes+  -> ROCContext a -- ^ Updated context+clusterizePostprocess ctx@ROCContext{..} = ctx { cntxPrototypes = V.filter isValuable cntxPrototypes }+  where+    threshold = rocThreshold cntxConfig+    isValuable p = prototypeWeight p >= threshold+{-# INLINE clusterizePostprocess #-}
+ test/Data/Cluster/ROCSpec.hs view
@@ -0,0 +1,49 @@+module Data.Cluster.ROCSpec(+    spec+  ) where++import Data.Cluster.ROC+import Data.List (nub)+import Test.Hspec+import Test.HUnit++-- | Config without threshold+cfg :: ROCConfig+cfg = defaultROCConfig++-- | Config with threshold+cfg' :: ROCConfig+cfg' = defaultROCConfig {+    rocThreshold = 0.1+  }++data Vec2 = Vec2 !Double !Double+  deriving (Eq, Show)++instance ClusterSpace Vec2 where+  pointZero = Vec2 0 0+  pointAdd (Vec2 x1 y1) (Vec2 x2 y2) = Vec2 (x1 + x2) (y1 + y2)+  pointScale v (Vec2 x y) = Vec2 (v*x) (v*y)+  -- gaus kernell with sigma = 1+  pointKernel (Vec2 x1 y1) (Vec2 x2 y2) = exp ( negate $ 0.5 * ((x2 - x1) ^ 2 + (y2 - y1) ^ 2) )+  pointDistanceSquared x y = 2 - 2 * pointKernel x y+  {-# INLINE pointZero #-}+  {-# INLINE pointAdd #-}+  {-# INLINE pointScale #-}+  {-# INLINE pointKernel #-}+  {-# INLINE pointDistanceSquared #-}++spec :: Spec+spec = do+  it "Handle empty clusterization" $ do+    let cntx :: ROCContext Vec2 = clusterize [] $ emptyROCContext cfg+    assertEqual "should be empty" [] $ rocPrototypes cntx+  it "Handle single clusterization" $ do+    let cntx :: ROCContext Vec2 = clusterize [Vec2 0 0] $ emptyROCContext cfg+    assertEqual "should be empty" [newPrototype (Vec2 0 0)] $ rocPrototypes cntx+  it "Handle simple clusterization" $ do+    let cntx :: ROCContext Vec2 = clusterize [Vec2 0 0, Vec2 0.1 0] $ emptyROCContext cfg+    assertBool "should be 2 clusters" $ length (nub $ rocPrototypes cntx) == 2+  it "Handle simple clusterization with postprocess" $ do+    let cntx :: ROCContext Vec2 = clusterize [Vec2 0 0, Vec2 0.1 0] $ emptyROCContext cfg'+    assertBool "should be 2 clusters" $ length (nub $ rocPrototypes cntx) == 1
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}