R/compare_rtables.R

In Roche/rtables: Reporting Tables

#' Compare two rtables
#'
#' Prints a matrix where `.` means cell matches, `X` means cell does
#' not match, `+` cell (row) is missing, and `-` cell (row)
#' should not be there. If `structure` is set to `TRUE`, `C` indicates
#' column-structure mismatch, `R` indicates row-structure mismatch, and
#' `S` indicates mismatch in both row and column structure.
#'
#' @param object (`VTableTree`)\cr `rtable` to test.
#' @param expected (`VTableTree`)\cr expected `rtable`.
#' @param tol (`numeric(1)`)\cr tolerance.
#' @param comp.attr (`flag`)\cr whether to compare cell formats. Other attributes are
#'   silently ignored.
#' @param structure (`flag`)\cr whether structures (in the form of column and row
#'   paths to cells) should be compared. Currently defaults to `FALSE`, but this is
#'   subject to change in future versions.
#'
#' @note In its current form, `compare_rtables` does not take structure into
#'   account, only row and cell position.
#'
#' @return A matrix of class `rtables_diff` representing the differences
#'  between `object` and `expected` as described above.
#'
#' @examples
#' t1 <- rtable(header = c("A", "B"), format = "xx", rrow("row 1", 1, 2))
#' t2 <- rtable(header = c("A", "B", "C"), format = "xx", rrow("row 1", 1, 2, 3))
#'
#' compare_rtables(object = t1, expected = t2)
#'
#' if (interactive()) {
#'   Viewer(t1, t2)
#' }
#'
#' expected <- rtable(
#'   header = c("ARM A\nN=100", "ARM B\nN=200"),
#'   format = "xx",
#'   rrow("row 1", 10, 15),
#'   rrow(),
#'   rrow("section title"),
#'   rrow("row colspan", rcell(c(.345543, .4432423), colspan = 2, format = "(xx.xx, xx.xx)"))
#' )
#'
#' expected
#'
#' object <- rtable(
#'   header = c("ARM A\nN=100", "ARM B\nN=200"),
#'   format = "xx",
#'   rrow("row 1", 10, 15),
#'   rrow("section title"),
#'   rrow("row colspan", rcell(c(.345543, .4432423), colspan = 2, format = "(xx.xx, xx.xx)"))
#' )
#'
#' compare_rtables(object, expected, comp.attr = FALSE)
#'
#' object <- rtable(
#'   header = c("ARM A\nN=100", "ARM B\nN=200"),
#'   format = "xx",
#'   rrow("row 1", 10, 15),
#'   rrow(),
#'   rrow("section title")
#' )
#'
#' compare_rtables(object, expected)
#'
#' object <- rtable(
#'   header = c("ARM A\nN=100", "ARM B\nN=200"),
#'   format = "xx",
#'   rrow("row 1", 14, 15.03),
#'   rrow(),
#'   rrow("section title"),
#'   rrow("row colspan", rcell(c(.345543, .4432423), colspan = 2, format = "(xx.xx, xx.xx)"))
#' )
#'
#' compare_rtables(object, expected)
#'
#' object <- rtable(
#'   header = c("ARM A\nN=100", "ARM B\nN=200"),
#'   format = "xx",
#'   rrow("row 1", 10, 15),
#'   rrow(),
#'   rrow("section title"),
#'   rrow("row colspan", rcell(c(.345543, .4432423), colspan = 2, format = "(xx.x, xx.x)"))
#' )
#'
#' compare_rtables(object, expected)
#'
#' @export
compare_rtables <- function(object, expected, tol = 0.1, comp.attr = TRUE,
                            structure = FALSE) {
  # if (identical(object, expected)) return(invisible(TRUE))

  if (!is(object, "VTableTree")) {
    stop(
      "argument object is expected to be of class TableTree or ",
      "ElementaryTable"
    )
  }
  if (!is(expected, "VTableTree")) {
    stop(
      "argument expected is expected to be of class TableTree or ",
      "ElementaryTable"
    )
  }
  dim_out <- apply(rbind(dim(object), dim(expected)), 2, max)

  X <- matrix(rep(".", dim_out[1] * dim_out[2]), ncol = dim_out[2])
  row.names(X) <- as.character(1:dim_out[1])
  colnames(X) <- as.character(1:dim_out[2])

  if (!identical(names(object), names(expected))) {
    attr(X, "info") <- "column names are not the same"
  }

  if (!comp.attr) {
    attr(X, "info") <- c(
      attr(X, "info"),
      "cell attributes have not been compared"
    )
  }
  if (!identical(row.names(object), row.names(expected))) {
    attr(X, "info") <- c(attr(X, "info"), "row labels are not the same")
  }

  nro <- nrow(object)
  nre <- nrow(expected)
  nco <- ncol(object)
  nce <- ncol(expected)

  if (nco < nce) {
    X[, seq(nco + 1, nce)] <- "-"
  } else if (nce < nco) {
    X[, seq(nce + 1, nco)] <- "+"
  }
  if (nro < nre) {
    X[seq(nro + 1, nre), ] <- "-"
  } else if (nre < nro) {
    X[seq(nre + 1, nro), ] <- "+"
  }

  orig_object <- object # nolint
  orig_expected <- expected # nolint
  if (nro != nre || nco != nce) {
    object <- object[1:min(nro, nre), 1:min(nco, nce), drop = FALSE]
    expected <- expected[1:min(nro, nre), 1:min(nco, nce), drop = FALSE]
    inner <- compare_rtables(object, expected, tol = tol, comp.attr = comp.attr, structure = structure)
    X[seq_len(nrow(object)), seq_len(ncol(object))] <- inner
    class(X) <- c("rtables_diff", class(X))
    return(X)
  }

  ## from here dimensions match!

  orows <- cell_values(object, omit_labrows = FALSE)
  erows <- cell_values(expected, omit_labrows = FALSE)
  if (nrow(object) == 1) {
    orows <- list(orows)
    erows <- list(erows)
  }
  res <- mapply(compare_rrows,
    row1 = orows, row2 = erows, tol = tol, ncol = ncol(object),
    USE.NAMES = FALSE, SIMPLIFY = FALSE
  )
  X <- do.call(rbind, res)
  rpo <- row_paths(object)
  rpe <- row_paths(expected)

  if (comp.attr) {
    ofmts <- value_formats(object)
    efmts <- value_formats(expected)
    ## dim(ofmts) <- NULL
    ## dim(efmts) <- NULL

    fmt_mismatch <- which(!mapply(identical, x = ofmts, y = efmts)) ## inherently ignores dim


    ## note the single index here!!!, no comma!!!!
    X[fmt_mismatch] <- "X"
  }


  if (structure) {
    rp_mismatches <- !mapply(identical, x = rpo, y = rpe)
    cpo <- col_paths(object)
    cpe <- col_paths(expected)
    cp_mismatches <- !mapply(identical, x = cpo, y = cpe)

    if (any(rp_mismatches)) { # P for (row or column) path do not match
      X[rp_mismatches, ] <- "R"
    }
    if (any(cp_mismatches)) {
      crep <- rep("C", nrow(X))
      if (any(rp_mismatches)) {
        crep[rp_mismatches] <- "P"
      }
      X[, cp_mismatches] <- rep(crep, sum(cp_mismatches))
    }
  }
  class(X) <- c("rtables_diff", class(X))
  X
}

