tests/run_tests.R

In XLConnect: Excel Connector for R

#############################################################################
#
# 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)
	}
	options(XLConnect.setCustomAttributes = TRUE)

	# 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)
		# only write results in FULL case, CRAN tries to run with readonly filesystem
		if (getOption("FULL.TEST.SUITE")) {
			# 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() && getOption("FULL.TEST.SUITE")) { 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()