som 7.5.0 → 8.0.0

raw patch · 14 files changed

+607/−696 lines, 14 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• som.cabal +3/−3
• src/Data/Datamining/Clustering/Classifier.hs +12/−21
• src/Data/Datamining/Clustering/DSOM.hs +5/−8
• src/Data/Datamining/Clustering/DSOMInternal.hs +79/−107
• src/Data/Datamining/Clustering/SOM.hs +6/−4
• src/Data/Datamining/Clustering/SOMInternal.hs +76/−79
• src/Data/Datamining/Clustering/SSOM.hs +5/−5
• src/Data/Datamining/Clustering/SSOMInternal.hs +50/−45
• src/Data/Datamining/Pattern.hs +1/−57
• test/Data/Datamining/Clustering/DSOMQC.hs +105/−99
• test/Data/Datamining/Clustering/SOMQC.hs +135/−148
• test/Data/Datamining/Clustering/SSOMQC.hs +128/−118
• test/Data/Datamining/PatternQC.hs +1/−1
• test/Main.hs +1/−1

@@ -1,5 +1,5 @@ Name:              som-Version:           7.5.0+Version:           8.0.0 Stability:         experimental Synopsis:          Self-Organising Maps. Description:       A Kohonen Self-organising Map (SOM) maps input patterns @@ -18,7 +18,7 @@ Category:          Math License:           BSD3 License-file:      LICENSE-Copyright:         (c) Amy de Buitléir 2010-2014+Copyright:         (c) Amy de Buitléir 2010-2015 Homepage:          https://github.com/mhwombat/som Bug-reports:       https://github.com/mhwombat/som/issues Author:            Amy de Buitléir@@ -33,7 +33,7 @@ source-repository this   type:     git   location: https://github.com/mhwombat/som.git-  tag:      7.5.0+  tag:      8.0.0   library

