[Rcpp-commits] r231 - in pkg: inst inst/doc inst/examples/RcppInline inst/unitTests src

noreply at r-forge.r-project.org noreply at r-forge.r-project.org
Wed Dec 30 12:03:17 CET 2009


Author: romain
Date: 2009-12-30 12:03:17 +0100 (Wed, 30 Dec 2009)
New Revision: 231

Added:
   pkg/inst/unitTests/runit.RObject.R
   pkg/inst/unitTests/runit.XPTr.R
   pkg/inst/unitTests/runit.exceptions.R
Modified:
   pkg/inst/ChangeLog
   pkg/inst/doc/Makefile
   pkg/inst/examples/RcppInline/external_pointer.r
   pkg/src/RcppExample.cpp
Log:
added some unit tests

Modified: pkg/inst/ChangeLog
===================================================================
--- pkg/inst/ChangeLog	2009-12-30 09:53:38 UTC (rev 230)
+++ pkg/inst/ChangeLog	2009-12-30 11:03:17 UTC (rev 231)
@@ -1,5 +1,11 @@
 2009-12-30  Romain Francois <francoisromain at free.fr>
 
+	* inst/unitTests/runit.RObject.R: new unit tests
+
+	* inst/unitTests/runit.exceptions.R: idem
+
+	* inst/unitTests/runit.XPtr.R: idem
+
 	* man/RcppUnitTests.Rd: shows and link unit test reports generated at
 	build time
 

Modified: pkg/inst/doc/Makefile
===================================================================
--- pkg/inst/doc/Makefile	2009-12-30 09:53:38 UTC (rev 230)
+++ pkg/inst/doc/Makefile	2009-12-30 11:03:17 UTC (rev 231)
@@ -1,5 +1,9 @@
-all: Rcpp-unitTests.html Rcpp-unitTests.pdf
+all: clean Rcpp-unitTests.html Rcpp-unitTests.pdf
 
+clean:
+	rm -fr Rcpp-unitTests.html
+	rm -fr Rcpp-unitTests.pdf
+
 Rcpp-unitTests.html: Rcpp-unitTests.R
 	Rscript --default-packages="Rcpp,RUnit,utils,tools" Rcpp-unitTests.R
 

Modified: pkg/inst/examples/RcppInline/external_pointer.r
===================================================================
--- pkg/inst/examples/RcppInline/external_pointer.r	2009-12-30 09:53:38 UTC (rev 230)
+++ pkg/inst/examples/RcppInline/external_pointer.r	2009-12-30 11:03:17 UTC (rev 231)
@@ -1,6 +1,6 @@
 #!/usr/bin/r -t
 #
-# Copyright (C) 2009 Romain Francois
+# Copyright (C) 2009 - 2010	Romain Francois
 #
 # This file is part of Rcpp.
 #

