R/conditions.R

In brodieG/unitizer: Interactive R Unit Tests

# Copyright (C) Brodie Gaslam
#
# This file is part of "unitizer - Interactive R Unit Tests"
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# Go to <https://www.r-project.org/Licenses/GPL-2> for a copy of the license.

#' Generates a Dummy Item For Use in Examples
#'
#' The only purpose of this function is to create a \code{unitizerItem} for use
#' by examples.
#'
#' @export
#' @return unitizerItem object

mock_item <- function() {
  new(
    "unitizerItem", call=quote(fun()), value=42,
    conditions=new(
      "conditionList",
      .items=list(
        simpleWarning("hello", call=quote(fun())),
        simpleWarning("goodbye", call=quote(fun()))
  ) ) )
}

#' Contains A List of Conditions
#'
#' Condition lists are S4 classes that contain \code{\link{condition}} objects
#' emitted by \code{unitizer} tests.  Condition lists will typically be
#' accessible via the \code{.NEW} and \code{.REF} \code{unitizer} test objects.
#' You can access individual conditions using \code{[[} (see examples), and for
#' the most part you can treat them as you would an S3 list containing
#' conditions.
#'
#' There are \code{show} and \code{all.equal} methods implemented for them, the
#' latter of which is used to compare conditions across tests.  If you wish to
#' implement a custom comparison function via \code{\link{unitizer_sect}}, your
#' function will need to compare \code{conditionList} objects.
#'
#' @note Implemented as an S4 class to avoid \code{setOldClass} and related
#' compatibility issues; the \code{conditionList} class contains
#' \code{\link{unitizerList}}.
#'
#' @rdname conditionList
#' @name conditionList
#' @aliases conditionList-class
#' @slot .items list of conditions
#' @seealso \code{\link{unitizer_sect}}, \code{\link{unitizerList}},
#'   \code{\link{all.equal.conditionList}}
#' @export conditionList
#' @exportClass conditionList
#' @examples
#' ## Create a test item as you would find normally at the `unitizer` prompt
#' ## for illustrative purposes:
#' .NEW <- mock_item()
#' ## Access the first condition from the new test evaluation
#' .NEW$conditions[[1L]]
#' ## loop through all conditions
#' for(i in seq_along(.NEW$conditions)) .NEW$conditions[[i]]

conditionList <- setClass("conditionList", contains="unitizerList")

#' Compare Conditions
#'
#' Tests that issue warnings or `stop` produce \code{\link{condition}} objects.
#' The functions documented here are specialized versions of
#' \code{\link{all.equal}} designed specifically to compare conditions and
#' condition lists produced during \code{unitizer} test evaluations.
#' \code{\link{conditionList}} objects are lists of conditions that come about
#' when test expressions emit multiple conditions (e.g. more than one warning).
#'
#' \code{\link{condition}} objects produced by tests have one additional
#' attributed \dQuote{printed} which disambiguates whether a condition was the
#' result of the test expression, or the \code{print} / \code{show} method used
#' to display it to screen.
#'
#' For \code{conditionList} objects, these methods only return TRUE if all
#' conditions are pairwise \code{all.equal}.
#'
#' @export
#' @aliases all.equal,condition,ANY-method all.equal,conditionList,ANY-method
#' @name all.equal.condition
#' @rdname all.equal.condition
#' @param target the list of conditions that we are matching against
#' @param current the list of conditions we are checking
#' @param ... provided for compatibility with generic
#' @return TRUE if the (lists of) conditions are equivalent, a character
#'   vector explaining why they are not otherwise
#' @examples
#' cond.1 <- simpleWarning('hello world')
#' cond.2 <- simpleError('hello world')
#' cond.3 <- simpleError('goodbye world')
#' all.equal(cond.1, cond.1)
#' all.equal(cond.1, cond.2)
#' all.equal(cond.2, cond.3)
#' ## Normally you would never actually create a `conditionList` yourself; these
#' ## are automatically generated by `unitizer` for review at the `unitizer`
#' ## prompt
#' all.equal(
#'   conditionList(.items=list(cond.1, cond.2)),
#'   conditionList(.items=list(cond.1, cond.3))
#' )

