
R version 3.3.3 (2017-03-06) -- "Another Canoe"
Copyright (C) 2017 The R Foundation for Statistical Computing
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.

> 
>  if ((! exists("DEBUG")) || (! identical(DEBUG, TRUE))) DEBUG <- FALSE
> 
>  library(mcmc)
> 
>  options(digits=4) # avoid rounding differences
> 
>  set.seed(42)
> 
>  save.initial.seed <- .Random.seed
> 
>  d <- 3
>  witch.which <- 1 - (1 / 2)^(1 / d) * (1 / 4)^(seq(0, 5) / d)
>  witch.which
[1] 0.2063 0.5000 0.6850 0.8016 0.8750 0.9213
> 
>  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, debug = DEBUG)
> 
>  names(out)
 [1] "lud"          "neighbors"    "nbatch"       "blen"         "nspac"       
 [6] "scale"        "outfun"       "debug"        "parallel"     "initial.seed"
[11] "final.seed"   "time"         "batch"        "acceptx"      "accepti"     
[16] "initial"      "final"       
> 
>  out$acceptx
[1] 0.6336 0.4974 0.3245 0.6022 0.6130 0.5914
> 
>  out$accepti
       [,1]   [,2]   [,3]   [,4]   [,5]   [,6]
[1,]     NA 0.7051 0.5497     NA     NA     NA
[2,] 0.7523     NA 0.5547 0.6288     NA     NA
[3,] 0.5794 0.5865     NA 0.5309 0.5476     NA
[4,]     NA 0.6667 0.5506     NA 0.8272 0.6837
[5,]     NA     NA 0.5439 0.8926     NA 0.8374
[6,]     NA     NA     NA 0.8391 0.9023     NA
> 
>  ### 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))
+  }
> 
>  out2 <- temper(out, outfun = outfun)
> 
>  colMeans(out2$batch)
[1] 0.54923 0.40923 0.39538 0.09692 0.12923 0.60000
>  apply(out2$batch, 2, sd) / sqrt(out$nbatch)
[1] 0.03482 0.04817 0.05464 0.02856 0.02113 0.05131
> 
>  ### try again
> 
>  out3 <- temper(out2, blen = 103)
> 
>  foo <- cbind(colMeans(out3$batch),
+      apply(out3$batch, 2, sd) / sqrt(out$nbatch))
>  colnames(foo) <- c("means", "MCSE")
>  foo
      means    MCSE
[1,] 0.5231 0.01390
[2,] 0.5361 0.02213
[3,] 0.4905 0.03961
[4,] 0.5652 0.04909
[5,] 0.4056 0.05107
[6,] 0.2450 0.05108
> 
> 
> proc.time()
   user  system elapsed 
  1.868   0.012   1.874 
