88021fb · grenade · git.iko.soy

git.iko.soy/grenade

on master help sign in

Better testing

88021fbHuw Campbell10 years ago

test/Test/Grenade/Layers/Convolution.hs+19−22

compare with master

unifiedsplit

@@ -20,8 +20,6 @@ import Grenade.Core.Shape

20import Grenade.Core.Network

21import Grenade.Layers.Convolution

23−import qualified Numeric.LinearAlgebra.Static as HStatic

24−

25import Disorder.Jack

23import Disorder.Jack

27import Test.Jack.Hmatrix

25import Test.Jack.Hmatrix

@@ -61,7 +59,6 @@ prop_conv_net =

61 (case onet of

59 (case onet of

62 (OpaqueConvolution (convLayer@(Convolution _ _) :: Convolution channels filters kernelRows kernelCols strideRows strideCols)) ->

60 (OpaqueConvolution (convLayer@(Convolution _ _) :: Convolution channels filters kernelRows kernelCols strideRows strideCols)) ->

63 let ok stride kernel = [extent | extent <- [(kernel + 1) .. 30 ], (extent - kernel) `mod` stride == 0]

61 let ok stride kernel = [extent | extent <- [(kernel + 1) .. 30 ], (extent - kernel) `mod` stride == 0]

64− ch = fromIntegral $ natVal (Proxy :: Proxy channels)

65 kr = fromIntegral $ natVal (Proxy :: Proxy kernelRows)

62 kr = fromIntegral $ natVal (Proxy :: Proxy kernelRows)

66 kc = fromIntegral $ natVal (Proxy :: Proxy kernelCols)

63 kc = fromIntegral $ natVal (Proxy :: Proxy kernelCols)

67 sr = fromIntegral $ natVal (Proxy :: Proxy strideRows)

64 sr = fromIntegral $ natVal (Proxy :: Proxy strideRows)

@@ -69,26 +66,26 @@ prop_conv_net =

70 in gamble (elements (ok sr kr)) $ \er ->

67 in gamble (elements (ok sr kr)) $ \er ->

71 gamble (elements (ok sc kc)) $ \ec ->

68 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

74 rc = ((ec - kc) `div` sc) + 1

70 rc = ((ec - kc) `div` sc) + 1

75− er' = someNatVal er

71+ Just er' = someNatVal er

76− ec' = someNatVal ec

72+ Just ec' = someNatVal ec

77− rr' = someNatVal rr

73+ Just rr' = someNatVal rr

78− rc' = someNatVal rc

74+ Just rc' = someNatVal rc

79− in gamble (vectorOf i sizedRealFrac) $ \(input :: [Double]) ->

80− case (er', ec', rr', rc') of

75+ in (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))) ->

76+ ( SomeNat (pinr :: Proxy inRows), SomeNat (_ :: Proxy inCols), SomeNat (pour :: Proxy outRows), SomeNat (_ :: Proxy outCols)) ->

82− let p1 = natDict pinr

83− p2 = natDict pour

84− in case ( p1 %* natDict (Proxy :: Proxy channels)

77+ case ( natDict pinr %* natDict (Proxy :: Proxy channels)

85− , p2 %* natDict (Proxy :: Proxy filters)

78+ , natDict pour %* natDict (Proxy :: Proxy filters)

86− -- Fake it till you make it.

79+ -- Fake it till you make it.

87− , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outRows - 1) * strideRows) ~ (inRows - kernelRows)))

80+ , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outRows - 1) * strideRows) ~ (inRows - kernelRows)))

88− , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outCols - 1) * strideCols) ~ (inCols - kernelCols)))) of

81+ , (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))

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

90− in x `seq` True

87+ in backed `seq` True

91− _ -> False

88+ ) :: Property

92 ) :: Property

89 ) :: Property

94return []

91return []

test/Test/Grenade/Layers/FullyConnected.hs+6−8

@@ -16,8 +16,6 @@ import Grenade.Core.Shape

16import Grenade.Core.Network

17import Grenade.Layers.FullyConnected

19−import qualified Numeric.LinearAlgebra.Static as HStatic

20−

21import Disorder.Jack

19import Disorder.Jack

