R/comparedf.R

In arsenal: An Arsenal of 'R' Functions for Large-Scale Statistical Summaries

# original function mockup done by Andy Hanson; re-envisioned by EPH starting 3/20/17

#' Compare two data.frames and report differences
#'
#' Compare two data.frames and report any differences between them,
#'  much like SAS's \code{PROC COMPARE} procedure.
#'
#' @param x,y A data.frame to compare
#' @param by,by.x,by.y Which variables are IDs to merge the two data.frames?
#'   If set to \code{"row.names"}, merging will occur over the row.names.
#'   If set to \code{NULL} (default), merging will occur row-by-row.
#' @param control A list of control parameters from \code{\link{comparedf.control}}.
#' @param ... Other arguments, passed to \code{\link{comparedf.control}} when appropriate.
#' @examples
#'
#' df1 <- data.frame(id = paste0("person", 1:3), a = c("a", "b", "c"),
#'                   b = c(1, 3, 4), c = c("f", "e", "d"),
#'                   row.names = paste0("rn", 1:3), stringsAsFactors = FALSE)
#' df2 <- data.frame(id = paste0("person", 3:1), a = c("c", "b", "a"),
#'                   b = c(1, 3, 4), d = paste0("rn", 1:3),
#'                   row.names = paste0("rn", c(1,3,2)), stringsAsFactors = FALSE)
#' summary(comparedf(df1, df2))
#' summary(comparedf(df1, df2, by = "id"))
#' summary(comparedf(df1, df2, by = "row.names"))
#' @author Ethan Heinzen, adapted from code from Andrew Hanson
#' @seealso \code{\link{summary.comparedf}}, \code{\link{comparedf.control}},
#'   \code{\link{diffs}}, \code{\link{n.diffs}}, \code{\link{n.diff.obs}}
#' @name comparedf
NULL
#> NULL

#' @rdname comparedf
#' @export
comparedf <- function(x, y, by = NULL, by.x = by, by.y = by, control = NULL, ...) {

  control <- c(list(...), control)
  control <- do.call("comparedf.control", control[!duplicated(names(control))])

  xname <- paste0(deparse(substitute(x)), collapse = "")
  yname <- paste0(deparse(substitute(y)), collapse = "")

  if(!is.data.frame(x) || !is.data.frame(y))
  {
    stop("Both 'x' and 'y' must be data.frames")
  }

  if(any(c("..row.x..", "..row.y..", "..row.names..") %in% c(colnames(x), colnames(y))))
  {
    stop("'..row.x..', '..row.y..', and '..row.names..' are reserved colnames in this function.")
  }

  if(is.null(by) && is.null(by.x) && is.null(by.y))
  {
    # user didn't supply any by-variables, so we'll merge by row
    by.x <- by.y <- "row.names"
    byrow <- TRUE
  } else if(is.null(by.x) || is.null(by.y))
  {
    stop("Either 'by' or both of 'by.x' and 'by.y' must be specified")
  } else byrow <- FALSE

  if(any(by.x %nin% c("row.names", colnames(x))) || any(by.y %nin% c("row.names", colnames(y))))
  {
    stop("One or more of 'by.x' doesn't match colnames(x) or 'by.y' doesn't match colnames(y).")
  }

  #### data frame summary ####

  frame.summary <- data.frame(
    version = c("x", "y"),
    arg = c(xname, yname),
    ncol = c(ncol(x), ncol(y)),
    nrow = c(nrow(x), nrow(y)), stringsAsFactors = FALSE
  )
  tmp.attrs <- list(attributes(x), attributes(y))

  if("row.names" %in% by.x)
  {
    x[["..row.names.."]] <- if(byrow) seq_len(nrow(x)) else row.names(x)
    by.x[by.x == "row.names"] <- "..row.names.."
  }
  if("row.names" %in% by.y)
  {
    y[["..row.names.."]] <- if(byrow) seq_len(nrow(y)) else row.names(y)
    by.y[by.y == "row.names"] <- "..row.names.."
  }
  frame.summary$by <- set_attr(list(by.x, by.y), "byrow", byrow)
  frame.summary$attrs <- tmp.attrs

  #### tweak the column names ####

  tcn <- tweakcolnames(by.x, by.y, colnames(x), colnames(y), control)
  rm(by.x, by.y) # just to make sure we don't try to use those anymore
  by <- tcn$by

  #### now merge the things together ####

  together <- merge(cbind(stats::setNames(x, tcn$cn.x), ..row.x.. = seq_len(nrow(x))),
                    cbind(stats::setNames(y, tcn$cn.y), ..row.y.. = seq_len(nrow(y))), by = by, all = TRUE)

  both <- together[!is.na(together[["..row.x.."]]) & !is.na(together[["..row.y.."]]), , drop = FALSE]

  #### get the unshared observations ####

  getunique <- function(whch, whch2, by. = by)
  {
    tmp <- together[is.na(together[[whch2]]), c(by., whch), drop = FALSE]
    colnames(tmp)[colnames(tmp) == whch] <- "observation"
    tmp
  }

  frame.summary$unique <- list(getunique("..row.x..", "..row.y.."), getunique("..row.y..", "..row.x.."))
  frame.summary$n.shared <- rep(nrow(both), times = 2)

  #### Make the main object in this function ####

  mkdf <- function(df, cn.new)
  {
    df2 <- data.frame(tmp = cn.new, var = colnames(df), pos = seq_along(df), stringsAsFactors = FALSE)
    df2$class <- unname(lapply(df, class))
    df2
  }

  vars.summary <- merge(mkdf(x, tcn$cn.x), mkdf(y, tcn$cn.y), by = "tmp", all = TRUE)
  ord <- order(is.na(vars.summary$var.x), is.na(vars.summary$var.y), vars.summary$pos.x, vars.summary$pos.y, na.last = TRUE)
  vars.summary <- vars.summary[ord, , drop = FALSE]
  row.names(vars.summary) <- NULL

  vars.summary$class.x <- lapply(vars.summary$class.x, cleanup.null.na)
  vars.summary$class.y <- lapply(vars.summary$class.y, cleanup.null.na)

  vars.summary$values <- lapply(seq_len(nrow(vars.summary)), compare_values, v = vars.summary, df = both, byvars = by, contr = control)
  vars.summary$attrs <- lapply(seq_len(nrow(vars.summary)), compare_attrs, v = vars.summary, x_ = x, y_ = y)
  vars.summary$tmp <- NULL

  structure(list(frame.summary = structure(frame.summary, class = c("comparedf.frame.summary", "data.frame")),
                 vars.summary = structure(vars.summary, class = c("comparedf.vars.summary", "data.frame")),
                 control = control, Call = match.call()), class = "comparedf")
}

