diff --git a/ChangeLog.md b/ChangeLog.md
--- a/ChangeLog.md
+++ b/ChangeLog.md
@@ -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.
diff --git a/som.cabal b/som.cabal
--- a/som.cabal
+++ b/som.cabal
@@ -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
diff --git a/src/Data/Datamining/Clustering/Classifier.hs b/src/Data/Datamining/Clustering/Classifier.hs
--- a/src/Data/Datamining/Clustering/Classifier.hs
+++ b/src/Data/Datamining/Clustering/Classifier.hs
@@ -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)
diff --git a/src/Data/Datamining/Clustering/DSOM.hs b/src/Data/Datamining/Clustering/DSOM.hs
--- a/src/Data/Datamining/Clustering/DSOM.hs
+++ b/src/Data/Datamining/Clustering/DSOM.hs
@@ -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
diff --git a/src/Data/Datamining/Clustering/DSOMInternal.hs b/src/Data/Datamining/Clustering/DSOMInternal.hs
--- a/src/Data/Datamining/Clustering/DSOMInternal.hs
+++ b/src/Data/Datamining/Clustering/DSOMInternal.hs
@@ -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
diff --git a/src/Data/Datamining/Clustering/SGM.hs b/src/Data/Datamining/Clustering/SGM.hs
--- a/src/Data/Datamining/Clustering/SGM.hs
+++ b/src/Data/Datamining/Clustering/SGM.hs
@@ -68,5 +68,5 @@
     trainBatch
   ) where
 
-import Data.Datamining.Clustering.SGMInternal
+import           Data.Datamining.Clustering.SGMInternal
 
diff --git a/src/Data/Datamining/Clustering/SGM2.hs b/src/Data/Datamining/Clustering/SGM2.hs
--- a/src/Data/Datamining/Clustering/SGM2.hs
+++ b/src/Data/Datamining/Clustering/SGM2.hs
@@ -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
 
diff --git a/src/Data/Datamining/Clustering/SGM2Internal.hs b/src/Data/Datamining/Clustering/SGM2Internal.hs
--- a/src/Data/Datamining/Clustering/SGM2Internal.hs
+++ b/src/Data/Datamining/Clustering/SGM2Internal.hs
@@ -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)
diff --git a/src/Data/Datamining/Clustering/SGM3.hs b/src/Data/Datamining/Clustering/SGM3.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Datamining/Clustering/SGM3.hs
@@ -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
+
diff --git a/src/Data/Datamining/Clustering/SGM3Internal.hs b/src/Data/Datamining/Clustering/SGM3Internal.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Datamining/Clustering/SGM3Internal.hs
@@ -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
+
diff --git a/src/Data/Datamining/Clustering/SGMInternal.hs b/src/Data/Datamining/Clustering/SGMInternal.hs
--- a/src/Data/Datamining/Clustering/SGMInternal.hs
+++ b/src/Data/Datamining/Clustering/SGMInternal.hs
@@ -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
diff --git a/src/Data/Datamining/Clustering/SOM.hs b/src/Data/Datamining/Clustering/SOM.hs
--- a/src/Data/Datamining/Clustering/SOM.hs
+++ b/src/Data/Datamining/Clustering/SOM.hs
@@ -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
 
diff --git a/src/Data/Datamining/Clustering/SOMInternal.hs b/src/Data/Datamining/Clustering/SOMInternal.hs
--- a/src/Data/Datamining/Clustering/SOMInternal.hs
+++ b/src/Data/Datamining/Clustering/SOMInternal.hs
@@ -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
diff --git a/src/Data/Datamining/Pattern.hs b/src/Data/Datamining/Pattern.hs
--- a/src/Data/Datamining/Pattern.hs
+++ b/src/Data/Datamining/Pattern.hs
@@ -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
diff --git a/test/Data/Datamining/Clustering/DSOMQC.hs b/test/Data/Datamining/Clustering/DSOMQC.hs
--- a/test/Data/Datamining/Clustering/DSOMQC.hs
+++ b/test/Data/Datamining/Clustering/DSOMQC.hs
@@ -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
diff --git a/test/Data/Datamining/Clustering/SGM2QC.hs b/test/Data/Datamining/Clustering/SGM2QC.hs
--- a/test/Data/Datamining/Clustering/SGM2QC.hs
+++ b/test/Data/Datamining/Clustering/SGM2QC.hs
@@ -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)
diff --git a/test/Data/Datamining/Clustering/SGM3QC.hs b/test/Data/Datamining/Clustering/SGM3QC.hs
new file mode 100644
--- /dev/null
+++ b/test/Data/Datamining/Clustering/SGM3QC.hs
@@ -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
+  ]
diff --git a/test/Data/Datamining/Clustering/SGMQC.hs b/test/Data/Datamining/Clustering/SGMQC.hs
--- a/test/Data/Datamining/Clustering/SGMQC.hs
+++ b/test/Data/Datamining/Clustering/SGMQC.hs
@@ -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)
diff --git a/test/Data/Datamining/Clustering/SOMQC.hs b/test/Data/Datamining/Clustering/SOMQC.hs
--- a/test/Data/Datamining/Clustering/SOMQC.hs
+++ b/test/Data/Datamining/Clustering/SOMQC.hs
@@ -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
diff --git a/test/Data/Datamining/PatternQC.hs b/test/Data/Datamining/PatternQC.hs
--- a/test/Data/Datamining/PatternQC.hs
+++ b/test/Data/Datamining/PatternQC.hs
@@ -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'
diff --git a/test/Spec.hs b/test/Spec.hs
--- a/test/Spec.hs
+++ b/test/Spec.hs
@@ -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,