#!/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" ) )
}
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.