Added: pkg/inst/unitTests/runit.RObject.R
===================================================================
--- pkg/inst/unitTests/runit.RObject.R	                        (rev 0)
+++ pkg/inst/unitTests/runit.RObject.R	2009-12-30 11:03:17 UTC (rev 231)
@@ -0,0 +1,113 @@
+#!/usr/bin/r -t
+#
+# Copyright (C) 2009 - 2010	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/>.
+
+.setUp <- function(){
+	suppressMessages( require( inline ) )
+}
+
+test.RObject.asDouble <- function(){
+	foo <- '
+	double d = Rcpp::RObject(x).asDouble();
+	return(Rcpp::RObject( 2*d ) );
+	'
+	funx <- cfunction(signature(x="numeric"), foo, 
+		Rcpp=TRUE, verbose=FALSE)
+	checkEquals( funx(2.123), 4.246, msg = "RObject.asDouble()" )
+	checkEquals( funx(2), 4, msg = "RObject.asDouble()" )
+	checkException( funx(x='2'), msg = "RObject.asDouble() can not convert character" )
+	checkException( funx(x=2:3), msg = "RObject.asDouble() expects the vector to be of length 1" )
+	checkEquals( funx(2L), 4.0, msg = "RObject.asDouble()" )
+}
+
+test.RObject.asInt <- function(){
+	foo <- '
+	int i = Rcpp::RObject(x).asInt();
+	return(Rcpp::RObject( 2*i ) ); '
+	funx <- cfunction(signature(x="numeric"), foo, 
+		Rcpp=TRUE, verbose=FALSE)
+	checkEquals( funx(2.123), 4L, msg = "RObject.asInt()" )
+	checkEquals( funx(2), 4L, msg = "RObject.asInt()" )
+	checkEquals( funx(2L), 4.0, msg = "RObject.asInt()" )
+	checkEquals( funx(as.raw(2L)), 4.0, msg = "RObject.asInt()" )
+	checkException( funx(x='2'), msg = "RObject.asInt() can not convert character" )
+	checkException( funx(x=2:3), msg = "RObject.asInt() expects the vector to be of length 1" )
+	
+}
+
+test.RObject.asStdString <- function(){
+	foo <- '
+	std::string s = Rcpp::RObject(x).asStdString();
+	return(Rcpp::RObject( s+s ) );'
+	funx <- cfunction(signature(x="character"), foo, 
+		Rcpp=TRUE, verbose=FALSE)
+	checkEquals( funx("abc"), "abcabc", msg = "RObject.asStdString()" )
+	checkException( funx(NULL), msg = "RObject.asStdString expects string" )
+	checkException( funx(0L), msg = "RObject.asStdString expects string" )
+	checkException( funx(0.1), msg = "RObject.asStdString expects string" )
+	checkException( funx(as.raw(0L)), msg = "RObject.asStdString expects string" )
+	
+	checkException( funx(letters), msg = "RObject.asStdString expects single string" )
+	
+}
+
+test.RObject.asRaw <- function(){
+	foo <- '
+	Rbyte i = Rcpp::RObject(x).asRaw();
+	return(Rcpp::RObject( (Rbyte)(2*i) ) ); '
+	funx <- cfunction(signature(x="raw"), foo, Rcpp=TRUE, verbose=FALSE)
+	checkEquals( funx(1L), as.raw(2L), msg = "RObject.asRaw(integer)" )
+	checkEquals( funx(1.3), as.raw(2L), msg = "RObject.asRaw(numeric)" )
+	checkEquals( funx(as.raw(1)), as.raw(2L), msg = "RObject.asRaw(raw)" )
+	checkException( funx(NULL) , msg = "RObject.asRaw(NULL) -> exception" )
+	checkException( funx("foo") , msg = "RObject.asRaw(character) -> exception" )
+	checkException( funx(1:2), msg = "RObject.asRaw(>1 integer) -> exception" )
+	checkException( funx(1.3), msg = "RObject.asRaw(>1 numeric) -> exception" )
+	checkException( funx(as.raw(1:3)), msg = "RObject.asRaw(>1 raw) -> exception" )
+	checkException( funx(integer(0)), msg = "RObject.asRaw(0 integer) -> exception" )
+	checkException( funx(numeric(0)), msg = "RObject.asRaw(0 numeric) -> exception" )
+	checkException( funx(raw(0)), msg = "RObject.asRaw(0 raw) -> exception" )
+}
+
+test.RObject.asLogical <- function(){
+	foo <- '
+	bool b = Rcpp::RObject(x).asBool();
+	return(Rcpp::RObject( !b ));'
+	funx <- cfunction(signature(x="logical"), foo, Rcpp=TRUE, verbose=FALSE)
+	checkTrue( !funx(TRUE), msg = "RObject::asBool(TRUE) -> true" )
+	checkTrue( funx(FALSE), msg = "RObject::asBool(FALSE) -> false" )
+	checkTrue( !funx(1L), msg = "RObject::asBool(1L) -> true" )
+	checkTrue( funx(0L), msg = "RObject::asBool(0L) -> false" )
+	checkTrue( !funx(1.0), msg = "RObject::asBool(1.0) -> true" )
+	checkTrue( funx(0.0), msg = "RObject::asBool(0.0) -> false" )
+	checkTrue( !funx(as.raw(1)), msg = "RObject::asBool(aw.raw(1)) -> true" )
+	checkTrue( funx(as.raw(0)), msg = "RObject::asBool(as.raw(0)) -> false" )
+	
+	checkException( funx(NULL), msg = "RObject::asBool(NULL) -> exception" )
+	checkException( funx(c(TRUE,FALSE)), msg = "RObject::asBool(>1 logical) -> exception" )
+	checkException( funx(1:2), msg = "RObject::asBool(>1 integer) -> exception" )
+	checkException( funx(1:2+.1), msg = "RObject::asBool(>1 numeric) -> exception" )
+	checkException( funx(as.raw(1:2)), msg = "RObject::asBool(>1 raw) -> exception" )
+	
+	checkException( funx(integer(0)), msg = "RObject.asBool(0 integer) -> exception" )
+	checkException( funx(numeric(0)), msg = "RObject.asBool(0 numeric) -> exception" )
+	checkException( funx(raw(0)), msg = "RObject.asBool(0 raw) -> exception" )
+}
+
+
+

