inst/unitTests/runit.misc.R

In jjallaire/Rcpp: Seamless R and C++ Integration

#!/usr/bin/r -t
#
# Copyright (C) 2010 - 2012  Dirk Eddelbuettel and Romain Francois
#
# This file is part of Rcpp.
#
# Rcpp 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.
#
# Rcpp 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 Rcpp.  If not, see <http://www.gnu.org/licenses/>.

.runThisTest <- Sys.getenv("RunAllRcppTests") == "yes"

if (.runThisTest) {

definitions <- function(){
    list(
        	"symbol_" = list(
        		signature(),
        		'
				SEXP res = PROTECT( Rf_allocVector( LGLSXP, 4) ) ;
				/* SYMSXP */
				LOGICAL(res)[0] = Symbol( Rf_install("foobar") ).asSexp() == Rf_install("foobar") ? TRUE : FALSE ;

				/* CHARSXP */
				LOGICAL(res)[1] = Symbol( Rf_mkChar("foobar") ).asSexp() == Rf_install("foobar") ? TRUE : FALSE ;

				/* STRSXP */
				LOGICAL(res)[2] = Symbol( Rf_mkString("foobar") ).asSexp() == Rf_install("foobar") ? TRUE : FALSE ;

				/* std::string */
				LOGICAL(res)[3] = Symbol( "foobar" ).asSexp() == Rf_install("foobar") ? TRUE : FALSE ;

				UNPROTECT(1) ; /* res */
				return res ;
				'
        	),
        	"symbol_ctor" = list(
        		signature(x="ANY"),
        		'return Symbol(x);'
        	),
        	"Argument_" = list(
        		signature(),
        		'
				Argument x("x");
				Argument y("y");

				return List::create( x = 2, y = 3 );
    			'
        	),
        	"Dimension_const" = list(
        		signature( ia = "integer" ),
        		'
				simple ss(ia);
				return wrap(ss.nrow());
				'
        	),
        	"evaluator_error" = list(
        		signature(),
        		'
				return Rcpp::Evaluator::run( Rf_lang2( Rf_install("stop"), Rf_mkString( "boom" ) ) ) ;
				'
        	),
        	"evaluator_ok" = list(
        		signature(x="integer"),  '
				return Rcpp::Evaluator::run( Rf_lang2( Rf_install("sample"), x ) ) ;
				'
        	),
        	"exceptions_" = list(
        		signature(), '
				throw std::range_error("boom") ;
				return R_NilValue ;
				'
        	)
        )
}

includes <- function(){
    "

    using namespace std;

	class simple {
	    Rcpp::Dimension dd;
	public:
	    simple(SEXP xp) : dd(xp) {}
	    int nrow() const { return dd[0]; }
	    int ncol() const { return dd[1]; }
	};
	"
}

cxxargs <- function() {
    ifelse(Rcpp:::capabilities()[["initializer lists"]],"-std=c++0x","")
}

.setUp <- function() {
    tests <- ".rcpp.misc"
    if( ! exists( tests, globalenv() )) {
        fun <- Rcpp:::compile_unit_tests(
            definitions(),
            includes = includes(),
            cxxargs = cxxargs()
        )
        assign( tests, fun, globalenv() )
    }
}

test.Symbol <- function(){
	funx <- .rcpp.misc$symbol_
	res <- funx()
	checkTrue( res[1L], msg = "Symbol creation - SYMSXP " )
	checkTrue( res[2L], msg = "Symbol creation - CHARSXP " )
	checkTrue( res[3L], msg = "Symbol creation - STRSXP " )
	checkTrue( res[4L], msg = "Symbol creation - std::string " )
}

test.Symbol.notcompatible <- function(){
	funx <- .rcpp.misc$symbol_ctor
	checkException( funx(funx), msg = "Symbol not compatible with function" )
	checkException( funx(asNamespace("Rcpp")), msg = "Symbol not compatible with environment" )
	checkException( funx(1:10), msg = "Symbol not compatible with integer" )
	checkException( funx(TRUE), msg = "Symbol not compatible with logical" )
	checkException( funx(1.3), msg = "Symbol not compatible with numeric" )
	checkException( funx(as.raw(1) ), msg = "Symbol not compatible with raw" )
}


test.Argument <- function(){
   funx <- .rcpp.misc$Argument_
   checkEquals( funx(), list( x = 2L, y = 3L ) , msg = "Argument")
}

test.Dimension.const <- function(){
	# from the Rcpp-devel thread
	# http://article.gmane.org/gmane.comp.lang.r.rcpp/327
	funx <- .rcpp.misc$Dimension_const
   checkEquals( funx( c(2L, 2L)) , 2L, msg = "testing const operator[]" )

}

test.evaluator.error <- function(){
   funx <- .rcpp.misc$evaluator_error
   checkException( funx(), msg = "Evaluator::run( stop() )" )
}

test.evaluator.ok <- function(){
	funx <- .rcpp.misc$evaluator_ok
	checkEquals( sort(funx(1:10)), 1:10, msg = "Evaluator running fine" )
}

test.exceptions <- function(){
	can.demangle <- Rcpp:::capabilities()[["demangling"]]

	funx <- .rcpp.misc$exceptions_
	e <- tryCatch(  funx(), "C++Error" = function(e) e )
	checkTrue( "C++Error" %in% class(e), msg = "exception class C++Error" )

	if( can.demangle ){
		checkTrue( "std::range_error" %in% class(e), msg = "exception class std::range_error" )
	}
	checkEquals( e$message, "boom", msg = "exception message" )

	if( can.demangle ){
		# same with direct handler
		e <- tryCatch(  funx(), "std::range_error" = function(e) e )
		checkTrue( "C++Error" %in% class(e), msg = "(direct handler) exception class C++Error" )
		checkTrue( "std::range_error" %in% class(e), msg = "(direct handler) exception class std::range_error" )
		checkEquals( e$message, "boom", msg = "(direct handler) exception message" )
	}
	f <- function(){
		try( funx(), silent = TRUE)
		"hello world"
	}
	checkEquals( f(), "hello world", msg = "life continues after an exception" )

}



test.has.iterator <- function(){

	classes <- c( "std::vector<int>", "std::list<int>", "std::deque<int>",
		"std::set<int>", "std::map<std::string,int>",
		"std::pair<std::string,int>",
		"Rcpp::Symbol"
		)
	code <- lapply( classes, function(.){
			sprintf( '
			bool ok = Rcpp::traits::has_iterator< %s >::value ;
			return wrap(ok) ;
			', . )
		} )
	signatures <- rep( list(signature()), 7 )
	names( code ) <- names( signatures ) <- sprintf( "runit_has_iterator_%d", 1:7 )
	fx <- cxxfunction( signatures, code, plugin = "Rcpp" )

	checkTrue( fx$runit_has_iterator_1() , msg = "has_iterator< std::vector<int> >" )
	checkTrue( fx$runit_has_iterator_2() , msg = "has_iterator< std::ist<int> >" )
	checkTrue( fx$runit_has_iterator_3() , msg = "has_iterator< std::deque<int> >" )
	checkTrue( fx$runit_has_iterator_4() , msg = "has_iterator< std::set<int> >" )
	checkTrue( fx$runit_has_iterator_5() , msg = "has_iterator< std::map<string,int> >" )

	checkTrue( ! fx$runit_has_iterator_6(), msg = "has_iterator< std::pair<string,int> >" )
	checkTrue( ! fx$runit_has_iterator_7(), msg = "Rcpp::Symbol" )

}

test.AreMacrosDefined <- function(){
    checkTrue( Rcpp:::areMacrosDefined( "__cplusplus" ) )    
}

}