packages feed

sgd 0.2.3 → 0.3

raw patch · 10 files changed

+603/−399 lines, 10 filesdep +binarydep +filepathdep +mtldep ~basedep ~containersdep ~deepseq

Dependencies added: binary, filepath, mtl, temporary

Dependency ranges changed: base, containers, deepseq

Files

+ Numeric/SGD.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE RecordWildCards #-}+++-- | Stochastic gradient descent implementation using mutable+-- vectors for efficient update of the parameters vector.+-- A user is provided with the immutable vector of parameters+-- so he is able to compute the gradient outside of the IO monad.+-- Currently only the Gaussian priors are implemented.+--+-- This is a preliminary version of the SGD library and API may change+-- in future versions.+++module Numeric.SGD+( SgdArgs (..)+, sgdArgsDefault+, Para+, sgd+, module Numeric.SGD.Grad+, module Numeric.SGD.Dataset+) where+++import           Control.Monad (forM_)+import qualified System.Random as R+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Unboxed.Mutable as UM+import qualified Control.Monad.Primitive as Prim++import           Numeric.SGD.Grad+import           Numeric.SGD.Dataset+++-- | SGD parameters controlling the learning process.+data SgdArgs = SgdArgs+    { -- | Size of the batch+      batchSize :: Int+    -- | Regularization variance+    , regVar    :: Double+    -- | Number of iterations+    , iterNum   :: Double+    -- | Initial gain parameter+    , gain0     :: Double+    -- | After how many iterations over the entire dataset+    -- the gain parameter is halved+    , tau       :: Double }+++-- | Default SGD parameter values.+sgdArgsDefault :: SgdArgs+sgdArgsDefault = SgdArgs+    { batchSize = 30+    , regVar    = 10+    , iterNum   = 10+    , gain0     = 1+    , tau       = 5 }+++-- | Vector of parameters.+type Para       = U.Vector Double +++-- | Type synonym for mutable vector with Double values.+type MVect      = UM.MVector (Prim.PrimState IO) Double+++-- | A stochastic gradient descent method.+-- A notification function can be used to provide user with+-- information about the progress of the learning.+sgd+    :: SgdArgs                  -- ^ SGD parameter values+    -> (Para -> Int -> IO ())   -- ^ Notification run every update+    -> (Para -> x -> Grad)      -- ^ Gradient for dataset element+    -> Dataset x                -- ^ Dataset+    -> Para                     -- ^ Starting point+    -> IO Para                  -- ^ SGD result+sgd SgdArgs{..} notify mkGrad dataset x0 = do+    u <- UM.new (U.length x0)+    doIt u 0 (R.mkStdGen 0) =<< U.thaw x0+  where+    -- Gain in k-th iteration.+    gain k = (gain0 * tau) / (tau + done k)++    -- Number of completed iterations over the full dataset.+    done k+        = fromIntegral (k * batchSize)+        / fromIntegral (size dataset)++    doIt u k stdGen x+      | done k > iterNum = do+        frozen <- U.unsafeFreeze x+        notify frozen k+        return frozen+      | otherwise = do+        (batch, stdGen') <- sample stdGen batchSize dataset++        -- Freeze mutable vector of parameters. The frozen version is+        -- then supplied to external mkGrad function provided by user.+        frozen <- U.unsafeFreeze x+        notify frozen k++        -- let grad = M.unions (map (mkGrad frozen) batch)+        let grad = parUnions (map (mkGrad frozen) batch)+        addUp grad u+        scale (gain k) u++        x' <- U.unsafeThaw frozen+        apply u x'+        doIt u (k+1) stdGen' x'+++-- | Add up all gradients and store results in normal domain.+addUp :: Grad -> MVect -> IO ()+addUp grad v = do+    UM.set v 0+    forM_ (toList grad) $ \(i, x) -> do+        y <- UM.unsafeRead v i+        UM.unsafeWrite v i (x + y)+++-- | Scale the vector by the given value.+scale :: Double -> MVect -> IO ()+scale c v = do+    forM_ [0 .. UM.length v - 1] $ \i -> do+        y <- UM.unsafeRead v i+        UM.unsafeWrite v i (c * y)+++-- | Apply gradient to the parameters vector, that is add the first vector to+-- the second one.+apply :: MVect -> MVect -> IO ()+apply w v = do +    forM_ [0 .. UM.length v - 1] $ \i -> do+        x <- UM.unsafeRead v i+        y <- UM.unsafeRead w i+        UM.unsafeWrite v i (x + y)
+ Numeric/SGD/Dataset.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE RecordWildCards #-}+++-- | Dataset abstraction.+++module Numeric.SGD.Dataset+( +-- * Dataset+  Dataset (..)+-- * Reading+, loadData+, sample+-- * Construction+, withVect+, withDisk+, withData+) where+++import           Control.Monad (forM_)+import           Data.Binary (Binary, encodeFile, decodeFile)+import           System.IO.Unsafe (unsafeInterleaveIO)+import           System.IO.Temp (withTempDirectory)+import           System.FilePath ((</>))+import qualified System.Random as R+import qualified Data.Vector as V+import qualified Control.Monad.State.Strict as S+++-- | A dataset with elements of type @a@.+data Dataset a = Dataset {+    -- | A size of the dataset.+      size      :: Int+    -- | Get dataset element with a given index.  The set of indices+    -- is of a {0, 1, .., size - 1} form.+    , elemAt    :: Int -> IO a }+++-------------------------------------------+-- Reading+-------------------------------------------+++-- | Lazily load dataset from a disk.+loadData :: Dataset a -> IO [a]+loadData Dataset{..} = lazyMapM elemAt [0 .. size - 1]+++-- | A dataset sample of the given size.+sample :: R.RandomGen g => g -> Int -> Dataset a -> IO ([a], g)+sample g 0 _       = return ([], g)+sample g n dataset = do+    (xs, g') <- sample g (n-1) dataset+    let (i, g'') = R.next g'+    x <- dataset `elemAt` (i `mod` size dataset)+    return (x:xs, g'')+++lazyMapM :: (a -> IO b) -> [a] -> IO [b]+lazyMapM f (x:xs) = do+    y <- f x+    ys <- unsafeInterleaveIO $ lazyMapM f xs+    return (y:ys)+lazyMapM _ [] = return []+++-------------------------------------------+-- Construction+-------------------------------------------+++-- | Construct dataset from a vector of elements and run the+-- given handler.+withVect :: [a] -> (Dataset a -> IO b) -> IO b+withVect xs handler =+    handler dataset+  where+    v = V.fromList xs+    dataset = Dataset+        { size      = V.length v+        , elemAt    = \k -> return (v V.! k) }+++-- | Construct dataset from a list of elements, store it on a disk+-- and run the given handler.+withDisk :: Binary a => [a] -> (Dataset a -> IO b) -> IO b+withDisk xs handler = withTempDirectory "." ".sgd" $ \tmpDir -> do+    n <- flip S.execStateT 0 $ forM_ (zip xs [0 :: Int ..]) $ \(x, ix) -> do+        S.lift $ encodeFile (tmpDir </> show ix) x+        S.modify (+1)+    let at ix = decodeFile (tmpDir </> show ix)+    handler $ Dataset {size = n, elemAt = at}+++-- | Use disk or vector dataset representation depending on+-- the first argument: when `True`, use `withDisk`, otherwise+-- use `withVect`.+withData :: Binary a => Bool -> [a] -> (Dataset a -> IO b) -> IO b+withData x = case x of+    True    -> withDisk+    False   -> withVect
+ Numeric/SGD/Grad.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE CPP #-}++-- | A gradient is represented by an IntMap from gradient indices+-- to values. Elements with no associated values in the gradient+-- are assumed to have a 0 value assigned. Such elements are+-- not interesting: when adding the gradient to the vector of+-- parameters, only nonzero elements are taken into account.+-- +-- Each value associated with a gradient position is a pair of+-- positive and negative components. They are stored separately+-- to ensure high accuracy of computation results.+-- Besides, both positive and negative components are stored+-- in a logarithmic domain.++module Numeric.SGD.Grad+( Grad+, empty+, add+, addL+, fromList+, fromLogList+, toList+, parUnions+) where++import Data.List (foldl')+import Control.Applicative ((<$>), (<*>))+import Control.Monad.Par.Scheds.Direct (Par, runPar, get)+#if MIN_VERSION_containers(0,4,2)+import Control.Monad.Par.Scheds.Direct (spawn)+#else+import Control.DeepSeq (deepseq)+import Control.Monad.Par.Scheds.Direct (spawn_)+#endif+import qualified Data.IntMap as M++import Numeric.SGD.LogSigned++-- | Gradient with nonzero values stored in a logarithmic domain.+-- Since values equal to zero have no impact on the update phase+-- of the SGD method, it is more efficient to not to store those+-- components in the gradient.+type Grad = M.IntMap LogSigned++{-# INLINE insertWith #-}+insertWith :: (a -> a -> a) -> M.Key -> a -> M.IntMap a -> M.IntMap a+#if MIN_VERSION_containers(0,4,1)+insertWith = M.insertWith'+#else+insertWith f k x m = +    M.alter g k m+  where+    g my = case my of+        Nothing -> Just x+        Just y  ->+            let z = f x y+            in  z `seq` Just z+-- insertWith f k x m = case M.lookup k m of+--     Just y  ->+--         let x' = f x y+--         in  x' `seq` M.insert k x' m+--     Nothing -> x `seq` M.insert k x m+#endif++-- | Add normal-domain double to the gradient at the given position.+{-# INLINE add #-}+add :: Grad -> Int -> Double -> Grad+add grad i y = insertWith (+) i (logSigned y) grad +++-- | Add log-domain, singed number to the gradient at the given position.+{-# INLINE addL #-}+addL :: Grad -> Int -> LogSigned -> Grad+addL grad i y = insertWith (+) i y grad ++-- | Construct gradient from a list of (index, value) pairs.+-- All values from the list are added at respective gradient+-- positions.+{-# INLINE fromList #-}+fromList :: [(Int, Double)] -> Grad+fromList =+    let ins grad (i, y) = add grad i y+    in  foldl' ins empty++-- | Construct gradient from a list of (index, signed, log-domain number)+-- pairs.  All values from the list are added at respective gradient+-- positions.+{-# INLINE fromLogList #-}+fromLogList :: [(Int, LogSigned)] -> Grad+fromLogList =+    let ins grad (i, y) = addL grad i y+    in  foldl' ins empty++-- | Collect gradient components with values in normal domain.+{-# INLINE toList #-}+toList :: Grad -> [(Int, Double)]+toList =+    let unLog (i, x) = (i, toNorm x)+    in  map unLog . M.assocs++-- | Empty gradient, i.e. with all elements set to 0.+{-# INLINE empty #-}+empty :: Grad+empty = M.empty++-- | Perform parallel unions operation on gradient list. +-- Experimental version.+parUnions :: [Grad] -> Grad+parUnions [] = error "parUnions: empty list"+parUnions xs = runPar (parUnionsP xs)++-- | Parallel unions in the Par monad.+parUnionsP :: [Grad] -> Par Grad+parUnionsP [x] = return x+parUnionsP zs  = do+    let (xs, ys) = split zs+#if MIN_VERSION_containers(0,4,2)+    xsP <- spawn (parUnionsP xs)+    ysP <- spawn (parUnionsP ys)+    M.unionWith (+) <$> get xsP <*> get ysP+#else+    xsP <- spawn_ (parUnionsP xs)+    ysP <- spawn_ (parUnionsP ys)+    x <- M.unionWith (+) <$> get xsP <*> get ysP+    M.elems x `deepseq` return x+#endif+  where+    split []        = ([], [])+    split (x:[])    = ([x], [])+    split (x:y:rest)  =+        let (xs, ys) = split rest+        in  (x:xs, y:ys)
+ Numeric/SGD/LogSigned.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- | Module provides data type for signed log-domain calculations.++module Numeric.SGD.LogSigned+( LogSigned (..)+, logSigned+, fromPos+, fromNeg+, toNorm+, toLogFloat+) where++import qualified Data.Number.LogFloat as L+import Data.Function (on)+import Control.DeepSeq (NFData(..))++-- | Signed real value in the logarithmic domain.+data LogSigned = LogSigned+    { pos :: {-# UNPACK #-} !L.LogFloat     -- ^ Positive component+    , neg :: {-# UNPACK #-} !L.LogFloat     -- ^ Negative component+    } deriving Show++instance Eq LogSigned where+    (==) = (==) `on` toLogFloat++instance Ord LogSigned where+    compare = compare `on` toLogFloat++-- All fields are strict and unpacked.+instance NFData LogSigned where+    rnf (LogSigned p q) = p `seq` q `seq` ()++-- | Smart LogSigned constructor.+{-# INLINE logSigned #-}+logSigned :: Double -> LogSigned+logSigned x+    | x > 0     = LogSigned (L.logFloat x) zero+    | x < 0     = LogSigned zero (L.logFloat (-x))+    | otherwise = LogSigned zero zero++-- | Make LogSigned from a positive, log-domain number.+{-# INLINE fromPos #-}+fromPos :: L.LogFloat -> LogSigned+fromPos x = LogSigned x zero++-- | Make LogSigned from a negative, log-domain number.+{-# INLINE fromNeg #-}+fromNeg :: L.LogFloat -> LogSigned+fromNeg x = LogSigned zero x++-- | Shift LogSigned to a normal domain.+{-# INLINE toNorm #-}+toNorm :: LogSigned -> Double+toNorm (LogSigned x y) = L.fromLogFloat x - L.fromLogFloat y++-- | Change the 'LogSigned' to either negative 'Left' 'L.LogFloat'+-- or positive 'Right' 'L.LogFloat'.+toLogFloat :: LogSigned -> Either L.LogFloat L.LogFloat+toLogFloat x = case signum x of+    -1  -> Left  $ neg x - pos x+    1   -> Right $ pos x - neg x+    _   -> Right $ L.logFloat (0 :: Double)++instance Num LogSigned where+    LogSigned x y + LogSigned x' y' =+        LogSigned (x + x') (y + y')+    LogSigned x y * LogSigned x' y' =+        LogSigned (x*x' + y*y') (x*y' + y*x')+    LogSigned x y - LogSigned x' y' =+        LogSigned (x + y') (y + x')+    negate  (LogSigned x y) = LogSigned y x+    abs     (LogSigned x y)+        | x >= y    = LogSigned x y+        | otherwise = LogSigned y x+    signum (LogSigned x y)+        | x > y     =  1+        | x < y     = -1+        | otherwise =  0+    fromInteger = logSigned . fromInteger++{-# INLINE zero #-}+zero :: L.LogFloat+zero = L.logFloat (0 :: Double)
− README.md 
+ examples/example1.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE RecordWildCards #-}++import Control.Applicative ((<$>), (<*>))+import Control.Monad (replicateM)+import System.IO (hSetBuffering, stdout, BufferMode (NoBuffering))+import qualified System.Random as R+import qualified Data.Vector as V+import qualified Data.Vector.Unboxed as U+import qualified Numeric.SGD as S++------------------------------------------------------------------------------+-- Dataset generation+------------------------------------------------------------------------------++-- | Element of a dataset.+type Elem = [(Int, Double)]++-- | Random dataset element.+elemR+    :: Int              -- ^ Maximum number of element items+    -> (Int, Int)       -- ^ Range for item's first component+    -> (Double, Double) -- ^ Range for item's second component+    -> IO Elem          -- ^ Result+elemR nMax xr yr = do+    n <- R.randomRIO (0, max 0 nMax)+    replicateM n ((,) <$> R.randomRIO xr <*> R.randomRIO yr)++-- | Random dataset.+dataSetR+    :: Int              -- ^ Dataset size+    -> Int              -- ^ Number of model parameters+    -> Int              -- ^ Maximum number of items in data element+    -> (Double, Double) -- ^ Range for item's second component+    -> IO (V.Vector Elem)   -- ^ Result+dataSetR m n k yRan =+    V.fromList <$> replicateM m (elemR k (0, n-1) yRan)++------------------------------------------------------------------------------+-- Objective function and gradient+------------------------------------------------------------------------------++-- | An objective function. The SGD method can be used when+-- the objective function is defined in a form of a sum.+goal :: S.Para -> [Elem] -> Double+goal para =+    sum . map perElem+  where+    perElem xs = sum+        [ (para U.! k - x) ^ (2 :: Int)+        | (k, x) <- xs ]++-- | Since the goal function has a form of a sum, it is sufficient to define+-- the gradient over one element only. The gradient with respect to the dataset+-- is a sum of gradients over its individual elements.+grad :: S.Para -> Elem -> S.Grad+grad para xs = S.fromList+    -- [ (k, 2 * (x - para U.! k))+    [ (k, 2 * (para U.! k - x))+    | (k, x) <- xs ]++-- | Negate gradient. We use it to find the minimum of the objective function.+negGrad :: (S.Para -> Elem -> S.Grad)+        -> (S.Para -> Elem -> S.Grad)+negGrad g para x = fmap negate (g para x)++------------------------------------------------------------------------------+-- SGD+------------------------------------------------------------------------------++-- | Notification run by the sgdM function every parameters update.+notify :: S.SgdArgs -> V.Vector Elem -> S.Para -> Int -> IO ()+notify S.SgdArgs{..} dataSet para k =+    if doneTotal k /= doneTotal (k - 1)+        then do+            let n = doneTotal k+                x = goal para (V.toList dataSet)+            putStrLn ("\n" ++ "[" ++ show n ++ "] f = " ++ show x)+        else+            putStr "."+  where+    doneTotal :: Int -> Int+    doneTotal = floor . done+    done :: Int -> Double+    done i+        = fromIntegral (i * batchSize)+        / fromIntegral (V.length dataSet)++-- | Run the monadic version of SGD.+runSgdM+    :: Int              -- ^ Dataset size+    -> Int              -- ^ Number of model parameters+    -> Int              -- ^ Maximum number of items in data element+    -> S.SgdArgs        -- ^ SGD parameters+    -> IO S.Para+runSgdM m n k sgdArgs = do+    dataSet <- dataSetR m n k (-10, 10)+    let para = U.replicate n 0+    hSetBuffering stdout NoBuffering+    S.sgdM sgdArgs (notify sgdArgs dataSet) (negGrad grad) dataSet para++-- | Run the monadic version of SGD with some default parameter values.+main = do+    let sgdArgs = S.sgdArgsDefault { S.iterNum = 50 }+    runSgdM 1000 1000000 10 sgdArgs
sgd.cabal view
@@ -1,47 +1,48 @@-cabal-version: 1.12+name:               sgd+version:            0.3+synopsis:           Stochastic gradient descent+description:+    Implementation of a Stochastic Gradient Descent optimization method.+    See examples directory in the source package for examples of usage.+    .+    It is a preliminary implementation of the SGD method and API may change+    in future versions.+license:            BSD3+license-file:       LICENSE+cabal-version:      >= 1.6+copyright:          Copyright (c) 2012 IPI PAN+author:             Jakub Waszczuk+maintainer:         waszczuk.kuba@gmail.com+stability:          experimental+category:           Math, Algorithms+homepage:           https://github.com/kawu/sgd+build-type:         Simple --- This file has been generated from package.yaml by hpack version 0.31.1.------ see: https://github.com/sol/hpack------ hash: 22ab2f64f9a599a15e88a4b7908141136d4cb9cbea758970534f7f6146408b8b+extra-source-files: examples/example1.hs -name:           sgd-version:        0.2.3-synopsis:       Stochastic gradient descent-description:    Please see the README on GitHub at <https://github.com/kawu/sgd#readme>-category:       Math, Algorithms-homepage:       https://github.com/kawu/sgd#readme-bug-reports:    https://github.com/kawu/sgd/issues-author:         Jakub Waszczuk-maintainer:     waszczuk.kuba@gmail.com-copyright:      2012-2019 IPI PAN, Jakub Waszczuk-license:        BSD3-license-file:   LICENSE-build-type:     Simple-extra-source-files:-    README.md+library+    build-depends:+        base >= 4 && < 5+      , containers+      , vector+      , random+      , primitive+      , logfloat+      , monad-par+      , deepseq+      , binary+      , mtl+      , filepath+      , temporary -source-repository head-  type: git-  location: https://github.com/kawu/sgd+    exposed-modules:+        Numeric.SGD+      , Numeric.SGD.Dataset+      , Numeric.SGD.LogSigned+      , Numeric.SGD.Grad -library-  exposed-modules:-      Numeric.SGD-      Numeric.SGD.Grad-      Numeric.SGD.LogSigned-  other-modules:-      Paths_sgd-  hs-source-dirs:-      src-  build-depends:-      base >=4.7 && <5-    , containers >=0.5 && <0.7-    , deepseq-    , logfloat-    , monad-par-    , primitive-    , random-    , vector-  default-language: Haskell2010+    ghc-options: -Wall -O2++source-repository head+    type: git+    location: git://github.com/kawu/sgd.git
− src/Numeric/SGD.hs 
@@ -1,162 +0,0 @@-{-# LANGUAGE RecordWildCards #-}---- | Stochastic gradient descent implementation using mutable--- vectors for efficient update of the parameters vector.--- A user is provided with the immutable version of parameters vector--- so he is able to compute the gradient outside the IO/ST monad.--- Currently only the Gaussian priors are implemented.------ This is a preliminary version of the SGD library and API may change--- in future versions.--module Numeric.SGD-( SgdArgs (..)-, sgdArgsDefault-, Dataset-, Para-, sgd-, sgdM-, module Numeric.SGD.Grad-) where--import Control.Monad (forM_)-import Control.Monad.ST (ST, runST)-import qualified System.Random as R-import qualified Data.Vector as V-import qualified Data.Vector.Unboxed as U-import qualified Data.Vector.Unboxed.Mutable as UM-import qualified Control.Monad.Primitive as Prim--import Numeric.SGD.Grad---- | SGD parameters controlling the learning process.-data SgdArgs = SgdArgs-    { -- | Size of the batch-      batchSize :: Int-    -- | Regularization variance-    , regVar    :: Double-    -- | Number of iterations-    , iterNum   :: Double-    -- | Initial gain parameter-    , gain0     :: Double-    -- | After how many iterations over the entire dataset-    -- the gain parameter is halved-    , tau       :: Double }---- | Default SGD parameter values.-sgdArgsDefault :: SgdArgs-sgdArgsDefault = SgdArgs-    { batchSize = 30-    , regVar    = 10-    , iterNum   = 10-    , gain0     = 1-    , tau       = 5 }---- | Dataset with elements of x type.-type Dataset x  = V.Vector x---- | Vector of parameters.-type Para       = U.Vector Double ---- | Type synonym for mutable vector with Double values.-type MVect m    = UM.MVector (Prim.PrimState m) Double---- | Pure version of the stochastic gradient descent method.-sgd :: SgdArgs              -- ^ SGD parameter values-    -> (Para -> x -> Grad)  -- ^ Gradient for dataset element-    -> Dataset x            -- ^ Dataset-    -> Para                 -- ^ Starting point-    -> Para                 -- ^ SGD result-sgd sgdArgs mkGrad dataset x0 =-    let dummy _ _ = return ()-    in  runST $ sgdM sgdArgs dummy mkGrad dataset x0---- | Monadic version of the stochastic gradient descent method.--- A notification function can be used to provide user with--- information about the progress of the learning.-{-# SPECIALIZE sgdM :: SgdArgs-                    -> (Para -> Int -> IO ())-                    -> (Para -> x -> Grad)-                    -> Dataset x -> Para -> IO Para #-}-{-# SPECIALIZE sgdM :: SgdArgs-                    -> (Para -> Int -> ST s ())-                    -> (Para -> x -> Grad)-                    -> Dataset x -> Para -> ST s Para #-}-sgdM-    :: (Prim.PrimMonad m)-    => SgdArgs              -- ^ SGD parameter values-    -> (Para -> Int -> m ())    -- ^ Notification run every update-    -> (Para -> x -> Grad)  -- ^ Gradient for dataset element-    -> Dataset x            -- ^ Dataset-    -> Para                 -- ^ Starting point-    -> m Para               -- ^ SGD result-sgdM SgdArgs{..} notify mkGrad dataset x0 = do-    u <- UM.new (U.length x0)-    doIt u 0 (R.mkStdGen 0) =<< U.thaw x0-  where-    -- | Gain in k-th iteration.-    gain k = (gain0 * tau) / (tau + done k)-    -- | Number of completed iterations over the full dataset.-    done k-        = fromIntegral (k * batchSize)-        / fromIntegral (V.length dataset) --    doIt u k stdGen x-      | done k > iterNum = do-        frozen <- U.unsafeFreeze x-        notify frozen k-        return frozen-      | otherwise = do-        let (batch, stdGen') = sample stdGen batchSize dataset--        -- Freeze mutable vector of parameters. The frozen version is-        -- then supplied to external mkGrad function provided by user.-        frozen <- U.unsafeFreeze x-        notify frozen k--        -- let grad = M.unions (map (mkGrad frozen) batch)-        let grad = parUnions (map (mkGrad frozen) batch)-        addUp grad u-        scale (gain k) u--        x' <- U.unsafeThaw frozen-        apply u x'-        doIt u (k+1) stdGen' x'---- | Add up all gradients and store results in normal domain.-{-# SPECIALIZE addUp :: Grad -> MVect IO -> IO () #-}-{-# SPECIALIZE addUp :: Grad -> MVect (ST s) -> ST s () #-}-addUp :: Prim.PrimMonad m => Grad -> MVect m -> m ()-addUp grad v = do-    UM.set v 0-    forM_ (toList grad) $ \(i, x) -> do-        y <- UM.unsafeRead v i-        UM.unsafeWrite v i (x + y)---- | Scale the vector by the given value.-{-# SPECIALIZE scale :: Double -> MVect IO -> IO () #-}-{-# SPECIALIZE scale :: Double -> MVect (ST s) -> ST s () #-}-scale :: Prim.PrimMonad m => Double -> MVect m -> m ()-scale c v = do-    forM_ [0 .. UM.length v - 1] $ \i -> do-        y <- UM.unsafeRead v i-        UM.unsafeWrite v i (c * y)---- | Apply gradient to the parameters vector, that is add the first vector to--- the second one.-{-# SPECIALIZE apply :: MVect IO -> MVect IO -> IO () #-}-{-# SPECIALIZE apply :: MVect (ST s) -> MVect (ST s) -> ST s () #-}-apply :: Prim.PrimMonad m => MVect m -> MVect m -> m ()-apply w v = do -    forM_ [0 .. UM.length v - 1] $ \i -> do-        x <- UM.unsafeRead v i-        y <- UM.unsafeRead w i-        UM.unsafeWrite v i (x + y)--sample :: R.RandomGen g => g -> Int -> Dataset x -> ([x], g)-sample g 0 _       = ([], g)-sample g n dataset =-    let (xs, g') = sample g (n-1) dataset-        (i, g'') = R.next g'-        x = dataset V.! (i `mod` V.length dataset)-    in  (x:xs, g'')
− src/Numeric/SGD/Grad.hs 
@@ -1,109 +0,0 @@--- {-# LANGUAGE CPP #-}---- | A gradient is represented by an IntMap from gradient indices--- to values. Elements with no associated values in the gradient--- are assumed to have a 0 value assigned. Such elements are--- not interesting: when adding the gradient to the vector of--- parameters, only nonzero elements are taken into account.--- --- Each value associated with a gradient position is a pair of--- positive and negative components. They are stored separately--- to ensure high accuracy of computation results.--- Besides, both positive and negative components are stored--- in a logarithmic domain.--module Numeric.SGD.Grad-( Grad-, empty-, add-, addL-, fromList-, fromLogList-, toList-, parUnions-) where--import Data.List (foldl')-import Control.Applicative ((<$>), (<*>))-import Control.Monad.Par.Scheds.Direct (Par, runPar, get)--- #if MIN_VERSION_containers(0,4,2)-import Control.Monad.Par.Scheds.Direct (spawn)--- #else--- import Control.DeepSeq (deepseq)--- import Control.Monad.Par.Scheds.Direct (spawn_)--- #endif-import qualified Data.IntMap.Strict as M--import Numeric.SGD.LogSigned---- | Gradient with nonzero values stored in a logarithmic domain.--- Since values equal to zero have no impact on the update phase--- of the SGD method, it is more efficient to not to store those--- components in the gradient.-type Grad = M.IntMap LogSigned--{-# INLINE insertWith #-}-insertWith :: (a -> a -> a) -> M.Key -> a -> M.IntMap a -> M.IntMap a-insertWith = M.insertWith---- | Add normal-domain double to the gradient at the given position.-{-# INLINE add #-}-add :: Grad -> Int -> Double -> Grad-add grad i y = insertWith (+) i (logSigned y) grad ----- | Add log-domain, singed number to the gradient at the given position.-{-# INLINE addL #-}-addL :: Grad -> Int -> LogSigned -> Grad-addL grad i y = insertWith (+) i y grad ---- | Construct gradient from a list of (index, value) pairs.--- All values from the list are added at respective gradient--- positions.-{-# INLINE fromList #-}-fromList :: [(Int, Double)] -> Grad-fromList =-    let ins grad (i, y) = add grad i y-    in  foldl' ins empty---- | Construct gradient from a list of (index, signed, log-domain number)--- pairs.  All values from the list are added at respective gradient--- positions.-{-# INLINE fromLogList #-}-fromLogList :: [(Int, LogSigned)] -> Grad-fromLogList =-    let ins grad (i, y) = addL grad i y-    in  foldl' ins empty---- | Collect gradient components with values in normal domain.-{-# INLINE toList #-}-toList :: Grad -> [(Int, Double)]-toList =-    let unLog (i, x) = (i, toNorm x)-    in  map unLog . M.assocs---- | Empty gradient, i.e. with all elements set to 0.-{-# INLINE empty #-}-empty :: Grad-empty = M.empty---- | Perform parallel unions operation on gradient list. --- Experimental version.-parUnions :: [Grad] -> Grad-parUnions [] = error "parUnions: empty list"-parUnions xs = runPar (parUnionsP xs)---- | Parallel unions in the Par monad.-parUnionsP :: [Grad] -> Par Grad-parUnionsP [x] = return x-parUnionsP zs  = do-    let (xs, ys) = split zs-    xsP <- spawn (parUnionsP xs)-    ysP <- spawn (parUnionsP ys)-    M.unionWith (+) <$> get xsP <*> get ysP-  where-    split []        = ([], [])-    split (x:[])    = ([x], [])-    split (x:y:rest)  =-        let (xs, ys) = split rest-        in  (x:xs, y:ys)
− src/Numeric/SGD/LogSigned.hs 
@@ -1,85 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}---- | Module provides data type for signed log-domain calculations.--module Numeric.SGD.LogSigned-( LogSigned (..)-, logSigned-, fromPos-, fromNeg-, toNorm-, toLogFloat-) where--import qualified Data.Number.LogFloat as L-import Data.Function (on)-import Control.DeepSeq (NFData(..))---- | Signed real value in the logarithmic domain.-data LogSigned = LogSigned-    { pos :: {-# UNPACK #-} !L.LogFloat     -- ^ Positive component-    , neg :: {-# UNPACK #-} !L.LogFloat     -- ^ Negative component-    } deriving Show--instance Eq LogSigned where-    (==) = (==) `on` toLogFloat--instance Ord LogSigned where-    compare = compare `on` toLogFloat---- All fields are strict and unpacked.-instance NFData LogSigned where-    rnf (LogSigned p q) = p `seq` q `seq` ()---- | Smart LogSigned constructor.-{-# INLINE logSigned #-}-logSigned :: Double -> LogSigned-logSigned x-    | x > 0     = LogSigned (L.logFloat x) zero-    | x < 0     = LogSigned zero (L.logFloat (-x))-    | otherwise = LogSigned zero zero---- | Make LogSigned from a positive, log-domain number.-{-# INLINE fromPos #-}-fromPos :: L.LogFloat -> LogSigned-fromPos x = LogSigned x zero---- | Make LogSigned from a negative, log-domain number.-{-# INLINE fromNeg #-}-fromNeg :: L.LogFloat -> LogSigned-fromNeg x = LogSigned zero x---- | Shift LogSigned to a normal domain.-{-# INLINE toNorm #-}-toNorm :: LogSigned -> Double-toNorm (LogSigned x y) = L.fromLogFloat x - L.fromLogFloat y---- | Change the 'LogSigned' to either negative 'Left' 'L.LogFloat'--- or positive 'Right' 'L.LogFloat'.-toLogFloat :: LogSigned -> Either L.LogFloat L.LogFloat-toLogFloat x = case signum x of-    -1  -> Left  $ neg x - pos x-    1   -> Right $ pos x - neg x-    _   -> Right $ L.logFloat (0 :: Double)--instance Num LogSigned where-    LogSigned x y + LogSigned x' y' =-        LogSigned (x + x') (y + y')-    LogSigned x y * LogSigned x' y' =-        LogSigned (x*x' + y*y') (x*y' + y*x')-    LogSigned x y - LogSigned x' y' =-        LogSigned (x + y') (y + x')-    negate  (LogSigned x y) = LogSigned y x-    abs     (LogSigned x y)-        | x >= y    = LogSigned x y-        | otherwise = LogSigned y x-    signum (LogSigned x y)-        | x > y     =  1-        | x < y     = -1-        | otherwise =  0-    fromInteger = logSigned . fromInteger--{-# INLINE zero #-}-zero :: L.LogFloat-zero = L.logFloat (0 :: Double)