packages feed

som 7.4.1 → 7.5.0

raw patch · 7 files changed

+998/−8 lines, 7 filesdep ~gridPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: grid

API changes (from Hackage documentation)

+ Data.Datamining.Clustering.DSOMInternal: withGridMap :: (gm p -> gm p) -> DSOM gm k p -> DSOM gm k p
+ Data.Datamining.Clustering.SOMInternal: withGridMap :: (gm p -> gm p) -> SOM f t gm k p -> SOM f t gm k p

Files

som.cabal view
@@ -1,5 +1,5 @@ Name:              som-Version:           7.4.1+Version:           7.5.0 Stability:         experimental Synopsis:          Self-Organising Maps. Description:       A Kohonen Self-organising Map (SOM) maps input patterns @@ -33,14 +33,14 @@ source-repository this   type:     git   location: https://github.com/mhwombat/som.git-  tag:      7.4.1+  tag:      7.5.0   library   hs-source-dirs:  src   build-depends:   base ==4.*,                    containers ==0.5.*,-                   grid ==7.*,+                   grid ==7.* && >=7.7,                    MonadRandom ==0.3.*   ghc-options:     -Wall   exposed-modules: Data.Datamining.Clustering.SOM,@@ -60,10 +60,14 @@                    test-framework ==0.8.*,                    som,                    containers ==0.5.*,-                   grid ==7.*,+                   grid ==7.* && >=7.7,                    MonadRandom ==0.3.*,                    random ==1.1.*   hs-source-dirs:  test   ghc-options:     -Wall   main-is:         Main.hs+  other-modules:   Data.Datamining.Clustering.SOMQC,+                   Data.Datamining.Clustering.DSOMQC,+                   Data.Datamining.Clustering.SSOMQC,+                   Data.Datamining.PatternQC
src/Data/Datamining/Clustering/DSOMInternal.hs view
@@ -67,9 +67,16 @@   toGrid = GM.toGrid . sGridMap   toMap = GM.toMap . sGridMap   mapWithKey = error "Not implemented"-  adjustWithKey f k s = s { sGridMap=gm' }+  delete k = withGridMap (GM.delete k)+  adjustWithKey f k = withGridMap (GM.adjustWithKey f k)+  insertWithKey f k v = withGridMap (GM.insertWithKey f k v)+  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-          gm' = GM.adjustWithKey f k gm+          gm' = f gm  -- | Extracts the grid and current models from the DSOM. toGridMap :: GM.GridMap gm p => DSOM gm k p -> gm p
src/Data/Datamining/Clustering/SOMInternal.hs view
@@ -135,9 +135,16 @@   toGrid = GM.toGrid . gridMap   toMap = GM.toMap . gridMap   mapWithKey = error "Not implemented"-  adjustWithKey f k s = s { gridMap=gm' }+  delete k = withGridMap (GM.delete k)+  adjustWithKey f k = withGridMap (GM.adjustWithKey f k)+  insertWithKey f k v = withGridMap (GM.insertWithKey f k v)+  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 f s = s { gridMap=gm' }     where gm = gridMap s-          gm' = GM.adjustWithKey f k gm+          gm' = f gm  currentLearningFunction   :: (LearningFunction f, Metric p ~ LearningRate f,
+ test/Data/Datamining/Clustering/DSOMQC.hs view
@@ -0,0 +1,274 @@+------------------------------------------------------------------------+-- |+-- Module      :  Data.Datamining.Clustering.DSOMQC+-- Copyright   :  (c) Amy de Buitléir 2012-2014+-- License     :  BSD-style+-- Maintainer  :  amy@nualeargais.ie+-- Stability   :  experimental+-- Portability :  portable+--+-- Tests+--+------------------------------------------------------------------------+{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleInstances,+    FlexibleContexts #-}+{-# OPTIONS_GHC -fno-warn-type-defaults -fno-warn-orphans #-}++module Data.Datamining.Clustering.DSOMQC+  (+    test+  ) where++import Data.Datamining.Pattern (Pattern, Metric, difference,+  euclideanDistanceSquared, magnitudeSquared, makeSimilar)+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.Hexagonal (HexHexGrid, hexHexGrid)+import Math.Geometry.GridMap ((!))+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)++positive :: (Num a, Ord a, Arbitrary a) => Gen a+positive = arbitrary `suchThat` (> 0)++data RougierArgs+  = RougierArgs Double Double Double Double Double deriving Show++instance Arbitrary RougierArgs where+  arbitrary = RougierArgs <$> choose (0,1) <*> choose (0,1)+                <*> arbitrary <*> choose (0,1) <*> positive++prop_rougierFunction_zero_if_perfect_model_exists :: RougierArgs -> Property+prop_rougierFunction_zero_if_perfect_model_exists (RougierArgs r p _ diff dist) =+  property $ rougierLearningFunction r p 0 diff dist == 0++prop_rougierFunction_r_if_bmu_is_bad_model :: RougierArgs -> Property+prop_rougierFunction_r_if_bmu_is_bad_model (RougierArgs r p _ _ _) =+  property $ rougierLearningFunction r p 1 1 0 == r++prop_rougierFunction_r_in_bounds :: RougierArgs -> Property+prop_rougierFunction_r_in_bounds (RougierArgs r p bmuDiff diff dist) =+  property $ 0 <= f && f <= 1+  where f = rougierLearningFunction r p bmuDiff diff dist++prop_rougierFunction_r_if_inelastic :: RougierArgs -> Property+prop_rougierFunction_r_if_inelastic (RougierArgs r _ _ _ _) =+  property $ rougierLearningFunction r 1.0 1.0 1.0 0 == r++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 <$> 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++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++approxEqual :: [TestPattern] -> [TestPattern] -> Bool+approxEqual xs ys = fractionDiff xs ys <= 0.1++data DSOMandTargets = DSOMandTargets (DSOM (LGridMap HexHexGrid) (Int, Int)+  TestPattern) [TestPattern] String++instance Show DSOMandTargets where+  show (DSOMandTargets _ _ desc) = desc++buildDSOMandTargets+  :: Int -> [TestPattern] -> Double -> Double -> [TestPattern] -> DSOMandTargets+buildDSOMandTargets len ps r p targets = DSOMandTargets s targets desc+    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++-- | 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+  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)+  targets <- vectorOf numberOfPatterns arbitrary+  return $ buildDSOMandTargets sideLength ps r p targets++instance Arbitrary DSOMandTargets where+  arbitrary = sized sizedDSOMandTargets++-- | 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 _) =+  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+          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 ==>+  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)++--   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+    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+    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+    where p = head ps+          s1 = trainNeighbourhood s (classify s p) p+          s2 = train s p++-- | 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 $+  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++instance Show SpecialDSOMandTargets where+  show (SpecialDSOMandTargets _ _ desc) = desc++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+    where g = hexHexGrid len+          gm = lazyGridMap g ps+          s = customDSOM gm (stepFunction r)+          desc = "buildSpecialDSOMandTargets " ++ show len ++ " "+            ++ show ps ++ " " ++ show r ++ " " ++ show targets++-- | 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+  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..]+  r <- choose (0.001, 1)+  let targets = map MkPattern $ take tileCount [5,105..]+  return $ buildSpecialDSOMandTargets sideLength ps r targets++instance Arbitrary SpecialDSOMandTargets where+  arbitrary = sized sizedSpecialDSOMandTargets++-- | If we train a classifier once on a set of patterns, where the+--   number of patterns in the set is equal to the number of nodes in+--   the classifier, then the classifier should become a better+--   representation of the training set. The initial models and training+--   set are designed to ensure that a single node will NOT train to+--   more than one pattern (which would render the test invalid).+prop_batch_training_works2 :: SpecialDSOMandTargets -> Property+prop_batch_training_works2 (SpecialDSOMandTargets 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'))++test :: Test+test = testGroup "QuickCheck Data.Datamining.Clustering.DSOM"+  [+    testProperty "prop_rougierFunction_zero_if_perfect_model_exists"+      prop_rougierFunction_zero_if_perfect_model_exists,+    testProperty "prop_rougierFunction_r_if_bmu_is_bad_model"+      prop_rougierFunction_r_if_bmu_is_bad_model,+    testProperty "prop_rougierFunction_r_if_inelastic"+      prop_rougierFunction_r_if_inelastic,+    testProperty "prop_rougierFunction_r_in_bounds"+      prop_rougierFunction_r_in_bounds,+    testProperty "prop_global_instant_training_works"+      prop_global_instant_training_works,+    testProperty "prop_training_works" prop_training_works,+    testProperty "prop_classifyAndTrainEquiv"+      prop_classifyAndTrainEquiv,+    testProperty "prop_diffAndTrainEquiv" prop_diffAndTrainEquiv,+    testProperty "prop_trainNeighbourhoodEquiv" prop_trainNeighbourhoodEquiv,+    testProperty "prop_batch_training_works" prop_batch_training_works,+    testProperty "prop_batch_training_works2"+      prop_batch_training_works2+  ]
+ test/Data/Datamining/Clustering/SOMQC.hs view
@@ -0,0 +1,351 @@+------------------------------------------------------------------------+-- |+-- Module      :  Data.Datamining.Clustering.SOMQC+-- Copyright   :  (c) Amy de Buitléir 2012-2014+-- License     :  BSD-style+-- Maintainer  :  amy@nualeargais.ie+-- Stability   :  experimental+-- Portability :  portable+--+-- Tests+--+------------------------------------------------------------------------+{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleInstances,+    FlexibleContexts #-}+{-# OPTIONS_GHC -fno-warn-type-defaults -fno-warn-orphans #-}++module Data.Datamining.Clustering.SOMQC+  (+    test+  ) where++import Data.Datamining.Pattern (Pattern, Metric, difference,+  euclideanDistanceSquared, magnitudeSquared, makeSimilar)+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.Hexagonal (HexHexGrid, hexHexGrid)+import Math.Geometry.GridMap ((!))+import Math.Geometry.GridMap.Lazy (LGridMap, lazyGridMap)+import System.Random (Random)+import Test.Framework as TF (Test, testGroup)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.QuickCheck ((==>), Gen, Arbitrary, arbitrary, choose,+  Property, property, sized, suchThat, vectorOf)++-- 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)++instance+  (Random a, Num a, Ord a, Arbitrary a)+  => Arbitrary (DecayingGaussian 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++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++prop_DecayingGaussian_starts_at_w0+  :: DecayingGaussian Double -> Property+prop_DecayingGaussian_starts_at_w0 f@(DecayingGaussian r0 _ w0 _ _)+  = property $+    rate f 0 inside >= r0 * exp (-0.5) && rate f 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++prop_DecayingGaussian_shrinks_to_wf+  :: DecayingGaussian Double -> Property+prop_DecayingGaussian_shrinks_to_wf f@(DecayingGaussian _ rf _ wf tf)+  = property $+    rate f tf inside >= rf * exp (-0.5) && rate f 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 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++approxEqual :: [TestPattern] -> [TestPattern] -> Bool+approxEqual xs ys = fractionDiff xs ys <= 0.1++-- | 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 SOMandTargets = SOMandTargets (SOM (DecayingGaussian Double)+  Int (LGridMap HexHexGrid) (Int, Int) TestPattern) [TestPattern]+    deriving (Eq, Show)++buildSOMandTargets+  :: Int -> [TestPattern] -> Double -> Double -> Double -> Double -> Int+     -> [TestPattern] -> SOMandTargets+buildSOMandTargets len ps r0 rf w0 wf tf targets =+  SOMandTargets s targets+    where g = hexHexGrid len+          gm = lazyGridMap g ps+          tf' = fromIntegral tf+          s = SOM gm (DecayingGaussian r0 rf w0 wf tf') 0++sizedSOMandTargets :: Int -> Gen SOMandTargets+sizedSOMandTargets 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+  r0 <- choose (0, 1)+  rf <- choose (0, r0)+  w0 <- choose (0, fromIntegral sideLength)+  wf <- choose (0, w0)+  tf <- choose (1, 10)+  targets <- vectorOf numberOfPatterns arbitrary+  return $ buildSOMandTargets sideLength ps r0 rf w0 wf tf targets++instance Arbitrary SOMandTargets where+  arbitrary = sized sizedSOMandTargets++-- | 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) =+  property $ finalModels `approxEqual` expectedModels+    where x = head xs+          gm = toGridMap s :: LGridMap HexHexGrid TestPattern+          f = (ConstantFunction 1)+          s2 = SOM gm f 0+          s3 = train s2 x+          finalModels = models s3 :: [TestPattern]+          expectedModels = replicate (numModels s) x :: [TestPattern]++prop_training_reduces_error :: SOMandTargets -> Property+prop_training_reduces_error (SOMandTargets 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)++--   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 $+  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 :: SOMandTargets -> Property+prop_diffAndTrainEquiv (SOMandTargets 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 :: SOMandTargets -> Property+prop_trainNeighbourhoodEquiv (SOMandTargets s ps) = property $+  gridMap s1 == gridMap s2+    where p = head ps+          s1 = trainNeighbourhood s (classify s p) p+          s2 = train s p++-- | 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 $+  classifications == (concat . replicate 5) firstSet+  where trainingSet = (concat . replicate 5) xs+        s' = trainBatch s trainingSet+        classifications = map (classify s') trainingSet+        firstSet = take (length xs) classifications++-- | WARNING: This can fail when two nodes are close enough in+--   value so that after training they become identical.+prop_classification_is_consistent+  :: SOMandTargets -> Property+prop_classification_is_consistent (SOMandTargets 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+--   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)++buildSpecialSOMandTargets+  :: Int -> [TestPattern] -> Double -> [TestPattern] -> SpecialSOMandTargets+buildSpecialSOMandTargets len ps r targets =+  SpecialSOMandTargets s targets+    where g = hexHexGrid len+          gm = lazyGridMap g ps+          s = SOM gm (StepFunction r) 0++sizedSpecialSOMandTargets :: Int -> Gen SpecialSOMandTargets+sizedSpecialSOMandTargets 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..]+  r <- choose (0.001, 1)+  let targets = map MkPattern $ take tileCount [5,105..]+  return $ buildSpecialSOMandTargets sideLength ps r targets++instance Arbitrary SpecialSOMandTargets where+  arbitrary = sized sizedSpecialSOMandTargets++-- | If we train a classifier once on a set of patterns, where the+--   number of patterns in the set is equal to the number of nodes in+--   the classifier, then the classifier should become a better+--   representation of the training set. The initial models and training+--   set are designed to ensure that a single node will NOT train to+--   more than one pattern (which would render the test invalid).+prop_batch_training_works2 :: SpecialSOMandTargets -> Property+prop_batch_training_works2 (SpecialSOMandTargets 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'))++data IncompleteSOMandTargets = IncompleteSOMandTargets (SOM+  (DecayingGaussian Double) Int (LGridMap HexHexGrid) (Int, Int)+  TestPattern) [TestPattern] deriving Show++buildIncompleteSOMandTargets+  :: Int -> [TestPattern] -> Double -> Double -> Double -> Double -> Int+     -> [TestPattern] -> IncompleteSOMandTargets+buildIncompleteSOMandTargets len ps r0 rf w0 wf tf targets =+  IncompleteSOMandTargets s targets+    where g = hexHexGrid len+          gm = lazyGridMap g ps+          tf' = fromIntegral tf+          s = SOM gm (DecayingGaussian r0 rf w0 wf tf') 0++-- | Same as sizedSOMandTargets, except some nodes don't have a value.+sizedIncompleteSOMandTargets :: Int -> Gen IncompleteSOMandTargets+sizedIncompleteSOMandTargets n = do+  sideLength <- choose (2, min (n+2) 5) --avoid long tests+  let tileCount = 3*sideLength*(sideLength-1) + 1+  numberOfPatterns <- choose (1,tileCount-1)+  ps <- vectorOf numberOfPatterns arbitrary+  r0 <- choose (0, 1)+  rf <- choose (0, r0)+  w0 <- choose (0, fromIntegral sideLength)+  wf <- choose (0, w0)+  tf <- choose (1, 10)+  targets <- vectorOf numberOfPatterns arbitrary+  return $ buildIncompleteSOMandTargets sideLength ps r0 rf w0 wf tf targets++instance Arbitrary IncompleteSOMandTargets where+  arbitrary = sized sizedIncompleteSOMandTargets++prop_can_train_incomplete_SOM :: IncompleteSOMandTargets -> Property+prop_can_train_incomplete_SOM (IncompleteSOMandTargets 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)++test :: Test+test = testGroup "QuickCheck Data.Datamining.Clustering.SOM"+  [+    testProperty "prop_DecayingGaussian_starts_at_r0"+      prop_DecayingGaussian_starts_at_r0,+    testProperty "prop_DecayingGaussian_starts_at_w0"+      prop_DecayingGaussian_starts_at_w0,+    testProperty "prop_DecayingGaussian_decays_to_rf"+      prop_DecayingGaussian_decays_to_rf,+    testProperty "prop_DecayingGaussian_shrinks_to_wf"+      prop_DecayingGaussian_shrinks_to_wf,+    testProperty "prop_global_instant_training_works"+      prop_global_instant_training_works,+    testProperty "prop_training_reduces_error"+      prop_training_reduces_error,+    testProperty "prop_classifyAndTrainEquiv"+      prop_classifyAndTrainEquiv,+    testProperty "prop_diffAndTrainEquiv" prop_diffAndTrainEquiv,+    testProperty "prop_trainNeighbourhoodEquiv" prop_trainNeighbourhoodEquiv,+    testProperty "prop_batch_training_works" prop_batch_training_works,+    testProperty "prop_classification_is_consistent"+      prop_classification_is_consistent,+    testProperty "prop_batch_training_works2"+      prop_batch_training_works2,+    testProperty "prop_can_train_incomplete_SOM"+      prop_can_train_incomplete_SOM+  ]
+ test/Data/Datamining/Clustering/SSOMQC.hs view
@@ -0,0 +1,266 @@+------------------------------------------------------------------------+-- |+-- Module      :  Data.Datamining.Clustering.SSOMQC+-- Copyright   :  (c) Amy de Buitléir 2012-2014+-- License     :  BSD-style+-- Maintainer  :  amy@nualeargais.ie+-- Stability   :  experimental+-- Portability :  portable+--+-- Tests+--+------------------------------------------------------------------------+{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleInstances,+    FlexibleContexts #-}+{-# OPTIONS_GHC -fno-warn-type-defaults -fno-warn-orphans #-}++module Data.Datamining.Clustering.SSOMQC+  (+    test+  ) where++import Data.Datamining.Pattern (Pattern, Metric, difference,+  euclideanDistanceSquared, makeSimilar)+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)++positive :: (Num a, Ord a, Arbitrary a) => Gen a+positive = arbitrary `suchThat` (> 0)++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++prop_Exponential_starts_at_r0+  :: Exponential Double -> Property+prop_Exponential_starts_at_r0 f@(Exponential r0 _)+  = property $ abs (rate f 0 - r0) < 0.01++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++absDiff :: [TestPattern] -> [TestPattern] -> Double+absDiff xs ys = euclideanDistanceSquared xs' ys'+  where xs' = map toDouble xs+        ys' = map toDouble ys++-- | 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)++buildSSOMandTargets+  :: [TestPattern] -> Double -> Double -> [TestPattern] -> SSOMandTargets+buildSSOMandTargets ps r0 d targets =+  SSOMandTargets s targets+    where gm = M.fromList . zip [0..] $ ps+          s = SSOM gm (Exponential r0 d) 0++sizedSSOMandTargets :: Int -> Gen SSOMandTargets+sizedSSOMandTargets 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++instance Arbitrary SSOMandTargets where+  arbitrary = sized sizedSSOMandTargets++prop_training_reduces_error :: SSOMandTargets -> Property+prop_training_reduces_error (SSOMandTargets 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)++--   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 $+  bmu == s `classify` p && toMap s1 == toMap s2+    where p = head ps+          (bmu, s1) = classifyAndTrain s p+          s2 = train s p++--   Invoking @diffAndTrain f s p@ should give identical results to+--   @(s `diff` p, train s f p)@.+prop_diffAndTrainEquiv :: SSOMandTargets -> Property+prop_diffAndTrainEquiv (SSOMandTargets s ps) = property $+  diffs == s `differences` p && toMap s1 == toMap s2+    where p = head ps+          (diffs, s1) = diffAndTrain s p+          s2 = train s p++--   Invoking @trainNode s (classify s p) p@ should give+--   identical results to @train s p@.+prop_trainNodeEquiv :: SSOMandTargets -> Property+prop_trainNodeEquiv (SSOMandTargets s ps) = property $+  toMap s1 == toMap s2+    where p = head ps+          s1 = trainNode s (classify s p) p+          s2 = train s p++-- | 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 $+  classifications == (concat . replicate 5) firstSet+  where trainingSet = (concat . replicate 5) xs+        s' = trainBatch s trainingSet+        classifications = map (classify s') trainingSet+        firstSet = take (length xs) classifications++-- | WARNING: This can fail when two nodes are close enough in+--   value so that after training they become identical.+prop_classification_is_consistent :: SSOMandTargets -> Property+prop_classification_is_consistent (SSOMandTargets 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+--   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)++buildSpecialSSOMandTargets+  :: [TestPattern] -> Double -> Double -> [TestPattern]+    -> SpecialSSOMandTargets+buildSpecialSSOMandTargets ps r0 d targets =+  SpecialSSOMandTargets s targets+    where gm = M.fromList . zip [0..] $ ps+          s = SSOM gm (Exponential r0 d) 0++sizedSpecialSSOMandTargets :: Int -> Gen SpecialSSOMandTargets+sizedSpecialSSOMandTargets n = do+  let len = n + 1+  let ps = map MkPattern $ take len [0,100..]+  r0 <- choose (0, 1)+  d <- positive+  let targets = map MkPattern $ take len [5,105..]+  return $ buildSpecialSSOMandTargets ps r0 d targets++instance Arbitrary SpecialSSOMandTargets where+  arbitrary = sized sizedSpecialSSOMandTargets++-- | If we train a classifier once on a set of patterns, where the+--   number of patterns in the set is equal to the number of nodes in+--   the classifier, then the classifier should become a better+--   representation of the training set. The initial models and training+--   set are designed to ensure that a single node will NOT train to+--   more than one pattern (which would render the test invalid).+prop_batch_training_works2 :: SpecialSSOMandTargets -> Property+prop_batch_training_works2 (SpecialSSOMandTargets 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'))++data IncompleteSSOMandTargets = IncompleteSSOMandTargets (SSOM+  (Exponential Double) Int Int TestPattern) [TestPattern] deriving Show++buildIncompleteSSOMandTargets+  :: [TestPattern] -> Double -> Double -> [TestPattern]+    -> IncompleteSSOMandTargets+buildIncompleteSSOMandTargets ps r0 d targets =+  IncompleteSSOMandTargets s targets+    where gm = M.fromList . zip [0..] $ ps+          s = SSOM gm (Exponential r0 d) 0++-- | Same as sizedSSOMandTargets, except some nodes don't have a value.+sizedIncompleteSSOMandTargets :: Int -> Gen IncompleteSSOMandTargets+sizedIncompleteSSOMandTargets 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++instance Arbitrary IncompleteSSOMandTargets where+  arbitrary = sized sizedIncompleteSSOMandTargets++prop_can_train_incomplete_SSOM :: IncompleteSSOMandTargets -> Property+prop_can_train_incomplete_SSOM (IncompleteSSOMandTargets 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)++test :: Test+test = testGroup "QuickCheck Data.Datamining.Clustering.SSOM"+  [+    testProperty "prop_Exponential_starts_at_r0"+      prop_Exponential_starts_at_r0,+    testProperty "prop_Exponential_ge_0"+      prop_Exponential_ge_0,+    testProperty "prop_training_reduces_error"+      prop_training_reduces_error,+    testProperty "prop_classifyAndTrainEquiv"+      prop_classifyAndTrainEquiv,+    testProperty "prop_diffAndTrainEquiv" prop_diffAndTrainEquiv,+    testProperty "prop_trainNodeEquiv" prop_trainNodeEquiv,+    testProperty "prop_batch_training_works" prop_batch_training_works,+    testProperty "prop_classification_is_consistent"+      prop_classification_is_consistent,+    testProperty "prop_batch_training_works2"+      prop_batch_training_works2,+    testProperty "prop_can_train_incomplete_SSOM"+      prop_can_train_incomplete_SSOM+  ]
+ test/Data/Datamining/PatternQC.hs view
@@ -0,0 +1,81 @@+------------------------------------------------------------------------+-- |+-- Module      :  Data.Datamining.PatternQC+-- Copyright   :  (c) Amy de Buitléir 2012-2014+-- License     :  BSD-style+-- Maintainer  :  amy@nualeargais.ie+-- Stability   :  experimental+-- Portability :  portable+--+-- Tests+--+------------------------------------------------------------------------+{-# LANGUAGE MultiParamTypeClasses, TypeFamilies #-}+{-# OPTIONS_GHC -fno-warn-type-defaults -fno-warn-orphans #-}++module Data.Datamining.PatternQC+  (+    test+  ) where++import Data.Datamining.Pattern++import Control.Applicative ((<$>), (<*>))+import Test.Framework as TF (Test, testGroup)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.QuickCheck ((==>), Gen, Arbitrary, arbitrary, choose, +  Property, property, sized, vector)++newtype UnitInterval = FromDouble Double deriving Show++instance Arbitrary UnitInterval where+  arbitrary = FromDouble <$> choose (0,1)++prop_adjustVector_doesnt_choke_on_infinite_lists ::+  [Double] -> UnitInterval -> Property+prop_adjustVector_doesnt_choke_on_infinite_lists xs (FromDouble d) = +  property $ +    length (adjustVector xs d [0,1..]) == length xs++data TwoVectorsSameLength = TwoVectorsSameLength [Double] [Double] +  deriving Show++sizedTwoVectorsSameLength :: Int -> Gen TwoVectorsSameLength+sizedTwoVectorsSameLength n = +  TwoVectorsSameLength <$> vector n <*> vector n++instance Arbitrary TwoVectorsSameLength where+  arbitrary = sized sizedTwoVectorsSameLength++prop_zero_adjustment_is_no_adjustment :: +  TwoVectorsSameLength -> Property+prop_zero_adjustment_is_no_adjustment (TwoVectorsSameLength xs ys) = +  property $ adjustVector xs 0 ys == ys++prop_full_adjustment_gives_perfect_match :: +  TwoVectorsSameLength -> Property+prop_full_adjustment_gives_perfect_match (TwoVectorsSameLength xs ys) = +  property $ adjustVector xs 1 ys == xs++prop_adjustVector_improves_similarity :: +  TwoVectorsSameLength -> UnitInterval -> Property+prop_adjustVector_improves_similarity +  (TwoVectorsSameLength xs ys) (FromDouble a) = +    a > 0 && a < 1 && not (null xs) ==> d2 < d1+      where d1 = euclideanDistanceSquared xs ys+            d2 = euclideanDistanceSquared xs ys'+            ys' = adjustVector xs a ys++test :: Test+test = testGroup "QuickCheck Data.Datamining.Clustering.PatternQC"+  [+    testProperty "prop_adjustVector_doesnt_choke_on_infinite_lists"+      prop_adjustVector_doesnt_choke_on_infinite_lists,+    testProperty "prop_zero_adjustment_is_no_adjustment"+      prop_zero_adjustment_is_no_adjustment,+    testProperty "prop_full_adjustment_gives_perfect_match"+      prop_full_adjustment_gives_perfect_match,+    testProperty "prop_adjustVector_improves_similarity"+      prop_adjustVector_improves_similarity+  ]+