Nothing
###################################################################################################
# RTest #
###################################################################################################
# #
# Changing testthat (>2.0) functions to work in RTest #
# #
# Date: 22 - Dec - 2018 #
# Author: Sebastian Wolf sebastian@mail-wolf.de #
# #
###################################################################################################
#' Method capturing the run
#'
#' @param quo an \code{rlang} quo
#' @param capture A function to derive the output / warnings / messages
#' of the function as e.g. \code{evaluate_promise}
#' @param label \code{character} A label for the evaluated value
#' @return \code{act} A list including the label (\code{lab}),
#' a caputre of the function (\code{cap}) and the code call
#' itself as (\code{..})
#'
#' @author Sebastian Wolf \email{sebastian@@mail-wolf.de})
quasi_capture <- function(quo, capture, label = NULL) {
force_implementation <- if(!is.null(options("force_implementation")[[1]])){
as.logical(options("force_implementation"))
}else{
FALSE
}
# In case quasi_capture is existing as a function
# from testthat (>2.0)
if(as.numeric(
stringr::str_extract(
as.character(packageVersion("testthat")),"[0-9]{1,2}\\.[0-9]{1,2}")) >=
2 && !force_implementation){
# Import quasi capture from testthat
`%:::%` = function(pkg, fun) get(fun, envir = asNamespace(pkg),
inherits = FALSE)
quasi_capture <- "testthat" %:::% "quasi_capture"
if (".quo" %in% formalArgs(quasi_capture)) {
return(quasi_capture(.quo=quo, .capture=capture, .label = deparse(quo)))
} else {
return(quasi_capture(quo=quo, capture=capture, label = deparse(quo)))
}
}else{
act <- list()
`%||%` = rlang::`%||%`
act$lab <- deparse(quo) %||% quo_label(quo)
act$cap <- capture(act$val <- eval_bare( rlang::get_expr(quo), rlang::get_env(quo)))
return(act)
# quasi capture source code from testthat 2.0.0.9000
# act <- list()
# act$lab <- label %||% rlang::quo_label(quo)
# act$cap <- capture(act$val <- rlang::eval_bare(rlang::get_expr(quo), rlang::get_env(quo)))
# return(act)
}
}
#' Expect a function call to run silent
#'
#' In case the function call is not silent, a message including all outputs, messages, warnings
#' is given.
#'
#' @export
#' @importFrom glue glue glue_collapse
#' @importFrom rlang enquo
#'
#' @param object executable function call
#'
#' @author Sebastian Wolf \email{sebastian@@mail-wolf.de}
expect_silent_RTest <- function(object) {
act <- quasi_capture(
rlang::enquo(object),
testthat::evaluate_promise,
label = deparse(object)
)
outputs <- c(
outputs = if (!identical(act$cap$output, "")) act$cap$output,
warnings = if (length(act$cap$warnings) > 0) act$cap$warnings %>%
strsplit(split="\n") %>% unlist(),
messages = if (length(act$cap$messages) > 0) act$cap$messages %>%
strsplit(split="\n") %>% unlist()
)
# Create a phrase that contains which outputs and warnings were created
outputs_string <- glue::glue("{names(outputs)} = '{outputs}'") %>%
glue::glue_collapse(sep="\n")
# Create the output for the test
expect(
length(outputs) == 0,
#sprintf("%s produced %s.", act$lab, paste(outputs, collapse = ", ")),
glue::glue("{act$lab} produced:\n {outputs_string}")
)
invisible(act$cap$result)
}
#'@rdname expect_less_more
expect_less_than <- function(...){
expect_lt(...)
}
#'@rdname expect_less_more
expect_more_than <- function(...){
expect_gt(...)
}
#'@rdname expect_less_more
expect_lt <- function(...){
force_implementation <- if(!is.null(options("force_implementation")[[1]])){
as.logical(options("force_implementation"))
}else{
FALSE
}
if(as.numeric(
stringr::str_extract(
as.character(packageVersion("testthat")),"[0-9]{1,2}\\.[0-9]{1,2}")) >=
2 && !force_implementation){
a <- list(...)
a$info <- NULL
do.call(getfun("testthat::expect_lt"),a)
}else{
testthat::expect_less_than(...)
}
}
#'Expect less or more
#'
#'@name expect_less_more
#'@aliases expect_gt
#'@param ... Any parameter sent to expect_gt or expect_lt of testthat
#'@rdname expect_less_more
expect_gt <- function(...){
force_implementation <- if(!is.null(options("force_implementation")[[1]])){
as.logical(options("force_implementation"))
}else{
FALSE
}
if(as.numeric(
stringr::str_extract(
as.character(packageVersion("testthat")),"[0-9]{1,2}\\.[0-9]{1,2}")) >=
2 && !force_implementation){
a <- list(...)
a$info <- NULL
do.call(getfun("testthat::expect_gt"),a)
}else{
testthat::expect_more_than(...)
}
}
#' testthat expect fun
#'
#' @export
#' @param ok (\code{logcal}) Whether code was ok
#' @param failure_message \code{character} What error cane out
#' @param info (\code{list}) List of infos given for execution
#' @param srcref (\code{call}) Call that was executed
expect_testthat <- function(ok, failure_message, info = NULL, srcref = NULL) {
type <- if (ok) "success" else "failure"
# Preserve existing API which appear to be used in package test code
# Can remove in next major release
if (missing(failure_message)) {
rlang::warn("`failure_message` is missing, with no default.")
message <- "unknown failure"
} else {
# A few packages include code in info that errors on evaluation
message <- paste(c(failure_message, info), collapse = "\n")
}
exp <- testthat::expectation(type, message, srcref = srcref)
withRestarts(
if (ok) signalCondition(exp) else stop(exp),
continue_test = function(e) NULL
)
invisible(exp)
}
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.