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