Added: pkg/inst/unitTests/runit.XPTr.R
===================================================================
--- pkg/inst/unitTests/runit.XPTr.R	                        (rev 0)
+++ pkg/inst/unitTests/runit.XPTr.R	2009-12-30 11:03:17 UTC (rev 231)
@@ -0,0 +1,75 @@
+#!/usr/bin/r -t
+#
+# Copyright (C) 2009 - 2010	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/>.
+
+.setUp <- function(){
+	suppressMessages( require( inline ) )
+}
+
+test.XPtr <- function(){
+	
+	funx <- cfunction(signature(), '
+		/* creating a pointer to a vector<int> */
+		std::vector<int>* v = new std::vector<int> ;
+		v->push_back( 1 ) ;
+		v->push_back( 2 ) ;
+		
+		/* wrap the pointer as an external pointer */
+		/* this automatically protected the external pointer from R garbage 
+		   collection until p goes out of scope. */
+		Rcpp::XPtr< std::vector<int> > p(v) ;
+		
+		/* return it back to R, since p goes out of scope after the return 
+		   the external pointer is no more protected by p, but it gets 
+		   protected by being on the R side */
+		return( p ) ;
+	', Rcpp=TRUE, verbose=FALSE)
+	xp <- funx()
+	checkEquals( typeof( xp ), "externalptr", 
+		msg = "checking external pointer creation" )
+	
+	# passing the pointer back to C++
+	funx <- cfunction(signature(x = "externalptr" ), '
+		/* wrapping x as smart external pointer */
+		/* The SEXP based constructor does not protect the SEXP from 
+		   garbage collection automatically, it is already protected 
+		   because it comes from the R side, however if you want to keep 
+		   the Rcpp::XPtr object on the C(++) side
+		   and return something else to R, you need to protect the external
+		   pointer, by using the protect member function */
+		Rcpp::XPtr< std::vector<int> > p(x) ;
+		
+		/* just return the front of the vector as a SEXP */
+		return( Rcpp::RObject( p->front() ) ) ;
+	', Rcpp=TRUE, verbose=FALSE)
+	front <- funx(xp)
+	checkEquals( front, 1L, msg = "check usage of external pointer" )
+Ma}
+
+# this is similar but without inline, the code is included in 
+# the dyn lib. One reason for this is to effectively instanciate one
+# template class Rcpp::XPtr at compile time, so that we know at that
+# point if something is wrong with the code
+test.XPtr.internal <- function(){
+	xp <- .Call( "RcppXPtrExample_create_external_pointer", PACKAGE = "Rcpp" )
+	checkEquals( typeof(xp), "externalptr", msg = "external pointer creation" )
+	
+	back <- .Call( "RcppXPtrExample_get_external_pointer", xp, PACKAGE = "Rcpp" )
+	checkEquals( back, 2L, msg = "external pointer usage" )
+}
+

Added: pkg/inst/unitTests/runit.exceptions.R
===================================================================
--- pkg/inst/unitTests/runit.exceptions.R	                        (rev 0)
+++ pkg/inst/unitTests/runit.exceptions.R	2009-12-30 11:03:17 UTC (rev 231)
@@ -0,0 +1,50 @@
+#!/usr/bin/r -t
+#
+# Copyright (C) 2009 - 2010	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/>.
+
+.setUp <- function(){
+	suppressMessages( require( inline ) )
+}
+
+test.exceptions <- function(){
+	funx <- cfunction(signature(), '
+	throw std::range_error("boom") ;
+	return R_NilValue ;
+	', Rcpp=TRUE, verbose=FALSE)
+	e <- tryCatch(  funx(), "C++Error" = function(e) e )
+	checkTrue( "C++Error" %in% class(e), msg = "exception class C++Error" )
+	checkTrue( "std::range_error" %in% class(e), msg = "exception class std::range_error" )
+	checkEquals( e$message, "boom", msg = "exception message" )
+	
+	# 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" )
+	
+}
+
+
+
+

Modified: pkg/src/RcppExample.cpp
===================================================================
--- pkg/src/RcppExample.cpp	2009-12-30 09:53:38 UTC (rev 230)
+++ pkg/src/RcppExample.cpp	2009-12-30 11:03:17 UTC (rev 231)
@@ -467,7 +467,7 @@
 	v->push_back( 1 ) ;
 	v->push_back( 2 ) ;
 	Rcpp::XPtr< std::vector<int> > p(v) ;
-	return p.asSexp() ;
+	return p ;
 }
 
 RcppExport SEXP RcppXPtrExample_get_external_pointer(SEXP x){



More information about the Rcpp-commits mailing list