"codamenu" <- function () 
{
  on.exit(tidy.up())
  coda.options(default=TRUE)
  file.menu <- c("Read BUGS output files", 
                 "Use an mcmc object", 
                 "Quit")
  pick <- menu(file.menu, title = "CODA startup menu")
  if (pick == 0 || pick == 3) 
    return(invisible())
  else if (pick == 1) {
    coda.global.assign("coda.dat", read.bugs.interactive())
    if (is.null(coda.dat)) {
      return(invisible())
    }
    coda.options(data.saved = FALSE)
  }
  else if (pick == 2) {
    msg <- "\nEnter name of saved object (or type \"exit\" to quit)"
    repeat {
      cat(msg, "\n")
      outname <- read.and.check(what = character())
      if (outname == "exit" || outname == "\"exit\"") {
        return(invisible())
      }
      else if (!exists(outname)) 
        msg <- "Can't find this object"
      else {
        work.dat <- eval(parse(text = outname))
        if (is.mcmc.list(work.dat)) {
          coda.global.assign("coda.dat", work.dat)
          break
        }
        else if (is.mcmc(work.dat)) {
          coda.global.assign("coda.dat", mcmc.list(work.dat))
          break
        }
        else
          msg <- "Not an mcmc or mcmc.list object"
      }
    }
  }
  else stop("Invalid option")
  coda.dat <- coda.dat               #Create local copy
  if (is.null(chanames(coda.dat))) 
    chanames(coda.dat) <- chanames(coda.dat, allow.null = FALSE)
  if (is.null(varnames(coda.dat))) 
    varnames(coda.dat) <- varnames(coda.dat, allow.null = FALSE)
  coda.global.assign("coda.dat", coda.dat)
  rm(coda.dat, inherits=FALSE)       #Destroy local copy
  coda.global.assign("work.dat", coda.dat, alias=TRUE)
  current.menu <- "codamenu.main"
  repeat {
    next.menu <- do.call(current.menu, vector("list", 0))
    if (next.menu == "quit") {
      if(read.yesno("Are you sure you want to quit", FALSE))
        break
    }
    else current.menu <- next.menu
  }
  invisible()
}

"codamenu.anal" <- function () 
{
  next.menu <- "codamenu.anal"
  choices <- c("Plots", "Statistics", "List/Change Options", 
               "Return to Main Menu")
  next.menu.list <- c("plots", "summary", "codamenu.options", 
                      "codamenu.main")
  cat("\n")
  pick <- menu(choices, title = "CODA Output Analysis menu")
  if (pick == 0) 
    next.menu <- "quit"
  else if (next.menu.list[pick] == "summary") {
    if (coda.options("combine.stats")) {
      print(summary(work.dat, quantiles = coda.options("quantiles"), 
                    digits = coda.options("digits")))
    }
    else for (i in 1:nchain(work.dat)) {
      cat(chanames(work.dat, allow.null = FALSE)[i], "\n")
      print(summary(work.dat[[i]], quantiles = coda.options("quantiles"), 
                    digits = coda.options("digits")))
    }
  }
  else if (next.menu.list[pick] == "plots") {
    auto.layout <- !coda.options("user.layout") 
    ask <- TRUE
    repeat {
      if (coda.options("combine.plots")) 
        plot(work.dat, trace = coda.options("trace"), 
             density = coda.options("densplot"),
             smooth = coda.options("lowess"), 
             auto.layout = auto.layout, bwf = coda.options("bandwidth"), 
             combine.chains = !coda.options("combine.plots"), 
             ask = ask)
      else for (i in 1:nchain(work.dat)) {
        plot(work.dat[[i]], trace = coda.options("trace"), 
             density = coda.options("densplot"),
             smooth = coda.options("lowess"), 
             auto.layout = auto.layout, bwf = coda.options("bandwidth"), 
             combine.chains = coda.options("combine.plots"), 
             ask = ask)
      }
      codamenu.ps()
      if (names(dev.cur()) == "postscript") 
        ask <- FALSE
      else break
    }
  }
  else next.menu <- next.menu.list[pick]
  return(next.menu)
}

"codamenu.diags" <- function () 
{
  next.menu <- "diags"
  while (next.menu == "diags") {
    choices <- c("Geweke", "Gelman and Rubin", "Raftery and Lewis", 
                 "Heidelberger and Welch", "Autocorrelations",
                 "Cross-Correlations", "List/Change Options",
                 "Return to Main Menu")
    next.menu.list <- c("codamenu.diags.geweke", "codamenu.diags.gelman", 
                        "codamenu.diags.raftery", "codamenu.diags.heidel", 
                        "codamenu.diags.autocorr", "codamenu.diags.crosscorr", 
                        "codamenu.options", "codamenu.main")
    pick <- menu(choices, title = "CODA Diagnostics Menu")
    if (pick == 0) 
      return("quit")
    else next.menu <- next.menu.list[pick]
  }
  return(next.menu)
}

"codamenu.diags.autocorr" <- function () 
{
  next.menu <- "codamenu.diags"
  codamenu.output.header("AUTOCORRELATIONS WITHIN EACH CHAIN:")
  print(autocorr(work.dat), digits = coda.options("digits"))
  choices <- c("Plot autocorrelations", "Return to Diagnostics Menu")
  pick <- menu(choices, title = "Autocorrelation Plots Menu")
  if (pick == 0) 
    next.menu <- "quit"
  else if (pick == 1) {
    ask <- TRUE
    repeat {
      autocorr.plot(work.dat, auto.layout = !coda.options("user.layout"), 
                    ask = ask)
      codamenu.ps()
      if (names(dev.cur()) == "postscript") 
        ask <- FALSE
      else break
    }
  }
  return(next.menu)
}

"codamenu.diags.crosscorr" <- function () 
{
  next.menu <- "codamenu.diags.crosscorr"
  crosscorr.out <- if (coda.options("combine.corr")) {
    crosscorr(work.dat)
  }
  else lapply(work.dat, crosscorr)
  if (coda.options("combine.corr") & nchain(work.dat) > 1) 
    cat("Pooling over chains:", chanames(work.dat, allow.null = FALSE), 
        sep = "\n", collapse = "\n")
  print(crosscorr.out, digits = coda.options("digits"))
  cat("\n")
  choices <- c("Change options",
               "Plot Cross Correlations", 
               "Return to Diagnostics Menu")
  pick <- menu(choices, title = "Cross correlation plots menu")
  if (pick == 0) 
    next.menu <- "quit"
  else
    switch(pick,
           change.tfoption("Combine chains", "combine.corr"), 
           {
             repeat {
               if (coda.options("combine.corr")) 
                 crosscorr.plot(work.dat)
               else {
                 opar <- par(ask = TRUE)
                 lapply(work.dat, crosscorr.plot)
                 par(opar)
               }
               codamenu.ps()
               if (names(dev.cur()) != "postscript") 
                 break
             }
           },
           next.menu <- "codamenu.diags")
  return(next.menu)
}

"codamenu.diags.heidel" <- function () 
{
  this.menu <- "codamenu.diags.heidel"
  next.menu <- "codamenu.diags"
  title <- "HEIDELBERGER AND WELCH STATIONARITY AND INTERVAL HALFWIDTH TESTS"
  codamenu.output.header(title)
  cat("Precision of halfwidth test =", coda.options("halfwidth"), "\n\n")
  heidel.out <- heidel.diag(work.dat, eps = coda.options("halfwidth"))
  print(heidel.out, digits = coda.options("digits"))
  choices <- c("Change precision", "Return to diagnostics menu")
  pick <- menu(choices)
  if (pick == 0) 
    next.menu <- "quit"
  else if (pick == 1) 
    next.menu <- codamenu.options.heidel(this.menu)
  return(next.menu)
}

"codamenu.diags.raftery" <- function () 
{
  next.menu <- this.menu <- "codamenu.diags.raftery"
  codamenu.output.header("RAFTERY AND LEWIS CONVERGENCE DIAGNOSTIC")
  print(raftery.diag(work.dat, q = coda.options("q"), r = coda.options("r"), 
                     s = coda.options("s")), digits = coda.options("digits"))
  choices <- c("Change parameters", "Return to diagnostics menu")
  pick <- menu(choices)
  next.menu <- if (pick == 0) 
    "quit"
  else if (pick == 1) {
    codamenu.options.raftery(this.menu)
  }
  else "codamenu.diags"
  return(next.menu)
}

"codamenu.main" <- function () 
{
  choices <- c("Output Analysis", "Diagnostics", "List/Change Options", "Quit")
  next.menu.list <- c("codamenu.anal", "codamenu.diags", "codamenu.options", 
                      "quit")
  pick <- menu(choices, title = "CODA Main Menu")
  if (pick == 0) 
    next.menu <- "quit"
  else next.menu <- next.menu.list[pick]
  return(next.menu)
}

"codamenu.diags.gelman" <- function (tol = 1e-08) 
{
  next.menu <- this.menu <- "codamenu.diags.gelman"
  if (nchain(work.dat) == 1) {
    cat("\nError: you need more than one chain.\n\n")
    return(next.menu = "codamenu.diags")
  }
  else if (niter(work.dat) <= 50) {
    cat("\nError: you need > 50 iterations in the working data\n")
    return(next.menu = "codamenu.diags")
  }
  z <- window(work.dat, start = niter(work.dat)/2)
  for (i in 2:nchain(z)) {
    for (j in 1:(i - 1)) {
      if (any(apply(as.matrix(z[[i]] - z[[j]]), 2, var)) < tol) {
        cat("\nError: 2nd halves of",
            chanames(z, allow.null = FALSE)[c(j, i)],
            "are identical for at least one variable\n")
        return(next.menu = "codamenu.diags")
      }
    }
  }
  codamenu.output.header("GELMAN AND RUBIN DIAGNOSTIC")
  print(gelman.diag(work.dat, transform = TRUE),
        digits = coda.options("digits"))
  choices <- c("Shrink Factor Plots", "Change bin size for shrink plot", 
               "Return to Diagnostics Menu")
  action.list <- c("ShrinkPlot", "ChangeBin", "Return")
  while (next.menu == "codamenu.diags.gelman") {
    pick <- menu(choices, title = "Gelman & Rubin menu")
    if (pick == 0) 
      next.menu <- "quit"
    else switch(action.list[pick], ShrinkPlot = {
      ask <- TRUE
      repeat {
        gelman.plot(work.dat, max.bins = coda.options("gr.max"), 
                    bin.width = coda.options("gr.bin"),
                    auto.layout = !coda.options("user.layout"), 
                    ask = ask)
        codamenu.ps()
        if (names(dev.cur()) == "postscript") 
          ask <- FALSE
        else break
      }
    }, ChangeBin = {
      codamenu.options.gelman(NULL)
    }, Return = {
      next.menu <- "codamenu.diags"
    })
  }
  return(next.menu)
}

"codamenu.diags.geweke" <- function () 
{
  next.menu <- "codamenu.diags.geweke"
  codamenu.output.header("GEWEKE CONVERGENCE DIAGNOSTIC (Z-score)")
  geweke.out <- geweke.diag(work.dat, frac1 = coda.options("frac1"), 
                            frac2 = coda.options("frac2"))
  print(geweke.out, digits = coda.options("digits"))
  choices <- c("Change window size", "Plot Z-scores",
               "Change number of bins for plot", 
               "Return to Diagnostics Menu")
  action.list <- c("ChangeWindow", "Plot", "ChangeBin", "Return")
  while (next.menu == "codamenu.diags.geweke") {
    pick <- menu(choices, title = "Geweke plots menu")
    if (pick == 0) 
      return("quit")
    switch(action.list[pick], ChangeWindow = {
      codamenu.options.geweke.win(NULL)
      geweke.out <- geweke.diag(work.dat,
                                frac1 = coda.options("frac1"), 
                                frac2 = coda.options("frac2"))
      print(geweke.out, digits = coda.options("digits"))
    }, Plot = {
      ask <- TRUE
      repeat {
        if(start(work.dat) >= end(work.dat)) {
          cat("Chain too short: end iteration must be at least twice\n")
          cat("the start iteration\n")
          break
        }
        geweke.plot(work.dat, frac1 = coda.options("frac1"), 
                    frac2 = coda.options("frac2"),
                    nbins = coda.options("geweke.nbin"),
                    auto.layout = !coda.options("user.layout"), 
                    ask = ask)
        codamenu.ps()
        if (names(dev.cur()) == "postscript") 
          ask <- FALSE
        else break
      }
    }, ChangeBin = {
      codamenu.options.geweke.bin(NULL)
    }, Return = {
      next.menu <- "codamenu.diags"
    })
  }
  return(next.menu)
}

