The R Project SVN R-packages

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

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

"coda.options" <-
function (...) 
{
  ## Set and display coda options
  single <- FALSE
  copt <- if (exists("options", envir=coda.env, inherits=FALSE)) {
      get("options", envir=coda.env, inherits=FALSE)
  }
  else {
    .Coda.Options.Default
  }
  if (nargs() == 0) {
    return(copt)
  }
  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(copt))) 
      value[v] <- copt[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) 
      copt <- .Coda.Options.Default
    for (v in names(args)) if (any(v == names(copt))) {
      oldvalue[v] <- copt[v]
      if (is.null(args[[v]])) 
        copt[v] <- list(NULL)
      else if (mode(copt[[v]]) == mode(args[[v]])) 
        copt[v] <- args[v]
    }
    assign("options", copt, envir=coda.env)
    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")
    ans <- scan(what = character(), sep = ",", strip.white = TRUE, 
                nlines = 1, quiet = TRUE)
    if (length(ans) > 0) {
      out <- numeric(0)
      for (i in 1:length(ans)) {
        nc <- nchar(ans[i])
        wrd <- substring(ans[i], 1:nc, 1:nc)
        colons <- wrd == ":"
        err <- any(is.na(as.numeric(wrd[!colons]))) | 
        sum(colons) > 1 | colons[1] | colons[nc]
        if (err) {
          cat("Error: you have specified a non-numeric value!\n")
          break
        }
        else {
          out <- c(out, eval(parse(text = ans[i])))
          if (min(out) < ifelse(allow.zero, 0, 1) | max(out) > 
              length(choices) | (any(out == 0) & length(out) > 
                                 1)) {
            err <- TRUE
            cat("Error: you have specified variable number(s) out of range!\n")
            break
          }
        }
      }
      if (!err) 
        break
    }
  }
  return(out)
}

"read.and.check" <-
  function (message = "", what = numeric(), lower, upper, answer.in, default) 
{
  ## Read data from the command line and check that it satisfies 
  ## certain conditions.  The function will loop until it gets 
  ## and answer satisfying the conditions. This entails extensive 
  ## checking of the conditions to  make sure they are consistent 
  ## so we don't end up in an infinite loop. 

  have.lower <- !missing(lower)
  have.upper <- !missing(upper)
  have.ans.in <- !missing(answer.in)
  have.default <- !missing(default)
  if (have.lower | have.upper) {
    if (!is.numeric(what)) 
      stop("Can't have upper or lower limits with non numeric input")
    if (have.lower && !is.numeric(lower)) 
      stop("lower limit not numeric")
    if (have.upper && !is.numeric(upper)) 
      stop("upper limit not numeric")
    if ((have.upper & have.lower) && upper < lower) 
      stop("lower limit greater than upper limit")
  }
  if (have.ans.in) {
    if (mode(answer.in) != mode(what)) 
      stop("inconsistent values of what and answer.in")
    if (have.lower) 
      answer.in <- answer.in[answer.in >= lower]
    if (have.upper) 
      answer.in <- answer.in[answer.in <= upper]
    if (length(answer.in) == 0) 
      stop("No possible response matches conditions")
  }
  if (have.default) {
    if (mode(default) != mode(what)) 
      stop("inconsistent values of what and default")
    if (have.lower && default < lower) 
      stop("default value below lower limit")
    if (have.upper && default > upper) 
      stop("default value above upper limit")
    if (have.ans.in && !any(answer.in == default)) 
      stop("default value does not satisfy conditions")
  }
  err <- TRUE
  while (err) {
    if (nchar(message) > 0) {
      cat("\n", message, "\n", sep = "")
      if (have.default) 
        cat("(Default = ", default, ")\n", sep = "")
    }
    repeat {
      cat("1:")
      ans <- readline()
      if (length(ans) == 1 && nchar(ans) > 0) 
        break
      else if (have.default) {
        ans <- default
        break
      }
    }
    if (is.numeric(what)) {
      err1 <- TRUE
      ans <- as.numeric(ans)
      message <- "You must enter a number"
      if (is.na(ans)) 
        NULL
      else if ((have.lower & have.upper) && (ans < lower | 
                                             ans > upper)) 
        message <- paste(message, "between", lower, "and", 
                         upper)
      else if (have.lower && ans < lower) 
        message <- paste(message, ">=", lower)
      else if (have.upper && ans > upper) 
        message <- paste(message, "<=", upper)
      else err1 <- FALSE
    }
    else err1 <- FALSE
    if (have.ans.in) {
      if (!is.na(ans) && !any(ans == answer.in)) {
        message <- paste("You must enter one of the following:", 
                         paste(answer.in, collapse = ","))
        err2 <- TRUE
      }
      else err2 <- FALSE
    }
    else err2 <- FALSE
    err <- err1 | err2
  }
  return(ans)
}

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

coda.env <- new.env()