#' @rdname comparedf
#' @export
print.comparedf <- function(x, ...)
{
  cat("Compare Object\n\n")
  cat("Function Call: \n")
  print(x$Call)
  cat("\n")
  cat("Shared: ", sum(idx_var_sum(x, "nonby.vars.shared")), " non-by variables and ", x$frame.summary$n.shared[1], " observations.\n", sep = "")
  cat("Not shared: ", sum(idx_var_sum(x, "vars.not.shared")), " variables and ",
      n.diff.obs(x), " observations.\n", sep = "")
  cat("\n")
  cat("Differences found in ", sum(idx_var_sum(x, "differences.found")), "/", sum(idx_var_sum(x, "vars.compared")), " variables compared.\n", sep = "")
  cat(sum(idx_var_sum(x, "non.identical.attributes")), " variables compared have non-identical attributes.\n", sep = "")
  invisible(x)
}

#' @export
print.comparedf.vars.summary <- function(x, ...)
{
  orig <- x
  f <- function(elt, txt1, txt2)
  {
    if(is.data.frame(elt)) paste0(nrow(elt), txt1) else if(is.null(elt)) txt2 else elt
  }

  x$values <- vapply(x$values, f, character(1), txt1 = " differences", txt2 = "Not compared")
  x$attrs <- vapply(x$attrs, f, character(1), txt1 = " attributes", txt2 = "0 attributes")
  NextMethod()
  invisible(orig)
}


#' @export
print.comparedf.frame.summary <- function(x, ...)
{
  orig <- x
  f <- function(elt, txt1, txt2)
  {
    if(is.data.frame(elt)) paste0(nrow(elt), txt1) else if(is.list(elt)) paste0(length(elt), txt1) else if(is.null(elt)) txt2 else elt
  }

  x$attrs <- vapply(x$attrs, f, character(1), txt1 = " attributes", txt2 = "0 attributes")
  x$unique <- vapply(x$unique, f, character(1), txt1 = " unique obs", txt2 = "")
  NextMethod()
  invisible(orig)
}