"codamenu.options" <- function () 
{
  next.menu <- "codamenu.options"
  choices <- c("List current options", "Data Options", "Plot Options", 
               "Summary Statistics Options", "Diagnostics Options", 
               "Output Analysis", "Diagnostics", "Main Menu")
  action.list <- c("ListOptions", "codamenu.options.data", 
                   "codamenu.options.plot", "codamenu.options.stats",
                   "codamenu.options.diag", "codamenu.anal",
                   "codamenu.diags", "codamenu.main")
  pick <- menu(choices, title = "CODA main options menu")
  if (pick == 0) 
    return("quit")
  if (action.list[pick] == "ListOptions") {
    print.coda.options(data = TRUE, stats = TRUE, plots = TRUE, 
                       diags = TRUE)
    next.menu <- "codamenu.options"
  }
  else next.menu <- action.list[pick]
  return(next.menu)
}

"codamenu.options.data" <- function () 
{
  next.menu <- "codamenu.options.data"
   
  work.vars <- varnames(work.dat)
  work.chains <- chanames(work.dat)
  work.start <- start(work.dat)
  work.end <- end(work.dat)
  work.thin <- thin(work.dat)
  
  choices <- c("List current data options", "Select variables for analysis", 
               "Select chains for analysis", "Select iterations for analysis", 
               "Select thinning interval", "Return to main options menu")
  action.list <- c("ListDataOptions", "SelectVars", "SelectChains", 
                   "SelectIters", "SelectThinInterval", "MainOptionsMenu")
  pick <- menu(choices, title = "CODA data options menu")
  if (pick == 0) 
    return("quit")
  switch(action.list[pick], ListDataOptions = {
    print.coda.options(data = TRUE)
  }, SelectVars = {
    work.vars <- multi.menu(varnames(coda.dat, allow.null = FALSE), 
                            "Select variables for analysis",
                            c("VARIABLE NUMBER", "VARIABLE NAME"),
                            allow.zero = FALSE)
  }, SelectChains = {
    work.chains <- multi.menu(chanames(coda.dat, allow.null = FALSE), 
                              "Select chains for analysis:",
                              c("CHAIN NUMBER", "CHAIN NAME"),
                              allow.zero = FALSE)
  }, SelectIters = {
    cat("\nIterations available = ", start(coda.dat), ":", 
        end(coda.dat), "\n", sep = "")
    work.start <- read.and.check("Enter iteration you wish to start at", 
                                 lower = start(coda.dat),
                                 upper = end(coda.dat),
                                 default = start(work.dat))
    work.end <- read.and.check("Enter iteration you wish to end at", 
                               lower = work.start,
                               upper = end(coda.dat),
                               default = end(work.dat))
  }, SelectThinInterval = {
    cat("\nThinning interval of full data = ", thin(coda.dat), "\n", sep = "")
    work.thin <- read.and.check("Enter thinning interval:", 
                                lower = thin(coda.dat),
                                default = thin(work.dat))
  }, MainOptionsMenu = {
    next.menu <- "codamenu.options"
  })
  if (action.list[pick] != "ListDataOptions" && action.list[pick] != 
      "MainOptionsMenu") {
    cat("Recreating working data...\n")
    wd <- window(coda.dat[, work.vars, drop = FALSE], start = work.start, 
                 end = work.end, thin = work.thin)
    coda.global.assign("work.dat", wd[work.chains, drop=FALSE])
  }
  return(next.menu)
}

"codamenu.options.diag" <- function () 
{
  next.menu <- this.menu <- "codamenu.options.diag"
  choices <- c("Display current diagnostic options",
               "Window sizes for Geweke's diagnostic", 
               "Bin size for plotting Geweke's diagnostic",
               "Bin size for plotting Gelman & Rubin's diagnostic", 
               "Parameters for Raftery & Lewis' diagnostic",
               "Halfwidth precision for Heidelberger & Welch's diagnostic", 
               "Combine chains to calculate correlation matrix",
               "Return to main options menu")
  pick <- menu(choices, title = "CODA diagnostics options menu")
  if (pick == 0) 
    return("quit")
  switch(pick, print.coda.options(diags = TRUE),
         next.menu <- codamenu.options.geweke.win(this.menu), 
         next.menu <- codamenu.options.geweke.bin(this.menu), 
         next.menu <- codamenu.options.gelman(this.menu),
         next.menu <- codamenu.options.raftery(this.menu), 
         next.menu <- codamenu.options.heidel(this.menu),
         {
           change.tfoption("Do you want to combine all chains to calculate correlation matrix",  "combine.corr")
         }, next.menu <- "codamenu.options")
  return(next.menu)
}

"codamenu.options.gelman" <- function (last.menu) 
{
  choices <- c("Default: bin width = 10; maximum number of bins = 50", 
               "User-specified bin width",
               "User-specified total number of bins")
  pick <- menu(choices, title = "Options for defining bin size to plot Gelman-Rubin-Brooks diagnostic")
  if (pick == 0) 
    return("quit")
  switch(pick, {
    coda.options(gr.max = 50)
    coda.options(gr.bin = 10)
  }, {
    coda.options(gr.max = Inf)
    default <- if (coda.options("gr.bin") == 0) 
      10
    else coda.options("gr.bin")
    msg <- "Enter required bin width:"
    coda.options(gr.bin = read.and.check(msg, lower = 1, 
                   upper = niter(work.dat) - 50, default = default))
  }, {
    coda.options(gr.bin = 0)
    default <- if (is.infinite(coda.options("gr.max"))) 
      50
    else coda.options("gr.max")
    msg <- "Enter total number of bins required:"
    coda.options(gr.max = read.and.check(msg, lower = 1, 
                   upper = niter(work.dat) - 50, default = default))
  })
  return(last.menu)
}

"codamenu.options.geweke.bin" <- function (last.menu) 
{
  msg <- "Enter number of bins for Geweke-Brooks plot"
  ans <- read.and.check(msg, what=numeric(), lower=1,
                        default=coda.options("geweke.nbin"))
  coda.options(geweke.nbin = ans)
  return(last.menu)
}

"codamenu.options.geweke.win" <-
function (last.menu) 
{
  msg1 <- "Enter fraction of chain to include in 1st window:"
  msg2 <- "Enter fraction of chain to include in 2nd window:"
  ans1 <- ans2 <- 1
  while (ans1 + ans2 >= 1) {
    ans1 <- read.and.check(msg1, lower = 0, upper = 1,
                           default = coda.options("frac1"))
    ans2 <- read.and.check(msg2, lower = 0, upper = 1,
                           default = coda.options("frac2"))
    ## Check that sum of fractions doesn't exceed 1.0
    if (ans1 + ans2 >= 1) 
      cat("Error: Sum of fractions in 1st and 2nd windows must be < 1.0\n")
  }
  coda.options(frac1 = ans1, frac2 = ans2)
  return(last.menu)
}

"codamenu.options.heidel" <- function (last.menu) 
{
  coda.options(halfwidth = read.and.check("Enter precision for halfwidth test",
                 lower = 0, default = coda.options("halfwidth")))
  return(last.menu)
}

"codamenu.options.plot" <-
function () 
{
  next.menu <- "codamenu.options.plot"
  choices <- c("Show current plotting options",
               "Plot trace of samples", 
               "Plot kernel density estimate",
               "Add smooth line through trace plot", 
               "Combine chains",
               "Single plot per page",
               "Specify page layout for plots", 
               "Select bandwidth function for kernel smoothing",
               "Return to main options menu")
  pick <- menu(choices, title = "CODA plotting options menu")
  if (pick == 0) 
    return("quit")
  switch(pick,
         print.coda.options(plots = TRUE),
         change.tfoption(choices[2], "trace"),
         change.tfoption(choices[3], "densplot"),
         change.tfoption(choices[4], "lowess"),
         change.tfoption(choices[5], "combine.plots"), 
         {
           ans <- read.yesno(choices[6], default=TRUE)
           if(ans) {
             coda.options(user.layout = TRUE)
             par(mfrow = c(1,1))
           }
         },
         {
           change.tfoption("Do you want to specify your own page layout for the plots", "user.layout")
           if (coda.options("user.layout")) {
             mrows <- read.and.check("Enter number of rows per page",
                                     lower = 1, upper = 7)
             mcols <- read.and.check("Enter number of columns per page",
                                     lower = 1, upper = 8)
             par(mfrow = c(mrows, mcols))
           }
         }, {
           next.menu <- "codamenu.options.plot.kernel"
         }, NULL)
  if (pick == length(choices)) 
    next.menu <- "codamenu.options"
  return(next.menu)
}

"codamenu.options.plot.kernel" <-
function () 
{
  if (!coda.options("densplot")) {
    cat("\nNo density plots requested - this option is irrelevant\n")
  }
  else {
    kernel.menu <- c("Smooth (0.25 * sample range)",
                     "Coarse (Silverman 1986 eqn. 3.28 & 3.30)", 
                     "User-defined function",
                     "Return to Plotting Options Menu")
    pick1 <- menu(kernel.menu, title = "Select kernel bandwidth function")
    if (pick1 == 0) 
      return("quit")
    switch(pick1, {
      bwf <- function(x) {
        (max(x) - min(x))/4
      }
      coda.options(bandwidth = bwf)
    }, {
      bwf <- function(x) {
        1.06 * min(sd(x), IQR(x)/1.34) * length(x)^-0.2
      }
      coda.options(bandwidth = bwf)
    }, {
      restart()
      func.OK <- FALSE
      while (!func.OK) {
        cat("Enter bandwidth as an expression in terms of x,\n")
        cat("the vector of sampled values, e.g. \n")
        cat("(max(x) - min(x)) / 4\n")
        ans <- scan(what = character())
        if (length(ans) > 0) {
          bwf <- "function(x){"
          for (i in 1:length(ans)) {
            bwf <- paste(bwf, ans[i], sep = "")
          }
          bwf <- paste(bwf, "}", sep = "")
          bwf <- eval(parse(text = bwf))
          ## Carry out simple test to check whether the
          ## function entered makes sense
          ##
          func.OK <- is.numeric(bw <- bwf(1:10)) && (length(bw) == 1)
          if(!func.OK) {
            cat("This is not a suitable function: it must return a single\n")
            cat("numeric value given a numeric vector x.")
          }
        }
      }
      coda.options(bandwidth = bwf)
    }, NULL)
  }
  return("codamenu.options.plot")
}

"codamenu.options.plot.ps" <- function () 
{
  choices <- c("Portrait", "Landscape")
  pick <- menu(choices, "Select options for saving plots to PostScript files")
  if (pick == 0) 
    return("quit")
  else coda.options(ps.orientation = c("portrait", "landscape")[pick])
  if (.Device == "X11") 
    x11(orientation = coda.options("ps.orientation"))
  else if (.Device == "Win32") 
    windows(orientation = coda.options("ps.orientation"))
  return("codamenu.options.plot")
}

