hasty-hamiltonian

Speedy gradient-based traversal through parameter space.
Log | Files | Refs | README | LICENSE

commit cd7b9e5f40201d3b3e066df83d87d8a9ffe2b914
parent 78372fbccb60397a57bc0b33dd66f03f5fc64f9f
Author: Jared Tobin <jared@jtobin.ca>
Date:   Thu,  8 Oct 2015 21:04:34 +1300

1.1.0 update.

Diffstat:
M.gitignore | 5+++++
MLICENSE | 43++++++++++++++++---------------------------
ANumeric/MCMC/Hamiltonian.hs | 218+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
DNumeric/Sampling/Hamiltonian.hs | 143-------------------------------------------------------------------------------
MREADME.md | 33++++++++++++++++++++++++---------
Mhasty-hamiltonian.cabal | 65+++++++++++++++++++++++++++++++++++++++++++++--------------------
Astack.yaml | 7+++++++
Atest/Beale.hs | 23+++++++++++++++++++++++
Atest/Booth.hs | 17+++++++++++++++++
Atest/Rosenbrock.hs | 17+++++++++++++++++
10 files changed, 372 insertions(+), 199 deletions(-)

diff --git a/.gitignore b/.gitignore @@ -19,3 +19,8 @@ tmp *hp *ps *aux +.stack-work +debug +test/Beale +test/Booth +test/Rosenbrock diff --git a/LICENSE b/LICENSE @@ -1,30 +1,19 @@ -Copyright (c) 2012, Jared Tobin +Copyright (c) 2012-2015 Jared Tobin -All rights reserved. +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Jared Tobin nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/Numeric/MCMC/Hamiltonian.hs b/Numeric/MCMC/Hamiltonian.hs @@ -0,0 +1,218 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module: Numeric.MCMC.Hamiltonian +-- Copyright: (c) 2015 Jared Tobin +-- License: MIT +-- +-- Maintainer: Jared Tobin <jared@jtobin.ca> +-- Stability: unstable +-- Portability: ghc +-- +-- This implementation performs Hamiltonian Monte Carlo using an identity mass +-- matrix. +-- +-- The 'mcmc' function streams a trace to stdout to be processed elsewhere, +-- while the `slice` transition can be used for more flexible purposes, such as +-- working with samples in memory. +-- +-- See <http://arxiv.org/pdf/1206.1901.pdf Neal, 2012> for the definitive +-- reference of the algorithm. + +module Numeric.MCMC.Hamiltonian ( + mcmc + , hamiltonian + + -- * Re-exported + , Target(..) + , MWC.create + , MWC.createSystemRandom + , MWC.withSystemRandom + , MWC.asGenIO + ) where + +import Control.Lens hiding (index) +import Control.Monad.Trans.State.Strict hiding (state) +import Control.Monad.Primitive (PrimState, PrimMonad, RealWorld) +import qualified Data.Foldable as Foldable (sum) +import Data.Maybe (fromMaybe) +import Data.Sampling.Types +import Data.Traversable (for) +import Pipes hiding (for, next) +import qualified Pipes.Prelude as Pipes +import System.Random.MWC.Probability (Prob, Gen) +import qualified System.Random.MWC.Probability as MWC + +-- | Trace 'n' iterations of a Markov chain and stream them to stdout. +-- +-- >>> withSystemRandom . asGenIO $ mcmc 3 1 [0, 0] target +mcmc + :: (Num (IxValue (t Double)), Show (t Double), Traversable t + , FunctorWithIndex (Index (t Double)) t, Ixed (t Double) + , IxValue (t Double) ~ Double) + => Int + -> Double + -> Int + -> t Double + -> Target (t Double) + -> Gen RealWorld + -> IO () +mcmc n step leaps chainPosition chainTarget gen = runEffect $ + chain step leaps Chain {..} gen + >-> Pipes.take n + >-> Pipes.mapM_ print + where + chainScore = lTarget chainTarget chainPosition + chainTunables = Nothing + +-- A Markov chain driven by the Metropolis transition operator. +chain + :: (Num (IxValue (t Double)), Traversable t + , FunctorWithIndex (Index (t Double)) t, Ixed (t Double) + , PrimMonad m, IxValue (t Double) ~ Double) + => Double + -> Int + -> Chain (t Double) b + -> Gen (PrimState m) + -> Producer (Chain (t Double) b) m () +chain step leaps = loop where + loop state prng = do + next <- lift (MWC.sample (execStateT (hamiltonian step leaps) state) prng) + yield next + loop next prng + +-- | A Hamiltonian transition operator. +hamiltonian + :: (Num (IxValue (t Double)), Traversable t + , FunctorWithIndex (Index (t Double)) t, Ixed (t Double), PrimMonad m + , IxValue (t Double) ~ Double) + => Double -> Int -> Transition m (Chain (t Double) b) +hamiltonian e l = do + Chain {..} <- get + r0 <- lift (for chainPosition (const MWC.standard)) + zc <- lift (MWC.uniform :: PrimMonad m => Prob m Double) + let (q, r) = leapfrogIntegrator chainTarget e l (chainPosition, r0) + perturbed = nextState chainTarget (chainPosition, q) (r0, r) zc + perturbedScore = lTarget chainTarget perturbed + put (Chain chainTarget perturbedScore perturbed chainTunables) + +-- Calculate the next state of the chain. +nextState + :: (Foldable s, Foldable t, FunctorWithIndex (Index (t Double)) t + , FunctorWithIndex (Index (s Double)) s, Ixed (s Double) + , Ixed (t Double), IxValue (t Double) ~ Double + , IxValue (s Double) ~ Double) + => Target b + -> (b, b) + -> (s Double, t Double) + -> Double + -> b +nextState target position momentum z + | z < pAccept = snd position + | otherwise = fst position + where + pAccept = acceptProb target position momentum + +-- Calculate the acceptance probability of a proposed moved. +acceptProb + :: (Foldable t, Foldable s, FunctorWithIndex (Index (t Double)) t + , FunctorWithIndex (Index (s Double)) s, Ixed (t Double) + , Ixed (s Double), IxValue (t Double) ~ Double + , IxValue (s Double) ~ Double) + => Target a + -> (a, a) + -> (s Double, t Double) + -> Double +acceptProb target (q0, q1) (r0, r1) = exp . min 0 $ + auxilliaryTarget target (q1, r1) - auxilliaryTarget target (q0, r0) + +-- A momentum-augmented target. +auxilliaryTarget + :: (Foldable t, FunctorWithIndex (Index (t Double)) t + , Ixed (t Double), IxValue (t Double) ~ Double) + => Target a + -> (a, t Double) + -> Double +auxilliaryTarget target (t, r) = f t - 0.5 * innerProduct r r where + f = lTarget target + +innerProduct + :: (Num (IxValue s), Foldable t, FunctorWithIndex (Index s) t, Ixed s) + => t (IxValue s) -> s -> IxValue s +innerProduct xs ys = Foldable.sum $ gzipWith (*) xs ys + +-- A container-generic zipwith. +gzipWith + :: (FunctorWithIndex (Index s) f, Ixed s) + => (a -> IxValue s -> b) -> f a -> s -> f b +gzipWith f xs ys = imap (\j x -> f x (fromMaybe err (ys ^? ix j))) xs where + err = error "gzipWith: invalid index" + +-- The leapfrog or Stormer-Verlet integrator. +leapfrogIntegrator + :: (Num (IxValue (f Double)), Num (IxValue (t Double)) + , FunctorWithIndex (Index (f Double)) t + , FunctorWithIndex (Index (t Double)) f + , Ixed (f Double), Ixed (t Double) + , IxValue (f Double) ~ Double + , IxValue (t Double) ~ Double) + => Target (f Double) + -> Double + -> Int + -> (f Double, t (IxValue (f Double))) + -> (f Double, t (IxValue (f Double))) +leapfrogIntegrator target e l (q0, r0) = go q0 r0 l where + go q r 0 = (q, r) + go q r n = go q1 r1 (pred n) where + (q1, r1) = leapfrog target e (q, r) + +-- A single leapfrog step. +leapfrog + :: (Num (IxValue (f Double)), Num (IxValue (t Double)) + , FunctorWithIndex (Index (f Double)) t + , FunctorWithIndex (Index (t Double)) f + , Ixed (t Double), Ixed (f Double) + , IxValue (f Double) ~ Double, IxValue (t Double) ~ Double) + => Target (f Double) + -> Double + -> (f Double, t (IxValue (f Double))) + -> (f Double, t (IxValue (f Double))) +leapfrog target e (q, r) = (qf, rf) where + rm = adjustMomentum target e (q, r) + qf = adjustPosition e (rm, q) + rf = adjustMomentum target e (qf, rm) + +adjustMomentum + :: (Functor f, Num (IxValue (f Double)) + , FunctorWithIndex (Index (f Double)) t, Ixed (f Double)) + => Target (f Double) + -> Double + -> (f Double, t (IxValue (f Double))) + -> t (IxValue (f Double)) +adjustMomentum target e (q, r) = r .+ ((0.5 * e) .* g q) where + g = fromMaybe err (glTarget target) + err = error "adjustMomentum: no gradient provided" + +adjustPosition + :: (Functor f, Num (IxValue (f Double)) + , FunctorWithIndex (Index (f Double)) t, Ixed (f Double)) + => Double + -> (f Double, t (IxValue (f Double))) + -> t (IxValue (f Double)) +adjustPosition e (r, q) = q .+ (e .* r) + +-- Scalar-vector product. +(.*) :: (Num a, Functor f) => a -> f a -> f a +z .* xs = fmap (* z) xs + +-- Vector addition. +(.+) + :: (Num (IxValue t), FunctorWithIndex (Index t) f, Ixed t) + => f (IxValue t) + -> t + -> f (IxValue t) +(.+) = gzipWith (+) + diff --git a/Numeric/Sampling/Hamiltonian.hs b/Numeric/Sampling/Hamiltonian.hs @@ -1,143 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} - --- | Hamiltonian Monte Carlo. See, ex: Neal (2012) --- http://arxiv.org/pdf/1206.1901.pdf. - -module Numeric.Sampling.Hamiltonian ( - Target(..) - , Tunables(..) - , Options(..) - , hamiltonian - , hmc - ) where - -import Control.Applicative -import Control.Monad -import Control.Monad.Primitive -import Control.Monad.Trans.Class -import Control.Monad.Trans.State.Strict -import qualified Data.Foldable as Foldable -import Data.Sampling.Types -import Data.Vector (Vector) -import qualified Data.Vector as V -import System.Random.MWC -import System.Random.MWC.Distributions - -data Tunables = Tunables { - stepSize :: !Double -- ^ step size for a given proposal - , leapfrogs :: !Int -- ^ number of leapfrog steps to take - } deriving Show - -data Options = Options { - epochs :: !Int -- ^ number of epochs to iterate the chain - , initial :: !Parameters -- ^ start location - } deriving Show - -type Particle = (Parameters, Parameters) - -type Transition m = StateT Parameters m Parameters - --- | The Hamiltonian transition operator. -hamiltonian - :: PrimMonad m - => Target - -> Tunables - -> Gen (PrimState m) - -> Transition m -hamiltonian target tunables g = do - q0 <- get - r0 <- V.replicateM (V.length q0) (lift $ standard g) - zc <- lift $ uniform g - let (q, r) = leapfrogIntegrator target tunables (q0, r0) - next = nextState target (q0, q) (r0, r) zc - put next - return next -{-# INLINE hamiltonian #-} - --- | The leapfrog or Stormer-Verlet integrator. -leapfrogIntegrator :: Target -> Tunables -> Particle -> Particle -leapfrogIntegrator target tunables (q0, r0) = go q0 r0 l where - l = leapfrogs tunables - go q r 0 = (q, r) - go q r n = - let (q1, r1) = leapfrog target tunables (q, r) - in go q1 r1 (pred n) -{-# INLINE leapfrogIntegrator #-} - --- | A single iteration of the leapfrog integrator. -leapfrog :: Target -> Tunables -> Particle -> Particle -leapfrog target tunables (q, r) = (qf, rf) where - rm = adjustMomentum target tunables (q, r) - qf = adjustPosition tunables (rm, q) - rf = adjustMomentum target tunables (qf, rm) -{-# INLINE leapfrog #-} - --- | Adjust momentum according to a half-leapfrog step. -adjustMomentum :: Target -> Tunables -> Particle -> Parameters -adjustMomentum target tunables (q, r) = r .+ ((0.5 * e) .* g q) where - e = stepSize tunables - g = glTarget target -{-# INLINE adjustMomentum #-} - --- | Adjust position according to a half-leapfrog step. -adjustPosition :: Tunables -> Particle -> Parameters -adjustPosition tunables (r, q) = q .+ (e .* r) where - e = stepSize tunables -{-# INLINE adjustPosition #-} - --- | Scalar-vector multiplication. -(.*) :: Double -> Parameters -> Parameters -z .* xs = (* z) <$> xs -{-# INLINE (.*) #-} - --- | Scalar-vector addition. -(.+) :: Parameters -> Parameters -> Parameters -xs .+ ys = V.zipWith (+) xs ys -{-# INLINE (.+) #-} - --- | The next state of the Markov chain. -nextState - :: Target - -> Particle - -> Particle - -> Double - -> Parameters -nextState target position momentum z - | z < pAccept = snd position - | otherwise = fst position - where - pAccept = acceptProb target position momentum -{-# INLINE nextState #-} - --- | A target augmented by momentum auxilliary variables. -auxilliaryTarget :: Target -> Particle -> Double -auxilliaryTarget target (t, r) = f t - 0.5 * innerProduct r r where - f = lTarget target -{-# INLINE auxilliaryTarget #-} - --- | The acceptance probability of a move. -acceptProb :: Target -> Particle -> Particle -> Double -acceptProb target (q0, q1) (r0, r1) = exp . min 0 $ - auxilliaryTarget target (q1, r1) - auxilliaryTarget target (q0, r0) -{-# INLINE acceptProb #-} - --- | Simple inner product. -innerProduct :: Parameters -> Parameters -> Double -innerProduct xs ys = V.sum $ V.zipWith (*) xs ys -{-# INLINE innerProduct #-} - --- | Run a chain of HMC. -hmc - :: PrimMonad m - => Target - -> Tunables - -> Options - -> Gen (PrimState m) - -> m [Parameters] -hmc target tunables options g = do - let h = hamiltonian target tunables g - n = epochs options - q = initial options - evalStateT (replicateM n h) q -{-# INLINE hmc #-} - diff --git a/README.md b/README.md @@ -1,16 +1,31 @@ -# hasty-hamiltonian [![Build Status](https://secure.travis-ci.org/jtobin/hasty-hamiltonian.png)](http://travis-ci.org/jtobin/hasty-hamiltonian) +# hasty-hamiltonian -Speedy, gradient-based traversal through parameter space. See the *examples* folder for example usage. +[![Build Status](https://secure.travis-ci.org/jtobin/hasty-hamiltonian.png)](http://travis-ci.org/jtobin/hasty-hamiltonian) +[![Hackage Version](https://img.shields.io/hackage/v/hasty-hamiltonian.svg)](http://hackage.haskell.org/package/hasty-hamiltonian) -Install notes: +Speedy, gradient-based traversal through parameter space. - cabal sandbox init - cabal install -j --only-dep +Exports a `mcmc` function that prints a trace to stdout, as well as a +`hamiltonian` transition operator that can be used more generally. -To build the example, +If you don't want to calculate your gradients by hand you can use the handy +[ad](https://hackage.haskell.org/package/ad) library for automatic +differentiation. - cabal install -j --only-dep --enable-tests - cabal build -j hasty-examples + import Numeric.AD (grad) + import Numeric.MCMC.Hamiltonian -You can then use `./dist/build/hasty-examples/hasty-examples` to see an example trace of a chain wandering over the [Rosenbrock density](http://en.wikipedia.org/wiki/Rosenbrock_function). + target :: RealFloat a => [a] -> a + target [x0, x1] = negate ((x0 + 2 * x1 - 7) ^ 2 + (2 * x0 + x1 - 5) ^ 2) + + gTarget :: [Double] -> [Double] + gTarget = grad target + + booth :: Target [Double] + booth = Target target (Just gTarget) + + main :: IO () + main = withSystemRandom . asGenIO $ mcmc 10000 0.05 20 [0, 0] booth + +![trace](https://dl.dropboxusercontent.com/spa/u0s6617yxinm2ca/osecfv_w.png) diff --git a/hasty-hamiltonian.cabal b/hasty-hamiltonian.cabal @@ -1,17 +1,42 @@ name: hasty-hamiltonian -version: 0.3.0.0 +version: 1.1.0 synopsis: Speedy traversal through parameter space. homepage: http://jtobin.github.com/hasty-hamiltonian -license: BSD3 +license: MIT license-file: LICENSE author: Jared Tobin maintainer: jared@jtobin.ca category: Numeric build-type: Simple -cabal-version: >=1.18 +cabal-version: >=1.10 Description: - - Speedy gradient-based traversal through parameter space. + Gradient-based traversal through parameter space. + . + This implementation of HMC algorithm uses 'lens' as a means to operate over + generic indexed traversable functors, so you can expect it to work if your + target function takes a list, vector, map, sequence, etc. as its argument. + . + If you don't want to calculate your gradients by hand you can use the + handy <https://hackage.haskell.org/package/ad ad> library for automatic + differentiation. + . + Exports a 'mcmc' function that prints a trace to stdout, as well as a + 'hamiltonian' transition operator that can be used more generally. + . + > import Numeric.AD (grad) + > import Numeric.MCMC.Hamiltonian + > + > target :: RealFloat a => [a] -> a + > target [x0, x1] = negate ((x0 + 2 * x1 - 7) ^ 2 + (2 * x0 + x1 - 5) ^ 2) + > + > gTarget :: [Double] -> [Double] + > gTarget = grad target + > + > booth :: Target [Double] + > booth = Target target (Just gTarget) + > + > main :: IO () + > main = withSystemRandom . asGenIO $ mcmc 10000 0.05 20 [0, 0] booth Source-repository head Type: git @@ -19,30 +44,30 @@ Source-repository head library default-language: Haskell2010 + ghc-options: + -Wall exposed-modules: - Numeric.Sampling.Hamiltonian + Numeric.MCMC.Hamiltonian build-depends: - base - , mtl - , mcmc-types - , mwc-random + base < 5 + , ghc-prim + , mcmc-types >= 1.0.1 + , mwc-probability >= 1.0.1 + , lens + , pipes , primitive , transformers - , vector - ghc-options: - -Wall -Test-Suite hasty-examples +Test-suite booth type: exitcode-stdio-1.0 - hs-source-dirs: examples - main-is: Example.hs + hs-source-dirs: test + main-is: Booth.hs default-language: Haskell2010 ghc-options: - -threaded -rtsopts -Wall -O2 + -rtsopts build-depends: ad - , base + , base < 5 + , mwc-probability >= 1.0.1 , hasty-hamiltonian - , mwc-random >= 0.13.2.0 - , vector diff --git a/stack.yaml b/stack.yaml @@ -0,0 +1,7 @@ +flags: {} +packages: +- '.' +extra-deps: + - mcmc-types-1.0.1 + - mwc-probability-1.0.1 +resolver: lts-3.3 diff --git a/test/Beale.hs b/test/Beale.hs @@ -0,0 +1,23 @@ +{-# OPTIONS_GHC -fno-warn-type-defaults #-} + +import Numeric.AD (grad) +import Numeric.MCMC.Hamiltonian + +target :: RealFloat a => [a] -> a +target [x0, x1] + | and [x0 >= -4.5, x0 <= 4.5, x1 >= -4.5, x1 <= 4.5] + = negate $ (1.5 - x0 + x0 * x1) ^ 2 + + (2.25 - x0 + x0 * x1 ^ 2) ^ 2 + + (2.625 - x0 + x0 * x1 ^ 3) ^ 2 + | otherwise = - (1 / 0) + +gTarget :: [Double] -> [Double] +gTarget = grad target + +beale :: Target [Double] +beale = Target target (Just gTarget) + +main :: IO () +main = withSystemRandom . asGenIO $ mcmc 10000 0.05 20 [0, 0] beale + + diff --git a/test/Booth.hs b/test/Booth.hs @@ -0,0 +1,17 @@ +{-# OPTIONS_GHC -fno-warn-type-defaults #-} + +import Numeric.AD (grad) +import Numeric.MCMC.Hamiltonian + +target :: RealFloat a => [a] -> a +target [x0, x1] = negate ((x0 + 2 * x1 - 7) ^ 2 + (2 * x0 + x1 - 5) ^ 2) + +gTarget :: [Double] -> [Double] +gTarget = grad target + +booth :: Target [Double] +booth = Target target (Just gTarget) + +main :: IO () +main = withSystemRandom . asGenIO $ mcmc 10000 0.05 20 [0, 0] booth + diff --git a/test/Rosenbrock.hs b/test/Rosenbrock.hs @@ -0,0 +1,17 @@ +{-# OPTIONS_GHC -fno-warn-type-defaults #-} + +import Numeric.AD (grad) +import Numeric.MCMC.Hamiltonian + +target :: RealFloat a => [a] -> a +target [x0, x1] = negate (5 *(x1 - x0 ^ 2) ^ 2 + 0.05 * (1 - x0) ^ 2) + +gTarget :: [Double] -> [Double] +gTarget = grad target + +rosenbrock :: Target [Double] +rosenbrock = Target target (Just gTarget) + +main :: IO () +main = withSystemRandom . asGenIO $ mcmc 3000 0.05 20 [0, 0] rosenbrock +