git.iko.soy/grenade
on master help sign in
Better testing
commit88021fbde76dc677cb9c29591e9d6021c9c2a04f authorHuw Campbell <huw.campbell@ambiata.com> dateThu 15 Dec 2016, 16:36 (10 years ago) parent424d791
5 files changed+49−105
compare with master
unifiedsplit
test/Test/Grenade/Layers/Convolution.hs+19−22 test/Test/Grenade/Layers/FullyConnected.hs+6−8 test/Test/Grenade/Layers/Internal/Convolution.hs+6−8 test/Test/Grenade/Layers/Internal/Pooling.hs+11−31 test/Test/Grenade/Layers/Internal/Reference.hs+7−36
test/Test/Grenade/Layers/Convolution.hs+19−22
@@ -20,8 +20,6 @@ import Grenade.Core.Shape
2020import Grenade.Core.Network
2121import Grenade.Layers.Convolution
2222
23−import qualified Numeric.LinearAlgebra.Static as HStatic
24−
2523import Disorder.Jack
2624
2725import Test.Jack.Hmatrix
@@ -61,7 +59,6 @@ prop_conv_net =
6159 (case onet of
6260 (OpaqueConvolution (convLayer@(Convolution _ _) :: Convolution channels filters kernelRows kernelCols strideRows strideCols)) ->
6361 let ok stride kernel = [extent | extent <- [(kernel + 1) .. 30 ], (extent - kernel) `mod` stride == 0]
64− ch = fromIntegral $ natVal (Proxy :: Proxy channels)
6562 kr = fromIntegral $ natVal (Proxy :: Proxy kernelRows)
6663 kc = fromIntegral $ natVal (Proxy :: Proxy kernelCols)
6764 sr = fromIntegral $ natVal (Proxy :: Proxy strideRows)
@@ -69,26 +66,26 @@ prop_conv_net =
6966
7067 in gamble (elements (ok sr kr)) $ \er ->
7168 gamble (elements (ok sc kc)) $ \ec ->
72− let i = fromIntegral (er * ec * ch)
73− rr = ((er - kr) `div` sr) + 1
69+ let rr = ((er - kr) `div` sr) + 1
7470 rc = ((ec - kc) `div` sc) + 1
75− er' = someNatVal er
76− ec' = someNatVal ec
77− rr' = someNatVal rr
78− rc' = someNatVal rc
79− in gamble (vectorOf i sizedRealFrac) $ \(input :: [Double]) ->
80− case (er', ec', rr', rc') of
81− (Just (SomeNat (pinr :: Proxy inRows)), Just (SomeNat (_ :: Proxy inCols)), Just (SomeNat (pour :: Proxy outRows)), Just (SomeNat (_ :: Proxy outCols))) ->
82− let p1 = natDict pinr
83− p2 = natDict pour
84− in case ( p1 %* natDict (Proxy :: Proxy channels)
85− , p2 %* natDict (Proxy :: Proxy filters)
86− -- Fake it till you make it.
87− , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outRows - 1) * strideRows) ~ (inRows - kernelRows)))
88− , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outCols - 1) * strideCols) ~ (inCols - kernelCols)))) of
89− (Dict, Dict, Dict, Dict) -> let x :: S' ('D3 outRows outCols filters) = runForwards convLayer ((S3D' (HStatic.matrix input)) :: S' ('D3 inRows inCols channels))
90− in x `seq` True
91− _ -> False
71+ Just er' = someNatVal er
72+ Just ec' = someNatVal ec
73+ Just rr' = someNatVal rr
74+ Just rc' = someNatVal rc
75+ in (case (er', ec', rr', rc') of
76+ ( SomeNat (pinr :: Proxy inRows), SomeNat (_ :: Proxy inCols), SomeNat (pour :: Proxy outRows), SomeNat (_ :: Proxy outCols)) ->
77+ case ( natDict pinr %* natDict (Proxy :: Proxy channels)
78+ , natDict pour %* natDict (Proxy :: Proxy filters)
79+ -- Fake it till you make it.
80+ , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outRows - 1) * strideRows) ~ (inRows - kernelRows)))
81+ , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outCols - 1) * strideCols) ~ (inCols - kernelCols)))) of
82+ (Dict, Dict, Dict, Dict) ->
83+ gamble (S3D' <$> uniformSample) $ \(input :: S' ('D3 inRows inCols channels)) ->
84+ let output :: S' ('D3 outRows outCols filters) = runForwards convLayer input
85+ backed :: (Gradient (Convolution channels filters kernelRows kernelCols strideRows strideCols), S' ('D3 inRows inCols channels))
86+ = runBackwards convLayer input output
87+ in backed `seq` True
88+ ) :: Property
9289 ) :: Property
9390
9491return []
test/Test/Grenade/Layers/FullyConnected.hs+6−8
@@ -16,8 +16,6 @@ import Grenade.Core.Shape
1616import Grenade.Core.Network
1717import Grenade.Layers.FullyConnected
1818
19−import qualified Numeric.LinearAlgebra.Static as HStatic
20−
2119import Disorder.Jack
2220
2321import Test.Jack.Hmatrix
@@ -32,7 +30,7 @@ instance Show OpaqueFullyConnected where
3230genOpaqueFullyConnected :: Jack OpaqueFullyConnected
3331genOpaqueFullyConnected = do
3432 input :: Integer <- choose (2, 100)
35− output :: Integer <- choose (2, 100)
33+ output :: Integer <- choose (1, 100)
3634 let Just input' = someNatVal input
3735 let Just output' = someNatVal output
3836 case (input', output') of
@@ -46,11 +44,11 @@ genOpaqueFullyConnected = do
4644prop_fully_connected_forwards :: Property
4745prop_fully_connected_forwards =
4846 gamble genOpaqueFullyConnected $ \(OpaqueFullyConnected (fclayer :: FullyConnected i o)) ->
49− let i = fromIntegral $ natVal (Proxy :: Proxy i)
50− in gamble (vectorOf i sizedRealFrac) $ \input ->
51− let x :: S' ('D1 o) = runForwards fclayer (S1D' (HStatic.vector input :: HStatic.R i))
52− in x `seq` True
53−
47+ gamble (S1D' <$> randomVector) $ \(input :: S' ('D1 i)) ->
48+ let output :: S' ('D1 o) = runForwards fclayer input
49+ backed :: (Gradient (FullyConnected i o), S' ('D1 i))
50+ = runBackwards fclayer input output
51+ in backed `seq` True
5452
5553return []
5654tests :: IO Bool
test/Test/Grenade/Layers/Internal/Convolution.hs+6−8
@@ -1,15 +1,13 @@
1−{-# LANGUAGE TemplateHaskell #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE GADTs #-}
4−{-# LANGUAGE ScopedTypeVariables #-}
5−{-# LANGUAGE ConstraintKinds #-}
6−{-# LANGUAGE TypeOperators #-}
1+{-# LANGUAGE TemplateHaskell #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE GADTs #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
5+{-# LANGUAGE ConstraintKinds #-}
6+{-# LANGUAGE TypeOperators #-}
77
88{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
99module Test.Grenade.Layers.Internal.Convolution where
1010
11−-- import Control.Monad.Random
12−
1311import Grenade.Layers.Internal.Convolution
1412
1513import Numeric.LinearAlgebra hiding (uniformSample, konst, (===))
test/Test/Grenade/Layers/Internal/Pooling.hs+11−31
@@ -1,9 +1,9 @@
1−{-# LANGUAGE TemplateHaskell #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE GADTs #-}
4−{-# LANGUAGE ScopedTypeVariables #-}
5−{-# LANGUAGE ConstraintKinds #-}
6−{-# LANGUAGE TypeOperators #-}
1+{-# LANGUAGE TemplateHaskell #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE GADTs #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
5+{-# LANGUAGE ConstraintKinds #-}
6+{-# LANGUAGE TypeOperators #-}
77
88{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
99module Test.Grenade.Layers.Internal.Pooling where
@@ -21,38 +21,18 @@ prop_poolForwards_poolBackwards_behaves_as_reference =
2121 output extent kernel stride = (extent - kernel) `div` stride + 1
2222 in gamble (choose (2, 100)) $ \height ->
2323 gamble (choose (2, 100)) $ \width ->
24− gamble (choose (2, height - 1)) $ \kernel_h ->
25− gamble (choose (2, width - 1)) $ \kernel_w ->
24+ gamble (choose (1, height - 1)) $ \kernel_h ->
25+ gamble (choose (1, width - 1)) $ \kernel_w ->
2626 gamble (elements (ok height kernel_h)) $ \stride_h ->
2727 gamble (elements (ok width kernel_w)) $ \stride_w ->
2828 gamble (listOfN (height * width) (height * width) sizedRealFrac) $ \input ->
2929 let input' = (height >< width) input
3030 outFast = poolForward 1 height width kernel_h kernel_w stride_h stride_w input'
31− -- retFast = poolBackward 1 height width kernel_h kernel_w stride_h stride_w input' outFast
31+ retFast = poolBackward 1 height width kernel_h kernel_w stride_h stride_w input' outFast
3232
3333 outReference = Reference.poolForward kernel_h kernel_w stride_h stride_w (output height kernel_h stride_h) (output width kernel_w stride_w) input'
34− -- retReference = Reference.poolBackward kernel_h kernel_w stride_h stride_w input' outReference
35− in outFast === outReference -- .&&. retFast === retReference
36−
37−
38−prop_poolForwards_poolBackwards_symmetry =
39− let factors n = [x | x <- [1..n], n `mod` x == 0]
40− output extent kernel stride = (extent - kernel) `div` stride + 1
41− in gamble (choose (2, 100)) $ \height ->
42− gamble (choose (2, 100)) $ \width ->
43− gamble ((height `div`) <$> elements (factors height)) $ \kernel_h ->
44− gamble ((width `div`) <$> elements (factors width)) $ \kernel_w ->
45− gamble (listOfN (height * width) (height * width) sizedRealFrac) $ \input ->
46− let input' = (height >< width) input
47− stride_h = kernel_h
48− stride_w = kernel_w
49− outFast = poolForward 1 height width kernel_h kernel_w stride_h stride_w input'
50− retFast = poolBackward 1 height width kernel_h kernel_w stride_h stride_w input' outFast
51−
52− outReference = Reference.poolForward kernel_h kernel_w stride_h stride_w (output height kernel_h stride_h) (output width kernel_w stride_w) input'
53− retReference = Reference.poolBackward kernel_h kernel_w stride_h stride_w input' outReference
54− in outFast === outReference .&&. retFast === retReference
55−
34+ retReference = Reference.poolBackward kernel_h kernel_w stride_h stride_w input' outReference
35+ in outFast === outReference .&&. retFast === retReference
5636
5737return []
5838tests :: IO Bool
test/Test/Grenade/Layers/Internal/Reference.hs+7−36
@@ -1,14 +1,6 @@
11module Test.Grenade.Layers.Internal.Reference where
22
3−
4−import Control.Monad.ST ( ST )
5−
6−import Data.Foldable ( forM_ )
7−import Data.Function ( on )
8−import Data.List ( maximumBy )
9−
103import Numeric.LinearAlgebra
11−import qualified Numeric.LinearAlgebra.Devel as U
124
135im2col :: Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double
146im2col nrows ncols srows scols m =
@@ -47,7 +39,6 @@ col2imfit starts krows kcols drows dcols m =
4739 accums = concatMap (\(conv',(stx',sty')) -> fmap (\((ix,iy), val) -> ((ix + stx', iy + sty'), val)) conv') pairs
4840 in accum (konst 0 (drows, dcols)) (+) accums
4941
50−
5142poolForward :: Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double
5243poolForward nrows ncols srows scols outputRows outputCols m =
5344 let starts = fittingStarts (rows m) nrows srows (cols m) ncols scols
@@ -60,7 +51,7 @@ poolForwardList nrows ncols srows scols inRows inCols outputRows outputCols ms =
6051
6152poolForwardFit :: [(Int,Int)] -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double
6253poolForwardFit starts nrows ncols _ outputCols m =
63− let els = fmap (\start -> unsafeMaxElementSubmatrix start (nrows, ncols) m) starts
54+ let els = fmap (\start -> maxElement $ subMatrix start (nrows, ncols) m) starts
6455 in matrix outputCols els
6556
6657poolBackward :: Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double -> Matrix Double
@@ -76,34 +67,14 @@ poolBackwardList krows kcols srows scols inRows inCols inputMatrices =
7667 in uncurry (poolBackwardFit starts krows kcols) <$> inputMatrices
7768
7869poolBackwardFit :: [(Int,Int)] -> Int -> Int -> Matrix Double -> Matrix Double -> Matrix Double
79−poolBackwardFit starts krows kcols inputMatrix gradientMatrix = U.runSTMatrix $ do
70+poolBackwardFit starts krows kcols inputMatrix gradientMatrix =
8071 let inRows = rows inputMatrix
8172 inCols = cols inputMatrix
82− gradCol = cols gradientMatrix
83− extent = (krows, kcols)
84−
85− retM <- U.newMatrix 0 inRows inCols
86−
87− forM_ (zip [0..] starts) $ \(ix, start) -> do
88− let loc = unsafeMaxIndexSubMatrix start extent inputMatrix
89− uncurry (unsafeModifyMatrix retM) loc ((+) $ uncurry (U.atM' gradientMatrix) $ divMod ix gradCol)
90−
91− return retM
92−
93−unsafeMaxElementSubmatrix :: (Int,Int) -> (Int,Int) -> Matrix Double -> Double
94−unsafeMaxElementSubmatrix starts extent m = uncurry (U.atM' m) $ unsafeMaxIndexSubMatrix starts extent m
95−
96−unsafeMaxIndexSubMatrix :: (Int,Int) -> (Int,Int) -> Matrix Double -> (Int, Int)
97−unsafeMaxIndexSubMatrix (startRow, startCol) (extentRow, extentCold) m =
98− let mrows = [startRow .. startRow + extentRow - 1]
99− mcols = [startCol .. startCol + extentCold - 1]
100− pairs = concatMap ( \r -> fmap (\c -> (r , c)) mcols ) mrows
101− in maximumBy (compare `on` uncurry (U.atM' m)) pairs
102−
103−
104−unsafeModifyMatrix :: U.STMatrix s Double -> Int -> Int -> (Double -> Double) -> ST s ()
105−unsafeModifyMatrix x r c f = U.unsafeReadMatrix x r c >>= U.unsafeWriteMatrix x r c . f
106−
73+ inds = fmap (\start -> maxIndex $ subMatrix start (krows, kcols) inputMatrix) starts
74+ grads = toList $ flatten gradientMatrix
75+ grads' = zip3 starts grads inds
76+ accums = fmap (\((stx',sty'),grad,(inx, iny)) -> ((stx' + inx, sty' + iny), grad)) grads'
77+ in accum (konst 0 (inRows, inCols)) (+) accums
10778
10879-- | These functions are not even remotely safe, but it's only called from the statically typed
10980-- commands, so we should be good ?!?!?