1 2temper <- function(obj, initial, neighbors, nbatch, blen = 1, 3 nspac = 1, scale = 1, outfun, debug = FALSE, parallel = FALSE, ...) 4UseMethod("temper") 5 6temper.tempering <- function(obj, initial, neighbors, nbatch, blen = 1, 7 nspac = 1, scale = 1, outfun, debug = FALSE, parallel = FALSE, ...) 8{ 9 # like metrop, ignore initial argument 10 initial <- obj$final 11 # makes no (at least little?) sense to change neighbor structure 12 neighbors <- obj$neighbors 13 if (missing(nbatch)) nbatch <- obj$nbatch 14 if (missing(blen)) blen <- obj$blen 15 if (missing(nspac)) nspac <- obj$nspac 16 if (missing(scale)) scale <- obj$scale 17 if (missing(debug)) debug <- obj$debug 18 # makes no sense to change from parallel to serial or vice versa 19 # size and shape of state wouldn't even be the same 20 parallel <- obj$parallel 21 assign(".Random.seed", obj$final.seed, .GlobalEnv) 22 if (missing(outfun)) { 23 if (is.null(obj$outfun)) { 24 temper.function(obj$lud, initial, neighbors, nbatch, blen, 25 nspac, scale, debug = debug, parallel = parallel, ...) 26 } else { 27 temper.function(obj$lud, initial, neighbors, nbatch, blen, 28 nspac, scale, obj$outfun, debug = debug, parallel = parallel, 29 ...) 30 } 31 } else { 32 temper.function(obj$lud, initial, neighbors, nbatch, blen, 33 nspac, scale, outfun, debug = debug, parallel = parallel, ...) 34 } 35} 36 37temper.function <- function(obj, initial, neighbors, nbatch, blen = 1, 38 nspac = 1, scale = 1, outfun, debug = FALSE, parallel = FALSE, ...) 39{ 40 if (! exists(".Random.seed")) runif(1) 41 saveseed <- .Random.seed 42 func1 <- function(state) obj(state, ...) 43 env1 <- environment(fun = func1) 44 if (missing(outfun)) { 45 func2 <- NULL 46 env2 <- NULL 47 outfun <- NULL 48 } else if (is.function(outfun)) { 49 func2 <- function(state) outfun(state, ...) 50 env2 <- environment(fun = func2) 51 } 52 53 stopifnot(is.numeric(initial)) 54 storage.mode(initial) <- "double" 55 56 if (is.list(scale)) { 57 for (i in 1:length(scale)) { 58 stopifnot(is.numeric(scale[[i]])) 59 storage.mode(scale[[i]]) <- "double" 60 } 61 } else { 62 stopifnot(is.numeric(scale)) 63 storage.mode(scale) <- "double" 64 } 65 66 out.time <- system.time( 67 out <- .Call(C_temper, func1, initial, neighbors, nbatch, blen, nspac, 68 scale, func2, debug, parallel, env1, env2) 69 ) 70 result <- structure(c(list(lud = obj, 71 neighbors = neighbors, nbatch = nbatch, blen = blen, nspac = nspac, 72 scale = scale, outfun = outfun, debug = debug, parallel = parallel, 73 initial.seed = saveseed, final.seed = .Random.seed, time = out.time), 74 out), class = c("mcmc", "tempering")) 75 return(result) 76} 77 78