packages feed

som 10.1.2 → 10.1.3

raw patch · 21 files changed

+912/−193 lines, 21 files

Files

ChangeLog.md view
@@ -1,6 +1,8 @@ # Changelog for som +10.1.3 Added SGM3. 10.1.2 Fixed a warning.+       Added SGM2. 10.1.1 Fixed a warning.        Added more documentation. 10.0.1 Upgraded to Stackage lts-12.16.
som.cabal view
@@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: a3aa4f1cafee447c60a82975496ad7f90007d0fab9af1ac9d17e3e4f32324370+-- hash: adbfa8982ae14db2b504e528d5122057466a1628c04b8f3d74dbbb3d25dc2fdd  name:           som-version:        10.1.2+version:        10.1.3 synopsis:       Self-Organising Maps description:    Please see the README on GitHub at <https://github.com/mhwombat/som#readme> category:       Math@@ -34,6 +34,8 @@       Data.Datamining.Clustering.SGM       Data.Datamining.Clustering.SGM2       Data.Datamining.Clustering.SGM2Internal+      Data.Datamining.Clustering.SGM3+      Data.Datamining.Clustering.SGM3Internal       Data.Datamining.Clustering.SGMInternal       Data.Datamining.Clustering.SOM       Data.Datamining.Clustering.SOMInternal@@ -56,6 +58,7 @@   other-modules:       Data.Datamining.Clustering.DSOMQC       Data.Datamining.Clustering.SGM2QC+      Data.Datamining.Clustering.SGM3QC       Data.Datamining.Clustering.SGMQC       Data.Datamining.Clustering.SOMQC       Data.Datamining.PatternQC
src/Data/Datamining/Clustering/Classifier.hs view
@@ -10,16 +10,18 @@ -- Tools for identifying patterns in data. -- -------------------------------------------------------------------------{-# LANGUAGE TypeFamilies, FlexibleContexts, MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies          #-} module Data.Datamining.Clustering.Classifier   (     Classifier(..)   ) where -import Data.List (minimumBy)-import Data.Ord (comparing)+import           Data.List (minimumBy)+import           Data.Ord  (comparing) --- | A machine which learns to classify input patterns. +-- | A machine which learns to classify input patterns. --   Minimal complete definition: @trainBatch@, @reportAndTrain@. class Classifier (c :: * -> * -> * -> *) v k p where   -- | Returns a list of index\/model pairs.@@ -31,12 +33,12 @@   -- | Returns the current models of the classifier.   models :: c v k p -> [p] -  -- | @'differences' c target@ returns the indices of all nodes in -  --   @c@, paired with the difference between @target@ and the +  -- | @'differences' c target@ returns the indices of all nodes in+  --   @c@, paired with the difference between @target@ and the   --   node's model.   differences :: c v k p -> p -> [(k, v)] -  -- | @classify c target@ returns the index of the node in @c@ +  -- | @classify c target@ returns the index of the node in @c@   --   whose model best matches the @target@.   classify :: Ord v => c v k p -> p -> k   classify c p = f $ differences c p@@ -57,7 +59,7 @@   --   index of the node in @c@ whose model best matches the input   --   @target@, and a modified copy of the classifier @c@ that has   --   partially learned the @target@. Invoking @classifyAndTrain c p@-  --   may be faster than invoking @(p `classify` c, train c p)@, but +  --   may be faster than invoking @(p `classify` c, train c p)@, but   --   they   --   should give identical results.   classifyAndTrain :: c v k p -> p -> (k, c v k p)
src/Data/Datamining/Clustering/DSOM.hs view
@@ -14,9 +14,9 @@ -- References: -- -- * Rougier, N. & Boniface, Y. (2011). Dynamic self-organising map.---   Neurocomputing, 74 (11), 1840-1847. +--   Neurocomputing, 74 (11), 1840-1847. ----- * Kohonen, T. (1982). Self-organized formation of topologically +-- * Kohonen, T. (1982). Self-organized formation of topologically --   correct feature maps. Biological Cybernetics, 43 (1), 59–69. ------------------------------------------------------------------------ @@ -32,4 +32,4 @@     trainNeighbourhood   ) where -import Data.Datamining.Clustering.DSOMInternal+import           Data.Datamining.Clustering.DSOMInternal
src/Data/Datamining/Clustering/DSOMInternal.hs view
@@ -11,21 +11,26 @@ -- use @DSOM@ instead. This module is subject to change without notice. -- -------------------------------------------------------------------------{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances,-    MultiParamTypeClasses, DeriveAnyClass, DeriveGeneric,-    UndecidableInstances #-}+{-# LANGUAGE DeriveAnyClass        #-}+{-# LANGUAGE DeriveGeneric         #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}  module Data.Datamining.Clustering.DSOMInternal where -import Control.DeepSeq (NFData)-import qualified Data.Foldable as F (Foldable, foldr)-import Data.List (foldl', minimumBy)-import Data.Ord (comparing)-import GHC.Generics (Generic)-import qualified Math.Geometry.Grid as G (Grid(..), FiniteGrid(..))-import qualified Math.Geometry.GridMap as GM (GridMap(..))-import Data.Datamining.Clustering.Classifier(Classifier(..))-import Prelude hiding (lookup)+import           Control.DeepSeq                       (NFData)+import           Data.Datamining.Clustering.Classifier (Classifier (..))+import qualified Data.Foldable                         as F (Foldable, foldr)+import           Data.List                             (foldl', minimumBy)+import           Data.Ord                              (comparing)+import           GHC.Generics                          (Generic)+import qualified Math.Geometry.Grid                    as G (FiniteGrid (..),+                                                             Grid (..))+import qualified Math.Geometry.GridMap                 as GM (GridMap (..))+import           Prelude                               hiding (lookup)  -- | A Self-Organising Map (DSOM). --@@ -44,14 +49,14 @@   {     -- | Maps patterns to tiles in a regular grid.     --   In the context of a SOM, the tiles are called "nodes"-    gridMap :: gm p,+    gridMap      :: gm p,     -- | A function which determines the how quickly the SOM learns.     learningRate :: (x -> x -> x -> 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,+    difference   :: p -> p -> x,     -- | A function which updates models.     --   If this function is @f@, then @f target amount pattern@ returns     --   a modified copy of @pattern@ that is more similar to @target@@@ -61,7 +66,7 @@     --   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+    makeSimilar  :: p -> x -> p -> p   } deriving (Generic, NFData)  instance (F.Foldable gm) => F.Foldable (DSOM gm x k) where
src/Data/Datamining/Clustering/SGM.hs view
@@ -68,5 +68,5 @@     trainBatch   ) where -import Data.Datamining.Clustering.SGMInternal+import           Data.Datamining.Clustering.SGMInternal
src/Data/Datamining/Clustering/SGM2.hs view
@@ -1,6 +1,6 @@ ------------------------------------------------------------------------ -- |--- Module      :  Data.Datamining.Clustering.SGM+-- Module      :  Data.Datamining.Clustering.SGM2 -- Copyright   :  (c) Amy de Buitléir 2012-2018 -- License     :  BSD-style -- Maintainer  :  amy@nualeargais.ie@@ -66,5 +66,5 @@     trainBatch   ) where -import Data.Datamining.Clustering.SGM2Internal+import           Data.Datamining.Clustering.SGM2Internal
src/Data/Datamining/Clustering/SGM2Internal.hs view
@@ -1,6 +1,6 @@ ------------------------------------------------------------------------ -- |--- Module      :  Data.Datamining.Clustering.SGMInternal+-- Module      :  Data.Datamining.Clustering.SGM2Internal -- Copyright   :  (c) Amy de Buitléir 2012-2018 -- License     :  BSD-style -- Maintainer  :  amy@nualeargais.ie@@ -11,19 +11,23 @@ -- use @SGM@ instead. This module is subject to change without notice. -- -------------------------------------------------------------------------{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances,-    MultiParamTypeClasses, DeriveAnyClass, DeriveGeneric,-    UndecidableInstances #-}+{-# LANGUAGE DeriveAnyClass        #-}+{-# LANGUAGE DeriveGeneric         #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}  module Data.Datamining.Clustering.SGM2Internal where -import Prelude hiding (lookup)+import           Prelude         hiding (lookup) -import Control.DeepSeq (NFData)-import Data.List ((\\), minimumBy, sortBy, foldl')-import Data.Ord (comparing)+import           Control.DeepSeq (NFData)+import           Data.List       (foldl', minimumBy, sortBy, (\\)) import qualified Data.Map.Strict as M-import GHC.Generics (Generic)+import           Data.Ord        (comparing)+import           GHC.Generics    (Generic)  -- | A typical learning function for classifiers. --   @'exponential' r0 d t@ returns the learning rate at time @t@.@@ -47,7 +51,7 @@ data SGM t x k p = SGM   {     -- | Maps patterns and match counts to nodes.-    toMap :: M.Map k (p, t),+    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.@@ -58,12 +62,12 @@     --   The learning rate should be between zero and one.     learningRate :: t -> x,     -- | The maximum number of models this SGM can hold.-    capacity :: Int,+    capacity     :: Int,     -- | 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,+    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@@@ -73,9 +77,9 @@     --   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,+    makeSimilar  :: p -> x -> p -> p,     -- | Index for the next node to add to the SGM.-    nextIndex :: k+    nextIndex    :: k   } deriving (Generic, NFData)  -- | @'makeSGM' lr n diff ms@ creates a new SGM that does not (yet)
+ src/Data/Datamining/Clustering/SGM3.hs view
@@ -0,0 +1,70 @@+------------------------------------------------------------------------+-- |+-- Module      :  Data.Datamining.Clustering.SGM3+-- Copyright   :  (c) Amy de Buitléir 2012-2018+-- License     :  BSD-style+-- Maintainer  :  amy@nualeargais.ie+-- Stability   :  experimental+-- Portability :  portable+--+-- A Self-generating Model (SGM). An SGM maps input patterns+-- onto a set, where each element in the set is a model of the input+-- data. An SGM 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 SGM is at capacity,+--   the least useful model will be deleted.+--+-- This implementation supports the use of non-numeric patterns.+--+-- In layman's terms, a SGM 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:+--+-- * Amy de Buitléir, Mark Daly, and Michael Russell.+--   The Self-generating Model: an Adaptation of the Self-organizing Map+--   for Intelligent Agents and Data Mining.+--   In: Artificial Life and Intelligent Agents: Second International+--   Symposium, ALIA 2016, Birmingham, UK, June 14-15, 2016,+--   Revised Selected Papers.+--   Ed. by Peter R. Lewis et al. Springer International Publishing,+--   2018, pp. 59–72.+--   Available at http://amydebuitleir.eu/publications/.+--+-- * Amy de Buitléir, Michael Russell, and Mark Daly.+--   Wains: A pattern-seeking artificial life species.+--   Artificial Life, (18)4:399–423, 2012.+--   Available at http://amydebuitleir.eu/publications/.+--+-- * Kohonen, T. (1982). Self-organized formation of topologically+--   correct feature maps. Biological Cybernetics, 43 (1), 59–69.+------------------------------------------------------------------------++module Data.Datamining.Clustering.SGM3+  (+    -- * Construction+    SGM(..),+    makeSGM,+    -- * Deconstruction+    time,+    isEmpty,+    size,+    modelMap,+    counterMap,+    modelAt,+    -- * Learning and classification+    exponential,+    classify,+    trainAndClassify,+    train,+    trainBatch+  ) where++import           Data.Datamining.Clustering.SGM3Internal+
+ src/Data/Datamining/Clustering/SGM3Internal.hs view
@@ -0,0 +1,342 @@+------------------------------------------------------------------------+-- |+-- Module      :  Data.Datamining.Clustering.SGM3Internal+-- Copyright   :  (c) Amy de Buitléir 2012-2018+-- License     :  BSD-style+-- Maintainer  :  amy@nualeargais.ie+-- Stability   :  experimental+-- Portability :  portable+--+-- A module containing private @SGM@ internals. Most developers should+-- use @SGM@ instead. This module is subject to change without notice.+--+------------------------------------------------------------------------+{-# LANGUAGE DeriveAnyClass        #-}+{-# LANGUAGE DeriveGeneric         #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++module Data.Datamining.Clustering.SGM3Internal where++import           Prelude         hiding+    (lookup)++import           Control.DeepSeq+    (NFData)+import           Data.List+    (foldl', minimumBy, sortBy, (\\))+import qualified Data.Map.Strict as M+import           Data.Ord+    (comparing)+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 (SGM).+--   @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 SGM t x k p = SGM+  {+    -- | 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 SGM can hold.+    capacity     :: Int,+    -- | 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 SGM.+    nextIndex    :: k+  } deriving (Generic, NFData)++-- | @'makeSGM' lr n diff ms@ creates a new SGM 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+--   the SGM is not at capacity, or a less useful model can be replaced.+--   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.+makeSGM+  :: Bounded k+    => (t -> x) -> Int -> (p -> p -> x) -> (p -> x -> p -> p) -> SGM t x k p+makeSGM lr n diff ms =+  if n <= 0+    then error "max size for SGM <= 0"+    else SGM M.empty lr n diff ms minBound++-- | Returns true if the SGM has no models, false otherwise.+isEmpty :: SGM t x k p -> Bool+isEmpty = M.null . toMap++-- | Returns the number of models the SGM currently contains.+size :: SGM t x k p -> Int+size = M.size . toMap++-- | Returns a map from node ID to model.+modelMap :: SGM 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 :: SGM t x k p -> M.Map k t+counterMap = M.map snd . toMap++-- | Returns the model at a specified node.+modelAt :: Ord k => SGM t x k p -> k -> p+modelAt s k = (modelMap s) M.! k++-- | Returns the match counter for a specified node.+counterAt :: Ord k => SGM t x k p -> k -> t+counterAt s k = (counterMap s) M.! k++-- | Returns the current labels.+labels :: SGM t x k p -> [k]+labels = M.keys . toMap++-- -- | Returns the current models.+-- models :: SGM 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 :: SGM t x k p -> [t]+-- counters = map snd . M.elems . toMap++-- | The current "time" (number of times the SGM has been trained).+time :: Num t => SGM t x k p -> t+time = sum . map snd . M.elems . toMap++-- | Adds a new node to the SGM.+addNode+  :: (Num t, Enum k, Ord k)+    => p -> SGM t x k p -> SGM t x k p+addNode p s = if size s >= capacity s+                then error "SGM is full"+                else s { toMap=gm', nextIndex=succ k }+  where gm = toMap s+        k = nextIndex s+        gm' = M.insert k (p, 0) gm++-- | Increments the match counter.+incrementCounter :: (Num t, Ord k) => k -> SGM t x k p -> SGM 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)+    => SGM t x k p -> k -> p -> SGM 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)++-- | Calculates the difference between all pairs of non-identical+--   labels in the SGM.+modelDiffs :: (Eq k, Ord k) => SGM t x k p -> [((k, k), x)]+modelDiffs s = map f $ labelPairs s+  where f (k, k') = ( (k, k'),+                      difference s (s `modelAt` k) (s `modelAt` k') )++-- | Generates all pairs of non-identical labels in the SGM.+labelPairs :: Eq k => SGM t x k p -> [(k, k)]+labelPairs s = concatMap (labelPairs' s) $ labels s++-- | Pairs a node label with all labels except itself.+labelPairs' :: Eq k => SGM t x k p -> k -> [(k, k)]+labelPairs' s k = map (\k' -> (k, k')) $ labels s \\ [k]++-- | Returns the labels of the two most similar models, and the+--   difference between them.+twoMostSimilar :: (Ord x, Eq k, Ord k) => SGM t x k p -> (k, k, x)+twoMostSimilar s+  | size s < 2 = error "there aren't two models to merge"+  | otherwise = (k, k', d)+  where ((k, k'), d) = minimumBy (comparing snd) $ modelDiffs s++-- | Returns the labels of the two most similar models, and the+--   difference between them.+meanModelDiff+  :: (Fractional x, Num x, Ord x, Eq k, Ord k)+  => SGM t x k p -> x+meanModelDiff s+  | size s == 0 = 0+  | otherwise  = mean . map snd $ modelDiffs s++-- | Calculate the mean of a set of values.+-- mean :: (Eq a, Fractional a, Foldable t) => t a -> a+mean :: (Fractional a, Eq a) => [a] -> a+mean xs+  | count == 0 = error "no data"+  | otherwise = total / count+  where (total, count) = foldr f (0, 0) xs+        f x (y, n) = (y+x, n+1)++-- | Deletes the least used (least matched) model in a pair,+--   and returns its label (now available) and the updated SGM.+--   TODO: Modify the other model to make it slightly more similar to+--   the one that was deleted?+mergeModels :: (Num t, Ord t, Ord k) => SGM t x k p -> k -> k -> (k, SGM t x k p)+mergeModels s k1 k2+  | not (M.member k1 gm) = error "no such node 1"+  | not (M.member k2 gm) = error "no such node 2"+  | otherwise          = (k, s { toMap = gm' })+  where c1 = s `counterAt` k1+        c2 = s `counterAt` k2+        k = if c1 >= c2+              then k1+              else k2+        gm = toMap s+        gm' = M.adjust f k $ M.delete k gm+        f (p, _) = (p, c1 + c2)++-- | Set the model for a node.+--   Useful when merging two models and replacing one.+setModel :: (Num t, Ord k) => SGM t x k p -> k -> p -> SGM t x k p+setModel s k p+  | M.member k gm = error "node already exists"+  | otherwise     = s { toMap = gm' }+  where gm = toMap s+        gm' = M.insert k (p, 0) gm++-- | Adds a new node, making room for it by merging two existing nodes.+mergeAddModel+  :: (Num t, Ord t, Ord k) => SGM t x k p -> k -> k -> p -> SGM t x k p+mergeAddModel s k1 k2 p = s3+  where (k3, s2) = mergeModels s k1 k2+        s3 = setModel s2 k3 p++-- | @'classify' s p@ identifies the model @s@ that most closely+--   matches the pattern @p@.+--   It will not make any changes to the classifier.+--   (I.e., it will not change the models or match counts.)+--   Returns the ID of the node with the best matching model,+--   the difference between the best matching model and the pattern,+--   and the SGM labels paired with the model and the difference+--   between the input and the corresponding model.+--   The final paired list is sorted in decreasing order of similarity.+classify+  :: (Num t, Ord t, Num x, Ord x, Enum k, Ord k)+    => SGM t x k p -> p -> (k, x, M.Map k (p, x))+classify s p+  | isEmpty s = error "SGM has no models"+  | otherwise = (bmu, bmuDiff, report)+  where report+          = M.map (\p0 -> (p0, difference s p p0)) . modelMap $ s+        (bmu, bmuDiff)+          = head . sortBy matchOrder . map (\(k, (_, x)) -> (k, x))+              . M.toList $ report++-- | Order models by ascending difference from the input pattern,+--   then by creation order (label number).+matchOrder :: (Ord a, Ord b) => (a, b) -> (a, b) -> Ordering+matchOrder (a, b) (c, d) = compare (b, a) (d, c)++-- | @'trainAndClassify' s p@ identifies the model in @s@ that most+--   closely matches @p@, and updates it to be a somewhat better match.+--   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 pattern and the best matching model+--   in the original SGM (before training or adding a new model),+--   the differences between the pattern and each model in the updated+--   SGM,+--   and the updated SGM.+trainAndClassify+  :: (Num t, Ord t, Fractional x, Num x, Ord x, Enum k, Ord k)+    => SGM t x k p -> p -> (k, x, M.Map k (p, x), SGM t x k p)+trainAndClassify s p+  | size s < 2               = addModelTrainAndClassify s p+  | bmuDiff > diffThreshold+       && size s < capacity s = addModelTrainAndClassify s p+  | bmuDiff > cutoff         = (bmu4, bmuDiff, report4, s4)+  | otherwise                = (bmu, bmuDiff, report, s2)+  where diffThreshold = meanModelDiff s+        (bmu, bmuDiff, report, s2) = trainAndClassify' s p+        (k1, k2, cutoff) = twoMostSimilar s+        s3 = mergeAddModel s k1 k2 p+        (bmu4, _, report4, s4) = trainAndClassify' s3 p++-- | Internal method.+-- NOTE: This function will adjust the model and update the match+-- for the BMU.+trainAndClassify'+  :: (Num t, Ord t, Num x, Ord x, Enum k, Ord k)+    => SGM t x k p -> p -> (k, x, M.Map k (p, x), SGM t x k p)+trainAndClassify' s p = (bmu2, bmuDiff, report, s3)+  where (bmu, bmuDiff, _) = classify s p+        s2 = incrementCounter bmu s+        s3 = trainNode s2 bmu p+        (bmu2, _, report) = classify s3 p++-- | Internal method.+addModelTrainAndClassify+  :: (Num t, Ord t, Num x, Ord x, Enum k, Ord k)+    => SGM t x k p -> p -> (k, x, M.Map k (p, x), SGM t x k p)+addModelTrainAndClassify s p = (bmu, 1, report, s')+  where (bmu, _, report, s') = trainAndClassify' (addNode p s) p++-- | @'train' s p@ identifies the model in @s@ that most closely+--   matches @p@, and updates it to be a somewhat better match.+--   If necessary, it will create a new node and model.+train+  :: (Num t, Ord t, Fractional x, Num x, Ord x, Enum k, Ord k)+    => SGM t x k p -> p -> SGM t x k p+train s p = s'+  where (_, _, _, s') = trainAndClassify 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, Fractional x, Num x, Ord x, Enum k, Ord k)+    => SGM t x k p -> [p] -> SGM t x k p+trainBatch = foldl' train+
src/Data/Datamining/Clustering/SGMInternal.hs view
@@ -11,19 +11,23 @@ -- use @SGM@ instead. This module is subject to change without notice. -- -------------------------------------------------------------------------{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances,-    MultiParamTypeClasses, DeriveAnyClass, DeriveGeneric,-    UndecidableInstances #-}+{-# LANGUAGE DeriveAnyClass        #-}+{-# LANGUAGE DeriveGeneric         #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}  module Data.Datamining.Clustering.SGMInternal where -import Prelude hiding (lookup)+import           Prelude         hiding (lookup) -import Control.DeepSeq (NFData)-import Data.List (minimumBy, sortBy, foldl')-import Data.Ord (comparing)+import           Control.DeepSeq (NFData)+import           Data.List       (foldl', minimumBy, sortBy) import qualified Data.Map.Strict as M-import GHC.Generics (Generic)+import           Data.Ord        (comparing)+import           GHC.Generics    (Generic)  -- | A typical learning function for classifiers. --   @'exponential' r0 d t@ returns the learning rate at time @t@.@@ -47,7 +51,7 @@ data SGM t x k p = SGM   {     -- | Maps patterns and match counts to nodes.-    toMap :: M.Map k (p, t),+    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.@@ -56,9 +60,9 @@     --   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,+    learningRate  :: t -> x,     -- | The maximum number of models this SGM can hold.-    maxSize :: Int,+    maxSize       :: Int,     -- | The threshold that triggers creation of a new model.     diffThreshold :: x,     -- | Delete existing models to make room for new ones? The least@@ -68,7 +72,7 @@     --   /non-negative/ number representing how different the patterns     --   are.     --   A result of @0@ indicates that the patterns are identical.-    difference :: p -> p -> x,+    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@@@ -78,9 +82,9 @@     --   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,+    makeSimilar   :: p -> x -> p -> p,     -- | Index for the next node to add to the SGM.-    nextIndex :: k+    nextIndex     :: k   } deriving (Generic, NFData)  -- | @'makeSGM' lr n dt diff ms@ creates a new SGM that does not (yet)@@ -162,7 +166,7 @@                 then M.delete k gm                 else error "no such node" --- | Increment the match counter.+-- | Increments the match counter. incrementCounter :: (Num t, Ord k) => k -> SGM t x k p -> SGM t x k p incrementCounter k s = s { toMap=gm' }   where gm = toMap s
src/Data/Datamining/Clustering/SOM.hs view
@@ -18,7 +18,7 @@ -- the underlying structure of some data. A tutorial is available at -- <https://github.com/mhwombat/som/wiki>. ----- NOTES: +-- NOTES: -- -- * Version 5.0 fixed a bug in the @`decayingGaussian`@ function. If --   you use @`defaultSOM`@ (which uses this function), your SOM@@ -32,7 +32,7 @@ -- -- References: ----- * Kohonen, T. (1982). Self-organized formation of topologically +-- * Kohonen, T. (1982). Self-organized formation of topologically --   correct feature maps. Biological Cybernetics, 43 (1), 59–69. ------------------------------------------------------------------------ @@ -50,5 +50,5 @@     trainNeighbourhood   ) where -import Data.Datamining.Clustering.SOMInternal+import           Data.Datamining.Clustering.SOMInternal
src/Data/Datamining/Clustering/SOMInternal.hs view
@@ -11,22 +11,26 @@ -- use @SOM@ instead. This module is subject to change without notice. -- -------------------------------------------------------------------------{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances,-    MultiParamTypeClasses, DeriveAnyClass, DeriveGeneric,-    UndecidableInstances #-}+{-# LANGUAGE DeriveAnyClass        #-}+{-# LANGUAGE DeriveGeneric         #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}  module Data.Datamining.Clustering.SOMInternal where -import Prelude hiding (lookup)+import           Prelude                               hiding (lookup) -import Control.DeepSeq (NFData)-import qualified Data.Foldable as F (Foldable, foldr)-import Data.List (foldl', minimumBy)-import Data.Ord (comparing)-import qualified Math.Geometry.Grid as G (Grid(..))-import qualified Math.Geometry.GridMap as GM (GridMap(..))-import Data.Datamining.Clustering.Classifier(Classifier(..))-import GHC.Generics (Generic)+import           Control.DeepSeq                       (NFData)+import           Data.Datamining.Clustering.Classifier (Classifier (..))+import qualified Data.Foldable                         as F (Foldable, foldr)+import           Data.List                             (foldl', minimumBy)+import           Data.Ord                              (comparing)+import           GHC.Generics                          (Generic)+import qualified Math.Geometry.Grid                    as G (Grid (..))+import qualified Math.Geometry.GridMap                 as GM (GridMap (..))  -- | A typical learning function for classifiers. --   @'decayingGaussian' r0 rf w0 wf tf@ returns a bell curve-shaped@@ -80,7 +84,7 @@   {     -- | Maps patterns to tiles in a regular grid.     --   In the context of a SOM, the tiles are called "nodes"-    gridMap :: gm p,+    gridMap      :: gm p,     -- | A function which determines the how quickly the SOM learns.     --   For example, if the function is @f@, then @f t d@ returns the     --   learning rate for a node.@@ -98,7 +102,7 @@     --   /non-negative/ number representing how different the patterns     --   are.     --   A result of @0@ indicates that the patterns are identical.-    difference :: p -> p -> x,+    difference   :: p -> p -> x,     -- | A function which updates models.     --   If this function is @f@, then @f target amount pattern@ returns     --   a modified copy of @pattern@ that is more similar to @target@@@ -108,12 +112,12 @@     --   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,+    makeSimilar  :: p -> x -> p -> p,     -- | A counter used as a "time" parameter.     --   If you create the SOM with a counter value @0@, and don't     --   directly modify it, then the counter will represent the number     --   of patterns that this SOM has classified.-    counter :: t+    counter      :: t   } deriving (Generic, NFData)  instance (F.Foldable gm) => F.Foldable (SOM t d gm x k) where
src/Data/Datamining/Pattern.hs view
@@ -10,7 +10,9 @@ -- Tools for identifying patterns in data. -- -------------------------------------------------------------------------{-# LANGUAGE TypeFamilies, FlexibleContexts, MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies          #-} module Data.Datamining.Pattern   (     -- * Numbers as patterns@@ -31,7 +33,7 @@     scaleAll   ) where -import Data.List (foldl')+import           Data.List (foldl')  -- -- Using numbers as patterns.@@ -97,8 +99,8 @@   | otherwise = avpl ts r xs  avpl :: (Num a, Ord a, Eq a) => [a] -> a -> [a] -> [a]-avpl _ _ [] = []-avpl [] _ x = x+avpl _ _ []          = []+avpl [] _ x          = x avpl (t:ts) r (x:xs) = (adjustNum' r t x) : (avpl ts r xs)  -- | A vector that has been normalised, i.e., the magnitude of the
test/Data/Datamining/Clustering/DSOMQC.hs view
@@ -10,11 +10,11 @@ -- Tests -- ------------------------------------------------------------------------+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies          #-} {-# OPTIONS_GHC -fno-warn-type-defaults -fno-warn-orphans #-}  module Data.Datamining.Clustering.DSOMQC@@ -22,27 +22,37 @@     test   ) where -import Data.Datamining.Pattern (euclideanDistanceSquared,-  magnitudeSquared, adjustNum, absDifference)-import Data.Datamining.Clustering.Classifier(classify,-  classifyAndTrain, differences, diffAndTrain, models,-  numModels, train, trainBatch)-import Data.Datamining.Clustering.DSOMInternal+import           Data.Datamining.Clustering.Classifier   (classify,+                                                          classifyAndTrain,+                                                          diffAndTrain,+                                                          differences, models,+                                                          numModels, train,+                                                          trainBatch)+import           Data.Datamining.Clustering.DSOMInternal+import           Data.Datamining.Pattern                 (absDifference,+                                                          adjustNum,+                                                          euclideanDistanceSquared,+                                                          magnitudeSquared)  #if MIN_VERSION_base(4,8,0) #else-import Control.Applicative+import           Control.Applicative #endif -import Data.List (sort)-import Math.Geometry.Grid (size)-import Math.Geometry.Grid.Hexagonal (HexHexGrid, hexHexGrid)-import Math.Geometry.GridMap ((!), elems)-import Math.Geometry.GridMap.Lazy (LGridMap, lazyGridMap)-import Test.Framework as TF (Test, testGroup)-import Test.Framework.Providers.QuickCheck2 (testProperty)-import Test.QuickCheck ((==>), Gen, Arbitrary, arbitrary, choose,-  Property, property, sized, suchThat, vectorOf, shrink)+import           Data.List                               (sort)+import           Math.Geometry.Grid                      (size)+import           Math.Geometry.Grid.Hexagonal            (HexHexGrid,+                                                          hexHexGrid)+import           Math.Geometry.GridMap                   (elems, (!))+import           Math.Geometry.GridMap.Lazy              (LGridMap, lazyGridMap)+import           Test.Framework                          as TF (Test, testGroup)+import           Test.Framework.Providers.QuickCheck2    (testProperty)+import           Test.QuickCheck                         (Arbitrary, Gen,+                                                          Property, arbitrary,+                                                          choose, property,+                                                          shrink, sized,+                                                          suchThat, vectorOf,+                                                          (==>))  positive :: (Num a, Ord a, Arbitrary a) => Gen a positive = arbitrary `suchThat` (> 0)@@ -109,16 +119,16 @@ data DSOMTestData   = DSOMTestData     {-      som1 :: DSOM (LGridMap HexHexGrid) Double (Int, Int) TestPattern,-      params1 :: RougierArgs,+      som1         :: DSOM (LGridMap HexHexGrid) Double (Int, Int) TestPattern,+      params1      :: RougierArgs,       trainingSet1 :: [TestPattern]     }  instance Show DSOMTestData where   show s = "buildDSOMTestData " ++ show (size . gridMap . som1 $ s)     ++ " " ++ show (elems . gridMap . som1 $ s)-    ++ " (" ++ show (params1 s) -    ++ ") " ++ show (trainingSet1 s) +    ++ " (" ++ show (params1 s)+    ++ ") " ++ show (trainingSet1 s)  buildDSOMTestData   :: Int -> [TestPattern] -> RougierArgs -> [TestPattern] -> DSOMTestData@@ -210,16 +220,16 @@ data SpecialDSOMTestData   = SpecialDSOMTestData     {-      som2 :: DSOM (LGridMap HexHexGrid) Double (Int, Int) TestPattern,-      params2 :: Double,+      som2         :: DSOM (LGridMap HexHexGrid) Double (Int, Int) TestPattern,+      params2      :: Double,       trainingSet2 :: [TestPattern]     }  instance Show SpecialDSOMTestData where   show s = "buildDSOMTestData " ++ show (size . gridMap . som2 $ s)     ++ " " ++ show (elems . gridMap . som2 $ s)-    ++ " (" ++ show (params2 s) -    ++ ") " ++ show (trainingSet2 s) +    ++ " (" ++ show (params2 s)+    ++ ") " ++ show (trainingSet2 s)  stepFunction :: Double -> Double -> Double -> Double -> Double stepFunction r _ _ d = if d == 0 then r else 0.0
test/Data/Datamining/Clustering/SGM2QC.hs view
@@ -1,6 +1,6 @@ ------------------------------------------------------------------------ -- |--- Module      :  Data.Datamining.Clustering.SGMQC+-- Module      :  Data.Datamining.Clustering.SGM2QC -- Copyright   :  (c) Amy de Buitléir 2012-2018 -- License     :  BSD-style -- Maintainer  :  amy@nualeargais.ie@@ -10,8 +10,10 @@ -- Tests -- -------------------------------------------------------------------------{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleInstances,-    FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies          #-} {-# OPTIONS_GHC -fno-warn-type-defaults -fno-warn-orphans #-}  module Data.Datamining.Clustering.SGM2QC@@ -19,19 +21,24 @@     test   ) where -import Control.DeepSeq (deepseq)-import Data.Datamining.Pattern (adjustNum, absDifference)-import Data.Datamining.Clustering.SGM2Internal-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)+import           Control.DeepSeq                         (deepseq)+import           Data.Datamining.Clustering.SGM2Internal+import           Data.Datamining.Pattern                 (absDifference,+                                                          adjustNum)+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                         (Arbitrary, Gen,+                                                          Positive, Property,+                                                          arbitrary, choose,+                                                          getPositive, property,+                                                          shrink, sized,+                                                          suchThat, vectorOf,+                                                          (==>))  newtype UnitInterval a = UnitInterval {getUnitInterval :: a}  deriving ( Eq, Ord, Show, Read)
+ test/Data/Datamining/Clustering/SGM3QC.hs view
@@ -0,0 +1,235 @@+------------------------------------------------------------------------+-- |+-- Module      :  Data.Datamining.Clustering.SGM3QC+-- Copyright   :  (c) Amy de Buitléir 2012-2018+-- License     :  BSD-style+-- Maintainer  :  amy@nualeargais.ie+-- Stability   :  experimental+-- Portability :  portable+--+-- Tests+--+------------------------------------------------------------------------+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies          #-}+{-# OPTIONS_GHC -fno-warn-type-defaults -fno-warn-orphans #-}++module Data.Datamining.Clustering.SGM3QC+  (+    test+  ) where++import           Control.DeepSeq+    (deepseq)+import           Data.Datamining.Clustering.SGM2Internal+import           Data.Datamining.Pattern+    (absDifference, adjustNum)+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+    ( Arbitrary+    , Gen+    , Positive+    , Property+    , arbitrary+    , choose+    , getPositive+    , property+    , shrink+    , sized+    , suchThat+    , vectorOf+    , (==>)+    )++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 TestSGM = TestSGM (SGM Int Double Word16 Double) String++instance Show TestSGM where+  show (TestSGM _ desc) = desc++buildTestSGM+  :: Double -> Double -> Int -> [Double] -> TestSGM+buildTestSGM r0 d maxSz ps = TestSGM s' desc+  where lrf = exponential r0 d+        s = makeSGM lrf maxSz absDifference adjustNum+        desc = "buildTestSGM " ++ show r0 ++ " " ++ show d+                 ++ " " ++ show maxSz+                 ++ " " ++ show ps+        s' = trainBatch s ps++sizedTestSGM :: Int -> Gen TestSGM+sizedTestSGM n = do+  maxSz <- choose (1, min (n+1) 1023)+  let numPatterns = n+  r0 <- choose (0, 1)+  d <- positive+  ps <- vectorOf numPatterns arbitrary+  return $ buildTestSGM r0 d maxSz ps++instance Arbitrary TestSGM where+  arbitrary = sized sizedTestSGM++prop_classify_chooses_best_fit :: TestSGM -> Double -> Property+prop_classify_chooses_best_fit (TestSGM s _) x+  = not (isEmpty s) ==> property $ bmu == bmu2+  where (bmu, _, report) = classify s x+        bmu2 = fst (minimumBy (comparing f) . M.toList $ report)+        f (_, (_, d)) = d++prop_trainAndClassify_chooses_best_fit :: TestSGM -> Double -> Property+prop_trainAndClassify_chooses_best_fit (TestSGM s _) x+  = property $ bmu == bmu2+  where (bmu, _, report, _) = trainAndClassify s x+        bmu2 = fst (minimumBy (comparing f) . M.toList $ report)+        f (_, (_, d)) = d++prop_classify_never_creates_model :: TestSGM -> Double -> Property+prop_classify_never_creates_model (TestSGM s _) x+  = not (isEmpty s) ==> bmu `elem` (labels s)+  where (bmu, _, _) = classify s x++prop_classify_never_causes_error_unless_som_empty+  :: TestSGM -> Double -> Property+prop_classify_never_causes_error_unless_som_empty (TestSGM s _) p+  = not (isEmpty s) ==> property $ deepseq x True+  where x = classify s p++prop_trainNode_reduces_diff :: TestSGM -> Double -> Property+prop_trainNode_reduces_diff (TestSGM s _) x = not (isEmpty s) ==>+  diffAfter < diffBefore || diffBefore == 0+                         || learningRate s (time s) < 1e-10+  where (bmu, diffBefore, _) = classify s x+        s2 = trainNode s bmu x+        (_, diffAfter, _) = classify s2 x++prop_training_reduces_diff :: TestSGM -> Double -> Property+prop_training_reduces_diff (TestSGM s _) x = not (isEmpty s) ==>+  diffAfter < diffBefore || diffBefore == 0+                         || learningRate s (time s) < 1e-10+  where (_, diffBefore, _) = classify s x+        s2 = train s x+        (_, diffAfter, _) = classify s2 x++-- TODO prop: map will never exceed capacity++prop_train_only_modifies_one_model+  :: TestSGM -> Double -> Property+prop_train_only_modifies_one_model (TestSGM s _) p+  = size s < capacity s ==> otherModelsBefore == otherModelsAfter+    where (bmu, _, _, s2) = trainAndClassify s p+          otherModelsBefore = M.delete bmu . M.map fst . toMap $ s+          otherModelsAfter = M.delete bmu . M.map fst . toMap $ s2++prop_train_increments_counter :: TestSGM -> Double -> Property+prop_train_increments_counter (TestSGM s _) x+  = size s < capacity s ==> countAfter == countBefore + 1+  -- We have to check if the SGM 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 :: TestSGM -> [Double] -> Property+prop_batch_training_works (TestSGM s _) ps+  -- = capacity s > length ps+  --   ==> classifications == (concat . replicate 5) firstSet+  = property $ classifications == (concat . replicate 5) firstSet+  where trainingSet = (concat . replicate 5) ps+        sRightSize = if capacity s >= length ps+          then s+          else s { capacity=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 :: TestSGM -> Double -> Property+prop_classification_is_consistent (TestSGM s _) x+  = property $ bmu == bmu'+  where (bmu, _, _, s2) = trainAndClassify s x+        (bmu', _, _) = classify s2 x++prop_classification_stabilises :: TestSGM -> [Double] -> Property+prop_classification_stabilises (TestSGM s _)  ps+  = (not . null $ ps) && capacity s > length ps ==> k2 == k1+  where sStable = trainBatch s . concat . replicate 10 $ ps+        (k1, _, _, sStable2) = trainAndClassify sStable (head ps)+        sStable3 = trainBatch sStable2 ps+        (k2, _, _) = classify sStable3 (head ps)++test :: Test+test = testGroup "QuickCheck Data.Datamining.Clustering.SGM2"+  [+    testProperty "prop_Exponential_starts_at_r0"+      prop_Exponential_starts_at_r0,+    testProperty "prop_Exponential_ge_0"+      prop_Exponential_ge_0,+    testProperty "prop_classify_chooses_best_fit"+      prop_classify_chooses_best_fit,+    testProperty "prop_trainAndClassify_chooses_best_fit"+      prop_trainAndClassify_chooses_best_fit,+    testProperty "prop_classify_never_creates_model"+      prop_classify_never_creates_model,+    testProperty "prop_classify_never_causes_error_unless_som_empty"+      prop_classify_never_causes_error_unless_som_empty,+    testProperty "prop_trainNode_reduces_diff"+      prop_trainNode_reduces_diff,+    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+  ]
test/Data/Datamining/Clustering/SGMQC.hs view
@@ -10,8 +10,10 @@ -- Tests -- -------------------------------------------------------------------------{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleInstances,-    FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies          #-} {-# OPTIONS_GHC -fno-warn-type-defaults -fno-warn-orphans #-}  module Data.Datamining.Clustering.SGMQC@@ -19,19 +21,24 @@     test   ) where -import Control.DeepSeq (deepseq)-import Data.Datamining.Pattern (adjustNum, absDifference)-import Data.Datamining.Clustering.SGMInternal-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)+import           Control.DeepSeq                        (deepseq)+import           Data.Datamining.Clustering.SGMInternal+import           Data.Datamining.Pattern                (absDifference,+                                                         adjustNum)+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                        (Arbitrary, Gen,+                                                         Positive, Property,+                                                         arbitrary, choose,+                                                         getPositive, property,+                                                         shrink, sized,+                                                         suchThat, vectorOf,+                                                         (==>))  newtype UnitInterval a = UnitInterval {getUnitInterval :: a}  deriving ( Eq, Ord, Show, Read)
test/Data/Datamining/Clustering/SOMQC.hs view
@@ -10,8 +10,10 @@ -- Tests -- -------------------------------------------------------------------------{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleInstances,-    FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies          #-} {-# OPTIONS_GHC -fno-warn-type-defaults -fno-warn-orphans #-}  module Data.Datamining.Clustering.SOMQC@@ -19,23 +21,32 @@     test   ) where -import Data.Datamining.Pattern (euclideanDistanceSquared,-  magnitudeSquared, adjustNum, absDifference)-import Data.Datamining.Clustering.Classifier(classify,-  classifyAndTrain, reportAndTrain, differences, diffAndTrain, models,-  numModels, train, trainBatch)-import Data.Datamining.Clustering.SOMInternal+import           Data.Datamining.Clustering.Classifier  (classify,+                                                         classifyAndTrain,+                                                         diffAndTrain,+                                                         differences, models,+                                                         numModels,+                                                         reportAndTrain, train,+                                                         trainBatch)+import           Data.Datamining.Clustering.SOMInternal+import           Data.Datamining.Pattern                (absDifference,+                                                         adjustNum,+                                                         euclideanDistanceSquared,+                                                         magnitudeSquared) -import Data.List (sort)-import Math.Geometry.Grid (size)-import Math.Geometry.Grid.Hexagonal (HexHexGrid, hexHexGrid)-import Math.Geometry.GridMap ((!), elems)-import Math.Geometry.GridMap.Lazy (LGridMap, lazyGridMap)-import System.Random (Random)-import Test.Framework as TF (Test, testGroup)-import Test.Framework.Providers.QuickCheck2 (testProperty)-import Test.QuickCheck ((==>), Gen, Arbitrary, arbitrary, choose,-  Property, property, sized, suchThat, vectorOf)+import           Data.List                              (sort)+import           Math.Geometry.Grid                     (size)+import           Math.Geometry.Grid.Hexagonal           (HexHexGrid, hexHexGrid)+import           Math.Geometry.GridMap                  (elems, (!))+import           Math.Geometry.GridMap.Lazy             (LGridMap, lazyGridMap)+import           System.Random                          (Random)+import           Test.Framework                         as TF (Test, testGroup)+import           Test.Framework.Providers.QuickCheck2   (testProperty)+import           Test.QuickCheck                        (Arbitrary, Gen,+                                                         Property, arbitrary,+                                                         choose, property,+                                                         sized, suchThat,+                                                         vectorOf, (==>))  positive :: (Num a, Ord a, Arbitrary a) => Gen a positive = arbitrary `suchThat` (> 0)@@ -108,8 +119,8 @@ instance Show SOMTestData where   show s = "buildSOMTestData " ++ show (size . gridMap . som1 $ s)     ++ " " ++ show (elems . gridMap . som1 $ s)-    ++ " (" ++ show (params1 s) -    ++ ") " ++ show (trainingSet1 s) +    ++ " (" ++ show (params1 s)+    ++ ") " ++ show (trainingSet1 s)  buildSOMTestData   :: Int -> [Double] -> DecayingGaussianParams Double@@ -215,16 +226,16 @@ data SpecialSOMTestData   = SpecialSOMTestData     {-      som2 :: SOM Int Int (LGridMap HexHexGrid) Double (Int, Int) Double,-      params2 :: Double,+      som2         :: SOM Int Int (LGridMap HexHexGrid) Double (Int, Int) Double,+      params2      :: Double,       trainingSet2 :: [Double]     }  instance Show SpecialSOMTestData where   show s = "buildSpecialSOMTestData " ++ show (size . gridMap . som2 $ s)     ++ " " ++ show (elems . gridMap . som2 $ s)-    ++ " " ++ show (params2 s) -    ++ " " ++ show (trainingSet2 s) +    ++ " " ++ show (params2 s)+    ++ " " ++ show (trainingSet2 s)  buildSpecialSOMTestData   :: Int -> [Double] -> Double -> [Double] -> SpecialSOMTestData@@ -270,8 +281,8 @@ instance Show IncompleteSOMTestData where   show s = "buildIncompleteSOMTestData " ++ show (size . gridMap . som3 $ s)     ++ " " ++ show (elems . gridMap . som3 $ s)-    ++ " " ++ show (params3 s) -    ++ " " ++ show (trainingSet3 s) +    ++ " " ++ show (params3 s)+    ++ " " ++ show (trainingSet3 s)  buildIncompleteSOMTestData   :: Int -> [Double] -> DecayingGaussianParams Double
test/Data/Datamining/PatternQC.hs view
@@ -10,9 +10,9 @@ -- Tests -- ------------------------------------------------------------------------+{-# LANGUAGE CPP                   #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies          #-} {-# OPTIONS_GHC -fno-warn-type-defaults -fno-warn-orphans #-}  module Data.Datamining.PatternQC@@ -20,16 +20,18 @@     test   ) where -import Data.Datamining.Pattern+import           Data.Datamining.Pattern -import Test.Framework as TF (Test, testGroup)-import Test.Framework.Providers.QuickCheck2 (testProperty)-import Test.QuickCheck ((==>), Gen, Arbitrary, arbitrary, choose, -  Property, property, sized, vector)+import           Test.Framework                       as TF (Test, testGroup)+import           Test.Framework.Providers.QuickCheck2 (testProperty)+import           Test.QuickCheck                      (Arbitrary, Gen, Property,+                                                       arbitrary, choose,+                                                       property, sized, vector,+                                                       (==>))  #if MIN_VERSION_base(4,8,0) #else-import Control.Applicative+import           Control.Applicative #endif  newtype UnitInterval = FromDouble Double deriving Show@@ -39,34 +41,34 @@  prop_adjustVector_doesnt_choke_on_infinite_lists ::   [Double] -> UnitInterval -> Property-prop_adjustVector_doesnt_choke_on_infinite_lists xs (FromDouble d) = -  property $ +prop_adjustVector_doesnt_choke_on_infinite_lists xs (FromDouble d) =+  property $     length (adjustVector xs d [0,1..]) == length xs -data TwoVectorsSameLength = TwoVectorsSameLength [Double] [Double] +data TwoVectorsSameLength = TwoVectorsSameLength [Double] [Double]   deriving Show  sizedTwoVectorsSameLength :: Int -> Gen TwoVectorsSameLength-sizedTwoVectorsSameLength n = +sizedTwoVectorsSameLength n =   TwoVectorsSameLength <$> vector n <*> vector n  instance Arbitrary TwoVectorsSameLength where   arbitrary = sized sizedTwoVectorsSameLength -prop_zero_adjustment_is_no_adjustment :: +prop_zero_adjustment_is_no_adjustment ::   TwoVectorsSameLength -> Property-prop_zero_adjustment_is_no_adjustment (TwoVectorsSameLength xs ys) = +prop_zero_adjustment_is_no_adjustment (TwoVectorsSameLength xs ys) =   property $ adjustVector xs 0 ys == ys -prop_full_adjustment_gives_perfect_match :: +prop_full_adjustment_gives_perfect_match ::   TwoVectorsSameLength -> Property-prop_full_adjustment_gives_perfect_match (TwoVectorsSameLength xs ys) = +prop_full_adjustment_gives_perfect_match (TwoVectorsSameLength xs ys) =   property $ adjustVector xs 1 ys == xs -prop_adjustVector_improves_similarity :: +prop_adjustVector_improves_similarity ::   TwoVectorsSameLength -> UnitInterval -> Property-prop_adjustVector_improves_similarity -  (TwoVectorsSameLength xs ys) (FromDouble a) = +prop_adjustVector_improves_similarity+  (TwoVectorsSameLength xs ys) (FromDouble a) =     a > 0 && a < 1 && not (null xs) ==> d2 < d1       where d1 = euclideanDistanceSquared xs ys             d2 = euclideanDistanceSquared xs ys'
test/Spec.hs view
@@ -10,18 +10,27 @@ -- Tests -- -------------------------------------------------------------------------import Data.Datamining.PatternQC ( test )-import Data.Datamining.Clustering.SOMQC ( test )-import Data.Datamining.Clustering.SGMQC ( test )-import Data.Datamining.Clustering.SGM2QC ( test )-import Data.Datamining.Clustering.DSOMQC ( test )+import           Data.Datamining.Clustering.DSOMQC+    (test)+import           Data.Datamining.Clustering.SGM2QC+    (test)+import           Data.Datamining.Clustering.SGM3QC+    (test)+import           Data.Datamining.Clustering.SGMQC+    (test)+import           Data.Datamining.Clustering.SOMQC+    (test)+import           Data.Datamining.PatternQC+    (test) -import Test.Framework as TF ( defaultMain, Test )+import           Test.Framework                    as TF+    (Test, defaultMain)  tests :: [TF.Test] tests =   [     Data.Datamining.PatternQC.test,+    Data.Datamining.Clustering.SGM3QC.test,     Data.Datamining.Clustering.SGM2QC.test,     Data.Datamining.Clustering.SGMQC.test,     Data.Datamining.Clustering.SOMQC.test,