148c777 · grenade · git.iko.soy

git.iko.soy/grenade

Simplify Network Type

commit148c7778ab4f6adafb124558d26188f066413d2e authorHuw Campbell <huw.campbell@ambiata.com> dateMon 23 Jan 2017, 12:47 (10 years ago) parent6ad9803

11 files changed+74−115

compare with master

unifiedsplit

main/recurrent.hs+4−5 src/Grenade/Core/Network.hs+10−11 src/Grenade/Core/Runner.hs+6−12 src/Grenade/Layers/Dropout.hs+13−19 src/Grenade/Layers/FullyConnected.hs+2−1 src/Grenade/Layers/Logit.hs+6−15 src/Grenade/Layers/Tanh.hs+1−1 src/Grenade/Recurrent/Core/Network.hs+17−20 src/Grenade/Recurrent/Core/Runner.hs+10−26 test/Test/Grenade/Layers/Convolution.hs+2−2 test/Test/Grenade/Layers/FullyConnected.hs+3−3

main/recurrent.hs+4−5

@@ -22,13 +22,12 @@ import Grenade.Recurrent

2222--

2323-- The F and R types are Tagging types to ensure that the runner and

2424-- creation function know how to treat the layers.

25−type F = FeedForward

2625type R = Recurrent

2726

28−type RecNet = RecurrentNetwork '[ R (LSTM 1 4), R (LSTM 4 1), F Trivial]

29− '[ 'D1 1, 'D1 4, 'D1 1, 'D1 1 ]

27+type RecNet = RecurrentNetwork '[ R (LSTM 1 4), R (LSTM 4 1)]

28+ '[ 'D1 1, 'D1 4, 'D1 1 ]

3029

31−type RecInput = RecurrentInputs '[ R (LSTM 1 4), R (LSTM 4 1), F Trivial]

30+type RecInput = RecurrentInputs '[ R (LSTM 1 4), R (LSTM 4 1)]

3231

3332randomNet :: MonadRandom m => m (RecNet, RecInput)

3433randomNet = randomRecurrent

@@ -51,7 +50,7 @@ netTest net0 i0 rate iterations =

5150data FeedForwardOpts = FeedForwardOpts Int LearningParameters

5251

5352feedForward' :: Parser FeedForwardOpts

54−feedForward' = FeedForwardOpts <$> option auto (long "examples" <> short 'e' <> value 20000)

53+feedForward' = FeedForwardOpts <$> option auto (long "examples" <> short 'e' <> value 40000)

