# Unit tests utilities
#
# Author: Renaud Gaujoux
# Creation: 25 Apr 2012
###############################################################################
#' @include utils.R
#' @include logging.R
NULL
#' Load RUnit Compatible Package
#'
#' Loads the package responsible for the implementation of the RUnit framework,
#' choosing amongst \sQuote{RUnitX}, \sQuote{svUnit} and \sQuote{RUnit}.
#'
#' @param ... arguments not used.
#'
#' @return nothing
#' @export
#'
requireRUnit <- local({
.cache <- NULL
function(...){
if( !is.null(.cache) ) return(.cache)
has_pkg <- function(x) length(find.package(x, quiet=TRUE)) > 0L
ruf <- c('RUnit', 'svUnit')
runit <- NULL
for( pkg in ruf){
if( require.quiet(pkg, character.only=TRUE) ){
runit <- pkg
break
}
}
if( is.null(runit) )
stop("Cannot find any package providing RUnit framework.")
message("Using RUnit framework provider: ", runit)
.cache <<- runit
# return name of the loaded framework
invisible(runit)
}
})
# Borrowed from RUnit::.existsTestLogger
.existsTestLogger <- function(envir = .GlobalEnv){
exists(".testLogger", envir = envir) && inherits(envir$.testLogger, "TestLogger")
}
#' Enhancing RUnit Logger
#'
#' Adds a function or a local variable to RUnit global logger.
#'
#' @param name name of the function or variable to add
#' @param value object to append to the logger.
#' If \code{value} is a function it is added to the list and is accessible via
#' \code{.testLogger$name}.
#' If \code{value} is a variable it is added to the local environment and is
#' therefore accessible in all logging functions.
#' @param logger an optional RUnit logger object.
#' If missing or \code{NULL}, the object \code{.testLogger} is searched in
#' \code{.GlobalEnv} -- and an error is thrown if it does not exist.
#'
#' @return the modified logger object. Note that the global object is also
#' modified if \code{logger} is \code{NULL}.
#'
addToLogger <- function(name, value, logger=NULL){
logobj <-
if( !is.null(logger) ) logger
else{
if( !.existsTestLogger() )
stop("No global logger exists")
get('.testLogger', envir=.GlobalEnv)
}
# get local logger environment
logenv <- environment(logobj$incrementCheckNum)
if( is.function(value) ){# add function to logger
if( is.null(logobj[[name]]) ){
environment(value) <- logenv
logobj[[name]] <- value
# update global logger if necessary
if( is.null(logger) ){
ge <- .GlobalEnv
assign('.testLogger', logobj, envir=ge)
}
}
}else{ # assign object in logger's local environment if not already there
if( !exists(name, envir=logenv) )
assign(name, value, envir=logenv)
}
# return modified logger object
logobj
}
#' Plot in Unit Tests
#'
#' Saves a plot in a PNG file that will be included in unit test HTML reports.
#'
#' @param expr expression that generate th eplot
#' @param width plot width
#' @param height plot height (not used)
#' @param msg plot msg explaining the plot . It will be used as the caption
#'
#' @return TRUE is the check is successful.
#'
#' @export
#' @keywords internal
checkPlot <- function(expr, msg=NULL, width=1000, height=NULL){
# get stuff from RUnit
uf <- requireRUnit()
if( is.null(uf) || uf != 'RUnit' ) return(TRUE)
#.existsTestLogger <- RUnit:::.existsTestLogger
.testLogger <- if( .existsTestLogger() ) .GlobalEnv$.testLogger
if (missing(expr)) {
stop("'expr' is missing.")
}
plotfile <-
if (.existsTestLogger()) {
.testLogger$incrementCheckNum()
if( is.null(.testLogger$setPlot) ){
# add .plot list to logger environment
addToLogger('.plots', NULL)
# add function setPlot to logger
.plots <- NULL # to trick R CMD check
addToLogger('setPlot',
function(name, msg=''){
##@bdescr
## add a plot to a test function.
##@edescr
##@in testFuncName : [character] name of test function
##@in name : [character] filename
##@in msg : [character] message string
##@edescr
if( is.null(.plots) ) .plots <<- list()
.plots[[name]] <<- msg
}
)
# add function setPlot to logger
.getTestData <-
.currentTestSuiteName <-
.currentSourceFileName <-
.getCheckNum <- NULL # not to get NOTES is R CMD check
addToLogger('getPlotfile',
function(name, msg=''){
td <- .getTestData()
# TODO from test function name
#fname <- tail(names(td[[.currentTestSuiteName]]$sourceFileResults[[.currentSourceFileName]]), 1L)
fname <- basename(tempfile(paste(.currentTestSuiteName, '_', .currentSourceFileName, '_', sep='')))
paste(fname, .getCheckNum(), sep='_')
}
)
# update local object with modified global logger
.testLogger <- .GlobalEnv$.testLogger
}
.testLogger$getPlotfile()
}
else tempfile(tmpdir='.')
# add extension to plot file
plotfile <- paste(plotfile, 'png', sep='.')
# reset the msg if none was provided
if( is.null(msg) ) msg <- plotfile
#plot in the PNG file
png(filename=plotfile, width=width)
# evaluate the expression that generates the plot
res <- try( eval(expr, envir = parent.frame()) )
# close the graphic device
dev.off()
# test if everything went alright
fileinfo <- file.info(plotfile)
if( inherits(res, "try-error") || is.na(fileinfo$size[1]) || fileinfo$size[1] == 0 ){
#make sure the plot file is removed
unlink(plotfile)
if (.existsTestLogger()) {
.testLogger$setFailure()
}
stop("Problem when generating plot:", res, msg)
}
if (.existsTestLogger()) {
.testLogger$setPlot(plotfile, msg)
}
return(TRUE)
}
if( FALSE ){
library(NMF, lib='build/lib')
utest('pkg/inst/tests/runit.algorithms.r', fun='test.brunet', framework='RUnit')
}
#' Extra Check Functions for RUnit
#'
#' \code{checkWarning} checks if a warning is generated by an expression, and
#' optionally follows an expected regular expression pattern.
#'
#' @param expr an R expression
#' @param expected expected value as regular expression pattern.
#' If a logical, then it specifies if a warning is expected or not.
#'
#' For backward compatibility, a \code{NULL} value is equivalent to \code{TRUE}.
#' @param msg informative message to add to the error in case of failure
#'
#' @export
#' @rdname uchecks
#'
#' @return * `checkWarning` returns TRUE is the check is successful.
#'
#' @examples
#'
#' # check warnings
#' checkWarning({ warning('ah ah'); 3})
#' checkWarning({ warning('ah oh ah'); 3}, 'oh')
#' try( checkWarning(3) )
#' try( checkWarning({ warning('ah ah'); 3}, 'warn you') )
#'
checkWarning <- function(expr, expected=TRUE, msg=NULL){
# get stuff from RUnit
uf <- requireRUnit()
#.existsTestLogger <- RUnit:::.existsTestLogger
.testLogger <- if( .existsTestLogger() ) .GlobalEnv$.testLogger
if (missing(expr)) {
stop("'expr' is missing")
}
# if (is.null(silent)) {
# silent <- FALSE
# warning("'silent' has to be of type 'logical'. Was NULL. Set to FALSE.")
# }
#
if (.existsTestLogger()) {
.testLogger$incrementCheckNum()
}
pf <- parent.frame()
warns <- NULL
withCallingHandlers(eval(expr, envir = pf)
, warning = function(w){
warns <<- c(warns, w$message)
}
)
# check that some warning was thrown
if( length(warns) == 0L ){
if( isFALSE(expected) ) return( TRUE )
if (.existsTestLogger()) {
.testLogger$setFailure()
}
stop("Warning not generated as expected\n", msg)
}
if( isFALSE(expected) ){
if (.existsTestLogger()) {
.testLogger$setFailure()
}
stop("Warning generated while none was expected:\n"
, " - Warning(s): ", if(length(warns)>1)"\n * ", str_out(warns, Inf, sep="\n * ") ,"\n"
, msg)
}
# check warnings
if( is.null(expected) || isTRUE(expected) ) return(TRUE)
if( any(grepl(expected, warns)) ) return(TRUE)
# throw error
if (.existsTestLogger()) {
.testLogger$setFailure()
}
stop("Warning does not match expected pattern:\n"
, " - Warning(s): ", if(length(warns)>1)"\n * ", str_out(warns, Inf, sep="\n * ") ,"\n"
, " - Pattern: '", expected,"'\n"
, msg)
TRUE
}
#' Make Vignette for Unit Tests
#'
#' Builds a vignette for unit tests in a package using the \code{\link{utest}}
#' and a template vignette file.
#'
#' @param pkg Package name
#' @param file Output file (.Rnw, .tex, or .pdf)
#' @param ... extra arguments passed to \code{\link{utest}}.
#' @param check logical that indactes the cal was made from R CMD check, in which case the vignette
#' is updated only if results of unit tests can be found in the unit test output directory,
#' where they would have been generated by \code{\link{utest}}.
#'
#' @return Result of running unit test suite
#'
#' @export
#'
makeUnitVignette <- function(pkg, file=paste(pkg, '-unitTests.pdf', sep=''), ..., check=FALSE){
package <- pkg
pkg <- sub("^package:", "", pkg)
# generate the vignette for unit test on exit
if( !is.null(file) )
on.exit( writeUnitVignette(pkg, file, check=check) )
# load this package
if( !require(pkg, character.only = TRUE ) ){
stop("Could not load package '", pkg, "' for testing [libPath= ", str_out(.libPaths(), Inf), "]")
}
# run unit tests if not check or if the test results are not there (e.g., R CMD build)
# if( userIs('renaud') ){
# env <- str_trim(capture.output(system('env', intern=TRUE)))
# if( check ) write(env, file="~/check_env.txt")
# else write(env, file="~/make_env.txt")
# }
# if( !check || !is.dir(utestPath(package=package)) ){
if( !check ){
# force running all tests
utestCheckMode(FALSE)
# run unit tests
tests <- utest(package, ...)
if( !requireNamespace('RUnit', quietly = TRUE) )
stop("Package 'RUnit' is required to make unit test vignettes")
# check for errors
err <- RUnit::getErrors(tests)
errMsg <- NULL
if( err$nFail > 0) {
errMsg <- c(errMsg, sprintf( "unit test problems: %d failures\n", err$nFail))
}
if( err$nErr > 0) {
errMsg <- c(errMsg, sprintf( "unit test problems: %d errors\n", err$nErr))
}
# stop if any failure or error occured
if( length(errMsg) > 0L )
stop(errMsg)
# return result of unit test suite
err
}else{
# do nothing: tests should have been already run by R CMD check
}
}
#' Writes Unit Tests Vignette
#'
#' Writes a vignette that contains the results from running unit test suites.
#'
#' @param pkg Package name
#' @param file Output Sweave (.Rnw) file
#' @param results result file or output character vector
#' @param check logical that indactes the cal was made from R CMD check,
#' in which case the vignette is updated only if results of unit tests can
#' be found in the unit test output directory, where they would have been
#' generated by \code{\link{utest}}.
#'
#' @return Path to the vignette file.
#'
#' @export
#'
writeUnitVignette <- function(pkg, file, results=NULL, check=FALSE){
Rnw.template <-
"
\\documentclass[10pt]{article}
%\\VignetteDepends{knitr}
%\\VignetteIndexEntry{@pkg@-unitTests}
%\\VignetteCompiler{knitr}
%\\VignetteEngine{knitr::knitr}
\\usepackage{vmargin}
\\setmargrb{0.75in}{0.75in}{0.75in}{0.75in}
<<setup, include=FALSE>>=
pkg <- '@pkg@'
require( pkg, character.only=TRUE )
prettyVersion <- packageDescription(pkg)$Version
prettyDate <- format(Sys.Date(), '%B %e, %Y')
authors <- packageDescription(pkg)$Author
@
\\usepackage[colorlinks]{hyperref}
\\author{\\Sexpr{authors}}
\\title{\\texttt{\\Sexpr{pkg}}: Unit testing results@resNote@}
\\date{\\texttt{\\Sexpr{pkg}} version \\Sexpr{prettyVersion} as of \\Sexpr{prettyDate}}
\\begin{document}
\\maketitle
@results@
\\section*{Session Information}
@sessionInfo@
\\end{document}
"
verbatim_wrap <- function(...){
c("\\\\begin{verbatim}\n", ..., "\n\\\\end{verbatim}")
}
# default is to load the unit test results from the global output directory
if( is.null(results) ){
upath <- utestPath(package=pkg)
results <- list.files(upath, pattern="\\.txt$", full.names=TRUE)
if( !length(results) ){
results <- verbatim_wrap('Could not find any unit test result in "', upath, '"')
}
}
if( is.file(results[1L]) ){
resFile <- results[1L]
name <- str_match(resFile, "([^.]+)\\.[^.]+$")[,2L]
results <- c(str_c("\\\\section{", name, "}"), verbatim_wrap(readLines(resFile)))
}else{
resFile <- NULL
}
results <- paste(results, collapse="\n")
# substitute template variables
contents <- Rnw.template
# package name
contents <- gsub("@pkg@", pkg, contents)
# unit test results
contents <- gsub("@results@", results, contents)
# session info (as when calling this function)
contents <- gsub("@sessionInfo@", gsub("\\", "\\\\", paste(toLatex(sessionInfo()), collapse="\n"), fixed=TRUE), contents)
# note on how tests were performed
resnote <- str_c("\\footnote{Vignette computed ", if( check ) ' via R CMD check/build ', ' on ', date(),"}")
if( check ){
# add path to included file if compiled from R CMD check (for debug purposes)
lfile <- gsub("([_$])", "\\\\\\1", paste(resFile, collapse="\\\\"))
resnote <- str_c(resnote, " \\footnote{File: '", lfile, "'}")
}
contents <- gsub("@resNote@", gsub("\\", "\\\\", resnote, fixed=TRUE), contents)
fileext <- toupper(file_extension(file))
fileext <- charmatch(fileext, c('RNW', 'TEX', 'PDF'))
if( is_NA(fileext) )
stop("Invalid output file extension [",fileext,"] from file '", file, "'")
fileRNW <- if( fileext == 1L ) file else str_c(pkg, '-unitTests.Rnw')
fileTEX <- if( fileext == 2L ) file else str_c(pkg, '-unitTests.tex')
filePDF <- if( fileext == 3L ) file else str_c(pkg, '-unitTests.pdf')
# write into Rnw file
writeLines(contents, fileRNW)
if( fileext == 1L ) return()
# compile vignette
rnw(fileRNW, fileTEX)
if( fileext == 2L ) return()
# Run texi2dvi tex file
res <- tools::texi2dvi(fileTEX, pdf = TRUE, clean = TRUE )
# copy file in main check directory
if( check ) file.copy(filePDF, '../../..')
res
}
# Unit test frameworks data
.UFdata <- list(
RUnit = list(
file_pattern="^runit.*\\.[rR]$"
, fun_pattern="^test\\."
, check_pattern = "^check.+"
, check_functions = c(
'checkTrue'
, 'checkIdentical'
, 'checkEquals'
, 'checkEqualsNumeric'
, 'checkException'
)
)
, testthat = list(
file_pattern="^test.*\\.[rR]$"
, check_pattern = "^(expect_.+)|(test_that$)"
, check_functions = c(
"test_that"
, "expect_equal"
, "expect_equivalent"
, "expect_error"
, "expect_false"
, "expect_identical"
, "expect_is"
, "expect_match"
, "expect_message"
, "expect_output"
, "expect_that"
, "expect_true"
, "expect_warning"
)
)
)
#' Inferring Unit Test Framework
#'
#' @param x an filename, a function or the body of a function
#' @param eval a logical that indicates if the value of \code{x} should be used.
#'
#' @return the name of the framework as a character string or NULL if
#' it could not be detected.
#'
#' @import codetools
#' @export
utestFramework <- function(x, eval=FALSE){
# check if one should detect within an expression
expr <- if( missing(eval) || !eval ) substitute(x)
else if( is.function(x) ) body(x)
# walk code using codetools looking up for known test functions
if( !is.null(expr) ){
cw <- makeCodeWalker(leaf= function(e, w) if( is.symbol(e) ) cat(e, "\n"))
s <- str_trim(capture.output(walkCode(expr, cw)))
if( length(s) > 1L ){
for( f in names(.UFdata) ){
if( any(s %in% .UFdata[[f]]$check_functions) ){
return(f)
}
}
}
# not found without evaluating
if( !missing(eval) && !eval ) return()
if( missing(eval) ){ # try evaluating
return(utestFramework(x, eval=TRUE))
}
}
if( !is.character(x) )
stop("Invalid argument `x`: expecting a character string")
path <- x
framework <- NULL
tf <- if( is.dir(path) ) list.files(path, "\\.[rR]$") else path
for( f in names(.UFdata) ){
if( any(grepl(.UFdata[[f]]$file_pattern, tf)) ){
return(f)
}
}
if( is.null(framework) )
stop("Could not determine unit test framework used in directory: '", path, "'")
framework
}
#' Embedded Unit Tests
#'
#' The function \code{unit.test} provides a way to write unit tests embedded within
#' package source files.
#' These tests are stored and organised in the package namespace, and can be run using
#' the unified interface provided by the function \code{link{utest}}.
#' Both Runit and testthat tests are supported -- and automatically detected.
#'
#'
#' @param x single character string used as test identifier/label
#' @param expr expression containing the actual test commands.
#' It is not evaluated, but only stored in the package namespace.
#' @param framework Unit test framework
#' @param envir the definition environment of object \code{x}.
#'
#' @return a test function with no arguments that wrapping around \code{expr}
#'
#' @import digest
#' @export
#'
unit.test <- function(x, expr, framework=NULL, envir=parent.frame()){
sid <- as.character(deparse(substitute(x)))
hash <- suppressWarnings(digest(x))
# get test environment
eTest <- packageTestEnv()
# wrap test into a function
f <- function(){}
environment(f) <- eTest
body(f) <- substitute({expr})
if( !grepl('"', sid) )
{
lmessage('Creating unit test for object: `', sid, '`')
eval(substitute(attr(x, 'test') <- f, list(x=substitute(x), f=f)), envir)
}else
lmessage('Creating unit test: ', sid)
# add the test to the package test environment
eTest[[str_c(sid, ':', hash)]] <- list(test=f, name=sid, object=is.name(x))
# return the test function
f
}
#' Returns the package internal environment where unit tests are stored.
#'
#' @param pkg package name.
#' If missing the caller's package is assumed.
#'
#' @return An environment.
#'
#' @export
packageTestEnv <- function(pkg){
if( !missing(pkg) && !is.null(pkg) ){
e <- packageEnv(pkg)
return( e$.packageTest )
}
e <- packageEnv()
# create test environment if necessary
if( is.null(e$.packageTest) )
e$.packageTest <- new.env(parent=e)
e$.packageTest
}
list.tests <- function(x, pattern=NULL){
}
#unit.test(packageEnv, {print('test for packageEnv')})
#unit.test('lmlm', {print('test for something else')})
#utest <- function(x, ..., framework="RUnit", PACKAGE=NULL){
#
# if( missing(x) )
# x <- packagePath('unitTests', PACKAGE=PACKAGE)
# else if( class(x)[1] != 'character')
# return( UseMethod('utest', x) )
#
# if( is.null(framework) ){
# stop("Not implemented")
# }else{
# # change directory to run tests
# owd <- setwd(x)
# on.exit(setwd(owd))
# # run tests under selected framework
# class(x) <- framework
# utest(x, ..., PACKAGE=PACKAGE)
# # output test result
# }
#}
#' Running Unit Tests
#'
#' Run unit tests in a variety of settings.
#' This is still \strong{very} experimental.
#'
#' @param x object to which a unit test is attached
#' @param ... extra arguments to allow extensions and are passed to
#' the unit framework running funcitons.
#'
#' @return Returns the result object returned by the unit-test suite executer.
#' @export
setGeneric('utest', function(x, ...) standardGeneric('utest'))
#' @describeIn utest Run the unit test assoicated to a function.
#'
#' @param run a logical that indicates if the unit test should be run
#'
setMethod('utest', 'function',
function(x, run = TRUE){
# get actual name of the function
sid <- as.character(deparse(substitute(x, parent.frame())))
# remove leading namespace specifications
sid <- sub("^[^:]+:::?", "", sid)
# get the package's
pkg <- attr(x, 'package')
eTest <- packageTestEnv(pkg)
if( is.null(eTest) ) return()
tfun <- ls(eTest, pattern=str_c("^", sid, ":"))
}
)
#' @describeIn utest Run a package test suite
#'
#' @param filter pattern to match files that contain the definition of
#' the unit tests functions to run.
#' @param fun patter to match the test functions to run.
#' @param testdir directory where to look for the test files
#' @param framework unit test framework
#' @param quiet a logical that indicates if the tests should be run silently
#' @param lib.loc path to a library where installed packages are searched for.
#' Used is of the form \code{x='package:*'}.
#'
setMethod('utest', 'character',
function(x, filter="^runit.+\\.[rR]$", fun="^test\\.", ...
, testdir='tests', framework=c('RUnit', 'testthat')
, quiet = Sys.getenv("RCMDCHECK") != "FALSE"
, lib.loc = NULL){
cat("#########################\n")
# define environment variable that identifies a test run (if not already defined)
if( is.na(utestCheckMode(raw = TRUE)) ){
oldUM <- utestCheckMode(TRUE)
on.exit( utestCheckMode(oldUM), add=TRUE)
}
#print(system('env'))
# detect type of input string
path <-
if( grepl("^package:", x) ){# installed package
pkg <- sub("^package:", "", x)
if( is.null(path <- path.package(pkg, quiet=TRUE)) ){
library(pkg, character.only=TRUE, lib.loc=lib.loc)
path <- path.package(pkg)
}
file.path(path, testdir)
}else{
# try to find a corresponding development package
if( qrequire('devtools') && requireNamespace('devtools')
&& devtools::is.package(pkg <- as.package(x, quiet=TRUE)) ){
devtools::load_all(pkg, TRUE)
file.path(pkg$path, 'inst', testdir)
}else{ # assume x is a path
x
}
}
# check that the path exists
if( !file.exists(path) ){
if( !hasArg(testdir) ){ # try another default
opath <- path
path <- file.path(dirname(path), 'unitTests')
if( !file.exists(path) )
stop("Could not find any default unit test directory ['", opath, "' nor '", path, "'].")
} else {
stop("Unit test directory '", path, "' does not exist")
}
}
message("Running unit tests in: '", path, "'")
# detect unit test framework: RUnit or testthat?
framework <-
if( missing(framework) ) utestFramework(path)
else match.arg(framework)
message("Using unit test framework: ", framework)
# load default patterns
up <- .UFdata[[framework]]
if( missing(filter) ) filter <- up$file_pattern
if( missing(fun) ) fun <- up$fun_pattern
# run tests
path <- normalizePath(path)
# remove/create output directory
opath <- utestPath(package=x)
if( file.exists( opath ) ){
unlink(opath, recursive=TRUE)
}
dir.create(opath, recursive=TRUE)
# copy results in working directory on exit
on.exit(
{ if( file.exists(opath) )
file.copy(opath, '.', recursive=TRUE)
}
, add=TRUE)
#
if( is.dir(path) ){ # all tests in a directory
if( framework == 'RUnit' ){ # RUnit
requireRUnit("Running RUnit test suites")
loadNamespace('RUnit')
s <- RUnit::defineTestSuite(x, path
, testFileRegexp=filter
, testFuncRegexp=fun, ...)
str(s)
utest(s, quiet=quiet, outdir=opath)
}else if( framework == 'testthat' ){ # testthat
mrequire("Running testthat unit test suites", 'testthat')
loadNamespace('testthat')
testthat::test_dir(path, filter=filter, ...)
}
}else{ # single test file
if( framework == 'RUnit' ){ # RUnit
requireRUnit("Running RUnit unit test file")
loadNamespace('RUnit')
RUnit::runTestFile(path, testFuncRegexp=fun, ...)
}else if( framework == 'testthat' ){ # testthat
mrequire("Running testthat unit test file", 'testthat')
loadNamespace('testthat')
testthat::test_file(path, ...)
}
}
}
)
setOldClass('RUnitTestSuite')
#' @describeIn utest Runs a RUnit test suite
#' @param outdir output directory
setMethod('utest', 'RUnitTestSuite',
function(x, ..., quiet=FALSE, outdir=NULL){
requireRUnit("Running RUnit test suites")
loadNamespace('RUnit')
pathReport <- file.path(outdir, str_c("utest.", sub("[:]", "_", x$name)))
t <- system.time({
if( quiet ){
suppressWarnings(suppressMessages(out <- capture.output(
tests <- RUnit::runTestSuite(x, ...)
)))
}else
tests <- RUnit::runTestSuite(x, ...)
})
## Report to stdout and text files
cat("------------------- UNIT TEST SUMMARY ---------------------\n\n")
summary_file <- paste(pathReport, ".Summary.txt", sep="")
RUnit::printTextProtocol(tests, showDetails=FALSE, fileName=summary_file)
# append timing
st <- c("\nTotal execution time\n***************************"
, paste(capture.output(print(t)), collapse="\n"))
write(st, file=summary_file, append=TRUE)
# detailed report
details_file <- paste(pathReport, ".Details.txt", sep="")
RUnit::printTextProtocol(tests, showDetails=TRUE, fileName=details_file)
write(st, file=details_file, append=TRUE)
#
## Report to HTML file
RUnit::printHTMLProtocol(tests, fileName=paste(pathReport, ".html", sep=""))
## Return stop() to cause R CMD check stop in case of
## - failures i.e. FALSE to unit tests or
## - errors i.e. R errors
tmp <- RUnit::getErrors(tests)
if(tmp$nFail > 0 | tmp$nErr > 0) {
# filter failures and errors
test_summary <- capture.output(.summaryRUnit(tests, c('error', 'failure'), print = TRUE))
stop(paste0(test_summary, collapse = "\n"))
# stop(paste("\n\nunit testing failed (#test failures: ", tmp$nFail,
# ", #R errors: ", tmp$nErr, ")\n\n", sep=""))
}
tests
}
)
.summaryRUnit <- function(testData, type = c('error', 'failure', 'deactivated'), print = FALSE){
# taken from printTextProtocol
res <- testData
for (tsName in names(testData)) {
if( print ){
cat("Functions:", testData[[tsName]]$nTestFunc, "|"
, "Errors:", testData[[tsName]]$nErr, "|"
, "Failures:", testData[[tsName]]$nFail, "\n")
}
srcFileRes <- testData[[tsName]][["sourceFileResults"]]
for (i in seq_along(srcFileRes)) {
fname <- basename(names(srcFileRes)[i])
testFuncNames <- names(srcFileRes[[i]])
keep <- integer()
for (j in seq_along(testFuncNames)) {
funcList <- srcFileRes[[i]][[testFuncNames[j]]]
if (funcList$kind %in% type){
keep <- c(keep, j)
if( print ){
if (funcList$kind == "error") {
cat("ERROR in ", fname, "::", testFuncNames[j], ": ", funcList$msg, sep = "")
}
else if (funcList$kind == "failure") {
cat("FAILURE in ", fname, "::", testFuncNames[j], ": ", funcList$msg, sep = "")
}
else if (funcList$kind == "deactivated") {
cat("DEACTIVATED ", fname, "::", testFuncNames[j], ": ", funcList$msg, sep = "")
}
}
}
}
if( length(keep) ) res[[tsName]][["sourceFileResults"]][[i]] <- srcFileRes[[i]][keep]
else res[[tsName]][["sourceFileResults"]] <- res[[tsName]][["sourceFileResults"]][-i]
}
}
invisible(res)
}
#' Unit Tests Result Directory
#'
#' Returns the path to the directory where the results of unit tests are stored.
#' This path is used by \code{\link{utest}} to save unit test results, which are
#' read by \code{\link{makeUnitVignette}} to update the unit test vignette when
#' runnning R CMD check.
#'
#' @param ... extra arguments passed to \code{\link{packagePath}}, e.g., \code{package}.
#'
#' @return The path tot the unit-test results.
#'
#' @export
utestPath <- function(...){
packagePath('tests-results', ...)
}
#uTest <- function(file, fun, ...){
#
# library(RUnit)
# tdir <- packagePath('unitTests')
# ufiles <- list.files(tdir)
#
# get.tfile <- function(file){
# i <- grep(paste(file,"(\\.[rR])?",sep=''), ufiles)
# if( length(i) > 0L ) ufiles[i[1L]]
# else NULL
# }
#
# tfile <- file
# if( is.null(tfile <- get.tfile(tfile)) ){
# tfile <- paste('runit.', file, sep='')
# if( is.null(tfile <- get.tfile(tfile)) ){
# tfile <- paste('testthat.', file, sep='')
# if( is.null(tfile <- get.tfile(tfile)) )
# stop("Could not find test file '", file, "' (nor runit.% or testthat.% versions) in '", tdir, "'")
# }
# }
# tfile <- file.path(tdir, tfile)
#
# if( !missing(fun) ){
# e <- new.env()
# source(tfile, local=e)
# tfun <- fun
# if( !exists(tfun, e, inherits=FALSE) ){
# tfun <- paste('test.', fun, sep='')
# if( !exists(tfun, e, , inherits=FALSE) )
# stop("Could not find test function '", fun, "' (not test.% version) in '", tfile, "'")
# }
# tfun <- gsub(".", "\\.", tfun, fixed=TRUE)
# runTestFile(tfile, testFuncRegexp=str_c("^", tfun, "$"), ...)
# }else
# runTestFile(tfile, ...)
#}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.