## for (i in 1:dim(X)[1]) {
##   for (j in 1:dim(X)[2]) {

##     is_equivalent <- TRUE
##     if (i <= nro && i <= nre && j <= nco && j <= nce) {
##       x <- object[i,j, drop = TRUE]
##       y <- expected[i,j, drop = TRUE]

##       attr_x <- attributes(x)
##       attr_y <- attributes(y)

##       attr_x_sorted <- if (is.null(attr_x)) NULL else attr_x[order(names(attr_x))]
##       attr_y_sorted <- if (is.null(attr_y)) NULL else attr_y[order(names(attr_y))]

##       if (comp.attr && !identical(attr_x_sorted, attr_y_sorted)) {
##         is_equivalent <- FALSE
##       } else if (is.numeric(x) && is.numeric(y)) {
##         if (any(abs(na.omit(x - y)) > tol)) {
##           is_equivalent <- FALSE
##         }
##       } else {
##         if (!identical(x, y)) {
##           is_equivalent <- FALSE
##         }
##       }

##       if (!is_equivalent) {
##         X[i,j] <- "X"
##       }
##     } else if (i > nro || j > nco) {
##       ## missing in object
##       X[i, j] <- "+"
##     } else {
##       ## too many elements
##       X[i, j] <- "-"
##     }
##   }
## }
## class(X) <- c("rtable_diff", class(X))
## X
## }

compare_value <- function(x, y, tol) {
  if (identical(x, y) || (is.numeric(x) && is.numeric(y) && max(abs(x - y)) <= tol)) {
    "."
  } else {
    "X"
  }
}

compare_rrows <- function(row1, row2, tol, ncol) {
  if (length(row1) == ncol && length(row2) == ncol) {
    mapply(compare_value, x = row1, y = row2, tol = tol, USE.NAMES = FALSE)
  } else if (length(row1) == 0 && length(row2) == 0) {
    rep(".", ncol)
  } else {
    rep("X", ncol)
  }
}

## #' @export
## print.rtable_diff <- function(x, ...) {
##   print.default(unclass(x), quote = FALSE, ...)
## }