"codamenu.options.raftery" <- function (last.menu) 
{
  coda.options(q = read.and.check("Enter quantile to be estimated:", 
                 lower = 0, upper = 1, default = coda.options("q")))
  coda.options(r = read.and.check("Enter required precision:", 
                 upper = coda.options("q"), default = coda.options("r")))
  coda.options(s = read.and.check("Enter required probability:", 
                 lower = 0, upper = 1, default = coda.options("s")))
  return(last.menu)
}

"codamenu.options.stats" <- function () 
{
  next.menu <- "codamenu.options.stats"
  choices <- c("Display current statistics options", "Combine chains for summary statistics", 
               "Quantiles for summary statistics", "Number of significant digits for printing", 
               "Return to main options menu")
  pick <- menu(choices, title = "CODA options for summary statistics")
  if (pick == 0) 
    return("quit")
  switch(pick, print.coda.options(stats = TRUE), {
    mssg <- "Do you want to combine all chains when calculating summary statistics"
    change.tfoption(mssg, "combine.stats")
  }, {
    mssg <- paste("Enter quantiles required, separated by commas\n(Default =", 
                  paste(coda.options("quantiles"), collapse = ", "))
    repeat {
      cat("\n", mssg, "\n")
      if (is.R()) 
        ans <- as.numeric(scan(what = character(), sep = ",", 
                               quiet = TRUE, nlines = 1))
      else ans <- as.numeric(scan(what = character(), sep = ","))
      if (length(ans) == 0) 
        ans <- coda.options("quantiles")
      if (any(is.na(ans))) 
        mssg <- "You must enter numeric values"
      else if (any(ans >= 1) || any(ans <= 0)) 
        mssg <- "You must enter values between 0 and 1"
      else break
    }
    if (length(ans) > 0) 
      coda.options(quantiles = sort(ans))
  }, {
    mssg <- "Enter number of significant digits to be printed"
    ans <- read.and.check(mssg, what = integer(), lower = 0, 
                          default = coda.options("digits"))
    coda.options(digits = ans)
  }, {
    next.menu <- "codamenu.options"
  })
  return(next.menu)
}

"print.coda.options" <-
  function (data = FALSE, stats = FALSE, plots = FALSE, diags = FALSE) 
{
  cat("\nCurrent option settings:")
  cat("\n=======================\n\n")
  if (data) {
    cat("WORKING DATA\n")
    cat("============\n")
    cat("Variables selected : ",
        paste(varnames(work.dat, allow.null = FALSE), collapse=", ")
        ,"\n", sep="")
    cat("Chains selected    : ",
        paste(chanames(work.dat, allow.null = FALSE), collapse=", ")
        , "\n", sep="")
    cat("Iterations - start : ", start(work.dat), "\n", sep="")
    cat("               end : ", end(work.dat), "\n", sep="")
    cat("Thinning interval  : ", thin(work.dat), "\n", sep="")
    cat("\n")
  }
  if (stats) {
    cat("SUMMARY STATISTICS OPTIONS\n")
    cat("==========================\n\n")
    cat("Combine chains     : ", coda.options("combine.stats"), "\n", sep="")
    cat("Quantiles          : ",
        paste(coda.options("quantiles") * 100, "%", sep="", collapse = ", "),
        "\n", sep="")
    cat("Significant digits : ", coda.options("digits"), "\n", sep="")
    cat("\n")
  }
  if (plots) {
    cat("PLOTTING OPTIONS\n")
    cat("================\n\n")
    cat("Trace               : ", coda.options("trace"),         "\n", sep="")
    cat("Density             : ", coda.options("densplot"),      "\n", sep="")
    cat("Smooth lines        : ", coda.options("lowess"),        "\n", sep="")
    cat("Combine chains      : ", coda.options("combine.plots"), "\n", sep="")
    cat("User-defined layout : ", coda.options("user.layout"),   "\n", sep="")
    if(coda.options("user.layout")) {
      cat("                    : ", paste(par("mfrow"), collapse=" X "), "\n", sep="")
    }
    cat("Bandwidth function  :\n")
    print(coda.options("bandwidth"))
    cat("\n")
  }
  if (diags) {
    cat("DIAGNOSTICS OPTIONS\n")
    cat("===================\n\n")
    cat("Geweke\n")
    cat("------\n")
    cat("Window 1 fraction  : ", coda.options("frac1"),      "\n", sep="")
    cat("Window 2 fraction  : ", coda.options("frac2"),      "\n", sep="")
    cat("Number of bins     : ", coda.options("geweke.nbin"), "\n", sep="")
    cat("\n")
    
    cat("Gelman & Rubin\n")
    cat("--------------\n")
    cat("Bin width          : ", coda.options("gr.bin"), "\n", sep="")
    cat("Max number of bins : ", coda.options("gr.max"), "\n", sep="")
    cat("\n")
    
    cat("Raftery & Lewis\n")
    cat("---------------\n")
    cat("Quantile (q)       : ", coda.options("q"), "\n", sep="")
    cat("Precision (+/- r)  : ", coda.options("r"), "\n", sep="")
    cat("Probability (s)    : ", coda.options("s"), "\n", sep="")
    cat("\n")
           
    cat("Cross-correlations\n")
    cat("------------------\n")
    cat("Combine chains     : ", coda.options("combine.corr"), "\n", sep="") 
    cat("\n")
  }
  invisible()
}

"read.bugs.interactive" <- function () 
{
  repeat {
    cat("Enter BUGS output filenames, separated by return key\n")
    cat("(leave blank to exit)\n")
    filenames <- scan(what = character(), sep = "\n", strip.white = TRUE, 
                      quiet = TRUE)
    if (length(filenames) == 0) 
      return()
    else {
      root <- character(length(filenames))
      for (i in 1:length(filenames)) {
        nc <- nchar(filenames[i])
        if (nc > 3) {
          file.ext <- substring(filenames[i], nc - 3, 
                                nc)
          root[i] <- if (any(file.ext == c(".ind", ".out"))) 
            substring(filenames[i], 0, nc - 4)
          else filenames[i]
        }
        else root[i] <- filenames[i]
      }
      root <- unique(root)
      all.files <- c(paste(root, ".ind", sep = ""), paste(root, 
                                                          ".out", sep = ""))
      if (any(!file.exists(all.files))) {
        cat("The following files were not found:\n")
        cat(paste(all.files[!file.exists(all.files)], 
                  collapse = "\n"), "\n\n")
      }
      else break
    }
  }
  nfiles <- length(root)
  chains <- vector("list", nfiles)
  names(chains) <- root
  for (i in 1:nfiles) chains[[i]] <- read.bugs(file = root[i])
  return(mcmc.list(chains))
}

"tidy.up" <- function () 
{
  cat("\nQuitting codamenu ...\n")
  if (!coda.options("data.saved")) {
    ans <- read.yesno("Do you want to save the mcmc output", default=FALSE)
    if (ans == TRUE) {
      cat("Enter name you want to call this object file:\n")
      fname <- scan(what = character(), nmax = 1, strip.white = TRUE)
      coda.global.assign(fname, coda.dat)
    }
  }
  coda.objects <- c("coda.dat", "work.dat")
  if (is.R()) 
    for (i in coda.objects) {
      if (exists(i)) 
        rm(list=i, pos = 1)
    }
  else {
    for (i in coda.objects) {
      if (exists(i)) 
        remove(i, where = 1)
    }
  }
}

"codamenu.ps" <- function () 
{
  if (names(dev.cur()) == "postscript") {
    dev.off()
  }
  else {
    cat("\nSave plots as a postscript file (y/N) ?\n")
    ans <- readline()
    if (length(ans) == 0) 
      ans <- "n"
    if (ans == "Y" | ans == "y") {
      repeat {
        mssg <- "Enter name you want to call this postscript file"
        ps.name <- read.and.check(mssg, what = character(), 
                                  default = "Rplots.ps")
        if (is.R() && file.exists(ps.name)) {
          pick <- menu(title = "File exists", choices = c("overwrite", 
                                                "choose another file name"))
          if (pick == 1) 
            break
        }
        else break
      }
      postscript(file = ps.name)
    }
  }
  return(dev.cur())
}

"codamenu.output.header" <- function (title) 
{
  ##
  ## A short header: common to most codamenu output
  ##
  cat("\n", title, sep = "")
  cat("\n", paste(rep("=", nchar(title)), collapse = ""), "\n\n", 
      sep = "")
  cat("Iterations used = ", start(work.dat), ":", end(work.dat), 
      "\n", sep = "")
  cat("Thinning interval =", thin(work.dat), "\n")
  cat("Sample size per chain =", niter(work.dat), "\n\n")
  invisible()
}









































"gelman.diag" <- function (x, confidence = 0.95, transform = FALSE) 
  ## Gelman and Rubin's diagnostic
  ## Gelman, A. and Rubin, D (1992). Inference from iterative simulation
  ## using multiple sequences.  Statistical Science, 7, 457-551.
  ##
  ## Correction and Multivariate generalization:
  ## Brooks, S.P. and Gelman, A. (1997) General methods for monitoring
  ## convergence of iterative simulations. Journal of Computational and
  ## Graphical Statistics, 7, 434-455.

{
  x <- as.mcmc.list(x)
  if (nchain(x) < 2) 
    stop("You need at least two chains")
  if (start(x) < end(x)/2) 
    x <- window(x, start = end(x)/2 + 1)
  Niter <- niter(x)
  Nchain <- nchain(x)
  Nvar <- nvar(x)
  ##  x <- as.array.mcmc.list(x, drop=FALSE)
  
  if(transform)
    x <- gelman.transform(x)
  ##
  ## Estimate mean within-chain variance (W) and between-chain variance
  ## (B/Niter), and calculate sampling variances and covariance of the
  ## estimates (varW, varB, covWB)
  ##
  ## Multivariate (upper case)
  x <- lapply(x, as.matrix)
  S2 <- array(sapply(x, var, simplify=TRUE), dim=c(Nvar,Nvar,Nchain))
  W <- apply(S2, c(1,2), mean)
  xbar <- matrix(sapply(x, apply, 2, mean, simplify=TRUE), nrow=Nvar,
                 ncol=Nchain)
  B <- Niter * var(t(xbar))

  if(Nvar > 1) {
    emax <- eigen(qr.solve(W,B), symmetric=FALSE, only.values=TRUE)$values[1]
    mpsrf <- sqrt( (1 - 1/Niter) + (1 + 1/Nvar) * emax/Niter )
  }
  else
    mpsrf <- NULL
  ## Univariate (lower case)
  w <- diag(W)
  b <- diag(B)


  s2 <- matrix(apply(S2, 3, diag), nrow=Nvar, ncol=Nchain)
  muhat <- apply(xbar,1,mean)
  var.w <- apply(s2, 1, var)/Nchain              
  var.b <- (2 * b^2)/(Nchain - 1)      
  cov.wb <- (Niter/Nchain) * diag(var(t(s2), t(xbar^2)) -
                              2 * muhat * var(t(s2), t(xbar)))
  ##
  ## Posterior interval combines all uncertainties in a t interval with
  ## center muhat, scale sqrt(V), and df.V degrees of freedom.
  ##
  V <- (Niter - 1) * w / Niter  + (1 + 1/Nchain) * b/ Niter
  var.V <- ((Niter - 1)^2 * var.w + (1 + 1/Nchain)^2 * 
            var.b + 2 * (Niter - 1) * (1 + 1/Nchain) * cov.wb)/Niter^2
  df.V <- (2 * V^2)/var.V
  ##
  ## Potential scale reduction factor (that would be achieved by
  ## continuing simulations forever) is estimated by 
  ##   R = sqrt(V/W) * df.adj
  ## where df.adj is a degrees of freedom adjustment for the width
  ## of the t-interval.
  ##
  ## To calculate upper confidence interval we divide R2 = R^2 into two
  ## parts, fixed and random.  The upper limit of the random part is
  ## calculated assuming that B/W has an F distribution.
  ##
  df.adj <- (df.V + 3)/(df.V + 1)
  B.df <- Nchain - 1
  W.df <- (2 * w^2)/var.w
  R2.fixed <- (Niter - 1)/Niter
  R2.random <- (1 + 1/Nchain) * (1/Niter) * (b/w)
  R2.estimate <- R2.fixed + R2.random
  R2.upper <- R2.fixed + qf((1 + confidence)/2, B.df, W.df) * R2.random
  psrf <- cbind(sqrt(df.adj * R2.estimate), sqrt(df.adj * R2.upper))
  dimnames(psrf) <- list(varnames(x),
                         c("Point est.",
                           paste(50 * (1+confidence), "% quantile", sep = ""))
                         )
  
  
  out <- list(psrf = psrf, mpsrf=mpsrf)
  class(out) <- "gelman.diag"
  out
}

