#############################################################################
#
# XLConnect
# Copyright (C) 2010-2024 Mirai Solutions GmbH
#
# 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 3 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.
#
# You should have received a copy of the GNU General Public License
# along with this program. If not, see <https://www.gnu.org/licenses/>.
#
#############################################################################
#############################################################################
#
# RUnit test-runner script
#
# Author: Martin Studer, Mirai Solutions GmbH
#
#############################################################################
# Set timezone to UTC
# Sys.setenv("TZ" = "UTC")
# Option to determine if full test suite should be run
options("FULL.TEST.SUITE" = Sys.getenv("FULL_TEST_SUITE") == "1")
# Limit number of GC threads; set timezone
j_params <- c("-XX:+UseParallelGC", "-XX:ParallelGCThreads=1", paste0("-Duser.timezone=", Sys.timezone()))
if(!getOption("FULL.TEST.SUITE")) {
j_params = c(j_params, "-XX:ActiveProcessorCount=1")
}
options(java.parameters = j_params)
# Load library built by R CMD check
library(package = "XLConnect", character.only = TRUE)
require(rJava)
rsrc <- function(resource) {
file.path(options()$path.unit.tests, resource)
}
checkNoException <- function(expr) {
res <- try(expr)
checkTrue(!is(res, "try-error"))
}
runUnitTests <- function() {
pkg <- "XLConnect"
if(!getOption("FULL.TEST.SUITE")) {
Sys.setenv("OMP_THREAD_LIMIT" = 1)
}
# RUnit is required for unit testing
if(require("RUnit", quietly = TRUE)) {
if(Sys.getenv("RCMDCHECK") == "FALSE") {
# Path to unit tests for standalone running under Makefile (not R CMD check)
path <- file.path(getwd(), "..", "inst", "unitTests")
} else {
# Path to unit tests for 'R CMD check' and as part of public API
path <- system.file(package = pkg, "unitTests")
}
cat("\nRunning Unit Tests\n")
print(list(WorkingDir = getwd(), PathToUnitTests = path))
# Add path to unit tests as option
# (used by rsrc function in unit tests)
options(path.unit.tests = path)
# Set up and run test suite
Sys.setlocale(category = "LC_NUMERIC", locale = "C")
jlocale = J("java.util.Locale")
jlocale$setDefault(jlocale$US)
orig.opts <- options(encoding = "UTF-8")
TestSuite <- defineTestSuite(paste(pkg, "Test Suite"), dirs = path)
TestResult <- runTestSuite(TestSuite)
options(orig.opts)
# Test protocol files
protocol <- file.path(getwd(), paste(pkg, "Unit_Tests", sep = "_"))
txtProtocol <- paste(protocol, ".txt", sep = "")
htmlProtocol <- paste(protocol, ".html", sep = "")
# Print (summary) test protocol to stdout
printTextProtocol(TestResult, showDetails = FALSE)
# Write detailed test protocol to text file
printTextProtocol(TestResult, showDetails = TRUE, fileName = txtProtocol)
# Write HTML protocol
printHTMLProtocol(TestResult, fileName = htmlProtocol)
# Show HTML Test Protocol
if (interactive()) { browseURL(url = htmlProtocol) }
## 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 <- getErrors(TestResult)
if(tmp$nFail > 0 | tmp$nErr > 0) {
stop(paste("\n\nUnit Testing failed (#test failures: ", tmp$nFail,
", #R errors: ", tmp$nErr, ")\n\n", sep=""))
}
} else {
warning("Cannot run unit tests -- Package 'RUnit' is not available!")
}
invisible()
}
# Run unit tests
runUnitTests()
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.