5554 <*> (LearningParameters

5655 <$> option auto (long "train_rate" <> short 'r' <> value 0.01)

5756 <*> option auto (long "momentum" <> value 0.9)

src/Grenade/Core/Network.hs+10−11

@@ -82,18 +82,18 @@ class UpdateLayer x => Layer x (i :: Shape) (o :: Shape) where

8282-- Can be considered to be a heterogeneous list of layers which are able to

8383-- transform the data shapes of the network.

8484data Network :: [*] -> [Shape] -> * where

85− O :: (SingI i, SingI o, Layer x i o) => !x -> Network '[x] '[i, o]

85+ NNil :: SingI i => Network '[] '[i]

8686 (:~>) :: (SingI i, SingI h, Layer x i h) => !x -> !(Network xs (h ': hs)) -> Network (x ': xs) (i ': h ': hs)

8787infixr 5 :~>

8888

8989instance Show (Network l h) where

90− show (O a) = "O " ++ show a

90+ show NNil = "NNil"

9191 show (i :~> o) = show i ++ "\n:~>\n" ++ show o

9292

9393-- | Gradients of a network.

9494-- Parameterised on the layers of a Network.

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

96− OG :: UpdateLayer x => Gradient x -> Gradients '[x]

96+ GNil :: Gradients '[]

9797 (:/>) :: UpdateLayer x => Gradient x -> Gradients xs -> Gradients (x ': xs)

9898

9999-- | A network can easily be created by hand with (:~>), but an easy way to initialise a random

@@ -102,19 +102,18 @@ class CreatableNetwork (xs :: [*]) (ss :: [Shape]) where

102102 -- | Create a network of the types requested

103103 randomNetwork :: MonadRandom m => m (Network xs ss)

104104

105−instance (SingI i, SingI o, Layer x i o) => CreatableNetwork (x ': '[]) (i ': o ': '[]) where

106− randomNetwork = O <$> createRandom

105+instance SingI i => CreatableNetwork '[] '[i] where

106+ randomNetwork = return NNil

107107

108−instance (SingI i, SingI o, Layer x i o, CreatableNetwork xs (o ': r ': rs)) => CreatableNetwork (x ': xs) (i ': o ': r ': rs) where

108+instance (SingI i, SingI o, Layer x i o, CreatableNetwork xs (o ': rs)) => CreatableNetwork (x ': xs) (i ': o ': rs) where

109109 randomNetwork = (:~>) <$> createRandom <*> randomNetwork

110110

111111

112112-- | Add very simple serialisation to the network

113−instance (SingI i, SingI o, Layer x i o, Serialize x) => Serialize (Network '[x] '[i, o]) where

114− put (O x) = put x

115− put _ = error "impossible"

116− get = O <$> get

113+instance SingI i => Serialize (Network '[] '[i]) where

114+ put NNil = pure ()

115+ get = return NNil

117116

118−instance (SingI i, SingI o, Layer x i o, Serialize x, Serialize (Network xs (o ': r ': rs))) => Serialize (Network (x ': xs) (i ': o ': r ': rs)) where

117+instance (SingI i, SingI o, Layer x i o, Serialize x, Serialize (Network xs (o ': rs))) => Serialize (Network (x ': xs) (i ': o ': rs)) where

119118 put (x :~> r) = put x >> put r

120119 get = (:~>) <$> get <*> get

src/Grenade/Core/Runner.hs+6−12

@@ -51,22 +51,16 @@ backPropagate network input target =

5151

5252 in (layer' :/> n', dWs)

5353

54− -- handle the output layer, bouncing the derivatives back down.

55− go !x (O layer)

56− = let (tape, y) = runForwards layer x

57− -- the gradient (how much y affects the error)

58− (layer', dWs) = runBackwards layer tape (y - target)

59−

60− in (OG layer', dWs)

54+ -- Bouncing the derivatives back down.

55+ go !x NNil

56+ = (GNil, x - target)

6157

6258-- | Apply one step of stochastic gradient decent across the network.

6359applyUpdate :: LearningParameters -> Network ls ss -> Gradients ls -> Network ls ss

64−applyUpdate rate (O layer) (OG gradient)

65− = O (runUpdate rate layer gradient)

60+applyUpdate _ NNil GNil

61+ = NNil

6662applyUpdate rate (layer :~> rest) (gradient :/> grest)

6763 = runUpdate rate layer gradient :~> applyUpdate rate rest grest

68−applyUpdate _ _ _

69− = error "Impossible for the gradients of a network to have a different length to the network"

7064

7165-- | Update a network with new weights after training with an instance.

7266train :: LearningParameters -> Network layers shapes -> S (Head shapes) -> S (Last shapes) -> Network layers shapes

@@ -77,4 +71,4 @@ train rate network input output =

7771-- | Run the network with input and return the given output.

7872runNet :: Network layers shapes -> S (Head shapes) -> S (Last shapes)

7973runNet (layer :~> n) !x = let (_, y) = runForwards layer x in runNet n y

80−runNet (O layer) !x = snd (runForwards layer x)

74+runNet NNil !x = x

src/Grenade/Layers/Dropout.hs+13−19

@@ -13,32 +13,26 @@ import GHC.TypeLits

1313import Grenade.Core.Shape

1414import Grenade.Core.Network

1515

16−import Numeric.LinearAlgebra.Static

17−

18−

1916-- Dropout layer help to reduce overfitting.

2017-- Idea here is that the vector is a shape of 1s and 0s, which we multiply the input by.

2118-- After backpropogation, we return a new matrix/vector, with different bits dropped out.

2219-- Double is the proportion to drop in each training iteration (like 1% or 5% would be

2320-- reasonable).

24−data Dropout o =

25− Dropout (R o)

26− deriving Show

21+data Dropout = Dropout {

22+ dropoutRate :: Double

23+ , dropoutSeed :: Int

24+ } deriving Show

2725

28−instance (KnownNat i) => UpdateLayer (Dropout i) where

29− type Gradient (Dropout i) = ()

26+instance UpdateLayer Dropout where

27+ type Gradient Dropout = ()

3028 runUpdate _ x _ = x

3129 createRandom = randomDropout 0.95

3230

33−randomDropout :: (MonadRandom m, KnownNat i)

34− => Double -> m (Dropout i)

35−randomDropout rate = do

36− seed <- getRandom

37− let wN = randomVector seed Uniform

38− xs = dvmap (\a -> if a <= rate then 0 else 1) wN

39− return $ Dropout xs

31+randomDropout :: MonadRandom m

32+ => Double -> m Dropout

33+randomDropout rate = Dropout rate <$> getRandom

4034

41−instance (KnownNat i) => Layer (Dropout i) ('D1 i) ('D1 i) where

42− type Tape (Dropout i) ('D1 i) ('D1 i) = ()

43− runForwards (Dropout drops) (S1D x) = ((), S1D $ x * drops)

44− runBackwards (Dropout drops) _ (S1D x) = ((), S1D $ x * drops)

35+instance (KnownNat i) => Layer Dropout ('D1 i) ('D1 i) where

36+ type Tape Dropout ('D1 i) ('D1 i) = ()

37+ runForwards (Dropout _ _) (S1D x) = ((), S1D x)

38+ runBackwards (Dropout _ _) _ (S1D x) = ((), S1D x)

src/Grenade/Layers/FullyConnected.hs+2−1

@@ -6,6 +6,7 @@

66{-# LANGUAGE ScopedTypeVariables #-}

77module Grenade.Layers.FullyConnected (

88 FullyConnected (..)

9+ , FullyConnected' (..)

910 , randomFullyConnected

1011 ) where

1112

@@ -25,7 +26,7 @@ import Grenade.Layers.Internal.Update

2526

2627-- | A basic fully connected (or inner product) neural network layer.

2728data FullyConnected i o = FullyConnected

28− !(FullyConnected' i o) -- Weuron weights

29+ !(FullyConnected' i o) -- Neuron weights

2930 !(FullyConnected' i o) -- Neuron momentum

3031

3132data FullyConnected' i o = FullyConnected'

src/Grenade/Layers/Logit.hs+6−15

@@ -1,6 +1,7 @@

11{-# LANGUAGE DataKinds #-}

22{-# LANGUAGE TypeOperators #-}

33{-# LANGUAGE TypeFamilies #-}

4+{-# LANGUAGE FlexibleInstances #-}

45{-# LANGUAGE MultiParamTypeClasses #-}

56module Grenade.Layers.Logit (

67 Logit (..)

@@ -8,8 +9,8 @@ module Grenade.Layers.Logit (

910

1011import Data.Serialize

12+import Data.Singletons

1113

12−import Data.Singletons.TypeLits

1314import Grenade.Core.Network

1415import Grenade.Core.Shape

1516

@@ -25,20 +26,10 @@ instance UpdateLayer Logit where

2526 runUpdate _ _ _ = Logit

2627 createRandom = return Logit

2728

28−instance (KnownNat i) => Layer Logit ('D1 i) ('D1 i) where

29− type Tape Logit ('D1 i) ('D1 i) = S ('D1 i)

30− runForwards _ (S1D y) = (S1D y, S1D (logistic y))

31− runBackwards _ (S1D y) (S1D dEdy) = ((), S1D (logistic' y * dEdy))

32−

33−instance (KnownNat i, KnownNat j) => Layer Logit ('D2 i j) ('D2 i j) where

34− type Tape Logit ('D2 i j) ('D2 i j) = S ('D2 i j)

35− runForwards _ (S2D y) = (S2D y, S2D (logistic y))

36− runBackwards _ (S2D y) (S2D dEdy) = ((), S2D (logistic' y * dEdy))

37−

38−instance (KnownNat i, KnownNat j, KnownNat k) => Layer Logit ('D3 i j k) ('D3 i j k) where

39− type Tape Logit ('D3 i j k) ('D3 i j k) = S ('D3 i j k)

40− runForwards _ (S3D y) = (S3D y, S3D (logistic y))

41− runBackwards _ (S3D y) (S3D dEdy) = ((), S3D (logistic' y * dEdy))

29+instance (a ~ b, SingI a) => Layer Logit a b where

30+ type Tape Logit a b = S a

31+ runForwards _ a = (a, logistic a)

32+ runBackwards _ a g = ((), logistic' a * g)

4233

4334instance Serialize Logit where

4435 put _ = return ()

src/Grenade/Layers/Tanh.hs+1−1

@@ -27,7 +27,7 @@ instance Serialize Tanh where

2727 put _ = return ()

2828 get = return Tanh

2929

30−instance (a ~ b, SingI a, SingI b) => Layer Tanh a b where

30+instance (a ~ b, SingI a) => Layer Tanh a b where

3131 type Tape Tanh a b = S a

3232 runForwards _ a = (a, tanh a)

3333 runBackwards _ a g = ((), tanh' a * g)

src/Grenade/Recurrent/Core/Network.hs+17−20

@@ -53,14 +53,14 @@ class (RecurrentUpdateLayer x, SingI (RecurrentShape x)) => RecurrentLayer x (i

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

5454

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

56− OR :: (SingI i, SingI o, Layer x i o) => !x -> RecurrentNetwork '[FeedForward x] '[i, o]

56+ RNil :: SingI i => RecurrentNetwork '[] '[i]

5757 (:~~>) :: (SingI i, Layer x i h) => !x -> !(RecurrentNetwork xs (h ': hs)) -> RecurrentNetwork (FeedForward x ': xs) (i ': h ': hs)

5858 (:~@>) :: (SingI i, RecurrentLayer x i h) => !x -> !(RecurrentNetwork xs (h ': hs)) -> RecurrentNetwork (Recurrent x ': xs) (i ': h ': hs)

5959infixr 5 :~~>

6060infixr 5 :~@>

6161

6262instance Show (RecurrentNetwork l h) where

63− show (OR a) = "OR " ++ show a

63+ show RNil = "RNil"

6464 show (i :~~> o) = show i ++ "\n:~~>\n" ++ show o

6565 show (i :~@> o) = show i ++ "\n:~@>\n" ++ show o

6666

@@ -68,8 +68,7 @@ instance Show (RecurrentNetwork l h) where

6868-- | Recurrent inputs (sideways shapes on an imaginary unrolled graph)

6969-- Parameterised on the layers of a Network.

7070data RecurrentInputs :: [*] -> * where

71− ORS :: UpdateLayer x

72− => () -> RecurrentInputs '[FeedForward x]

71+ RINil :: RecurrentInputs '[]

7372 (:~~+>) :: UpdateLayer x

7473 => () -> !(RecurrentInputs xs) -> RecurrentInputs (FeedForward x ': xs)

7574 (:~@+>) :: (SingI (RecurrentShape x), RecurrentUpdateLayer x)

@@ -83,18 +82,17 @@ class CreatableRecurrent (xs :: [*]) (ss :: [Shape]) where

8382 -- | Create a network of the types requested

8483 randomRecurrent :: MonadRandom m => m (RecurrentNetwork xs ss, RecurrentInputs xs)

8584

86−instance (SingI i, SingI o, Layer x i o) => CreatableRecurrent (FeedForward x ': '[]) (i ': o ': '[]) where

87− randomRecurrent = do

88− thisLayer <- createRandom

89− return (OR thisLayer, ORS ())

85+instance SingI i => CreatableRecurrent '[] '[i] where

86+ randomRecurrent =

87+ return (RNil, RINil)

9088

91−instance (SingI i, Layer x i o, CreatableRecurrent xs (o ': r ': rs)) => CreatableRecurrent (FeedForward x ': xs) (i ': o ': r ': rs) where

89+instance (SingI i, Layer x i o, CreatableRecurrent xs (o ': rs)) => CreatableRecurrent (FeedForward x ': xs) (i ': o ': rs) where

9290 randomRecurrent = do

9391 thisLayer <- createRandom

9492 (rest, resti) <- randomRecurrent

9593 return (thisLayer :~~> rest, () :~~+> resti)

9694

97−instance (SingI i, RecurrentLayer x i o, CreatableRecurrent xs (o ': r ': rs)) => CreatableRecurrent (Recurrent x ': xs) (i ': o ': r ': rs) where

95+instance (SingI i, RecurrentLayer x i o, CreatableRecurrent xs (o ': rs)) => CreatableRecurrent (Recurrent x ': xs) (i ': o ': rs) where

9896 randomRecurrent = do

9997 thisLayer <- createRandom

10098 thisShape <- randomOfShape

@@ -102,28 +100,27 @@ instance (SingI i, RecurrentLayer x i o, CreatableRecurrent xs (o ': r ': rs)) =

102100 return (thisLayer :~@> rest, thisShape :~@+> resti)

103101

104102-- | Add very simple serialisation to the recurrent network

105−instance (SingI i, SingI o, Layer x i o, Serialize x) => Serialize (RecurrentNetwork '[FeedForward x] '[i, o]) where

106− put (OR x) = put x

107− put _ = error "impossible"

108− get = OR <$> get

103+instance SingI i => Serialize (RecurrentNetwork '[] '[i]) where

104+ put RNil = pure ()

105+ get = pure RNil

109106

110−instance (SingI i, Layer x i o, Serialize x, Serialize (RecurrentNetwork xs (o ': r ': rs))) => Serialize (RecurrentNetwork (FeedForward x ': xs) (i ': o ': r ': rs)) where

107+instance (SingI i, Layer x i o, Serialize x, Serialize (RecurrentNetwork xs (o ': rs))) => Serialize (RecurrentNetwork (FeedForward x ': xs) (i ': o ': rs)) where

111108 put (x :~~> r) = put x >> put r

112109 get = (:~~>) <$> get <*> get

113110

114−instance (SingI i, RecurrentLayer x i o, Serialize x, Serialize (RecurrentNetwork xs (o ': r ': rs))) => Serialize (RecurrentNetwork (Recurrent x ': xs) (i ': o ': r ': rs)) where

111+instance (SingI i, RecurrentLayer x i o, Serialize x, Serialize (RecurrentNetwork xs (o ': rs))) => Serialize (RecurrentNetwork (Recurrent x ': xs) (i ': o ': rs)) where

115112 put (x :~@> r) = put x >> put r

116113 get = (:~@>) <$> get <*> get

117114

118−instance (UpdateLayer x) => (Serialize (RecurrentInputs '[FeedForward x])) where

115+instance (Serialize (RecurrentInputs '[])) where

119116 put _ = return ()

120− get = return (ORS ())

117+ get = return RINil

121118

122−instance (UpdateLayer x, Serialize (RecurrentInputs (y ': ys))) => (Serialize (RecurrentInputs (FeedForward x ': y ': ys))) where

119+instance (UpdateLayer x, Serialize (RecurrentInputs ys)) => (Serialize (RecurrentInputs (FeedForward x ': ys))) where

123120 put ( () :~~+> rest) = put rest

124121 get = ( () :~~+> ) <$> get

125122

126−instance (SingI (RecurrentShape x), RecurrentUpdateLayer x, Serialize (RecurrentInputs (y ': ys))) => (Serialize (RecurrentInputs (Recurrent x ': y ': ys))) where

123+instance (SingI (RecurrentShape x), RecurrentUpdateLayer x, Serialize (RecurrentInputs ys)) => (Serialize (RecurrentInputs (Recurrent x ': ys))) where

127124 put ( i :~@+> rest ) = do

128125 _ <- (case i of

129126 (S1D x) -> putListOf put . LA.toList . LAS.extract $ x

src/Grenade/Recurrent/Core/Runner.hs+10−26

@@ -76,23 +76,12 @@ trainRecurrent rate network recinputs examples =

7676

7777 -- Handle the output layer, bouncing the derivatives back down.

7878 -- We may not have a target for each example, so when we don't use 0 gradient.

79− go !xs (OR layer) (ORS ())

80− = let tys = runForwards layer <$> xs

81− tapes = fst <$> tys

82− ys = snd <$> tys

83− -- recursively run the rest of the network, and get the gradients from above.

84− back = uncurry (runBackwards layer) <$> zip tapes (zipWith makeError ys targets)

85− -- the new trained layer.

86− newlayer = runUpdates rate layer (reverse $ fst <$> back)

87− in (OR newlayer, ORS (), reverse (snd <$> back))

88−

89− go _ _ _ =

90− error "Impossible for network and recurrent inputs to have different shapes"

91−

92−

93− makeError :: S (Last shapes) -> Maybe (S (Last shapes)) -> S (Last shapes)

94− makeError _ Nothing = 0

95− makeError y (Just t) = y - t

79+ go !xs RNil RINil

80+ = (RNil, RINil, reverse (zipWith makeError xs targets))

81+ where

82+ makeError :: S (Last shapes) -> Maybe (S (Last shapes)) -> S (Last shapes)

83+ makeError _ Nothing = 0

84+ makeError y (Just t) = y - t

9685

9786 updateRecInputs :: forall sublayers.

9887 LearningParameters

@@ -106,10 +95,8 @@ trainRecurrent rate network recinputs examples =

10695 updateRecInputs l@LearningParameters {..} (x :~@+> xs) (y :~@+> ys)

10796 = (realToFrac (learningRate * learningRegulariser) * x - realToFrac learningRate * y) :~@+> updateRecInputs l xs ys

10897

109− updateRecInputs _ (ORS ()) (ORS ())

110− = ORS ()

111− updateRecInputs _ _ _

112− = error "Impossible for updateRecInputs to have different shapes"

98+ updateRecInputs _ RINil RINil

99+ = RINil

113100

114101scanlFrom :: forall x i o. RecurrentLayer x i o

115102 => x -- ^ the layer

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

147134 = let (recin', y) = runRecurrentForwards layer recin x

148135 (nr', o) = runRecurrent n nr y

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

150−runRecurrent (OR layer) (ORS ()) !x

151− = (ORS (), snd $ runForwards layer x)

152−

153−runRecurrent _ _ _

154− = error "Impossible for the gradients of a network to have a different length or shape to the network"

137+runRecurrent RNil RINil !x

138+ = (RINil, x)

test/Test/Grenade/Layers/Convolution.hs+2−2

@@ -92,9 +92,9 @@ prop_conv_net =

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

9393 (Dict, Dict, Dict, Dict) ->

9494 gamble (S3D <$> uniformSample) $ \(input :: S ('D3 inRows inCols channels)) ->

95− let output :: S ('D3 outRows outCols filters) = runForwards convLayer input

95+ let (tape, output :: S ('D3 outRows outCols filters)) = runForwards convLayer input

9696 backed :: (Gradient (Convolution channels filters kernelRows kernelCols strideRows strideCols), S ('D3 inRows inCols channels))

97− = runBackwards convLayer input output

97+ = runBackwards convLayer tape output

9898 in backed `seq` True

9999 ) :: Property

100100 ) :: Property

test/Test/Grenade/Layers/FullyConnected.hs+3−3

@@ -39,15 +39,15 @@ genOpaqueFullyConnected = do

3939 bM <- randomVector

4040 wN <- uniformSample

4141 kM <- uniformSample

42− return . OpaqueFullyConnected $ (FullyConnected wB bM wN kM :: FullyConnected i' o')

42+ return . OpaqueFullyConnected $ (FullyConnected (FullyConnected' wB wN) (FullyConnected' bM kM) :: FullyConnected i' o')

4343

4444prop_fully_connected_forwards :: Property

4545prop_fully_connected_forwards =

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

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

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

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

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

50− = runBackwards fclayer input output

50+ = runBackwards fclayer tape output

5151 in backed `seq` True

5252

5353return []