"gelman.transform" <- function(x)
  ## Gelman and Rubin diagnostic assumes a normal distribution. To
  ## improve the normal approximation, variables on [0, Inf) are log
  ## transformed, and variables on [0,1] are logit-transformed.
{
  if (nvar(x) == 1) {
    z <- data.frame(lapply(x, unclass))
    if (min(z) > 0) {
      y <- if(max(z) < 1)
        log(z/(1-z))
      else log(z)
      for (j in 1:nchain(x)) x[[j]] <- y[,j]
    }
  }
  else for (i in 1:nvar(x)) {
    z <- data.frame(lapply(x[, i], unclass))
    if (min(z) > 0) {
      y <- if (max(z) < 1) 
        log(z/(1 - z))
      else log(z)
      for (j in 1:nchain(x)) x[[j]][, i] <- y[, j]
    }
  }
  return(x)
}

"gelman.mv.diag" <- function (x, confidence = 0.95, transform = FALSE)
{
  s2 <- sapply(x, var, simplify=TRUE)
  W <- matrix(apply(s2, 1, mean), nvar(x), nvar(x))
  xbar <- sapply(x, apply, 2, mean, simplify=TRUE)
  B <- niter(x) * var(t(xbar))
  emax <- eigen(qr.solve(W,B), symmetric=FALSE, only.values=TRUE)$values[1]
  mpsrf <- sqrt( (1 - 1/niter(x)) + (1 + 1/nvar(x)) * emax )
  return(mpsrf)
}

  
"print.gelman.diag" <-
  function (x, digits = 3, ...) 
{
  cat("Potential scale reduction factors:\n\n")
  print.default(x$psrf, digits = digits, ...)
  if(!is.null(x$mpsrf)) {
    cat("\nMultivariate psrf\n\n")
    cat(format(x$mpsrf,digits = digits))
  }
  cat("\n")
}

"gelman.plot" <-
  function (x, bin.width = 10, max.bins = 50, confidence = 0.95,
            transform = FALSE, auto.layout = TRUE, ask = TRUE,
            col = 1:2, lty = 1:2, xlab = "last iteration in chain",
            ylab = "shrink factor", type = "l", ...) 
{
  x <- as.mcmc.list(x)
  oldpar <- NULL
  on.exit(par(oldpar))
  if (auto.layout) 
    oldpar <- par(mfrow = set.mfrow(Nchains = nchain(x), Nparms = nvar(x)))
  oldpar <- c(oldpar, par(ask = ask))
  y <- gelman.preplot(x, bin.width = bin.width, max.bins = max.bins, 
                      confidence = confidence)
  all.na <- apply(is.na(y$shrink[, , 1, drop = FALSE]), 2, all)
  if (!any(all.na)) 
    for (j in 1:nvar(x)) {
      matplot(y$last.iter, y$shrink[, j, ], col = col, 
              lty = lty, xlab = xlab, ylab = ylab, type = type, 
              ...)
      abline(h = 1)
      ymax <- max(c(1, y$shrink[, j, ]), na.rm = TRUE)
      leg <- dimnames(y$shrink)[[3]]
      if (is.R()) {
        xmax <- max(y$last.iter)
        legend(xmax, ymax, legend = leg, lty = lty, bty = "n", 
               col = col, xjust = 1, yjust = 1)
      }
      else {
        xmid <- (max(y$last.iter) + min(y$last.iter))/2
        legend(xmid, ymax, legend = leg, lty = lty, bty = "n", 
               col = col)
      }
      title(main = varnames(x)[j])
    }
  return(invisible(y))
}

"gelman.preplot" <-
  function (x, confidence = 0.95, transform = FALSE, bin.width = 10, 
            max.bins = 50) 
{
  x <- as.mcmc.list(x)
  if (niter(x) <= 50) 
    stop("Less than 50 iterations in chain")
  nbin <- min(floor((niter(x) - 50)/thin(x)), max.bins)
  binw <- floor((niter(x) - 50)/nbin)
  last.iter <- c(seq(from = start(x) + 50 * thin(x), by = binw * 
                     thin(x), length = nbin), end(x))
  shrink <- array(dim = c(nbin + 1, nvar(x), 2))
  dimnames(shrink) <- list(last.iter, varnames(x),
                           c("median", paste(50 * (confidence + 1), "%",
                                             sep = ""))
                           )
  for (i in 1:(nbin + 1)) {
    shrink[i, , ] <- gelman.diag(window(x, end = last.iter[i]), 
                                 confidence = confidence,
                                 transform = transform)$psrf
  }
  all.na <- apply(is.na(shrink[, , 1, drop = FALSE]), 2, all)
  if (any(all.na)) {
    cat("\n******* Error: *******\n")
    cat("Cannot compute Gelman & Rubin's diagnostic for any chain \n")
    cat("segments for variables", varnames(x)[all.na], "\n")
    cat("This indicates convergence failure\n")
  }
  return(shrink = shrink, last.iter = last.iter)
}

































"geweke.diag" <-
  function (x, frac1 = 0.1, frac2 = 0.5) 
  ## 
{
  if (is.mcmc.list(x)) 
    return(lapply(x, geweke.diag, frac1, frac2))
  x <- as.mcmc(x)
  xstart <- c(start(x), end(x) - frac2 * (end(x) - start(x)))
  xend <- c(start(x) + frac1 * (end(x) - start(x)), end(x))
  y.variance <- y.mean <- vector("list", 2)
  for (i in 1:2) {
    y <- window(x, start = xstart[i], end = xend[i])
    y.mean[[i]] <- apply(as.matrix(y), 2, mean)
    y.variance[[i]] <- spectrum0(y)$spec/niter(y)
  }
  z <- (y.mean[[1]] - y.mean[[2]])/sqrt(y.variance[[1]] + y.variance[[2]])
  out <- list(z = z, frac = c(frac1, frac2))
  class(out) <- "geweke.diag"
  return(out)
}

"geweke.plot" <-
  function (x, frac1 = 0.1, frac2 = 0.5, nbins = 20, 
            pvalue = 0.05, auto.layout = TRUE, ask = TRUE, ...) 
{
  x <- as.mcmc.list(x)
  if(start(x) >= end(x)/2)
    stop("Markov chain too short")
  oldpar <- NULL
  on.exit(par(oldpar))
  if (auto.layout) 
    oldpar <- par(mfrow = set.mfrow(Nchains = nchain(x), 
                    Nparms = nvar(x)))
  oldpar <- c(oldpar, par(ask = ask))
  ystart <- seq(from = start(x), to = end(x)/2, length = nbins)
  gcd <- array(dim = c(length(ystart), nvar(x), nchain(x)), 
               dimnames = c(ystart, varnames(x), chanames(x)))
  for (n in 1:length(ystart)) {
    geweke.out <- geweke.diag(window(x, start = ystart[n]), 
                              frac1 = frac1, frac2 = frac2)
    for (k in 1:nchain(x)) gcd[n, , k] <- geweke.out[[k]]$z
  }
  climit <- qnorm(1 - pvalue/2)
  for (k in 1:nchain(x)) for (j in 1:nvar(x)) {
    ylimit <- max(c(climit, abs(gcd[, j, k])))
    plot(ystart, gcd[, j, k], type = "p", xlab = "First iteration in segment", 
         ylab = "Z-score", pch = 4, ylim = c(-ylimit, ylimit), 
         ...)
    abline(h = c(climit, -climit), lty = 2)
    if (nchain(x) > 1) {
      title(main = paste(varnames(x, allow.null = FALSE)[j], 
              " (", chanames(x, allow.null = FALSE)[k], ")", 
              sep = ""))
    }
    else {
      title(main = paste(varnames(x, allow.null = FALSE)[j], 
              sep = ""))
    }
  }
  invisible(list(start.iter = ystart, z = gcd))
}

"print.geweke.diag" <- function (x, digits = min(4, .Options$digits), ...) 
  ## Print method for output from geweke.diag
{
  cat("\nFraction in 1st window =", x$frac[1])
  cat("\nFraction in 2nd window =", x$frac[2], "\n\n")
  print.default(x$z, digits = digits, ...)
  cat("\n")
  invisible(x)
}











"heidel.diag" <- function (x, eps = 0.1, pvalue=0.05) 
{
  if (is.mcmc.list(x)) 
    return(lapply(x, heidel.diag, eps))
  x <- as.mcmc(as.matrix(x))
  HW.mat0 <- matrix(0, ncol = 6, nrow = nvar(x))
  dimnames(HW.mat0) <- list(varnames(x),
                            c("stest", "start", "pvalue", "htest",
                              "mean", "halfwidth"))
  HW.mat <- HW.mat0
  for (j in 1:nvar(x)) {
    start.vec <- seq(from=start(x), to = end(x)/2, by=niter(x)/10)
    Y <- x[, j, drop = TRUE]    
    n1 <- length(Y)
    ## Schruben's test for convergence, applied sequentially
    ##
    S0 <- spectrum0(window(Y, start=end(Y)/2))$spec
    converged <- FALSE
    for (i in seq(along = start.vec)) {
      Y <- window(Y, start = start.vec[i])
      n <- niter(Y)
      ybar <- mean(Y)
      B <- cumsum(Y) - ybar * (1:n)
      Bsq <- (B * B)/(n * S0)
      I <- sum(Bsq)/n
      if(converged <- !is.na(I) && pcramer(I) < 1 - pvalue)
        break
    }
    ## Recalculate S0 using section of chain that passed convergence test
    S0ci <- spectrum0(Y)$spec
    halfwidth <- 1.96 * sqrt(S0ci/n)
    passed.hw <- !is.na(halfwidth) & (abs(halfwidth/ybar) <= eps)
    if (!converged || is.na(I) || is.na(halfwidth)) {
      nstart <- NA
      passed.hw <- NA
      halfwidth <- NA
      ybar <- NA
    }
    else {
      nstart <- start(Y)
    }
    HW.mat[j, ] <- c(converged, nstart, 1 - pcramer(I), 
                     passed.hw, ybar, halfwidth)
  }
  class(HW.mat) <- "heidel.diag"
  return(HW.mat)
}

"print.heidel.diag" <-
  function (x, digits = 3, ...) 
{
  HW.title <- matrix(c("Stationarity", "test", "start", "iteration",
                       "p-value", "", 
                       "Halfwidth", "test", "Mean", "", "Halfwidth", ""),
                     nrow = 2)
  y <- matrix("", nrow = nrow(x), ncol = 6)
  for (j in 1:ncol(y)) {
    y[, j] <- format(x[, j], digits = digits)
  }
  y[, c(1, 4)] <- ifelse(x[, c(1, 4)], "passed", "failed")
  y <- rbind(HW.title, y)
  vnames <- if (is.null(rownames(x))) 
    paste("[,", 1:nrow(x), "]", sep = "")
  else rownames(x)
  dimnames(y) <- list(c("", "", vnames), rep("", 6))
  print.default(y[, 1:3], quote = FALSE, ...)
  print.default(y[, 4:6], quote = FALSE, ...)
  invisible(x)
}

