4dc408f · grenade · git.iko.soy

git.iko.soy/grenade

Add very basic model saving and loading

commit4dc408f39db2e3cded4442faf425e14976a4ef77 authorHuw Campbell <huw.campbell@ambiata.com> dateSat 10 Dec 2016, 09:31 (10 years ago) parent20e7e48

13 files changed+131−22

compare with master

unifiedsplit

README.md+5−1 grenade.cabal+3 main/feedforward.hs+38−18 main/shakespeare.hs+3−3 src/Grenade/Core/Network.hs+13 src/Grenade/Layers/Convolution.hs+17 src/Grenade/Layers/Flatten.hs+7 src/Grenade/Layers/FullyConnected.hs+17 src/Grenade/Layers/Logit.hs+6 src/Grenade/Layers/Pad.hs+5 src/Grenade/Layers/Pooling.hs+5 src/Grenade/Layers/Relu.hs+6 src/Grenade/Layers/Tanh.hs+6

README.md+5−1

@@ -89,7 +89,6 @@ and the tests run using:

8989

9090Grenade is currently known to build with ghc 7.10 and 8.0.

9191

92−

9392Thanks

9493------

9594Writing a library like this has been on my mind for a while now, but a big shout

@@ -108,8 +107,13 @@ Being purely functional, it should also be easy to run batches in parallel, whic

108107would be appropriate for larger networks, my current examples however are single

109108threaded.

110109

110+<<<<<<< 20e7e483d75613f16580baa71b44fa9864c940fd

111111Training 15 generations over Kaggle's 41000 sample MNIST training set on a single

112112core took around 12 minutes, achieving 1.5% error rate on a 1000 sample holdout set.

113+=======

114+Training 15 generations over Kaggle's 42000 sample MNIST training set took under

115+an hour on my laptop, achieving 0.5% error rate on a 1000 sample holdout set.

116+>>>>>>> Add very basic model saving and loading

113117

114118Contributing

115119------------

grenade.cabal+3

@@ -22,6 +22,7 @@ library

2222 , containers

2323 , deepseq

2424 , either == 4.4.*

25+ , cereal

2526 , exceptions == 0.8.*

2627 , hmatrix

2728 , MonadRandom

@@ -85,6 +86,8 @@ executable feedforward

8586 build-depends: base

8687 , grenade

8788 , attoparsec

89+ , bytestring

90+ , cereal

8891 , either

8992 , optparse-applicative == 0.12.*

9093 , text == 1.2.*

main/feedforward.hs+38−18

@@ -8,6 +8,9 @@ import Control.Monad

88import Control.Monad.Random

99import Data.List ( foldl' )

1010

11+import qualified Data.ByteString as B

12+import Data.Serialize

13+

1114import GHC.TypeLits

1215

1316import qualified Numeric.LinearAlgebra.Static as SA

@@ -16,13 +19,12 @@ import Options.Applicative

1619

1720import Grenade

1821

19−-- The defininition for our simple feed forward network.

20−-- The type level list represents the shapes passed through the layers. One can see that for this demonstration

21−-- we are using relu, tanh and logit non-linear units, which can be easily subsituted for each other in and out.

22−

23−-- It's important to keep the type signatures, as there's many layers which can "squeeze" into the gaps

24−-- between the shapes, so inference can't do it all for us.

2522

23+-- The defininition for our simple feed forward network.

24+-- The type level lists represents the layers and the shapes passed through the layers.

25+-- One can see that for this demonstration we are using relu, tanh and logit non-linear

26+-- units, which can be easily subsituted for each other in and out.

27+--

2628-- With around 100000 examples, this should show two clear circles which have been learned by the network.

2729type FFNet = Network '[ FullyConnected 2 40, Tanh, FullyConnected 40 10, Relu, FullyConnected 10 1, Logit ]

2830 '[ 'D1 2, 'D1 40, 'D1 40, 'D1 10, 'D1 10, 'D1 1, 'D1 1]

@@ -30,8 +32,8 @@ type FFNet = Network '[ FullyConnected 2 40, Tanh, FullyConnected 40 10, Relu, F

3032randomNet :: MonadRandom m => m FFNet

3133randomNet = randomNetwork

3234

33−netTest :: MonadRandom m => LearningParameters -> Int -> m String

34−netTest rate n = do

35+netTrain :: FFNet -> LearningParameters -> Int -> IO FFNet

36+netTrain net0 rate n = do

3537 inps <- replicateM n $ do