setMethod("all.equal", "conditionList",
  function(target, current, ...) {
    if(
      !all(vapply(as.list(target), inherits, FALSE, "condition")) ||
      !all(vapply(as.list(current), inherits, FALSE, "condition"))
    ) return("`target` or `current` are not both lists of conditions")

    if(length(target) != length(current)) {
      return(
        paste0(
          "Condition count mismatch; expected ",length(target), " (got ",
          length(current), ")"
    ) ) }
    cond.len <- min(length(target), length(current))

    res <- lapply(
      seq(length.out=cond.len), function(x) all.equal(target[[x]], current[[x]])
    )
    errs <- which(vapply(res, Negate(isTRUE), logical(1L)))
    if(!(err.len <- length(errs))) {
      return(TRUE)
    } else if (err.len == 1) {
      err.msg <- paste0(
        "There is one condition mismatch at index [[", errs, "]]"
      )
    } else {
      err.msg <- paste0(
        "There are ", err.len, " condition mismatches, first one at index [[",
        errs[[1]],"]]"
      )
    }
    if(err.len) return(err.msg)
} )
# So that S3 dispatch works
#' @rdname all.equal.condition
#' @export

all.equal.conditionList <- function(target, current, ...)
  all.equal(target, current, ...)

#' @export
#' @rdname all.equal.condition

all.equal.condition <- function(target, current, ...) {
  if(!inherits(target, "condition") || !inherits(current, "condition"))
    return("One of `target` or `current` is not a condition")

  target.printed <- isTRUE(attr(target, "unitizer.printed"))
  current.printed <- isTRUE(attr(current, "unitizer.printed"))

  if(!is.null(attr(target, "unitizer.printed")))
    attr(target, "unitizer.printed") <- NULL
  if(!is.null(attr(current, "unitizer.printed")))
    attr(current, "unitizer.printed") <- NULL

  err.msg <- character()
  if(
    !identical(
      type.targ <- get_condition_type(target),
      type.curr <- get_condition_type(current)
    )
  ) {
    err.msg <- paste0(
      "Condition type mismatch, `target` is '", type.targ,
      "', but `current` is '", type.curr, "'"
    )
  } else if(
    !isTRUE(all.equal(conditionMessage(target), conditionMessage(current)))
  ) {
    err.msg <- paste0(type.targ, " condition messages do not match")
  } else if(!isTRUE(compare_condition_calls(target, current))) {
    err.msg <- paste0(type.targ, " condition calls do not match")
  }
  if(length(err.msg) && (target.printed || current.printed)) {
    print.show.err <- paste0(
      "Condition mismatch may involve print/show methods; carefully review ",
      "conditions with `.NEW$conditions` and `.REF$conditions` as just ",
      "typing `.ref` or `.new` at the prompt will invoke print/show methods, ",
      "which themselves may be the cause of the mismatch"
    )
    err.msg <- c(err.msg, print.show.err)
  }
  if(length(err.msg)) return(err.msg)
  TRUE
}
## Compare Two Calls Generously
##
## Designed to minimize false positive errors caused by instability in C level
## errors issued whether the code is byte-compiled or not (e.g. when run under
## `covr`, or iterating at the prompt).

compare_condition_calls <- function(target, current) {
  tar.c <- conditionCall(target)
  cur.c <- conditionCall(current)
  if(!is.null(tar.c) && !is.null(cur.c)) {
    # Only check the things that are present in both
    tar.l <- as.list(tar.c)
    cur.l <- as.list(cur.c)
    if(length(tar.l) && length(cur.l)) {
      if(!isTRUE(all.equal(tar.l[[1]], cur.l[[1]]))) {
        # Function different
        FALSE
      } else {
        # compare comon names.  We don't compare unnamed arguments, in theory we
        # should by using some kind of match.call style arrangement.
        tar.n <- names(tar.l)
        cur.n <- names(cur.l)
        common.n <- intersect(tar.n, cur.n)
        common.n <- common.n[nzchar(common.n)]
        if(length(common.n)) isTRUE(all.equal(tar.l[common.n], cur.l[common.n]))
        else TRUE
      }
    } else {
      TRUE
    }
  } else {
    # If one of the calls is NULL, let it match
    TRUE
  }
}