@@ -1,7 +1,7 @@ ------------------------------------------------------------------------ -- | -- Module      :  Data.Datamining.Clustering.Classifier--- Copyright   :  (c) Amy de Buitléir 2012-2014+-- Copyright   :  (c) Amy de Buitléir 2012-2015 -- License     :  BSD-style -- Maintainer  :  amy@nualeargais.ie -- Stability   :  experimental@@ -16,45 +16,42 @@     Classifier(..)   ) where -import Data.Datamining.Pattern (Pattern, Metric) import Data.List (minimumBy) import Data.Ord (comparing)  -- | A machine which learns to classify input patterns.  --   Minimal complete definition: @trainBatch@, @reportAndTrain@.-class Classifier (c :: * -> * -> *) k p where+class Classifier (c :: * -> * -> * -> *) v k p where   -- | Returns a list of index\/model pairs.-  toList :: c k p -> [(k, p)]+  toList :: c v k p -> [(k, p)]    -- | Returns the number of models this classifier can learn.-  numModels :: c k p -> Int+  numModels :: c v k p -> Int    -- | Returns the current models of the classifier.-  models :: c k p -> [p]+  models :: c v k p -> [p]    -- | @'differences' c target@ returns the indices of all nodes in    --   @c@, paired with the difference between @target@ and the    --   node's model.-  differences :: (Pattern p, v ~ Metric p) => c k p -> p -> [(k, v)]+  differences :: c v k p -> p -> [(k, v)]    -- | @classify c target@ returns the index of the node in @c@    --   whose model best matches the @target@.-  classify :: (Pattern p, Ord v, v ~ Metric p) => c k p -> p -> k+  classify :: Ord v => c v k p -> p -> k   classify c p = f $ differences c p     where f [] = error "classifier has no models"           f xs = fst $ minimumBy (comparing snd) xs    -- | @'train' c target@ returns a modified copy   --   of the classifier @c@ that has partially learned the @target@.-  train-    :: (Ord v, v ~ Metric p) => -      c k p -> p -> c k p+  train :: c v k p -> p -> c v k p   train c p = c'     where (_, _, c') = reportAndTrain c p    -- | @'trainBatch' c targets@ returns a modified copy   --   of the classifier @c@ that has partially learned the @targets@.-  trainBatch :: c k p -> [p] -> c k p+  trainBatch :: c v k p -> [p] -> c v k p    -- | @'classifyAndTrain' c target@ returns a tuple containing the   --   index of the node in @c@ whose model best matches the input@@ -63,9 +60,7 @@   --   may be faster than invoking @(p `classify` c, train c p)@, but    --   they   --   should give identical results.-  classifyAndTrain -    :: (Ord v, v ~ Metric p) => -      c k p -> p -> (k, c k p)+  classifyAndTrain :: c v k p -> p -> (k, c v k p)   classifyAndTrain c p = (bmu, c')     where (bmu, _, c') = reportAndTrain c p @@ -77,9 +72,7 @@   --   Invoking @diffAndTrain c p@ may be faster than invoking   --   @(p `diff` c, train c p)@, but they should give identical   --   results.-  diffAndTrain-    :: (Ord v, v ~ Metric p) => -      c k p -> p -> ([(k, v)], c k p)+  diffAndTrain :: c v k p -> p -> ([(k, v)], c v k p)   diffAndTrain c p = (ds, c')     where (_, ds, c') = reportAndTrain c p @@ -93,8 +86,6 @@   --   Invoking @diffAndTrain c p@ may be faster than invoking   --   @(p `diff` c, train c p)@, but they should give identical   --   results.-  reportAndTrain -    :: (Ord v, v ~ Metric p) => -      c k p -> p -> (k, [(k, v)], c k p)+  reportAndTrain :: c v k p -> p -> (k, [(k, v)], c v k p)  

@@ -1,7 +1,7 @@ ------------------------------------------------------------------------ -- | -- Module      :  Data.Datamining.Clustering.SOM--- Copyright   :  (c) Amy de Buitléir 2012-2014+-- Copyright   :  (c) Amy de Buitléir 2012-2015 -- License     :  BSD-style -- Maintainer  :  amy@nualeargais.ie -- Stability   :  experimental@@ -23,16 +23,13 @@ module Data.Datamining.Clustering.DSOM   (     -- * Construction-    DSOM,-    defaultDSOM,-    customDSOM,-    rougierLearningFunction,+    DSOM(..),     -- * Deconstruction     toGridMap,+    -- * Learning functions+    rougierLearningFunction,     -- * Advanced control     trainNeighbourhood   ) where -import Data.Datamining.Clustering.DSOMInternal (DSOM, defaultDSOM,-  customDSOM, rougierLearningFunction, toGridMap, trainNeighbourhood)-+import Data.Datamining.Clustering.DSOMInternal

@@ -1,7 +1,7 @@ ------------------------------------------------------------------------ -- | -- Module      :  Data.Datamining.Clustering.DSOMInternal--- Copyright   :  (c) Amy de Buitléir 2012-2014+-- Copyright   :  (c) Amy de Buitléir 2012-2015 -- License     :  BSD-style -- Maintainer  :  amy@nualeargais.ie -- Stability   :  experimental@@ -21,7 +21,6 @@ import Data.Ord (comparing) import qualified Math.Geometry.Grid as G (Grid(..), FiniteGrid(..)) import qualified Math.Geometry.GridMap as GM (GridMap(..))-import Data.Datamining.Pattern (Pattern(..)) import Data.Datamining.Clustering.Classifier(Classifier(..)) import Prelude hiding (lookup) @@ -38,34 +37,52 @@ --      just return an @error@). It would be problematic to implement --      them because the input DSOM and the output DSOM would have to --      have the same @Metric@ type.-data DSOM gm k p = DSOM+data DSOM gm x k p = DSOM   {-    sGridMap :: gm p,-    sLearningFunction :: (Metric p -> Metric p -> Metric p -> Metric p)+    -- | Maps patterns to tiles in a regular grid.+    --   In the context of a SOM, the tiles are called "nodes"+    gridMap :: gm p,+    -- | A function which determines the how quickly the SOM learns.+    learningRate :: (x -> x -> x -> x),+    -- | A function which compares two patterns and returns a +    --   /non-negative/ numberrepresenting how different the patterns+    --   are.+    --   A result of @0@ indicates that the patterns are identical.+    difference :: p -> p -> x,+    -- | A function which updates models.+    --   If this function is @f@, then @f target amount pattern@ returns+    --   a modified copy of @pattern@ that is more similar to @target@+    --   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   } -instance (F.Foldable gm) => F.Foldable (DSOM gm k) where-  foldr f x g = F.foldr f x (sGridMap g)+instance (F.Foldable gm) => F.Foldable (DSOM gm x k) where+  foldr f x g = F.foldr f x (gridMap g) -instance (G.Grid (gm p)) => G.Grid (DSOM gm k p) where-  type Index (DSOM gm k p) = G.Index (gm p)-  type Direction (DSOM gm k p) = G.Direction (gm p)-  indices = G.indices . sGridMap-  distance = G.distance . sGridMap-  neighbours = G.neighbours . sGridMap-  contains = G.contains . sGridMap-  viewpoint = G.viewpoint . sGridMap-  directionTo = G.directionTo . sGridMap-  tileCount = G.tileCount . sGridMap-  null = G.null . sGridMap-  nonNull = G.nonNull . sGridMap+instance (G.Grid (gm p)) => G.Grid (DSOM gm x k p) where+  type Index (DSOM gm x k p) = G.Index (gm p)+  type Direction (DSOM gm x k p) = G.Direction (gm p)+  indices = G.indices . gridMap+  distance = G.distance . gridMap+  neighbours = G.neighbours . gridMap+  contains = G.contains . gridMap+  viewpoint = G.viewpoint . gridMap+  directionTo = G.directionTo . gridMap+  tileCount = G.tileCount . gridMap+  null = G.null . gridMap+  nonNull = G.nonNull . gridMap  instance   (F.Foldable gm, GM.GridMap gm p, G.FiniteGrid (GM.BaseGrid gm p)) =>-    GM.GridMap (DSOM gm k) p where-  type BaseGrid (DSOM gm k) p = GM.BaseGrid gm p-  toGrid = GM.toGrid . sGridMap-  toMap = GM.toMap . sGridMap+    GM.GridMap (DSOM gm x k) p where+  type BaseGrid (DSOM gm x k) p = GM.BaseGrid gm p+  toGrid = GM.toGrid . gridMap+  toMap = GM.toMap . gridMap   mapWithKey = error "Not implemented"   delete k = withGridMap (GM.delete k)   adjustWithKey f k = withGridMap (GM.adjustWithKey f k)@@ -73,25 +90,26 @@   alter f k = withGridMap (GM.alter f k)   filterWithKey f = withGridMap (GM.filterWithKey f) -withGridMap :: (gm p -> gm p) -> DSOM gm k p -> DSOM gm k p-withGridMap f s = s { sGridMap=gm' }-    where gm = sGridMap s+withGridMap :: (gm p -> gm p) -> DSOM gm x k p -> DSOM gm x k p+withGridMap f s = s { gridMap=gm' }+    where gm = gridMap s           gm' = f gm  -- | Extracts the grid and current models from the DSOM.-toGridMap :: GM.GridMap gm p => DSOM gm k p -> gm p-toGridMap = sGridMap+toGridMap :: GM.GridMap gm p => DSOM gm x k p -> gm p+toGridMap = gridMap  adjustNode-  :: (Pattern p, G.FiniteGrid (gm p), GM.GridMap gm p,-      k ~ G.Index (gm p), Ord k, k ~ G.Index (GM.BaseGrid gm p),-      Num (Metric p), Fractional (Metric p)) => -     gm p -> (Metric p -> Metric p -> Metric p) -> p -> k -> k -> p -> p-adjustNode gm f target bmu k = makeSimilar target amount-  where diff = difference (gm GM.! k) target+  :: (G.FiniteGrid (gm p), GM.GridMap gm p,+      k ~ G.Index (gm p), k ~ G.Index (GM.BaseGrid gm p),+      Ord k, Num x, Fractional x) => +     gm p -> (p -> x -> p -> p) -> (p -> p -> x) -> (x -> x -> x) -> p -> k -> k+       -> (p -> p)+adjustNode gm fms fd fr target bmu k = fms target amount+  where diff = fd (gm GM.! k) target         dist = scaleDistance (G.distance gm bmu k)                  (G.maxPossibleDistance gm)-        amount = f diff dist+        amount = fr diff dist  scaleDistance :: (Num a, Fractional a) => Int -> Int -> a scaleDistance d dMax@@ -103,39 +121,40 @@ --   Most users should use @train@, which automatically determines --   the BMU and trains it and its neighbourhood. trainNeighbourhood-  :: (Pattern p, G.FiniteGrid (gm p), GM.GridMap gm p, Num (Metric p),-      Ord k, k ~ G.Index (gm p),-      k ~ G.Index (GM.BaseGrid gm p), Fractional (Metric p)) =>-     DSOM gm t p -> k -> p -> DSOM gm k p-trainNeighbourhood s bmu target = s { sGridMap=gm' }-  where gm = sGridMap s-        gm' = GM.mapWithKey (adjustNode gm f target bmu) gm-        f = (sLearningFunction s) bmuDiff-        bmuDiff = difference (gm GM.! bmu) target+  :: (G.FiniteGrid (gm p), GM.GridMap gm p,+      k ~ G.Index (gm p), k ~ G.Index (GM.BaseGrid gm p),+      Ord k, Num x, Fractional x) => +      DSOM gm x t p -> k -> p -> DSOM gm x k p+trainNeighbourhood s bmu target = s { gridMap=gm' }+  where gm = gridMap s+        gm' = GM.mapWithKey (adjustNode gm fms fd fr target bmu) gm+        fms = makeSimilar s+        fd = difference s+        fr = (learningRate s) bmuDiff+        bmuDiff = (difference s) (gm GM.! bmu) target  justTrain-  :: (Pattern p, G.FiniteGrid (gm p), GM.GridMap gm p,-      Num (Metric p), Ord (Metric p), Ord (G.Index (gm p)),-      GM.GridMap gm (Metric p), Fractional (Metric p),-      G.Index (GM.BaseGrid gm (Metric p)) ~ G.Index (gm p),-      G.Index (GM.BaseGrid gm p) ~ G.Index (gm p)) =>-     DSOM gm t p -> p -> DSOM gm (G.Index (gm p)) p+  :: (G.FiniteGrid (gm p), GM.GridMap gm p, GM.GridMap gm x,+      k ~ G.Index (gm p), k ~ G.Index (gm x),+      k ~ G.Index (GM.BaseGrid gm p), k ~ G.Index (GM.BaseGrid gm x),+      Ord k, Ord x, Num x, Fractional x) => +     DSOM gm x t p -> p -> DSOM gm x k p justTrain s p = trainNeighbourhood s bmu p-  where ds = GM.toList . GM.map (p `difference`) $ sGridMap s+  where ds = GM.toList . GM.map (difference s p) $ gridMap s         bmu = f ds         f [] = error "DSOM has no models"         f xs = fst $ minimumBy (comparing snd) xs  instance-  (GM.GridMap gm p, k ~ G.Index (GM.BaseGrid gm p), Pattern p,-    G.FiniteGrid (gm p), GM.GridMap gm (Metric p), k ~ G.Index (gm p),-    k ~ G.Index (GM.BaseGrid gm (Metric p)), Ord k, Ord (Metric p),-    Num (Metric p), Fractional (Metric p)) =>-   Classifier (DSOM gm) k p where-  toList = GM.toList . sGridMap-  numModels = G.tileCount . sGridMap-  models = GM.elems . sGridMap-  differences s p = GM.toList . GM.map (p `difference`) $ sGridMap s+  (GM.GridMap gm p, k ~ G.Index (GM.BaseGrid gm p), +    G.FiniteGrid (gm p), GM.GridMap gm x, k ~ G.Index (gm p),+    k ~ G.Index (gm x), k ~ G.Index (GM.BaseGrid gm x), Ord k, Ord x,+    Num x, Fractional x) =>+   Classifier (DSOM gm) x k p where+  toList = GM.toList . gridMap+  numModels = G.tileCount . gridMap+  models = GM.elems . gridMap+  differences s p = GM.toList . GM.map (difference s p) $ gridMap s   trainBatch s = foldl' justTrain s   reportAndTrain s p = (bmu, ds, s')     where ds = differences s p@@ -143,53 +162,6 @@           f [] = error "DSOM has no models"           f xs = fst $ minimumBy (comparing snd) xs           s' = trainNeighbourhood s bmu p----- | Creates a classifier with a default (bell-shaped) learning---   function. Usage is @'defaultDSOM' gm r w t@, where:------   [@gm@] The geometry and initial models for this classifier.---   A reasonable choice here is @'lazyGridMap' g ps@, where @g@ is a---   @'HexHexGrid'@, and @ps@ is a set of random patterns.------   [@r@] and [@p@] are the first two parameters to the---   @'rougierLearningFunction'@.-defaultDSOM-  :: (Eq (Metric p), Ord (Metric p), Floating (Metric p)) =>-     gm p -> Metric p -> Metric p -> DSOM gm k p-defaultDSOM gm r p =-  DSOM {-        sGridMap=gm,-        sLearningFunction=rougierLearningFunction r p-      }---- | Creates a classifier with a custom learning function.---   Usage is @'customDSOM' gm g@, where:------   [@gm@] The geometry and initial models for this classifier.---   A reasonable choice here is @'lazyGridMap' g ps@, where @g@ is a---   @'HexHexGrid'@, and @ps@ is a set of random patterns.------   [@f@] A function used to determine the learning rate (for---   adjusting the models in the classifier).---   This function will be invoked with three parameters.---   The first parameter will indicate how different the BMU is from---   the input pattern.---   The second parameter indicates how different the pattern of the---   node currently being trained is from the input pattern.---   The third parameter is the grid distance from the BMU to the node---   currently being trained, as a fraction of the maximum grid---   distance.---   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.-customDSOM-  :: gm p -> (Metric p -> Metric p -> Metric p -> Metric p) -> DSOM gm k p-customDSOM gm f =-  DSOM {-        sGridMap=gm,-        sLearningFunction=f-      }  -- | Configures a learning function that depends not on the time, but --   on how good a model we already have for the target. If the

@@ -1,7 +1,7 @@ ------------------------------------------------------------------------ -- | -- Module      :  Data.Datamining.Clustering.SOM--- Copyright   :  (c) Amy de Buitléir 2012-2014+-- Copyright   :  (c) Amy de Buitléir 2012-2015 -- License     :  BSD-style -- Maintainer  :  amy@nualeargais.ie -- Stability   :  experimental@@ -40,13 +40,15 @@   (     -- * Construction     SOM(..),-    DecayingGaussian(..),     -- * Deconstruction     toGridMap,+    -- * Learning functions+    decayingGaussian,+    stepFunction,+    constantFunction,     -- * Advanced control     trainNeighbourhood   ) where -import Data.Datamining.Clustering.SOMInternal (SOM(..),-  DecayingGaussian(..), toGridMap, trainNeighbourhood)+import Data.Datamining.Clustering.SOMInternal 

@@ -1,7 +1,7 @@ ------------------------------------------------------------------------ -- | -- Module      :  Data.Datamining.Clustering.SOMInternal--- Copyright   :  (c) Amy de Buitléir 2012-2014+-- Copyright   :  (c) Amy de Buitléir 2012-2015 -- License     :  BSD-style -- Maintainer  :  amy@nualeargais.ie -- Stability   :  experimental@@ -21,28 +21,12 @@ import Data.Ord (comparing) import qualified Math.Geometry.Grid as G (Grid(..)) import qualified Math.Geometry.GridMap as GM (GridMap(..))-import Data.Datamining.Pattern (Pattern(..)) import Data.Datamining.Clustering.Classifier(Classifier(..)) import GHC.Generics (Generic) import Prelude hiding (lookup) --- | A function used to adjust the models in a classifier.-class LearningFunction f where-  type LearningRate f-  -- | @'rate' f t d@ returns the learning rate for a node.-  --   The parameter @f@ is the learning function.-  --   The parameter @t@ 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 parameter @d@ is the grid distance from the node being-  --   updated to the BMU (Best Matching Unit).-  --   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.-  rate :: f -> LearningRate f -> LearningRate f -> LearningRate f- -- | A typical learning function for classifiers.---   @'DecayingGaussian' r0 rf w0 wf tf@ returns a bell curve-shaped+--   @'decayingGaussian' r0 rf w0 wf tf@ returns a bell curve-shaped --   function. At time zero, the maximum learning rate (applied to the --   BMU) is @r0@, and the neighbourhood width is @w0@. Over time the --   bell curve shrinks and the learning rate tapers off, until at time@@ -58,33 +42,23 @@ -- --   where << means "is much smaller than" (not the Haskell @<<@ --   operator!)-data DecayingGaussian a = DecayingGaussian a a a a a-  deriving (Eq, Show, Generic)--instance (Floating a, Fractional a, Num a)-    => LearningFunction (DecayingGaussian a) where-  type LearningRate (DecayingGaussian a) = a-  rate (DecayingGaussian r0 rf w0 wf tf) t d = r * exp (-(d*d)/(2*w*w))-    where a = t/tf-          r = r0 * ((rf/r0)**a)-          w = w0 * ((wf/w0)**a)+decayingGaussian :: Floating x => x -> x -> x -> x -> x -> x -> x -> x+decayingGaussian r0 rf w0 wf tf t d = r * exp (-x/y)+  where a = t / tf+        r = r0 * ((rf/r0)**a)+        w = w0 * ((wf/w0)**a)+        x =  (d*d)+        y =  (2*w*w)  -- | A learning function that only updates the BMU and has a constant --   learning rate.-data StepFunction a = StepFunction a deriving (Eq, Show, Generic)--instance (Fractional a, Eq a)-  => LearningFunction (StepFunction a) where-  type LearningRate (StepFunction a) = a-  rate (StepFunction r) _ d = if d == 0 then r else 0.0+stepFunction :: (Num d, Fractional x, Eq d) => x -> t -> d -> x+stepFunction r _ d = if d == 0 then r else 0.0  -- | A learning function that updates all nodes with the same, constant --   learning rate. This can be useful for testing.-data ConstantFunction a = ConstantFunction a deriving (Eq, Show, Generic)--instance (Fractional a) => LearningFunction (ConstantFunction a) where-  type LearningRate (ConstantFunction a) = a-  rate (ConstantFunction r) _ _ = r+constantFunction :: x -> t -> d -> x+constantFunction r _ _ = r  -- | A Self-Organising Map (SOM). --@@ -99,26 +73,52 @@ --      just return an @error@). It would be problematic to implement --      them because the input SOM and the output SOM would have to have --      the same @Metric@ type.-data SOM f t gm k p = SOM+data SOM t d gm x k p = SOM   {     -- | Maps patterns to tiles in a regular grid.     --   In the context of a SOM, the tiles are called "nodes"     gridMap :: gm p,-    -- | The function used to update the nodes.-    learningFunction :: f,+    -- | A function which determines the how quickly the SOM learns.+    --   For example, if the function is @f@, then @f t d@ returns the+    --   learning rate for a node.+    --   The parameter @t@ 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 parameter @d@ is the grid distance from the node being+    --   updated to the BMU (Best Matching Unit).+    --   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 -> d -> x,+    -- | A function which compares two patterns and returns a +    --   /non-negative/ numberrepresenting how different the patterns+    --   are.+    --   A result of @0@ indicates that the patterns are identical.+    difference :: p -> p -> x,+    -- | A function which updates models.+    --   If this function is @f@, then @f target amount pattern@ returns+    --   a modified copy of @pattern@ that is more similar to @target@+    --   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 SOM with a counter value @0@, and don't     --   directly modify it, then the counter will represent the number     --   of patterns that this SOM has classified.     counter :: t-  } deriving (Eq, Show, Generic)+  } deriving (Generic) -instance (F.Foldable gm) => F.Foldable (SOM f t gm k) where+instance (F.Foldable gm) => F.Foldable (SOM t d gm x k) where   foldr f x g = F.foldr f x (gridMap g) -instance (G.Grid (gm p)) => G.Grid (SOM f t gm k p) where-  type Index (SOM f t gm k p) = G.Index (gm p)-  type Direction (SOM f t gm k p) = G.Direction (gm p)+instance (G.Grid (gm p)) => G.Grid (SOM t d gm x k p) where+  type Index (SOM t d gm x k p) = G.Index (gm p)+  type Direction (SOM t d gm x k p) = G.Direction (gm p)   indices = G.indices . gridMap   distance = G.distance . gridMap   neighbours = G.neighbours . gridMap@@ -130,8 +130,8 @@   nonNull = G.nonNull . gridMap  instance (F.Foldable gm, GM.GridMap gm p, G.Grid (GM.BaseGrid gm p))-    => GM.GridMap (SOM f t gm k) p where-  type BaseGrid (SOM f t gm k) p = GM.BaseGrid gm p+    => GM.GridMap (SOM t d gm x k) p where+  type BaseGrid (SOM t d gm x k) p = GM.BaseGrid gm p   toGrid = GM.toGrid . gridMap   toMap = GM.toMap . gridMap   mapWithKey = error "Not implemented"@@ -141,27 +141,26 @@   alter f k = withGridMap (GM.alter f k)   filterWithKey f = withGridMap (GM.filterWithKey f) -withGridMap :: (gm p -> gm p) -> SOM f t gm k p -> SOM f t gm k p+withGridMap :: (gm p -> gm p) -> SOM t d gm x k p -> SOM t d gm x k p withGridMap f s = s { gridMap=gm' }     where gm = gridMap s           gm' = f gm  currentLearningFunction-  :: (LearningFunction f, Metric p ~ LearningRate f,-    Num (LearningRate f), Integral t)-      => SOM f t gm k p -> (LearningRate f -> Metric p)+  :: (Num t)+    => SOM t d gm x k p -> (d -> x) currentLearningFunction s-  = rate (learningFunction s) (fromIntegral $ counter s)+  = (learningRate s) (counter s)  -- | Extracts the grid and current models from the SOM. --   A synonym for @'gridMap'@.-toGridMap :: GM.GridMap gm p => SOM f t gm k p -> gm p+toGridMap :: GM.GridMap gm p => SOM t d gm x k p -> gm p toGridMap = gridMap  adjustNode-  :: (Pattern p, G.Grid g, k ~ G.Index g, Num t) =>-     g -> (t -> Metric p) -> p -> k -> k -> p -> p-adjustNode g f target bmu k = makeSimilar target (f d)+  :: (G.Grid g, k ~ G.Index g, Num t) =>+     g -> (t -> x) -> (p -> x -> p -> p) -> p -> k -> k -> p -> p+adjustNode g rateF adjustF target bmu k = adjustF target (rateF d)   where d = fromIntegral $ G.distance g bmu k  -- | Trains the specified node and the neighbourood around it to better@@ -169,42 +168,40 @@ --   Most users should use @'train'@, which automatically determines --   the BMU and trains it and its neighbourhood. trainNeighbourhood-  :: (Pattern p, G.Grid (gm p), GM.GridMap gm p,-      G.Index (GM.BaseGrid gm p) ~ G.Index (gm p), LearningFunction f,-      Metric p ~ LearningRate f, Num (LearningRate f), Integral t) =>-     SOM f t gm k p -> G.Index (gm p) -> p -> SOM f t gm k p+  :: (G.Grid (gm p), GM.GridMap gm p,+      G.Index (GM.BaseGrid gm p) ~ G.Index (gm p), Num t, Num x,+      Num d) =>+     SOM t d gm x k p -> G.Index (gm p) -> p -> SOM t d gm x k p trainNeighbourhood s bmu target = s { gridMap=gm' }   where gm = gridMap s-        gm' = GM.mapWithKey (adjustNode gm f target bmu) gm-        f = currentLearningFunction s+        gm' = GM.mapWithKey (adjustNode gm f1 f2 target bmu) gm+        f1 = currentLearningFunction s+        f2 = makeSimilar s -incrementCounter :: Num t => SOM f t gm k p -> SOM f t gm k p+incrementCounter :: Num t => SOM t d gm x k p -> SOM t d gm x k p incrementCounter s = s { counter=counter s + 1}  justTrain-  :: (Ord (Metric p), Pattern p, G.Grid (gm p),-      GM.GridMap gm (Metric p), GM.GridMap gm p,-      G.Index (GM.BaseGrid gm (Metric p)) ~ G.Index (gm p),-      G.Index (GM.BaseGrid gm p) ~ G.Index (gm p), LearningFunction f,-      Metric p ~ LearningRate f, Num (LearningRate f), Integral t) =>-     SOM f t gm k p -> p -> SOM f t gm k p+  :: (Ord x, G.Grid (gm p), GM.GridMap gm x, GM.GridMap gm p,+      G.Index (GM.BaseGrid gm x) ~ G.Index (gm p),+      G.Index (GM.BaseGrid gm p) ~ G.Index (gm p), Num t, Num x,+      Num d) =>+     SOM t d gm x k p -> p -> SOM t d gm x k p justTrain s p = trainNeighbourhood s bmu p-  where ds = GM.toList . GM.map (p `difference`) $ gridMap s+  where ds = GM.toList . GM.map (difference s p) $ gridMap s         bmu = f ds         f [] = error "SOM has no models"         f xs = fst $ minimumBy (comparing snd) xs  instance-  (GM.GridMap gm p, k ~ G.Index (GM.BaseGrid gm p), Pattern p,-  G.Grid (gm p), GM.GridMap gm (Metric p), k ~ G.Index (gm p),-  k ~ G.Index (GM.BaseGrid gm (Metric p)), Ord (Metric p),-  LearningFunction f, Metric p ~ LearningRate f, Num (LearningRate f),-  Integral t)-    => Classifier (SOM f t gm) k p where+  (GM.GridMap gm p, k ~ G.Index (GM.BaseGrid gm p), G.Grid (gm p),+  GM.GridMap gm x, k ~ G.Index (gm p), k ~ G.Index (GM.BaseGrid gm x),+  Num t, Ord x, Num x, Num d)+    => Classifier (SOM t d gm) x k p where   toList = GM.toList . gridMap   numModels = G.tileCount . gridMap   models = GM.elems . gridMap-  differences s p = GM.toList . GM.map (p `difference`) $ gridMap s+  differences s p = GM.toList . GM.map (difference s p) $ gridMap s   trainBatch s = incrementCounter . foldl' justTrain s   reportAndTrain s p = (bmu, ds, incrementCounter s')     where ds = differences s p

