som 8.0.6 → 8.1.1

raw patch · 4 files changed

+506/−2 lines, 4 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• som.cabal +5/−2
• src/Data/Datamining/Clustering/SOS.hs +59/−0
• src/Data/Datamining/Clustering/SOSInternal.hs +231/−0
• test/Data/Datamining/Clustering/SOSQC.hs +211/−0

@@ -1,5 +1,5 @@ Name:              som-Version:           8.0.6+Version:           8.1.1 Stability:         experimental Synopsis:          Self-Organising Maps. Description:       A Kohonen Self-organising Map (SOM) maps input patterns @@ -33,7 +33,7 @@ source-repository this   type:     git   location: https://github.com/mhwombat/som.git-  tag:      8.0.6+  tag:      8.1.1   library@@ -51,6 +51,8 @@                    Data.Datamining.Clustering.DSOMInternal,                    Data.Datamining.Clustering.SSOM,                    Data.Datamining.Clustering.SSOMInternal,+                   Data.Datamining.Clustering.SOS,+                   Data.Datamining.Clustering.SOSInternal,                    Data.Datamining.Clustering.Classifier,                    Data.Datamining.Pattern @@ -72,5 +74,6 @@   other-modules:   Data.Datamining.Clustering.SOMQC,                    Data.Datamining.Clustering.DSOMQC,                    Data.Datamining.Clustering.SSOMQC,+                   Data.Datamining.Clustering.SOSQC,                    Data.Datamining.PatternQC 

@@ -0,0 +1,59 @@+------------------------------------------------------------------------+-- |+-- Module      :  Data.Datamining.Clustering.SOS+-- Copyright   :  (c) Amy de Buitléir 2012-2015+-- License     :  BSD-style+-- Maintainer  :  amy@nualeargais.ie+-- Stability   :  experimental+-- Portability :  portable+--+-- A Self-organising Set (SOS). An SOS maps input patterns+-- onto a set, where each element in the set is a model of the input+-- data. An SOS is like a Kohonen Self-organising Map (SOM), except:+--+-- * Instead of a grid, it uses a simple set of unconnected models.+--   Since the models are unconnected, only the model that best matches+--   the input is ever updated. This makes it faster, however,+--   topological relationships within the input data are not preserved.+-- * New models are created on-the-fly when no existing model is+--   similar enough to an input pattern. If the SOS is at capacity,+--   the least useful model will be deleted.+--+-- This implementation supports the use of non-numeric patterns.+--+-- In layman's terms, a SOS can be useful when you you want to build+-- a set of models on some data. A tutorial is available at+-- <https://github.com/mhwombat/som/wiki>.+--+-- References:+--+-- * de Buitléir, Amy, Russell, Michael and Daly, Mark. (2012). Wains:+--   A pattern-seeking artificial life species. Artificial Life, 18 (4),+--   399-423. +-- +-- * Kohonen, T. (1982). Self-organized formation of topologically +--   correct feature maps. Biological Cybernetics, 43 (1), 59–69.+------------------------------------------------------------------------++module Data.Datamining.Clustering.SOS+  (+    -- * Construction+    SOS(..),+    makeSOS,+    -- * Deconstruction+    time,+    isEmpty,+    numModels,+    modelMap,+    counterMap,+    -- models,+    -- counters,+    -- * Learning and classification+    exponential,+    classify,+    train,+    trainBatch+  ) where++import Data.Datamining.Clustering.SOSInternal+

