"coda.credits" <-
function (file = "") 
{
    credits <- c("  _______________________________________________________________\n", 
        "|                                                               |\n", 
        "|                 Welcome to CODA for R!                        |\n", 
        "|  Convergence Diagnostics and Output Analysis for BUGS output  |\n", 
        "|_______________________________________________________________|\n", 
        "|                                                               |\n", 
        "|                                                               |\n", 
        "|  Authors : Martyn Plummer, Nicky Best, Kate Cowles,           |\n", 
        "|            Karen Vines                                        |\n", 
        "|                                                               |\n", 
        "|  R-CODA version 0.4 Copyright (c) 1995-9 MRC Biostatistics    |\n", 
        "|  Unit and others (see AUTHORS file)                           |\n", 
        "|  This is free software and commes with ABSOLUTELY NO WARRANTY |\n", 
        "|_______________________________________________________________|\n", 
        "\n")
    cat(credits, file = file)
}
"codamenu" <-
function () 
{
    on.exit(tidy.up())
    coda.options(.Coda.Options.Default)
    file.menu <- c("Begin a new CODA session using BUGS output files", 
        "Begin a new CODA session using data saved from a previous CODA session", 
        "Quit")
    coda.credits()
    pick <- menu(file.menu, title = "CODA startup menu")
    if (pick == 0 || pick == 3) 
        return(invisible())
    else if (pick == 1) {
        coda.dat <<- read.bugs.interactive()
        coda.options(data.saved = FALSE)
        if (is.null(coda.dat)) {
            rm(coda.dat, pos = 1)
            return(invisible())
        }
    }
    else if (pick == 2) {
        msg <- "\nEnter name of object saved from a previous CODA session:\n"
        repeat {
            cat(msg, "\n")
            outname <- readline()
            if (length(outname) == 0) 
                msg <- "You must enter something"
            else if (outname == "0") {
                return(invisible())
            }
            else if (!exists(outname)) 
                msg <- "Can't find this object"
            else if (!is.mcmc.list(eval(parse(text = outname)))) 
                msg <- "Not an mcmc list object"
            else {
                if (is.R()) 
                  coda.dat <<- .Alias(eval(parse(text = outname)))
                else coda.dat <<- eval(parse(text = outname))
                coda.options(data.saved = TRUE)
                break
            }
            msg <- paste(msg, "Please re-enter another name or type 0 to quit:\n", 
                sep = "\n")
        }
    }
    else stop("Invalid option")
    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)
    if (is.R()) 
        work.dat <<- .Alias(coda.dat)
    else work.dat <<- coda.dat
    codamenu.devices()
    current.menu <- "codamenu.main"
    repeat {
        next.menu <- do.call(current.menu, vector("list", 0))
        if (next.menu == "quit") {
            cat("Are you sure you want to quit? (y/N)\n")
            if (any(readline() == c("y", "Y"))) 
                break
        }
        else current.menu <- next.menu
    }
    invisible()
}
"codamenu.anal" <-
function () 
{
    # 
    # outanal -- Output analysis menu for CODA system 
    # 
    # Author: Kate Cowles 
    # 
    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") && !coda.options("onepage")
        if (coda.options("onepage")) {
            opar <- par(mfrow = c(1, 1))
            on.exit(par(opar))
        }
        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 () 
{
    #
    # diags -- Diagnostics menu for CODA system
    #
    # Author: Kate Cowles
    #
    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 () 
{
    #
    # autocorr -- Calculate Autocorrelations for CODA system
    #
    # Author: Kate Cowles
    # Modified by: Nicky Best
    #
    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 () 
{
    # 
    # codamenu.main -- CODA main menu 
    # 
    # Author: Kate Cowles 
    # Modified by: Nicky Best 
    # and by: Martyn Plummer 
    # 
    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 bin size 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 {
                geweke.plot(work.dat, frac1 = coda.options("frac1"), 
                  frac2 = coda.options("frac2"), max.bins = coda.options("geweke.max"), 
                  bin.width = coda.options("geweke.bin"), 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 () 
{
    #
    # codamenu.options-- Main options menu for CODA system
    #
    # Author: Nicky Best
    #
    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)
        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) 
{
    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 Geweke's diagnostic")
    if (pick == 0) 
        return("quit")
    switch(pick, {
        coda.options(geweke.max = 50)
        coda.options(geweke.bin = 10)
    }, {
        coda.options(geweke.max = Inf)
        default <- if (coda.options("geweke.bin") == 0) 
            10
        else coda.options("geweke.bin")
        default <- min(default, niter(work.dat) - 50)
        msg <- "Enter required bin width:"
        coda.options(geweke.bin = read.and.check(msg, lower = 1, 
            upper = niter(work.dat) - 50, default = default))
    }, {
        coda.options(geweke.bin = 0)
        default <- if (is.infinite(coda.options("geweke.max"))) 
            min(50, niter(work.dat) - 50)
        else coda.options("geweke.max")
        default <- min(default, niter(work.dat) - 50)
        msg <- "Enter total number of bins required:"
        coda.options(geweke.max = read.and.check(msg, lower = 1, 
            upper = niter(work.dat) - 50, default = default))
    })
    return(last.menu)
}
"codamenu.options.geweke.win" <-
function (last.menu) 
{
    msg1 <- "Enter fraction of chain to include in 1st window of \nGeweke's diagnostic:"
    msg2 <- "Enter fraction of chain to include in 2nd window of \nGeweke's diagnostic:"
    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
        msg1 <- if (ans1 + ans2 == 1) 
            "Error: Sum of fractions in 1st and 2nd windows equals 1.0\nYou must leave a gap in the chain between the 2 windows\nPlease re-enter fraction of chain to include in 1st window:"
        else "Error: Sum of fractions in 1st and 2nd windows exceeds 1.0\nPlease re-enter fraction of chain to include in 1st window:"
        msg2 <- "Now re-enter fraction of chain to include in 2nd window:"
    }
    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", 
        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"), 
        change.tfoption(choices[6], "onepage"), {
            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 of plots per page (maximum=7)", 
                  lower = 1, upper = 7)
                mcols <- read.and.check("Enter number of columns of plots per page (maximum=8)", 
                  lower = 1, upper = 8)
                coda.options(mrows = mrows)
                coda.options(mcols = mcols)
                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, {
            bw <- function(y) {
                (max(y) - min(y))/4
            }
            coda.options(bandwidth = bw)
        }, {
            bw <- function(x) {
                1.06 * min(sd(x), IQR(x)/1.34) * length(x)^-0.2
            }
            coda.options(bandwidth = bw)
        }, {
            if (is.R()) {
                cat("DANGER! DANGER WILL ROBINSON!\n")
                cat("If you make a mistake here you will crash\n")
                cat("the codamenu session. Sorry, but there is\n")
                cat("no way round this at the moment (R 0.64.0)\n")
                cat("Do you want to try? (y/N)\n")
                ans <- readline()
                if (ans != "y" && ans != "Y") 
                  return("codamenu.options.plot")
            }
            else restart()
            func.OK <- FALSE
            while (!func.OK) {
                cat("Enter bandwidth as a function of y, the sampled values, e.g. \n(max(y) - min(y)) / 4\n")
                ans <- scan(what = character())
                if (length(ans) > 0) {
                  bw <- "function(y){"
                  for (i in 1:length(ans)) {
                    bw <- paste(bw, ans[i], sep = "")
                  }
                  #
                  bw <- paste(bw, "}", sep = "")
                  bw <- eval(parse(text = bw))
                  # Carry out simple test to check whether the
                  # function entered makes sense
                  #
                  func.OK <- test.bandwidth()
                }
            }
            coda.options(bandwidth = bw)
        }, 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) 
{
    #Display working data and coda options in pretty format 
    ## 
    # First define some formatting functions 
    # 
    doline <- function(x, title, type) {
        if (is.null(Version()$language)) 
            doline <- get("doline", frame = sys.parent())
        if (length(x) > 1) {
            doline(x[1], title)
            for (i in 2:length(x)) doline(x[i], "")
            return()
        }
        if (is.logical(x)) 
            x <- ifelse(x, "Yes", "No")
        if (!missing(type) && mode(x) != type) 
            x <- "N/A"
        len.title <- nchar(title)
        endchar <- ifelse(x == "", " ", ":")
        cat("| ", title, paste(rep(" ", 20 - nchar(title)), collapse = ""), 
            sep = "")
        widthleft <- options("width")$width - 25 - nchar(x)
        if (widthleft > 0) 
            cat("| ", x, paste(rep(" ", widthleft), collapse = ""), 
                "|\n", sep = "")
        else cat("| ", x, "\n", sep = "")
    }
    dotitle <- function(title) {
        if (is.null(Version()$language)) 
            doline <- get("doline", frame = sys.parent())
        doline("", title)
        doline("", paste(rep("-", nchar(title)), collapse = ""))
    }
    domaintitle <- function(title) {
        cat("| ", title, paste(rep(" ", options()$width - nchar(title) - 
            3), collapse = ""), "|\n", sep = "")
    }
    doblank <- function() {
        if (is.null(Version()$language)) 
            doline <- get("doline", frame = sys.parent())
        doline("", "")
    }
    dosepline <- function() {
        cat("+", paste(rep("-", options("width")$width - 2), 
            collapse = ""), "+\n", sep = "")
    }
    strbrk <- function(x) {
        WIDTH <- options("width")$width - 26
        N <- length(x)
        x[-N] <- paste(x[-N], ", ", sep = "")
        tmp <- cumsum(nchar(x))
        lr <- vector("list", 1)
        lr[[1]] <- (1:N)[tmp <= WIDTH]
        rr <- x[lr[[1]]]
        i <- 1
        while (rr[length(rr)] != x[N]) {
            tmp <- tmp + (WIDTH - sum(nchar(rr)))
            lr <- c(lr, c(1:N)[tmp > (WIDTH * i) & tmp <= (WIDTH * 
                (i + 1))])
            rr <- x[lr[[i + 1]]]
            i <- i + 1
        }
        y <- character(length(lr))
        for (i in 1:length(y)) y[[i]] <- paste(x[lr[[i]]], collapse = "")
        return(y)
    }
    # 
    # Now we can get on with it 
    # 
    cat("\nCurrent option settings:")
    cat("\n=======================\n\n")
    dosepline()
    if (data) {
        domaintitle("WORKING DATA")
        dosepline()
        doblank()
        ans <- strbrk(varnames(work.dat, allow.null = FALSE))
        doline(ans, "Variables selected")
        ans <- strbrk(chanames(work.dat, allow.null = FALSE))
        doline(ans, "Chains selected")
        doline(start(work.dat), "Iterations - start")
        doline(end(work.dat), "             end")
        doline(thin(work.dat), "Thinning interval")
        doblank()
        dosepline()
    }
    if (stats) {
        domaintitle("SUMMARY STATISTICS OPTIONS")
        dosepline()
        doblank()
        doline(coda.options("combine.stats"), "Combine chains")
        ans <- strbrk(paste(coda.options("quantiles") * 100, 
            "%", sep = ""))
        doline(ans, "Quantiles")
        doline(coda.options("digits"), "Significant digits")
        doblank()
        dosepline()
    }
    if (plots) {
        domaintitle("PLOTTING OPTIONS")
        dosepline()
        doblank()
        doline(coda.options("trace"), "Trace")
        doline(coda.options("densplot"), "Density")
        doline(coda.options("lowess"), "Smooth lines")
        doline(coda.options("combine.plots"), "Combine chains")
        doline(coda.options("onepage"), "One plot/page.")
        doline(coda.options("user.layout"), "User-defined layout")
        if (coda.options("user.layout")) 
            doline(paste(par("mfrow"), collapse = " X "), "")
        width.cut <- options("width")[[1]] - 26
        if (is.null(options()$language)) {
            func <- deparse(coda.options("bandwidth"))
            for (i in 1:length(func)) {
                func.i <- substring(func[i], 1:nchar(func[i]), 
                  1:nchar(func[i]))
                if (any(func.i == "\t")) {
                  func.i[func.i == "\t"] <- "     "
                  func[i] <- paste(func.i, collapse = "")
                }
            }
        }
        else func <- deparse(coda.options("bandwidth"), width.cutoff = width.cut)
        func.print <- vector("list", length(func))
        for (i in 1:length(func)) {
            if (nchar(func[i]) <= width.cut) 
                func.print[[i]] <- func[i]
            else {
                first <- seq(from = 1, to = nchar(func[i]), by = width.cut)
                last <- seq(from = width.cut, to = nchar(func[i]), 
                  by = width.cut)
                if (max(last) < nchar(func[i])) 
                  last <- c(last, nchar(func[i]))
                func.print[[i]] <- substring(func[i], first = first, 
                  last = last)
            }
        }
        doline(unlist(func.print), "Bandwidth")
        doblank()
        dosepline()
    }
    if (diags) {
        domaintitle("DIAGNOSTICS OPTIONS")
        dosepline()
        doblank()
        dotitle("Geweke")
        doline(coda.options("frac1"), "Window 1 fraction")
        doline(coda.options("frac2"), "Window 2 fraction")
        doline(coda.options("geweke.bin"), "Bin width", type = "numeric")
        doline(coda.options("geweke.max"), "Max number of bins", 
            type = "numeric")
        doblank()
        dotitle("Gelman & Rubin")
        ans <- coda.options("gr.bin")
        doline(ans, "Bin width", type = "numeric")
        doline(coda.options("gr.max"), "Max number of bins", 
            type = "numeric")
        doblank()
        dotitle("Raftery & Lewis")
        doline(coda.options("q"), "Quantile (q)")
        doline(coda.options("r"), "Precision (+/- r)")
        doline(coda.options("s"), "Probability (s)")
        doblank()
        dotitle("Cross-correlations")
        doline(coda.options("combine.corr"), "Combine chains")
        doblank()
        dosepline()
    }
    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))
}
"coda.objects" <-
c("autocorr.plot", "chanames", "change.tfoption", "coda.credits", 
"coda.options", "codamenu", "codamenu.anal", "codamenu.diags", 
"codamenu.diags.autocorr", "codamenu.diags.crosscorr", "codamenu.diags.gelman", 
"codamenu.diags.geweke", "codamenu.diags.heidel", "codamenu.diags.raftery", 
"codamenu.main", "codamenu.options", "codamenu.options.data", 
"codamenu.options.diag", "codamenu.options.gelman", "codamenu.options.geweke.bin", 
"codamenu.options.geweke.win", "codamenu.options.heidel", "codamenu.options.plot", 
"codamenu.options.plot.kernel", "codamenu.options.plot.ps", "codamenu.options.raftery", 
"codamenu.options.stats", "codamenu.output.header", "crosscorr", 
"crosscorr.plot", "densplot", "end.mcmc", "frequency.mcmc", "gelman.diag", 
"geweke.diag", "geweke.nse", "geweke.plot", "geweke.power", "heidel.diag", 
"is.mcmc", "mcmc", "multi.menu", "nchain", "niter", "nvar", "plot.mcmc", 
"print.coda.options", "print.gelman.diag", "print.geweke.diag", 
"print.heidel.diag", "print.mcmc", "print.raftery.diag", "print.summary.mcmc", 
"raftery.diag", "read.and.check", "read.bugs", "read.bugs.interactive", 
"set.mfrow", "spec.pgram", "start.mcmc", "summary.mcmc", "test.bandwidth", 
"thin", "thin.mcmc", "tidy.up", "time.mcmc", "traceplot", "varnames", 
"window.mcmc")
"tidy.up" <-
function () 
{
    # 
    # tidy.up -- gives option to save input files in S format; then deletes all  
    #	     S-plus objects created during current CODA session, and 
    #	     closes all graphics windows 
    # 
    # Author: Nicky Best 
    # 
    cat("\nQuitting CODA....\n")
    if (exists("coda.dat", where = 1) && !coda.options("data.saved")) {
        cat("\nDo you want to save the BUGS output as an R object file(y/N) ?\n")
        ans <- read.and.check(what = character(), default = "n")
        if (ans == "Y" | ans == "y") {
            cat("Enter name you want to call this object file:\n")
            fname <- scan(what = character(), nmax = 1, strip.white = TRUE)
            assign(fname, coda.dat, envir = sys.frame(0))
        }
    }
    coda.objects <- c("coda.dat", "work.dat")
    if (is.R()) 
        for (i in coda.objects) {
            if (exists(i)) 
                rm(list = i, inherits = TRUE)
        }
    else {
        for (i in coda.objects) {
            if (exists(i)) 
                remove(i, where = 1)
        }
    }
    graphics.off()
}
"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()
}
"codamenu.devices" <-
function () 
{
    devices <- c("X11", "motif", "openlook", "win.graph")
    have.device <- vector("logical", length(devices))
    for (i in 1:length(devices)) {
        have.device[i] <- exists(devices[i])
    }
    devices <- devices[have.device]
    if (length(devices) == 0) 
        stop("Can't find any graphics devices")
    else {
        if (length(devices) == 1) 
            do.call(devices[1], list())
        else repeat {
            pick <- menu(choices = devices, title = "choose graphics device")
            if (pick != 0) {
                do.call(devices[pick], list())
                break
            }
        }
    }
    return(dev.cur())
}
"gelman.diag" <-
function (x, confidence = 0.95, transform = FALSE) 
{
    #
    # Gelman and Rubin's code
    #
    # Adapted to work on mcmc objects. Now you can analyse
    # several variables at once.
    #
    #
    # 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)*(var(s2,xdot^2) - 2*muhat*var(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
    #
    x <- as.mcmc.list(x)
    if (nchain(x) == 1) 
        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)
    confshrink <- matrix(nrow = nvar(x), ncol = 2, dimnames = list(varnames(x), 
        c("Point est.", paste(50 * (1 + confidence), "% quantile", 
            sep = ""))))
    z <- matrix(NA, nrow = niter(x), ncol = nchain(x))
    for (i in 1:nvar(x)) {
        for (j in 1:nchain(x)) z[, j] <- as.matrix(x[[j]])[, 
            i, drop = TRUE]
        if (transform) 
            if (min(z) > 0) 
                z <- if (max(z) < 1) 
                  log(z/(1 - z))
                else log(z)
        s2 <- apply(z, 2, var)
        W <- mean(s2)
        zbar <- apply(z, 2, mean)
        B <- Niter * var(zbar)
        sig2hat <- ((Niter - 1) * W + B)/Niter
        muhat <- mean(zbar)
        varW <- var(s2)/Nchain
        varB <- (2 * B^2)/(Nchain - 1)
        #
        covWB <- (Niter/Nchain) * (var(s2, zbar^2) - 2 * muhat * 
            var(s2, zbar))
        # 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
        #
        # 
        # 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/(Niter * Nchain)
        varpostvar <- ((Niter - 1)^2 * varW + (1 + 1/Nchain)^2 * 
            varB + 2 * (Niter - 1) * (1 + 1/Nchain) * covWB)/Niter^2
        post.df <- (2 * postvar^2)/varpostvar
        #
        df.adj <- (post.df + 3)/(post.df + 1)
        # Estimated potential scale reduction (that would be achieved
        # by continuing simulations forever) has two components: an
        # estimate and an approx upper bound.
        #
        # confshrink = sqrt(postvar/W), 
        #     multiplied by sqrt((df+3)/(df+1)) as an adjustment for the
        #     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.)
        #
        varlo.df <- (2 * W^2)/varW
        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, Nchain - 
            1, varlo.df) * R2.random
        confshrink[i, 1] <- sqrt(df.adj * R2.estimate)
        confshrink[i, 2] <- sqrt(df.adj * R2.upper)
    }
    out <- list(confshrink = confshrink)
    class(out) <- "gelman.diag"
    out
}
"print.gelman.diag" <-
function (x, digits = 3, ...) 
{
    cat("Shrink factors:\n\n")
    print.default(x$confshrink, 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)$confshrink
    }
    all.na <- apply(is.na(shrink[, , 1, drop = FALSE]), 2, all)
    if (any(all.na)) {
        cat("\n******* Error: *******\nCannot compute Gelman & Rubin's diagnostic for any chain \nsegments for variables", 
            varnames(x)[all.na], "\nThis indicates convergence failure ==> Run chains for more iterations\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.vom <- y.mean <- vector("list", 2)
    for (i in 1:2) {
        y <- window(x, start = xstart[i], end = xend[i])
        spans <- min(sqrt(niter(y))/0.3 + 1, niter(y) - 1)
        spec0 <- spec.pgram(y, spans = spans, demean = TRUE, 
            detrend = FALSE, plot = FALSE)$spec[1, ]
        y.vom[[i]] <- 10^(spec0/10)/niter(y)
        y.mean[[i]] <- apply(as.matrix(y), 2, mean)
    }
    z <- (y.mean[[1]] - y.mean[[2]])/sqrt(y.vom[[1]] + y.vom[[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, bin.width = 10, max.bins = 50, 
    coverage = 0.95, auto.layout = TRUE, ask = TRUE, ...) 
{
    x <- as.mcmc.list(x)
    nbin <- min(floor((niter(x) - 50)/bin.width), max.bins)
    binw <- floor((niter(x) - 50)/nbin)
    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) - 49 * thin(x), 
        by = binw * thin(x))
    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
    }
    for (k in 1:nchain(x)) for (j in 1:nvar(x)) {
        climit <- qnorm((1 + coverage)/2)
        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(ylimit, -ylimit), 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))
}
"geweke.power" <-
function (x) 
{
    # 
    # geweke.power 
    # 
    # spans parm for smoothing periodogram 
    a <- length(x)
    nspans <- sqrt(a)/0.3 + 1
    if (nspans >= a) {
        # spans is longer than time series 
        nspans <- a - 1
    }
    pgram1 <- spec.pgram(x, spans = nspans, demean = TRUE, detrend = FALSE, 
        plot = FALSE)
    #changed 03/20/94        
    # power <- 2 * pi * (10^(pgram1$spec[1]/10))     
    power <- (10^(pgram1$spec[1]/10))
    # spectral density converted from decibels       
    nse <- sqrt(power/a)
    power
}
"print.geweke.diag" <-
function (x, digits = min(4, .Options$digits), ...) 
{
    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)
}
"geweke.nse" <-
function (x) 
{
    # 
    # geweke.nse 
    # 
    # Author: Kate Cowles 
    # 
    # spans parm for smoothing periodogram 
    a <- length(x)
    #  
    nspans <- sqrt(a)/0.3 + 1
    if (nspans >= a) {
        # spans is longer than time series 
        nspans <- a - 1
    }
    pgram1 <- spec.pgram(x, spans = nspans, demean = TRUE, detrend = FALSE, 
        plot = FALSE)
    # changed 03/20/94 
    # power <- 2 * pi * (10^(pgram1$spec[1]/10))     
    power <- (10^(pgram1$spec[1]/10))
    # spectral density converted from decibels       
    nse <- sqrt(power/a)
    nse
}
"heidel.diag" <-
function (x, eps = 0.1) 
{
    if (is.mcmc.list(x)) 
        return(lapply(x, heidel.diag, eps))
    x <- as.mcmc(x)
    HW.mat0 <- matrix(0, ncol = 7, nrow = nvar(x))
    dimnames(HW.mat0) <- list(varnames(x), c("stest", "keep", 
        "discard", "C-vonM", "htest", "mean", "halfwidth"))
    HW.mat <- HW.mat0
    for (j in 1:nvar(x)) {
        Y <- as.matrix(x)[, j, drop = TRUE]
        n1 <- length(Y)
        n <- length(Y)
        S0 <- geweke.power(Y[(n/2 + 1):n])
        passed <- FALSE
        while (n >= n1/2 && !passed) {
            T1 <- cumsum(Y)
            ybar <- mean(Y)
            B <- T1 - ybar * (1:n)
            Bsq <- (B * B)/(n * S0)
            I <- (2 * sum(Bsq[seq(2, n - 2, by = 2)]) + 4 * sum(Bsq[seq(1, 
                n - 1, by = 2)]) + Bsq[n])/(3 * n)
            passed <- !is.na(I) & I < 0.46
            if (!passed) {
                Y <- Y[(n1/10 + 1):n]
                n <- length(Y)
            }
        }
        S0ci <- geweke.power(Y)
        halfwidth <- 1.96 * sqrt(S0ci/n)
        passed2 <- (!is.na(halfwidth) & abs(halfwidth/ybar) <= 
            eps)
        if (is.na(I) | is.na(halfwidth) | !passed) {
            n <- NA
            nd <- NA
            passed2 <- NA
            ybar <- NA
            halfwidth <- NA
        }
        else {
            nd <- length(as.matrix(x)[, j, drop = TRUE]) - n
        }
        HW.mat[j, ] <- c(passed, n * thin(x), nd * thin(x), I, 
            passed2, ybar, halfwidth)
    }
    class(HW.mat) <- "heidel.diag"
    return(HW.mat)
}
"print.heidel.diag" <-
function (x, digits = 3, ...) 
{
    HW.title <- matrix(c("Stationarity", "test", "# of iters.", 
        "to keep", "# of iters.", "to discard", "C-vonM", "stat.", 
        "Halfwidth", "test", "Mean", "", "Halfwidth", ""), nrow = 2)
    y <- matrix("", nrow = nrow(x), ncol = 7)
    for (j in 1:ncol(y)) {
        y[, j] <- format(x[, j], digits = digits)
    }
    y[, c(1, 5)] <- ifelse(x[, c(1, 5)], "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("", 7))
    print.default(y[, 1:4], quote = FALSE, ...)
    print.default(y[, 5:7], quote = FALSE, ...)
    invisible(x)
}
"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)) 
        NCOL(x)
    else if (is.mcmc.list(x)) 
        NCOL(x[[1]])
    else NULL
}
"niter" <-
function (x) 
{
    if (is.mcmc(x)) 
        NROW(x)
    else if (is.mcmc.list(x)) 
        NROW(x[[1]])
    else NULL
}
"[.mcmc" <-
function (x, i, j, drop = missing(i)) 
{
    y <- NextMethod("[")
    if (length(y) == 0 || is.null(y)) 
        return(y)
    if (missing(i)) 
        y <- mcmc(y, start = start(x), thin = thin(x))
    else {
        xtimes <- time(x)
        ytimes <- time(x)[i]
        delta <- unique(ytimes[-1] - ytimes[-length(ytimes)])
        if (length(delta) != 1 || delta <= 0) {
            if (!drop) 
                warning("Not returning an mcmc object")
            attr(y, "mcpar") <- NULL
            class(y) <- NULL
        }
        else {
            #Coerce to vector to avoid annoying warnings from
            #"[.ts"
            start <- as.vector(ytimes)[1]
            end <- as.vector(ytimes)[length(ytimes)]
            y <- mcmc(y, start = start, end = end, thin = delta)
        }
    }
    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)
    if (nchain(x) > 1) 
        stop("Can't coerce to time series")
    else y <- ts(x, start = start(x), end = end(x), deltat = thin(x))
    attr(y, "mcpar") <- NULL
    return(y)
}
"start.mcmc" <-
function (x) 
{
    attr(as.mcmc(x), "mcpar")[1]
}
"end.mcmc" <-
function (x) 
{
    attr(as.mcmc(x), "mcpar")[2]
}
"frequency.mcmc" <-
function (x) 
{
    1/attr(as.mcmc(x), "mcpar")[3]
}
"thin.mcmc" <-
function (x) 
{
    attr(as.mcmc(x), "mcpar")[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) 
{
    niter <- NROW(data)
    nvar <- NCOL(data)
    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, ...) 
{
    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)
}
"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, sepplot = FALSE, one.page = FALSE)
        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))
    if (is.matrix(x)) {
        xmean <- apply(x, 2, mean)
        xvar <- apply(x, 2, var)
        xnse <- apply(x, 2, geweke.nse)
        varquant <- t(apply(x, 2, quantile, quantiles))
    }
    else {
        xmean <- mean(x, na.rm = TRUE)
        xvar <- var(x, na.rm = TRUE)
        xnse <- geweke.nse(x)
        varquant <- quantile(x, quantiles)
    }
    varstats[, 1] <- xmean
    varstats[, 2] <- sqrt(xvar)
    varstats[, 3] <- sqrt(xvar/niter(x))
    varstats[, 4] <- xnse
    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)
}
"as.matrix.mcmc" <-
function (x, iters = FALSE) 
{
    #as.matrix.mcmc
    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:NROW(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]
    if (is.matrix(x)) 
        return(x[use, , drop = FALSE])
    else return(x[use])
}
"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")
}
"[.mcmc.list" <-
function (x, i, j, drop = TRUE) 
{
    if (nargs() < 3 + !missing(drop)) {
        y <- NextMethod("[")
        if (is.list(y)) 
            y <- mcmc.list(y)
    }
    else {
        y <- vector("list", length(x))
        names(y) <- names(x)
        for (k in 1:length(y)) {
            y[[k]] <- if (missing(i) && missing(j)) 
                x[[k]]
            else if (missing(i)) 
                as.matrix(x[[k]])[, j, drop = drop]
            else if (missing(j)) 
                as.matrix(x[[k]])[i, , drop = drop]
            else as.matrix(x[[k]])[i, j, drop = drop]
        }
        if (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, ...) 
{
    oldpar <- NULL
    on.exit(par(oldpar))
    if (auto.layout) {
        mfrow <- set.mfrow(Nchains = nchain(x), Nparms = nvar(x), 
            nplots = trace + density, sepplot = FALSE, one.page = FALSE)
        oldpar <- par(mfrow = mfrow)
    }
    oldpar <- c(oldpar, par(ask = TRUE))
    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))
    xnse <- matrix(nrow = nchain(x), ncol = nvar(x))
    if (is.matrix(x[[1]])) {
        for (i in 1:nchain(x)) xnse[i, ] <- apply(x[[i]], 2, 
            geweke.nse)
        xlong <- do.call("rbind", x)
    }
    else {
        for (i in 1:nchain(x)) xnse[i, ] <- geweke.nse(x[[i]])
        xlong <- as.matrix(x)
    }
    xnse <- sqrt(apply(xnse^2, 2, mean))
    xmean <- apply(xlong, 2, mean)
    xvar <- apply(xlong, 2, var)
    varquant <- t(apply(xlong, 2, quantile, quantiles))
    varstats[, 1] <- xmean
    varstats[, 2] <- sqrt(xvar)
    varstats[, 3] <- sqrt(xvar/niter(x))
    varstats[, 4] <- xnse
    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, chains = FALSE, iters = FALSE) 
{
    #as.matrix.mcmc.list
    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: 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)