3638 s <- getRandom

3739 return $ S1D $ SA.randomVector s SA.Uniform * 2 - 1

@@ -39,20 +41,28 @@ netTest rate n = do

3941 if v `inCircle` (fromRational 0.33, 0.33) || v `inCircle` (fromRational (-0.33), 0.33)

4042 then S1D $ fromRational 1

4143 else S1D $ fromRational 0

42− net0 <- randomNet

4344

4445 let trained = foldl' trainEach net0 (zip inps outs)

45− let testIns = [ [ (x,y) | x <- [0..50] ]

46− | y <- [0..20] ]

47−

48− let outMat = fmap (fmap (\(x,y) -> (render . normx) $ runNet trained (S1D $ SA.vector [x / 25 - 1,y / 10 - 1]))) testIns

49− return $ unlines outMat

46+ return trained

5047

5148 where

5249 inCircle :: KnownNat n => SA.R n -> (SA.R n, Double) -> Bool

5350 v `inCircle` (o, r) = SA.norm_2 (v - o) <= r

5451 trainEach !network (i,o) = train rate network i o

5552

53+netLoad :: FilePath -> IO FFNet

54+netLoad modelPath = do

55+ modelData <- B.readFile modelPath

56+ either fail return $ runGet (get :: Get FFNet) modelData

57+

58+netScore :: FFNet -> IO ()

59+netScore network = do

60+ let testIns = [ [ (x,y) | x <- [0..50] ]

61+ | y <- [0..20] ]

62+ outMat = fmap (fmap (\(x,y) -> (render . normx) $ runNet network (S1D $ SA.vector [x / 25 - 1,y / 10 - 1]))) testIns

63+ putStrLn $ unlines outMat

64+

65+ where

5666 render n' | n' <= 0.2 = ' '

5767 | n' <= 0.4 = '.'

5868 | n' <= 0.6 = '-'

@@ -62,7 +72,7 @@ netTest rate n = do

6272 normx :: S ('D1 1) -> Double

6373 normx (S1D r) = SA.mean r

6474

65−data FeedForwardOpts = FeedForwardOpts Int LearningParameters

75+data FeedForwardOpts = FeedForwardOpts Int LearningParameters (Maybe FilePath) (Maybe FilePath)

6676

6777feedForward' :: Parser FeedForwardOpts

6878feedForward' =

@@ -72,9 +82,19 @@ feedForward' =

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

7383 <*> option auto (long "l2" <> value 0.0005)

7484 )

85+ <*> optional (strOption (long "load"))

86+ <*> optional (strOption (long "save"))

7587

7688main :: IO ()

7789main = do