@@ -0,0 +1,231 @@+------------------------------------------------------------------------+-- |+-- Module      :  Data.Datamining.Clustering.SOSInternal+-- Copyright   :  (c) Amy de Buitléir 2012-2015+-- License     :  BSD-style+-- Maintainer  :  amy@nualeargais.ie+-- Stability   :  experimental+-- Portability :  portable+--+-- A module containing private @SOS@ internals. Most developers should+-- use @SOS@ instead. This module is subject to change without notice.+--+------------------------------------------------------------------------+{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances,+    MultiParamTypeClasses, DeriveAnyClass, DeriveGeneric #-}++module Data.Datamining.Clustering.SOSInternal where++import Prelude hiding (lookup)++import Control.DeepSeq (NFData)+import Data.List (minimumBy, foldl')+import Data.Ord (comparing)+import qualified Data.Map.Strict as M+import GHC.Generics (Generic)++-- | A typical learning function for classifiers.+--   @'exponential' r0 d t@ returns the learning rate at time @t@.+--   When @t = 0@, the learning rate is @r0@.+--   Over time the learning rate decays exponentially; the decay rate is+--   @d@.+--   Normally the parameters are chosen such that:+--+--   * 0 < r0 < 1+--+--   * 0 < d+exponential :: (Floating a, Integral t) => a -> a -> t -> a+exponential r0 d t = r0 * exp (-d*t')+  where t' = fromIntegral t++-- | A Simplified Self-Organising Map (SOS).+--   @t@ is the type of the counter.+--   @x@ is the type of the learning rate and the difference metric.+--   @k@ is the type of the model indices.+--   @p@ is the type of the input patterns and models.+data SOS t x k p = SOS+  {+    -- | Maps patterns and match counts to nodes.+    toMap :: M.Map k (p, t),+    -- | A function which determines the learning rate for a node.+    --   The input parameter indicates how many patterns (or pattern+    --   batches) have previously been presented to the classifier.+    --   Typically this is used to make the learning rate decay over+    --   time.+    --   The output is the learning rate for that node (the amount by+    --   which the node's model should be updated to match the target).+    --   The learning rate should be between zero and one.+    learningRate :: t -> x,+    -- | The maximum number of models this SOS can hold.+    maxSize :: Int,+    -- | The threshold that triggers creation of a new model.+    diffThreshold :: x,+    -- | A function which compares two patterns and returns a+    --   /non-negative/ number representing how different the patterns+    --   are.+    --   A result of @0@ indicates that the patterns are identical.+    difference :: p -> p -> x,+    -- | A function which updates models.+    --   For example, if this function is @f@, then+    --   @f target amount pattern@ returns a modified copy of @pattern@+    --   that is more similar to @target@ than @pattern@ is.+    --   The magnitude of the adjustment is controlled by the @amount@+    --   parameter, which should be a number between 0 and 1.+    --   Larger values for @amount@ permit greater adjustments.+    --   If @amount@=1, the result should be identical to the @target@.+    --   If @amount@=0, the result should be the unmodified @pattern@.+    makeSimilar :: p -> x -> p -> p,+    -- | Index for the next node to add to the SOS.+    nextIndex :: k+  } deriving (Generic, NFData)++-- @'makeSOS' lr n dt diff ms@ creates a new SOS that does not (yet)+-- contain any models.+-- It will learn at the rate determined by the learning function @lr@,+-- and will be able to hold up to @n@ models.+-- It will create a new model based on a pattern presented to it when+-- (1) the SOS contains no models, or+-- (2) the difference between the pattern and the closest matching+-- model exceeds the threshold @dt@.+-- It will use the function @diff@ to measure the similarity between+-- an input pattern and a model.+-- It will use the function @ms@ to adjust models as needed to make+-- them more similar to input patterns.+makeSOS+  :: Bounded k+    => (t -> x) -> Int -> x -> (p -> p -> x) -> (p -> x -> p -> p)+      -> SOS t x k p+makeSOS lr n dt diff ms =+  if n <= 0+    then error "max size for SOS <= 0"+    else SOS M.empty lr n dt diff ms minBound++-- | Returns true if the SOS has no models, false otherwise.+isEmpty :: SOS t x k p -> Bool+isEmpty = M.null . toMap++-- | Returns the number of models the SOS currently contains.+numModels :: SOS t x k p -> Int+numModels = length . M.keys . toMap++-- | Returns a map from node ID to model.+modelMap :: SOS t x k p -> M.Map k p+modelMap = M.map fst . toMap++-- | Returns a map from node ID to counter (number of times the+--   node's model has been the closest match to an input pattern).+counterMap :: SOS t x k p -> M.Map k t+counterMap = M.map snd . toMap++-- | Returns the current models.+models :: SOS t x k p -> [p]+models = map fst . M.elems . toMap++-- | Returns the current counters (number of times the+--   node's model has been the closest match to an input pattern).+counters :: SOS t x k p -> [t]+counters = map snd . M.elems . toMap++-- | The current "time" (number of times the SOS has been trained).+time :: Num t => SOS t x k p -> t+time = sum . map snd . M.elems . toMap++-- | Adds a new node to the SOS.+addNode+  :: (Num t, Enum k, Ord k)+    => p -> SOS t x k p -> SOS t x k p+addNode p s = if numModels s >= maxSize s+                then error "SOS is full"+                else s { toMap=gm', nextIndex=succ k }+  where gm = toMap s+        k = nextIndex s+        gm' = M.insert k (p, 0) gm++-- | Removes a node from the SOS.+--   Deleted nodes are never re-used.+deleteNode :: Ord k => k -> SOS t x k p -> SOS t x k p+deleteNode k s = s { toMap=gm' }+  where gm = toMap s+        gm' = if M.member k gm+                then M.delete k gm+                else error "no such node"++incrementCounter :: (Num t, Ord k) => k -> SOS t x k p -> SOS t x k p+incrementCounter k s = s { toMap=gm' }+  where gm = toMap s+        gm' = if M.member k gm+                then M.adjust inc k gm+                else error "no such node"+        inc (p, t) = (p, t+1)++-- | Trains the specified node to better match a target.+--   Most users should use @'train'@, which automatically determines+--   the BMU and trains it.+trainNode+  :: (Num t, Ord k)+    => SOS t x k p -> k -> p -> SOS t x k p+trainNode s k target = s { toMap=gm' }+  where gm = toMap s+        gm' = M.adjust tweakModel k gm+        r = (learningRate s) (time s)+        tweakModel (p, t) = (makeSimilar s target r p, t)++leastUsefulNode :: Ord t => SOS t x k p -> k+leastUsefulNode s = if isEmpty s+                      then error "SOS has no nodes"+                      else fst . minimumBy (comparing (snd . snd))+                             . M.toList . toMap $ s++deleteLeastUsefulNode :: (Ord t, Ord k) => SOS t x k p -> SOS t x k p+deleteLeastUsefulNode s = deleteNode k s+  where k = leastUsefulNode s++addModel+  :: (Num t, Ord t, Enum k, Ord k)+    => p -> SOS t x k p -> SOS t x k p+addModel p s = addNode p s'+  where s' = if numModels s >= maxSize s+                then deleteLeastUsefulNode s+                else s++-- reportAddModel+--   :: (Num t, Ord t, Num x, Enum k, Ord k)+--     => SOS t x k p -> p -> (k, x, [(k, x)], SOS t x k p)+-- reportAddModel s p = (k, 0, [(k, 0)], s'')+--   where (k, s') = addModel p s+--         s'' = incrementCounter k s'++-- | @'classify' s p@ identifies the model @s@ that most closely+--   matches the pattern @p@.+--   If necessary, it will create a new node and model.+--   Returns the ID of the node with the best matching model,+--   the difference between the best matching model and the pattern,+--   the differences between the input and each model in the SOS,+--   and the (possibly updated) SOS.+classify+  :: (Num t, Ord t, Num x, Ord x, Enum k, Ord k)+    => SOS t x k p -> p -> (k, x, [(k, x)], SOS t x k p)+classify s p+  | isEmpty s                 = classify (addModel p s) p+  | bmuDiff > diffThreshold s = classify (addModel p s) p+  | otherwise                 = (bmu, bmuDiff, diffs, s')+  where (bmu, bmuDiff) = minimumBy (comparing snd) diffs+        diffs = M.toList . M.map (difference s p) . M.map fst+                    . toMap $ s+        s' = incrementCounter bmu s++-- | @'train' s p@ identifies the model in @s@ that most closely+--   matches @p@, and updates it to be a somewhat better match.+train+  :: (Num t, Ord t, Num x, Ord x, Enum k, Ord k)+    => SOS t x k p -> p -> SOS t x k p+train s p = trainNode s' bmu p+  where (bmu, _, _, s') = classify s p++-- | For each pattern @p@ in @ps@, @'trainBatch' s ps@ identifies the+--   model in @s@ that most closely matches @p@,+--   and updates it to be a somewhat better match.+trainBatch+  :: (Num t, Ord t, Num x, Ord x, Enum k, Ord k)+    => SOS t x k p -> [p] -> SOS t x k p+trainBatch = foldl' train

@@ -0,0 +1,211 @@+------------------------------------------------------------------------+-- |+-- Module      :  Data.Datamining.Clustering.SOSQC+-- Copyright   :  (c) Amy de Buitléir 2012-2015+-- License     :  BSD-style+-- Maintainer  :  amy@nualeargais.ie+-- Stability   :  experimental+-- Portability :  portable+--+-- Tests+--+------------------------------------------------------------------------+{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleInstances,+    FlexibleContexts #-}+{-# OPTIONS_GHC -fno-warn-type-defaults -fno-warn-orphans #-}++module Data.Datamining.Clustering.SOSQC+  (+    test+  ) where++import Data.Datamining.Pattern (adjustNum, absDifference)+import Data.Datamining.Clustering.SOSInternal+import Data.List (minimumBy)+import qualified Data.Map.Strict as M+import Data.Ord (comparing)+import Data.Word (Word16)+import System.Random (Random)+import Test.Framework as TF (Test, testGroup)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.QuickCheck ((==>), Gen, Arbitrary, Property, Positive,+  arbitrary, shrink, choose, property, sized, suchThat, vectorOf,+  getPositive)++newtype UnitInterval a = UnitInterval {getUnitInterval :: a}+ deriving ( Eq, Ord, Show, Read)++instance Functor UnitInterval where+  fmap f (UnitInterval x) = UnitInterval (f x)++instance (Num a, Ord a, Random a, Arbitrary a)+    => Arbitrary (UnitInterval a) where+  arbitrary = fmap UnitInterval $ choose (0,1)+  shrink (UnitInterval x) =+    [ UnitInterval x' | x' <- shrink x, x' >= 0, x' <= 1]++prop_Exponential_starts_at_r0+  :: UnitInterval Double -> Positive Double -> Property+prop_Exponential_starts_at_r0 r0 d+  = property $ abs (exponential r0' d' 0 - r0') < 0.01+  where r0' = getUnitInterval r0+        d' = getPositive d++prop_Exponential_ge_0+  :: UnitInterval Double -> Positive Double -> Positive Int -> Property+prop_Exponential_ge_0 r0 d t = property $ exponential r0' d' t' >= 0+  where r0' = getUnitInterval r0+        d' = getPositive d+        t' = getPositive t++positive :: (Num a, Ord a, Arbitrary a) => Gen a+positive = arbitrary `suchThat` (> 0)++data TestSOS = TestSOS (SOS Int Double Word16 Double) String++instance Show TestSOS where+  show (TestSOS _ desc) = desc++buildTestSOS+  :: Double -> Double -> Int -> Double -> [Double] -> TestSOS+buildTestSOS r0 d maxSz dt ps = TestSOS s' desc+  where lrf = exponential r0 d+        s = makeSOS lrf maxSz dt absDifference adjustNum+        desc = "buildTestSOS " ++ show r0 ++ " " ++ show d+                 ++ " " ++ show maxSz+                 ++ " " ++ show dt+                 ++ " " ++ show ps+        s' = trainBatch s ps++sizedTestSOS :: Int -> Gen TestSOS+sizedTestSOS n = do+  maxSz <- choose (1, n+1)+  let numPatterns = n+  r0 <- choose (0, 1)+  d <- positive+  dt <- choose (0, 1)+  ps <- vectorOf numPatterns arbitrary+  return $ buildTestSOS r0 d maxSz dt ps++instance Arbitrary TestSOS where+  arbitrary = sized sizedTestSOS++prop_classify_increments_counter :: TestSOS -> Double -> Property+prop_classify_increments_counter (TestSOS s _) x+  = numModels s < maxSize s ==> countAfter == countBefore + 1+  -- We have to check if the SOS is full, otherwise we'll replace an+  -- existing model (and its counter), which means that the total+  -- count could change by an arbitrary amount.+  where countBefore = time s+        countAfter = time s'+        (_, _, _, s') = classify s x++prop_classify_chooses_best_fit :: TestSOS -> Double -> Property+prop_classify_chooses_best_fit (TestSOS s _) x+  = property $ bmu == fst (minimumBy (comparing snd) diffs)+  where (bmu, _, diffs, _) = classify s x++prop_trainNode_reduces_diff :: TestSOS -> Double -> Property+prop_trainNode_reduces_diff (TestSOS s _) x = not (isEmpty s) ==>+  diffAfter < diffBefore || diffBefore == 0+                         || learningRate s (time s) < 1e-10+  where (bmu, diffBefore, _, s2) = classify s x+        s3 = trainNode s2 bmu x+        (_, diffAfter, _, _) = classify s3 x++prop_diff_lt_threshold_after_training :: TestSOS -> Double -> Property+prop_diff_lt_threshold_after_training (TestSOS s _) x =+  property $ diffAfter < diffThreshold s+  where s' = train s x+        (_, diffAfter, _, _) = classify s' x++prop_training_reduces_diff :: TestSOS -> Double -> Property+prop_training_reduces_diff (TestSOS s _) x = not (isEmpty s) ==>+  diffAfter < diffBefore || diffBefore == 0+                         || learningRate s (time s) < 1e-10+  where (_, diffBefore, _, s2) = classify s x+        s3 = train s2 x+        (_, diffAfter, _, _) = classify s3 x++-- TODO prop: map will never exceed maxSize++prop_train_only_modifies_one_model+  :: TestSOS -> Double -> Property+prop_train_only_modifies_one_model (TestSOS s _) p+  = numModels s < maxSize s ==> otherModelsBefore == otherModelsAfter+    where (bmu, _, _, s2) = classify s p+          s3 = train s2 p+          otherModelsBefore = M.delete bmu . M.map fst . toMap $ s2+          otherModelsAfter = M.delete bmu . M.map fst . toMap $ s3++prop_train_increments_counter :: TestSOS -> Double -> Property+prop_train_increments_counter (TestSOS s _) x+  = numModels s < maxSize s ==> countAfter == countBefore + 1+  -- We have to check if the SOS is full, otherwise we'll replace an+  -- existing model (and its counter), which means that the total+  -- count could change by an arbitrary amount.+  where countBefore = time s+        countAfter = time $ train s x++-- | The training set consists of the same vectors in the same order,+--   several times over. So the resulting classifications should consist+--   of the same integers in the same order, over and over.+prop_batch_training_works :: TestSOS -> [Double] -> Property+prop_batch_training_works (TestSOS s _) ps+  -- = maxSize s > length ps+  --   ==> classifications == (concat . replicate 5) firstSet+  = property $ classifications == (concat . replicate 5) firstSet+  where trainingSet = (concat . replicate 5) ps+        sRightSize = if maxSize s >= length ps+          then s+          else s { maxSize=length ps + 1}+        s' = trainBatch sRightSize trainingSet+        classifications = map (justBMU . classify s') trainingSet+        justBMU = \(bmu, _, _, _) -> bmu+        firstSet = take (length ps) classifications++-- | WARNING: This can fail when two nodes are close enough in+--   value so that after training they become identical.+prop_classification_is_consistent :: TestSOS -> Double -> Property+prop_classification_is_consistent (TestSOS s _) x+  = property $ bmu == bmu'+  where (bmu, _, _, s2) = classify s x+        s3 = train s2 x+        (bmu', _, _, _) = classify s3 x++prop_classification_stabilises+  :: TestSOS -> [Double] -> Property+prop_classification_stabilises (TestSOS s _)  ps+  = (not . null $ ps) && maxSize s > length ps ==> k2 == k1+  where sStable = trainBatch s . concat . replicate 10 $ ps+        (k1, _, _, sStable2) = classify sStable (head ps)+        sStable3 = trainBatch sStable2 ps+        (k2, _, _, _) = classify sStable3 (head ps)++test :: Test+test = testGroup "QuickCheck Data.Datamining.Clustering.SOS"+  [+    testProperty "prop_Exponential_starts_at_r0"+      prop_Exponential_starts_at_r0,+    testProperty "prop_Exponential_ge_0"+      prop_Exponential_ge_0,+    testProperty "prop_classify_increments_counter"+      prop_classify_increments_counter,+    testProperty "prop_classify_chooses_best_fit"+      prop_classify_chooses_best_fit,+    testProperty "prop_trainNode_reduces_diff"+      prop_trainNode_reduces_diff,+    testProperty "prop_diff_lt_threshold_after_training"+      prop_diff_lt_threshold_after_training,+    testProperty "prop_training_reduces_diff"+      prop_training_reduces_diff,+    testProperty "prop_train_only_modifies_one_model"+      prop_train_only_modifies_one_model,+    testProperty "prop_train_increments_counter"+      prop_train_increments_counter,+    testProperty "prop_batch_training_works" prop_batch_training_works,+    testProperty "prop_classification_is_consistent"+      prop_classification_is_consistent,+    testProperty "prop_classification_stabilises"+      prop_classification_stabilises+  ]