e6179ce · grenade · git.iko.soy

git.iko.soy/grenade

Add recurrent tapes

commite6179ce5a4d12b2a0ed587ed531e22364287d126 authorHuw Campbell <huw.campbell@ambiata.com> dateSat 28 Jan 2017, 14:13 (10 years ago) parentd82a121

12 files changed+77−20

compare with master

unifiedsplit

grenade.cabal+1 main/mnist.hs+1−1 src/Grenade.hs+1 src/Grenade/Core/Network.hs−1 src/Grenade/Core/Shape.hs+1 src/Grenade/Recurrent/Core/Network.hs+4−2 src/Grenade/Recurrent/Core/Runner.hs+14−12 src/Grenade/Recurrent/Layers/BasicRecurrent.hs+4−2 src/Grenade/Recurrent/Layers/LSTM.hs+4−2 test/Test/Jack/Hmatrix.hs+12 test/Test/Jack/TypeLits.hs+33 test/test.hs+2

grenade.cabal+1

@@ -54,6 +54,7 @@ library

5454 Grenade.Layers.Fuse

5555 Grenade.Layers.Logit

5656 Grenade.Layers.Relu

57+ Grenade.Layers.Elu

5758 Grenade.Layers.Tanh

5859 Grenade.Layers.Pad

5960 Grenade.Layers.Pooling

main/mnist.hs+1−1

@@ -33,7 +33,7 @@ import Grenade.Utils.OneHot

3333

3434-- With the mnist data from Kaggle normalised to doubles between 0 and 1, learning rate of 0.01 and 15 iterations,

3535-- this network should get down to about a 1.3% error rate.

36−type MNIST = Network '[ Convolution 1 10 5 5 1 1, Pooling 2 2 2 2, Relu, Convolution 10 16 5 5 1 1, Pooling 2 2 2 2, Relu, FlattenLayer, FullyConnected 256 80, Logit, FullyConnected 80 10, Logit]

36+type MNIST = Network '[ Convolution 1 10 5 5 1 1, Pooling 2 2 2 2, Elu, Convolution 10 16 5 5 1 1, Pooling 2 2 2 2, Elu, FlattenLayer, FullyConnected 256 80, Logit, FullyConnected 80 10, Logit]

3737 '[ 'D2 28 28, 'D3 24 24 10, 'D3 12 12 10, 'D3 12 12 10, 'D3 8 8 16, 'D3 4 4 16, 'D3 4 4 16, 'D1 256, 'D1 80, 'D1 80, 'D1 10, 'D1 10]

3838

3939randomMnist :: MonadRandom m => m MNIST

src/Grenade.hs+1

@@ -15,5 +15,6 @@ import Grenade.Layers.FullyConnected as X

1515import Grenade.Layers.Logit as X

1616import Grenade.Layers.Convolution as X

1717import Grenade.Layers.Relu as X

18+import Grenade.Layers.Elu as X

1819import Grenade.Layers.Tanh as X

1920import Grenade.Layers.Softmax as X

src/Grenade/Core/Network.hs−1

@@ -91,7 +91,6 @@ instance Show (Network '[] '[i]) where

9191instance (Show x, Show (Network xs rs)) => Show (Network (x ': xs) (i ': rs)) where

9292 show (x :~> xs) = show x ++ "\n~>\n" ++ show xs

9393

94−

9594-- | Gradients of a network.

9695-- Parameterised on the layers of a Network.

9796data Gradients :: [*] -> * where

src/Grenade/Core/Shape.hs+1

@@ -25,6 +25,7 @@ are understood by Grenade.

2525module Grenade.Core.Shape (

2626 Shape (..)

2727 , S (..)

28+ , Sing (..)

2829 , randomOfShape

2930 , fromStorable

3031 ) where

src/Grenade/Recurrent/Core/Network.hs+4−2

@@ -43,14 +43,16 @@ class UpdateLayer x => RecurrentUpdateLayer x where

4343 type RecurrentShape x :: Shape

4444

4545class (RecurrentUpdateLayer x, SingI (RecurrentShape x)) => RecurrentLayer x (i :: Shape) (o :: Shape) where

