som 8.2.3 → 9.0
raw patch · 11 files changed
+565/−1007 lines, 11 files
Files
- som.cabal +4/−7
- src/Data/Datamining/Clustering/SGM.hs +60/−0
- src/Data/Datamining/Clustering/SGMInternal.hs +258/−0
- src/Data/Datamining/Clustering/SOS.hs +0/−59
- src/Data/Datamining/Clustering/SOSInternal.hs +0/−236
- src/Data/Datamining/Clustering/SSOM.hs +0/−46
- src/Data/Datamining/Clustering/SSOMInternal.hs +0/−120
- test/Data/Datamining/Clustering/SGMQC.hs +241/−0
- test/Data/Datamining/Clustering/SOSQC.hs +0/−248
- test/Data/Datamining/Clustering/SSOMQC.hs +0/−287
- test/Main.hs +2/−4
som.cabal view
@@ -1,5 +1,5 @@ Name: som-Version: 8.2.3+Version: 9.0 Stability: experimental Synopsis: Self-Organising Maps. Description: A Kohonen Self-organising Map (SOM) maps input patterns @@ -49,10 +49,8 @@ Data.Datamining.Clustering.SOMInternal, Data.Datamining.Clustering.DSOM, Data.Datamining.Clustering.DSOMInternal,- Data.Datamining.Clustering.SSOM,- Data.Datamining.Clustering.SSOMInternal,- Data.Datamining.Clustering.SOS,- Data.Datamining.Clustering.SOSInternal,+ Data.Datamining.Clustering.SGM,+ Data.Datamining.Clustering.SGMInternal, Data.Datamining.Clustering.Classifier, Data.Datamining.Pattern @@ -73,7 +71,6 @@ main-is: Main.hs other-modules: Data.Datamining.Clustering.SOMQC, Data.Datamining.Clustering.DSOMQC,- Data.Datamining.Clustering.SSOMQC,- Data.Datamining.Clustering.SOSQC,+ Data.Datamining.Clustering.SGMQC, Data.Datamining.PatternQC
+ src/Data/Datamining/Clustering/SGM.hs view
@@ -0,0 +1,60 @@+------------------------------------------------------------------------+-- |+-- Module : Data.Datamining.Clustering.SGM+-- Copyright : (c) Amy de Buitléir 2012-2015+-- 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:+--+-- * de Buitléir, Amy, Russell, Michael and Daly, Mark. (2012). Wains:+-- A pattern-seeking artificial life species. Artificial Life, 18 (4),+-- 399-423. +-- +-- * Kohonen, T. (1982). Self-organized formation of topologically +-- correct feature maps. Biological Cybernetics, 43 (1), 59–69.+------------------------------------------------------------------------++module Data.Datamining.Clustering.SGM+ (+ -- * Construction+ SGM(..),+ makeSGM,+ -- * Deconstruction+ time,+ isEmpty,+ numModels,+ modelMap,+ counterMap,+ -- models,+ -- counters,+ -- * Learning and classification+ exponential,+ classify,+ trainAndClassify,+ train,+ trainBatch+ ) where++import Data.Datamining.Clustering.SGMInternal+
+ src/Data/Datamining/Clustering/SGMInternal.hs view
@@ -0,0 +1,258 @@+------------------------------------------------------------------------+-- |+-- Module : Data.Datamining.Clustering.SGMInternal+-- Copyright : (c) Amy de Buitléir 2012-2015+-- 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 TypeFamilies, FlexibleContexts, FlexibleInstances,+ MultiParamTypeClasses, DeriveAnyClass, DeriveGeneric #-}++module Data.Datamining.Clustering.SGMInternal where++import Prelude hiding (lookup)++import Control.DeepSeq (NFData)+import Data.List (minimumBy, foldl')+import Data.Ord (comparing)+import qualified Data.Map.Strict as M+import GHC.Generics (Generic)++-- | A typical learning function for classifiers.+-- @'exponential' r0 d t@ returns the learning rate at time @t@.+-- When @t = 0@, the learning rate is @r0@.+-- Over time the learning rate decays exponentially; the decay rate is+-- @d@.+-- Normally the parameters are chosen such that:+--+-- * 0 < r0 < 1+--+-- * 0 < d+exponential :: (Floating a, Integral t) => a -> a -> t -> a+exponential r0 d t = r0 * exp (-d*t')+ where t' = fromIntegral t++-- | A Simplified Self-Organising Map (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.+ maxSize :: Int,+ -- | The threshold that triggers creation of a new model.+ diffThreshold :: x,+ -- | Delete existing models to make room for new ones? The least+ -- useful (least frequently matched) models will be deleted first.+ allowDeletion :: Bool,+ -- | 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 dt 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+-- (1) the SGM contains no models, or+-- (2) the difference between the pattern and the closest matching+-- model exceeds the threshold @dt@.+-- It will use the function @diff@ to measure the similarity between+-- an input pattern and a model.+-- It will use the function @ms@ to adjust models as needed to make+-- them more similar to input patterns.+makeSGM+ :: Bounded k+ => (t -> x) -> Int -> x -> Bool -> (p -> p -> x)+ -> (p -> x -> p -> p) -> SGM t x k p+makeSGM lr n dt ad diff ms =+ if n <= 0+ then error "max size for SGM <= 0"+ else SGM M.empty lr n dt ad 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.+numModels :: SGM t x k p -> Int+numModels = 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 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 numModels s >= maxSize 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++-- | Removes a node from the SGM.+-- Deleted nodes are never re-used.+deleteNode :: Ord k => k -> SGM t x k p -> SGM t x k p+deleteNode k s = s { toMap=gm' }+ where gm = toMap s+ gm' = if M.member k gm+ then M.delete k gm+ else error "no such node"++incrementCounter :: (Num t, Ord k) => k -> 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)++leastUsefulNode :: Ord t => SGM t x k p -> k+leastUsefulNode s = if isEmpty s+ then error "SGM has no nodes"+ else fst . minimumBy (comparing (snd . snd))+ . M.toList . toMap $ s++deleteLeastUsefulNode :: (Ord t, Ord k) => SGM t x k p -> SGM t x k p+deleteLeastUsefulNode s = deleteNode k s+ where k = leastUsefulNode s++addModel+ :: (Num t, Ord t, Enum k, Ord k)+ => p -> SGM t x k p -> SGM t x k p+addModel p s = addNode p s'+ where s' = if numModels s >= maxSize s+ then deleteLeastUsefulNode s+ else s++-- | @'classify' s p@ identifies the model @s@ that most closely+-- matches the pattern @p@.+-- It will not make any changes to the classifier.+-- Returns the ID of the node with the best matching model,+-- the difference between the best matching model and the pattern,+-- and the differences between the input and each model in the SGM.+classify+ :: (Num t, Ord t, Num x, Ord x, Enum k, Ord k)+ => SGM t x k p -> p -> (k, x, [(k, x)])+classify s p = (bmu, bmuDiff, diffs)+ where sFull = s { maxSize = 0, allowDeletion = False } -- no changes!+ (bmu, bmuDiff, diffs, _) = classify' sFull p+ ++-- NOTE: This function may create a new model, but it does not modify+-- existing models.+classify'+ :: (Num t, Ord t, Num x, Ord x, Enum k, Ord k)+ => SGM t x k p -> p -> (k, x, [(k, x)], SGM t x k p)+classify' s p+ | isEmpty s = classify' (addModel p s) p+ | bmuDiff > diffThreshold s+ && (numModels s < maxSize s || allowDeletion s)+ = classify' (addModel p s) p+ | otherwise = (bmu, bmuDiff, diffs, s')+ where (bmu, bmuDiff) = minimumBy (comparing snd) diffs+ diffs = M.toList . M.map (difference s p) . M.map fst+ . toMap $ s+ s' = incrementCounter bmu s++-- | @'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 best matching model and the pattern,+-- the differences between the input and each model in the SGM,+-- and the updated SGM.+trainAndClassify+ :: (Num t, Ord t, Num x, Ord x, Enum k, Ord k)+ => SGM t x k p -> p -> (k, x, [(k, x)], SGM t x k p)+trainAndClassify s p = (bmu, bmuDiff, diffs, s3)+ where (bmu, bmuDiff, diffs, s2) = classify' s p+ s3 = trainNode s2 bmu 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, 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, 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/SOS.hs
@@ -1,59 +0,0 @@---------------------------------------------------------------------------- |--- Module : Data.Datamining.Clustering.SOS--- Copyright : (c) Amy de Buitléir 2012-2015--- License : BSD-style--- Maintainer : amy@nualeargais.ie--- Stability : experimental--- Portability : portable------ A Self-organising Set (SOS). An SOS maps input patterns--- onto a set, where each element in the set is a model of the input--- data. An SOS is like a Kohonen Self-organising Map (SOM), except:------ * Instead of a grid, it uses a simple set of unconnected models.--- Since the models are unconnected, only the model that best matches--- the input is ever updated. This makes it faster, however,--- topological relationships within the input data are not preserved.--- * New models are created on-the-fly when no existing model is--- similar enough to an input pattern. If the SOS is at capacity,--- the least useful model will be deleted.------ This implementation supports the use of non-numeric patterns.------ In layman's terms, a SOS can be useful when you you want to build--- a set of models on some data. A tutorial is available at--- <https://github.com/mhwombat/som/wiki>.------ References:------ * de Buitléir, Amy, Russell, Michael and Daly, Mark. (2012). Wains:--- A pattern-seeking artificial life species. Artificial Life, 18 (4),--- 399-423. --- --- * Kohonen, T. (1982). Self-organized formation of topologically --- correct feature maps. Biological Cybernetics, 43 (1), 59–69.---------------------------------------------------------------------------module Data.Datamining.Clustering.SOS- (- -- * Construction- SOS(..),- makeSOS,- -- * Deconstruction- time,- isEmpty,- numModels,- modelMap,- counterMap,- -- models,- -- counters,- -- * Learning and classification- exponential,- classify,- train,- trainBatch- ) where--import Data.Datamining.Clustering.SOSInternal-
− src/Data/Datamining/Clustering/SOSInternal.hs
@@ -1,236 +0,0 @@---------------------------------------------------------------------------- |--- Module : Data.Datamining.Clustering.SOSInternal--- Copyright : (c) Amy de Buitléir 2012-2015--- License : BSD-style--- Maintainer : amy@nualeargais.ie--- Stability : experimental--- Portability : portable------ A module containing private @SOS@ internals. Most developers should--- use @SOS@ instead. This module is subject to change without notice.-----------------------------------------------------------------------------{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances,- MultiParamTypeClasses, DeriveAnyClass, DeriveGeneric #-}--module Data.Datamining.Clustering.SOSInternal where--import Prelude hiding (lookup)--import Control.DeepSeq (NFData)-import Data.List (minimumBy, foldl')-import Data.Ord (comparing)-import qualified Data.Map.Strict as M-import GHC.Generics (Generic)---- | A typical learning function for classifiers.--- @'exponential' r0 d t@ returns the learning rate at time @t@.--- When @t = 0@, the learning rate is @r0@.--- Over time the learning rate decays exponentially; the decay rate is--- @d@.--- Normally the parameters are chosen such that:------ * 0 < r0 < 1------ * 0 < d-exponential :: (Floating a, Integral t) => a -> a -> t -> a-exponential r0 d t = r0 * exp (-d*t')- where t' = fromIntegral t---- | A Simplified Self-Organising Map (SOS).--- @t@ is the type of the counter.--- @x@ is the type of the learning rate and the difference metric.--- @k@ is the type of the model indices.--- @p@ is the type of the input patterns and models.-data SOS t x k p = SOS- {- -- | Maps patterns and match counts to nodes.- toMap :: M.Map k (p, t),- -- | A function which determines the learning rate for a node.- -- The input parameter indicates how many patterns (or pattern- -- batches) have previously been presented to the classifier.- -- Typically this is used to make the learning rate decay over- -- time.- -- The output is the learning rate for that node (the amount by- -- which the node's model should be updated to match the target).- -- The learning rate should be between zero and one.- learningRate :: t -> x,- -- | The maximum number of models this SOS can hold.- maxSize :: Int,- -- | The threshold that triggers creation of a new model.- diffThreshold :: x,- -- | Delete existing models to make room for new ones? The least- -- useful (least frequently matched) models will be deleted first.- allowDeletion :: Bool,- -- | A function which compares two patterns and returns a- -- /non-negative/ number representing how different the patterns- -- are.- -- A result of @0@ indicates that the patterns are identical.- difference :: p -> p -> x,- -- | A function which updates models.- -- For example, if this function is @f@, then- -- @f target amount pattern@ returns a modified copy of @pattern@- -- that is more similar to @target@ than @pattern@ is.- -- The magnitude of the adjustment is controlled by the @amount@- -- parameter, which should be a number between 0 and 1.- -- Larger values for @amount@ permit greater adjustments.- -- If @amount@=1, the result should be identical to the @target@.- -- If @amount@=0, the result should be the unmodified @pattern@.- makeSimilar :: p -> x -> p -> p,- -- | Index for the next node to add to the SOS.- nextIndex :: k- } deriving (Generic, NFData)---- @'makeSOS' lr n dt diff ms@ creates a new SOS that does not (yet)--- contain any models.--- It will learn at the rate determined by the learning function @lr@,--- and will be able to hold up to @n@ models.--- It will create a new model based on a pattern presented to it when--- (1) the SOS contains no models, or--- (2) the difference between the pattern and the closest matching--- model exceeds the threshold @dt@.--- It will use the function @diff@ to measure the similarity between--- an input pattern and a model.--- It will use the function @ms@ to adjust models as needed to make--- them more similar to input patterns.-makeSOS- :: Bounded k- => (t -> x) -> Int -> x -> Bool -> (p -> p -> x)- -> (p -> x -> p -> p) -> SOS t x k p-makeSOS lr n dt ad diff ms =- if n <= 0- then error "max size for SOS <= 0"- else SOS M.empty lr n dt ad diff ms minBound---- | Returns true if the SOS has no models, false otherwise.-isEmpty :: SOS t x k p -> Bool-isEmpty = M.null . toMap---- | Returns the number of models the SOS currently contains.-numModels :: SOS t x k p -> Int-numModels = M.size . toMap---- | Returns a map from node ID to model.-modelMap :: SOS t x k p -> M.Map k p-modelMap = M.map fst . toMap---- | Returns a map from node ID to counter (number of times the--- node's model has been the closest match to an input pattern).-counterMap :: SOS t x k p -> M.Map k t-counterMap = M.map snd . toMap---- | Returns the current models.-models :: SOS t x k p -> [p]-models = map fst . M.elems . toMap---- | Returns the current counters (number of times the--- node's model has been the closest match to an input pattern).-counters :: SOS t x k p -> [t]-counters = map snd . M.elems . toMap---- | The current "time" (number of times the SOS has been trained).-time :: Num t => SOS t x k p -> t-time = sum . map snd . M.elems . toMap---- | Adds a new node to the SOS.-addNode- :: (Num t, Enum k, Ord k)- => p -> SOS t x k p -> SOS t x k p-addNode p s = if numModels s >= maxSize s- then error "SOS is full"- else s { toMap=gm', nextIndex=succ k }- where gm = toMap s- k = nextIndex s- gm' = M.insert k (p, 0) gm---- | Removes a node from the SOS.--- Deleted nodes are never re-used.-deleteNode :: Ord k => k -> SOS t x k p -> SOS t x k p-deleteNode k s = s { toMap=gm' }- where gm = toMap s- gm' = if M.member k gm- then M.delete k gm- else error "no such node"--incrementCounter :: (Num t, Ord k) => k -> SOS t x k p -> SOS t x k p-incrementCounter k s = s { toMap=gm' }- where gm = toMap s- gm' = if M.member k gm- then M.adjust inc k gm- else error "no such node"- inc (p, t) = (p, t+1)---- | Trains the specified node to better match a target.--- Most users should use @'train'@, which automatically determines--- the BMU and trains it.-trainNode- :: (Num t, Ord k)- => SOS t x k p -> k -> p -> SOS t x k p-trainNode s k target = s { toMap=gm' }- where gm = toMap s- gm' = M.adjust tweakModel k gm- r = (learningRate s) (time s)- tweakModel (p, t) = (makeSimilar s target r p, t)--leastUsefulNode :: Ord t => SOS t x k p -> k-leastUsefulNode s = if isEmpty s- then error "SOS has no nodes"- else fst . minimumBy (comparing (snd . snd))- . M.toList . toMap $ s--deleteLeastUsefulNode :: (Ord t, Ord k) => SOS t x k p -> SOS t x k p-deleteLeastUsefulNode s = deleteNode k s- where k = leastUsefulNode s--addModel- :: (Num t, Ord t, Enum k, Ord k)- => p -> SOS t x k p -> SOS t x k p-addModel p s = addNode p s'- where s' = if numModels s >= maxSize s- then deleteLeastUsefulNode s- else s---- reportAddModel--- :: (Num t, Ord t, Num x, Enum k, Ord k)--- => SOS t x k p -> p -> (k, x, [(k, x)], SOS t x k p)--- reportAddModel s p = (k, 0, [(k, 0)], s'')--- where (k, s') = addModel p s--- s'' = incrementCounter k s'---- | @'classify' s p@ identifies the model @s@ that most closely--- matches the pattern @p@.--- If necessary, it will create a new node and model.--- Returns the ID of the node with the best matching model,--- the difference between the best matching model and the pattern,--- the differences between the input and each model in the SOS,--- and the (possibly updated) SOS.-classify- :: (Num t, Ord t, Num x, Ord x, Enum k, Ord k)- => SOS t x k p -> p -> (k, x, [(k, x)], SOS t x k p)-classify s p- | isEmpty s = classify (addModel p s) p- | bmuDiff > diffThreshold s- && (numModels s < maxSize s || allowDeletion s)- = classify (addModel p s) p- | otherwise = (bmu, bmuDiff, diffs, s')- where (bmu, bmuDiff) = minimumBy (comparing snd) diffs- diffs = M.toList . M.map (difference s p) . M.map fst- . toMap $ s- s' = incrementCounter bmu s---- | @'train' s p@ identifies the model in @s@ that most closely--- matches @p@, and updates it to be a somewhat better match.-train- :: (Num t, Ord t, Num x, Ord x, Enum k, Ord k)- => SOS t x k p -> p -> SOS t x k p-train s p = trainNode s' bmu p- where (bmu, _, _, s') = classify s p---- | For each pattern @p@ in @ps@, @'trainBatch' s ps@ identifies the--- model in @s@ that most closely matches @p@,--- and updates it to be a somewhat better match.-trainBatch- :: (Num t, Ord t, Num x, Ord x, Enum k, Ord k)- => SOS t x k p -> [p] -> SOS t x k p-trainBatch = foldl' train
− src/Data/Datamining/Clustering/SSOM.hs
@@ -1,46 +0,0 @@---------------------------------------------------------------------------- |--- Module : Data.Datamining.Clustering.SSOM--- Copyright : (c) Amy de Buitléir 2012-2015--- License : BSD-style--- Maintainer : amy@nualeargais.ie--- Stability : experimental--- Portability : portable------ A Simplified Self-organising Map (SSOM). An SSOM maps input patterns--- onto a set, where each element in the set is a model of the input--- data. An SSOM is like a Kohonen Self-organising Map (SOM), except--- that 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.--- This implementation supports the use of non-numeric patterns.------ In layman's terms, a SSOM can be useful when you you want to build--- a set of models on some data. A tutorial is available at--- <https://github.com/mhwombat/som/wiki>.------ References:------ * de Buitléir, Amy, Russell, Michael and Daly, Mark. (2012). Wains:--- A pattern-seeking artificial life species. Artificial Life, 18 (4),--- 399-423. --- --- * Kohonen, T. (1982). Self-organized formation of topologically --- correct feature maps. Biological Cybernetics, 43 (1), 59–69.---------------------------------------------------------------------------module Data.Datamining.Clustering.SSOM- (- -- * Construction- SSOM(..),- -- * Deconstruction- toMap,- -- * Learning functions- exponential,- -- * Advanced control- trainNode- ) where--import Data.Datamining.Clustering.SSOMInternal-
− src/Data/Datamining/Clustering/SSOMInternal.hs
@@ -1,120 +0,0 @@---------------------------------------------------------------------------- |--- Module : Data.Datamining.Clustering.SSOMInternal--- Copyright : (c) Amy de Buitléir 2012-2015--- License : BSD-style--- Maintainer : amy@nualeargais.ie--- Stability : experimental--- Portability : portable------ A module containing private @SSOM@ internals. Most developers should--- use @SSOM@ instead. This module is subject to change without notice.-----------------------------------------------------------------------------{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances,- MultiParamTypeClasses, DeriveAnyClass, DeriveGeneric #-}--module Data.Datamining.Clustering.SSOMInternal where--import Control.DeepSeq (NFData)-import Data.List (foldl', minimumBy)-import Data.Ord (comparing)-import Data.Datamining.Clustering.Classifier(Classifier(..))-import qualified Data.Map.Strict as M-import GHC.Generics (Generic)-import Prelude hiding (lookup)---- | 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 => a -> a -> a -> a-exponential r0 d t = r0 * exp (-d*t)---- | A Simplified Self-Organising Map (SSOM).--- @x@ is the type of the learning rate and the difference metric.--- @t@ is the type of the counter.--- @k@ is the type of the model indices.--- @p@ is the type of the input patterns and models.-data SSOM t x k p = SSOM- {- -- | Maps patterns to nodes.- sMap :: M.Map k p,- -- | 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,- -- | 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,- -- | A counter used as a "time" parameter.- -- If you create the SSOM with a counter value @0@, and don't- -- directly modify it, then the counter will represent the number- -- of patterns that this SSOM has classified.- counter :: t- } deriving (Generic, NFData)---- | Extracts the current models from the SSOM.--- A synonym for @'sMap'@.-toMap :: SSOM t x k p -> M.Map k p-toMap = sMap---- | 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)- => SSOM t x k p -> k -> p -> SSOM t x k p-trainNode s k target = s { sMap=gm' }- where gm = sMap s- gm' = M.adjust (makeSimilar s target r) k gm- r = (learningRate s) (counter s)--incrementCounter :: Num t => SSOM t x k p -> SSOM t x k p-incrementCounter s = s { counter=counter s + 1}--justTrain- :: (Num t, Ord k, Ord x)- => SSOM t x k p -> p -> SSOM t x k p-justTrain s p = trainNode s bmu p- where ds = M.toList . M.map (difference s p) . toMap $ s- bmu = f ds- f [] = error "SSOM has no models"- f xs = fst $ minimumBy (comparing snd) xs--instance- (Num t, Ord x, Num x, Ord k)- => Classifier (SSOM t) x k p where- toList = M.toList . toMap- -- TODO: If the # of models is fixed, make more efficient- numModels = M.size . sMap- models = M.elems . toMap- differences s p = M.toList . M.map (difference s p) $ toMap s- trainBatch s = incrementCounter . foldl' justTrain s- reportAndTrain s p = (bmu, ds, s')- where ds = differences s p- bmu = fst $ minimumBy (comparing snd) ds- s' = incrementCounter . trainNode s bmu $ p
+ test/Data/Datamining/Clustering/SGMQC.hs view
@@ -0,0 +1,241 @@+------------------------------------------------------------------------+-- |+-- Module : Data.Datamining.Clustering.SGMQC+-- Copyright : (c) Amy de Buitléir 2012-2015+-- License : BSD-style+-- Maintainer : amy@nualeargais.ie+-- Stability : experimental+-- Portability : portable+--+-- Tests+--+------------------------------------------------------------------------+{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleInstances,+ FlexibleContexts #-}+{-# OPTIONS_GHC -fno-warn-type-defaults -fno-warn-orphans #-}++module Data.Datamining.Clustering.SGMQC+ (+ test+ ) where++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)++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 -> Bool -> [Double] -> TestSGM+buildTestSGM r0 d maxSz dt ad ps = TestSGM s' desc+ where lrf = exponential r0 d+ s = makeSGM lrf maxSz dt ad absDifference adjustNum+ desc = "buildTestSGM " ++ show r0 ++ " " ++ show d+ ++ " " ++ show maxSz+ ++ " " ++ show dt+ ++ " " ++ show ad+ ++ " " ++ show ps+ s' = trainBatch s ps++sizedTestSGM :: Int -> Gen TestSGM+sizedTestSGM n = do+ maxSz <- choose (1, n+1)+ let numPatterns = n+ r0 <- choose (0, 1)+ d <- positive+ dt <- choose (0, 1)+ ad <- arbitrary+ ps <- vectorOf numPatterns arbitrary+ return $ buildTestSGM r0 d maxSz dt ad ps++instance Arbitrary TestSGM where+ arbitrary = sized sizedTestSGM++prop_classify_chooses_best_fit :: TestSGM -> Double -> Property+prop_classify_chooses_best_fit (TestSGM s _) x+ = property $ bmu == fst (minimumBy (comparing snd) diffs)+ where (bmu, _, diffs, _) = trainAndClassify s x++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_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_diff_lt_threshold_after_training :: TestSGM -> Double -> Property+prop_diff_lt_threshold_after_training (TestSGM s _) x =+ numModels s < maxSize s ==> diffAfter < diffThreshold s+ where (_, _, _, s') = trainAndClassify s x+ (_, diffAfter, _) = classify s' 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 maxSize++prop_train_only_modifies_one_model+ :: TestSGM -> Double -> Property+prop_train_only_modifies_one_model (TestSGM s _) p+ = numModels s < maxSize 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+ = numModels s < maxSize 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+ -- = maxSize s > length ps+ -- ==> classifications == (concat . replicate 5) firstSet+ = property $ classifications == (concat . replicate 5) firstSet+ where trainingSet = (concat . replicate 5) ps+ sRightSize = if maxSize s >= length ps+ then s+ else s { maxSize=length ps + 1}+ s' = trainBatch sRightSize trainingSet+ classifications = map (justBMU . classify s') trainingSet+ justBMU = \(bmu, _, _) -> bmu+ firstSet = take (length ps) classifications++-- | WARNING: This can fail when two nodes are close enough in+-- value so that after training they become identical.+prop_classification_is_consistent :: 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_results_are_consistent+ :: TestSGM -> Double -> Property+prop_classification_results_are_consistent (TestSGM s _) x+ = property $ bmu == fst (minimumBy (comparing snd) diffs)+ where (bmu, _, diffs, _) = trainAndClassify s x++prop_classification_results_are_consistent2+ :: TestSGM -> Double -> Property+prop_classification_results_are_consistent2 (TestSGM s _) x+ = property $ bmuDiff == snd (minimumBy (comparing snd) diffs)+ where (_, bmuDiff, diffs, _) = trainAndClassify s x++prop_classification_stabilises :: TestSGM -> [Double] -> Property+prop_classification_stabilises (TestSGM s _) ps+ = (not . null $ ps) && maxSize 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)++prop_models_not_deleted_unless_allowed+ :: TestSGM -> Double -> Property+prop_models_not_deleted_unless_allowed (TestSGM s _) x =+ (not . allowDeletion $ s) ==> null (labelsBefore \\ labelsAfter)+ where labelsBefore = M.keys $ modelMap s+ labelsAfter = M.keys $ modelMap s'+ (_, _, _, s') = trainAndClassify s x++prop_models_not_deleted_unless_allowed2+ :: TestSGM -> Double -> Property+prop_models_not_deleted_unless_allowed2 (TestSGM s _) x =+ (not . allowDeletion $ s) ==> null (labelsBefore \\ labelsAfter)+ where labelsBefore = M.keys $ modelMap s+ labelsAfter = M.keys $ modelMap s'+ s' = train s x++test :: Test+test = testGroup "QuickCheck Data.Datamining.Clustering.SGM"+ [+ 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_classify_never_creates_model"+ prop_classify_never_creates_model,+ testProperty "prop_trainNode_reduces_diff"+ prop_trainNode_reduces_diff,+ testProperty "prop_diff_lt_threshold_after_training"+ prop_diff_lt_threshold_after_training,+ testProperty "prop_training_reduces_diff"+ prop_training_reduces_diff,+ testProperty "prop_train_only_modifies_one_model"+ prop_train_only_modifies_one_model,+ testProperty "prop_train_increments_counter"+ prop_train_increments_counter,+ testProperty "prop_batch_training_works" prop_batch_training_works,+ testProperty "prop_classification_is_consistent"+ prop_classification_is_consistent,+ testProperty "prop_classification_results_are_consistent"+ prop_classification_results_are_consistent,+ testProperty "prop_classification_results_are_consistent2"+ prop_classification_results_are_consistent2,+ testProperty "prop_classification_stabilises"+ prop_classification_stabilises,+ testProperty "prop_models_not_deleted_unless_allowed"+ prop_models_not_deleted_unless_allowed,+ testProperty "prop_models_not_deleted_unless_allowed2"+ prop_models_not_deleted_unless_allowed2 + ]
− test/Data/Datamining/Clustering/SOSQC.hs
@@ -1,248 +0,0 @@---------------------------------------------------------------------------- |--- Module : Data.Datamining.Clustering.SOSQC--- Copyright : (c) Amy de Buitléir 2012-2015--- License : BSD-style--- Maintainer : amy@nualeargais.ie--- Stability : experimental--- Portability : portable------ Tests-----------------------------------------------------------------------------{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleInstances,- FlexibleContexts #-}-{-# OPTIONS_GHC -fno-warn-type-defaults -fno-warn-orphans #-}--module Data.Datamining.Clustering.SOSQC- (- test- ) where--import Data.Datamining.Pattern (adjustNum, absDifference)-import Data.Datamining.Clustering.SOSInternal-import Data.List ((\\), minimumBy)-import qualified Data.Map.Strict as M-import Data.Ord (comparing)-import Data.Word (Word16)-import System.Random (Random)-import Test.Framework as TF (Test, testGroup)-import Test.Framework.Providers.QuickCheck2 (testProperty)-import Test.QuickCheck ((==>), Gen, Arbitrary, Property, Positive,- arbitrary, shrink, choose, property, sized, suchThat, vectorOf,- getPositive)--newtype UnitInterval a = UnitInterval {getUnitInterval :: a}- deriving ( Eq, Ord, Show, Read)--instance Functor UnitInterval where- fmap f (UnitInterval x) = UnitInterval (f x)--instance (Num a, Ord a, Random a, Arbitrary a)- => Arbitrary (UnitInterval a) where- arbitrary = fmap UnitInterval $ choose (0,1)- shrink (UnitInterval x) =- [ UnitInterval x' | x' <- shrink x, x' >= 0, x' <= 1]--prop_Exponential_starts_at_r0- :: UnitInterval Double -> Positive Double -> Property-prop_Exponential_starts_at_r0 r0 d- = property $ abs (exponential r0' d' 0 - r0') < 0.01- where r0' = getUnitInterval r0- d' = getPositive d--prop_Exponential_ge_0- :: UnitInterval Double -> Positive Double -> Positive Int -> Property-prop_Exponential_ge_0 r0 d t = property $ exponential r0' d' t' >= 0- where r0' = getUnitInterval r0- d' = getPositive d- t' = getPositive t--positive :: (Num a, Ord a, Arbitrary a) => Gen a-positive = arbitrary `suchThat` (> 0)--data TestSOS = TestSOS (SOS Int Double Word16 Double) String--instance Show TestSOS where- show (TestSOS _ desc) = desc--buildTestSOS- :: Double -> Double -> Int -> Double -> Bool -> [Double] -> TestSOS-buildTestSOS r0 d maxSz dt ad ps = TestSOS s' desc- where lrf = exponential r0 d- s = makeSOS lrf maxSz dt ad absDifference adjustNum- desc = "buildTestSOS " ++ show r0 ++ " " ++ show d- ++ " " ++ show maxSz- ++ " " ++ show dt- ++ " " ++ show ad- ++ " " ++ show ps- s' = trainBatch s ps--sizedTestSOS :: Int -> Gen TestSOS-sizedTestSOS n = do- maxSz <- choose (1, n+1)- let numPatterns = n- r0 <- choose (0, 1)- d <- positive- dt <- choose (0, 1)- ad <- arbitrary- ps <- vectorOf numPatterns arbitrary- return $ buildTestSOS r0 d maxSz dt ad ps--instance Arbitrary TestSOS where- arbitrary = sized sizedTestSOS--prop_classify_increments_counter :: TestSOS -> Double -> Property-prop_classify_increments_counter (TestSOS s _) x- = numModels s < maxSize s ==> countAfter == countBefore + 1- -- We have to check if the SOS is full, otherwise we'll replace an- -- existing model (and its counter), which means that the total- -- count could change by an arbitrary amount.- where countBefore = time s- countAfter = time s'- (_, _, _, s') = classify s x--prop_classify_chooses_best_fit :: TestSOS -> Double -> Property-prop_classify_chooses_best_fit (TestSOS s _) x- = property $ bmu == fst (minimumBy (comparing snd) diffs)- where (bmu, _, diffs, _) = classify s x--prop_trainNode_reduces_diff :: TestSOS -> Double -> Property-prop_trainNode_reduces_diff (TestSOS s _) x = not (isEmpty s) ==>- diffAfter < diffBefore || diffBefore == 0- || learningRate s (time s) < 1e-10- where (bmu, diffBefore, _, s2) = classify s x- s3 = trainNode s2 bmu x- (_, diffAfter, _, _) = classify s3 x--prop_diff_lt_threshold_after_training :: TestSOS -> Double -> Property-prop_diff_lt_threshold_after_training (TestSOS s _) x =- numModels s < maxSize s ==> diffAfter < diffThreshold s- where s' = train s x- (_, diffAfter, _, _) = classify s' x--prop_training_reduces_diff :: TestSOS -> Double -> Property-prop_training_reduces_diff (TestSOS s _) x = not (isEmpty s) ==>- diffAfter < diffBefore || diffBefore == 0- || learningRate s (time s) < 1e-10- where (_, diffBefore, _, s2) = classify s x- s3 = train s2 x- (_, diffAfter, _, _) = classify s3 x---- TODO prop: map will never exceed maxSize--prop_train_only_modifies_one_model- :: TestSOS -> Double -> Property-prop_train_only_modifies_one_model (TestSOS s _) p- = numModels s < maxSize s ==> otherModelsBefore == otherModelsAfter- where (bmu, _, _, s2) = classify s p- s3 = train s2 p- otherModelsBefore = M.delete bmu . M.map fst . toMap $ s2- otherModelsAfter = M.delete bmu . M.map fst . toMap $ s3--prop_train_increments_counter :: TestSOS -> Double -> Property-prop_train_increments_counter (TestSOS s _) x- = numModels s < maxSize s ==> countAfter == countBefore + 1- -- We have to check if the SOS is full, otherwise we'll replace an- -- existing model (and its counter), which means that the total- -- count could change by an arbitrary amount.- where countBefore = time s- countAfter = time $ train s x---- | The training set consists of the same vectors in the same order,--- several times over. So the resulting classifications should consist--- of the same integers in the same order, over and over.-prop_batch_training_works :: TestSOS -> [Double] -> Property-prop_batch_training_works (TestSOS s _) ps- -- = maxSize s > length ps- -- ==> classifications == (concat . replicate 5) firstSet- = property $ classifications == (concat . replicate 5) firstSet- where trainingSet = (concat . replicate 5) ps- sRightSize = if maxSize s >= length ps- then s- else s { maxSize=length ps + 1}- s' = trainBatch sRightSize trainingSet- classifications = map (justBMU . classify s') trainingSet- justBMU = \(bmu, _, _, _) -> bmu- firstSet = take (length ps) classifications---- | WARNING: This can fail when two nodes are close enough in--- value so that after training they become identical.-prop_classification_is_consistent :: TestSOS -> Double -> Property-prop_classification_is_consistent (TestSOS s _) x- = property $ bmu == bmu'- where (bmu, _, _, s2) = classify s x- s3 = train s2 x- (bmu', _, _, _) = classify s3 x--prop_classification_results_are_consistent- :: TestSOS -> Double -> Property-prop_classification_results_are_consistent (TestSOS s _) x- = property $ bmu == fst (minimumBy (comparing snd) diffs)- where (bmu, _, diffs, _) = classify s x--prop_classification_results_are_consistent2- :: TestSOS -> Double -> Property-prop_classification_results_are_consistent2 (TestSOS s _) x- = property $ bmuDiff == snd (minimumBy (comparing snd) diffs)- where (_, bmuDiff, diffs, _) = classify s x--prop_classification_stabilises :: TestSOS -> [Double] -> Property-prop_classification_stabilises (TestSOS s _) ps- = (not . null $ ps) && maxSize s > length ps ==> k2 == k1- where sStable = trainBatch s . concat . replicate 10 $ ps- (k1, _, _, sStable2) = classify sStable (head ps)- sStable3 = trainBatch sStable2 ps- (k2, _, _, _) = classify sStable3 (head ps)--prop_models_not_deleted_unless_allowed- :: TestSOS -> Double -> Property-prop_models_not_deleted_unless_allowed (TestSOS s _) x =- (not . allowDeletion $ s) ==> null (labelsBefore \\ labelsAfter)- where labelsBefore = M.keys $ modelMap s- labelsAfter = M.keys $ modelMap s'- (_, _, _, s') = classify s x--prop_models_not_deleted_unless_allowed2- :: TestSOS -> Double -> Property-prop_models_not_deleted_unless_allowed2 (TestSOS s _) x =- (not . allowDeletion $ s) ==> null (labelsBefore \\ labelsAfter)- where labelsBefore = M.keys $ modelMap s- labelsAfter = M.keys $ modelMap s'- s' = train s x--test :: Test-test = testGroup "QuickCheck Data.Datamining.Clustering.SOS"- [- testProperty "prop_Exponential_starts_at_r0"- prop_Exponential_starts_at_r0,- testProperty "prop_Exponential_ge_0"- prop_Exponential_ge_0,- testProperty "prop_classify_increments_counter"- prop_classify_increments_counter,- testProperty "prop_classify_chooses_best_fit"- prop_classify_chooses_best_fit,- testProperty "prop_trainNode_reduces_diff"- prop_trainNode_reduces_diff,- testProperty "prop_diff_lt_threshold_after_training"- prop_diff_lt_threshold_after_training,- testProperty "prop_training_reduces_diff"- prop_training_reduces_diff,- testProperty "prop_train_only_modifies_one_model"- prop_train_only_modifies_one_model,- testProperty "prop_train_increments_counter"- prop_train_increments_counter,- testProperty "prop_batch_training_works" prop_batch_training_works,- testProperty "prop_classification_is_consistent"- prop_classification_is_consistent,- testProperty "prop_classification_results_are_consistent"- prop_classification_results_are_consistent,- testProperty "prop_classification_results_are_consistent2"- prop_classification_results_are_consistent2,- testProperty "prop_classification_stabilises"- prop_classification_stabilises,- testProperty "prop_models_not_deleted_unless_allowed"- prop_models_not_deleted_unless_allowed,- testProperty "prop_models_not_deleted_unless_allowed2"- prop_models_not_deleted_unless_allowed2 - ]
− test/Data/Datamining/Clustering/SSOMQC.hs
@@ -1,287 +0,0 @@---------------------------------------------------------------------------- |--- Module : Data.Datamining.Clustering.SSOMQC--- Copyright : (c) Amy de Buitléir 2012-2015--- License : BSD-style--- Maintainer : amy@nualeargais.ie--- Stability : experimental--- Portability : portable------ Tests-----------------------------------------------------------------------------{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleInstances,- FlexibleContexts #-}-{-# OPTIONS_GHC -fno-warn-type-defaults -fno-warn-orphans #-}--module Data.Datamining.Clustering.SSOMQC- (- test- ) where--import Data.Datamining.Pattern (euclideanDistanceSquared, adjustNum,- absDifference)-import Data.Datamining.Clustering.Classifier(classify,- classifyAndTrain, reportAndTrain, differences, diffAndTrain, models,- train, trainBatch, numModels)-import Data.Datamining.Clustering.SSOMInternal-import qualified Data.Map.Strict as M--import Data.List (sort)-import System.Random (Random)-import Test.Framework as TF (Test, testGroup)-import Test.Framework.Providers.QuickCheck2 (testProperty)-import Test.QuickCheck ((==>), Gen, Arbitrary, Property, Positive,- arbitrary, shrink, choose, property, sized, suchThat, vectorOf,- getPositive)--newtype UnitInterval a = UnitInterval {getUnitInterval :: a}- deriving ( Eq, Ord, Show, Read)--instance Functor UnitInterval where- fmap f (UnitInterval x) = UnitInterval (f x)--instance (Num a, Ord a, Random a, Arbitrary a)- => Arbitrary (UnitInterval a) where- arbitrary = fmap UnitInterval $ choose (0,1)- shrink (UnitInterval x) =- [ UnitInterval x' | x' <- shrink x, x' >= 0, x' <= 1]--prop_Exponential_starts_at_r0- :: UnitInterval Double -> Positive Double -> Property-prop_Exponential_starts_at_r0 r0 d- = property $ abs (exponential r0' d' 0 - r0') < 0.01- where r0' = getUnitInterval r0- d' = getPositive d--prop_Exponential_ge_0- :: UnitInterval Double -> Positive Double -> Positive Double -> 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)---- | A classifier and a training set. The training set will consist of--- @j@ vectors of equal length, where @j@ is the number of patterns--- the classifier can model. After running through the training set a--- few times, the classifier should be very accurate at identifying--- any of those @j@ vectors.-data SSOMTestData- = SSOMTestData- {- som1 :: SSOM Double Double Int Double,- learningRateDesc1 :: String,- trainingSet1 :: [Double]- }--instance Show SSOMTestData where- show s = "buildSSOMTestData " ++ show (M.elems . sMap . som1 $ s)- ++ " " ++ learningRateDesc1 s - ++ " " ++ show (trainingSet1 s) --buildSSOMTestData- :: [Double] -> Double -> Double -> [Double] -> SSOMTestData-buildSSOMTestData ps r0 d targets =- SSOMTestData s desc targets- where gm = M.fromList . zip [0..] $ ps- lrf = exponential r0 d- s = SSOM gm lrf absDifference adjustNum 0- desc = show r0 ++ " " ++ show d--sizedSSOMTestData :: Int -> Gen SSOMTestData-sizedSSOMTestData n = do- let len = n + 1- ps <- vectorOf len arbitrary- r0 <- choose (0, 1)- d <- positive- targets <- vectorOf len arbitrary- return $ buildSSOMTestData ps r0 d targets--instance Arbitrary SSOMTestData where- arbitrary = sized sizedSSOMTestData--prop_training_reduces_error :: SSOMTestData -> Property-prop_training_reduces_error (SSOMTestData s _ xs) = errBefore /= 0 ==>- errAfter < errBefore- where (bmu, s') = classifyAndTrain s x- x = head xs- errBefore = abs $ x - (toMap s M.! bmu)- errAfter = abs $ x - (toMap s' M.! bmu)---- Invoking @diffAndTrain f s p@ should give identical results to--- @(p `classify` s, train s f p)@.-prop_classifyAndTrainEquiv :: SSOMTestData -> Property-prop_classifyAndTrainEquiv (SSOMTestData s _ ps) = property $- bmu == s `classify` p && toMap s1 == toMap s2- where p = head ps- (bmu, s1) = classifyAndTrain s p- s2 = train s p---- Invoking @diffAndTrain f s p@ should give identical results to--- @(s `diff` p, train s f p)@.-prop_diffAndTrainEquiv :: SSOMTestData -> Property-prop_diffAndTrainEquiv (SSOMTestData s _ ps) = property $- diffs == s `differences` p && toMap s1 == toMap s2- where p = head ps- (diffs, s1) = diffAndTrain s p- s2 = train s p---- Invoking @trainNode s (classify s p) p@ should give--- identical results to @train s p@.-prop_trainNodeEquiv :: SSOMTestData -> Property-prop_trainNodeEquiv (SSOMTestData s _ ps) = property $- toMap s1 == toMap s2- where p = head ps- s1 = trainNode s (classify s p) p- s2 = train s p--prop_train_node_only_modifies_one_model :: Int -> SSOMTestData -> Property-prop_train_node_only_modifies_one_model n (SSOMTestData s _ ps)- = property $ as == as' && bs == bs'- where p = head ps- k = n `mod` (numModels s)- s' = trainNode s k p- (as, _:bs) = splitAt k (models s)- (as', _:bs') = splitAt k (models s')---- | 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 :: SSOMTestData -> Property-prop_batch_training_works (SSOMTestData s _ xs) = property $- classifications == (concat . replicate 5) firstSet- where trainingSet = (concat . replicate 5) xs- s' = trainBatch s trainingSet- classifications = map (classify s') trainingSet- firstSet = take (length xs) classifications---- | WARNING: This can fail when two nodes are close enough in--- value so that after training they become identical.-prop_classification_is_consistent :: SSOMTestData -> Property-prop_classification_is_consistent (SSOMTestData s _ (x:_))- = property $ bmu == bmu'- where (bmu, _, s') = reportAndTrain s x- (bmu', _, _) = reportAndTrain s' x-prop_classification_is_consistent _ = error "Should not happen"---- | Same as SSOMTestData, except that the initial models and training--- set are designed to ensure that a single node will NOT train to--- more than one pattern.-data SpecialSSOMTestData- = SpecialSSOMTestData- {- som2 :: SSOM Double Double Int Double,- learningRateDesc2 :: String,- trainingSet2 :: [Double]- }--instance Show SpecialSSOMTestData where- show s = "buildSpecialSSOMTestData "- ++ show (M.elems . sMap . som2 $ s)- ++ " " ++ learningRateDesc2 s - ++ " " ++ show (trainingSet2 s) --buildSpecialSSOMTestData- :: [Double] -> Double -> Double -> [Double] -> SpecialSSOMTestData-buildSpecialSSOMTestData ps r0 d targets =- SpecialSSOMTestData s desc targets- where gm = M.fromList . zip [0..] $ ps- lrf = exponential r0 d- s = SSOM gm lrf absDifference adjustNum 0- desc = show r0 ++ " " ++ show d--sizedSpecialSSOMTestData :: Int -> Gen SpecialSSOMTestData-sizedSpecialSSOMTestData n = do- let len = n + 1- let ps = take len [0,100..]- r0 <- choose (0, 1)- d <- positive- let targets = take len [5,105..]- return $ buildSpecialSSOMTestData ps r0 d targets--instance Arbitrary SpecialSSOMTestData where- arbitrary = sized sizedSpecialSSOMTestData---- | If we train a classifier once on a set of patterns, where the--- number of patterns in the set is equal to the number of nodes in--- the classifier, then the classifier should become a better--- representation of the training set. The initial models and training--- set are designed to ensure that a single node will NOT train to--- more than one pattern (which would render the test invalid).-prop_batch_training_works2 :: SpecialSSOMTestData -> Property-prop_batch_training_works2 (SpecialSSOMTestData s _ xs) =- errBefore /= 0 ==> errAfter < errBefore- where s' = trainBatch s xs- errBefore = euclideanDistanceSquared (sort xs) (sort (models s))- errAfter = euclideanDistanceSquared (sort xs) (sort (models s'))---- | Same as sizedSSOMTestData, except some nodes don't have a value.-data IncompleteSSOMTestData- = IncompleteSSOMTestData- {- som3 :: SSOM Double Double Int Double,- learningRateDesc3 :: String,- trainingSet3 :: [Double]- }--instance Show IncompleteSSOMTestData where- show s = "buildIncompleteSSOMTestData "- ++ show (M.elems . sMap . som3 $ s)- ++ " " ++ learningRateDesc3 s - ++ " " ++ show (trainingSet3 s) --buildIncompleteSSOMTestData- :: [Double] -> Double -> Double -> [Double] -> IncompleteSSOMTestData-buildIncompleteSSOMTestData ps r0 d targets =- IncompleteSSOMTestData s desc targets- where gm = M.fromList . zip [0..] $ ps- lrf = exponential r0 d- s = SSOM gm lrf absDifference adjustNum 0- desc = show r0 ++ " " ++ show d--sizedIncompleteSSOMTestData :: Int -> Gen IncompleteSSOMTestData-sizedIncompleteSSOMTestData n = do- let len = n + 1- ps <- vectorOf len arbitrary- r0 <- choose (0, 1)- d <- positive- targets <- vectorOf len arbitrary- return $ buildIncompleteSSOMTestData ps r0 d targets--instance Arbitrary IncompleteSSOMTestData where- arbitrary = sized sizedIncompleteSSOMTestData--prop_can_train_incomplete_SSOM :: IncompleteSSOMTestData -> Property-prop_can_train_incomplete_SSOM (IncompleteSSOMTestData s _ xs) = errBefore /= 0 ==>- errAfter < errBefore- where (bmu, s') = classifyAndTrain s x- x = head xs- errBefore = abs $ x - (toMap s M.! bmu)- errAfter = abs $ x - (toMap s' M.! bmu)--test :: Test-test = testGroup "QuickCheck Data.Datamining.Clustering.SSOM"- [- testProperty "prop_Exponential_starts_at_r0"- prop_Exponential_starts_at_r0,- testProperty "prop_Exponential_ge_0"- prop_Exponential_ge_0,- testProperty "prop_training_reduces_error"- prop_training_reduces_error,- testProperty "prop_classifyAndTrainEquiv"- prop_classifyAndTrainEquiv,- testProperty "prop_diffAndTrainEquiv" prop_diffAndTrainEquiv,- testProperty "prop_trainNodeEquiv" prop_trainNodeEquiv,- testProperty "prop_train_node_only_modifies_one_model"- prop_train_node_only_modifies_one_model,- testProperty "prop_batch_training_works" prop_batch_training_works,- testProperty "prop_classification_is_consistent"- prop_classification_is_consistent,- testProperty "prop_batch_training_works2"- prop_batch_training_works2,- testProperty "prop_can_train_incomplete_SSOM"- prop_can_train_incomplete_SSOM- ]
test/Main.hs view
@@ -15,8 +15,7 @@ import Data.Datamining.PatternQC ( test ) import Data.Datamining.Clustering.SOMQC ( test )-import Data.Datamining.Clustering.SOSQC ( test )-import Data.Datamining.Clustering.SSOMQC ( test )+import Data.Datamining.Clustering.SGMQC ( test ) import Data.Datamining.Clustering.DSOMQC ( test ) import Test.Framework as TF ( defaultMain, Test )@@ -25,8 +24,7 @@ tests = [ Data.Datamining.PatternQC.test,- Data.Datamining.Clustering.SSOMQC.test,- Data.Datamining.Clustering.SOSQC.test,+ Data.Datamining.Clustering.SGMQC.test, Data.Datamining.Clustering.SOMQC.test, Data.Datamining.Clustering.DSOMQC.test ]