som 9.0.3 → 9.0.4
raw patch · 5 files changed
+967/−9 lines, 5 filesdep ~QuickCheckdep ~basedep ~containersPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: QuickCheck, base, containers, deepseq, som, test-framework-quickcheck2
API changes (from Hackage documentation)
Files
- som.cabal +14/−9
- test/Data/Datamining/Clustering/DSOMQC.hs +287/−0
- test/Data/Datamining/Clustering/SGMQC.hs +241/−0
- test/Data/Datamining/Clustering/SOMQC.hs +338/−0
- test/Data/Datamining/PatternQC.hs +87/−0
som.cabal view
@@ -1,5 +1,5 @@ name: som-version: 9.0.3+version: 9.0.4 cabal-version: >=1.10 build-type: Simple license: BSD3@@ -42,9 +42,9 @@ Data.Datamining.Pattern build-depends: assert >=0.0.1.2 && <0.1,- base >=4.9.1.0 && <4.10,- containers >=0.5.7.1 && <0.6,- deepseq >=1.4.2.0 && <1.5,+ base >=4.7 && <5,+ containers >=0.5.10.2 && <0.6,+ deepseq >=1.4.3.0 && <1.5, grid >=7.8.8 && <7.9, MonadRandom >=0.5.1 && <0.6 default-language: Haskell2010@@ -56,15 +56,20 @@ main-is: Main.hs build-depends: assert >=0.0.1.2 && <0.1,- base ==4.9.*,- test-framework-quickcheck2 >=0.3.0.3 && <0.4,- QuickCheck >=2.9.2 && <2.10,+ base >=4.10.0.0 && <4.11,+ test-framework-quickcheck2 >=0.3.0.4 && <0.4,+ QuickCheck >=2.10.0.1 && <2.11, test-framework >=0.8.1.1 && <0.9,- som >=9.0.3 && <9.1,- containers >=0.5.7.1 && <0.6,+ som,+ containers >=0.5.10.2 && <0.6, grid >=7.8.8 && <7.9, MonadRandom >=0.5.1 && <0.6, random ==1.1.* default-language: Haskell2010 hs-source-dirs: test+ other-modules:+ Data.Datamining.Clustering.DSOMQC+ Data.Datamining.Clustering.SGMQC+ Data.Datamining.Clustering.SOMQC+ Data.Datamining.PatternQC ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall
+ test/Data/Datamining/Clustering/DSOMQC.hs view
@@ -0,0 +1,287 @@+------------------------------------------------------------------------+-- |+-- Module : Data.Datamining.Clustering.DSOMQC+-- Copyright : (c) Amy de Buitléir 2012-2016+-- License : BSD-style+-- Maintainer : amy@nualeargais.ie+-- Stability : experimental+-- Portability : portable+--+-- Tests+--+------------------------------------------------------------------------+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-type-defaults -fno-warn-orphans #-}++module Data.Datamining.Clustering.DSOMQC+ (+ test+ ) where++import Data.Datamining.Pattern (euclideanDistanceSquared,+ magnitudeSquared, adjustNum, absDifference)+import Data.Datamining.Clustering.Classifier(classify,+ classifyAndTrain, differences, diffAndTrain, models,+ numModels, train, trainBatch)+import Data.Datamining.Clustering.DSOMInternal++#if MIN_VERSION_base(4,8,0)+#else+import Control.Applicative+#endif++import Data.List (sort)+import Math.Geometry.Grid (size)+import Math.Geometry.Grid.Hexagonal (HexHexGrid, hexHexGrid)+import Math.Geometry.GridMap ((!), elems)+import Math.Geometry.GridMap.Lazy (LGridMap, lazyGridMap)+import Test.Framework as TF (Test, testGroup)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.QuickCheck ((==>), Gen, Arbitrary, arbitrary, choose,+ Property, property, sized, suchThat, vectorOf, shrink)++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++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++approxEqual :: [TestPattern] -> [TestPattern] -> Bool+approxEqual xs ys = fractionDiff xs' ys' <= 0.1+ where xs' = map toDouble xs+ ys' = map toDouble ys++-- We need to ensure that the absolute value of the difference+-- between any two test patterns is on the unit interval.++newtype TestPattern = TestPattern {toDouble :: Double}+ deriving ( Eq, Ord, Show, Read)++instance Arbitrary TestPattern where+ arbitrary = fmap TestPattern $ choose (0,1)+ shrink (TestPattern x) =+ [ TestPattern x' | x' <- shrink x, x' >= 0, x' <= 1]++testPatternDiff :: TestPattern -> TestPattern -> Double+testPatternDiff (TestPattern a) (TestPattern b) = absDifference a b++adjustTestPattern :: TestPattern -> Double -> TestPattern -> TestPattern+adjustTestPattern (TestPattern target) r (TestPattern x)+ = TestPattern $ adjustNum target r x++-- | 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 DSOMTestData where+ show s = "buildDSOMTestData " ++ show (size . gridMap . som1 $ s)+ ++ " " ++ show (elems . gridMap . som1 $ s)+ ++ " (" ++ show (params1 s) + ++ ") " ++ show (trainingSet1 s) ++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+ 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.+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+ rp <- arbitrary+ targets <- vectorOf numberOfPatterns arbitrary+ return $ buildDSOMTestData sideLength ps rp targets++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 :: 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+ s2 = DSOM gm f testPatternDiff adjustTestPattern+ s3 = train s2 x+ finalModels = models s3 :: [TestPattern]+ expectedModels = replicate (numModels s) x :: [TestPattern]++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 = 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 :: 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 :: 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 :: 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++-- | 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 :: 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 SpecialDSOMTestData+ = SpecialDSOMTestData+ {+ som2 :: DSOM (LGridMap HexHexGrid) Double (Int, Int) TestPattern,+ params2 :: Double,+ trainingSet2 :: [TestPattern]+ }++instance Show SpecialDSOMTestData where+ show s = "buildDSOMTestData " ++ show (size . gridMap . som2 $ s)+ ++ " " ++ show (elems . gridMap . som2 $ s)+ ++ " (" ++ show (params2 s) + ++ ") " ++ show (trainingSet2 s) ++stepFunction :: Double -> Double -> Double -> Double -> Double+stepFunction r _ _ d = if d == 0 then r else 0.0++buildSpecialDSOMTestData+ :: Int -> [TestPattern] -> Double -> [TestPattern] -> SpecialDSOMTestData+buildSpecialDSOMTestData len ps r targets =+ SpecialDSOMTestData s r targets+ where g = hexHexGrid len+ gm = lazyGridMap g ps+ 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.+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 TestPattern $ take tileCount [0,100..]+ r <- choose (0.001, 1)+ let targets = map TestPattern $ take tileCount [5,105..]+ return $ buildSpecialDSOMTestData sideLength ps r targets++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+-- 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 :: SpecialDSOMTestData -> Property+prop_batch_training_works2 (SpecialDSOMTestData s _ xs) =+ errBefore /= 0 ==> errAfter < errBefore+ where s' = trainBatch s xs+ 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"+ [+ 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/SGMQC.hs view
@@ -0,0 +1,241 @@+------------------------------------------------------------------------+-- |+-- Module : Data.Datamining.Clustering.SGMQC+-- Copyright : (c) Amy de Buitléir 2012-2016+-- License : BSD-style+-- Maintainer : amy@nualeargais.ie+-- Stability : experimental+-- Portability : portable+--+-- Tests+--+------------------------------------------------------------------------+{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleInstances,+ FlexibleContexts #-}+{-# OPTIONS_GHC -fno-warn-type-defaults -fno-warn-orphans #-}++module Data.Datamining.Clustering.SGMQC+ (+ test+ ) where++import Data.Datamining.Pattern (adjustNum, absDifference)+import Data.Datamining.Clustering.SGMInternal+import Data.List ((\\), minimumBy)+import qualified Data.Map.Strict as M+import Data.Ord (comparing)+import Data.Word (Word16)+import System.Random (Random)+import Test.Framework as TF (Test, testGroup)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.QuickCheck ((==>), Gen, Arbitrary, Property, Positive,+ arbitrary, shrink, choose, property, sized, suchThat, vectorOf,+ getPositive)++newtype UnitInterval a = UnitInterval {getUnitInterval :: a}+ deriving ( Eq, Ord, Show, Read)++instance Functor UnitInterval where+ fmap f (UnitInterval x) = UnitInterval (f x)++instance (Num a, Ord a, Random a, Arbitrary a)+ => Arbitrary (UnitInterval a) where+ arbitrary = fmap UnitInterval $ choose (0,1)+ shrink (UnitInterval x) =+ [ UnitInterval x' | x' <- shrink x, x' >= 0, x' <= 1]++prop_Exponential_starts_at_r0+ :: UnitInterval Double -> Positive Double -> Property+prop_Exponential_starts_at_r0 r0 d+ = property $ abs (exponential r0' d' 0 - r0') < 0.01+ where r0' = getUnitInterval r0+ d' = getPositive d++prop_Exponential_ge_0+ :: UnitInterval Double -> Positive Double -> Positive Int -> Property+prop_Exponential_ge_0 r0 d t = property $ exponential r0' d' t' >= 0+ where r0' = getUnitInterval r0+ d' = getPositive d+ t' = getPositive t++positive :: (Num a, Ord a, Arbitrary a) => Gen a+positive = arbitrary `suchThat` (> 0)++data TestSGM = TestSGM (SGM Int Double Word16 Double) String++instance Show TestSGM where+ show (TestSGM _ desc) = desc++buildTestSGM+ :: Double -> Double -> Int -> Double -> Bool -> [Double] -> TestSGM+buildTestSGM r0 d maxSz dt ad ps = TestSGM s' desc+ where lrf = exponential r0 d+ s = makeSGM lrf maxSz dt ad absDifference adjustNum+ desc = "buildTestSGM " ++ show r0 ++ " " ++ show d+ ++ " " ++ show maxSz+ ++ " " ++ show dt+ ++ " " ++ show ad+ ++ " " ++ show ps+ s' = trainBatch s ps++sizedTestSGM :: Int -> Gen TestSGM+sizedTestSGM n = do+ maxSz <- choose (1, n+1)+ let numPatterns = n+ r0 <- choose (0, 1)+ d <- positive+ dt <- choose (0, 1)+ ad <- arbitrary+ ps <- vectorOf numPatterns arbitrary+ return $ buildTestSGM r0 d maxSz dt ad ps++instance Arbitrary TestSGM where+ arbitrary = sized sizedTestSGM++prop_classify_chooses_best_fit :: TestSGM -> Double -> Property+prop_classify_chooses_best_fit (TestSGM s _) x+ = property $ bmu == fst (minimumBy (comparing snd) diffs)+ where (bmu, _, diffs, _) = trainAndClassify s x++prop_classify_never_creates_model :: TestSGM -> Double -> Property+prop_classify_never_creates_model (TestSGM s _) x+ = not (isEmpty s) ==> bmu `elem` (labels s)+ where (bmu, _, _) = classify s x++prop_trainNode_reduces_diff :: TestSGM -> Double -> Property+prop_trainNode_reduces_diff (TestSGM s _) x = not (isEmpty s) ==>+ diffAfter < diffBefore || diffBefore == 0+ || learningRate s (time s) < 1e-10+ where (bmu, diffBefore, _) = classify s x+ s2 = trainNode s bmu x+ (_, diffAfter, _) = classify s2 x++prop_diff_lt_threshold_after_training :: TestSGM -> Double -> Property+prop_diff_lt_threshold_after_training (TestSGM s _) x =+ numModels s < maxSize s ==> diffAfter < diffThreshold s+ where (_, _, _, s') = trainAndClassify s x+ (_, diffAfter, _) = classify s' x++prop_training_reduces_diff :: TestSGM -> Double -> Property+prop_training_reduces_diff (TestSGM s _) x = not (isEmpty s) ==>+ diffAfter < diffBefore || diffBefore == 0+ || learningRate s (time s) < 1e-10+ where (_, diffBefore, _) = classify s x+ s2 = train s x+ (_, diffAfter, _) = classify s2 x++-- TODO prop: map will never exceed maxSize++prop_train_only_modifies_one_model+ :: TestSGM -> Double -> Property+prop_train_only_modifies_one_model (TestSGM s _) p+ = numModels s < maxSize s ==> otherModelsBefore == otherModelsAfter+ where (bmu, _, _, s2) = trainAndClassify s p+ otherModelsBefore = M.delete bmu . M.map fst . toMap $ s+ otherModelsAfter = M.delete bmu . M.map fst . toMap $ s2++prop_train_increments_counter :: TestSGM -> Double -> Property+prop_train_increments_counter (TestSGM s _) x+ = numModels s < maxSize s ==> countAfter == countBefore + 1+ -- We have to check if the SGM is full, otherwise we'll replace an+ -- existing model (and its counter), which means that the total+ -- count could change by an arbitrary amount.+ where countBefore = time s+ countAfter = time $ train s x++-- | The training set consists of the same vectors in the same order,+-- several times over. So the resulting classifications should consist+-- of the same integers in the same order, over and over.+prop_batch_training_works :: TestSGM -> [Double] -> Property+prop_batch_training_works (TestSGM s _) ps+ -- = maxSize s > length ps+ -- ==> classifications == (concat . replicate 5) firstSet+ = property $ classifications == (concat . replicate 5) firstSet+ where trainingSet = (concat . replicate 5) ps+ sRightSize = if maxSize s >= length ps+ then s+ else s { maxSize=length ps + 1}+ s' = trainBatch sRightSize trainingSet+ classifications = map (justBMU . classify s') trainingSet+ justBMU = \(bmu, _, _) -> bmu+ firstSet = take (length ps) classifications++-- | WARNING: This can fail when two nodes are close enough in+-- value so that after training they become identical.+prop_classification_is_consistent :: TestSGM -> Double -> Property+prop_classification_is_consistent (TestSGM s _) x+ = property $ bmu == bmu'+ where (bmu, _, _, s2) = trainAndClassify s x+ (bmu', _, _) = classify s2 x++prop_classification_results_are_consistent+ :: TestSGM -> Double -> Property+prop_classification_results_are_consistent (TestSGM s _) x+ = property $ bmu == fst (minimumBy (comparing snd) diffs)+ where (bmu, _, diffs, _) = trainAndClassify s x++prop_classification_results_are_consistent2+ :: TestSGM -> Double -> Property+prop_classification_results_are_consistent2 (TestSGM s _) x+ = property $ bmuDiff == snd (minimumBy (comparing snd) diffs)+ where (_, bmuDiff, diffs, _) = trainAndClassify s x++prop_classification_stabilises :: TestSGM -> [Double] -> Property+prop_classification_stabilises (TestSGM s _) ps+ = (not . null $ ps) && maxSize s > length ps ==> k2 == k1+ where sStable = trainBatch s . concat . replicate 10 $ ps+ (k1, _, _, sStable2) = trainAndClassify sStable (head ps)+ sStable3 = trainBatch sStable2 ps+ (k2, _, _) = classify sStable3 (head ps)++prop_models_not_deleted_unless_allowed+ :: TestSGM -> Double -> Property+prop_models_not_deleted_unless_allowed (TestSGM s _) x =+ (not . allowDeletion $ s) ==> null (labelsBefore \\ labelsAfter)+ where labelsBefore = M.keys $ modelMap s+ labelsAfter = M.keys $ modelMap s'+ (_, _, _, s') = trainAndClassify s x++prop_models_not_deleted_unless_allowed2+ :: TestSGM -> Double -> Property+prop_models_not_deleted_unless_allowed2 (TestSGM s _) x =+ (not . allowDeletion $ s) ==> null (labelsBefore \\ labelsAfter)+ where labelsBefore = M.keys $ modelMap s+ labelsAfter = M.keys $ modelMap s'+ s' = train s x++test :: Test+test = testGroup "QuickCheck Data.Datamining.Clustering.SGM"+ [+ testProperty "prop_Exponential_starts_at_r0"+ prop_Exponential_starts_at_r0,+ testProperty "prop_Exponential_ge_0"+ prop_Exponential_ge_0,+ testProperty "prop_classify_chooses_best_fit"+ prop_classify_chooses_best_fit,+ testProperty "prop_classify_never_creates_model"+ prop_classify_never_creates_model,+ testProperty "prop_trainNode_reduces_diff"+ prop_trainNode_reduces_diff,+ testProperty "prop_diff_lt_threshold_after_training"+ prop_diff_lt_threshold_after_training,+ testProperty "prop_training_reduces_diff"+ prop_training_reduces_diff,+ testProperty "prop_train_only_modifies_one_model"+ prop_train_only_modifies_one_model,+ testProperty "prop_train_increments_counter"+ prop_train_increments_counter,+ testProperty "prop_batch_training_works" prop_batch_training_works,+ testProperty "prop_classification_is_consistent"+ prop_classification_is_consistent,+ testProperty "prop_classification_results_are_consistent"+ prop_classification_results_are_consistent,+ testProperty "prop_classification_results_are_consistent2"+ prop_classification_results_are_consistent2,+ testProperty "prop_classification_stabilises"+ prop_classification_stabilises,+ testProperty "prop_models_not_deleted_unless_allowed"+ prop_models_not_deleted_unless_allowed,+ testProperty "prop_models_not_deleted_unless_allowed2"+ prop_models_not_deleted_unless_allowed2 + ]
+ test/Data/Datamining/Clustering/SOMQC.hs view
@@ -0,0 +1,338 @@+------------------------------------------------------------------------+-- |+-- Module : Data.Datamining.Clustering.SOMQC+-- Copyright : (c) Amy de Buitléir 2012-2016+-- 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 (euclideanDistanceSquared,+ magnitudeSquared, adjustNum, absDifference)+import Data.Datamining.Clustering.Classifier(classify,+ classifyAndTrain, reportAndTrain, differences, diffAndTrain, models,+ numModels, train, trainBatch)+import Data.Datamining.Clustering.SOMInternal++import Data.List (sort)+import Math.Geometry.Grid (size)+import Math.Geometry.Grid.Hexagonal (HexHexGrid, hexHexGrid)+import Math.Geometry.GridMap ((!), elems)+import Math.Geometry.GridMap.Lazy (LGridMap, lazyGridMap)+import System.Random (Random)+import Test.Framework as TF (Test, testGroup)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.QuickCheck ((==>), Gen, Arbitrary, arbitrary, choose,+ Property, property, sized, suchThat, vectorOf)++positive :: (Num a, Ord a, Arbitrary a) => Gen a+positive = arbitrary `suchThat` (> 0)++data DecayingGaussianParams a = DecayingGaussianParams a a a a a+ deriving (Eq, Show)++instance+ (Random a, Num a, Ord a, Arbitrary a)+ => Arbitrary (DecayingGaussianParams a) where+ arbitrary = do+ r0 <- choose (0,1)+ rf <- choose (0,r0)+ w0 <- positive+ wf <- choose (0,w0)+ tf <- positive+ return $ DecayingGaussianParams r0 rf w0 wf tf++prop_DecayingGaussian_starts_at_r0+ :: 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+ :: DecayingGaussianParams Double -> Property+prop_DecayingGaussian_starts_at_w0 (DecayingGaussianParams r0 rf w0 wf tf)+ = property $+ 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.99999+ outside = w0 * 1.00001++prop_DecayingGaussian_decays_to_rf+ :: 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+ :: DecayingGaussianParams Double -> Property+prop_DecayingGaussian_shrinks_to_wf (DecayingGaussianParams r0 rf w0 wf tf)+ = property $+ 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.99999+ outside = wf * 1.00001++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++approxEqual :: [Double] -> [Double] -> 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 SOMTestData+ = SOMTestData+ {+ som1 :: SOM Double Double (LGridMap HexHexGrid) Double (Int, Int) Double,+ params1 :: DecayingGaussianParams Double,+ trainingSet1 :: [Double]+ }++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+ fr = decayingGaussian r0 rf w0 wf tf+ s = SOM gm fr absDifference adjustNum 0++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+ 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 $ buildSOMTestData sideLength ps (DecayingGaussianParams r0 rf w0 wf tf) targets++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 :: SOMTestData -> Property+prop_global_instant_training_works (SOMTestData s _ xs) =+ property $ finalModels `approxEqual` expectedModels+ where x = head xs+ gm = toGridMap s :: LGridMap HexHexGrid Double+ f _ _ = 1+ s2 = SOM gm f absDifference adjustNum 0+ s3 = train s2 x+ finalModels = models s3 :: [Double]+ expectedModels = replicate (numModels s) x :: [Double]++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 $ 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 :: 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+ s2 = train s p++-- Invoking @diffAndTrain f s p@ should give identical results to+-- @(s `diff` p, train s f p)@.+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+ s2 = train s p++-- Invoking @trainNeighbourhood s (classify s p) p@ should give+-- identical results to @train s p@.+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+ 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 :: 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+ 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.+-- This only happens rarely, so if the test fails, try again.+prop_classification_is_consistent+ :: 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 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 SpecialSOMTestData+ = SpecialSOMTestData+ {+ som2 :: SOM Int Int (LGridMap HexHexGrid) Double (Int, Int) Double,+ params2 :: Double,+ trainingSet2 :: [Double]+ }++instance Show SpecialSOMTestData where+ show s = "buildSpecialSOMTestData " ++ show (size . gridMap . som2 $ s)+ ++ " " ++ show (elems . gridMap . som2 $ s)+ ++ " " ++ show (params2 s) + ++ " " ++ show (trainingSet2 s) ++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) absDifference adjustNum 0++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 = take tileCount [0,100..]+ r <- choose (0.001, 1)+ let targets = take tileCount [5,105..]+ return $ buildSpecialSOMTestData sideLength ps r targets++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+-- 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 :: SpecialSOMTestData -> Property+prop_batch_training_works2 (SpecialSOMTestData s _ xs) =+ errBefore /= 0 ==> errAfter < errBefore+ where s' = trainBatch s xs+ errBefore = euclideanDistanceSquared (sort xs) (sort (models s))+ errAfter = euclideanDistanceSquared (sort xs) (sort (models s'))++data IncompleteSOMTestData+ = IncompleteSOMTestData+ {+ som3 :: SOM Double Double (LGridMap HexHexGrid) Double (Int, Int) Double,+ params3 :: DecayingGaussianParams Double,+ trainingSet3 :: [Double]+ }++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+ fr = decayingGaussian r0 rf w0 wf tf+ s = SOM gm fr absDifference adjustNum 0++-- | 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)+ 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 $ buildIncompleteSOMTestData sideLength ps (DecayingGaussianParams r0 rf w0 wf tf) targets++instance Arbitrary IncompleteSOMTestData where+ arbitrary = sized sizedIncompleteSOMTestData++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 $ x - (gridMap s ! bmu)+ errAfter = abs $ x - (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/PatternQC.hs view
@@ -0,0 +1,87 @@+------------------------------------------------------------------------+-- |+-- Module : Data.Datamining.PatternQC+-- Copyright : (c) Amy de Buitléir 2012-2016+-- License : BSD-style+-- Maintainer : amy@nualeargais.ie+-- Stability : experimental+-- Portability : portable+--+-- Tests+--+------------------------------------------------------------------------+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-type-defaults -fno-warn-orphans #-}++module Data.Datamining.PatternQC+ (+ test+ ) where++import Data.Datamining.Pattern++import Test.Framework as TF (Test, testGroup)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.QuickCheck ((==>), Gen, Arbitrary, arbitrary, choose, + Property, property, sized, vector)++#if MIN_VERSION_base(4,8,0)+#else+import Control.Applicative+#endif++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+ ]+