packages feed

som 10.1.8 → 10.1.11

raw patch · 21 files changed

+780/−98 lines, 21 filesdep ~basedep ~containersdep ~deepseqsetup-changed

Dependency ranges changed: base, containers, deepseq, grid

Files

+ CHANGELOG.md view
@@ -0,0 +1,32 @@+# Changelog for som++10.1.11 Simplified nix build config.++10.1.10 Added SGM6.++10.1.9 Added SGM4.+       Updated copyright year.++10.1.8 Revamped to work with Nix + cabal-install.++10.1.7 Revamped to work with Nix + Stack.++10.1.6 Removed SGM2 and SGM3; they aren't ready for use.++10.1.5 Bug fix in SGM3.++10.1.4 Modified SGM3 to work with limited range floating point types.++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.++10.0.0 Revamped to work with Stack v1.7.1.++## Unreleased changes
− ChangeLog.md 
@@ -1,25 +0,0 @@-# Changelog for som--10.1.8 Revamped to work with Nix + cabal-install.--10.1.7 Revamped to work with Nix + Stack.--10.1.6 Removed SGM2 and SGM3; they aren't ready for use.--10.1.5 Bug fix in SGM3.--10.1.4 Modified SGM3 to work with limited range floating point types.--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.--10.0.0 Revamped to work with Stack v1.7.1.--## Unreleased changes
LICENSE view
@@ -1,4 +1,4 @@-Copyright Amy de Buitléir (c) 2010-2018+Copyright (c) 2010-2021 Amy de Buitléir  All rights reserved.
− Setup.hs 
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
som.cabal view
@@ -1,63 +1,71 @@-name:                som-version:             10.1.8-synopsis:            Self-Organising Maps-description:         Please see the README on GitHub at <https://github.com/mhwombat/som#readme>-homepage:            https://github.com/mhwombat/som#readme-license:             BSD3-license-file:        LICENSE-author:              Amy de Buitléir-maintainer:          amy@nualeargais.ie-copyright:           2012-2018 Amy de Buitléir-category:            Math-bug-reports:         https://github.com/mhwombat/som/issues-build-type:          Simple+cabal-version:      2.4+name:               som+version:            10.1.11+synopsis:           Self-Organising Maps+description:+  Please see the README on GitHub at <https://github.com/mhwombat/som#readme>+homepage:           https://github.com/mhwombat/som+bug-reports:        https://github.com/mhwombat/som/issues+license:            BSD-3-Clause+license-file:       LICENSE+author:             Amy de Buitléir+maintainer:         amy@nualeargais.ie+copyright:          2012-2021 Amy de Buitléir+category:           Math extra-source-files:-    README.md-    ChangeLog.md-cabal-version:       >=1.10+  CHANGELOG.md+  README.md +source-repository head+  type:     git+  location: https://github.com/mhwombat/som++common common-stuff+  default-language: Haskell2010+ library+  import:          common-stuff+  hs-source-dirs:  src   exposed-modules:-      Data.Datamining.Clustering.Classifier-      Data.Datamining.Clustering.DSOM-      Data.Datamining.Clustering.DSOMInternal-      Data.Datamining.Clustering.SGM-      Data.Datamining.Clustering.SGMInternal-      Data.Datamining.Clustering.SOM-      Data.Datamining.Clustering.SOMInternal-      Data.Datamining.Pattern-  other-modules:-      Paths_som-  hs-source-dirs:-      src-  ghc-options: -Wall+    Data.Datamining.Clustering.Classifier+    Data.Datamining.Clustering.DSOM+    Data.Datamining.Clustering.DSOMInternal+    Data.Datamining.Clustering.SGM+    Data.Datamining.Clustering.SGM4+    Data.Datamining.Clustering.SGM4Internal+    Data.Datamining.Clustering.SGMInternal+    Data.Datamining.Clustering.SOM+    Data.Datamining.Clustering.SOMInternal+    Data.Datamining.Pattern+  other-modules:   Paths_som+  autogen-modules: Paths_som+  ghc-options:     -Wall -Wunused-packages   build-depends:-      base >=4.7 && <5-    , containers ==0.5.* || ==0.6.*-    , deepseq ==1.4.*-    , grid >=7.8.12 && <7.9-  default-language: Haskell2010+    , base        >=4.7    && <5+    , containers  >=0.5    && <0.7+    , deepseq     ^>=1.4+    , grid        ^>=7.8.15  test-suite som-test-  type: exitcode-stdio-1.0-  main-is: Spec.hs+  import:         common-stuff+  type:           exitcode-stdio-1.0+  hs-source-dirs: test+  main-is:        Spec.hs   other-modules:-      Data.Datamining.Clustering.DSOMQC-      Data.Datamining.Clustering.SGMQC-      Data.Datamining.Clustering.SOMQC-      Data.Datamining.PatternQC-      Paths_som-  hs-source-dirs:-      test-  ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall+    Data.Datamining.Clustering.DSOMQC+    Data.Datamining.Clustering.SGM4QC+    Data.Datamining.Clustering.SGMQC+    Data.Datamining.Clustering.SOMQC+    Data.Datamining.PatternQC+  ghc-options:+    -threaded -rtsopts -with-rtsopts=-N -Wall -Wunused-packages   build-depends:-      QuickCheck-    , base >=4.6 && <5+    , base     , containers     , deepseq     , grid+    , QuickCheck     , random     , som     , test-framework     , test-framework-quickcheck2-  default-language: Haskell2010
src/Data/Datamining/Clustering/Classifier.hs view
@@ -1,7 +1,7 @@ ------------------------------------------------------------------------ -- | -- Module      :  Data.Datamining.Clustering.Classifier--- Copyright   :  (c) Amy de Buitléir 2012-2018+-- Copyright   :  (c) 2012-2021 Amy de Buitléir -- License     :  BSD-style -- Maintainer  :  amy@nualeargais.ie -- Stability   :  experimental
src/Data/Datamining/Clustering/DSOM.hs view
@@ -1,7 +1,7 @@ ------------------------------------------------------------------------ -- | -- Module      :  Data.Datamining.Clustering.SOM--- Copyright   :  (c) Amy de Buitléir 2012-2018+-- Copyright   :  (c) 2012-2021 Amy de Buitléir -- License     :  BSD-style -- Maintainer  :  amy@nualeargais.ie -- Stability   :  experimental
src/Data/Datamining/Clustering/DSOMInternal.hs view
@@ -1,7 +1,7 @@ ------------------------------------------------------------------------ -- | -- Module      :  Data.Datamining.Clustering.DSOMInternal--- Copyright   :  (c) Amy de Buitléir 2012-2018+-- Copyright   :  (c) 2012-2021 Amy de Buitléir -- License     :  BSD-style -- Maintainer  :  amy@nualeargais.ie -- Stability   :  experimental
src/Data/Datamining/Clustering/SGM.hs view
@@ -1,7 +1,7 @@ ------------------------------------------------------------------------ -- | -- Module      :  Data.Datamining.Clustering.SGM--- Copyright   :  (c) Amy de Buitléir 2012-2018+-- Copyright   :  (c) 2012-2021 Amy de Buitléir -- License     :  BSD-style -- Maintainer  :  amy@nualeargais.ie -- Stability   :  experimental
+ src/Data/Datamining/Clustering/SGM4.hs view
@@ -0,0 +1,75 @@+------------------------------------------------------------------------+-- |+-- Module      :  Data.Datamining.Clustering.SGM4+-- Copyright   :  (c) 2012-2021 Amy de Buitléir+-- 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.SGM4+  (+    -- * Construction+    SGM(..),+    makeSGM,+    -- * Deconstruction+    time,+    isEmpty,+    size,+    modelMap,+    counterMap,+    modelAt,+    -- * Learning and classification+    exponential,+    classify,+    trainAndClassify,+    train,+    trainBatch,+    imprint,+    imprintBatch,+    -- * Other+    filter+  ) where++import           Data.Datamining.Clustering.SGM4Internal+import           Prelude                                 hiding (filter)+
+ src/Data/Datamining/Clustering/SGM4Internal.hs view
@@ -0,0 +1,358 @@+------------------------------------------------------------------------+-- |+-- Module      :  Data.Datamining.Clustering.SGM4Internal+-- Copyright   :  (c) 2012-2021 Amy de Buitléir+-- 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.SGM4Internal where++import           Prelude         hiding (filter, lookup)++import           Control.DeepSeq (NFData)+import           Data.List       (foldl', minimumBy, sortBy, (\\))+import qualified Data.Map.Strict as M+import           Data.Ord        (comparing)+-- import           Data.Ratio      ((%))+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 x, Integral t) => x -> x -> t -> x+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++-- | 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, Bounded k, Enum k, Ord k)+    => SGM t x k p -> p -> SGM t x k p+addNode s p = addNodeAt s (nextIndex s) p++addNodeAt+  :: (Num t, Bounded k, Enum k, Ord k)+    => SGM t x k p -> k -> p -> SGM t x k p+addNodeAt s k p+  | atCapacity s   = error "SGM is full"+  | s `hasLabel` k = error "label already exists"+  | otherwise      = s { toMap=gm', nextIndex=kNext }+  where gm = toMap s+        gm' = M.insert k (p, 0) gm+        -- kNext = succ . maximum . M.keys $ gm'+        allPossibleIndices = enumFromTo minBound maxBound+        usedIndices = M.keys gm'+        availableIndices = allPossibleIndices \\ usedIndices+        kNext = head availableIndices++-- | 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' | M.member k gm = M.adjust inc k gm+            | otherwise     = 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)++hasLabel :: Ord k => SGM t x k p -> k -> Bool+hasLabel s k = M.member k . toMap $ s++imprint+  :: (Num t, Ord t, Fractional x, Num x, Ord x,+     Bounded k, Enum k, Ord k)+  => SGM t x k p -> k -> p -> SGM t x k p+imprint s k p+  | s `hasLabel` k = trainNode s k p+  | atCapacity s   = train s p+  | otherwise      = addNodeAt s k p++imprintBatch+  :: (Num t, Ord t, Fractional x, Num x, Ord x,+     Bounded k, Enum k, Ord k)+  => SGM t x k p -> [(k, p)] -> SGM t x k p+imprintBatch = foldl' imprintOne+  where imprintOne s' (k, p) = imprint s' k p++-- | 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', x)+  where ((k, k'), x) = minimumBy (comparing snd) $ modelDiffs s++-- | 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          = (kDelete, s { toMap = gm' })+  where c1 = s `counterAt` k1+        c2 = s `counterAt` k2+        (kKeep, kDelete) | c1 >= c2   = (k1, k2)+                         | otherwise = (k2, k1)+        gm = toMap s+        gm' = M.adjust f kKeep $ M.delete kDelete gm+        f (p, _) = (p, c1 + c2)++-- | Returns True if the SOM is full; returns False if it can add one+--   or more models.+atCapacity :: SGM t x k p -> Bool+atCapacity s = size s == capacity s++-- | @'consolidate' s@ finds the two most similar models, and combines+--   them. This can be used to free up more space for learning. It+--   returns the index of the newly free node, and the updated SGM.+consolidate :: (Num t, Ord t, Ord x, Ord k) => SGM t x k p -> (k, SGM t x k p)+consolidate s = (k3, s2)+  where (k1, k2, _) = twoMostSimilar s+        (k3, s2) = mergeModels s k1 k2++consolidateAndAdd+  :: (Num t, Ord t, Ord x, Bounded k, Enum k, Ord k)+  => SGM t x k p -> p -> SGM t x k p+consolidateAndAdd s p = addNode s' p+  where (_, s') = consolidate s++-- | 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++-- | @'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,+     Bounded k, 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 = trainAndClassify' s' p+  where s' | size s > 1 && bmuDiff == 0        = s+           | atCapacity s && capacity s == 1   = s+           | size s < 2                      = addNode s p+           | atCapacity s && bmuDiff >= cutoff = consolidateAndAdd s p+           | atCapacity s                    = s+           | otherwise                       = addNode s p+        (_, bmuDiff, _) = classify s p+        (_, _, cutoff) = twoMostSimilar s++-- | 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++-- | @'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,+     Bounded k, 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,+     Bounded k, Enum k, Ord k)+    => SGM t x k p -> [p] -> SGM t x k p+trainBatch = foldl' train++-- | Same as @'size'@.+numModels :: SGM t x k p -> Int+numModels = size++-- | Same as @'capacity'@.+maxSize :: SGM t x k p -> Int+maxSize = capacity++-- | Returns a copy of the SOM containing only models that satisfy the+--   predicate.+filter :: (p -> Bool) -> SGM t x k p -> SGM t x k p+filter f s = s { toMap = pm' }+  where pm = toMap s+        pm' = M.filter (\(p, _) -> f p) pm
src/Data/Datamining/Clustering/SGMInternal.hs view
@@ -1,7 +1,7 @@ ------------------------------------------------------------------------ -- | -- Module      :  Data.Datamining.Clustering.SGMInternal--- Copyright   :  (c) Amy de Buitléir 2012-2018+-- Copyright   :  (c) 2012-2021 Amy de Buitléir -- License     :  BSD-style -- Maintainer  :  amy@nualeargais.ie -- Stability   :  experimental
src/Data/Datamining/Clustering/SOM.hs view
@@ -1,7 +1,7 @@ ------------------------------------------------------------------------ -- | -- Module      :  Data.Datamining.Clustering.SOM--- Copyright   :  (c) Amy de Buitléir 2012-2018+-- Copyright   :  (c) 2012-2021 Amy de Buitléir -- License     :  BSD-style -- Maintainer  :  amy@nualeargais.ie -- Stability   :  experimental
src/Data/Datamining/Clustering/SOMInternal.hs view
@@ -1,7 +1,7 @@ ------------------------------------------------------------------------ -- | -- Module      :  Data.Datamining.Clustering.SOMInternal--- Copyright   :  (c) Amy de Buitléir 2012-2018+-- Copyright   :  (c) 2012-2021 Amy de Buitléir -- License     :  BSD-style -- Maintainer  :  amy@nualeargais.ie -- Stability   :  experimental
src/Data/Datamining/Pattern.hs view
@@ -1,7 +1,7 @@ ------------------------------------------------------------------------ -- | -- Module      :  Data.Datamining.Pattern--- Copyright   :  (c) Amy de Buitléir 2012-2018+-- Copyright   :  (c) 2012-2021 Amy de Buitléir -- License     :  BSD-style -- Maintainer  :  amy@nualeargais.ie -- Stability   :  experimental
test/Data/Datamining/Clustering/DSOMQC.hs view
@@ -1,7 +1,7 @@ ------------------------------------------------------------------------ -- | -- Module      :  Data.Datamining.Clustering.DSOMQC--- Copyright   :  (c) Amy de Buitléir 2012-2018+-- Copyright   :  (c) 2012-2021 Amy de Buitléir -- License     :  BSD-style -- Maintainer  :  amy@nualeargais.ie -- Stability   :  experimental
+ test/Data/Datamining/Clustering/SGM4QC.hs view
@@ -0,0 +1,239 @@+------------------------------------------------------------------------+-- |+-- Module      :  Data.Datamining.Clustering.SGM4QC+-- Copyright   :  (c) 2012-2021 Amy de Buitléir+-- 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.SGM4QC+  (+    test+  ) where++import           Control.DeepSeq                         (deepseq)+import           Data.Datamining.Clustering.SGM4Internal+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] -> [(Word16, Double)] -> TestSGM+buildTestSGM r0 d maxSz ps kps = TestSGM s'' desc+  where lrf = exponential r0 d+        s = makeSGM lrf maxSz absDifference adjustNum+        desc = "buildTestSGM " ++ show r0 ++ " " ++ show d+                 ++ " " ++ show maxSz+                 ++ " " ++ show ps+                 ++ " " ++ show kps+        s' = trainBatch s ps+        s'' = imprintBatch s' kps++sizedTestSGM :: Int -> Gen TestSGM+sizedTestSGM n = do+  maxSz <- choose (1, min (n+1) 1023)+  numTrainingPatterns <- choose (0, n)+  let numImprintPatterns = n - numTrainingPatterns+  r0 <- choose (0, 1)+  d <- positive+  ps <- vectorOf numTrainingPatterns arbitrary+  kps <- vectorOf numImprintPatterns arbitrary+  return $ buildTestSGM r0 d maxSz ps kps++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 (classify s p) True++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_addNode_never_causes_error :: TestSGM -> Double -> Property+prop_addNode_never_causes_error (TestSGM s _) p+  = size s < capacity s ==> deepseq (addNode s p) True++prop_train_never_causes_error :: TestSGM -> Double -> Property+prop_train_never_causes_error (TestSGM s _) p+  = property $ deepseq (train s p) True++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 n) firstSet+  where trainingSet = (concat . replicate n) ps+        n = 4+        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 > 1 + length ps ==> k2 == k1+  where sStable = trainBatch s . concat . replicate 8 $ ps+        (k1, _, _, sStable2) = trainAndClassify sStable (head ps)+        sStable3 = trainBatch sStable2 ps+        (k2, _, _) = classify sStable3 (head ps)++prop_imprint_never_causes_error :: TestSGM -> Word16 -> Double -> Property+prop_imprint_never_causes_error (TestSGM s _) k p+  = property $ deepseq (imprint s k p) True+++test :: Test+test = testGroup "QuickCheck Data.Datamining.Clustering.SGM4"+  [+    testProperty "prop_Exponential_starts_at_r0"+      prop_Exponential_starts_at_r0,+    testProperty "prop_Exponential_ge_0"+      prop_Exponential_ge_0,+    testProperty "prop_addNode_never_causes_error"+      prop_addNode_never_causes_error,+    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_never_causes_error"+      prop_train_never_causes_error,+    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,+    testProperty "prop_imprint_never_causes_error"+      prop_imprint_never_causes_error+  ]
test/Data/Datamining/Clustering/SGMQC.hs view
@@ -1,7 +1,7 @@ ------------------------------------------------------------------------ -- | -- Module      :  Data.Datamining.Clustering.SGMQC--- Copyright   :  (c) Amy de Buitléir 2012-2018+-- Copyright   :  (c) 2012-2021 Amy de Buitléir -- License     :  BSD-style -- Maintainer  :  amy@nualeargais.ie -- Stability   :  experimental
test/Data/Datamining/Clustering/SOMQC.hs view
@@ -1,7 +1,7 @@ ------------------------------------------------------------------------ -- | -- Module      :  Data.Datamining.Clustering.SOMQC--- Copyright   :  (c) Amy de Buitléir 2012-2018+-- Copyright   :  (c) 2012-2021 Amy de Buitléir -- License     :  BSD-style -- Maintainer  :  amy@nualeargais.ie -- Stability   :  experimental
test/Data/Datamining/PatternQC.hs view
@@ -1,7 +1,7 @@ ------------------------------------------------------------------------ -- | -- Module      :  Data.Datamining.PatternQC--- Copyright   :  (c) Amy de Buitléir 2012-2018+-- Copyright   :  (c) 2012-2021 Amy de Buitléir -- License     :  BSD-style -- Maintainer  :  amy@nualeargais.ie -- Stability   :  experimental
test/Spec.hs view
@@ -1,7 +1,7 @@ ------------------------------------------------------------------------ -- | -- Module      :  Main--- Copyright   :  (c) Amy de Buitléir 2012-2018+-- Copyright   :  (c) 2012-2021 Amy de Buitléir -- License     :  BSD-style -- Maintainer  :  amy@nualeargais.ie -- Stability   :  experimental@@ -10,23 +10,20 @@ -- Tests -- -------------------------------------------------------------------------import Data.Datamining.Clustering.DSOMQC-    (test)-import Data.Datamining.Clustering.SGMQC-    (test)-import Data.Datamining.Clustering.SOMQC-    (test)-import Data.Datamining.PatternQC-    (test)+import           Data.Datamining.Clustering.DSOMQC (test)+import           Data.Datamining.Clustering.SGM4QC (test)+import           Data.Datamining.Clustering.SGMQC  (test)+import           Data.Datamining.Clustering.SOMQC  (test)+import           Data.Datamining.PatternQC         (test) -import Test.Framework                    as TF-    (Test, defaultMain)+import           Test.Framework                    as TF (Test, defaultMain)  tests :: [TF.Test] tests =   [     Data.Datamining.PatternQC.test,     Data.Datamining.Clustering.SGMQC.test,+    Data.Datamining.Clustering.SGM4QC.test,     Data.Datamining.Clustering.SOMQC.test,     Data.Datamining.Clustering.DSOMQC.test   ]