benchmarks; first MNIST demo

Author: brunjlar

benchmark/benchmark.hs

@@ -0,0 +1,77 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE BangPatterns #-}
+
+module Main where
+
+import Control.Arrow  hiding (loop)
+import Criterion.Main
+import Data.MyPrelude
+import Data.Utils
+import Data.Void
+import Numeric.Neural
+
+main :: IO ()
+main = defaultMain 
+    [ bgroup "white" 
+        [ bench "10/200"     $ whnf (w   10)   200
+        , bench "10/2000"    $ whnf (w   10)  2000
+        , bench "10/20000"   $ whnf (w   10) 20000
+        , bench "100/200"    $ whnf (w  100)   200
+        , bench "100/2000"   $ whnf (w  100)  2000
+        , bench "100/20000"  $ whnf (w  100) 20000
+        , bench "1000/200"   $ whnf (w 1000)   200
+        , bench "1000/2000"  $ whnf (w 1000)  2000
+        , bench "1000/20000" $ whnf (w 1000) 20000
+        ]
+    , env setupEnv $ \ ~(m, xss) -> bgroup "linear"
+        [ l m xss  1 5 
+        , l m xss  5 5
+        , l m xss 10 5
+        ]
+    ]
+
+w :: Int -> Int -> Double
+w sampleCount testCount = flip evalRand (mkStdGen 123456) $ do
+    stats   <- mkStats'
+    samples <- replicateM sampleCount $ mkSample stats
+    let m = whiten model' samples
+    xss <- replicateM testCount $ mkSample stats
+    return $ sum [model m xs | xs <- xss]
+
+  where
+
+    mkStats' :: MonadRandom m => m (Vector Width (Double, Double))
+    mkStats' = sequenceA (pure $ (,) <$> getRandomR (-100, 100) <*> getRandomR (0.1, 20))
+
+    mkSample :: MonadRandom m => Vector Width (Double, Double) -> m (Vector Width Double)
+    mkSample = mapM $ uncurry boxMuller'
+
+    model' :: Model (Vector Width) Identity Void (Vector Width Double) Double
+    model' = Model (arr $ Identity . sum) absurd id runIdentity
+
+type Width = 10
+
+l :: M -> [Vector Width' Double] -> Int -> Int -> Benchmark
+l m xss batchSize steps = bench (printf "%d/%d" batchSize steps) $ whnf l' steps where
+
+    l' :: Int -> Double
+    l' steps' = 
+        let m' = loop steps' m 
+            xs = pure 0
+        in  modelError m' [(xs, xs)]
+
+    loop :: Int -> M -> M
+    loop 0  m' = m'
+    loop !n m' =
+        let m'' = m' `deepseq` snd $ descent m' 0.01 [(xs, xs) | xs <- take batchSize xss]
+        in  loop (pred n) m''
+
+setupEnv :: IO (M, [Vector Width' Double])
+setupEnv = return $ flip evalRand (mkStdGen 987654) $ do
+    m   <- modelR $ mkStdModel linearLayer (sqDiff . (fromDouble <$>)) id id
+    xss <- replicateM 100 $ let r = getRandomR (-5, 5) in sequence $ pure r
+    return (m, xss)
+
+type M = StdModel (Vector Width') (Vector Width') (Vector Width' Double) (Vector Width' Double)
+
+type Width' = 100

examples/MNIST/MNIST.hs

@@ -1,6 +1,9 @@
+{-# LANGUAGE DataKinds #-}
+
 module Main where
 
 import           Codec.Picture
+import           Control.Arrow
 import qualified Data.Array     as A
 import           Data.MyPrelude
 import           Data.Utils
@@ -9,7 +12,36 @@ import           Pipes.GZip     (decompress)
 import qualified Pipes.Prelude  as P
 
 main :: IO ()
-main = runSafeT (runEffect $ trainSamples >-> P.take 50 >-> consumeSamples "test")
+main = do
+    xs <- runSafeT $ P.toListM (trainSamples >-> P.take 1000)
+    printf "loaded %d train samples\n" (length xs)
+    ys <- runSafeT $ P.toListM (testSamples >-> P.take 500)
+    printf "loaded %d test samples\n" (length ys)
+    flip evalRandT (mkStdGen 999999) $ do
+        xs' <- takeR 100 $ fst <$> xs
+        m <- modelR (whiten mnistModel xs')
+        runEffect $
+                simpleBatchP xs 20
+            >-> descentP m 1 (const 0.1)
+            >-> reportTSP 1 report
+            >-> consumeTSP (check ys)
+
+  where
+
+    report ts = liftIO $ printf "%7d %8.6f %10.8f\n" (tsGeneration ts) (tsEta ts) (tsBatchError ts)
+
+    check ys ts = --return $ if tsGeneration ts == 3 then Just () else Nothing
+        if tsGeneration ts `mod` 5 == 0
+            then do
+                let a = accuracy (tsModel ts) ys :: Double
+                liftIO $ printf "\naccuracy %f\n\n" a
+                return Nothing
+            else return Nothing
+
+    correct m (img, d) = model m img == d
+
+    accuracy m ys = let c = length $ filter (correct m) ys
+                    in  fromIntegral c / fromIntegral (length ys)
 
 type Img = Image Pixel8
 
@@ -45,10 +77,12 @@ testSamples  = P.zip (images testImagesFile)  (labels testLabelsFile)
 writeImg :: MonadIO m => FilePath -> Img -> m ()
 writeImg f i = liftIO $ saveTiffImage (f <.> "tiff") (ImageY8 i)
 
-consumeSamples :: MonadIO m => String -> Consumer Sample m ()
-consumeSamples f = g (1 :: Int) where
+mnistModel :: Classifier (Matrix 28 28) 10 Img Digit
+mnistModel = mkStdClassifier c i where
+
+    c = f ^>> (tanhLayer :: Layer 784 10) >>> tanhLayer
+
+    i img = let m = mgenerate $ \(x, y) -> fromIntegral (pixelAt img x y) in force m
 
-    g i = do
-        (img, l) <- await
-        writeImg (printf "%s_%05d_%d" f i (fromEnum l)) img
-        g (succ i)
+    f :: Matrix 28 28 Analytic -> Vector 784 Analytic
+    f m = generate $ \w -> m !!! (w `mod` 28, w `div` 28)

neural.cabal

@@ -112,7 +112,16 @@ test-suite neural-doctest
                      , doctest
                      , Glob
   ghc-options:         -Wall -threaded -rtsopts -with-rtsopts=-N -fexcess-precision -optc-O3 -optc-ffast-math
+  default-language:    Haskell2010
 
+benchmark neural-bench
+  type:                exitcode-stdio-1.0
+  hs-source-dirs:      benchmark
+  main-is:             benchmark.hs
+  build-depends:       base >= 4.7 && < 5
+                     , criterion
+                     , neural
+  ghc-options:         -Wall -threaded -rtsopts -with-rtsopts=-N -fexcess-precision -optc-O3 -optc-ffast-math
   default-language:    Haskell2010
 
 executable iris
@@ -150,3 +159,8 @@ source-repository head
   type:     git
   location: https://github.com/brunjlar/neural.git
 
+source-repository this
+  type:     git
+  location: https://github.com/brunjlar/neural.git
+  tag:      0.1.1.0
+

src/Data/MyPrelude.hs

@@ -13,12 +13,12 @@ This module simply reexports a selection of commonly used standard types and fun
 -}
 
 module Data.MyPrelude
-    ( NFData(..)
+    ( NFData(..), deepseq, force
     , (&), (^.), (.~), Lens', Getter, to, lens
     , when, unless, forM, forM_, void, replicateM, forever, guard
     , Identity(..)
     , MonadIO(..)
-    , MonadRandom, getRandom, getRandomR, RandT, runRandT, evalRandT, StdGen, mkStdGen
+    , MonadRandom, getRandom, getRandomR, Rand, RandT, runRand, evalRand, runRandT, evalRandT, StdGen, mkStdGen
     , MonadState(..)
     , lift
     , State, StateT, modify, runState, evalState, execState, runStateT, evalStateT, execStateT
@@ -36,12 +36,12 @@ module Data.MyPrelude
     , printf
     ) where
 
-import Control.DeepSeq            (NFData(..))
+import Control.DeepSeq            (NFData(..), deepseq, force)
 import Control.Lens               ((&), (^.), (.~), Lens', Getter, to, lens)
 import Control.Monad              (when, unless, forM, forM_, void, replicateM, forever, guard)
 import Control.Monad.Identity     (Identity(..))
 import Control.Monad.IO.Class     (MonadIO(..))
-import Control.Monad.Random       (MonadRandom, getRandom, getRandomR, RandT, runRandT, evalRandT, StdGen, mkStdGen)
+import Control.Monad.Random       (MonadRandom, getRandom, getRandomR, Rand, RandT, runRand, evalRand, runRandT, evalRandT, StdGen, mkStdGen)
 import Control.Monad.State.Class  (MonadState(..))
 import Control.Monad.Trans.Class  (lift)
 import Control.Monad.Trans.State  (State, StateT, modify, runState, evalState, execState, runStateT, evalStateT, execStateT)

src/Data/Utils/Matrix.hs

@@ -7,6 +7,7 @@
 {-# LANGUAGE DeriveTraversable #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 
 {-|
 Module      : Data.Utils.Matrix
@@ -38,7 +39,7 @@ import Data.Utils.Vector
 -- | @'Matrix' m n a@ is the type of /matrices/ with @m@ rows, @n@ columns and entries of type @a@.
 --
 newtype Matrix (m :: Nat) (n :: Nat) a = Matrix (Vector m (Vector n a)) 
-    deriving (Eq, Show, Functor, Foldable, Traversable)
+    deriving (Eq, Show, Functor, Foldable, Traversable, NFData)
 
 instance (KnownNat m, KnownNat n) => Applicative (Matrix m n) where
 

src/Data/Utils/Vector.hs

@@ -79,14 +79,18 @@ instance (KnownNat n, Read a) => Read (Vector n a) where
                         n'  = fromIntegral (natVal (Proxy :: Proxy n))
                     in  [(Vector ys, t) | (ys, t) <- xs, length ys == n']    
 
+instance (NFData a) => NFData (Vector n a) where
+
+    rnf (Vector v) = rnf v
+
 -- | The /scalar product/ of two vectors of the same length.
 --
 -- >>> :set -XDataKinds
 -- >>> cons 1 (cons 2 nil) <%> cons 3 (cons 4 nil) :: Int
 -- 11
 --
 (<%>) :: Num a => Vector n a -> Vector n a -> a
-xs <%> ys = sum $ zipWith (*) (toList xs) (toList ys)
+Vector v <%> Vector w = V.sum $ V.zipWith (*) v w
 
 -- | The vector of length zero.
 nil :: Vector 0 a

src/Numeric/Neural/Model.hs

@@ -8,6 +8,7 @@
 {-# LANGUAGE Arrows #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE FlexibleContexts #-}
 
 {-|
 Module      : Neural.Model
@@ -40,6 +41,7 @@ module Numeric.Neural.Model
     , mkStdModel
     ) where
 
+import Control.Applicative    
 import Control.Arrow
 import Control.Category
 import Data.Profunctor
@@ -88,7 +90,7 @@ instance Profunctor (ParamFun t) where dimap  = dimapArr
 --   In contrast to 'ParamFun', when components are composed, parameters are not shared. 
 --   Each component carries its own collection of parameters instead.
 --
-data Component a b = forall t. (Traversable t, Applicative t) => Component
+data Component a b = forall t. (Traversable t, Applicative t, NFData (t Double)) => Component
     { weights :: t Double                                -- ^ the specific parameter values
     , compute :: ParamFun t a b                          -- ^ the encapsulated parameterized function
     , initR   :: forall m. MonadRandom m => m (t Double) -- ^ randomly sets the parameters
@@ -115,8 +117,16 @@ instance Applicative Empty where
 
     Empty <*> Empty = Empty
 
+instance NFData (Empty a) where
+
+    rnf Empty = ()
+
 data Pair s t a = Pair (s a) (t a) deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)
 
+instance (NFData (s a), NFData (t a)) => NFData (Pair s t a) where
+
+    rnf (Pair xs ys) = rnf xs `seq` rnf ys `seq` ()
+
 instance (Applicative s, Applicative t) => Applicative (Pair s t) where
 
     pure x = Pair (pure x) (pure x)
@@ -161,6 +171,10 @@ instance Applicative (Component a) where pure = pureArr; (<*>) = apArr
 
 instance Profunctor Component where dimap = dimapArr
 
+instance NFData (Component a b) where
+
+    rnf (Component ws _ _) = rnf ws
+
 -- | A @'Model' f g a b c@ wraps a @'Component' (f 'Analytic') (g 'Analytic')@
 --   and models functions @b -> c@ with "samples" (for model error determination)
 --   of type @a@.
@@ -178,6 +192,10 @@ instance Profunctor (Model f g a) where
 
     dimap m n (Model c e i o) = Model c e (i . m) (n . o)
 
+instance NFData (Model f g a b c) where
+
+    rnf (Model c _ _ _) = rnf c
+
 -- | A 'Lens' for accessing the component embedded in a model.
 --
 _component :: Lens' (Model f g a b c) (Component (f Analytic) (g Analytic))
@@ -195,28 +213,29 @@ modelR (Model c e i o) = case c of
         ws <- r
         return $ Model (Component ws f r) e i o
 
-errFun :: (Functor f, Foldable h, Traversable t)
+errFun :: (Functor f, Traversable t)
           => (a -> (f Double, g Analytic -> Analytic))
-          -> h a
+          -> a
           -> ParamFun t (f Analytic) (g Analytic)
           -> (t Analytic -> Analytic)
-errFun e xs f = runPF f' xs where
-
-    f' = toList ^>> convolve f'' >>^ mean
+errFun e x f = runPF f' x where
 
-    f'' = proc x -> do
-        let (x', h) = e x
+    f' = proc z -> do
+        let (x', h) = e z
             x''     = fromDouble <$> x'
         y <- f -< x''
         returnA -< h y
 
+modelError' :: Model f g a b c -> a -> Double
+modelError' (Model c e _ _) x = case c of
+    Component ws f _ -> let f'  = errFun e x f
+                            f'' = fromJust . fromAnalytic . f' . fmap fromDouble
+                        in  f'' ws
+
 -- | Calculates the avarage model error for a "mini-batch" of samples.
 --
 modelError :: Foldable h => Model f g a b c -> h a -> Double
-modelError (Model c e _ _) xs = case c of
-    Component ws f _ -> let f'  = errFun e xs f
-                            f'' = fromJust . fromAnalytic . f' . fmap fromDouble
-                        in  f'' ws
+modelError m xs = mean $ modelError' m <$> toList xs
 
 -- | Performs one step of gradient descent/ backpropagation on the model,
 descent :: (Foldable h)
@@ -226,10 +245,13 @@ descent :: (Foldable h)
            -> (Double, Model f g a b c) -- ^ returns the average sample error and the improved model
 descent (Model c e i o) eta xs = case c of
     Component ws f r ->
-        let f' = errFun e xs f
-            (err, ws') = gradient (\w dw -> w - eta * dw) f' ws
-            c'         = Component ws' f r
-            m          = Model c' e i o
+        let f' x = gradient (\_ dw -> dw) (errFun e x f) ws
+            ys   = f' <$> toList xs 
+            err = mean $ fst <$> ys
+            grad = (* eta) . mean . getZipList <$> sequenceA (ZipList (snd <$> ys))
+            ws'  = (-) <$> ws <*> grad
+            c'   = Component ws' f r
+            m    = Model c' e i o
         in  (err, m)
 
 -- | A type abbreviation for the most common type of models, where samples are just input-output tuples.

src/Numeric/Neural/Normalization.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE BangPatterns #-}
 
 {-|
 Module      : Numeric.Neural.Normalization
@@ -155,8 +156,8 @@ white xss = ((w <$> sequenceA xss) <*>) where
 
     w xs = case toList xs of
         []  -> id
-        xs' -> let (_, m, v) = countMeanVar xs'
-                   s         = if v == 0 then 1 else 1 / sqrt v
+        xs' -> let (_, !m, !v) = countMeanVar xs'
+                   !s          = if v == 0 then 1 else 1 / sqrt v
                in  \x -> (x - m) * s
 
 -- | Modifies a 'Model' by whitening the input before feeding it into the embedded component.
@@ -182,4 +183,4 @@ mkStdClassifier :: (Functor f, KnownNat n, Enum c)
                    => Component (f Analytic) (Vector n Analytic) -- ^ the embedded component
                    -> (b -> f Double)                            -- ^ converts input
                    -> Classifier f n b c
-mkStdClassifier c i = mkStdModel (c >>^ softmax) crossEntropyError i decode1ofN where
+mkStdClassifier c i = mkStdModel (c >>^ softmax) crossEntropyError i decode1ofN