Nothing
# 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]]
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.