[Rcpp-commits] r1837 - pkg/Rcpp/inst/unitTests
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Jul 8 14:38:30 CEST 2010
Author: romain
Date: 2010-07-08 14:38:30 +0200 (Thu, 08 Jul 2010)
New Revision: 1837
Modified:
pkg/Rcpp/inst/unitTests/runit.Matrix.R
pkg/Rcpp/inst/unitTests/runit.S4.R
Log:
faster runit.S4
Modified: pkg/Rcpp/inst/unitTests/runit.Matrix.R
===================================================================
--- pkg/Rcpp/inst/unitTests/runit.Matrix.R 2010-07-08 12:25:38 UTC (rev 1836)
+++ pkg/Rcpp/inst/unitTests/runit.Matrix.R 2010-07-08 12:38:30 UTC (rev 1837)
@@ -17,7 +17,6 @@
# 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() {
tests <- ".rcpp.Matrix"
if( ! exists( tests, globalenv() )) {
Modified: pkg/Rcpp/inst/unitTests/runit.S4.R
===================================================================
--- pkg/Rcpp/inst/unitTests/runit.S4.R 2010-07-08 12:25:38 UTC (rev 1836)
+++ pkg/Rcpp/inst/unitTests/runit.S4.R 2010-07-08 12:38:30 UTC (rev 1837)
@@ -17,52 +17,107 @@
# 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() {
+ tests <- ".rcpp.S4"
+ if( ! exists( tests, globalenv() )) {
+ ## definition of all the functions at once
+ f <- list(
+ "S4_methods" = list(
+ signature(x = "ANY" ), '
+ RObject y(x) ;
+ List res(5) ;
+ res[0] = y.isS4() ;
+ res[1] = y.hasSlot("x") ;
+ res[2] = y.hasSlot("z") ;
+ res[3] = y.slot("x") ;
+ res[4] = y.slot("y") ;
+ return res ;
+ '
+ ),
+ "S4_getslots" = list(
+ signature(x = "ANY" ), '
+ RObject y(x) ;
+ y.slot( "x" ) = 10.0 ;
+ y.slot( "y" ) = 20.0 ;
+ return R_NilValue ;
+ '
+ ),
+ "S4_setslots" = list(
+ signature(x = "ANY" ), '
+ RObject y(x) ;
+ y.slot( "foo" ) = 10.0 ;
+ return R_NilValue ;
+ '
+ ),
+ "S4_setslots_2" = list(
+ signature(x = "ANY" ), '
+ RObject y(x) ;
+ y.slot( "foo" ) ;
+ return R_NilValue ;
+ '
+ ),
+ "S4_ctor" = list(
+ signature( clazz = "character" ),
+ '
+ std::string cl = as<std::string>( clazz );
+ return S4( cl );
+ '
+ ),
+ "S4_is" = list(
+ signature(tr="ANY"), '
+ S4 o(tr) ;
+ return wrap( o.is( "track" ) ) ;
+ '
+ ),
+ "S4_is_2" = list(
+ signature(tr="ANY"), '
+ S4 o(tr) ;
+ return wrap( o.is( "trackCurve" ) ) ;
+ '
+ ),
+ "S4_slotproxy" = list(
+ signature(tr="ANY"),
+ ' S4 o(tr); return NumericVector(o.slot("x")); '
+ ),
+ "S4_attrproxy" = list(
+ signature(tr="ANY"),
+ ' IntegerVector o(tr); return CharacterVector(o.attr("foo")); '
+ )
+ )
+
+ signatures <- lapply(f, "[[", 1L)
+ bodies <- lapply(f, "[[", 2L)
+ fun <- cxxfunction(signatures, bodies,
+ plugin = "Rcpp",
+ cxxargs = ifelse(Rcpp:::capabilities()[["initializer lists"]],"-std=c++0x",""))
+ getDynLib( fun ) # just forcing loading the dll now
+ assign( tests, fun, globalenv() )
+ }
+}
+
test.RObject.S4methods <- function(){
- funx <- cppfunction(signature(x = "ANY" ), '
- RObject y(x) ;
- List res(5) ;
- res[0] = y.isS4() ;
- res[1] = y.hasSlot("x") ;
- res[2] = y.hasSlot("z") ;
- res[3] = y.slot("x") ;
- res[4] = y.slot("y") ;
- return res ;
- ' )
+ fx <- .rcpp.S4$S4_methods
setClass("track",
representation(x="numeric", y="numeric"))
tr <- new( "track", x = 2, y = 2 )
- checkEquals( funx(tr),
+ checkEquals( fx(tr),
list( TRUE, TRUE, FALSE, 2.0, 2.0 )
, msg = "slot management" )
- funx <- cppfunction(signature(x = "ANY" ), '
- RObject y(x) ;
- y.slot( "x" ) = 10.0 ;
- y.slot( "y" ) = 20.0 ;
- return R_NilValue ;
- ' )
- funx( tr )
+ fx <- .rcpp.S4$S4_getslots
+ fx( tr )
checkEquals( tr at x, 10.0 , msg = "slot('x') = 10" )
checkEquals( tr at y, 20.0 , msg = "slot('y') = 20" )
- funx <- cppfunction(signature(x = "ANY" ), '
- RObject y(x) ;
- y.slot( "foo" ) = 10.0 ;
- return R_NilValue ;
- ' )
- checkException( funx( tr ), msg = "slot does not exist" )
+ fx <- .rcpp.S4$S4_setslots
+ checkException( fx( tr ), msg = "slot does not exist" )
- funx <- cppfunction(signature(x = "ANY" ), '
- RObject y(x) ;
- y.slot( "foo" ) ;
- return R_NilValue ;
- ' )
- checkException( funx( tr ), msg = "slot does not exist" )
+ fx <- .rcpp.S4$S4_setslots_2
+ checkException( fx( tr ), msg = "slot does not exist" )
}
test.S4 <- function(){
-
setClass("track",
representation(x="numeric", y="numeric"))
tr <- new( "track", x = 2, y = 3 )
@@ -73,17 +128,12 @@
checkException( fx( list( x = 2, y = 3 ) ), msg = "not S4" )
checkException( fx( structure( list( x = 2, y = 3 ), class = "track" ) ), msg = "S3 is not S4" )
- fx <- cppfunction( signature( clazz = "character" ),
- '
- std::string cl = as<std::string>( clazz );
- return S4( cl );
- ' )
+ fx <- .rcpp.S4$S4_ctor
tr <- fx( "track" )
checkTrue( inherits( tr, "track" ) )
checkEquals( tr at x, numeric(0) )
checkEquals( tr at y, numeric(0) )
checkException( fx( "someclassthatdoesnotexist" ) )
-
}
@@ -94,17 +144,11 @@
tr1 <- new( "track", x = 2, y = 3 )
tr2 <- new( "trackCurve", x = 2, y = 3, smooth = 5 )
- fx <- cppfunction( signature(tr="ANY"), '
- S4 o(tr) ;
- return wrap( o.is( "track" ) ) ;
- ' )
+ fx <- .rcpp.S4$S4_is
checkTrue( fx( tr1 ), msg = 'track is track' )
checkTrue( fx( tr2 ), msg = 'trackCurve is track' )
- fx <- cppfunction( signature(tr="ANY"), '
- S4 o(tr) ;
- return wrap( o.is( "trackCurve" ) ) ;
- ' )
+ fx <- .rcpp.S4$S4_is_2
checkTrue( !fx( tr1 ), msg = 'track is not trackCurve' )
checkTrue( fx( tr2 ), msg = 'trackCurve is trackCurve' )
@@ -115,9 +159,7 @@
setClass("trackCurve", representation(smooth = "numeric"), contains = "track")
tr1 <- new( "track", x = 2, y = 3 )
- fx <- cppfunction( signature(tr="ANY"),
- ' S4 o(tr); return NumericVector(o.slot("x")); '
- )
+ fx <- .rcpp.S4$S4_slotproxy
checkEquals( fx(tr1), 2, "Vector( SlotProxy ) ambiguity" )
}
@@ -126,9 +168,7 @@
x <- 1:10
attr( x, "foo" ) <- "bar"
- fx <- cppfunction( signature(tr="ANY"),
- ' IntegerVector o(tr); return CharacterVector(o.attr("foo")); '
- )
+ fx <- .rcpp.S4$S4_attrproxy
checkEquals( fx(x), "bar", "Vector( AttributeProxy ) ambiguity" )
}
More information about the Rcpp-commits
mailing list