"spectrum0" <- function(x, max.freq=0.5, order=1, max.length=NULL)
{
  ## Estimate spectral density of time series x at frequency 0.
  ## spectrum0(x)/length(x) estimates the variance of mean(x)
  ##
  ## NB We do NOT use the same definition of spectral density
  ## as in spec.pgram.
  ##
  x <- as.matrix(x)
  fmla <- switch(order+1,
                 spec ~ one,
                 spec ~ f1,
                 spec ~ f1 + f2)
  if(is.null(fmla))
    stop("invalid order")

  if (!is.null(max.length) && nrow(x) > max.length) {
    ## batch.size <- 2^floor(log(nrow(x)/max.length, base=2))
    batch.size <- ceiling(nrow(x)/max.length)
    x <- aggregate(ts(x, frequency=batch.size), nfreq = 1, FUN=mean)
  }
  else {
    batch.size <- 1
  }
  N <- nrow(x)
  Nfreq <- floor(N/2)
  freq <- seq(from = 1/N, by = 1/N, length = Nfreq)
  f1 <- sqrt(3) * (4 * freq - 1)
  f2 <- sqrt(5) * (24 * freq^2 - 12 * freq + 1)
  v0 <- numeric(ncol(x))
  for(i in 1:ncol(x)) {
    y <- x[,i]
    yfft <- fft(y)
    spec <- Re(yfft * Conj(yfft))/ N
    spec.data <- data.frame(one = rep(1, Nfreq), f1=f1, f2=f2,
                            spec = spec[1 + (1:Nfreq)],
                            inset = I(freq<=max.freq))

    glm.out <- glm(fmla, family=Gamma(link="log"), data=spec.data,
                   subset=inset)
    v0[i] <- predict(glm.out, type="response",
                     newdata=data.frame(spec=0,one=1,f1=-sqrt(3),f2=sqrt(5)))
  }
  return(list(spec=v0 * batch.size))

}

"pcramer" <- function (q, eps=1.0e-5)
{
  ## Distribution function of the Cramer-von Mises statistic
  ##
  log.eps <- log(eps)
  y <- matrix(0, nrow=4, ncol=length(q))
  for(k in 0:3) {
    z <- gamma(k + 0.5) * sqrt(4*k + 1)/(gamma(k+1) * pi^(3/2) * sqrt(q))
    u <- (4*k + 1)^2/(16*q)
    y[k+1,] <- ifelse(u > -log.eps, 0, z * exp(-u) * besselK(x = u, nu=1/4))
  }
  return(apply(y,2,sum))
}



















"chanames" <-
function (x, allow.null = TRUE) 
{
  if (is.mcmc.list(x)) {
    if (is.null(names(x))) 
      if (allow.null) 
        NULL
      else paste("chain", 1:length(x), sep = "")
    else names(x)
  }
  else NULL
}

"chanames<-" <-
function (x, value) 
{
  if (is.mcmc.list(x)) 
      names(x) <- value
    else stop("Not an mcmc.list object")
    x
}

"varnames" <-
function (x, allow.null = TRUE) 
{
  if (!is.mcmc(x) && !is.mcmc.list(x)) 
    return(NULL)
  y <- if (is.mcmc(x)) 
    dimnames(x)[[2]]
  else if (is.mcmc.list(x)) 
    dimnames(x[[1]])[[2]]
  if (is.null(y) && !allow.null) 
    y <- paste("var", 1:nvar(x), sep = "")
  return(y)
}

"varnames<-" <-
function (x, value) 
{
    if (is.mcmc(x)) {
        x <- as.matrix(x)
        dimnames(x)[[2]] <- value
    }
    else if (is.mcmc.list(x)) 
        for (i in 1:nchain(x)) varnames(x[[i]]) <- value
    else stop("Not an mcmc or mcmc.list object")
    x
}

"nchain" <-
function (x) 
{
    if (is.mcmc(x)) 
        1
    else if (is.mcmc.list(x)) 
        length(x)
    else NULL
}

"nvar" <-
function (x) 
{
  
  if (is.mcmc(x)) {
    if (is.matrix(x)) ncol(x) else 1
  }
  else if (is.mcmc.list(x)) {
    if (is.matrix(x[[1]])) ncol(x[[1]]) else 1
  }
  else NULL
}

"niter" <-
function (x) 
{
  if (is.mcmc(x)) {
    if (is.matrix(x)) nrow(x) else length(x)
  }
  else if (is.mcmc.list(x)) {
    if (is.matrix(x[[1]])) nrow(x[[1]]) else length(x[[1]])
  }
  else NULL
}












"[.mcmc" <- function (x, i, j, drop = missing(i)) 
{
  xstart <- start(x)
  xthin <- thin(x)
  y <- NextMethod("[")
  if (length(y) == 0 || is.null(y)) 
    return(y)
  if (missing(i)) 
    y <- mcmc(y, start = xstart, thin = xthin)
  else
    return(y)
}

"as.mcmc" <- function (x) 
  UseMethod("as.mcmc")

"as.mcmc.default" <- function (x) 
  if (is.mcmc(x)) x else mcmc(x)

"as.ts.mcmc" <- function (x) 
{
  x <- as.mcmc(x)
  y <- ts(x, start = start(x), end = end(x), deltat = thin(x))
  attr(y, "mcpar") <- NULL
  return(y)
}

"start.mcmc" <- function (x) 
{
  mcpar(as.mcmc(x))[1]
}

"end.mcmc" <- function (x) 
{
  mcpar(as.mcmc(x))[2]
}

"frequency.mcmc" <- function (x) 
{
  1/thin(x)
}

"thin.mcmc" <- function (x) 
{
  mcpar(as.mcmc(x))[3]
}

"is.mcmc" <- function (x) 
{
  if (inherits(x, "mcmc")) 
    if (length(dim(x)) == 3) 
      stop("Obsolete mcmc object\nUpdate with a command like\nx <- upgrade.mcmc(x)")
    else TRUE
  else FALSE
}

"mcmc" <- function (data = NA, start = 1, end = numeric(0), thin = 1) 
{
  if (is.matrix(data)) {
    niter <- nrow(data)
    nvar <- ncol(data)
  }
  else {
    niter <- length(data)
    nvar <- 1
  }
  thin <- round(thin)
  if (length(start) > 1) 
    stop("Invalid start")
  if (length(end) > 1) 
    stop("Invalid end")
  if (length(thin) != 1) 
    stop("Invalid thin")
  if (missing(end)) 
    end <- start + (niter - 1) * thin
  else if (missing(start)) 
    start <- end - (niter - 1) * thin
  nobs <- floor((end - start)/thin + 1.01)
  if (niter < nobs) 
    stop("Start, end and thin incompatible with data")
  else {
    end <- start + thin * (nobs - 1)
    if (nobs < niter) 
      data <- data[1:nobs, , , drop = FALSE]
  }
  attr(data, "mcpar") <- c(start, end, thin)
  attr(data, "class") <- "mcmc"
  data
}

"print.mcmc" <- function (x, ...) 
{
  x.orig <- x
  cat("Markov Chain Monte Carlo (MCMC) output:\nStart =", start(x), 
      "\nEnd =", end(x), "\nThinning interval =", thin(x), "\n")
  attr(x, "mcpar") <- NULL
  attr(x, "class") <- NULL
  NextMethod("print", ...)
  invisible(x.orig)
}


"as.matrix.mcmc" <- function (x, iters = FALSE) 
{
  y <- matrix(nrow = niter(x), ncol = nvar(x) + iters)
  var.cols <- iters + 1:nvar(x)
  if (iters) 
    y[, 1] <- as.vector(time(x))
  y[, var.cols] <- x
  rownames <- character(ncol(y))
  if (iters) 
    rownames[1] <- "ITER"
  rownames[var.cols] <- varnames(x, allow.null = FALSE)
  dimnames(y) <- list(NULL, rownames)
  mcmc(y, start = start(x), end = end(x), thin = thin(x))
}

"time.mcmc" <- function (x) 
{
  x <- as.mcmc(x)
  ts(seq(from = start(x), to = end(x), by = thin(x)), start = start(x), 
     end = end(x), deltat = thin(x))
}

"window.mcmc" <- function (x, start, end, thin, ts.eps = .Options$ts.eps) 
{
  xmcpar <- mcpar(x)
  xstart <- xmcpar[1]
  xend <- xmcpar[2]
  xthin <- xmcpar[3]
  if (missing(thin)) 
    thin <- xthin
  else if (thin%%xthin != 0) {
    thin <- xthin
    warning("Thin value not changed")
  }
  xtime <- as.vector(time(x))
  if (missing(start)) 
    start <- xstart
  else if (length(start) != 1) 
    stop("bad value for start")
  else if (start < xstart) {
    start <- xstart
    warning("start value not changed")
  }
  if (missing(end)) 
    end <- xend
  else if (length(end) != 1) 
    stop("bad value for end")
  else if (end > xend) {
    end <- xend
    warning("end value not changed")
  }
  if (start > end) 
    stop("start cannot be after end")
  if (all(abs(xtime - start) > abs(start) * ts.eps)) {
    start <- xtime[(xtime > start) & ((start + xthin) > xtime)]
  }
  if (all(abs(end - xtime) > abs(end) * ts.eps)) {
    end <- xtime[(xtime < end) & ((end - xthin) < xtime)]
  }
  use <- 1:niter(x)
  use <- use[use >= trunc((start - xstart)/xthin + 1.5) &
             use <= trunc((end - xstart)/xthin + 1.5) &
             (use - trunc((start- xstart)/xthin + 1.5))%%(thin%/%xthin) == 0]
  y <- if (is.matrix(x)) 
    x[use, , drop = FALSE]
  else x[use]
  return(mcmc(y, start=start, end=end, thin=thin))
}

"mcpar" <- function (x) 
{
  attr(x, "mcpar")
}

"upgrade.mcmc" <- function (x) 
{
  if (inherits(x, "mcmc")) {
    if (length(dim(x)) == 3) {
      nchain <- dim(x)[3]
      xtspar <- attr(x, "tspar")
      xstart <- xtspar[1]
      xend <- xtspar[2]
      xthin <- xtspar[3]
      out <- vector("list", nchain)
      for (i in 1:nchain) {
        y <- unclass(x)[, , 1, drop = TRUE]
        attr(y, "title") <- NULL
        attr(y, "tspar") <- NULL
        out[[i]] <- mcmc(y, start = xstart, end = xend, 
                         thin = xthin)
      }
      if (nchain == 1) 
        return(out[[1]])
      else return(mcmc.list(out))
    }
    else return(x)
  }
  else stop("Can't upgrade")
}

"thin" <-
function (x, ...)
  UseMethod("thin")