"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 = "", ...) 
{
    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]
            }
            plot(dens, ylab = "", main = main, type = "l", , 
                ylim = c(0, max(dens$y)), ...)
            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) 
{
    #Based on readdat by Karen Vines 
    #Index object not required  
    #We don't remove missing values - each row of the output should 
    #contain at least one non-missing value. 
    #We return an mcmc object, if possible 
    # 
    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) {
        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]]
        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])
        }
    }
}
"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)
}
"thin" <-
function (x, ...) 
UseMethod("thin")
"acf" <-
function (x, lag.max = NULL, plot = FALSE, type = "correlation") 
{
    if (plot) 
        warning(" acf plot not yet supported.")
    if (0 == charmatch(type, c("covariance", "correlation", "partial"), 
        nomatch = 0)) 
        stop("type not allowed in acf")
    if (!is.array(x)) 
        x <- matrix(x, length(x), 1)
    series <- deparse(substitute(x))
    x.freq <- frequency(as.ts(x))
    attr(x, "tsp") <- NULL
    attr(x, "class") <- NULL
    x <- as.matrix(x)
    sampleT <- nrow(x)
    #  or ? lag.max <- floor(10 * log10(sampleT))
    if (is.null(lag.max)) 
        lag.max <- floor(10 * (log10(sampleT) - log10(ncol(x))))
    lag.max <- min(lag.max, sampleT - 1)
    acf <- lag <- array(NA, c(lag.max + 1, ncol(x), ncol(x)))
    xb <- sweep(x, 2, apply(x, 2, mean))
    for (i in 0:lag.max) {
        Om <- (t(xb[(i + 1):sampleT, , drop = FALSE]) %*% xb[1:(sampleT - 
            i), , drop = FALSE])/sampleT
        if (type == "correlation") {
            # nrow above for univariate case
            if (i == 0) 
                Om0 <- diag(1/sqrt(diag(Om)), nrow = nrow(Om))
            Om <- Om0 %*% Om %*% Om0
        }
        acf[i + 1, , ] <- Om
        for (j in 1:ncol(x)) for (k in 1:ncol(x)) lag[i + 1, 
            j, k] <- ifelse(j > k, -i, i)
    }
    if (type == "partial") {
        warning("acf type partial not yet supported. 0 value being returned")
        acf <- array(0, dim(acf))
    }
    list(acf = acf, type = type, n.used = sampleT, lag = lag, 
        series = series)
}
"spec.pgram" <-
function (x, spans = 1, taper = 0.1, demean = FALSE, detrend = TRUE, 
    pad = FALSE, plot = FALSE) 
{
    x <- as.matrix(x)
    N <- nrow(x)
    if (detrend) {
        t <- 1:N
        for (i in 1:ncol(x)) x[, i] <- residuals(lm(x[, i] ~ 
            t))
    }
    else if (demean) {
        x <- sweep(x, 2, apply(x, 2, mean))
    }
    if (taper > 0.5 || taper < 0) 
        stop("taper must be between 0 and 0.5")
    else if (taper > 0) {
        w <- rep(1, N)
        n <- max(round(N * taper), 1)
        w[1:n] <- sin(((1:n - 0.5) * pi)/(2 * n))^2
        w[N:(N - n + 1)] <- w[1:n]
        x <- x * w
    }
    if (pad) 
        x <- rbind(x, matrix(0, nrow = (nextn(N) - N), ncol = ncol(x)))
    Nspec <- ceiling(N/2) + 1
    #
    # Should use mvfft here but there is a fatal bug!!!
    # 22.4.99 - MTP
    #
    spec <- matrix(NA, nrow = nrow(x), ncol = ncol(x))
    for (i in 1:ncol(x)) spec[, i] <- (Mod(fft(x[, i]))^2)/N
    filter.list <- vector("list", length(spans))
    for (i in 1:length(spans)) {
        m <- floor(spans[i]/2)
        filter.list[[i]] <- if (m > 0) 
            c(0.5, rep(1, 2 * m - 1), 0.5)/(2 * m)
        else 1
    }
    filter <- filter.list[[1]]
    if (length(spans) > 1) 
        for (i in 2:length(spans)) {
            filter <- convolve.open(filter.list[[i]], filter)
        }
    if (length(filter) > 1) {
        ndiff <- nrow(spec) - length(filter)
        m <- floor(length(filter)/2)
        if (ndiff < 0) 
            stop("filter too long!")
        else for (i in 1:ncol(spec)) {
            spec[, i] <- convolve(spec[, i], c(filter[(m + 1):(2 * 
                m + 1)], rep(0, ndiff), filter[1:m]))
        }
    }
    spec <- spec[1:(1 + ceiling(N/2)), , drop = FALSE]
    spec <- 10 * log10(spec)
    freq <- seq(from = 0, to = 0.5, length = Nspec)
    return(spec = spec, freq = freq)
}
"change.tfoption" <-
function (string, option) 
{
    current.value <- coda.options(option)
    if (!is.logical(current.value)) 
        stop("Invalid option: must take logical values")
    wrd <- ifelse(current.value, " (Y/n)?\n:", " (y/N)?\n:")
    cat("\n", string, wrd, sep = "")
    ans <- readline()
    changeit <- (current.value && (ans == "N" | ans == "n")) || 
        (!current.value && (ans == "Y" | ans == "y"))
    if (changeit) {
        arg <- list(!current.value)
        names(arg) <- option
        coda.options(arg)
    }
    return()
}
"coda.options" <-
function (...) 
{
    #Set and display coda options
    #Works like options() and par(), ie
    #MTP start
    #Displays current values if no arguments are given
    #Displays current values of selected arguments if arguments are names
    #Resets values if argument is a named list
    #Like par it returns a value (rather than a list) if asked to
    #display one argument 
    #In addition
    #Resets to defaults if the "default=TRUE" argument is given.
    #TODO put in value checking. Currently only checks mode
    #MTP finish
    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)
}
"set.mfrow" <-
function (Nchains = 1, Nparms = 1, nplots = 1, sepplot = FALSE, 
    one.page = 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) 
    # If more plots are required than will fit on one page, the 
    # browser function is used to cycle round multiple pages of plots 
    #  
    if (one.page) 
        Nparms <- 1
    if (sepplot && Nchains > 1) {
        if (nplots == 1) {
            mrows <- ifelse((Nparms == 1 && Nchains == 2), 1, 
                ifelse((Nparms == 2 && Nchains == 2) || (Nparms == 
                  1 && any(Nchains == c(3, 4))) || (any(Nparms == 
                  c(2, 4)) && Nchains == 3), 2, ifelse((Nparms == 
                  4 && Nchains == 2) || (Nchains == 4 && Nparms > 
                  1), 4, 3)))
            mcols <- ifelse((Nchains == 3 && any(Nparms == c(2, 
                4))) || ((Nparms == 3 || Nparms >= 5) && Nchains == 
                3) || any(Nchains == c(7:9)) || Nchains >= 13, 
                3, 2)
        }
        else {
            mrows <- ifelse(Nchains <= 4, Nchains, ifelse(any(Nchains == 
                c(5, 6, 10:12)), 3, 4))
            mcols <- 2
        }
    }
    else {
        if (nplots == 1) {
            mrows <- ifelse(Nparms <= 2, 1, ifelse(Nparms <= 
                4, 2, 3))
            mcols <- ifelse(Nparms <= 9, Nparms%/%mrows + ifelse(Nparms%%mrows == 
                0, 0, 1), ifelse(any(Nparms == c(10:12)), 2, 
                3))
        }
        else {
            mrows <- ifelse(Nparms <= 4, Nparms, ifelse(any(Nparms == 
                c(5, 6, 10:12)), 3, 4))
            mcols <- 2
        }
    }
    return(mfrow = c(mrows, mcols))
}
"test.bandwidth" <-
function () 
{
    # 
    # test.bandwidth -- Attempts to evaluate the bandwidth function specified 
    #                   by the user. If a single numeric value results, then 
    #                   the function is passed, else an error is returned or 
    #                   the function is dumped  
    # 
    # Author: Nicky Best 
    # 
    out <- FALSE
    y <- 1:10
    err <- coda.options("bandwidth")(y)
    if (is.numeric(err) & length(err) == 1) {
        out <- TRUE
    }
    else {
        cat("Error: this function is not appropriate for calculating kernel bandwidths!\n\n")
        out <- FALSE
    }
    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)
}
"make.coda.package" <-
function () 
{
    if (search()[2] != "package:coda") 
        stop("CODA package must be loaded in position 2")
    mcmc.obs <- c("[.mcmc", "as.mcmc", "as.mcmc.default", "as.ts.mcmc", 
        "start.mcmc", "end.mcmc", "frequency.mcmc", "thin.mcmc", 
        "is.mcmc", "mcmc", "print.mcmc", "plot.mcmc", "summary.mcmc", 
        "print.summary.mcmc", "as.matrix.mcmc", "time.mcmc", 
        "window.mcmc", "mcpar", "upgrade.mcmc")
    thin.obs <- c("thin")
    mcmclist.obs <- c("[.mcmc.list", "mcmc.list", "start.mcmc.list", 
        "end.mcmc.list", "thin.mcmc.list", "is.mcmc.list", "plot.mcmc.list", 
        "summary.mcmc.list", "as.matrix.mcmc.list", "as.mcmc.mcmc.list", 
        "time.mcmc.list", "window.mcmc.list", "as.mcmc.list", 
        "as.mcmc.list.default")
    mcextractor.obs <- c("chanames", "chanames<-", "varnames", 
        "varnames<-", "nchain", "nvar", "niter")
    gelman.obs <- c("gelman.diag", "print.gelman.diag", "gelman.plot", 
        "gelman.preplot")
    geweke.obs <- c("geweke.diag", "geweke.plot", "geweke.power", 
        "print.geweke.diag", "geweke.nse")
    heidel.obs <- c("heidel.diag", "print.heidel.diag")
    raftery.obs <- c("raftery.diag", "print.raftery.diag")
    ts.obs <- c("acf", "spec.pgram")
    util.obs <- c("change.tfoption", "coda.options", "multi.menu", 
        "set.mfrow", "test.bandwidth", "read.and.check", "make.coda.package", 
        ".Coda.Options.Default", "convolve.open")
    output.obs <- c("autocorr", "autocorr.plot", "crosscorr", 
        "crosscorr.plot", "densplot", "read.bugs", "traceplot")
    codamenu.obs <- c("coda.credits", "codamenu", "codamenu.anal", 
        "codamenu.diags", "codamenu.diags.autocorr", "codamenu.diags.crosscorr", 
        "codamenu.diags.heidel", "codamenu.diags.raftery", "codamenu.main", 
        "codamenu.diags.gelman", "codamenu.diags.geweke", "codamenu.options", 
        "codamenu.options.data", "codamenu.options.diag", "codamenu.options.gelman", 
        "codamenu.options.geweke.bin", "codamenu.options.geweke.win", 
        "codamenu.options.heidel", "codamenu.options.plot", "codamenu.options.plot.kernel", 
        "codamenu.options.plot.ps", "codamenu.options.raftery", 
        "codamenu.options.stats", "print.coda.options", "read.bugs.interactive", 
        "coda.objects", "tidy.up", "codamenu.ps", "codamenu.output.header", 
        "codamenu.devices")
    ob.list <- c("mcmc.obs", "thin.obs", "mcmclist.obs", "mcextractor.obs", 
        "gelman.obs", "geweke.obs", "heidel.obs", "ts.obs", "util.obs", 
        "output.obs", "raftery.obs", "codamenu.obs")
    all.obs <- character(0)
    for (i in 1:length(ob.list)) {
        all.obs <- c(all.obs, get(ob.list[i]))
    }
    if (length(unique(all.obs)) < length(all.obs)) {
        dup.obs <- paste(all.obs[duplicated(all.obs)], collapse = "\n")
        stop(paste("Duplicated objects in package list:\n", dup.obs))
    }
    lib.obs <- unique(c(objects(pos = 1, all.names = TRUE), objects(pos = 2, 
        all.names = TRUE)))
    x <- c(lib.obs, all.obs)
    x <- x[!duplicated(x)]
    x <- x[-(1:length(lib.obs))]
    if (length(x) > 0) {
        x <- paste(x, collapse = "\n")
        stop(paste("package objects not found:\n", x, sep = "\n"))
    }
    y <- c(all.obs, lib.obs)
    y <- y[!duplicated(y)]
    y <- y[-(1:length(all.obs))]
    if (length(y) > 0) {
        y <- paste(y, collapse = "\n")
        stop(paste("objects found not in package list:\n", y, 
            sep = "\n"))
    }
    for (i in 1:length(ob.list)) {
        root <- substring(ob.list[i], 1, nchar(ob.list[i]) - 
            4)
        filename <- paste(root, ".R", sep = "")
        dump(get(ob.list[i]), filename)
    }
    cat("DONE\n")
    invisible()
}
".Coda.Options.Default" <-
structure(list(trace = TRUE, densplot = TRUE, lowess = FALSE, 
    combine.plots = TRUE, onepage = FALSE, bandwidth = function (x) 
    {
        x <- x[!is.na(x)]
        1.06 * min(sd(x), IQR(x)/1.34) * length(x)^-0.2
    }, pos.parms = 0, pos.parmsmat = 0, prop.parms = 0, prop.parmsmat = 0, 
    batch.size = 25, 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, ps.plot = 1, 
    halfwidth = 0.1, user.layout = FALSE, mrows = 1, mcols = 1, 
    gr.bin = 10, geweke.bin = 10, gr.max = 50, geweke.max = 50, 
    data.saved = FALSE), .Names = c("trace", "densplot", "lowess", 
"combine.plots", "onepage", "bandwidth", "pos.parms", "pos.parmsmat", 
"prop.parms", "prop.parmsmat", "batch.size", "digits", "quantiles", 
"frac1", "frac2", "q", "r", "s", "combine.stats", "combine.corr", 
"ps.plot", "halfwidth", "user.layout", "mrows", "mcols", "gr.bin", 
"geweke.bin", "gr.max", "geweke.max", "data.saved"))
"convolve.open" <-
function (x, y, conj = TRUE) 
{
    nx <- length(x)
    ny <- length(y)
    n <- nx + ny - 1
    x <- c(rep(0, ny - 1), x)
    y <- c(y, rep(0, nx - 1))
    Re(fft(fft(x) * (if (conj) Conj(fft(y)) else fft(y)), inv = TRUE))/n
}