23import Test.Jack.Hmatrix

21import Test.Jack.Hmatrix

@@ -32,7 +30,7 @@ instance Show OpaqueFullyConnected where

32genOpaqueFullyConnected :: Jack OpaqueFullyConnected

30genOpaqueFullyConnected :: Jack OpaqueFullyConnected

33genOpaqueFullyConnected = do

31genOpaqueFullyConnected = do

34 input :: Integer <- choose (2, 100)

32 input :: Integer <- choose (2, 100)

35− output :: Integer <- choose (2, 100)

33+ output :: Integer <- choose (1, 100)

36 let Just input' = someNatVal input

34 let Just input' = someNatVal input

37 let Just output' = someNatVal output

35 let Just output' = someNatVal output

38 case (input', output') of

36 case (input', output') of

@@ -46,11 +44,11 @@ genOpaqueFullyConnected = do

46prop_fully_connected_forwards :: Property

44prop_fully_connected_forwards :: Property

47prop_fully_connected_forwards =

45prop_fully_connected_forwards =

48 gamble genOpaqueFullyConnected $ \(OpaqueFullyConnected (fclayer :: FullyConnected i o)) ->

46 gamble genOpaqueFullyConnected $ \(OpaqueFullyConnected (fclayer :: FullyConnected i o)) ->

49− let i = fromIntegral $ natVal (Proxy :: Proxy i)

47+ gamble (S1D' <$> randomVector) $ \(input :: S' ('D1 i)) ->

50− in gamble (vectorOf i sizedRealFrac) $ \input ->

51− let x :: S' ('D1 o) = runForwards fclayer (S1D' (HStatic.vector input :: HStatic.R i))

48+ let output :: S' ('D1 o) = runForwards fclayer input

49+ backed :: (Gradient (FullyConnected i o), S' ('D1 i))

50+ = runBackwards fclayer input output

52− in x `seq` True

51+ in backed `seq` True

53−

55return []

53return []

56tests :: IO Bool

54tests :: IO Bool

test/Test/Grenade/Layers/Internal/Convolution.hs+6−8

@@ -1,15 +1,13 @@

