R/Correlation.R

In lessR: Less Code with More Comprehensive Results

Correlation <-
function(x, y, data=d, # x can be a data frame, or variables in a data frame
         miss=c("pairwise", "listwise", "everything"),
         show=c("cor", "missing"),
         fill_low=NULL, fill_hi=NULL,
         brief=FALSE, digits_d=NULL, heat_map=TRUE,
         main=NULL, bottom=3, right=3, quiet=getOption("quiet"),
         pdf_file=NULL, width=5, height=5, ...) {


  # a dot in a parameter name to an underscore
  dots <- list(...)
  if (length(dots) > 0) {
    for (i in 1:length(dots)) {
      if (length(grep(".", names(dots)[i], fixed=TRUE)) > 0) {
        nm <- gsub(".", "_", names(dots)[i], fixed=TRUE)
        assign(nm, dots[[i]])
      }
    }
  }

  miss <- match.arg(miss)
  show <- match.arg(show)

  # replace older names with current name
  if (length(dots) > 0) {
    for (i in 1:length(dots)) {
      if (names(dots)[i] == "graphics")  heat_map <- dots[[i]]
      if (names(dots)[i] == "show_n") {
      cat("\n"); stop(call.=FALSE, "\n------\n",
        "New parameter  show  replaces  show_n.\n",
        "Obtain pairwise missing value counts with  show=\"missing\", \n\n")
    }
    }
  }
  
  x.name <- deparse(substitute(x))
  options(xname = x.name)

  is.df <- FALSE  # is data frame
  df.ok <- FALSE  # data frame mode successfully established

  if (missing(y)) {  # is a data frame or a list of variables
    is.df <- TRUE
    if (missing(x)) {
      x.name <- "$"  # in case x is missing, i.e., data frame d
      if (missing(data)) data <- eval(substitute(d))
      df.ok <- TRUE
    }
    else if ( (!grepl(":", x.name) && !grepl(",", x.name)) ) {
      # x must name a data frame in the global environment
      if (is.data.frame(x) && exists(x.name, where=.GlobalEnv)) {
        data <- x  # specified data name
        df.ok <- TRUE
      }
    }

    else {  # two variables
      all.vars <- as.list(seq_along(data))
      names(all.vars) <- names(data)
      # proceed here only if x.name is in data or is a list
      if ((x.name %in% names(all.vars)) || grepl(":", x.name)
            || grepl(",", x.name) ) {
        x.col <- eval(substitute(x), envir=all.vars, enclos=parent.frame())

        # if x is a variable list, create subset data frame
        if (length(x.col) > 1) {
          data <- data[, x.col]
          is.df <- TRUE
          df.ok <- TRUE
        }
      }
    }

    # x given but is not a data frame or variable list: too little
    if (!df.ok) {
      cat("\n"); stop(call.=FALSE, "\n------\n",
        x.name, " is not the name of a data frame, and no second\n",
        "variable was provided for a correlation.\n\n",
        "Correlate two variables with:  Correlation(x, y)\n",
        "Correlate a data frame with:  Correlation(mydata)\n\n")
    }
  }  # end missing y


  if (!is.df) {  # pairwise

    dname <- deparse(substitute(data))
    options(dname = dname)

    # get conditions and check for data existing
    is.frml <- ifelse (grepl("~", x.name), TRUE, FALSE)
    in.global <- df.or.global(x.name, dname, role="x",
                              fun.name="Correlation")

    # see if the variable exists in data frame, if x not in global env
    if (!in.global) .xcheck(x.name, dname, names(data))

    if (in.global) x.call <- x else x.call <- eval(substitute(data$x))

    # evaluate y
    # get actual variable name before potential call of data$x
    y.name <- deparse(substitute(y))
    options(yname = y.name)

    # get conditions and check for data existing
    in.global <- df.or.global(y.name, dname, role="y",
                              fun.name="Correlation")

    # see if var exists in data frame, if not in global env
    if (!in.global) .xcheck(y.name, dname, names(data))

    if (in.global) y.call <- y
    else y.call <- eval(substitute(data$y))

  }  # x not data frame


  if (is.df) { 
    stuff <- .cr.data.frame(data, miss, show, digits_d,
                   heat_map, fill_low, fill_hi, main, bottom, right, quiet, 
                   pdf_file, width, height, ...) 

    txmis <- stuff$txm

    class(txmis) <- "out"

    if (show == "cor") {
      if (!quiet)
        return(stuff$R)
      else
        invisible(stuff$R)
      }
    else if (show == "missing") return(txmis)
  }

  else {  # pairwise
  
    if (!is.null(pdf_file)) {
      cat("\n");   warning(call.=FALSE, "\n","------\n",
        " To produce a scatter plot, pass a vector to:  Plot\n",
        " No heat map produced here and yet a pdf file is specified.\n\n",
         sep="")
     }

    stuff <- .cr.main(x.call, y.call, brief, ...) 
    txbck <- stuff$txb
    txdsc <- stuff$txd
    txinf <- stuff$txi

    class(txbck) <- "out"
    class(txdsc) <- "out"
    class(txinf) <- "out"

    output <- list(out_background=txbck, out_describe=txdsc,
      out_inference=txinf,
      r=stuff$r, tvalue=stuff$tvalue, df=stuff$df, pvalue=stuff$pvalue,
      lb=stuff$lb, ub=stuff$ub)

    class(output) <- "out_all"
    return(output)
  }  # end pairwise

}