diff --git a/som.cabal b/som.cabal --- a/som.cabal +++ b/som.cabal @@ -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 diff --git a/src/Data/Datamining/Clustering/DSOMInternal.hs b/src/Data/Datamining/Clustering/DSOMInternal.hs --- a/src/Data/Datamining/Clustering/DSOMInternal.hs +++ b/src/Data/Datamining/Clustering/DSOMInternal.hs @@ -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 diff --git a/src/Data/Datamining/Clustering/SOMInternal.hs b/src/Data/Datamining/Clustering/SOMInternal.hs --- a/src/Data/Datamining/Clustering/SOMInternal.hs +++ b/src/Data/Datamining/Clustering/SOMInternal.hs @@ -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, diff --git a/test/Data/Datamining/Clustering/DSOMQC.hs b/test/Data/Datamining/Clustering/DSOMQC.hs new file mode 100644 --- /dev/null +++ b/test/Data/Datamining/Clustering/DSOMQC.hs @@ -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 + ] diff --git a/test/Data/Datamining/Clustering/SOMQC.hs b/test/Data/Datamining/Clustering/SOMQC.hs new file mode 100644 --- /dev/null +++ b/test/Data/Datamining/Clustering/SOMQC.hs @@ -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 + ] diff --git a/test/Data/Datamining/Clustering/SSOMQC.hs b/test/Data/Datamining/Clustering/SSOMQC.hs new file mode 100644 --- /dev/null +++ b/test/Data/Datamining/Clustering/SSOMQC.hs @@ -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 + ] diff --git a/test/Data/Datamining/PatternQC.hs b/test/Data/Datamining/PatternQC.hs new file mode 100644 --- /dev/null +++ b/test/Data/Datamining/PatternQC.hs @@ -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 + ] +