"set.mfrow" <-
function (Nchains = 1, Nparms = 1, nplots = 1, sepplot = FALSE) 
{
  ## Set up dimensions of graphics window: 
  ## If only density plots OR trace plots are requested, dimensions are: 
  ##	1 x 1	if Nparms = 1 
  ##	1 X 2 	if Nparms = 2 
  ##	2 X 2 	if Nparms = 3 or 4 
  ##	3 X 2 	if Nparms = 5 or 6 or 10 - 12 
  ##	3 X 3 	if Nparms = 7 - 9 or >= 13 
  ## If both density plots AND trace plots are requested, dimensions are: 
  ##	1 x 2	if Nparms = 1 
  ##	2 X 2 	if Nparms = 2 
  ##	3 X 2 	if Nparms = 3, 5, 6, 10, 11, or 12 
  ##	4 x 2	if Nparms otherwise 
  ## If separate plots are requested for each chain, dimensions are: 
  ##	1 x 2	if Nparms = 1 & Nchains = 2 
  ##	2 X 2 	if Nparms = 2 & Nchains = 2 OR Nparms = 1 & Nchains = 3 or 4 
  ##	3 x 2	if Nparms = 3 or >= 5 & Nchains = 2  
  ##		   OR Nchains = 5 or 6 or 10 - 12 (and any Nparms) 
  ##	2 x 3	if Nparms = 2 or 4 & Nchains = 3 
  ##	4 x 2   if Nparms = 4 & Nchains = 2  
  ##		   OR Nchains = 4 & Nparms > 1 
  ##	3 x 3	if Nparms = 3 or >= 5  & Nchains = 3  
  ##		   OR Nchains = 7 - 9 or >= 13 (and any Nparms)
  mfrow <- if (sepplot && Nchains > 1 && nplots == 1) {
    ## Separate plots per chain
    ## Only one plot per variable
    if (Nchains == 2) {
      switch(min(Nparms, 5),
             c(1,2),
             c(2,2),
             c(3,2),
             c(4,2),
             c(3,2))
    }
    else if (Nchains == 3) {
      switch(min(Nparms, 5),
             c(2,2),
             c(2,3),
             c(3,3),
             c(2,3),
             c(3,3))
    }
    else if (Nchains == 4) {
      if (Nparms == 1)
        c(2,2)
      else
        c(4,2)
    }
    else if (any(Nchains == c(5,6,10,11,12)))
      c(3,2)
    else if (any(Nchains == c(7,8,9)) || Nchains >=13)
      c(3,3)
      
  }
  else {
    if (nplots==1) {
      ## One plot per variable
      mfrow <- switch(min(Nparms,13),
                      c(1,1),
                      c(1,2),
                      c(2,2),
                      c(2,2),
                      c(3,2),
                      c(3,2),
                      c(3,3),
                      c(3,3),
                      c(3,3),
                      c(3,2),
                      c(3,2),
                      c(3,2),
                      c(3,3))
    }
    else {
      ## Two plot per variable
      ##
      mfrow <- switch(min(Nparms, 13),
                      c(1,2),
                      c(2,2),
                      c(3,2),
                      c(4,2),
                      c(3,2),
                      c(3,2),
                      c(4,2),
                      c(4,2),
                      c(4,2),
                      c(3,2),
                      c(3,2),
                      c(3,2),
                      c(4,2))
    }
  }
  return(mfrow)
}












"[.mcmc.list" <- function (x, i, j, drop = TRUE) 
{
  ## Trying to squeeze too much functionality in here
  ## x[p:q] will subset the list
  ## x[p,], x[,q], x[p,q] will be recursively applied to
  ## the elements of the list, even if they are vectors
  if (nargs() < 3 + !missing(drop)) {
    ## Subset the list
    y <- NextMethod("[")
  }
  else {
    ## Subset the elements of the list
    y <- vector("list", length(x))
    names(y) <- names(x)
    for (k in 1:length(y)) {
      drop1 <- drop | !is.matrix(x[[k]])
      y[[k]] <- if (missing(i) && missing(j)) 
        x[[k]]
      else if (missing(i)) 
        as.matrix(x[[k]])[, j, drop = drop1]
      else if (missing(j)) 
        as.matrix(x[[k]])[i, , drop = drop1]
      else as.matrix(x[[k]])[i, j, drop = drop1]
    }
  }
  if (is.list(y) && all(sapply(y, is.mcmc, simplify = TRUE))) 
    y <- mcmc.list(y)
  return(y)
}


"mcmc.list" <- function (...) 
{
  x <- list(...)
  if (length(x) == 1 && is.list(x[[1]])) 
    x <- x[[1]]
  if (!all(unlist(lapply(x, is.mcmc)))) 
    stop("Arguments must be mcmc objects")
  nargs <- length(x)
  if (nargs >= 2) {
    xmcpar <- lapply(x, mcpar)
    if (!all(unlist(lapply(xmcpar, "==", xmcpar[[1]])))) 
      stop("Different start, end or thin values in each chain")
    xnvar <- lapply(x, nvar)
    if (!all(unlist(lapply(xnvar, "==", xnvar[[1]])))) 
      stop("Different number of variables in each chain")
    xvarnames <- lapply(x, varnames, allow.null = FALSE)
    if (!all(unlist(lapply(xvarnames, "==", xvarnames[[1]])))) 
      stop("Different variable names in each chain")
  }
  class(x) <- "mcmc.list"
  return(x)
}

"start.mcmc.list" <- function (x) 
{
  start(x[[1]])
}

"end.mcmc.list" <- function (x) 
{
  end(x[[1]])
}

"thin.mcmc.list" <- function (x) 
{
  thin(x[[1]])
}

"is.mcmc.list" <- function (x) 
  inherits(x, "mcmc.list")

"plot.mcmc.list" <-
  function (x, trace = TRUE, density = TRUE, smooth = TRUE, bwf, 
            auto.layout = TRUE, ask = TRUE, ...) 
{
  oldpar <- NULL
  on.exit(par(oldpar))
  if (auto.layout) {
    mfrow <- set.mfrow(Nchains = nchain(x), Nparms = nvar(x), 
                       nplots = trace + density)
    oldpar <- par(mfrow = mfrow)
  }
  oldpar <- c(oldpar, par(ask = ask))
  for (i in 1:nvar(x)) {
    if (trace) 
      traceplot(x[, i, drop = FALSE], smooth = smooth)
    if (density) 
      if (missing(bwf)) 
        densplot(x[, i, drop = FALSE])
      else densplot(x[, i, drop = FALSE], bwf = bwf)
  }
}

"summary.mcmc.list" <-
  function (x, quantiles = c(0.025, 0.25, 0.5, 0.75, 0.975), ...) 
{
  x <- mcmc.list(x)
  statnames <- c("Mean", "SD", "Naive SE", "Time-series SE")
  varstats <- matrix(nrow = nvar(x), ncol = length(statnames), 
                     dimnames = list(varnames(x), statnames))
  xtsvar <- matrix(nrow = nchain(x), ncol = nvar(x))
  if (is.matrix(x[[1]])) {
    for (i in 1:nchain(x))
      for(j in 1:nvar(x))
        xtsvar[i, j] <- spectrum0(x[[i]][,j])$spec
    xlong <- do.call("rbind", x)
  }
  else {
    for (i in 1:nchain(x))
      xtsvar[i, ] <- spectrum0(x[[i]])$spec
    xlong <- as.matrix(x)
  }

  xmean <- apply(xlong, 2, mean)
  xvar <- apply(xlong, 2, var)
  xtsvar <- apply(xtsvar, 2, mean)
  varquant <- t(apply(xlong, 2, quantile, quantiles))
  varstats[, 1] <- xmean
  varstats[, 2] <- sqrt(xvar)
  varstats[, 3] <- sqrt(xvar/niter(x))
  varstats[, 4] <- sqrt(xtsvar/niter(x))
  varquant <- drop(varquant)
  varstats <- drop(varstats)
  out <- list(statistics = varstats, quantiles = varquant, 
              start = start(x), end = end(x), thin = thin(x),
              nchain = nchain(x))
  class(out) <- "summary.mcmc"
  return(out)
}

"as.matrix.mcmc.list" <-
  function (x, iters = FALSE, chains = FALSE) 
{
  x <- mcmc.list(x)
  y <- matrix(nrow = niter(x) * nchain(x), ncol = nvar(x) + 
              chains + iters)
  var.cols <- chains + iters + 1:nvar(x)
  for (i in 1:nchain(x)) {
    use.rows <- niter(x) * (i - 1) + 1:niter(x)
    if (chains) 
      y[use.rows, 1] <- i
    if (iters) 
      y[use.rows, chains + 1] <- as.vector(time(x))
    y[use.rows, var.cols] <- x[[i]]
  }
  rownames <- character(ncol(y))
  if (chains) 
    rownames[1] <- "CHAIN"
  if (iters) 
    rownames[1 + chains] <- "ITER"
  rownames[var.cols] <- varnames(x, allow.null = FALSE)
  dimnames(y) <- list(NULL, rownames)
  return(y)
}

"as.mcmc.mcmc.list" <- function (x) 
{
  if (nchain(x) == 1) 
    return(x[[1]])
  else stop("Can't coerce mcmc.list to mcmc object:\n more than 1 chain")
}

"time.mcmc.list" <- function (x) 
  time(x[[1]])

"window.mcmc.list" <- function (x, ...) 
{
  structure(lapply(x, window.mcmc, ...), class = "mcmc.list")
}

"as.mcmc.list" <- function (x, ...) 
  UseMethod("as.mcmc.list")

"as.mcmc.list.default" <- function (x, ...) 
  if (is.mcmc.list(x)) x else mcmc.list(x)

"as.array.mcmc.list" <- function(x, drop=TRUE, ...)
{
  y <- array(dim=c(niter(x), nvar(x), nchain(x)),
             dimnames = list(iter=time(x), var=varnames(x), chain=chanames(x)))
  for(i in 1:nchain(x))
    y[,,i] <- x[[i]]
  if(drop)
    return(drop(y))
  else
    return(y)
}












"autocorr" <-
function (x, lags = c(0, 1, 5, 10, 50), relative = TRUE) 
{
  if (relative) 
    lags <- lags * thin(x)
  else if (any(lags%%thin(x) != 0)) 
    stop("Lags do not conform to thinning interval")
  lags <- lags[lags < niter(x) * thin(x)]
  if (is.mcmc.list(x)) 
    return(lapply(x, autocorr, lags, relative))
  x <- as.mcmc(x)
  y <- array(dim = c(length(lags), nvar(x), nvar(x)))
  dimnames(y) <- list(paste("Lag", lags), varnames(x), varnames(x))
  acf.out <- acf(as.ts.mcmc(x), lag.max = max(lags), plot = FALSE)$acf
  y[, , ] <- if (is.array(acf.out)) 
    acf.out[lags%/%thin(x) + 1, , ]
  else acf.out[lags%/%thin(x) + 1]
  return(y)
}

"autocorr.plot" <-
function (x, lag.max, auto.layout = TRUE, ask = TRUE, ...) 
{
    oldpar <- par(ask = TRUE)
    on.exit(par(oldpar))
    if (auto.layout) 
        oldpar <- par(mfrow = set.mfrow(Nchains = nchain(x), 
            Nparms = nvar(x)))
    oldpar <- c(oldpar, par(ask = ask))
    if (!is.mcmc.list(x)) 
        x <- mcmc.list(as.mcmc(x))
    for (i in 1:nchain(x)) {
        xacf <- if (missing(lag.max)) 
            acf(as.ts.mcmc(x[[i]]), plot = FALSE)
        else acf(as.ts.mcmc(x[[i]]), lag.max = lag.max, plot = FALSE)
        for (j in 1:nvar(x)) {
            plot(xacf$lag[, j, j], xacf$acf[, j, j], type = "h", 
                ylab = "Autocorrelation", xlab = "Lag", ylim = c(-1, 
                  1), ...)
            title(paste(varnames(x)[j], ifelse(is.null(chanames(x)), 
                "", ":"), chanames(x)[i], sep = ""))
        }
    }
    invisible(x)
}

"crosscorr" <-
function (x) 
{
    cor(as.matrix(x))
}

