[Rcpp-devel] [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){
_______________________________________________
Rcpp-commits mailing list
Rcpp-commits at lists.r-forge.r-project.org
https://lists.r-forge.r-project.org/cgi-bin/mailman/listinfo/rcpp-commits
More information about the Rcpp-devel
mailing list