mirror of
https://github.com/HuwCampbell/grenade.git
synced 2024-09-11 09:45:55 +03:00
Better testing
This commit is contained in:
parent
424d791a30
commit
88021fbde7
@ -20,8 +20,6 @@ import Grenade.Core.Shape
|
|||||||
import Grenade.Core.Network
|
import Grenade.Core.Network
|
||||||
import Grenade.Layers.Convolution
|
import Grenade.Layers.Convolution
|
||||||
|
|
||||||
import qualified Numeric.LinearAlgebra.Static as HStatic
|
|
||||||
|
|
||||||
import Disorder.Jack
|
import Disorder.Jack
|
||||||
|
|
||||||
import Test.Jack.Hmatrix
|
import Test.Jack.Hmatrix
|
||||||
@ -61,7 +59,6 @@ prop_conv_net =
|
|||||||
(case onet of
|
(case onet of
|
||||||
(OpaqueConvolution (convLayer@(Convolution _ _) :: Convolution channels filters kernelRows kernelCols strideRows strideCols)) ->
|
(OpaqueConvolution (convLayer@(Convolution _ _) :: Convolution channels filters kernelRows kernelCols strideRows strideCols)) ->
|
||||||
let ok stride kernel = [extent | extent <- [(kernel + 1) .. 30 ], (extent - kernel) `mod` stride == 0]
|
let ok stride kernel = [extent | extent <- [(kernel + 1) .. 30 ], (extent - kernel) `mod` stride == 0]
|
||||||
ch = fromIntegral $ natVal (Proxy :: Proxy channels)
|
|
||||||
kr = fromIntegral $ natVal (Proxy :: Proxy kernelRows)
|
kr = fromIntegral $ natVal (Proxy :: Proxy kernelRows)
|
||||||
kc = fromIntegral $ natVal (Proxy :: Proxy kernelCols)
|
kc = fromIntegral $ natVal (Proxy :: Proxy kernelCols)
|
||||||
sr = fromIntegral $ natVal (Proxy :: Proxy strideRows)
|
sr = fromIntegral $ natVal (Proxy :: Proxy strideRows)
|
||||||
@ -69,26 +66,26 @@ prop_conv_net =
|
|||||||
|
|
||||||
in gamble (elements (ok sr kr)) $ \er ->
|
in gamble (elements (ok sr kr)) $ \er ->
|
||||||
gamble (elements (ok sc kc)) $ \ec ->
|
gamble (elements (ok sc kc)) $ \ec ->
|
||||||
let i = fromIntegral (er * ec * ch)
|
let rr = ((er - kr) `div` sr) + 1
|
||||||
rr = ((er - kr) `div` sr) + 1
|
|
||||||
rc = ((ec - kc) `div` sc) + 1
|
rc = ((ec - kc) `div` sc) + 1
|
||||||
er' = someNatVal er
|
Just er' = someNatVal er
|
||||||
ec' = someNatVal ec
|
Just ec' = someNatVal ec
|
||||||
rr' = someNatVal rr
|
Just rr' = someNatVal rr
|
||||||
rc' = someNatVal rc
|
Just rc' = someNatVal rc
|
||||||
in gamble (vectorOf i sizedRealFrac) $ \(input :: [Double]) ->
|
in (case (er', ec', rr', rc') of
|
||||||
case (er', ec', rr', rc') of
|
( SomeNat (pinr :: Proxy inRows), SomeNat (_ :: Proxy inCols), SomeNat (pour :: Proxy outRows), SomeNat (_ :: Proxy outCols)) ->
|
||||||
(Just (SomeNat (pinr :: Proxy inRows)), Just (SomeNat (_ :: Proxy inCols)), Just (SomeNat (pour :: Proxy outRows)), Just (SomeNat (_ :: Proxy outCols))) ->
|
case ( natDict pinr %* natDict (Proxy :: Proxy channels)
|
||||||
let p1 = natDict pinr
|
, natDict pour %* natDict (Proxy :: Proxy filters)
|
||||||
p2 = natDict pour
|
-- Fake it till you make it.
|
||||||
in case ( p1 %* natDict (Proxy :: Proxy channels)
|
, (unsafeCoerce (Dict :: Dict ()) :: Dict (((outRows - 1) * strideRows) ~ (inRows - kernelRows)))
|
||||||
, p2 %* natDict (Proxy :: Proxy filters)
|
, (unsafeCoerce (Dict :: Dict ()) :: Dict (((outCols - 1) * strideCols) ~ (inCols - kernelCols)))) of
|
||||||
-- Fake it till you make it.
|
(Dict, Dict, Dict, Dict) ->
|
||||||
, (unsafeCoerce (Dict :: Dict ()) :: Dict (((outRows - 1) * strideRows) ~ (inRows - kernelRows)))
|
gamble (S3D' <$> uniformSample) $ \(input :: S' ('D3 inRows inCols channels)) ->
|
||||||
, (unsafeCoerce (Dict :: Dict ()) :: Dict (((outCols - 1) * strideCols) ~ (inCols - kernelCols)))) of
|
let output :: S' ('D3 outRows outCols filters) = runForwards convLayer input
|
||||||
(Dict, Dict, Dict, Dict) -> let x :: S' ('D3 outRows outCols filters) = runForwards convLayer ((S3D' (HStatic.matrix input)) :: S' ('D3 inRows inCols channels))
|
backed :: (Gradient (Convolution channels filters kernelRows kernelCols strideRows strideCols), S' ('D3 inRows inCols channels))
|
||||||
in x `seq` True
|
= runBackwards convLayer input output
|
||||||
_ -> False
|
in backed `seq` True
|
||||||
|
) :: Property
|
||||||
) :: Property
|
) :: Property
|
||||||
|
|
||||||
return []
|
return []
|
||||||
|
@ -16,8 +16,6 @@ import Grenade.Core.Shape
|
|||||||
import Grenade.Core.Network
|
import Grenade.Core.Network
|
||||||
import Grenade.Layers.FullyConnected
|
import Grenade.Layers.FullyConnected
|
||||||
|
|
||||||
import qualified Numeric.LinearAlgebra.Static as HStatic
|
|
||||||
|
|
||||||
import Disorder.Jack
|
import Disorder.Jack
|
||||||
|
|
||||||
import Test.Jack.Hmatrix
|
import Test.Jack.Hmatrix
|
||||||
@ -32,7 +30,7 @@ instance Show OpaqueFullyConnected where
|
|||||||
genOpaqueFullyConnected :: Jack OpaqueFullyConnected
|
genOpaqueFullyConnected :: Jack OpaqueFullyConnected
|
||||||
genOpaqueFullyConnected = do
|
genOpaqueFullyConnected = do
|
||||||
input :: Integer <- choose (2, 100)
|
input :: Integer <- choose (2, 100)
|
||||||
output :: Integer <- choose (2, 100)
|
output :: Integer <- choose (1, 100)
|
||||||
let Just input' = someNatVal input
|
let Just input' = someNatVal input
|
||||||
let Just output' = someNatVal output
|
let Just output' = someNatVal output
|
||||||
case (input', output') of
|
case (input', output') of
|
||||||
@ -46,11 +44,11 @@ genOpaqueFullyConnected = do
|
|||||||
prop_fully_connected_forwards :: Property
|
prop_fully_connected_forwards :: Property
|
||||||
prop_fully_connected_forwards =
|
prop_fully_connected_forwards =
|
||||||
gamble genOpaqueFullyConnected $ \(OpaqueFullyConnected (fclayer :: FullyConnected i o)) ->
|
gamble genOpaqueFullyConnected $ \(OpaqueFullyConnected (fclayer :: FullyConnected i o)) ->
|
||||||
let i = fromIntegral $ natVal (Proxy :: Proxy i)
|
gamble (S1D' <$> randomVector) $ \(input :: S' ('D1 i)) ->
|
||||||
in gamble (vectorOf i sizedRealFrac) $ \input ->
|
let output :: S' ('D1 o) = runForwards fclayer input
|
||||||
let x :: S' ('D1 o) = runForwards fclayer (S1D' (HStatic.vector input :: HStatic.R i))
|
backed :: (Gradient (FullyConnected i o), S' ('D1 i))
|
||||||
in x `seq` True
|
= runBackwards fclayer input output
|
||||||
|
in backed `seq` True
|
||||||
|
|
||||||
return []
|
return []
|
||||||
tests :: IO Bool
|
tests :: IO Bool
|
||||||
|
@ -1,15 +1,13 @@
|
|||||||
{-# LANGUAGE TemplateHaskell #-}
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
{-# LANGUAGE DataKinds #-}
|
{-# LANGUAGE DataKinds #-}
|
||||||
{-# LANGUAGE GADTs #-}
|
{-# LANGUAGE GADTs #-}
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
{-# LANGUAGE ConstraintKinds #-}
|
{-# LANGUAGE ConstraintKinds #-}
|
||||||
{-# LANGUAGE TypeOperators #-}
|
{-# LANGUAGE TypeOperators #-}
|
||||||
|
|
||||||
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
|
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
|
||||||
module Test.Grenade.Layers.Internal.Convolution where
|
module Test.Grenade.Layers.Internal.Convolution where
|
||||||
|
|
||||||
-- import Control.Monad.Random
|
|
||||||
|
|
||||||
import Grenade.Layers.Internal.Convolution
|
import Grenade.Layers.Internal.Convolution
|
||||||
|
|
||||||
import Numeric.LinearAlgebra hiding (uniformSample, konst, (===))
|
import Numeric.LinearAlgebra hiding (uniformSample, konst, (===))
|
||||||
|
@ -1,9 +1,9 @@
|
|||||||
{-# LANGUAGE TemplateHaskell #-}
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
{-# LANGUAGE DataKinds #-}
|
{-# LANGUAGE DataKinds #-}
|
||||||
{-# LANGUAGE GADTs #-}
|
{-# LANGUAGE GADTs #-}
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
{-# LANGUAGE ConstraintKinds #-}
|
{-# LANGUAGE ConstraintKinds #-}
|
||||||
{-# LANGUAGE TypeOperators #-}
|
{-# LANGUAGE TypeOperators #-}
|
||||||
|
|
||||||
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
|
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
|
||||||
module Test.Grenade.Layers.Internal.Pooling where
|
module Test.Grenade.Layers.Internal.Pooling where
|
||||||
@ -21,38 +21,18 @@ prop_poolForwards_poolBackwards_behaves_as_reference =
|
|||||||
output extent kernel stride = (extent - kernel) `div` stride + 1
|
output extent kernel stride = (extent - kernel) `div` stride + 1
|
||||||
in gamble (choose (2, 100)) $ \height ->
|
in gamble (choose (2, 100)) $ \height ->
|
||||||
gamble (choose (2, 100)) $ \width ->
|
gamble (choose (2, 100)) $ \width ->
|
||||||
gamble (choose (2, height - 1)) $ \kernel_h ->
|
gamble (choose (1, height - 1)) $ \kernel_h ->
|
||||||
gamble (choose (2, width - 1)) $ \kernel_w ->
|
gamble (choose (1, width - 1)) $ \kernel_w ->
|
||||||
gamble (elements (ok height kernel_h)) $ \stride_h ->
|
gamble (elements (ok height kernel_h)) $ \stride_h ->
|
||||||
gamble (elements (ok width kernel_w)) $ \stride_w ->
|
gamble (elements (ok width kernel_w)) $ \stride_w ->
|
||||||
gamble (listOfN (height * width) (height * width) sizedRealFrac) $ \input ->
|
gamble (listOfN (height * width) (height * width) sizedRealFrac) $ \input ->
|
||||||
let input' = (height >< width) input
|
let input' = (height >< width) input
|
||||||
outFast = poolForward 1 height width kernel_h kernel_w stride_h stride_w input'
|
outFast = poolForward 1 height width kernel_h kernel_w stride_h stride_w input'
|
||||||
-- retFast = poolBackward 1 height width kernel_h kernel_w stride_h stride_w input' outFast
|
retFast = poolBackward 1 height width kernel_h kernel_w stride_h stride_w input' outFast
|
||||||
|
|
||||||
outReference = Reference.poolForward kernel_h kernel_w stride_h stride_w (output height kernel_h stride_h) (output width kernel_w stride_w) input'
|
outReference = Reference.poolForward kernel_h kernel_w stride_h stride_w (output height kernel_h stride_h) (output width kernel_w stride_w) input'
|
||||||
-- retReference = Reference.poolBackward kernel_h kernel_w stride_h stride_w input' outReference
|
retReference = Reference.poolBackward kernel_h kernel_w stride_h stride_w input' outReference
|
||||||
in outFast === outReference -- .&&. retFast === retReference
|
in outFast === outReference .&&. retFast === retReference
|
||||||
|
|
||||||
|
|
||||||
prop_poolForwards_poolBackwards_symmetry =
|
|
||||||
let factors n = [x | x <- [1..n], n `mod` x == 0]
|
|
||||||
output extent kernel stride = (extent - kernel) `div` stride + 1
|
|
||||||
in gamble (choose (2, 100)) $ \height ->
|
|
||||||
gamble (choose (2, 100)) $ \width ->
|
|
||||||
gamble ((height `div`) <$> elements (factors height)) $ \kernel_h ->
|
|
||||||
gamble ((width `div`) <$> elements (factors width)) $ \kernel_w ->
|
|
||||||
gamble (listOfN (height * width) (height * width) sizedRealFrac) $ \input ->
|
|
||||||
let input' = (height >< width) input
|
|
||||||
stride_h = kernel_h
|
|
||||||
stride_w = kernel_w
|
|
||||||
outFast = poolForward 1 height width kernel_h kernel_w stride_h stride_w input'
|
|
||||||
retFast = poolBackward 1 height width kernel_h kernel_w stride_h stride_w input' outFast
|
|
||||||
|
|
||||||
outReference = Reference.poolForward kernel_h kernel_w stride_h stride_w (output height kernel_h stride_h) (output width kernel_w stride_w) input'
|
|
||||||
retReference = Reference.poolBackward kernel_h kernel_w stride_h stride_w input' outReference
|
|
||||||
in outFast === outReference .&&. retFast === retReference
|
|
||||||
|
|
||||||
|
|
||||||
return []
|
return []
|
||||||
tests :: IO Bool
|
tests :: IO Bool
|
||||||
|
@ -1,14 +1,6 @@
|
|||||||
module Test.Grenade.Layers.Internal.Reference where
|
module Test.Grenade.Layers.Internal.Reference where
|
||||||
|
|
||||||
|
|
||||||
import Control.Monad.ST ( ST )
|
|
||||||
|
|
||||||
import Data.Foldable ( forM_ )
|
|
||||||
import Data.Function ( on )
|
|
||||||
import Data.List ( maximumBy )
|
|
||||||
|
|
||||||
import Numeric.LinearAlgebra
|
import Numeric.LinearAlgebra
|
||||||
import qualified Numeric.LinearAlgebra.Devel as U
|
|
||||||
|
|
||||||
im2col :: Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double
|
im2col :: Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double
|
||||||
im2col nrows ncols srows scols m =
|
im2col nrows ncols srows scols m =
|
||||||
@ -47,7 +39,6 @@ col2imfit starts krows kcols drows dcols m =
|
|||||||
accums = concatMap (\(conv',(stx',sty')) -> fmap (\((ix,iy), val) -> ((ix + stx', iy + sty'), val)) conv') pairs
|
accums = concatMap (\(conv',(stx',sty')) -> fmap (\((ix,iy), val) -> ((ix + stx', iy + sty'), val)) conv') pairs
|
||||||
in accum (konst 0 (drows, dcols)) (+) accums
|
in accum (konst 0 (drows, dcols)) (+) accums
|
||||||
|
|
||||||
|
|
||||||
poolForward :: Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double
|
poolForward :: Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double
|
||||||
poolForward nrows ncols srows scols outputRows outputCols m =
|
poolForward nrows ncols srows scols outputRows outputCols m =
|
||||||
let starts = fittingStarts (rows m) nrows srows (cols m) ncols scols
|
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 =
|
|||||||
|
|
||||||
poolForwardFit :: [(Int,Int)] -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double
|
poolForwardFit :: [(Int,Int)] -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double
|
||||||
poolForwardFit starts nrows ncols _ outputCols m =
|
poolForwardFit starts nrows ncols _ outputCols m =
|
||||||
let els = fmap (\start -> unsafeMaxElementSubmatrix start (nrows, ncols) m) starts
|
let els = fmap (\start -> maxElement $ subMatrix start (nrows, ncols) m) starts
|
||||||
in matrix outputCols els
|
in matrix outputCols els
|
||||||
|
|
||||||
poolBackward :: Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double -> Matrix Double
|
poolBackward :: Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double -> Matrix Double
|
||||||
@ -76,34 +67,14 @@ poolBackwardList krows kcols srows scols inRows inCols inputMatrices =
|
|||||||
in uncurry (poolBackwardFit starts krows kcols) <$> inputMatrices
|
in uncurry (poolBackwardFit starts krows kcols) <$> inputMatrices
|
||||||
|
|
||||||
poolBackwardFit :: [(Int,Int)] -> Int -> Int -> Matrix Double -> Matrix Double -> Matrix Double
|
poolBackwardFit :: [(Int,Int)] -> Int -> Int -> Matrix Double -> Matrix Double -> Matrix Double
|
||||||
poolBackwardFit starts krows kcols inputMatrix gradientMatrix = U.runSTMatrix $ do
|
poolBackwardFit starts krows kcols inputMatrix gradientMatrix =
|
||||||
let inRows = rows inputMatrix
|
let inRows = rows inputMatrix
|
||||||
inCols = cols inputMatrix
|
inCols = cols inputMatrix
|
||||||
gradCol = cols gradientMatrix
|
inds = fmap (\start -> maxIndex $ subMatrix start (krows, kcols) inputMatrix) starts
|
||||||
extent = (krows, kcols)
|
grads = toList $ flatten gradientMatrix
|
||||||
|
grads' = zip3 starts grads inds
|
||||||
retM <- U.newMatrix 0 inRows inCols
|
accums = fmap (\((stx',sty'),grad,(inx, iny)) -> ((stx' + inx, sty' + iny), grad)) grads'
|
||||||
|
in accum (konst 0 (inRows, inCols)) (+) accums
|
||||||
forM_ (zip [0..] starts) $ \(ix, start) -> do
|
|
||||||
let loc = unsafeMaxIndexSubMatrix start extent inputMatrix
|
|
||||||
uncurry (unsafeModifyMatrix retM) loc ((+) $ uncurry (U.atM' gradientMatrix) $ divMod ix gradCol)
|
|
||||||
|
|
||||||
return retM
|
|
||||||
|
|
||||||
unsafeMaxElementSubmatrix :: (Int,Int) -> (Int,Int) -> Matrix Double -> Double
|
|
||||||
unsafeMaxElementSubmatrix starts extent m = uncurry (U.atM' m) $ unsafeMaxIndexSubMatrix starts extent m
|
|
||||||
|
|
||||||
unsafeMaxIndexSubMatrix :: (Int,Int) -> (Int,Int) -> Matrix Double -> (Int, Int)
|
|
||||||
unsafeMaxIndexSubMatrix (startRow, startCol) (extentRow, extentCold) m =
|
|
||||||
let mrows = [startRow .. startRow + extentRow - 1]
|
|
||||||
mcols = [startCol .. startCol + extentCold - 1]
|
|
||||||
pairs = concatMap ( \r -> fmap (\c -> (r , c)) mcols ) mrows
|
|
||||||
in maximumBy (compare `on` uncurry (U.atM' m)) pairs
|
|
||||||
|
|
||||||
|
|
||||||
unsafeModifyMatrix :: U.STMatrix s Double -> Int -> Int -> (Double -> Double) -> ST s ()
|
|
||||||
unsafeModifyMatrix x r c f = U.unsafeReadMatrix x r c >>= U.unsafeWriteMatrix x r c . f
|
|
||||||
|
|
||||||
|
|
||||||
-- | These functions are not even remotely safe, but it's only called from the statically typed
|
-- | These functions are not even remotely safe, but it's only called from the statically typed
|
||||||
-- commands, so we should be good ?!?!?
|
-- commands, so we should be good ?!?!?
|
||||||
|
Loading…
Reference in New Issue
Block a user