46+ -- | Wengert Tape

47+ type RecTape x i o :: *

4648 -- | Used in training and scoring. Take the input from the previous

4749 -- layer, and give the output from this layer.

48− runRecurrentForwards :: x -> S (RecurrentShape x) -> S i -> (S (RecurrentShape x), S o)

50+ runRecurrentForwards :: x -> S (RecurrentShape x) -> S i -> (RecTape x i o, S (RecurrentShape x), S o)

4951 -- | Back propagate a step. Takes the current layer, the input that the

5052 -- layer gave from the input and the back propagated derivatives from

5153 -- the layer above.

5254 -- Returns the gradient layer and the derivatives to push back further.

53− runRecurrentBackwards :: x -> S (RecurrentShape x) -> S i -> S (RecurrentShape x) -> S o -> (Gradient x, S (RecurrentShape x), S i)

55+ runRecurrentBackwards :: x -> RecTape x i o -> S (RecurrentShape x) -> S o -> (Gradient x, S (RecurrentShape x), S i)

5456

5557data RecurrentNetwork :: [*] -> [Shape] -> * where

5658 RNil :: SingI i => RecurrentNetwork '[] '[i]

src/Grenade/Recurrent/Core/Runner.hs+14−12

@@ -66,11 +66,13 @@ trainRecurrent rate network recinputs examples =

6666 -- This is a recurrent layer, so we need to do a scan, first input to last, providing

6767 -- the recurrent shape output to the next layer.

6868 go !xs (layer :~@> n) (g :~@+> nIn)

69− = let ys = scanlFrom layer g xs

69+ = let tys = scanlFrom layer g xs

70+ tapes = fst <$> tys

71+ ys = snd <$> tys

7072

71− (newFN, ig, grads) = go (snd <$> ys) n nIn

73+ (newFN, ig, grads) = go ys n nIn

7274

73− backExamples = zip3 (fst <$> reverse ys) (reverse xs) grads

75+ backExamples = zip (reverse tapes) grads

7476

7577 (rg, back) = myscanbackward layer backExamples

7678 -- the new trained layer.

@@ -105,22 +107,22 @@ scanlFrom :: forall x i o. RecurrentLayer x i o

105107 => x -- ^ the layer

106108 -> S (RecurrentShape x) -- ^ place to start

107109 -> [S i] -- ^ list of inputs to scan through

108− -> [(S (RecurrentShape x), S o)] -- ^ list of scan inputs and outputs

110+ -> [(RecTape x i o, S o)] -- ^ list of scan inputs and outputs

109111scanlFrom !layer !recShape (x:xs) =

110− let (lerec, lepush) = runRecurrentForwards layer recShape x

111− in (recShape, lepush) : scanlFrom layer lerec xs

112+ let (tape, lerec, lepush) = runRecurrentForwards layer recShape x

113+ in (tape, lepush) : scanlFrom layer lerec xs

112114scanlFrom _ _ [] = []

113115

114116myscanbackward :: forall x i o. RecurrentLayer x i o

115117 => x -- ^ the layer

116− -> [(S (RecurrentShape x), S i, S o)] -- ^ the list of inputs and output to scan over

118+ -> [(RecTape x i o, S o)] -- ^ the list of inputs and output to scan over

117119 -> (S (RecurrentShape x), [(Gradient x, S i)]) -- ^ list of gradients to fold and inputs to backprop

118120myscanbackward layer =

119121 goX 0

120122 where

121− goX :: S (RecurrentShape x) -> [(S (RecurrentShape x), S i, S o)] -> (S (RecurrentShape x), [(Gradient x, S i)])

122− goX !lastback ((recShape, lastin, backgrad):xs) =

123− let (layergrad, recgrad, ingrad) = runRecurrentBackwards layer recShape lastin lastback backgrad

123+ goX :: S (RecurrentShape x) -> [(RecTape x i o, S o)] -> (S (RecurrentShape x), [(Gradient x, S i)])

124+ goX !lastback ((recTape, backgrad):xs) =

125+ let (layergrad, recgrad, ingrad) = runRecurrentBackwards layer recTape lastback backgrad

