[Rcpp-commits] r979 - in pkg/RcppGsl: R inst inst/include inst/unitTests src
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sun Apr 4 15:18:24 CEST 2010
Author: romain
Date: 2010-04-04 15:18:24 +0200 (Sun, 04 Apr 2010)
New Revision: 979
Added:
pkg/RcppGsl/R/unit.test.R
pkg/RcppGsl/inst/unitTests/
pkg/RcppGsl/inst/unitTests/runTests.R
pkg/RcppGsl/inst/unitTests/runit.gsl.R
Modified:
pkg/RcppGsl/inst/include/RcppGsl.h
pkg/RcppGsl/src/RcppGsl.cpp
Log:
add the typical unit test framework
Added: pkg/RcppGsl/R/unit.test.R
===================================================================
--- pkg/RcppGsl/R/unit.test.R (rev 0)
+++ pkg/RcppGsl/R/unit.test.R 2010-04-04 13:18:24 UTC (rev 979)
@@ -0,0 +1,29 @@
+# Copyright (C) 2010 Romain Francois
+#
+# This file is part of RcppGsl.
+#
+# RcppGsl 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 2 of the License, or
+# (at your option) any later version.
+#
+# RcppGsl 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 RcppGsl. If not, see <http://www.gnu.org/licenses/>.
+
+test <- function( output = if( file.exists( "/tmp" ) ) "/tmp" else getwd() ){
+ if( !file.exists( output ) ){ stop( "output directory does not exist" ) }
+
+ Rscript <- file.path( R.home( component = "bin" ), "Rscript" )
+ if( .Platform$OS.type == "windows" ){
+ Rscript <- sprintf( "%s.exe", Rscript )
+ }
+ test.script <- system.file( "unitTests", "runTests.R", package = "RcppGsl" )
+ cmd <- sprintf( '"%s" "%s" --output=%s', Rscript, test.script, output )
+ system( cmd )
+}
+
Modified: pkg/RcppGsl/inst/include/RcppGsl.h
===================================================================
--- pkg/RcppGsl/inst/include/RcppGsl.h 2010-04-04 13:07:05 UTC (rev 978)
+++ pkg/RcppGsl/inst/include/RcppGsl.h 2010-04-04 13:18:24 UTC (rev 979)
@@ -1,8 +1,6 @@
-// -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; tab-width: 8 -*-
-//
// RcppGsl.h: Rcpp/gsl glue
//
-// Copyright (C) 2010 Dirk Eddelbuettel and Romain Francois
+// Copyright (C) 2010 Romain Francois
//
// This file is part of RcppGsl.
//
Added: pkg/RcppGsl/inst/unitTests/runTests.R
===================================================================
--- pkg/RcppGsl/inst/unitTests/runTests.R (rev 0)
+++ pkg/RcppGsl/inst/unitTests/runTests.R 2010-04-04 13:18:24 UTC (rev 979)
@@ -0,0 +1,88 @@
+pkg <- "RcppArmadillo"
+
+if(require("RUnit", quietly = TRUE)) {
+
+ is_local <- function(){
+ if( exists( "argv", globalenv() ) && "--local" %in% argv ) return(TRUE)
+ if( "--local" %in% commandArgs(TRUE) ) return(TRUE)
+ FALSE
+ }
+ if( is_local() ) path <- getwd()
+
+ library(package=pkg, character.only = TRUE)
+ if(!(exists("path") && file.exists(path)))
+ path <- system.file("unitTests", package = pkg)
+
+ ## --- Testing ---
+
+ ## Define tests
+ testSuite <- defineTestSuite(name=paste(pkg, "unit testing"), dirs = path)
+
+ if(interactive()) {
+ cat("Now have RUnit Test Suite 'testSuite' for package '", pkg,
+ "' :\n", sep='')
+ str(testSuite)
+ cat('', "Consider doing",
+ "\t tests <- runTestSuite(testSuite)", "\nand later",
+ "\t printTextProtocol(tests)", '', sep="\n")
+ } else { ## run from shell / Rscript / R CMD Batch / ...
+ ## Run
+ tests <- runTestSuite(testSuite)
+
+ output <- NULL
+
+ process_args <- function(argv){
+ if( !is.null(argv) && length(argv) > 0 ){
+ rx <- "^--output=(.*)$"
+ g <- grep( rx, argv, value = TRUE )
+ if( length(g) ){
+ sub( rx, "\\1", g[1L] )
+ }
+ }
+ }
+
+ # give a chance to the user to customize where he/she wants
+ # the unit tests results to be stored with the --output= command
+ # line argument
+ if( exists( "argv", globalenv() ) ){
+ # littler
+ output <- process_args(argv)
+ } else {
+ # Rscript
+ output <- process_args(commandArgs(TRUE))
+ }
+
+ # if it did not work, try to use /tmp
+ if( is.null(output) ){
+ if( file.exists( "/tmp" ) ){
+ output <- "/tmp"
+ } else{
+ output <- getwd()
+ }
+ }
+
+ ## Print results
+ output.txt <- file.path( output, sprintf("%s-unitTests.txt", pkg))
+ output.html <- file.path( output, sprintf("%s-unitTests.html", pkg))
+
+ printTextProtocol(tests, fileName=output.txt)
+ message( sprintf( "saving txt unit test report to '%s'", output.txt ) )
+
+ ## Print HTML version to a file
+ ## printHTMLProtocol has problems on Mac OS X
+ if (Sys.info()["sysname"] != "Darwin"){
+ message( sprintf( "saving html unit test report to '%s'", output.html ) )
+ printHTMLProtocol(tests, fileName=output.html)
+ }
+
+ ## stop() if there are any failures i.e. FALSE to unit test.
+ ## This will cause R CMD check to return error and stop
+ if(getErrors(tests)$nFail > 0) {
+ stop("one of the unit tests failed")
+ }
+ }
+} else {
+ cat("R package 'RUnit' cannot be loaded -- no unit tests run\n",
+ "for package", pkg,"\n")
+}
+
Added: pkg/RcppGsl/inst/unitTests/runit.gsl.R
===================================================================
--- pkg/RcppGsl/inst/unitTests/runit.gsl.R (rev 0)
+++ pkg/RcppGsl/inst/unitTests/runit.gsl.R 2010-04-04 13:18:24 UTC (rev 979)
@@ -0,0 +1,24 @@
+#!/usr/bin/r -t
+#
+# Copyright (C) 2010 Romain Francois
+#
+# This file is part of RcppGsl.
+#
+# RcppGsl 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 2 of the License, or
+# (at your option) any later version.
+#
+# RcppGsl 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 RcppGsl. If not, see <http://www.gnu.org/licenses/>.
+
+test.gsl.vector <- function(){
+ res <- .Call( "test_gsl_vector", PACKAGE = "RcppGsl" )
+ checkEquals( res, numeric(10) , msg = "wrap( gsl_vector )" )
+}
+
Modified: pkg/RcppGsl/src/RcppGsl.cpp
===================================================================
--- pkg/RcppGsl/src/RcppGsl.cpp 2010-04-04 13:07:05 UTC (rev 978)
+++ pkg/RcppGsl/src/RcppGsl.cpp 2010-04-04 13:18:24 UTC (rev 979)
@@ -2,6 +2,8 @@
extern "C" SEXP test_gsl_vector(){
gsl_vector * x = gsl_vector_alloc (10);
+ gsl_vector_set_zero( x ) ;
+
Rcpp::NumericVector xx = Rcpp::wrap( *x ) ;
gsl_vector_free (x);
return xx ;
More information about the Rcpp-commits
mailing list