# dev_mode()
getCollate <- function(packagedir) {
lst <- try(scan(textConnection(read.dcf(file.path(packagedir, 'DESCRIPTION'),
'Collate')), character(0), quiet = TRUE), silent = TRUE)
if (!is(lst, 'try-error') && !is.na(lst) && length(lst)>0){
return(lst)
} else {
return(NULL)
}
}
getCorePackages <- function(ind = 1) {
if (file.exists(R.home('share/make/vars.mk'))) {
fn <- R.home('share/make/vars.mk')
re <- read.table(fn, sep = '=', as.is = TRUE)
re <- scan(text = re[ind, 2], what = 'character', quiet = TRUE)
} else {
# If R installation is different, we can only get information from defaultPackages
re <- options('defaultPackages')[[1]]
}
re
}
# Test packages for code coverage.
#
# A wrapper function providing a convenient way of running reportCoverage
# against multiple source packages.
#
# @param package Vector of package paths, "core" or some the name of a package from
# CRAN and any combination of the above.
# @param clean Boolean. After each iteration should we clean away all variables
# in .GlobalEnv? Default TRUE.
# @param r.ver R version string eg. "R-3.0.2". Default is the current version
# of R.
# @param test.dir String contaning a path to the unit test directory. By
# default the insts/tests folder is used.
# @param ... Any parameters to pass reportCoverage.
# @return A list with two entries.
# The first is a vector of the coverage values and the
# second is an environment with test coverage reports generated by
# \code{reportCoverage} or \code{buildHTMLreport}.
# @details
# Source packages must be available either as a path to the package folder or
# as the name of a package which is downloadable from CRAN.
#
# This is a convenience function that assumes that the tests for all packages
# are in the "inst/tests" folder. If not \code{\link{reportCoverage}} should be
# used with individual packages.
#
# The parameter r.ver is only necessary only if you want to test
# 'core' and cause this function has to download the R source.
# @seealso \code{\link{reportCoverage}}
# @author Mango Solutions \email{support@@mango-solutions.com}
# @export
# @examples
# \dontrun{
# testCoverageWrapper(c('plyr', 'stringr'))
# }
testCoverageWrapper <- function(package, clean = TRUE,
r.ver = paste("R", getRversion(), sep = "-"),
test.dir = "", ...) {
ind <- which(package == 'core')
core.pkg.ind <- which( package %in% getCorePackages() )
if (length(ind)>0 || length(core.pkg.ind)>0) {
xs0 <- package[-union(ind, core.pkg.ind)]
in_dir(tempdir(),
{
if (!file.exists(sprintf('%s.tar.gz', r.ver))) {
download.file(
sprintf("http://cran.r-project.org/src/base/R-3/%s.tar.gz", r.ver),
sprintf('%s.tar.gz', r.ver))
untar(sprintf('%s.tar.gz', r.ver))
}
}
)
if (length(ind)>0) {
package <- c(xs0, file.path(sprintf('%s/%s/src/library', tempdir(), r.ver),
getCorePackages()))
} else {
package <- c(xs0, file.path(sprintf('%s/%s/src/library', tempdir(), r.ver),
package[core.pkg.ind]))
}
}
executionL <- new.env(parent = emptyenv())
old.Global <- ls(all.names = TRUE, envir = .GlobalEnv)
clear.Global <- function() {
lst <- base::ls(all = TRUE, envir = .GlobalEnv)
base::rm(list = lst[! (lst %in% old.Global)], envir = .GlobalEnv)
}
on.exit(clear.Global())
for(i in seq_along(package)) {
if (clean)
clear.Global()
test.result = try(testCoverageWrapper0(package[i],
reportfile = sprintf('coverage_report_%s.html', basename(package[i])),
outputfile = sprintf('trace_%s.txt', basename(package[i])),
unittestdir = test.dir),
silent = T, ...)
assign(basename(package[i]), test.result, envir = executionL)
}
Coverage = as.matrix(eapply(executionL, function(x) {
re = if (is(x, 'try-error')) 0
else sum(x$A[-1, ])/sum(x$A[1, ])
if (is.nan(re)) re = 0
re
}))
colnames(Coverage) = 'Coverage'
re = list(Coverage = Coverage, env = executionL)
re
}
## test x either to be path to source or a package name from CRAN
testCoverageWrapper0 <- function(x, unittestdir, reportfile, ...) {
is.a.dir <- function(x) {
file.exists(x) && file.info(x)$isdir
}
newSkeleton <- function(pkgPath){
# We must ensure 'a' < 'A'; or the sorted files are not in correct order and will met a error
oldlc <- Sys.getlocale('LC_COLLATE')
on.exit(Sys.setlocale('LC_COLLATE', oldlc))
Sys.setlocale('LC_COLLATE', 'C')
f <- function(x) {
l <- list.files(x)
ind <- grep('\\.[RrqQ]$', l)
l <- l[ind]
if (basename(pkgPath) == 'base') {
l <- l[(basename(l) %in% c(
'table.R',
'stop.R',
'warnings.R',
'gl.R',
'outer.R',
'zapsmall.R',
'aperm.R'
))]
}
l <- sort(l)
l
}
f.res <- function(pkg = basename(pkgPath)) {
l <- list.files(system.file('test.resources', package = 'testCoverage'),
full.names = T)
#ind = grep(sprintf('^test\\.%s.*\\.[Rr]$',pkg),basename(l))
#l[ind]
}
re <- list()
stopifnot(is.a.dir(R <- file.path(pkgPath, 'R')))
re$Collate = getCollate(pkgPath)
if (is.null(re$Collate)) {
re$R <- f(R)
} else {
re$R <- re$Collate
}
if (is.a.dir(tests <- file.path(pkgPath, 'tests'))){
re$tests <- f(tests)
}
if (is.a.dir(testthats <- file.path(pkgPath, 'inst/tests'))){
re$testthats <- f(testthats)
}
if (is.a.dir(unittests <- file.path(pkgPath, 'inst/unittests'))){
re$unittests <- f(unittests)
}
if (is.a.dir(additionaltests <- unittestdir)){
re$additionaltests <- f(additionaltests)
}
re$testable <- TRUE
if (basename(pkgPath) %in% getCorePackages()) {
re$extern.tests <- f.res()
} else
if (length(c(re$tests, re$testthats, re$unittests, re$additionaltests)) == 0) {
cat('No test or test that scripts in the package!\n')
re$testable <- FALSE
}
re
}
outpath <- getwd()
on.exit(setwd(outpath))
if (!is.a.dir(x)) {
cat(sprintf('Assuming %s is a package from CRAN.\n', x))
re <-
in_dir(tempdir(), {
if (!is.a.dir(x)) {
fn <- download.packages(x, '.', type = 'source')
untar(fn[2])
} else {
fn <- c(basename(x), x)
}
if (!(s<-newSkeleton(fn[1]))$testable) {
cat(sprintf(" %s is not a testable package\n", x))
return(NULL)
}
b = list(...)
if (!is.null(s$testthats) || !is.null(s$additionaltests)) {
if (is.null(b$htmlwd)) {
if (!is.null(s$testthats))
reportCoverage(
packagename = fn[1], packagedir = fn[1], htmlwd = outpath,
reportfile = paste0(gsub(".html$", "", reportfile),
"_internal.html"), ...)
if (!is.null(s$additionaltests))
reportCoverage(
packagename = fn[1], packagedir = fn[1], htmlwd = outpath,
unittestdir = unittestdir,
reportfile = paste0(gsub(".html$", "", reportfile),
"_additional.html"), ...)
} else {
if (!is.null(s$testthats))
reportCoverage(
packagename = fn[1], packagedir = fn[1],
reportfile = paste0(gsub(".html$", "", reportfile),
"_internal.html"), ...)
if (!is.null(s$additionaltests))
reportCoverage(
packagename = fn[1], packagedir = fn[1], unittestdir = unittestdir,
reportfile = paste0(gsub(".html$", "", reportfile),
"_additional.html"), ...)
}
} else {
sfs <- file.path(fn[1], 'R', s$R)
if (!is.null(s$unittests))
exfs <- file.path(fn[1], 'inst/unittests', s$unittests)
else
if (!is.null(s$extern.tests))
exfs <- s$extern.tests
else
exfs <- file.path(fn[1], 'tests', s$tests)
if (is.null(b$htmlwd))
reportCoverage(packagename = fn[1], htmlwd = outpath,
sourcefiles = sfs,
executionfiles = exfs ,
unittestdir = unittestdir, ...)
else
reportCoverage(packagename = fn[1],
sourcefiles = sfs,
executionfiles = exfs,
unittestdir = unittestdir, ...)
}
})
} else {
if (!(s<-newSkeleton(x))$testable) {
cat(sprintf(" %s is not a testable package\n", x))
return(NULL)
}
in_dir(outpath, { # avoid possible change of working dir, e.g. MASS
if (!is.null(s$testthats) || !is.null(s$additionaltests)) {
if (!is.null(s$testthats)) re <- reportCoverage(packagename = basename(x),
packagedir = x, reportfile = paste0(gsub(".html$", "", reportfile),
"_internal.html"), ...)
if (!is.null(s$additionaltests)) re <- reportCoverage(
packagename = basename(x), packagedir = x, unittestdir = unittestdir,
reportfile = paste0(gsub(".html$", "", reportfile),
"_additional.html"), ...)
} else {
sfs <- file.path(x,'R',s$R)
if (!is.null(s$unittests))
exfs <- file.path(x,'inst/unittests',s$unittests)
else
if (!is.null(s$extern.tests))
exfs <- s$extern.tests
else
exfs <- file.path(x,'tests',s$tests)
re <- reportCoverage(packagename = basename(x),
sourcefiles = sfs,
executionfiles = exfs ,
unittestdir = unittestdir,
#This line will make problem, if we want to set isrunit, we should pass it from ...
#isrunit = TRUE, runitfileregexp = "\\.[rR]$", runitfuncregexp = "^test.+",
...)
}
})
}
invisible(re)
}
is.a.dir <- function(x) {
file.exists(x) && file.info(x)$isdir
}
newSkeleton <- function(pkgPath, unittestdir = NULL){
# We must ensure 'a' < 'A'; or the sorted files are not in correct order and will met a error
oldlc <- Sys.getlocale('LC_COLLATE')
on.exit(Sys.setlocale('LC_COLLATE', oldlc))
Sys.setlocale('LC_COLLATE', 'C')
f <- function(x) {
l <- list.files(x)
ind <- grep('\\.[RrqQ]$', l)
l <- l[ind]
ind <- grep('^testthat.R$', l, invert = TRUE)
l <- l[ind]
if (basename(pkgPath) == 'base') {
l <- l[(basename(l) %in% c(
'table.R',
'stop.R',
'warnings.R',
'gl.R',
'outer.R',
'zapsmall.R',
'aperm.R'
))]
}
l <- sort(l)
if(length(l) == 0)
return(NULL)
else
return(l)
}
f.res <- function(pkg = basename(pkgPath)) {
l <- list.files(system.file('test.resources', package = 'testCoverage'),
full.names = T)
}
re <- list()
stopifnot(is.a.dir(R <- file.path(pkgPath, 'R')))
re$Collate = getCollate(pkgPath)
if (is.null(re$Collate)) {
re$R <- f(R)
} else {
re$R <- re$Collate
}
if (is.a.dir(tests <- file.path(pkgPath, 'tests')))
re$tests <- f(tests)
if (is.a.dir(testthats <- file.path(pkgPath, 'tests/testthat'))) {
re$testthats <- f(testthats)
re$testthatdir <- 'tests/testthat'
} else if (is.a.dir(testthats <- file.path(pkgPath, 'inst/tests'))) {
re$testthats <- f(testthats)
re$testthatdir <- 'inst/tests'
}
if (is.a.dir(unittests <- file.path(pkgPath, 'inst/unittests')))
re$unittests <- f(unittests)
if (!is.null(unittestdir) && is.a.dir(additionaltests <- file.path(pkgPath, unittestdir)))
re$additionaltests <- f(additionaltests)
re$testable <- TRUE
if (basename(pkgPath) %in% getCorePackages()) {
re$extern.tests <- f.res()
} else
if (length(c(re$tests, re$testthats, re$unittests, re$additionaltests)) == 0) {
cat('No test or test that scripts in the package!\n')
re$testable <- FALSE
}
re
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.