"crosscorr.plot" <-
function (x, col = topo.colors(10), ...) 
{
    Nvar <- nvar(x)
    pcorr <- crosscorr(x)
    dens <- ((pcorr + 1) * length(col))%/%2 + (pcorr < 1) + (pcorr < 
        -1)
    cutoffs <- format(seq(from = 1, to = -1, length = length(col) + 
        1), digits = 2)
    leg <- paste("(", cutoffs[-1], ",", cutoffs[-length(cutoffs)], 
        "]", sep = "")
    oldpar <- NULL
    on.exit(par(oldpar))
    oldpar <- c(par(pty = "s", adj = 0.5), oldpar)
    plot(0, 0, type = "n", xlim = c(0, Nvar), ylim = c(0, Nvar), 
        xlab = "", ylab = "", xaxt = "n", yaxt = "n", ...)
    axis(1, at = 1:Nvar - 0.5, labels = abbreviate(varnames(x, 
        allow.null = FALSE), minlength = 7))
    axis(2, at = 1:Nvar - 0.5, labels = abbreviate(varnames(x, 
        allow.null = FALSE), minlength = 7)[Nvar:1])
    for (cl in 1:Nvar) {
        for (rw in 1:(Nvar - cl + 1)) polygon(y = c(cl - 1, cl - 
            1, cl, cl, cl - 1), x = c(rw - 1, rw, rw, rw - 1, 
            rw - 1), col = col[dens[nrow(dens) - cl + 1, rw]])
    }
    yval <- seq(from = Nvar/2, to = Nvar, length = length(col) + 
        1)
    ydelta <- Nvar/(2 * (length(col) + 1))
    for (i in 1:length(col)) {
        polygon(y = c(yval[i], yval[i + 1], yval[i + 1], yval[i], 
            yval[i]), col = col[i], x = c(Nvar - ydelta, Nvar - 
            ydelta, Nvar, Nvar, Nvar - ydelta))
    }
    text(Nvar - ydelta, Nvar, "1", adj = c(1, 1))
    text(Nvar - ydelta, 0.5 * Nvar, "-1", adj = c(1, 0))
    text(Nvar - ydelta, 0.75 * Nvar, "0", adj = c(1, 0.5))
    return()
}

"densplot" <-
function (x, show.obs = TRUE, bwf, main = "", ylim, ...) 
{
  xx <- as.matrix(x)
  for (i in 1:nvar(x)) {
    y <- xx[, i, drop = TRUE]
    if (missing(bwf)) 
      bwf <- function(x) {
        x <- x[!is.na(as.vector(x))]
        return(1.06 * min(sd(x), IQR(x)/1.34) * length(x)^-0.2)
      }
    bw <- bwf(y)
    width <- 4 * bw
    if (max(abs(y - floor(y))) == 0 || bw == 0) 
      hist(y, prob = TRUE, main = main, ...)
    else {
      scale <- "open"
      if (max(y) <= 1 && 1 - max(y) < 2 * bw) {
        if (min(y) >= 0 && min(y) < 2 * bw) {
          scale <- "proportion"
          y <- c(y, -y, 2 - y)
        }
      }
      else if (min(y) >= 0 && min(y) < 2 * bw) {
        scale <- "positive"
        y <- c(y, -y)
      }
      else scale <- "open"
      dens <- density(y, width = width)
      if (scale == "proportion") {
        dens$y <- 3 * dens$y[dens$x >= 0 & dens$x <= 
                             1]
        dens$x <- dens$x[dens$x >= 0 & dens$x <= 1]
      }
      else if (scale == "positive") {
        dens$y <- 2 * dens$y[dens$x >= 0]
        dens$x <- dens$x[dens$x >= 0]
      }
      if(missing(ylim))
        ylim <- c(0, max(dens$y))
      plot(dens, ylab = "", main = main, type = "l", 
           ylim = ylim, ...)
      if (show.obs) 
        lines(y[1:niter(x)], rep(max(dens$y)/100, niter(x)), 
              type = "h")
    }
    if (!is.null(varnames(x)) && is.null(list(...)$main)) 
      title(paste("Density of", varnames(x)[i]))
  }
  return(invisible(x))
}

"read.bugs" <-
function (file = "bugs.out", start, end, thin, quiet=FALSE) 
{
  nc <- nchar(file)
  if (nc > 3 && substring(file, nc - 3, nc) == ".out") 
    root <- substring(file, 1, nc - 4)
  else root <- file
  index <- read.table(file = paste(root, ".ind", sep = ""), 
                      row.names = 1, col.names = c("", "begin", "end"))
  vnames <- row.names(index)

  temp <- scan(file = paste(root, ".out", sep = ""), what = list(iter = 0, 
                                                       val = 0), quiet = TRUE)
  ## Do one pass through the data to see if we can construct 
  ## a regular time series easily 
  ## 
  start.vec <- end.vec <- thin.vec <- numeric(nrow(index))
  for (i in 1:length(vnames)) {
    iter.i <- temp$iter[index[i, "begin"]:index[i, "end"]]
    thin.i <- unique(diff(iter.i))
    thin.vec[i] <- if (length(thin.i) == 1) 
      thin.i
    else NA
    start.vec[i] <- iter.i[1]
    end.vec[i] <- iter.i[length(iter.i)]
  }
  if (any(is.na(start.vec)) || any(thin.vec != thin.vec[1]) || 
      any((start.vec - start.vec[1])%%thin.vec[1] != 0)) {
    ## 
    ## Do it the brute force way 
    ## 
    iter <- sort(unique(temp$iter))
    old.thin <- unique(diff(iter))
    if (length(old.thin) == 1) 
      is.regular <- TRUE
    else {
      if (all(old.thin%%min(old.thin) == 0)) 
        old.thin <- min(old.thin)
      else old.thin <- 1
      is.regular <- FALSE
    }
  }
  else {
    iter <- seq(from = min(start.vec), to = max(end.vec), 
                by = thin.vec[1])
    old.thin <- thin.vec[1]
    is.regular <- TRUE
  }
  if (missing(start)) 
    start <- min(start.vec)
  else if (start < min(start.vec)) {
    warning("start not changed")
    start <- min(start.vec)
  }
  else if (start > max(end.vec)) 
    stop("Start after end of data")
  else iter <- iter[iter >= start]
  if (missing(end)) 
    end <- max(end.vec)
  else if (end > max(end.vec)) {
    warning("end not changed")
    end <- max(end.vec)
  }
  else if (end < min(start.vec)) 
    stop("End before start of data")
  else iter <- iter[iter <= end]
  if (missing(thin)) 
    thin <- old.thin
  else if (thin%%old.thin != 0) {
    thin <- old.thin
    warning("thin not changed")
  }
  else {
    new.iter <- iter[(iter - start)%%thin == 0]
    new.thin <- unique(diff(new.iter))
    if (length(new.thin) != 1 || new.thin != thin) 
      warning("thin not changed")
    else {
      iter <- new.iter
      end <- max(iter)
      is.regular <- TRUE
    }
  }
  out <- matrix(NA, nrow = length(iter), ncol = nrow(index))
  dimnames(out) <- list(iter, vnames)
  for (v in vnames) {
    if(!quiet)
      cat("Abstracting", v, "... ")
    inset <- index[v, "begin"]:index[v, "end"]
    iter.v <- temp$iter[inset]
    if (!is.regular) {
      use.v <- duplicated(c(iter, iter.v))[-(1:length(iter))]
      use <- duplicated(c(iter.v, iter))[-(1:length(iter.v))]
    }
    else {
      use.v <- (iter.v - start)%%thin == 0 & iter.v >= 
        start & iter.v <= end
      use <- (iter.v[use.v] - start)%/%thin + 1
    }
    if (any(use) & any(use.v)) 
      out[use, v] <- temp$val[inset[use.v]]
    if(!quiet)
      cat(length(use), "valid values\n")
  }
  if (is.regular) 
    out <- mcmc(out, start = start, end = end, thin = thin)
  else warning("not returning an mcmc object")
  return(out)
}

"traceplot" <-
function (x, smooth = TRUE, col = 1:6, type = "l", ylab = "", 
    ...) 
{
  x <- mcmc.list(x)
  args <- list(...)
  for (j in 1:nvar(x)) {
    xp <- as.vector(time(x))
    yp <- if (nvar(x) > 1) 
      x[, j, drop = TRUE]
    else x
    yp <- do.call("cbind", yp)
    matplot(xp, yp, xlab = "Iterations", ylab = ylab, type = type, 
            col = col, ...)
    if (!is.null(varnames(x)) && is.null(list(...)$main)) 
      title(paste("Trace of", varnames(x)[j]))
    if (smooth) {
      scol <- rep(col, length = nchain(x))
      for (k in 1:nchain(x)) lines(lowess(xp, yp[, k]), 
                                   col = scol[k])
    }
  }
}

"plot.mcmc" <- function (x, trace = TRUE, density = TRUE, smooth = TRUE, bwf, 
                         auto.layout = TRUE, ask = TRUE, ...) 
{
  oldpar <- NULL
  on.exit(par(oldpar))
  if (auto.layout) {
    mfrow <- set.mfrow(Nchains = nchain(x), Nparms = nvar(x), 
                       nplots = trace + density)
    oldpar <- par(mfrow = mfrow)
  }
  oldpar <- c(oldpar, par(ask = ask))
  for (i in 1:nvar(x)) {
    y <- as.matrix(x)[, i, drop = FALSE]
    if (trace) 
      traceplot(y, smooth = smooth)
    if (density) 
      if (missing(bwf)) 
        densplot(y)
      else densplot(y, bwf = bwf)
  }
}

"summary.mcmc" <-
  function (x, quantiles = c(0.025, 0.25, 0.5, 0.75, 0.975), ...) 
{
  x <- as.mcmc(x)
  statnames <- c("Mean", "SD", "Naive SE", "Time-series SE")
  varstats <- matrix(nrow = nvar(x), ncol = length(statnames), 
                     dimnames = list(varnames(x), statnames))
  sp0 <- function(x) spectrum0(x)$spec
  if (is.matrix(x)) {
    xmean <- apply(x, 2, mean)
    xvar <- apply(x, 2, var)
    xtsvar <- apply(x, 2, sp0)
    varquant <- t(apply(x, 2, quantile, quantiles))
  }
  else {
    xmean <- mean(x, na.rm = TRUE)
    xvar <- var(x, na.rm = TRUE)
    xtsvar <- sp0(x)
    varquant <- quantile(x, quantiles)
  }
  varstats[, 1] <- xmean
  varstats[, 2] <- sqrt(xvar)
  varstats[, 3] <- sqrt(xvar/niter(x))
  varstats[, 4] <- sqrt(xtsvar/niter(x))
  varstats <- drop(varstats)
  varquant <- drop(varquant)
  out <- list(statistics = varstats, quantiles = varquant, 
              start = start(x), end = end(x), thin = thin(x), nchain = 1)
  class(out) <- "summary.mcmc"
  return(out)
}

"print.summary.mcmc" <-
  function (x, digits = max(3, .Options$digits - 3), ...) 
{
  cat("\n", "Iterations = ", x$start, ":", x$end, "\n", sep = "")
  cat("Thinning interval =", x$thin, "\n")
  cat("Number of chains =", x$nchain, "\n")
  cat("Sample size per chain =", (x$end - x$start)/x$thin + 
      1, "\n")
  cat("\n1. Empirical mean and standard deviation for each variable,")
  cat("\n   plus standard error of the mean:\n\n")
  print(x$statistics, digits = digits, ...)
  cat("\n2. Quantiles for each variable:\n\n")
  print(x$quantiles, digits = digits, ...)
  cat("\n")
  invisible(x)
}








