.packageName <- "R2WinBUGS"
attach.all <- function(.a, overwrite = FALSE){
  if(class(.a) != "bugs")
    stop("attach.all() requires a bugs object.")
  .a <- c(.a, .a$sims.list)
  if (overwrite){
    for (j in 1:length(.a)){
      if (names(.a)[j] %in% ls(.GlobalEnv))
        remove (list=names(.a)[j], envir=.GlobalEnv)
    }
  }
  attach(.a)
}

detach.all <- function() detach(.a)
"bugs" <-
function(data, inits, parameters.to.save, model.file = "model.txt",
    n.chains = 3, n.iter = 2000, n.burnin = floor(n.iter / 2),
    n.thin = max(1, floor(n.chains * (n.iter - n.burnin) / 1000)), debug = FALSE,
    DIC = TRUE, digits = 5, codaPkg = FALSE, 
    bugs.directory = "c:/Program Files/WinBUGS14/", working.directory = NULL){

  # Checking number of inits, which is NOT save here:
  if(!missing(inits) && !is.function(inits) && (length(inits) != n.chains)) 
    stop("Number of initialized chains (length(inits)) != n.chains")
  if(!is.null(working.directory)){
      savedWD <- getwd()
      setwd(working.directory)
      on.exit(setwd(savedWD))
  }
  if(!file.exists(model.file)) stop(paste(model.file, "does not exist."))
  if(!(length(data) == 1 && is.vector(data) && is.character(data) && data == "data.txt"))
    bugs.data(data, dir = getwd(), digits)  
  else if(!file.exists(data))
    stop("File data.txt does not exist.")
  bugs.inits(inits, n.chains, digits)
  if(DIC) parameters.to.save <- c(parameters.to.save, "deviance")
  # Model files with extension ".bug" need to be renamed to ".txt"
  if(length(grep("\\.bug$", model.file))){
    new.model.file <- sub("\\.bug$", "\\.txt", model.file)
    file.copy(model.file, new.model.file, overwrite = TRUE)
    on.exit(file.remove(new.model.file))
  }
  else new.model.file <- model.file
  bugs.script(parameters.to.save, n.chains, n.iter, n.burnin, n.thin,
    bugs.directory, new.model.file, debug=debug, is.inits=!is.null(inits))
  bugs.run(n.burnin, bugs.directory)
  if(codaPkg){
    for(i in 1:n.chains){
        file.rename(paste("coda", i, ".txt", sep=""), paste("coda", i, ".out", sep=""))
        file.copy("codaIndex.txt", paste("coda", i, ".ind", sep=""), overwrite = TRUE)
    }
    return(file.path(getwd(), paste("coda", 1:n.chains, sep="")))
  }
  else{
    sims <- c(bugs.sims(parameters.to.save, n.chains, n.iter, n.burnin, n.thin, DIC), 
        model.file = model.file, is.DIC = DIC)
    class(sims) <- "bugs"
    return(sims)
  }
}
"bugs.data" <-
function(data, dir = getwd(), digits = 5){
  if(is.numeric(unlist(data)))
    write.datafile(lapply(data, formatC, digits = digits, format = "E"), 
        file.path(dir, "data.txt"))   
  else {
    data.list <- lapply(as.list(data), get, pos = parent.frame(2))
    names(data.list) <- as.list(data)
    write.datafile(lapply(data.list, formatC, digits = digits, format = "E"), 
        file.path(dir, "data.txt"))
  }
}
"bugs.inits" <-
function (inits, n.chains, digits){
  if(!is.null(inits)){
      for (i in 1:n.chains){
        if (is.function(inits))
          write.datafile(lapply(inits(), formatC, digits = digits, format = "E"),
            paste ("inits", i, ".txt", sep=""))
        else
          write.datafile(lapply(inits[[i]], formatC, digits = digits, format = "E"),
            paste ("inits", i, ".txt", sep=""))
      }
  }
}
"bugs.plot.inferences" <-
function (sims, display.parallel, ...){
  if (.Device=="windows" ||
      (.Device=="null device" && options("device")=="windows")){
    cex.names <- .7
    cex.axis <- .6
    cex.tiny <- .4
    cex.points <- .7
    standard.width <- 30
    max.width <- 40
    min.width <- .02
  }
  else {
    cex.names <- .7
    cex.axis <- .6
    cex.tiny <- .4
    cex.points <- .3
    standard.width <- 30
    max.width <- 40
    min.width <- .01
  }
  rootnames <- sims$root.short
  n.roots <- length(rootnames)
  sims.array <- sims$sims.array
  n.chains <- sims$n.chains
  dimension.short <- sims$dimension.short
  indexes.short <- sims$indexes.short
  long.short <- sims$long.short
  height <- .6
  par (mar=c(0,0,1,0))
  plot (c(0,1), c(-n.roots-.5,-.4),
        ann=FALSE, bty="n", xaxt="n", yaxt="n", type="n")
  W <- max(strwidth(rootnames, cex=cex.names))
  B <- (1-W)/3.8
  A <- 1-3.5*B
  if (display.parallel)
    text (A, -.4, "80% interval for each chain", adj=0, cex=cex.names)
  else
    text (A, -.4, "medians and 80% intervals", adj=0, cex=cex.names)
  num.height <- strheight (1:9, cex=cex.tiny)
  for (k in 1:n.roots){
    text (0, -k, rootnames[k], adj=0, cex=cex.names)
    J <- min (length(long.short[[k]]), max.width)
    if (k==1)
      index <- 1:J
    else
      index <- sum (unlist(lapply(long.short,length))[1:(k-1)]) + 1:J
    spacing <- 3.5/max(J,standard.width)
    med <- numeric(J)
    i80 <- matrix( , J, 2)
    med.chains <- matrix( , J, sims$n.chains)
    i80.chains <- array(NA, c(J, sims$n.chains, 2))
    for (j in 1:J){
      med[j] <- median(sims.array[,,index[j]])
      i80[j,] <- quantile(sims.array[,,index[j]], c(.1,.9))
      for (m in 1:n.chains){
        med.chains[j,m] <- quantile (sims.array[,m,index[j]], .5)
        i80.chains[j,m,] <- quantile (sims.array[,m,index[j]], c(.1,.9))
      }
    }
    rng <- range (i80, i80.chains)
    p.rng <- pretty(rng, n = 2)
    b <- height/(max(p.rng) - min(p.rng))
    a <- -(k+height/2) - b*p.rng[1]
    lines (A+c(0,0), -k+c(-height/2,height/2))
#
# plot a line at zero (if zero is in the range of the mini-plot)
#    
    if (min(p.rng)<0 & max(p.rng)>0)
      lines (A+B*spacing*c(0,J+1), rep (a,2), lwd=.5, col="gray")
    
    for (x in p.rng){
      text (A-B*.2, a+b*x, x, cex=cex.axis)
      lines (A+B*c(-.05,0), rep(a+b*x,2))
    }
    for (j in 1:J){
      if (display.parallel){
        for (m in 1:n.chains){
          interval <- a + b*i80.chains[j,m,]
          if (interval[2]-interval[1] < min.width)
            interval <- mean(interval) + c(-1,1)*min.width/2
          lines (A+B*spacing*rep(j+.6*(m-(n.chains+1)/2)/n.chains,2),
                 interval, lwd=.5, col=m+1)
        }
      }
      else {
        lines (A+B*spacing*rep(j,2), a + b*i80[j,], lwd=.5)
        for (m in 1:n.chains)
#        points (A+B*spacing*j, a + b*med[j], pch=20, cex=cex.points)
          points (A+B*spacing*j, a + b*med.chains[j,m], pch=20, cex=cex.points,
                  col=m+1)
      }
      dk <- dimension.short[k]
      if (dk>0){
        for (m in 1:dk){
          index0 <- indexes.short[[k]][[j]][m]
          if (j==1)
            text(A+B*spacing*j, -k-height/2-.05-num.height*(m-1), index0,
              cex=cex.tiny)
          else if (index0!=indexes.short[[k]][[j-1]][m] &
            (index0%%(floor(log10(index0)+1))==0))
              text(A+B*spacing*j, -k-height/2-.05-num.height*(m-1), index0,
                cex=cex.tiny)
        }
      }
    }
    if (J<length(long.short[[k]])) text (-.015, -k, "*",
                                         cex=cex.names, col="red")
  }
}
"bugs.plot.summary" <-
function (sims, ...){
  DIC <- sims$is.DIC
  if (.Device=="windows" ||
      (.Device=="null device" && options("device")=="windows")){
    cex.names <- .7
    cex.top <- .7
    cex.points <- .7
    max.length <- 50
    min.width <- .01
  }
  else {
    cex.names <- .7
    cex.top <- .7
    cex.points <- .3
    max.length <- 80
    min.width <- .005
  }
  summ <- sims$summary
  sims.array <- sims$sims.array
  n.chains <- sims$n.chains
  n.parameters <- nrow(summ)
 
  J0 <- unlist(lapply(sims$long.short, length))
  if (DIC) J0 <- J0[1:(length(J0)-1)]  # don't display deviance summaries
  J <- J0
  total <- ceiling(sum(J+.5))
  while ((total > max.length) && max(J)>1){### vielleicht optimieren ...
    J[J==max(J)] <- max(J)-1
    total <- ceiling(sum(J+.5))
  }
  pos <- -1
  ypos <- NULL
  id <- NULL
  ystart <- NULL
  jj <- 1:J[1]
  n.roots <- length(sims$root.short)
  if (DIC) n.roots <- n.roots-1        # don't display deviance summaries
  ystart <- numeric(n.roots)
  for (k in 1:n.roots){
    ystart[k] <- pos
    ypos <- c(ypos, pos - seq(0, J[k]-1))
    id <- c(id, 1:J[k])
    pos <- pos - J[k] -.5
    if (k>1) jj <- c(jj, sum(J0[1:(k-1)]) + (1:J[k]))
  }
  bottom <- min(ypos)-1  
  
  med <- numeric(sum(J))
  i80 <- matrix( , sum(J), 2)
  i80.chains <- array (NA, c(sum(J), n.chains, 2))
  for (j in 1:sum(J)){
    med[j] <- median (sims.array[,,jj[j]])
    i80[j,] <- quantile (sims.array[,,jj[j]], c(.1,.9))
    for (m in 1:n.chains)
      i80.chains[j,m,] <- quantile (sims.array[,m,jj[j]], c(.1,.9))
  }
  rng <- range (i80, i80.chains)
  p.rng <- pretty(rng, n = 2)
  b <- 2 / (max(p.rng) - min(p.rng))
  a <- -b * p.rng[1]
  
  par (mar=c(0,0,1,3))
  plot (c(0,1), c(min(bottom, -max.length)-3,2.5),
        ann=FALSE, bty="n", xaxt="n", yaxt="n", type="n")
  W <- max(strwidth(unlist(dimnames(summ)[[1]]), cex=cex.names))
  B <- (1-W)/3.6
  A <- 1-3.5*B
  B <- (1-A)/3.5
  b <- B*b
  a <- A + B*a
  text (A+B*1, 2.5, "80% interval for each chain", cex=cex.top)
  lines (A+B*c(0,2), c(0,0))
  lines (A+B*c(0,2), rep(bottom,2))  
  if(n.chains > 1){
    text (A+B*3, 2.6, "R-hat", cex=cex.top)
    lines (A+B*c(2.5,3.5), c(0,0))
    lines (A+B*c(2.5,3.5), rep(bottom,2))
  }
#
# line at zero
#
  if (min(p.rng)<0 & max(p.rng)>0)
    lines (rep(a,2), c(0,bottom), lwd=.5, col="gray")
      
  for (x in p.rng){
    text (a+b*x, 1, x, cex=cex.names)
    lines (rep(a+b*x,2), c(0,-.2))
    text (a+b*x, bottom-1, x, cex=cex.names)
    lines (rep(a+b*x,2), bottom+c(0,.2))
  }
  if(n.chains > 1)
      for (x in seq(1,2,.5)){
        text (A+B*(1.5+seq(1,2,.5)), rep(1,3), c("1","1.5","2+"), cex=cex.names)
        lines (A+B*rep(1.5+x,2), c(0,-.2))
        text (A+B*(1.5+seq(1,2,.5)), rep(bottom-1,3), c("1","1.5","2+"),
              cex=cex.names)
        lines (A+B*rep(1.5+x,2), bottom+c(0,.2))
      }
  for (j in 1:sum(J)){
    name <- dimnames(summ)[[1]][jj[j]]
    if (id[j]==1)
      text (0, ypos[j], name, adj=0, cex=cex.names)
    else {
      pos <- as.vector(regexpr("[[]", name))
      text (strwidth(substring(name,1,pos-1),cex=cex.names),
            ypos[j], substring(name, pos, nchar(name)), adj=0, cex=cex.names)
    }
    for (m in 1:n.chains){
      interval <- a + b*i80.chains[j,m,]
      if (interval[2]-interval[1] < min.width)
        interval <- mean(interval) + c(-1,1)*min.width/2
      lines (interval, rep(ypos[j]-.1*(m-(n.chains+1)/2),2), lwd=1, col=m+1)
      if(n.chains > 1) 
        points (A+B*(1.5 + min(max(summ[jj[j],"Rhat"],1),2)), ypos[j], pch=20, cex=cex.points)
    }
  }
  for (k in 1:n.roots){
    if (J[k]<J0[k]) text (-.015, ystart[k], "*", cex=cex.names,
                          col="red")
  }
  if (sum(J!=J0)>0) text (0, bottom-3,
    "*  array truncated for lack of space", adj=0, cex=cex.names, col="red")
}
"bugs.run" <-
function (n.burnin, bugs.directory){
# Update the lengths of the adaptive phases in the Bugs updaters
  bugs.update.settings(n.burnin, bugs.directory)
# Return the lengths of the adaptive phases to their original settings
  on.exit(file.copy(paste(bugs.directory, "System/Rsrc/Registry_Rsave.odc", sep=""), 
      paste(bugs.directory, "System/Rsrc/Registry.odc", sep=""),
      overwrite = TRUE))
# Search Win*.exe (WinBUGS executable) within bugs.directory
  dos.location <- file.path(bugs.directory, 
    grep("^Win[[:alnum:]]*\.exe$", list.files(bugs.directory), value = TRUE)[1])
  if(!file.exists(dos.location)) 
    stop(paste("WinBUGS executable does not exist in", bugs.directory))
# Call Bugs and have it run with script.txt
  temp <- system(paste('"', dos.location, '"', " /par ", "script.txt", sep = ""))
  if(temp == -1)
      stop("Error in bugs.run().\nCheck that WinBUGS is in the specified directory.")
# Stop and print an error message if Bugs did not run correctly
  if (length(grep("Bugs did not run correctly",
    scan("coda1.txt", character(), quiet=TRUE, sep="\n"))) > 0)
      stop("Look at the log file and\ntry again with debug=TRUE and figure out what went wrong within Bugs.")
}
"bugs.script" <-
function (parameters.to.save, n.chains, n.iter, n.burnin,
    n.thin, bugs.directory, model.file, debug=FALSE, is.inits){
# Write file script.txt for Bugs to read
#  if (n.chains<2) stop ("n.chains must be at least 2")
  n.keep <- ceiling(n.iter/n.thin)-ceiling(n.burnin/n.thin)
  if (n.keep < 2) stop ("(n.iter-n.burnin)/n.thin must be at least 2")
  working.directory <- getwd()
  script <- file.path(bugs.directory, "script.txt")
  model <- if(length(grep("\\\\", model.file)) || length(grep("/", model.file)))
    model.file
    else file.path(working.directory, model.file)
  data <- file.path(working.directory, "data.txt")
  history <- file.path(working.directory, "history.odc")
  coda  <- file.path(working.directory, "coda")
  logfile <- file.path(working.directory, "log.odc")
  inits <- paste(working.directory, "/inits", 1:n.chains, ".txt", sep="")
  initlist <- paste("inits (", 1:n.chains, ", '", inits, "')\n", sep="")
  savelist <- paste("set (", parameters.to.save, ")\n", sep="")
  cat(
    "display ('log')\n",
    "check ('", model, "')\n",
    "data ('", data, "')\n",
    "compile (", n.chains, ")\n",
    if(is.inits) initlist,
    "gen.inits()\n",
    "beg (", ceiling(n.burnin/n.thin)+1, ")\n",
    "thin.updater (", n.thin, ")\n",
    savelist,
#    "dic.set()\n",
    "update (", ceiling(n.iter/n.thin), ")\n",
    "stats (*)\n",
#    "dic.stats()\n",
    "history (*, '", history, "')\n",
    "coda (*, '", coda, "')\n",
    "save ('", logfile, "')\n", file=script, sep="", append=FALSE)
  if (!debug) cat ("quit ()\n", file=script, append=TRUE)
  sims.files <- paste ("coda", 1:n.chains, ".txt", sep="")
  for (i in 1:n.chains) cat ("WinBUGS did not run correctly.\n",
    file=sims.files[i], append=FALSE)
}
"bugs.sims" <-
function (parameters.to.save, n.chains, n.iter, n.burnin, n.thin, DIC = TRUE){
# Read the simulations from Bugs into R, format them, and monitor convergence
  sims.files <- paste ("coda", 1:n.chains, ".txt", sep="")
  index <- read.table ("codaIndex.txt", header=FALSE, sep="\t")
  parameter.names <- as.vector(index[,1])
  n.keep <- index[1,3] - index[1,2] + 1
  n.parameters <- length(parameter.names)
  n.sims <- n.keep*n.chains
  sims <- matrix( , n.sims, n.parameters)
  sims.array <- array (NA, c(n.keep, n.chains, n.parameters))
  root.long <- character(n.parameters)
  indexes.long <- vector(n.parameters, mode = "list")
  for (i in 1:n.parameters){
    temp <- decode.parameter.name(parameter.names[i])
    root.long[i] <- temp$root
    indexes.long[[i]] <- temp$indexes
  }
  n.roots <- length(parameters.to.save)
  left.bracket.short <- as.vector (regexpr("[[]", parameters.to.save))
  right.bracket.short <- as.vector (regexpr("[]]", parameters.to.save))
  root.short <- ifelse (left.bracket.short==-1, parameters.to.save,
    substring (parameters.to.save, 1, left.bracket.short-1))
  dimension.short <- rep(0, n.roots)
  indexes.short <- vector(n.roots, mode = "list")
  n.indexes.short <- vector(n.roots, mode = "list")
  long.short <- vector(n.roots, mode = "list")
  length.short <- numeric(n.roots)
  ##SS, UL##: Let's optimize the following loops ...
  for (j in 1:n.roots){
    long.short[[j]] <- (1:n.parameters)[root.long==root.short[j]]
    length.short[j] <- length(long.short[[j]])
    if (length.short[j]==0)
      stop (paste ("parameter", root.short[[j]], "is not in the model"))
    else if (length.short[j]>1){
      dimension.short[j] <- length(indexes.long[[long.short[[j]][1]]])       
      n.indexes.short[[j]] <- numeric(dimension.short[j])
      for (k in 1:dimension.short[j]) n.indexes.short[[j]][k] <- length (
        unique (unlist (lapply (indexes.long[long.short[[j]]], .subset, k))))
      length.short[j] <- prod(n.indexes.short[[j]])
      if (length(long.short[[j]])!=length.short[j]) stop (paste
        ("error in parameter", root.short[[j]], "in parameters.to.save"))
      indexes.short[[j]] <- as.list(numeric(length.short[j]))
      for (k in 1:length.short[j])
        indexes.short[[j]][[k]] <- indexes.long[[long.short[[j]][k]]]
    }
  }
#  rank.long <- rank(paste(rep(root.short,length.short),
#    (1:n.parameters)/10^ceiling(log10(n.parameters)),sep="."))
  rank.long <- unlist(long.short)

  for (i in 1:n.chains){
    sims.i <- scan (sims.files[i], quiet=TRUE) [2*(1:(n.keep*n.parameters))]
    sims[(n.keep*(i-1)+1):(n.keep*i), ] <- sims.i
    sims.array[,i,] <- sims.i
  }
  dimnames (sims) <- list (NULL, parameter.names)
  dimnames (sims.array) <- list (NULL, NULL, parameter.names)
#
#  Perform convergence checks and compute medians and quantiles.
#
  summary <- monitor (sims.array, n.chains, keep.all=TRUE)
#
#  Create outputs
#
  last.values <- as.list (numeric(n.chains))
  for (i in 1:n.chains){
    n.roots.0 <- if(DIC) n.roots-1 else n.roots
    last.values[[i]] <- as.list (numeric(n.roots.0))
    names(last.values[[i]]) <- root.short[1:n.roots.0]
    for (j in 1:n.roots.0){
      if (dimension.short[j]<=1){
        last.values[[i]][[j]] <- sims.array[n.keep,i,long.short[[j]]]
        names(last.values[[i]][[j]]) <- NULL
      }
      else
        last.values[[i]][[j]] <- aperm (array(sims.array[n.keep,i,long.short[[j]]],
           rev(n.indexes.short[[j]])), dimension.short[j]:1)
    }
  }
  sims <- sims [sample(n.sims),]    # scramble (for convenience in analysis)
  sims.list <- summary.mean <- summary.sd <-  summary.median <- vector(n.roots, mode = "list")
  names(sims.list) <- names(summary.mean) <- names(summary.sd) <- names(summary.median) <- root.short
  for (j in 1:n.roots){
    if (length.short[j]==1){
      sims.list[[j]] <- sims[,long.short[[j]]]
      summary.mean[[j]] <- summary[long.short[[j]],"mean"]
      summary.sd[[j]] <- summary[long.short[[j]],"sd"]
      summary.median[[j]] <- summary[long.short[[j]],"50%"]
    }
    else{
      temp2 <- dimension.short[j]:1
      sims.list[[j]] <- aperm (array (sims[,long.short[[j]]],
        c(n.sims,rev(n.indexes.short[[j]]))), c(1,(dimension.short[j]+1):2))
      summary.mean[[j]] <- aperm (array (summary[long.short[[j]],"mean"],
        rev(n.indexes.short[[j]])), temp2)
      summary.sd[[j]] <- aperm (array (summary[long.short[[j]],"sd"],
        rev(n.indexes.short[[j]])), temp2)
      summary.median[[j]] <- aperm (array (summary[long.short[[j]],"50%"],
        rev(n.indexes.short[[j]])), temp2)
      }
  }
  summary <- summary[rank.long,]
  all <- list (n.chains=n.chains, n.iter=n.iter, n.burnin=n.burnin,
    n.thin=n.thin, n.keep=n.keep, n.sims=n.sims,
    sims.array=sims.array[,,rank.long,drop=FALSE], sims.list=sims.list,
    sims.matrix=sims[,rank.long], summary=summary, mean=summary.mean,
    sd=summary.sd, median=summary.median, root.short=root.short,
    long.short=long.short, dimension.short=dimension.short,
    indexes.short=indexes.short, last.values=last.values)
  if(DIC){
    deviance <- all$sims.array[,,dim(sims.array)[3], drop = FALSE]
    dim(deviance) <- dim(deviance)[1:2]
    pD <- numeric(n.chains)
    DIC <- numeric(n.chains)
    for (i in 1:n.chains){
      pD[i] <- var(deviance[,i])/2
      DIC[i] <- mean(deviance[,i]) + pD[i]
    }
    all <- c(all, list (pD=mean(pD), DIC=mean(DIC)))
  }
  return(all)
}
"bugs.update.settings" <-
function (n.burnin, bugs.directory){
  char.burnin <- as.character(n.burnin)
  file.copy(file.path(bugs.directory, "System/Rsrc/Registry.odc"),
            file.path(bugs.directory, "System/Rsrc/Registry_Rsave.odc"),
            overwrite = TRUE)
  registry <- readBin (file.path(bugs.directory,
      "System/Rsrc/Registry.odc"), "character", 400, size=1)
  info <- registry[regexpr("Int",registry)>0]
  while (regexpr("\r",info)>0){
    newline <- regexpr("\r",info)
    info <- substring (info, newline+1)
      line <- substring (info, 1, regexpr("\r",info)-1)
    if (regexpr ("AdaptivePhase", line) > 0){
      numpos <- regexpr ("Int", line) + 4
      num <- substring (line, numpos)
      if (as.numeric(num) > n.burnin){
        num.new <- paste (paste (rep(" ", nchar(num)-nchar(char.burnin)),
                                 sep="", collapse=""), char.burnin, sep="")
        line.new <- sub (num, num.new, line)
        registry <- sub (line, line.new, registry)
      }
    }
  }
  writeBin (registry,
      file.path(bugs.directory, "System/Rsrc/Registry.odc"))
}
"conv.par" <-
function (x, n.chains, Rupper.keep = TRUE) {
  m <- ncol(x)
  n <- nrow(x)

# We compute the following statistics:
#
#  xdot:  vector of sequence means
#  s2:  vector of sequence sample variances (dividing by n-1)
#  W = mean(s2):  within MS
#  B = n*var(xdot):  between MS.
#  muhat = mean(xdot):  grand mean; unbiased under strong stationarity
#  varW = var(s2)/m:  estimated sampling var of W
#  varB = B^2 * 2/(m+1):  estimated sampling var of B
#  covWB = (n/m)*(cov(s2,xdot^2) - 2*muhat*cov(s^2,xdot)):
#                                               estimated sampling cov(W,B)
#  sig2hat = ((n-1)/n))*W + (1/n)*B:  estimate of sig2; unbiased under
#                                               strong stationarity
#  quantiles:  emipirical quantiles from last half of simulated sequences

  xdot <- apply(x,2,mean)
  muhat <- mean(xdot)
  s2 <- apply(x,2,var)
  W <- mean(s2)
  quantiles <- quantile (as.vector(x), probs=c(.025,.25,.5,.75,.975))

  if ((W > 1.e-8) && (n.chains > 1)) {            # non-degenerate case
  
  B <- n*var(xdot)
  varW <- var(s2)/m
  varB <- B^2 * 2/(m-1)
  covWB <- (n/m)*(cov(s2,xdot^2) - 2*muhat*cov(s2,xdot))
  sig2hat <- ((n-1)*W + B)/n

# Posterior interval post.range combines all uncertainties
# in a t interval with center muhat, scale sqrt(postvar),
# and postvar.df degrees of freedom.
#
#       postvar = sig2hat + B/(mn):  variance for the posterior interval
#                               The B/(mn) term is there because of the
#                               sampling variance of muhat.
#       varpostvar:  estimated sampling variance of postvar

    postvar <- sig2hat + B/(m*n)
    varpostvar <- max(0, 
        (((n-1)^2) * varW + (1 + 1/m)^2 * varB + 2 * (n-1) * (1 + 1/m) * covWB) / n^2)
    post.df <- min(2*(postvar^2/varpostvar), 1000)

# Estimated potential scale reduction (that would be achieved by
# continuing simulations forever) has two components:  an estimate and
# an approx. 97.5% upper bound.
#
# confshrink = sqrt(postvar/W),
#     multiplied by sqrt(df/(df-2)) as an adjustment for the
###      CHANGED TO sqrt((df+3)/(df+1))
#     width of the t-interval with df degrees of freedom.
#
# postvar/W = (n-1)/n + (1+1/m)(1/n)(B/W); we approximate the sampling dist.
# of (B/W) by an F distribution, with degrees of freedom estimated
# from the approximate chi-squared sampling dists for B and W.  (The
# F approximation assumes that the sampling dists of B and W are independent;
# if they are positively correlated, the approximation is conservative.)

    confshrink.range <- postvar/W
    if(Rupper.keep){
        varlo.df <- 2*(W^2/varW) 
        confshrink.range <- c(confshrink.range, 
            (n-1)/n + (1+1/m)*(1/n)*(B/W) * qf(.975, m-1, varlo.df))
    }
    confshrink.range <- sqrt(confshrink.range * (post.df+3) / (post.df+1))
    
# Calculate effective sample size:  m*n*min(sigma.hat^2/B,1)
# This is a crude measure of sample size because it relies on the between
# variance, B, which can only be estimated with m degrees of freedom.
    
    n.eff <- m*n*min(sig2hat/B,1)
    list(quantiles=quantiles, confshrink=confshrink.range,
         n.eff=n.eff)

  }
  else {      # degenerate case:  all entries in "data matrix" are identical
    list (quantiles=quantiles, confshrink = rep(1, Rupper.keep + 1),
          n.eff=1)

  }
}
"decode.parameter.name" <-
function (a){
#
# Decodes Bugs parameter names
#   (e.g., "beta[3,14]" becomes "beta" with 2 indexes:  3 and 14)
# for use by the bugs.sim() function
#
  left.bracket <- regexpr ("[[]", a)
  if (left.bracket==-1){
    root <- a
    dimension <- 0
    indexes <- NA
  }
  else {
    root <- substring (a, 1, left.bracket-1)
    right.bracket <- regexpr ("[]]", a)
    a <- substring (a, left.bracket+1, right.bracket-1)
    indexes <- as.numeric(unlist(strsplit(a, ",")))
    dimension <- length(indexes)
  }
  return (list (root=root, dimension=dimension, indexes=indexes))
}
"formatdata" <-
function (datalist){
    if (!is.list(datalist) || is.data.frame(datalist)) 
        stop("Argument to formatdata() must be a list.")
    n <- length(datalist)
    datalist.string <- vector(n, mode = "list")
    for (i in 1:n) {
        if (length(datalist[[i]]) == 1) 
            datalist.string[[i]] <- paste(names(datalist)[i], 
                "=", as.character(datalist[[i]]), sep = "")
        if (is.vector(datalist[[i]]) && length(datalist[[i]]) > 1) 
            datalist.string[[i]] <- paste(names(datalist)[i], 
                "=c(", paste(as.character(datalist[[i]]), collapse = ", "), 
                ")", sep = "")
        if (is.array(datalist[[i]])) 
            datalist.string[[i]] <- paste(names(datalist)[i], 
                "= structure(.Data= c(", paste(as.character(as.vector(aperm(datalist[[i]]))), 
                  collapse = ", "), "), .Dim=c(", paste(as.character(dim(datalist[[i]])), 
                  collapse = ", "), "))", sep = "")
    }
    datalist.tofile <- paste("list(", paste(unlist(datalist.string), 
        collapse = ", "), ")", sep = "")
    return(datalist.tofile)
}
"monitor" <-
function (a, n.chains, trans=NULL, keep.all=FALSE, Rupper.keep=FALSE) {

# If keep.all=T:  a is a n x m x k array:
#   m sequences of length n, k variables measured
# If keep.all=F:  a is a 2n x m x k array (first half will be discarded)
#
# trans is a vector of length k:  "" if no transformation, or "log" or "logit"
# (If trans is not defined, it will be set to "log" for parameters that
# are all-positive and 0 otherwise.)
#
# If Rupper.keep=T:  keep Rupper.  (Otherwise don't display it.)
  invlogit <- function (x) {1 / (1 + exp(-x))}
  nparams <- if(length(dim(a)) < 3) 1 else dim(a)[length(dim(a))]
  # Calculation and initialization of the required matrix "output"
  output <- matrix( , ncol = if(n.chains > 1){if(Rupper.keep) 10 else 9} else 7, nrow = nparams)
  if (length(dim(a))==2) a <- array (a, c(dim(a),1))
  if (!keep.all){
    n <- floor(dim(a)[1]/2)
    a <- a[(n+1):(2*n), , , drop = FALSE]
  }
  if (is.null(trans))
    trans <- ifelse ((apply (a<=0, 3, sum))==0, "log", "")
  for (i in 1:nparams){
    # Rupper.keep:  discard Rupper (nobody ever uses it)
    ai <- a[ , , i, drop = FALSE]
    if (trans[i]=="log"){
        conv.p <- conv.par(log(ai), n.chains, Rupper.keep=Rupper.keep) # reason????
        conv.p <- list(quantiles = exp(conv.p$quantiles),
            confshrink = conv.p$confshrink, n.eff = conv.p$n.eff)
    }
    else if (trans[i]=="logit"){
        conv.p <- conv.par(logit(ai), n.chains, Rupper.keep=Rupper.keep)
        conv.p <- list(quantiles = invlogit(conv.p$quantiles),
            confshrink = conv.p$confshrink, n.eff = conv.p$n.eff)
    }
    else conv.p <- conv.par(ai, n.chains, Rupper.keep=Rupper.keep)
    output[i, ] <- c(mean(ai), sd(as.vector(ai)),
      conv.p$quantiles, 
        if(n.chains > 1) conv.p$confshrink, 
        if(n.chains > 1) round(conv.p$n.eff, min(0, 1 - floor(log10(conv.p$n.eff))))
      )
  }
  if(n.chains > 1)
    dimnames(output) <- list(dimnames(a)[[3]], c("mean","sd",
        "2.5%","25%","50%","75%","97.5%", "Rhat", if(Rupper.keep) "Rupper","n.eff"))
  else
    dimnames(output) <- list(dimnames(a)[[3]], c("mean","sd",
        "2.5%","25%","50%","75%","97.5%"))
   return (output)
}
plot.bugs <- function (x, display.parallel=FALSE, ...){
    mar.old <- par("mar")
    par (pty = "m")
    layout(matrix(c(1,2),1,2))
    bugs.plot.summary (x, ...)
    bugs.plot.inferences (x, display.parallel, ...)
    mtext (paste ("Bugs model at \"", x$model.file, "\", ", x$n.chains,
      " chains, each with ", x$n.iter, " iterations", sep=""),
           outer=TRUE, line=-1, cex=.7)
    par (mar = mar.old)
}
print.bugs <- function (x, digits.summary = 1, ...){
    cat ('Inference for Bugs model at \"', x$model.file, "\"\n ",
         x$n.chains, " chains, each with ", x$n.iter, " iterations (first ",
         x$n.burnin, " discarded)", sep="")
    if (x$n.thin > 1) cat (", n.thin =", x$n.thin)
    cat ("\n n.sims =", x$n.sims, "iterations saved\n")
    print (round (x$summary, digits.summary), ...)
    if (!is.null(x$DIC)){
      cat (" pD =", round(x$pD, 1), "and DIC =", round(x$DIC, 1),
           "(using the rule, pD = var(deviance)/2)\n")
      if(x$n.chains > 1){
        cat("\n For each parameter, n.eff is a crude measure of effective sample size,")
        cat("\n and Rhat is the potential scale reduction factor (at convergence, Rhat=1).")
      }
      cat("\nDIC is an estimate of expected predictive error (lower deviance is better).\n") 
    }
}
"write.datafile" <-
function (datalist, towhere, fill = TRUE){
  if (!is.list(datalist) || is.data.frame(datalist)) 
      stop("First argument to write.datafile must be a list.")
  cat(formatdata(datalist), file = towhere, fill = fill)
}