124126 (pushedback, ll) = goX recgrad xs

125127 in (pushedback, (layergrad, ingrad) : ll)

126128 goX !lastback [] = (lastback, [])

@@ -134,8 +136,8 @@ runRecurrent (layer :~~> n) (() :~~+> nr) !x

134136 (nr', o) = runRecurrent n nr ys

135137 in (() :~~+> nr', o)

136138runRecurrent (layer :~@> n) (recin :~@+> nr) !x

137− = let (recin', y) = runRecurrentForwards layer recin x

138− (nr', o) = runRecurrent n nr y

139+ = let (_, recin', y) = runRecurrentForwards layer recin x

140+ (nr', o) = runRecurrent n nr y

139141 in (recin' :~@+> nr', o)

140142runRecurrent RNil RINil !x

141143 = (RINil, x)

src/Grenade/Recurrent/Layers/BasicRecurrent.hs+4−2

@@ -72,13 +72,15 @@ instance (KnownNat i, KnownNat o, KnownNat (i + o), i <= (i + o), o ~ ((i + o) -

7272 type RecurrentShape (BasicRecurrent i o) = 'D1 o

7373

7474instance (KnownNat i, KnownNat o, KnownNat (i + o), i <= (i + o), o ~ ((i + o) - i)) => RecurrentLayer (BasicRecurrent i o) ('D1 i) ('D1 o) where

75+

76+ type RecTape (BasicRecurrent i o) ('D1 i) ('D1 o) = (S ('D1 o), S ('D1 i))

7577 -- Do a matrix vector multiplication and return the result.

7678 runRecurrentForwards (BasicRecurrent wB _ wN _) (S1D lastOutput) (S1D thisInput) =

7779 let thisOutput = S1D $ wB + wN #> (thisInput # lastOutput)

78− in (thisOutput, thisOutput)

80+ in ((S1D lastOutput, S1D thisInput), thisOutput, thisOutput)

7981

8082 -- Run a backpropogation step for a full connected layer.

81− runRecurrentBackwards (BasicRecurrent _ _ wN _) (S1D lastOutput) (S1D thisInput) (S1D dRec) (S1D dEdy) =

83+ runRecurrentBackwards (BasicRecurrent _ _ wN _) (S1D lastOutput, S1D thisInput) (S1D dRec) (S1D dEdy) =

8284 let biasGradient = (dRec + dEdy)

8385 layerGrad = (dRec + dEdy) `outer` (thisInput # lastOutput)

8486 -- calcluate derivatives for next step

src/Grenade/Recurrent/Layers/LSTM.hs+4−2

@@ -131,6 +131,8 @@ instance (KnownNat i, KnownNat o) => RecurrentUpdateLayer (LSTM i o) where

131131 type RecurrentShape (LSTM i o) = 'D1 o

132132

133133instance (KnownNat i, KnownNat o) => RecurrentLayer (LSTM i o) ('D1 i) ('D1 o) where

134+

135+ type RecTape (LSTM i o) ('D1 i) ('D1 o) = (S ('D1 o), S ('D1 i))

134136 -- Forward propagation for the LSTM layer.

135137 -- The size of the cell state is also the size of the output.

136138 runRecurrentForwards (LSTM (LSTMWeights {..}) _) (S1D cell) (S1D input) =

@@ -146,7 +148,7 @@ instance (KnownNat i, KnownNat o) => RecurrentLayer (LSTM i o) ('D1 i) ('D1 o) w

146148 c_t = f_t * cell + i_t * c_x

147149 -- Output (it's sometimes recommended to use tanh c_t)

148150 h_t = o_t * c_t

149− in (S1D c_t, S1D h_t)

151+ in ((S1D cell, S1D input), S1D c_t, S1D h_t)

150152

151153 -- Run a backpropogation step for an LSTM layer.

152154 -- We're doing all the derivatives by hand here, so one should

@@ -154,7 +156,7 @@ instance (KnownNat i, KnownNat o) => RecurrentLayer (LSTM i o) ('D1 i) ('D1 o) w

154156 --

155157 -- There's a test version using the AD library without hmatrix in the test

156158 -- suite. These should match always.

157− runRecurrentBackwards (LSTM (LSTMWeights {..}) _) (S1D cell) (S1D input) (S1D cellGrad) (S1D h_t') =

159+ runRecurrentBackwards (LSTM (LSTMWeights {..}) _) (S1D cell, S1D input) (S1D cellGrad) (S1D h_t') =

158160 -- We're not keeping the Wengert tape during the forward pass,

159161 -- so we're duplicating some work here.

160162 --

test/Test/Jack/Hmatrix.hs+12

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

11{-# LANGUAGE RankNTypes #-}

22{-# LANGUAGE DataKinds #-}

33{-# LANGUAGE ScopedTypeVariables #-}

4+{-# LANGUAGE GADTs #-}

56module Test.Jack.Hmatrix where

8+import Grenade

9+import Data.Singletons

10+

711import Disorder.Jack

812

913import GHC.TypeLits

@@ -15,3 +19,11 @@ randomVector = (\s -> HStatic.randomVector s HStatic.Uniform * 2 - 1) <$> sizedN

1519

1620uniformSample :: forall m n. (KnownNat m, KnownNat n) => Jack (HStatic.L m n)

1721uniformSample = (\s -> HStatic.uniformSample s (-1) 1 ) <$> sizedNat

22+

23+-- | Generate random data of the desired shape

24+genOfShape :: forall x. ( SingI x ) => Jack (S x)

25+genOfShape =

26+ case (sing :: Sing x) of

27+ D1Sing -> S1D <$> randomVector

28+ D2Sing -> S2D <$> uniformSample

29+ D3Sing -> S3D <$> uniformSample

test/Test/Jack/TypeLits.hs+33

@@ -4,11 +4,44 @@

55module Test.Jack.TypeLits where

7+import Data.Constraint

8+import Data.Singletons

79import Disorder.Jack

810

11+import Grenade

12+

913import GHC.TypeLits

14+import GHC.TypeLits.Witnesses

1015

1116genNat :: Jack SomeNat

1217genNat = do

1318 Just n <- someNatVal <$> choose (1, 10)

1419 return n

20+

21+genShape :: Jack (SomeSing Shape)

22+genShape

23+ = oneOf [

24+ genD1

25+ , genD2

26+ , genD3

27+ ]

28+ where

29+ genD1 = do

30+ n <- genNat

31+ return $ case n of

32+ SomeNat (_ :: Proxy x) -> SomeSing (sing :: Sing ('D1 x))

33+

34+ genD2 = do

35+ n <- genNat

36+ m <- genNat

37+ return $ case (n, m) of

38+ (SomeNat (_ :: Proxy x), SomeNat (_ :: Proxy y)) -> SomeSing (sing :: Sing ('D2 x y))

39+

40+ genD3 = do

41+ n <- genNat

42+ m <- genNat

43+ o <- genNat

44+ return $ case (n, m, o) of

45+ (SomeNat (px :: Proxy x), SomeNat (_ :: Proxy y), SomeNat (pz :: Proxy z)) ->

46+ case natDict px %* natDict pz of

47+ Dict -> SomeSing (sing :: Sing ('D3 x y z))

test/test.hs+2

@@ -3,6 +3,7 @@ import Disorder.Core.Main

33import qualified Test.Grenade.Layers.Pooling

44import qualified Test.Grenade.Layers.Convolution

55import qualified Test.Grenade.Layers.FullyConnected

6+import qualified Test.Grenade.Layers.Nonlinear

78import qualified Test.Grenade.Layers.Internal.Convolution

89import qualified Test.Grenade.Layers.Internal.Pooling

@@ -15,6 +16,7 @@ main =

1516 Test.Grenade.Layers.Pooling.tests

1617 , Test.Grenade.Layers.Convolution.tests

1718 , Test.Grenade.Layers.FullyConnected.tests

19+ , Test.Grenade.Layers.Nonlinear.tests

1820

1921 , Test.Grenade.Layers.Internal.Convolution.tests

2022 , Test.Grenade.Layers.Internal.Pooling.tests