"raftery.diag" <-
function (data, q = 0.025, r = 0.005, s = 0.95, converge.eps = 0.001) 
{
    if (is.mcmc.list(data)) 
        return(lapply(data, raftery.diag, q, r, s, converge.eps))
    data <- as.mcmc(data)
    resmatrix <- matrix(nrow = nvar(data), ncol = 4, dimnames = list(varnames(data, 
        allow.null = TRUE), c("M", "N", "Nmin", "I")))
    phi <- qnorm(0.5 * (1 + s))
    nmin <- as.integer(ceiling((q * (1 - q) * phi^2)/r^2))
    if (nmin > niter(data)) 
        resmatrix <- c("Error", nmin)
    else for (i in 1:nvar(data)) {
        #          First need to find the thinning parameter kthin 
        # 
        if (is.matrix(data)) {
            quant <- quantile(data[, i, drop = TRUE], probs = q)
            dichot <- mcmc(data[, i, drop = TRUE] <= quant, start = start(data), 
                end = end(data), thin = thin(data))
        }
        else {
            quant <- quantile(data, probs = q)
            dichot <- mcmc(data <= quant, start = start(data), 
                end = end(data), thin = thin(data))
        }
        kthin <- 0
        bic <- 1
        while (bic >= 0) {
            kthin <- kthin + thin(data)
            testres <- as.vector(window.mcmc(dichot, thin = kthin))
            newdim <- length(testres)
            testtran <- table(testres[1:(newdim - 2)], testres[2:(newdim - 
                1)], testres[3:newdim])
            testtran <- array(as.double(testtran), dim = dim(testtran))
            g2 <- 0
            for (i1 in 1:2) {
                for (i2 in 1:2) {
                  for (i3 in 1:2) {
                    if (testtran[i1, i2, i3] != 0) {
                      fitted <- (sum(testtran[i1, i2, 1:2]) * 
                        sum(testtran[1:2, i2, i3]))/(sum(testtran[1:2, 
                        i2, 1:2]))
                      g2 <- g2 + testtran[i1, i2, i3] * log(testtran[i1, 
                        i2, i3]/fitted) * 2
                    }
                  }
                }
            }
            bic <- g2 - log(newdim - 2) * 2
        }
        #
        # then need to find length of burn-in and No of iterations for required precision 
        # 
        finaltran <- table(testres[1:(newdim - 1)], testres[2:newdim])
        alpha <- finaltran[1, 2]/(finaltran[1, 1] + finaltran[1, 
            2])
        beta <- finaltran[2, 1]/(finaltran[2, 1] + finaltran[2, 
            2])
        tempburn <- log((converge.eps * (alpha + beta))/max(alpha, 
            beta))/(log(abs(1 - alpha - beta)))
        nburn <- as.integer(ceiling(tempburn) * kthin)
        tempprec <- ((2 - alpha - beta) * alpha * beta * phi^2)/(((alpha + 
            beta)^3) * r^2)
        nkeep <- as.integer(ceiling(tempprec) * kthin)
        iratio <- (nburn + nkeep)/nmin
        resmatrix[i, 1] <- nburn
        resmatrix[i, 2] <- nkeep + nburn
        resmatrix[i, 3] <- nmin
        resmatrix[i, 4] <- signif(iratio, digits = 3)
    }
    y <- list(params = c(r = r, s = s, q = q), resmatrix = resmatrix)
    class(y) <- "raftery.diag"
    return(y)
}
"print.raftery.diag" <-
function (x, digits = 3, ...) 
{
    cat("\nQuantile (q) =", x$params["q"])
    cat("\nAccuracy (r) = +/-", x$params["r"])
    cat("\nProbability (s) =", x$params["s"], "\n")
    if (x$resmatrix[1] == "Error") 
        cat("\nYou need a sample size of at least", x$resmatrix[2], 
            "with these values of q, r and s\n")
    else {
        out <- x$resmatrix
        for (i in ncol(out)) out[, i] <- format(out[, i], digits = digits)
        out <- rbind(matrix(c("Burn-in ", "Total", "Lower bound ", 
            "Dependence", "(M)", "(N)", "(Nmin)", "factor (I)"), 
            byrow = TRUE, nrow = 2), out)
        if (!is.null(rownames(x$resmatrix))) 
            out <- cbind(c("", "", rownames(x$resmatrix)), out)
        dimnames(out) <- list(rep("", nrow(out)), rep("", ncol(out)))
        print.default(out, quote = FALSE, ...)
        cat("\n")
    }
    invisible(x)
}

"coda.global.assign" <- function(name, value, alias=FALSE)
{
  ## Utility function to overcome some incompatibilities between
  ## S and R when creating global variables.
  #
  if(is.R()) {
    ## R - assign to global environment
    if(alias)
      assign(name, .Alias(value), pos=1)  
    else
      assign(name, value, pos=1)          
  }
  else {
    ## S - assign to session database
    assign(name, value, where=0)          
  }
}

  ".First.lib" <- function(lib,pkg)
{
  require(ts)
}

"read.yesno" <-
function (string, default=TRUE)
{
  wrd <- ifelse(default, " (Y/n)?\n:", " (y/N)?\n:")
  cat("\n", string, wrd, sep = "")
  ans <- readline()
  val <- if (default) 
    pmatch(ans, c("no","NO"), nomatch=0) == 0
  else
    pmatch(ans, c("yes","YES"), nomatch=0) != 0
  return(val)
}

"change.tfoption" <-
function (string, option) 
{
  current.value <- coda.options(option)
  if (!is.logical(current.value)) 
    stop("Invalid option: must take logical values")
  new.value <- read.yesno(string, current.value)
  if (new.value != current.value) {
    arg <- list(new.value)
    names(arg) <- option
    coda.options(arg)
  }
  return()
}

"coda.options" <-
function (...) 
{
  ## Set and display coda options
  single <- FALSE
  if (!exists(".Coda.Options", frame = 1)) 
    .Coda.Options <<- .Coda.Options.Default
  if (nargs() == 0) {
    return(.Coda.Options)
  }
  else {
    args <- list(...)
    if (length(args) == 1) {
      if (is.list(args[[1]])) 
        args <- args[[1]]
      else if (is.null(names(args))) 
        single <- TRUE
    }
  }
  if (is.null(names(args))) {
    ## Display options
    args <- unlist(args)
    value <- vector("list", length(args))
    names(value) <- args
    for (v in args) if (any(v == names(.Coda.Options))) 
      value[v] <- .Coda.Options[v]
    if (single) 
      return(value[[1]])
    else return(value)
  }
  else {
    ## Set options
    oldvalue <- vector("list", length(args))
    names(oldvalue) <- names(args)
    if (any(names(args) == "default") && args$default == 
        TRUE) 
      .Coda.Options <<- .Coda.Options.Default
    for (v in names(args)) if (any(v == names(.Coda.Options))) {
      oldvalue[v] <- .Coda.Options[v]
      if (is.null(args[[v]])) 
        .Coda.Options[v] <<- list(NULL)
      else if (mode(.Coda.Options[[v]]) == mode(args[[v]])) 
        .Coda.Options[v] <<- args[v]
    }
    invisible(oldvalue)
  }
}

"multi.menu" <- function (choices, title, header, allow.zero = TRUE) 
{
  ## Select more than one value from a menu 
  ## 
  if (!missing(title)) 
    cat(title, "\n\n")
  mat <- matrix(c(1:length(choices), choices), ncol = 2)
  if (!missing(header)) {
    if (length(header) == 2) 
      mat <- rbind(header, mat)
    else stop("header is wrong length")
  }
  cat(paste(format(mat[, 1]), format(mat[, 2])), sep = "\n")
  repeat {
    cat("\nEnter relevant number(s), separated by commas", 
        "Ranges such as 3:7 may be specified)", sep = "\n")
    if (allow.zero) 
      cat("(Enter 0 for none)\n")
    if (is.R()) 
      ans <- scan(what = character(), sep = ",", strip.white = TRUE, 
                  nlines = 1, quiet = TRUE)
    else ans <- scan(what = character(), sep = ",", strip.white = TRUE)
    if (length(ans) > 0) {
      out <- numeric(0)
      for (i in 1:length(ans)) {
        nc <- nchar(ans[i])
        wrd <- substring(ans[i], 1:nc, 1:nc)
        colons <- wrd == ":"
        err <- any(is.na(as.numeric(wrd[!colons]))) | 
        sum(colons) > 1 | colons[1] | colons[nc]
        if (err) {
          cat("Error: you have specified a non-numeric value!\n")
          break
        }
        else {
          out <- c(out, eval(parse(text = ans[i])))
          if (min(out) < ifelse(allow.zero, 0, 1) | max(out) > 
              length(choices) | (any(out == 0) & length(out) > 
                                 1)) {
            err <- TRUE
            cat("Error: you have specified variable number(s) out of range!\n")
            break
          }
        }
      }
      if (!err) 
        break
    }
  }
  return(out)
}

"read.and.check" <-
  function (message = "", what = numeric(), lower, upper, answer.in, default) 
{
  ## Read data from the command line and check that it satisfies 
  ## certain conditions.  The function will loop until it gets 
  ## and answer satisfying the conditions. This entails extensive 
  ## checking of the conditions to  make sure they are consistent 
  ## so we don't end up in an infinite loop. 
  have.lower <- !missing(lower)
  have.upper <- !missing(upper)
  have.ans.in <- !missing(answer.in)
  have.default <- !missing(default)
  if (have.lower | have.upper) {
    if (!is.numeric(what)) 
      stop("Can't have upper or lower limits with non numeric input")
    if (have.lower && !is.numeric(lower)) 
      stop("lower limit not numeric")
    if (have.upper && !is.numeric(upper)) 
      stop("upper limit not numeric")
    if ((have.upper & have.lower) && upper < lower) 
      stop("lower limit greater than upper limit")
  }
  if (have.ans.in) {
    if (mode(answer.in) != mode(what)) 
      stop("inconsistent values of what and answer.in")
    if (have.lower) 
      answer.in <- answer.in[answer.in >= lower]
    if (have.upper) 
      answer.in <- answer.in[answer.in <= upper]
    if (length(answer.in) == 0) 
      stop("No possible response matches conditions")
  }
  if (have.default) {
    if (mode(default) != mode(what)) 
      stop("inconsistent values of what and default")
    if (have.lower && default < lower) 
      stop("default value below lower limit")
    if (have.upper && default > upper) 
      stop("default value above upper limit")
    if (have.ans.in && !any(answer.in == default)) 
      stop("default value does not satisfy conditions")
  }
  err <- TRUE
  while (err) {
    if (nchar(message) > 0) {
      cat("\n", message, "\n", sep = "")
      if (have.default) 
        cat("(Default = ", default, ")\n", sep = "")
    }
    repeat {
      cat("1:")
      ans <- readline()
      if (length(ans) == 1 && nchar(ans) > 0) 
        break
      else if (have.default) {
        ans <- default
        break
      }
    }
    if (is.numeric(what)) {
      err1 <- TRUE
      ans <- as.numeric(ans)
      message <- "You must enter a number"
      if (is.na(ans)) 
        NULL
      else if ((have.lower & have.upper) && (ans < lower | 
                                             ans > upper)) 
        message <- paste(message, "between", lower, "and", 
                         upper)
      else if (have.lower && ans < lower) 
        message <- paste(message, ">=", lower)
      else if (have.upper && ans > upper) 
        message <- paste(message, "<=", upper)
      else err1 <- FALSE
    }
    else err1 <- FALSE
    if (have.ans.in) {
      if (!is.na(ans) && !any(ans == answer.in)) {
        message <- paste("You must enter one of the following:", 
                         paste(answer.in, collapse = ","))
        err2 <- TRUE
      }
      else err2 <- FALSE
    }
    else err2 <- FALSE
    err <- err1 | err2
  }
  return(ans)
}

".Coda.Options.Default" <-
  list(trace = TRUE,
       densplot = TRUE,
       lowess = FALSE, 
       combine.plots = TRUE,
       bandwidth = function (x) 
       {
         x <- x[!is.na(x)]
         1.06 * min(sd(x), IQR(x)/1.34) * length(x)^-0.2
       },
       digits = 3,
       quantiles = c(0.025, 0.25, 0.5, 0.75, 0.975),
       frac1 = 0.1,
       frac2 = 0.5,
       q = 0.025,
       r = 0.005, 
       s = 0.95,
       combine.stats = FALSE,
       combine.corr = FALSE,
       halfwidth = 0.1,
       user.layout = FALSE,
       gr.bin = 10,
       geweke.nbin = 20,
       gr.max = 50,
       data.saved = TRUE
       )