78− FeedForwardOpts examples rate <- execParser (info (feedForward' <**> helper) idm)

79− putStrLn "Training network..."

80− putStrLn =<< evalRandIO (netTest rate examples)

90+ FeedForwardOpts examples rate load save <- execParser (info (feedForward' <**> helper) idm)

91+ net0 <- case load of

92+ Just loadFile -> netLoad loadFile

93+ Nothing -> randomNet

94+

95+ net <- netTrain net0 rate examples

96+ netScore net

97+

98+ case save of

99+ Just saveFile -> B.writeFile saveFile $ runPut (put net)

100+ Nothing -> return ()

main/shakespeare.hs+3−3

@@ -50,11 +50,11 @@ type F = FeedForward

5050type R = Recurrent

5151

5252-- The definition of our network

53−type Shakespeare = RecurrentNetwork '[ R (LSTM 40 40), F (FullyConnected 40 40), F Logit]

54− '[ 'D1 40, 'D1 40, 'D1 40, 'D1 40 ]

53+type Shakespeare = RecurrentNetwork '[ R (LSTM 40 50), R (LSTM 50 40), F (FullyConnected 40 40), F Logit]

54+ '[ 'D1 40, 'D1 50, 'D1 40, 'D1 40, 'D1 40 ]

5555

5656-- The definition of the "sideways" input, which the network if fed recurrently.

57−type Shakespearian = RecurrentInputs '[ R (LSTM 40 40), F (FullyConnected 40 40), F Logit]

57+type Shakespearian = RecurrentInputs '[ R (LSTM 40 50), R (LSTM 50 40), F (FullyConnected 40 40), F Logit]

5858

5959randomNet :: MonadRandom m => m (Shakespeare, Shakespearian)

6060randomNet = randomRecurrent

src/Grenade/Core/Network.hs+13

@@ -29,6 +29,8 @@ import Control.Monad.Random (MonadRandom)

2929import Data.List ( foldl' )

3030import Data.Singletons

3131

32+import Data.Serialize

33+

3234import Grenade.Core.Shape

3335

3436-- | Learning parameters for stochastic gradient descent.

@@ -101,3 +103,14 @@ instance (SingI i, SingI o, Layer x i o) => CreatableNetwork (x ': '[]) (i ': o

101103

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

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

106+

107+

108+-- | Add very simple serialisation to the network

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

110+ put (O x) = put x

111+ put _ = error "impossible"

112+ get = O <$> get

113+

114+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

115+ put (x :~> r) = put x >> put r

116+ get = (:~>) <$> get <*> get

src/Grenade/Layers/Convolution.hs+17

@@ -16,7 +16,9 @@ module Grenade.Layers.Convolution (

1616import Control.Monad.Random hiding ( fromList )

1717import Data.Maybe

1818import Data.Proxy

19+import Data.Serialize

1920import Data.Singletons.TypeLits

21+

2022import GHC.TypeLits

2123

2224import Numeric.LinearAlgebra hiding ( uniformSample, konst )

@@ -125,6 +127,21 @@ instance ( KnownNat channels

125127

126128 createRandom = randomConvolution

127129

130+instance ( KnownNat channels

131+ , KnownNat filters

132+ , KnownNat kernelRows

133+ , KnownNat kernelColumns

134+ , KnownNat strideRows

135+ , KnownNat strideColumns

136+ , KnownNat (kernelRows * kernelColumns * channels)

137+ ) => Serialize (Convolution channels filters kernelRows kernelColumns strideRows strideColumns) where

138+ put (Convolution w _) = putListOf put . toList . flatten . extract $ w

139+ get = do

140+ let f = fromIntegral $ natVal (Proxy :: Proxy filters)

141+ wN <- maybe (fail "Vector of incorrect size") return . create . reshape f . LA.fromList =<< getListOf get

142+ let mm = konst 0

143+ return $ Convolution wN mm

144+

128145-- | A two dimentional image may have a convolution filter applied to it

129146instance ( KnownNat kernelRows

130147 , KnownNat kernelCols

src/Grenade/Layers/Flatten.hs+7

@@ -7,6 +7,8 @@ module Grenade.Layers.Flatten (

77 FlattenLayer (..)

88 ) where

10+import Data.Serialize

11+

1012import Data.Singletons.TypeLits

1113import GHC.TypeLits

1214

@@ -41,6 +43,11 @@ instance (KnownNat y, KnownNat x, KnownNat z, z ~ 1) => Layer FlattenLayer ('D3

4143 runForwards _ (S3D y) = S2D y

4244 runBackwards _ _ (S2D y) = ((), S3D y)

4345

46+instance Serialize FlattenLayer where

47+ put _ = return ()

48+ get = return FlattenLayer

49+

50+

4451fromJust' :: Maybe x -> x

4552fromJust' (Just x) = x

4653fromJust' Nothing = error $ "FlattenLayer error: data shape couldn't be converted."

src/Grenade/Layers/FullyConnected.hs+17

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

33{-# LANGUAGE TypeOperators #-}

44{-# LANGUAGE TypeFamilies #-}

55{-# LANGUAGE MultiParamTypeClasses #-}

6+{-# LANGUAGE ScopedTypeVariables #-}

67module Grenade.Layers.FullyConnected (

78 FullyConnected (..)

89 , randomFullyConnected

@@ -10,8 +11,11 @@ module Grenade.Layers.FullyConnected (

1011

1112import Control.Monad.Random hiding (fromList)

1213

14+import Data.Proxy

15+import Data.Serialize

1316import Data.Singletons.TypeLits

1417

18+import qualified Numeric.LinearAlgebra as LA

1519import Numeric.LinearAlgebra.Static

1620

1721import Grenade.Core.Network

@@ -55,6 +59,19 @@ instance (KnownNat i, KnownNat o) => Layer (FullyConnected i o) ('D1 i) ('D1 o)

5559 dWs = tr wN #> dEdy

5660 in (FullyConnected' wB' mm', S1D dWs)

5761

62+instance (KnownNat i, KnownNat o) => Serialize (FullyConnected i o) where

63+ put (FullyConnected b _ w _) = do

64+ putListOf put . LA.toList . extract $ b

65+ putListOf put . LA.toList . LA.flatten . extract $ w

66+

67+ get = do

68+ let f = fromIntegral $ natVal (Proxy :: Proxy i)

69+ b <- maybe (fail "Vector of incorrect size") return . create . LA.fromList =<< getListOf get

70+ k <- maybe (fail "Vector of incorrect size") return . create . LA.reshape f . LA.fromList =<< getListOf get

71+ let bm = konst 0

72+ let mm = konst 0

73+ return $ FullyConnected b bm k mm

74+

5875randomFullyConnected :: (MonadRandom m, KnownNat i, KnownNat o)

5976 => m (FullyConnected i o)

6077randomFullyConnected = do

src/Grenade/Layers/Logit.hs+6

@@ -7,6 +7,8 @@ module Grenade.Layers.Logit (

77 ) where

10+import Data.Serialize

11+

1012import Data.Singletons.TypeLits

1113import Grenade.Core.Network

1214import Grenade.Core.Shape

@@ -35,6 +37,10 @@ instance (KnownNat i, KnownNat j, KnownNat k) => Layer Logit ('D3 i j k) ('D3 i

3537 runForwards _ (S3D y) = S3D (logistic y)

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

3739

40+instance Serialize Logit where

41+ put _ = return ()

42+ get = return Logit

43+

3844logistic :: Floating a => a -> a

3945logistic x = 1 / (1 + exp (-x))

4046

src/Grenade/Layers/Pad.hs+5

@@ -10,6 +10,7 @@ module Grenade.Layers.Pad (

1010

1111import Data.Maybe

1212import Data.Proxy

13+import Data.Serialize

1314import Data.Singletons.TypeLits

1415import GHC.TypeLits

1516

@@ -34,6 +35,10 @@ instance UpdateLayer (Pad l t r b) where

3435 runUpdate _ x _ = x

3536 createRandom = return Pad

3637

38+instance Serialize (Pad l t r b) where

39+ put _ = return ()

40+ get = return Pad

41+

3742-- | A two dimentional image can be padped.

3843instance ( KnownNat padLeft

3944 , KnownNat padTop

src/Grenade/Layers/Pooling.hs+5

@@ -12,6 +12,7 @@ module Grenade.Layers.Pooling (

1212

1313import Data.Maybe

1414import Data.Proxy

15+import Data.Serialize

1516import Data.Singletons.TypeLits

1617import GHC.TypeLits

1718

@@ -39,6 +40,10 @@ instance UpdateLayer (Pooling kernelRows kernelColumns strideRows strideColumns)

3940 runUpdate _ Pooling _ = Pooling

4041 createRandom = return Pooling

4142

43+instance Serialize (Pooling kernelRows kernelColumns strideRows strideColumns) where

44+ put _ = return ()

45+ get = return Pooling

46+

4247-- | A two dimentional image can be pooled.

4348instance ( KnownNat kernelRows

4449 , KnownNat kernelColumns

src/Grenade/Layers/Relu.hs+6

@@ -6,6 +6,8 @@ module Grenade.Layers.Relu (

66 Relu (..)

77 ) where

9+import Data.Serialize

10+

911import GHC.TypeLits

1012import Grenade.Core.Network

1113import Grenade.Core.Shape

@@ -23,6 +25,10 @@ instance UpdateLayer Relu where

2325 runUpdate _ _ _ = Relu

2426 createRandom = return Relu

2527

28+instance Serialize Relu where

29+ put _ = return ()

30+ get = return Relu

31+

2632instance ( KnownNat i) => Layer Relu ('D1 i) ('D1 i) where

2733 runForwards _ (S1D y) = S1D (relu y)

2834 where

src/Grenade/Layers/Tanh.hs+6

@@ -6,6 +6,8 @@ module Grenade.Layers.Tanh (

66 Tanh (..)

77 ) where

9+import Data.Serialize

10+

911import GHC.TypeLits

1012import Grenade.Core.Network

1113import Grenade.Core.Shape

@@ -20,6 +22,10 @@ instance UpdateLayer Tanh where

2022 runUpdate _ _ _ = Tanh

2123 createRandom = return Tanh

2224

25+instance Serialize Tanh where

26+ put _ = return ()

27+ get = return Tanh

28+

2329instance KnownNat i => Layer Tanh ('D1 i) ('D1 i) where

2430 runForwards _ (S1D y) = S1D (tanh y)

2531 runBackwards _ (S1D y) (S1D dEdy) = ((), S1D (tanh' y * dEdy))