@@ -1,7 +1,7 @@ ------------------------------------------------------------------------ -- | -- Module      :  Data.Datamining.Clustering.SSOM--- Copyright   :  (c) Amy de Buitléir 2012-2014+-- Copyright   :  (c) Amy de Buitléir 2012-2015 -- License     :  BSD-style -- Maintainer  :  amy@nualeargais.ie -- Stability   :  experimental@@ -34,13 +34,13 @@   (     -- * Construction     SSOM(..),-    Exponential(..),     -- * Deconstruction     toMap,+    -- * Learning functions+    exponential,     -- * Advanced control-    trainNode,+    trainNode   ) where -import Data.Datamining.Clustering.SSOMInternal (SSOM(..),-  Exponential(..), toMap, trainNode)+import Data.Datamining.Clustering.SSOMInternal 

@@ -1,7 +1,7 @@ ------------------------------------------------------------------------ -- | -- Module      :  Data.Datamining.Clustering.SSOMInternal--- Copyright   :  (c) Amy de Buitléir 2012-2014+-- Copyright   :  (c) Amy de Buitléir 2012-2015 -- License     :  BSD-style -- Maintainer  :  amy@nualeargais.ie -- Stability   :  experimental@@ -18,30 +18,17 @@  import Data.List (foldl', minimumBy) import Data.Ord (comparing)-import Data.Datamining.Pattern (Pattern(..)) import Data.Datamining.Clustering.Classifier(Classifier(..)) import qualified Data.Map.Strict as M import GHC.Generics (Generic) import Prelude hiding (lookup) --- | A function used to adjust the models in a classifier.-class LearningFunction f where-  type LearningRate f-  -- | @'rate' f t@ returns the learning rate for a node.-  --   The parameter @f@ is the learning function.-  --   The parameter @t@ 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.-  rate :: f -> LearningRate f -> LearningRate f- -- | A typical learning function for classifiers.---   @'Exponential' r0 d@ returns a function to calculate the---   learning rate. At time zero, the learning rate is @r0@. Over time---   the learning rate decays exponentially. Normally the parameters---   should be chosen such that:+--   @'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 --@@ -49,67 +36,85 @@ -- --   where << means "is much smaller than" (not the Haskell @<<@ --   operator!)-data Exponential a = Exponential a a-  deriving (Eq, Show, Generic)--instance (Floating a, Fractional a, Num a)-    => LearningFunction (Exponential a) where-  type LearningRate (Exponential a) = a-  rate (Exponential r0 d) t = r0 * exp (-d*t)+exponential :: Floating a => a -> a -> a -> a+exponential r0 d t = r0 * exp (-d*t)  -- | A Simplified Self-Organising Map (SSOM).-data SSOM f t k p = 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,-    -- | The function used to update the nodes.-    learningFunction :: f,+    -- | 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/ numberrepresenting 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 (Eq, Show, Generic)+  } deriving (Generic)  -- | Extracts the current models from the SSOM. --   A synonym for @'sMap'@.-toMap :: SSOM f t k p -> M.Map k p+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-  :: (Pattern p, LearningFunction f, Metric p ~ LearningRate f,-    Num (LearningRate f), Ord k, Integral t)-      => SSOM f t k p -> k -> p -> SSOM f t k p+  :: (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 target r) k gm-        r = rate (learningFunction s) (fromIntegral $ counter s)+        gm' = M.adjust (makeSimilar s target r) k gm+        r = (learningRate s) (counter s) -incrementCounter :: Num t => SSOM f t k p -> SSOM f t k p+incrementCounter :: Num t => SSOM t x k p -> SSOM t x k p incrementCounter s = s { counter=counter s + 1}  justTrain-  :: (Ord (Metric p), Pattern p, LearningFunction f,-    Metric p ~ LearningRate f, Num (LearningRate f), Ord k, Integral t)-      => SSOM f t k p -> p -> SSOM f t k p+  :: (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 (p `difference`) . toMap $ s+  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-  (Pattern p, Ord (Metric p), LearningFunction f,-    Metric p ~ LearningRate f, Num (LearningRate f), Ord k, Integral t)-      => Classifier (SSOM f t) k p where+  (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 = length . M.keys . sMap   models = M.elems . toMap-  differences s p = M.toList . M.map (p `difference`) $ toMap s+  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