1−{-# LANGUAGE TemplateHaskell #-}

1+{-# LANGUAGE TemplateHaskell #-}

2−{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE GADTs #-}

3+{-# LANGUAGE GADTs #-}

4−{-# LANGUAGE ScopedTypeVariables #-}

4+{-# LANGUAGE ScopedTypeVariables #-}

5−{-# LANGUAGE ConstraintKinds #-}

5+{-# LANGUAGE ConstraintKinds #-}

6−{-# LANGUAGE TypeOperators #-}

6+{-# LANGUAGE TypeOperators #-}

8{-# OPTIONS_GHC -fno-warn-missing-signatures #-}

9module Test.Grenade.Layers.Internal.Convolution where

11−-- import Control.Monad.Random

12−

13import Grenade.Layers.Internal.Convolution

11import Grenade.Layers.Internal.Convolution

15import Numeric.LinearAlgebra hiding (uniformSample, konst, (===))

13import Numeric.LinearAlgebra hiding (uniformSample, konst, (===))

test/Test/Grenade/Layers/Internal/Pooling.hs+11−31

@@ -1,9 +1,9 @@

1−{-# LANGUAGE TemplateHaskell #-}

1+{-# LANGUAGE TemplateHaskell #-}

2−{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE GADTs #-}

3+{-# LANGUAGE GADTs #-}

4−{-# LANGUAGE ScopedTypeVariables #-}

4+{-# LANGUAGE ScopedTypeVariables #-}

5−{-# LANGUAGE ConstraintKinds #-}

5+{-# LANGUAGE ConstraintKinds #-}

6−{-# LANGUAGE TypeOperators #-}

6+{-# LANGUAGE TypeOperators #-}

8{-# OPTIONS_GHC -fno-warn-missing-signatures #-}

9module Test.Grenade.Layers.Internal.Pooling where

@@ -21,38 +21,18 @@ prop_poolForwards_poolBackwards_behaves_as_reference =

21 output extent kernel stride = (extent - kernel) `div` stride + 1

22 in gamble (choose (2, 100)) $ \height ->

23 gamble (choose (2, 100)) $ \width ->

24− gamble (choose (2, height - 1)) $ \kernel_h ->

24+ gamble (choose (1, height - 1)) $ \kernel_h ->

25− gamble (choose (2, width - 1)) $ \kernel_w ->

25+ gamble (choose (1, width - 1)) $ \kernel_w ->

26 gamble (elements (ok height kernel_h)) $ \stride_h ->

27 gamble (elements (ok width kernel_w)) $ \stride_w ->

28 gamble (listOfN (height * width) (height * width) sizedRealFrac) $ \input ->

29 let input' = (height >< width) input

30 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

33 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

34+ retReference = Reference.poolBackward kernel_h kernel_w stride_h stride_w input' outReference

35− in outFast === outReference -- .&&. retFast === retReference

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−

57return []

37return []

58tests :: IO Bool

38tests :: IO Bool

test/Test/Grenade/Layers/Internal/Reference.hs+7−36

@@ -1,14 +1,6 @@

1module Test.Grenade.Layers.Internal.Reference where

3−

4−import Control.Monad.ST ( ST )

5−

6−import Data.Foldable ( forM_ )

7−import Data.Function ( on )

8−import Data.List ( maximumBy )

9−

10import Numeric.LinearAlgebra

3import Numeric.LinearAlgebra

11−import qualified Numeric.LinearAlgebra.Devel as U

13im2col :: Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double

5im2col :: Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double

14im2col nrows ncols srows scols m =

6im2col nrows ncols srows scols m =

@@ -47,7 +39,6 @@ col2imfit starts krows kcols drows dcols m =

47 accums = concatMap (\(conv',(stx',sty')) -> fmap (\((ix,iy), val) -> ((ix + stx', iy + sty'), val)) conv') pairs

39 accums = concatMap (\(conv',(stx',sty')) -> fmap (\((ix,iy), val) -> ((ix + stx', iy + sty'), val)) conv') pairs

48 in accum (konst 0 (drows, dcols)) (+) accums

40 in accum (konst 0 (drows, dcols)) (+) accums

50−

51poolForward :: Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double

42poolForward :: Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double

52poolForward nrows ncols srows scols outputRows outputCols m =

43poolForward nrows ncols srows scols outputRows outputCols m =

53 let starts = fittingStarts (rows m) nrows srows (cols m) ncols scols

44 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 =

61poolForwardFit :: [(Int,Int)] -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double

52poolForwardFit :: [(Int,Int)] -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double

62poolForwardFit starts nrows ncols _ outputCols m =

53poolForwardFit 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

64 in matrix outputCols els

55 in matrix outputCols els

66poolBackward :: Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double -> Matrix Double

57poolBackward :: Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double -> Matrix Double

@@ -76,34 +67,14 @@ poolBackwardList krows kcols srows scols inRows inCols inputMatrices =

76 in uncurry (poolBackwardFit starts krows kcols) <$> inputMatrices

67 in uncurry (poolBackwardFit starts krows kcols) <$> inputMatrices

78poolBackwardFit :: [(Int,Int)] -> Int -> Int -> Matrix Double -> Matrix Double -> Matrix Double

69poolBackwardFit :: [(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 =

80 let inRows = rows inputMatrix

71 let inRows = rows inputMatrix

81 inCols = cols inputMatrix

72 inCols = cols inputMatrix

82− gradCol = cols gradientMatrix

73+ inds = fmap (\start -> maxIndex $ subMatrix start (krows, kcols) inputMatrix) starts

83− extent = (krows, kcols)

74+ grads = toList $ flatten gradientMatrix

84−

75+ grads' = zip3 starts grads inds

85− retM <- U.newMatrix 0 inRows inCols

76+ accums = fmap (\((stx',sty'),grad,(inx, iny)) -> ((stx' + inx, sty' + iny), grad)) grads'

86−

77+ in accum (konst 0 (inRows, inCols)) (+) accums

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−

107

108-- | These functions are not even remotely safe, but it's only called from the statically typed

79-- | These functions are not even remotely safe, but it's only called from the statically typed

109-- commands, so we should be good ?!?!?

80-- commands, so we should be good ?!?!?