#' Prints A list of Conditions
#'
#' S4 method for \code{\link{conditionList}} objects.
#'
#' @name show.conditionList
#' @aliases show,conditionList-method
#' @export
#' @seealso \code{\link{conditionList}}
#' @param object a \code{\link{conditionList}} object (list of conditions)
#' @return object, invisibly
#' @examples
#' ## Create a test item as you would find normally at the `unitizer` prompt
#' ## for illustrative purposes:
#' .NEW <- mock_item()
#' ## Show the conditions the test generated (typing `show` here is optional
#' ## since auto-printing should dispatch to `show`)
#' show(.NEW$conditions)

setMethod("show", "conditionList",
  function(object) {
    width=getOption("width")
    cond.len <- length(object)
    if(!cond.len) {
      word_cat("Empty condition list")
      return(invisible(object))
    } else {
      word_cat(
        "Condition list with", cond.len,
        paste0("condition", if(cond.len > 1) "s", ":")
      )
    }
    cond.calls <- vapply(
      as.list(object), function(x) !is.null(conditionCall(x)), logical(1L)
    )
    nums <- paste0(format(seq_along(object)), ". ")
    out <- paste0(
      ifelse(
        print.show <- vapply(
          as.list(object),
          function(y) isTRUE(attr(y, "unitizer.printed")), logical(1L)
        ),
        "[print] ", ""
      ),
      vapply(as.list(object), get_condition_type, character(1L)),
      ifelse(cond.calls, " in ", "")
    )
    desc.chars <- max(width - max(nchar(nums)), 20L)

    cond.detail <- vapply(
      as.list(object), FUN.VALUE=character(1L),
      function(y) {
        if(is.null(conditionCall(y))) {
          paste0(": ", conditionMessage(y))
        } else {
          paste0(deparse(conditionCall(y))[[1L]], " : ", conditionMessage(y))
        }
    } )
    out.w <- word_wrap(paste0(out, cond.detail), width=desc.chars, unlist=FALSE)
    out.lens <- vapply(out.w, length, integer(1L))
    if(!all(out.lens)) {
      # nocov start
      stop("Internal Error: empty condition data; contact maintainer.")
      # nocov end
    }

    nums.pad <- Map(
      function(x, y) c(x, rep(paste0(rep(" ", nchar(x)), collapse=""), y - 1L)),
      nums, out.lens
    )
    out.fin <- unlist(Map(paste0, nums.pad, out.w))

    if(any(print.show)) {
      out.fin <- c(
        out.fin,
        word_wrap(
          cc(
            "\n[print] means condition was issued by a print or show method ",
            "for an auto-printed result."
          ),
          width=width
    ) ) }
    out.fin <- c(out.fin)
    cat(out.fin, sep="\n")
    return(invisible(object))
  }
)
# Extracts Condition Type From Condition Classes
#
# Type (e.g. Error, Warning), is taken to be the second to last class.
#
# @keywords internal
# @param x a condition
# @return character 1 length the type of condition

get_condition_type <- function(x) {
  if(!inherits(x, "condition")) stop("Argument `x` must be a condition")
  classes <- class(x)
  if(length(classes) < 2L || classes[[length(classes)]] != "condition") "Unknown"
  else if(identical(classes, c("simpleError", "error", "condition")))
    "Error"
  else if(identical(classes, c("simpleWarning", "warning", "condition")))
    "Warning"
  else if(identical(classes, c("simpleMessage", "message", "condition")))
    "Message"
  else classes[[1L]]
}