@@ -1,7 +1,7 @@ ------------------------------------------------------------------------ -- | -- Module      :  Data.Datamining.Pattern--- Copyright   :  (c) Amy de Buitléir 2012-2014+-- Copyright   :  (c) Amy de Buitléir 2012-2015 -- License     :  BSD-style -- Maintainer  :  amy@nualeargais.ie -- Stability   :  experimental@@ -13,15 +13,11 @@ {-# LANGUAGE TypeFamilies, FlexibleContexts, MultiParamTypeClasses #-} module Data.Datamining.Pattern   (-    -- * Patterns-    Pattern(..),     -- * Numbers as patterns-    -- $Num     adjustNum,     absDifference,     -- * Numeric vectors as patterns     -- ** Raw vectors-    -- $Vector     adjustVector,     euclideanDistanceSquared,     magnitudeSquared,@@ -36,22 +32,6 @@  import Data.List (foldl') --- | A pattern to be learned or classified.-class Pattern p where-  type Metric p-  -- | 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 -> Metric p-  -- | @'makeSimilar' 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 -> Metric p -> p -> p- -- -- Using numbers as patterns. --@@ -63,23 +43,12 @@ adjustNum target r x   | r < 0     = error "Negative learning rate"   | r > 1     = error "Learning rate > 1"-  | r == 1     = x   | otherwise = adjustNum' r target x  -- Note that parameters are swapped adjustNum' :: Num a => a -> a -> a -> a adjustNum' r target x = x + r*(target - x) -{- $Num-If you wish to use, say, a @Double@ as a pattern, one option is to-use @no-warn-orphans@ and add the following to your code:--> instance Double => Pattern Double where->   type Metric Double = Double->   difference = absDifference->   makeSimilar = adjustNum--}- -- -- Using numeric vectors as patterns. --@@ -118,14 +87,6 @@ norm xs = sqrt $ sum (map f xs)   where f x = x*x -instance (Floating a, Fractional a, Ord a, Eq a) =>-    Pattern (NormalisedVector a) where-  type Metric (NormalisedVector a) = a-  difference (NormalisedVector xs) (NormalisedVector ys) =-    euclideanDistanceSquared xs ys-  makeSimilar (NormalisedVector xs) r (NormalisedVector ys) =-    normalise $ adjustVector xs r ys- -- | A vector that has been scaled so that all elements in the vector --   are between zero and one. To scale a set of vectors, use --   @'scaleAll'@. Alternatively, if you can identify a maximum and@@ -158,20 +119,3 @@ quantify' :: Ord a => [(a,a)] -> [a] -> [(a,a)] quantify' = zipWith f   where f (minX, maxX) x = (min minX x, max maxX x)--instance (Fractional a, Ord a, Eq a) => Pattern (ScaledVector a) where-  type Metric (ScaledVector a) = a-  difference (ScaledVector xs) (ScaledVector ys) =-    euclideanDistanceSquared xs ys-  makeSimilar (ScaledVector xs) r (ScaledVector ys) =-    ScaledVector $ adjustVector xs r ys--{- $Vector-If you wish to use raw numeric vectors as a pattern, one option is to-use @no-warn-orphans@ and add the following to your code:--> instance (Floating a, Fractional a, Ord a, Eq a) => Pattern [a] where->   type Metric [a] = a->   difference = euclideanDistanceSquared->   makeSimilar = adjustVector--}

@@ -1,7 +1,7 @@ ------------------------------------------------------------------------ -- | -- Module      :  Data.Datamining.Clustering.DSOMQC--- Copyright   :  (c) Amy de Buitléir 2012-2014+-- Copyright   :  (c) Amy de Buitléir 2012-2015 -- License     :  BSD-style -- Maintainer  :  amy@nualeargais.ie -- Stability   :  experimental@@ -19,23 +19,23 @@     test   ) where -import Data.Datamining.Pattern (Pattern, Metric, difference,-  euclideanDistanceSquared, magnitudeSquared, makeSimilar)+import Data.Datamining.Pattern (euclideanDistanceSquared,+  magnitudeSquared, adjustNum, absDifference) import Data.Datamining.Clustering.Classifier(classify,   classifyAndTrain, differences, diffAndTrain, models,   numModels, train, trainBatch) import Data.Datamining.Clustering.DSOMInternal  import Control.Applicative ((<$>), (<*>))-import Data.Function (on) import Data.List (sort)+import Math.Geometry.Grid (size) import Math.Geometry.Grid.Hexagonal (HexHexGrid, hexHexGrid)-import Math.Geometry.GridMap ((!))+import Math.Geometry.GridMap ((!), elems) import Math.Geometry.GridMap.Lazy (LGridMap, lazyGridMap) import Test.Framework as TF (Test, testGroup) import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.QuickCheck ((==>), Gen, Arbitrary, arbitrary, choose,-  Property, property, sized, suchThat, vectorOf)+  Property, property, sized, suchThat, vectorOf, shrink)  positive :: (Num a, Ord a, Arbitrary a) => Gen a positive = arbitrary `suchThat` (> 0)@@ -64,128 +64,127 @@ prop_rougierFunction_r_if_inelastic (RougierArgs r _ _ _ _) =   property $ rougierLearningFunction r 1.0 1.0 1.0 0 == r -newtype TestPattern = MkPattern Double deriving Show+fractionDiff :: [Double] -> [Double] -> Double+fractionDiff xs ys = if denom == 0 then 0 else d / denom+  where d = sqrt $ euclideanDistanceSquared xs ys+        denom = max xMag yMag+        xMag = sqrt $ magnitudeSquared xs+        yMag = sqrt $ magnitudeSquared ys -instance Eq TestPattern where-  (==) = (==) `on` toDouble+approxEqual :: [TestPattern] -> [TestPattern] -> Bool+approxEqual xs ys = fractionDiff xs' ys' <= 0.1+  where xs' = map toDouble xs+        ys' = map toDouble ys -instance Ord TestPattern where-  compare = compare `on` toDouble+-- We need to ensure that the absolute value of the difference+-- between any two test patterns is on the unit interval. -instance Pattern TestPattern where-  type Metric TestPattern = Double-  difference (MkPattern a) (MkPattern b) = abs (a - b)-  makeSimilar orig@(MkPattern a) r (MkPattern b)-    | r < 0     = error "Negative learning rate"-    | r > 1     = error "Learning rate > 1"-    | r == 1     = orig-    | otherwise = MkPattern (b + delta)-        where diff = a - b-              delta = r*diff+newtype TestPattern = TestPattern {toDouble :: Double}+ deriving ( Eq, Ord, Show, Read)  instance Arbitrary TestPattern where-  arbitrary = MkPattern <$> choose (0,1)--toDouble :: TestPattern -> Double-toDouble (MkPattern a) = a--absDiff :: [TestPattern] -> [TestPattern] -> Double-absDiff xs ys = euclideanDistanceSquared xs' ys'-  where xs' = map toDouble xs-        ys' = map toDouble ys+  arbitrary = fmap TestPattern $ choose (0,1)+  shrink (TestPattern x) =+    [ TestPattern x' | x' <- shrink x, x' >= 0, x' <= 1] -fractionDiff :: [TestPattern] -> [TestPattern] -> Double-fractionDiff xs ys = if denom == 0 then 0 else d / denom-  where d = sqrt $ euclideanDistanceSquared xs' ys'-        denom = max xMag yMag-        xMag = sqrt $ magnitudeSquared xs'-        yMag = sqrt $ magnitudeSquared ys'-        xs' = map toDouble xs-        ys' = map toDouble ys+testPatternDiff :: TestPattern -> TestPattern -> Double+testPatternDiff (TestPattern a) (TestPattern b) = absDifference a b -approxEqual :: [TestPattern] -> [TestPattern] -> Bool-approxEqual xs ys = fractionDiff xs ys <= 0.1+adjustTestPattern :: TestPattern -> Double -> TestPattern -> TestPattern+adjustTestPattern (TestPattern target) r (TestPattern x)+  = TestPattern $ adjustNum target r x -data DSOMandTargets = DSOMandTargets (DSOM (LGridMap HexHexGrid) (Int, Int)-  TestPattern) [TestPattern] String+-- | 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 DSOMTestData+  = DSOMTestData+    {+      som1 :: DSOM (LGridMap HexHexGrid) Double (Int, Int) TestPattern,+      params1 :: RougierArgs,+      trainingSet1 :: [TestPattern]+    } -instance Show DSOMandTargets where-  show (DSOMandTargets _ _ desc) = desc+instance Show DSOMTestData where+  show s = "buildDSOMTestData " ++ show (size . gridMap . som1 $ s)+    ++ " " ++ show (elems . gridMap . som1 $ s)+    ++ " (" ++ show (params1 s) +    ++ ") " ++ show (trainingSet1 s)  -buildDSOMandTargets-  :: Int -> [TestPattern] -> Double -> Double -> [TestPattern] -> DSOMandTargets-buildDSOMandTargets len ps r p targets = DSOMandTargets s targets desc+buildDSOMTestData+  :: Int -> [TestPattern] -> RougierArgs -> [TestPattern] -> DSOMTestData+buildDSOMTestData len ps rp@(RougierArgs r p _ _ _) targets =+  DSOMTestData s rp targets     where g = hexHexGrid len           gm = lazyGridMap g ps-          s = defaultDSOM gm r p-          desc = "buildDSOMandTargets " ++ show len ++ " " ++ show ps ++-            " " ++ show r ++ " " ++ show p ++ " " ++ show targets+          fr = rougierLearningFunction r p+          s = DSOM gm fr testPatternDiff adjustTestPattern  -- | Generate a classifier and a training set. The training set will --   consist @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.-sizedDSOMandTargets :: Int -> Gen DSOMandTargets-sizedDSOMandTargets n = do+sizedDSOMTestData :: Int -> Gen DSOMTestData+sizedDSOMTestData n = do   sideLength <- choose (1, min (n+1) 5) --avoid long tests   let tileCount = 3*sideLength*(sideLength-1) + 1   let numberOfPatterns = tileCount   ps <- vectorOf numberOfPatterns arbitrary-  r <- choose (0, 1)-  p <- choose (0, 1)+  rp <- arbitrary   targets <- vectorOf numberOfPatterns arbitrary-  return $ buildDSOMandTargets sideLength ps r p targets+  return $ buildDSOMTestData sideLength ps rp targets -instance Arbitrary DSOMandTargets where-  arbitrary = sized sizedDSOMandTargets+instance Arbitrary DSOMTestData where+  arbitrary = sized sizedDSOMTestData  -- | If we use a fixed learning rate of one (regardless of the distance --   from the BMU), and train a classifier once on one pattern, then all --   nodes should match the input vector.-prop_global_instant_training_works :: DSOMandTargets -> Property-prop_global_instant_training_works (DSOMandTargets s xs _) =+prop_global_instant_training_works :: DSOMTestData -> Property+prop_global_instant_training_works (DSOMTestData s _ xs) =   property $ finalModels `approxEqual` expectedModels     where x = head xs           gm = toGridMap s :: LGridMap HexHexGrid TestPattern-          f = (\_ _ _ -> 1) -              :: Metric TestPattern -> Metric TestPattern -> Metric TestPattern -> Metric TestPattern-          s2 = customDSOM gm f :: DSOM (LGridMap HexHexGrid) (Int, Int) TestPattern+          f _ _ _ = 1+          s2 = DSOM gm f testPatternDiff adjustTestPattern           s3 = train s2 x           finalModels = models s3 :: [TestPattern]           expectedModels = replicate (numModels s) x :: [TestPattern] -prop_training_works :: DSOMandTargets -> Property-prop_training_works (DSOMandTargets s xs _) = errBefore /= 0 ==>+prop_training_works :: DSOMTestData -> Property+prop_training_works (DSOMTestData s _ xs) = errBefore /= 0 ==>   errAfter < errBefore     where (bmu, s') = classifyAndTrain s x           x = head xs-          errBefore = abs $ toDouble x - toDouble (sGridMap s ! bmu)-          errAfter = abs $ toDouble x - toDouble (sGridMap s' ! bmu)+          errBefore = testPatternDiff x (gridMap s ! bmu)+          errAfter = testPatternDiff x (gridMap s' ! bmu)  --   Invoking @diffAndTrain f s p@ should give identical results to --   @(p `classify` s, train s f p)@.-prop_classifyAndTrainEquiv :: DSOMandTargets -> Property-prop_classifyAndTrainEquiv (DSOMandTargets s ps _) = property $-  bmu == s `classify` p && sGridMap s1 == sGridMap s2+prop_classifyAndTrainEquiv :: DSOMTestData -> Property+prop_classifyAndTrainEquiv (DSOMTestData s _ ps) = property $+  bmu == s `classify` p && gridMap s1 == gridMap 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 :: DSOMandTargets -> Property-prop_diffAndTrainEquiv (DSOMandTargets s ps _) = property $-  diffs == s `differences` p && sGridMap s1 == sGridMap s2+prop_diffAndTrainEquiv :: DSOMTestData -> Property+prop_diffAndTrainEquiv (DSOMTestData s _ ps) = property $+  diffs == s `differences` p && gridMap s1 == gridMap s2     where p = head ps           (diffs, s1) = diffAndTrain s p           s2 = train s p  --   Invoking @trainNeighbourhood s (classify s p) p@ should give --   identical results to @train s p@.-prop_trainNeighbourhoodEquiv :: DSOMandTargets -> Property-prop_trainNeighbourhoodEquiv (DSOMandTargets s ps _) = property $-  sGridMap s1 == sGridMap s2+prop_trainNeighbourhoodEquiv :: DSOMTestData -> Property+prop_trainNeighbourhoodEquiv (DSOMTestData s _ ps) = property $+  gridMap s1 == gridMap s2     where p = head ps           s1 = trainNeighbourhood s (classify s p) p           s2 = train s p@@ -193,49 +192,56 @@ -- | 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 :: DSOMandTargets -> Property-prop_batch_training_works (DSOMandTargets s xs _) = property $+prop_batch_training_works :: DSOMTestData -> Property+prop_batch_training_works (DSOMTestData 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 -data SpecialDSOMandTargets = SpecialDSOMandTargets (DSOM (LGridMap HexHexGrid) (Int, Int)-  TestPattern) [TestPattern] String+data SpecialDSOMTestData+  = SpecialDSOMTestData+    {+      som2 :: DSOM (LGridMap HexHexGrid) Double (Int, Int) TestPattern,+      params2 :: Double,+      trainingSet2 :: [TestPattern]+    } -instance Show SpecialDSOMandTargets where-  show (SpecialDSOMandTargets _ _ desc) = desc+instance Show SpecialDSOMTestData where+  show s = "buildDSOMTestData " ++ show (size . gridMap . som2 $ s)+    ++ " " ++ show (elems . gridMap . som2 $ s)+    ++ " (" ++ show (params2 s) +    ++ ") " ++ show (trainingSet2 s)   stepFunction :: Double -> Double -> Double -> Double -> Double stepFunction r _ _ d = if d == 0 then r else 0.0 -buildSpecialDSOMandTargets-  :: Int -> [TestPattern] -> Double -> [TestPattern] -> SpecialDSOMandTargets-buildSpecialDSOMandTargets len ps r targets =-  SpecialDSOMandTargets s targets desc+buildSpecialDSOMTestData+  :: Int -> [TestPattern] -> Double -> [TestPattern] -> SpecialDSOMTestData+buildSpecialDSOMTestData len ps r targets =+  SpecialDSOMTestData s r targets     where g = hexHexGrid len           gm = lazyGridMap g ps-          s = customDSOM gm (stepFunction r)-          desc = "buildSpecialDSOMandTargets " ++ show len ++ " "-            ++ show ps ++ " " ++ show r ++ " " ++ show targets+          fr = stepFunction r+          s = DSOM gm fr testPatternDiff adjustTestPattern  -- | Generate a classifier and a training set. The training set will --   consist @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.-sizedSpecialDSOMandTargets :: Int -> Gen SpecialDSOMandTargets-sizedSpecialDSOMandTargets n = do+sizedSpecialDSOMTestData :: Int -> Gen SpecialDSOMTestData+sizedSpecialDSOMTestData n = do   sideLength <- choose (1, min (n+1) 5) --avoid long tests   let tileCount = 3*sideLength*(sideLength-1) + 1-  let ps = map MkPattern $ take tileCount [0,100..]+  let ps = map TestPattern $ take tileCount [0,100..]   r <- choose (0.001, 1)-  let targets = map MkPattern $ take tileCount [5,105..]-  return $ buildSpecialDSOMandTargets sideLength ps r targets+  let targets = map TestPattern $ take tileCount [5,105..]+  return $ buildSpecialDSOMTestData sideLength ps r targets -instance Arbitrary SpecialDSOMandTargets where-  arbitrary = sized sizedSpecialDSOMandTargets+instance Arbitrary SpecialDSOMTestData where+  arbitrary = sized sizedSpecialDSOMTestData  -- | 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@@ -243,12 +249,12 @@ --   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 :: SpecialDSOMandTargets -> Property-prop_batch_training_works2 (SpecialDSOMandTargets s xs _) =+prop_batch_training_works2 :: SpecialDSOMTestData -> Property+prop_batch_training_works2 (SpecialDSOMTestData s _ xs) =   errBefore /= 0 ==> errAfter < errBefore     where s' = trainBatch s xs-          errBefore = absDiff (sort xs) (sort (models s))-          errAfter = absDiff (sort xs) (sort (models s'))+          errBefore = euclideanDistanceSquared (map toDouble . sort $ xs) (map toDouble . sort . models $ s)+          errAfter = euclideanDistanceSquared (map toDouble . sort $ xs) (map toDouble . sort . models $ s')  test :: Test test = testGroup "QuickCheck Data.Datamining.Clustering.DSOM"

@@ -1,7 +1,7 @@ ------------------------------------------------------------------------ -- | -- Module      :  Data.Datamining.Clustering.SOMQC--- Copyright   :  (c) Amy de Buitléir 2012-2014+-- Copyright   :  (c) Amy de Buitléir 2012-2015 -- License     :  BSD-style -- Maintainer  :  amy@nualeargais.ie -- Stability   :  experimental@@ -19,18 +19,17 @@     test   ) where -import Data.Datamining.Pattern (Pattern, Metric, difference,-  euclideanDistanceSquared, magnitudeSquared, makeSimilar)+import Data.Datamining.Pattern (euclideanDistanceSquared,+  magnitudeSquared, adjustNum, absDifference) import Data.Datamining.Clustering.Classifier(classify,   classifyAndTrain, reportAndTrain, differences, diffAndTrain, models,   numModels, train, trainBatch) import Data.Datamining.Clustering.SOMInternal -import Control.Applicative-import Data.Function (on) import Data.List (sort)+import Math.Geometry.Grid (size) import Math.Geometry.Grid.Hexagonal (HexHexGrid, hexHexGrid)-import Math.Geometry.GridMap ((!))+import Math.Geometry.GridMap ((!), elems) import Math.Geometry.GridMap.Lazy (LGridMap, lazyGridMap) import System.Random (Random) import Test.Framework as TF (Test, testGroup)@@ -38,101 +37,59 @@ import Test.QuickCheck ((==>), Gen, Arbitrary, arbitrary, choose,   Property, property, sized, suchThat, vectorOf) --- data GaussianArgs = GaussianArgs Double Double Int deriving Show- positive :: (Num a, Ord a, Arbitrary a) => Gen a positive = arbitrary `suchThat` (> 0) --- instance Arbitrary GaussianArgs where---   arbitrary = GaussianArgs <$> choose (0,1) <*> positive <*> positive---- arbDecayingGaussian :: Gen (DecayingGaussian--- prop_decayingGaussian_small_after_tMax :: GaussianArgs -> Property--- prop_decayingGaussian_small_after_tMax (GaussianArgs r w0 tMax) =---   property $ decayingGaussian r w0 tMax (tMax+1) 0 < exp(-1)---- prop_decayingGaussian_small_far_from_bmu :: GaussianArgs -> Property--- prop_decayingGaussian_small_far_from_bmu (GaussianArgs r w0 tMax)---   = property $---       decayingGaussian r w0 tMax 0 (2*(ceiling w0)) < r * exp(-1)+data DecayingGaussianParams a = DecayingGaussianParams a a a a a+  deriving (Eq, Show)  instance   (Random a, Num a, Ord a, Arbitrary a)-  => Arbitrary (DecayingGaussian a) where+  => Arbitrary (DecayingGaussianParams a) where   arbitrary = do     r0 <- choose (0,1)     rf <- choose (0,r0)     w0 <- positive     wf <- choose (0,w0)     tf <- positive-    return $ DecayingGaussian r0 rf w0 wf tf+    return $ DecayingGaussianParams r0 rf w0 wf tf  prop_DecayingGaussian_starts_at_r0-  :: DecayingGaussian Double -> Property-prop_DecayingGaussian_starts_at_r0 f@(DecayingGaussian r0 _ _ _ _)-  = property $ abs ((rate f 0 0) - r0) < 0.01+  :: DecayingGaussianParams Double -> Property+prop_DecayingGaussian_starts_at_r0 (DecayingGaussianParams r0 rf w0 wf tf)+  = property $ abs ((decayingGaussian r0 rf w0 wf tf 0 0) - r0) < 0.01  prop_DecayingGaussian_starts_at_w0-  :: DecayingGaussian Double -> Property-prop_DecayingGaussian_starts_at_w0 f@(DecayingGaussian r0 _ w0 _ _)+  :: DecayingGaussianParams Double -> Property+prop_DecayingGaussian_starts_at_w0 (DecayingGaussianParams r0 rf w0 wf tf)   = property $-    rate f 0 inside >= r0 * exp (-0.5) && rate f 0 outside < r0 * exp (-0.5)+    decayingGaussian r0 rf w0 wf tf 0 inside >= r0 * exp (-0.5)+      && decayingGaussian r0 rf w0 wf tf 0 outside < r0 * exp (-0.5)   where inside = w0 - 0.001         outside = w0 + 0.001  prop_DecayingGaussian_decays_to_rf-  :: DecayingGaussian Double -> Property-prop_DecayingGaussian_decays_to_rf f@(DecayingGaussian _ rf _ _ tf)-  = property $ abs ((rate f tf 0) - rf) < 0.01+  :: DecayingGaussianParams Double -> Property+prop_DecayingGaussian_decays_to_rf (DecayingGaussianParams r0 rf w0 wf tf)+  = property $ abs ((decayingGaussian r0 rf w0 wf tf tf 0) - rf) < 0.01  prop_DecayingGaussian_shrinks_to_wf-  :: DecayingGaussian Double -> Property-prop_DecayingGaussian_shrinks_to_wf f@(DecayingGaussian _ rf _ wf tf)+  :: DecayingGaussianParams Double -> Property+prop_DecayingGaussian_shrinks_to_wf (DecayingGaussianParams r0 rf w0 wf tf)   = property $-    rate f tf inside >= rf * exp (-0.5) && rate f tf outside < rf * exp (-0.5)+    decayingGaussian r0 rf w0 wf tf tf inside >= rf * exp (-0.5)+      && decayingGaussian r0 rf w0 wf tf tf outside < rf * exp (-0.5)   where inside = wf - 0.001         outside = wf + 0.001 -newtype TestPattern = MkPattern Double deriving Show--instance Eq TestPattern where-  (==) = (==) `on` toDouble--instance Ord TestPattern where-  compare = compare `on` toDouble--instance Pattern TestPattern where-  type Metric TestPattern = Double-  difference (MkPattern a) (MkPattern b) = abs (a - b)-  makeSimilar orig@(MkPattern a) r (MkPattern b)-    | r < 0     = error "Negative learning rate"-    | r > 1     = error "Learning rate > 1"-    | r == 1     = orig-    | otherwise = MkPattern (b + delta)-        where diff = a - b-              delta = r*diff--instance Arbitrary TestPattern where-  arbitrary = MkPattern <$> arbitrary--toDouble :: TestPattern -> Double-toDouble (MkPattern a) = a--absDiff :: [TestPattern] -> [TestPattern] -> Double-absDiff xs ys = euclideanDistanceSquared xs' ys'-  where xs' = map toDouble xs-        ys' = map toDouble ys--fractionDiff :: [TestPattern] -> [TestPattern] -> Double+fractionDiff :: [Double] -> [Double] -> Double fractionDiff xs ys = if denom == 0 then 0 else d / denom-  where d = sqrt $ euclideanDistanceSquared xs' ys'+  where d = sqrt $ euclideanDistanceSquared xs ys         denom = max xMag yMag-        xMag = sqrt $ magnitudeSquared xs'-        yMag = sqrt $ magnitudeSquared ys'-        xs' = map toDouble xs-        ys' = map toDouble ys+        xMag = sqrt $ magnitudeSquared xs+        yMag = sqrt $ magnitudeSquared ys -approxEqual :: [TestPattern] -> [TestPattern] -> Bool+approxEqual :: [Double] -> [Double] -> Bool approxEqual xs ys = fractionDiff xs ys <= 0.1  -- | A classifier and a training set. The training set will consist of@@ -140,22 +97,32 @@ --   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 SOMandTargets = SOMandTargets (SOM (DecayingGaussian Double)-  Int (LGridMap HexHexGrid) (Int, Int) TestPattern) [TestPattern]-    deriving (Eq, Show)+data SOMTestData+  = SOMTestData+    {+      som1 :: SOM Double Double (LGridMap HexHexGrid) Double (Int, Int) Double,+      params1 :: DecayingGaussianParams Double,+      trainingSet1 :: [Double]+    } -buildSOMandTargets-  :: Int -> [TestPattern] -> Double -> Double -> Double -> Double -> Int-     -> [TestPattern] -> SOMandTargets-buildSOMandTargets len ps r0 rf w0 wf tf targets =-  SOMandTargets s targets+instance Show SOMTestData where+  show s = "buildSOMTestData " ++ show (size . gridMap . som1 $ s)+    ++ " " ++ show (elems . gridMap . som1 $ s)+    ++ " (" ++ show (params1 s) +    ++ ") " ++ show (trainingSet1 s) ++buildSOMTestData+  :: Int -> [Double] -> DecayingGaussianParams Double+     -> [Double] -> SOMTestData+buildSOMTestData len ps p@(DecayingGaussianParams r0 rf w0 wf tf) targets =+  SOMTestData s p targets     where g = hexHexGrid len           gm = lazyGridMap g ps-          tf' = fromIntegral tf-          s = SOM gm (DecayingGaussian r0 rf w0 wf tf') 0+          fr = decayingGaussian r0 rf w0 wf tf+          s = SOM gm fr absDifference adjustNum 0 -sizedSOMandTargets :: Int -> Gen SOMandTargets-sizedSOMandTargets n = do+sizedSOMTestData :: Int -> Gen SOMTestData+sizedSOMTestData n = do   sideLength <- choose (1, min (n+1) 5) --avoid long tests   let tileCount = 3*sideLength*(sideLength-1) + 1   let numberOfPatterns = tileCount@@ -166,37 +133,37 @@   wf <- choose (0, w0)   tf <- choose (1, 10)   targets <- vectorOf numberOfPatterns arbitrary-  return $ buildSOMandTargets sideLength ps r0 rf w0 wf tf targets+  return $ buildSOMTestData sideLength ps (DecayingGaussianParams r0 rf w0 wf tf) targets -instance Arbitrary SOMandTargets where-  arbitrary = sized sizedSOMandTargets+instance Arbitrary SOMTestData where+  arbitrary = sized sizedSOMTestData  -- | If we use a fixed learning rate of one (regardless of the distance --   from the BMU), and train a classifier once on one pattern, then all --   nodes should match the input vector.-prop_global_instant_training_works :: SOMandTargets -> Property-prop_global_instant_training_works (SOMandTargets s xs) =+prop_global_instant_training_works :: SOMTestData -> Property+prop_global_instant_training_works (SOMTestData s _ xs) =   property $ finalModels `approxEqual` expectedModels     where x = head xs-          gm = toGridMap s :: LGridMap HexHexGrid TestPattern-          f = (ConstantFunction 1)-          s2 = SOM gm f 0+          gm = toGridMap s :: LGridMap HexHexGrid Double+          f _ _ = 1+          s2 = SOM gm f absDifference adjustNum 0           s3 = train s2 x-          finalModels = models s3 :: [TestPattern]-          expectedModels = replicate (numModels s) x :: [TestPattern]+          finalModels = models s3 :: [Double]+          expectedModels = replicate (numModels s) x :: [Double] -prop_training_reduces_error :: SOMandTargets -> Property-prop_training_reduces_error (SOMandTargets s xs) = errBefore /= 0 ==>+prop_training_reduces_error :: SOMTestData -> Property+prop_training_reduces_error (SOMTestData s _ xs) = errBefore /= 0 ==>   errAfter < errBefore     where (bmu, s') = classifyAndTrain s x           x = head xs-          errBefore = abs $ toDouble x - toDouble (gridMap s ! bmu)-          errAfter = abs $ toDouble x - toDouble (gridMap s' ! bmu)+          errBefore = abs $ x - (gridMap s ! bmu)+          errAfter = abs $ x - (gridMap s' ! bmu)  --   Invoking @diffAndTrain f s p@ should give identical results to --   @(p `classify` s, train s f p)@.-prop_classifyAndTrainEquiv :: SOMandTargets -> Property-prop_classifyAndTrainEquiv (SOMandTargets s ps) = property $+prop_classifyAndTrainEquiv :: SOMTestData -> Property+prop_classifyAndTrainEquiv (SOMTestData s _ ps) = property $   bmu == s `classify` p && gridMap s1 == gridMap s2     where p = head ps           (bmu, s1) = classifyAndTrain s p@@ -204,8 +171,8 @@  --   Invoking @diffAndTrain f s p@ should give identical results to --   @(s `diff` p, train s f p)@.-prop_diffAndTrainEquiv :: SOMandTargets -> Property-prop_diffAndTrainEquiv (SOMandTargets s ps) = property $+prop_diffAndTrainEquiv :: SOMTestData -> Property+prop_diffAndTrainEquiv (SOMTestData s _ ps) = property $   diffs == s `differences` p && gridMap s1 == gridMap s2     where p = head ps           (diffs, s1) = diffAndTrain s p@@ -213,8 +180,8 @@  --   Invoking @trainNeighbourhood s (classify s p) p@ should give --   identical results to @train s p@.-prop_trainNeighbourhoodEquiv :: SOMandTargets -> Property-prop_trainNeighbourhoodEquiv (SOMandTargets s ps) = property $+prop_trainNeighbourhoodEquiv :: SOMTestData -> Property+prop_trainNeighbourhoodEquiv (SOMTestData s _ ps) = property $   gridMap s1 == gridMap s2     where p = head ps           s1 = trainNeighbourhood s (classify s p) p@@ -223,8 +190,8 @@ -- | 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 :: SOMandTargets -> Property-prop_batch_training_works (SOMandTargets s xs) = property $+prop_batch_training_works :: SOMTestData -> Property+prop_batch_training_works (SOMTestData s _ xs) = property $   classifications == (concat . replicate 5) firstSet   where trainingSet = (concat . replicate 5) xs         s' = trainBatch s trainingSet@@ -233,41 +200,51 @@  -- | WARNING: This can fail when two nodes are close enough in --   value so that after training they become identical.+--   This only happens rarely, so if the test fails, try again. prop_classification_is_consistent-  :: SOMandTargets -> Property-prop_classification_is_consistent (SOMandTargets s (x:_))+  :: SOMTestData -> Property+prop_classification_is_consistent (SOMTestData 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 SOMandTargets, except that the initial models and training+-- | Same as SOMTestData, 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 SpecialSOMandTargets = SpecialSOMandTargets (SOM-  (StepFunction Double) Int (LGridMap HexHexGrid) (Int, Int)-  TestPattern) [TestPattern]-    deriving (Eq, Show)+data SpecialSOMTestData+  = SpecialSOMTestData+    {+      som2 :: SOM Int Int (LGridMap HexHexGrid) Double (Int, Int) Double,+      params2 :: Double,+      trainingSet2 :: [Double]+    } -buildSpecialSOMandTargets-  :: Int -> [TestPattern] -> Double -> [TestPattern] -> SpecialSOMandTargets-buildSpecialSOMandTargets len ps r targets =-  SpecialSOMandTargets s targets+instance Show SpecialSOMTestData where+  show s = "buildSpecialSOMTestData " ++ show (size . gridMap . som2 $ s)+    ++ " " ++ show (elems . gridMap . som2 $ s)+    ++ " " ++ show (params2 s) +    ++ " " ++ show (trainingSet2 s) ++buildSpecialSOMTestData+  :: Int -> [Double] -> Double -> [Double] -> SpecialSOMTestData+buildSpecialSOMTestData len ps r targets =+  SpecialSOMTestData s r targets     where g = hexHexGrid len           gm = lazyGridMap g ps-          s = SOM gm (StepFunction r) 0+          s = SOM gm (stepFunction r) absDifference adjustNum 0 -sizedSpecialSOMandTargets :: Int -> Gen SpecialSOMandTargets-sizedSpecialSOMandTargets n = do+sizedSpecialSOMTestData :: Int -> Gen SpecialSOMTestData+sizedSpecialSOMTestData n = do   sideLength <- choose (1, min (n+1) 5) --avoid long tests   let tileCount = 3*sideLength*(sideLength-1) + 1-  let ps = map MkPattern $ take tileCount [0,100..]+  let ps = take tileCount [0,100..]   r <- choose (0.001, 1)-  let targets = map MkPattern $ take tileCount [5,105..]-  return $ buildSpecialSOMandTargets sideLength ps r targets+  let targets = take tileCount [5,105..]+  return $ buildSpecialSOMTestData sideLength ps r targets -instance Arbitrary SpecialSOMandTargets where-  arbitrary = sized sizedSpecialSOMandTargets+instance Arbitrary SpecialSOMTestData where+  arbitrary = sized sizedSpecialSOMTestData  -- | 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@@ -275,30 +252,40 @@ --   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 :: SpecialSOMandTargets -> Property-prop_batch_training_works2 (SpecialSOMandTargets s xs) =+prop_batch_training_works2 :: SpecialSOMTestData -> Property+prop_batch_training_works2 (SpecialSOMTestData s _ xs) =   errBefore /= 0 ==> errAfter < errBefore     where s' = trainBatch s xs-          errBefore = absDiff (sort xs) (sort (models s))-          errAfter = absDiff (sort xs) (sort (models s'))+          errBefore = euclideanDistanceSquared (sort xs) (sort (models s))+          errAfter = euclideanDistanceSquared (sort xs) (sort (models s')) -data IncompleteSOMandTargets = IncompleteSOMandTargets (SOM-  (DecayingGaussian Double) Int (LGridMap HexHexGrid) (Int, Int)-  TestPattern) [TestPattern] deriving Show+data IncompleteSOMTestData+  = IncompleteSOMTestData+    {+      som3 :: SOM Double Double (LGridMap HexHexGrid) Double (Int, Int) Double,+      params3 :: DecayingGaussianParams Double,+      trainingSet3 :: [Double]+    } -buildIncompleteSOMandTargets-  :: Int -> [TestPattern] -> Double -> Double -> Double -> Double -> Int-     -> [TestPattern] -> IncompleteSOMandTargets-buildIncompleteSOMandTargets len ps r0 rf w0 wf tf targets =-  IncompleteSOMandTargets s targets+instance Show IncompleteSOMTestData where+  show s = "buildIncompleteSOMTestData " ++ show (size . gridMap . som3 $ s)+    ++ " " ++ show (elems . gridMap . som3 $ s)+    ++ " " ++ show (params3 s) +    ++ " " ++ show (trainingSet3 s) ++buildIncompleteSOMTestData+  :: Int -> [Double] -> DecayingGaussianParams Double+     -> [Double] -> IncompleteSOMTestData+buildIncompleteSOMTestData len ps p@(DecayingGaussianParams r0 rf w0 wf tf) targets =+  IncompleteSOMTestData s p targets     where g = hexHexGrid len           gm = lazyGridMap g ps-          tf' = fromIntegral tf-          s = SOM gm (DecayingGaussian r0 rf w0 wf tf') 0+          fr = decayingGaussian r0 rf w0 wf tf+          s = SOM gm fr absDifference adjustNum 0 --- | Same as sizedSOMandTargets, except some nodes don't have a value.-sizedIncompleteSOMandTargets :: Int -> Gen IncompleteSOMandTargets-sizedIncompleteSOMandTargets n = do+-- | Same as sizedSOMTestData, except some nodes don't have a value.+sizedIncompleteSOMTestData :: Int -> Gen IncompleteSOMTestData+sizedIncompleteSOMTestData n = do   sideLength <- choose (2, min (n+2) 5) --avoid long tests   let tileCount = 3*sideLength*(sideLength-1) + 1   numberOfPatterns <- choose (1,tileCount-1)@@ -309,18 +296,18 @@   wf <- choose (0, w0)   tf <- choose (1, 10)   targets <- vectorOf numberOfPatterns arbitrary-  return $ buildIncompleteSOMandTargets sideLength ps r0 rf w0 wf tf targets+  return $ buildIncompleteSOMTestData sideLength ps (DecayingGaussianParams r0 rf w0 wf tf) targets -instance Arbitrary IncompleteSOMandTargets where-  arbitrary = sized sizedIncompleteSOMandTargets+instance Arbitrary IncompleteSOMTestData where+  arbitrary = sized sizedIncompleteSOMTestData -prop_can_train_incomplete_SOM :: IncompleteSOMandTargets -> Property-prop_can_train_incomplete_SOM (IncompleteSOMandTargets s xs) = errBefore /= 0 ==>+prop_can_train_incomplete_SOM :: IncompleteSOMTestData -> Property+prop_can_train_incomplete_SOM (IncompleteSOMTestData s _ xs) = errBefore /= 0 ==>   errAfter < errBefore     where (bmu, s') = classifyAndTrain s x           x = head xs-          errBefore = abs $ toDouble x - toDouble (gridMap s ! bmu)-          errAfter = abs $ toDouble x - toDouble (gridMap s' ! bmu)+          errBefore = abs $ x - (gridMap s ! bmu)+          errAfter = abs $ x - (gridMap s' ! bmu)  test :: Test test = testGroup "QuickCheck Data.Datamining.Clustering.SOM"

@@ -1,7 +1,7 @@ ------------------------------------------------------------------------ -- | -- Module      :  Data.Datamining.Clustering.SSOMQC--- Copyright   :  (c) Amy de Buitléir 2012-2014+-- Copyright   :  (c) Amy de Buitléir 2012-2015 -- License     :  BSD-style -- Maintainer  :  amy@nualeargais.ie -- Stability   :  experimental@@ -19,115 +19,102 @@     test   ) where -import Data.Datamining.Pattern (Pattern, Metric, difference,-  euclideanDistanceSquared, makeSimilar)+import Data.Datamining.Pattern (euclideanDistanceSquared, adjustNum,+  absDifference) import Data.Datamining.Clustering.Classifier(classify,   classifyAndTrain, reportAndTrain, differences, diffAndTrain, models,   train, trainBatch) import Data.Datamining.Clustering.SSOMInternal import qualified Data.Map.Strict as M -import Control.Applicative-import Data.Function (on) 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, arbitrary, choose,-  Property, property, sized, suchThat, vectorOf)+import Test.QuickCheck ((==>), Gen, Arbitrary, Property, Positive,+  arbitrary, shrink, choose, property, sized, suchThat, vectorOf,+  getPositive) -positive :: (Num a, Ord a, Arbitrary a) => Gen a-positive = arbitrary `suchThat` (> 0)+newtype UnitInterval a = UnitInterval {getUnitInterval :: a}+ deriving ( Eq, Ord, Show, Read) -instance-  (Random a, Num a, Ord a, Arbitrary a)-  => Arbitrary (Exponential a) where-  arbitrary = do-    r0 <- choose (0,1)-    d <- positive-    return $ Exponential r0 d+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-  :: Exponential Double -> Property-prop_Exponential_starts_at_r0 f@(Exponential r0 _)-  = property $ abs (rate f 0 - r0) < 0.01+  :: 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-  :: Exponential Double -> Double -> Property-prop_Exponential_ge_0 f t-  = property $ rate f t' >= 0-  where t' = abs t--newtype TestPattern = MkPattern Double deriving Show--instance Eq TestPattern where-  (==) = (==) `on` toDouble--instance Ord TestPattern where-  compare = compare `on` toDouble--instance Pattern TestPattern where-  type Metric TestPattern = Double-  difference (MkPattern a) (MkPattern b) = abs (a - b)-  makeSimilar orig@(MkPattern a) r (MkPattern b)-    | r < 0     = error "Negative learning rate"-    | r > 1     = error "Learning rate > 1"-    | r == 1     = orig-    | otherwise = MkPattern (b + delta)-        where diff = a - b-              delta = r*diff--instance Arbitrary TestPattern where-  arbitrary = MkPattern <$> arbitrary--toDouble :: TestPattern -> Double-toDouble (MkPattern a) = a+  :: 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 -absDiff :: [TestPattern] -> [TestPattern] -> Double-absDiff xs ys = euclideanDistanceSquared xs' ys'-  where xs' = map toDouble xs-        ys' = map toDouble ys+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 SSOMandTargets = SSOMandTargets (SSOM (Exponential Double)-  Int Int TestPattern) [TestPattern]-    deriving (Eq, Show)+data SSOMTestData+  = SSOMTestData+    {+      som1 :: SSOM Double Double Int Double,+      learningRateDesc1 :: String,+      trainingSet1 :: [Double]+    } -buildSSOMandTargets-  :: [TestPattern] -> Double -> Double -> [TestPattern] -> SSOMandTargets-buildSSOMandTargets ps r0 d targets =-  SSOMandTargets s targets+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-          s = SSOM gm (Exponential r0 d) 0+          lrf = exponential r0 d+          s = SSOM gm lrf absDifference adjustNum 0+          desc = show r0 ++ " " ++ show d -sizedSSOMandTargets :: Int -> Gen SSOMandTargets-sizedSSOMandTargets n = do+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 $ buildSSOMandTargets ps r0 d targets+  return $ buildSSOMTestData ps r0 d targets -instance Arbitrary SSOMandTargets where-  arbitrary = sized sizedSSOMandTargets+instance Arbitrary SSOMTestData where+  arbitrary = sized sizedSSOMTestData -prop_training_reduces_error :: SSOMandTargets -> Property-prop_training_reduces_error (SSOMandTargets s xs) = errBefore /= 0 ==>+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 $ toDouble x - toDouble (toMap s M.! bmu)-          errAfter = abs $ toDouble x - toDouble (toMap s' M.! bmu)+          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 :: SSOMandTargets -> Property-prop_classifyAndTrainEquiv (SSOMandTargets s ps) = property $+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@@ -135,8 +122,8 @@  --   Invoking @diffAndTrain f s p@ should give identical results to --   @(s `diff` p, train s f p)@.-prop_diffAndTrainEquiv :: SSOMandTargets -> Property-prop_diffAndTrainEquiv (SSOMandTargets s ps) = property $+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@@ -144,8 +131,8 @@  --   Invoking @trainNode s (classify s p) p@ should give --   identical results to @train s p@.-prop_trainNodeEquiv :: SSOMandTargets -> Property-prop_trainNodeEquiv (SSOMandTargets s ps) = property $+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@@ -154,8 +141,8 @@ -- | 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 :: SSOMandTargets -> Property-prop_batch_training_works (SSOMandTargets s xs) = property $+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@@ -164,39 +151,50 @@  -- | WARNING: This can fail when two nodes are close enough in --   value so that after training they become identical.-prop_classification_is_consistent :: SSOMandTargets -> Property-prop_classification_is_consistent (SSOMandTargets s (x:_))+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 SSOMandTargets, except that the initial models and training+-- | 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 SpecialSSOMandTargets = SpecialSSOMandTargets (SSOM-  (Exponential Double) Int Int TestPattern) [TestPattern]-    deriving (Eq, Show)+data SpecialSSOMTestData+  = SpecialSSOMTestData+    {+      som2 :: SSOM Double Double Int Double,+      learningRateDesc2 :: String,+      trainingSet2 :: [Double]+    } -buildSpecialSSOMandTargets-  :: [TestPattern] -> Double -> Double -> [TestPattern]-    -> SpecialSSOMandTargets-buildSpecialSSOMandTargets ps r0 d targets =-  SpecialSSOMandTargets s targets+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-          s = SSOM gm (Exponential r0 d) 0+          lrf = exponential r0 d+          s = SSOM gm lrf absDifference adjustNum 0+          desc = show r0 ++ " " ++ show d -sizedSpecialSSOMandTargets :: Int -> Gen SpecialSSOMandTargets-sizedSpecialSSOMandTargets n = do+sizedSpecialSSOMTestData :: Int -> Gen SpecialSSOMTestData+sizedSpecialSSOMTestData n = do   let len = n + 1-  let ps = map MkPattern $ take len [0,100..]+  let ps = take len [0,100..]   r0 <- choose (0, 1)   d <- positive-  let targets = map MkPattern $ take len [5,105..]-  return $ buildSpecialSSOMandTargets ps r0 d targets+  let targets = take len [5,105..]+  return $ buildSpecialSSOMTestData ps r0 d targets -instance Arbitrary SpecialSSOMandTargets where-  arbitrary = sized sizedSpecialSSOMandTargets+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@@ -204,44 +202,56 @@ --   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 :: SpecialSSOMandTargets -> Property-prop_batch_training_works2 (SpecialSSOMandTargets s xs) =+prop_batch_training_works2 :: SpecialSSOMTestData -> Property+prop_batch_training_works2 (SpecialSSOMTestData s _ xs) =   errBefore /= 0 ==> errAfter < errBefore     where s' = trainBatch s xs-          errBefore = absDiff (sort xs) (sort (models s))-          errAfter = absDiff (sort xs) (sort (models s'))+          errBefore = euclideanDistanceSquared (sort xs) (sort (models s))+          errAfter = euclideanDistanceSquared (sort xs) (sort (models s')) -data IncompleteSSOMandTargets = IncompleteSSOMandTargets (SSOM-  (Exponential Double) Int Int TestPattern) [TestPattern] deriving Show+-- | Same as sizedSSOMTestData, except some nodes don't have a value.+data IncompleteSSOMTestData+  = IncompleteSSOMTestData+    {+      som3 :: SSOM Double Double Int Double,+      learningRateDesc3 :: String,+      trainingSet3 :: [Double]+    } -buildIncompleteSSOMandTargets-  :: [TestPattern] -> Double -> Double -> [TestPattern]-    -> IncompleteSSOMandTargets-buildIncompleteSSOMandTargets ps r0 d targets =-  IncompleteSSOMandTargets s targets+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-          s = SSOM gm (Exponential r0 d) 0+          lrf = exponential r0 d+          s = SSOM gm lrf absDifference adjustNum 0+          desc = show r0 ++ " " ++ show d --- | Same as sizedSSOMandTargets, except some nodes don't have a value.-sizedIncompleteSSOMandTargets :: Int -> Gen IncompleteSSOMandTargets-sizedIncompleteSSOMandTargets n = do+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 $ buildIncompleteSSOMandTargets ps r0 d targets+  return $ buildIncompleteSSOMTestData ps r0 d targets -instance Arbitrary IncompleteSSOMandTargets where-  arbitrary = sized sizedIncompleteSSOMandTargets+instance Arbitrary IncompleteSSOMTestData where+  arbitrary = sized sizedIncompleteSSOMTestData -prop_can_train_incomplete_SSOM :: IncompleteSSOMandTargets -> Property-prop_can_train_incomplete_SSOM (IncompleteSSOMandTargets s xs) = errBefore /= 0 ==>+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 $ toDouble x - toDouble (toMap s M.! bmu)-          errAfter = abs $ toDouble x - toDouble (toMap s' M.! bmu)+          errBefore = abs $ x - (toMap s M.! bmu)+          errAfter = abs $ x - (toMap s' M.! bmu)  test :: Test test = testGroup "QuickCheck Data.Datamining.Clustering.SSOM"

@@ -1,7 +1,7 @@ ------------------------------------------------------------------------ -- | -- Module      :  Data.Datamining.PatternQC--- Copyright   :  (c) Amy de Buitléir 2012-2014+-- Copyright   :  (c) Amy de Buitléir 2012-2015 -- License     :  BSD-style -- Maintainer  :  amy@nualeargais.ie -- Stability   :  experimental

@@ -1,7 +1,7 @@ ------------------------------------------------------------------------ -- | -- Module      :  Main--- Copyright   :  (c) Amy de Buitléir 2012-2014+-- Copyright   :  (c) Amy de Buitléir 2012-2015 -- License     :  BSD-style -- Maintainer  :  amy@nualeargais.ie -- Stability   :  experimental