## THE 'ADMIT' PACKAGE
## by David Ardia, Lennart F. Hoogerheide, Herman K. van Dijk
## forthcoming in Rnews
## this version : 20090103 / David Ardia <david.ardia@unifr.ch>

## Initialisation
rm(list = ls())
library("AdMit")
options(digits = 4, max.print = 30)

## Define Gelman-Meng kernel function
GelmanMeng <- function(x, log = TRUE)
{
  if (is.vector(x))
    x <- matrix(x, nrow = 1)
  r <- -0.5 * ( 5 * x[,1]^2 * x[,2]^2
               + x[,1]^2 + x[,2]^2
               - 10 * x[,1] * x[,2]
               - 6 * x[,1] - 7 * x[,2] )
  if (!log)
    r <- exp(r)
  as.vector(r)
}

## Contour plot of the 'GelmanMeng' kernel function
PlotGelmanMeng <- function(x1, x2, log = FALSE)
  GelmanMeng(cbind(x1, x2), log = log)
x1 <- x2 <- seq(from = -1.0, to = 6.0, by = 0.1)
z <- outer(x1, x2, FUN = PlotGelmanMeng)
contour(x1, x2, z, nlevel = 20, las = 1, lwd = 1,
        col = rainbow(20), cex.axis = 1.2, cex.lab = 1.2,
        xlab = expression(X[1]), ylab = expression(X[2]), 
        main = "Gelman-Meng kernel")

x1 <- x2 <- seq(from = -1.0, to = 6.0, by = 0.02)
z <- outer(x1, x2, FUN = PlotGelmanMeng)
image(x1, x2, z, las = 1, col = gray((40:0)/40),
      cex.axis = 1.2, cex.lab = 1.2,
      xlab = expression(X[1]), ylab = expression(X[2]),
      main = "Gelman-Meng kernel")
box()

## AdMit fitting
args(AdMit)
set.seed(1234)
outAdMit <- AdMit(KERNEL = GelmanMeng,
                  mu0 = c(0.0, 0.1))
print(outAdMit)

## Plot the mixture approximation
PlotMit <- function(x1, x2, mit, log = FALSE)
  dMit(cbind(x1, x2), mit = mit, log = log)
x1 <- x2 <- seq(from = -1.0, to = 6.0, by = 0.1)
z <- outer(x1, x2, FUN = PlotMit, mit = outAdMit$mit)
contour(x1, x2, z, nlevel = 20, las = 1, lwd = 1, 
        col = rainbow(20), cex.axis = 1.2, cex.lab = 1.2,
        xlab = expression(X[1]), ylab = expression(X[2]), 
        main = "AdMit approximation")

x1 <- x2 <- seq(from = -1.0, to = 6.0, by = 0.02)
z <- outer(x1, x2, FUN = PlotMit, mit = outAdMit$mit)
image(x1, x2, z, las = 1, col = gray((40:0)/40),
      cex.axis = 1.2, cex.lab = 1.2,
      xlab = expression(X[1]), ylab = expression(X[2]),
      main = "AdMit approximation")
box()

## IS sampling
args(AdMitIS)
outAdMitIS <- AdMitIS(N = 1e5,
                      KERNEL = GelmanMeng,
                      mit = outAdMit$mit)
print(outAdMitIS)

## MH sampling
args(AdMitMH)
outAdMitMH <- AdMitMH(N = 101000,
                      KERNEL = GelmanMeng,
                      mit = outAdMit$mit)
print(outAdMitMH)

library("coda")
draws <- as.mcmc(outAdMitMH$draws)
draws <- window(draws, start = 1001)
colnames(draws) <- c("X1", "X2")
summary(draws)$stat
effectiveSize(draws) / niter(draws)

## Gibbs sampling
N <- 101000
set.seed(1234)
e1 <- rnorm(N)
e2 <- rnorm(N)
X <- matrix(data = NA, N, 2, dimnames = list(1:N, c("X1", "X2")))
X[1,] <- c(1,1)
A <- 5
B <- 5
C1 <- 3
C2 <- 3.5
for (i in 2:N)
{
  tmp <- A * X[i-1,2]^2 + 1
  X[i,1] <- (B * X[i-1,2] + C1) / tmp + sqrt(1/tmp) * e1[i]
  tmp <- A * X[i,1]^2 + 1
  X[i,2] <- (B * X[i,1] + C2) / tmp + sqrt(1/tmp) * e2[i]
}
draws.Gibbs <- as.mcmc(X)
draws.Gibbs <- window(draws.Gibbs, start = 1001)
dim(draws.Gibbs)
summary(draws.Gibbs)$stat
effectiveSize(draws.Gibbs) / niter(draws.Gibbs)

## ACF comparison
par(mfrow = c(2,2))
acf(draws[,1], las = 1, ylab = "", cex.axis = 1.2, cex.lab = 1.2,
    main = expression(paste("ACF ", X[1] ," (AdMit)")))
acf(draws[,2], las = 1, ylab = "", cex.axis = 1.2, cex.lab = 1.2,
    main = expression(paste("ACF ", X[2] ," (AdMit)")))
acf(draws.Gibbs[,1], las = 1, ylab = "", cex.axis = 1.2, cex.lab = 1.2,
    main = expression(paste("ACF ", X[1] ," (Gibbs)")))
acf(draws.Gibbs[,2], las = 1, ylab = "", cex.axis = 1.2, cex.lab = 1.2, 
    main = expression(paste("ACF ", X[2] ," (Gibbs)")))