[r-cran-mcmc] 02/11: Import Upstream version 0.9-4
Andreas Tille
tille at debian.org
Wed Sep 6 20:05:43 UTC 2017
This is an automated email from the git hooks/post-receive script.
tille pushed a commit to branch master
in repository r-cran-mcmc.
commit 4f808aaf358099df7cab57efc8bc1332a675f8b3
Author: Andreas Tille <tille at debian.org>
Date: Wed Sep 6 21:49:34 2017 +0200
Import Upstream version 0.9-4
---
.Rinstignore | 2 +
ChangeLog | 72 +++
DESCRIPTION | 25 +
LICENSE | 2 +
MD5 | 100 ++++
NAMESPACE | 20 +
R/initseq.R | 5 +
R/metrop.R | 69 +++
R/morph.R | 183 ++++++++
R/morph.metrop.R | 62 +++
R/olbm.R | 25 +
R/temper.R | 73 +++
build/vignette.rds | Bin 0 -> 294 bytes
data/foo.txt.gz | Bin 0 -> 2833 bytes
data/logit.txt.gz | Bin 0 -> 1094 bytes
inst/doc/Makefile | 42 ++
inst/doc/bfst.R | 226 +++++++++
inst/doc/bfst.Rnw | 804 +++++++++++++++++++++++++++++++
inst/doc/bfst.pdf | Bin 0 -> 245607 bytes
inst/doc/debug.R | 9 +
inst/doc/debug.Rnw | 274 +++++++++++
inst/doc/debug.pdf | Bin 0 -> 102701 bytes
inst/doc/demo.R | 296 ++++++++++++
inst/doc/demo.Rnw | 609 ++++++++++++++++++++++++
inst/doc/demo.pdf | Bin 0 -> 400106 bytes
inst/doc/metrop.pdf | Bin 0 -> 167867 bytes
inst/doc/metrop.tex | 398 ++++++++++++++++
inst/doc/morph.R | 392 ++++++++++++++++
inst/doc/morph.Rnw | 703 ++++++++++++++++++++++++++++
inst/doc/morph.pdf | Bin 0 -> 678050 bytes
inst/doc/temper.pdf | Bin 0 -> 173320 bytes
inst/doc/temper.tex | 270 +++++++++++
man/foo.Rd | 24 +
man/initseq.Rd | 103 ++++
man/logit.Rd | 25 +
man/metrop.Rd | 138 ++++++
man/morph.Rd | 128 +++++
man/morph.metrop.Rd | 137 ++++++
man/olbm.Rd | 40 ++
man/temper.Rd | 219 +++++++++
src/getListElement.c | 53 +++
src/getScalarInteger.c | 51 ++
src/getScalarLogical.c | 46 ++
src/initseq.c | 128 +++++
src/isAllFinite.c | 51 ++
src/metrop.c | 493 +++++++++++++++++++
src/myutil.h | 40 ++
src/olbm.c | 109 +++++
src/temper.c | 1015 ++++++++++++++++++++++++++++++++++++++++
tests/circle.R | 71 +++
tests/circle.Rout.save | 104 ++++
tests/initseq.R | 47 ++
tests/initseq.Rout.save | 87 ++++
tests/isotropic.R | 37 ++
tests/isotropic.Rout.save | 68 +++
tests/logit.R | 101 ++++
tests/logit.Rout.save | 179 +++++++
tests/logitbat.R | 105 +++++
tests/logitbat.Rout.save | 142 ++++++
tests/logitfun.R | 111 +++++
tests/logitfun.Rout.save | 150 ++++++
tests/logitfunarg.R | 68 +++
tests/logitfunarg.Rout.save | 116 +++++
tests/logitidx.R | 108 +++++
tests/logitidx.Rout.save | 145 ++++++
tests/logitlogidx.R | 108 +++++
tests/logitlogidx.Rout.save | 145 ++++++
tests/logitmat.R | 121 +++++
tests/logitmat.Rout.save | 166 +++++++
tests/logitnegidx.R | 108 +++++
tests/logitnegidx.Rout.save | 145 ++++++
tests/logitsub.R | 101 ++++
tests/logitsub.Rout.save | 138 ++++++
tests/logitsubbat.R | 105 +++++
tests/logitsubbat.Rout.save | 142 ++++++
tests/logitvec.R | 113 +++++
tests/logitvec.Rout.save | 151 ++++++
tests/morph.R | 123 +++++
tests/morph.Rout.save | 164 +++++++
tests/morph.metrop.R | 30 ++
tests/morph.metrop.Rout.save | 57 +++
tests/morphtoo.R | 61 +++
tests/morphtoo.Rout.save | 91 ++++
tests/saveseed.R | 18 +
tests/saveseed.Rout.save | 38 ++
tests/saveseedmorph.R | 25 +
tests/saveseedmorph.Rout.save | 49 ++
tests/temp-par-witch.R | 72 +++
tests/temp-par.R | 302 ++++++++++++
tests/temp-par.Rout.save | 380 +++++++++++++++
tests/temp-ser-witch.R | 102 ++++
tests/temp-ser-witch.Rout.save | 149 ++++++
tests/temp-ser.R | 292 ++++++++++++
tests/temp-ser.Rout.save | 378 +++++++++++++++
vignettes/bfst.Rnw | 804 +++++++++++++++++++++++++++++++
vignettes/bfst1.rda | Bin 0 -> 60014 bytes
vignettes/bfst2.rda | Bin 0 -> 76559 bytes
vignettes/debug.Rnw | 274 +++++++++++
vignettes/demo.Rnw | 609 ++++++++++++++++++++++++
vignettes/morph.Rnw | 703 ++++++++++++++++++++++++++++
vignettes/morph1.rda | Bin 0 -> 13622 bytes
vignettes/morph2.rda | Bin 0 -> 17796 bytes
102 files changed, 15364 insertions(+)
diff --git a/.Rinstignore b/.Rinstignore
new file mode 100644
index 0000000..97c972a
--- /dev/null
+++ b/.Rinstignore
@@ -0,0 +1,2 @@
+doc/Makefile
+doc/.*[.]tex
diff --git a/ChangeLog b/ChangeLog
new file mode 100644
index 0000000..4f9fb8d
--- /dev/null
+++ b/ChangeLog
@@ -0,0 +1,72 @@
+
+ 0.4.1 fixed documentation for metrop
+
+ 0.5 changed licence to X11 (was AFL, which apparently sucks)
+
+ changed to NAMESPACE
+ cleaned up latex in inst/doc, added Makefile
+ removed src/Makevars
+
+ had to get rid of R_IsNaNorNA in src/metrop.c
+
+ generally, lots of changes to get ready for CRAN
+
+ all of the tests/*.Rout.save redone because the digits
+ in numerical printing seem to have changed -- cannot get
+ bit for bit identical with earlier R (even before code changes).
+
+ changed first arg of metrop from "o" to "obj"
+
+ 0.5-1 changed package vignette to fix bogus MCSE calculation
+ (bogosity still admitted and explained in appendix).
+
+ 0.6 added initseq function
+
+ 0.7 added temper function -- not tested yet
+
+ 0.7-1 fix bug && to ||
+ much confusion about whether my_i and my_j were 0-origin or 1-origin
+ forgot to allocate debug_acceptd
+ confusion about dimension of state (nx + 1 vector if serial,
+ ncomp x nx matrix if parallel) and <= nx versus < nx in loop bounds
+ bug where my_swapped_proposal_log_dens was used twice when one should
+ have been my_swapped_coproposal_log_dens
+ bug in dimension of debug_state when parallel (last dim nx not nx + 1)
+ accepted swap didn't actually swap, fixed
+ all the accept decisions when log_hastings_ratio < 0 were backwards
+ batch means accumulation has = instead of +=
+ batch means divided by nbatch rather than blen
+ accepti entries stored in wrong places in output structure
+ ripped out old system for caching lud values, put in new that caches all
+ (more efficient, but real reason was old was broken somehow)
+ of course, its first implementation had 0-origin vs 1-origin confuse
+ yet another instance 0-origin vs 1-origin confusion (my_i should be
+ my_i - 1
+ length of output structure (len_result) determined incorrectly, fixed
+ caching of current lud value broken in serial case (stored in i not j)
+ after all that, everything now checked even with --use-valgrind and
+ --use-gct
+
+ 0.7-3 add bugs section to initseq.Rd
+ fix example in temper.Rd to actually be for temper rather than metrop
+ fix comment in temper.c
+ add inst/doc/debug.Rnw a vignette about debugging and debug output
+
+ 0.7-4 some changes to /inst/doc/demo.Rnw
+
+ 0.7-5 add inst/doc/bfst.Rnw a vignette about Bayes factors and serial tempering
+
+ 0.8 earlier versions calculated the Hastings ratio wrong in doing serial
+ tempering, ignoring the number of neighbors each component had, hence
+ computing wrong answers when components differed in number of neighbors
+
+ 0.9 morph, morph.metrop functions and morph.pdf vignette
+ bumped required R version to 2.10.0 (required by xtable)
+
+ 0.9-1 added PACKAGE = "mcmc" where missing to .C and .Call
+
+ 0.9-3 move vignettes to vignettes directory
+ changed LICENCE file yet again as per CRAN requirements
+
+ 0.9-4 cleaned up some tests
+ import from stats, as required by R-3.3.0
diff --git a/DESCRIPTION b/DESCRIPTION
new file mode 100644
index 0000000..fed811b
--- /dev/null
+++ b/DESCRIPTION
@@ -0,0 +1,25 @@
+Package: mcmc
+Version: 0.9-4
+Date: 2015-07-16
+Title: Markov Chain Monte Carlo
+Author: Charles J. Geyer <charlie at stat.umn.edu> and Leif T. Johnson
+ <ltjohnson at google.com>
+Maintainer: Charles J. Geyer <charlie at stat.umn.edu>
+Depends: R (>= 2.10.0)
+Imports: stats
+Suggests: xtable, Iso
+ByteCompile: TRUE
+Description: Simulates continuous distributions of random vectors using
+ Markov chain Monte Carlo (MCMC). Users specify the distribution by an
+ R function that evaluates the log unnormalized density. Algorithms
+ are random walk Metropolis algorithm (function metrop), simulated
+ tempering (function temper), and morphometric random walk Metropolis
+ (Johnson and Geyer, Annals of Statistics, 2012, function morph.metrop),
+ which achieves geometric ergodicity by change of variable.
+License: MIT + file LICENSE
+URL: http://www.stat.umn.edu/geyer/mcmc/,
+ https://github.com/cjgeyer/mcmc
+NeedsCompilation: yes
+Packaged: 2015-07-16 21:03:00 UTC; geyer
+Repository: CRAN
+Date/Publication: 2015-07-17 00:31:01
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..fdca7ad
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,2 @@
+YEAR: 2005, 2009, 2010, 2012
+COPYRIGHT HOLDER: Charles J. Geyer and Leif T. Johnson
diff --git a/MD5 b/MD5
new file mode 100644
index 0000000..906dd48
--- /dev/null
+++ b/MD5
@@ -0,0 +1,100 @@
+53308ef80c1bbb400bd0c73adb34e795 *ChangeLog
+6a7bd914e2d9ff47bdf231dd2a0d2f6c *DESCRIPTION
+66e0aaa6082a6fa8bd0f666e544a98b0 *LICENSE
+701a83055a16667ee4d0492493d5e8c8 *NAMESPACE
+2ab15c9110b4e34f9252ed1df9e35762 *R/initseq.R
+45122218ce71e9342c4bf1e8cd07389f *R/metrop.R
+f403046228ade5ac29a4f8f0bb91aabf *R/morph.R
+4b899785af3a35a3a773946c6f13b4ca *R/morph.metrop.R
+05f5205389ba50052d1d33ef2d457aea *R/olbm.R
+e633e27d06c3546b183413cc481d4ea3 *R/temper.R
+95ae0c6c4dc2289fc7686979fa66f7e3 *build/vignette.rds
+c13cfd5bf58c446f5aa035cb7611c3ed *data/foo.txt.gz
+fd9bd39298983c002e96c9e7373200a8 *data/logit.txt.gz
+3f6f0fb621fa345776a25a7d5f778484 *inst/doc/Makefile
+80b096a40b8dc0ba718641000bab7114 *inst/doc/bfst.R
+756267219c99d98813a8154e4b7b46f4 *inst/doc/bfst.Rnw
+db205118740bb021a53eddb27d2bba70 *inst/doc/bfst.pdf
+85f1c6719e9b9dcf3b56c6eb016935ee *inst/doc/debug.R
+c5d145108c9efcff74744153fc68bfe0 *inst/doc/debug.Rnw
+fd7e3066d561b1f4b962085d46bbdaad *inst/doc/debug.pdf
+63f74f8a150711d3ba8065b174636ecb *inst/doc/demo.R
+53007c6969b412aed8ca356ff9347e5a *inst/doc/demo.Rnw
+30eab1b82f92c9c7a359806124abf285 *inst/doc/demo.pdf
+0d0c2ce0dfaa641aab62c181227b1cf5 *inst/doc/metrop.pdf
+bb2ba2d13ff2fc81e79f0af3f9ba8ce1 *inst/doc/metrop.tex
+a52b909d82f36678ee7921fd12d80595 *inst/doc/morph.R
+018df3c12cabc9de877013fe309d7447 *inst/doc/morph.Rnw
+40164a8fcdacea29a7022f5b4cb52143 *inst/doc/morph.pdf
+728d89fe79b4a873cc5fc846b16d399c *inst/doc/temper.pdf
+177420ab597fd25ca27435d726117a89 *inst/doc/temper.tex
+fede69d8e361ef6548637fe54060f709 *man/foo.Rd
+f77daf0c3cd0922e649a4a6c03a362fd *man/initseq.Rd
+828a4296b11b5041ca9ab38eb74c8b2b *man/logit.Rd
+d77bbb9faee227d2f0f6c86ac88c7c6a *man/metrop.Rd
+7f8ec860609476a448d615d70ff074e2 *man/morph.Rd
+656dc31b07400ce3202b0719692b6fba *man/morph.metrop.Rd
+d0908e5b3c8bf592f6a420d761988836 *man/olbm.Rd
+118350de2df78a1d966a7e096e80fdd0 *man/temper.Rd
+c05d85819c8f2d55c67b86d8bc09c599 *src/getListElement.c
+214e108c068ecadb4b1567383b37d125 *src/getScalarInteger.c
+4313c1050389a49f26fc50f51b723d6a *src/getScalarLogical.c
+be626015b2fd7067a06eb3392417cde7 *src/initseq.c
+2e581f0775cc807c353c723113809601 *src/isAllFinite.c
+a27470783b1c322fd8beefdc26ef9231 *src/metrop.c
+8a271789517b6b21c5b65ae6b7086733 *src/myutil.h
+e5ccb1e6d0a7395518b7ef35ad7824ce *src/olbm.c
+abab96dfa4cd64801719cf7d39a59307 *src/temper.c
+30579f6813cad807b8c301897da45de6 *tests/circle.R
+b1d6d5e55c62aaa9f331659161fceba1 *tests/circle.Rout.save
+dfbc7b09d19a44e9415ddead1ed5bcfe *tests/initseq.R
+cba98dc947958991168123a62e8e2bd8 *tests/initseq.Rout.save
+01f734e085fc75dc37615d76381f9568 *tests/isotropic.R
+7b1a10898e9abe34fab48f6c43aa51a3 *tests/isotropic.Rout.save
+ced46ef84ed611b440a653bae2b25805 *tests/logit.R
+fbed3c07f389f3d184457e82098b4057 *tests/logit.Rout.save
+0fde60fa5097a775ee157fff16d2a59e *tests/logitbat.R
+e8a16c5b726f225061edc5757e6595c1 *tests/logitbat.Rout.save
+0a1fc457e1b2ab0216488c9666be211e *tests/logitfun.R
+cbf893997832a1b30d6d3694ebdd6937 *tests/logitfun.Rout.save
+5db180c421281a11a8f1cd46043b4fa0 *tests/logitfunarg.R
+2b5aa1b25cf19934a83d6b32641217fe *tests/logitfunarg.Rout.save
+2576700457eafee888139309ee8b95fa *tests/logitidx.R
+950a2753391a7e8c81fff604cba087a2 *tests/logitidx.Rout.save
+7a2c271c18d53312291dee40418e12bc *tests/logitlogidx.R
+3b4b09c246712b9397deed8c89dd0f86 *tests/logitlogidx.Rout.save
+6b721b8a80f8f732bda17972d95c3fa3 *tests/logitmat.R
+72ac94e093a31f23a6c22a14dccb7611 *tests/logitmat.Rout.save
+11e13ee697c0cb513728b89580c1a22f *tests/logitnegidx.R
+7bc0f8e352a432dfc574f54505e2e624 *tests/logitnegidx.Rout.save
+c6f8f05fa12d1f9ad774438181c4cb5d *tests/logitsub.R
+35c123712c42df695c80d553bc08db47 *tests/logitsub.Rout.save
+7432d0f64ce00cc031e9b5b09178506b *tests/logitsubbat.R
+555fb26065eb2213b0fad8baa7226f01 *tests/logitsubbat.Rout.save
+dcbc8752e05665f204812c82515c6320 *tests/logitvec.R
+a9884c4e3994725d60f279b2a139a42d *tests/logitvec.Rout.save
+850d625fead9ff993eb8daedb9701742 *tests/morph.R
+f71816a66c639975e79cf40410c22037 *tests/morph.Rout.save
+22f5e0b4adc734ec63ffc8491500b244 *tests/morph.metrop.R
+803417a95108119bccb2c448216ee59b *tests/morph.metrop.Rout.save
+984594df82bfcbac4479d524237123f4 *tests/morphtoo.R
+dbc222dd8db7af358381261431ee0f7c *tests/morphtoo.Rout.save
+81c5b299d1b20a8168a25b6c9d209f2e *tests/saveseed.R
+1d84beebb0113a970da2a3f337c57ff3 *tests/saveseed.Rout.save
+eb13e0e12345cdaa38d2625f813b5ac9 *tests/saveseedmorph.R
+48d749cc35ad957b44a12cf2d141273e *tests/saveseedmorph.Rout.save
+25a3e6688b5bce4708356b4118923bb1 *tests/temp-par-witch.R
+a3794f2948a37ac905ae40116cdf9307 *tests/temp-par.R
+bf3bc0d39d6c81855fb2ba92b86cf12a *tests/temp-par.Rout.save
+e0cdab5f26ba0548eacfaac87368b5d5 *tests/temp-ser-witch.R
+8d0c33d90c3b24b34c4098b5e4d0afc2 *tests/temp-ser-witch.Rout.save
+3348850e6103ab402de362dcdf2b717b *tests/temp-ser.R
+fa0b5361231a056559c55945c98c247f *tests/temp-ser.Rout.save
+756267219c99d98813a8154e4b7b46f4 *vignettes/bfst.Rnw
+9020ac34c43c9a166b7e6529f3dcedeb *vignettes/bfst1.rda
+16bf2cf64bb79d5d3c7d69cd596fbebf *vignettes/bfst2.rda
+c5d145108c9efcff74744153fc68bfe0 *vignettes/debug.Rnw
+53007c6969b412aed8ca356ff9347e5a *vignettes/demo.Rnw
+018df3c12cabc9de877013fe309d7447 *vignettes/morph.Rnw
+584ffd92ffbf78907b1f5f826d0f8196 *vignettes/morph1.rda
+747e3888d39cbdc4a283e69686e0bc20 *vignettes/morph2.rda
diff --git a/NAMESPACE b/NAMESPACE
new file mode 100644
index 0000000..0cd5e75
--- /dev/null
+++ b/NAMESPACE
@@ -0,0 +1,20 @@
+
+useDynLib(mcmc)
+
+export(metrop)
+export(morph)
+export(olbm)
+export(initseq)
+export(temper)
+export(morph.metrop)
+export(morph)
+export(morph.identity)
+
+S3method(metrop, metropolis)
+S3method(metrop, "function")
+S3method(morph.metrop, morph.metropolis)
+S3method(morph.metrop, "function")
+S3method(temper, tempering)
+S3method(temper, "function")
+
+importFrom(stats, runif)
diff --git a/R/initseq.R b/R/initseq.R
new file mode 100644
index 0000000..a4fea93
--- /dev/null
+++ b/R/initseq.R
@@ -0,0 +1,5 @@
+initseq <- function(x) {
+ stopifnot(is.numeric(x))
+ stopifnot(is.finite(x))
+ .Call("initseq", x - mean(x), PACKAGE = "mcmc")
+}
diff --git a/R/metrop.R b/R/metrop.R
new file mode 100644
index 0000000..4898dae
--- /dev/null
+++ b/R/metrop.R
@@ -0,0 +1,69 @@
+
+metrop <- function(obj, initial, nbatch, blen = 1,
+ nspac = 1, scale = 1, outfun, debug = FALSE, ...)
+UseMethod("metrop")
+
+metrop.metropolis <- function(obj, initial, nbatch, blen = 1,
+ nspac = 1, scale = 1, outfun, debug = FALSE, ...)
+{
+ if (missing(nbatch)) nbatch <- obj$nbatch
+ if (missing(blen)) blen <- obj$blen
+ if (missing(nspac)) nspac <- obj$nspac
+ if (missing(scale)) scale <- obj$scale
+ if (missing(debug)) debug <- obj$debug
+ assign(".Random.seed", obj$final.seed, .GlobalEnv)
+ if (missing(outfun)) {
+ if (is.null(obj$outfun)) {
+ metrop.function(obj$lud, obj$final, nbatch, blen,
+ nspac, scale, debug = debug, ...)
+ } else {
+ metrop.function(obj$lud, obj$final, nbatch, blen,
+ nspac, scale, obj$outfun, debug, ...)
+ }
+ } else {
+ metrop.function(obj$lud, obj$final, nbatch, blen,
+ nspac, scale, outfun, debug, ...)
+ }
+}
+
+metrop.function <- function(obj, initial, nbatch, blen = 1,
+ nspac = 1, scale = 1, outfun, debug = FALSE, ...)
+{
+ if (! exists(".Random.seed")) runif(1)
+ saveseed <- .Random.seed
+ func1 <- function(state) obj(state, ...)
+ env1 <- environment(fun = func1)
+ if (missing(outfun)) {
+ func2 <- NULL
+ env2 <- NULL
+ outfun <- NULL
+ } else if (is.function(outfun)) {
+ func2 <- function(state) outfun(state, ...)
+ env2 <- environment(fun = func2)
+ } else {
+ func2 <- outfun
+ env2 <- NULL
+ }
+
+ out.time <- system.time(
+ out <- .Call("metrop", func1, initial, nbatch, blen, nspac,
+ scale, func2, debug, env1, env2, PACKAGE = "mcmc")
+ )
+ out$initial.seed <- saveseed
+ out$final.seed <- .Random.seed
+ out$time <- out.time
+ out$lud <- obj
+ out$nbatch <- nbatch
+ out$blen <- blen
+ out$nspac <- nspac
+ out$scale <- scale
+ out$outfun <- outfun
+ out$batch <- t(out$batch)
+ out$debug <- debug
+ if (! is.null(out$current)) out$current <- t(out$current)
+ if (! is.null(out$proposal)) out$proposal <- t(out$proposal)
+ if (! is.null(out$z)) out$z <- t(out$z)
+ class(out) <- c("mcmc", "metropolis")
+ return(out)
+}
+
diff --git a/R/morph.R b/R/morph.R
new file mode 100644
index 0000000..3598d2a
--- /dev/null
+++ b/R/morph.R
@@ -0,0 +1,183 @@
+euclid.norm <- function(x) {
+ sqrt(sum(x * x))
+}
+
+isotropic <- function(f) {
+ force(f)
+ function(x) {
+ x.norm <- euclid.norm(x)
+ if (x.norm == 0)
+ rep(0, length(x))
+ else
+ f(x.norm) * x / x.norm
+ }
+}
+
+isotropic.logjacobian <- function(f, d.f) {
+ force(f)
+ force(d.f)
+ function(x) {
+ x.norm <- euclid.norm(x)
+ k <- length(x)
+ if (x.norm == 0) {
+ k * log(d.f(x.norm))
+ } else {
+ log(d.f(x.norm)) + (k - 1) * (log(f(x.norm)) - log(x.norm))
+ }
+ }
+}
+
+# rearranged by charlie
+# add starting point so we can use a better starting point for
+# the current actual use
+# also do one more Newton step after error is < sqrt(machine.eps)
+# so ultimate error is about machine.eps
+newton.raphson <- function(f, df, x, r, x0 = 2 * r) {
+ f.err <- function(cur) f(cur) - x
+ step <- function(cur, err=NULL)
+ cur - ifelse(is.null(err), f.err(cur), err) / df(cur)
+ err <- f.err(x0)
+ while(err >= sqrt(.Machine$double.eps)) {
+ x0 <- step(x0, err)
+ err <- f.err(x0)
+ }
+ # if you don't want to use an extra-step, replace this return with
+ # return(x0)
+ return(step(x0, err))
+}
+
+subexponential <- function(b=1) {
+ if (missing(b) | is.null(b)) b <- 1
+ stopifnot(b > 0)
+ force(b)
+ f.inv <- function(x) ifelse(x > 1/b,
+ exp(b * x) - exp(1)/3,
+ (x * b)^3 * exp(1) / 6 + x * b * exp(1) / 2)
+ d.f.inv <- function(x) ifelse(x > 1/b,
+ b * exp(b * x),
+ b * (x * b)^2 * exp(1) / 2 + b * exp(1) / 2)
+ f <- function(x) {
+ # x > exp(b * 1 / b) - exp(1) / 3
+ if (x > 2 * exp(1) / 3) {
+ log(x + exp(1)/3) / b
+ } else {
+ poly.inv <- exp(1/3) *
+ (sqrt(b^12 * (9 * x^2 + exp(2))) - 3 * b^6 * x)^(-1/3)
+ poly.inv * b - 1 / (poly.inv * b^3)
+ }
+ }
+ return(list(f=f, f.inv=f.inv, d.f.inv=d.f.inv))
+}
+
+exponential <- function(r=1, p=3) {
+ if (missing(p) || is.null(p)) p <- 3
+ if (missing(r) || is.null(r)) r <- 0
+ stopifnot(p > 2)
+ stopifnot(r >= 0)
+ f.inv <- function(x) ifelse(x <= r, x, x + (x-r)^p)
+ d.f.inv <- function(x) ifelse(x <= r, 1, 1 + p * (x-r)^(p-1))
+ if (p == 3) {
+ g <- function(x) {
+ n <- sqrt((27*r-27*x)^2 + 108) + 27 * (r - x)
+ r + (2/n)^(1/3) - (n/2)^(1/3)/3
+ }
+ f <- function(x) ifelse(x < r, x, g(x))
+ } else {
+ # No general closed form solution exists. However, since the
+ # transformation has polynomial form, using the Newton-Raphson method
+ # should work well.
+ f <- function(x) ifelse(x < r, x,
+ newton.raphson(f.inv, d.f.inv, x, r, x0 = r + x^(1 / p)))
+ }
+ return(list(f=f, f.inv=f.inv, d.f.inv=d.f.inv))
+}
+
+.make.outfun <- function(out) {
+ force(out)
+ function(f) {
+ force(f)
+ if (is.null(f))
+ return(out$inverse)
+ else if (is.function(f))
+ return(function(state, ...) f(out$inverse(state), ...))
+ else
+ return(function(state) out$inverse(state)[f])
+ }
+}
+
+identity.func <- function(x) x
+morph.identity <- function() {
+ out <- list(transform=identity.func,
+ inverse=identity.func,
+ lud=function(f) function(x, ...) f(x, ...),
+ log.jacobian=function(x) 0,
+ center=0,
+ f=identity.func,
+ f.inv=identity.func)
+ out$outfun <- .make.outfun(out)
+ return(out)
+}
+
+morph <- function(b, r, p, center) {
+ if (all(missing(b), missing(r), missing(p), missing(center)))
+ return(morph.identity())
+ if (missing(center)) center <- 0
+ use.subexpo <- !missing(b)
+ use.expo <- !(missing(r) && missing(p))
+
+ if (!use.expo && !use.subexpo) {
+ f <- function(x) x
+ f.inv <- function(x) x
+ log.jacobian <- function(x) 0
+ } else {
+ if (use.expo && !use.subexpo) {
+ expo <- exponential(r, p)
+
+ f <- expo$f
+ f.inv <- expo$f.inv
+ d.f.inv <- expo$d.f.inv
+ } else if (!use.expo && use.subexpo) {
+ subexpo <- subexponential(b)
+
+ f <- subexpo$f
+ f.inv <- subexpo$f.inv
+ d.f.inv <- subexpo$d.f.inv
+ } else { #use.expo && use.subexpo
+ expo <- exponential(r, p)
+ subexpo <- subexponential(b)
+
+ f <- function(x) expo$f(subexpo$f(x))
+ f.inv <- function(x) subexpo$f.inv(expo$f.inv(x))
+ d.f.inv <- function(x) expo$d.f.inv(x) * subexpo$d.f.inv(expo$f.inv(x))
+ }
+
+ f <- isotropic(f)
+ f.inv <- isotropic(f.inv)
+ log.jacobian <- isotropic.logjacobian(f.inv, d.f.inv)
+ }
+
+ out <- list(f=f, f.inv=f.inv, log.jacobian=log.jacobian,
+ center=center)
+ out$transform <- function(state) out$f(state - out$center)
+ out$inverse <- function(state) out$f.inv(state) + out$center
+
+ out$outfun <- .make.outfun(out)
+
+ out$lud <- function(lud) {
+ force(lud)
+ function(state, ...) {
+ foo <- lud(out$inverse(state), ...)
+ if (length(foo) != 1)
+ stop("log unnormalized density function returned vector not scalar")
+ if (is.na(foo))
+ stop("log unnormalized density function returned NA or NaN")
+ if (foo == -Inf) return(foo)
+ if (! is.finite(foo))
+ stop("log unnormalized density function returned +Inf")
+ foo + out$log.jacobian(state)
+ }
+ }
+
+ return(out)
+}
+
diff --git a/R/morph.metrop.R b/R/morph.metrop.R
new file mode 100644
index 0000000..a4a420c
--- /dev/null
+++ b/R/morph.metrop.R
@@ -0,0 +1,62 @@
+morph.metrop <- function(obj, initial, nbatch, blen = 1,
+ nspac = 1, scale = 1, outfun, debug = FALSE, morph,
+ ...)
+UseMethod("morph.metrop")
+
+morph.metrop.morph.metropolis <- function(obj, initial, nbatch, blen = 1,
+ nspac = 1, scale = 1, outfun, debug = FALSE, morph, ...) {
+ if (missing(morph)) {
+ morph <- obj$morph
+ obj$final <- obj$morph.final
+ } else {
+ # if the transformation was changed, transform the last state from the
+ # original space to be the initial state.
+ obj$final <- morph$transform(obj$final)
+ }
+
+ if (missing(outfun)) outfun <- obj$outfun
+ if (missing(blen)) blen <- obj$blen
+ if (missing(nspac)) nspac <- obj$nspac
+ if (missing(debug)) debug <- obj$debug
+ if (missing(scale)) scale <- obj$scale
+
+ morphed.obj <- metrop.metropolis(obj,
+ nbatch=nbatch,
+ blen=blen,
+ nspac=nspac,
+ scale=scale,
+ outfun=morph$outfun(outfun),
+ debug=debug,
+ ...)
+
+ unmorphed.obj <- .morph.unmorph(morphed.obj, morph, outfun)
+ return(unmorphed.obj)
+}
+
+morph.metrop.function <- function(obj, initial, nbatch, blen = 1,
+ nspac = 1, scale = 1, outfun, debug = FALSE, morph, ...) {
+
+ if (missing(morph)) morph <- morph.identity()
+ if (missing(outfun)) outfun <- NULL
+
+ morphed.obj <- metrop.function(morph$lud(obj),
+ initial=morph$transform(initial),
+ nbatch=nbatch,
+ blen=blen,
+ scale=scale,
+ outfun=morph$outfun(outfun),
+ debug=debug,
+ ...)
+
+ unmorphed.obj <- .morph.unmorph(morphed.obj, morph, outfun)
+ return(unmorphed.obj)
+}
+
+.morph.unmorph <- function(obj, morph, outfun) {
+ obj$morph <- morph
+ obj$morph.final <- obj$final
+ obj$final <- morph$inverse(obj$final)
+ obj$outfun <- outfun
+ class(obj) <- c("mcmc", "morph.metropolis")
+ return(obj)
+}
diff --git a/R/olbm.R b/R/olbm.R
new file mode 100644
index 0000000..0de5ee9
--- /dev/null
+++ b/R/olbm.R
@@ -0,0 +1,25 @@
+
+olbm <- function(x, batch.length, demean = TRUE) {
+ x <- as.matrix(x)
+ n <- nrow(x)
+ p <- ncol(x)
+ storage.mode(x) <- "double"
+ if (batch.length > n) stop("batch.length must be <= nrow(x)")
+ if (demean) {
+ mean <- apply(x, 2, mean)
+ no.calc.mean <- TRUE
+ } else {
+ mean <- double(p)
+ no.calc.mean <- FALSE
+ }
+ out <- .C("olbm",
+ x=x,
+ n=as.integer(n),
+ p=as.integer(p),
+ batch.length=as.integer(batch.length),
+ mean=as.double(mean),
+ var=matrix(as.double(0), p, p),
+ no.calc.mean=as.logical(no.calc.mean), PACKAGE = "mcmc")
+ return(out$var)
+}
+
diff --git a/R/temper.R b/R/temper.R
new file mode 100644
index 0000000..3a0936c
--- /dev/null
+++ b/R/temper.R
@@ -0,0 +1,73 @@
+
+temper <- function(obj, initial, neighbors, nbatch, blen = 1,
+ nspac = 1, scale = 1, outfun, debug = FALSE, parallel = FALSE, ...)
+UseMethod("temper")
+
+temper.tempering <- function(obj, initial, neighbors, nbatch, blen = 1,
+ nspac = 1, scale = 1, outfun, debug = FALSE, parallel = FALSE, ...)
+{
+ if (missing(initial)) initial <- obj$final
+ if (missing(neighbors)) neighbors <- obj$neighbors
+ if (missing(nbatch)) nbatch <- obj$nbatch
+ if (missing(blen)) blen <- obj$blen
+ if (missing(nspac)) nspac <- obj$nspac
+ if (missing(scale)) scale <- obj$scale
+ if (missing(debug)) debug <- obj$debug
+ if (missing(parallel)) parallel <- obj$parallel
+ assign(".Random.seed", obj$final.seed, .GlobalEnv)
+ if (missing(outfun)) {
+ if (is.null(obj$outfun)) {
+ temper.function(obj$lud, initial, neighbors, nbatch, blen,
+ nspac, scale, debug = debug, parallel = parallel, ...)
+ } else {
+ temper.function(obj$lud, initial, neighbors, nbatch, blen,
+ nspac, scale, obj$outfun, debug = debug, parallel = parallel,
+ ...)
+ }
+ } else {
+ temper.function(obj$lud, initial, neighbors, nbatch, blen,
+ nspac, scale, outfun, debug = debug, parallel = parallel, ...)
+ }
+}
+
+temper.function <- function(obj, initial, neighbors, nbatch, blen = 1,
+ nspac = 1, scale = 1, outfun, debug = FALSE, parallel = FALSE, ...)
+{
+ if (! exists(".Random.seed")) runif(1)
+ saveseed <- .Random.seed
+ func1 <- function(state) obj(state, ...)
+ env1 <- environment(fun = func1)
+ if (missing(outfun)) {
+ func2 <- NULL
+ env2 <- NULL
+ outfun <- NULL
+ } else if (is.function(outfun)) {
+ func2 <- function(state) outfun(state, ...)
+ env2 <- environment(fun = func2)
+ }
+
+ stopifnot(is.numeric(initial))
+ storage.mode(initial) <- "double"
+
+ if (is.list(scale)) {
+ for (i in 1:length(scale)) {
+ stopifnot(is.numeric(scale[[i]]))
+ storage.mode(scale[[i]]) <- "double"
+ }
+ } else {
+ stopifnot(is.numeric(scale))
+ storage.mode(scale) <- "double"
+ }
+
+ out.time <- system.time(
+ out <- .Call("temper", func1, initial, neighbors, nbatch, blen, nspac,
+ scale, func2, debug, parallel, env1, env2, PACKAGE = "mcmc")
+ )
+ result <- structure(c(list(lud = obj, initial = initial,
+ neighbors = neighbors, nbatch = nbatch, blen = blen, nspac = nspac,
+ scale = scale, outfun = outfun, debug = debug, parallel = parallel,
+ initial.seed = saveseed, final.seed = .Random.seed, time = out.time),
+ out), class = c("mcmc", "tempering"))
+ return(result)
+}
+
diff --git a/build/vignette.rds b/build/vignette.rds
new file mode 100644
index 0000000..bea2a1d
Binary files /dev/null and b/build/vignette.rds differ
diff --git a/data/foo.txt.gz b/data/foo.txt.gz
new file mode 100644
index 0000000..2011565
Binary files /dev/null and b/data/foo.txt.gz differ
diff --git a/data/logit.txt.gz b/data/logit.txt.gz
new file mode 100644
index 0000000..d99c47b
Binary files /dev/null and b/data/logit.txt.gz differ
diff --git a/inst/doc/Makefile b/inst/doc/Makefile
new file mode 100644
index 0000000..d05375c
--- /dev/null
+++ b/inst/doc/Makefile
@@ -0,0 +1,42 @@
+
+all : bfst.pdf demo.pdf metrop.pdf temper.pdf debug.pdf clean
+
+demo.tex : demo.Rnw
+ $(R_HOME)/bin/R CMD Sweave demo.Rnw
+
+demo.pdf : demo.tex
+ pdflatex demo.tex
+ pdflatex demo.tex
+
+metrop.pdf : metrop.tex
+ pdflatex metrop.tex
+ pdflatex metrop.tex
+
+temper.pdf : temper.tex
+ pdflatex temper.tex
+ pdflatex temper.tex
+
+debug.tex : debug.Rnw
+ $(R_HOME)/bin/R CMD Sweave debug.Rnw
+
+debug.pdf : debug.tex
+ pdflatex debug.tex
+ pdflatex debug.tex
+
+bfst.tex : bfst.Rnw
+ $(R_HOME)/bin/R CMD Sweave bfst.Rnw
+
+bfst.pdf : bfst.tex
+ pdflatex bfst.tex
+ pdflatex bfst.tex
+
+morph.tex : morph.Rnw
+ $(R_HOME)/bin/R CMD Sweave morph.Rnw
+
+morph.pdf : morph.tex
+ pdflatex morph.tex
+ pdflatex morph.tex
+
+clean :
+ rm -f *.dvi *.aux *.log demo-fig* morph-*.pdf Rplots.*
+
diff --git a/inst/doc/bfst.R b/inst/doc/bfst.R
new file mode 100644
index 0000000..3687495
--- /dev/null
+++ b/inst/doc/bfst.R
@@ -0,0 +1,226 @@
+### R code from vignette source 'bfst.Rnw'
+### Encoding: UTF-8
+
+###################################################
+### code chunk number 1: foo
+###################################################
+options(keep.source = TRUE, width = 65)
+
+
+###################################################
+### code chunk number 2: library
+###################################################
+library(mcmc)
+
+
+###################################################
+### code chunk number 3: baz
+###################################################
+baz <- library(help = "mcmc")
+baz <- baz$info[[1]]
+baz <- baz[grep("Version", baz)]
+baz <- sub("^Version: *", "", baz)
+bazzer <- paste(R.version$major, R.version$minor, sep = ".")
+
+
+###################################################
+### code chunk number 4: set-seed
+###################################################
+set.seed(42)
+
+
+###################################################
+### code chunk number 5: frequentist
+###################################################
+data(logit)
+out <- glm(y ~ x1 + x2 + x3 + x4, data = logit,
+ family = binomial, x = TRUE)
+summary(out)
+
+
+###################################################
+### code chunk number 6: models
+###################################################
+varnam <- names(coefficients(out))
+varnam <- varnam[varnam != "(Intercept)"]
+nvar <- length(varnam)
+
+models <- NULL
+foo <- seq(0, 2^nvar - 1)
+for (i in 1:nvar) {
+ bar <- foo %/% 2^(i - 1)
+ bar <- bar %% 2
+ models <- cbind(bar, models, deparse.level = 0)
+}
+colnames(models) <- varnam
+models
+
+
+###################################################
+### code chunk number 7: neighbor
+###################################################
+neighbors <- matrix(FALSE, nrow(models), nrow(models))
+for (i in 1:nrow(neighbors)) {
+ for (j in 1:ncol(neighbors)) {
+ foo <- models[i, ]
+ bar <- models[j, ]
+ if (sum(foo != bar) == 1) neighbors[i, j] <- TRUE
+ }
+}
+
+
+###################################################
+### code chunk number 8: ludfun
+###################################################
+modmat <- out$x
+y <- logit$y
+
+ludfun <- function(state, log.pseudo.prior) {
+ stopifnot(is.numeric(state))
+ stopifnot(length(state) == ncol(models) + 2)
+ icomp <- state[1]
+ stopifnot(icomp == as.integer(icomp))
+ stopifnot(1 <= icomp && icomp <= nrow(models))
+ stopifnot(is.numeric(log.pseudo.prior))
+ stopifnot(length(log.pseudo.prior) == nrow(models))
+ beta <- state[-1]
+ inies <- c(TRUE, as.logical(models[icomp, ]))
+ beta.logl <- beta
+ beta.logl[! inies] <- 0
+ eta <- as.numeric(modmat %*% beta.logl)
+ logp <- ifelse(eta < 0, eta - log1p(exp(eta)), - log1p(exp(- eta)))
+ logq <- ifelse(eta < 0, - log1p(exp(eta)), - eta - log1p(exp(- eta)))
+ logl <- sum(logp[y == 1]) + sum(logq[y == 0])
+ logl + sum(dnorm(beta, 0, 2, log = TRUE)) + log.pseudo.prior[icomp]
+}
+
+
+###################################################
+### code chunk number 9: try1
+###################################################
+state.initial <- c(nrow(models), out$coefficients)
+
+qux <- rep(0, nrow(models))
+
+out <- temper(ludfun, initial = state.initial, neighbors = neighbors,
+ nbatch = 1000, blen = 100, log.pseudo.prior = qux)
+
+names(out)
+out$time
+
+
+###################################################
+### code chunk number 10: what
+###################################################
+ibar <- colMeans(out$ibatch)
+ibar
+
+
+###################################################
+### code chunk number 11: adjust
+###################################################
+qux <- qux + pmin(log(max(ibar) / ibar), 10)
+qux <- qux - min(qux)
+qux
+
+
+###################################################
+### code chunk number 12: iterate
+###################################################
+lout <- suppressWarnings(try(load("bfst1.rda"), silent = TRUE))
+if (inherits(lout, "try-error")) {
+ qux.save <- qux
+ time.save <- out$time
+ repeat{
+ out <- temper(out, log.pseudo.prior = qux)
+ ibar <- colMeans(out$ibatch)
+ qux <- qux + pmin(log(max(ibar) / ibar), 10)
+ qux <- qux - min(qux)
+ qux.save <- rbind(qux.save, qux, deparse.level = 0)
+ time.save <- rbind(time.save, out$time, deparse.level = 0)
+ if (max(ibar) / min(ibar) < 2) break
+ }
+ save(out, qux, qux.save, time.save, file = "bfst1.rda")
+} else {
+ .Random.seed <- out$final.seed
+}
+print(qux.save, digits = 3)
+print(qux, digits = 3)
+apply(time.save, 2, sum)
+
+
+###################################################
+### code chunk number 13: accept-i-x
+###################################################
+print(out$accepti, digits = 3)
+print(out$acceptx, digits = 3)
+
+
+###################################################
+### code chunk number 14: accept-i-min
+###################################################
+min(as.vector(out$accepti), na.rm = TRUE)
+
+
+###################################################
+### code chunk number 15: scale
+###################################################
+out <- temper(out, scale = 0.5, log.pseudo.prior = qux)
+time.save <- rbind(time.save, out$time, deparse.level = 0)
+print(out$acceptx, digits = 3)
+
+
+###################################################
+### code chunk number 16: try6
+###################################################
+lout <- suppressWarnings(try(load("bfst2.rda"), silent = TRUE))
+if (inherits(lout, "try-error")) {
+ out <- temper(out, blen = 10 * out$blen, log.pseudo.prior = qux)
+ save(out, file = "bfst2.rda")
+} else {
+ .Random.seed <- out$final.seed
+}
+time.save <- rbind(time.save, out$time, deparse.level = 0)
+foo <- apply(time.save, 2, sum)
+foo.min <- floor(foo[1] / 60)
+foo.sec <- foo[1] - 60 * foo.min
+c(foo.min, foo.sec)
+
+
+###################################################
+### code chunk number 17: doit
+###################################################
+log.10.unnorm.bayes <- (qux - log(colMeans(out$ibatch))) / log(10)
+k <- seq(along = log.10.unnorm.bayes)[log.10.unnorm.bayes
+ == min(log.10.unnorm.bayes)]
+models[k, ]
+
+log.10.bayes <- log.10.unnorm.bayes - log.10.unnorm.bayes[k]
+log.10.bayes
+
+
+###################################################
+### code chunk number 18: doit-se-one
+###################################################
+fred <- var(out$ibatch) / out$nbatch
+sally <- colMeans(out$ibatch)
+mcse.log.10.bayes <- (1 / log(10)) * sqrt(diag(fred) / sally^2 -
+ 2 * fred[ , k] / (sally * sally[k]) +
+ fred[k, k] / sally[k]^2)
+mcse.log.10.bayes
+
+foompter <- cbind(models, log.10.bayes, mcse.log.10.bayes)
+round(foompter, 5)
+
+
+###################################################
+### code chunk number 19: doit-too
+###################################################
+ibar <- colMeans(out$ibatch)
+herman <- sweep(out$ibatch, 2, ibar, "/")
+herman <- sweep(herman, 1, herman[ , k], "-")
+mcse.log.10.bayes.too <- (1 / log(10)) *
+ apply(herman, 2, sd) /sqrt(out$nbatch)
+all.equal(mcse.log.10.bayes, mcse.log.10.bayes.too)
+
+
diff --git a/inst/doc/bfst.Rnw b/inst/doc/bfst.Rnw
new file mode 100644
index 0000000..3c376ec
--- /dev/null
+++ b/inst/doc/bfst.Rnw
@@ -0,0 +1,804 @@
+
+\documentclass[11pt]{article}
+
+\usepackage{amsmath}
+\usepackage{amsfonts}
+\usepackage{indentfirst}
+\usepackage{natbib}
+\usepackage{url}
+\usepackage[utf8]{inputenc}
+
+\newcommand{\real}{\mathbb{R}}
+
+\DeclareMathOperator{\prior}{pri}
+\DeclareMathOperator{\posterior}{post}
+\DeclareMathOperator{\indicator}{ind}
+
+\newcommand{\fatdot}{\,\cdot\,}
+
+% \VignetteIndexEntry{Bayes Factors via Serial Tempering}
+
+\begin{document}
+
+\title{Bayes Factors via Serial Tempering}
+\author{Charles J. Geyer}
+\maketitle
+
+<<foo,include=FALSE,echo=FALSE>>=
+options(keep.source = TRUE, width = 65)
+@
+
+\section{Introduction}
+
+\subsection{Bayes Factors} \label{sec:bayes-factors}
+
+Let $\mathcal{M}$ be a finite or countable set of models (here we only
+deal with finite $\mathcal{M}$ but Bayes factors make sense for countable
+$\mathcal{M}$). For each model
+$m \in \mathcal{M}$ we have the prior probability of the model $\prior(m)$.
+It does not matter if this prior on models is unnormalized.
+
+Each model $m$ has a parameter space $\Theta_m$ and a prior
+$$
+ g(\theta \mid m), \qquad \theta \in \Theta_m
+$$
+The spaces $\Theta_m$ can and usually do have different dimensions. That's
+the point. These within model priors must be normalized proper priors.
+The calculations to follow make no sense if these priors are unnormalized
+or improper.
+
+Each model $m$ has a data distribution
+$$
+ f(y \mid \theta, m)
+$$
+and the observed data $y$ may be either discrete or continuous
+(it makes no difference to
+the Bayesian who treats $y$ as fixed after it is observed and treats
+only $\theta$ and $m$ as random).
+
+The unnormalized posterior for everything
+(for models and parameters within models)
+is
+$$
+ f(y \mid \theta, m) g(\theta \mid m) \prior(m)
+$$
+To obtain the conditional distribution of $y$ given $m$, we must integrate
+out the nuisance parameter $\theta$
+\begin{align*}
+ q(y \mid m)
+ & =
+ \int_{\Theta_m} f(y \mid \theta, m) g(\theta \mid m) \prior(m) \, d \theta
+ \\
+ & =
+ \prior(m) \int_{\Theta_m} f(y \mid \theta, m) g(\theta \mid m) \, d \theta
+\end{align*}
+These are the unnormalized posterior probabilities of the models. The
+normalized posterior probabilities are
+$$
+ \posterior(m \mid y)
+ =
+ \frac{ q(y \mid m) }{ \sum_{m \in \mathcal{M}} q(y \mid m) }
+$$
+
+It is considered useful to define
+$$
+ b(y \mid m)
+ =
+ \int_{\Theta_m} f(y \mid \theta, m) g(\theta \mid m) \, d \theta
+$$
+so
+$$
+ q(y \mid m) = b(y \mid m) \prior(m)
+$$
+Then the ratio of posterior probabilities of models $m_1$ and $m_2$ is
+$$
+ \frac{\posterior(m_1 \mid y)}{\posterior(m_2 \mid y)}
+ =
+ \frac{q(y \mid m_1)}{q(y \mid m_2)}
+ =
+ \frac{b(y \mid m_1)}{b(y \mid m_2)}
+ \cdot
+ \frac{\prior(m_1)}{\prior(m_2)}
+$$
+This ratio is called the \emph{posterior odds} of the models (a ratio of
+probabilities is called an \emph{odds}) of these models.
+
+The \emph{prior odds} is
+$$
+ \frac{\prior(m_1)}{\prior(m_2)}
+$$
+
+The term we have not yet named in
+$$
+ \frac{\posterior(m_1 \mid y)}{\posterior(m_2 \mid y)}
+ =
+ \frac{b(y \mid m_1)}{b(y \mid m_2)}
+ \cdot
+ \frac{\prior(m_1)}{\prior(m_2)}
+$$
+is called the \emph{Bayes factor}
+\begin{equation} \label{eq:factor}
+ \frac{b(y \mid m_1)}{b(y \mid m_2)}
+\end{equation}
+the ratio of posterior odds to prior odds.
+
+The prior odds tells how the prior compares the probability of the models.
+The Bayes factor tells us how the data shifts that comparison going from
+prior to posterior via Bayes rule.
+Bayes factors are the primary tool Bayesians use for model comparison,
+the competitor for frequentist $P$-values in frequentist hypothesis
+tests of model comparison.
+
+Note that our clumsy multiple letter notation for priors and posteriors
+$\prior(m)$ and $\posterior(m \mid y)$ does not matter because neither
+is involved in the actual calculation of Bayes factors \eqref{eq:factor}.
+Priors and posteriors are involved in motivating Bayes factors but not in
+calculating them.
+
+\subsection{Tempering} \label{sec:temper}
+
+Simulated tempering \citep{marinari-parisi,geyer-thompson} is a method of
+Markov chain Monte Carlo (MCMC) simulation of many distributions at once.
+It was originally invented with the primary aim of speeding up MCMC
+convergence, but was also recognized to be useful for sampling multiple
+distributions \citep{geyer-thompson}. In the latter role it is sometimes
+referred to as ``umbrella sampling'' which is a term coined
+by \citet{torrie-valleau} for sampling multiple distributions via MCMC.
+
+We have a finite set of unnormalized distributions we want to sample,
+all related in some way. The R function \texttt{temper}
+in the CRAN package \texttt{mcmc}
+requires all to have continuous distributions for random vectors of the same
+dimension (all distributions have the same domain $\real^p$).
+Let $h_i$, $i \in \mathcal{I}$ denote the unnormalized densities of
+these distributions. Simulated tempering (called ``serial tempering'' by
+the \texttt{temper} function to distinguish from a related scheme not used
+in this document called ``parallel tempering'' and in either case abbreviated
+ST) runs a Markov chain whose
+state is a pair $(i, x)$ where $i \in \mathcal{I}$ and $x \in \real^p$.
+
+The unnormalized density of stationary distribution of the ST chain is
+\begin{equation} \label{eq:st-joint}
+ h(i, x) = h_i(x) c_i
+\end{equation}
+where the $c_i$ are arbitrary constants chosen by the user (more on this later).
+
+The equilibrium distribution of the ST state $(I, X)$ --- both bits random ---
+is such that conditional distribution of $X$ given $I = i$ is the distribution
+with unnormalized density $h_i$. This is obvious from $h(i, x)$ being the
+unnormalized conditional density --- the same function thought of as
+a function of both variables is the unnormalized joint density and thought
+of as a function of just one of the variables is an unnormalized conditional
+density --- and $h(i, x)$ thought of as a function of $x$ for fixed $i$ being
+proportional to $h_i$. The equilibrium unnormalized marginal distribution
+of $I$ is
+\begin{equation} \label{eq:margin}
+ \int h(i, x) \, d x = c_i \int h_i(x) \, d x = c_i d_i
+\end{equation}
+where
+$$
+ d_i = \int h_i(x) \, d x
+$$
+is the normalizing constant for $h_i$, that is, $h_i / d_i$ is a normalized
+distribution.
+
+It is clear from \eqref{eq:margin} being the unnormalized marginal distribution
+that in order for the marginal distribution to be uniform we must choose the
+tuning constants $c_i$ to be proportional to $1 / d_i$. It is not important
+that the marginal distribution be exactly uniform, but unless it is
+approximately uniform, the sampler will not visit each distribution frequently.
+Thus we do need to have the $c_i$ to be approximately proportional to $1 / d_i$.
+This is accomplished by trial and
+error (one example is done in this document) and is easy for easy problems
+and hard for hard problems \citep[have much to say about adjusting
+the $c_i$]{geyer-thompson}. For the rest of this section we will assume
+the tuning constants $c_i$ have been so adjusted:
+we do not have the $c_i$ exactly proportional to $1 / d_i$ but do have
+them approximately proportional to $1 / d_i$.
+
+\subsection{Tempering and Bayes Factors}
+
+Bayes factors are very important in Bayesian inference and many methods have
+been invented to calculate them. No method except the one described here
+using ST is anywhere near as accurate and straightforward. Thus no competitors
+will be discussed.
+
+In using ST for Bayes factors we identify the index set $\mathcal{I}$ with
+the model set $\mathcal{M}$ and use the integers 1, $\ldots$, $k$ for both.
+We would like to identify the within model parameter vector $\theta$ with
+the vector $x$ that is the continuous part of the state of the ST Markov
+chain, but cannot because the dimension of $\theta$ depends on $m$ and this
+is not allowed. Thus we have to do something a bit more complicated. We
+``pad'' $\theta$ so that it always has the same dimension, doing so in
+a way that does not interfere with the Bayes factor calculation. Write
+$\theta = (\theta_{\text{actual}}, \theta_{\text{pad}})$, the dimension
+of both parts depending on the model $m$. Then we insist on the following
+conditions:
+$$
+ f(y \mid \theta, m) = f(y \mid \theta_{\text{actual}}, m)
+$$
+so the data distribution does not depend on the ``padding'' and
+$$
+ g(\theta \mid m) = g_{\text{actual}}(\theta_{\text{actual}} \mid m)
+ \cdot g_{\text{pad}}(\theta_{\text{pad}} \mid m)
+$$
+so the two parts are \emph{a priori} independent and both parts of the prior
+are normalized proper priors. This assures that
+\begin{equation} \label{eq:unnormalized-bayes-factors}
+\begin{split}
+ b(y \mid m)
+ & =
+ \int_{\Theta_m} f(y \mid \theta, m) g(\theta \mid m) \, d \theta
+ \\
+ & =
+ \iint f(y \mid \theta_{\text{actual}}, m)
+ g_{\text{actual}}(\theta_{\text{actual}} \mid m)
+ g_{\text{pad}}(\theta_{\text{pad}} \mid m)
+ \, d \theta_{\text{actual}}
+ \, d \theta_{\text{pad}}
+ \\
+ & =
+ \int_{\Theta_m} f(y \mid \theta_{\text{actual}}, m)
+ g_{\text{actual}}(\theta_{\text{actual}} \mid m)
+ \, d \theta_{\text{actual}}
+\end{split}
+\end{equation}
+so the calculation of the unnormalized Bayes factors is the same whether
+or not we ``pad'' $\theta$, and we may then take
+\begin{align*}
+ h_m(\theta)
+ & =
+ f(y \mid \theta, m) g(\theta \mid m)
+ \\
+ & =
+ f(y \mid \theta_{\text{actual}}, m)
+ g_{\text{actual}}(\theta_{\text{actual}} \mid m)
+ g_{\text{pad}}(\theta_{\text{pad}} \mid m)
+\end{align*}
+to be the unnormalized densities for the component distributions of the ST
+chain, in which case the unnormalized Bayes factors are proportional to the
+normalizing constants $d_i$ in Section~\ref{sec:temper}.
+
+\subsection{Tempering and Normalizing Constants}
+
+Let $d$ be the normalizing constant for the joint equilibrium distribution
+of the ST chain \eqref{eq:st-joint}. When we are running the ST chain we know
+neither $d$ nor the $d_i$ but we do know the $c_i$, which are constants we
+have chosen based on the results of previous runs but are fixed known numbers
+for the current run. Let $(I_t, X_t)$, $t = 1$, 2, $\ldots$ be the sample
+path of the ST chain. Recall that (somewhat annoyingly) we are using the
+notation $(i, x)$ for the state vector of a general ST chain and the notation
+$(m, \theta)$ for ST chains used to calculate Bayes factors, identifying
+$i = m$ and $x = \theta$.
+
+Let $\indicator(\fatdot)$ denote the function that maps logical values to
+numerical values, false to zero and true to one. Normalizing constants are
+estimated by averaging the time spent in each model
+\begin{equation} \label{eq:st-estimates}
+ \hat{\delta}_n(m) = \frac{1}{n} \sum_{t = 1}^n \indicator(I_t = m)
+\end{equation}
+For the purposes of approximating Bayes factors the $X_t$ are ignored.
+The $X_t$ may be useful for other purposes, such as
+Bayesian model averaging \citep*{bma}, but this is not discussed here.
+
+The Monte Carlo approximations \eqref{eq:st-estimates} converge
+to their expected values under the equilibrium distribution
+\begin{equation} \label{eq:st-expectations}
+ E\{ \indicator(I_t = m) \}
+ =
+ \int \frac{h(m, x)}{d} \, d x
+ =
+ \frac{c_m d_m}{d}
+ =
+ \delta(m)
+\end{equation}
+We want to estimate the unnormalized Bayes factors
+\eqref{eq:unnormalized-bayes-factors}, which are in this context proportional
+to the $d_m$. The $c_m$ are known, $d$ is unknown but does not matter since
+we only need to estimate the $d_m = b(m \mid y)$ up to an overall unknown
+constant of proportionality, which cancels out of Bayes factors
+\eqref{eq:factor}.
+
+Note that our discussion here applies unchanged to the general problem of
+estimating normalizing constants up to an unknown constant of proportionality,
+which has applications other than Bayes factors, for example, missing data
+maximum likelihood \citep{thompson-guo,geyer,sung-geyer}.
+The ST method approximates normalizing constants up to an overall constant of
+proportionality with high accuracy regardless of how large or small they are
+(whether they are $10^{100}$ or $10^{-100}$), and no other method that does
+not use essentially the same idea can do this.
+
+The key is what seems at first sight to be a weakness of ST, the need to
+adjust the tuning constants $c_i$ by trial and error. In this context the
+weakness is actually a strength: the adjusted $c_i$ contain most of the
+information about the size of the normalizing constants $d_i$ and the
+Monte Carlo averages \eqref{eq:st-estimates} add only the finishing touch.
+Thus multiple runs of the ST chain with different choices of the $c_i$ used
+in each run are needed (the ``trial and error''), but the information from
+all are incorporated in the final run used for final approximation of the
+normalizing constants (Bayes factors). It is perhaps surprising that the
+Monte Carlo error approximation is trivial. In the context of the last run
+of the ST chain the $c_i$ are known constants and contribute no error.
+The Monte Carlo error of the averages \eqref{eq:st-estimates} is
+straightforwardly estimated by batch means or competing methods.
+
+\citet{geyer-thompson} note that the $c_i$ enter formally like a prior:
+one can think of $h_i(x) c_i$ as likelihood times prior. But one should
+not think of the $c_i$ as representing prior information, informative,
+non-informative, or in between. The $c_i$ are adjusted to make the ST
+distribution sample all the models $h_i$, and that is the only criterion
+for the adjustment. For this reason \citet{geyer-thompson} call the
+$c_i$ the \emph{pseudoprior}. This is a special case of a general principle
+of MCMC. When doing MCMC one should forget the statistical motivation
+(in this case Bayes factors). One should set up a Markov chain that does
+a good job of simulating the required equilibrium distribution, whatever
+it is. Thinking about the statistical motivation of the equilibrium does
+not help and can hurt (if one thinks of the pseudoprior as an actual prior,
+one may be tempted to adjust it to represent prior information).
+
+\section{R Package MCMC}
+
+We use the R statistical computing environment \citep{rcore} in our analysis.
+It is free software and can be obtained from
+\url{http://cran.r-project.org}. Precompiled binaries
+are available for Windows, Macintosh, and popular Linux distributions.
+We use the contributed package \verb at mcmc@ \citep{mcmc-R-package}
+If R has been installed, but this package has
+not yet been installed, do
+\begin{verbatim}
+install.packages("mcmc")
+\end{verbatim}
+from the R command line
+(or do the equivalent using the GUI menus if on Apple Macintosh
+or Microsoft Windows). This may require root or administrator privileges.
+
+Assuming the \verb at mcmc@ package has been installed, we load it
+<<library>>=
+library(mcmc)
+@
+<<baz,include=FALSE,echo=FALSE>>=
+baz <- library(help = "mcmc")
+baz <- baz$info[[1]]
+baz <- baz[grep("Version", baz)]
+baz <- sub("^Version: *", "", baz)
+bazzer <- paste(R.version$major, R.version$minor, sep = ".")
+@
+The version of the package used to make this document
+is \Sexpr{baz} (which is available on CRAN).
+The version of R used to make this document is \Sexpr{bazzer}.
+
+We also set the random number generator seed so that the results are
+reproducible.
+<<set-seed>>=
+set.seed(42)
+@
+To get different results, change the setting or don't set the seed at all.
+
+\section{Logistic Regression Example}
+
+We use the same logistic regression example used in the \texttt{mcmc}
+package vignette for the \texttt{metrop} function (file \texttt{demo.pdf}.
+Simulated data for the problem are in the data set \verb at logit@.
+There are five variables in the data set, the response \verb at y@
+and four predictors, \verb at x1@, \verb at x2@, \verb at x3@, and \verb at x4@.
+
+A frequentist analysis for the problem is done by the following R statements
+<<frequentist>>=
+data(logit)
+out <- glm(y ~ x1 + x2 + x3 + x4, data = logit,
+ family = binomial, x = TRUE)
+summary(out)
+@
+
+But this example isn't about frequentist analysis, we want a Bayesian
+analysis. For our Bayesian analysis we assume the same data model as the
+frequentist, and we assume the prior distribution of the five parameters
+(the regression coefficients) makes them independent and identically
+normally distributed with mean 0 and standard deviation 2.
+
+Moreover, we wish to calculate Bayes factors for the $16 = 2^4$ possible
+submodels that include or exclude each of the
+predictors, \verb at x1@, \verb at x2@, \verb at x3@, and \verb at x4@.
+
+\subsection{Setup}
+
+We set up a matrix that indicates these models.
+<<models>>=
+varnam <- names(coefficients(out))
+varnam <- varnam[varnam != "(Intercept)"]
+nvar <- length(varnam)
+
+models <- NULL
+foo <- seq(0, 2^nvar - 1)
+for (i in 1:nvar) {
+ bar <- foo %/% 2^(i - 1)
+ bar <- bar %% 2
+ models <- cbind(bar, models, deparse.level = 0)
+}
+colnames(models) <- varnam
+models
+@
+In each row, 1 indicates the predictor is in the model and 0 indicates it is
+out.
+
+The function \texttt{temper} in the \text{mcmc} package that does tempering
+requires a notion of neighbors among models. It attempts jumps only between
+neighboring models. Here we choose models to be neighbors if they differ
+only by one predictor.
+<<neighbor>>=
+neighbors <- matrix(FALSE, nrow(models), nrow(models))
+for (i in 1:nrow(neighbors)) {
+ for (j in 1:ncol(neighbors)) {
+ foo <- models[i, ]
+ bar <- models[j, ]
+ if (sum(foo != bar) == 1) neighbors[i, j] <- TRUE
+ }
+}
+@
+
+Now we specify the equilibrium distribution of the ST chain. Its state vector
+is $(i, x)$ or $(m, \theta)$ in our alternative notations, where $i$ is an
+integer between $1$ and \verb at nrow(models)@ = \Sexpr{nrow(models)} and
+$\theta$ is the parameter vector ``padded'' to always be the same length,
+so we take it to be the length of the parameter vector of the full model
+which is \verb at length(out$coefficients)@ or \verb at ncol(models) + 1@ which makes
+the length of the state of the ST chain \verb at ncol(models) + 2 at .
+We take the within model priors for the ``padded'' components of the parameter
+vector to be the same as those for the ``actual'' components, normal with
+mean 0 and standard deviation 2 for all cases.
+As is seen in \eqref{eq:unnormalized-bayes-factors} the priors for the
+``padded'' components (parameters not in the model for the current state)
+do not matter because they drop out of the Bayes factor calculation.
+The choice does not matter much for this toy example.
+See the discussion section for more on this issue.
+It is important that we use normalized log priors,
+the term \verb at dnorm(beta, 0, 2, log = TRUE)@ in the function, unlike
+when we are simulating only one model as in the \texttt{mcmc} package vignette
+where it would be o.~k.\ to use unnormalized log priors \verb at - beta^2 / 8 at .
+The \texttt{temper} function wants the log unnormalized density of the
+equilibrium distribution.
+We include an additional argument \texttt{log.pseudo.prior},
+which is $\log(c_i)$ in our mathematical development, because this changes
+from run to run as we adjust it by trial and error. Other ``arguments''
+are the model matrix of the full model \texttt{modmat}, the matrix
+\texttt{models} relating integer indices (the first component of the state
+vector of the ST chain) to which predictors are in or out of the model,
+and the data vector \texttt{y}, but these are not passed as arguments to our
+function and instead are found in the R global environment.
+<<ludfun>>=
+modmat <- out$x
+y <- logit$y
+
+ludfun <- function(state, log.pseudo.prior) {
+ stopifnot(is.numeric(state))
+ stopifnot(length(state) == ncol(models) + 2)
+ icomp <- state[1]
+ stopifnot(icomp == as.integer(icomp))
+ stopifnot(1 <= icomp && icomp <= nrow(models))
+ stopifnot(is.numeric(log.pseudo.prior))
+ stopifnot(length(log.pseudo.prior) == nrow(models))
+ beta <- state[-1]
+ inies <- c(TRUE, as.logical(models[icomp, ]))
+ beta.logl <- beta
+ beta.logl[! inies] <- 0
+ eta <- as.numeric(modmat %*% beta.logl)
+ logp <- ifelse(eta < 0, eta - log1p(exp(eta)), - log1p(exp(- eta)))
+ logq <- ifelse(eta < 0, - log1p(exp(eta)), - eta - log1p(exp(- eta)))
+ logl <- sum(logp[y == 1]) + sum(logq[y == 0])
+ logl + sum(dnorm(beta, 0, 2, log = TRUE)) + log.pseudo.prior[icomp]
+}
+@
+
+\subsection{Trial and Error}
+
+Now we are ready to try it out. We start in the full model at its MLE,
+and we initialize \texttt{log.pseudo.prior} at all zeros, having no idea
+\emph{a priori} what it should be.
+<<try1>>=
+state.initial <- c(nrow(models), out$coefficients)
+
+qux <- rep(0, nrow(models))
+
+out <- temper(ludfun, initial = state.initial, neighbors = neighbors,
+ nbatch = 1000, blen = 100, log.pseudo.prior = qux)
+
+names(out)
+out$time
+@
+So what happened?
+<<what>>=
+ibar <- colMeans(out$ibatch)
+ibar
+@
+The ST chain did not mix well, several models not being visited even once.
+So we adjust the pseudo priors to get uniform distribution.
+<<adjust>>=
+qux <- qux + pmin(log(max(ibar) / ibar), 10)
+qux <- qux - min(qux)
+qux
+@
+The new pseudoprior should be proportional to \verb at 1 / ibar@ if \texttt{ibar}
+is an accurate estimate of \eqref{eq:st-expectations}, but this makes no sense
+when the estimates are bad, in particular, when the are exactly zero. Thus
+we put an upper bound, chosen arbitrarily (here 10) on the maximum increase
+of the log pseudoprior. The statement
+\begin{verbatim}
+qux <- qux - min(qux)
+\end{verbatim}
+is unnecessary. An overall arbitrary constant can be added to
+the log pseudoprior without changing the equilibrium distribution of the
+ST chain.
+We do this only to make \texttt{qux} more comparable from
+run to run.
+
+Now we repeat this until the log pseudoprior ``converges'' roughly.
+Because this loop takes longer than CRAN vingettes are supposed to
+take, we save the results to a file
+and load the results from this file if it already exists.
+<<iterate>>=
+lout <- suppressWarnings(try(load("bfst1.rda"), silent = TRUE))
+if (inherits(lout, "try-error")) {
+ qux.save <- qux
+ time.save <- out$time
+ repeat{
+ out <- temper(out, log.pseudo.prior = qux)
+ ibar <- colMeans(out$ibatch)
+ qux <- qux + pmin(log(max(ibar) / ibar), 10)
+ qux <- qux - min(qux)
+ qux.save <- rbind(qux.save, qux, deparse.level = 0)
+ time.save <- rbind(time.save, out$time, deparse.level = 0)
+ if (max(ibar) / min(ibar) < 2) break
+ }
+ save(out, qux, qux.save, time.save, file = "bfst1.rda")
+} else {
+ .Random.seed <- out$final.seed
+}
+print(qux.save, digits = 3)
+print(qux, digits = 3)
+apply(time.save, 2, sum)
+@
+
+Now that the pseudoprior is adjusted well enough, we need to perhaps
+make other adjustments to get acceptance rates near 20\%.
+<<accept-i-x>>=
+print(out$accepti, digits = 3)
+print(out$acceptx, digits = 3)
+@
+The acceptance rates for swaps seem o. k.
+<<accept-i-min>>=
+min(as.vector(out$accepti), na.rm = TRUE)
+@
+and there is nothing simple we can do to adjust them (adjustment is possible,
+see the discussion section for more on this issue). We adjust the
+acceptance rates for within model moves by adjusting the scaling.
+<<scale>>=
+out <- temper(out, scale = 0.5, log.pseudo.prior = qux)
+time.save <- rbind(time.save, out$time, deparse.level = 0)
+print(out$acceptx, digits = 3)
+@
+Looks o.~k.\ now.
+
+Inspection of autocorrelation functions for components
+of \verb at out$ibatch@ (not shown) says batch length needs to be at least
+4 times longer. We make it 10 times longer for safety.
+
+Because this run takes longer than CRAN vingettes are supposed to
+take, we save the results to a file
+and load the results from this file if it already exists.
+<<try6>>=
+lout <- suppressWarnings(try(load("bfst2.rda"), silent = TRUE))
+if (inherits(lout, "try-error")) {
+ out <- temper(out, blen = 10 * out$blen, log.pseudo.prior = qux)
+ save(out, file = "bfst2.rda")
+} else {
+ .Random.seed <- out$final.seed
+}
+time.save <- rbind(time.save, out$time, deparse.level = 0)
+foo <- apply(time.save, 2, sum)
+foo.min <- floor(foo[1] / 60)
+foo.sec <- foo[1] - 60 * foo.min
+c(foo.min, foo.sec)
+@
+The total time for all runs of the temper function was
+\Sexpr{foo.min} minutes and \Sexpr{round(foo.sec, 1)} seconds.
+
+\subsection{Bayes Factor Calculations}
+
+Now we calculate log 10 Bayes factors relative to the model with the highest
+unnormalized Bayes factor.
+<<doit>>=
+log.10.unnorm.bayes <- (qux - log(colMeans(out$ibatch))) / log(10)
+k <- seq(along = log.10.unnorm.bayes)[log.10.unnorm.bayes
+ == min(log.10.unnorm.bayes)]
+models[k, ]
+
+log.10.bayes <- log.10.unnorm.bayes - log.10.unnorm.bayes[k]
+log.10.bayes
+@
+These are base 10 logarithms of the Bayes factors against the $k$-th
+model where $k = \Sexpr{k}$. For example, the Bayes factor for the $k$-th
+model divided by the Bayes factor for the first model is
+$10^{\Sexpr{round(log.10.bayes[1], 3)}}$.
+
+Now we calculate Monte Carlo standard errors two different ways. One is
+the way the delta method is usually taught. To simplify notation, denote
+the Bayes factors
+$$
+ b_m = b(y \mid m)
+$$
+and their Monte Carlo approximations $\hat{b}_m$. Then the log Bayes factors
+are
+$$
+ g_i(b) = \log_{10} b_i - \log_{10} b_k
+$$
+hence we need to apply the delta method with the function $g_i$, which has
+derivatives
+\begin{align*}
+ \frac{\partial g_i(b)}{\partial b_i}
+ & =
+ \frac{1}{b_i \log_e(10)}
+ \\
+ \frac{\partial g_i(b)}{\partial b_k}
+ & =
+ - \frac{1}{b_k \log_e(10)}
+ \\
+ \frac{\partial g_i(b)}{\partial b_j}
+ & =
+ 0, \qquad \text{$j \neq i$ and $j \neq k$}
+\end{align*}
+<<doit-se-one>>=
+fred <- var(out$ibatch) / out$nbatch
+sally <- colMeans(out$ibatch)
+mcse.log.10.bayes <- (1 / log(10)) * sqrt(diag(fred) / sally^2 -
+ 2 * fred[ , k] / (sally * sally[k]) +
+ fred[k, k] / sally[k]^2)
+mcse.log.10.bayes
+
+foompter <- cbind(models, log.10.bayes, mcse.log.10.bayes)
+round(foompter, 5)
+@
+
+An alternative calculation of the MCSE replaces the actual function
+of the raw Bayes factors with its best linear approximation
+$$
+ \frac{1}{\log_e(10)} \left(\frac{\hat{b}_i - b_i}{b_i}
+ - \frac{\hat{b}_k - b_k}{b_k} \right)
+$$
+and calculates the standard deviation of this quantity by batch means
+<<doit-too>>=
+ibar <- colMeans(out$ibatch)
+herman <- sweep(out$ibatch, 2, ibar, "/")
+herman <- sweep(herman, 1, herman[ , k], "-")
+mcse.log.10.bayes.too <- (1 / log(10)) *
+ apply(herman, 2, sd) /sqrt(out$nbatch)
+all.equal(mcse.log.10.bayes, mcse.log.10.bayes.too)
+@
+
+\section{Discussion}
+
+We hope readers are impressed with the power of this method. The key
+to the method is pseudopriors adjusted by trial and error. The method
+could have been invented by any Bayesian who realized that the priors
+on models, $\prior(m)$ in our notation in Section~\ref{sec:bayes-factors},
+do not affect the Bayes factors and hence are irrelevant to calculating
+Bayes factors. Thus the priors (or pseudopriors in our terminology) should
+be chosen for reasons of computational convenience, as we have done,
+rather than to incorporate prior information.
+
+The rest of the details of the method are unimportant. The \texttt{temper}
+function in R is convenient to use for this purpose, but there is no reason
+to believe that it provides optimal sampling. Samplers carefully designed
+for each particular application would undoubtedly do better. Our notion
+of ``padding'' so that the within model parameters have the same dimension
+for all models follows \citet{carlin-chib} but ``reversible jump'' samplers
+\citep{green} would undoubtedly do better. Unfortunately, there seems to
+be no way to code up a function like \texttt{temper} that uses ``reversible
+jump'' and requires no theoretical work from users that if messed up destroys
+the algorithm. The \texttt{temper} function is foolproof in the sense that
+if the log unnormalized density function written by the user
+(like our \texttt{ludfun}) is correct, then the ST Markov chain has the
+equilibrium distribution is supposed to have. There is nothing the
+user can mess up except this user written function. No analog of this
+for ``reversible jump'' chains is apparent (to your humble author).
+
+Two issues remain where the text above said ``see the discussion section for
+more on this issue.'' The first was about within model priors for the
+``padding'' components of within model parameter vectors
+$g_{\text{pad}}(\theta_{\text{pad}} \mid m)$ in
+the notation in \eqref{eq:unnormalized-bayes-factors}.
+Rather than choose these so that they do not depend on the data (as we did),
+it would be better (if more trouble) to choose them differently for each
+``padding'' component, centering $g_{\text{pad}}(\theta_{\text{pad}} \mid m)$
+so the distribution of a component of $\theta_{\text{pad}}$ is near to the
+marginal distribution of the same component in neighboring models (according to
+the \texttt{neighbors} argument of the \texttt{temper} function).
+
+The other remaining issue is adjusting acceptance rates for jumps. There
+is no way to adjust this other than by changing the number of models and
+their definitions. But the models we have cannot be changed; if we are
+to calculate Bayes factors for them, then we must sample them as they are.
+But we can insert new models between old models. For example,
+if the acceptance for swaps between model $i$ and model $j$ is too low, then
+we can insert distribution $k$ between them that has unnormalized density
+$$
+ h_k(x) = \sqrt{h_i(x) h_j(x)}.
+$$
+This idea is inherited from simulated tempering; \citep{geyer-thompson}
+have much
+discussion of how to insert additional distributions into a tempering network.
+It is another key issue in using tempering to speed up sampling. It is
+less obvious in the Bayes factor context, but still an available technique
+if needed.
+
+
+\begin{thebibliography}{}
+
+\bibitem[Carlin and Chib(1995)]{carlin-chib}
+Carlin, B.~P. and Chib, S. (1995).
+\newblock Bayesian model choice via Markov chain Monte Carlo methods.
+\newblock \emph{Journal of the Royal Statistical Society, Series B},
+ \textbf{57}, 473--484.
+
+\bibitem[Geyer(1994)]{geyer}
+Geyer, C.~J. (1994).
+\newblock On the convergence of Monte Carlo maximum likelihood calculations.
+\newblock \emph{Journal of the Royal Statistical Society, Series B},
+ \textbf{56} 261--274.
+
+\bibitem[Geyer., 2009]{mcmc-R-package}
+Geyer., C.~J. (2009).
+\newblock \emph{mcmc: Markov Chain Monte Carlo}.
+\newblock R package version 0.7-2, available from CRAN.
+
+\bibitem[Geyer and Thompson(1995)]{geyer-thompson}
+Geyer, C.~J., and Thompson, E.~A. (1995).
+\newblock Annealing Markov chain Monte Carlo with applications to ancestral
+ inference.
+\newblock \emph{Journal of the American Statistical Association}, \textbf{90},
+ 909--920.
+
+\bibitem[Green(1995)]{green}
+Green, P.~J. (1995).
+\newblock Reversible jump {M}arkov chain {M}onte {C}arlo computation and
+ {B}ayesian model determination.
+\newblock \emph{Biometrika}, \textbf{82}, 711--732.
+
+\bibitem[Hoeting et al.(1999)Hoeting, Madigan, Raftery, and Volinsky]{bma}
+Hoeting, J.~A., Madigan, D., Raftery, A.~E. and Volinsky, C.~T. (1999).
+\newblock Bayesian model averaging: A tutorial (with discussion).
+\newblock \emph{Statical Science}, \textbf{19}, 382--417.
+\newblock The version printed in the journal had the equations messed up in
+ the production process; a corrected version is available at
+ \url{http://www.stat.washington.edu/www/research/online/1999/hoeting.pdf}.
+
+\bibitem[Marinari and Parisi(1992)]{marinari-parisi}
+Marinari, E., and Parisi G. (1992).
+\newblock Simulated tempering: A new Monte Carlo Scheme.
+\newblock \emph{Europhysics Letters}, \textbf{19}, 451--458.
+
+\bibitem[R Development Core Team(2010)]{rcore}
+R Development Core Team (2010).
+\newblock R: A language and environment for statistical computing.
+\newblock R Foundation for Statistical Computing, Vienna, Austria.
+\newblock \url{http://www.R-project.org}.
+
+\bibitem[Sung and Geyer(2007)]{sung-geyer}
+Sung, Y.~J. and Geyer, C.~J. (2007).
+\newblock Monte Carlo likelihood inference for missing data models.
+\newblock \emph{Annals of Statistics}, \textbf{35}, 990--1011.
+
+\bibitem[Thompson and Guo(1991)]{thompson-guo}
+Thompson, E. A. and Guo, S. W. (1991).
+\newblock Evaluation of likelihood ratios for complex genetic models.
+\newblock \emph{IMA J. Math. Appl. Med. Biol.}, \textbf{8}, 149--169.
+
+\bibitem[Torrie and Valleau(1977)]{torrie-valleau}
+Torrie, G.~M., and Valleau, J.~P. (1977).
+\newblock Nonphysical sampling distributions in Monte Carlo free-energy
+ estimation: Umbrella sampling.
+\newblock \emph{Journal of Computational Physics}, \textbf{23}, 187--199.
+
+\end{thebibliography}
+
+\end{document}
+
diff --git a/inst/doc/bfst.pdf b/inst/doc/bfst.pdf
new file mode 100644
index 0000000..0a0db33
Binary files /dev/null and b/inst/doc/bfst.pdf differ
diff --git a/inst/doc/debug.R b/inst/doc/debug.R
new file mode 100644
index 0000000..2f09732
--- /dev/null
+++ b/inst/doc/debug.R
@@ -0,0 +1,9 @@
+### R code from vignette source 'debug.Rnw'
+
+###################################################
+### code chunk number 1: foo
+###################################################
+options(keep.source = TRUE, width = 60)
+foo <- packageDescription("mcmc")
+
+
diff --git a/inst/doc/debug.Rnw b/inst/doc/debug.Rnw
new file mode 100644
index 0000000..2da3897
--- /dev/null
+++ b/inst/doc/debug.Rnw
@@ -0,0 +1,274 @@
+
+\documentclass{article}
+
+\usepackage{amstext}
+
+% \VignetteIndexEntry{Debugging MCMC Code}
+
+\begin{document}
+
+<<foo,include=FALSE,echo=FALSE>>=
+options(keep.source = TRUE, width = 60)
+foo <- packageDescription("mcmc")
+@
+
+\title{Debugging MCMC Code}
+\author{Charles J. Geyer}
+\maketitle
+
+\section{Introduction}
+
+This document discusses debugging Markov chain Monte Carlo code
+using the R contributed package \texttt{mcmc} (Version \Sexpr{foo$Version})
+for examples. It also documents the debugging output of the functions
+\texttt{mcmc} and \texttt{temper}.
+
+Debugging MCMC code if the code is taken as a black box is basically
+impossible. In interesting examples, the only thing one knows about
+the equilibrium distribution of an MCMC sampler is what one learns
+from the samples. This obviously doesn't help with testing. If the
+sampler is buggy, then the only thing you know about the equilibrium
+distribution is wrong, but if you don't know it is buggy, then you don't
+know it is wrong. So you don't know anything. There is no way to tell
+whether random output has the correct distribution when you don't know
+anything about the distribution it is supposed to have.
+
+The secret to debugging MCMC code lies in two principles:
+\begin{itemize}
+\item take the randomness out, and
+\item expose the innards.
+\end{itemize}
+The first slogan means consider the algorithm a deterministic function
+of the elementary pseudo-random numbers that are trusted (for example,
+the outputs of the R random number generators, which you aren't responsible
+for debugging and are also well tested).
+The second slogan means output, at least for debugging purposes, enough
+intermediate state so that testing is straightforward.
+
+For a Gibbs sampler, this means outputting all of the trusted elementary
+pseudo-random numbers used, the state before and after each elementary
+Gibbs update, and which update is being done if a random scan is used.
+Also one needs to output the initial seeds of the pseudo-random number
+generator (this is true for all situations and will not be mentioned again).
+
+For a Metropolis-Hastings sampler, this means outputting all of the trusted
+elementary
+pseudo-random numbers used, the state before and after each elementary
+Metropolis-Hastings update, the proposal for that update, the Hastings ratio
+for that update, decision (accept or reject) in that update.
+
+For more complicated MCMC samplers, there is more ``innards'' to ``expose''
+(see the discussion of the \texttt{temper} function below), but you get the
+idea. You can't output too much debugging information.
+
+\section{The Metrop Function}
+
+The R function \texttt{metrop} in the \texttt{mcmc} package has an argument
+\verb at debug = FALSE@ that when \verb at TRUE@ causes extra debugging information
+to be output.
+Let \texttt{niter} be the number of iterations
+\verb at nbatch * blen * nspac@, and let \texttt{d} be the dimension of the state
+vector. The result of invoking \texttt{metrop} is a list. When
+\verb at debug = TRUE@ it has the following additional components
+\begin{itemize}
+\item \texttt{current}, an \texttt{niter} by \texttt{d} matrix
+ of mode \verb@"numeric"@, the state before iteration \texttt{i}
+ is \verb at current[i, ]@
+\item \texttt{proposal}, an \texttt{niter} by \texttt{d} matrix
+ of mode \verb@"numeric"@, the proposal for iteration \texttt{i}
+ is \verb at proposal[i, ]@
+\item \texttt{z}, an \texttt{niter} by \texttt{d} matrix
+ of mode \verb@"numeric"@, the vector of standard normal random variates
+ used to generate the proposal for iteration \texttt{i}
+ is \verb at z[i, ]@
+\item \texttt{log.green}, a vector of length \texttt{niter}
+ and mode \verb@"numeric"@, the logarithm of the Hastings ratio
+ for each iteration
+\item \texttt{u}, a vector of length \texttt{niter}
+ and mode \verb@"numeric"@, the $\text{Uniform}(0, 1)$ random variate
+ compared to the Hastings ratio for each iteration or \texttt{NA} if
+ none is needed (when the log Hastings ratio is nonnegative)
+\item \texttt{debug.accept}, a vector of length \texttt{niter}
+ and mode \verb@"logical"@, the decision for each iteration,
+ accept the proposal (\texttt{TRUE}) or reject it (\texttt{FALSE})
+\end{itemize}
+(The components \texttt{z} and \texttt{debug.accept} were added in
+version 0.7-3 of the \texttt{mcmc} package. Before that only the others
+were output.)
+
+Two components of the list returned by the \texttt{metrop} function always
+(whether \verb at debug = TRUE@ or \verb at debug = FALSE@) are also necessary
+for debugging. They are
+\begin{itemize}
+\item \texttt{initial.seed} the value of the variable \texttt{.Random.seed}
+ that contains the seeds of the R random number generator system before
+ invocation of the \texttt{metrop} function
+\item \texttt{final}, a vector of length \texttt{d} and mode \verb@"numeric"@,
+ the state after the last iteration
+\end{itemize}
+
+All of the files in the \texttt{tests} directory of the source for the
+package (not installed but found in the source tarball on CRAN) test
+the \texttt{metrop} function except those beginning \texttt{temp},
+which test the \texttt{temper} function. Since these tests were written
+many years ago, are spread out over many files, and are not commented,
+we will not describe them in detail. Suffice it to say that they check
+every aspect of the functioning of the \texttt{metrop} function.
+
+\section{The Temper Function}
+
+The R function \texttt{temper} in the \texttt{mcmc} package has an argument
+\verb at debug = FALSE@ that when \verb at TRUE@ causes extra debugging information
+to be output.
+Let \texttt{niter} be the number of iterations
+\verb at nbatch * blen * nspac@, let \texttt{d} be the dimension of the state
+vector, and let \texttt{ncomp} be the number of components of the tempering
+mixture.
+The result of invoking \texttt{temper} is a list. When
+\verb at debug = TRUE@ and \verb at parallel = TRUE@ it has the following additional
+components
+% which
+% unif.which
+% state
+% log.hastings
+% unif.hastings
+% proposal
+% acceptd
+% norm
+% unif.choose
+% coproposal
+\begin{itemize}
+\item \texttt{which}, a vector of length \texttt{niter}
+ and mode \verb@"logical"@ the type of update for each iteration,
+ within component (\texttt{TRUE}) or swap components (\texttt{FALSE}).
+\item \texttt{unif.which}, a vector of length \texttt{niter}
+ and mode \verb@"numeric"@, the $\text{Uniform}(0, 1)$ random variate
+ used to decide which type of update is done.
+\item \texttt{state}, an \texttt{niter} by \texttt{ncomp} by \texttt{d}
+ array of mode \verb@"numeric"@, the state before iteration \texttt{i}
+ is \verb at state[i, , ]@
+\item \texttt{proposal}, an \texttt{niter} by \verb at d + 1@
+ matrix of mode \verb@"numeric"@, the proposal for iteration \texttt{i}
+ is \verb at proposal[i, ]@ (explanation below)
+\item \texttt{coproposal}, an \texttt{niter} by \verb at d + 1@
+ matrix of mode \verb@"numeric"@, the proposal for iteration \texttt{i}
+ is \verb at coproposal[i, ]@ (explanation below)
+\item \texttt{log.hastings}, a vector of length \texttt{niter}
+ and mode \verb@"numeric"@, the logarithm of the Hastings ratio for
+ each iteration
+\item \texttt{unif.hastings}, a vector of length \texttt{niter}
+ and mode \verb@"numeric"@, the $\text{Uniform}(0, 1)$ random variate
+ compared to the Hastings ratio for each iteration or \texttt{NA} if
+ none is needed (when the log Hastings ratio is nonnegative)
+\item \texttt{acceptd}, a vector of length \texttt{niter}
+ and mode \verb@"logical"@, the decision for each iteration,
+ accept the proposal (\texttt{TRUE}) or reject it (\texttt{FALSE})
+\item \texttt{norm}, an \texttt{niter} by \texttt{d} matrix
+ of mode \verb@"numeric"@, the vector of standard normal random variates
+ used to generate the proposal for iteration \texttt{i} is \verb at z[i, ]@
+ unless none are needed (for swap updates) when it is \texttt{NA}
+\item \texttt{unif.choose}, an \texttt{niter} by 2 matrix
+ of mode \verb@"numeric"@, the vector of $\text{Uniform}(0, 1)$
+ random variates used to choose the components to update in iteration
+ \texttt{i} is \verb at unif.choose[i, ]@; in a swap update two are used;
+ in a within-component update only one is used and the second is \texttt{NA}
+\end{itemize}
+
+In a within-component update, one component say \texttt{j} is chosen for
+update. The \emph{coproposal} is the current value of the state for this
+component, which is a vector of length \verb at d + 1@, the first
+component of which is \texttt{j} and the rest of which is \verb at state[i, j, ]@
+if we are in iteration \texttt{i}.
+The \emph{proposal} is a similar vector, the first
+component of which is again \texttt{j} and the rest of which is a multivariate
+normal random vector centered at \verb at state[i, j, ]@.
+The coproposal is the current state; the proposal is the possible value
+(if accepted) of the state at the next time.
+
+In a swap update, two components say \texttt{j1} and \texttt{j2} are chosen for
+update. Strictly, speaking the coproposal is the pair of vectors
+\verb at c(j1, state[i, j1, ])@ and \verb at c(j2, state[i, j2, ])@
+and the proposal is these swapped, that is, the pair of vectors
+\verb at c(j2, state[i, j1, ])@ and \verb at c(j1, state[i, j2, ])@
+if we are in iteration \texttt{i}.
+Since, however, there is a lot of redundant information here,
+the vector \verb at c(j1, state[i, j1, ])@ is output as \verb at coproposal[i, ]@
+and the vector \verb at c(j2, state[i, j2, ])@ is output as \verb at proposal[i, ]@.
+
+When \verb at debug = TRUE@ and \verb at parallel = FALSE@
+the result of invoking \texttt{temper} is a list having
+the following additional components
+% which
+% unif.which
+% state
+% log.hastings
+% unif.hastings
+% proposal
+% acceptd
+% norm
+% unif.choose
+\begin{itemize}
+\item \texttt{which}, a vector of length \texttt{niter}
+ and mode \verb@"logical"@ the type of update for each iteration,
+ within component (\texttt{TRUE}) or jump from one component to
+ another (\texttt{FALSE}).
+\item \texttt{unif.which}, a vector of length \texttt{niter}
+ and mode \verb@"numeric"@, the $\text{Uniform}(0, 1)$ random variate
+ used to decide which type of update is done.
+\item \texttt{state}, an \texttt{niter} by \verb at d + 1@
+ matrix of mode \verb@"numeric"@, the state before iteration \texttt{i}
+ is \verb at state[i, ]@
+\item \texttt{proposal}, an \texttt{niter} by \verb at d + 1@
+ matrix of mode \verb@"numeric"@, the proposal for iteration \texttt{i}
+ is \verb at proposal[i, ]@
+\item \texttt{log.hastings}, a vector of length \texttt{niter}
+ and mode \verb@"numeric"@, the logarithm of the Hastings ratio for
+ each iteration
+\item \texttt{unif.hastings}, a vector of length \texttt{niter}
+ and mode \verb@"numeric"@, the $\text{Uniform}(0, 1)$ random variate
+ compared to the Hastings ratio for each iteration or \texttt{NA} if
+ none is needed (when the log Hastings ratio is nonnegative)
+\item \texttt{acceptd}, a vector of length \texttt{niter}
+ and mode \verb@"logical"@, the decision for each iteration,
+ accept the proposal (\texttt{TRUE}) or reject it (\texttt{FALSE})
+\item \texttt{norm}, an \texttt{niter} by \texttt{d} matrix
+ of mode \verb@"numeric"@, the vector of standard normal random variates
+ used to generate the proposal for iteration \texttt{i} is \verb at z[i, ]@
+ unless none are needed (for jump updates) when it is \texttt{NA}
+\item \texttt{unif.choose}, a vector of length \texttt{niter}
+ and mode \verb@"numeric"@, the $\text{Uniform}(0, 1)$
+ random variates used to choose the component to update in iteration
+ \texttt{i} is \verb at unif.choose[i, ]@; in a jump update one is used;
+ in a within-component update none is used and \texttt{NA} is output
+\end{itemize}
+
+All of the files in the \texttt{tests} directory of the source for the
+package (not installed but found in the source tarball on CRAN)
+beginning \texttt{temp} test the \texttt{temper} function.
+They check every aspect of the functioning of the \texttt{temper} function.
+
+In the file \texttt{temp-par.R} in the \texttt{tests} directory, the following
+checks are made according to the comments in that file
+\begin{enumerate}
+\item check decision about within-component or jump/swap
+\item check proposal and coproposal are actually current state or part thereof
+\item check hastings ratio calculated correctly
+\item check hastings rejection decided correctly
+\item check acceptance carried out or not (according to decision) correctly
+\item check within-component proposal
+\item check swap proposal
+\item check standard normal and uniform random numbers are as purported
+\item check batch means
+\item check acceptance rates
+\item check scale vector
+\item check scale matrix
+\item check scale list
+\item check outfun
+\end{enumerate}
+In the file \texttt{temp-ser.R} in the \texttt{tests} directory, the all of
+the same checks are made according to the comments in that file except for
+check number 2 above, which would make no sense because there is no
+\texttt{coproposal} component in the serial (\verb at parallel = FALSE@) case.
+
+\end{document}
+
diff --git a/inst/doc/debug.pdf b/inst/doc/debug.pdf
new file mode 100644
index 0000000..2b4d79a
Binary files /dev/null and b/inst/doc/debug.pdf differ
diff --git a/inst/doc/demo.R b/inst/doc/demo.R
new file mode 100644
index 0000000..ee0ac5e
--- /dev/null
+++ b/inst/doc/demo.R
@@ -0,0 +1,296 @@
+### R code from vignette source 'demo.Rnw'
+### Encoding: UTF-8
+
+###################################################
+### code chunk number 1: foo
+###################################################
+options(keep.source = TRUE, width = 60)
+foo <- packageDescription("mcmc")
+
+
+###################################################
+### code chunk number 2: frequentist
+###################################################
+library(mcmc)
+data(logit)
+out <- glm(y ~ x1 + x2 + x3 + x4, data = logit,
+ family = binomial(), x = TRUE)
+summary(out)
+
+
+###################################################
+### code chunk number 3: log.unnormalized.posterior
+###################################################
+x <- out$x
+y <- out$y
+
+lupost <- function(beta, x, y) {
+ eta <- as.numeric(x %*% beta)
+ logp <- ifelse(eta < 0, eta - log1p(exp(eta)), - log1p(exp(- eta)))
+ logq <- ifelse(eta < 0, - log1p(exp(eta)), - eta - log1p(exp(- eta)))
+ logl <- sum(logp[y == 1]) + sum(logq[y == 0])
+ return(logl - sum(beta^2) / 8)
+}
+
+
+###################################################
+### code chunk number 4: metropolis-try-1
+###################################################
+set.seed(42) # to get reproducible results
+beta.init <- as.numeric(coefficients(out))
+out <- metrop(lupost, beta.init, 1e3, x = x, y = y)
+names(out)
+out$accept
+
+
+###################################################
+### code chunk number 5: metropolis-try-2
+###################################################
+out <- metrop(out, scale = 0.1, x = x, y = y)
+out$accept
+out <- metrop(out, scale = 0.3, x = x, y = y)
+out$accept
+out <- metrop(out, scale = 0.5, x = x, y = y)
+out$accept
+out <- metrop(out, scale = 0.4, x = x, y = y)
+out$accept
+
+
+###################################################
+### code chunk number 6: metropolis-try-3
+###################################################
+out <- metrop(out, nbatch = 1e4, x = x, y = y)
+out$accept
+out$time
+
+
+###################################################
+### code chunk number 7: fig1too
+###################################################
+plot(ts(out$batch))
+
+
+###################################################
+### code chunk number 8: fig1
+###################################################
+plot(ts(out$batch))
+
+
+###################################################
+### code chunk number 9: fig2too
+###################################################
+acf(out$batch)
+
+
+###################################################
+### code chunk number 10: fig2
+###################################################
+acf(out$batch)
+
+
+###################################################
+### code chunk number 11: metropolis-try-4
+###################################################
+out <- metrop(out, nbatch = 1e2, blen = 100,
+ outfun = function(z, ...) c(z, z^2), x = x, y = y)
+out$accept
+out$time
+
+
+###################################################
+### code chunk number 12: metropolis-batch
+###################################################
+apply(out$batch, 2, mean)
+
+
+###################################################
+### code chunk number 13: metropolis-batch-too
+###################################################
+foo <- apply(out$batch, 2, mean)
+mu <- foo[1:5]
+sigmasq <- foo[6:10] - mu^2
+mu
+sigmasq
+
+
+###################################################
+### code chunk number 14: metropolis-mcse-mu
+###################################################
+mu.mcse <- apply(out$batch[ , 1:5], 2, sd) / sqrt(out$nbatch)
+mu.mcse
+
+
+###################################################
+### code chunk number 15: metropolis-mcse-sigmasq
+###################################################
+u <- out$batch[ , 1:5]
+v <- out$batch[ , 6:10]
+ubar <- apply(u, 2, mean)
+vbar <- apply(v, 2, mean)
+deltau <- sweep(u, 2, ubar)
+deltav <- sweep(v, 2, vbar)
+foo <- sweep(deltau, 2, ubar, "*")
+sigmasq.mcse <- sqrt(apply((deltav - 2 * foo)^2, 2, mean) / out$nbatch)
+sigmasq.mcse
+
+
+###################################################
+### code chunk number 16: metropolis-mcse-sigmasq-too
+###################################################
+sqrt(mean(((v[ , 2] - vbar[2]) - 2 * ubar[2] * (u[ , 2] - ubar[2]))^2) /
+ out$nbatch)
+
+
+###################################################
+### code chunk number 17: metropolis-mcse-sigma
+###################################################
+sigma <- sqrt(sigmasq)
+sigma.mcse <- sigmasq.mcse / (2 * sigma)
+sigma
+sigma.mcse
+
+
+###################################################
+### code chunk number 18: metropolis-try-5
+###################################################
+out <- metrop(out, nbatch = 5e2, blen = 400, x = x, y = y)
+out$accept
+out$time
+foo <- apply(out$batch, 2, mean)
+mu <- foo[1:5]
+sigmasq <- foo[6:10] - mu^2
+mu
+sigmasq
+mu.mcse <- apply(out$batch[ , 1:5], 2, sd) / sqrt(out$nbatch)
+mu.mcse
+u <- out$batch[ , 1:5]
+v <- out$batch[ , 6:10]
+ubar <- apply(u, 2, mean)
+vbar <- apply(v, 2, mean)
+deltau <- sweep(u, 2, ubar)
+deltav <- sweep(v, 2, vbar)
+foo <- sweep(deltau, 2, ubar, "*")
+sigmasq.mcse <- sqrt(apply((deltav - 2 * foo)^2, 2, mean) / out$nbatch)
+sigmasq.mcse
+sigma <- sqrt(sigmasq)
+sigma.mcse <- sigmasq.mcse / (2 * sigma)
+sigma
+sigma.mcse
+
+
+###################################################
+### code chunk number 19: tab1
+###################################################
+foo <- rbind(mu, mu.mcse)
+dimnames(foo) <- list(c("estimate", "MCSE"),
+ c("constant", paste("$x_", 1:4, "$", sep = "")))
+library(xtable)
+print(xtable(foo, digits = rep(4, 6),
+ align = c("l", rep("c", 5))), floating = FALSE,
+ caption.placement = "top",
+ sanitize.colnames.function = function(x) return(x))
+
+
+###################################################
+### code chunk number 20: tab1
+###################################################
+foo <- rbind(sigmasq, sigmasq.mcse)
+dimnames(foo) <- list(c("estimate", "MCSE"),
+ c("constant", paste("$x_", 1:4, "$", sep = "")))
+library(xtable)
+print(xtable(foo, digits = rep(4, 6),
+ align = c("l", rep("c", 5))), floating = FALSE,
+ caption.placement = "top",
+ sanitize.colnames.function = function(x) return(x))
+
+
+###################################################
+### code chunk number 21: tab1
+###################################################
+foo <- rbind(sigma, sigma.mcse)
+dimnames(foo) <- list(c("estimate", "MCSE"),
+ c("constant", paste("$x_", 1:4, "$", sep = "")))
+library(xtable)
+print(xtable(foo, digits = rep(4, 6),
+ align = c("l", rep("c", 5))), floating = FALSE,
+ caption.placement = "top",
+ sanitize.colnames.function = function(x) return(x))
+
+
+###################################################
+### code chunk number 22: time
+###################################################
+cat(out$time[1], "\n")
+
+
+###################################################
+### code chunk number 23: x
+###################################################
+n <- 2e4
+rho <- 0.99
+x <- arima.sim(model = list(ar = rho), n = n)
+
+
+###################################################
+### code chunk number 24: figgamtoo
+###################################################
+out <- initseq(x)
+plot(seq(along = out$Gamma.pos) - 1, out$Gamma.pos,
+ xlab = "k", ylab = expression(Gamma[k]), type = "l")
+lines(seq(along = out$Gamma.dec) - 1, out$Gamma.dec, lty = "dotted")
+lines(seq(along = out$Gamma.con) - 1, out$Gamma.con, lty = "dashed")
+
+
+###################################################
+### code chunk number 25: figgam
+###################################################
+out <- initseq(x)
+plot(seq(along = out$Gamma.pos) - 1, out$Gamma.pos,
+ xlab = "k", ylab = expression(Gamma[k]), type = "l")
+lines(seq(along = out$Gamma.dec) - 1, out$Gamma.dec, lty = "dotted")
+lines(seq(along = out$Gamma.con) - 1, out$Gamma.con, lty = "dashed")
+
+
+###################################################
+### code chunk number 26: assvar
+###################################################
+out$var.con
+(1 + rho) / (1 - rho) * 1 / (1 - rho^2)
+
+
+###################################################
+### code chunk number 27: batx
+###################################################
+blen <- 5
+x.batch <- apply(matrix(x, nrow = blen), 2, mean)
+bout <- initseq(x.batch)
+
+
+###################################################
+### code chunk number 28: figgambattoo
+###################################################
+plot(seq(along = bout$Gamma.con) - 1, bout$Gamma.con,
+ xlab = "k", ylab = expression(Gamma[k]), type = "l")
+
+
+###################################################
+### code chunk number 29: figgambat
+###################################################
+plot(seq(along = bout$Gamma.con) - 1, bout$Gamma.con,
+ xlab = "k", ylab = expression(Gamma[k]), type = "l")
+
+
+###################################################
+### code chunk number 30: compvar
+###################################################
+out$var.con
+bout$var.con * blen
+
+
+###################################################
+### code chunk number 31: ci-con
+###################################################
+mean(x) + c(-1, 1) * qnorm(0.975) * sqrt(out$var.con / length(x))
+mean(x.batch) + c(-1, 1) * qnorm(0.975) * sqrt(bout$var.con / length(x.batch))
+
+
diff --git a/inst/doc/demo.Rnw b/inst/doc/demo.Rnw
new file mode 100644
index 0000000..4f84b9e
--- /dev/null
+++ b/inst/doc/demo.Rnw
@@ -0,0 +1,609 @@
+
+\documentclass{article}
+
+\usepackage{natbib}
+\usepackage{graphics}
+\usepackage{amsmath}
+\usepackage{indentfirst}
+\usepackage[utf8]{inputenc}
+
+\DeclareMathOperator{\var}{var}
+\DeclareMathOperator{\cov}{cov}
+
+% \VignetteIndexEntry{MCMC Example}
+
+\begin{document}
+
+<<foo,include=FALSE,echo=FALSE>>=
+options(keep.source = TRUE, width = 60)
+foo <- packageDescription("mcmc")
+@
+
+\title{MCMC Package Example (Version \Sexpr{foo$Version})}
+\author{Charles J. Geyer}
+\maketitle
+
+\section{The Problem}
+
+This is an example of using the \verb at mcmc@ package in R. The problem comes
+from a take-home question on a (take-home) PhD qualifying exam
+(School of Statistics, University of Minnesota).
+
+Simulated data for the problem are in the dataset \verb at logit@.
+There are five variables in the data set, the response \verb at y@
+and four predictors, \verb at x1@, \verb at x2@, \verb at x3@, and \verb at x4@.
+
+A frequentist analysis for the problem is done by the following R statements
+<<frequentist>>=
+library(mcmc)
+data(logit)
+out <- glm(y ~ x1 + x2 + x3 + x4, data = logit,
+ family = binomial(), x = TRUE)
+summary(out)
+@
+
+But this problem isn't about that frequentist analysis, we want a Bayesian
+analysis. For our Bayesian analysis we assume the same data model as the
+frequentist, and we assume the prior distribution of the five parameters
+(the regression coefficients) makes them independent and identically
+normally distributed with mean 0 and standard deviation 2.
+
+The log unnormalized posterior (log likelihood plus log prior) density
+for this model is calculated by
+the following R function (given the preceding data definitions)
+<<log.unnormalized.posterior>>=
+x <- out$x
+y <- out$y
+
+lupost <- function(beta, x, y) {
+ eta <- as.numeric(x %*% beta)
+ logp <- ifelse(eta < 0, eta - log1p(exp(eta)), - log1p(exp(- eta)))
+ logq <- ifelse(eta < 0, - log1p(exp(eta)), - eta - log1p(exp(- eta)))
+ logl <- sum(logp[y == 1]) + sum(logq[y == 0])
+ return(logl - sum(beta^2) / 8)
+}
+@
+The tricky calculation of the log likelihood avoids overflow and catastrophic
+cancellation in calculation of $\log(p)$ and $\log(q)$ where
+\begin{align*}
+ p & = \frac{\exp(\eta)}{1 + \exp(\eta)} = \frac{1}{1 + \exp(- \eta)}
+ \\
+ q & = \frac{1}{1 + \exp(\eta)} = \frac{\exp(- \eta)}{1 + \exp(- \eta)}
+\end{align*}
+so taking logs gives
+\begin{align*}
+ \log(p) & = \eta - \log(1 + \exp(\eta)) = - \log(1 + \exp(- \eta))
+ \\
+ \log(q) & = - \log(1 + \exp(\eta)) = - \eta - \log(1 + \exp(- \eta))
+\end{align*}
+To avoid overflow, we always chose the case where the argument of $\exp$
+is negative. We have also avoided catastrophic cancellation when
+$\lvert\eta\rvert$ is large. If $\eta$ is large and positive, then
+\begin{align*}
+ p & \approx 1
+ \\
+ q & \approx 0
+ \\
+ \log(p) & \approx - \exp(- \eta)
+ \\
+ \log(q) & \approx - \eta - \exp(- \eta)
+\end{align*}
+and our use of the R function \texttt{log1p}, which calculates the
+function $x \mapsto \log(1 + x)$
+correctly for small $x$ avoids all problems. The case where $\eta$ is large
+and negative is similar.
+
+\section{Beginning MCMC}
+
+With those definitions in place, the following code runs the Metropolis
+algorithm to simulate the posterior.
+<<metropolis-try-1>>=
+set.seed(42) # to get reproducible results
+beta.init <- as.numeric(coefficients(out))
+out <- metrop(lupost, beta.init, 1e3, x = x, y = y)
+names(out)
+out$accept
+@
+
+The arguments to the \verb at metrop@ function used here (there are others
+we don't use) are
+\begin{itemize}
+\item an R function (here \verb at lupost@) that evaluates the log unnormalized
+ density of the desired stationary distribution of the Markov chain
+ (here a posterior distribution). Note that (although this example
+ does not exhibit the phenomenon) that the unnormalized density may
+ be zero, in which case the log unnormalized density is \verb at -Inf@.
+\item an initial state (here \verb at beta.init@) of the Markov chain.
+\item a number of batches (here \verb at 1e3@) for the Markov chain.
+ This combines with batch length and spacing (both 1 by default)
+ to determine the number of iterations done.
+\item additional arguments (here \verb at x@ and \verb at y@) supplied to
+ provided functions (here \verb at lupost@).
+\item there is no ``burn-in'' argument, although burn-in is easily
+ accomplished, if desired (more on this below).
+\end{itemize}
+
+The output is in the component \verb at out$batch@ returned by the \verb at metrop@
+function. We'll look at it presently, but first we need to adjust the
+proposal to get a higher acceptance rate (\verb at out$accept@). It is generally
+accepted \citep*{grg} that an acceptance rate of about 20\% is right, although
+this recommendation is based on the asymptotic analysis of a toy problem
+(simulating a multivariate normal distribution) for which one would never
+use MCMC and is very unrepresentative of difficult MCMC applications.
+
+\citet{geyer-temp} came to a similar conclusion,
+that a 20\% acceptance rate is about right, in a very different situation.
+But they also warned that a 20\% acceptance rate could be very wrong
+and produced
+an example where a 20\% acceptance rate was impossible and attempting to
+reduce the acceptance rate below 70\% would keep the sampler from ever
+visiting part of the state space. So the 20\% magic number must be
+considered like other rules of thumb we teach in intro courses
+(like $n > 30$ means means normal approximation is valid).
+We know these rules of thumb can fail.
+There are examples in the literature where
+they do fail. We keep repeating them because we want something simple to
+tell beginners, and they are all right for some problems.
+
+Be that as it may, we try for 20\%.
+<<metropolis-try-2>>=
+out <- metrop(out, scale = 0.1, x = x, y = y)
+out$accept
+out <- metrop(out, scale = 0.3, x = x, y = y)
+out$accept
+out <- metrop(out, scale = 0.5, x = x, y = y)
+out$accept
+out <- metrop(out, scale = 0.4, x = x, y = y)
+out$accept
+@
+
+Here the first argument to each instance of the \verb at metrop@ function is
+the output of a previous invocation. The Markov chain continues where
+the previous run stopped, doing just what it would have done if it had
+kept going, the initial state and random seed being the final state and
+random seed of the previous invocation. Everything stays the same
+except for the arguments supplied (here \verb at scale@).
+\begin{itemize}
+\item The argument \verb at scale@ controls the size of the Metropolis
+ ``normal random walk'' proposal. The default is \verb at scale = 1 at .
+ Big steps give lower acceptance rates. Small steps give higher.
+ We want something about 20\%. It is also possible to make \verb at scale@
+ a vector or a matrix. See \verb at help(metrop)@.
+\end{itemize}
+
+Because each run starts where the last one stopped (when the first argument
+to \verb at metrop@ is the output of the previous invocation), each run serves
+as ``burn-in'' for its successor (assuming that any part of that run was
+worth anything at all).
+
+\section{Diagnostics}
+
+O.~K. That does it for the acceptance rate. So let's do a longer run
+and look at the results.
+<<label=metropolis-try-3>>=
+out <- metrop(out, nbatch = 1e4, x = x, y = y)
+out$accept
+out$time
+@
+
+Figure~\ref{fig:fig1} (page~\pageref{fig:fig1})
+shows the time series plot made by the R statement
+<<label=fig1too,include=FALSE>>=
+plot(ts(out$batch))
+@
+\begin{figure}
+\begin{center}
+<<label=fig1,fig=TRUE,echo=FALSE>>=
+<<fig1too>>
+@
+\end{center}
+\caption{Time series plot of MCMC output.}
+\label{fig:fig1}
+\end{figure}
+
+Another way to look at the output is an autocorrelation plot.
+Figure~\ref{fig:fig2} (page~\pageref{fig:fig2})
+shows the time series plot made by the R statement
+<<label=fig2too,include=FALSE>>=
+acf(out$batch)
+@
+\begin{figure}
+\begin{center}
+<<label=fig2,fig=TRUE,echo=FALSE>>=
+<<fig2too>>
+@
+\end{center}
+\caption{Autocorrelation plot of MCMC output.}
+\label{fig:fig2}
+\end{figure}
+
+As with any multiplot plot, these are a bit hard to read. Readers are
+invited to make the separate plots to get a better picture.
+As with all ``diagnostic'' plots in MCMC, these don't ``diagnose''
+subtle problems. As
+\begin{verbatim}
+http://www.stat.umn.edu/~charlie/mcmc/diag.html
+\end{verbatim}
+says
+\begin{quotation}
+The purpose of regression diagnostics is to find obvious, gross,
+embarrassing problems that jump out of simple plots.
+\end{quotation}
+The time series plots will show \emph{obvious} nonstationarity.
+They will not show \emph{nonobvious} nonstationarity. They
+provide no guarantee whatsoever that your Markov chain is sampling
+anything remotely resembling the correct stationary distribution
+(with log unnormalized density \verb at lupost@). In this very easy
+problem, we do not expect any convergence difficulties and so believe
+what the diagnostics seem to show, but one is a fool to trust such
+diagnostics in difficult problems.
+
+The autocorrelation plots seem to show that the
+the autocorrelations are negligible after about lag 25.
+This diagnostic inference is reliable if the sampler is actually
+working (has nearly reached equilibrium) and worthless otherwise.
+Thus batches of length 25 should be sufficient, but let's use
+length 100 to be safe.
+
+\section{Monte Carlo Estimates and Standard Errors}
+
+<<label=metropolis-try-4>>=
+out <- metrop(out, nbatch = 1e2, blen = 100,
+ outfun = function(z, ...) c(z, z^2), x = x, y = y)
+out$accept
+out$time
+@
+
+We have added an argument \verb at outfun@ that gives the ``functional''
+of the state we want to average. For this problem we are interested
+in both posterior mean and variance. Mean is easy, just average the
+variables in question. But variance is a little tricky. We need to
+use the identity
+$$
+ \var(X) = E(X^2) - E(X)^2
+$$
+to write variance as a function of two things that can be estimated
+by simple averages. Hence we want to average the state itself and
+the squares of each component. Hence our \verb at outfun@ returns
+\verb at c(z, z^2)@ for an argument (the state vector) \verb at z@.
+
+The \verb at ...@ argument to \verb at outfun@ is required, since the
+function is also passed the other arguments (here \verb at x@ and \verb at y@)
+to \verb at metrop@.
+
+\subsection{Simple Means}
+
+The grand means (means of batch means) are
+<<label=metropolis-batch>>=
+apply(out$batch, 2, mean)
+@
+The first 5 numbers are the Monte Carlo estimates of the posterior means.
+The second 5 numbers are the Monte Carlo estimates of the posterior
+ordinary second moments. We get the posterior variances by
+<<label=metropolis-batch-too>>=
+foo <- apply(out$batch, 2, mean)
+mu <- foo[1:5]
+sigmasq <- foo[6:10] - mu^2
+mu
+sigmasq
+@
+
+Monte Carlo standard errors (MCSE) are calculated from the batch means.
+This is simplest for the means.
+<<label=metropolis-mcse-mu>>=
+mu.mcse <- apply(out$batch[ , 1:5], 2, sd) / sqrt(out$nbatch)
+mu.mcse
+@
+The extra factor \verb at sqrt(out$nbatch)@ arises because the batch means
+have variance $\sigma^2 / b$ where $b$ is the batch length, which is
+\verb at out$blen@,
+whereas the overall means \verb at mu@ have variance $\sigma^2 / n$ where
+$n$ is the total number of iterations, which is \verb at out$blen * out$nbatch at .
+
+\subsection{Functions of Means}
+
+To get the MCSE for the posterior variances we apply the delta method.
+Let $u_i$ denote the sequence of batch means of the first kind for one
+parameter and $\bar{u}$ the grand mean (the estimate of the posterior mean
+of that parameter),
+let $v_i$ denote the sequence of batch means of the second kind for the
+same parameter and $\bar{v}$ the grand mean (the estimate of the posterior
+second absolute moment of that parameter), and let $\mu = E(\bar{u})$ and
+$\nu = E(\bar{v})$. Then the delta method linearizes the nonlinear function
+$$
+ g(\mu, \nu) = \nu - \mu^2
+$$
+as
+$$
+ \Delta g(\mu, \nu) = \Delta \nu - 2 \mu \Delta \mu
+$$
+saying that
+$$
+ g(\bar{u}, \bar{v}) - g(\mu, \nu)
+$$
+has the same asymptotic normal distribution as
+$$
+ (\bar{v} - \nu) - 2 \mu (\bar{u} - \mu)
+$$
+which, of course, has variance \verb at 1 / nbatch@ times that of
+$$
+ (v_i - \nu) - 2 \mu (u_i - \mu)
+$$
+and this variance is estimated by
+$$
+ \frac{1}{n_{\text{batch}}} \sum_{i = 1}^{n_{\text{batch}}}
+ \bigl[ (v_i - \bar{v}) - 2 \bar{u} (u_i - \bar{u}) \bigr]^2
+$$
+So
+<<label=metropolis-mcse-sigmasq>>=
+u <- out$batch[ , 1:5]
+v <- out$batch[ , 6:10]
+ubar <- apply(u, 2, mean)
+vbar <- apply(v, 2, mean)
+deltau <- sweep(u, 2, ubar)
+deltav <- sweep(v, 2, vbar)
+foo <- sweep(deltau, 2, ubar, "*")
+sigmasq.mcse <- sqrt(apply((deltav - 2 * foo)^2, 2, mean) / out$nbatch)
+sigmasq.mcse
+@
+does the MCSE for the posterior variance.
+
+Let's just check that this complicated \verb at sweep@ and \verb at apply@ stuff
+does do the right thing.
+<<label=metropolis-mcse-sigmasq-too>>=
+sqrt(mean(((v[ , 2] - vbar[2]) - 2 * ubar[2] * (u[ , 2] - ubar[2]))^2) /
+ out$nbatch)
+@
+
+\paragraph{Comment} Through version 0.5 of this vignette it contained
+an incorrect procedure for calculating this MCSE, justified by a handwave
+(which was incorrect).
+Essentially, it said to use the standard deviation of the batch means called
+\verb at v@ here, which appears to be very conservative.
+
+\subsection{Functions of Functions of Means}
+
+If we are also interested in the posterior standard deviation
+(a natural question, although not asked on the exam problem),
+the delta method gives its standard error in terms of that
+for the variance
+<<label=metropolis-mcse-sigma>>=
+sigma <- sqrt(sigmasq)
+sigma.mcse <- sigmasq.mcse / (2 * sigma)
+sigma
+sigma.mcse
+@
+
+\section{A Final Run}
+
+So that's it. The only thing left to do is a little more precision
+(the exam problem directed ``use a long enough run of your Markov chain
+sampler so that the MCSE are less than 0.01'')
+<<label=metropolis-try-5>>=
+out <- metrop(out, nbatch = 5e2, blen = 400, x = x, y = y)
+out$accept
+out$time
+<<metropolis-batch-too>>
+<<metropolis-mcse-mu>>
+<<metropolis-mcse-sigmasq>>
+<<metropolis-mcse-sigma>>
+@
+and some nicer output, which is presented in three tables
+constructed from the R variables defined above
+using the R \verb at xtable@ command in the \verb at xtable@ library.
+
+First the posterior means,
+\begin{table}[ht]
+\caption{Posterior Means}
+\label{tab:mu}
+\begin{center}
+<<label=tab1,echo=FALSE,results=tex>>=
+foo <- rbind(mu, mu.mcse)
+dimnames(foo) <- list(c("estimate", "MCSE"),
+ c("constant", paste("$x_", 1:4, "$", sep = "")))
+library(xtable)
+print(xtable(foo, digits = rep(4, 6),
+ align = c("l", rep("c", 5))), floating = FALSE,
+ caption.placement = "top",
+ sanitize.colnames.function = function(x) return(x))
+@
+\end{center}
+\end{table}
+then the posterior variances (table on page~\pageref{tab:sigmasq}),
+\begin{table}[ht]
+\caption{Posterior Variances}
+\label{tab:sigmasq}
+\begin{center}
+<<label=tab1,echo=FALSE,results=tex>>=
+foo <- rbind(sigmasq, sigmasq.mcse)
+dimnames(foo) <- list(c("estimate", "MCSE"),
+ c("constant", paste("$x_", 1:4, "$", sep = "")))
+library(xtable)
+print(xtable(foo, digits = rep(4, 6),
+ align = c("l", rep("c", 5))), floating = FALSE,
+ caption.placement = "top",
+ sanitize.colnames.function = function(x) return(x))
+@
+\end{center}
+\end{table}
+and finally the posterior standard deviations
+(table on page~\pageref{tab:sigma}).
+\begin{table}[ht]
+\caption{Posterior Standard Deviations}
+\label{tab:sigma}
+\begin{center}
+<<label=tab1,echo=FALSE,results=tex>>=
+foo <- rbind(sigma, sigma.mcse)
+dimnames(foo) <- list(c("estimate", "MCSE"),
+ c("constant", paste("$x_", 1:4, "$", sep = "")))
+library(xtable)
+print(xtable(foo, digits = rep(4, 6),
+ align = c("l", rep("c", 5))), floating = FALSE,
+ caption.placement = "top",
+ sanitize.colnames.function = function(x) return(x))
+@
+\end{center}
+\end{table}
+
+Note for the record that the all the results presented in the tables
+are from ``one long run'' where long here took only
+<<label=time,echo=FALSE,results=tex>>=
+cat(out$time[1], "\n")
+@
+seconds (on whatever computer it was run on).
+
+\section{New Variance Estimation Functions}
+
+A new function \texttt{initseq} estimates variances in the Markov chain
+central limit theorem (CLT) following the methodology introduced by
+\citet[Section~3.3]{practical}. These methods only apply to scalar-valued
+functionals of
+reversible Markov chains, but the Markov chains produced by the \texttt{metrop}
+function satisfy this condition, even, as we shall see below, when batching
+is used.
+
+Rather than redo the Markov chains in the preceding material, we just look
+at a toy problem, an AR(1) time series, which can be simulated in one line
+of R. This is the example on the help page for \texttt{initseq}.
+<<x>>=
+n <- 2e4
+rho <- 0.99
+x <- arima.sim(model = list(ar = rho), n = n)
+@
+The time series \texttt{x} is a reversible Markov chain and trivially
+a scalar-valued functional of a Markov chain.
+
+Define
+\begin{equation} \label{eq:little}
+ \gamma_k = \cov(X_i, X_{i + k})
+\end{equation}
+where the covariances refer to the stationary Markov chain having the
+same transition probabilities as \texttt{x}. Then the variance in the CLT
+is
+$$
+ \sigma^2 = \gamma_0 + 2 \sum_{k = 1}^\infty \gamma_k
+$$
+\citep[Theorem~2.1]{practical}, that is,
+$$
+ \bar{x}_n \approx \text{Normal}\left(\mu, \frac{\sigma^2}{n}\right),
+$$
+where $\mu = E(X_i)$ is the quantity being estimated by MCMC (in this
+toy problem we know $\mu = 0$).
+
+Naive estimates of $\sigma^2$ obtained by plugging in empirical
+estimates of the gammas do not provide consistent estimation
+\citep[Section~3.1]{practical}. Thus the scheme implemented
+by the R function \texttt{initseq}. Define
+\begin{equation} \label{eq:big}
+ \Gamma_k = \gamma_{2 k} + \gamma_{2 k + 1}
+\end{equation}
+\citet[Theorem~3.1]{practical} says that $\Gamma_k$ considered as a function
+of $k$ is strictly positive, strictly decreasing, and strictly convex
+(provided we are, as stated above, working with a reversible Markov chain).
+Thus it makes sense to use estimators that use these properties.
+The estimators implemented by the R function \texttt{initseq} and
+described by \citet[Section~3.3]{practical} are conservative-consistent
+in the sense of Theorem~3.2 of that section.
+
+Figure~\ref{fig:gamma} (page~\pageref{fig:gamma})
+shows the time series plot made by the R statement
+<<label=figgamtoo,include=FALSE>>=
+out <- initseq(x)
+plot(seq(along = out$Gamma.pos) - 1, out$Gamma.pos,
+ xlab = "k", ylab = expression(Gamma[k]), type = "l")
+lines(seq(along = out$Gamma.dec) - 1, out$Gamma.dec, lty = "dotted")
+lines(seq(along = out$Gamma.con) - 1, out$Gamma.con, lty = "dashed")
+@
+\begin{figure}
+\begin{center}
+<<label=figgam,fig=TRUE,echo=FALSE>>=
+<<figgamtoo>>
+@
+\end{center}
+\caption{Plot ``Big Gamma'' defined by \eqref{eq:little} and \eqref{eq:big}.
+Solid line, initial positive sequence estimator.
+Dotted line, initial monotone sequence estimator.
+Dashed line, initial convex sequence estimator.}
+\label{fig:gamma}
+\end{figure}
+One can use whichever curve one chooses, but now that
+the \texttt{initseq} function makes the computation trivial, it makes
+sense to use the initial convex sequence.
+
+Of course, one is not interested in Figure~\ref{fig:gamma}, except
+perhaps when explaining the methodology. What is actually important
+is the estimate of $\sigma^2$, which is given by
+<<assvar>>=
+out$var.con
+(1 + rho) / (1 - rho) * 1 / (1 - rho^2)
+@
+where for comparison we have given the exact theoretical value of $\sigma^2$,
+which, of course, is never available in a non-toy problem.
+
+These initial sequence estimators seem, at first sight to be a competitor
+for the method of batch means. However, appearances can be deceiving.
+The two methods are complementary. The sequence of batch means is itself
+a scalar-valued functional of a reversible Markov chain. Hence the
+initial sequence estimators can be applied to it.
+<<batx>>=
+blen <- 5
+x.batch <- apply(matrix(x, nrow = blen), 2, mean)
+bout <- initseq(x.batch)
+@
+Because the batch length is too short, the variance of the batch means
+does not estimate $\sigma^2$. We must account for the autocorrelation
+of the batches, shown in Figure~\ref{fig:gambat}.
+<<label=figgambattoo,include=FALSE>>=
+plot(seq(along = bout$Gamma.con) - 1, bout$Gamma.con,
+ xlab = "k", ylab = expression(Gamma[k]), type = "l")
+@
+\begin{figure}
+\begin{center}
+<<label=figgambat,fig=TRUE,echo=FALSE>>=
+<<figgambattoo>>
+@
+\end{center}
+\caption{Plot ``Big Gamma'' defined by \eqref{eq:little} and \eqref{eq:big}
+for the sequence of batch means (batch length \Sexpr{blen}).
+Only initial convex sequence estimator is shown.}
+\label{fig:gambat}
+\end{figure}
+Because the the variance is proportional to one over the batch length,
+we need to multiply by the batch length to estimate the $\sigma^2$
+for the original series.
+<<compvar>>=
+out$var.con
+bout$var.con * blen
+@
+Another way to look at this is that the MCMC estimator of $\mu$ is
+either \texttt{mean(x)} or \texttt{mean(x.batch)}. And the variance
+must be divided by the sample size to give standard errors. So either
+<<ci-con>>=
+mean(x) + c(-1, 1) * qnorm(0.975) * sqrt(out$var.con / length(x))
+mean(x.batch) + c(-1, 1) * qnorm(0.975) * sqrt(bout$var.con / length(x.batch))
+@
+is an asymptotic 95\% confidence interval for $\mu$. Just divide by
+the relevant sample size.
+
+\begin{thebibliography}{}
+
+\bibitem[Gelman et al.(1996)Gelman, Roberts, and Gilks]{grg}
+Gelman, A., G.~O. Roberts, and W.~R. Gilks (1996).
+\newblock Efficient Metropolis jumping rules.
+\newblock In \emph{Bayesian Statistics, 5 (Alicante, 1994)}, pp.~599--607.
+ Oxford University Press.
+
+\bibitem[Geyer(1992)]{practical}
+Geyer, C.~J. (1992).
+\newblock Practical Markov chain Monte Carlo (with discussion).
+\newblock \emph{Statistical Science}, 7, 473--511.
+
+\bibitem[Geyer and Thompson(1995)]{geyer-temp}
+Geyer, C.~J. and E.~A. Thompson (1995).
+\newblock Annealing Markov chain Monte Carlo with applications to
+ ancestral inference.
+\newblock \emph{Journal of the American Statistical Association}, 90, 909--920.
+
+\end{thebibliography}
+
+\end{document}
diff --git a/inst/doc/demo.pdf b/inst/doc/demo.pdf
new file mode 100644
index 0000000..396d0f7
Binary files /dev/null and b/inst/doc/demo.pdf differ
diff --git a/inst/doc/metrop.pdf b/inst/doc/metrop.pdf
new file mode 100644
index 0000000..0dc647d
Binary files /dev/null and b/inst/doc/metrop.pdf differ
diff --git a/inst/doc/metrop.tex b/inst/doc/metrop.tex
new file mode 100644
index 0000000..b16ff58
--- /dev/null
+++ b/inst/doc/metrop.tex
@@ -0,0 +1,398 @@
+
+\documentclass{article}
+
+\usepackage{indentfirst}
+
+\begin{document}
+
+\title{An MCMC Package for R}
+\author{Charles J. Geyer}
+\maketitle
+
+\section{Introduction}
+
+This package is a simple first attempt at a sensible \emph{general}
+MCMC package. It doesn't do much yet. It only does ``normal random-walk''
+Metropolis for continuous distributions.
+No non-normal proposals. No Metropolis-Hastings or Metropolis-Hastings-Green.
+No discrete state. No dimension jumping. No simulated tempering.
+No perfect sampling. There's a lot left to do. Still, limited as it is,
+it does equilibrium distributions that no other R package does.
+
+Its basic idea is the following. Given an R function \verb at fred@ that
+calculates the unnormalized density of the desired equilibrium distribution
+of the Markov chain, or, better yet, \emph{log} unnormalized density,
+so we avoid overflow and underflow, the \verb at metrop@ function should
+generate a Markov chain having this stationary distribution.
+
+The package does not do any of the following.
+\begin{itemize}
+\item \textbf{Theory.} (What R package does?) It doesn't prove the
+Markov chain is irreducible or ergodic or positive recurrent or
+Harris recurrent or geometrically
+ergodic or uniformly ergodic or satisfies conditions for the central limit
+theorem.
+\item \textbf{Diagnostics.} There are no non-bogus Markov chain diagnostics
+(except for perfect sampling). This package doesn't do any bogus diagnostics
+(other R packages do them).
+\item \textbf{Calculus.} If the putative unnormalized density specified
+by \verb at fred@ is not integrable, then it does not specify an equilibrium
+distribution. But this package doesn't check that either.
+\end{itemize}
+
+Thus the only requirement the package has to satisfy is that given
+a function \verb at fred@ it correctly simulates a Markov chain that
+actually has \verb at fred@ as its equilibrium distribution
+(when \verb at fred@ actually does specify some equilibrium
+distribution)
+
+\section{Design Issues}
+
+\subsection{First Try}
+
+For a start we have a function with signature
+\begin{verbatim}
+metrop(lud, initial, niter, ...)
+\end{verbatim}
+such that when
+\begin{itemize}
+\item \verb at initial@ is a real vector, the initial state of the Markov
+chain,
+\item \verb at lud@ is a function, the log unnormalized density of the
+equilibrium distribution of the Markov chain,
+such that
+\begin{itemize}
+\item \verb at lud(initial, ...)@ works and produces a finite scalar value and
+\item \verb at lud(x, ...)@ works for any real vector \verb at x@
+having the same length as \verb at initial@ and all elements finite and
+and produces a scalar value that is finite or \verb at -Inf@,
+\end{itemize}
+\end{itemize}
+then the function produces an \verb at niter@ by \verb at length(initial)@ matrix
+whose rows are the iterations of the Markov chain.
+
+\subsubsection{Checks}
+
+If
+\begin{verbatim}
+logh <- lud(initial, ...)
+\end{verbatim}
+then \verb at is.finite(logh)@ is \verb at TRUE@.
+
+Moreover, if \verb at x@ is any vector such that
+\verb at length(x) == length(initial)@ and \verb at all(is.finite(x))@
+are \verb at TRUE@ and
+\begin{verbatim}
+logh <- lud(x, ...)
+\end{verbatim}
+then
+\begin{verbatim}
+is.finite(logh) | (logh == -Inf)
+\end{verbatim}
+is \verb at TRUE@.
+
+Points \verb at x@ having log unnormalized density \verb at -Inf@ have
+density zero (normalized or unnormalized, since a constant times zero is zero)
+hence cannot occur. Thus if
+\begin{verbatim}
+path <- metrop(fred, x, n, some, extra, arguments)
+\end{verbatim}
+then
+\begin{verbatim}
+all(is.finite(apply(path, 1, fred, some, extra, arguments)))
+\end{verbatim}
+is \verb at TRUE@.
+
+This is how we specify log unnormalized densities for distribution
+having support that is not all of Euclidean space. The value
+of the log unnormalized density off the support is \verb at -Inf@.
+
+Thus when coding a log unnormalized density, we should normally do
+something like
+\begin{verbatim}
+fred <- function(x, ...)
+{
+ if (! is.numeric(x))
+ stop("argument x not numeric")
+ if (length(x) != d)
+ stop("argument x wrong length")
+ if (! all(is.finite(x)))
+ stop("elements of argument x not all finite")
+ if (! is.in.the.support(x))
+ return(-Inf)
+ return(log.unnormalized.density(x))
+}
+\end{verbatim}
+where \verb at d@ is the dimension of the state space of the Markov chain
+(defined in the global environment or in the \verb at ...@ arguments),
+\verb at is.in.the.support(x)@ returns
+\verb at TRUE@ if \verb at x@ is in the support of the desired equilibrium
+distribution and \verb at FALSE@ otherwise and \verb at log.unnormalized.density(x)@
+calculates the log unnormalized density of the desired equilibrium
+distribution at the point \verb at x@, which
+is guaranteed to be finite because \verb at x@ is in the support if the
+this code is executed.
+
+Of course, you needn't actually have functions named
+\verb at is.in.the.support@ and \verb at log.unnormalized.density@.
+The point is that you use this logic. First you check
+whether \verb at x@ is in the support. If not return \verb at -Inf@.
+If it is, return a finite value. Do not crash. Do not return
+\verb at NA@, \verb at NaN@, or \verb at Inf@. If you do, then \verb at metrop@
+crashes, and it's your fault.
+
+Of course, a crash is no big deal. Lots of first efforts in R crash.
+You just fix the problem and retry. Error messages are your friends.
+
+\subsection{Proposal}
+
+We also need to specify the proposal distribution (the preceding stuff
+assumed some default proposal). This can be any multivariate normal
+distribution on the Euclidean space of dimension \verb at length(initial)@
+having mean zero. Thus it is specified by specifying its covariance
+matrix.
+
+But to avoid having to check whether the specified covariance
+matrix actually is a covariance matrix, we make the specification
+an arbitrary \verb at d@ by \verb at d@ matrix, call it \verb at scale@,
+where \verb at d@ is the dimension of the state space, specified by
+\verb at length(initial)@,
+and use the proposal \verb at x + scale %*% z@, where \verb at x@ is the
+current state and \verb at z@ is a standard normal random vector
+(``standard'' meaning its covariance matrix is the identity matrix).
+
+Thus we need to add this to the argument list of our function.
+It is now
+\begin{verbatim}
+metrop(lud, initial, niter, scale, ...)
+\end{verbatim}
+
+The covariance matrix specified by this is, of course,
+\verb at scale %*% t(scale)@. If you want the proposal to have covariance
+matrix \verb at melvin@, then specifying
+\verb at scale = t(chol(melvin))@ will do the job.
+(Of course, many other specifications will also do the job.)
+
+For convenience, we also allow \verb at scale@ to be a vector of
+length \verb at d@ and in this case take \verb at scale = sally@
+to mean the same thing as \verb at scale = diag(sally)@.
+
+For convenience, we also allow \verb at scale@ to be a vector of
+length 1 and in this case take \verb at scale = sally@
+to mean the same thing as \verb at scale = sally * diag(d)@
+where \verb at d@ is still the dimension of the state space
+\verb at length(initial)@.
+
+We can use this last convenience option to give \verb at scale@ a default
+\begin{verbatim}
+metrop(lud, initial, niter, scale = 1, ...)
+\end{verbatim}
+
+In order to tell what is sensible scaling, we need to return the
+acceptance rate (the proportion of proposals that are accepted).
+The only criterion known for choosing sensible scaling is to adjust
+so that the acceptance rate is about 20\%. Of course, that recommendation
+was derived for a specific toy model that is not very much like what
+people do in real MCMC applications, so 20\% is only a very rough guideline.
+But acceptance rate is all we know to use, so that's what we will output.
+
+Thus the result of \verb at metrop@, assuming we write it in R will be
+something like
+\begin{verbatim}
+return(structure(list(path = path, rate = rate),
+ class = "mcmc"))
+\end{verbatim}
+and if we write it in C will be whatever does the same job.
+
+\subsection{Output I}
+
+Generally we don't want \verb at path@ to be as described above.
+It may be way too big. We might have \verb at d@, the dimension of the
+state space $10^3$ or even larger and we might have \verb at niter@
+$10^7$ or even larger, the resulting \verb at path@ matrix would
+be $10^{10}$ doubles or $8 \times 10^{10}$ bytes. Too big to fit in
+my computer!
+
+Thus we facilitate subsampling and batching of the output.
+
+\subsubsection{Subsampling}
+
+If the Markov chain exhibits high autocorrelation, subsampling the
+chain may lose little information. (Most users way overdo the subsampling,
+but it's not the job of a computer program to keep users from overdoing
+things). Thus we add an argument \verb at nspac@ that specifies subsampling.
+Only every \verb at nspac@ iterate is output.
+
+\subsubsection{Batching}
+
+The method of batch means uses ``batches'' which are sums over consecutive
+blocks of output. For most purposes batching is better than subsampling.
+It loses no information while reducing the amount of output even more
+than subsampling. So we introduce arguments \verb at nbatch@ specifying
+the number of batches and \verb at blen@ specifying the length of the batches.
+
+Our function now has signature
+\begin{verbatim}
+metrop(lud, initial, nbatch, blen = 1, nspac = 1, scale = 1,
+ ...)
+\end{verbatim}
+Note that the argument \verb at niter@ formerly present has vanished.
+The number of iterations that will now be done is
+\verb at nbatch * blen * nspac at . If we accept the defaults
+\verb at blen = 1@ and \verb at nspac = 1@, then \verb at nbatch@ is the same
+as the former argument \verb at niter@. Otherwise, it is quite different.
+
+\subsection{Output II}
+
+The preceding section takes care of of the problem of \verb at niter@ being
+too big. This section deals with the dimension of the state space being
+too big. When the dimension of the state space is large, we generally
+do not want to output the whole state, but only some function of the
+state.
+
+Thus we need another function (besides \verb at lud@) to produce the
+output vector. Call it \verb at outfun@. The requirements on \verb at outfun@
+are
+\begin{itemize}
+\item If \verb at is.finite(lud(x, ...))@, then \verb at outfun(x, ...)@
+works (it does not crash) and produces a vector having all elements finite
+and always of the same length (say \verb at k@).
+\end{itemize}
+\verb at outfun@ will never be called in any other situation
+(that is, never when \verb at x@ is not in the support of the equilibrium
+distribution).
+
+Now we can describe the \verb at path@ component of the output.
+We'll use a little math here. Write $L$ for \verb at blen@ and
+$M$ for \verb at nspac@. Write $x_i$ for the $i$-th iterate of the
+Markov chain, and write $g$ for \verb at outfun@. Then \verb at path[@$j$\verb@, ]@
+is the vector
+$$
+ \frac{1}{L} \sum_{i = 1}^L g(x_{M [L (j - 1) + i]})
+$$
+
+For convenience, we also allow \verb at outfun@ to be a logical vector of
+length \verb at d@ or an integer vector having elements in \verb at 1:d@
+or in \verb at -(1:d)@ and in this case take \verb at outfun = fred@
+to mean the same thing as \verb at outfun = function(x) x[fred]@.
+
+For convenience, we also allow \verb at outfun@ to be missing
+take this to mean the same thing as \verb at outfun = function(x) x@,
+that is, the ``outfun'' is the identity function and we are back
+to outputting the entire state.
+
+Our function now has signature
+\begin{verbatim}
+metrop(lud, initial, nbatch, blen = 1, nspac = 1, scale = 1,
+ outfun, ...)
+\end{verbatim}
+
+\subsection{Restarting}
+
+It should be possible to restart the Markov chain and get exactly the
+same results. It should be possible to continue the Markov chain and
+get exactly the same results. Thus we need to save the initial and
+final state of the Markov chain
+and the initial and final state of the random number generator
+(the R object \verb at .Random.seed@).
+
+Thus the result of \verb at metrop@ now looks like
+\begin{verbatim}
+return(structure(list(path = path, rate = rate,
+ initial = initial, final = final,
+ initial.seed = iseed, final.seed = .Random.seed),
+ class = "mcmc"))
+\end{verbatim}
+
+We also need to add arguments to \verb at metrop@. It now has signature
+\begin{verbatim}
+metrop(lud, initial, nbatch, blen = 1, nspac = 1, scale = 1,
+ outfun, object, restart = FALSE, ...)
+\end{verbatim}
+Here \verb at object@ is an R object of class \verb@"mcmc"@, the output
+a previous call to \verb at metrop@, from which we take either initial
+or final state and seed depending the value of \verb at restart@.
+
+While we are at it, it is convenient to allow any or all of the other
+arguments to be missing if \verb at object@ is supplied. We just take
+the argument from \verb at object@. Thus we can make calls like
+\begin{verbatim}
+out <- metrop(fred, x, 1e3, scale = 4, blen = 3)
+out.too <- metrop(object = out, nbatch = 1e4)
+\end{verbatim}
+
+Woof! I now see (how embarrasing) after four earlier versions how to
+use the R class system to make this convenient. We have three functions.
+\begin{verbatim}
+metrop.default <- function(o, ...)
+UseMethod("metrop")
+
+metrop.mcmc <- function(o, initial, nbatch, blen = 1,
+ nspac = 1, scale = 1, outfun, restart = FALSE, ...)
+{
+ if (missing(nbatch)) nbatch <- o$nbatch
+ if (missing(blen)) blen <- o$blen
+ if (missing(nspac)) nspac <- o$nspac
+ if (missing(scale)) scale <- o$scale
+ if (missing(outfun)) outfun <- o$outfun
+
+ if (restart) {
+ .Random.seed <- o$final.seed
+ return(metrop.function(o$lud, o$final, nbatch, blen,
+ nspac, scale, outfun))
+ } else {
+ .Random.seed <- o$initial.seed
+ return(metrop.function(o$lud, o$initial, nbatch, blen,
+ nspac, scale, outfun))
+ }
+}
+
+metrop.function <- function(o, initial, nbatch, blen = 1,
+ nspac = 1, scale = 1, outfun, restart = FALSE, ...)
+{
+ if (! exists(".Random.seed")) runif(1)
+ initial.seed <- .Random.seed
+ func1 <- function(state) o(state, ...)
+ func2 <- function(state) outfun(state, ...)
+ .Call("metrop", func1, initial, nbatch, blen,
+ nspac, scale, func2, environment(fun = func1),
+ environment(fun = func2))
+}
+\end{verbatim}
+Note that \verb at restart@ is ignored in \verb at metrop.function@.
+We can't ``restart'' when we have no saved state in an \verb@"mcmc"@
+object.
+
+Note also that our \verb@"mcmc"@ objects must now store a lot more stuff
+(and more to come in the next section).
+
+\subsection{Testing and Debugging}
+
+It is nearly impossible to test or debug a random algorithm
+(any Monte Carlo) from looking at its designed (useful to the user)
+output. In order to do any serious testing or debugging, it is necessary
+to look under the hood. For the Metropolis algorithm, we need to look
+at the current state, the proposal, the log odds ratio, the uniform
+random variate (if any) used in the Metropolis rejection, and the
+result (accept or reject) of the Metropolis rejection.
+
+Hence we need to add one final argument \verb at debug = FALSE@ to our
+functions and a lot of debugging output to the result.
+
+In debugging a Metropolis (etc.)\ algorithm there is a very important
+principle. Debugging should use Markov chain theory! Just enlarge
+the state space of the Markov chain to include
+\begin{itemize}
+\item the proposal (vector),
+\item details of the calculation of the Metropolis-Hastings-Green ratio
+ (for Metropolis this is just the log unnormalized density at the
+ current state and proposal, for others it includes proposal densities)
+ and the calculated ratio,
+\item the uniform random number (if any) used in the decision, and
+\item the decision (\verb at TRUE@ or \verb at FALSE@) in the Metropolis rejection.
+\end{itemize}
+With all that it is easy to tell whether the algorithm is doing the Right
+Thing. Without all that, it's nearly impossible.
+
+\end{document}
+
diff --git a/inst/doc/morph.R b/inst/doc/morph.R
new file mode 100644
index 0000000..0eacd9f
--- /dev/null
+++ b/inst/doc/morph.R
@@ -0,0 +1,392 @@
+### R code from vignette source 'morph.Rnw'
+### Encoding: UTF-8
+
+###################################################
+### code chunk number 1: foo
+###################################################
+options(keep.source = TRUE, width = 60)
+foo <- packageDescription("mcmc")
+
+
+###################################################
+### code chunk number 2: morph.Rnw:98-100
+###################################################
+library(mcmc)
+h2 <- morph(b=1)
+
+
+###################################################
+### code chunk number 3: morph.Rnw:105-107
+###################################################
+lud <- function(x) dt(x, df=3, log=TRUE)
+lud.induced <- h2$lud(lud)
+
+
+###################################################
+### code chunk number 4: morph.Rnw:110-114
+###################################################
+curve(exp(Vectorize(lud.induced)(x)), from = -3, to = 3, lty = 2,
+ xlab = "t", ylab = "density")
+curve(exp(lud(x)), add = TRUE)
+legend("topright", c("t density", "induced density"), lty=1:2)
+
+
+###################################################
+### code chunk number 5: morph.Rnw:123-129
+###################################################
+lud(1:4)
+lud(1)
+foo <- try(lud.induced(1:4))
+class(foo)
+cat(foo, "\n")
+lud.induced(1)
+
+
+###################################################
+### code chunk number 6: set-seed
+###################################################
+set.seed(42)
+
+
+###################################################
+### code chunk number 7: morph.Rnw:146-147
+###################################################
+out <- morph.metrop(lud, 0, blen=100, nbatch=100, morph=morph(b=1))
+
+
+###################################################
+### code chunk number 8: morph.Rnw:153-155
+###################################################
+# adjust scale to find a roughly 20% acceptance rate
+out$accept
+
+
+###################################################
+### code chunk number 9: morph.Rnw:161-163
+###################################################
+out <- morph.metrop(out, scale=4)
+out$accept
+
+
+###################################################
+### code chunk number 10: fig0too
+###################################################
+acf(out$batch)
+
+
+###################################################
+### code chunk number 11: fig0
+###################################################
+acf(out$batch)
+
+
+###################################################
+### code chunk number 12: morph.Rnw:187-188
+###################################################
+t.test(out$batch)
+
+
+###################################################
+### code chunk number 13: morph.Rnw:191-193
+###################################################
+colMeans(out$batch)
+apply(out$batch, 2, sd) / sqrt(out$nbatch)
+
+
+###################################################
+### code chunk number 14: unmorph-metrop-adjust
+###################################################
+out.unmorph <- metrop(lud, 0, blen=1000, nbatch=1)
+out.unmorph$accept
+out.unmorph <- metrop(out.unmorph, scale=4)
+out.unmorph$accept
+out.unmorph <- metrop(out.unmorph, scale=6)
+out.unmorph$accept
+
+
+###################################################
+### code chunk number 15: unmorph-metrop-t-long-run
+###################################################
+lout <- suppressWarnings(try(load("morph1.rda"), silent = TRUE))
+if (inherits(lout, "try-error")) {
+ out.unmorph <- metrop(out.unmorph, blen = 1e5, nbatch = 1e3)
+ save(out.unmorph, file = "morph1.rda")
+} else {
+ .Random.seed <- out.unmorph$final.seed
+}
+out.unmorph$accept
+
+
+###################################################
+### code chunk number 16: fig4too
+###################################################
+foo <- as.vector(out.unmorph$batch)
+qqnorm(foo)
+qqline(foo)
+
+
+###################################################
+### code chunk number 17: fig4
+###################################################
+foo <- as.vector(out.unmorph$batch)
+qqnorm(foo)
+qqline(foo)
+
+
+###################################################
+### code chunk number 18: shapiro-wilk
+###################################################
+shapiro.test(foo)
+
+
+###################################################
+### code chunk number 19: morph-metrop-t-long-run
+###################################################
+lout <- suppressWarnings(try(load("morph2.rda"), silent = TRUE))
+if (inherits(lout, "try-error")) {
+ out.morph <- morph.metrop(out, blen = 1e5, nbatch = 1e3)
+ save(out.morph, file = "morph2.rda")
+} else {
+ .Random.seed <- out.morph$final.seed
+}
+out.morph$accept
+
+
+###################################################
+### code chunk number 20: fig5too
+###################################################
+foo <- as.vector(out.morph$batch)
+qqnorm(foo)
+qqline(foo)
+
+
+###################################################
+### code chunk number 21: fig5
+###################################################
+foo <- as.vector(out.morph$batch)
+qqnorm(foo)
+qqline(foo)
+
+
+###################################################
+### code chunk number 22: shapiro-wilk
+###################################################
+shapiro.test(foo)
+
+
+###################################################
+### code chunk number 23: def-posterior-binom
+###################################################
+lud.binom <- function(beta, M, x, n) {
+ MB <- M %*% beta
+ sum(x * MB) - sum(n * log(1 + exp(MB)))
+}
+
+
+###################################################
+### code chunk number 24: convert
+###################################################
+dat <- as.data.frame(UCBAdmissions)
+dat.split <- split(dat, dat$Admit)
+dat.split <- lapply(dat.split,
+ function(d) {
+ val <- as.character(d$Admit[1])
+ d["Admit"] <- NULL
+ names(d)[names(d) == "Freq"] <- val
+ d
+ })
+dat <- merge(dat.split[[1]], dat.split[[2]])
+
+
+###################################################
+### code chunk number 25: build-model-matrix
+###################################################
+formula <- cbind(Admitted, Rejected) ~ (Gender + Dept)^2
+mf <- model.frame(formula, dat)
+M <- model.matrix(formula, mf)
+
+
+###################################################
+### code chunk number 26: morph.Rnw:396-398
+###################################################
+xi <- 0.30
+nu <- 5
+
+
+###################################################
+### code chunk number 27: lud-binom
+###################################################
+lud.berkeley <- function(B)
+ lud.binom(B, M, dat$Admitted + xi * nu, dat$Admitted + dat$Rejected + nu)
+
+
+###################################################
+### code chunk number 28: morph.Rnw:410-419
+###################################################
+berkeley.out <- morph.metrop(lud.berkeley, rep(0, ncol(M)), blen=1000,
+ nbatch=1, scale=0.1, morph=morph(p=3))
+berkeley.out$accept
+berkeley.out <- morph.metrop(berkeley.out, scale=0.05)
+berkeley.out$accept
+berkeley.out <- morph.metrop(berkeley.out, scale=0.02)
+berkeley.out$accept
+berkeley.out <- morph.metrop(berkeley.out, blen=10000)
+berkeley.out$accept
+
+
+###################################################
+### code chunk number 29: morph.Rnw:422-423
+###################################################
+berkeley.out <- morph.metrop(berkeley.out, blen=1, nbatch=100000)
+
+
+###################################################
+### code chunk number 30: morph.Rnw:428-433
+###################################################
+beta <- setNames(colMeans(berkeley.out$batch), colnames(M))
+MB <- M %*% beta
+dat$p <- dat$Admitted / (dat$Admitted + dat$Rejected)
+dat$p.post <- exp(MB) / (1 + exp(MB))
+dat
+
+
+###################################################
+### code chunk number 31: calculate-posterior-probabilities
+###################################################
+posterior.probabilities <-
+ t(apply(berkeley.out$batch, 1,
+ function(r) {
+ eMB <- exp(M %*% r)
+ eMB / (1 + eMB)
+ }))
+quants <- apply(posterior.probabilities, 2, quantile, prob=c(0.05, 0.95))
+quants.str <- matrix(apply(quants, 2,
+ function(r) sprintf("[%0.2f, %0.2f]", r[1], r[2])),
+ nrow=2, byrow=TRUE)
+
+
+
+###################################################
+### code chunk number 32: fig1
+###################################################
+x <- (0:5) * 2 + 1
+plot(x[c(1, 6)] + 0.5 * c(-1, 1), 0:1,
+ xlab="Department", ylab="Probability", xaxt="n", type="n")
+axis(1, x, LETTERS[1:6])
+for(i in 1:6) {
+ lines((x[i]-0.25)*c(1, 1), quants[1:2, i], lwd=2, col="gray")
+ lines((x[i] + 0.25) * c(1, 1), quants[1:2, i + 6], lwd=2, col="gray")
+ points(x[i] + 0.25 * c(-1, 1), dat$p.post[i + c(0, 6)], pch=c("F", "M"))
+}
+
+
+###################################################
+### code chunk number 33: cauchy-data
+###################################################
+n <- 15
+mu0 <- 50
+sigma0 <- 10
+x <- rcauchy(n, mu0, sigma0)
+round(sort(x), 1)
+
+
+###################################################
+### code chunk number 34: cauchy-log-unnormalized-posterior
+###################################################
+lup <- function(theta) {
+ if (any(is.na(theta)))
+ stop("NA or NaN in input to log unnormalized density function")
+ mu <- theta[1]
+ sigma <- theta[2]
+ if (sigma <= 0) return(-Inf)
+ if (any(! is.finite(theta))) return(-Inf)
+ result <- sum(dcauchy(x, mu, sigma, log = TRUE)) - log(sigma)
+ if (! is.finite(result)) {
+ warning(paste("Oops! mu = ", mu, "and sigma =", sigma))
+ }
+ return(result)
+}
+
+
+###################################################
+### code chunk number 35: cauchy-robust
+###################################################
+mu.twiddle <- median(x)
+sigma.twiddle <- IQR(x)
+c(mu.twiddle, sigma.twiddle)
+
+
+###################################################
+### code chunk number 36: cauchy-posterior-mode
+###################################################
+oout <- optim(c(mu.twiddle, sigma.twiddle), lup,
+ control = list(fnscale = -1), hessian = TRUE)
+stopifnot(oout$convergence == 0)
+mu.hat <- oout$par[1]
+sigma.hat <- oout$par[2]
+c(mu.hat, sigma.hat)
+
+
+###################################################
+### code chunk number 37: cauchy-hessian
+###################################################
+oout$hessian
+
+
+###################################################
+### code chunk number 38: cauchy-se
+###################################################
+sqrt(- 1 / diag(oout$hessian))
+
+
+###################################################
+### code chunk number 39: cauchy-doit
+###################################################
+moo <- morph(b = 0.5, r = 7, center = c(mu.hat, sigma.hat))
+mout <- morph.metrop(lup, c(mu.hat, sigma.hat), 1e4,
+ scale = 3, morph = moo)
+mout$accept
+mout <- morph.metrop(mout)
+
+
+###################################################
+### code chunk number 40: cfig1too
+###################################################
+acf(mout$batch)
+
+
+###################################################
+### code chunk number 41: cfig1
+###################################################
+acf(mout$batch)
+
+
+###################################################
+### code chunk number 42: cfig2too
+###################################################
+mu <- mout$batch[ , 1]
+i <- seq(1, mout$nbatch, by = 15)
+out.sub <- density(mu[i])
+out <- density(mu, bw = out.sub$bw)
+plot(out)
+
+
+###################################################
+### code chunk number 43: cfig2
+###################################################
+mu <- mout$batch[ , 1]
+i <- seq(1, mout$nbatch, by = 15)
+out.sub <- density(mu[i])
+out <- density(mu, bw = out.sub$bw)
+plot(out)
+
+
+###################################################
+### code chunk number 44: cfig3
+###################################################
+sigma <- mout$batch[ , 2]
+out.sub <- density(sigma[i])
+out <- density(sigma, bw = out.sub$bw)
+plot(out)
+
+
diff --git a/inst/doc/morph.Rnw b/inst/doc/morph.Rnw
new file mode 100644
index 0000000..e6e403c
--- /dev/null
+++ b/inst/doc/morph.Rnw
@@ -0,0 +1,703 @@
+\documentclass{article}
+
+\usepackage{natbib}
+\usepackage{graphics}
+\usepackage{amsmath,amssymb}
+\usepackage{indentfirst}
+\usepackage[utf8]{inputenc}
+\usepackage[tableposition=top]{caption}
+\usepackage{url}
+
+\DeclareMathOperator{\var}{var}
+\DeclareMathOperator{\cov}{cov}
+\DeclareMathOperator{\E}{E}
+\newcommand{\inner}[1]{\langle #1 \rangle}
+
+% \VignetteIndexEntry{MCMC Morph Example}
+
+\begin{document}
+
+<<foo,include=FALSE,echo=FALSE>>=
+options(keep.source = TRUE, width = 60)
+foo <- packageDescription("mcmc")
+@
+
+\title{Morphometric MCMC (mcmc Package Ver.~\Sexpr{foo$Version})}
+% $ (Just to make emacs syntax highlighting work properly)
+\author{Leif T. Johnson \and Charles J. Geyer}
+\maketitle
+
+\section{Overview}
+
+This is an example how to use morphometric Markov chains as implemented in
+the \verb at mcmc@ package in R.
+
+Let $X$ be an $\mathbb{R}^k$ valued random variable with probability density
+function, $f_X$. Let $g$ be a diffeomorphism, and $Y=g(X)$. Then the
+probability density function of $Y$, $f_Y$ is given by
+\begin{equation}\label{eq:def-fy}
+ f_Y(y) = f_X\bigl(g^{-1}(y)\bigr) \det\bigl( \nabla g^{-1}(y) \bigr).
+\end{equation}
+Since $g$ is a diffeomorphism, we can draw inference about $X$ from information
+about $Y$ (and vice versa).
+
+It is not unusual for $f_X$ to either be known only up to a normalizing
+constant, or to be analytically intractable in other ways --- such as
+being high dimensional.
+A common solution to this problem is to use Markov chain
+Monte Carlo (MCMC) methods to learn about $f_X$.
+
+When using MCMC, a primary concern of the practitioner should be the question
+``Does the Markov chain converge fast enough to be useful?'' One very useful
+convergence rate is called \emph{geometrically ergodic}
+\citep[Chapter~1]{johnson-thesis}.
+
+The \texttt{mcmc} package implements the Metropolis random-walk algorithm for
+arbitrary log unnormalized probability densities. But the Metropolis
+random-walk algorithm does not always perform well. As is demonstrated in
+\citet{johnson-geyer}, for $f_X$ and $f_Y$ related by diffeomorphism as in
+\eqref{eq:def-fy}, a Metropolis random-walk for $f_Y$ can be geometrically
+ergodic
+even though a Metropolis random-walk for $f_X$ is not.
+Since the transformation is
+one-to-one, inference about $f_X$ can be drawn from the Markov chain for $f_Y$.
+
+The \texttt{morph.metrop} and \texttt{morph} functions in the \texttt{mcmc}
+package provide this functionality, and this vignette gives a demonstration
+on how to use them.
+
+\section{T Distribution} \label{sec:toy}
+
+We start with a univariate example, which is a Student $t$ distribution
+with three degrees of freedom.
+Of course, one doesn't need MCMC to simulate this distribution
+(the R function \texttt{rt} does that), so this is just a toy problem.
+But it does illustrate some aspects of using variable transformation.
+
+A necessary condition for geometric ergodicity of a random-walk Metropolis
+algorithm is that the target density $\pi$ have a moment generating function
+\citep{jarner-tweedie}.
+For a univariate target density, which we have in this section,
+a sufficient condition for geometric ergodicity of a random-walk Metropolis
+algorithm is that the target density $\pi$ be exponentially light
+\citet{mengersen-tweedie}.
+Thus if we do not use variable transformation,
+the Markov chain simulated by the \texttt{metrop} function will not
+be geometrically ergodic.
+\citet[Example 4.2]{johnson-geyer} show that a $t$ distribution is
+sub-exponentially light. Hence using the transformations
+described in their Corollaries~1 and~2 will induce a target density
+$\pi_\gamma$ for which a Metropolis random-walk will be geometrically
+ergodic.
+using the transformation described as $h_2$ in
+\citet[Corollary~2]{johnson-geyer} will induce a target density for which a
+Metropolis random-walk will be geometrically ergodic.
+
+Passing a positive value for \texttt{b} to \texttt{morph} function will
+create the aforementioned transformation, $h_2$. It's as simple as
+<<>>=
+library(mcmc)
+h2 <- morph(b=1)
+@
+We can now see the induced density. Note that \texttt{morph} works for
+log unnormalized densities, so we need exponentiate the induced density to
+plot it on the usual scale.
+<<>>=
+lud <- function(x) dt(x, df=3, log=TRUE)
+lud.induced <- h2$lud(lud)
+@
+We can plot the two densities,
+<<fig=TRUE>>=
+curve(exp(Vectorize(lud.induced)(x)), from = -3, to = 3, lty = 2,
+ xlab = "t", ylab = "density")
+curve(exp(lud(x)), add = TRUE)
+legend("topright", c("t density", "induced density"), lty=1:2)
+@
+
+The \texttt{Vectorize} in this example is necessary because
+the function \texttt{lud.induced} is not vectorized.
+Instead, it treats any vector passed as a single input, which
+is rescaled (using the specified diffeomorphism) and passed to
+\texttt{lud}. Compare the behavior of \texttt{lud} and
+\texttt{lud.induced} in the following example.
+<<>>=
+lud(1:4)
+lud(1)
+foo <- try(lud.induced(1:4))
+class(foo)
+cat(foo, "\n")
+lud.induced(1)
+@
+Because the function \texttt{dt} is vectorized, the function \texttt{lud}
+is also vectorized, mapping vectors to vectors,
+whereas the function \texttt{lud.induced} is not vectorized,
+mapping vectors to scalars.
+
+Before we start using random numbers, we set the seed of the random number
+generator so this document always produces the same results.
+<<set-seed>>=
+set.seed(42)
+@
+To change the results, change the seed or delete the \texttt{set.seed}
+statement.
+
+Running a Markov chain for the induced density is done with
+\texttt{morph.metrop}.
+<<>>=
+out <- morph.metrop(lud, 0, blen=100, nbatch=100, morph=morph(b=1))
+@
+The content of \texttt{out\$batch} is on the scale of used by
+\texttt{lud}. Once the transformation has been set, no adjustment is
+needed (unless you want to change transformations). We start by adjusting
+the scale.
+<<>>=
+# adjust scale to find a roughly 20% acceptance rate
+out$accept
+@
+An acceptance rate of \Sexpr{round(100 * out$accept, 1)}\%
+%$ to fix emacs highlighting
+is probably too high. By increasing the scale of the proposal distribution
+we can bring it down towards 20\%.
+<<>>=
+out <- morph.metrop(out, scale=4)
+out$accept
+@
+We now use this Markov chain to estimate the expectation of the target
+distribution.
+But first we need to check whether our batch length is good.
+The following code
+<<label=fig0too,include=FALSE>>=
+acf(out$batch)
+@
+makes the autocorrelation plot (Figure~\ref{fig:fig0}).
+\begin{figure}
+\begin{center}
+<<label=fig0,fig=TRUE,echo=FALSE>>=
+<<fig0too>>
+@
+\end{center}
+\caption{Autocorrelation plot for the sequence of batch means.}
+\label{fig:fig0}
+\end{figure}
+It looks like there is no significant autocorrelation among the batches
+so the following produces a valid confidence interval for the true
+unknown mean of the target distribution (since this is a toy problem
+we actually know the true ``unknown'' mean is zero, but we pretend we
+don't know that for the purposes of the toy problem)
+<<>>=
+t.test(out$batch)
+@
+If we want a point estimate and a Monte Carlo standard error, those are
+<<>>=
+colMeans(out$batch)
+apply(out$batch, 2, sd) / sqrt(out$nbatch)
+@
+If a shorter confidence interval is desired, the Markov chain can be run
+longer (increase either the number of batches or the batch length, or both).
+
+Note that when calculating our estimate and the Monte Carlo standard error
+we are not concerned with what was happening on the transformed scale. The
+\texttt{morph.metrop} function seamlessly does this for us.
+
+\subsection{Comparison of Morphed and Unmorphed}
+
+To show the utility of the transformation, we will study the behavior
+of the Markov chain with and without the transformation for the same
+problem as in the preceding section.
+We will consider two different estimation methods.
+\begin{enumerate}
+\item \label{enum:rw} Estimate the mean of the target distribution
+ using a random-walk Metropolis algorithm implemented by the \texttt{metrop}
+ function. \citet{jarner-roberts} demonstrate that a central limit
+ theorem does not hold for these estimates.
+\item \label{enum:rw-induced} Estimate the mean of the target distribution
+ using a random-walk Metropolis algorithm implemented by the
+ \texttt{morph.metrop} function with argument \texttt{morph = morph(b=1)}.
+ \citet{johnson-geyer} demonstrate that a central limit
+ theorem does hold for these estimates.
+\end{enumerate}
+
+For the former, we need to adjust the scale.
+<<unmorph-metrop-adjust>>=
+out.unmorph <- metrop(lud, 0, blen=1000, nbatch=1)
+out.unmorph$accept
+out.unmorph <- metrop(out.unmorph, scale=4)
+out.unmorph$accept
+out.unmorph <- metrop(out.unmorph, scale=6)
+out.unmorph$accept
+@
+A scale of 6 appears to be about right. Now we do a long run for
+this sampler.
+Because this run takes longer than CRAN vingettes are supposed to
+take, we save the results to a file
+and load the results from this file if it already exists.
+<<unmorph-metrop-t-long-run>>=
+lout <- suppressWarnings(try(load("morph1.rda"), silent = TRUE))
+if (inherits(lout, "try-error")) {
+ out.unmorph <- metrop(out.unmorph, blen = 1e5, nbatch = 1e3)
+ save(out.unmorph, file = "morph1.rda")
+} else {
+ .Random.seed <- out.unmorph$final.seed
+}
+out.unmorph$accept
+@
+
+Let's look at the distribution of batch means.
+The following code
+<<label=fig4too,include=FALSE>>=
+foo <- as.vector(out.unmorph$batch)
+qqnorm(foo)
+qqline(foo)
+@
+makes a Q-Q plot of the batch means (Figure~\ref{fig:fig4}).
+\begin{figure}
+\begin{center}
+<<label=fig4,fig=TRUE,echo=FALSE>>=
+<<fig4too>>
+@
+\end{center}
+\caption{Q-Q plot of batch means (batch length \Sexpr{out.unmorph$blen})
+for the unmorphed chain.}
+\label{fig:fig4}
+\end{figure}
+We see bad behavior of the unmorphed chain. These batch means
+(or at least some batch means for sufficiently long batch length) should
+look normally distributed, and these don't. Not even close.
+We do a formal test just to check our interpretation of the plot
+<<shapiro-wilk>>=
+shapiro.test(foo)
+@
+
+Now for comparison, we check the morphed chain.
+<<morph-metrop-t-long-run>>=
+lout <- suppressWarnings(try(load("morph2.rda"), silent = TRUE))
+if (inherits(lout, "try-error")) {
+ out.morph <- morph.metrop(out, blen = 1e5, nbatch = 1e3)
+ save(out.morph, file = "morph2.rda")
+} else {
+ .Random.seed <- out.morph$final.seed
+}
+out.morph$accept
+@
+
+The following code
+<<label=fig5too,include=FALSE>>=
+foo <- as.vector(out.morph$batch)
+qqnorm(foo)
+qqline(foo)
+@
+makes a Q-Q plot of the batch means (Figure~\ref{fig:fig5}).
+\begin{figure}
+\begin{center}
+<<label=fig5,fig=TRUE,echo=FALSE>>=
+<<fig5too>>
+@
+\end{center}
+\caption{Q-Q plot of batch means (batch length \Sexpr{out.unmorph$blen})
+for the morphed chain.}
+\label{fig:fig5}
+\end{figure}
+We see good behavior of the morphed chain. These batch means do
+look normally distributed.
+We do a formal test just to check our interpretation of the plot
+<<shapiro-wilk>>=
+shapiro.test(foo)
+@
+
+\section{Binomial Distribution with a Conjugate Prior}
+
+We demonstrate a morphometric Markov chain using the \texttt{UCBAdmisions}
+data set included in \texttt{R}, (use \texttt{help(UCBAdmissions)} to see
+details of this data set). We will model the probability of a student
+being admitted or rejected, using the sex of the student and the department
+that the student applied to as predictor variables. For our prior, we
+naively assume that 30\% of all students are admitted, independent of sex
+or department. As this is a naive prior, we will only add 5 students to
+each gender-department combination. This will not give the prior much
+weight, most of the information in the posterior distribution will be from
+the data.
+
+If we have $L$ observations from a multinomial distribution, then using a
+multinomial logit-link, with model matrices $M^1,\dots,M^L$, regression
+parameter $\beta$, observed counts $Y^1,\dots,Y^N$ with observed sample
+sizes $N^1,\dots,N^L$ and prior probabilities $\xi^1, \dots, \xi^L$ and
+prior ``sample sizes'' $\nu^1,\dots,\nu^L$ then the posterior distribution
+of $\beta$ is given by \citep[Sec. 5.1.2]{johnson-thesis}
+\begin{equation}\label{eq:mult-post-conj-complicated}
+\pi(\beta|y,n,\xi,\nu) \propto \exp\biggl\{ \sum_{l=1}^L \inner{y^l + \xi^l
+ \nu^l, M^l \beta} - (n^l + \nu^l) \log\bigl(
+ \sum_j e^{M_{j\cdot} \beta} \bigr) \biggr\}
+\end{equation}
+where $\inner{a, b}$ denotes the usual inner product between vectors $a$
+and $b$. For our application, we can simplify this in two ways.
+
+First, we use the posterior counts instead of the sum of the prior and data
+counts, i.e. use $y^{*l} = y^l + \xi^l \nu^l$ and $n^{*l} = n^l + \nu^l$.
+
+Second, to avoid having a direction of recession in $\pi(\beta|\cdot)$, we
+need to fix the elements of $\beta$ that correspond with one of the
+response categories. Since we are going to fitting a binomial response, if
+we set these elements of $\beta$ to be $0$, we may then replace the
+sequence of model matrices with a single model matrix; $M$ instead of
+$M^1,\dots,M^L$. The $l$-th row of $M$ will correspond to $M^l$. Label
+the two response categories $A$ and $B$. Without loss of generality, we
+will fix the elements of $\beta$ corresponding to category $B$ to 0.
+
+Let $x_1,\dots,x_L$ represent the posterior counts of category $A$, and
+$\beta^*$ represent the corresponding elements of $\beta$ --- these are the
+elements of $\beta$ we did not fix as 0. The meaning of
+$n^{*1},\dots,n^{*L}$ is unchanged. Then our simplified unnormalized
+posterior density is
+\begin{equation}\label{eq:simplified-posterior}
+ \pi(\beta|x,n^*) \propto
+ \exp\biggl\{
+ \inner{x, M \beta^*}
+ -
+ \sum_{l=1}^L n^{*l} \log\bigl(1 + e^{(M \beta^*)_l}\bigr)
+ \biggr\}.
+\end{equation}
+This can be computed with a very simple \texttt{R} function, we implement
+it in log form.
+<<def-posterior-binom>>=
+lud.binom <- function(beta, M, x, n) {
+ MB <- M %*% beta
+ sum(x * MB) - sum(n * log(1 + exp(MB)))
+}
+@
+
+Now that we have a function to calculate a log-unnormalized posterior
+density, we can run the Markov chain. To that, we need the model matrix.
+First we convert the \texttt{UCAdmissions} data to a \texttt{data.frame}.
+<<convert>>=
+dat <- as.data.frame(UCBAdmissions)
+dat.split <- split(dat, dat$Admit)
+dat.split <- lapply(dat.split,
+ function(d) {
+ val <- as.character(d$Admit[1])
+ d["Admit"] <- NULL
+ names(d)[names(d) == "Freq"] <- val
+ d
+ })
+dat <- merge(dat.split[[1]], dat.split[[2]])
+@
+
+Next we build the model matrix. Our model specification allows for an
+interaction between gender and department, even though our prior assumes
+that they are independent.
+<<build-model-matrix>>=
+formula <- cbind(Admitted, Rejected) ~ (Gender + Dept)^2
+mf <- model.frame(formula, dat)
+M <- model.matrix(formula, mf)
+@
+
+As stated above, we will take $\nu = 5$ and $\xi=0.30$. That is, we will
+add 5 students to each gender-department combination, where each
+combination has a 30\% acceptance rate.
+<<>>=
+xi <- 0.30
+nu <- 5
+@
+
+<<lud-binom>>=
+lud.berkeley <- function(B)
+ lud.binom(B, M, dat$Admitted + xi * nu, dat$Admitted + dat$Rejected + nu)
+@
+
+This function is suitable for passing to \texttt{metrop} or
+\texttt{morph.metrop}. We know that using \texttt{morph.metrop} with
+\texttt{morph=morph(p=3)} will run a geometrically ergodic Markov chain
+\citep{johnson-geyer}.
+<<>>=
+berkeley.out <- morph.metrop(lud.berkeley, rep(0, ncol(M)), blen=1000,
+ nbatch=1, scale=0.1, morph=morph(p=3))
+berkeley.out$accept
+berkeley.out <- morph.metrop(berkeley.out, scale=0.05)
+berkeley.out$accept
+berkeley.out <- morph.metrop(berkeley.out, scale=0.02)
+berkeley.out$accept
+berkeley.out <- morph.metrop(berkeley.out, blen=10000)
+berkeley.out$accept
+@
+
+<<>>=
+berkeley.out <- morph.metrop(berkeley.out, blen=1, nbatch=100000)
+@
+
+Estimate the posterior mean acceptance probabilities for each
+gender-department combination.
+<<>>=
+beta <- setNames(colMeans(berkeley.out$batch), colnames(M))
+MB <- M %*% beta
+dat$p <- dat$Admitted / (dat$Admitted + dat$Rejected)
+dat$p.post <- exp(MB) / (1 + exp(MB))
+dat
+@
+The small difference between the data and posterior probabilities is
+expected, our prior was given very little weight. Using
+\texttt{morph.metrop} with the setting \texttt{morph=morph(p=3)} in this
+setting is an efficient way of sampling from the posterior distribution.
+
+We can also compare the posterior distribution of admittance
+probability for each gender-department combination.
+Table~\ref{tab:post-quant} gives the 5\% and 95\% quantiles for the
+posterior distribution of the admittance probabilities for each
+gender-department combination. Figure~\ref{fig:posterior-probs} gives
+the same quantiles, plus the mean posterior-probability for each
+gender-department combination. From these we can see that for each
+department, there is considerable overlap of the distributions of
+probabilities for males and females.
+
+<<calculate-posterior-probabilities>>=
+posterior.probabilities <-
+ t(apply(berkeley.out$batch, 1,
+ function(r) {
+ eMB <- exp(M %*% r)
+ eMB / (1 + eMB)
+ }))
+quants <- apply(posterior.probabilities, 2, quantile, prob=c(0.05, 0.95))
+quants.str <- matrix(apply(quants, 2,
+ function(r) sprintf("[%0.2f, %0.2f]", r[1], r[2])),
+ nrow=2, byrow=TRUE)
+
+@
+
+\begin{table}[ht]
+ \caption{5\% and 95\% posterior quantiles for admittance probability
+ for each gender-department combination}
+ \begin{center}
+\begin{tabular}{|l|c|c|c|c|c|c|}
+ \hline
+ Gender & Dept. A & Dept. B & Dept. C & Dept. D & Dept. E. & Dept. F \\
+ \hline
+ Female & \Sexpr{paste(quants.str[1, 1:6], collapse=" & ")} \\
+ Male & \Sexpr{paste(quants.str[2, 1:6], collapse=" & ")} \\
+ \hline
+\end{tabular}
+\label{tab:post-quant}
+\end{center}
+\end{table}
+
+\begin{figure}
+\begin{center}
+<<label=fig1,fig=TRUE,echo=FALSE>>=
+x <- (0:5) * 2 + 1
+plot(x[c(1, 6)] + 0.5 * c(-1, 1), 0:1,
+ xlab="Department", ylab="Probability", xaxt="n", type="n")
+axis(1, x, LETTERS[1:6])
+for(i in 1:6) {
+ lines((x[i]-0.25)*c(1, 1), quants[1:2, i], lwd=2, col="gray")
+ lines((x[i] + 0.25) * c(1, 1), quants[1:2, i + 6], lwd=2, col="gray")
+ points(x[i] + 0.25 * c(-1, 1), dat$p.post[i + c(0, 6)], pch=c("F", "M"))
+}
+@
+\end{center}
+\caption{Posterior 5\% and 95\% quantiles and mean, by department and gender.}
+\label{fig:posterior-probs}
+\end{figure}
+
+\section{Cauchy Location-Scale Model}
+
+We are going to do a Cauchy location-scale family objective Bayesianly.
+
+\subsection{Data}
+
+First we generate some data.
+<<cauchy-data>>=
+n <- 15
+mu0 <- 50
+sigma0 <- 10
+x <- rcauchy(n, mu0, sigma0)
+round(sort(x), 1)
+@
+\texttt{mu0} and \texttt{sigma0} are the true unknown parameter values
+(since the data are simulated we actually know these ``unknown'' parameter
+values, but we must pretend we don't know them and estimate them).
+
+\subsection{Prior}
+
+The standard objective prior distribution for this situation
+(insofar as any prior distribution can be said to be an objective standard)
+is the improper prior
+$$
+ g(\mu, \sigma) = \frac{1}{\sigma}
+$$
+which is right Haar measure for the location-scale group, and is the
+standard prior that comes from the group invariance argument
+\citep[Section~3.2]{kass-wasserman}.
+
+\subsection{Log Unnormalized Posterior}
+
+We need a function whose argument is a two-vector
+<<cauchy-log-unnormalized-posterior>>=
+lup <- function(theta) {
+ if (any(is.na(theta)))
+ stop("NA or NaN in input to log unnormalized density function")
+ mu <- theta[1]
+ sigma <- theta[2]
+ if (sigma <= 0) return(-Inf)
+ if (any(! is.finite(theta))) return(-Inf)
+ result <- sum(dcauchy(x, mu, sigma, log = TRUE)) - log(sigma)
+ if (! is.finite(result)) {
+ warning(paste("Oops! mu = ", mu, "and sigma =", sigma))
+ }
+ return(result)
+}
+@
+
+\subsection{Laplace Approximation}
+
+To have some idea what we are doing, we first maximize the log unnormalized
+posterior. To do it helps to have good starting points for the optimization.
+Robust estimators of location and scale are
+<<cauchy-robust>>=
+mu.twiddle <- median(x)
+sigma.twiddle <- IQR(x)
+c(mu.twiddle, sigma.twiddle)
+@
+The posterior mode is
+<<cauchy-posterior-mode>>=
+oout <- optim(c(mu.twiddle, sigma.twiddle), lup,
+ control = list(fnscale = -1), hessian = TRUE)
+stopifnot(oout$convergence == 0)
+mu.hat <- oout$par[1]
+sigma.hat <- oout$par[2]
+c(mu.hat, sigma.hat)
+@
+and the hessian evaluated at the posterior mode (calculated by
+\texttt{optim} using finite differences) is
+<<cauchy-hessian>>=
+oout$hessian
+@
+The hessian is nearly diagonal and one can check that theoretically
+is exactly diagonal. Thus approximate (asymptotic) posterior standard
+deviations are
+<<cauchy-se>>=
+sqrt(- 1 / diag(oout$hessian))
+@
+
+\subsection{Theory}
+
+To use the theory in \citet{johnson-geyer} we must verify that the
+target distribution (the unnormalized posterior) is everywhere positive,
+and it isn't (it is zero for $\sigma \le 0$). We tried making $\log(\sigma)$
+the parameter but this didn't work either because $\log(\sigma)$ goes to
+infinity so slowly that this stretches out the tails so much that the
+transformations introduced by \citet{johnson-geyer} can't pull them back
+in again. We do know \citep[Example~3.4]{johnson-geyer} that if we fix
+$\sigma$ this is a sub-exponentially light target distribution. Letting
+$\sigma$ vary can only make this worse. Thus, if we don't do anything
+and just use the \texttt{metrop} function, then performance will be very
+bad. So we are going to use the transformations and the \texttt{morph.metrop}
+function, even though the theory that motivates them does not hold.
+
+\subsection{Morph}
+
+We want to center the transformation at the posterior mode, and use a
+radius $r$ that doesn't transform until several approximate standard deviations
+<<cauchy-doit>>=
+moo <- morph(b = 0.5, r = 7, center = c(mu.hat, sigma.hat))
+mout <- morph.metrop(lup, c(mu.hat, sigma.hat), 1e4,
+ scale = 3, morph = moo)
+mout$accept
+mout <- morph.metrop(mout)
+@
+Good enough. An attempt to increase the scale led to error when the
+transformation functions overflowed. Can't take steps too big with this
+stuff.
+The following code
+<<label=cfig1too,include=FALSE>>=
+acf(mout$batch)
+@
+makes an autocorrelation plot (Figure~\ref{fig:cfig1}).
+\begin{figure}
+\begin{center}
+<<label=cfig1,fig=TRUE,echo=FALSE>>=
+<<cfig1too>>
+@
+\end{center}
+\caption{Autocorrelation plot. First component is $\mu$, second is $\sigma$.}
+\label{fig:cfig1}
+\end{figure}
+It looks like lag 10 to 15 is enough to get near independence.
+
+Now we want to make marginal density plots.
+If we just feed our MCMC output to the R function \texttt{density}
+it undersmooths because it expects independent and identically distributed
+data rather than autocorrelated
+data. Thus we feed it subsampled, nearly uncorrelated data to select
+the bandwidth and then use that bandwidth on the full data. Here's
+how that works.
+The following code
+<<label=cfig2too,include=FALSE>>=
+mu <- mout$batch[ , 1]
+i <- seq(1, mout$nbatch, by = 15)
+out.sub <- density(mu[i])
+out <- density(mu, bw = out.sub$bw)
+plot(out)
+@
+makes the density plot (Figure~\ref{fig:cfig2}).
+\begin{figure}
+\begin{center}
+<<label=cfig2,fig=TRUE,echo=FALSE>>=
+<<cfig2too>>
+@
+\end{center}
+\caption{Density plot for the marginal posterior for $\mu$.}
+\label{fig:cfig2}
+\end{figure}
+And a similar plot for $\sigma$ (Figure~\ref{fig:cfig3})
+\begin{figure}
+\begin{center}
+<<label=cfig3,fig=TRUE,echo=FALSE>>=
+sigma <- mout$batch[ , 2]
+out.sub <- density(sigma[i])
+out <- density(sigma, bw = out.sub$bw)
+plot(out)
+@
+\end{center}
+\caption{Density plot for the marginal posterior for $\sigma$.}
+\label{fig:cfig3}
+\end{figure}
+
+\begin{thebibliography}{}
+
+\bibitem[Jarner and Roberts(2007)]{jarner-roberts}
+Jarner, S.F., and G.O. Roberts (2007).
+\newblock Convergence of heavy-tailed Monte Carlo Markov chain algorithms.
+\newblock \emph{Scandinavian Journal of Statistics}, 34, 781--815.
+
+\bibitem[Jarner and Tweedie(2003)]{jarner-tweedie}
+Jarner, S.~F., and Tweedie, R.~L. (2003).
+\newblock Necessary conditions for geometric and polynomial ergodicity of
+ random-walk-type Markov chains.
+\newblock \emph{Bernoulli}, 9, 559--578.
+
+\bibitem[Johnson(2011)]{johnson-thesis}
+Johnson, L.~T. (2011).
+\newblock Geometric Ergodicity of a Random-Walk Metropolis Algorithm via
+ Variable Transformation and Computer Aided Reasoning in Statistics.
+\newblock Ph.~D. thesis. University of Minesota.
+ \url{http://purl.umn.edu/113140}
+
+\bibitem[Johnson and Geyer(submitted)]{johnson-geyer}
+Johnson, L.~T., and C.~J. Geyer (submitted).
+\newblock Variable Transformation to Obtain Geometric Ergodicity
+ in the Random-walk Metropolis Algorithm.
+\newblock Revised and resubmitted to \emph{Annals of Statistics}.
+
+\bibitem[Kass and Wasserman(1996)]{kass-wasserman}
+Kass, R.~E., and Wasserman, L. (1996).
+\newblock Formal rules for selecting prior distributions: A review and
+ annotated bibliography.
+\newblock \emph{Journal of the American Statistical Association},
+ 435, 1343--1370.
+
+\bibitem[Mengersen and Tweedie(1996)]{mengersen-tweedie}
+ Mengersen, K.L., ad R. L. Tweedie (1996).
+\newblock Rates of convergence of the Hastings and Metropolis algorithms.
+\newblock \emph{Annals of Statistics}, 24, 101--121.
+
+\end{thebibliography}
+
+\end{document}
+
diff --git a/inst/doc/morph.pdf b/inst/doc/morph.pdf
new file mode 100644
index 0000000..7c140fd
Binary files /dev/null and b/inst/doc/morph.pdf differ
diff --git a/inst/doc/temper.pdf b/inst/doc/temper.pdf
new file mode 100644
index 0000000..e76d13d
Binary files /dev/null and b/inst/doc/temper.pdf differ
diff --git a/inst/doc/temper.tex b/inst/doc/temper.tex
new file mode 100644
index 0000000..6c68efe
--- /dev/null
+++ b/inst/doc/temper.tex
@@ -0,0 +1,270 @@
+
+\documentclass[11pt]{article}
+
+\usepackage{amsmath}
+\usepackage{indentfirst}
+\usepackage{natbib}
+\usepackage{url}
+
+\RequirePackage{amsfonts}
+\newcommand{\real}{\mathbb{R}}
+
+\newcommand{\fatdot}{\,\cdot\,}
+
+\begin{document}
+
+\title{Simulated Tempering for the MCMC Package}
+
+\author{Charles J. Geyer}
+
+\maketitle
+
+\section{Parallel and Serial Tempering}
+
+Serial tempering \citep{marinari-parisi,geyer-thompson}
+runs a Markov chain whose state is $(i, x)$, where $i$
+is a positive integer between 1 and $k$ and $x$ is an element of $\real^p$.
+The unnormalized density of the equilibrium distribution is $h(i, x)$.
+The integer $i$ is called the \emph{index of the component of the mixture},
+and the integer $k$ is called the \emph{number of components of the mixture}.
+The reason for this terminology is that
+\begin{equation} \label{eq:mix}
+ h(x) = \sum_{i = 1}^k h(i, x),
+\end{equation}
+which is the unnormalized marginal density of $x$ derived from the unnormalized
+joint density $h(i, x)$ of the equilibrium distribution of the Markov chain,
+is a mixture of $k$ component distributions having unnormalized density
+$h(i, \fatdot)$ for different $i$.
+
+Parallel tempering \citep{geyer}
+runs a Markov chain whose state is $(x_1, \ldots, x_k)$
+where each $x_i$ is an element of $\real^p$. Thus the state is a vector
+whose elements are vectors, which may be thought of as a $k \times p$ matrix.
+The unnormalized density of the equilibrium distribution is
+\begin{equation} \label{eq:parallel-joint}
+ h(x_1, \ldots, x_k) = \prod_{i \in I} h(i, x_i).
+\end{equation}
+This joint equilibrium distribution is the product of the marginals
+$h(i, \fatdot)$ for different $i$. This the $x_i$ are asymptotically
+independent in parallel tempering.
+
+\section{Sensitivity to Normalization}
+
+So long as one is only interested in one of the component distributions
+$h(i, \fatdot)$, both parallel and serial tempering do the job. And
+this job is what gives them the name ``tempering'' by analogy with simulated
+annealing \citep{marinari-parisi}. The other component distributions only help
+in sampling the component of interest. In this job, parallel tempering is
+easier to set up because it is insensitive to normalizing constants in the
+following sense. Suppose we change the normalization for each component
+distribution using
+$$
+ h^*(i, x) = a_i h(i, x).
+$$
+This greatly changes the mixture distribution \eqref{eq:mix} sampled by
+simulated tempering. We now get
+$$
+ h^*(x) = \sum_{i = 1}^k h^*(i, x) = \sum_{i = 1}^k a_i h(i, x),
+$$
+which may be very different from \eqref{eq:mix}, even considered as an
+unnormalized density (which it is). But \eqref{eq:parallel-joint}, considered
+as an unnormalized density (which it is), does not change at all
+\begin{align*}
+ h^*(x_1, \ldots, x_k)
+ & =
+ \prod_{i = 1}^k h^*(i, x)
+ \\
+ & =
+ \prod_{i = 1}^k a_i h(i, x)
+ \\
+ & =
+ \left( \prod_{i = 1}^k a_i \right)
+ \left( \prod_{i = 1}^k h(i, x) \right)
+ \\
+ & =
+ \left( \prod_{i = 1}^k a_i \right)
+ h(x_1, \ldots, x_k)
+\end{align*}
+(the normalizing constant changes, but that does not matter for an unnormalized
+density; it still specifies the same probability distribution). All this is
+to say that serial tempering is very sensitive to the choices of normalizing
+constants of the individual component distributions (the $a_i$ in the preceding
+discussion) and parallel tempering is totally insensitive to them. Thus
+parallel tempering is easier to set up and get working.
+\citet{geyer-thompson}, however, independently invented serial tempering
+because it worked for
+a problem where parallel tempering failed. So for this ``tempering'' job,
+where one is only interested in sampling one component distribution (and the
+others are just helpers) parallel tempering is easier to use but serial
+tempering works better.
+
+\section{Umbrella Sampling}
+
+Sometimes one is actually interested in sampling a particular mixture
+distribution having unnormalized density \eqref{eq:mix}. This arises
+in Bayesian and frequentist model averaging and for other reasons.
+An umbrella term for this application is ``umbrella sampling''
+\citep{torrie-valleau}. In this application only serial tempering does more
+than parallel tempering. Parallel tempering can simulate any directly
+specified mixture. If
+$$
+ f(i, x) = \frac{h(i, x)}{\int h(i, x) \, d x}
+$$
+are the normalized component distributions and $b_1$, $\dots$, $b_k$ are
+nonnegative and sum to one, then
+$$
+ f(x) = \sum_{i = 1}^k b_i f(i, x)
+$$
+is a normalized mixture distribution, and parallel tempering can be used
+to sample it. However, this ``directly specified'' mixture is often not
+of interest because the individual component normalizing constants
+\begin{equation} \label{eq:norm-con}
+ c_i = \int h(i, x) \, d x
+\end{equation}
+are unknown. Suppose we are doing Bayesian model
+averaging and $h(i, x)$ is the unnormalized posterior density (likelihood times
+prior). This means $i$ and $x$ are parameters to the Bayesian; $i$ denotes
+the model and $x$ denotes the within-model parameters. Then the normalizing
+constants \eqref{eq:norm-con} are unnormalized Bayes factors, which Bayesians
+use for model comparison.
+
+The function $i \mapsto c_i$ is the unnormalized density of the marginal
+distribution of the random
+variable $i$ derived from the joint distribution $h(i, x)$, which is the
+equilibrium distribution of the Markov chain. It is therefore estimated,
+up to a constant of proportionality, by the marginal distribution of $i$.
+Thus serial tempering, unlike parallel tempering, provides simple and direct
+estimates of Bayes factors and other normalizing constants.
+
+\section{Update Mechanisms}
+
+Traditionally, tempering makes two kinds of elementary updates, one changes
+only $x$ in serial tempering or one $x_i$ in parallel tempering. We call
+them within-component updates, and will use normal random walk Metropolis
+updates analogous to those used by the \texttt{metrop} function. The other
+kind changes $i$ in serial tempering or swaps $x_i$ and $x_j$ in parallel
+tempering. We call them jump/swap updates (jump in serial tempering, swap
+in parallel tempering).
+
+\subsection{Serial Tempering}
+
+The combined update is a 50-50 mixture of within-component elementary updates
+and jump updates. Suppose the current state is $(i, x)$. A within-component
+update proposes $x^*$ which is normally distributed centered at $x$. Then
+Metropolis rejection of the proposal is done with Metropolis ratio
+$$
+ \frac{h(i, x^*)}{h(i, x)}
+$$
+This is valid because the proposal is symmetric by symmetry of the normal
+distribution. A jump update proposes $i^*$, which is chosen uniformly at
+random from the ``neighbors'' of $i$ (the neighbor relation is specified
+by a user-supplied logical matrix). This proposal need not be symmetric,
+because $i$ and $i^*$ need not have the same number of neighbors. Write
+$n(i)$ and $n(i^*)$ for these neighbor counts. Then the probability of
+proposing $i^*$ when the current state is $i$ is $1 / n(i)$, and the
+probability of
+proposing $i$ when the current state is $i^*$ is $1 / n(i^*)$. Hence
+the appropriate Hastings ratio for Metropolis-Hastings rejection is
+$$
+ \frac{h(i^*, x) / n(i^*)}{h(i, x) / n(i)}
+ =
+ \frac{h(i^*, x)}{h(i, x)} \cdot
+ \frac{n(i)}{n(i^*)}
+$$
+
+\subsection{Parallel Tempering}
+
+The combined update is a 50-50 mixture of within-component elementary updates
+and swap updates. Suppose the current state is $(x_1, \ldots, x_k)$.
+A within-component chooses $i$ uniformly at random in $\{ 1, \ldots, k \}$,
+and then proposes $x_i^*$ which is normally distributed centered at $x_i$.
+Then Metropolis rejection of the proposal is done with Metropolis ratio
+$$
+ \frac{h(i, x_i^*)}{h(i, x_i)}
+$$
+This is valid because the proposal is symmetric by symmetry of the normal
+distribution. A swap update chooses $i$ uniformly at random in
+$\{ 1, \ldots, k \}$ and then $j$, which is chosen uniformly at
+random from the neighbors of $i$.
+This proposal is automatically symmetric, because a swap move is its own
+inverse.
+Hence the appropriate Hastings ratio for Metropolis-Hastings rejection is
+$$
+ \frac{h(i, x_j) h(j, x_i)}{h(i, x_i) h(j, x_j)}
+$$
+
+\section{Acceptance Rates}
+
+Metropolis-Hastings acceptance rates are not comparable
+to Metropolis acceptance rates. For serial tempering
+$$
+ E \left\{ 1 \wedge
+ \frac{h(i^*, x)}{h(i, x)} \cdot
+ \frac{n(i)}{n(i^*)}
+ \right\}
+ \neq
+ E \left\{ 1 \wedge
+ \frac{h(i^*, x)}{h(i, x)}
+ \right\}
+$$
+where the expectations are taken with respect to $(i, x)$ having
+the equilibrium distribution of the Markov chain and
+the conditional distribution of $i^*$ given $i$ being uniform over neighbors
+of $i$.
+For parallel tempering,
+$$
+ E \left\{ 1 \wedge
+ \frac{h(i, x_j) h(j, x_i)}{h(i, x_i) h(j, x_j)} \cdot
+ \frac{n(i)}{n(j)}
+ \right\}
+ \neq
+ E \left\{ 1 \wedge
+ \frac{h(i, x_j) h(j, x_i)}{h(i, x_i) h(j, x_j)}
+ \right\}
+$$
+where the expectations are taken with respect to $(x_1, \ldots, x_k)$ having
+the equilibrium distribution of the Markov chain, $(i, j)$ being independent
+of $(x_1, \ldots, x_k)$, the marginal distribution of $i$ being uniform on
+$\{ 1, \ldots, k \}$, and the conditional distribution of $j$ given $i$ being
+uniform over neighbors of $i$.
+
+Thus we need to report rates going both ways, for example,
+for serial tempering, when $i = 1$ and $i^* = 2$
+as well as when $i = 2$ and $i^* = 1$.
+And similarly for parallel tempering.
+
+\begin{thebibliography}{}
+
+\bibitem[Geyer(1991)]{geyer}
+Geyer, C.~J. (1991).
+\newblock Markov chain Monte Carlo maximum likelihood.
+\newblock \emph{Computing Science and Statistics: Proceedings of the Symposium
+ on Interface Critical Applications of Scientific Computing (23rd): Biology,
+ Engineering, Medicine, Speech Held in Seattle, Washington on 21-24 April
+ 1991}, J.~R. Kettenring and E.~M. Keramidas, eds., 156--163.
+\newblock \url{http://www.stat.umn.edu/geyer/f05/8931/c.ps}
+
+\bibitem[Geyer and Thompson(1995)]{geyer-thompson}
+Geyer, C.~J., and Thompson, E.~A. (1995).
+\newblock Annealing Markov chain Monte Carlo with applications to ancestral
+ inference.
+\newblock \emph{Journal of the American Statistical Association}, \textbf{90},
+ 909--920.
+
+\bibitem[Marinari and Parisi(1992)]{marinari-parisi}
+Marinari, E., and Parisi G. (1992).
+\newblock Simulated tempering: A new Monte Carlo Scheme.
+\newblock \emph{Europhysics Letters}, \textbf{19}, 451--458.
+
+\bibitem[Torrie and Valleau(1977)]{torrie-valleau}
+Torrie, G.~M., and Valleau, J.~P. (1977).
+\newblock Nonphysical sampling distributions in Monte Carlo free-energy
+ estimation: Umbrella sampling.
+\newblock \emph{Journal of Computational Physics}, \textbf{23}, 187--199.
+
+\end{thebibliography}
+
+
+
+\end{document}
+
diff --git a/man/foo.Rd b/man/foo.Rd
new file mode 100644
index 0000000..f2a93de
--- /dev/null
+++ b/man/foo.Rd
@@ -0,0 +1,24 @@
+\name{foo}
+\docType{data}
+\alias{foo}
+\title{Simulated logistic regression data.}
+\description{
+ Like it says
+}
+\usage{data(foo)}
+\format{
+ A data frame with variables
+ \describe{
+ \item{x1}{quantitative predictor.}
+ \item{x2}{quantitative predictor.}
+ \item{x3}{quantitative predictor.}
+ \item{y}{Bernoulli response.}
+ }
+}
+\examples{
+library(mcmc)
+data(foo)
+out <- glm(y ~ x1 + x2 + x3, family = binomial, data = foo)
+summary(out)
+}
+\keyword{datasets}
diff --git a/man/initseq.Rd b/man/initseq.Rd
new file mode 100644
index 0000000..3d546c7
--- /dev/null
+++ b/man/initseq.Rd
@@ -0,0 +1,103 @@
+\name{initseq}
+\alias{initseq}
+\title{Initial Sequence Estimators}
+\description{
+ Variance of sample mean of functional of reversible Markov chain
+ using methods of Geyer (1992).
+}
+\usage{
+initseq(x)
+}
+\arguments{
+ \item{x}{a numeric vector that is a scalar-valued functional of a reversible
+ Markov chain.}
+}
+\details{
+Let
+\deqn{\gamma_k = \textrm{cov}(X_i, X_{i + k})}{gamma[k] = cov(x[i], x[i + k])}
+considered as a function of the lag \eqn{k} be
+the autocovariance function of the input time series.
+Define
+\deqn{\Gamma_k = \gamma_{2 k} + \gamma_{2 k + 1}}{Gamma[k] = gamma[2 k] + gamma[2 k + 1]}
+the sum of consecutive pairs of autocovariances. Then Theorem 3.1 in
+Geyer (1992) says that \eqn{\Gamma_k}{Gamma[k]} considered as a function of
+\eqn{k} is strictly positive, strictly decreasing, and strictly convex,
+assuming the input time series is a scalar-valued functional of a reversible Markov
+chain. All of the MCMC done by this package is reversible.
+This \R function estimates the \dQuote{big gamma} function,
+\eqn{\Gamma_k}{Gamma[k]} considered as a function of
+\eqn{k}, subject to three different constraints, (1) nonnegative,
+(2) nonnegative and nonincreasing, and (3) nonnegative, nonincreasing,
+and convex. It also estimates the variance in the Markov chain central
+limit theorem (CLT)
+\deqn{\gamma_0 + 2 \sum_{k = 1}^\infty \gamma_k = - \gamma_0 + 2 \sum_{k = 0}^\infty \Gamma_k}{- gamma0 + 2 * sum(gamma) = - gamma0 + 2 * sum(Gamma)}
+
+\strong{Note:} The batch means provided by \code{\link{metrop}} are also
+scalar functionals of a reversible Markov chain. Thus these initial sequence
+estimators applied to the batch means give valid standard errors for the
+mean of the match means even when the batch length is too short to provide
+a valid estimate of asymptotic variance. One does, of course, have to
+multiply the asymptotic variance of the batch means by the batch length
+to get the asymptotic variance for the unbatched chain.
+}
+\value{
+a list containing the following components:
+
+ \item{gamma0}{the scalar \eqn{\gamma_0}{gamma[0]}, the marginal variance
+ of \code{x}.}
+ \item{Gamma.pos}{the vector \eqn{\Gamma}{Gamma}, estimated so as to be nonnegative,
+ where, as always, \R uses one-origin indexing so \code{Gamma.pos[1]} is
+ \eqn{\Gamma_0}{Gamma[0]}.}
+ \item{Gamma.dec}{the vector \eqn{\Gamma}{Gamma}, estimated so as to be nonnegative
+ and nonincreasing, where, as always,
+ \R uses one-origin indexing so \code{Gamma.dec[1]} is
+ \eqn{\Gamma_0}{Gamma[0]}.}
+ \item{Gamma.con}{the vector \eqn{\Gamma}{Gamma}, estimated so as to be nonnegative
+ and nonincreasing and convex, where, as always,
+ \R uses one-origin indexing so \code{Gamma.con[1]} is
+ \eqn{\Gamma_0}{Gamma[0]}.}
+ \item{var.pos}{the scalar \code{- gamma0 + 2 * sum(Gamma.pos)}, which is
+ the asymptotic variance in the Markov chain CLT. Divide by \code{length(x)}
+ to get the approximate variance of the sample mean of \code{x}.}
+ \item{var.dec}{the scalar \code{- gamma0 + 2 * sum(Gamma.dec)}, which is
+ the asymptotic variance in the Markov chain CLT. Divide by \code{length(x)}
+ to get the approximate variance of the sample mean of \code{x}.}
+ \item{var.con}{the scalar \code{- gamma0 + 2 * sum(Gamma.con)}, which is
+ the asymptotic variance in the Markov chain CLT. Divide by \code{length(x)}
+ to get the approximate variance of the sample mean of \code{x}.}
+}
+\section{Bugs}{
+Not precisely a bug, but \code{var.pos}, \code{var.dec}, and \code{var.con}
+can be negative. This happens only when the chain is way too short to estimate
+the variance, and even then rarely. But it does happen.
+}
+\references{
+Geyer, C. J. (1992)
+Practical Markov Chain Monte Carlo.
+\emph{Statistical Science} \bold{7} 473--483.
+}
+\seealso{
+\code{\link{metrop}}
+}
+\examples{
+n <- 2e4
+rho <- 0.99
+x <- arima.sim(model = list(ar = rho), n = n)
+out <- initseq(x)
+\dontrun{
+plot(seq(along = out$Gamma.pos) - 1, out$Gamma.pos,
+ xlab = "k", ylab = expression(Gamma[k]), type = "l")
+lines(seq(along = out$Gamma.dec) - 1, out$Gamma.dec, col = "red")
+lines(seq(along = out$Gamma.con) - 1, out$Gamma.con, col = "blue")
+}
+# asymptotic 95\% confidence interval for mean of x
+mean(x) + c(-1, 1) * qnorm(0.975) * sqrt(out$var.con / length(x))
+# estimated asymptotic variance
+out$var.con
+# theoretical asymptotic variance
+(1 + rho) / (1 - rho) * 1 / (1 - rho^2)
+# illustrating use with batch means
+bm <- apply(matrix(x, nrow = 5), 2, mean)
+initseq(bm)$var.con * 5
+}
+\keyword{ts}
diff --git a/man/logit.Rd b/man/logit.Rd
new file mode 100644
index 0000000..aa9144e
--- /dev/null
+++ b/man/logit.Rd
@@ -0,0 +1,25 @@
+\name{logit}
+\docType{data}
+\alias{logit}
+\title{Simulated logistic regression data.}
+\description{
+ Like it says
+}
+\usage{data(logit)}
+\format{
+ A data frame with variables
+ \describe{
+ \item{x1}{quantitative predictor.}
+ \item{x2}{quantitative predictor.}
+ \item{x3}{quantitative predictor.}
+ \item{x4}{quantitative predictor.}
+ \item{y}{Bernoulli response.}
+ }
+}
+\examples{
+library(mcmc)
+data(logit)
+out <- glm(y ~ x1 + x2 + x3 + x4, family = binomial, data = logit)
+summary(out)
+}
+\keyword{datasets}
diff --git a/man/metrop.Rd b/man/metrop.Rd
new file mode 100644
index 0000000..bcbe1b6
--- /dev/null
+++ b/man/metrop.Rd
@@ -0,0 +1,138 @@
+\name{metrop}
+\alias{metrop}
+\alias{metrop.function}
+\alias{metrop.metropolis}
+\title{Metropolis Algorithm}
+\description{
+ Markov chain Monte Carlo for continuous random vector using a Metropolis
+ algorithm.
+}
+\usage{
+metrop(obj, initial, nbatch, blen = 1, nspac = 1, scale = 1, outfun,
+ debug = FALSE, ...)
+}
+\arguments{
+ \item{obj}{an R function that evaluates the log unnormalized probability
+ density of the desired equilibrium distribution of the Markov chain.
+ First argument is the state vector of the Markov chain. Other arguments
+ arbitrary and taken from the \code{...} arguments of this function.
+ Should return \code{- Inf} for points of the state space having
+ probability zero under the desired equilibrium distribution.
+ Alternatively, an object of class \code{"metropolis"} from a
+ previous run can be supplied, in which case any missing arguments
+ (including the log unnormalized density function) are taken from
+ this object (up until version 0.7-2 this was incorrect with respect
+ to the \code{debug} argument, now it applies to it too).}
+ \item{initial}{a real vector, the initial state of the Markov chain.}
+ \item{nbatch}{the number of batches.}
+ \item{blen}{the length of batches.}
+ \item{nspac}{the spacing of iterations that contribute to batches.}
+ \item{scale}{controls the proposal step size. If scalar or
+ vector, the proposal is \code{x + scale * z} where \code{x} is
+ the current state and \code{z} is a standard normal random vector.
+ If matrix, the proposal is \code{x + scale \%*\% z}.}
+ \item{outfun}{controls the output. If a function, then the batch means
+ of \code{outfun(state, ...)} are returned. If a numeric
+ or logical vector, then the batch means of \code{state[outfun]}
+ (if this makes sense). If missing, the the batch means
+ of \code{state} are returned.}
+ \item{debug}{if \code{TRUE} extra output useful for testing.}
+ \item{...}{additional arguments for \code{obj} or \code{outfun}.}
+}
+\details{
+Runs a \dQuote{random-walk} Metropolis algorithm, terminology introduced
+by Tierney (1994), with multivariate normal proposal
+producing a Markov chain with equilibrium distribution having a specified
+unnormalized density. Distribution must be continuous. Support of the
+distribution is the support of the density specified by argument \code{obj}.
+The initial state must satisfy \code{obj(state, ...) > - Inf}.
+Description of a complete MCMC analysis (Bayesian logistic regression)
+using this function can be found in the vignette \code{demo}
+(\url{../doc/demo.pdf}).
+
+Suppose the function coded by the log unnormalized function (either
+\code{obj} or \code{obj$lud}) is actually a log unnormalized density,
+that is, if \eqn{w} denotes that function, then \eqn{e^w}{exp(w)} integrates
+to some value strictly between zero and infinity. Then the \code{metrop}
+function always simulates a reversible, Harris ergodic Markov chain having
+the equilibrium distribution with this log unnormalized density.
+The chain is not guaranteed to be geometrically ergodic. In fact it cannot
+be geometrically ergodic if the tails of the log unnormalized density are
+sufficiently heavy. The \code{\link{morph.metrop}} function deals with this
+situation.
+}
+\value{
+ an object of class \code{"mcmc"}, subclass \code{"metropolis"},
+ which is a list containing at least the following components:
+ \item{accept}{fraction of Metropolis proposals accepted.}
+ \item{batch}{\code{nbatch} by \code{p} matrix, the batch means, where
+ \code{p} is the dimension of the result of \code{outfun}
+ if \code{outfun} is a function, otherwise the dimension of
+ \code{state[outfun]} if that makes sense, and the dimension
+ of \code{state} when \code{outfun} is missing.}
+ \item{initial}{value of argument \code{initial}.}
+ \item{final}{final state of Markov chain.}
+ \item{initial.seed}{value of \code{.Random.seed} before the run.}
+ \item{final.seed}{value of \code{.Random.seed} after the run.}
+ \item{time}{running time of Markov chain from \code{system.time()}.}
+ \item{lud}{the function used to calculate log unnormalized density,
+ either \code{obj} or \code{obj$lud} from a previous run.}
+ \item{nbatch}{the argument \code{nbatch} or \code{obj$nbatch}.}
+ \item{blen}{the argument \code{blen} or \code{obj$blen}.}
+ \item{nspac}{the argument \code{nspac} or \code{obj$nspac}.}
+ \item{outfun}{the argument \code{outfun} or \code{obj$outfun}.}
+ Description of additional output when \code{debug = TRUE} can be
+ found in the vignette \code{debug} (\url{../doc/debug.pdf}).
+}
+\section{Warning}{
+If \code{outfun} is missing or not a function, then the log unnormalized
+density can be defined without a \ldots argument and that works fine.
+One can define it starting \code{ludfun <- function(state)} and that works
+or \code{ludfun <- function(state, foo, bar)}, where \code{foo} and \code{bar}
+are supplied as additional arguments to \code{metrop}.
+
+If \code{outfun} is a function, then both it and the log unnormalized
+density function can be defined without \ldots arguments \emph{if they
+have exactly the same arguments list} and that works fine. Otherwise it
+doesn't work. Start the definitions \code{ludfun <- function(state, foo)}
+and \code{outfun <- function(state, bar)} and you get an error about
+unused arguments. Instead start the definitions
+\code{ludfun <- function(state, foo, \ldots)}
+and \code{outfun <- function(state, bar, \ldots)}, supply
+\code{foo} and \code{bar} as additional arguments to \code{metrop},
+and that works fine.
+
+In short, the log unnormalized density function and \code{outfun} need
+to have \ldots in their arguments list to be safe. Sometimes it works
+when \ldots is left out and sometimes it doesn't.
+
+Of course, one can avoid this whole issue by always defining the log
+unnormalized density function and \code{outfun} to have only one argument
+\code{state} and use global variables (objects in the R global environment) to
+specify any other information these functions need to use. That too
+follows the R way. But some people consider that bad programming practice.
+}
+\references{
+Tierney, L. (1994)
+Markov chains for exploring posterior distributions (with discussion).
+\emph{Annals of Statistics} \bold{22} 1701--1762.
+}
+\seealso{
+\code{\link{morph.metrop}}
+}
+\examples{
+h <- function(x) if (all(x >= 0) && sum(x) <= 1) return(1) else return(-Inf)
+out <- metrop(h, rep(0, 5), 1000)
+out$accept
+# acceptance rate too low
+out <- metrop(out, scale = 0.1)
+out$accept
+# acceptance rate o. k. (about 25 percent)
+plot(out$batch[ , 1])
+# but run length too short (few excursions from end to end of range)
+out <- metrop(out, nbatch = 1e4)
+out$accept
+plot(out$batch[ , 1])
+hist(out$batch[ , 1])
+}
+\keyword{misc}
diff --git a/man/morph.Rd b/man/morph.Rd
new file mode 100644
index 0000000..086e888
--- /dev/null
+++ b/man/morph.Rd
@@ -0,0 +1,128 @@
+\name{morph}
+\encoding{UTF-8}
+\alias{morph}
+\alias{morph.identity}
+\title{Variable Transformation}
+\description{
+ Utility functions for variable transformation.
+}
+\usage{
+morph(b, r, p, center)
+morph.identity()
+}
+\arguments{
+ \item{b}{Positive real number. May be missing.}
+ \item{r}{Non-negative real number. May be missing. If \code{p} is
+ specified, \code{r} defaults to 0.}
+ \item{p}{Real number strictly greater than 2. May be missing. If
+ \code{r} is specified, \code{p} defaults to 3.}
+ \item{center}{Real scalar or vector. May be missing. If
+ \code{center} is a vector it should be the same length of the state
+ of the Markov chain, \code{center} defaults to 0}
+}
+\section{Warning}{
+ The equations for the returned \code{transform} function (see below)
+ do not have a general analytical solution when \code{p} is not equal
+ to 3. This implementation uses numerical approximation to calculate
+ \code{transform} when \code{p} is not equal to 3. If computation
+ speed is a factor, it is advisable to use \code{p=3}. This is not a
+ factor when using \code{\link{morph.metrop}}, as \code{transform} is
+ only called once during setup, and not at all while running the Markov chain.
+}
+\details{
+ The \code{morph} function facilitates using variable transformations
+ by providing functions to (using \eqn{X} for the original random
+ variable with the pdf \eqn{f_X}{f.X}, and \eqn{Y} for the transformed
+ random variable with the pdf \eqn{f_Y}{f.Y}):
+ \itemize{
+ \item Calculate the log unnormalized probability density for \eqn{Y}
+ induced by the transformation.
+ \item Transform an arbitrary function of \eqn{X} to a function of
+ \eqn{Y}.
+ \item Transform values of \eqn{X} to values of \eqn{Y}.
+ \item Transform values of \eqn{Y} to values of \eqn{X}
+ (the inverse transformation).
+ }
+ for a select few transformations.
+
+ \code{morph.identity} implements the identity transformation,
+ \eqn{Y=X}.
+
+ The parameters \code{r}, \code{p}, \code{b} and \code{center} specify the
+ transformation function. In all cases, \code{center} gives the center
+ of the transformation, which is the value \eqn{c} in the equation
+ \deqn{Y = f(X - c).} If no parameters are specified, the identity
+ transformation, \eqn{Y=X}, is used.
+
+ The parameters \code{r}, \code{p} and \code{b} specify a function
+ \eqn{g}, which is a monotonically increasing bijection from the
+ non-negative reals to the non-negative reals. Then
+ \deqn{f(X) = g\bigl(|X|\bigr) \frac{X}{|X|}}{f(X) = g(|X|) * X / |X|}
+ where \eqn{|X|} represents the Euclidean norm of the vector \eqn{X}.
+ The inverse function is given by
+ \deqn{f^{-1}(Y) = g^{-1}\bigl(|Y|\bigr) \frac{Y}{|Y|}.}{f^{-1}(Y) = g^{-1}(|Y|) * Y / |Y|.}
+
+ The parameters \code{r} and \code{p} are used to define the function
+ \deqn{g_1(x) = x + (x-r)^p I(x > r)}{g1(x) = x + (x-r)^p * I(x > r)}
+ where \eqn{I( \cdot )}{I(•)} is the indicator
+ function. We require that \code{r} is non-negative and \code{p} is
+ strictly greater than 2. The parameter \code{b} is used to define the
+ function
+ \deqn{g_2(x) = \bigl(e^{bx} - e / 3\bigr) I(x > \frac{1}{b}) +
+ \bigl(x^3 b^3 e / 6 + x b e / 2\bigr) I(x \leq
+ \frac{1}{b})}{
+ g2(x) = (exp(b * x) - exp(1) / 3) * I(x > 1 / b) +
+ (x^3 * b^3 exp(1) / 6 + x * b * exp(1) / 2) * I(x <= 1 / b).}
+ We require that \eqn{b} is positive.
+
+ The parameters \code{r}, \code{p} and \code{b} specify \eqn{f^{-1}} in
+ the following manner:
+ \itemize{
+ \item If one or both of \code{r} and \code{p} is specified, and \code{b}
+ is not specified, then \deqn{f^{-1}(X) = g_1(|X|)
+ \frac{X}{|X|}.}{f^{-1}(X) = g1(|X|) * X / |X|.} If only
+ \code{r} is specified, \code{p = 3} is used. If only \code{p} is specified,
+ \code{r = 0} is used.
+
+ \item If only \code{b} is specified, then \deqn{f^{-1}(X) = g_2(|X|)
+ \frac{X}{|X|}.}{f^{-1}(X) = g2(|X|) * X / |X|.}
+
+ \item If one or both of \code{r} and \code{p} is specified, and \code{b} is
+ also specified, then \deqn{f^{-1}(X) = g_2(g_1(|X|))
+ \frac{X}{|X|}.}{f^{-1}(X) = g2(g1(|X|)) * X / |X|.}
+ }
+}
+\value{
+ a list containing the functions
+ \itemize{
+ \item \code{outfun(f)}, a function that operates on functions.
+ \code{outfun(f)} returns the function \code{function(state, ...)
+ f(inverse(state), ...)}.
+ \item \code{inverse}, the inverse transformation function.
+ \item \code{transform}, the transformation function.
+ \item \code{lud}, a function that operates on functions. As input,
+ \code{lud} takes a function that calculates a log unnormalized
+ probability density, and returns a function that calculates the
+ log unnormalized density by transforming a random variable using the
+ \code{transform} function. \code{lud(f) = function(state, ...)
+ f(inverse(state), ...) + log.jacobian(state)}, where
+ \code{log.jacobian} represents the function that calculate the log
+ Jacobian of the transformation. \code{log.jacobian} is not returned.
+}
+}
+\examples{
+
+# use an exponential transformation, centered at 100.
+b1 <- morph(b=1, center=100)
+# original log unnormalized density is from a t distribution with 3
+# degrees of freedom, centered at 100.
+lud.transformed <- b1$lud(function(x) dt(x - 100, df=3, log=TRUE))
+d.transformed <- Vectorize(function(x) exp(lud.transformed(x)))
+\dontrun{
+curve(d.transformed, from=-3, to=3, ylab="Induced Density")
+}
+}
+\seealso{
+ \code{\link{morph.metrop}}
+}
+\keyword{misc}
diff --git a/man/morph.metrop.Rd b/man/morph.metrop.Rd
new file mode 100644
index 0000000..e7b3a58
--- /dev/null
+++ b/man/morph.metrop.Rd
@@ -0,0 +1,137 @@
+\name{morph.metrop}
+\alias{morph.metrop}
+\alias{morph.metrop.function}
+\alias{morph.metrop.morph.metropolis}
+\title{Morphometric Metropolis Algorithm}
+\description{
+ Markov chain Monte Carlo for continuous random vector using a
+ Metropolis algorithm for an induced density.
+}
+\usage{
+morph.metrop(obj, initial, nbatch, blen = 1, nspac = 1, scale = 1,
+ outfun, debug = FALSE, morph, ...)
+}
+\arguments{
+ \item{obj}{see \code{\link{metrop}}.}
+ \item{initial}{see \code{\link{metrop}}.}
+ \item{nbatch}{see \code{\link{metrop}}.}
+ \item{blen}{see \code{\link{metrop}}.}
+ \item{nspac}{see \code{\link{metrop}}.}
+ \item{scale}{see \code{\link{metrop}}.}
+ \item{outfun}{unlike for \code{\link{metrop}} must be a function or missing;
+ if missing the identity function, \code{function(x) x}, is used.}
+ \item{debug}{see \code{\link{metrop}}.}
+ \item{morph}{morph object used for transformations. See \code{\link{morph}}.}
+ \item{...}{see \code{\link{metrop}}.}
+}
+\details{
+ \code{morph.metrop} implements morphometric methods for Markov
+ chains. The caller specifies a log unnormalized probability density
+ and a transformation. The transformation specified by the
+ \code{morph} parameter is used to induce a new log unnormalized
+ probability density, a Metropolis algorithm is
+ run for the induced density. The Markov chain is transformed back to
+ the original scale. Running the Metropolis algorithm for the induced
+ density, instead of the original density, can result in a Markov chain
+ with better convergence properties. For more details see Johnson and Geyer
+ (submitted). Except for \code{morph}, all parameters are
+ passed to \code{\link{metrop}}, transformed when necessary. The
+ \code{scale} parameter is \emph{not} transformed.
+
+ If \eqn{X} is a real vector valued continuous random variable, and
+ \eqn{Y = f(X)} where \eqn{f} is a diffeomorphism, then the pdf of
+ \eqn{Y} is given by \deqn{f_Y(y) = f_X(f^{-1}(y)) | \nabla f^{-1}(y)
+ |}{ fY(y) = fX(f^{-1}(y)) | del f^{-1}(y) |} where \eqn{f_X}{fX} is
+ the pdf of \eqn{X} and \eqn{\nabla f^{-1}}{del f^{-1}} is the Jacobian
+ of \eqn{f^{-1}}. Because \eqn{f} is a diffeomorphism, a Markov chain
+ for \eqn{f_Y}{fY} may be transformed into a Markov chain for
+ \eqn{f_X}{fX}. Furthermore, these Markov chains are isomorphic
+ (Johnson and Geyer, submitted) and have the same convergence rate.
+ The \code{\link{morph}} variable provides a diffeomorphism,
+ \code{morph.metrop} uses this diffeomorphism to induce the log
+ unnormalized density, \eqn{\log f_Y}{log fY} based on the user
+ supplied log unnormalized density, \eqn{\log f_X}{log fX}.
+ \code{morph.metrop} runs a Metropolis algorithm for \eqn{\log f_Y}{log
+ fY} and transforms the resulting Markov chain into a Markov chain for
+ \eqn{f_X}{fX}. The user accessible output components are the same as
+ those that come from \code{\link{metrop}}, see the documentation for
+ \code{\link{metrop}} for details.
+
+ Subsequent calls of \code{morph.metrop} may change to the
+ transformation by specifying a new value for \code{morph}.
+
+ Any of the other parameters to \code{morph.metrop} may also be
+ modified in subsequent calls. See \code{\link{metrop}} for more details.
+
+ The general idea is that a random-walk Metropolis sampler
+ (what \code{\link{metrop}} does) will not be geometrically
+ ergodic unless the tails of the unnormalized density decrease
+ superexponentially fast (so the tails of the log unnormalized density
+ decrease faster than linearly). It may not be geometrically ergodic
+ even then (see Johnson and Geyer, submitted, for the complete theory).
+ The transformations used by this function (provided by \code{\link{morph}})
+ can produce geometrically ergodic chains when the tails of the log
+ unnormalized density are too light for \code{\link{metrop}} to do so.
+
+ When the tails of the unnormalized density are exponentially light but
+ not superexponentially light (so the tails of the log unnormalized density
+ are asymptotically linear, as in the case of exponential family models
+ when conjugate priors are used, for example logistic regression, Poisson
+ regression with log link, or log-linear models for categorical data), one
+ should use \code{\link{morph}} with \code{b = 0} (the default), which
+ produces a transformation of the form \eqn{g_1}{g1} in the notation
+ used in the details section of the help for \code{\link{morph}}.
+ This will produce a geometrically ergodic sampler if other features of the
+ log unnormalized density are well behaved. For example it will do so
+ for the exponential family examples mentioned above.
+ (See Johnson and Geyer, submitted, for the complete theory.)
+
+ The transformation \eqn{g_1}{g1} behaves like a shift transformation
+ on a ball of radius \code{r} centered at \code{center}, so these arguments
+ to \code{\link{morph}} should be chosen so that a sizable proportion of
+ the probability under the original (untransformed) unnormalized density
+ is contained in this ball. This function will work when \code{r = 0} and
+ \code{center = 0} (the defaults) are used, but may not work as well as when
+ \code{r} and \code{center} are well chosen.
+
+ When the tails of the unnormalized density are not exponentially light
+ (so the tails of the log unnormalized density decrease sublinearly, as
+ in the case of univariate and multivariate \eqn{t} distributions), one
+ should use \code{\link{morph}} with \code{r > 0} and \code{p = 3}, which
+ produces a transformation of the form \eqn{g_2}{g2} composed
+ with \eqn{g_1}{g1} in the notation
+ used in the details section of the help for \code{\link{morph}}.
+ This will produce a geometrically ergodic sampler if other features of the
+ log unnormalized density are well behaved. For example it will do so
+ for the \eqn{t} examples mentioned above.
+ (See Johnson and Geyer, submitted, for the complete theory.)
+}
+\value{
+ an object of class \code{mcmc}, subclass \code{morph.metropolis}.
+ This object is a list containing all of the elements from an object
+ returned by \code{\link{metrop}}, plus at least the following
+ components:
+ \item{morph}{the morph object used for the transformations.}
+ \item{morph.final}{the final state of the Markov chain on the
+ transformed scale.}
+}
+\examples{
+out <- morph.metrop(function(x) dt(x, df=3, log=TRUE), 0, blen=100,
+ nbatch=100, morph=morph(b=1))
+# change the transformation.
+out <- morph.metrop(out, morph=morph(b=2))
+out$accept
+# accept rate is high, increase the scale.
+out <- morph.metrop(out, scale=4)
+# close to 0.20 is about right.
+out$accept
+}
+\references{
+Johnson, L. T. and Geyer, C. J. (submitted)
+Variable Transformation to Obtain Geometric Ergodicity
+ in the Random-walk Metropolis Algorithm.
+}
+\seealso{
+ \code{\link{metrop}}, \code{\link{morph}}.
+}
+\keyword{misc}
diff --git a/man/olbm.Rd b/man/olbm.Rd
new file mode 100644
index 0000000..49362bf
--- /dev/null
+++ b/man/olbm.Rd
@@ -0,0 +1,40 @@
+\name{olbm}
+\alias{olbm}
+\title{Overlapping Batch Means}
+\description{
+ Variance of sample mean of time series calculated using overlapping
+ batch means.
+}
+\usage{
+olbm(x, batch.length, demean = TRUE)
+}
+\arguments{
+ \item{x}{a matrix or time series object. Each column of \code{x} is
+ treated as a scalar time series.}
+ \item{batch.length}{length of batches.}
+ \item{demean}{when \code{demean = TRUE} (the default) the sample mean
+ is subtracted from each batch mean when estimating the variance.
+ Using \code{demean = FALSE} would essentially assume the true mean
+ is known to be zero, which might be useful in a toy problem where
+ the answer is known.}
+}
+\value{
+ The estimated variance of the sample mean.
+}
+\seealso{
+ \code{\link{ts}}
+}
+\examples{
+h <- function(x) if (all(x >= 0) && sum(x) <= 1) return(1) else return(-Inf)
+out <- metrop(h, rep(0, 5), 1000)
+out <- metrop(out, scale = 0.1)
+out <- metrop(out, nbatch = 1e4)
+olbm(out$batch, 150)
+# monte carlo estimates (true means are same by symmetry)
+apply(out$batch, 1, mean)
+# monte carlo standard errors (true s. d. are same by symmetry)
+sqrt(diag(olbm(out$batch, 150)))
+# check that batch length is reasonable
+acf(out$batch, lag.max = 200)
+}
+\keyword{ts}
diff --git a/man/temper.Rd b/man/temper.Rd
new file mode 100644
index 0000000..d3a3f38
--- /dev/null
+++ b/man/temper.Rd
@@ -0,0 +1,219 @@
+\name{temper}
+\alias{temper}
+\alias{temper.function}
+\alias{temper.tempering}
+\title{Simulated Tempering and Umbrella Sampling}
+\description{
+ Markov chain Monte Carlo for continuous random vectors using parallel
+ or serial simulated tempering, also called umbrella sampling. For
+ serial tempering the state of the Markov chain is a pair \eqn{(i, x)},
+ where \eqn{i} is an integer between 1 and \eqn{k} and \eqn{x} is a vector
+ of length \eqn{p}. This pair is represented as a single real vector
+ \code{c(i, x)}. For parallel tempering the state of the Markov chain
+ is vector of vectors \eqn{(x_1, \ldots, x_k)}{(x[1], \ldots, x[k])},
+ where each \code{x} is of length \eqn{p}. This vector of vectors is
+ represented as a \eqn{k \times p}{k by p} matrix.
+}
+\usage{
+temper(obj, initial, neighbors, nbatch, blen = 1, nspac = 1, scale = 1,
+ outfun, debug = FALSE, parallel = FALSE, \dots)
+}
+\arguments{
+ \item{obj}{either an \R function or an object of class \code{"tempering"} from
+ a previous run. If a function, should evaluate the log unnormalized
+ density \eqn{\log h(i, x)}{log h(i, x)} of the desired equilibrium
+ distribution of the Markov chain for serial tempering (the same function
+ is used for both serial and parallel tempering, see details below for
+ further explanation). If an object, the log unnormalized density function
+ is \code{obj$lud}, and missing arguments of \code{temper} are
+ obtained from the corresponding elements of \code{obj}.
+ The first argument of the log unnormalized density function is the
+ state for simulated tempering \eqn{(i, x)} is supplied as an \R vector
+ \code{c(i, x)}; other arguments are arbitrary and taken from
+ the \code{\dots} arguments of \code{temper}. The log unnormalized density
+ function should return \code{-Inf} for points of the state space having
+ probability zero.}
+ \item{initial}{for serial tempering, a real vector \code{c(i, x)} as
+ described above. For parallel tempering, a real
+ \eqn{k \times p}{k by p} matrix as described above. In either case,
+ the initial state of the Markov chain.}
+ \item{neighbors}{a logical symmetric matrix of dimension \code{k}
+ by \code{k}. Elements that are \code{TRUE} indicate jumps
+ or swaps attempted by the Markov chain.}
+ \item{nbatch}{the number of batches.}
+ \item{blen}{the length of batches.}
+ \item{nspac}{the spacing of iterations that contribute to batches.}
+ \item{scale}{controls the proposal step size for real elements of the state
+ vector. For serial tempering, proposing a new value for the \eqn{x}
+ part of the state \eqn{(i, x)}. For parallel tempering, proposing
+ a new value for the \eqn{x_i}{x[i]} part of the state
+ \eqn{(x_1, \ldots, x_k)}{(x[1], \ldots, x[k])}. In either case, the proposal
+ is a real vector of length \eqn{p}. If scalar or vector, the proposal
+ is \code{x + scale * z} where \code{x} is the part \eqn{x} or
+ \eqn{x_i}{x[i]} of the state the proposal may replace.
+ If matrix, the proposal is
+ \code{x + scale \%*\% z}. If list, the length must be \code{k},
+ and each element must be scalar, vector, or matrix, and operate as
+ described above. The \eqn{i}-th component of the list is used to update
+ \eqn{x} when the state is \eqn{(i, x)} or \eqn{x_i}{x[i]} otherwise.}
+ \item{outfun}{controls the output. If a function, then the batch means
+ of \code{outfun(state, \dots)} are returned. The argument \code{state}
+ is like the argument \code{initial} of this function. If missing, the
+ batch means of the real part of the state vector or matrix are returned,
+ and for serial tempering the batch means of a multivariate Bernoulli
+ indicating the current component are returned.}
+ \item{debug}{if \code{TRUE} extra output useful for testing.}
+ \item{parallel}{if \code{TRUE} does parallel tempering, if \code{FALSE} does
+ serial tempering.}
+ \item{...}{additional arguments for \code{obj} or \code{outfun}.}
+}
+\details{
+Serial tempering simulates a mixture of distributions of a continuous random
+vector. The number of components of the mixture is \code{k}, and the dimension
+of the random vector is \code{p}. Denote the state \eqn{(i, x)}, where \eqn{i}
+is a positive integer between 1 and \eqn{k}, and let \eqn{h(i, x)} denote
+the unnormalized joint density of their equilibrium distribution.
+The logarithm of this function is what \code{obj} or \code{obj$lud} calculates.
+The mixture distribution is the marginal for \eqn{x} derived from
+the equilibrium distribution \eqn{h(i, x)}, that is,
+\deqn{h(x) = \sum_{i = 1}^k h(i, x)}{h(x) = sum[i = 1 to k] h(i, x)}
+
+Parallel tempering simulates a product of distributions of a continuous random
+vector. Denote the state \eqn{(x_1, \ldots, x_k)}{(x[1], \ldots, x[k])},
+then the unnormalized joint density of the equilibrium distribution is
+\deqn{h(x_1, \ldots, x_k) = \prod_{i = 1}^k h(i, x_i)}{h(x[1], \dots, x[k]) = prod[i = 1 to k] h(i, x[i])}
+
+The update mechanism of the Markov chain combines two kinds of elementary
+updates: jump/swap updates (jump for serial tempering, swap for parallel
+tempering) and within-component updates. Each iteration of the Markov chain
+one of these elementary updates is done. With probability 1/2 a jump/swap
+update is done, and with probability 1/2 a with-component update is done.
+
+Within-component updates are the same for both serial and parallel tempering.
+They are \dQuote{random-walk} Metropolis updates with multivariate normal
+proposal, the proposal distribution being determined by the argument
+\code{scale}. In serial tempering, the \eqn{x} part of the current state
+\eqn{(i, x)} is updated preserving \eqn{h(i, x)}.
+In parallel tempering, an index \eqn{i} is chosen at random and the part
+of the state \eqn{x_i}{x[i]} representing that component is updated,
+again preserving \eqn{h(i, x)}.
+
+Jump updates choose uniformly at random a neighbor of the current component:
+if \eqn{i} indexes the current component, then it chooses uniformly at random
+a \eqn{j} such that \code{neighbors[i, j] == TRUE}. It then does does a
+Metropolis-Hastings update for changing the current state from \eqn{(i, x)}
+to \eqn{(j, x)}.
+
+Swap updates choose a component uniformly at random and a neighbor of that
+component uniformly at random: first an index \eqn{i} is chosen uniformly
+at random between 1 and \eqn{k}, then an index \eqn{j} is chosen
+uniformly at random such that \code{neighbors[i, j] == TRUE}. It then does
+does a Metropolis-Hastings update for swapping the states of the
+two components: interchanging \eqn{x_i}{x[i, ]} and \eqn{x_j}{x[j, ]}
+while preserving \eqn{h(x_1, \ldots, x_k)}{h(x[1], \dots, x[k])}.
+
+The initial state must satisfy \code{lud(initial, ...) > - Inf} for serial
+tempering or must satisfy \code{lud(initial[i, ], ...) > - Inf} for each
+\code{i} for parallel tempering, where \code{lud} is either \code{obj}
+or \code{obj$lud}.
+That is, the initial state must have positive probability.
+}
+\value{
+ an object of class \code{"mcmc"}, subclass \code{"tempering"},
+ which is a list containing at least the following components:
+ \item{batch}{the batch means of the continuous part of the state.
+ If \code{outfun} is missing, an \code{nbatch} by \code{k} by \code{p}
+ array. Otherwise, an \code{nbatch} by \code{m} matrix, where \code{m}
+ is the length of the result of \code{outfun}.}
+ \item{ibatch}{(returned for serial tempering only) an \code{nbatch}
+ by \code{k} matrix giving batch means for the multivariate Bernoulli
+ random vector that is all zeros except for a 1 in the \code{i}-th place
+ when the current state is \eqn{(i, x)}.}
+ \item{acceptx}{fraction of Metropolis within-component proposals accepted.
+ A vector of length \code{k} giving the acceptance rate for each component.}
+ \item{accepti}{fraction of Metropolis jump/swap proposals accepted.
+ A \code{k} by \code{k} matrix giving the acceptance rate for each allowed
+ jump or swap component. \code{NA} for elements such that the corresponding
+ elements of \code{neighbors} is \code{FALSE}.}
+ \item{initial}{value of argument \code{initial}.}
+ \item{final}{final state of Markov chain.}
+ \item{initial.seed}{value of \code{.Random.seed} before the run.}
+ \item{final.seed}{value of \code{.Random.seed} after the run.}
+ \item{time}{running time of Markov chain from \code{system.time()}.}
+ \item{lud}{the function used to calculate log unnormalized density,
+ either \code{obj} or \code{obj$lud} from a previous run.}
+ \item{nbatch}{the argument \code{nbatch} or \code{obj$nbatch}.}
+ \item{blen}{the argument \code{blen} or \code{obj$blen}.}
+ \item{nspac}{the argument \code{nspac} or \code{obj$nspac}.}
+ \item{outfun}{the argument \code{outfun} or \code{obj$outfun}.}
+ Description of additional output when \code{debug = TRUE} can be
+ found in the vignette \code{debug} (\url{../doc/debug.pdf}).
+}
+\section{Warning}{
+If \code{outfun} is missing, then the log unnormalized
+density function can be defined without a \ldots argument and that works fine.
+One can define it starting \code{ludfun <- function(state)} and that works
+or \code{ludfun <- function(state, foo, bar)}, where \code{foo} and \code{bar}
+are supplied as additional arguments to \code{temper} and that works too.
+
+If \code{outfun} is a function, then both it and the log unnormalized
+density function can be defined without \ldots arguments \emph{if they
+have exactly the same arguments list} and that works fine. Otherwise it
+doesn't work. Start the definitions \code{ludfun <- function(state, foo)}
+and \code{outfun <- function(state, bar)} and you get an error about
+unused arguments. Instead start the definitions
+\code{ludfun <- function(state, foo, \ldots)}
+and \code{outfun <- function(state, bar, \ldots)}, supply
+\code{foo} and \code{bar} as additional arguments to \code{temper},
+and that works fine.
+
+In short, the log unnormalized density function and \code{outfun} need
+to have \ldots in their arguments list to be safe. Sometimes it works
+when \ldots is left out and sometimes it doesn't.
+
+Of course, one can avoid this whole issue by always defining the log
+unnormalized density function and \code{outfun} to have only one argument
+\code{state} and use global variables (objects in the R global environment) to
+specify any other information these functions need to use. That too
+follows the R way. But some people consider that bad programming practice.
+}
+\examples{
+d <- 9
+witch.which <- c(0.1, 0.3, 0.5, 0.7, 1.0)
+ncomp <- length(witch.which)
+
+neighbors <- matrix(FALSE, ncomp, ncomp)
+neighbors[row(neighbors) == col(neighbors) + 1] <- TRUE
+neighbors[row(neighbors) == col(neighbors) - 1] <- TRUE
+
+ludfun <- function(state, log.pseudo.prior = rep(0, ncomp)) {
+ stopifnot(is.numeric(state))
+ stopifnot(length(state) == d + 1)
+ icomp <- state[1]
+ stopifnot(icomp == as.integer(icomp))
+ stopifnot(1 <= icomp && icomp <= ncomp)
+ stopifnot(is.numeric(log.pseudo.prior))
+ stopifnot(length(log.pseudo.prior) == ncomp)
+ theta <- state[-1]
+ if (any(theta > 1.0)) return(-Inf)
+ bnd <- witch.which[icomp]
+ lpp <- log.pseudo.prior[icomp]
+ if (any(theta > bnd)) return(lpp)
+ return(- d * log(bnd) + lpp)
+}
+
+# parallel tempering
+thetas <- matrix(0.5, ncomp, d)
+out <- temper(ludfun, initial = thetas, neighbors = neighbors, nbatch = 20,
+ blen = 10, nspac = 5, scale = 0.56789, parallel = TRUE, debug = TRUE)
+
+# serial tempering
+theta.initial <- c(1, rep(0.5, d))
+# log pseudo prior found by trial and error
+qux <- c(0, 9.179, 13.73, 16.71, 20.56)
+
+out <- temper(ludfun, initial = theta.initial, neighbors = neighbors,
+ nbatch = 50, blen = 30, nspac = 2, scale = 0.56789,
+ parallel = FALSE, debug = FALSE, log.pseudo.prior = qux)
+}
+\keyword{misc}
diff --git a/src/getListElement.c b/src/getListElement.c
new file mode 100644
index 0000000..a1ef1a4
--- /dev/null
+++ b/src/getListElement.c
@@ -0,0 +1,53 @@
+
+/*
+*
+* mcmc and MCMC package for R
+* Copyright (c) 2005 Charles J. Geyer
+*
+* 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, and/or sell copies of the
+* Software, and to permit persons to whom the Software is furnished to do so,
+* provided that the above copyright notice(s) and this permission notice appear
+* in all copies of the Software and that both the above copyright notice(s) and
+* this permission notice appear in supporting documentation.
+*
+* 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 OF THIRD PARTY RIGHTS.
+* IN NO EVENT SHALL THE COPYRIGHT HOLDER OR HOLDERS INCLUDED IN THIS NOTICE
+* BE LIABLE FOR ANY CLAIM, OR ANY SPECIAL INDIRECT OR CONSEQUENTIAL DAMAGES,
+* OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+* WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
+* ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+*
+* Except as contained in this notice, the name of a copyright holder shall
+* not be used in advertising or otherwise to promote the sale, use or other
+* dealings in this Software without prior written authorization of the
+* copyright holder.
+*/
+
+#include <R.h>
+#include <Rinternals.h>
+#include "myutil.h"
+
+SEXP getListElement(SEXP list, char *str)
+{
+ SEXP elmt = R_NilValue;
+ SEXP names = getAttrib(list, R_NamesSymbol);
+ int i;
+
+ if (names == R_NilValue)
+ return R_NilValue;
+
+ for (i = 0; i < length(list); i++)
+ if(strcmp(CHAR(STRING_ELT(names, i)), str) == 0) {
+ elmt = VECTOR_ELT(list, i);
+ break;
+ }
+ return elmt;
+}
+
diff --git a/src/getScalarInteger.c b/src/getScalarInteger.c
new file mode 100644
index 0000000..2195630
--- /dev/null
+++ b/src/getScalarInteger.c
@@ -0,0 +1,51 @@
+
+/*
+*
+* mcmc and MCMC package for R
+* Copyright (c) 2005 Charles J. Geyer
+*
+* 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, and/or sell copies of the
+* Software, and to permit persons to whom the Software is furnished to do so,
+* provided that the above copyright notice(s) and this permission notice appear
+* in all copies of the Software and that both the above copyright notice(s) and
+* this permission notice appear in supporting documentation.
+*
+* 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 OF THIRD PARTY RIGHTS.
+* IN NO EVENT SHALL THE COPYRIGHT HOLDER OR HOLDERS INCLUDED IN THIS NOTICE
+* BE LIABLE FOR ANY CLAIM, OR ANY SPECIAL INDIRECT OR CONSEQUENTIAL DAMAGES,
+* OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+* WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
+* ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+*
+* Except as contained in this notice, the name of a copyright holder shall
+* not be used in advertising or otherwise to promote the sale, use or other
+* dealings in this Software without prior written authorization of the
+* copyright holder.
+*/
+
+#include <R.h>
+#include <Rinternals.h>
+#include "myutil.h"
+
+int
+getScalarInteger(SEXP foo, char *argname)
+{
+ if (! isNumeric(foo))
+ error("argument \"%s\" must be numeric", argname);
+ if (LENGTH(foo) != 1)
+ error("argument \"%s\" must be scalar", argname);
+ if (isInteger(foo)) {
+ return INTEGER(foo)[0];
+ } else {
+ SEXP bar = coerceVector(foo, INTSXP);
+ return INTEGER(bar)[0];
+ }
+}
+
diff --git a/src/getScalarLogical.c b/src/getScalarLogical.c
new file mode 100644
index 0000000..79e844d
--- /dev/null
+++ b/src/getScalarLogical.c
@@ -0,0 +1,46 @@
+
+/*
+*
+* mcmc and MCMC package for R
+* Copyright (c) 2005 Charles J. Geyer
+*
+* 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, and/or sell copies of the
+* Software, and to permit persons to whom the Software is furnished to do so,
+* provided that the above copyright notice(s) and this permission notice appear
+* in all copies of the Software and that both the above copyright notice(s) and
+* this permission notice appear in supporting documentation.
+*
+* 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 OF THIRD PARTY RIGHTS.
+* IN NO EVENT SHALL THE COPYRIGHT HOLDER OR HOLDERS INCLUDED IN THIS NOTICE
+* BE LIABLE FOR ANY CLAIM, OR ANY SPECIAL INDIRECT OR CONSEQUENTIAL DAMAGES,
+* OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+* WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
+* ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+*
+* Except as contained in this notice, the name of a copyright holder shall
+* not be used in advertising or otherwise to promote the sale, use or other
+* dealings in this Software without prior written authorization of the
+* copyright holder.
+*/
+
+#include <R.h>
+#include <Rinternals.h>
+#include "myutil.h"
+
+int
+getScalarLogical(SEXP foo, char *argname)
+{
+ if (! isLogical(foo))
+ error("argument \"%s\" must be logical", argname);
+ if (LENGTH(foo) != 1)
+ error("argument \"%s\" must be scalar", argname);
+ return LOGICAL(foo)[0];
+}
+
diff --git a/src/initseq.c b/src/initseq.c
new file mode 100644
index 0000000..7fbad2a
--- /dev/null
+++ b/src/initseq.c
@@ -0,0 +1,128 @@
+
+#include <R.h>
+#include <Rinternals.h>
+#include "myutil.h"
+
+SEXP initseq(SEXP x)
+{
+ SEXP xreal;
+
+ if (! isNumeric(x))
+ error("argument must be numeric");
+
+ PROTECT(xreal = coerceVector(x, REALSXP));
+ if (! isAllFinite(x))
+ error("all elements of argument must be finite");
+ int len = LENGTH(xreal);
+
+ double *buff = (double *) R_alloc(len / 2, sizeof(double));
+
+ int i;
+ double gamma_zero = 0.0; /* for gcc -Wall -Wextra */
+
+ for (i = 0; i < len / 2; ++i) {
+
+ int lag1 = 2 * i;
+ double gam1 = 0.0;
+ for (int j = 0; j + lag1 < len; ++j)
+ gam1 += REAL(xreal)[j] * REAL(xreal)[j + lag1];
+ gam1 /= len;
+
+ if (i == 0)
+ gamma_zero = gam1;
+
+ int lag2 = lag1 + 1;
+ double gam2 = 0.0;
+ for (int j = 0; j + lag2 < len; ++j)
+ gam2 += REAL(xreal)[j] * REAL(xreal)[j + lag2];
+ gam2 /= len;
+
+ buff[i] = gam1 + gam2;
+ if (buff[i] < 0.0) {
+ buff[i] = 0.0;
+ ++i;
+ break;
+ }
+ }
+
+ SEXP gamma_pos, gamma_dec, gamma_con;
+
+ PROTECT(gamma_pos = allocVector(REALSXP, i));
+ for (int j = 0; j < i; ++j)
+ REAL(gamma_pos)[j] = buff[j];
+
+ for (int j = 1; j < i; ++j)
+ if (buff[j] > buff[j - 1])
+ buff[j] = buff[j - 1];
+
+ PROTECT(gamma_dec = allocVector(REALSXP, i));
+ for (int j = 0; j < i; ++j)
+ REAL(gamma_dec)[j] = buff[j];
+
+ for (int j = i - 1; j > 0; --j)
+ buff[j] -= buff[j - 1];
+
+ /* Pool Adjacent Violators Algorithm (PAVA) */
+ double *puff = (double *) R_alloc(i, sizeof(double));
+ int *nuff = (int *) R_alloc(i, sizeof(int));
+ int nstep = 0;
+ for (int j = 1; j < i; ++j) {
+ puff[nstep] = buff[j];
+ nuff[nstep] = 1;
+ ++nstep;
+ while(nstep > 1 && puff[nstep - 1] / nuff[nstep - 1]
+ < puff[nstep - 2] / nuff[nstep - 2]) {
+ puff[nstep - 2] += puff[nstep - 1];
+ nuff[nstep - 2] += nuff[nstep - 1];
+ --nstep;
+ }
+ }
+
+ for (int jstep = 0, j = 1; jstep < nstep; ++jstep) {
+ double muff = puff[jstep] / nuff[jstep];
+ for (int k = 0; k < nuff[jstep]; ++j, ++k)
+ buff[j] = buff[j - 1] + muff;
+ }
+
+ PROTECT(gamma_con = allocVector(REALSXP, i));
+ for (int j = 0; j < i; ++j)
+ REAL(gamma_con)[j] = buff[j];
+
+ double var_pos = 0.0;
+ double var_dec = 0.0;
+ double var_con = 0.0;
+ for (int j = 0; j < i; ++j) {
+ var_pos += REAL(gamma_pos)[j];
+ var_dec += REAL(gamma_dec)[j];
+ var_con += REAL(gamma_con)[j];
+ }
+ var_pos *= 2.0;
+ var_dec *= 2.0;
+ var_con *= 2.0;
+ var_pos -= gamma_zero;
+ var_dec -= gamma_zero;
+ var_con -= gamma_zero;
+
+ SEXP result, resultnames;
+ PROTECT(result = allocVector(VECSXP, 7));
+ PROTECT(resultnames = allocVector(STRSXP, 7));
+ SET_VECTOR_ELT(result, 0, ScalarReal(gamma_zero));
+ SET_STRING_ELT(resultnames, 0, mkChar("gamma0"));
+ SET_VECTOR_ELT(result, 1, gamma_pos);
+ SET_STRING_ELT(resultnames, 1, mkChar("Gamma.pos"));
+ SET_VECTOR_ELT(result, 2, gamma_dec);
+ SET_STRING_ELT(resultnames, 2, mkChar("Gamma.dec"));
+ SET_VECTOR_ELT(result, 3, gamma_con);
+ SET_STRING_ELT(resultnames, 3, mkChar("Gamma.con"));
+ SET_VECTOR_ELT(result, 4, ScalarReal(var_pos));
+ SET_STRING_ELT(resultnames, 4, mkChar("var.pos"));
+ SET_VECTOR_ELT(result, 5, ScalarReal(var_dec));
+ SET_STRING_ELT(resultnames, 5, mkChar("var.dec"));
+ SET_VECTOR_ELT(result, 6, ScalarReal(var_con));
+ SET_STRING_ELT(resultnames, 6, mkChar("var.con"));
+ namesgets(result, resultnames);
+
+ UNPROTECT(6);
+ return result;
+}
+
diff --git a/src/isAllFinite.c b/src/isAllFinite.c
new file mode 100644
index 0000000..c129b32
--- /dev/null
+++ b/src/isAllFinite.c
@@ -0,0 +1,51 @@
+
+/*
+*
+* mcmc and MCMC package for R
+* Copyright (c) 2005 Charles J. Geyer
+*
+* 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, and/or sell copies of the
+* Software, and to permit persons to whom the Software is furnished to do so,
+* provided that the above copyright notice(s) and this permission notice appear
+* in all copies of the Software and that both the above copyright notice(s) and
+* this permission notice appear in supporting documentation.
+*
+* 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 OF THIRD PARTY RIGHTS.
+* IN NO EVENT SHALL THE COPYRIGHT HOLDER OR HOLDERS INCLUDED IN THIS NOTICE
+* BE LIABLE FOR ANY CLAIM, OR ANY SPECIAL INDIRECT OR CONSEQUENTIAL DAMAGES,
+* OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+* WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
+* ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+*
+* Except as contained in this notice, the name of a copyright holder shall
+* not be used in advertising or otherwise to promote the sale, use or other
+* dealings in this Software without prior written authorization of the
+* copyright holder.
+*/
+
+#include <R.h>
+#include <Rinternals.h>
+#include "myutil.h"
+
+int
+isAllFinite(SEXP foo)
+{
+ int d, i;
+ int result = TRUE;
+
+ if (! isReal(foo))
+ error("argument must be real");
+
+ d = LENGTH(foo);
+ for (i = 0; i < d; i++)
+ result &= R_finite(REAL(foo)[i]);
+ return result;
+}
+
diff --git a/src/metrop.c b/src/metrop.c
new file mode 100644
index 0000000..848d09a
--- /dev/null
+++ b/src/metrop.c
@@ -0,0 +1,493 @@
+
+/*
+*
+* mcmc and MCMC package for R
+* Copyright (c) 2005 Charles J. Geyer
+*
+* 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, and/or sell copies of the
+* Software, and to permit persons to whom the Software is furnished to do so,
+* provided that the above copyright notice(s) and this permission notice appear
+* in all copies of the Software and that both the above copyright notice(s) and
+* this permission notice appear in supporting documentation.
+*
+* 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 OF THIRD PARTY RIGHTS.
+* IN NO EVENT SHALL THE COPYRIGHT HOLDER OR HOLDERS INCLUDED IN THIS NOTICE
+* BE LIABLE FOR ANY CLAIM, OR ANY SPECIAL INDIRECT OR CONSEQUENTIAL DAMAGES,
+* OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+* WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
+* ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+*
+* Except as contained in this notice, the name of a copyright holder shall
+* not be used in advertising or otherwise to promote the sale, use or other
+* dealings in this Software without prior written authorization of the
+* copyright holder.
+*/
+
+#include <R.h>
+#include <Rinternals.h>
+#include <Rmath.h>
+#include "myutil.h"
+
+static void proposal_setup(SEXP scale, int d);
+
+static void propose(SEXP state, SEXP proposal, double *z);
+
+static double logh(SEXP func, SEXP state, SEXP rho);
+
+static int out_setup(SEXP func, SEXP rho, SEXP state);
+
+static void outfun(SEXP state, SEXP buffer);
+
+SEXP metrop(SEXP func1, SEXP initial, SEXP nbatch, SEXP blen, SEXP nspac,
+ SEXP scale, SEXP func2, SEXP debug, SEXP rho1, SEXP rho2)
+{
+ int int_nbatch, int_blen, int_nspac, int_debug;
+ SEXP state, proposal;
+ int dim_state, dim_out;
+ SEXP result, resultnames, acceptance_rate, path,
+ save_initial, save_final;
+ double *batch_buffer;
+ SEXP out_buffer;
+ int ibatch, jbatch, ispac;
+
+ int i, k;
+ double acceptances = 0.0;
+ double tries = 0.0;
+
+ double current_log_dens;
+
+ if (! isFunction(func1))
+ error("argument \"func1\" must be function");
+ if (! isEnvironment(rho1))
+ error("argument \"rho1\" must be environment");
+
+ if (! isNumeric(initial))
+ error("argument \"initial\" must be numeric");
+ if (! isNumeric(nbatch))
+ error("argument \"nbatch\" must be numeric");
+ if (! isNumeric(blen))
+ error("argument \"blen\" must be numeric");
+ if (! isNumeric(nspac))
+ error("argument \"nspac\" must be numeric");
+ if (! isNumeric(scale))
+ error("argument \"scale\" must be numeric");
+
+ if (! isLogical(debug))
+ error("argument \"debug\" must be logical");
+
+ int_nbatch = getScalarInteger(nbatch, "nbatch");
+ int_blen = getScalarInteger(blen, "blen");
+ int_nspac = getScalarInteger(nspac, "nspac");
+
+ int_debug = getScalarLogical(debug, "debug");
+
+ if (int_nbatch <= 0)
+ error("argument \"nbatch\" must be positive");
+ if (int_blen <= 0)
+ error("argument \"blen\" must be positive");
+ if (int_nspac <= 0)
+ error("argument \"nspac\" must be positive");
+
+ PROTECT(state = coerceVector(duplicate(initial), REALSXP));
+ if (! isAllFinite(state))
+ error("all elements of \"state\" must be finite");
+ dim_state = LENGTH(state);
+
+ PROTECT(proposal = allocVector(REALSXP, dim_state));
+ proposal_setup(scale, dim_state);
+
+ dim_out = out_setup(func2, rho2, state);
+ batch_buffer = (double *) R_alloc(dim_out, sizeof(double));
+ PROTECT(out_buffer = allocVector(REALSXP, dim_out));
+
+ if (! int_debug) {
+ PROTECT(result = allocVector(VECSXP, 4));
+ PROTECT(resultnames = allocVector(STRSXP, 4));
+ } else {
+ PROTECT(result = allocVector(VECSXP, 10));
+ PROTECT(resultnames = allocVector(STRSXP, 10));
+ }
+ PROTECT(acceptance_rate = allocVector(REALSXP, 1));
+ SET_VECTOR_ELT(result, 0, acceptance_rate);
+ PROTECT(path = allocMatrix(REALSXP, dim_out, int_nbatch));
+ SET_VECTOR_ELT(result, 1, path);
+ PROTECT(save_initial = duplicate(state));
+ SET_VECTOR_ELT(result, 2, save_initial);
+ UNPROTECT(3);
+ SET_STRING_ELT(resultnames, 0, mkChar("accept"));
+ SET_STRING_ELT(resultnames, 1, mkChar("batch"));
+ SET_STRING_ELT(resultnames, 2, mkChar("initial"));
+ SET_STRING_ELT(resultnames, 3, mkChar("final"));
+ if (int_debug) {
+ SEXP spath, ppath, gpath, upath, zpath, apath;
+ int nn = int_nbatch * int_blen * int_nspac;
+ PROTECT(spath = allocMatrix(REALSXP, dim_state, nn));
+ SET_VECTOR_ELT(result, 4, spath);
+ PROTECT(ppath = allocMatrix(REALSXP, dim_state, nn));
+ SET_VECTOR_ELT(result, 5, ppath);
+ PROTECT(gpath = allocVector(REALSXP, nn));
+ SET_VECTOR_ELT(result, 6, gpath);
+ PROTECT(upath = allocVector(REALSXP, nn));
+ SET_VECTOR_ELT(result, 7, upath);
+ PROTECT(zpath = allocMatrix(REALSXP, dim_state, nn));
+ SET_VECTOR_ELT(result, 8, zpath);
+ PROTECT(apath = allocVector(LGLSXP, nn));
+ SET_VECTOR_ELT(result, 9, apath);
+ UNPROTECT(6);
+ SET_STRING_ELT(resultnames, 4, mkChar("current"));
+ SET_STRING_ELT(resultnames, 5, mkChar("proposal"));
+ SET_STRING_ELT(resultnames, 6, mkChar("log.green"));
+ SET_STRING_ELT(resultnames, 7, mkChar("u"));
+ SET_STRING_ELT(resultnames, 8, mkChar("z"));
+ SET_STRING_ELT(resultnames, 9, mkChar("debug.accept"));
+ }
+ namesgets(result, resultnames);
+ UNPROTECT(1);
+
+ GetRNGstate();
+
+ current_log_dens = logh(func1, state, rho1);
+ if (current_log_dens == R_NegInf)
+ error("log unnormalized density -Inf at initial state");
+
+ for (ibatch = 0, k = 0; ibatch < int_nbatch; ibatch++) {
+
+ int j;
+
+ for (i = 0; i < dim_out; i++)
+ batch_buffer[i] = 0.0;
+
+ for (jbatch = 0; jbatch < int_blen; jbatch++) {
+
+ double proposal_log_dens;
+
+ for (ispac = 0; ispac < int_nspac; ispac++) {
+
+ int accept;
+ double u = -1.0; /* impossible return from unif_rand() */
+ double z[dim_state]; /* buffer for output of norm_rand() */
+
+ /* Note: should never happen! */
+ if (current_log_dens == R_NegInf)
+ error("log density -Inf at current state");
+
+ propose(state, proposal, z);
+
+ proposal_log_dens = logh(func1, proposal, rho1);
+
+ accept = FALSE;
+ if (proposal_log_dens != R_NegInf) {
+ if (proposal_log_dens > current_log_dens) {
+ accept = TRUE;
+ } else {
+ double green = exp(proposal_log_dens
+ - current_log_dens);
+ u = unif_rand();
+ accept = u < green;
+ }
+ }
+
+ if (int_debug) {
+ int l = ispac + int_nspac * (jbatch + int_blen * ibatch);
+ int lbase = l * dim_state;
+ SEXP spath = VECTOR_ELT(result, 4);
+ SEXP ppath = VECTOR_ELT(result, 5);
+ SEXP gpath = VECTOR_ELT(result, 6);
+ SEXP upath = VECTOR_ELT(result, 7);
+ SEXP zpath = VECTOR_ELT(result, 8);
+ SEXP apath = VECTOR_ELT(result, 9);
+ int lj;
+ for (lj = 0; lj < dim_state; lj++) {
+ REAL(spath)[lbase + lj] = REAL(state)[lj];
+ REAL(ppath)[lbase + lj] = REAL(proposal)[lj];
+ REAL(zpath)[lbase + lj] = z[lj];
+ }
+ REAL(gpath)[l] = proposal_log_dens - current_log_dens;
+ if (u == -1.0)
+ REAL(upath)[l] = NA_REAL;
+ else
+ REAL(upath)[l] = u;
+ LOGICAL(apath)[l] = accept;
+ }
+
+ if (accept) {
+ int jj;
+ for (jj = 0; jj < dim_state; jj++)
+ REAL(state)[jj] = REAL(proposal)[jj];
+ current_log_dens = proposal_log_dens;
+ acceptances++;
+ }
+ tries++;
+ } /* end of inner loop (one iteration) */
+
+ outfun(state, out_buffer);
+ for (j = 0; j < dim_out; j++)
+ batch_buffer[j] += REAL(out_buffer)[j];
+
+ } /* end of middle loop (one batch) */
+
+ for (j = 0; j < dim_out; j++, k++)
+ REAL(path)[k] = batch_buffer[j] / int_blen;
+
+ } /* end of outer loop */
+
+ PutRNGstate();
+
+ REAL(acceptance_rate)[0] = acceptances / tries;
+
+ PROTECT(save_final = coerceVector(state, REALSXP));
+ SET_VECTOR_ELT(result, 3, save_final);
+
+ UNPROTECT(5);
+ return result;
+}
+
+static double logh(SEXP func, SEXP state, SEXP rho)
+{
+ SEXP call, result, foo;
+ double bar;
+
+ PROTECT(call = lang2(func, state));
+ PROTECT(result = eval(call, rho));
+ if (! isNumeric(result))
+ error("logh: result of function call must be numeric");
+ if (LENGTH(result) != 1)
+ error("logh: result of function call must be scalar");
+ PROTECT(foo = coerceVector(result, REALSXP));
+ bar = REAL(foo)[0];
+ UNPROTECT(3);
+ if (bar == R_PosInf)
+ error("logh: func returned +Inf");
+ if (R_IsNaN(bar) || R_IsNA(bar))
+ error("logh: func returned NA or NaN");
+ /* Note: -Inf is allowed */
+ return bar;
+}
+
+static double *scale_factor;
+static double scale_factor_buffer;
+static int scale_option;
+static int state_dimension;
+#define CONSTANT 1
+#define DIAGONAL 2
+#define FULL 3
+
+static void proposal_setup(SEXP scale, int d)
+{
+ SEXP foo;
+
+ state_dimension = d;
+
+ PROTECT(foo = coerceVector(scale, REALSXP));
+ if (isMatrix(scale)) {
+ SEXP bar;
+ PROTECT(bar = getAttrib(scale, R_DimSymbol));
+ if (INTEGER(bar)[0] == d && INTEGER(bar)[1] == d) {
+ int i;
+ scale_factor = (double *) R_alloc(d * d, sizeof(double));
+ for (i = 0; i < d * d; i++)
+ scale_factor[i] = REAL(foo)[i];
+ scale_option = FULL;
+ } else {
+ error("dimensions of \"scale\" matrix not d by d");
+ }
+ UNPROTECT(1);
+ } else if (LENGTH(foo) == d) {
+ int i;
+ scale_factor = (double *) R_alloc(d, sizeof(double));
+ for (i = 0; i < d; i++)
+ scale_factor[i] = REAL(foo)[i];
+ scale_option = DIAGONAL;
+ } else if (LENGTH(foo) == 1) {
+ scale_factor = &scale_factor_buffer;
+ scale_factor[0] = REAL(foo)[0];
+ scale_option = CONSTANT;
+ } else {
+ error("length of \"scale\" vector not d or 1");
+ }
+ UNPROTECT(1);
+}
+
+static void propose(SEXP state, SEXP proposal, double *z)
+{
+ int d = state_dimension;
+ int i, j, k;
+
+ if (scale_option == 0)
+ error("attempt to call propose without setup");
+
+ if (LENGTH(state) != d || LENGTH(proposal) != d)
+ error("State or proposal length different from initialization\n");
+
+ for (j = 0; j < d; j++)
+ z[j] = norm_rand();
+
+ switch (scale_option) {
+ case CONSTANT:
+ for (j = 0; j < d; j++)
+ REAL(proposal)[j] = REAL(state)[j]
+ + scale_factor[0] * z[j];
+ break;
+ case DIAGONAL:
+ for (j = 0; j < d; j++)
+ REAL(proposal)[j] = REAL(state)[j]
+ + scale_factor[j] * z[j];
+ break;
+ case FULL:
+ for (j = 0; j < d; j++)
+ REAL(proposal)[j] = REAL(state)[j];
+
+ for (i = 0, k = 0; i < d; i++) {
+ double u = z[i];
+ for (j = 0; j < d; j++)
+ REAL(proposal)[j] += scale_factor[k++] * u;
+ }
+ break;
+ default:
+ error("bogus scaling option\n");
+ }
+}
+
+static SEXP out_func;
+static SEXP out_env;
+static int *out_index;
+static int out_option;
+static int out_dimension;
+static int out_state_dimension;
+#define OUT_FUNCTION 1
+#define OUT_INDEX 2
+#define OUT_IDENTITY 3
+
+static int out_setup(SEXP func, SEXP rho, SEXP state)
+{
+ out_state_dimension = LENGTH(state);
+
+ if (func == R_NilValue) {
+ out_option = OUT_IDENTITY;
+ out_dimension = out_state_dimension;
+ out_func = R_NilValue;
+ out_env = R_NilValue;
+ } else if (isFunction(func)) {
+ if (! isEnvironment(rho))
+ error("out_setup: argument \"rho\" must be environment");
+ out_option = OUT_FUNCTION;
+ out_func = func;
+ out_env = rho;
+ out_dimension = LENGTH(eval(lang2(func, state), rho));
+ } else if (isLogical(func)) {
+ int i;
+ if (LENGTH(func) != out_state_dimension)
+ error("is.logical(outfun) & (length(outfun) != length(initial))");
+ out_option = OUT_INDEX;
+ out_index = (int *) R_alloc(out_state_dimension, sizeof(int));
+ for (i = 0, out_dimension = 0; i < out_state_dimension; i++) {
+ out_index[i] = LOGICAL(func)[i];
+ out_dimension += out_index[i];
+ }
+ } else if (isNumeric(func)) {
+ SEXP foo;
+ int foolen, i;
+ int foopos = 0;
+ int fooneg = 0;
+ PROTECT(foo = coerceVector(func, REALSXP));
+ foolen = LENGTH(foo);
+ for (i = 0; i < foolen; i++) {
+ double foodble = REAL(foo)[i];
+ int fooint = foodble;
+ int fooabs = fooint > 0 ? fooint : (- fooint);
+
+ if (foodble == 0)
+ error("is.numeric(outfun) & any(outfun == 0)");
+ if (foodble != fooint)
+ error("is.numeric(outfun) & any(outfun != as.integer(outfun))");
+ if (fooabs > out_state_dimension)
+ error("is.numeric(outfun) & any(abs(outfun) > length(initial)");
+
+ if (foodble > 0)
+ foopos++;
+ else if (foodble < 0)
+ fooneg++;
+ }
+
+ if ((foopos > 0) && (fooneg > 0))
+ error("is.numeric(outfun) & any(outfun > 0) & any(outfun < 0)");
+
+ out_option = OUT_INDEX;
+ out_index = (int *) R_alloc(out_state_dimension, sizeof(int));
+ if (foopos > 0) {
+ for (i = 0; i < out_state_dimension; i++)
+ out_index[i] = FALSE;
+ for (i = 0; i < foolen; i++) {
+ int fooint = REAL(foo)[i];
+ out_index[fooint - 1] = TRUE;
+ }
+ } else /* (fooneg > 0) */ {
+ for (i = 0; i < out_state_dimension; i++)
+ out_index[i] = TRUE;
+ for (i = 0; i < foolen; i++) {
+ int fooint = REAL(foo)[i];
+ int fooabs = (- fooint);
+ out_index[fooabs - 1] = FALSE;
+ }
+ }
+ for (i = 0, out_dimension = 0; i < out_state_dimension; i++)
+ out_dimension += out_index[i];
+ UNPROTECT(1);
+ }
+ return out_dimension;
+}
+
+static void outfun(SEXP state, SEXP buffer)
+{
+ int j, k;
+
+ if (out_option == 0)
+ error("attempt to call outfun without setup");
+
+ if (LENGTH(state) != out_state_dimension)
+ error("outfun: state length different from initialization");
+ if (! isReal(buffer))
+ error("outfun: buffer must be real");
+ if (LENGTH(buffer) != out_dimension)
+ error("outfun: buffer length different from initialization");
+
+ switch (out_option) {
+ case OUT_IDENTITY:
+ for (j = 0; j < out_state_dimension; j++)
+ REAL(buffer)[j] = REAL(state)[j];
+ break;
+ case OUT_INDEX:
+ for (j = 0, k = 0; j < out_state_dimension; j++)
+ if (out_index[j])
+ REAL(buffer)[k++] = REAL(state)[j];
+ break;
+ case OUT_FUNCTION:
+ {
+ SEXP call, result, foo;
+
+ PROTECT(call = lang2(out_func, state));
+ PROTECT(result = eval(call, out_env));
+ if (! isNumeric(result))
+ error("outfun: result of function call must be numeric");
+ PROTECT(foo = coerceVector(result, REALSXP));
+ if (! isAllFinite(foo))
+ error("outfun returned vector with non-finite element");
+ if (LENGTH(foo) != out_dimension)
+ error("outfun return vector length changed from initial");
+ for (k = 0; k < out_dimension; k++)
+ REAL(buffer)[k] = REAL(foo)[k];
+ UNPROTECT(3);
+ }
+ break;
+ default:
+ error("bogus out option\n");
+ }
+}
+
diff --git a/src/myutil.h b/src/myutil.h
new file mode 100644
index 0000000..ed42cd1
--- /dev/null
+++ b/src/myutil.h
@@ -0,0 +1,40 @@
+
+/*
+*
+* mcmc and MCMC package for R
+* Copyright (c) 2005 Charles J. Geyer
+*
+* 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, and/or sell copies of the
+* Software, and to permit persons to whom the Software is furnished to do so,
+* provided that the above copyright notice(s) and this permission notice appear
+* in all copies of the Software and that both the above copyright notice(s) and
+* this permission notice appear in supporting documentation.
+*
+* 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 OF THIRD PARTY RIGHTS.
+* IN NO EVENT SHALL THE COPYRIGHT HOLDER OR HOLDERS INCLUDED IN THIS NOTICE
+* BE LIABLE FOR ANY CLAIM, OR ANY SPECIAL INDIRECT OR CONSEQUENTIAL DAMAGES,
+* OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+* WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
+* ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+*
+* Except as contained in this notice, the name of a copyright holder shall
+* not be used in advertising or otherwise to promote the sale, use or other
+* dealings in this Software without prior written authorization of the
+* copyright holder.
+*/
+
+#include <R.h>
+#include <Rinternals.h>
+
+SEXP getListElement(SEXP list, char *str);
+int getScalarInteger(SEXP foo, char *argname);
+int getScalarLogical(SEXP foo, char *argname);
+int isAllFinite(SEXP foo);
+
diff --git a/src/olbm.c b/src/olbm.c
new file mode 100644
index 0000000..26adefb
--- /dev/null
+++ b/src/olbm.c
@@ -0,0 +1,109 @@
+
+/*
+*
+* mcmc and MCMC package for R
+* Copyright (c) 2005 Charles J. Geyer
+*
+* 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, and/or sell copies of the
+* Software, and to permit persons to whom the Software is furnished to do so,
+* provided that the above copyright notice(s) and this permission notice appear
+* in all copies of the Software and that both the above copyright notice(s) and
+* this permission notice appear in supporting documentation.
+*
+* 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 OF THIRD PARTY RIGHTS.
+* IN NO EVENT SHALL THE COPYRIGHT HOLDER OR HOLDERS INCLUDED IN THIS NOTICE
+* BE LIABLE FOR ANY CLAIM, OR ANY SPECIAL INDIRECT OR CONSEQUENTIAL DAMAGES,
+* OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+* WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
+* ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+*
+* Except as contained in this notice, the name of a copyright holder shall
+* not be used in advertising or otherwise to promote the sale, use or other
+* dealings in this Software without prior written authorization of the
+* copyright holder.
+*/
+
+#include <R.h>
+
+/* overlapping batch means for vector time series
+*
+* input:
+*
+* x time series, n x p matrix, n time points and p components
+* len batch length
+*
+* output:
+*
+* mean sample mean, a p vector
+* var estimated variance of sample mean, a p x p matrix
+*
+*/
+
+#define X(I,J) x[(I) + n * (J)]
+#define VAR(I,J) var[(I) + p * (J)]
+
+void olbm(double *x, long *nin, long *pin, long *lin, double *mean,
+ double *var, long *nocalcin)
+{
+ int n = nin[0];
+ int p = pin[0];
+ int len = lin[0];
+ double nbatch = n - len + 1;
+ int nocalc = nocalcin[0];
+ double *work = (double *) R_alloc(p, sizeof(double));
+
+ int i, j, k, l;
+
+ if (len > n)
+ error("len > n\n");
+
+ if (! nocalc)
+ for (i=0; i<p; i++) {
+ double sum = 0.0;
+ for (k=0; k<n; k++)
+ sum += X(k,i);
+ mean[i] = sum / n;
+ }
+
+ /* easier to work with len * means, change means to that until
+ * further notice
+ */
+ for (i=0; i<p; i++)
+ mean[i] *= len;
+
+ for (i=0; i<p; i++) {
+ work[i] = 0.0;
+ for (k=0; k<len; k++)
+ work[i] += X(k,i);
+ for (j=i; j>=0; j--)
+ VAR(i,j) = (work[i] - mean[i]) * (work[j] - mean[j]);
+ }
+
+ for (k=0, l=len; l<n; k++, l++)
+ for (i=0; i<p; i++) {
+ work[i] -= X(k,i);
+ work[i] += X(l,i);
+ for (j=i; j>=0; j--)
+ VAR(i,j) += (work[i] - mean[i]) *
+ (work[j] - mean[j]);
+ }
+
+ /* fix up means and variances, divide out factors of len and len^2 */
+ for (i=0; i<p; i++)
+ mean[i] /= len;
+
+ for (i=0; i<p; i++)
+ for (j=0; j<=i; j++) {
+ VAR(i,j) /= nbatch * n * len;
+ if (j < i) VAR(j,i) = VAR(i,j);
+ }
+
+}
+
diff --git a/src/temper.c b/src/temper.c
new file mode 100644
index 0000000..78f3e21
--- /dev/null
+++ b/src/temper.c
@@ -0,0 +1,1015 @@
+
+/*
+*
+* mcmc and MCMC package for R
+* Copyright (c) 2009 Charles J. Geyer
+*
+* 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, and/or sell copies of the
+* Software, and to permit persons to whom the Software is furnished to do so,
+* provided that the above copyright notice(s) and this permission notice appear
+* in all copies of the Software and that both the above copyright notice(s) and
+* this permission notice appear in supporting documentation.
+*
+* 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 OF THIRD PARTY RIGHTS.
+* IN NO EVENT SHALL THE COPYRIGHT HOLDER OR HOLDERS INCLUDED IN THIS NOTICE
+* BE LIABLE FOR ANY CLAIM, OR ANY SPECIAL INDIRECT OR CONSEQUENTIAL DAMAGES,
+* OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+* WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
+* ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+*
+* Except as contained in this notice, the name of a copyright holder shall
+* not be used in advertising or otherwise to promote the sale, use or other
+* dealings in this Software without prior written authorization of the
+* copyright holder.
+*/
+
+#include <R.h>
+#include <Rinternals.h>
+#include <Rmath.h>
+#include "myutil.h"
+
+#ifdef BLEAT
+#include <stdio.h>
+#endif /* BLEAT */
+
+static void propose(SEXP coproposal, SEXP proposal, SEXP scale, double *z);
+
+static double logh(SEXP func, SEXP state, SEXP rho);
+
+static SEXP outfun(SEXP func, SEXP state, SEXP rho);
+
+static void check_valid_scale(SEXP scale, int i, int ncomp, int nx);
+
+SEXP temper(SEXP func1, SEXP initial, SEXP neighbors, SEXP nbatch,
+ SEXP blen, SEXP nspac, SEXP scale, SEXP func2, SEXP debug,
+ SEXP parallel, SEXP rho1, SEXP rho2)
+{
+ if (! isFunction(func1))
+ error("argument \"func1\" must be function");
+ if (! isEnvironment(rho1))
+ error("argument \"rho1\" must be environment");
+
+ int is_parallel = getScalarLogical(parallel, "parallel");
+ int is_debug = getScalarLogical(debug, "debug");
+
+ if (! isLogical(neighbors))
+ error("argument \"neighbors\" must be logical");
+ if (! isMatrix(neighbors))
+ error("argument \"neighbors\" must be matrix");
+ if (nrows(neighbors) != ncols(neighbors))
+ error("argument \"neighbors\" must have same row and column dimension");
+ int ncomp = nrows(neighbors);
+ for (int i = 0; i < ncomp; i++)
+ for (int j = 0; j < ncomp; j++)
+ if (LOGICAL(neighbors)[i + ncomp * j] != LOGICAL(neighbors)[j + ncomp * i])
+ error("argument \"neighbors\" must be symmetric matrix");
+
+ if (! isReal(initial))
+ error("argument \"initial\" must be real");
+ if (! isAllFinite(initial))
+ error("argument \"initial\" must have all elements finite");
+ int nx;
+ if (is_parallel) {
+ if (! isMatrix(initial))
+ error("argument \"initial\" must be matrix in parallel case");
+ if (nrows(initial) != ncomp)
+ error("row dim of args \"initial\" and \"neighbors\" must be same in parallel case");
+ nx = ncols(initial);
+ } else /* serial */ {
+ if (! (LENGTH(initial) > 1))
+ error("argument \"initial\" must have length > 1 in serial case");
+ double reali = REAL(initial)[0];
+ int i = reali;
+ if (i != reali)
+ error("1st elem of argument \"initial\" must be integer in serial case");
+ if (i <= 0 || i > ncomp)
+ error("1st elem of argument \"initial\" must be in 1, ..., k in serial case");
+ nx = LENGTH(initial) - 1;
+ }
+
+ int int_nbatch = getScalarInteger(nbatch, "nbatch");
+ if (int_nbatch <= 0)
+ error("argument \"nbatch\" must be positive");
+
+ int int_blen = getScalarInteger(blen, "blen");
+ if (int_blen <= 0)
+ error("argument \"blen\" must be positive");
+
+ int int_nspac = getScalarInteger(nspac, "nspac");
+ if (int_nspac <= 0)
+ error("argument \"nspac\" must be positive");
+
+ if (isNewList(scale)) {
+ if (LENGTH(scale) != ncomp)
+ error("argument \"scale\" must have length k if list");
+ for (int i = 0; i < ncomp; i++) {
+ SEXP fred = VECTOR_ELT(scale, i);
+ check_valid_scale(fred, i, ncomp, nx);
+ }
+ } else /* scale not list */ {
+ check_valid_scale(scale, -1, ncomp, nx);
+ }
+
+ int no_outfun = isNull(func2);
+ if (! no_outfun) {
+ if (! isFunction(func2))
+ error("argument \"outfun\" must be function");
+ if (! isEnvironment(rho2))
+ error("argument \"rho2\" must be environment");
+ }
+
+ double current_log_dens[ncomp];
+ if (is_parallel) {
+ SEXP fred;
+ PROTECT(fred = allocVector(REALSXP, nx + 1));
+ for (int i = 0; i < ncomp; i++) {
+ REAL(fred)[0] = i + 1;
+ for (int j = 0; j < nx; j++)
+ REAL(fred)[j + 1] = REAL(initial)[i + ncomp * j];
+ current_log_dens[i] = logh(func1, fred, rho1);
+#ifdef BLATHER
+ fprintf(stderr, "current_log_dens[%d] = %e\n", i, current_log_dens[i]);
+ for (int j = 0; j < nx; j++)
+ fprintf(stderr, " state[%d, %d] = %e\n",
+ i, j, REAL(initial)[i + ncomp * j]);
+ for (int j = 0; j <= nx; j++)
+ fprintf(stderr, " fred[%d] = %e\n", j, REAL(fred)[j]);
+ fprintf(stderr, " logh(func1, fred, rho1)) = %e\n",
+ logh(func1, fred, rho1));
+#endif /* BLATHER */
+ if (current_log_dens[i] == R_NegInf)
+ error("log unnormalized density -Inf at initial state");
+ }
+ UNPROTECT(1);
+ } else /* serial */ {
+ for (int i = 0; i < ncomp; i++)
+ current_log_dens[i] = R_NaN;
+ int i = REAL(initial)[0] - 1;
+ current_log_dens[i] = logh(func1, initial, rho1);
+ if (current_log_dens[i] == R_NegInf)
+ error("log unnormalized density -Inf at initial state");
+ }
+
+ /* at this point, all arguments have been checked for validity */
+
+ // current_log_dens saves info that cuts in half
+ // the number of invocations of log unnormalized density
+
+ SEXP state, proposal, coproposal;
+ PROTECT(state = duplicate(initial));
+ PROTECT(proposal = allocVector(REALSXP, nx + 1));
+ PROTECT(coproposal = allocVector(REALSXP, nx + 1));
+
+ int nout;
+ if (no_outfun) {
+ nout = is_parallel ? nx * ncomp : nx;
+ } else /* has outfun */ {
+ nout = LENGTH(outfun(func2, state, rho2));
+ }
+
+ int niter = int_nbatch * int_blen * int_nspac;
+
+ // TO DO LIST
+ //
+ // regular output (if serial)
+ //
+ // batch nbatch x nout matrix
+ // ibatch nbatch x ncomp matrix
+ // acceptx vector of length ncomp
+ // accepti ncomp x ncomp matrix
+ // initial copy of initial state
+ // final final state
+ //
+ // regular output (if parallel)
+ //
+ // batch (if outfun) nbatch x nout matrix
+ // (if no outfun) nbatch x ncomp x nx array
+ // acceptx vector of length ncomp
+ // accepti ncomp x ncomp matrix
+ // initial copy of initial state
+ // final final state
+ //
+ // debug output (if not parallel)
+ //
+ // which vector of length niter (TRUE if within-component)
+ // unif_which vector of length niter (uniform for deciding which)
+ // state niter x (nx + 1) matrix (state before)
+ // proposal niter x (nx + 1) matrix
+ // log_hastings niter vector
+ // unif_hastings niter vector (uniform for deciding acceptance)
+ // acceptd niter vector (TRUE if accept)
+ // norm niter x nx matrix (std normals)
+ // unif_choose niter vector (uniform for choosing neighbor)
+ //
+ // debug output (if parallel)
+ //
+ // which vector of length niter (TRUE if within-component)
+ // unif_which vector of length niter (uniform for deciding which)
+ // state niter x ncomp x nx array (state before)
+ // coproposal niter x (nx + 1) matrix
+ // proposal niter x (nx + 1) matrix
+ // log_hastings niter vector
+ // unif_hastings niter vector (uniform for deciding acceptance)
+ // acceptd niter vector (TRUE if accept)
+ // norm niter x nx matrix (std normals)
+ // unif_choose niter x 2 matrix (uniforms for choosing components
+ // to update)
+ //
+ // for within-component move coproposal and proposal have natural
+ // meaning
+ // for swap move we have 2 coproposals (i, x_i) and (j, x_j)
+ // and 2 proposals (i, x_j) and (j, x_i) but since the information
+ // here is quite redundant we just store (i, x_i) in "coproposal"
+ // and (j, x_j) in "proposal" -- the checker can figure it out
+
+ int len_result_regular = is_parallel ? 5 : 6;
+ int len_result_debug = is_parallel ? 10 : 9;
+ int len_result = len_result_regular;
+ len_result += is_debug ? len_result_debug : 0;
+
+#ifdef BLEAT
+ fprintf(stderr, "len_result = %d\n", len_result);
+#endif /* BLEAT */
+
+ SEXP result, resultnames, acceptx, accepti, batch, ibatch,
+ save_initial, save_final, debug_which, debug_unif_which,
+ debug_state, debug_coproposal, debug_proposal,
+ debug_log_hastings, debug_unif_hastings, debug_acceptd,
+ debug_norm, debug_unif_choose;
+
+ PROTECT(result = allocVector(VECSXP, len_result));
+ PROTECT(resultnames = allocVector(STRSXP, len_result));
+ namesgets(result, resultnames);
+ UNPROTECT(1);
+
+ if (no_outfun && is_parallel)
+ PROTECT(batch = alloc3DArray(REALSXP, int_nbatch, ncomp, nx));
+ else
+ PROTECT(batch = allocMatrix(REALSXP, int_nbatch, nout));
+ SET_VECTOR_ELT(result, 0, batch);
+ SET_STRING_ELT(resultnames, 0, mkChar("batch"));
+ UNPROTECT(1);
+
+ PROTECT(acceptx = allocVector(REALSXP, ncomp));
+ SET_VECTOR_ELT(result, 1, acceptx);
+ SET_STRING_ELT(resultnames, 1, mkChar("acceptx"));
+ UNPROTECT(1);
+
+ PROTECT(accepti = allocMatrix(REALSXP, ncomp, ncomp));
+ SET_VECTOR_ELT(result, 2, accepti);
+ SET_STRING_ELT(resultnames, 2, mkChar("accepti"));
+ UNPROTECT(1);
+
+ PROTECT(save_initial = duplicate(initial));
+ SET_VECTOR_ELT(result, 3, save_initial);
+ SET_STRING_ELT(resultnames, 3, mkChar("initial"));
+ UNPROTECT(1);
+
+ SET_STRING_ELT(resultnames, 4, mkChar("final"));
+ // at end need to duplicate state as save_final and copy to result[4]
+
+ if (! is_parallel) {
+ PROTECT(ibatch = allocMatrix(REALSXP, int_nbatch, ncomp));
+ SET_VECTOR_ELT(result, 5, ibatch);
+ SET_STRING_ELT(resultnames, 5, mkChar("ibatch"));
+ UNPROTECT(1);
+ }
+
+ if (is_debug) {
+
+ PROTECT(debug_which = allocVector(LGLSXP, niter));
+ SET_VECTOR_ELT(result, len_result_regular + 0, debug_which);
+ SET_STRING_ELT(resultnames, len_result_regular + 0, mkChar("which"));
+ UNPROTECT(1);
+
+ PROTECT(debug_unif_which = allocVector(REALSXP, niter));
+ SET_VECTOR_ELT(result, len_result_regular + 1, debug_unif_which);
+ SET_STRING_ELT(resultnames, len_result_regular + 1,
+ mkChar("unif.which"));
+ UNPROTECT(1);
+
+ if (is_parallel)
+ PROTECT(debug_state = alloc3DArray(REALSXP, niter, ncomp, nx));
+ else
+ PROTECT(debug_state = allocMatrix(REALSXP, niter, nx + 1));
+ SET_VECTOR_ELT(result, len_result_regular + 2, debug_state);
+ SET_STRING_ELT(resultnames, len_result_regular + 2, mkChar("state"));
+ UNPROTECT(1);
+
+ PROTECT(debug_log_hastings = allocVector(REALSXP, niter));
+ SET_VECTOR_ELT(result, len_result_regular + 3, debug_log_hastings);
+ SET_STRING_ELT(resultnames, len_result_regular + 3,
+ mkChar("log.hastings"));
+ UNPROTECT(1);
+
+ PROTECT(debug_unif_hastings = allocVector(REALSXP, niter));
+ SET_VECTOR_ELT(result, len_result_regular + 4, debug_unif_hastings);
+ SET_STRING_ELT(resultnames, len_result_regular + 4,
+ mkChar("unif.hastings"));
+ UNPROTECT(1);
+
+ PROTECT(debug_proposal = allocMatrix(REALSXP, niter, nx + 1));
+ SET_VECTOR_ELT(result, len_result_regular + 5, debug_proposal);
+ SET_STRING_ELT(resultnames, len_result_regular + 5,
+ mkChar("proposal"));
+ UNPROTECT(1);
+
+ PROTECT(debug_acceptd = allocVector(LGLSXP, niter));
+ SET_VECTOR_ELT(result, len_result_regular + 6, debug_acceptd);
+ SET_STRING_ELT(resultnames, len_result_regular + 6,
+ mkChar("acceptd"));
+ UNPROTECT(1);
+
+ PROTECT(debug_norm = allocMatrix(REALSXP, niter, nx));
+ SET_VECTOR_ELT(result, len_result_regular + 7, debug_norm);
+ SET_STRING_ELT(resultnames, len_result_regular + 7,
+ mkChar("norm"));
+ UNPROTECT(1);
+
+ if (is_parallel)
+ PROTECT(debug_unif_choose = allocMatrix(REALSXP, niter, 2));
+ else
+ PROTECT(debug_unif_choose = allocVector(REALSXP, niter));
+ SET_VECTOR_ELT(result, len_result_regular + 8, debug_unif_choose);
+ SET_STRING_ELT(resultnames, len_result_regular + 8,
+ mkChar("unif.choose"));
+ UNPROTECT(1);
+
+ if (is_parallel) {
+ PROTECT(debug_coproposal = allocMatrix(REALSXP, niter, nx + 1));
+ SET_VECTOR_ELT(result, len_result_regular + 9, debug_coproposal);
+ SET_STRING_ELT(resultnames, len_result_regular + 9,
+ mkChar("coproposal"));
+ UNPROTECT(1);
+ }
+ }
+
+ // at this point, entire output structure (SEXP result) is set up, except
+ // for aforementioned need to duplicate final state and put in result[4]
+
+ GetRNGstate();
+
+ // need buffers for acceptance rate(s)
+
+ double acceptx_numer[ncomp];
+ double acceptx_denom[ncomp];
+ double accepti_numer[ncomp][ncomp];
+ double accepti_denom[ncomp][ncomp];
+ for (int i = 0; i < ncomp; i++) {
+ acceptx_numer[i] = 0;
+ acceptx_denom[i] = 0;
+ for (int j = 0; j < ncomp; j++) {
+ accepti_numer[i][j] = 0;
+ accepti_denom[i][j] = 0;
+ }
+ }
+
+ // need neighbor counts and neighbors
+ // note: the_neighbors uses zero-origin indexing both for indexing
+ // and values
+
+ double n_neighbors[ncomp];
+ for (int i = 0; i < ncomp; i++) {
+ n_neighbors[i] = 0;
+ for (int j = 0; j < ncomp; j++)
+ n_neighbors[i] += LOGICAL(neighbors)[i + ncomp * j];
+ }
+
+ double the_neighbors[ncomp][ncomp];
+ for (int i = 0; i < ncomp; i++) {
+ for (int j = 0, k = 0; j < ncomp; j++) {
+ if (LOGICAL(neighbors)[i + ncomp * j])
+ the_neighbors[i][k++] = j;
+ }
+ }
+
+ // need buffers for batch means
+
+ double batch_buff[nout];
+ double ibatch_buff[ncomp];
+
+ for (int kbatch = 0, iiter = 0; kbatch < int_nbatch; kbatch++) {
+
+ for (int i = 0; i < nout; i++)
+ batch_buff[i] = 0.0;
+ for (int i = 0; i < ncomp; i++)
+ ibatch_buff[i] = 0.0;
+
+ for (int jbatch = 0; jbatch < int_blen; jbatch++) {
+
+ for (int ispac = 0; ispac < int_nspac; ispac++, iiter++) {
+
+#ifdef EXTRA_CHECK
+#ifdef WOOF
+ fprintf(stderr, "Check for validity of current_log_dens at top of inner loop\n");
+#endif /* WOOF */
+ if (is_parallel) {
+ for (int i = 0; i < ncomp; i++) {
+ REAL(proposal)[0] = i + 1;
+ for (int j = 0; j < nx; j++)
+ REAL(proposal)[j + 1] = REAL(state)[i + ncomp * j];
+#ifdef BLATHER
+ fprintf(stderr, "current_log_dens[%d] = %e\n", i, current_log_dens[i]);
+ for (int j = 0; j < nx; j++)
+ fprintf(stderr, " state[%d, %d] = %e\n",
+ i, j, REAL(state)[i + ncomp * j]);
+ for (int j = 0; j <= nx; j++)
+ fprintf(stderr, " proposal[%d] = %e\n", j, REAL(proposal)[j]);
+ fprintf(stderr, " logh(func1, proposal, rho1)) = %e\n",
+ logh(func1, proposal, rho1));
+#endif /* BLATHER */
+ if (current_log_dens[i] != logh(func1, proposal, rho1))
+ error("current_log_dens[%d] bogus\n", i);
+ }
+ } else /* serial */ {
+ for (int j = 0; j <= nx; j++)
+ REAL(proposal)[j] = REAL(state)[j];
+ int i = REAL(proposal)[0] - 1;
+ double my_actual_logh = logh(func1, proposal, rho1);
+ double my_stored_logh = current_log_dens[i];
+#ifdef WOOF
+ fprintf(stderr, "icomp = %d, stored logh = %e, actual logh = %e\n",
+ i + 1, my_stored_logh, my_actual_logh);
+#endif /* WOOF */
+ if (my_stored_logh != my_actual_logh)
+ error("current_log_dens[%d] bogus\n", i);
+ }
+#endif /* EXTRA_CHECK */
+
+ if (is_debug) {
+ int len_state = is_parallel ? ncomp * nx : nx + 1;
+ for (int j = 0; j < len_state; j++)
+ REAL(debug_state)[iiter + niter * j] = REAL(state)[j];
+ }
+
+ double my_unif_which = unif_rand();
+ int my_which = my_unif_which < 0.5;
+
+ if (is_debug) {
+ LOGICAL(debug_which)[iiter] = my_which;
+ REAL(debug_unif_which)[iiter] = my_unif_which;
+ }
+
+ if (my_which) /* within-component update */ {
+
+ if (is_parallel) {
+
+ // note: my_i and my_j are 1-origin indexing (for R)
+ // go from 1, ..., ncomp
+ // everything else 0-origin indexing (for C)
+
+ double unif_choose = unif_rand();
+
+ int my_i = trunc(ncomp * unif_choose) + 1;
+ if (my_i > ncomp) my_i--;
+ if (my_i <= 0 || my_i > ncomp)
+ error("Can't happen: my_i out of range");
+
+ REAL(coproposal)[0] = my_i;
+ for (int j = 0; j < nx; j++)
+ REAL(coproposal)[j + 1] =
+ REAL(state)[(my_i - 1) + ncomp * j];
+
+ double z[nx];
+ propose(coproposal, proposal, scale, z);
+
+ double my_coproposal_log_dens =
+ current_log_dens[my_i - 1];
+
+#ifdef EXTRA_CHECK
+ if (my_coproposal_log_dens != logh(func1, coproposal, rho1)) {
+ fprintf(stderr, "with-in component update (parallel)\n");
+ error("saving logh didn't work right (coproposal)");
+ }
+#endif /* EXTRA_CHECK */
+#ifdef BLEAT
+ if (my_coproposal_log_dens == R_NegInf) {
+ fprintf(stderr, "Oopsie #1!\n");
+ fprintf(stderr, " my_i = %d\n", my_i);
+ fprintf(stderr, " current_log_dens[my_i - 1] = %e\n", current_log_dens[my_i - 1]);
+ fprintf(stderr, " my_coproposal_log_dens = %e\n", my_coproposal_log_dens);
+ for (int j = 0; j <= nx; j++)
+ fprintf(stderr, " coproposal[%d] = %e\n", j + 1, REAL(coproposal)[j]);
+ fprintf(stderr, " logh(coproposal) = %e\n", logh(func1, coproposal, rho1));
+ }
+#endif /* BLEAT */
+ if (my_coproposal_log_dens == R_NegInf)
+ error("Can't happen: log density -Inf at current state");
+
+ double my_new_log_dens = logh(func1, proposal, rho1);
+ double my_log_hastings = my_new_log_dens -
+ my_coproposal_log_dens;
+
+ if (isnan(my_log_hastings) ||
+ (isinf(my_log_hastings) && my_log_hastings > 0))
+ error("Can't happen: log hastings ratio +Inf or NaN\n");
+
+ int my_accept = 1;
+ double my_unif_hastings = R_NaReal;
+ if (my_log_hastings < 0.0) {
+ my_unif_hastings = unif_rand();
+ my_accept = my_unif_hastings < exp(my_log_hastings);
+ }
+
+ if (is_debug) {
+ for (int j = 0; j <= nx; j++)
+ REAL(debug_proposal)[iiter + niter * j] =
+ REAL(proposal)[j];
+ for (int j = 0; j <= nx; j++)
+ REAL(debug_coproposal)[iiter + niter * j] =
+ REAL(coproposal)[j];
+ REAL(debug_log_hastings)[iiter] = my_log_hastings;
+ REAL(debug_unif_hastings)[iiter] = my_unif_hastings;
+ LOGICAL(debug_acceptd)[iiter] = my_accept;
+ for (int j = 0; j < nx; j++)
+ REAL(debug_norm)[iiter + niter * j] = z[j];
+ REAL(debug_unif_choose)[iiter] = unif_choose;
+ REAL(debug_unif_choose)[iiter + niter] = R_NaReal;
+ }
+
+ if (my_accept) {
+ for (int j = 0; j < nx; j++)
+ REAL(state)[(my_i - 1) + ncomp * j] =
+ REAL(proposal)[j + 1];
+ current_log_dens[my_i - 1] = my_new_log_dens;
+ acceptx_numer[my_i - 1]++;
+ }
+ acceptx_denom[my_i - 1]++;
+
+ } else /* serial */ {
+
+ int my_i = REAL(state)[0];
+ if (my_i <= 0 || my_i > ncomp)
+ error("Can't happen: my_i out of range");
+
+ REAL(coproposal)[0] = my_i;
+ for (int j = 0; j < nx; j++)
+ REAL(coproposal)[j + 1] = REAL(state)[j + 1];
+
+ double z[nx];
+ propose(coproposal, proposal, scale, z);
+ double my_new_log_dens = logh(func1, proposal, rho1);
+ double my_old_log_dens = current_log_dens[my_i - 1];
+
+#ifdef BLEAT
+ if (my_old_log_dens == R_NegInf) {
+ fprintf(stderr, "Oopsie #2!\n");
+ }
+#endif /* BLEAT */
+ if (my_old_log_dens == R_NegInf)
+ error("Can't happen: log density -Inf at current state");
+#ifdef EXTRA_CHECK
+ if (my_old_log_dens != logh(func1, coproposal, rho1)) {
+ fprintf(stderr, "with-in component update (serial)\n");
+ error("saving logh didn't work right (coproposal)");
+ }
+#endif /* EXTRA_CHECK */
+
+ double my_log_hastings =
+ my_new_log_dens - my_old_log_dens;
+
+ if (isnan(my_log_hastings) ||
+ (isinf(my_log_hastings) && my_log_hastings > 0)) {
+#ifdef WOOF
+ fprintf(stderr, "my_old_log_dens = %e\n", my_old_log_dens);
+ fprintf(stderr, "my_new_log_dens = %e\n", my_old_log_dens);
+ fprintf(stderr, "my_i = %d\n", my_i);
+#endif /* WOOF */
+ error("Can't happen: log hastings ratio +Inf or NaN\n");
+ }
+
+ int my_accept = 1;
+ double my_unif_hastings = R_NaReal;
+ if (my_log_hastings < 0.0) {
+ my_unif_hastings = unif_rand();
+ my_accept = my_unif_hastings < exp(my_log_hastings);
+ }
+
+ if (is_debug) {
+ for (int j = 0; j <= nx; j++)
+ REAL(debug_proposal)[iiter + niter * j] =
+ REAL(proposal)[j];
+ REAL(debug_log_hastings)[iiter] = my_log_hastings;
+ REAL(debug_unif_hastings)[iiter] = my_unif_hastings;
+ LOGICAL(debug_acceptd)[iiter] = my_accept;
+ for (int j = 0; j < nx; j++)
+ REAL(debug_norm)[iiter + niter * j] = z[j];
+ REAL(debug_unif_choose)[iiter] = R_NaReal;
+ }
+
+ if (my_accept) {
+ for (int j = 0; j <= nx; j++)
+ REAL(state)[j] = REAL(proposal)[j];
+ current_log_dens[my_i - 1] = my_new_log_dens;
+ acceptx_numer[my_i - 1]++;
+ }
+ acceptx_denom[my_i - 1]++;
+
+ }
+
+ } else /* jump/swap update */ {
+
+ if (is_parallel) {
+
+ double unif_choose_one = unif_rand();
+ double unif_choose_two = unif_rand();
+
+ int my_i = trunc(ncomp * unif_choose_one) + 1;
+ if (my_i > ncomp) my_i--;
+ if (my_i <= 0 || my_i > ncomp)
+ error("Can't happen: my_i out of range");
+
+ REAL(coproposal)[0] = my_i;
+ for (int j = 0; j < nx; j++)
+ REAL(coproposal)[j + 1] =
+ REAL(state)[(my_i - 1) + ncomp * j];
+
+ int my_i_neighbors = n_neighbors[my_i - 1];
+
+ int foo = trunc(my_i_neighbors * unif_choose_two) + 1;
+ if (foo > my_i_neighbors) foo--;
+
+ int my_j = the_neighbors[my_i - 1][foo - 1] + 1;
+#ifdef BLEAT
+ fprintf(stderr, "my_i = %d, my_i_neighbors = %d, foo = %d\n", my_i, my_i_neighbors, foo);
+ fprintf(stderr, "(parallel) ncomp = %d, my_j = %d\n", ncomp, my_j);
+#endif /* BLEAT */
+ if (my_j <= 0 || my_j > ncomp)
+ error("Can't happen: my_j out of range");
+
+ REAL(proposal)[0] = my_j;
+ for (int j = 0; j < nx; j++)
+ REAL(proposal)[j + 1] =
+ REAL(state)[(my_j - 1) + ncomp * j];
+
+ double my_coproposal_log_dens =
+ current_log_dens[my_i - 1];
+
+#ifdef EXTRA_CHECK
+ if (my_coproposal_log_dens != logh(func1, coproposal, rho1)) {
+ fprintf(stderr, "swap component update (parallel)\n");
+ error("saving logh didn't work right (coproposal)");
+ }
+#endif /* EXTRA_CHECK */
+#ifdef BLEAT
+ if (my_coproposal_log_dens == R_NegInf) {
+ fprintf(stderr, "Oopsie #3!\n");
+ fprintf(stderr, " my_i = %d\n", my_i);
+ fprintf(stderr, " current_log_dens[my_i - 1] = %e\n", current_log_dens[my_i - 1]);
+ fprintf(stderr, " my_coproposal_log_dens = %e\n", my_coproposal_log_dens);
+ for (int j = 0; j <= nx; j++)
+ fprintf(stderr, " coproposal[%d] = %e\n", j + 1, REAL(coproposal)[j]);
+ fprintf(stderr, " logh(coproposal) = %e\n", logh(func1, coproposal, rho1));
+ }
+#endif /* BLEAT */
+ if (my_coproposal_log_dens == R_NegInf)
+ error("Can't happen: log density -Inf at current state");
+
+ double my_proposal_log_dens =
+ current_log_dens[my_j - 1];
+
+#ifdef EXTRA_CHECK
+ if (my_proposal_log_dens != logh(func1, proposal, rho1)) {
+ fprintf(stderr, "swap component update (parallel)\n");
+ error("saving logh didn't work right (proposal)");
+ }
+#endif /* EXTRA_CHECK */
+#ifdef BLEAT
+ if (my_proposal_log_dens == R_NegInf) {
+ fprintf(stderr, "Oopsie #4!\n");
+ }
+#endif /* BLEAT */
+ if (my_proposal_log_dens == R_NegInf)
+ error("Can't happen: log density -Inf at current state");
+
+ if (is_debug) {
+ for (int j = 0; j <= nx; j++)
+ REAL(debug_proposal)[iiter + niter * j] =
+ REAL(proposal)[j];
+ for (int j = 0; j <= nx; j++)
+ REAL(debug_coproposal)[iiter + niter * j] =
+ REAL(coproposal)[j];
+ }
+
+ // proposal and coproposal now saved and logh evaluated
+ // for them, can clobber to evaluate for swap
+
+ REAL(proposal)[0] = my_i;
+ REAL(coproposal)[0] = my_j;
+ double my_swapped_coproposal_log_dens =
+ logh(func1, coproposal, rho1);
+ double my_swapped_proposal_log_dens =
+ logh(func1, proposal, rho1);
+ double my_log_hastings = my_swapped_proposal_log_dens +
+ my_swapped_coproposal_log_dens -
+ my_proposal_log_dens - my_coproposal_log_dens;
+
+ if (isnan(my_log_hastings) ||
+ (isinf(my_log_hastings) && my_log_hastings > 0))
+ error("Can't happen: log hastings ratio +Inf or NaN\n");
+
+ int my_accept = 1;
+ double my_unif_hastings = R_NaReal;
+ if (my_log_hastings < 0.0) {
+ my_unif_hastings = unif_rand();
+ my_accept = my_unif_hastings < exp(my_log_hastings);
+ }
+
+ if (is_debug) {
+ REAL(debug_log_hastings)[iiter] = my_log_hastings;
+ REAL(debug_unif_hastings)[iiter] = my_unif_hastings;
+ LOGICAL(debug_acceptd)[iiter] = my_accept;
+ for (int j = 0; j < nx; j++)
+ REAL(debug_norm)[iiter + niter * j] = R_NaReal;
+ REAL(debug_unif_choose)[iiter] = unif_choose_one;
+ REAL(debug_unif_choose)[iiter + niter] =
+ unif_choose_two;
+ }
+
+ if (my_accept) {
+ for (int j = 0; j < nx; j++)
+ REAL(state)[(my_j - 1) + ncomp * j] =
+ REAL(coproposal)[j + 1];
+ for (int j = 0; j < nx; j++)
+ REAL(state)[(my_i - 1) + ncomp * j] =
+ REAL(proposal)[j + 1];
+ current_log_dens[my_i - 1] =
+ my_swapped_proposal_log_dens;
+ current_log_dens[my_j - 1] =
+ my_swapped_coproposal_log_dens;
+ accepti_numer[my_i - 1][my_j - 1]++;
+ }
+ accepti_denom[my_i - 1][my_j - 1]++;
+
+ } else /* serial */ {
+
+ int my_i = REAL(state)[0];
+ if (my_i <= 0 || my_i > ncomp)
+ error("Can't happen: my_i out of range");
+
+ int my_i_neighbors = n_neighbors[my_i - 1];
+
+ double unif_choose = unif_rand();
+ int foo = trunc(my_i_neighbors * unif_choose) + 1;
+ if (foo > my_i_neighbors) foo--;
+
+ int my_j = the_neighbors[my_i - 1][foo - 1] + 1;
+ int my_j_neighbors = n_neighbors[my_j - 1];
+
+#ifdef BLEAT
+ fprintf(stderr, "(serial) ncomp = %d, my_j = %d, my_i_neighbors = %d, foo = %d\n", ncomp, my_j, my_i_neighbors, foo);
+ fprintf(stderr, " unif_choose = %f\n", unif_choose);
+ for (int j = 0; j < ncomp; j++)
+ fprintf(stderr, " LOGICAL(neighbors)[(my_i - 1) + ncomp * %d] = %d\n", j, LOGICAL(neighbors)[(my_i - 1) + ncomp * j]);
+#endif /* BLEAT */
+ if (my_j <= 0 || my_j > ncomp)
+ error("Can't happen: my_j out of range");
+
+ REAL(proposal)[0] = my_j;
+ for (int j = 0; j < nx; j++)
+ REAL(proposal)[j + 1] = REAL(state)[j + 1];
+
+#ifdef WOOF
+ fprintf(stderr, "got to here, about to call logh\n");
+ fprintf(stderr, " REAL(proposal)[0] = %e\n", REAL(proposal)[0]);
+#endif /* WOOF */
+
+ double my_new_log_dens = logh(func1, proposal, rho1);
+ double my_old_log_dens = current_log_dens[my_i - 1];
+#ifdef BLEAT
+ if (my_old_log_dens == R_NegInf) {
+ fprintf(stderr, "Oopsie #5!\n");
+ }
+#endif /* BLEAT */
+#ifdef EXTRA_CHECK
+ for (int j = 0; j <= nx; j++)
+ REAL(coproposal)[j] = REAL(state)[j];
+ if (my_old_log_dens != logh(func1, coproposal, rho1)) {
+ fprintf(stderr, "swap component update (serial)\n");
+ error("saving logh didn't work right (coproposal)");
+ }
+#endif /* EXTRA_CHECK */
+ if (my_old_log_dens == R_NegInf)
+ error("Can't happen: log density -Inf at current state");
+
+ double my_log_hastings =
+ my_new_log_dens - my_old_log_dens +
+ log(my_i_neighbors) - log(my_j_neighbors);
+
+ if (isnan(my_log_hastings) ||
+ (isinf(my_log_hastings) && my_log_hastings > 0))
+ error("Can't happen: log hastings ratio +Inf or NaN\n");
+
+ int my_accept = 1;
+ double my_unif_hastings = R_NaReal;
+ if (my_log_hastings < 0.0) {
+ my_unif_hastings = unif_rand();
+ my_accept = my_unif_hastings < exp(my_log_hastings);
+ }
+
+ if (is_debug) {
+ for (int j = 0; j <= nx; j++)
+ REAL(debug_proposal)[iiter + niter * j] =
+ REAL(proposal)[j];
+ REAL(debug_log_hastings)[iiter] = my_log_hastings;
+ REAL(debug_unif_hastings)[iiter] = my_unif_hastings;
+ LOGICAL(debug_acceptd)[iiter] = my_accept;
+ for (int j = 0; j < nx; j++)
+ REAL(debug_norm)[iiter + niter * j] = R_NaReal;
+ REAL(debug_unif_choose)[iiter] = unif_choose;
+ }
+
+#ifdef WOOF_WOOF
+ fprintf(stderr, "unif_choose = %f, ", unif_choose);
+ fprintf(stderr, "REAL(debug_unif_choose)[iiter] = %f\n", REAL(debug_unif_choose)[iiter]);
+#endif /* WOOF_WOOF */
+
+ if (my_accept) {
+ for (int j = 0; j <= nx; j++)
+ REAL(state)[j] = REAL(proposal)[j];
+ current_log_dens[my_j - 1] = my_new_log_dens;
+ accepti_numer[my_i - 1][my_j - 1]++;
+ }
+ accepti_denom[my_i - 1][my_j - 1]++;
+
+ }
+ }
+
+ } /* end of inner loop (one iteration) */
+
+ if (no_outfun) {
+ if (is_parallel)
+ for (int i = 0; i < nout; i++)
+ batch_buff[i] += REAL(state)[i];
+ else
+ for (int i = 0; i < nout; i++)
+ batch_buff[i] += REAL(state)[i + 1];
+ } else /* has outfun */ {
+ SEXP fred = outfun(func2, state, rho2);
+ if (LENGTH(fred) != nout)
+ error("function outfun returns results of different lengths");
+ for (int i = 0; i < nout; i++)
+ batch_buff[i] += REAL(fred)[i];
+ }
+
+ if (! is_parallel)
+ ibatch_buff[((int) REAL(state)[0]) - 1]++;
+
+ } /* end of middle loop (one batch) */
+
+ if (no_outfun && is_parallel)
+ for (int i = 0; i < ncomp; i++)
+ for (int j = 0; j < nx; j++)
+ REAL(batch)[kbatch + int_nbatch * (i + ncomp * j)] =
+ batch_buff[i + ncomp * j] / int_blen;
+ else
+ for (int i = 0; i < nout; i++)
+ REAL(batch)[kbatch + int_nbatch * i] =
+ batch_buff[i] / int_blen;
+
+ if (! is_parallel)
+ for (int i = 0; i < ncomp; i++)
+ REAL(ibatch)[kbatch + int_nbatch * i] =
+ ibatch_buff[i] / int_blen;
+
+ } /* end of outer loop */
+
+ for (int i = 0; i < ncomp; i++)
+ REAL(acceptx)[i] = acceptx_numer[i] / acceptx_denom[i];
+
+ for (int i = 0; i < ncomp; i++)
+ for (int j = 0; j < ncomp; j++)
+ if (LOGICAL(neighbors)[i + ncomp * j])
+ REAL(accepti)[i + ncomp * j] = accepti_numer[i][j] / accepti_denom[i][j];
+ else
+ REAL(accepti)[i + ncomp * j] = R_NaReal;
+
+ PutRNGstate();
+
+ PROTECT(save_final = duplicate(state));
+ SET_VECTOR_ELT(result, 4, save_final);
+ UNPROTECT(5);
+
+ return result;
+}
+
+static void check_valid_scale(SEXP scale, int i, int ncomp, int nx)
+{
+ if (i > ncomp)
+ error("check_valid_scale: i = %d, ncomp = %d, invalid\n", i, ncomp);
+
+ if (! isReal(scale)) {
+ if (i >= 0)
+ error("component %d of scale not type double", i + 1);
+ else
+ error("scale not type double");
+ }
+ if (! isAllFinite(scale)) {
+ if (i >= 0)
+ error("component %d of scale has non-finite element", i + 1);
+ else
+ error("scale has non-finite element");
+ }
+ if (isMatrix(scale)) {
+ if (nrows(scale) != nx) {
+ if (i >= 0)
+ error("component %d of scale matrix with wrong row dim", i + 1);
+ else
+ error("scale matrix with wrong row dim");
+ }
+ if (ncols(scale) != nx) {
+ if (i >= 0)
+ error("component %d of scale matrix with wrong col dim", i + 1);
+ else
+ error("scale matrix with wrong col dim");
+ }
+ } else /* scale not matrix */ {
+ if (! (LENGTH(scale) == 1 || LENGTH(scale) == nx)) {
+ if (i >= 0)
+ error("component %d of scale not matrix, scalar, or vector of length k", i + 1);
+ else
+ error("scale not matrix, scalar, or vector of length k");
+ }
+ }
+}
+
+static double logh(SEXP func, SEXP state, SEXP rho)
+{
+ SEXP call, result, foo;
+ double bar;
+
+ PROTECT(call = lang2(func, state));
+ PROTECT(result = eval(call, rho));
+ if (! isNumeric(result))
+ error("log unnormalized density function returned non-numeric");
+ if (LENGTH(result) != 1)
+ error("log unnormalized density function returned non-scalar");
+ PROTECT(foo = coerceVector(result, REALSXP));
+ bar = REAL(foo)[0];
+ UNPROTECT(3);
+ if (bar == R_PosInf)
+ error("log unnormalized density function returned +Inf");
+ if (R_IsNaN(bar) || R_IsNA(bar))
+ error("log unnormalized density function returned NA or NaN");
+ /* Note: -Inf is allowed */
+ return bar;
+}
+
+static SEXP outfun(SEXP func, SEXP state, SEXP rho)
+{
+ SEXP call, result, foo;
+
+ PROTECT(call = lang2(func, state));
+ PROTECT(result = eval(call, rho));
+ if (! isNumeric(result))
+ error("outfun returned non-numeric");
+ PROTECT(foo = coerceVector(result, REALSXP));
+ UNPROTECT(3);
+ return foo;
+}
+
+static void propose(SEXP coproposal, SEXP proposal, SEXP scale, double *z)
+{
+ int my_i = REAL(coproposal)[0];
+ int nx = LENGTH(coproposal) - 1;
+
+ for (int j = 0; j < nx; j++)
+ z[j] = norm_rand();
+
+ if (isNewList(scale))
+ scale = VECTOR_ELT(scale, my_i - 1);
+
+ REAL(proposal)[0] = my_i;
+
+ if (LENGTH(scale) == 1) {
+
+ for (int j = 0; j < nx; j++)
+ REAL(proposal)[j + 1] = REAL(coproposal)[j + 1] +
+ REAL(scale)[0] * z[j];
+
+ } else if (LENGTH(scale) == nx) {
+
+ for (int j = 0; j < nx; j++)
+ REAL(proposal)[j + 1] = REAL(coproposal)[j + 1] +
+ REAL(scale)[j] * z[j];
+
+ } else /* scale is nx by nx matrix */ {
+
+ for (int j = 0; j < nx; j++)
+ REAL(proposal)[j + 1] = REAL(coproposal)[j + 1];
+
+ for (int j = 0, m = 0; j < nx; j++) {
+ double u = z[j];
+ for (int k = 0; k < nx; k++)
+ REAL(proposal)[k + 1] += REAL(scale)[m++] * u;
+ }
+ }
+}
+
diff --git a/tests/circle.R b/tests/circle.R
new file mode 100644
index 0000000..c1794bc
--- /dev/null
+++ b/tests/circle.R
@@ -0,0 +1,71 @@
+
+ epsilon <- 1e-15
+
+ library(mcmc)
+
+ RNGkind("Marsaglia-Multicarry")
+ set.seed(42)
+
+ d <- 5
+
+ logh <- function(x) {
+ if (! is.numeric(x)) stop("x not numeric")
+ if (length(x) != d) stop("length(x) != d")
+ fred <- 1 - sum(x^2)
+ if (fred > 0) return(log(fred)) else return(-Inf)
+ }
+
+ out.metro <- metrop(logh, rep(0, d), 1e3, scale = 0.01)
+ out.metro$accept
+
+ out.metro <- metrop(out.metro, scale = 0.1)
+ out.metro$accept
+
+ out.metro <- metrop(out.metro, scale = 0.5)
+ out.metro$accept
+
+ out.metro <- metrop(out.metro, scale = 0.4)
+ out.metro$accept
+
+ out.metro <- metrop(out.metro, nbatch = 1e2, debug = TRUE)
+
+ all(out.metro$batch[- out.metro$nbatch, ] == out.metro$current[- 1, ])
+ all(out.metro$current[1, ] == out.metro$initial)
+ all(out.metro$batch[out.metro$nbatch, ] == out.metro$final)
+
+ .Random.seed <- out.metro$initial.seed
+ d <- ncol(out.metro$proposal)
+ n <- nrow(out.metro$proposal)
+ my.proposal <- matrix(NA, n, d)
+ my.u <- double(n)
+ ska <- out.metro$scale
+ for (i in 1:n) {
+ my.proposal[i, ] <- out.metro$current[i, ] + ska * rnorm(d)
+ if (is.na(out.metro$u[i])) {
+ my.u[i] <- NA
+ } else {
+ my.u[i] <- runif(1)
+ }
+ }
+ max(abs(out.metro$proposal - my.proposal)) < epsilon
+ all(is.na(out.metro$u) == is.na(my.u))
+ all(out.metro$u[!is.na(out.metro$u)] == my.u[!is.na(my.u)])
+
+ my.curr.log.green <- apply(out.metro$current, 1, logh)
+ my.prop.log.green <- apply(out.metro$proposal, 1, logh)
+ all(is.na(out.metro$u) == ((my.prop.log.green == -Inf) |
+ (my.prop.log.green > my.curr.log.green)))
+ foo <- my.prop.log.green - my.curr.log.green
+ blurfle <- foo - out.metro$log.green
+ blurfle[foo == -Inf & out.metro$log.green == -Inf] <- 0
+ max(blurfle) < epsilon
+
+ my.accept <- (my.prop.log.green > -Inf) & (is.na(my.u) | my.u < exp(foo))
+ sum(my.accept) == round(n * out.metro$accept)
+
+ my.path <- matrix(NA, n, d)
+ my.path[my.accept, ] <- out.metro$proposal[my.accept, ]
+ my.path[! my.accept, ] <- out.metro$current[! my.accept, ]
+
+ all(my.path == out.metro$batch)
+
diff --git a/tests/circle.Rout.save b/tests/circle.Rout.save
new file mode 100644
index 0000000..9887dcc
--- /dev/null
+++ b/tests/circle.Rout.save
@@ -0,0 +1,104 @@
+
+R version 2.13.1 (2011-07-08)
+Copyright (C) 2011 The R Foundation for Statistical Computing
+ISBN 3-900051-07-0
+Platform: x86_64-pc-linux-gnu (64-bit)
+
+R is free software and comes with ABSOLUTELY NO WARRANTY.
+You are welcome to redistribute it under certain conditions.
+Type 'license()' or 'licence()' for distribution details.
+
+R is a collaborative project with many contributors.
+Type 'contributors()' for more information and
+'citation()' on how to cite R or R packages in publications.
+
+Type 'demo()' for some demos, 'help()' for on-line help, or
+'help.start()' for an HTML browser interface to help.
+Type 'q()' to quit R.
+
+>
+> epsilon <- 1e-15
+>
+> library(mcmc)
+>
+> RNGkind("Marsaglia-Multicarry")
+> set.seed(42)
+>
+> d <- 5
+>
+> logh <- function(x) {
++ if (! is.numeric(x)) stop("x not numeric")
++ if (length(x) != d) stop("length(x) != d")
++ fred <- 1 - sum(x^2)
++ if (fred > 0) return(log(fred)) else return(-Inf)
++ }
+>
+> out.metro <- metrop(logh, rep(0, d), 1e3, scale = 0.01)
+> out.metro$accept
+[1] 0.979
+>
+> out.metro <- metrop(out.metro, scale = 0.1)
+> out.metro$accept
+[1] 0.72
+>
+> out.metro <- metrop(out.metro, scale = 0.5)
+> out.metro$accept
+[1] 0.16
+>
+> out.metro <- metrop(out.metro, scale = 0.4)
+> out.metro$accept
+[1] 0.228
+>
+> out.metro <- metrop(out.metro, nbatch = 1e2, debug = TRUE)
+>
+> all(out.metro$batch[- out.metro$nbatch, ] == out.metro$current[- 1, ])
+[1] TRUE
+> all(out.metro$current[1, ] == out.metro$initial)
+[1] TRUE
+> all(out.metro$batch[out.metro$nbatch, ] == out.metro$final)
+[1] TRUE
+>
+> .Random.seed <- out.metro$initial.seed
+> d <- ncol(out.metro$proposal)
+> n <- nrow(out.metro$proposal)
+> my.proposal <- matrix(NA, n, d)
+> my.u <- double(n)
+> ska <- out.metro$scale
+> for (i in 1:n) {
++ my.proposal[i, ] <- out.metro$current[i, ] + ska * rnorm(d)
++ if (is.na(out.metro$u[i])) {
++ my.u[i] <- NA
++ } else {
++ my.u[i] <- runif(1)
++ }
++ }
+> max(abs(out.metro$proposal - my.proposal)) < epsilon
+[1] TRUE
+> all(is.na(out.metro$u) == is.na(my.u))
+[1] TRUE
+> all(out.metro$u[!is.na(out.metro$u)] == my.u[!is.na(my.u)])
+[1] TRUE
+>
+> my.curr.log.green <- apply(out.metro$current, 1, logh)
+> my.prop.log.green <- apply(out.metro$proposal, 1, logh)
+> all(is.na(out.metro$u) == ((my.prop.log.green == -Inf) |
++ (my.prop.log.green > my.curr.log.green)))
+[1] TRUE
+> foo <- my.prop.log.green - my.curr.log.green
+> blurfle <- foo - out.metro$log.green
+> blurfle[foo == -Inf & out.metro$log.green == -Inf] <- 0
+> max(blurfle) < epsilon
+[1] TRUE
+>
+> my.accept <- (my.prop.log.green > -Inf) & (is.na(my.u) | my.u < exp(foo))
+> sum(my.accept) == round(n * out.metro$accept)
+[1] TRUE
+>
+> my.path <- matrix(NA, n, d)
+> my.path[my.accept, ] <- out.metro$proposal[my.accept, ]
+> my.path[! my.accept, ] <- out.metro$current[! my.accept, ]
+>
+> all(my.path == out.metro$batch)
+[1] TRUE
+>
+>
diff --git a/tests/initseq.R b/tests/initseq.R
new file mode 100644
index 0000000..3346028
--- /dev/null
+++ b/tests/initseq.R
@@ -0,0 +1,47 @@
+
+ library(mcmc)
+
+ set.seed(42)
+
+ n <- 1e5
+ rho <- 0.99
+
+ x <- arima.sim(model = list(ar = rho), n = n)
+ gamma <- acf(x, lag.max = 1999, type = "covariance",
+ plot = FALSE)$acf
+ k <- seq(along = gamma)
+ Gamma <- gamma[k %% 2 == 1] + gamma[k %% 2 == 0]
+ k <- min(seq(along = Gamma)[Gamma < 0])
+ Gamma <- Gamma[1:k]
+ Gamma[k] < 0
+ Gamma[k] <- 0
+
+ out <- .Call("initseq", x - mean(x))
+ names(out)
+
+ all.equal(gamma[1], out$gamma0)
+
+ length(out$Gamma.pos) == length(Gamma)
+ all.equal(out$Gamma.pos, Gamma)
+
+ Gamma.dec <- cummin(Gamma)
+ all.equal(out$Gamma.dec, Gamma.dec)
+
+library(Iso)
+ Gamma.con <- Gamma.dec[1] + cumsum(c(0, pava(diff(Gamma.dec))))
+ all.equal(out$Gamma.con, Gamma.con)
+
+ all.equal(0, min(out$Gamma.pos - out$Gamma.dec))
+ max(diff(out$Gamma.dec)) < sqrt(.Machine$double.eps)
+
+ all.equal(0, min(out$Gamma.dec - out$Gamma.con))
+ min(diff(diff(out$Gamma.con))) > (- sqrt(.Machine$double.eps))
+
+ all.equal(2 * sum(out$Gamma.pos) - out$gamma0, out$var.pos)
+ all.equal(2 * sum(out$Gamma.dec) - out$gamma0, out$var.dec)
+ all.equal(2 * sum(out$Gamma.con) - out$gamma0, out$var.con)
+
+ rev(out$Gamma.pos)[1] == 0
+ rev(out$Gamma.dec)[1] == 0
+ all.equal(rev(out$Gamma.con)[1], 0)
+
diff --git a/tests/initseq.Rout.save b/tests/initseq.Rout.save
new file mode 100644
index 0000000..b7ec81e
--- /dev/null
+++ b/tests/initseq.Rout.save
@@ -0,0 +1,87 @@
+
+R version 3.2.1 (2015-06-18) -- "World-Famous Astronaut"
+Copyright (C) 2015 The R Foundation for Statistical Computing
+Platform: i686-pc-linux-gnu (32-bit)
+
+R is free software and comes with ABSOLUTELY NO WARRANTY.
+You are welcome to redistribute it under certain conditions.
+Type 'license()' or 'licence()' for distribution details.
+
+R is a collaborative project with many contributors.
+Type 'contributors()' for more information and
+'citation()' on how to cite R or R packages in publications.
+
+Type 'demo()' for some demos, 'help()' for on-line help, or
+'help.start()' for an HTML browser interface to help.
+Type 'q()' to quit R.
+
+>
+> library(mcmc)
+>
+> set.seed(42)
+>
+> n <- 1e5
+> rho <- 0.99
+>
+> x <- arima.sim(model = list(ar = rho), n = n)
+> gamma <- acf(x, lag.max = 1999, type = "covariance",
++ plot = FALSE)$acf
+> k <- seq(along = gamma)
+> Gamma <- gamma[k %% 2 == 1] + gamma[k %% 2 == 0]
+> k <- min(seq(along = Gamma)[Gamma < 0])
+> Gamma <- Gamma[1:k]
+> Gamma[k] < 0
+[1] TRUE
+> Gamma[k] <- 0
+>
+> out <- .Call("initseq", x - mean(x))
+> names(out)
+[1] "gamma0" "Gamma.pos" "Gamma.dec" "Gamma.con" "var.pos" "var.dec"
+[7] "var.con"
+>
+> all.equal(gamma[1], out$gamma0)
+[1] TRUE
+>
+> length(out$Gamma.pos) == length(Gamma)
+[1] TRUE
+> all.equal(out$Gamma.pos, Gamma)
+[1] TRUE
+>
+> Gamma.dec <- cummin(Gamma)
+> all.equal(out$Gamma.dec, Gamma.dec)
+[1] TRUE
+>
+> library(Iso)
+Iso 0.0-17
+> Gamma.con <- Gamma.dec[1] + cumsum(c(0, pava(diff(Gamma.dec))))
+> all.equal(out$Gamma.con, Gamma.con)
+[1] TRUE
+>
+> all.equal(0, min(out$Gamma.pos - out$Gamma.dec))
+[1] TRUE
+> max(diff(out$Gamma.dec)) < sqrt(.Machine$double.eps)
+[1] TRUE
+>
+> all.equal(0, min(out$Gamma.dec - out$Gamma.con))
+[1] TRUE
+> min(diff(diff(out$Gamma.con))) > (- sqrt(.Machine$double.eps))
+[1] TRUE
+>
+> all.equal(2 * sum(out$Gamma.pos) - out$gamma0, out$var.pos)
+[1] TRUE
+> all.equal(2 * sum(out$Gamma.dec) - out$gamma0, out$var.dec)
+[1] TRUE
+> all.equal(2 * sum(out$Gamma.con) - out$gamma0, out$var.con)
+[1] TRUE
+>
+> rev(out$Gamma.pos)[1] == 0
+[1] TRUE
+> rev(out$Gamma.dec)[1] == 0
+[1] TRUE
+> all.equal(rev(out$Gamma.con)[1], 0)
+[1] TRUE
+>
+>
+> proc.time()
+ user system elapsed
+ 3.096 0.048 3.138
diff --git a/tests/isotropic.R b/tests/isotropic.R
new file mode 100644
index 0000000..3505471
--- /dev/null
+++ b/tests/isotropic.R
@@ -0,0 +1,37 @@
+library(mcmc)
+isotropic <- mcmc:::isotropic
+isotropic.logjacobian <- mcmc:::isotropic.logjacobian
+
+# create identity test function
+identity <- function(x) x
+d.identity <- function(x) 1
+
+# check that isotropic is length preserving for vectors of lengths 1--1000
+all(sapply(1:1000, function(x) length(isotropic(identity)(rep(1, x))) == x))
+
+# test that isotropic(identity) is an identity function
+all.equal(isotropic(identity)(1:10), 1:10)
+x <- seq(0, 1, length.out=200)
+all.equal(isotropic(identity)(x), x)
+
+# make sure that isotropic.logjacobian(identity, d.identity) is a 0 function
+all.equal(isotropic.logjacobian(identity, d.identity)(1:10), 0)
+
+# make sure that 0 as an input does not cause divide-by-zero errors
+all.equal(isotropic(identity)(0), 0)
+all.equal(isotropic(identity)(0 * 1:4), rep(0, 4))
+all.equal(isotropic.logjacobian(identity, d.identity)(0), 0)
+all.equal(isotropic.logjacobian(identity, d.identity)(0 * 1:4), 0)
+
+# try isotropic with f(x) = x^2, then we should get
+# istropic(f)(x) := |x| * x
+f <- function(x) x^2
+all.equal(isotropic(f)(1), 1)
+all.equal(isotropic(f)(c(1, 1)), sqrt(2) * c(1, 1))
+all.equal(isotropic(f)(c(1, 0, 1)), sqrt(2) * c(1, 0, 1))
+
+# make sure lazy-loading works properly.
+g <- function(x) x^2
+g.iso <- isotropic(g)
+g <- function(x) x
+all.equal(g.iso(2), 2*2)
diff --git a/tests/isotropic.Rout.save b/tests/isotropic.Rout.save
new file mode 100644
index 0000000..ff42d96
--- /dev/null
+++ b/tests/isotropic.Rout.save
@@ -0,0 +1,68 @@
+
+R version 2.13.1 (2011-07-08)
+Copyright (C) 2011 The R Foundation for Statistical Computing
+ISBN 3-900051-07-0
+Platform: x86_64-pc-linux-gnu (64-bit)
+
+R is free software and comes with ABSOLUTELY NO WARRANTY.
+You are welcome to redistribute it under certain conditions.
+Type 'license()' or 'licence()' for distribution details.
+
+R is a collaborative project with many contributors.
+Type 'contributors()' for more information and
+'citation()' on how to cite R or R packages in publications.
+
+Type 'demo()' for some demos, 'help()' for on-line help, or
+'help.start()' for an HTML browser interface to help.
+Type 'q()' to quit R.
+
+> library(mcmc)
+> isotropic <- mcmc:::isotropic
+> isotropic.logjacobian <- mcmc:::isotropic.logjacobian
+>
+> # create identity test function
+> identity <- function(x) x
+> d.identity <- function(x) 1
+>
+> # check that isotropic is length preserving for vectors of lengths 1--1000
+> all(sapply(1:1000, function(x) length(isotropic(identity)(rep(1, x))) == x))
+[1] TRUE
+>
+> # test that isotropic(identity) is an identity function
+> all.equal(isotropic(identity)(1:10), 1:10)
+[1] TRUE
+> x <- seq(0, 1, length.out=200)
+> all.equal(isotropic(identity)(x), x)
+[1] TRUE
+>
+> # make sure that isotropic.logjacobian(identity, d.identity) is a 0 function
+> all.equal(isotropic.logjacobian(identity, d.identity)(1:10), 0)
+[1] TRUE
+>
+> # make sure that 0 as an input does not cause divide-by-zero errors
+> all.equal(isotropic(identity)(0), 0)
+[1] TRUE
+> all.equal(isotropic(identity)(0 * 1:4), rep(0, 4))
+[1] TRUE
+> all.equal(isotropic.logjacobian(identity, d.identity)(0), 0)
+[1] TRUE
+> all.equal(isotropic.logjacobian(identity, d.identity)(0 * 1:4), 0)
+[1] TRUE
+>
+> # try isotropic with f(x) = x^2, then we should get
+> # istropic(f)(x) := |x| * x
+> f <- function(x) x^2
+> all.equal(isotropic(f)(1), 1)
+[1] TRUE
+> all.equal(isotropic(f)(c(1, 1)), sqrt(2) * c(1, 1))
+[1] TRUE
+> all.equal(isotropic(f)(c(1, 0, 1)), sqrt(2) * c(1, 0, 1))
+[1] TRUE
+>
+> # make sure lazy-loading works properly.
+> g <- function(x) x^2
+> g.iso <- isotropic(g)
+> g <- function(x) x
+> all.equal(g.iso(2), 2*2)
+[1] TRUE
+>
diff --git a/tests/logit.R b/tests/logit.R
new file mode 100644
index 0000000..65fda96
--- /dev/null
+++ b/tests/logit.R
@@ -0,0 +1,101 @@
+
+ epsilon <- 1e-15
+
+ library(mcmc)
+
+ RNGkind("Marsaglia-Multicarry")
+ set.seed(42)
+
+ options(digits = 3)
+
+ n <- 100
+ rho <- 0.5
+ beta0 <- 0.25
+ beta1 <- 1
+ beta2 <- 0.5
+
+ x1 <- rnorm(n)
+ x2 <- rho * x1 + sqrt(1 - rho^2) * rnorm(n)
+ eta <- beta0 + beta1 * x1 + beta2 * x2
+ p <- 1 / (1 + exp(- eta))
+ y <- as.numeric(runif(n) < p)
+
+ out <- glm(y ~ x1 + x2, family = binomial())
+ summary(out)
+
+ mlogl <- function(beta) {
+ if (length(beta) != 3) stop("length(beta) != 3")
+ beta0 <- beta[1]
+ beta1 <- beta[2]
+ beta2 <- beta[3]
+ eta <- beta0 + beta1 * x1 + beta2 * x2
+ p <- exp(eta) / (1 + exp(eta))
+ return(- sum(log(p[y == 1])) - sum(log(1 - p[y == 0])))
+ }
+
+ out.nlm <- nlm(mlogl, coefficients(out), print.level = 2)
+
+ logl <- function(beta) {
+ if (length(beta) != 3) stop("length(beta) != 3")
+ beta0 <- beta[1]
+ beta1 <- beta[2]
+ beta2 <- beta[3]
+ eta <- beta0 + beta1 * x1 + beta2 * x2
+ p <- exp(eta) / (1 + exp(eta))
+ return(sum(log(p[y == 1])) + sum(log(1 - p[y == 0])))
+ }
+
+ out.metro <- metrop(logl, coefficients(out), 1e3, scale = 0.01)
+ out.metro$accept
+
+ out.metro <- metrop(out.metro, scale = 0.1)
+ out.metro$accept
+
+ out.metro <- metrop(out.metro, scale = 0.5)
+ out.metro$accept
+
+ apply(out.metro$batch, 2, mean)
+ var(out.metro$batch)
+ olbm(out.metro$batch, 25)
+
+ saveseed <- .Random.seed
+ out.metro <- metrop(logl, as.numeric(coefficients(out)), 1e2,
+ scale = 0.5, debug = TRUE)
+
+ all(out.metro$batch[- out.metro$nbatch, ] == out.metro$current[- 1, ])
+ all(out.metro$current[1, ] == out.metro$initial)
+ all(out.metro$batch[out.metro$nbatch, ] == out.metro$final)
+
+ .Random.seed <- saveseed
+ d <- ncol(out.metro$proposal)
+ n <- nrow(out.metro$proposal)
+ my.proposal <- matrix(NA, n, d)
+ my.u <- double(n)
+ ska <- out.metro$scale
+ for (i in 1:n) {
+ my.proposal[i, ] <- out.metro$current[i, ] + ska * rnorm(d)
+ if (is.na(out.metro$u[i])) {
+ my.u[i] <- NA
+ } else {
+ my.u[i] <- runif(1)
+ }
+ }
+ max(abs(out.metro$proposal - my.proposal)) < epsilon
+ all(is.na(out.metro$u) == is.na(my.u))
+ all(out.metro$u[!is.na(out.metro$u)] == my.u[!is.na(my.u)])
+
+ my.curr.log.green <- apply(out.metro$current, 1, logl)
+ my.prop.log.green <- apply(out.metro$proposal, 1, logl)
+ all(is.na(out.metro$u) == (my.prop.log.green > my.curr.log.green))
+ foo <- my.prop.log.green - my.curr.log.green
+ max(abs(foo - out.metro$log.green)) < epsilon
+
+ my.accept <- is.na(my.u) | my.u < exp(foo)
+ sum(my.accept) == round(n * out.metro$accept)
+
+ my.path <- matrix(NA, n, d)
+ my.path[my.accept, ] <- out.metro$proposal[my.accept, ]
+ my.path[! my.accept, ] <- out.metro$current[! my.accept, ]
+
+ all(my.path == out.metro$batch)
+
diff --git a/tests/logit.Rout.save b/tests/logit.Rout.save
new file mode 100644
index 0000000..8855b61
--- /dev/null
+++ b/tests/logit.Rout.save
@@ -0,0 +1,179 @@
+
+R version 3.2.1 (2015-06-18) -- "World-Famous Astronaut"
+Copyright (C) 2015 The R Foundation for Statistical Computing
+Platform: i686-pc-linux-gnu (32-bit)
+
+R is free software and comes with ABSOLUTELY NO WARRANTY.
+You are welcome to redistribute it under certain conditions.
+Type 'license()' or 'licence()' for distribution details.
+
+R is a collaborative project with many contributors.
+Type 'contributors()' for more information and
+'citation()' on how to cite R or R packages in publications.
+
+Type 'demo()' for some demos, 'help()' for on-line help, or
+'help.start()' for an HTML browser interface to help.
+Type 'q()' to quit R.
+
+>
+> epsilon <- 1e-15
+>
+> library(mcmc)
+>
+> RNGkind("Marsaglia-Multicarry")
+> set.seed(42)
+>
+> options(digits = 3)
+>
+> n <- 100
+> rho <- 0.5
+> beta0 <- 0.25
+> beta1 <- 1
+> beta2 <- 0.5
+>
+> x1 <- rnorm(n)
+> x2 <- rho * x1 + sqrt(1 - rho^2) * rnorm(n)
+> eta <- beta0 + beta1 * x1 + beta2 * x2
+> p <- 1 / (1 + exp(- eta))
+> y <- as.numeric(runif(n) < p)
+>
+> out <- glm(y ~ x1 + x2, family = binomial())
+> summary(out)
+
+Call:
+glm(formula = y ~ x1 + x2, family = binomial())
+
+Deviance Residuals:
+ Min 1Q Median 3Q Max
+-2.064 -0.821 -0.246 0.840 2.070
+
+Coefficients:
+ Estimate Std. Error z value Pr(>|z|)
+(Intercept) 0.0599 0.2477 0.24 0.80905
+x1 1.3682 0.3844 3.56 0.00037 ***
+x2 0.4760 0.3135 1.52 0.12886
+---
+Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
+
+(Dispersion parameter for binomial family taken to be 1)
+
+ Null deviance: 138.469 on 99 degrees of freedom
+Residual deviance: 99.293 on 97 degrees of freedom
+AIC: 105.3
+
+Number of Fisher Scoring iterations: 5
+
+>
+> mlogl <- function(beta) {
++ if (length(beta) != 3) stop("length(beta) != 3")
++ beta0 <- beta[1]
++ beta1 <- beta[2]
++ beta2 <- beta[3]
++ eta <- beta0 + beta1 * x1 + beta2 * x2
++ p <- exp(eta) / (1 + exp(eta))
++ return(- sum(log(p[y == 1])) - sum(log(1 - p[y == 0])))
++ }
+>
+> out.nlm <- nlm(mlogl, coefficients(out), print.level = 2)
+iteration = 0
+Parameter:
+[1] 0.0599 1.3682 0.4760
+Function Value
+[1] 49.6
+Gradient:
+[1] 8.24e-06 5.50e-06 6.08e-06
+
+Relative gradient close to zero.
+Current iterate is probably solution.
+
+>
+> logl <- function(beta) {
++ if (length(beta) != 3) stop("length(beta) != 3")
++ beta0 <- beta[1]
++ beta1 <- beta[2]
++ beta2 <- beta[3]
++ eta <- beta0 + beta1 * x1 + beta2 * x2
++ p <- exp(eta) / (1 + exp(eta))
++ return(sum(log(p[y == 1])) + sum(log(1 - p[y == 0])))
++ }
+>
+> out.metro <- metrop(logl, coefficients(out), 1e3, scale = 0.01)
+> out.metro$accept
+[1] 0.982
+>
+> out.metro <- metrop(out.metro, scale = 0.1)
+> out.metro$accept
+[1] 0.795
+>
+> out.metro <- metrop(out.metro, scale = 0.5)
+> out.metro$accept
+[1] 0.264
+>
+> apply(out.metro$batch, 2, mean)
+[1] 0.0608 1.4230 0.5263
+> var(out.metro$batch)
+ [,1] [,2] [,3]
+[1,] 0.06755 -0.0108 0.00989
+[2,] -0.01080 0.1758 -0.06155
+[3,] 0.00989 -0.0615 0.10483
+> olbm(out.metro$batch, 25)
+ [,1] [,2] [,3]
+[1,] 4.54e-04 9.47e-05 -1.92e-05
+[2,] 9.47e-05 1.84e-03 -6.45e-04
+[3,] -1.92e-05 -6.45e-04 9.09e-04
+>
+> saveseed <- .Random.seed
+> out.metro <- metrop(logl, as.numeric(coefficients(out)), 1e2,
++ scale = 0.5, debug = TRUE)
+>
+> all(out.metro$batch[- out.metro$nbatch, ] == out.metro$current[- 1, ])
+[1] TRUE
+> all(out.metro$current[1, ] == out.metro$initial)
+[1] TRUE
+> all(out.metro$batch[out.metro$nbatch, ] == out.metro$final)
+[1] TRUE
+>
+> .Random.seed <- saveseed
+> d <- ncol(out.metro$proposal)
+> n <- nrow(out.metro$proposal)
+> my.proposal <- matrix(NA, n, d)
+> my.u <- double(n)
+> ska <- out.metro$scale
+> for (i in 1:n) {
++ my.proposal[i, ] <- out.metro$current[i, ] + ska * rnorm(d)
++ if (is.na(out.metro$u[i])) {
++ my.u[i] <- NA
++ } else {
++ my.u[i] <- runif(1)
++ }
++ }
+> max(abs(out.metro$proposal - my.proposal)) < epsilon
+[1] TRUE
+> all(is.na(out.metro$u) == is.na(my.u))
+[1] TRUE
+> all(out.metro$u[!is.na(out.metro$u)] == my.u[!is.na(my.u)])
+[1] TRUE
+>
+> my.curr.log.green <- apply(out.metro$current, 1, logl)
+> my.prop.log.green <- apply(out.metro$proposal, 1, logl)
+> all(is.na(out.metro$u) == (my.prop.log.green > my.curr.log.green))
+[1] TRUE
+> foo <- my.prop.log.green - my.curr.log.green
+> max(abs(foo - out.metro$log.green)) < epsilon
+[1] TRUE
+>
+> my.accept <- is.na(my.u) | my.u < exp(foo)
+> sum(my.accept) == round(n * out.metro$accept)
+[1] TRUE
+>
+> my.path <- matrix(NA, n, d)
+> my.path[my.accept, ] <- out.metro$proposal[my.accept, ]
+> my.path[! my.accept, ] <- out.metro$current[! my.accept, ]
+>
+> all(my.path == out.metro$batch)
+[1] TRUE
+>
+>
+> proc.time()
+ user system elapsed
+ 0.532 0.028 0.551
diff --git a/tests/logitbat.R b/tests/logitbat.R
new file mode 100644
index 0000000..9499779
--- /dev/null
+++ b/tests/logitbat.R
@@ -0,0 +1,105 @@
+
+ # test batching (blen)
+
+ epsilon <- 1e-15
+
+ library(mcmc)
+
+ RNGkind("Marsaglia-Multicarry")
+ set.seed(42)
+
+ n <- 100
+ rho <- 0.5
+ beta0 <- 0.25
+ beta1 <- 1
+ beta2 <- 0.5
+
+ x1 <- rnorm(n)
+ x2 <- rho * x1 + sqrt(1 - rho^2) * rnorm(n)
+ eta <- beta0 + beta1 * x1 + beta2 * x2
+ p <- 1 / (1 + exp(- eta))
+ y <- as.numeric(runif(n) < p)
+
+ out <- glm(y ~ x1 + x2, family = binomial())
+
+ logl <- function(beta) {
+ if (length(beta) != 3) stop("length(beta) != 3")
+ beta0 <- beta[1]
+ beta1 <- beta[2]
+ beta2 <- beta[3]
+ eta <- beta0 + beta1 * x1 + beta2 * x2
+ p <- exp(eta) / (1 + exp(eta))
+ return(sum(log(p[y == 1])) + sum(log(1 - p[y == 0])))
+ }
+
+ out.metro <- metrop(logl, coefficients(out), 1e3, scale = 0.01)
+ out.metro$accept
+
+ out.metro <- metrop(out.metro, scale = 0.1)
+ out.metro$accept
+
+ out.metro <- metrop(out.metro, scale = 0.5)
+ out.metro$accept
+
+ apply(out.metro$batch, 2, mean)
+
+ out.metro <- metrop(logl, as.numeric(coefficients(out)), 1e2,
+ scale = 0.5, debug = TRUE, blen = 5)
+
+ niter <- out.metro$nbatch * out.metro$blen * out.metro$nspac
+ niter == nrow(out.metro$current)
+ niter == nrow(out.metro$proposal)
+ all(out.metro$current[1, ] == out.metro$initial)
+ all(out.metro$current[niter, ] == out.metro$final) |
+ all(out.metro$proposal[niter, ] == out.metro$final)
+
+ .Random.seed <- out.metro$initial.seed
+ d <- ncol(out.metro$proposal)
+ n <- nrow(out.metro$proposal)
+ my.proposal <- matrix(NA, n, d)
+ my.u <- double(n)
+ ska <- out.metro$scale
+ for (i in 1:n) {
+ my.proposal[i, ] <- out.metro$current[i, ] + ska * rnorm(d)
+ if (is.na(out.metro$u[i])) {
+ my.u[i] <- NA
+ } else {
+ my.u[i] <- runif(1)
+ }
+ }
+ max(abs(out.metro$proposal - my.proposal)) < epsilon
+ all(is.na(out.metro$u) == is.na(my.u))
+ all(out.metro$u[!is.na(out.metro$u)] == my.u[!is.na(my.u)])
+
+ my.curr.log.green <- apply(out.metro$current, 1, logl)
+ my.prop.log.green <- apply(out.metro$proposal, 1, logl)
+ all(is.na(out.metro$u) == (my.prop.log.green > my.curr.log.green))
+ foo <- my.prop.log.green - my.curr.log.green
+ max(abs(foo - out.metro$log.green)) < epsilon
+
+ my.accept <- is.na(my.u) | my.u < exp(foo)
+ sum(my.accept) == round(n * out.metro$accept)
+ if (my.accept[niter]) {
+ all(out.metro$proposal[niter, ] == out.metro$final)
+ } else {
+ all(out.metro$current[niter, ] == out.metro$final)
+ }
+
+ my.current <- out.metro$current
+ my.current[my.accept, ] <- my.proposal[my.accept, ]
+ my.current <- rbind(out.metro$initial, my.current[- niter, ])
+ max(abs(out.metro$current - my.current)) < epsilon
+
+ my.path <- matrix(NA, n, d)
+ my.path[my.accept, ] <- out.metro$proposal[my.accept, ]
+ my.path[! my.accept, ] <- out.metro$current[! my.accept, ]
+ nspac <- out.metro$nspac
+
+ my.path <- my.path[seq(nspac, niter, by = nspac), ]
+
+ foom <- array(as.vector(t(my.path)), c(d, out.metro$blen, out.metro$nbatch))
+ boom <- t(apply(foom, c(1, 3), mean))
+
+ all(dim(boom) == dim(out.metro$batch))
+ max(abs(boom - out.metro$batch)) < epsilon
+
diff --git a/tests/logitbat.Rout.save b/tests/logitbat.Rout.save
new file mode 100644
index 0000000..30fb48c
--- /dev/null
+++ b/tests/logitbat.Rout.save
@@ -0,0 +1,142 @@
+
+R version 2.13.1 (2011-07-08)
+Copyright (C) 2011 The R Foundation for Statistical Computing
+ISBN 3-900051-07-0
+Platform: x86_64-pc-linux-gnu (64-bit)
+
+R is free software and comes with ABSOLUTELY NO WARRANTY.
+You are welcome to redistribute it under certain conditions.
+Type 'license()' or 'licence()' for distribution details.
+
+R is a collaborative project with many contributors.
+Type 'contributors()' for more information and
+'citation()' on how to cite R or R packages in publications.
+
+Type 'demo()' for some demos, 'help()' for on-line help, or
+'help.start()' for an HTML browser interface to help.
+Type 'q()' to quit R.
+
+>
+> # test batching (blen)
+>
+> epsilon <- 1e-15
+>
+> library(mcmc)
+>
+> RNGkind("Marsaglia-Multicarry")
+> set.seed(42)
+>
+> n <- 100
+> rho <- 0.5
+> beta0 <- 0.25
+> beta1 <- 1
+> beta2 <- 0.5
+>
+> x1 <- rnorm(n)
+> x2 <- rho * x1 + sqrt(1 - rho^2) * rnorm(n)
+> eta <- beta0 + beta1 * x1 + beta2 * x2
+> p <- 1 / (1 + exp(- eta))
+> y <- as.numeric(runif(n) < p)
+>
+> out <- glm(y ~ x1 + x2, family = binomial())
+>
+> logl <- function(beta) {
++ if (length(beta) != 3) stop("length(beta) != 3")
++ beta0 <- beta[1]
++ beta1 <- beta[2]
++ beta2 <- beta[3]
++ eta <- beta0 + beta1 * x1 + beta2 * x2
++ p <- exp(eta) / (1 + exp(eta))
++ return(sum(log(p[y == 1])) + sum(log(1 - p[y == 0])))
++ }
+>
+> out.metro <- metrop(logl, coefficients(out), 1e3, scale = 0.01)
+> out.metro$accept
+[1] 0.982
+>
+> out.metro <- metrop(out.metro, scale = 0.1)
+> out.metro$accept
+[1] 0.795
+>
+> out.metro <- metrop(out.metro, scale = 0.5)
+> out.metro$accept
+[1] 0.264
+>
+> apply(out.metro$batch, 2, mean)
+[1] 0.06080257 1.42304941 0.52634149
+>
+> out.metro <- metrop(logl, as.numeric(coefficients(out)), 1e2,
++ scale = 0.5, debug = TRUE, blen = 5)
+>
+> niter <- out.metro$nbatch * out.metro$blen * out.metro$nspac
+> niter == nrow(out.metro$current)
+[1] TRUE
+> niter == nrow(out.metro$proposal)
+[1] TRUE
+> all(out.metro$current[1, ] == out.metro$initial)
+[1] TRUE
+> all(out.metro$current[niter, ] == out.metro$final) |
++ all(out.metro$proposal[niter, ] == out.metro$final)
+[1] TRUE
+>
+> .Random.seed <- out.metro$initial.seed
+> d <- ncol(out.metro$proposal)
+> n <- nrow(out.metro$proposal)
+> my.proposal <- matrix(NA, n, d)
+> my.u <- double(n)
+> ska <- out.metro$scale
+> for (i in 1:n) {
++ my.proposal[i, ] <- out.metro$current[i, ] + ska * rnorm(d)
++ if (is.na(out.metro$u[i])) {
++ my.u[i] <- NA
++ } else {
++ my.u[i] <- runif(1)
++ }
++ }
+> max(abs(out.metro$proposal - my.proposal)) < epsilon
+[1] TRUE
+> all(is.na(out.metro$u) == is.na(my.u))
+[1] TRUE
+> all(out.metro$u[!is.na(out.metro$u)] == my.u[!is.na(my.u)])
+[1] TRUE
+>
+> my.curr.log.green <- apply(out.metro$current, 1, logl)
+> my.prop.log.green <- apply(out.metro$proposal, 1, logl)
+> all(is.na(out.metro$u) == (my.prop.log.green > my.curr.log.green))
+[1] TRUE
+> foo <- my.prop.log.green - my.curr.log.green
+> max(abs(foo - out.metro$log.green)) < epsilon
+[1] TRUE
+>
+> my.accept <- is.na(my.u) | my.u < exp(foo)
+> sum(my.accept) == round(n * out.metro$accept)
+[1] TRUE
+> if (my.accept[niter]) {
++ all(out.metro$proposal[niter, ] == out.metro$final)
++ } else {
++ all(out.metro$current[niter, ] == out.metro$final)
++ }
+[1] TRUE
+>
+> my.current <- out.metro$current
+> my.current[my.accept, ] <- my.proposal[my.accept, ]
+> my.current <- rbind(out.metro$initial, my.current[- niter, ])
+> max(abs(out.metro$current - my.current)) < epsilon
+[1] TRUE
+>
+> my.path <- matrix(NA, n, d)
+> my.path[my.accept, ] <- out.metro$proposal[my.accept, ]
+> my.path[! my.accept, ] <- out.metro$current[! my.accept, ]
+> nspac <- out.metro$nspac
+>
+> my.path <- my.path[seq(nspac, niter, by = nspac), ]
+>
+> foom <- array(as.vector(t(my.path)), c(d, out.metro$blen, out.metro$nbatch))
+> boom <- t(apply(foom, c(1, 3), mean))
+>
+> all(dim(boom) == dim(out.metro$batch))
+[1] TRUE
+> max(abs(boom - out.metro$batch)) < epsilon
+[1] TRUE
+>
+>
diff --git a/tests/logitfun.R b/tests/logitfun.R
new file mode 100644
index 0000000..7d2b79b
--- /dev/null
+++ b/tests/logitfun.R
@@ -0,0 +1,111 @@
+
+ # test outfun (function)
+
+ epsilon <- 1e-15
+
+ library(mcmc)
+
+ RNGkind("Marsaglia-Multicarry")
+ set.seed(42)
+
+ n <- 100
+ rho <- 0.5
+ beta0 <- 0.25
+ beta1 <- 1
+ beta2 <- 0.5
+
+ x1 <- rnorm(n)
+ x2 <- rho * x1 + sqrt(1 - rho^2) * rnorm(n)
+ eta <- beta0 + beta1 * x1 + beta2 * x2
+ p <- 1 / (1 + exp(- eta))
+ y <- as.numeric(runif(n) < p)
+
+ out <- glm(y ~ x1 + x2, family = binomial())
+
+ logl <- function(beta) {
+ if (length(beta) != 3) stop("length(beta) != 3")
+ beta0 <- beta[1]
+ beta1 <- beta[2]
+ beta2 <- beta[3]
+ eta <- beta0 + beta1 * x1 + beta2 * x2
+ p <- exp(eta) / (1 + exp(eta))
+ return(sum(log(p[y == 1])) + sum(log(1 - p[y == 0])))
+ }
+
+ out.metro <- metrop(logl, coefficients(out), 1e3, scale = 0.01)
+ out.metro$accept
+
+ out.metro <- metrop(out.metro, scale = 0.1)
+ out.metro$accept
+
+ out.metro <- metrop(out.metro, scale = 0.5)
+ out.metro$accept
+
+ apply(out.metro$batch, 2, mean)
+
+ out.metro <- metrop(logl, as.numeric(coefficients(out)), 1e2,
+ scale = 0.5, debug = TRUE, outfun = function(x) c(x, x^2))
+
+ niter <- out.metro$nbatch * out.metro$blen * out.metro$nspac
+ niter == nrow(out.metro$current)
+ niter == nrow(out.metro$proposal)
+ all(out.metro$current[1, ] == out.metro$initial)
+ all(out.metro$current[niter, ] == out.metro$final) |
+ all(out.metro$proposal[niter, ] == out.metro$final)
+
+ .Random.seed <- out.metro$initial.seed
+ d <- ncol(out.metro$proposal)
+ n <- nrow(out.metro$proposal)
+ my.proposal <- matrix(NA, n, d)
+ my.u <- double(n)
+ ska <- out.metro$scale
+ for (i in 1:n) {
+ my.proposal[i, ] <- out.metro$current[i, ] + ska * rnorm(d)
+ if (is.na(out.metro$u[i])) {
+ my.u[i] <- NA
+ } else {
+ my.u[i] <- runif(1)
+ }
+ }
+ max(abs(out.metro$proposal - my.proposal)) < epsilon
+ all(is.na(out.metro$u) == is.na(my.u))
+ all(out.metro$u[!is.na(out.metro$u)] == my.u[!is.na(my.u)])
+
+ my.curr.log.green <- apply(out.metro$current, 1, logl)
+ my.prop.log.green <- apply(out.metro$proposal, 1, logl)
+ all(is.na(out.metro$u) == (my.prop.log.green > my.curr.log.green))
+ foo <- my.prop.log.green - my.curr.log.green
+ max(abs(foo - out.metro$log.green)) < epsilon
+
+ my.accept <- is.na(my.u) | my.u < exp(foo)
+ sum(my.accept) == round(n * out.metro$accept)
+ if (my.accept[niter]) {
+ all(out.metro$proposal[niter, ] == out.metro$final)
+ } else {
+ all(out.metro$current[niter, ] == out.metro$final)
+ }
+
+ my.current <- out.metro$current
+ my.current[my.accept, ] <- my.proposal[my.accept, ]
+ my.current <- rbind(out.metro$initial, my.current[- niter, ])
+ max(abs(out.metro$current - my.current)) < epsilon
+
+ my.path <- matrix(NA, n, d)
+ my.path[my.accept, ] <- out.metro$proposal[my.accept, ]
+ my.path[! my.accept, ] <- out.metro$current[! my.accept, ]
+ nspac <- out.metro$nspac
+
+ my.path <- my.path[seq(nspac, niter, by = nspac), ]
+
+ fred <- t(apply(my.path, 1, out.metro$outfun))
+ k <- ncol(fred)
+
+ foom <- array(as.vector(t(fred)), c(k, out.metro$blen, out.metro$nbatch))
+ boom <- t(apply(foom, c(1, 3), mean))
+
+ all(dim(boom) == dim(out.metro$batch))
+ max(abs(boom - out.metro$batch)) < epsilon
+
+ goom <- cbind(my.path, my.path^2)
+ all(dim(goom) == dim(out.metro$batch))
+ max(abs(goom - out.metro$batch)) < epsilon
diff --git a/tests/logitfun.Rout.save b/tests/logitfun.Rout.save
new file mode 100644
index 0000000..9026958
--- /dev/null
+++ b/tests/logitfun.Rout.save
@@ -0,0 +1,150 @@
+
+R version 2.13.1 (2011-07-08)
+Copyright (C) 2011 The R Foundation for Statistical Computing
+ISBN 3-900051-07-0
+Platform: x86_64-pc-linux-gnu (64-bit)
+
+R is free software and comes with ABSOLUTELY NO WARRANTY.
+You are welcome to redistribute it under certain conditions.
+Type 'license()' or 'licence()' for distribution details.
+
+R is a collaborative project with many contributors.
+Type 'contributors()' for more information and
+'citation()' on how to cite R or R packages in publications.
+
+Type 'demo()' for some demos, 'help()' for on-line help, or
+'help.start()' for an HTML browser interface to help.
+Type 'q()' to quit R.
+
+>
+> # test outfun (function)
+>
+> epsilon <- 1e-15
+>
+> library(mcmc)
+>
+> RNGkind("Marsaglia-Multicarry")
+> set.seed(42)
+>
+> n <- 100
+> rho <- 0.5
+> beta0 <- 0.25
+> beta1 <- 1
+> beta2 <- 0.5
+>
+> x1 <- rnorm(n)
+> x2 <- rho * x1 + sqrt(1 - rho^2) * rnorm(n)
+> eta <- beta0 + beta1 * x1 + beta2 * x2
+> p <- 1 / (1 + exp(- eta))
+> y <- as.numeric(runif(n) < p)
+>
+> out <- glm(y ~ x1 + x2, family = binomial())
+>
+> logl <- function(beta) {
++ if (length(beta) != 3) stop("length(beta) != 3")
++ beta0 <- beta[1]
++ beta1 <- beta[2]
++ beta2 <- beta[3]
++ eta <- beta0 + beta1 * x1 + beta2 * x2
++ p <- exp(eta) / (1 + exp(eta))
++ return(sum(log(p[y == 1])) + sum(log(1 - p[y == 0])))
++ }
+>
+> out.metro <- metrop(logl, coefficients(out), 1e3, scale = 0.01)
+> out.metro$accept
+[1] 0.982
+>
+> out.metro <- metrop(out.metro, scale = 0.1)
+> out.metro$accept
+[1] 0.795
+>
+> out.metro <- metrop(out.metro, scale = 0.5)
+> out.metro$accept
+[1] 0.264
+>
+> apply(out.metro$batch, 2, mean)
+[1] 0.06080257 1.42304941 0.52634149
+>
+> out.metro <- metrop(logl, as.numeric(coefficients(out)), 1e2,
++ scale = 0.5, debug = TRUE, outfun = function(x) c(x, x^2))
+>
+> niter <- out.metro$nbatch * out.metro$blen * out.metro$nspac
+> niter == nrow(out.metro$current)
+[1] TRUE
+> niter == nrow(out.metro$proposal)
+[1] TRUE
+> all(out.metro$current[1, ] == out.metro$initial)
+[1] TRUE
+> all(out.metro$current[niter, ] == out.metro$final) |
++ all(out.metro$proposal[niter, ] == out.metro$final)
+[1] TRUE
+>
+> .Random.seed <- out.metro$initial.seed
+> d <- ncol(out.metro$proposal)
+> n <- nrow(out.metro$proposal)
+> my.proposal <- matrix(NA, n, d)
+> my.u <- double(n)
+> ska <- out.metro$scale
+> for (i in 1:n) {
++ my.proposal[i, ] <- out.metro$current[i, ] + ska * rnorm(d)
++ if (is.na(out.metro$u[i])) {
++ my.u[i] <- NA
++ } else {
++ my.u[i] <- runif(1)
++ }
++ }
+> max(abs(out.metro$proposal - my.proposal)) < epsilon
+[1] TRUE
+> all(is.na(out.metro$u) == is.na(my.u))
+[1] TRUE
+> all(out.metro$u[!is.na(out.metro$u)] == my.u[!is.na(my.u)])
+[1] TRUE
+>
+> my.curr.log.green <- apply(out.metro$current, 1, logl)
+> my.prop.log.green <- apply(out.metro$proposal, 1, logl)
+> all(is.na(out.metro$u) == (my.prop.log.green > my.curr.log.green))
+[1] TRUE
+> foo <- my.prop.log.green - my.curr.log.green
+> max(abs(foo - out.metro$log.green)) < epsilon
+[1] TRUE
+>
+> my.accept <- is.na(my.u) | my.u < exp(foo)
+> sum(my.accept) == round(n * out.metro$accept)
+[1] TRUE
+> if (my.accept[niter]) {
++ all(out.metro$proposal[niter, ] == out.metro$final)
++ } else {
++ all(out.metro$current[niter, ] == out.metro$final)
++ }
+[1] TRUE
+>
+> my.current <- out.metro$current
+> my.current[my.accept, ] <- my.proposal[my.accept, ]
+> my.current <- rbind(out.metro$initial, my.current[- niter, ])
+> max(abs(out.metro$current - my.current)) < epsilon
+[1] TRUE
+>
+> my.path <- matrix(NA, n, d)
+> my.path[my.accept, ] <- out.metro$proposal[my.accept, ]
+> my.path[! my.accept, ] <- out.metro$current[! my.accept, ]
+> nspac <- out.metro$nspac
+>
+> my.path <- my.path[seq(nspac, niter, by = nspac), ]
+>
+> fred <- t(apply(my.path, 1, out.metro$outfun))
+> k <- ncol(fred)
+>
+> foom <- array(as.vector(t(fred)), c(k, out.metro$blen, out.metro$nbatch))
+> boom <- t(apply(foom, c(1, 3), mean))
+>
+> all(dim(boom) == dim(out.metro$batch))
+[1] TRUE
+> max(abs(boom - out.metro$batch)) < epsilon
+[1] TRUE
+>
+> goom <- cbind(my.path, my.path^2)
+> all(dim(goom) == dim(out.metro$batch))
+[1] TRUE
+> max(abs(goom - out.metro$batch)) < epsilon
+[1] TRUE
+>
diff --git a/tests/logitfunarg.R b/tests/logitfunarg.R
new file mode 100644
index 0000000..5f1e77d
--- /dev/null
+++ b/tests/logitfunarg.R
@@ -0,0 +1,68 @@
+
+ # test outfun (function)
+
+ epsilon <- 1e-15
+
+ library(mcmc)
+
+ RNGkind("Marsaglia-Multicarry")
+ set.seed(42)
+
+ n <- 100
+ rho <- 0.5
+ beta0 <- 0.25
+ beta1 <- 1
+ beta2 <- 0.5
+
+ x1 <- rnorm(n)
+ x2 <- rho * x1 + sqrt(1 - rho^2) * rnorm(n)
+ eta <- beta0 + beta1 * x1 + beta2 * x2
+ p <- 1 / (1 + exp(- eta))
+ y <- as.numeric(runif(n) < p)
+
+ out <- glm(y ~ x1 + x2, family = binomial())
+
+ logl <- function(beta) {
+ if (length(beta) != 3) stop("length(beta) != 3")
+ beta0 <- beta[1]
+ beta1 <- beta[2]
+ beta2 <- beta[3]
+ eta <- beta0 + beta1 * x1 + beta2 * x2
+ p <- exp(eta) / (1 + exp(eta))
+ return(sum(log(p[y == 1])) + sum(log(1 - p[y == 0])))
+ }
+
+ out.metro <- metrop(logl, coefficients(out), 1e3, scale = 0.01)
+ out.metro$accept
+
+ out.metro <- metrop(out.metro, scale = 0.1)
+ out.metro$accept
+
+ out.metro <- metrop(out.metro, scale = 0.5)
+ out.metro$accept
+
+ apply(out.metro$batch, 2, mean)
+
+ out.metro <- metrop(logl, as.numeric(coefficients(out)), 1e2,
+ scale = 0.5, debug = TRUE, outfun = function(x) c(x, x^2))
+
+ out.metro <- metrop(out.metro)
+ out.metro$outfun
+ dim(out.metro$batch)
+
+ logl <- function(beta, x1, x2, y) {
+ if (length(beta) != 3) stop("length(beta) != 3")
+ beta0 <- beta[1]
+ beta1 <- beta[2]
+ beta2 <- beta[3]
+ eta <- beta0 + beta1 * x1 + beta2 * x2
+ p <- exp(eta) / (1 + exp(eta))
+ return(sum(log(p[y == 1])) + sum(log(1 - p[y == 0])))
+ }
+
+ out.metro <- metrop(logl, as.numeric(coefficients(out)), 1e2,
+ scale = 0.5, debug = TRUE, x1 = x1, x2 = x2, y = y)
+ out.metro$lud
+ out.metro <- metrop(out.metro, x1 = x1, x2 = x2, y = y)
+ out.metro$lud
+
diff --git a/tests/logitfunarg.Rout.save b/tests/logitfunarg.Rout.save
new file mode 100644
index 0000000..91a83d3
--- /dev/null
+++ b/tests/logitfunarg.Rout.save
@@ -0,0 +1,116 @@
+
+R version 2.13.1 (2011-07-08)
+Copyright (C) 2011 The R Foundation for Statistical Computing
+ISBN 3-900051-07-0
+Platform: x86_64-pc-linux-gnu (64-bit)
+
+R is free software and comes with ABSOLUTELY NO WARRANTY.
+You are welcome to redistribute it under certain conditions.
+Type 'license()' or 'licence()' for distribution details.
+
+R is a collaborative project with many contributors.
+Type 'contributors()' for more information and
+'citation()' on how to cite R or R packages in publications.
+
+Type 'demo()' for some demos, 'help()' for on-line help, or
+'help.start()' for an HTML browser interface to help.
+Type 'q()' to quit R.
+
+>
+> # test outfun (function)
+>
+> epsilon <- 1e-15
+>
+> library(mcmc)
+>
+> RNGkind("Marsaglia-Multicarry")
+> set.seed(42)
+>
+> n <- 100
+> rho <- 0.5
+> beta0 <- 0.25
+> beta1 <- 1
+> beta2 <- 0.5
+>
+> x1 <- rnorm(n)
+> x2 <- rho * x1 + sqrt(1 - rho^2) * rnorm(n)
+> eta <- beta0 + beta1 * x1 + beta2 * x2
+> p <- 1 / (1 + exp(- eta))
+> y <- as.numeric(runif(n) < p)
+>
+> out <- glm(y ~ x1 + x2, family = binomial())
+>
+> logl <- function(beta) {
++ if (length(beta) != 3) stop("length(beta) != 3")
++ beta0 <- beta[1]
++ beta1 <- beta[2]
++ beta2 <- beta[3]
++ eta <- beta0 + beta1 * x1 + beta2 * x2
++ p <- exp(eta) / (1 + exp(eta))
++ return(sum(log(p[y == 1])) + sum(log(1 - p[y == 0])))
++ }
+>
+> out.metro <- metrop(logl, coefficients(out), 1e3, scale = 0.01)
+> out.metro$accept
+[1] 0.982
+>
+> out.metro <- metrop(out.metro, scale = 0.1)
+> out.metro$accept
+[1] 0.795
+>
+> out.metro <- metrop(out.metro, scale = 0.5)
+> out.metro$accept
+[1] 0.264
+>
+> apply(out.metro$batch, 2, mean)
+[1] 0.06080257 1.42304941 0.52634149
+>
+> out.metro <- metrop(logl, as.numeric(coefficients(out)), 1e2,
++ scale = 0.5, debug = TRUE, outfun = function(x) c(x, x^2))
+>
+> out.metro <- metrop(out.metro)
+> out.metro$outfun
+function (x)
+c(x, x^2)
+> dim(out.metro$batch)
+[1] 100 6
+>
+> logl <- function(beta, x1, x2, y) {
++ if (length(beta) != 3) stop("length(beta) != 3")
++ beta0 <- beta[1]
++ beta1 <- beta[2]
++ beta2 <- beta[3]
++ eta <- beta0 + beta1 * x1 + beta2 * x2
++ p <- exp(eta) / (1 + exp(eta))
++ return(sum(log(p[y == 1])) + sum(log(1 - p[y == 0])))
++ }
+>
+> out.metro <- metrop(logl, as.numeric(coefficients(out)), 1e2,
++ scale = 0.5, debug = TRUE, x1 = x1, x2 = x2, y = y)
+> out.metro$lud
+function (beta, x1, x2, y)
+{
+ if (length(beta) != 3)
+ stop("length(beta) != 3")
+ beta0 <- beta[1]
+ beta1 <- beta[2]
+ beta2 <- beta[3]
+ eta <- beta0 + beta1 * x1 + beta2 * x2
+ p <- exp(eta)/(1 + exp(eta))
+ return(sum(log(p[y == 1])) + sum(log(1 - p[y == 0])))
+}
+> out.metro <- metrop(out.metro, x1 = x1, x2 = x2, y = y)
+> out.metro$lud
+function (beta, x1, x2, y)
+{
+ if (length(beta) != 3)
+ stop("length(beta) != 3")
+ beta0 <- beta[1]
+ beta1 <- beta[2]
+ beta2 <- beta[3]
+ eta <- beta0 + beta1 * x1 + beta2 * x2
+ p <- exp(eta)/(1 + exp(eta))
+ return(sum(log(p[y == 1])) + sum(log(1 - p[y == 0])))
+}
+>
+>
diff --git a/tests/logitidx.R b/tests/logitidx.R
new file mode 100644
index 0000000..7291cf7
--- /dev/null
+++ b/tests/logitidx.R
@@ -0,0 +1,108 @@
+
+ # test outfun (positive index vector)
+
+ epsilon <- 1e-15
+
+ library(mcmc)
+
+ RNGkind("Marsaglia-Multicarry")
+ set.seed(42)
+
+ n <- 100
+ rho <- 0.5
+ beta0 <- 0.25
+ beta1 <- 1
+ beta2 <- 0.5
+
+ x1 <- rnorm(n)
+ x2 <- rho * x1 + sqrt(1 - rho^2) * rnorm(n)
+ eta <- beta0 + beta1 * x1 + beta2 * x2
+ p <- 1 / (1 + exp(- eta))
+ y <- as.numeric(runif(n) < p)
+
+ out <- glm(y ~ x1 + x2, family = binomial())
+
+ logl <- function(beta) {
+ if (length(beta) != 3) stop("length(beta) != 3")
+ beta0 <- beta[1]
+ beta1 <- beta[2]
+ beta2 <- beta[3]
+ eta <- beta0 + beta1 * x1 + beta2 * x2
+ p <- exp(eta) / (1 + exp(eta))
+ return(sum(log(p[y == 1])) + sum(log(1 - p[y == 0])))
+ }
+
+ out.metro <- metrop(logl, coefficients(out), 1e3, scale = 0.01)
+ out.metro$accept
+
+ out.metro <- metrop(out.metro, scale = 0.1)
+ out.metro$accept
+
+ out.metro <- metrop(out.metro, scale = 0.5)
+ out.metro$accept
+
+ apply(out.metro$batch, 2, mean)
+
+ out.metro <- metrop(logl, as.numeric(coefficients(out)), 1e2,
+ scale = 0.5, debug = TRUE, outfun = c(2, 3))
+
+ niter <- out.metro$nbatch * out.metro$blen * out.metro$nspac
+ niter == nrow(out.metro$current)
+ niter == nrow(out.metro$proposal)
+ all(out.metro$current[1, ] == out.metro$initial)
+ all(out.metro$current[niter, ] == out.metro$final) |
+ all(out.metro$proposal[niter, ] == out.metro$final)
+
+ .Random.seed <- out.metro$initial.seed
+ d <- ncol(out.metro$proposal)
+ n <- nrow(out.metro$proposal)
+ my.proposal <- matrix(NA, n, d)
+ my.u <- double(n)
+ ska <- out.metro$scale
+ for (i in 1:n) {
+ my.proposal[i, ] <- out.metro$current[i, ] + ska * rnorm(d)
+ if (is.na(out.metro$u[i])) {
+ my.u[i] <- NA
+ } else {
+ my.u[i] <- runif(1)
+ }
+ }
+ max(abs(out.metro$proposal - my.proposal)) < epsilon
+ all(is.na(out.metro$u) == is.na(my.u))
+ all(out.metro$u[!is.na(out.metro$u)] == my.u[!is.na(my.u)])
+
+ my.curr.log.green <- apply(out.metro$current, 1, logl)
+ my.prop.log.green <- apply(out.metro$proposal, 1, logl)
+ all(is.na(out.metro$u) == (my.prop.log.green > my.curr.log.green))
+ foo <- my.prop.log.green - my.curr.log.green
+ max(abs(foo - out.metro$log.green)) < epsilon
+
+ my.accept <- is.na(my.u) | my.u < exp(foo)
+ sum(my.accept) == round(n * out.metro$accept)
+ if (my.accept[niter]) {
+ all(out.metro$proposal[niter, ] == out.metro$final)
+ } else {
+ all(out.metro$current[niter, ] == out.metro$final)
+ }
+
+ my.current <- out.metro$current
+ my.current[my.accept, ] <- my.proposal[my.accept, ]
+ my.current <- rbind(out.metro$initial, my.current[- niter, ])
+ max(abs(out.metro$current - my.current)) < epsilon
+
+ my.path <- matrix(NA, n, d)
+ my.path[my.accept, ] <- out.metro$proposal[my.accept, ]
+ my.path[! my.accept, ] <- out.metro$current[! my.accept, ]
+ nspac <- out.metro$nspac
+
+ my.path <- my.path[seq(nspac, niter, by = nspac), ]
+
+ fred <- my.path[ , out.metro$outfun]
+ k <- ncol(fred)
+
+ foom <- array(as.vector(t(fred)), c(k, out.metro$blen, out.metro$nbatch))
+ boom <- t(apply(foom, c(1, 3), mean))
+
+ all(dim(boom) == dim(out.metro$batch))
+ max(abs(boom - out.metro$batch)) < epsilon
+
diff --git a/tests/logitidx.Rout.save b/tests/logitidx.Rout.save
new file mode 100644
index 0000000..28dc298
--- /dev/null
+++ b/tests/logitidx.Rout.save
@@ -0,0 +1,145 @@
+
+R version 2.13.1 (2011-07-08)
+Copyright (C) 2011 The R Foundation for Statistical Computing
+ISBN 3-900051-07-0
+Platform: x86_64-pc-linux-gnu (64-bit)
+
+R is free software and comes with ABSOLUTELY NO WARRANTY.
+You are welcome to redistribute it under certain conditions.
+Type 'license()' or 'licence()' for distribution details.
+
+R is a collaborative project with many contributors.
+Type 'contributors()' for more information and
+'citation()' on how to cite R or R packages in publications.
+
+Type 'demo()' for some demos, 'help()' for on-line help, or
+'help.start()' for an HTML browser interface to help.
+Type 'q()' to quit R.
+
+>
+> # test outfun (positive index vector)
+>
+> epsilon <- 1e-15
+>
+> library(mcmc)
+>
+> RNGkind("Marsaglia-Multicarry")
+> set.seed(42)
+>
+> n <- 100
+> rho <- 0.5
+> beta0 <- 0.25
+> beta1 <- 1
+> beta2 <- 0.5
+>
+> x1 <- rnorm(n)
+> x2 <- rho * x1 + sqrt(1 - rho^2) * rnorm(n)
+> eta <- beta0 + beta1 * x1 + beta2 * x2
+> p <- 1 / (1 + exp(- eta))
+> y <- as.numeric(runif(n) < p)
+>
+> out <- glm(y ~ x1 + x2, family = binomial())
+>
+> logl <- function(beta) {
++ if (length(beta) != 3) stop("length(beta) != 3")
++ beta0 <- beta[1]
++ beta1 <- beta[2]
++ beta2 <- beta[3]
++ eta <- beta0 + beta1 * x1 + beta2 * x2
++ p <- exp(eta) / (1 + exp(eta))
++ return(sum(log(p[y == 1])) + sum(log(1 - p[y == 0])))
++ }
+>
+> out.metro <- metrop(logl, coefficients(out), 1e3, scale = 0.01)
+> out.metro$accept
+[1] 0.982
+>
+> out.metro <- metrop(out.metro, scale = 0.1)
+> out.metro$accept
+[1] 0.795
+>
+> out.metro <- metrop(out.metro, scale = 0.5)
+> out.metro$accept
+[1] 0.264
+>
+> apply(out.metro$batch, 2, mean)
+[1] 0.06080257 1.42304941 0.52634149
+>
+> out.metro <- metrop(logl, as.numeric(coefficients(out)), 1e2,
++ scale = 0.5, debug = TRUE, outfun = c(2, 3))
+>
+> niter <- out.metro$nbatch * out.metro$blen * out.metro$nspac
+> niter == nrow(out.metro$current)
+[1] TRUE
+> niter == nrow(out.metro$proposal)
+[1] TRUE
+> all(out.metro$current[1, ] == out.metro$initial)
+[1] TRUE
+> all(out.metro$current[niter, ] == out.metro$final) |
++ all(out.metro$proposal[niter, ] == out.metro$final)
+[1] TRUE
+>
+> .Random.seed <- out.metro$initial.seed
+> d <- ncol(out.metro$proposal)
+> n <- nrow(out.metro$proposal)
+> my.proposal <- matrix(NA, n, d)
+> my.u <- double(n)
+> ska <- out.metro$scale
+> for (i in 1:n) {
++ my.proposal[i, ] <- out.metro$current[i, ] + ska * rnorm(d)
++ if (is.na(out.metro$u[i])) {
++ my.u[i] <- NA
++ } else {
++ my.u[i] <- runif(1)
++ }
++ }
+> max(abs(out.metro$proposal - my.proposal)) < epsilon
+[1] TRUE
+> all(is.na(out.metro$u) == is.na(my.u))
+[1] TRUE
+> all(out.metro$u[!is.na(out.metro$u)] == my.u[!is.na(my.u)])
+[1] TRUE
+>
+> my.curr.log.green <- apply(out.metro$current, 1, logl)
+> my.prop.log.green <- apply(out.metro$proposal, 1, logl)
+> all(is.na(out.metro$u) == (my.prop.log.green > my.curr.log.green))
+[1] TRUE
+> foo <- my.prop.log.green - my.curr.log.green
+> max(abs(foo - out.metro$log.green)) < epsilon
+[1] TRUE
+>
+> my.accept <- is.na(my.u) | my.u < exp(foo)
+> sum(my.accept) == round(n * out.metro$accept)
+[1] TRUE
+> if (my.accept[niter]) {
++ all(out.metro$proposal[niter, ] == out.metro$final)
++ } else {
++ all(out.metro$current[niter, ] == out.metro$final)
++ }
+[1] TRUE
+>
+> my.current <- out.metro$current
+> my.current[my.accept, ] <- my.proposal[my.accept, ]
+> my.current <- rbind(out.metro$initial, my.current[- niter, ])
+> max(abs(out.metro$current - my.current)) < epsilon
+[1] TRUE
+>
+> my.path <- matrix(NA, n, d)
+> my.path[my.accept, ] <- out.metro$proposal[my.accept, ]
+> my.path[! my.accept, ] <- out.metro$current[! my.accept, ]
+> nspac <- out.metro$nspac
+>
+> my.path <- my.path[seq(nspac, niter, by = nspac), ]
+>
+> fred <- my.path[ , out.metro$outfun]
+> k <- ncol(fred)
+>
+> foom <- array(as.vector(t(fred)), c(k, out.metro$blen, out.metro$nbatch))
+> boom <- t(apply(foom, c(1, 3), mean))
+>
+> all(dim(boom) == dim(out.metro$batch))
+[1] TRUE
+> max(abs(boom - out.metro$batch)) < epsilon
+[1] TRUE
+>
+>
diff --git a/tests/logitlogidx.R b/tests/logitlogidx.R
new file mode 100644
index 0000000..d055ea4
--- /dev/null
+++ b/tests/logitlogidx.R
@@ -0,0 +1,108 @@
+
+ # test outfun (logical index vector)
+
+ epsilon <- 1e-15
+
+ library(mcmc)
+
+ RNGkind("Marsaglia-Multicarry")
+ set.seed(42)
+
+ n <- 100
+ rho <- 0.5
+ beta0 <- 0.25
+ beta1 <- 1
+ beta2 <- 0.5
+
+ x1 <- rnorm(n)
+ x2 <- rho * x1 + sqrt(1 - rho^2) * rnorm(n)
+ eta <- beta0 + beta1 * x1 + beta2 * x2
+ p <- 1 / (1 + exp(- eta))
+ y <- as.numeric(runif(n) < p)
+
+ out <- glm(y ~ x1 + x2, family = binomial())
+
+ logl <- function(beta) {
+ if (length(beta) != 3) stop("length(beta) != 3")
+ beta0 <- beta[1]
+ beta1 <- beta[2]
+ beta2 <- beta[3]
+ eta <- beta0 + beta1 * x1 + beta2 * x2
+ p <- exp(eta) / (1 + exp(eta))
+ return(sum(log(p[y == 1])) + sum(log(1 - p[y == 0])))
+ }
+
+ out.metro <- metrop(logl, coefficients(out), 1e3, scale = 0.01)
+ out.metro$accept
+
+ out.metro <- metrop(out.metro, scale = 0.1)
+ out.metro$accept
+
+ out.metro <- metrop(out.metro, scale = 0.5)
+ out.metro$accept
+
+ apply(out.metro$batch, 2, mean)
+
+ out.metro <- metrop(logl, as.numeric(coefficients(out)), 1e2,
+ scale = 0.5, debug = TRUE, outfun = seq(1:3) > 1)
+
+ niter <- out.metro$nbatch * out.metro$blen * out.metro$nspac
+ niter == nrow(out.metro$current)
+ niter == nrow(out.metro$proposal)
+ all(out.metro$current[1, ] == out.metro$initial)
+ all(out.metro$current[niter, ] == out.metro$final) |
+ all(out.metro$proposal[niter, ] == out.metro$final)
+
+ .Random.seed <- out.metro$initial.seed
+ d <- ncol(out.metro$proposal)
+ n <- nrow(out.metro$proposal)
+ my.proposal <- matrix(NA, n, d)
+ my.u <- double(n)
+ ska <- out.metro$scale
+ for (i in 1:n) {
+ my.proposal[i, ] <- out.metro$current[i, ] + ska * rnorm(d)
+ if (is.na(out.metro$u[i])) {
+ my.u[i] <- NA
+ } else {
+ my.u[i] <- runif(1)
+ }
+ }
+ max(abs(out.metro$proposal - my.proposal)) < epsilon
+ all(is.na(out.metro$u) == is.na(my.u))
+ all(out.metro$u[!is.na(out.metro$u)] == my.u[!is.na(my.u)])
+
+ my.curr.log.green <- apply(out.metro$current, 1, logl)
+ my.prop.log.green <- apply(out.metro$proposal, 1, logl)
+ all(is.na(out.metro$u) == (my.prop.log.green > my.curr.log.green))
+ foo <- my.prop.log.green - my.curr.log.green
+ max(abs(foo - out.metro$log.green)) < epsilon
+
+ my.accept <- is.na(my.u) | my.u < exp(foo)
+ sum(my.accept) == round(n * out.metro$accept)
+ if (my.accept[niter]) {
+ all(out.metro$proposal[niter, ] == out.metro$final)
+ } else {
+ all(out.metro$current[niter, ] == out.metro$final)
+ }
+
+ my.current <- out.metro$current
+ my.current[my.accept, ] <- my.proposal[my.accept, ]
+ my.current <- rbind(out.metro$initial, my.current[- niter, ])
+ max(abs(out.metro$current - my.current)) < epsilon
+
+ my.path <- matrix(NA, n, d)
+ my.path[my.accept, ] <- out.metro$proposal[my.accept, ]
+ my.path[! my.accept, ] <- out.metro$current[! my.accept, ]
+ nspac <- out.metro$nspac
+
+ my.path <- my.path[seq(nspac, niter, by = nspac), ]
+
+ fred <- my.path[ , out.metro$outfun]
+ k <- ncol(fred)
+
+ foom <- array(as.vector(t(fred)), c(k, out.metro$blen, out.metro$nbatch))
+ boom <- t(apply(foom, c(1, 3), mean))
+
+ all(dim(boom) == dim(out.metro$batch))
+ max(abs(boom - out.metro$batch)) < epsilon
+
diff --git a/tests/logitlogidx.Rout.save b/tests/logitlogidx.Rout.save
new file mode 100644
index 0000000..2d75d73
--- /dev/null
+++ b/tests/logitlogidx.Rout.save
@@ -0,0 +1,145 @@
+
+R version 2.13.1 (2011-07-08)
+Copyright (C) 2011 The R Foundation for Statistical Computing
+ISBN 3-900051-07-0
+Platform: x86_64-pc-linux-gnu (64-bit)
+
+R is free software and comes with ABSOLUTELY NO WARRANTY.
+You are welcome to redistribute it under certain conditions.
+Type 'license()' or 'licence()' for distribution details.
+
+R is a collaborative project with many contributors.
+Type 'contributors()' for more information and
+'citation()' on how to cite R or R packages in publications.
+
+Type 'demo()' for some demos, 'help()' for on-line help, or
+'help.start()' for an HTML browser interface to help.
+Type 'q()' to quit R.
+
+>
+> # test outfun (logical index vector)
+>
+> epsilon <- 1e-15
+>
+> library(mcmc)
+>
+> RNGkind("Marsaglia-Multicarry")
+> set.seed(42)
+>
+> n <- 100
+> rho <- 0.5
+> beta0 <- 0.25
+> beta1 <- 1
+> beta2 <- 0.5
+>
+> x1 <- rnorm(n)
+> x2 <- rho * x1 + sqrt(1 - rho^2) * rnorm(n)
+> eta <- beta0 + beta1 * x1 + beta2 * x2
+> p <- 1 / (1 + exp(- eta))
+> y <- as.numeric(runif(n) < p)
+>
+> out <- glm(y ~ x1 + x2, family = binomial())
+>
+> logl <- function(beta) {
++ if (length(beta) != 3) stop("length(beta) != 3")
++ beta0 <- beta[1]
++ beta1 <- beta[2]
++ beta2 <- beta[3]
++ eta <- beta0 + beta1 * x1 + beta2 * x2
++ p <- exp(eta) / (1 + exp(eta))
++ return(sum(log(p[y == 1])) + sum(log(1 - p[y == 0])))
++ }
+>
+> out.metro <- metrop(logl, coefficients(out), 1e3, scale = 0.01)
+> out.metro$accept
+[1] 0.982
+>
+> out.metro <- metrop(out.metro, scale = 0.1)
+> out.metro$accept
+[1] 0.795
+>
+> out.metro <- metrop(out.metro, scale = 0.5)
+> out.metro$accept
+[1] 0.264
+>
+> apply(out.metro$batch, 2, mean)
+[1] 0.06080257 1.42304941 0.52634149
+>
+> out.metro <- metrop(logl, as.numeric(coefficients(out)), 1e2,
++ scale = 0.5, debug = TRUE, outfun = seq(1:3) > 1)
+>
+> niter <- out.metro$nbatch * out.metro$blen * out.metro$nspac
+> niter == nrow(out.metro$current)
+[1] TRUE
+> niter == nrow(out.metro$proposal)
+[1] TRUE
+> all(out.metro$current[1, ] == out.metro$initial)
+[1] TRUE
+> all(out.metro$current[niter, ] == out.metro$final) |
++ all(out.metro$proposal[niter, ] == out.metro$final)
+[1] TRUE
+>
+> .Random.seed <- out.metro$initial.seed
+> d <- ncol(out.metro$proposal)
+> n <- nrow(out.metro$proposal)
+> my.proposal <- matrix(NA, n, d)
+> my.u <- double(n)
+> ska <- out.metro$scale
+> for (i in 1:n) {
++ my.proposal[i, ] <- out.metro$current[i, ] + ska * rnorm(d)
++ if (is.na(out.metro$u[i])) {
++ my.u[i] <- NA
++ } else {
++ my.u[i] <- runif(1)
++ }
++ }
+> max(abs(out.metro$proposal - my.proposal)) < epsilon
+[1] TRUE
+> all(is.na(out.metro$u) == is.na(my.u))
+[1] TRUE
+> all(out.metro$u[!is.na(out.metro$u)] == my.u[!is.na(my.u)])
+[1] TRUE
+>
+> my.curr.log.green <- apply(out.metro$current, 1, logl)
+> my.prop.log.green <- apply(out.metro$proposal, 1, logl)
+> all(is.na(out.metro$u) == (my.prop.log.green > my.curr.log.green))
+[1] TRUE
+> foo <- my.prop.log.green - my.curr.log.green
+> max(abs(foo - out.metro$log.green)) < epsilon
+[1] TRUE
+>
+> my.accept <- is.na(my.u) | my.u < exp(foo)
+> sum(my.accept) == round(n * out.metro$accept)
+[1] TRUE
+> if (my.accept[niter]) {
++ all(out.metro$proposal[niter, ] == out.metro$final)
++ } else {
++ all(out.metro$current[niter, ] == out.metro$final)
++ }
+[1] TRUE
+>
+> my.current <- out.metro$current
+> my.current[my.accept, ] <- my.proposal[my.accept, ]
+> my.current <- rbind(out.metro$initial, my.current[- niter, ])
+> max(abs(out.metro$current - my.current)) < epsilon
+[1] TRUE
+>
+> my.path <- matrix(NA, n, d)
+> my.path[my.accept, ] <- out.metro$proposal[my.accept, ]
+> my.path[! my.accept, ] <- out.metro$current[! my.accept, ]
+> nspac <- out.metro$nspac
+>
+> my.path <- my.path[seq(nspac, niter, by = nspac), ]
+>
+> fred <- my.path[ , out.metro$outfun]
+> k <- ncol(fred)
+>
+> foom <- array(as.vector(t(fred)), c(k, out.metro$blen, out.metro$nbatch))
+> boom <- t(apply(foom, c(1, 3), mean))
+>
+> all(dim(boom) == dim(out.metro$batch))
+[1] TRUE
+> max(abs(boom - out.metro$batch)) < epsilon
+[1] TRUE
+>
+>
diff --git a/tests/logitmat.R b/tests/logitmat.R
new file mode 100644
index 0000000..b21a363
--- /dev/null
+++ b/tests/logitmat.R
@@ -0,0 +1,121 @@
+
+ # test matrix scaling
+
+ epsilon <- 1e-15
+
+ library(mcmc)
+
+ RNGkind("Marsaglia-Multicarry")
+ set.seed(42)
+
+ n <- 100
+ rho <- 0.5
+ beta0 <- 0.25
+ beta1 <- 1
+ beta2 <- 0.5
+
+ x1 <- rnorm(n)
+ x2 <- rho * x1 + sqrt(1 - rho^2) * rnorm(n)
+ eta <- beta0 + beta1 * x1 + beta2 * x2
+ p <- 1 / (1 + exp(- eta))
+ y <- as.numeric(runif(n) < p)
+
+ out <- glm(y ~ x1 + x2, family = binomial())
+
+ logl <- function(beta) {
+ if (length(beta) != 3) stop("length(beta) != 3")
+ beta0 <- beta[1]
+ beta1 <- beta[2]
+ beta2 <- beta[3]
+ eta <- beta0 + beta1 * x1 + beta2 * x2
+ p <- exp(eta) / (1 + exp(eta))
+ return(sum(log(p[y == 1])) + sum(log(1 - p[y == 0])))
+ }
+
+ out.metro <- metrop(logl, coefficients(out), 1e3, scale = 0.01)
+ out.metro$accept
+
+ out.metro <- metrop(out.metro, scale = 0.1)
+ out.metro$accept
+
+ out.metro <- metrop(out.metro, scale = 0.5)
+ out.metro$accept
+
+ apply(out.metro$batch, 2, mean)
+ fred <- var(out.metro$batch)
+ sally <- t(chol(fred))
+ max(abs(fred - sally %*% t(sally))) < epsilon
+
+ out.metro <- metrop(out.metro, scale = sally)
+ out.metro$accept
+
+ out.metro <- metrop(logl, as.numeric(coefficients(out)), 1e2,
+ scale = sally, debug = TRUE)
+ names(out.metro)
+
+ niter <- out.metro$nbatch * out.metro$blen * out.metro$nspac
+ niter == nrow(out.metro$current)
+ niter == nrow(out.metro$proposal)
+ all(out.metro$current[1, ] == out.metro$initial)
+ all(out.metro$current[niter, ] == out.metro$final) |
+ all(out.metro$proposal[niter, ] == out.metro$final)
+
+ .Random.seed <- out.metro$initial.seed
+ d <- ncol(out.metro$proposal)
+ n <- nrow(out.metro$proposal)
+ my.proposal <- matrix(NA, n, d)
+ my.u <- double(n)
+ my.z <- matrix(NA, n, d)
+ ska <- out.metro$scale
+ for (i in 1:n) {
+ zed <- rnorm(d)
+ my.proposal[i, ] <- out.metro$current[i, ] + ska %*% zed
+ if (is.na(out.metro$u[i])) {
+ my.u[i] <- NA
+ } else {
+ my.u[i] <- runif(1)
+ }
+ my.z[i, ] <- zed
+ }
+ max(abs(out.metro$proposal - my.proposal)) < epsilon
+
+ all(is.na(out.metro$u) == is.na(my.u))
+ all(out.metro$u[!is.na(out.metro$u)] == my.u[!is.na(my.u)])
+ identical(out.metro$z, my.z)
+
+ my.curr.log.green <- apply(out.metro$current, 1, logl)
+ my.prop.log.green <- apply(out.metro$proposal, 1, logl)
+ all(is.na(out.metro$u) == (my.prop.log.green > my.curr.log.green))
+ foo <- my.prop.log.green - my.curr.log.green
+ max(abs(foo - out.metro$log.green)) < epsilon
+
+ my.accept <- is.na(my.u) | my.u < exp(foo)
+ sum(my.accept) == round(n * out.metro$accept)
+ if (my.accept[niter]) {
+ all(out.metro$proposal[niter, ] == out.metro$final)
+ } else {
+ all(out.metro$current[niter, ] == out.metro$final)
+ }
+ identical(my.accept, out.metro$debug.accept)
+
+ my.current <- out.metro$current
+ my.current[my.accept, ] <- my.proposal[my.accept, ]
+ my.current <- rbind(out.metro$initial, my.current[- niter, ])
+ max(abs(out.metro$current - my.current)) < epsilon
+
+ my.path <- matrix(NA, n, d)
+ my.path[my.accept, ] <- out.metro$proposal[my.accept, ]
+ my.path[! my.accept, ] <- out.metro$current[! my.accept, ]
+ nspac <- out.metro$nspac
+
+ my.path <- my.path[seq(nspac, niter, by = nspac), ]
+
+ fred <- my.path
+ k <- ncol(fred)
+
+ foom <- array(as.vector(t(fred)), c(k, out.metro$blen, out.metro$nbatch))
+ boom <- t(apply(foom, c(1, 3), mean))
+
+ all(dim(boom) == dim(out.metro$batch))
+ max(abs(boom - out.metro$batch)) < epsilon
+
diff --git a/tests/logitmat.Rout.save b/tests/logitmat.Rout.save
new file mode 100644
index 0000000..95e2336
--- /dev/null
+++ b/tests/logitmat.Rout.save
@@ -0,0 +1,166 @@
+
+R version 2.13.1 (2011-07-08)
+Copyright (C) 2011 The R Foundation for Statistical Computing
+ISBN 3-900051-07-0
+Platform: x86_64-pc-linux-gnu (64-bit)
+
+R is free software and comes with ABSOLUTELY NO WARRANTY.
+You are welcome to redistribute it under certain conditions.
+Type 'license()' or 'licence()' for distribution details.
+
+R is a collaborative project with many contributors.
+Type 'contributors()' for more information and
+'citation()' on how to cite R or R packages in publications.
+
+Type 'demo()' for some demos, 'help()' for on-line help, or
+'help.start()' for an HTML browser interface to help.
+Type 'q()' to quit R.
+
+>
+> # test matrix scaling
+>
+> epsilon <- 1e-15
+>
+> library(mcmc)
+>
+> RNGkind("Marsaglia-Multicarry")
+> set.seed(42)
+>
+> n <- 100
+> rho <- 0.5
+> beta0 <- 0.25
+> beta1 <- 1
+> beta2 <- 0.5
+>
+> x1 <- rnorm(n)
+> x2 <- rho * x1 + sqrt(1 - rho^2) * rnorm(n)
+> eta <- beta0 + beta1 * x1 + beta2 * x2
+> p <- 1 / (1 + exp(- eta))
+> y <- as.numeric(runif(n) < p)
+>
+> out <- glm(y ~ x1 + x2, family = binomial())
+>
+> logl <- function(beta) {
++ if (length(beta) != 3) stop("length(beta) != 3")
++ beta0 <- beta[1]
++ beta1 <- beta[2]
++ beta2 <- beta[3]
++ eta <- beta0 + beta1 * x1 + beta2 * x2
++ p <- exp(eta) / (1 + exp(eta))
++ return(sum(log(p[y == 1])) + sum(log(1 - p[y == 0])))
++ }
+>
+> out.metro <- metrop(logl, coefficients(out), 1e3, scale = 0.01)
+> out.metro$accept
+[1] 0.982
+>
+> out.metro <- metrop(out.metro, scale = 0.1)
+> out.metro$accept
+[1] 0.795
+>
+> out.metro <- metrop(out.metro, scale = 0.5)
+> out.metro$accept
+[1] 0.264
+>
+> apply(out.metro$batch, 2, mean)
+[1] 0.06080257 1.42304941 0.52634149
+> fred <- var(out.metro$batch)
+> sally <- t(chol(fred))
+> max(abs(fred - sally %*% t(sally))) < epsilon
+[1] TRUE
+>
+> out.metro <- metrop(out.metro, scale = sally)
+> out.metro$accept
+[1] 0.451
+>
+> out.metro <- metrop(logl, as.numeric(coefficients(out)), 1e2,
++ scale = sally, debug = TRUE)
+> names(out.metro)
+ [1] "accept" "batch" "initial" "final" "current"
+ [6] "proposal" "log.green" "u" "z" "debug.accept"
+[11] "initial.seed" "final.seed" "time" "lud" "nbatch"
+[16] "blen" "nspac" "scale" "debug"
+>
+> niter <- out.metro$nbatch * out.metro$blen * out.metro$nspac
+> niter == nrow(out.metro$current)
+[1] TRUE
+> niter == nrow(out.metro$proposal)
+[1] TRUE
+> all(out.metro$current[1, ] == out.metro$initial)
+[1] TRUE
+> all(out.metro$current[niter, ] == out.metro$final) |
++ all(out.metro$proposal[niter, ] == out.metro$final)
+[1] TRUE
+>
+> .Random.seed <- out.metro$initial.seed
+> d <- ncol(out.metro$proposal)
+> n <- nrow(out.metro$proposal)
+> my.proposal <- matrix(NA, n, d)
+> my.u <- double(n)
+> my.z <- matrix(NA, n, d)
+> ska <- out.metro$scale
+> for (i in 1:n) {
++ zed <- rnorm(d)
++ my.proposal[i, ] <- out.metro$current[i, ] + ska %*% zed
++ if (is.na(out.metro$u[i])) {
++ my.u[i] <- NA
++ } else {
++ my.u[i] <- runif(1)
++ }
++ my.z[i, ] <- zed
++ }
+> max(abs(out.metro$proposal - my.proposal)) < epsilon
+[1] TRUE
+>
+> all(is.na(out.metro$u) == is.na(my.u))
+[1] TRUE
+> all(out.metro$u[!is.na(out.metro$u)] == my.u[!is.na(my.u)])
+[1] TRUE
+> identical(out.metro$z, my.z)
+[1] TRUE
+>
+> my.curr.log.green <- apply(out.metro$current, 1, logl)
+> my.prop.log.green <- apply(out.metro$proposal, 1, logl)
+> all(is.na(out.metro$u) == (my.prop.log.green > my.curr.log.green))
+[1] TRUE
+> foo <- my.prop.log.green - my.curr.log.green
+> max(abs(foo - out.metro$log.green)) < epsilon
+[1] TRUE
+>
+> my.accept <- is.na(my.u) | my.u < exp(foo)
+> sum(my.accept) == round(n * out.metro$accept)
+[1] TRUE
+> if (my.accept[niter]) {
++ all(out.metro$proposal[niter, ] == out.metro$final)
++ } else {
++ all(out.metro$current[niter, ] == out.metro$final)
++ }
+[1] TRUE
+> identical(my.accept, out.metro$debug.accept)
+[1] TRUE
+>
+> my.current <- out.metro$current
+> my.current[my.accept, ] <- my.proposal[my.accept, ]
+> my.current <- rbind(out.metro$initial, my.current[- niter, ])
+> max(abs(out.metro$current - my.current)) < epsilon
+[1] TRUE
+>
+> my.path <- matrix(NA, n, d)
+> my.path[my.accept, ] <- out.metro$proposal[my.accept, ]
+> my.path[! my.accept, ] <- out.metro$current[! my.accept, ]
+> nspac <- out.metro$nspac
+>
+> my.path <- my.path[seq(nspac, niter, by = nspac), ]
+>
+> fred <- my.path
+> k <- ncol(fred)
+>
+> foom <- array(as.vector(t(fred)), c(k, out.metro$blen, out.metro$nbatch))
+> boom <- t(apply(foom, c(1, 3), mean))
+>
+> all(dim(boom) == dim(out.metro$batch))
+[1] TRUE
+> max(abs(boom - out.metro$batch)) < epsilon
+[1] TRUE
+>
+>
diff --git a/tests/logitnegidx.R b/tests/logitnegidx.R
new file mode 100644
index 0000000..0ae9061
--- /dev/null
+++ b/tests/logitnegidx.R
@@ -0,0 +1,108 @@
+
+ # test outfun (negative index vector)
+
+ epsilon <- 1e-15
+
+ library(mcmc)
+
+ RNGkind("Marsaglia-Multicarry")
+ set.seed(42)
+
+ n <- 100
+ rho <- 0.5
+ beta0 <- 0.25
+ beta1 <- 1
+ beta2 <- 0.5
+
+ x1 <- rnorm(n)
+ x2 <- rho * x1 + sqrt(1 - rho^2) * rnorm(n)
+ eta <- beta0 + beta1 * x1 + beta2 * x2
+ p <- 1 / (1 + exp(- eta))
+ y <- as.numeric(runif(n) < p)
+
+ out <- glm(y ~ x1 + x2, family = binomial())
+
+ logl <- function(beta) {
+ if (length(beta) != 3) stop("length(beta) != 3")
+ beta0 <- beta[1]
+ beta1 <- beta[2]
+ beta2 <- beta[3]
+ eta <- beta0 + beta1 * x1 + beta2 * x2
+ p <- exp(eta) / (1 + exp(eta))
+ return(sum(log(p[y == 1])) + sum(log(1 - p[y == 0])))
+ }
+
+ out.metro <- metrop(logl, coefficients(out), 1e3, scale = 0.01)
+ out.metro$accept
+
+ out.metro <- metrop(out.metro, scale = 0.1)
+ out.metro$accept
+
+ out.metro <- metrop(out.metro, scale = 0.5)
+ out.metro$accept
+
+ apply(out.metro$batch, 2, mean)
+
+ out.metro <- metrop(logl, as.numeric(coefficients(out)), 1e2,
+ scale = 0.5, debug = TRUE, outfun = - 2)
+
+ niter <- out.metro$nbatch * out.metro$blen * out.metro$nspac
+ niter == nrow(out.metro$current)
+ niter == nrow(out.metro$proposal)
+ all(out.metro$current[1, ] == out.metro$initial)
+ all(out.metro$current[niter, ] == out.metro$final) |
+ all(out.metro$proposal[niter, ] == out.metro$final)
+
+ .Random.seed <- out.metro$initial.seed
+ d <- ncol(out.metro$proposal)
+ n <- nrow(out.metro$proposal)
+ my.proposal <- matrix(NA, n, d)
+ my.u <- double(n)
+ ska <- out.metro$scale
+ for (i in 1:n) {
+ my.proposal[i, ] <- out.metro$current[i, ] + ska * rnorm(d)
+ if (is.na(out.metro$u[i])) {
+ my.u[i] <- NA
+ } else {
+ my.u[i] <- runif(1)
+ }
+ }
+ max(abs(out.metro$proposal - my.proposal)) < epsilon
+ all(is.na(out.metro$u) == is.na(my.u))
+ all(out.metro$u[!is.na(out.metro$u)] == my.u[!is.na(my.u)])
+
+ my.curr.log.green <- apply(out.metro$current, 1, logl)
+ my.prop.log.green <- apply(out.metro$proposal, 1, logl)
+ all(is.na(out.metro$u) == (my.prop.log.green > my.curr.log.green))
+ foo <- my.prop.log.green - my.curr.log.green
+ max(abs(foo - out.metro$log.green)) < epsilon
+
+ my.accept <- is.na(my.u) | my.u < exp(foo)
+ sum(my.accept) == round(n * out.metro$accept)
+ if (my.accept[niter]) {
+ all(out.metro$proposal[niter, ] == out.metro$final)
+ } else {
+ all(out.metro$current[niter, ] == out.metro$final)
+ }
+
+ my.current <- out.metro$current
+ my.current[my.accept, ] <- my.proposal[my.accept, ]
+ my.current <- rbind(out.metro$initial, my.current[- niter, ])
+ max(abs(out.metro$current - my.current)) < epsilon
+
+ my.path <- matrix(NA, n, d)
+ my.path[my.accept, ] <- out.metro$proposal[my.accept, ]
+ my.path[! my.accept, ] <- out.metro$current[! my.accept, ]
+ nspac <- out.metro$nspac
+
+ my.path <- my.path[seq(nspac, niter, by = nspac), ]
+
+ fred <- my.path[ , out.metro$outfun]
+ k <- ncol(fred)
+
+ foom <- array(as.vector(t(fred)), c(k, out.metro$blen, out.metro$nbatch))
+ boom <- t(apply(foom, c(1, 3), mean))
+
+ all(dim(boom) == dim(out.metro$batch))
+ max(abs(boom - out.metro$batch)) < epsilon
+
diff --git a/tests/logitnegidx.Rout.save b/tests/logitnegidx.Rout.save
new file mode 100644
index 0000000..7c12ecf
--- /dev/null
+++ b/tests/logitnegidx.Rout.save
@@ -0,0 +1,145 @@
+
+R version 2.13.1 (2011-07-08)
+Copyright (C) 2011 The R Foundation for Statistical Computing
+ISBN 3-900051-07-0
+Platform: x86_64-pc-linux-gnu (64-bit)
+
+R is free software and comes with ABSOLUTELY NO WARRANTY.
+You are welcome to redistribute it under certain conditions.
+Type 'license()' or 'licence()' for distribution details.
+
+R is a collaborative project with many contributors.
+Type 'contributors()' for more information and
+'citation()' on how to cite R or R packages in publications.
+
+Type 'demo()' for some demos, 'help()' for on-line help, or
+'help.start()' for an HTML browser interface to help.
+Type 'q()' to quit R.
+
+>
+> # test outfun (negative index vector)
+>
+> epsilon <- 1e-15
+>
+> library(mcmc)
+>
+> RNGkind("Marsaglia-Multicarry")
+> set.seed(42)
+>
+> n <- 100
+> rho <- 0.5
+> beta0 <- 0.25
+> beta1 <- 1
+> beta2 <- 0.5
+>
+> x1 <- rnorm(n)
+> x2 <- rho * x1 + sqrt(1 - rho^2) * rnorm(n)
+> eta <- beta0 + beta1 * x1 + beta2 * x2
+> p <- 1 / (1 + exp(- eta))
+> y <- as.numeric(runif(n) < p)
+>
+> out <- glm(y ~ x1 + x2, family = binomial())
+>
+> logl <- function(beta) {
++ if (length(beta) != 3) stop("length(beta) != 3")
++ beta0 <- beta[1]
++ beta1 <- beta[2]
++ beta2 <- beta[3]
++ eta <- beta0 + beta1 * x1 + beta2 * x2
++ p <- exp(eta) / (1 + exp(eta))
++ return(sum(log(p[y == 1])) + sum(log(1 - p[y == 0])))
++ }
+>
+> out.metro <- metrop(logl, coefficients(out), 1e3, scale = 0.01)
+> out.metro$accept
+[1] 0.982
+>
+> out.metro <- metrop(out.metro, scale = 0.1)
+> out.metro$accept
+[1] 0.795
+>
+> out.metro <- metrop(out.metro, scale = 0.5)
+> out.metro$accept
+[1] 0.264
+>
+> apply(out.metro$batch, 2, mean)
+[1] 0.06080257 1.42304941 0.52634149
+>
+> out.metro <- metrop(logl, as.numeric(coefficients(out)), 1e2,
++ scale = 0.5, debug = TRUE, outfun = - 2)
+>
+> niter <- out.metro$nbatch * out.metro$blen * out.metro$nspac
+> niter == nrow(out.metro$current)
+[1] TRUE
+> niter == nrow(out.metro$proposal)
+[1] TRUE
+> all(out.metro$current[1, ] == out.metro$initial)
+[1] TRUE
+> all(out.metro$current[niter, ] == out.metro$final) |
++ all(out.metro$proposal[niter, ] == out.metro$final)
+[1] TRUE
+>
+> .Random.seed <- out.metro$initial.seed
+> d <- ncol(out.metro$proposal)
+> n <- nrow(out.metro$proposal)
+> my.proposal <- matrix(NA, n, d)
+> my.u <- double(n)
+> ska <- out.metro$scale
+> for (i in 1:n) {
++ my.proposal[i, ] <- out.metro$current[i, ] + ska * rnorm(d)
++ if (is.na(out.metro$u[i])) {
++ my.u[i] <- NA
++ } else {
++ my.u[i] <- runif(1)
++ }
++ }
+> max(abs(out.metro$proposal - my.proposal)) < epsilon
+[1] TRUE
+> all(is.na(out.metro$u) == is.na(my.u))
+[1] TRUE
+> all(out.metro$u[!is.na(out.metro$u)] == my.u[!is.na(my.u)])
+[1] TRUE
+>
+> my.curr.log.green <- apply(out.metro$current, 1, logl)
+> my.prop.log.green <- apply(out.metro$proposal, 1, logl)
+> all(is.na(out.metro$u) == (my.prop.log.green > my.curr.log.green))
+[1] TRUE
+> foo <- my.prop.log.green - my.curr.log.green
+> max(abs(foo - out.metro$log.green)) < epsilon
+[1] TRUE
+>
+> my.accept <- is.na(my.u) | my.u < exp(foo)
+> sum(my.accept) == round(n * out.metro$accept)
+[1] TRUE
+> if (my.accept[niter]) {
++ all(out.metro$proposal[niter, ] == out.metro$final)
++ } else {
++ all(out.metro$current[niter, ] == out.metro$final)
++ }
+[1] TRUE
+>
+> my.current <- out.metro$current
+> my.current[my.accept, ] <- my.proposal[my.accept, ]
+> my.current <- rbind(out.metro$initial, my.current[- niter, ])
+> max(abs(out.metro$current - my.current)) < epsilon
+[1] TRUE
+>
+> my.path <- matrix(NA, n, d)
+> my.path[my.accept, ] <- out.metro$proposal[my.accept, ]
+> my.path[! my.accept, ] <- out.metro$current[! my.accept, ]
+> nspac <- out.metro$nspac
+>
+> my.path <- my.path[seq(nspac, niter, by = nspac), ]
+>
+> fred <- my.path[ , out.metro$outfun]
+> k <- ncol(fred)
+>
+> foom <- array(as.vector(t(fred)), c(k, out.metro$blen, out.metro$nbatch))
+> boom <- t(apply(foom, c(1, 3), mean))
+>
+> all(dim(boom) == dim(out.metro$batch))
+[1] TRUE
+> max(abs(boom - out.metro$batch)) < epsilon
+[1] TRUE
+>
+>
diff --git a/tests/logitsub.R b/tests/logitsub.R
new file mode 100644
index 0000000..168e930
--- /dev/null
+++ b/tests/logitsub.R
@@ -0,0 +1,101 @@
+
+ # test spacing (nspac)
+
+ epsilon <- 1e-15
+
+ library(mcmc)
+
+ RNGkind("Marsaglia-Multicarry")
+ set.seed(42)
+
+ n <- 100
+ rho <- 0.5
+ beta0 <- 0.25
+ beta1 <- 1
+ beta2 <- 0.5
+
+ x1 <- rnorm(n)
+ x2 <- rho * x1 + sqrt(1 - rho^2) * rnorm(n)
+ eta <- beta0 + beta1 * x1 + beta2 * x2
+ p <- 1 / (1 + exp(- eta))
+ y <- as.numeric(runif(n) < p)
+
+ out <- glm(y ~ x1 + x2, family = binomial())
+
+ logl <- function(beta) {
+ if (length(beta) != 3) stop("length(beta) != 3")
+ beta0 <- beta[1]
+ beta1 <- beta[2]
+ beta2 <- beta[3]
+ eta <- beta0 + beta1 * x1 + beta2 * x2
+ p <- exp(eta) / (1 + exp(eta))
+ return(sum(log(p[y == 1])) + sum(log(1 - p[y == 0])))
+ }
+
+ out.metro <- metrop(logl, coefficients(out), 1e3, scale = 0.01)
+ out.metro$accept
+
+ out.metro <- metrop(out.metro, scale = 0.1)
+ out.metro$accept
+
+ out.metro <- metrop(out.metro, scale = 0.5)
+ out.metro$accept
+
+ apply(out.metro$batch, 2, mean)
+
+ out.metro <- metrop(logl, as.numeric(coefficients(out)), 1e2,
+ scale = 0.5, debug = TRUE, nspac = 3)
+
+ niter <- out.metro$nbatch * out.metro$blen * out.metro$nspac
+ niter == nrow(out.metro$current)
+ niter == nrow(out.metro$proposal)
+ all(out.metro$current[1, ] == out.metro$initial)
+ all(out.metro$current[niter, ] == out.metro$final) |
+ all(out.metro$proposal[niter, ] == out.metro$final)
+
+ .Random.seed <- out.metro$initial.seed
+ d <- ncol(out.metro$proposal)
+ n <- nrow(out.metro$proposal)
+ my.proposal <- matrix(NA, n, d)
+ my.u <- double(n)
+ ska <- out.metro$scale
+ for (i in 1:n) {
+ my.proposal[i, ] <- out.metro$current[i, ] + ska * rnorm(d)
+ if (is.na(out.metro$u[i])) {
+ my.u[i] <- NA
+ } else {
+ my.u[i] <- runif(1)
+ }
+ }
+ max(abs(out.metro$proposal - my.proposal)) < epsilon
+ all(is.na(out.metro$u) == is.na(my.u))
+ all(out.metro$u[!is.na(out.metro$u)] == my.u[!is.na(my.u)])
+
+ my.curr.log.green <- apply(out.metro$current, 1, logl)
+ my.prop.log.green <- apply(out.metro$proposal, 1, logl)
+ all(is.na(out.metro$u) == (my.prop.log.green > my.curr.log.green))
+ foo <- my.prop.log.green - my.curr.log.green
+ max(abs(foo - out.metro$log.green)) < epsilon
+
+ my.accept <- is.na(my.u) | my.u < exp(foo)
+ sum(my.accept) == round(n * out.metro$accept)
+ if (my.accept[niter]) {
+ all(out.metro$proposal[niter, ] == out.metro$final)
+ } else {
+ all(out.metro$current[niter, ] == out.metro$final)
+ }
+
+ my.current <- out.metro$current
+ my.current[my.accept, ] <- my.proposal[my.accept, ]
+ my.current <- rbind(out.metro$initial, my.current[- niter, ])
+ max(abs(out.metro$current - my.current)) < epsilon
+
+ my.path <- matrix(NA, n, d)
+ my.path[my.accept, ] <- out.metro$proposal[my.accept, ]
+ my.path[! my.accept, ] <- out.metro$current[! my.accept, ]
+ nspac <- out.metro$nspac
+ my.path <- my.path[seq(nspac, niter, by = nspac), ]
+ all(dim(my.path) == dim(out.metro$batch))
+
+ all(my.path == out.metro$batch)
+
diff --git a/tests/logitsub.Rout.save b/tests/logitsub.Rout.save
new file mode 100644
index 0000000..cbba466
--- /dev/null
+++ b/tests/logitsub.Rout.save
@@ -0,0 +1,138 @@
+
+R version 2.13.1 (2011-07-08)
+Copyright (C) 2011 The R Foundation for Statistical Computing
+ISBN 3-900051-07-0
+Platform: x86_64-pc-linux-gnu (64-bit)
+
+R is free software and comes with ABSOLUTELY NO WARRANTY.
+You are welcome to redistribute it under certain conditions.
+Type 'license()' or 'licence()' for distribution details.
+
+R is a collaborative project with many contributors.
+Type 'contributors()' for more information and
+'citation()' on how to cite R or R packages in publications.
+
+Type 'demo()' for some demos, 'help()' for on-line help, or
+'help.start()' for an HTML browser interface to help.
+Type 'q()' to quit R.
+
+>
+> # test spacing (nspac)
+>
+> epsilon <- 1e-15
+>
+> library(mcmc)
+>
+> RNGkind("Marsaglia-Multicarry")
+> set.seed(42)
+>
+> n <- 100
+> rho <- 0.5
+> beta0 <- 0.25
+> beta1 <- 1
+> beta2 <- 0.5
+>
+> x1 <- rnorm(n)
+> x2 <- rho * x1 + sqrt(1 - rho^2) * rnorm(n)
+> eta <- beta0 + beta1 * x1 + beta2 * x2
+> p <- 1 / (1 + exp(- eta))
+> y <- as.numeric(runif(n) < p)
+>
+> out <- glm(y ~ x1 + x2, family = binomial())
+>
+> logl <- function(beta) {
++ if (length(beta) != 3) stop("length(beta) != 3")
++ beta0 <- beta[1]
++ beta1 <- beta[2]
++ beta2 <- beta[3]
++ eta <- beta0 + beta1 * x1 + beta2 * x2
++ p <- exp(eta) / (1 + exp(eta))
++ return(sum(log(p[y == 1])) + sum(log(1 - p[y == 0])))
++ }
+>
+> out.metro <- metrop(logl, coefficients(out), 1e3, scale = 0.01)
+> out.metro$accept
+[1] 0.982
+>
+> out.metro <- metrop(out.metro, scale = 0.1)
+> out.metro$accept
+[1] 0.795
+>
+> out.metro <- metrop(out.metro, scale = 0.5)
+> out.metro$accept
+[1] 0.264
+>
+> apply(out.metro$batch, 2, mean)
+[1] 0.06080257 1.42304941 0.52634149
+>
+> out.metro <- metrop(logl, as.numeric(coefficients(out)), 1e2,
++ scale = 0.5, debug = TRUE, nspac = 3)
+>
+> niter <- out.metro$nbatch * out.metro$blen * out.metro$nspac
+> niter == nrow(out.metro$current)
+[1] TRUE
+> niter == nrow(out.metro$proposal)
+[1] TRUE
+> all(out.metro$current[1, ] == out.metro$initial)
+[1] TRUE
+> all(out.metro$current[niter, ] == out.metro$final) |
++ all(out.metro$proposal[niter, ] == out.metro$final)
+[1] TRUE
+>
+> .Random.seed <- out.metro$initial.seed
+> d <- ncol(out.metro$proposal)
+> n <- nrow(out.metro$proposal)
+> my.proposal <- matrix(NA, n, d)
+> my.u <- double(n)
+> ska <- out.metro$scale
+> for (i in 1:n) {
++ my.proposal[i, ] <- out.metro$current[i, ] + ska * rnorm(d)
++ if (is.na(out.metro$u[i])) {
++ my.u[i] <- NA
++ } else {
++ my.u[i] <- runif(1)
++ }
++ }
+> max(abs(out.metro$proposal - my.proposal)) < epsilon
+[1] TRUE
+> all(is.na(out.metro$u) == is.na(my.u))
+[1] TRUE
+> all(out.metro$u[!is.na(out.metro$u)] == my.u[!is.na(my.u)])
+[1] TRUE
+>
+> my.curr.log.green <- apply(out.metro$current, 1, logl)
+> my.prop.log.green <- apply(out.metro$proposal, 1, logl)
+> all(is.na(out.metro$u) == (my.prop.log.green > my.curr.log.green))
+[1] TRUE
+> foo <- my.prop.log.green - my.curr.log.green
+> max(abs(foo - out.metro$log.green)) < epsilon
+[1] TRUE
+>
+> my.accept <- is.na(my.u) | my.u < exp(foo)
+> sum(my.accept) == round(n * out.metro$accept)
+[1] TRUE
+> if (my.accept[niter]) {
++ all(out.metro$proposal[niter, ] == out.metro$final)
++ } else {
++ all(out.metro$current[niter, ] == out.metro$final)
++ }
+[1] TRUE
+>
+> my.current <- out.metro$current
+> my.current[my.accept, ] <- my.proposal[my.accept, ]
+> my.current <- rbind(out.metro$initial, my.current[- niter, ])
+> max(abs(out.metro$current - my.current)) < epsilon
+[1] TRUE
+>
+> my.path <- matrix(NA, n, d)
+> my.path[my.accept, ] <- out.metro$proposal[my.accept, ]
+> my.path[! my.accept, ] <- out.metro$current[! my.accept, ]
+> nspac <- out.metro$nspac
+> my.path <- my.path[seq(nspac, niter, by = nspac), ]
+> all(dim(my.path) == dim(out.metro$batch))
+[1] TRUE
+>
+> all(my.path == out.metro$batch)
+[1] TRUE
+>
+>
diff --git a/tests/logitsubbat.R b/tests/logitsubbat.R
new file mode 100644
index 0000000..0c56ec9
--- /dev/null
+++ b/tests/logitsubbat.R
@@ -0,0 +1,105 @@
+
+ # test batching (blen) and spacing (nspac) together
+
+ epsilon <- 1e-15
+
+ library(mcmc)
+
+ RNGkind("Marsaglia-Multicarry")
+ set.seed(42)
+
+ n <- 100
+ rho <- 0.5
+ beta0 <- 0.25
+ beta1 <- 1
+ beta2 <- 0.5
+
+ x1 <- rnorm(n)
+ x2 <- rho * x1 + sqrt(1 - rho^2) * rnorm(n)
+ eta <- beta0 + beta1 * x1 + beta2 * x2
+ p <- 1 / (1 + exp(- eta))
+ y <- as.numeric(runif(n) < p)
+
+ out <- glm(y ~ x1 + x2, family = binomial())
+
+ logl <- function(beta) {
+ if (length(beta) != 3) stop("length(beta) != 3")
+ beta0 <- beta[1]
+ beta1 <- beta[2]
+ beta2 <- beta[3]
+ eta <- beta0 + beta1 * x1 + beta2 * x2
+ p <- exp(eta) / (1 + exp(eta))
+ return(sum(log(p[y == 1])) + sum(log(1 - p[y == 0])))
+ }
+
+ out.metro <- metrop(logl, coefficients(out), 1e3, scale = 0.01)
+ out.metro$accept
+
+ out.metro <- metrop(out.metro, scale = 0.1)
+ out.metro$accept
+
+ out.metro <- metrop(out.metro, scale = 0.5)
+ out.metro$accept
+
+ apply(out.metro$batch, 2, mean)
+
+ out.metro <- metrop(logl, as.numeric(coefficients(out)), 1e2,
+ scale = 0.5, debug = TRUE, blen = 5, nspac = 3)
+
+ niter <- out.metro$nbatch * out.metro$blen * out.metro$nspac
+ niter == nrow(out.metro$current)
+ niter == nrow(out.metro$proposal)
+ all(out.metro$current[1, ] == out.metro$initial)
+ all(out.metro$current[niter, ] == out.metro$final) |
+ all(out.metro$proposal[niter, ] == out.metro$final)
+
+ .Random.seed <- out.metro$initial.seed
+ d <- ncol(out.metro$proposal)
+ n <- nrow(out.metro$proposal)
+ my.proposal <- matrix(NA, n, d)
+ my.u <- double(n)
+ ska <- out.metro$scale
+ for (i in 1:n) {
+ my.proposal[i, ] <- out.metro$current[i, ] + ska * rnorm(d)
+ if (is.na(out.metro$u[i])) {
+ my.u[i] <- NA
+ } else {
+ my.u[i] <- runif(1)
+ }
+ }
+ max(abs(out.metro$proposal - my.proposal)) < epsilon
+ all(is.na(out.metro$u) == is.na(my.u))
+ all(out.metro$u[!is.na(out.metro$u)] == my.u[!is.na(my.u)])
+
+ my.curr.log.green <- apply(out.metro$current, 1, logl)
+ my.prop.log.green <- apply(out.metro$proposal, 1, logl)
+ all(is.na(out.metro$u) == (my.prop.log.green > my.curr.log.green))
+ foo <- my.prop.log.green - my.curr.log.green
+ max(abs(foo - out.metro$log.green)) < epsilon
+
+ my.accept <- is.na(my.u) | my.u < exp(foo)
+ sum(my.accept) == round(n * out.metro$accept)
+ if (my.accept[niter]) {
+ all(out.metro$proposal[niter, ] == out.metro$final)
+ } else {
+ all(out.metro$current[niter, ] == out.metro$final)
+ }
+
+ my.current <- out.metro$current
+ my.current[my.accept, ] <- my.proposal[my.accept, ]
+ my.current <- rbind(out.metro$initial, my.current[- niter, ])
+ max(abs(out.metro$current - my.current)) < epsilon
+
+ my.path <- matrix(NA, n, d)
+ my.path[my.accept, ] <- out.metro$proposal[my.accept, ]
+ my.path[! my.accept, ] <- out.metro$current[! my.accept, ]
+ nspac <- out.metro$nspac
+
+ my.path <- my.path[seq(nspac, niter, by = nspac), ]
+
+ foom <- array(as.vector(t(my.path)), c(d, out.metro$blen, out.metro$nbatch))
+ boom <- t(apply(foom, c(1, 3), mean))
+
+ all(dim(boom) == dim(out.metro$batch))
+ max(abs(boom - out.metro$batch)) < epsilon
+
diff --git a/tests/logitsubbat.Rout.save b/tests/logitsubbat.Rout.save
new file mode 100644
index 0000000..c3d4082
--- /dev/null
+++ b/tests/logitsubbat.Rout.save
@@ -0,0 +1,142 @@
+
+R version 2.13.1 (2011-07-08)
+Copyright (C) 2011 The R Foundation for Statistical Computing
+ISBN 3-900051-07-0
+Platform: x86_64-pc-linux-gnu (64-bit)
+
+R is free software and comes with ABSOLUTELY NO WARRANTY.
+You are welcome to redistribute it under certain conditions.
+Type 'license()' or 'licence()' for distribution details.
+
+R is a collaborative project with many contributors.
+Type 'contributors()' for more information and
+'citation()' on how to cite R or R packages in publications.
+
+Type 'demo()' for some demos, 'help()' for on-line help, or
+'help.start()' for an HTML browser interface to help.
+Type 'q()' to quit R.
+
+>
+> # test batching (blen) and spacing (nspac) together
+>
+> epsilon <- 1e-15
+>
+> library(mcmc)
+>
+> RNGkind("Marsaglia-Multicarry")
+> set.seed(42)
+>
+> n <- 100
+> rho <- 0.5
+> beta0 <- 0.25
+> beta1 <- 1
+> beta2 <- 0.5
+>
+> x1 <- rnorm(n)
+> x2 <- rho * x1 + sqrt(1 - rho^2) * rnorm(n)
+> eta <- beta0 + beta1 * x1 + beta2 * x2
+> p <- 1 / (1 + exp(- eta))
+> y <- as.numeric(runif(n) < p)
+>
+> out <- glm(y ~ x1 + x2, family = binomial())
+>
+> logl <- function(beta) {
++ if (length(beta) != 3) stop("length(beta) != 3")
++ beta0 <- beta[1]
++ beta1 <- beta[2]
++ beta2 <- beta[3]
++ eta <- beta0 + beta1 * x1 + beta2 * x2
++ p <- exp(eta) / (1 + exp(eta))
++ return(sum(log(p[y == 1])) + sum(log(1 - p[y == 0])))
++ }
+>
+> out.metro <- metrop(logl, coefficients(out), 1e3, scale = 0.01)
+> out.metro$accept
+[1] 0.982
+>
+> out.metro <- metrop(out.metro, scale = 0.1)
+> out.metro$accept
+[1] 0.795
+>
+> out.metro <- metrop(out.metro, scale = 0.5)
+> out.metro$accept
+[1] 0.264
+>
+> apply(out.metro$batch, 2, mean)
+[1] 0.06080257 1.42304941 0.52634149
+>
+> out.metro <- metrop(logl, as.numeric(coefficients(out)), 1e2,
++ scale = 0.5, debug = TRUE, blen = 5, nspac = 3)
+>
+> niter <- out.metro$nbatch * out.metro$blen * out.metro$nspac
+> niter == nrow(out.metro$current)
+[1] TRUE
+> niter == nrow(out.metro$proposal)
+[1] TRUE
+> all(out.metro$current[1, ] == out.metro$initial)
+[1] TRUE
+> all(out.metro$current[niter, ] == out.metro$final) |
++ all(out.metro$proposal[niter, ] == out.metro$final)
+[1] TRUE
+>
+> .Random.seed <- out.metro$initial.seed
+> d <- ncol(out.metro$proposal)
+> n <- nrow(out.metro$proposal)
+> my.proposal <- matrix(NA, n, d)
+> my.u <- double(n)
+> ska <- out.metro$scale
+> for (i in 1:n) {
++ my.proposal[i, ] <- out.metro$current[i, ] + ska * rnorm(d)
++ if (is.na(out.metro$u[i])) {
++ my.u[i] <- NA
++ } else {
++ my.u[i] <- runif(1)
++ }
++ }
+> max(abs(out.metro$proposal - my.proposal)) < epsilon
+[1] TRUE
+> all(is.na(out.metro$u) == is.na(my.u))
+[1] TRUE
+> all(out.metro$u[!is.na(out.metro$u)] == my.u[!is.na(my.u)])
+[1] TRUE
+>
+> my.curr.log.green <- apply(out.metro$current, 1, logl)
+> my.prop.log.green <- apply(out.metro$proposal, 1, logl)
+> all(is.na(out.metro$u) == (my.prop.log.green > my.curr.log.green))
+[1] TRUE
+> foo <- my.prop.log.green - my.curr.log.green
+> max(abs(foo - out.metro$log.green)) < epsilon
+[1] TRUE
+>
+> my.accept <- is.na(my.u) | my.u < exp(foo)
+> sum(my.accept) == round(n * out.metro$accept)
+[1] TRUE
+> if (my.accept[niter]) {
++ all(out.metro$proposal[niter, ] == out.metro$final)
++ } else {
++ all(out.metro$current[niter, ] == out.metro$final)
++ }
+[1] TRUE
+>
+> my.current <- out.metro$current
+> my.current[my.accept, ] <- my.proposal[my.accept, ]
+> my.current <- rbind(out.metro$initial, my.current[- niter, ])
+> max(abs(out.metro$current - my.current)) < epsilon
+[1] TRUE
+>
+> my.path <- matrix(NA, n, d)
+> my.path[my.accept, ] <- out.metro$proposal[my.accept, ]
+> my.path[! my.accept, ] <- out.metro$current[! my.accept, ]
+> nspac <- out.metro$nspac
+>
+> my.path <- my.path[seq(nspac, niter, by = nspac), ]
+>
+> foom <- array(as.vector(t(my.path)), c(d, out.metro$blen, out.metro$nbatch))
+> boom <- t(apply(foom, c(1, 3), mean))
+>
+> all(dim(boom) == dim(out.metro$batch))
+[1] TRUE
+> max(abs(boom - out.metro$batch)) < epsilon
+[1] TRUE
+>
+>
diff --git a/tests/logitvec.R b/tests/logitvec.R
new file mode 100644
index 0000000..bf82476
--- /dev/null
+++ b/tests/logitvec.R
@@ -0,0 +1,113 @@
+
+ # test vector (diag(foo)) scaling
+
+ epsilon <- 1e-15
+
+ library(mcmc)
+
+ RNGkind("Marsaglia-Multicarry")
+ set.seed(42)
+
+ n <- 100
+ rho <- 0.5
+ beta0 <- 0.25
+ beta1 <- 1
+ beta2 <- 0.5
+
+ x1 <- rnorm(n)
+ x2 <- rho * x1 + sqrt(1 - rho^2) * rnorm(n)
+ eta <- beta0 + beta1 * x1 + beta2 * x2
+ p <- 1 / (1 + exp(- eta))
+ y <- as.numeric(runif(n) < p)
+
+ out <- glm(y ~ x1 + x2, family = binomial())
+
+ logl <- function(beta) {
+ if (length(beta) != 3) stop("length(beta) != 3")
+ beta0 <- beta[1]
+ beta1 <- beta[2]
+ beta2 <- beta[3]
+ eta <- beta0 + beta1 * x1 + beta2 * x2
+ p <- exp(eta) / (1 + exp(eta))
+ return(sum(log(p[y == 1])) + sum(log(1 - p[y == 0])))
+ }
+
+ out.metro <- metrop(logl, coefficients(out), 1e3, scale = 0.01)
+ out.metro$accept
+
+ out.metro <- metrop(out.metro, scale = 0.1)
+ out.metro$accept
+
+ out.metro <- metrop(out.metro, scale = 0.5)
+ out.metro$accept
+
+ apply(out.metro$batch, 2, mean)
+ sally <- apply(out.metro$batch, 2, sd)
+
+ out.metro <- metrop(out.metro, scale = sally)
+ out.metro$accept
+
+ out.metro <- metrop(logl, as.numeric(coefficients(out)), 1e2,
+ scale = sally, debug = TRUE)
+
+ niter <- out.metro$nbatch * out.metro$blen * out.metro$nspac
+ niter == nrow(out.metro$current)
+ niter == nrow(out.metro$proposal)
+ all(out.metro$current[1, ] == out.metro$initial)
+ all(out.metro$current[niter, ] == out.metro$final) |
+ all(out.metro$proposal[niter, ] == out.metro$final)
+
+ .Random.seed <- out.metro$initial.seed
+ d <- ncol(out.metro$proposal)
+ n <- nrow(out.metro$proposal)
+ my.proposal <- matrix(NA, n, d)
+ my.u <- double(n)
+ ska <- out.metro$scale
+ for (i in 1:n) {
+ my.proposal[i, ] <- out.metro$current[i, ] + ska * rnorm(d)
+ if (is.na(out.metro$u[i])) {
+ my.u[i] <- NA
+ } else {
+ my.u[i] <- runif(1)
+ }
+ }
+ max(abs(out.metro$proposal - my.proposal)) < epsilon
+
+ all(is.na(out.metro$u) == is.na(my.u))
+ all(out.metro$u[!is.na(out.metro$u)] == my.u[!is.na(my.u)])
+
+ my.curr.log.green <- apply(out.metro$current, 1, logl)
+ my.prop.log.green <- apply(out.metro$proposal, 1, logl)
+ all(is.na(out.metro$u) == (my.prop.log.green > my.curr.log.green))
+ foo <- my.prop.log.green - my.curr.log.green
+ max(abs(foo - out.metro$log.green)) < epsilon
+
+ my.accept <- is.na(my.u) | my.u < exp(foo)
+ sum(my.accept) == round(n * out.metro$accept)
+ if (my.accept[niter]) {
+ all(out.metro$proposal[niter, ] == out.metro$final)
+ } else {
+ all(out.metro$current[niter, ] == out.metro$final)
+ }
+
+ my.current <- out.metro$current
+ my.current[my.accept, ] <- my.proposal[my.accept, ]
+ my.current <- rbind(out.metro$initial, my.current[- niter, ])
+ max(abs(out.metro$current - my.current)) < epsilon
+
+ my.path <- matrix(NA, n, d)
+ my.path[my.accept, ] <- out.metro$proposal[my.accept, ]
+ my.path[! my.accept, ] <- out.metro$current[! my.accept, ]
+ nspac <- out.metro$nspac
+
+ my.path <- my.path[seq(nspac, niter, by = nspac), ]
+
+ fred <- my.path
+ k <- ncol(fred)
+
+ foom <- array(as.vector(t(fred)), c(k, out.metro$blen, out.metro$nbatch))
+ boom <- t(apply(foom, c(1, 3), mean))
+
+ all(dim(boom) == dim(out.metro$batch))
+ max(abs(boom - out.metro$batch)) < epsilon
+
diff --git a/tests/logitvec.Rout.save b/tests/logitvec.Rout.save
new file mode 100644
index 0000000..b5d5bd5
--- /dev/null
+++ b/tests/logitvec.Rout.save
@@ -0,0 +1,151 @@
+
+R version 2.13.1 (2011-07-08)
+Copyright (C) 2011 The R Foundation for Statistical Computing
+ISBN 3-900051-07-0
+Platform: x86_64-pc-linux-gnu (64-bit)
+
+R is free software and comes with ABSOLUTELY NO WARRANTY.
+You are welcome to redistribute it under certain conditions.
+Type 'license()' or 'licence()' for distribution details.
+
+R is a collaborative project with many contributors.
+Type 'contributors()' for more information and
+'citation()' on how to cite R or R packages in publications.
+
+Type 'demo()' for some demos, 'help()' for on-line help, or
+'help.start()' for an HTML browser interface to help.
+Type 'q()' to quit R.
+
+>
+> # test vector (diag(foo)) scaling
+>
+> epsilon <- 1e-15
+>
+> library(mcmc)
+>
+> RNGkind("Marsaglia-Multicarry")
+> set.seed(42)
+>
+> n <- 100
+> rho <- 0.5
+> beta0 <- 0.25
+> beta1 <- 1
+> beta2 <- 0.5
+>
+> x1 <- rnorm(n)
+> x2 <- rho * x1 + sqrt(1 - rho^2) * rnorm(n)
+> eta <- beta0 + beta1 * x1 + beta2 * x2
+> p <- 1 / (1 + exp(- eta))
+> y <- as.numeric(runif(n) < p)
+>
+> out <- glm(y ~ x1 + x2, family = binomial())
+>
+> logl <- function(beta) {
++ if (length(beta) != 3) stop("length(beta) != 3")
++ beta0 <- beta[1]
++ beta1 <- beta[2]
++ beta2 <- beta[3]
++ eta <- beta0 + beta1 * x1 + beta2 * x2
++ p <- exp(eta) / (1 + exp(eta))
++ return(sum(log(p[y == 1])) + sum(log(1 - p[y == 0])))
++ }
+>
+> out.metro <- metrop(logl, coefficients(out), 1e3, scale = 0.01)
+> out.metro$accept
+[1] 0.982
+>
+> out.metro <- metrop(out.metro, scale = 0.1)
+> out.metro$accept
+[1] 0.795
+>
+> out.metro <- metrop(out.metro, scale = 0.5)
+> out.metro$accept
+[1] 0.264
+>
+> apply(out.metro$batch, 2, mean)
+[1] 0.06080257 1.42304941 0.52634149
+> sally <- apply(out.metro$batch, 2, sd)
+>
+> out.metro <- metrop(out.metro, scale = sally)
+> out.metro$accept
+[1] 0.398
+>
+> out.metro <- metrop(logl, as.numeric(coefficients(out)), 1e2,
++ scale = sally, debug = TRUE)
+>
+> niter <- out.metro$nbatch * out.metro$blen * out.metro$nspac
+> niter == nrow(out.metro$current)
+[1] TRUE
+> niter == nrow(out.metro$proposal)
+[1] TRUE
+> all(out.metro$current[1, ] == out.metro$initial)
+[1] TRUE
+> all(out.metro$current[niter, ] == out.metro$final) |
++ all(out.metro$proposal[niter, ] == out.metro$final)
+[1] TRUE
+>
+> .Random.seed <- out.metro$initial.seed
+> d <- ncol(out.metro$proposal)
+> n <- nrow(out.metro$proposal)
+> my.proposal <- matrix(NA, n, d)
+> my.u <- double(n)
+> ska <- out.metro$scale
+> for (i in 1:n) {
++ my.proposal[i, ] <- out.metro$current[i, ] + ska * rnorm(d)
++ if (is.na(out.metro$u[i])) {
++ my.u[i] <- NA
++ } else {
++ my.u[i] <- runif(1)
++ }
++ }
+> max(abs(out.metro$proposal - my.proposal)) < epsilon
+[1] TRUE
+>
+> all(is.na(out.metro$u) == is.na(my.u))
+[1] TRUE
+> all(out.metro$u[!is.na(out.metro$u)] == my.u[!is.na(my.u)])
+[1] TRUE
+>
+> my.curr.log.green <- apply(out.metro$current, 1, logl)
+> my.prop.log.green <- apply(out.metro$proposal, 1, logl)
+> all(is.na(out.metro$u) == (my.prop.log.green > my.curr.log.green))
+[1] TRUE
+> foo <- my.prop.log.green - my.curr.log.green
+> max(abs(foo - out.metro$log.green)) < epsilon
+[1] TRUE
+>
+> my.accept <- is.na(my.u) | my.u < exp(foo)
+> sum(my.accept) == round(n * out.metro$accept)
+[1] TRUE
+> if (my.accept[niter]) {
++ all(out.metro$proposal[niter, ] == out.metro$final)
++ } else {
++ all(out.metro$current[niter, ] == out.metro$final)
++ }
+[1] TRUE
+>
+> my.current <- out.metro$current
+> my.current[my.accept, ] <- my.proposal[my.accept, ]
+> my.current <- rbind(out.metro$initial, my.current[- niter, ])
+> max(abs(out.metro$current - my.current)) < epsilon
+[1] TRUE
+>
+> my.path <- matrix(NA, n, d)
+> my.path[my.accept, ] <- out.metro$proposal[my.accept, ]
+> my.path[! my.accept, ] <- out.metro$current[! my.accept, ]
+> nspac <- out.metro$nspac
+>
+> my.path <- my.path[seq(nspac, niter, by = nspac), ]
+>
+> fred <- my.path
+> k <- ncol(fred)
+>
+> foom <- array(as.vector(t(fred)), c(k, out.metro$blen, out.metro$nbatch))
+> boom <- t(apply(foom, c(1, 3), mean))
+>
+> all(dim(boom) == dim(out.metro$batch))
+[1] TRUE
+> max(abs(boom - out.metro$batch)) < epsilon
+[1] TRUE
+>
+>
diff --git a/tests/morph.R b/tests/morph.R
new file mode 100644
index 0000000..fde7252
--- /dev/null
+++ b/tests/morph.R
@@ -0,0 +1,123 @@
+library(mcmc)
+isotropic <- mcmc:::isotropic
+isotropic.logjacobian <- mcmc:::isotropic.logjacobian
+
+# make sure morph identity works properly
+TestMorphIdentity <- function(m.id) {
+ ident.func <- function(x) x
+ if (!all.equal(m.id$transform(1:10), 1:10))
+ return(FALSE)
+ if (!all.equal(m.id$inverse(1:10), 1:10))
+ return(FALSE)
+ x <- seq(-1,1, length.out=15)
+ if (!all.equal(sapply(x, m.id$lud(function(x) dnorm(x, log=TRUE))),
+ dnorm(x, log=TRUE)))
+ return(FALSE)
+ if (!all.equal(m.id$outfun(ident.func)(x), x))
+ return(FALSE)
+ return(TRUE)
+}
+
+TestMorphIdentity(morph())
+TestMorphIdentity(morph.identity())
+
+TestMorphIdentityOutfun <- function(m) {
+ f <- m$outfun(NULL)
+ x <- 1:20
+ if (!identical(x, f(x)))
+ return(FALSE)
+ f <- m$outfun(c(6, 8))
+ if (!identical(x[c(6, 8)], f(x)))
+ return(FALSE)
+ i <- rep(FALSE, 20)
+ i[c(1, 3, 5)] <- TRUE
+ f <- m$outfun(i)
+ if (!identical(x[i], f(x)))
+ return(FALSE)
+ return(TRUE)
+}
+
+TestMorphIdentityOutfun(morph())
+TestMorphIdentityOutfun(morph.identity())
+
+# make sure that morph and morph.identity give back the same things
+all.equal(sort(names(morph.identity())), sort(names(morph(b=1))))
+
+# test center parameter, univariate version
+zero.func <- function(x) 0
+center <- 2
+x <- seq(-1,1, length.out=15)
+morph.center <- morph(center=center)
+all.equal(sapply(x, morph.center$transform), x-center)
+all.equal(sapply(x, morph.center$inverse), x+center)
+all.equal(sapply(x, morph.center$lud(function(y) dnorm(y, log=TRUE))),
+ dnorm(x, log=TRUE, mean=-2))
+
+# test center parameter, multivariate version
+center <- 1:4
+x <- rep(0, 4)
+morph.center <- morph(center=center)
+lud.mult.dnorm <- function(x) prod(dnorm(x, log=TRUE))
+all.equal(morph.center$transform(x), x-center)
+all.equal(morph.center$inverse(x), x+center)
+all.equal(morph.center$lud(lud.mult.dnorm)(x),
+ lud.mult.dnorm(x - center))
+# test 'r'.
+r <- 1
+morph.r <- morph(r=r)
+x <- seq(-1, 1, length.out=20)
+all.equal(sapply(x, morph.r$lud(function(x) dnorm(x, log=TRUE))),
+ dnorm(x, log=TRUE))
+x <- seq(1.1, 2, length.out=10)
+all(sapply(x, morph.r$lud(function(x) dnorm(x, log=TRUE)))
+ !=
+ dnorm(x, log=TRUE))
+
+TestExponentialEvenPWithRInverse <- function() {
+ r <- 0.3
+ p <- 2.2
+ morph.r <- morph(r=r, p=p)
+ x <- seq(0, r, length.out=20)
+ all.equal(x, sapply(x, morph.r$inverse))
+}
+
+TestExponentialEvenPWithRInverse()
+
+# make sure morph$lud passes '...' arguments.
+mean <- 2
+ident.morph <- morph()
+dnorm.morph <- ident.morph$lud(function(x, mean=0)
+ dnorm(x, mean=mean, log=TRUE))
+all.equal(dnorm.morph(2, mean), dnorm(2, mean=mean, log=TRUE))
+x <- seq(-3, 3, length.out=20)
+m2 <- morph(r=10)
+dnorm.morph <- m2$lud(function(x, mean)
+ dnorm(x, mean=mean, log=TRUE))
+all.equal(sapply(x, function(y) dnorm.morph(y, 2)),
+ dnorm(x, mean=2, log=TRUE))
+
+# make sure morph$outfun passes '...' arguments.
+outfun.orig <- function(x, mean) x + mean
+ident.morph <- morph()
+mean <- 1
+outfun.morph <- ident.morph$outfun(outfun.orig)
+all.equal(outfun.morph(1:10, mean), 1:10+mean)
+
+m2 <- morph(r=10)
+outfun.morph <- m2$outfun(outfun.orig)
+all.equal(sapply(1:10, function(x) outfun.morph(x, mean)), 1:10+mean)
+
+###########################################################################
+# test built-in exponential and polynomial transformations.
+f <- morph(b=3)
+x <- seq(0, 10, length.out=100)
+all.equal(x, sapply(sapply(x, f$transform), f$inverse))
+
+f <- morph(p=3)
+all.equal(x, sapply(sapply(x, f$transform), f$inverse))
+
+f <- morph(p=3, r=10)
+all.equal(-10:10, Vectorize(f$transform)(-10:10))
+
+f <- morph(p=3, b=1)
+all.equal(x, sapply(sapply(x, f$transform), f$inverse))
diff --git a/tests/morph.Rout.save b/tests/morph.Rout.save
new file mode 100644
index 0000000..7a5532d
--- /dev/null
+++ b/tests/morph.Rout.save
@@ -0,0 +1,164 @@
+
+R version 2.13.1 (2011-07-08)
+Copyright (C) 2011 The R Foundation for Statistical Computing
+ISBN 3-900051-07-0
+Platform: x86_64-pc-linux-gnu (64-bit)
+
+R is free software and comes with ABSOLUTELY NO WARRANTY.
+You are welcome to redistribute it under certain conditions.
+Type 'license()' or 'licence()' for distribution details.
+
+R is a collaborative project with many contributors.
+Type 'contributors()' for more information and
+'citation()' on how to cite R or R packages in publications.
+
+Type 'demo()' for some demos, 'help()' for on-line help, or
+'help.start()' for an HTML browser interface to help.
+Type 'q()' to quit R.
+
+> library(mcmc)
+> isotropic <- mcmc:::isotropic
+> isotropic.logjacobian <- mcmc:::isotropic.logjacobian
+>
+> # make sure morph identity works properly
+> TestMorphIdentity <- function(m.id) {
++ ident.func <- function(x) x
++ if (!all.equal(m.id$transform(1:10), 1:10))
++ return(FALSE)
++ if (!all.equal(m.id$inverse(1:10), 1:10))
++ return(FALSE)
++ x <- seq(-1,1, length.out=15)
++ if (!all.equal(sapply(x, m.id$lud(function(x) dnorm(x, log=TRUE))),
++ dnorm(x, log=TRUE)))
++ return(FALSE)
++ if (!all.equal(m.id$outfun(ident.func)(x), x))
++ return(FALSE)
++ return(TRUE)
++ }
+>
+> TestMorphIdentity(morph())
+[1] TRUE
+> TestMorphIdentity(morph.identity())
+[1] TRUE
+>
+> TestMorphIdentityOutfun <- function(m) {
++ f <- m$outfun(NULL)
++ x <- 1:20
++ if (!identical(x, f(x)))
++ return(FALSE)
++ f <- m$outfun(c(6, 8))
++ if (!identical(x[c(6, 8)], f(x)))
++ return(FALSE)
++ i <- rep(FALSE, 20)
++ i[c(1, 3, 5)] <- TRUE
++ f <- m$outfun(i)
++ if (!identical(x[i], f(x)))
++ return(FALSE)
++ return(TRUE)
++ }
+>
+> TestMorphIdentityOutfun(morph())
+[1] TRUE
+> TestMorphIdentityOutfun(morph.identity())
+[1] TRUE
+>
+> # make sure that morph and morph.identity give back the same things
+> all.equal(sort(names(morph.identity())), sort(names(morph(b=1))))
+[1] TRUE
+>
+> # test center parameter, univariate version
+> zero.func <- function(x) 0
+> center <- 2
+> x <- seq(-1,1, length.out=15)
+> morph.center <- morph(center=center)
+> all.equal(sapply(x, morph.center$transform), x-center)
+[1] TRUE
+> all.equal(sapply(x, morph.center$inverse), x+center)
+[1] TRUE
+> all.equal(sapply(x, morph.center$lud(function(y) dnorm(y, log=TRUE))),
++ dnorm(x, log=TRUE, mean=-2))
+[1] TRUE
+>
+> # test center parameter, multivariate version
+> center <- 1:4
+> x <- rep(0, 4)
+> morph.center <- morph(center=center)
+> lud.mult.dnorm <- function(x) prod(dnorm(x, log=TRUE))
+> all.equal(morph.center$transform(x), x-center)
+[1] TRUE
+> all.equal(morph.center$inverse(x), x+center)
+[1] TRUE
+> all.equal(morph.center$lud(lud.mult.dnorm)(x),
++ lud.mult.dnorm(x - center))
+[1] TRUE
+> # test 'r'.
+> r <- 1
+> morph.r <- morph(r=r)
+> x <- seq(-1, 1, length.out=20)
+> all.equal(sapply(x, morph.r$lud(function(x) dnorm(x, log=TRUE))),
++ dnorm(x, log=TRUE))
+[1] TRUE
+> x <- seq(1.1, 2, length.out=10)
+> all(sapply(x, morph.r$lud(function(x) dnorm(x, log=TRUE)))
++ !=
++ dnorm(x, log=TRUE))
+[1] TRUE
+>
+> TestExponentialEvenPWithRInverse <- function() {
++ r <- 0.3
++ p <- 2.2
++ morph.r <- morph(r=r, p=p)
++ x <- seq(0, r, length.out=20)
++ all.equal(x, sapply(x, morph.r$inverse))
++ }
+>
+> TestExponentialEvenPWithRInverse()
+[1] TRUE
+>
+> # make sure morph$lud passes '...' arguments.
+> mean <- 2
+> ident.morph <- morph()
+> dnorm.morph <- ident.morph$lud(function(x, mean=0)
++ dnorm(x, mean=mean, log=TRUE))
+> all.equal(dnorm.morph(2, mean), dnorm(2, mean=mean, log=TRUE))
+[1] TRUE
+> x <- seq(-3, 3, length.out=20)
+> m2 <- morph(r=10)
+> dnorm.morph <- m2$lud(function(x, mean)
++ dnorm(x, mean=mean, log=TRUE))
+> all.equal(sapply(x, function(y) dnorm.morph(y, 2)),
++ dnorm(x, mean=2, log=TRUE))
+[1] TRUE
+>
+> # make sure morph$outfun passes '...' arguments.
+> outfun.orig <- function(x, mean) x + mean
+> ident.morph <- morph()
+> mean <- 1
+> outfun.morph <- ident.morph$outfun(outfun.orig)
+> all.equal(outfun.morph(1:10, mean), 1:10+mean)
+[1] TRUE
+>
+> m2 <- morph(r=10)
+> outfun.morph <- m2$outfun(outfun.orig)
+> all.equal(sapply(1:10, function(x) outfun.morph(x, mean)), 1:10+mean)
+[1] TRUE
+>
+> ###########################################################################
+> # test built-in exponential and polynomial transformations.
+> f <- morph(b=3)
+> x <- seq(0, 10, length.out=100)
+> all.equal(x, sapply(sapply(x, f$transform), f$inverse))
+[1] TRUE
+>
+> f <- morph(p=3)
+> all.equal(x, sapply(sapply(x, f$transform), f$inverse))
+[1] TRUE
+>
+> f <- morph(p=3, r=10)
+> all.equal(-10:10, Vectorize(f$transform)(-10:10))
+[1] TRUE
+>
+> f <- morph(p=3, b=1)
+> all.equal(x, sapply(sapply(x, f$transform), f$inverse))
+[1] TRUE
+>
diff --git a/tests/morph.metrop.R b/tests/morph.metrop.R
new file mode 100644
index 0000000..fd30457
--- /dev/null
+++ b/tests/morph.metrop.R
@@ -0,0 +1,30 @@
+library(mcmc)
+
+.morph.unmorph <- mcmc:::.morph.unmorph
+
+###########################################################################
+# basic functionality check, can morph.metro run? Can we change the
+# transformation?
+set.seed(42)
+obj <- morph.metrop(function(x) dt(x, df=3, log=TRUE),
+ 100, 100, morph=morph(b=3))
+obj <- morph.metrop(obj, morph=morph(b=1))
+
+obj <- morph.metrop(function(x) prod(dt(x, df=3, log=TRUE)),
+ rep(100, 3), 100, morph=morph(p=3, b=1))
+obj <- morph.metrop(obj, morph=morph(r=1, p=3, b=1))
+
+all.equal(class(obj), c("mcmc", "morph.metropolis"))
+
+###########################################################################
+# check .morph.unmorph
+obj <- list(final=10)
+outfun <- function(x) x
+m <- morph(p=3)
+obj <- .morph.unmorph(obj, m, outfun)
+all.equal(class(obj), c("mcmc", "morph.metropolis"))
+all.equal(sort(names(obj)),
+ sort(c("final", "morph", "morph.final", "outfun")))
+all.equal(c(obj$final, obj$morph.final), c(m$inverse(10), 10))
+all.equal(obj$outfun, outfun)
+all.equal(obj$morph, m)
diff --git a/tests/morph.metrop.Rout.save b/tests/morph.metrop.Rout.save
new file mode 100644
index 0000000..bcf3226
--- /dev/null
+++ b/tests/morph.metrop.Rout.save
@@ -0,0 +1,57 @@
+
+R version 3.2.1 (2015-06-18) -- "World-Famous Astronaut"
+Copyright (C) 2015 The R Foundation for Statistical Computing
+Platform: i686-pc-linux-gnu (32-bit)
+
+R is free software and comes with ABSOLUTELY NO WARRANTY.
+You are welcome to redistribute it under certain conditions.
+Type 'license()' or 'licence()' for distribution details.
+
+R is a collaborative project with many contributors.
+Type 'contributors()' for more information and
+'citation()' on how to cite R or R packages in publications.
+
+Type 'demo()' for some demos, 'help()' for on-line help, or
+'help.start()' for an HTML browser interface to help.
+Type 'q()' to quit R.
+
+> library(mcmc)
+>
+> .morph.unmorph <- mcmc:::.morph.unmorph
+>
+> ###########################################################################
+> # basic functionality check, can morph.metro run? Can we change the
+> # transformation?
+> set.seed(42)
+> obj <- morph.metrop(function(x) dt(x, df=3, log=TRUE),
++ 100, 100, morph=morph(b=3))
+> obj <- morph.metrop(obj, morph=morph(b=1))
+>
+> obj <- morph.metrop(function(x) prod(dt(x, df=3, log=TRUE)),
++ rep(100, 3), 100, morph=morph(p=3, b=1))
+> obj <- morph.metrop(obj, morph=morph(r=1, p=3, b=1))
+>
+> all.equal(class(obj), c("mcmc", "morph.metropolis"))
+[1] TRUE
+>
+> ###########################################################################
+> # check .morph.unmorph
+> obj <- list(final=10)
+> outfun <- function(x) x
+> m <- morph(p=3)
+> obj <- .morph.unmorph(obj, m, outfun)
+> all.equal(class(obj), c("mcmc", "morph.metropolis"))
+[1] TRUE
+> all.equal(sort(names(obj)),
++ sort(c("final", "morph", "morph.final", "outfun")))
+[1] TRUE
+> all.equal(c(obj$final, obj$morph.final), c(m$inverse(10), 10))
+[1] TRUE
+> all.equal(obj$outfun, outfun)
+[1] TRUE
+> all.equal(obj$morph, m)
+[1] TRUE
+>
+> proc.time()
+ user system elapsed
+ 0.384 0.024 0.401
diff --git a/tests/morphtoo.R b/tests/morphtoo.R
new file mode 100644
index 0000000..9aa6b39
--- /dev/null
+++ b/tests/morphtoo.R
@@ -0,0 +1,61 @@
+
+ library(mcmc)
+
+ x <- seq(0, 10, length = 10001)
+
+ ### sub-exponentially light transformation
+
+ b <- 0.5
+ fsub <- morph(b = b)
+
+ y <- unlist(Map(fsub$inverse, x))
+
+ myfsub <- function(x) ifelse(x > 1 / b, exp(b * x) - exp(1) / 3,
+ (x * b)^3 * exp(1) / 6 + x * b * exp(1) / 2)
+ y2 <- myfsub(x)
+ all.equal(y, y2, tolerance = 1e-14)
+
+ z <- unlist(Map(fsub$transform, y))
+ all.equal(z, x, tolerance = 1e-14)
+
+ ### exponentially light transformation
+
+ r <- 5
+ p <- 3
+ fp3 <- morph(r = r)
+
+ y <- unlist(Map(fp3$inverse, x))
+
+ myfp3 <- function(x) ifelse(x < r, x, x + (x - r)^p)
+ y2 <- myfp3(x)
+ all.equal(y, y2, tolerance = 1e-14)
+
+ z <- unlist(Map(fp3$transform, y))
+ all.equal(z, x, tolerance = 1e-12)
+
+ ### both together
+
+ fboth <- morph(b = b, r = r)
+
+ y <- unlist(Map(fboth$inverse, x))
+ y2 <- myfsub(myfp3(x))
+ all.equal(y, y2, tolerance = 1e-14)
+
+ z <- unlist(Map(fboth$transform, y))
+ all.equal(z, x, tolerance = 1e-12)
+
+ ### exponentially light transformation with p != 3
+
+ r <- 5
+ p <- 2.2
+ fpo <- morph(r = r, p = p)
+
+ y <- unlist(Map(fpo$inverse, x))
+
+ myfpo <- function(x) ifelse(x < r, x, x + (x - r)^p)
+ y2 <- myfpo(x)
+ all.equal(y, y2, tolerance = 1e-14)
+
+ z <- unlist(Map(fpo$transform, y))
+ all.equal(z, x, tolerance = 1e-14)
+
diff --git a/tests/morphtoo.Rout.save b/tests/morphtoo.Rout.save
new file mode 100644
index 0000000..46fea9f
--- /dev/null
+++ b/tests/morphtoo.Rout.save
@@ -0,0 +1,91 @@
+
+R version 2.15.0 (2012-03-30)
+Copyright (C) 2012 The R Foundation for Statistical Computing
+ISBN 3-900051-07-0
+Platform: i686-pc-linux-gnu (32-bit)
+
+R is free software and comes with ABSOLUTELY NO WARRANTY.
+You are welcome to redistribute it under certain conditions.
+Type 'license()' or 'licence()' for distribution details.
+
+R is a collaborative project with many contributors.
+Type 'contributors()' for more information and
+'citation()' on how to cite R or R packages in publications.
+
+Type 'demo()' for some demos, 'help()' for on-line help, or
+'help.start()' for an HTML browser interface to help.
+Type 'q()' to quit R.
+
+>
+> library(mcmc)
+>
+> x <- seq(0, 10, length = 10001)
+>
+> ### sub-exponentially light transformation
+>
+> b <- 0.5
+> fsub <- morph(b = b)
+>
+> y <- unlist(Map(fsub$inverse, x))
+>
+> myfsub <- function(x) ifelse(x > 1 / b, exp(b * x) - exp(1) / 3,
++ (x * b)^3 * exp(1) / 6 + x * b * exp(1) / 2)
+> y2 <- myfsub(x)
+> all.equal(y, y2, tolerance = 1e-14)
+[1] TRUE
+>
+> z <- unlist(Map(fsub$transform, y))
+> all.equal(z, x, tolerance = 1e-14)
+[1] TRUE
+>
+> ### exponentially light transformation
+>
+> r <- 5
+> p <- 3
+> fp3 <- morph(r = r)
+>
+> y <- unlist(Map(fp3$inverse, x))
+>
+> myfp3 <- function(x) ifelse(x < r, x, x + (x - r)^p)
+> y2 <- myfp3(x)
+> all.equal(y, y2, tolerance = 1e-14)
+[1] TRUE
+>
+> z <- unlist(Map(fp3$transform, y))
+> all.equal(z, x, tolerance = 1e-12)
+[1] TRUE
+>
+> ### both together
+>
+> fboth <- morph(b = b, r = r)
+>
+> y <- unlist(Map(fboth$inverse, x))
+> y2 <- myfsub(myfp3(x))
+> all.equal(y, y2, tolerance = 1e-14)
+[1] TRUE
+>
+> z <- unlist(Map(fboth$transform, y))
+> all.equal(z, x, tolerance = 1e-12)
+[1] TRUE
+>
+> ### exponentially light transformation with p != 3
+>
+> r <- 5
+> p <- 2.2
+> fpo <- morph(r = r, p = p)
+>
+> y <- unlist(Map(fpo$inverse, x))
+>
+> myfpo <- function(x) ifelse(x < r, x, x + (x - r)^p)
+> y2 <- myfpo(x)
+> all.equal(y, y2, tolerance = 1e-14)
+[1] TRUE
+>
+> z <- unlist(Map(fpo$transform, y))
+> all.equal(z, x, tolerance = 1e-14)
+[1] TRUE
+>
+>
+> proc.time()
+ user system elapsed
+ 4.024 0.036 4.038
diff --git a/tests/saveseed.R b/tests/saveseed.R
new file mode 100644
index 0000000..619038b
--- /dev/null
+++ b/tests/saveseed.R
@@ -0,0 +1,18 @@
+
+ library(mcmc)
+
+ set.seed(42)
+
+ h <- function(x) if (all(x >= 0) && sum(x) <= 1) return(1) else return(-Inf)
+ out <- metrop(h, initial = rep(0, 5), nbatch = 100, blen = 17, nspac = 3,
+ scale = 0.1)
+
+ save.seed <- .Random.seed
+
+ out1 <- metrop(out)
+ out2 <- metrop(out1)
+ out3 <- metrop(out, nbatch = 2 * out$nbatch)
+
+ fred <- rbind(out1$batch, out2$batch)
+ identical(fred, out3$batch)
+
diff --git a/tests/saveseed.Rout.save b/tests/saveseed.Rout.save
new file mode 100644
index 0000000..c5a6103
--- /dev/null
+++ b/tests/saveseed.Rout.save
@@ -0,0 +1,38 @@
+
+R version 2.13.1 (2011-07-08)
+Copyright (C) 2011 The R Foundation for Statistical Computing
+ISBN 3-900051-07-0
+Platform: x86_64-pc-linux-gnu (64-bit)
+
+R is free software and comes with ABSOLUTELY NO WARRANTY.
+You are welcome to redistribute it under certain conditions.
+Type 'license()' or 'licence()' for distribution details.
+
+R is a collaborative project with many contributors.
+Type 'contributors()' for more information and
+'citation()' on how to cite R or R packages in publications.
+
+Type 'demo()' for some demos, 'help()' for on-line help, or
+'help.start()' for an HTML browser interface to help.
+Type 'q()' to quit R.
+
+>
+> library(mcmc)
+>
+> set.seed(42)
+>
+> h <- function(x) if (all(x >= 0) && sum(x) <= 1) return(1) else return(-Inf)
+> out <- metrop(h, initial = rep(0, 5), nbatch = 100, blen = 17, nspac = 3,
++ scale = 0.1)
+>
+> save.seed <- .Random.seed
+>
+> out1 <- metrop(out)
+> out2 <- metrop(out1)
+> out3 <- metrop(out, nbatch = 2 * out$nbatch)
+>
+> fred <- rbind(out1$batch, out2$batch)
+> identical(fred, out3$batch)
+[1] TRUE
+>
+>
diff --git a/tests/saveseedmorph.R b/tests/saveseedmorph.R
new file mode 100644
index 0000000..d0c2690
--- /dev/null
+++ b/tests/saveseedmorph.R
@@ -0,0 +1,25 @@
+
+ library(mcmc)
+
+ set.seed(42)
+
+ h <- function(x) if (all(x >= 0) && sum(x) <= 1) return(1) else return(-Inf)
+ out <- morph.metrop(obj = h, initial = rep(0, 5), nbatch = 100, blen = 17,
+ nspac = 3, scale = 0.1)
+
+ out1 <- morph.metrop(out)
+ out2 <- morph.metrop(out1)
+ out3 <- morph.metrop(out, nbatch = 2 * out$nbatch)
+
+ fred <- rbind(out1$batch, out2$batch)
+ identical(fred, out3$batch)
+
+ out <- morph.metrop(out, morph = morph(p = 2.2, r = 0.3))
+
+ out1 <- morph.metrop(out)
+ out2 <- morph.metrop(out1)
+ out3 <- morph.metrop(out, nbatch = 2 * out$nbatch)
+
+ fred <- rbind(out1$batch, out2$batch)
+ identical(fred, out3$batch)
+
diff --git a/tests/saveseedmorph.Rout.save b/tests/saveseedmorph.Rout.save
new file mode 100644
index 0000000..0497311
--- /dev/null
+++ b/tests/saveseedmorph.Rout.save
@@ -0,0 +1,49 @@
+
+R version 2.15.0 (2012-03-30)
+Copyright (C) 2012 The R Foundation for Statistical Computing
+ISBN 3-900051-07-0
+Platform: i686-pc-linux-gnu (32-bit)
+
+R is free software and comes with ABSOLUTELY NO WARRANTY.
+You are welcome to redistribute it under certain conditions.
+Type 'license()' or 'licence()' for distribution details.
+
+R is a collaborative project with many contributors.
+Type 'contributors()' for more information and
+'citation()' on how to cite R or R packages in publications.
+
+Type 'demo()' for some demos, 'help()' for on-line help, or
+'help.start()' for an HTML browser interface to help.
+Type 'q()' to quit R.
+
+>
+> library(mcmc)
+>
+> set.seed(42)
+>
+> h <- function(x) if (all(x >= 0) && sum(x) <= 1) return(1) else return(-Inf)
+> out <- morph.metrop(obj = h, initial = rep(0, 5), nbatch = 100, blen = 17,
++ nspac = 3, scale = 0.1)
+>
+> out1 <- morph.metrop(out)
+> out2 <- morph.metrop(out1)
+> out3 <- morph.metrop(out, nbatch = 2 * out$nbatch)
+>
+> fred <- rbind(out1$batch, out2$batch)
+> identical(fred, out3$batch)
+[1] TRUE
+>
+> out <- morph.metrop(out, morph = morph(p = 2.2, r = 0.3))
+>
+> out1 <- morph.metrop(out)
+> out2 <- morph.metrop(out1)
+> out3 <- morph.metrop(out, nbatch = 2 * out$nbatch)
+>
+> fred <- rbind(out1$batch, out2$batch)
+> identical(fred, out3$batch)
+[1] TRUE
+>
+>
+> proc.time()
+ user system elapsed
+ 0.752 0.036 0.767
diff --git a/tests/temp-par-witch.R b/tests/temp-par-witch.R
new file mode 100644
index 0000000..8bacc38
--- /dev/null
+++ b/tests/temp-par-witch.R
@@ -0,0 +1,72 @@
+
+ library(mcmc)
+
+ options(digits=4) # avoid rounding differences
+
+ set.seed(42)
+
+ d <- 3
+ witch.which <- 1 - (1 / 2)^(1 / d) * (1 / 4)^(seq(0, 5) / d)
+ witch.which
+
+ ncomp <- length(witch.which)
+
+ neighbors <- matrix(FALSE, ncomp, ncomp)
+ neighbors[row(neighbors) == col(neighbors) + 1] <- TRUE
+ neighbors[row(neighbors) == col(neighbors) - 1] <- TRUE
+ neighbors[row(neighbors) == col(neighbors) + 2] <- TRUE
+ neighbors[row(neighbors) == col(neighbors) - 2] <- TRUE
+
+ ludfun <- function(state) {
+ stopifnot(is.numeric(state))
+ stopifnot(length(state) == d + 1)
+ icomp <- state[1]
+ stopifnot(icomp == as.integer(icomp))
+ stopifnot(1 <= icomp && icomp <= ncomp)
+ theta <- state[-1]
+ if (any(abs(theta) > 1.0)) return(-Inf)
+ bnd <- witch.which[icomp]
+ if(bnd >= 1.0)
+ stop(sprintf("witch.which[%d] >= 1.0", icomp))
+ if(bnd <= 0.0)
+ stop(sprintf("witch.which[%d] <= 0.0", icomp))
+ if (all(abs(theta) > bnd))
+ return(- (d + 1) * log(2) - d * log(1 - bnd))
+ return(- (d + 1) * log(2) - log1p(- (1 - bnd)^d))
+ }
+
+ thetas <- matrix(0, ncomp, d)
+ out <- temper(ludfun, initial = thetas, neighbors = neighbors, nbatch = 50,
+ blen = 13, nspac = 7, scale = 0.3456789, parallel = TRUE)
+
+ names(out)
+
+ out$acceptx
+
+ out$accepti
+
+ ### check that have prob 1 / 2 for corners
+
+ outfun <- function(state) {
+ stopifnot(is.matrix(state))
+ ncomp <- nrow(state)
+ d <- ncol(state)
+ foo <- sweep(abs(state), 1, witch.which)
+ bar <- apply(foo > 0, 1, all)
+ return(as.numeric(bar))
+ }
+
+ out <- temper(out, outfun = outfun)
+
+ colMeans(out$batch)
+ apply(out$batch, 2, sd) / sqrt(out$nbatch)
+
+ ### try again
+
+ out <- temper(out, blen = 103, outfun = outfun)
+
+ foo <- cbind(colMeans(out$batch),
+ apply(out$batch, 2, sd) / sqrt(out$nbatch))
+ colnames(foo) <- c("means", "MCSE")
+ foo
+
diff --git a/tests/temp-par.R b/tests/temp-par.R
new file mode 100644
index 0000000..04ea4da
--- /dev/null
+++ b/tests/temp-par.R
@@ -0,0 +1,302 @@
+
+ library(mcmc)
+
+ set.seed(42)
+
+ data(foo)
+ attach(foo)
+
+ out <- glm(y ~ x1 + x2 + x3, family = binomial, x = TRUE)
+ summary(out)
+
+ modmat <- out$x
+
+ models <- cbind(rep(0:1, each = 4), rep(rep(0:1, times = 2), each = 2),
+ rep(0:1, times = 4))
+
+ exes <- paste("x", 1:3, sep = "")
+ betas <- NULL
+ for (i in 1:nrow(models)) {
+ inies <- as.logical(models[i, ])
+ foo <- exes[inies]
+ bar <- paste("y ~", paste(foo, collapse = " + "))
+ if (! any(inies)) bar <- paste(bar, "1")
+ baz <- glm(as.formula(bar), family = binomial)
+ beta <- rep(0, 4)
+ beta[c(TRUE, inies)] <- baz$coef
+ betas <- rbind(betas, beta)
+ }
+
+ neighbors <- matrix(FALSE, nrow(models), nrow(models))
+ for (i in 1:nrow(neighbors)) {
+ for (j in 1:ncol(neighbors)) {
+ foo <- models[i, ]
+ bar <- models[j, ]
+ if (sum(foo != bar) == 1) neighbors[i, j] <- TRUE
+ }
+ }
+
+ ludfun <- function(state, ...) {
+ stopifnot(is.numeric(state))
+ stopifnot(length(state) == ncol(models) + 2)
+ stopifnot(length(state) == ncol(models) + 2)
+ icomp <- state[1]
+ stopifnot(icomp == as.integer(icomp))
+ stopifnot(1 <= icomp && icomp <= nrow(models))
+ beta <- state[-1]
+ inies <- c(TRUE, as.logical(models[icomp, ]))
+ beta.logl <- beta
+ beta.logl[! inies] <- 0
+ eta <- as.numeric(modmat %*% beta.logl)
+ logp <- ifelse(eta < 0, eta - log1p(exp(eta)), - log1p(exp(- eta)))
+ logq <- ifelse(eta < 0, - log1p(exp(eta)), - eta - log1p(exp(- eta)))
+ logl <- sum(logp[y == 1]) + sum(logq[y == 0])
+ val <- logl - sum(beta^2) / 2
+ return(val)
+ }
+
+ ludval <- NULL
+ for (i in 1:nrow(models)) ludval <- c(ludval, ludfun(c(i, betas[i, ])))
+ all(is.finite(ludval))
+
+
+ out <- temper(ludfun, initial = betas, neighbors = neighbors, nbatch = 20,
+ blen = 10, nspac = 5, scale = 0.56789, parallel = TRUE, debug = TRUE)
+
+ names(out)
+
+ ### check decision about within-component or jump/swap
+
+ identical(out$unif.which < 0.5, out$which)
+
+ identical(out$which, out$proposal[ , 1] == out$coproposal[ , 1])
+
+ ### check proposal and coproposal are actually current state or part thereof
+
+ prop <- out$proposal
+ coprop <- out$coproposal
+ prop.i <- prop[ , 1]
+ coprop.i <- coprop[ , 1]
+ alt.prop <- prop
+ alt.coprop <- coprop
+ for (i in 1:nrow(prop)) {
+ alt.prop[i, ] <- c(prop.i[i], out$state[i, prop.i[i], ])
+ alt.coprop[i, ] <- c(coprop.i[i], out$state[i, coprop.i[i], ])
+ }
+ identical(coprop, alt.coprop)
+ identical(prop[! out$which, ], alt.prop[! out$which, ])
+ identical(prop[out$which, 1], alt.prop[out$which, 1])
+
+ ### check hastings ratio calculated correctly
+
+ foo <- apply(prop, 1, ludfun)
+ fooco <- apply(coprop, 1, ludfun)
+ prop[ , 1] <- out$coproposal[ , 1]
+ coprop[ , 1] <- out$proposal[ , 1]
+ foo.swap <- apply(prop, 1, ludfun)
+ fooco.swap <- apply(coprop, 1, ludfun)
+ log.haste <- ifelse(out$which, foo - fooco,
+ foo.swap + fooco.swap - foo - fooco)
+ all.equal(log.haste, out$log.hastings)
+
+ ### check hastings rejection decided correctly
+
+ identical(out$log.hastings >= 0, is.na(out$unif.hastings))
+ all(out$log.hastings < 0 | out$acceptd)
+ identical(out$acceptd,
+ out$log.hastings >= 0 | out$unif.hastings < exp(out$log.hastings))
+
+ ### check acceptance carried out or not (according to decision) correctly
+
+ before <- out$state
+ after <- before
+ after[- dim(after)[1], , ] <- before[-1, , ]
+ after[dim(after)[1], , ] <- out$final
+ my.after <- before
+ for (i in 1:length(out$acceptd)) {
+ if (out$acceptd[i]) {
+ if (out$which[i]) {
+ j <- out$proposal[i, 1]
+ my.after[i, j, ] <- out$proposal[i, -1]
+ } else {
+ j <- out$proposal[i, 1]
+ k <- out$coproposal[i, 1]
+ my.after[i, j, ] <- out$coproposal[i, -1]
+ my.after[i, k, ] <- out$proposal[i, -1]
+ }
+ }
+ }
+ identical(after, my.after)
+
+ ### check within-component proposal
+
+ my.coproposal.within <- out$coproposal[out$which, ]
+ proposal.within <- out$proposal[out$which, ]
+ my.z <- out$norm[out$which, ]
+ my.proposal.within <- my.coproposal.within
+ my.proposal.within[ , -1] <- my.coproposal.within[ , -1] + out$scale * my.z
+ all.equal(proposal.within, my.proposal.within)
+
+ my.unif.choose <- out$unif.choose[out$which, 1]
+ my.i <- floor(nrow(models) * my.unif.choose) + 1
+ all(1 <= my.i & my.i <= nrow(models))
+ identical(my.i, my.coproposal.within[ , 1])
+
+ ### check swap proposal
+
+ coproposal.swap <- out$coproposal[! out$which, ]
+ proposal.swap <- out$proposal[! out$which, ]
+ unif.choose.swap <- out$unif.choose[! out$which, ]
+ my.i <- floor(nrow(models) * unif.choose.swap[ , 1]) + 1
+ nneighbors <- apply(out$neighbors, 1, sum)
+ my.nneighbors <- nneighbors[my.i]
+ my.k <- floor(my.nneighbors * unif.choose.swap[ , 2]) + 1
+ my.j <- my.k
+ foo <- seq(1, ncol(out$neighbors))
+ for (i in seq(along = my.j)) {
+ my.j[i] <- (foo[out$neighbors[my.i[i], ]])[my.k[i]]
+ }
+ identical(coproposal.swap[ , 1], my.i)
+ identical(proposal.swap[ , 1], my.j)
+
+ ### check standard normal and uniform random numbers are as purported
+
+ save.Random.seed <- .Random.seed
+ .Random.seed <- out$initial.seed
+
+ nx <- ncol(out$initial)
+ niter <- out$nbatch * out$blen * out$nspac
+ my.norm <- matrix(NA, nrow = nrow(out$norm), ncol = ncol(out$norm))
+ my.unif.which <- rep(NA, niter)
+ my.unif.hastings <- rep(NA, niter)
+ my.unif.choose <- matrix(NA, niter, 2)
+ for (iiter in 1:niter) {
+ my.unif.which[iiter] <- runif(1)
+ if (out$which[iiter]) {
+ my.unif.choose[iiter, 1] <- runif(1)
+ my.norm[iiter, ] <- rnorm(nx)
+ if (out$log.hastings[iiter] < 0) my.unif.hastings[iiter] <- runif(1)
+ } else {
+ my.unif.choose[iiter, ] <- runif(2)
+ if (out$log.hastings[iiter] < 0) my.unif.hastings[iiter] <- runif(1)
+ }
+ }
+ identical(my.norm, out$norm)
+ identical(my.unif.which, out$unif.which)
+ identical(my.unif.hastings, out$unif.hastings)
+ identical(my.unif.choose, out$unif.choose)
+
+ .Random.seed <- save.Random.seed
+
+ ### check batch means
+
+ foo <- after[seq(1, niter) %% out$nspac == 0, , ]
+ foo <- array(as.vector(foo), dim = c(out$blen, out$nbatch, dim(foo)[2:3]))
+ foo <- apply(foo, c(2, 3, 4), mean)
+ all.equal(foo, out$batch)
+
+ ### check acceptance rates
+
+ accept.within <- out$acceptd[out$which]
+ my.i.within <- out$coproposal[out$which, 1]
+ my.acceptx <- as.vector(sapply(split(accept.within, my.i.within), mean))
+ identical(my.acceptx, out$acceptx)
+
+ accept.swap <- out$acceptd[! out$which]
+ my.i.swap <- out$coproposal[! out$which, 1]
+ my.j.swap <- out$proposal[! out$which, 1]
+ nmodel <- nrow(out$neighbors)
+ my.accepti <- matrix(NA, nmodel, nmodel)
+ for (i in 1:nmodel) {
+ for (j in 1:nmodel) {
+ if (out$neighbors[i, j]) {
+ my.accepti[i, j] <-
+ mean(accept.swap[my.i.swap == i & my.j.swap == j])
+ }
+ }
+ }
+ identical(my.accepti, out$accepti)
+
+ ### check scale vector
+
+ nx <- ncol(models) + 1
+ newscale <- rnorm(nx, 0.5, 0.1)
+
+ out <- temper(out, scale = newscale)
+
+ my.coproposal.within <- out$coproposal[out$which, ]
+ proposal.within <- out$proposal[out$which, ]
+ my.z <- out$norm[out$which, ]
+ my.proposal.within <- my.coproposal.within
+ my.proposal.within[ , -1] <- my.coproposal.within[ , -1] +
+ sweep(my.z, 2, out$scale, "*")
+ all.equal(proposal.within, my.proposal.within)
+
+ ### check scale matrix
+
+ matscale <- matrix(rnorm(nx * nx, 0.0, 0.1), nx, nx)
+ diag(matscale) <- 0.56789
+
+ out <- temper(out, scale = matscale)
+
+ my.coproposal.within <- out$coproposal[out$which, ]
+ proposal.within <- out$proposal[out$which, ]
+ my.z <- out$norm[out$which, ]
+ my.proposal.within <- my.coproposal.within
+ my.proposal.within[ , -1] <- my.coproposal.within[ , -1] +
+ my.z %*% t(out$scale)
+ all.equal(proposal.within, my.proposal.within)
+
+ ### check scale list
+
+ lisztscale <- list(0.56789, newscale, matscale, matscale, newscale,
+ 0.98765, 0.98765, newscale)
+
+ out <- temper(out, scale = lisztscale)
+
+ my.coproposal.within <- out$coproposal[out$which, ]
+ proposal.within <- out$proposal[out$which, ]
+ my.z <- out$norm[out$which, ]
+ my.proposal.within <- my.coproposal.within
+ for (iiter in 1:nrow(my.z)) {
+ my.i <- my.coproposal.within[iiter, 1]
+ my.scale <- out$scale[[my.i]]
+ if (is.matrix(my.scale)) {
+ my.proposal.within[iiter, -1] <- my.coproposal.within[iiter, -1] +
+ my.z[iiter, , drop = FALSE] %*% t(my.scale)
+ } else {
+ my.proposal.within[iiter, -1] <- my.coproposal.within[iiter, -1] +
+ my.z[iiter, ] * my.scale
+ }
+ }
+ all.equal(proposal.within, my.proposal.within)
+
+ ### check outfun
+
+ outfun <- function(state, icomp, ...) {
+ stopifnot(is.matrix(state))
+ stopifnot(is.numeric(state))
+ nx <- ncol(betas)
+ ncomp <- nrow(betas)
+ stopifnot(ncol(state) == nx)
+ stopifnot(nrow(state) == ncomp)
+ stopifnot(1 <= icomp && icomp <= ncomp)
+ foo <- state[icomp, ]
+ bar <- foo^2
+ return(c(foo, bar))
+ }
+
+ out <- temper(out, outfun = outfun, icomp = 4)
+
+ before <- out$state
+ after <- before
+ after[- dim(after)[1], , ] <- before[-1, , ]
+ after[dim(after)[1], , ] <- out$final
+ outies <- apply(after, 1, outfun, icomp = 4)
+ outies <- t(outies)
+
+ foo <- outies[seq(1, niter) %% out$nspac == 0, ]
+ foo <- array(as.vector(foo), dim = c(out$blen, out$nbatch, dim(foo)[2]))
+ foo <- apply(foo, c(2, 3), mean)
+ all.equal(foo, out$batch)
+
diff --git a/tests/temp-par.Rout.save b/tests/temp-par.Rout.save
new file mode 100644
index 0000000..51f35e2
--- /dev/null
+++ b/tests/temp-par.Rout.save
@@ -0,0 +1,380 @@
+
+R version 2.13.1 (2011-07-08)
+Copyright (C) 2011 The R Foundation for Statistical Computing
+ISBN 3-900051-07-0
+Platform: x86_64-pc-linux-gnu (64-bit)
+
+R is free software and comes with ABSOLUTELY NO WARRANTY.
+You are welcome to redistribute it under certain conditions.
+Type 'license()' or 'licence()' for distribution details.
+
+R is a collaborative project with many contributors.
+Type 'contributors()' for more information and
+'citation()' on how to cite R or R packages in publications.
+
+Type 'demo()' for some demos, 'help()' for on-line help, or
+'help.start()' for an HTML browser interface to help.
+Type 'q()' to quit R.
+
+>
+> library(mcmc)
+>
+> set.seed(42)
+>
+> data(foo)
+> attach(foo)
+>
+> out <- glm(y ~ x1 + x2 + x3, family = binomial, x = TRUE)
+> summary(out)
+
+Call:
+glm(formula = y ~ x1 + x2 + x3, family = binomial, x = TRUE)
+
+Deviance Residuals:
+ Min 1Q Median 3Q Max
+-2.0371 -0.6337 0.2394 0.6685 1.9599
+
+Coefficients:
+ Estimate Std. Error z value Pr(>|z|)
+(Intercept) 0.5772 0.2766 2.087 0.036930 *
+x1 0.3362 0.4256 0.790 0.429672
+x2 0.8475 0.4701 1.803 0.071394 .
+x3 1.5143 0.4426 3.422 0.000622 ***
+---
+Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
+
+(Dispersion parameter for binomial family taken to be 1)
+
+ Null deviance: 134.602 on 99 degrees of freedom
+Residual deviance: 86.439 on 96 degrees of freedom
+AIC: 94.439
+
+Number of Fisher Scoring iterations: 5
+
+>
+> modmat <- out$x
+>
+> models <- cbind(rep(0:1, each = 4), rep(rep(0:1, times = 2), each = 2),
++ rep(0:1, times = 4))
+>
+> exes <- paste("x", 1:3, sep = "")
+> betas <- NULL
+> for (i in 1:nrow(models)) {
++ inies <- as.logical(models[i, ])
++ foo <- exes[inies]
++ bar <- paste("y ~", paste(foo, collapse = " + "))
++ if (! any(inies)) bar <- paste(bar, "1")
++ baz <- glm(as.formula(bar), family = binomial)
++ beta <- rep(0, 4)
++ beta[c(TRUE, inies)] <- baz$coef
++ betas <- rbind(betas, beta)
++ }
+>
+> neighbors <- matrix(FALSE, nrow(models), nrow(models))
+> for (i in 1:nrow(neighbors)) {
++ for (j in 1:ncol(neighbors)) {
++ foo <- models[i, ]
++ bar <- models[j, ]
++ if (sum(foo != bar) == 1) neighbors[i, j] <- TRUE
++ }
++ }
+>
+> ludfun <- function(state, ...) {
++ stopifnot(is.numeric(state))
++ stopifnot(length(state) == ncol(models) + 2)
++ stopifnot(length(state) == ncol(models) + 2)
++ icomp <- state[1]
++ stopifnot(icomp == as.integer(icomp))
++ stopifnot(1 <= icomp && icomp <= nrow(models))
++ beta <- state[-1]
++ inies <- c(TRUE, as.logical(models[icomp, ]))
++ beta.logl <- beta
++ beta.logl[! inies] <- 0
++ eta <- as.numeric(modmat %*% beta.logl)
++ logp <- ifelse(eta < 0, eta - log1p(exp(eta)), - log1p(exp(- eta)))
++ logq <- ifelse(eta < 0, - log1p(exp(eta)), - eta - log1p(exp(- eta)))
++ logl <- sum(logp[y == 1]) + sum(logq[y == 0])
++ val <- logl - sum(beta^2) / 2
++ return(val)
++ }
+>
+> ludval <- NULL
+> for (i in 1:nrow(models)) ludval <- c(ludval, ludfun(c(i, betas[i, ])))
+> all(is.finite(ludval))
+[1] TRUE
+>
+>
+> out <- temper(ludfun, initial = betas, neighbors = neighbors, nbatch = 20,
++ blen = 10, nspac = 5, scale = 0.56789, parallel = TRUE, debug = TRUE)
+>
+> names(out)
+ [1] "lud" "initial" "neighbors" "nbatch"
+ [5] "blen" "nspac" "scale" "outfun"
+ [9] "debug" "parallel" "initial.seed" "final.seed"
+[13] "time" "batch" "acceptx" "accepti"
+[17] "initial" "final" "which" "unif.which"
+[21] "state" "log.hastings" "unif.hastings" "proposal"
+[25] "acceptd" "norm" "unif.choose" "coproposal"
+>
+> ### check decision about within-component or jump/swap
+>
+> identical(out$unif.which < 0.5, out$which)
+[1] TRUE
+>
+> identical(out$which, out$proposal[ , 1] == out$coproposal[ , 1])
+[1] TRUE
+>
+> ### check proposal and coproposal are actually current state or part thereof
+>
+> prop <- out$proposal
+> coprop <- out$coproposal
+> prop.i <- prop[ , 1]
+> coprop.i <- coprop[ , 1]
+> alt.prop <- prop
+> alt.coprop <- coprop
+> for (i in 1:nrow(prop)) {
++ alt.prop[i, ] <- c(prop.i[i], out$state[i, prop.i[i], ])
++ alt.coprop[i, ] <- c(coprop.i[i], out$state[i, coprop.i[i], ])
++ }
+> identical(coprop, alt.coprop)
+[1] TRUE
+> identical(prop[! out$which, ], alt.prop[! out$which, ])
+[1] TRUE
+> identical(prop[out$which, 1], alt.prop[out$which, 1])
+[1] TRUE
+>
+> ### check hastings ratio calculated correctly
+>
+> foo <- apply(prop, 1, ludfun)
+> fooco <- apply(coprop, 1, ludfun)
+> prop[ , 1] <- out$coproposal[ , 1]
+> coprop[ , 1] <- out$proposal[ , 1]
+> foo.swap <- apply(prop, 1, ludfun)
+> fooco.swap <- apply(coprop, 1, ludfun)
+> log.haste <- ifelse(out$which, foo - fooco,
++ foo.swap + fooco.swap - foo - fooco)
+> all.equal(log.haste, out$log.hastings)
+[1] TRUE
+>
+> ### check hastings rejection decided correctly
+>
+> identical(out$log.hastings >= 0, is.na(out$unif.hastings))
+[1] TRUE
+> all(out$log.hastings < 0 | out$acceptd)
+[1] TRUE
+> identical(out$acceptd,
++ out$log.hastings >= 0 | out$unif.hastings < exp(out$log.hastings))
+[1] TRUE
+>
+> ### check acceptance carried out or not (according to decision) correctly
+>
+> before <- out$state
+> after <- before
+> after[- dim(after)[1], , ] <- before[-1, , ]
+> after[dim(after)[1], , ] <- out$final
+> my.after <- before
+> for (i in 1:length(out$acceptd)) {
++ if (out$acceptd[i]) {
++ if (out$which[i]) {
++ j <- out$proposal[i, 1]
++ my.after[i, j, ] <- out$proposal[i, -1]
++ } else {
++ j <- out$proposal[i, 1]
++ k <- out$coproposal[i, 1]
++ my.after[i, j, ] <- out$coproposal[i, -1]
++ my.after[i, k, ] <- out$proposal[i, -1]
++ }
++ }
++ }
+> identical(after, my.after)
+[1] TRUE
+>
+> ### check within-component proposal
+>
+> my.coproposal.within <- out$coproposal[out$which, ]
+> proposal.within <- out$proposal[out$which, ]
+> my.z <- out$norm[out$which, ]
+> my.proposal.within <- my.coproposal.within
+> my.proposal.within[ , -1] <- my.coproposal.within[ , -1] + out$scale * my.z
+> all.equal(proposal.within, my.proposal.within)
+[1] TRUE
+>
+> my.unif.choose <- out$unif.choose[out$which, 1]
+> my.i <- floor(nrow(models) * my.unif.choose) + 1
+> all(1 <= my.i & my.i <= nrow(models))
+[1] TRUE
+> identical(my.i, my.coproposal.within[ , 1])
+[1] TRUE
+>
+> ### check swap proposal
+>
+> coproposal.swap <- out$coproposal[! out$which, ]
+> proposal.swap <- out$proposal[! out$which, ]
+> unif.choose.swap <- out$unif.choose[! out$which, ]
+> my.i <- floor(nrow(models) * unif.choose.swap[ , 1]) + 1
+> nneighbors <- apply(out$neighbors, 1, sum)
+> my.nneighbors <- nneighbors[my.i]
+> my.k <- floor(my.nneighbors * unif.choose.swap[ , 2]) + 1
+> my.j <- my.k
+> foo <- seq(1, ncol(out$neighbors))
+> for (i in seq(along = my.j)) {
++ my.j[i] <- (foo[out$neighbors[my.i[i], ]])[my.k[i]]
++ }
+> identical(coproposal.swap[ , 1], my.i)
+[1] TRUE
+> identical(proposal.swap[ , 1], my.j)
+[1] TRUE
+>
+> ### check standard normal and uniform random numbers are as purported
+>
+> save.Random.seed <- .Random.seed
+> .Random.seed <- out$initial.seed
+>
+> nx <- ncol(out$initial)
+> niter <- out$nbatch * out$blen * out$nspac
+> my.norm <- matrix(NA, nrow = nrow(out$norm), ncol = ncol(out$norm))
+> my.unif.which <- rep(NA, niter)
+> my.unif.hastings <- rep(NA, niter)
+> my.unif.choose <- matrix(NA, niter, 2)
+> for (iiter in 1:niter) {
++ my.unif.which[iiter] <- runif(1)
++ if (out$which[iiter]) {
++ my.unif.choose[iiter, 1] <- runif(1)
++ my.norm[iiter, ] <- rnorm(nx)
++ if (out$log.hastings[iiter] < 0) my.unif.hastings[iiter] <- runif(1)
++ } else {
++ my.unif.choose[iiter, ] <- runif(2)
++ if (out$log.hastings[iiter] < 0) my.unif.hastings[iiter] <- runif(1)
++ }
++ }
+> identical(my.norm, out$norm)
+[1] TRUE
+> identical(my.unif.which, out$unif.which)
+[1] TRUE
+> identical(my.unif.hastings, out$unif.hastings)
+[1] TRUE
+> identical(my.unif.choose, out$unif.choose)
+[1] TRUE
+>
+> .Random.seed <- save.Random.seed
+>
+> ### check batch means
+>
+> foo <- after[seq(1, niter) %% out$nspac == 0, , ]
+> foo <- array(as.vector(foo), dim = c(out$blen, out$nbatch, dim(foo)[2:3]))
+> foo <- apply(foo, c(2, 3, 4), mean)
+> all.equal(foo, out$batch)
+[1] TRUE
+>
+> ### check acceptance rates
+>
+> accept.within <- out$acceptd[out$which]
+> my.i.within <- out$coproposal[out$which, 1]
+> my.acceptx <- as.vector(sapply(split(accept.within, my.i.within), mean))
+> identical(my.acceptx, out$acceptx)
+[1] TRUE
+>
+> accept.swap <- out$acceptd[! out$which]
+> my.i.swap <- out$coproposal[! out$which, 1]
+> my.j.swap <- out$proposal[! out$which, 1]
+> nmodel <- nrow(out$neighbors)
+> my.accepti <- matrix(NA, nmodel, nmodel)
+> for (i in 1:nmodel) {
++ for (j in 1:nmodel) {
++ if (out$neighbors[i, j]) {
++ my.accepti[i, j] <-
++ mean(accept.swap[my.i.swap == i & my.j.swap == j])
++ }
++ }
++ }
+> identical(my.accepti, out$accepti)
+[1] TRUE
+>
+> ### check scale vector
+>
+> nx <- ncol(models) + 1
+> newscale <- rnorm(nx, 0.5, 0.1)
+>
+> out <- temper(out, scale = newscale)
+>
+> my.coproposal.within <- out$coproposal[out$which, ]
+> proposal.within <- out$proposal[out$which, ]
+> my.z <- out$norm[out$which, ]
+> my.proposal.within <- my.coproposal.within
+> my.proposal.within[ , -1] <- my.coproposal.within[ , -1] +
++ sweep(my.z, 2, out$scale, "*")
+> all.equal(proposal.within, my.proposal.within)
+[1] TRUE
+>
+> ### check scale matrix
+>
+> matscale <- matrix(rnorm(nx * nx, 0.0, 0.1), nx, nx)
+> diag(matscale) <- 0.56789
+>
+> out <- temper(out, scale = matscale)
+>
+> my.coproposal.within <- out$coproposal[out$which, ]
+> proposal.within <- out$proposal[out$which, ]
+> my.z <- out$norm[out$which, ]
+> my.proposal.within <- my.coproposal.within
+> my.proposal.within[ , -1] <- my.coproposal.within[ , -1] +
++ my.z %*% t(out$scale)
+> all.equal(proposal.within, my.proposal.within)
+[1] TRUE
+>
+> ### check scale list
+>
+> lisztscale <- list(0.56789, newscale, matscale, matscale, newscale,
++ 0.98765, 0.98765, newscale)
+>
+> out <- temper(out, scale = lisztscale)
+>
+> my.coproposal.within <- out$coproposal[out$which, ]
+> proposal.within <- out$proposal[out$which, ]
+> my.z <- out$norm[out$which, ]
+> my.proposal.within <- my.coproposal.within
+> for (iiter in 1:nrow(my.z)) {
++ my.i <- my.coproposal.within[iiter, 1]
++ my.scale <- out$scale[[my.i]]
++ if (is.matrix(my.scale)) {
++ my.proposal.within[iiter, -1] <- my.coproposal.within[iiter, -1] +
++ my.z[iiter, , drop = FALSE] %*% t(my.scale)
++ } else {
++ my.proposal.within[iiter, -1] <- my.coproposal.within[iiter, -1] +
++ my.z[iiter, ] * my.scale
++ }
++ }
+> all.equal(proposal.within, my.proposal.within)
+[1] TRUE
+>
+> ### check outfun
+>
+> outfun <- function(state, icomp, ...) {
++ stopifnot(is.matrix(state))
++ stopifnot(is.numeric(state))
++ nx <- ncol(betas)
++ ncomp <- nrow(betas)
++ stopifnot(ncol(state) == nx)
++ stopifnot(nrow(state) == ncomp)
++ stopifnot(1 <= icomp && icomp <= ncomp)
++ foo <- state[icomp, ]
++ bar <- foo^2
++ return(c(foo, bar))
++ }
+>
+> out <- temper(out, outfun = outfun, icomp = 4)
+>
+> before <- out$state
+> after <- before
+> after[- dim(after)[1], , ] <- before[-1, , ]
+> after[dim(after)[1], , ] <- out$final
+> outies <- apply(after, 1, outfun, icomp = 4)
+> outies <- t(outies)
+>
+> foo <- outies[seq(1, niter) %% out$nspac == 0, ]
+> foo <- array(as.vector(foo), dim = c(out$blen, out$nbatch, dim(foo)[2]))
+> foo <- apply(foo, c(2, 3), mean)
+> all.equal(foo, out$batch)
+[1] TRUE
+>
+>
diff --git a/tests/temp-ser-witch.R b/tests/temp-ser-witch.R
new file mode 100644
index 0000000..fa6d414
--- /dev/null
+++ b/tests/temp-ser-witch.R
@@ -0,0 +1,102 @@
+
+ library(mcmc)
+
+ set.seed(42)
+
+ d <- 3
+ witch.which <- 1 - (1 / 2)^(1 / d) * (1 / 4)^(seq(0, 5) / d)
+ witch.which
+
+ ncomp <- length(witch.which)
+
+ neighbors <- matrix(FALSE, ncomp, ncomp)
+ neighbors[row(neighbors) == col(neighbors) + 1] <- TRUE
+ neighbors[row(neighbors) == col(neighbors) - 1] <- TRUE
+ neighbors[row(neighbors) == col(neighbors) + 2] <- TRUE
+ neighbors[row(neighbors) == col(neighbors) - 2] <- TRUE
+
+ ludfun <- function(state) {
+ stopifnot(is.numeric(state))
+ stopifnot(length(state) == d + 1)
+ icomp <- state[1]
+ stopifnot(icomp == as.integer(icomp))
+ stopifnot(1 <= icomp && icomp <= ncomp)
+ theta <- state[-1]
+ if (any(abs(theta) > 1.0)) return(-Inf)
+ bnd <- witch.which[icomp]
+ if(bnd >= 1.0)
+ stop(sprintf("witch.which[%d] >= 1.0", icomp))
+ if(bnd <= 0.0)
+ stop(sprintf("witch.which[%d] <= 0.0", icomp))
+ if (all(abs(theta) > bnd))
+ return(- (d + 1) * log(2) - d * log(1 - bnd))
+ return(- (d + 1) * log(2) - log1p(- (1 - bnd)^d))
+ }
+
+ initial <- c(1, rep(0, d))
+
+ out <- temper(ludfun, initial = initial, neighbors = neighbors,
+ nbatch = 50, blen = 13, nspac = 7, scale = 0.3456789)
+
+ names(out)
+
+ out$acceptx
+
+ out$accepti
+
+ colMeans(out$ibatch)
+
+ ### check that have prob 1 / 2 for corners
+
+ outfun <- function(state) {
+ stopifnot(is.numeric(state))
+ icomp <- state[1]
+ stopifnot(icomp == as.integer(icomp))
+ stopifnot(1 <= icomp && icomp <= length(witch.which))
+ theta <- state[-1]
+ foo <- all(abs(theta) > witch.which[icomp])
+ bar <- rep(0, length(witch.which))
+ baz <- rep(0, length(witch.which))
+ bar[icomp] <- as.numeric(foo)
+ baz[icomp] <- 1
+ return(c(bar, baz))
+ }
+
+ out <- temper(out, blen = 103, outfun = outfun, debug = TRUE)
+
+ eta.batch <- out$batch[ , seq(1, ncomp)]
+ noo.batch <- out$batch[ , seq(ncomp + 1, ncomp + ncomp)]
+ eta <- colMeans(eta.batch)
+ noo <- colMeans(noo.batch)
+ mu <- eta / noo
+ eta
+ noo
+ mu
+
+ eta.batch.rel <- sweep(eta.batch, 2, eta, "/")
+ noo.batch.rel <- sweep(noo.batch, 2, noo, "/")
+ mu.batch.rel <- eta.batch.rel - noo.batch.rel
+
+ mu.mcse.rel <- apply(mu.batch.rel, 2, sd) / sqrt(out$nbatch)
+ mu.mcse.rel
+
+ foo <- cbind(mu, mu * mu.mcse.rel)
+ colnames(foo) <- c("means", "MCSE")
+ foo
+
+ ### check decision about within-component or jump/swap
+
+ identical(out$unif.which < 0.5, out$which)
+
+ identical(out$which, out$proposal[ , 1] == out$state[ , 1])
+
+ ### check hastings ratio calculated correctly
+
+ n <- apply(neighbors, 1, sum)
+ i <- out$state[ , 1]
+ istar <- out$proposal[ , 1]
+ foo <- apply(out$state, 1, ludfun)
+ bar <- apply(out$proposal, 1, ludfun)
+ my.log.hastings <- bar - foo - log(n[istar]) + log(n[i])
+ all.equal(my.log.hastings, out$log.hastings)
+
diff --git a/tests/temp-ser-witch.Rout.save b/tests/temp-ser-witch.Rout.save
new file mode 100644
index 0000000..581194e
--- /dev/null
+++ b/tests/temp-ser-witch.Rout.save
@@ -0,0 +1,149 @@
+
+R version 2.13.1 (2011-07-08)
+Copyright (C) 2011 The R Foundation for Statistical Computing
+ISBN 3-900051-07-0
+Platform: x86_64-pc-linux-gnu (64-bit)
+
+R is free software and comes with ABSOLUTELY NO WARRANTY.
+You are welcome to redistribute it under certain conditions.
+Type 'license()' or 'licence()' for distribution details.
+
+R is a collaborative project with many contributors.
+Type 'contributors()' for more information and
+'citation()' on how to cite R or R packages in publications.
+
+Type 'demo()' for some demos, 'help()' for on-line help, or
+'help.start()' for an HTML browser interface to help.
+Type 'q()' to quit R.
+
+>
+> library(mcmc)
+>
+> set.seed(42)
+>
+> d <- 3
+> witch.which <- 1 - (1 / 2)^(1 / d) * (1 / 4)^(seq(0, 5) / d)
+> witch.which
+[1] 0.2062995 0.5000000 0.6850197 0.8015749 0.8750000 0.9212549
+>
+> ncomp <- length(witch.which)
+>
+> neighbors <- matrix(FALSE, ncomp, ncomp)
+> neighbors[row(neighbors) == col(neighbors) + 1] <- TRUE
+> neighbors[row(neighbors) == col(neighbors) - 1] <- TRUE
+> neighbors[row(neighbors) == col(neighbors) + 2] <- TRUE
+> neighbors[row(neighbors) == col(neighbors) - 2] <- TRUE
+>
+> ludfun <- function(state) {
++ stopifnot(is.numeric(state))
++ stopifnot(length(state) == d + 1)
++ icomp <- state[1]
++ stopifnot(icomp == as.integer(icomp))
++ stopifnot(1 <= icomp && icomp <= ncomp)
++ theta <- state[-1]
++ if (any(abs(theta) > 1.0)) return(-Inf)
++ bnd <- witch.which[icomp]
++ if(bnd >= 1.0)
++ stop(sprintf("witch.which[%d] >= 1.0", icomp))
++ if(bnd <= 0.0)
++ stop(sprintf("witch.which[%d] <= 0.0", icomp))
++ if (all(abs(theta) > bnd))
++ return(- (d + 1) * log(2) - d * log(1 - bnd))
++ return(- (d + 1) * log(2) - log1p(- (1 - bnd)^d))
++ }
+>
+> initial <- c(1, rep(0, d))
+>
+> out <- temper(ludfun, initial = initial, neighbors = neighbors,
++ nbatch = 50, blen = 13, nspac = 7, scale = 0.3456789)
+>
+> names(out)
+ [1] "lud" "initial" "neighbors" "nbatch" "blen"
+ [6] "nspac" "scale" "outfun" "debug" "parallel"
+[11] "initial.seed" "final.seed" "time" "batch" "acceptx"
+[16] "accepti" "initial" "final" "ibatch"
+>
+> out$acceptx
+[1] 0.6388889 0.4385246 0.3631714 0.4885246 0.4709677 0.4735516
+>
+> out$accepti
+ [,1] [,2] [,3] [,4] [,5] [,6]
+[1,] NA 0.5071770 0.2727273 NA NA NA
+[2,] 0.7070064 NA 0.4355828 0.4186047 NA NA
+[3,] 0.5816327 0.8039216 NA 0.5888889 0.5662651 NA
+[4,] NA 0.7415730 0.8571429 NA 0.7857143 0.6626506
+[5,] NA NA 0.5204082 0.6516854 NA 0.8378378
+[6,] NA NA NA 0.3515152 0.5056818 NA
+>
+> colMeans(out$ibatch)
+[1] 0.1830769 0.2153846 0.1630769 0.1369231 0.1353846 0.1661538
+>
+> ### check that have prob 1 / 2 for corners
+>
+> outfun <- function(state) {
++ stopifnot(is.numeric(state))
++ icomp <- state[1]
++ stopifnot(icomp == as.integer(icomp))
++ stopifnot(1 <= icomp && icomp <= length(witch.which))
++ theta <- state[-1]
++ foo <- all(abs(theta) > witch.which[icomp])
++ bar <- rep(0, length(witch.which))
++ baz <- rep(0, length(witch.which))
++ bar[icomp] <- as.numeric(foo)
++ baz[icomp] <- 1
++ return(c(bar, baz))
++ }
+>
+> out <- temper(out, blen = 103, outfun = outfun, debug = TRUE)
+>
+> eta.batch <- out$batch[ , seq(1, ncomp)]
+> noo.batch <- out$batch[ , seq(ncomp + 1, ncomp + ncomp)]
+> eta <- colMeans(eta.batch)
+> noo <- colMeans(noo.batch)
+> mu <- eta / noo
+> eta
+[1] 0.06660194 0.06388350 0.05766990 0.06563107 0.10368932 0.22912621
+> noo
+[1] 0.1365049 0.1258252 0.1293204 0.1370874 0.1716505 0.2996117
+> mu
+[1] 0.4879090 0.5077160 0.4459459 0.4787535 0.6040724 0.7647440
+>
+> eta.batch.rel <- sweep(eta.batch, 2, eta, "/")
+> noo.batch.rel <- sweep(noo.batch, 2, noo, "/")
+> mu.batch.rel <- eta.batch.rel - noo.batch.rel
+>
+> mu.mcse.rel <- apply(mu.batch.rel, 2, sd) / sqrt(out$nbatch)
+> mu.mcse.rel
+[1] 0.05010927 0.07897321 0.09678339 0.12636113 0.11261781 0.07082685
+>
+> foo <- cbind(mu, mu * mu.mcse.rel)
+> colnames(foo) <- c("means", "MCSE")
+> foo
+ means MCSE
+[1,] 0.4879090 0.02444876
+[2,] 0.5077160 0.04009596
+[3,] 0.4459459 0.04316016
+[4,] 0.4787535 0.06049584
+[5,] 0.6040724 0.06802931
+[6,] 0.7647440 0.05416441
+>
+> ### check decision about within-component or jump/swap
+>
+> identical(out$unif.which < 0.5, out$which)
+[1] TRUE
+>
+> identical(out$which, out$proposal[ , 1] == out$state[ , 1])
+[1] TRUE
+>
+> ### check hastings ratio calculated correctly
+>
+> n <- apply(neighbors, 1, sum)
+> i <- out$state[ , 1]
+> istar <- out$proposal[ , 1]
+> foo <- apply(out$state, 1, ludfun)
+> bar <- apply(out$proposal, 1, ludfun)
+> my.log.hastings <- bar - foo - log(n[istar]) + log(n[i])
+> all.equal(my.log.hastings, out$log.hastings)
+[1] TRUE
+>
+>
diff --git a/tests/temp-ser.R b/tests/temp-ser.R
new file mode 100644
index 0000000..d327b69
--- /dev/null
+++ b/tests/temp-ser.R
@@ -0,0 +1,292 @@
+
+ library(mcmc)
+
+ set.seed(42)
+
+ data(foo)
+ attach(foo)
+
+ out <- glm(y ~ x1 + x2 + x3, family = binomial, x = TRUE)
+ summary(out)
+
+ modmat <- out$x
+
+ models <- cbind(rep(0:1, each = 4), rep(rep(0:1, times = 2), each = 2),
+ rep(0:1, times = 4))
+
+ exes <- paste("x", 1:3, sep = "")
+ models[nrow(models), ]
+ beta.initial <- c(nrow(models), out$coefficients)
+
+ neighbors <- matrix(FALSE, nrow(models), nrow(models))
+ for (i in 1:nrow(neighbors)) {
+ for (j in 1:ncol(neighbors)) {
+ foo <- models[i, ]
+ bar <- models[j, ]
+ if (sum(foo != bar) == 1) neighbors[i, j] <- TRUE
+ }
+ }
+ neighbors
+
+ ludfun <- function(state, log.pseudo.prior, ...) {
+ stopifnot(is.numeric(state))
+ stopifnot(length(state) == ncol(models) + 2)
+ icomp <- state[1]
+ stopifnot(icomp == as.integer(icomp))
+ stopifnot(1 <= icomp && icomp <= nrow(models))
+ stopifnot(is.numeric(log.pseudo.prior))
+ stopifnot(length(log.pseudo.prior) == nrow(models))
+ beta <- state[-1]
+ inies <- c(TRUE, as.logical(models[icomp, ]))
+ beta.logl <- beta
+ beta.logl[! inies] <- 0
+ eta <- as.numeric(modmat %*% beta.logl)
+ logp <- ifelse(eta < 0, eta - log1p(exp(eta)), - log1p(exp(- eta)))
+ logq <- ifelse(eta < 0, - log1p(exp(eta)), - eta - log1p(exp(- eta)))
+ logl <- sum(logp[y == 1]) + sum(logq[y == 0])
+ val <- logl - sum(beta^2) / 2 + log.pseudo.prior[icomp]
+ return(val)
+ }
+
+ qux <- c(25.01, 5.875, 9.028, 0.6959, 11.73, 2.367, 5.864, 0.0)
+
+ out <- temper(ludfun, initial = beta.initial, neighbors = neighbors,
+ nbatch = 25, blen = 20, nspac = 5, scale = 0.56789, debug = TRUE,
+ log.pseudo.prior = qux)
+
+ names(out)
+
+ apply(out$ibatch, 2, mean)
+
+ ### check decision about within-component or jump/swap
+
+ identical(out$unif.which < 0.5, out$which)
+
+ identical(out$which, out$proposal[ , 1] == out$state[ , 1])
+
+ ### check hastings ratio calculated correctly
+
+ foo <- apply(out$state, 1, ludfun, log.pseudo.prior = qux)
+ bar <- apply(out$proposal, 1, ludfun, log.pseudo.prior = qux)
+ all.equal(bar - foo, out$log.hastings)
+
+ ### check hastings rejection decided correctly
+
+ identical(out$log.hastings >= 0, is.na(out$unif.hastings))
+ all(out$log.hastings < 0 | out$acceptd)
+ identical(out$acceptd,
+ out$log.hastings >= 0 | out$unif.hastings < exp(out$log.hastings))
+
+ ### check acceptance carried out or not (according to decision) correctly
+
+ before <- out$state
+ after <- before
+ after[- dim(after)[1], ] <- before[-1, ]
+ after[dim(after)[1], ] <- out$final
+ my.after <- before
+ my.after[out$acceptd, ] <- out$proposal[out$acceptd, ]
+ identical(after, my.after)
+
+ ### check within-component proposal
+
+ my.coproposal.within <- out$state[out$which, ]
+ proposal.within <- out$proposal[out$which, ]
+ my.z <- out$norm[out$which, ]
+ my.proposal.within <- my.coproposal.within
+ my.proposal.within[ , -1] <- my.coproposal.within[ , -1] + out$scale * my.z
+ all.equal(proposal.within, my.proposal.within)
+
+ ### check swap proposal
+
+ coproposal.swap <- out$state[! out$which, ]
+ proposal.swap <- out$proposal[! out$which, ]
+ unif.choose.swap <- out$unif.choose[! out$which]
+ my.i <- coproposal.swap[ , 1]
+ nneighbors <- apply(out$neighbors, 1, sum)
+ my.nneighbors <- nneighbors[my.i]
+ my.k <- floor(my.nneighbors * unif.choose.swap) + 1
+ my.j <- my.k
+ foo <- seq(1, ncol(out$neighbors))
+ for (i in seq(along = my.j)) {
+ my.j[i] <- (foo[out$neighbors[my.i[i], ]])[my.k[i]]
+ }
+ identical(coproposal.swap[ , 1], my.i)
+ identical(proposal.swap[ , 1], my.j)
+
+ ### check standard normal and uniform random numbers are as purported
+
+ save.Random.seed <- .Random.seed
+ .Random.seed <- out$initial.seed
+
+ nx <- length(out$initial) - 1
+ niter <- out$nbatch * out$blen * out$nspac
+ my.norm <- matrix(NA, nrow = nrow(out$norm), ncol = ncol(out$norm))
+ my.unif.which <- rep(NA, niter)
+ my.unif.hastings <- rep(NA, niter)
+ my.unif.choose <- rep(NA, niter)
+ for (iiter in 1:niter) {
+ my.unif.which[iiter] <- runif(1)
+ if (out$which[iiter]) {
+ my.norm[iiter, ] <- rnorm(nx)
+ if (out$log.hastings[iiter] < 0) my.unif.hastings[iiter] <- runif(1)
+ } else {
+ my.unif.choose[iiter] <- runif(1)
+ if (out$log.hastings[iiter] < 0) my.unif.hastings[iiter] <- runif(1)
+ }
+ }
+ identical(my.norm, out$norm)
+ identical(my.unif.which, out$unif.which)
+ identical(my.unif.hastings, out$unif.hastings)
+ identical(my.unif.choose, out$unif.choose)
+
+ .Random.seed <- save.Random.seed
+
+ ### check batch means
+
+ my.xstate <- after[ , -1]
+ foo <- my.xstate[seq(1, niter) %% out$nspac == 0, ]
+ foo <- array(as.vector(foo), dim = c(out$blen, out$nbatch, dim(foo)[2]))
+ foo <- apply(foo, c(2, 3), mean)
+ all.equal(foo, out$batch)
+
+ ### check ibatch means
+
+ my.istate <- after[ , 1]
+ my.istate.matrix <- matrix(0, length(my.istate), nrow(models))
+ for (i in 1:nrow(my.istate.matrix))
+ my.istate.matrix[i, my.istate[i]] <- 1
+ foo <- my.istate.matrix[seq(1, niter) %% out$nspac == 0, ]
+ foo <- array(as.vector(foo), dim = c(out$blen, out$nbatch, dim(foo)[2]))
+ foo <- apply(foo, c(2, 3), mean)
+ all.equal(foo, out$ibatch)
+
+ ### check acceptance rates
+
+ nmodel <- nrow(out$neighbors)
+
+ accept.within <- out$acceptd[out$which]
+ my.i.within <- out$state[out$which, 1]
+ my.i.within.accept <- my.i.within[accept.within]
+ my.acceptx.numer <- tabulate(my.i.within.accept, nbins = nmodel)
+ my.acceptx.denom <- tabulate(my.i.within, nbins = nmodel)
+ my.acceptx <- my.acceptx.numer / my.acceptx.denom
+ identical(my.acceptx, out$acceptx)
+
+ accept.swap <- out$acceptd[! out$which]
+ my.i.swap <- out$state[! out$which, 1]
+ my.j.swap <- out$proposal[! out$which, 1]
+ my.accepti <- matrix(NA, nmodel, nmodel)
+ for (i in 1:nmodel) {
+ for (j in 1:nmodel) {
+ if (out$neighbors[i, j]) {
+ my.accepti[i, j] <-
+ mean(accept.swap[my.i.swap == i & my.j.swap == j])
+ }
+ }
+ }
+ identical(my.accepti, out$accepti)
+
+ ### check scale vector
+
+ nx <- ncol(models) + 1
+ newscale <- rnorm(nx, 0.5, 0.1)
+
+ out <- temper(out, scale = newscale, log.pseudo.prior = qux)
+
+ my.coproposal.within <- out$state[out$which, ]
+ proposal.within <- out$proposal[out$which, ]
+ my.z <- out$norm[out$which, ]
+ my.proposal.within <- my.coproposal.within
+ my.proposal.within[ , -1] <- my.coproposal.within[ , -1] +
+ sweep(my.z, 2, out$scale, "*")
+ all.equal(proposal.within, my.proposal.within)
+
+ ### check scale matrix
+
+ matscale <- matrix(rnorm(nx * nx, 0.0, 0.1), nx, nx)
+ diag(matscale) <- 0.56789
+
+ out <- temper(out, scale = matscale, log.pseudo.prior = qux)
+
+ my.coproposal.within <- out$state[out$which, ]
+ proposal.within <- out$proposal[out$which, ]
+ my.z <- out$norm[out$which, ]
+ my.proposal.within <- my.coproposal.within
+ my.proposal.within[ , -1] <- my.coproposal.within[ , -1] +
+ my.z %*% t(out$scale)
+ all.equal(proposal.within, my.proposal.within)
+
+ ### check scale list
+
+ lisztscale <- list(0.56789, newscale, matscale, matscale, newscale,
+ 0.98765, 0.98765, newscale)
+
+ out <- temper(out, scale = lisztscale, log.pseudo.prior = qux)
+
+ my.coproposal.within <- out$state[out$which, ]
+ proposal.within <- out$proposal[out$which, ]
+ my.z <- out$norm[out$which, ]
+ my.proposal.within <- my.coproposal.within
+ for (iiter in 1:nrow(my.z)) {
+ my.i <- my.coproposal.within[iiter, 1]
+ my.scale <- out$scale[[my.i]]
+ if (is.matrix(my.scale)) {
+ my.proposal.within[iiter, -1] <- my.coproposal.within[iiter, -1] +
+ my.z[iiter, , drop = FALSE] %*% t(my.scale)
+ } else {
+ my.proposal.within[iiter, -1] <- my.coproposal.within[iiter, -1] +
+ my.z[iiter, ] * my.scale
+ }
+ }
+ all.equal(proposal.within, my.proposal.within)
+
+ ### check outfun
+
+ outfun <- function(state, icomp) {
+ stopifnot(is.matrix(state))
+ stopifnot(is.numeric(state))
+ nx <- ncol(initial)
+ ncomp <- nrow(initial)
+ stopifnot(ncol(state) == nx)
+ stopifnot(nrow(state) == ncomp)
+ stopifnot(1 <= icomp & icomp <= ncomp)
+ foo <- state[icomp, ]
+ bar <- foo^2
+ return(c(foo, bar))
+ }
+
+ ncomp <- nrow(models)
+ nx <- length(beta.initial) - 1
+
+ outfun <- function(state, icomp, ...) {
+ stopifnot(is.numeric(state))
+ stopifnot(length(state) == nx + 1)
+ istate <- state[1]
+ stopifnot(istate == as.integer(istate))
+ stopifnot(1 <= istate && istate <= ncomp)
+ stopifnot(1 <= icomp && icomp <= ncomp)
+ if (istate == icomp) {
+ foo <- state[-1]
+ } else {
+ foo <- rep(0, nx)
+ }
+ bar <- foo^2
+ return(c(foo, bar))
+ }
+
+ out <- temper(ludfun, initial = out$final, neighbors = neighbors,
+ nbatch = 25, blen = 20, nspac = 5, scale = 0.56789, debug = TRUE,
+ outfun = outfun, log.pseudo.prior = qux, icomp = 4)
+
+ before <- out$state
+ after <- before
+ after[- dim(after)[1], ] <- before[-1, ]
+ after[dim(after)[1], ] <- out$final
+ outies <- apply(after, 1, outfun, icomp = 4)
+ outies <- t(outies)
+
+ foo <- outies[seq(1, niter) %% out$nspac == 0, ]
+ foo <- array(as.vector(foo), dim = c(out$blen, out$nbatch, dim(foo)[2]))
+ foo <- apply(foo, c(2, 3), mean)
+ all.equal(foo, out$batch)
+
diff --git a/tests/temp-ser.Rout.save b/tests/temp-ser.Rout.save
new file mode 100644
index 0000000..f7eece0
--- /dev/null
+++ b/tests/temp-ser.Rout.save
@@ -0,0 +1,378 @@
+
+R version 3.2.1 (2015-06-18) -- "World-Famous Astronaut"
+Copyright (C) 2015 The R Foundation for Statistical Computing
+Platform: i686-pc-linux-gnu (32-bit)
+
+R is free software and comes with ABSOLUTELY NO WARRANTY.
+You are welcome to redistribute it under certain conditions.
+Type 'license()' or 'licence()' for distribution details.
+
+R is a collaborative project with many contributors.
+Type 'contributors()' for more information and
+'citation()' on how to cite R or R packages in publications.
+
+Type 'demo()' for some demos, 'help()' for on-line help, or
+'help.start()' for an HTML browser interface to help.
+Type 'q()' to quit R.
+
+>
+> library(mcmc)
+>
+> set.seed(42)
+>
+> data(foo)
+> attach(foo)
+>
+> out <- glm(y ~ x1 + x2 + x3, family = binomial, x = TRUE)
+> summary(out)
+
+Call:
+glm(formula = y ~ x1 + x2 + x3, family = binomial, x = TRUE)
+
+Deviance Residuals:
+ Min 1Q Median 3Q Max
+-2.0371 -0.6337 0.2394 0.6685 1.9599
+
+Coefficients:
+ Estimate Std. Error z value Pr(>|z|)
+(Intercept) 0.5772 0.2766 2.087 0.036930 *
+x1 0.3362 0.4256 0.790 0.429672
+x2 0.8475 0.4701 1.803 0.071394 .
+x3 1.5143 0.4426 3.422 0.000622 ***
+---
+Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
+
+(Dispersion parameter for binomial family taken to be 1)
+
+ Null deviance: 134.602 on 99 degrees of freedom
+Residual deviance: 86.439 on 96 degrees of freedom
+AIC: 94.439
+
+Number of Fisher Scoring iterations: 5
+
+>
+> modmat <- out$x
+>
+> models <- cbind(rep(0:1, each = 4), rep(rep(0:1, times = 2), each = 2),
++ rep(0:1, times = 4))
+>
+> exes <- paste("x", 1:3, sep = "")
+> models[nrow(models), ]
+[1] 1 1 1
+> beta.initial <- c(nrow(models), out$coefficients)
+>
+> neighbors <- matrix(FALSE, nrow(models), nrow(models))
+> for (i in 1:nrow(neighbors)) {
++ for (j in 1:ncol(neighbors)) {
++ foo <- models[i, ]
++ bar <- models[j, ]
++ if (sum(foo != bar) == 1) neighbors[i, j] <- TRUE
++ }
++ }
+> neighbors
+ [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8]
+[1,] FALSE TRUE TRUE FALSE TRUE FALSE FALSE FALSE
+[2,] TRUE FALSE FALSE TRUE FALSE TRUE FALSE FALSE
+[3,] TRUE FALSE FALSE TRUE FALSE FALSE TRUE FALSE
+[4,] FALSE TRUE TRUE FALSE FALSE FALSE FALSE TRUE
+[5,] TRUE FALSE FALSE FALSE FALSE TRUE TRUE FALSE
+[6,] FALSE TRUE FALSE FALSE TRUE FALSE FALSE TRUE
+[7,] FALSE FALSE TRUE FALSE TRUE FALSE FALSE TRUE
+[8,] FALSE FALSE FALSE TRUE FALSE TRUE TRUE FALSE
+>
+> ludfun <- function(state, log.pseudo.prior, ...) {
++ stopifnot(is.numeric(state))
++ stopifnot(length(state) == ncol(models) + 2)
++ icomp <- state[1]
++ stopifnot(icomp == as.integer(icomp))
++ stopifnot(1 <= icomp && icomp <= nrow(models))
++ stopifnot(is.numeric(log.pseudo.prior))
++ stopifnot(length(log.pseudo.prior) == nrow(models))
++ beta <- state[-1]
++ inies <- c(TRUE, as.logical(models[icomp, ]))
++ beta.logl <- beta
++ beta.logl[! inies] <- 0
++ eta <- as.numeric(modmat %*% beta.logl)
++ logp <- ifelse(eta < 0, eta - log1p(exp(eta)), - log1p(exp(- eta)))
++ logq <- ifelse(eta < 0, - log1p(exp(eta)), - eta - log1p(exp(- eta)))
++ logl <- sum(logp[y == 1]) + sum(logq[y == 0])
++ val <- logl - sum(beta^2) / 2 + log.pseudo.prior[icomp]
++ return(val)
++ }
+>
+> qux <- c(25.01, 5.875, 9.028, 0.6959, 11.73, 2.367, 5.864, 0.0)
+>
+> out <- temper(ludfun, initial = beta.initial, neighbors = neighbors,
++ nbatch = 25, blen = 20, nspac = 5, scale = 0.56789, debug = TRUE,
++ log.pseudo.prior = qux)
+>
+> names(out)
+ [1] "lud" "initial" "neighbors" "nbatch"
+ [5] "blen" "nspac" "scale" "outfun"
+ [9] "debug" "parallel" "initial.seed" "final.seed"
+[13] "time" "batch" "acceptx" "accepti"
+[17] "initial" "final" "ibatch" "which"
+[21] "unif.which" "state" "log.hastings" "unif.hastings"
+[25] "proposal" "acceptd" "norm" "unif.choose"
+>
+> apply(out$ibatch, 2, mean)
+[1] 0.776 0.170 0.000 0.006 0.024 0.010 0.004 0.010
+>
+> ### check decision about within-component or jump/swap
+>
+> identical(out$unif.which < 0.5, out$which)
+[1] TRUE
+>
+> identical(out$which, out$proposal[ , 1] == out$state[ , 1])
+[1] TRUE
+>
+> ### check hastings ratio calculated correctly
+>
+> foo <- apply(out$state, 1, ludfun, log.pseudo.prior = qux)
+> bar <- apply(out$proposal, 1, ludfun, log.pseudo.prior = qux)
+> all.equal(bar - foo, out$log.hastings)
+[1] TRUE
+>
+> ### check hastings rejection decided correctly
+>
+> identical(out$log.hastings >= 0, is.na(out$unif.hastings))
+[1] TRUE
+> all(out$log.hastings < 0 | out$acceptd)
+[1] TRUE
+> identical(out$acceptd,
++ out$log.hastings >= 0 | out$unif.hastings < exp(out$log.hastings))
+[1] TRUE
+>
+> ### check acceptance carried out or not (according to decision) correctly
+>
+> before <- out$state
+> after <- before
+> after[- dim(after)[1], ] <- before[-1, ]
+> after[dim(after)[1], ] <- out$final
+> my.after <- before
+> my.after[out$acceptd, ] <- out$proposal[out$acceptd, ]
+> identical(after, my.after)
+[1] TRUE
+>
+> ### check within-component proposal
+>
+> my.coproposal.within <- out$state[out$which, ]
+> proposal.within <- out$proposal[out$which, ]
+> my.z <- out$norm[out$which, ]
+> my.proposal.within <- my.coproposal.within
+> my.proposal.within[ , -1] <- my.coproposal.within[ , -1] + out$scale * my.z
+> all.equal(proposal.within, my.proposal.within)
+[1] TRUE
+>
+> ### check swap proposal
+>
+> coproposal.swap <- out$state[! out$which, ]
+> proposal.swap <- out$proposal[! out$which, ]
+> unif.choose.swap <- out$unif.choose[! out$which]
+> my.i <- coproposal.swap[ , 1]
+> nneighbors <- apply(out$neighbors, 1, sum)
+> my.nneighbors <- nneighbors[my.i]
+> my.k <- floor(my.nneighbors * unif.choose.swap) + 1
+> my.j <- my.k
+> foo <- seq(1, ncol(out$neighbors))
+> for (i in seq(along = my.j)) {
++ my.j[i] <- (foo[out$neighbors[my.i[i], ]])[my.k[i]]
++ }
+> identical(coproposal.swap[ , 1], my.i)
+[1] TRUE
+> identical(proposal.swap[ , 1], my.j)
+[1] TRUE
+>
+> ### check standard normal and uniform random numbers are as purported
+>
+> save.Random.seed <- .Random.seed
+> .Random.seed <- out$initial.seed
+>
+> nx <- length(out$initial) - 1
+> niter <- out$nbatch * out$blen * out$nspac
+> my.norm <- matrix(NA, nrow = nrow(out$norm), ncol = ncol(out$norm))
+> my.unif.which <- rep(NA, niter)
+> my.unif.hastings <- rep(NA, niter)
+> my.unif.choose <- rep(NA, niter)
+> for (iiter in 1:niter) {
++ my.unif.which[iiter] <- runif(1)
++ if (out$which[iiter]) {
++ my.norm[iiter, ] <- rnorm(nx)
++ if (out$log.hastings[iiter] < 0) my.unif.hastings[iiter] <- runif(1)
++ } else {
++ my.unif.choose[iiter] <- runif(1)
++ if (out$log.hastings[iiter] < 0) my.unif.hastings[iiter] <- runif(1)
++ }
++ }
+> identical(my.norm, out$norm)
+[1] TRUE
+> identical(my.unif.which, out$unif.which)
+[1] TRUE
+> identical(my.unif.hastings, out$unif.hastings)
+[1] TRUE
+> identical(my.unif.choose, out$unif.choose)
+[1] TRUE
+>
+> .Random.seed <- save.Random.seed
+>
+> ### check batch means
+>
+> my.xstate <- after[ , -1]
+> foo <- my.xstate[seq(1, niter) %% out$nspac == 0, ]
+> foo <- array(as.vector(foo), dim = c(out$blen, out$nbatch, dim(foo)[2]))
+> foo <- apply(foo, c(2, 3), mean)
+> all.equal(foo, out$batch)
+[1] TRUE
+>
+> ### check ibatch means
+>
+> my.istate <- after[ , 1]
+> my.istate.matrix <- matrix(0, length(my.istate), nrow(models))
+> for (i in 1:nrow(my.istate.matrix))
++ my.istate.matrix[i, my.istate[i]] <- 1
+> foo <- my.istate.matrix[seq(1, niter) %% out$nspac == 0, ]
+> foo <- array(as.vector(foo), dim = c(out$blen, out$nbatch, dim(foo)[2]))
+> foo <- apply(foo, c(2, 3), mean)
+> all.equal(foo, out$ibatch)
+[1] TRUE
+>
+> ### check acceptance rates
+>
+> nmodel <- nrow(out$neighbors)
+>
+> accept.within <- out$acceptd[out$which]
+> my.i.within <- out$state[out$which, 1]
+> my.i.within.accept <- my.i.within[accept.within]
+> my.acceptx.numer <- tabulate(my.i.within.accept, nbins = nmodel)
+> my.acceptx.denom <- tabulate(my.i.within, nbins = nmodel)
+> my.acceptx <- my.acceptx.numer / my.acceptx.denom
+> identical(my.acceptx, out$acceptx)
+[1] TRUE
+>
+> accept.swap <- out$acceptd[! out$which]
+> my.i.swap <- out$state[! out$which, 1]
+> my.j.swap <- out$proposal[! out$which, 1]
+> my.accepti <- matrix(NA, nmodel, nmodel)
+> for (i in 1:nmodel) {
++ for (j in 1:nmodel) {
++ if (out$neighbors[i, j]) {
++ my.accepti[i, j] <-
++ mean(accept.swap[my.i.swap == i & my.j.swap == j])
++ }
++ }
++ }
+> identical(my.accepti, out$accepti)
+[1] TRUE
+>
+> ### check scale vector
+>
+> nx <- ncol(models) + 1
+> newscale <- rnorm(nx, 0.5, 0.1)
+>
+> out <- temper(out, scale = newscale, log.pseudo.prior = qux)
+>
+> my.coproposal.within <- out$state[out$which, ]
+> proposal.within <- out$proposal[out$which, ]
+> my.z <- out$norm[out$which, ]
+> my.proposal.within <- my.coproposal.within
+> my.proposal.within[ , -1] <- my.coproposal.within[ , -1] +
++ sweep(my.z, 2, out$scale, "*")
+> all.equal(proposal.within, my.proposal.within)
+[1] TRUE
+>
+> ### check scale matrix
+>
+> matscale <- matrix(rnorm(nx * nx, 0.0, 0.1), nx, nx)
+> diag(matscale) <- 0.56789
+>
+> out <- temper(out, scale = matscale, log.pseudo.prior = qux)
+>
+> my.coproposal.within <- out$state[out$which, ]
+> proposal.within <- out$proposal[out$which, ]
+> my.z <- out$norm[out$which, ]
+> my.proposal.within <- my.coproposal.within
+> my.proposal.within[ , -1] <- my.coproposal.within[ , -1] +
++ my.z %*% t(out$scale)
+> all.equal(proposal.within, my.proposal.within)
+[1] TRUE
+>
+> ### check scale list
+>
+> lisztscale <- list(0.56789, newscale, matscale, matscale, newscale,
++ 0.98765, 0.98765, newscale)
+>
+> out <- temper(out, scale = lisztscale, log.pseudo.prior = qux)
+>
+> my.coproposal.within <- out$state[out$which, ]
+> proposal.within <- out$proposal[out$which, ]
+> my.z <- out$norm[out$which, ]
+> my.proposal.within <- my.coproposal.within
+> for (iiter in 1:nrow(my.z)) {
++ my.i <- my.coproposal.within[iiter, 1]
++ my.scale <- out$scale[[my.i]]
++ if (is.matrix(my.scale)) {
++ my.proposal.within[iiter, -1] <- my.coproposal.within[iiter, -1] +
++ my.z[iiter, , drop = FALSE] %*% t(my.scale)
++ } else {
++ my.proposal.within[iiter, -1] <- my.coproposal.within[iiter, -1] +
++ my.z[iiter, ] * my.scale
++ }
++ }
+> all.equal(proposal.within, my.proposal.within)
+[1] TRUE
+>
+> ### check outfun
+>
+> outfun <- function(state, icomp) {
++ stopifnot(is.matrix(state))
++ stopifnot(is.numeric(state))
++ nx <- ncol(initial)
++ ncomp <- nrow(initial)
++ stopifnot(ncol(state) == nx)
++ stopifnot(nrow(state) == ncomp)
++ stopifnot(1 <= icomp & icomp <= ncomp)
++ foo <- state[icomp, ]
++ bar <- foo^2
++ return(c(foo, bar))
++ }
+>
+> ncomp <- nrow(models)
+> nx <- length(beta.initial) - 1
+>
+> outfun <- function(state, icomp, ...) {
++ stopifnot(is.numeric(state))
++ stopifnot(length(state) == nx + 1)
++ istate <- state[1]
++ stopifnot(istate == as.integer(istate))
++ stopifnot(1 <= istate && istate <= ncomp)
++ stopifnot(1 <= icomp && icomp <= ncomp)
++ if (istate == icomp) {
++ foo <- state[-1]
++ } else {
++ foo <- rep(0, nx)
++ }
++ bar <- foo^2
++ return(c(foo, bar))
++ }
+>
+> out <- temper(ludfun, initial = out$final, neighbors = neighbors,
++ nbatch = 25, blen = 20, nspac = 5, scale = 0.56789, debug = TRUE,
++ outfun = outfun, log.pseudo.prior = qux, icomp = 4)
+>
+> before <- out$state
+> after <- before
+> after[- dim(after)[1], ] <- before[-1, ]
+> after[dim(after)[1], ] <- out$final
+> outies <- apply(after, 1, outfun, icomp = 4)
+> outies <- t(outies)
+>
+> foo <- outies[seq(1, niter) %% out$nspac == 0, ]
+> foo <- array(as.vector(foo), dim = c(out$blen, out$nbatch, dim(foo)[2]))
+> foo <- apply(foo, c(2, 3), mean)
+> all.equal(foo, out$batch)
+[1] TRUE
+>
+>
+> proc.time()
+ user system elapsed
+ 5.196 0.036 5.232
diff --git a/vignettes/bfst.Rnw b/vignettes/bfst.Rnw
new file mode 100644
index 0000000..3c376ec
--- /dev/null
+++ b/vignettes/bfst.Rnw
@@ -0,0 +1,804 @@
+
+\documentclass[11pt]{article}
+
+\usepackage{amsmath}
+\usepackage{amsfonts}
+\usepackage{indentfirst}
+\usepackage{natbib}
+\usepackage{url}
+\usepackage[utf8]{inputenc}
+
+\newcommand{\real}{\mathbb{R}}
+
+\DeclareMathOperator{\prior}{pri}
+\DeclareMathOperator{\posterior}{post}
+\DeclareMathOperator{\indicator}{ind}
+
+\newcommand{\fatdot}{\,\cdot\,}
+
+% \VignetteIndexEntry{Bayes Factors via Serial Tempering}
+
+\begin{document}
+
+\title{Bayes Factors via Serial Tempering}
+\author{Charles J. Geyer}
+\maketitle
+
+<<foo,include=FALSE,echo=FALSE>>=
+options(keep.source = TRUE, width = 65)
+@
+
+\section{Introduction}
+
+\subsection{Bayes Factors} \label{sec:bayes-factors}
+
+Let $\mathcal{M}$ be a finite or countable set of models (here we only
+deal with finite $\mathcal{M}$ but Bayes factors make sense for countable
+$\mathcal{M}$). For each model
+$m \in \mathcal{M}$ we have the prior probability of the model $\prior(m)$.
+It does not matter if this prior on models is unnormalized.
+
+Each model $m$ has a parameter space $\Theta_m$ and a prior
+$$
+ g(\theta \mid m), \qquad \theta \in \Theta_m
+$$
+The spaces $\Theta_m$ can and usually do have different dimensions. That's
+the point. These within model priors must be normalized proper priors.
+The calculations to follow make no sense if these priors are unnormalized
+or improper.
+
+Each model $m$ has a data distribution
+$$
+ f(y \mid \theta, m)
+$$
+and the observed data $y$ may be either discrete or continuous
+(it makes no difference to
+the Bayesian who treats $y$ as fixed after it is observed and treats
+only $\theta$ and $m$ as random).
+
+The unnormalized posterior for everything
+(for models and parameters within models)
+is
+$$
+ f(y \mid \theta, m) g(\theta \mid m) \prior(m)
+$$
+To obtain the conditional distribution of $y$ given $m$, we must integrate
+out the nuisance parameter $\theta$
+\begin{align*}
+ q(y \mid m)
+ & =
+ \int_{\Theta_m} f(y \mid \theta, m) g(\theta \mid m) \prior(m) \, d \theta
+ \\
+ & =
+ \prior(m) \int_{\Theta_m} f(y \mid \theta, m) g(\theta \mid m) \, d \theta
+\end{align*}
+These are the unnormalized posterior probabilities of the models. The
+normalized posterior probabilities are
+$$
+ \posterior(m \mid y)
+ =
+ \frac{ q(y \mid m) }{ \sum_{m \in \mathcal{M}} q(y \mid m) }
+$$
+
+It is considered useful to define
+$$
+ b(y \mid m)
+ =
+ \int_{\Theta_m} f(y \mid \theta, m) g(\theta \mid m) \, d \theta
+$$
+so
+$$
+ q(y \mid m) = b(y \mid m) \prior(m)
+$$
+Then the ratio of posterior probabilities of models $m_1$ and $m_2$ is
+$$
+ \frac{\posterior(m_1 \mid y)}{\posterior(m_2 \mid y)}
+ =
+ \frac{q(y \mid m_1)}{q(y \mid m_2)}
+ =
+ \frac{b(y \mid m_1)}{b(y \mid m_2)}
+ \cdot
+ \frac{\prior(m_1)}{\prior(m_2)}
+$$
+This ratio is called the \emph{posterior odds} of the models (a ratio of
+probabilities is called an \emph{odds}) of these models.
+
+The \emph{prior odds} is
+$$
+ \frac{\prior(m_1)}{\prior(m_2)}
+$$
+
+The term we have not yet named in
+$$
+ \frac{\posterior(m_1 \mid y)}{\posterior(m_2 \mid y)}
+ =
+ \frac{b(y \mid m_1)}{b(y \mid m_2)}
+ \cdot
+ \frac{\prior(m_1)}{\prior(m_2)}
+$$
+is called the \emph{Bayes factor}
+\begin{equation} \label{eq:factor}
+ \frac{b(y \mid m_1)}{b(y \mid m_2)}
+\end{equation}
+the ratio of posterior odds to prior odds.
+
+The prior odds tells how the prior compares the probability of the models.
+The Bayes factor tells us how the data shifts that comparison going from
+prior to posterior via Bayes rule.
+Bayes factors are the primary tool Bayesians use for model comparison,
+the competitor for frequentist $P$-values in frequentist hypothesis
+tests of model comparison.
+
+Note that our clumsy multiple letter notation for priors and posteriors
+$\prior(m)$ and $\posterior(m \mid y)$ does not matter because neither
+is involved in the actual calculation of Bayes factors \eqref{eq:factor}.
+Priors and posteriors are involved in motivating Bayes factors but not in
+calculating them.
+
+\subsection{Tempering} \label{sec:temper}
+
+Simulated tempering \citep{marinari-parisi,geyer-thompson} is a method of
+Markov chain Monte Carlo (MCMC) simulation of many distributions at once.
+It was originally invented with the primary aim of speeding up MCMC
+convergence, but was also recognized to be useful for sampling multiple
+distributions \citep{geyer-thompson}. In the latter role it is sometimes
+referred to as ``umbrella sampling'' which is a term coined
+by \citet{torrie-valleau} for sampling multiple distributions via MCMC.
+
+We have a finite set of unnormalized distributions we want to sample,
+all related in some way. The R function \texttt{temper}
+in the CRAN package \texttt{mcmc}
+requires all to have continuous distributions for random vectors of the same
+dimension (all distributions have the same domain $\real^p$).
+Let $h_i$, $i \in \mathcal{I}$ denote the unnormalized densities of
+these distributions. Simulated tempering (called ``serial tempering'' by
+the \texttt{temper} function to distinguish from a related scheme not used
+in this document called ``parallel tempering'' and in either case abbreviated
+ST) runs a Markov chain whose
+state is a pair $(i, x)$ where $i \in \mathcal{I}$ and $x \in \real^p$.
+
+The unnormalized density of stationary distribution of the ST chain is
+\begin{equation} \label{eq:st-joint}
+ h(i, x) = h_i(x) c_i
+\end{equation}
+where the $c_i$ are arbitrary constants chosen by the user (more on this later).
+
+The equilibrium distribution of the ST state $(I, X)$ --- both bits random ---
+is such that conditional distribution of $X$ given $I = i$ is the distribution
+with unnormalized density $h_i$. This is obvious from $h(i, x)$ being the
+unnormalized conditional density --- the same function thought of as
+a function of both variables is the unnormalized joint density and thought
+of as a function of just one of the variables is an unnormalized conditional
+density --- and $h(i, x)$ thought of as a function of $x$ for fixed $i$ being
+proportional to $h_i$. The equilibrium unnormalized marginal distribution
+of $I$ is
+\begin{equation} \label{eq:margin}
+ \int h(i, x) \, d x = c_i \int h_i(x) \, d x = c_i d_i
+\end{equation}
+where
+$$
+ d_i = \int h_i(x) \, d x
+$$
+is the normalizing constant for $h_i$, that is, $h_i / d_i$ is a normalized
+distribution.
+
+It is clear from \eqref{eq:margin} being the unnormalized marginal distribution
+that in order for the marginal distribution to be uniform we must choose the
+tuning constants $c_i$ to be proportional to $1 / d_i$. It is not important
+that the marginal distribution be exactly uniform, but unless it is
+approximately uniform, the sampler will not visit each distribution frequently.
+Thus we do need to have the $c_i$ to be approximately proportional to $1 / d_i$.
+This is accomplished by trial and
+error (one example is done in this document) and is easy for easy problems
+and hard for hard problems \citep[have much to say about adjusting
+the $c_i$]{geyer-thompson}. For the rest of this section we will assume
+the tuning constants $c_i$ have been so adjusted:
+we do not have the $c_i$ exactly proportional to $1 / d_i$ but do have
+them approximately proportional to $1 / d_i$.
+
+\subsection{Tempering and Bayes Factors}
+
+Bayes factors are very important in Bayesian inference and many methods have
+been invented to calculate them. No method except the one described here
+using ST is anywhere near as accurate and straightforward. Thus no competitors
+will be discussed.
+
+In using ST for Bayes factors we identify the index set $\mathcal{I}$ with
+the model set $\mathcal{M}$ and use the integers 1, $\ldots$, $k$ for both.
+We would like to identify the within model parameter vector $\theta$ with
+the vector $x$ that is the continuous part of the state of the ST Markov
+chain, but cannot because the dimension of $\theta$ depends on $m$ and this
+is not allowed. Thus we have to do something a bit more complicated. We
+``pad'' $\theta$ so that it always has the same dimension, doing so in
+a way that does not interfere with the Bayes factor calculation. Write
+$\theta = (\theta_{\text{actual}}, \theta_{\text{pad}})$, the dimension
+of both parts depending on the model $m$. Then we insist on the following
+conditions:
+$$
+ f(y \mid \theta, m) = f(y \mid \theta_{\text{actual}}, m)
+$$
+so the data distribution does not depend on the ``padding'' and
+$$
+ g(\theta \mid m) = g_{\text{actual}}(\theta_{\text{actual}} \mid m)
+ \cdot g_{\text{pad}}(\theta_{\text{pad}} \mid m)
+$$
+so the two parts are \emph{a priori} independent and both parts of the prior
+are normalized proper priors. This assures that
+\begin{equation} \label{eq:unnormalized-bayes-factors}
+\begin{split}
+ b(y \mid m)
+ & =
+ \int_{\Theta_m} f(y \mid \theta, m) g(\theta \mid m) \, d \theta
+ \\
+ & =
+ \iint f(y \mid \theta_{\text{actual}}, m)
+ g_{\text{actual}}(\theta_{\text{actual}} \mid m)
+ g_{\text{pad}}(\theta_{\text{pad}} \mid m)
+ \, d \theta_{\text{actual}}
+ \, d \theta_{\text{pad}}
+ \\
+ & =
+ \int_{\Theta_m} f(y \mid \theta_{\text{actual}}, m)
+ g_{\text{actual}}(\theta_{\text{actual}} \mid m)
+ \, d \theta_{\text{actual}}
+\end{split}
+\end{equation}
+so the calculation of the unnormalized Bayes factors is the same whether
+or not we ``pad'' $\theta$, and we may then take
+\begin{align*}
+ h_m(\theta)
+ & =
+ f(y \mid \theta, m) g(\theta \mid m)
+ \\
+ & =
+ f(y \mid \theta_{\text{actual}}, m)
+ g_{\text{actual}}(\theta_{\text{actual}} \mid m)
+ g_{\text{pad}}(\theta_{\text{pad}} \mid m)
+\end{align*}
+to be the unnormalized densities for the component distributions of the ST
+chain, in which case the unnormalized Bayes factors are proportional to the
+normalizing constants $d_i$ in Section~\ref{sec:temper}.
+
+\subsection{Tempering and Normalizing Constants}
+
+Let $d$ be the normalizing constant for the joint equilibrium distribution
+of the ST chain \eqref{eq:st-joint}. When we are running the ST chain we know
+neither $d$ nor the $d_i$ but we do know the $c_i$, which are constants we
+have chosen based on the results of previous runs but are fixed known numbers
+for the current run. Let $(I_t, X_t)$, $t = 1$, 2, $\ldots$ be the sample
+path of the ST chain. Recall that (somewhat annoyingly) we are using the
+notation $(i, x)$ for the state vector of a general ST chain and the notation
+$(m, \theta)$ for ST chains used to calculate Bayes factors, identifying
+$i = m$ and $x = \theta$.
+
+Let $\indicator(\fatdot)$ denote the function that maps logical values to
+numerical values, false to zero and true to one. Normalizing constants are
+estimated by averaging the time spent in each model
+\begin{equation} \label{eq:st-estimates}
+ \hat{\delta}_n(m) = \frac{1}{n} \sum_{t = 1}^n \indicator(I_t = m)
+\end{equation}
+For the purposes of approximating Bayes factors the $X_t$ are ignored.
+The $X_t$ may be useful for other purposes, such as
+Bayesian model averaging \citep*{bma}, but this is not discussed here.
+
+The Monte Carlo approximations \eqref{eq:st-estimates} converge
+to their expected values under the equilibrium distribution
+\begin{equation} \label{eq:st-expectations}
+ E\{ \indicator(I_t = m) \}
+ =
+ \int \frac{h(m, x)}{d} \, d x
+ =
+ \frac{c_m d_m}{d}
+ =
+ \delta(m)
+\end{equation}
+We want to estimate the unnormalized Bayes factors
+\eqref{eq:unnormalized-bayes-factors}, which are in this context proportional
+to the $d_m$. The $c_m$ are known, $d$ is unknown but does not matter since
+we only need to estimate the $d_m = b(m \mid y)$ up to an overall unknown
+constant of proportionality, which cancels out of Bayes factors
+\eqref{eq:factor}.
+
+Note that our discussion here applies unchanged to the general problem of
+estimating normalizing constants up to an unknown constant of proportionality,
+which has applications other than Bayes factors, for example, missing data
+maximum likelihood \citep{thompson-guo,geyer,sung-geyer}.
+The ST method approximates normalizing constants up to an overall constant of
+proportionality with high accuracy regardless of how large or small they are
+(whether they are $10^{100}$ or $10^{-100}$), and no other method that does
+not use essentially the same idea can do this.
+
+The key is what seems at first sight to be a weakness of ST, the need to
+adjust the tuning constants $c_i$ by trial and error. In this context the
+weakness is actually a strength: the adjusted $c_i$ contain most of the
+information about the size of the normalizing constants $d_i$ and the
+Monte Carlo averages \eqref{eq:st-estimates} add only the finishing touch.
+Thus multiple runs of the ST chain with different choices of the $c_i$ used
+in each run are needed (the ``trial and error''), but the information from
+all are incorporated in the final run used for final approximation of the
+normalizing constants (Bayes factors). It is perhaps surprising that the
+Monte Carlo error approximation is trivial. In the context of the last run
+of the ST chain the $c_i$ are known constants and contribute no error.
+The Monte Carlo error of the averages \eqref{eq:st-estimates} is
+straightforwardly estimated by batch means or competing methods.
+
+\citet{geyer-thompson} note that the $c_i$ enter formally like a prior:
+one can think of $h_i(x) c_i$ as likelihood times prior. But one should
+not think of the $c_i$ as representing prior information, informative,
+non-informative, or in between. The $c_i$ are adjusted to make the ST
+distribution sample all the models $h_i$, and that is the only criterion
+for the adjustment. For this reason \citet{geyer-thompson} call the
+$c_i$ the \emph{pseudoprior}. This is a special case of a general principle
+of MCMC. When doing MCMC one should forget the statistical motivation
+(in this case Bayes factors). One should set up a Markov chain that does
+a good job of simulating the required equilibrium distribution, whatever
+it is. Thinking about the statistical motivation of the equilibrium does
+not help and can hurt (if one thinks of the pseudoprior as an actual prior,
+one may be tempted to adjust it to represent prior information).
+
+\section{R Package MCMC}
+
+We use the R statistical computing environment \citep{rcore} in our analysis.
+It is free software and can be obtained from
+\url{http://cran.r-project.org}. Precompiled binaries
+are available for Windows, Macintosh, and popular Linux distributions.
+We use the contributed package \verb at mcmc@ \citep{mcmc-R-package}
+If R has been installed, but this package has
+not yet been installed, do
+\begin{verbatim}
+install.packages("mcmc")
+\end{verbatim}
+from the R command line
+(or do the equivalent using the GUI menus if on Apple Macintosh
+or Microsoft Windows). This may require root or administrator privileges.
+
+Assuming the \verb at mcmc@ package has been installed, we load it
+<<library>>=
+library(mcmc)
+@
+<<baz,include=FALSE,echo=FALSE>>=
+baz <- library(help = "mcmc")
+baz <- baz$info[[1]]
+baz <- baz[grep("Version", baz)]
+baz <- sub("^Version: *", "", baz)
+bazzer <- paste(R.version$major, R.version$minor, sep = ".")
+@
+The version of the package used to make this document
+is \Sexpr{baz} (which is available on CRAN).
+The version of R used to make this document is \Sexpr{bazzer}.
+
+We also set the random number generator seed so that the results are
+reproducible.
+<<set-seed>>=
+set.seed(42)
+@
+To get different results, change the setting or don't set the seed at all.
+
+\section{Logistic Regression Example}
+
+We use the same logistic regression example used in the \texttt{mcmc}
+package vignette for the \texttt{metrop} function (file \texttt{demo.pdf}.
+Simulated data for the problem are in the data set \verb at logit@.
+There are five variables in the data set, the response \verb at y@
+and four predictors, \verb at x1@, \verb at x2@, \verb at x3@, and \verb at x4@.
+
+A frequentist analysis for the problem is done by the following R statements
+<<frequentist>>=
+data(logit)
+out <- glm(y ~ x1 + x2 + x3 + x4, data = logit,
+ family = binomial, x = TRUE)
+summary(out)
+@
+
+But this example isn't about frequentist analysis, we want a Bayesian
+analysis. For our Bayesian analysis we assume the same data model as the
+frequentist, and we assume the prior distribution of the five parameters
+(the regression coefficients) makes them independent and identically
+normally distributed with mean 0 and standard deviation 2.
+
+Moreover, we wish to calculate Bayes factors for the $16 = 2^4$ possible
+submodels that include or exclude each of the
+predictors, \verb at x1@, \verb at x2@, \verb at x3@, and \verb at x4@.
+
+\subsection{Setup}
+
+We set up a matrix that indicates these models.
+<<models>>=
+varnam <- names(coefficients(out))
+varnam <- varnam[varnam != "(Intercept)"]
+nvar <- length(varnam)
+
+models <- NULL
+foo <- seq(0, 2^nvar - 1)
+for (i in 1:nvar) {
+ bar <- foo %/% 2^(i - 1)
+ bar <- bar %% 2
+ models <- cbind(bar, models, deparse.level = 0)
+}
+colnames(models) <- varnam
+models
+@
+In each row, 1 indicates the predictor is in the model and 0 indicates it is
+out.
+
+The function \texttt{temper} in the \text{mcmc} package that does tempering
+requires a notion of neighbors among models. It attempts jumps only between
+neighboring models. Here we choose models to be neighbors if they differ
+only by one predictor.
+<<neighbor>>=
+neighbors <- matrix(FALSE, nrow(models), nrow(models))
+for (i in 1:nrow(neighbors)) {
+ for (j in 1:ncol(neighbors)) {
+ foo <- models[i, ]
+ bar <- models[j, ]
+ if (sum(foo != bar) == 1) neighbors[i, j] <- TRUE
+ }
+}
+@
+
+Now we specify the equilibrium distribution of the ST chain. Its state vector
+is $(i, x)$ or $(m, \theta)$ in our alternative notations, where $i$ is an
+integer between $1$ and \verb at nrow(models)@ = \Sexpr{nrow(models)} and
+$\theta$ is the parameter vector ``padded'' to always be the same length,
+so we take it to be the length of the parameter vector of the full model
+which is \verb at length(out$coefficients)@ or \verb at ncol(models) + 1@ which makes
+the length of the state of the ST chain \verb at ncol(models) + 2 at .
+We take the within model priors for the ``padded'' components of the parameter
+vector to be the same as those for the ``actual'' components, normal with
+mean 0 and standard deviation 2 for all cases.
+As is seen in \eqref{eq:unnormalized-bayes-factors} the priors for the
+``padded'' components (parameters not in the model for the current state)
+do not matter because they drop out of the Bayes factor calculation.
+The choice does not matter much for this toy example.
+See the discussion section for more on this issue.
+It is important that we use normalized log priors,
+the term \verb at dnorm(beta, 0, 2, log = TRUE)@ in the function, unlike
+when we are simulating only one model as in the \texttt{mcmc} package vignette
+where it would be o.~k.\ to use unnormalized log priors \verb at - beta^2 / 8 at .
+The \texttt{temper} function wants the log unnormalized density of the
+equilibrium distribution.
+We include an additional argument \texttt{log.pseudo.prior},
+which is $\log(c_i)$ in our mathematical development, because this changes
+from run to run as we adjust it by trial and error. Other ``arguments''
+are the model matrix of the full model \texttt{modmat}, the matrix
+\texttt{models} relating integer indices (the first component of the state
+vector of the ST chain) to which predictors are in or out of the model,
+and the data vector \texttt{y}, but these are not passed as arguments to our
+function and instead are found in the R global environment.
+<<ludfun>>=
+modmat <- out$x
+y <- logit$y
+
+ludfun <- function(state, log.pseudo.prior) {
+ stopifnot(is.numeric(state))
+ stopifnot(length(state) == ncol(models) + 2)
+ icomp <- state[1]
+ stopifnot(icomp == as.integer(icomp))
+ stopifnot(1 <= icomp && icomp <= nrow(models))
+ stopifnot(is.numeric(log.pseudo.prior))
+ stopifnot(length(log.pseudo.prior) == nrow(models))
+ beta <- state[-1]
+ inies <- c(TRUE, as.logical(models[icomp, ]))
+ beta.logl <- beta
+ beta.logl[! inies] <- 0
+ eta <- as.numeric(modmat %*% beta.logl)
+ logp <- ifelse(eta < 0, eta - log1p(exp(eta)), - log1p(exp(- eta)))
+ logq <- ifelse(eta < 0, - log1p(exp(eta)), - eta - log1p(exp(- eta)))
+ logl <- sum(logp[y == 1]) + sum(logq[y == 0])
+ logl + sum(dnorm(beta, 0, 2, log = TRUE)) + log.pseudo.prior[icomp]
+}
+@
+
+\subsection{Trial and Error}
+
+Now we are ready to try it out. We start in the full model at its MLE,
+and we initialize \texttt{log.pseudo.prior} at all zeros, having no idea
+\emph{a priori} what it should be.
+<<try1>>=
+state.initial <- c(nrow(models), out$coefficients)
+
+qux <- rep(0, nrow(models))
+
+out <- temper(ludfun, initial = state.initial, neighbors = neighbors,
+ nbatch = 1000, blen = 100, log.pseudo.prior = qux)
+
+names(out)
+out$time
+@
+So what happened?
+<<what>>=
+ibar <- colMeans(out$ibatch)
+ibar
+@
+The ST chain did not mix well, several models not being visited even once.
+So we adjust the pseudo priors to get uniform distribution.
+<<adjust>>=
+qux <- qux + pmin(log(max(ibar) / ibar), 10)
+qux <- qux - min(qux)
+qux
+@
+The new pseudoprior should be proportional to \verb at 1 / ibar@ if \texttt{ibar}
+is an accurate estimate of \eqref{eq:st-expectations}, but this makes no sense
+when the estimates are bad, in particular, when the are exactly zero. Thus
+we put an upper bound, chosen arbitrarily (here 10) on the maximum increase
+of the log pseudoprior. The statement
+\begin{verbatim}
+qux <- qux - min(qux)
+\end{verbatim}
+is unnecessary. An overall arbitrary constant can be added to
+the log pseudoprior without changing the equilibrium distribution of the
+ST chain.
+We do this only to make \texttt{qux} more comparable from
+run to run.
+
+Now we repeat this until the log pseudoprior ``converges'' roughly.
+Because this loop takes longer than CRAN vingettes are supposed to
+take, we save the results to a file
+and load the results from this file if it already exists.
+<<iterate>>=
+lout <- suppressWarnings(try(load("bfst1.rda"), silent = TRUE))
+if (inherits(lout, "try-error")) {
+ qux.save <- qux
+ time.save <- out$time
+ repeat{
+ out <- temper(out, log.pseudo.prior = qux)
+ ibar <- colMeans(out$ibatch)
+ qux <- qux + pmin(log(max(ibar) / ibar), 10)
+ qux <- qux - min(qux)
+ qux.save <- rbind(qux.save, qux, deparse.level = 0)
+ time.save <- rbind(time.save, out$time, deparse.level = 0)
+ if (max(ibar) / min(ibar) < 2) break
+ }
+ save(out, qux, qux.save, time.save, file = "bfst1.rda")
+} else {
+ .Random.seed <- out$final.seed
+}
+print(qux.save, digits = 3)
+print(qux, digits = 3)
+apply(time.save, 2, sum)
+@
+
+Now that the pseudoprior is adjusted well enough, we need to perhaps
+make other adjustments to get acceptance rates near 20\%.
+<<accept-i-x>>=
+print(out$accepti, digits = 3)
+print(out$acceptx, digits = 3)
+@
+The acceptance rates for swaps seem o. k.
+<<accept-i-min>>=
+min(as.vector(out$accepti), na.rm = TRUE)
+@
+and there is nothing simple we can do to adjust them (adjustment is possible,
+see the discussion section for more on this issue). We adjust the
+acceptance rates for within model moves by adjusting the scaling.
+<<scale>>=
+out <- temper(out, scale = 0.5, log.pseudo.prior = qux)
+time.save <- rbind(time.save, out$time, deparse.level = 0)
+print(out$acceptx, digits = 3)
+@
+Looks o.~k.\ now.
+
+Inspection of autocorrelation functions for components
+of \verb at out$ibatch@ (not shown) says batch length needs to be at least
+4 times longer. We make it 10 times longer for safety.
+
+Because this run takes longer than CRAN vingettes are supposed to
+take, we save the results to a file
+and load the results from this file if it already exists.
+<<try6>>=
+lout <- suppressWarnings(try(load("bfst2.rda"), silent = TRUE))
+if (inherits(lout, "try-error")) {
+ out <- temper(out, blen = 10 * out$blen, log.pseudo.prior = qux)
+ save(out, file = "bfst2.rda")
+} else {
+ .Random.seed <- out$final.seed
+}
+time.save <- rbind(time.save, out$time, deparse.level = 0)
+foo <- apply(time.save, 2, sum)
+foo.min <- floor(foo[1] / 60)
+foo.sec <- foo[1] - 60 * foo.min
+c(foo.min, foo.sec)
+@
+The total time for all runs of the temper function was
+\Sexpr{foo.min} minutes and \Sexpr{round(foo.sec, 1)} seconds.
+
+\subsection{Bayes Factor Calculations}
+
+Now we calculate log 10 Bayes factors relative to the model with the highest
+unnormalized Bayes factor.
+<<doit>>=
+log.10.unnorm.bayes <- (qux - log(colMeans(out$ibatch))) / log(10)
+k <- seq(along = log.10.unnorm.bayes)[log.10.unnorm.bayes
+ == min(log.10.unnorm.bayes)]
+models[k, ]
+
+log.10.bayes <- log.10.unnorm.bayes - log.10.unnorm.bayes[k]
+log.10.bayes
+@
+These are base 10 logarithms of the Bayes factors against the $k$-th
+model where $k = \Sexpr{k}$. For example, the Bayes factor for the $k$-th
+model divided by the Bayes factor for the first model is
+$10^{\Sexpr{round(log.10.bayes[1], 3)}}$.
+
+Now we calculate Monte Carlo standard errors two different ways. One is
+the way the delta method is usually taught. To simplify notation, denote
+the Bayes factors
+$$
+ b_m = b(y \mid m)
+$$
+and their Monte Carlo approximations $\hat{b}_m$. Then the log Bayes factors
+are
+$$
+ g_i(b) = \log_{10} b_i - \log_{10} b_k
+$$
+hence we need to apply the delta method with the function $g_i$, which has
+derivatives
+\begin{align*}
+ \frac{\partial g_i(b)}{\partial b_i}
+ & =
+ \frac{1}{b_i \log_e(10)}
+ \\
+ \frac{\partial g_i(b)}{\partial b_k}
+ & =
+ - \frac{1}{b_k \log_e(10)}
+ \\
+ \frac{\partial g_i(b)}{\partial b_j}
+ & =
+ 0, \qquad \text{$j \neq i$ and $j \neq k$}
+\end{align*}
+<<doit-se-one>>=
+fred <- var(out$ibatch) / out$nbatch
+sally <- colMeans(out$ibatch)
+mcse.log.10.bayes <- (1 / log(10)) * sqrt(diag(fred) / sally^2 -
+ 2 * fred[ , k] / (sally * sally[k]) +
+ fred[k, k] / sally[k]^2)
+mcse.log.10.bayes
+
+foompter <- cbind(models, log.10.bayes, mcse.log.10.bayes)
+round(foompter, 5)
+@
+
+An alternative calculation of the MCSE replaces the actual function
+of the raw Bayes factors with its best linear approximation
+$$
+ \frac{1}{\log_e(10)} \left(\frac{\hat{b}_i - b_i}{b_i}
+ - \frac{\hat{b}_k - b_k}{b_k} \right)
+$$
+and calculates the standard deviation of this quantity by batch means
+<<doit-too>>=
+ibar <- colMeans(out$ibatch)
+herman <- sweep(out$ibatch, 2, ibar, "/")
+herman <- sweep(herman, 1, herman[ , k], "-")
+mcse.log.10.bayes.too <- (1 / log(10)) *
+ apply(herman, 2, sd) /sqrt(out$nbatch)
+all.equal(mcse.log.10.bayes, mcse.log.10.bayes.too)
+@
+
+\section{Discussion}
+
+We hope readers are impressed with the power of this method. The key
+to the method is pseudopriors adjusted by trial and error. The method
+could have been invented by any Bayesian who realized that the priors
+on models, $\prior(m)$ in our notation in Section~\ref{sec:bayes-factors},
+do not affect the Bayes factors and hence are irrelevant to calculating
+Bayes factors. Thus the priors (or pseudopriors in our terminology) should
+be chosen for reasons of computational convenience, as we have done,
+rather than to incorporate prior information.
+
+The rest of the details of the method are unimportant. The \texttt{temper}
+function in R is convenient to use for this purpose, but there is no reason
+to believe that it provides optimal sampling. Samplers carefully designed
+for each particular application would undoubtedly do better. Our notion
+of ``padding'' so that the within model parameters have the same dimension
+for all models follows \citet{carlin-chib} but ``reversible jump'' samplers
+\citep{green} would undoubtedly do better. Unfortunately, there seems to
+be no way to code up a function like \texttt{temper} that uses ``reversible
+jump'' and requires no theoretical work from users that if messed up destroys
+the algorithm. The \texttt{temper} function is foolproof in the sense that
+if the log unnormalized density function written by the user
+(like our \texttt{ludfun}) is correct, then the ST Markov chain has the
+equilibrium distribution is supposed to have. There is nothing the
+user can mess up except this user written function. No analog of this
+for ``reversible jump'' chains is apparent (to your humble author).
+
+Two issues remain where the text above said ``see the discussion section for
+more on this issue.'' The first was about within model priors for the
+``padding'' components of within model parameter vectors
+$g_{\text{pad}}(\theta_{\text{pad}} \mid m)$ in
+the notation in \eqref{eq:unnormalized-bayes-factors}.
+Rather than choose these so that they do not depend on the data (as we did),
+it would be better (if more trouble) to choose them differently for each
+``padding'' component, centering $g_{\text{pad}}(\theta_{\text{pad}} \mid m)$
+so the distribution of a component of $\theta_{\text{pad}}$ is near to the
+marginal distribution of the same component in neighboring models (according to
+the \texttt{neighbors} argument of the \texttt{temper} function).
+
+The other remaining issue is adjusting acceptance rates for jumps. There
+is no way to adjust this other than by changing the number of models and
+their definitions. But the models we have cannot be changed; if we are
+to calculate Bayes factors for them, then we must sample them as they are.
+But we can insert new models between old models. For example,
+if the acceptance for swaps between model $i$ and model $j$ is too low, then
+we can insert distribution $k$ between them that has unnormalized density
+$$
+ h_k(x) = \sqrt{h_i(x) h_j(x)}.
+$$
+This idea is inherited from simulated tempering; \citep{geyer-thompson}
+have much
+discussion of how to insert additional distributions into a tempering network.
+It is another key issue in using tempering to speed up sampling. It is
+less obvious in the Bayes factor context, but still an available technique
+if needed.
+
+
+\begin{thebibliography}{}
+
+\bibitem[Carlin and Chib(1995)]{carlin-chib}
+Carlin, B.~P. and Chib, S. (1995).
+\newblock Bayesian model choice via Markov chain Monte Carlo methods.
+\newblock \emph{Journal of the Royal Statistical Society, Series B},
+ \textbf{57}, 473--484.
+
+\bibitem[Geyer(1994)]{geyer}
+Geyer, C.~J. (1994).
+\newblock On the convergence of Monte Carlo maximum likelihood calculations.
+\newblock \emph{Journal of the Royal Statistical Society, Series B},
+ \textbf{56} 261--274.
+
+\bibitem[Geyer., 2009]{mcmc-R-package}
+Geyer., C.~J. (2009).
+\newblock \emph{mcmc: Markov Chain Monte Carlo}.
+\newblock R package version 0.7-2, available from CRAN.
+
+\bibitem[Geyer and Thompson(1995)]{geyer-thompson}
+Geyer, C.~J., and Thompson, E.~A. (1995).
+\newblock Annealing Markov chain Monte Carlo with applications to ancestral
+ inference.
+\newblock \emph{Journal of the American Statistical Association}, \textbf{90},
+ 909--920.
+
+\bibitem[Green(1995)]{green}
+Green, P.~J. (1995).
+\newblock Reversible jump {M}arkov chain {M}onte {C}arlo computation and
+ {B}ayesian model determination.
+\newblock \emph{Biometrika}, \textbf{82}, 711--732.
+
+\bibitem[Hoeting et al.(1999)Hoeting, Madigan, Raftery, and Volinsky]{bma}
+Hoeting, J.~A., Madigan, D., Raftery, A.~E. and Volinsky, C.~T. (1999).
+\newblock Bayesian model averaging: A tutorial (with discussion).
+\newblock \emph{Statical Science}, \textbf{19}, 382--417.
+\newblock The version printed in the journal had the equations messed up in
+ the production process; a corrected version is available at
+ \url{http://www.stat.washington.edu/www/research/online/1999/hoeting.pdf}.
+
+\bibitem[Marinari and Parisi(1992)]{marinari-parisi}
+Marinari, E., and Parisi G. (1992).
+\newblock Simulated tempering: A new Monte Carlo Scheme.
+\newblock \emph{Europhysics Letters}, \textbf{19}, 451--458.
+
+\bibitem[R Development Core Team(2010)]{rcore}
+R Development Core Team (2010).
+\newblock R: A language and environment for statistical computing.
+\newblock R Foundation for Statistical Computing, Vienna, Austria.
+\newblock \url{http://www.R-project.org}.
+
+\bibitem[Sung and Geyer(2007)]{sung-geyer}
+Sung, Y.~J. and Geyer, C.~J. (2007).
+\newblock Monte Carlo likelihood inference for missing data models.
+\newblock \emph{Annals of Statistics}, \textbf{35}, 990--1011.
+
+\bibitem[Thompson and Guo(1991)]{thompson-guo}
+Thompson, E. A. and Guo, S. W. (1991).
+\newblock Evaluation of likelihood ratios for complex genetic models.
+\newblock \emph{IMA J. Math. Appl. Med. Biol.}, \textbf{8}, 149--169.
+
+\bibitem[Torrie and Valleau(1977)]{torrie-valleau}
+Torrie, G.~M., and Valleau, J.~P. (1977).
+\newblock Nonphysical sampling distributions in Monte Carlo free-energy
+ estimation: Umbrella sampling.
+\newblock \emph{Journal of Computational Physics}, \textbf{23}, 187--199.
+
+\end{thebibliography}
+
+\end{document}
+
diff --git a/vignettes/bfst1.rda b/vignettes/bfst1.rda
new file mode 100644
index 0000000..606fa6f
Binary files /dev/null and b/vignettes/bfst1.rda differ
diff --git a/vignettes/bfst2.rda b/vignettes/bfst2.rda
new file mode 100644
index 0000000..5795601
Binary files /dev/null and b/vignettes/bfst2.rda differ
diff --git a/vignettes/debug.Rnw b/vignettes/debug.Rnw
new file mode 100644
index 0000000..2da3897
--- /dev/null
+++ b/vignettes/debug.Rnw
@@ -0,0 +1,274 @@
+
+\documentclass{article}
+
+\usepackage{amstext}
+
+% \VignetteIndexEntry{Debugging MCMC Code}
+
+\begin{document}
+
+<<foo,include=FALSE,echo=FALSE>>=
+options(keep.source = TRUE, width = 60)
+foo <- packageDescription("mcmc")
+@
+
+\title{Debugging MCMC Code}
+\author{Charles J. Geyer}
+\maketitle
+
+\section{Introduction}
+
+This document discusses debugging Markov chain Monte Carlo code
+using the R contributed package \texttt{mcmc} (Version \Sexpr{foo$Version})
+for examples. It also documents the debugging output of the functions
+\texttt{mcmc} and \texttt{temper}.
+
+Debugging MCMC code if the code is taken as a black box is basically
+impossible. In interesting examples, the only thing one knows about
+the equilibrium distribution of an MCMC sampler is what one learns
+from the samples. This obviously doesn't help with testing. If the
+sampler is buggy, then the only thing you know about the equilibrium
+distribution is wrong, but if you don't know it is buggy, then you don't
+know it is wrong. So you don't know anything. There is no way to tell
+whether random output has the correct distribution when you don't know
+anything about the distribution it is supposed to have.
+
+The secret to debugging MCMC code lies in two principles:
+\begin{itemize}
+\item take the randomness out, and
+\item expose the innards.
+\end{itemize}
+The first slogan means consider the algorithm a deterministic function
+of the elementary pseudo-random numbers that are trusted (for example,
+the outputs of the R random number generators, which you aren't responsible
+for debugging and are also well tested).
+The second slogan means output, at least for debugging purposes, enough
+intermediate state so that testing is straightforward.
+
+For a Gibbs sampler, this means outputting all of the trusted elementary
+pseudo-random numbers used, the state before and after each elementary
+Gibbs update, and which update is being done if a random scan is used.
+Also one needs to output the initial seeds of the pseudo-random number
+generator (this is true for all situations and will not be mentioned again).
+
+For a Metropolis-Hastings sampler, this means outputting all of the trusted
+elementary
+pseudo-random numbers used, the state before and after each elementary
+Metropolis-Hastings update, the proposal for that update, the Hastings ratio
+for that update, decision (accept or reject) in that update.
+
+For more complicated MCMC samplers, there is more ``innards'' to ``expose''
+(see the discussion of the \texttt{temper} function below), but you get the
+idea. You can't output too much debugging information.
+
+\section{The Metrop Function}
+
+The R function \texttt{metrop} in the \texttt{mcmc} package has an argument
+\verb at debug = FALSE@ that when \verb at TRUE@ causes extra debugging information
+to be output.
+Let \texttt{niter} be the number of iterations
+\verb at nbatch * blen * nspac@, and let \texttt{d} be the dimension of the state
+vector. The result of invoking \texttt{metrop} is a list. When
+\verb at debug = TRUE@ it has the following additional components
+\begin{itemize}
+\item \texttt{current}, an \texttt{niter} by \texttt{d} matrix
+ of mode \verb@"numeric"@, the state before iteration \texttt{i}
+ is \verb at current[i, ]@
+\item \texttt{proposal}, an \texttt{niter} by \texttt{d} matrix
+ of mode \verb@"numeric"@, the proposal for iteration \texttt{i}
+ is \verb at proposal[i, ]@
+\item \texttt{z}, an \texttt{niter} by \texttt{d} matrix
+ of mode \verb@"numeric"@, the vector of standard normal random variates
+ used to generate the proposal for iteration \texttt{i}
+ is \verb at z[i, ]@
+\item \texttt{log.green}, a vector of length \texttt{niter}
+ and mode \verb@"numeric"@, the logarithm of the Hastings ratio
+ for each iteration
+\item \texttt{u}, a vector of length \texttt{niter}
+ and mode \verb@"numeric"@, the $\text{Uniform}(0, 1)$ random variate
+ compared to the Hastings ratio for each iteration or \texttt{NA} if
+ none is needed (when the log Hastings ratio is nonnegative)
+\item \texttt{debug.accept}, a vector of length \texttt{niter}
+ and mode \verb@"logical"@, the decision for each iteration,
+ accept the proposal (\texttt{TRUE}) or reject it (\texttt{FALSE})
+\end{itemize}
+(The components \texttt{z} and \texttt{debug.accept} were added in
+version 0.7-3 of the \texttt{mcmc} package. Before that only the others
+were output.)
+
+Two components of the list returned by the \texttt{metrop} function always
+(whether \verb at debug = TRUE@ or \verb at debug = FALSE@) are also necessary
+for debugging. They are
+\begin{itemize}
+\item \texttt{initial.seed} the value of the variable \texttt{.Random.seed}
+ that contains the seeds of the R random number generator system before
+ invocation of the \texttt{metrop} function
+\item \texttt{final}, a vector of length \texttt{d} and mode \verb@"numeric"@,
+ the state after the last iteration
+\end{itemize}
+
+All of the files in the \texttt{tests} directory of the source for the
+package (not installed but found in the source tarball on CRAN) test
+the \texttt{metrop} function except those beginning \texttt{temp},
+which test the \texttt{temper} function. Since these tests were written
+many years ago, are spread out over many files, and are not commented,
+we will not describe them in detail. Suffice it to say that they check
+every aspect of the functioning of the \texttt{metrop} function.
+
+\section{The Temper Function}
+
+The R function \texttt{temper} in the \texttt{mcmc} package has an argument
+\verb at debug = FALSE@ that when \verb at TRUE@ causes extra debugging information
+to be output.
+Let \texttt{niter} be the number of iterations
+\verb at nbatch * blen * nspac@, let \texttt{d} be the dimension of the state
+vector, and let \texttt{ncomp} be the number of components of the tempering
+mixture.
+The result of invoking \texttt{temper} is a list. When
+\verb at debug = TRUE@ and \verb at parallel = TRUE@ it has the following additional
+components
+% which
+% unif.which
+% state
+% log.hastings
+% unif.hastings
+% proposal
+% acceptd
+% norm
+% unif.choose
+% coproposal
+\begin{itemize}
+\item \texttt{which}, a vector of length \texttt{niter}
+ and mode \verb@"logical"@ the type of update for each iteration,
+ within component (\texttt{TRUE}) or swap components (\texttt{FALSE}).
+\item \texttt{unif.which}, a vector of length \texttt{niter}
+ and mode \verb@"numeric"@, the $\text{Uniform}(0, 1)$ random variate
+ used to decide which type of update is done.
+\item \texttt{state}, an \texttt{niter} by \texttt{ncomp} by \texttt{d}
+ array of mode \verb@"numeric"@, the state before iteration \texttt{i}
+ is \verb at state[i, , ]@
+\item \texttt{proposal}, an \texttt{niter} by \verb at d + 1@
+ matrix of mode \verb@"numeric"@, the proposal for iteration \texttt{i}
+ is \verb at proposal[i, ]@ (explanation below)
+\item \texttt{coproposal}, an \texttt{niter} by \verb at d + 1@
+ matrix of mode \verb@"numeric"@, the proposal for iteration \texttt{i}
+ is \verb at coproposal[i, ]@ (explanation below)
+\item \texttt{log.hastings}, a vector of length \texttt{niter}
+ and mode \verb@"numeric"@, the logarithm of the Hastings ratio for
+ each iteration
+\item \texttt{unif.hastings}, a vector of length \texttt{niter}
+ and mode \verb@"numeric"@, the $\text{Uniform}(0, 1)$ random variate
+ compared to the Hastings ratio for each iteration or \texttt{NA} if
+ none is needed (when the log Hastings ratio is nonnegative)
+\item \texttt{acceptd}, a vector of length \texttt{niter}
+ and mode \verb@"logical"@, the decision for each iteration,
+ accept the proposal (\texttt{TRUE}) or reject it (\texttt{FALSE})
+\item \texttt{norm}, an \texttt{niter} by \texttt{d} matrix
+ of mode \verb@"numeric"@, the vector of standard normal random variates
+ used to generate the proposal for iteration \texttt{i} is \verb at z[i, ]@
+ unless none are needed (for swap updates) when it is \texttt{NA}
+\item \texttt{unif.choose}, an \texttt{niter} by 2 matrix
+ of mode \verb@"numeric"@, the vector of $\text{Uniform}(0, 1)$
+ random variates used to choose the components to update in iteration
+ \texttt{i} is \verb at unif.choose[i, ]@; in a swap update two are used;
+ in a within-component update only one is used and the second is \texttt{NA}
+\end{itemize}
+
+In a within-component update, one component say \texttt{j} is chosen for
+update. The \emph{coproposal} is the current value of the state for this
+component, which is a vector of length \verb at d + 1@, the first
+component of which is \texttt{j} and the rest of which is \verb at state[i, j, ]@
+if we are in iteration \texttt{i}.
+The \emph{proposal} is a similar vector, the first
+component of which is again \texttt{j} and the rest of which is a multivariate
+normal random vector centered at \verb at state[i, j, ]@.
+The coproposal is the current state; the proposal is the possible value
+(if accepted) of the state at the next time.
+
+In a swap update, two components say \texttt{j1} and \texttt{j2} are chosen for
+update. Strictly, speaking the coproposal is the pair of vectors
+\verb at c(j1, state[i, j1, ])@ and \verb at c(j2, state[i, j2, ])@
+and the proposal is these swapped, that is, the pair of vectors
+\verb at c(j2, state[i, j1, ])@ and \verb at c(j1, state[i, j2, ])@
+if we are in iteration \texttt{i}.
+Since, however, there is a lot of redundant information here,
+the vector \verb at c(j1, state[i, j1, ])@ is output as \verb at coproposal[i, ]@
+and the vector \verb at c(j2, state[i, j2, ])@ is output as \verb at proposal[i, ]@.
+
+When \verb at debug = TRUE@ and \verb at parallel = FALSE@
+the result of invoking \texttt{temper} is a list having
+the following additional components
+% which
+% unif.which
+% state
+% log.hastings
+% unif.hastings
+% proposal
+% acceptd
+% norm
+% unif.choose
+\begin{itemize}
+\item \texttt{which}, a vector of length \texttt{niter}
+ and mode \verb@"logical"@ the type of update for each iteration,
+ within component (\texttt{TRUE}) or jump from one component to
+ another (\texttt{FALSE}).
+\item \texttt{unif.which}, a vector of length \texttt{niter}
+ and mode \verb@"numeric"@, the $\text{Uniform}(0, 1)$ random variate
+ used to decide which type of update is done.
+\item \texttt{state}, an \texttt{niter} by \verb at d + 1@
+ matrix of mode \verb@"numeric"@, the state before iteration \texttt{i}
+ is \verb at state[i, ]@
+\item \texttt{proposal}, an \texttt{niter} by \verb at d + 1@
+ matrix of mode \verb@"numeric"@, the proposal for iteration \texttt{i}
+ is \verb at proposal[i, ]@
+\item \texttt{log.hastings}, a vector of length \texttt{niter}
+ and mode \verb@"numeric"@, the logarithm of the Hastings ratio for
+ each iteration
+\item \texttt{unif.hastings}, a vector of length \texttt{niter}
+ and mode \verb@"numeric"@, the $\text{Uniform}(0, 1)$ random variate
+ compared to the Hastings ratio for each iteration or \texttt{NA} if
+ none is needed (when the log Hastings ratio is nonnegative)
+\item \texttt{acceptd}, a vector of length \texttt{niter}
+ and mode \verb@"logical"@, the decision for each iteration,
+ accept the proposal (\texttt{TRUE}) or reject it (\texttt{FALSE})
+\item \texttt{norm}, an \texttt{niter} by \texttt{d} matrix
+ of mode \verb@"numeric"@, the vector of standard normal random variates
+ used to generate the proposal for iteration \texttt{i} is \verb at z[i, ]@
+ unless none are needed (for jump updates) when it is \texttt{NA}
+\item \texttt{unif.choose}, a vector of length \texttt{niter}
+ and mode \verb@"numeric"@, the $\text{Uniform}(0, 1)$
+ random variates used to choose the component to update in iteration
+ \texttt{i} is \verb at unif.choose[i, ]@; in a jump update one is used;
+ in a within-component update none is used and \texttt{NA} is output
+\end{itemize}
+
+All of the files in the \texttt{tests} directory of the source for the
+package (not installed but found in the source tarball on CRAN)
+beginning \texttt{temp} test the \texttt{temper} function.
+They check every aspect of the functioning of the \texttt{temper} function.
+
+In the file \texttt{temp-par.R} in the \texttt{tests} directory, the following
+checks are made according to the comments in that file
+\begin{enumerate}
+\item check decision about within-component or jump/swap
+\item check proposal and coproposal are actually current state or part thereof
+\item check hastings ratio calculated correctly
+\item check hastings rejection decided correctly
+\item check acceptance carried out or not (according to decision) correctly
+\item check within-component proposal
+\item check swap proposal
+\item check standard normal and uniform random numbers are as purported
+\item check batch means
+\item check acceptance rates
+\item check scale vector
+\item check scale matrix
+\item check scale list
+\item check outfun
+\end{enumerate}
+In the file \texttt{temp-ser.R} in the \texttt{tests} directory, the all of
+the same checks are made according to the comments in that file except for
+check number 2 above, which would make no sense because there is no
+\texttt{coproposal} component in the serial (\verb at parallel = FALSE@) case.
+
+\end{document}
+
diff --git a/vignettes/demo.Rnw b/vignettes/demo.Rnw
new file mode 100644
index 0000000..4f84b9e
--- /dev/null
+++ b/vignettes/demo.Rnw
@@ -0,0 +1,609 @@
+
+\documentclass{article}
+
+\usepackage{natbib}
+\usepackage{graphics}
+\usepackage{amsmath}
+\usepackage{indentfirst}
+\usepackage[utf8]{inputenc}
+
+\DeclareMathOperator{\var}{var}
+\DeclareMathOperator{\cov}{cov}
+
+% \VignetteIndexEntry{MCMC Example}
+
+\begin{document}
+
+<<foo,include=FALSE,echo=FALSE>>=
+options(keep.source = TRUE, width = 60)
+foo <- packageDescription("mcmc")
+@
+
+\title{MCMC Package Example (Version \Sexpr{foo$Version})}
+\author{Charles J. Geyer}
+\maketitle
+
+\section{The Problem}
+
+This is an example of using the \verb at mcmc@ package in R. The problem comes
+from a take-home question on a (take-home) PhD qualifying exam
+(School of Statistics, University of Minnesota).
+
+Simulated data for the problem are in the dataset \verb at logit@.
+There are five variables in the data set, the response \verb at y@
+and four predictors, \verb at x1@, \verb at x2@, \verb at x3@, and \verb at x4@.
+
+A frequentist analysis for the problem is done by the following R statements
+<<frequentist>>=
+library(mcmc)
+data(logit)
+out <- glm(y ~ x1 + x2 + x3 + x4, data = logit,
+ family = binomial(), x = TRUE)
+summary(out)
+@
+
+But this problem isn't about that frequentist analysis, we want a Bayesian
+analysis. For our Bayesian analysis we assume the same data model as the
+frequentist, and we assume the prior distribution of the five parameters
+(the regression coefficients) makes them independent and identically
+normally distributed with mean 0 and standard deviation 2.
+
+The log unnormalized posterior (log likelihood plus log prior) density
+for this model is calculated by
+the following R function (given the preceding data definitions)
+<<log.unnormalized.posterior>>=
+x <- out$x
+y <- out$y
+
+lupost <- function(beta, x, y) {
+ eta <- as.numeric(x %*% beta)
+ logp <- ifelse(eta < 0, eta - log1p(exp(eta)), - log1p(exp(- eta)))
+ logq <- ifelse(eta < 0, - log1p(exp(eta)), - eta - log1p(exp(- eta)))
+ logl <- sum(logp[y == 1]) + sum(logq[y == 0])
+ return(logl - sum(beta^2) / 8)
+}
+@
+The tricky calculation of the log likelihood avoids overflow and catastrophic
+cancellation in calculation of $\log(p)$ and $\log(q)$ where
+\begin{align*}
+ p & = \frac{\exp(\eta)}{1 + \exp(\eta)} = \frac{1}{1 + \exp(- \eta)}
+ \\
+ q & = \frac{1}{1 + \exp(\eta)} = \frac{\exp(- \eta)}{1 + \exp(- \eta)}
+\end{align*}
+so taking logs gives
+\begin{align*}
+ \log(p) & = \eta - \log(1 + \exp(\eta)) = - \log(1 + \exp(- \eta))
+ \\
+ \log(q) & = - \log(1 + \exp(\eta)) = - \eta - \log(1 + \exp(- \eta))
+\end{align*}
+To avoid overflow, we always chose the case where the argument of $\exp$
+is negative. We have also avoided catastrophic cancellation when
+$\lvert\eta\rvert$ is large. If $\eta$ is large and positive, then
+\begin{align*}
+ p & \approx 1
+ \\
+ q & \approx 0
+ \\
+ \log(p) & \approx - \exp(- \eta)
+ \\
+ \log(q) & \approx - \eta - \exp(- \eta)
+\end{align*}
+and our use of the R function \texttt{log1p}, which calculates the
+function $x \mapsto \log(1 + x)$
+correctly for small $x$ avoids all problems. The case where $\eta$ is large
+and negative is similar.
+
+\section{Beginning MCMC}
+
+With those definitions in place, the following code runs the Metropolis
+algorithm to simulate the posterior.
+<<metropolis-try-1>>=
+set.seed(42) # to get reproducible results
+beta.init <- as.numeric(coefficients(out))
+out <- metrop(lupost, beta.init, 1e3, x = x, y = y)
+names(out)
+out$accept
+@
+
+The arguments to the \verb at metrop@ function used here (there are others
+we don't use) are
+\begin{itemize}
+\item an R function (here \verb at lupost@) that evaluates the log unnormalized
+ density of the desired stationary distribution of the Markov chain
+ (here a posterior distribution). Note that (although this example
+ does not exhibit the phenomenon) that the unnormalized density may
+ be zero, in which case the log unnormalized density is \verb at -Inf@.
+\item an initial state (here \verb at beta.init@) of the Markov chain.
+\item a number of batches (here \verb at 1e3@) for the Markov chain.
+ This combines with batch length and spacing (both 1 by default)
+ to determine the number of iterations done.
+\item additional arguments (here \verb at x@ and \verb at y@) supplied to
+ provided functions (here \verb at lupost@).
+\item there is no ``burn-in'' argument, although burn-in is easily
+ accomplished, if desired (more on this below).
+\end{itemize}
+
+The output is in the component \verb at out$batch@ returned by the \verb at metrop@
+function. We'll look at it presently, but first we need to adjust the
+proposal to get a higher acceptance rate (\verb at out$accept@). It is generally
+accepted \citep*{grg} that an acceptance rate of about 20\% is right, although
+this recommendation is based on the asymptotic analysis of a toy problem
+(simulating a multivariate normal distribution) for which one would never
+use MCMC and is very unrepresentative of difficult MCMC applications.
+
+\citet{geyer-temp} came to a similar conclusion,
+that a 20\% acceptance rate is about right, in a very different situation.
+But they also warned that a 20\% acceptance rate could be very wrong
+and produced
+an example where a 20\% acceptance rate was impossible and attempting to
+reduce the acceptance rate below 70\% would keep the sampler from ever
+visiting part of the state space. So the 20\% magic number must be
+considered like other rules of thumb we teach in intro courses
+(like $n > 30$ means means normal approximation is valid).
+We know these rules of thumb can fail.
+There are examples in the literature where
+they do fail. We keep repeating them because we want something simple to
+tell beginners, and they are all right for some problems.
+
+Be that as it may, we try for 20\%.
+<<metropolis-try-2>>=
+out <- metrop(out, scale = 0.1, x = x, y = y)
+out$accept
+out <- metrop(out, scale = 0.3, x = x, y = y)
+out$accept
+out <- metrop(out, scale = 0.5, x = x, y = y)
+out$accept
+out <- metrop(out, scale = 0.4, x = x, y = y)
+out$accept
+@
+
+Here the first argument to each instance of the \verb at metrop@ function is
+the output of a previous invocation. The Markov chain continues where
+the previous run stopped, doing just what it would have done if it had
+kept going, the initial state and random seed being the final state and
+random seed of the previous invocation. Everything stays the same
+except for the arguments supplied (here \verb at scale@).
+\begin{itemize}
+\item The argument \verb at scale@ controls the size of the Metropolis
+ ``normal random walk'' proposal. The default is \verb at scale = 1 at .
+ Big steps give lower acceptance rates. Small steps give higher.
+ We want something about 20\%. It is also possible to make \verb at scale@
+ a vector or a matrix. See \verb at help(metrop)@.
+\end{itemize}
+
+Because each run starts where the last one stopped (when the first argument
+to \verb at metrop@ is the output of the previous invocation), each run serves
+as ``burn-in'' for its successor (assuming that any part of that run was
+worth anything at all).
+
+\section{Diagnostics}
+
+O.~K. That does it for the acceptance rate. So let's do a longer run
+and look at the results.
+<<label=metropolis-try-3>>=
+out <- metrop(out, nbatch = 1e4, x = x, y = y)
+out$accept
+out$time
+@
+
+Figure~\ref{fig:fig1} (page~\pageref{fig:fig1})
+shows the time series plot made by the R statement
+<<label=fig1too,include=FALSE>>=
+plot(ts(out$batch))
+@
+\begin{figure}
+\begin{center}
+<<label=fig1,fig=TRUE,echo=FALSE>>=
+<<fig1too>>
+@
+\end{center}
+\caption{Time series plot of MCMC output.}
+\label{fig:fig1}
+\end{figure}
+
+Another way to look at the output is an autocorrelation plot.
+Figure~\ref{fig:fig2} (page~\pageref{fig:fig2})
+shows the time series plot made by the R statement
+<<label=fig2too,include=FALSE>>=
+acf(out$batch)
+@
+\begin{figure}
+\begin{center}
+<<label=fig2,fig=TRUE,echo=FALSE>>=
+<<fig2too>>
+@
+\end{center}
+\caption{Autocorrelation plot of MCMC output.}
+\label{fig:fig2}
+\end{figure}
+
+As with any multiplot plot, these are a bit hard to read. Readers are
+invited to make the separate plots to get a better picture.
+As with all ``diagnostic'' plots in MCMC, these don't ``diagnose''
+subtle problems. As
+\begin{verbatim}
+http://www.stat.umn.edu/~charlie/mcmc/diag.html
+\end{verbatim}
+says
+\begin{quotation}
+The purpose of regression diagnostics is to find obvious, gross,
+embarrassing problems that jump out of simple plots.
+\end{quotation}
+The time series plots will show \emph{obvious} nonstationarity.
+They will not show \emph{nonobvious} nonstationarity. They
+provide no guarantee whatsoever that your Markov chain is sampling
+anything remotely resembling the correct stationary distribution
+(with log unnormalized density \verb at lupost@). In this very easy
+problem, we do not expect any convergence difficulties and so believe
+what the diagnostics seem to show, but one is a fool to trust such
+diagnostics in difficult problems.
+
+The autocorrelation plots seem to show that the
+the autocorrelations are negligible after about lag 25.
+This diagnostic inference is reliable if the sampler is actually
+working (has nearly reached equilibrium) and worthless otherwise.
+Thus batches of length 25 should be sufficient, but let's use
+length 100 to be safe.
+
+\section{Monte Carlo Estimates and Standard Errors}
+
+<<label=metropolis-try-4>>=
+out <- metrop(out, nbatch = 1e2, blen = 100,
+ outfun = function(z, ...) c(z, z^2), x = x, y = y)
+out$accept
+out$time
+@
+
+We have added an argument \verb at outfun@ that gives the ``functional''
+of the state we want to average. For this problem we are interested
+in both posterior mean and variance. Mean is easy, just average the
+variables in question. But variance is a little tricky. We need to
+use the identity
+$$
+ \var(X) = E(X^2) - E(X)^2
+$$
+to write variance as a function of two things that can be estimated
+by simple averages. Hence we want to average the state itself and
+the squares of each component. Hence our \verb at outfun@ returns
+\verb at c(z, z^2)@ for an argument (the state vector) \verb at z@.
+
+The \verb at ...@ argument to \verb at outfun@ is required, since the
+function is also passed the other arguments (here \verb at x@ and \verb at y@)
+to \verb at metrop@.
+
+\subsection{Simple Means}
+
+The grand means (means of batch means) are
+<<label=metropolis-batch>>=
+apply(out$batch, 2, mean)
+@
+The first 5 numbers are the Monte Carlo estimates of the posterior means.
+The second 5 numbers are the Monte Carlo estimates of the posterior
+ordinary second moments. We get the posterior variances by
+<<label=metropolis-batch-too>>=
+foo <- apply(out$batch, 2, mean)
+mu <- foo[1:5]
+sigmasq <- foo[6:10] - mu^2
+mu
+sigmasq
+@
+
+Monte Carlo standard errors (MCSE) are calculated from the batch means.
+This is simplest for the means.
+<<label=metropolis-mcse-mu>>=
+mu.mcse <- apply(out$batch[ , 1:5], 2, sd) / sqrt(out$nbatch)
+mu.mcse
+@
+The extra factor \verb at sqrt(out$nbatch)@ arises because the batch means
+have variance $\sigma^2 / b$ where $b$ is the batch length, which is
+\verb at out$blen@,
+whereas the overall means \verb at mu@ have variance $\sigma^2 / n$ where
+$n$ is the total number of iterations, which is \verb at out$blen * out$nbatch at .
+
+\subsection{Functions of Means}
+
+To get the MCSE for the posterior variances we apply the delta method.
+Let $u_i$ denote the sequence of batch means of the first kind for one
+parameter and $\bar{u}$ the grand mean (the estimate of the posterior mean
+of that parameter),
+let $v_i$ denote the sequence of batch means of the second kind for the
+same parameter and $\bar{v}$ the grand mean (the estimate of the posterior
+second absolute moment of that parameter), and let $\mu = E(\bar{u})$ and
+$\nu = E(\bar{v})$. Then the delta method linearizes the nonlinear function
+$$
+ g(\mu, \nu) = \nu - \mu^2
+$$
+as
+$$
+ \Delta g(\mu, \nu) = \Delta \nu - 2 \mu \Delta \mu
+$$
+saying that
+$$
+ g(\bar{u}, \bar{v}) - g(\mu, \nu)
+$$
+has the same asymptotic normal distribution as
+$$
+ (\bar{v} - \nu) - 2 \mu (\bar{u} - \mu)
+$$
+which, of course, has variance \verb at 1 / nbatch@ times that of
+$$
+ (v_i - \nu) - 2 \mu (u_i - \mu)
+$$
+and this variance is estimated by
+$$
+ \frac{1}{n_{\text{batch}}} \sum_{i = 1}^{n_{\text{batch}}}
+ \bigl[ (v_i - \bar{v}) - 2 \bar{u} (u_i - \bar{u}) \bigr]^2
+$$
+So
+<<label=metropolis-mcse-sigmasq>>=
+u <- out$batch[ , 1:5]
+v <- out$batch[ , 6:10]
+ubar <- apply(u, 2, mean)
+vbar <- apply(v, 2, mean)
+deltau <- sweep(u, 2, ubar)
+deltav <- sweep(v, 2, vbar)
+foo <- sweep(deltau, 2, ubar, "*")
+sigmasq.mcse <- sqrt(apply((deltav - 2 * foo)^2, 2, mean) / out$nbatch)
+sigmasq.mcse
+@
+does the MCSE for the posterior variance.
+
+Let's just check that this complicated \verb at sweep@ and \verb at apply@ stuff
+does do the right thing.
+<<label=metropolis-mcse-sigmasq-too>>=
+sqrt(mean(((v[ , 2] - vbar[2]) - 2 * ubar[2] * (u[ , 2] - ubar[2]))^2) /
+ out$nbatch)
+@
+
+\paragraph{Comment} Through version 0.5 of this vignette it contained
+an incorrect procedure for calculating this MCSE, justified by a handwave
+(which was incorrect).
+Essentially, it said to use the standard deviation of the batch means called
+\verb at v@ here, which appears to be very conservative.
+
+\subsection{Functions of Functions of Means}
+
+If we are also interested in the posterior standard deviation
+(a natural question, although not asked on the exam problem),
+the delta method gives its standard error in terms of that
+for the variance
+<<label=metropolis-mcse-sigma>>=
+sigma <- sqrt(sigmasq)
+sigma.mcse <- sigmasq.mcse / (2 * sigma)
+sigma
+sigma.mcse
+@
+
+\section{A Final Run}
+
+So that's it. The only thing left to do is a little more precision
+(the exam problem directed ``use a long enough run of your Markov chain
+sampler so that the MCSE are less than 0.01'')
+<<label=metropolis-try-5>>=
+out <- metrop(out, nbatch = 5e2, blen = 400, x = x, y = y)
+out$accept
+out$time
+<<metropolis-batch-too>>
+<<metropolis-mcse-mu>>
+<<metropolis-mcse-sigmasq>>
+<<metropolis-mcse-sigma>>
+@
+and some nicer output, which is presented in three tables
+constructed from the R variables defined above
+using the R \verb at xtable@ command in the \verb at xtable@ library.
+
+First the posterior means,
+\begin{table}[ht]
+\caption{Posterior Means}
+\label{tab:mu}
+\begin{center}
+<<label=tab1,echo=FALSE,results=tex>>=
+foo <- rbind(mu, mu.mcse)
+dimnames(foo) <- list(c("estimate", "MCSE"),
+ c("constant", paste("$x_", 1:4, "$", sep = "")))
+library(xtable)
+print(xtable(foo, digits = rep(4, 6),
+ align = c("l", rep("c", 5))), floating = FALSE,
+ caption.placement = "top",
+ sanitize.colnames.function = function(x) return(x))
+@
+\end{center}
+\end{table}
+then the posterior variances (table on page~\pageref{tab:sigmasq}),
+\begin{table}[ht]
+\caption{Posterior Variances}
+\label{tab:sigmasq}
+\begin{center}
+<<label=tab1,echo=FALSE,results=tex>>=
+foo <- rbind(sigmasq, sigmasq.mcse)
+dimnames(foo) <- list(c("estimate", "MCSE"),
+ c("constant", paste("$x_", 1:4, "$", sep = "")))
+library(xtable)
+print(xtable(foo, digits = rep(4, 6),
+ align = c("l", rep("c", 5))), floating = FALSE,
+ caption.placement = "top",
+ sanitize.colnames.function = function(x) return(x))
+@
+\end{center}
+\end{table}
+and finally the posterior standard deviations
+(table on page~\pageref{tab:sigma}).
+\begin{table}[ht]
+\caption{Posterior Standard Deviations}
+\label{tab:sigma}
+\begin{center}
+<<label=tab1,echo=FALSE,results=tex>>=
+foo <- rbind(sigma, sigma.mcse)
+dimnames(foo) <- list(c("estimate", "MCSE"),
+ c("constant", paste("$x_", 1:4, "$", sep = "")))
+library(xtable)
+print(xtable(foo, digits = rep(4, 6),
+ align = c("l", rep("c", 5))), floating = FALSE,
+ caption.placement = "top",
+ sanitize.colnames.function = function(x) return(x))
+@
+\end{center}
+\end{table}
+
+Note for the record that the all the results presented in the tables
+are from ``one long run'' where long here took only
+<<label=time,echo=FALSE,results=tex>>=
+cat(out$time[1], "\n")
+@
+seconds (on whatever computer it was run on).
+
+\section{New Variance Estimation Functions}
+
+A new function \texttt{initseq} estimates variances in the Markov chain
+central limit theorem (CLT) following the methodology introduced by
+\citet[Section~3.3]{practical}. These methods only apply to scalar-valued
+functionals of
+reversible Markov chains, but the Markov chains produced by the \texttt{metrop}
+function satisfy this condition, even, as we shall see below, when batching
+is used.
+
+Rather than redo the Markov chains in the preceding material, we just look
+at a toy problem, an AR(1) time series, which can be simulated in one line
+of R. This is the example on the help page for \texttt{initseq}.
+<<x>>=
+n <- 2e4
+rho <- 0.99
+x <- arima.sim(model = list(ar = rho), n = n)
+@
+The time series \texttt{x} is a reversible Markov chain and trivially
+a scalar-valued functional of a Markov chain.
+
+Define
+\begin{equation} \label{eq:little}
+ \gamma_k = \cov(X_i, X_{i + k})
+\end{equation}
+where the covariances refer to the stationary Markov chain having the
+same transition probabilities as \texttt{x}. Then the variance in the CLT
+is
+$$
+ \sigma^2 = \gamma_0 + 2 \sum_{k = 1}^\infty \gamma_k
+$$
+\citep[Theorem~2.1]{practical}, that is,
+$$
+ \bar{x}_n \approx \text{Normal}\left(\mu, \frac{\sigma^2}{n}\right),
+$$
+where $\mu = E(X_i)$ is the quantity being estimated by MCMC (in this
+toy problem we know $\mu = 0$).
+
+Naive estimates of $\sigma^2$ obtained by plugging in empirical
+estimates of the gammas do not provide consistent estimation
+\citep[Section~3.1]{practical}. Thus the scheme implemented
+by the R function \texttt{initseq}. Define
+\begin{equation} \label{eq:big}
+ \Gamma_k = \gamma_{2 k} + \gamma_{2 k + 1}
+\end{equation}
+\citet[Theorem~3.1]{practical} says that $\Gamma_k$ considered as a function
+of $k$ is strictly positive, strictly decreasing, and strictly convex
+(provided we are, as stated above, working with a reversible Markov chain).
+Thus it makes sense to use estimators that use these properties.
+The estimators implemented by the R function \texttt{initseq} and
+described by \citet[Section~3.3]{practical} are conservative-consistent
+in the sense of Theorem~3.2 of that section.
+
+Figure~\ref{fig:gamma} (page~\pageref{fig:gamma})
+shows the time series plot made by the R statement
+<<label=figgamtoo,include=FALSE>>=
+out <- initseq(x)
+plot(seq(along = out$Gamma.pos) - 1, out$Gamma.pos,
+ xlab = "k", ylab = expression(Gamma[k]), type = "l")
+lines(seq(along = out$Gamma.dec) - 1, out$Gamma.dec, lty = "dotted")
+lines(seq(along = out$Gamma.con) - 1, out$Gamma.con, lty = "dashed")
+@
+\begin{figure}
+\begin{center}
+<<label=figgam,fig=TRUE,echo=FALSE>>=
+<<figgamtoo>>
+@
+\end{center}
+\caption{Plot ``Big Gamma'' defined by \eqref{eq:little} and \eqref{eq:big}.
+Solid line, initial positive sequence estimator.
+Dotted line, initial monotone sequence estimator.
+Dashed line, initial convex sequence estimator.}
+\label{fig:gamma}
+\end{figure}
+One can use whichever curve one chooses, but now that
+the \texttt{initseq} function makes the computation trivial, it makes
+sense to use the initial convex sequence.
+
+Of course, one is not interested in Figure~\ref{fig:gamma}, except
+perhaps when explaining the methodology. What is actually important
+is the estimate of $\sigma^2$, which is given by
+<<assvar>>=
+out$var.con
+(1 + rho) / (1 - rho) * 1 / (1 - rho^2)
+@
+where for comparison we have given the exact theoretical value of $\sigma^2$,
+which, of course, is never available in a non-toy problem.
+
+These initial sequence estimators seem, at first sight to be a competitor
+for the method of batch means. However, appearances can be deceiving.
+The two methods are complementary. The sequence of batch means is itself
+a scalar-valued functional of a reversible Markov chain. Hence the
+initial sequence estimators can be applied to it.
+<<batx>>=
+blen <- 5
+x.batch <- apply(matrix(x, nrow = blen), 2, mean)
+bout <- initseq(x.batch)
+@
+Because the batch length is too short, the variance of the batch means
+does not estimate $\sigma^2$. We must account for the autocorrelation
+of the batches, shown in Figure~\ref{fig:gambat}.
+<<label=figgambattoo,include=FALSE>>=
+plot(seq(along = bout$Gamma.con) - 1, bout$Gamma.con,
+ xlab = "k", ylab = expression(Gamma[k]), type = "l")
+@
+\begin{figure}
+\begin{center}
+<<label=figgambat,fig=TRUE,echo=FALSE>>=
+<<figgambattoo>>
+@
+\end{center}
+\caption{Plot ``Big Gamma'' defined by \eqref{eq:little} and \eqref{eq:big}
+for the sequence of batch means (batch length \Sexpr{blen}).
+Only initial convex sequence estimator is shown.}
+\label{fig:gambat}
+\end{figure}
+Because the the variance is proportional to one over the batch length,
+we need to multiply by the batch length to estimate the $\sigma^2$
+for the original series.
+<<compvar>>=
+out$var.con
+bout$var.con * blen
+@
+Another way to look at this is that the MCMC estimator of $\mu$ is
+either \texttt{mean(x)} or \texttt{mean(x.batch)}. And the variance
+must be divided by the sample size to give standard errors. So either
+<<ci-con>>=
+mean(x) + c(-1, 1) * qnorm(0.975) * sqrt(out$var.con / length(x))
+mean(x.batch) + c(-1, 1) * qnorm(0.975) * sqrt(bout$var.con / length(x.batch))
+@
+is an asymptotic 95\% confidence interval for $\mu$. Just divide by
+the relevant sample size.
+
+\begin{thebibliography}{}
+
+\bibitem[Gelman et al.(1996)Gelman, Roberts, and Gilks]{grg}
+Gelman, A., G.~O. Roberts, and W.~R. Gilks (1996).
+\newblock Efficient Metropolis jumping rules.
+\newblock In \emph{Bayesian Statistics, 5 (Alicante, 1994)}, pp.~599--607.
+ Oxford University Press.
+
+\bibitem[Geyer(1992)]{practical}
+Geyer, C.~J. (1992).
+\newblock Practical Markov chain Monte Carlo (with discussion).
+\newblock \emph{Statistical Science}, 7, 473--511.
+
+\bibitem[Geyer and Thompson(1995)]{geyer-temp}
+Geyer, C.~J. and E.~A. Thompson (1995).
+\newblock Annealing Markov chain Monte Carlo with applications to
+ ancestral inference.
+\newblock \emph{Journal of the American Statistical Association}, 90, 909--920.
+
+\end{thebibliography}
+
+\end{document}
diff --git a/vignettes/morph.Rnw b/vignettes/morph.Rnw
new file mode 100644
index 0000000..e6e403c
--- /dev/null
+++ b/vignettes/morph.Rnw
@@ -0,0 +1,703 @@
+\documentclass{article}
+
+\usepackage{natbib}
+\usepackage{graphics}
+\usepackage{amsmath,amssymb}
+\usepackage{indentfirst}
+\usepackage[utf8]{inputenc}
+\usepackage[tableposition=top]{caption}
+\usepackage{url}
+
+\DeclareMathOperator{\var}{var}
+\DeclareMathOperator{\cov}{cov}
+\DeclareMathOperator{\E}{E}
+\newcommand{\inner}[1]{\langle #1 \rangle}
+
+% \VignetteIndexEntry{MCMC Morph Example}
+
+\begin{document}
+
+<<foo,include=FALSE,echo=FALSE>>=
+options(keep.source = TRUE, width = 60)
+foo <- packageDescription("mcmc")
+@
+
+\title{Morphometric MCMC (mcmc Package Ver.~\Sexpr{foo$Version})}
+% $ (Just to make emacs syntax highlighting work properly)
+\author{Leif T. Johnson \and Charles J. Geyer}
+\maketitle
+
+\section{Overview}
+
+This is an example how to use morphometric Markov chains as implemented in
+the \verb at mcmc@ package in R.
+
+Let $X$ be an $\mathbb{R}^k$ valued random variable with probability density
+function, $f_X$. Let $g$ be a diffeomorphism, and $Y=g(X)$. Then the
+probability density function of $Y$, $f_Y$ is given by
+\begin{equation}\label{eq:def-fy}
+ f_Y(y) = f_X\bigl(g^{-1}(y)\bigr) \det\bigl( \nabla g^{-1}(y) \bigr).
+\end{equation}
+Since $g$ is a diffeomorphism, we can draw inference about $X$ from information
+about $Y$ (and vice versa).
+
+It is not unusual for $f_X$ to either be known only up to a normalizing
+constant, or to be analytically intractable in other ways --- such as
+being high dimensional.
+A common solution to this problem is to use Markov chain
+Monte Carlo (MCMC) methods to learn about $f_X$.
+
+When using MCMC, a primary concern of the practitioner should be the question
+``Does the Markov chain converge fast enough to be useful?'' One very useful
+convergence rate is called \emph{geometrically ergodic}
+\citep[Chapter~1]{johnson-thesis}.
+
+The \texttt{mcmc} package implements the Metropolis random-walk algorithm for
+arbitrary log unnormalized probability densities. But the Metropolis
+random-walk algorithm does not always perform well. As is demonstrated in
+\citet{johnson-geyer}, for $f_X$ and $f_Y$ related by diffeomorphism as in
+\eqref{eq:def-fy}, a Metropolis random-walk for $f_Y$ can be geometrically
+ergodic
+even though a Metropolis random-walk for $f_X$ is not.
+Since the transformation is
+one-to-one, inference about $f_X$ can be drawn from the Markov chain for $f_Y$.
+
+The \texttt{morph.metrop} and \texttt{morph} functions in the \texttt{mcmc}
+package provide this functionality, and this vignette gives a demonstration
+on how to use them.
+
+\section{T Distribution} \label{sec:toy}
+
+We start with a univariate example, which is a Student $t$ distribution
+with three degrees of freedom.
+Of course, one doesn't need MCMC to simulate this distribution
+(the R function \texttt{rt} does that), so this is just a toy problem.
+But it does illustrate some aspects of using variable transformation.
+
+A necessary condition for geometric ergodicity of a random-walk Metropolis
+algorithm is that the target density $\pi$ have a moment generating function
+\citep{jarner-tweedie}.
+For a univariate target density, which we have in this section,
+a sufficient condition for geometric ergodicity of a random-walk Metropolis
+algorithm is that the target density $\pi$ be exponentially light
+\citet{mengersen-tweedie}.
+Thus if we do not use variable transformation,
+the Markov chain simulated by the \texttt{metrop} function will not
+be geometrically ergodic.
+\citet[Example 4.2]{johnson-geyer} show that a $t$ distribution is
+sub-exponentially light. Hence using the transformations
+described in their Corollaries~1 and~2 will induce a target density
+$\pi_\gamma$ for which a Metropolis random-walk will be geometrically
+ergodic.
+using the transformation described as $h_2$ in
+\citet[Corollary~2]{johnson-geyer} will induce a target density for which a
+Metropolis random-walk will be geometrically ergodic.
+
+Passing a positive value for \texttt{b} to \texttt{morph} function will
+create the aforementioned transformation, $h_2$. It's as simple as
+<<>>=
+library(mcmc)
+h2 <- morph(b=1)
+@
+We can now see the induced density. Note that \texttt{morph} works for
+log unnormalized densities, so we need exponentiate the induced density to
+plot it on the usual scale.
+<<>>=
+lud <- function(x) dt(x, df=3, log=TRUE)
+lud.induced <- h2$lud(lud)
+@
+We can plot the two densities,
+<<fig=TRUE>>=
+curve(exp(Vectorize(lud.induced)(x)), from = -3, to = 3, lty = 2,
+ xlab = "t", ylab = "density")
+curve(exp(lud(x)), add = TRUE)
+legend("topright", c("t density", "induced density"), lty=1:2)
+@
+
+The \texttt{Vectorize} in this example is necessary because
+the function \texttt{lud.induced} is not vectorized.
+Instead, it treats any vector passed as a single input, which
+is rescaled (using the specified diffeomorphism) and passed to
+\texttt{lud}. Compare the behavior of \texttt{lud} and
+\texttt{lud.induced} in the following example.
+<<>>=
+lud(1:4)
+lud(1)
+foo <- try(lud.induced(1:4))
+class(foo)
+cat(foo, "\n")
+lud.induced(1)
+@
+Because the function \texttt{dt} is vectorized, the function \texttt{lud}
+is also vectorized, mapping vectors to vectors,
+whereas the function \texttt{lud.induced} is not vectorized,
+mapping vectors to scalars.
+
+Before we start using random numbers, we set the seed of the random number
+generator so this document always produces the same results.
+<<set-seed>>=
+set.seed(42)
+@
+To change the results, change the seed or delete the \texttt{set.seed}
+statement.
+
+Running a Markov chain for the induced density is done with
+\texttt{morph.metrop}.
+<<>>=
+out <- morph.metrop(lud, 0, blen=100, nbatch=100, morph=morph(b=1))
+@
+The content of \texttt{out\$batch} is on the scale of used by
+\texttt{lud}. Once the transformation has been set, no adjustment is
+needed (unless you want to change transformations). We start by adjusting
+the scale.
+<<>>=
+# adjust scale to find a roughly 20% acceptance rate
+out$accept
+@
+An acceptance rate of \Sexpr{round(100 * out$accept, 1)}\%
+%$ to fix emacs highlighting
+is probably too high. By increasing the scale of the proposal distribution
+we can bring it down towards 20\%.
+<<>>=
+out <- morph.metrop(out, scale=4)
+out$accept
+@
+We now use this Markov chain to estimate the expectation of the target
+distribution.
+But first we need to check whether our batch length is good.
+The following code
+<<label=fig0too,include=FALSE>>=
+acf(out$batch)
+@
+makes the autocorrelation plot (Figure~\ref{fig:fig0}).
+\begin{figure}
+\begin{center}
+<<label=fig0,fig=TRUE,echo=FALSE>>=
+<<fig0too>>
+@
+\end{center}
+\caption{Autocorrelation plot for the sequence of batch means.}
+\label{fig:fig0}
+\end{figure}
+It looks like there is no significant autocorrelation among the batches
+so the following produces a valid confidence interval for the true
+unknown mean of the target distribution (since this is a toy problem
+we actually know the true ``unknown'' mean is zero, but we pretend we
+don't know that for the purposes of the toy problem)
+<<>>=
+t.test(out$batch)
+@
+If we want a point estimate and a Monte Carlo standard error, those are
+<<>>=
+colMeans(out$batch)
+apply(out$batch, 2, sd) / sqrt(out$nbatch)
+@
+If a shorter confidence interval is desired, the Markov chain can be run
+longer (increase either the number of batches or the batch length, or both).
+
+Note that when calculating our estimate and the Monte Carlo standard error
+we are not concerned with what was happening on the transformed scale. The
+\texttt{morph.metrop} function seamlessly does this for us.
+
+\subsection{Comparison of Morphed and Unmorphed}
+
+To show the utility of the transformation, we will study the behavior
+of the Markov chain with and without the transformation for the same
+problem as in the preceding section.
+We will consider two different estimation methods.
+\begin{enumerate}
+\item \label{enum:rw} Estimate the mean of the target distribution
+ using a random-walk Metropolis algorithm implemented by the \texttt{metrop}
+ function. \citet{jarner-roberts} demonstrate that a central limit
+ theorem does not hold for these estimates.
+\item \label{enum:rw-induced} Estimate the mean of the target distribution
+ using a random-walk Metropolis algorithm implemented by the
+ \texttt{morph.metrop} function with argument \texttt{morph = morph(b=1)}.
+ \citet{johnson-geyer} demonstrate that a central limit
+ theorem does hold for these estimates.
+\end{enumerate}
+
+For the former, we need to adjust the scale.
+<<unmorph-metrop-adjust>>=
+out.unmorph <- metrop(lud, 0, blen=1000, nbatch=1)
+out.unmorph$accept
+out.unmorph <- metrop(out.unmorph, scale=4)
+out.unmorph$accept
+out.unmorph <- metrop(out.unmorph, scale=6)
+out.unmorph$accept
+@
+A scale of 6 appears to be about right. Now we do a long run for
+this sampler.
+Because this run takes longer than CRAN vingettes are supposed to
+take, we save the results to a file
+and load the results from this file if it already exists.
+<<unmorph-metrop-t-long-run>>=
+lout <- suppressWarnings(try(load("morph1.rda"), silent = TRUE))
+if (inherits(lout, "try-error")) {
+ out.unmorph <- metrop(out.unmorph, blen = 1e5, nbatch = 1e3)
+ save(out.unmorph, file = "morph1.rda")
+} else {
+ .Random.seed <- out.unmorph$final.seed
+}
+out.unmorph$accept
+@
+
+Let's look at the distribution of batch means.
+The following code
+<<label=fig4too,include=FALSE>>=
+foo <- as.vector(out.unmorph$batch)
+qqnorm(foo)
+qqline(foo)
+@
+makes a Q-Q plot of the batch means (Figure~\ref{fig:fig4}).
+\begin{figure}
+\begin{center}
+<<label=fig4,fig=TRUE,echo=FALSE>>=
+<<fig4too>>
+@
+\end{center}
+\caption{Q-Q plot of batch means (batch length \Sexpr{out.unmorph$blen})
+for the unmorphed chain.}
+\label{fig:fig4}
+\end{figure}
+We see bad behavior of the unmorphed chain. These batch means
+(or at least some batch means for sufficiently long batch length) should
+look normally distributed, and these don't. Not even close.
+We do a formal test just to check our interpretation of the plot
+<<shapiro-wilk>>=
+shapiro.test(foo)
+@
+
+Now for comparison, we check the morphed chain.
+<<morph-metrop-t-long-run>>=
+lout <- suppressWarnings(try(load("morph2.rda"), silent = TRUE))
+if (inherits(lout, "try-error")) {
+ out.morph <- morph.metrop(out, blen = 1e5, nbatch = 1e3)
+ save(out.morph, file = "morph2.rda")
+} else {
+ .Random.seed <- out.morph$final.seed
+}
+out.morph$accept
+@
+
+The following code
+<<label=fig5too,include=FALSE>>=
+foo <- as.vector(out.morph$batch)
+qqnorm(foo)
+qqline(foo)
+@
+makes a Q-Q plot of the batch means (Figure~\ref{fig:fig5}).
+\begin{figure}
+\begin{center}
+<<label=fig5,fig=TRUE,echo=FALSE>>=
+<<fig5too>>
+@
+\end{center}
+\caption{Q-Q plot of batch means (batch length \Sexpr{out.unmorph$blen})
+for the morphed chain.}
+\label{fig:fig5}
+\end{figure}
+We see good behavior of the morphed chain. These batch means do
+look normally distributed.
+We do a formal test just to check our interpretation of the plot
+<<shapiro-wilk>>=
+shapiro.test(foo)
+@
+
+\section{Binomial Distribution with a Conjugate Prior}
+
+We demonstrate a morphometric Markov chain using the \texttt{UCBAdmisions}
+data set included in \texttt{R}, (use \texttt{help(UCBAdmissions)} to see
+details of this data set). We will model the probability of a student
+being admitted or rejected, using the sex of the student and the department
+that the student applied to as predictor variables. For our prior, we
+naively assume that 30\% of all students are admitted, independent of sex
+or department. As this is a naive prior, we will only add 5 students to
+each gender-department combination. This will not give the prior much
+weight, most of the information in the posterior distribution will be from
+the data.
+
+If we have $L$ observations from a multinomial distribution, then using a
+multinomial logit-link, with model matrices $M^1,\dots,M^L$, regression
+parameter $\beta$, observed counts $Y^1,\dots,Y^N$ with observed sample
+sizes $N^1,\dots,N^L$ and prior probabilities $\xi^1, \dots, \xi^L$ and
+prior ``sample sizes'' $\nu^1,\dots,\nu^L$ then the posterior distribution
+of $\beta$ is given by \citep[Sec. 5.1.2]{johnson-thesis}
+\begin{equation}\label{eq:mult-post-conj-complicated}
+\pi(\beta|y,n,\xi,\nu) \propto \exp\biggl\{ \sum_{l=1}^L \inner{y^l + \xi^l
+ \nu^l, M^l \beta} - (n^l + \nu^l) \log\bigl(
+ \sum_j e^{M_{j\cdot} \beta} \bigr) \biggr\}
+\end{equation}
+where $\inner{a, b}$ denotes the usual inner product between vectors $a$
+and $b$. For our application, we can simplify this in two ways.
+
+First, we use the posterior counts instead of the sum of the prior and data
+counts, i.e. use $y^{*l} = y^l + \xi^l \nu^l$ and $n^{*l} = n^l + \nu^l$.
+
+Second, to avoid having a direction of recession in $\pi(\beta|\cdot)$, we
+need to fix the elements of $\beta$ that correspond with one of the
+response categories. Since we are going to fitting a binomial response, if
+we set these elements of $\beta$ to be $0$, we may then replace the
+sequence of model matrices with a single model matrix; $M$ instead of
+$M^1,\dots,M^L$. The $l$-th row of $M$ will correspond to $M^l$. Label
+the two response categories $A$ and $B$. Without loss of generality, we
+will fix the elements of $\beta$ corresponding to category $B$ to 0.
+
+Let $x_1,\dots,x_L$ represent the posterior counts of category $A$, and
+$\beta^*$ represent the corresponding elements of $\beta$ --- these are the
+elements of $\beta$ we did not fix as 0. The meaning of
+$n^{*1},\dots,n^{*L}$ is unchanged. Then our simplified unnormalized
+posterior density is
+\begin{equation}\label{eq:simplified-posterior}
+ \pi(\beta|x,n^*) \propto
+ \exp\biggl\{
+ \inner{x, M \beta^*}
+ -
+ \sum_{l=1}^L n^{*l} \log\bigl(1 + e^{(M \beta^*)_l}\bigr)
+ \biggr\}.
+\end{equation}
+This can be computed with a very simple \texttt{R} function, we implement
+it in log form.
+<<def-posterior-binom>>=
+lud.binom <- function(beta, M, x, n) {
+ MB <- M %*% beta
+ sum(x * MB) - sum(n * log(1 + exp(MB)))
+}
+@
+
+Now that we have a function to calculate a log-unnormalized posterior
+density, we can run the Markov chain. To that, we need the model matrix.
+First we convert the \texttt{UCAdmissions} data to a \texttt{data.frame}.
+<<convert>>=
+dat <- as.data.frame(UCBAdmissions)
+dat.split <- split(dat, dat$Admit)
+dat.split <- lapply(dat.split,
+ function(d) {
+ val <- as.character(d$Admit[1])
+ d["Admit"] <- NULL
+ names(d)[names(d) == "Freq"] <- val
+ d
+ })
+dat <- merge(dat.split[[1]], dat.split[[2]])
+@
+
+Next we build the model matrix. Our model specification allows for an
+interaction between gender and department, even though our prior assumes
+that they are independent.
+<<build-model-matrix>>=
+formula <- cbind(Admitted, Rejected) ~ (Gender + Dept)^2
+mf <- model.frame(formula, dat)
+M <- model.matrix(formula, mf)
+@
+
+As stated above, we will take $\nu = 5$ and $\xi=0.30$. That is, we will
+add 5 students to each gender-department combination, where each
+combination has a 30\% acceptance rate.
+<<>>=
+xi <- 0.30
+nu <- 5
+@
+
+<<lud-binom>>=
+lud.berkeley <- function(B)
+ lud.binom(B, M, dat$Admitted + xi * nu, dat$Admitted + dat$Rejected + nu)
+@
+
+This function is suitable for passing to \texttt{metrop} or
+\texttt{morph.metrop}. We know that using \texttt{morph.metrop} with
+\texttt{morph=morph(p=3)} will run a geometrically ergodic Markov chain
+\citep{johnson-geyer}.
+<<>>=
+berkeley.out <- morph.metrop(lud.berkeley, rep(0, ncol(M)), blen=1000,
+ nbatch=1, scale=0.1, morph=morph(p=3))
+berkeley.out$accept
+berkeley.out <- morph.metrop(berkeley.out, scale=0.05)
+berkeley.out$accept
+berkeley.out <- morph.metrop(berkeley.out, scale=0.02)
+berkeley.out$accept
+berkeley.out <- morph.metrop(berkeley.out, blen=10000)
+berkeley.out$accept
+@
+
+<<>>=
+berkeley.out <- morph.metrop(berkeley.out, blen=1, nbatch=100000)
+@
+
+Estimate the posterior mean acceptance probabilities for each
+gender-department combination.
+<<>>=
+beta <- setNames(colMeans(berkeley.out$batch), colnames(M))
+MB <- M %*% beta
+dat$p <- dat$Admitted / (dat$Admitted + dat$Rejected)
+dat$p.post <- exp(MB) / (1 + exp(MB))
+dat
+@
+The small difference between the data and posterior probabilities is
+expected, our prior was given very little weight. Using
+\texttt{morph.metrop} with the setting \texttt{morph=morph(p=3)} in this
+setting is an efficient way of sampling from the posterior distribution.
+
+We can also compare the posterior distribution of admittance
+probability for each gender-department combination.
+Table~\ref{tab:post-quant} gives the 5\% and 95\% quantiles for the
+posterior distribution of the admittance probabilities for each
+gender-department combination. Figure~\ref{fig:posterior-probs} gives
+the same quantiles, plus the mean posterior-probability for each
+gender-department combination. From these we can see that for each
+department, there is considerable overlap of the distributions of
+probabilities for males and females.
+
+<<calculate-posterior-probabilities>>=
+posterior.probabilities <-
+ t(apply(berkeley.out$batch, 1,
+ function(r) {
+ eMB <- exp(M %*% r)
+ eMB / (1 + eMB)
+ }))
+quants <- apply(posterior.probabilities, 2, quantile, prob=c(0.05, 0.95))
+quants.str <- matrix(apply(quants, 2,
+ function(r) sprintf("[%0.2f, %0.2f]", r[1], r[2])),
+ nrow=2, byrow=TRUE)
+
+@
+
+\begin{table}[ht]
+ \caption{5\% and 95\% posterior quantiles for admittance probability
+ for each gender-department combination}
+ \begin{center}
+\begin{tabular}{|l|c|c|c|c|c|c|}
+ \hline
+ Gender & Dept. A & Dept. B & Dept. C & Dept. D & Dept. E. & Dept. F \\
+ \hline
+ Female & \Sexpr{paste(quants.str[1, 1:6], collapse=" & ")} \\
+ Male & \Sexpr{paste(quants.str[2, 1:6], collapse=" & ")} \\
+ \hline
+\end{tabular}
+\label{tab:post-quant}
+\end{center}
+\end{table}
+
+\begin{figure}
+\begin{center}
+<<label=fig1,fig=TRUE,echo=FALSE>>=
+x <- (0:5) * 2 + 1
+plot(x[c(1, 6)] + 0.5 * c(-1, 1), 0:1,
+ xlab="Department", ylab="Probability", xaxt="n", type="n")
+axis(1, x, LETTERS[1:6])
+for(i in 1:6) {
+ lines((x[i]-0.25)*c(1, 1), quants[1:2, i], lwd=2, col="gray")
+ lines((x[i] + 0.25) * c(1, 1), quants[1:2, i + 6], lwd=2, col="gray")
+ points(x[i] + 0.25 * c(-1, 1), dat$p.post[i + c(0, 6)], pch=c("F", "M"))
+}
+@
+\end{center}
+\caption{Posterior 5\% and 95\% quantiles and mean, by department and gender.}
+\label{fig:posterior-probs}
+\end{figure}
+
+\section{Cauchy Location-Scale Model}
+
+We are going to do a Cauchy location-scale family objective Bayesianly.
+
+\subsection{Data}
+
+First we generate some data.
+<<cauchy-data>>=
+n <- 15
+mu0 <- 50
+sigma0 <- 10
+x <- rcauchy(n, mu0, sigma0)
+round(sort(x), 1)
+@
+\texttt{mu0} and \texttt{sigma0} are the true unknown parameter values
+(since the data are simulated we actually know these ``unknown'' parameter
+values, but we must pretend we don't know them and estimate them).
+
+\subsection{Prior}
+
+The standard objective prior distribution for this situation
+(insofar as any prior distribution can be said to be an objective standard)
+is the improper prior
+$$
+ g(\mu, \sigma) = \frac{1}{\sigma}
+$$
+which is right Haar measure for the location-scale group, and is the
+standard prior that comes from the group invariance argument
+\citep[Section~3.2]{kass-wasserman}.
+
+\subsection{Log Unnormalized Posterior}
+
+We need a function whose argument is a two-vector
+<<cauchy-log-unnormalized-posterior>>=
+lup <- function(theta) {
+ if (any(is.na(theta)))
+ stop("NA or NaN in input to log unnormalized density function")
+ mu <- theta[1]
+ sigma <- theta[2]
+ if (sigma <= 0) return(-Inf)
+ if (any(! is.finite(theta))) return(-Inf)
+ result <- sum(dcauchy(x, mu, sigma, log = TRUE)) - log(sigma)
+ if (! is.finite(result)) {
+ warning(paste("Oops! mu = ", mu, "and sigma =", sigma))
+ }
+ return(result)
+}
+@
+
+\subsection{Laplace Approximation}
+
+To have some idea what we are doing, we first maximize the log unnormalized
+posterior. To do it helps to have good starting points for the optimization.
+Robust estimators of location and scale are
+<<cauchy-robust>>=
+mu.twiddle <- median(x)
+sigma.twiddle <- IQR(x)
+c(mu.twiddle, sigma.twiddle)
+@
+The posterior mode is
+<<cauchy-posterior-mode>>=
+oout <- optim(c(mu.twiddle, sigma.twiddle), lup,
+ control = list(fnscale = -1), hessian = TRUE)
+stopifnot(oout$convergence == 0)
+mu.hat <- oout$par[1]
+sigma.hat <- oout$par[2]
+c(mu.hat, sigma.hat)
+@
+and the hessian evaluated at the posterior mode (calculated by
+\texttt{optim} using finite differences) is
+<<cauchy-hessian>>=
+oout$hessian
+@
+The hessian is nearly diagonal and one can check that theoretically
+is exactly diagonal. Thus approximate (asymptotic) posterior standard
+deviations are
+<<cauchy-se>>=
+sqrt(- 1 / diag(oout$hessian))
+@
+
+\subsection{Theory}
+
+To use the theory in \citet{johnson-geyer} we must verify that the
+target distribution (the unnormalized posterior) is everywhere positive,
+and it isn't (it is zero for $\sigma \le 0$). We tried making $\log(\sigma)$
+the parameter but this didn't work either because $\log(\sigma)$ goes to
+infinity so slowly that this stretches out the tails so much that the
+transformations introduced by \citet{johnson-geyer} can't pull them back
+in again. We do know \citep[Example~3.4]{johnson-geyer} that if we fix
+$\sigma$ this is a sub-exponentially light target distribution. Letting
+$\sigma$ vary can only make this worse. Thus, if we don't do anything
+and just use the \texttt{metrop} function, then performance will be very
+bad. So we are going to use the transformations and the \texttt{morph.metrop}
+function, even though the theory that motivates them does not hold.
+
+\subsection{Morph}
+
+We want to center the transformation at the posterior mode, and use a
+radius $r$ that doesn't transform until several approximate standard deviations
+<<cauchy-doit>>=
+moo <- morph(b = 0.5, r = 7, center = c(mu.hat, sigma.hat))
+mout <- morph.metrop(lup, c(mu.hat, sigma.hat), 1e4,
+ scale = 3, morph = moo)
+mout$accept
+mout <- morph.metrop(mout)
+@
+Good enough. An attempt to increase the scale led to error when the
+transformation functions overflowed. Can't take steps too big with this
+stuff.
+The following code
+<<label=cfig1too,include=FALSE>>=
+acf(mout$batch)
+@
+makes an autocorrelation plot (Figure~\ref{fig:cfig1}).
+\begin{figure}
+\begin{center}
+<<label=cfig1,fig=TRUE,echo=FALSE>>=
+<<cfig1too>>
+@
+\end{center}
+\caption{Autocorrelation plot. First component is $\mu$, second is $\sigma$.}
+\label{fig:cfig1}
+\end{figure}
+It looks like lag 10 to 15 is enough to get near independence.
+
+Now we want to make marginal density plots.
+If we just feed our MCMC output to the R function \texttt{density}
+it undersmooths because it expects independent and identically distributed
+data rather than autocorrelated
+data. Thus we feed it subsampled, nearly uncorrelated data to select
+the bandwidth and then use that bandwidth on the full data. Here's
+how that works.
+The following code
+<<label=cfig2too,include=FALSE>>=
+mu <- mout$batch[ , 1]
+i <- seq(1, mout$nbatch, by = 15)
+out.sub <- density(mu[i])
+out <- density(mu, bw = out.sub$bw)
+plot(out)
+@
+makes the density plot (Figure~\ref{fig:cfig2}).
+\begin{figure}
+\begin{center}
+<<label=cfig2,fig=TRUE,echo=FALSE>>=
+<<cfig2too>>
+@
+\end{center}
+\caption{Density plot for the marginal posterior for $\mu$.}
+\label{fig:cfig2}
+\end{figure}
+And a similar plot for $\sigma$ (Figure~\ref{fig:cfig3})
+\begin{figure}
+\begin{center}
+<<label=cfig3,fig=TRUE,echo=FALSE>>=
+sigma <- mout$batch[ , 2]
+out.sub <- density(sigma[i])
+out <- density(sigma, bw = out.sub$bw)
+plot(out)
+@
+\end{center}
+\caption{Density plot for the marginal posterior for $\sigma$.}
+\label{fig:cfig3}
+\end{figure}
+
+\begin{thebibliography}{}
+
+\bibitem[Jarner and Roberts(2007)]{jarner-roberts}
+Jarner, S.F., and G.O. Roberts (2007).
+\newblock Convergence of heavy-tailed Monte Carlo Markov chain algorithms.
+\newblock \emph{Scandinavian Journal of Statistics}, 34, 781--815.
+
+\bibitem[Jarner and Tweedie(2003)]{jarner-tweedie}
+Jarner, S.~F., and Tweedie, R.~L. (2003).
+\newblock Necessary conditions for geometric and polynomial ergodicity of
+ random-walk-type Markov chains.
+\newblock \emph{Bernoulli}, 9, 559--578.
+
+\bibitem[Johnson(2011)]{johnson-thesis}
+Johnson, L.~T. (2011).
+\newblock Geometric Ergodicity of a Random-Walk Metropolis Algorithm via
+ Variable Transformation and Computer Aided Reasoning in Statistics.
+\newblock Ph.~D. thesis. University of Minesota.
+ \url{http://purl.umn.edu/113140}
+
+\bibitem[Johnson and Geyer(submitted)]{johnson-geyer}
+Johnson, L.~T., and C.~J. Geyer (submitted).
+\newblock Variable Transformation to Obtain Geometric Ergodicity
+ in the Random-walk Metropolis Algorithm.
+\newblock Revised and resubmitted to \emph{Annals of Statistics}.
+
+\bibitem[Kass and Wasserman(1996)]{kass-wasserman}
+Kass, R.~E., and Wasserman, L. (1996).
+\newblock Formal rules for selecting prior distributions: A review and
+ annotated bibliography.
+\newblock \emph{Journal of the American Statistical Association},
+ 435, 1343--1370.
+
+\bibitem[Mengersen and Tweedie(1996)]{mengersen-tweedie}
+ Mengersen, K.L., ad R. L. Tweedie (1996).
+\newblock Rates of convergence of the Hastings and Metropolis algorithms.
+\newblock \emph{Annals of Statistics}, 24, 101--121.
+
+\end{thebibliography}
+
+\end{document}
+
diff --git a/vignettes/morph1.rda b/vignettes/morph1.rda
new file mode 100644
index 0000000..09ba42e
Binary files /dev/null and b/vignettes/morph1.rda differ
diff --git a/vignettes/morph2.rda b/vignettes/morph2.rda
new file mode 100644
index 0000000..9a03684
Binary files /dev/null and b/vignettes/morph2.rda differ
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/debian-science/packages/r-cran-mcmc.git
More information about the debian-science-commits
mailing list