[Rcpp-commits] r4325 - in pkg/Rcpp: . inst/unitTests inst/unitTests/cpp
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu May 30 18:01:04 CEST 2013
Author: romain
Date: 2013-05-30 18:01:04 +0200 (Thu, 30 May 2013)
New Revision: 4325
Added:
pkg/Rcpp/inst/unitTests/cpp/Reference.cpp
pkg/Rcpp/inst/unitTests/cpp/S4.cpp
pkg/Rcpp/inst/unitTests/runit.Reference.R
Modified:
pkg/Rcpp/ChangeLog
pkg/Rcpp/inst/unitTests/runit.S4.R
Log:
added Reference unit test
Modified: pkg/Rcpp/ChangeLog
===================================================================
--- pkg/Rcpp/ChangeLog 2013-05-30 14:13:18 UTC (rev 4324)
+++ pkg/Rcpp/ChangeLog 2013-05-30 16:01:04 UTC (rev 4325)
@@ -5,6 +5,10 @@
* include/Rcpp/sugar/functions/is_finite.h : added sugar is_finite function
* include/Rcpp/traits/is_finite.h : added is_finite trait
* unitTests/runit.sugar.R : added test for is_finite
+ * unitTests/cpp/S4.cpp : new cpp file to host S4 unit tests
+ * unitTests/runit.S4.R : rework unit tests to use attributes
+ * unitTests/runit.Reference.R : unit tests for Rcpp::Reference
+ * unitTests/cpp/Reference.cpp : unit tests c++ code
2013-05-26 Dirk Eddelbuettel <edd at debian.org>
Added: pkg/Rcpp/inst/unitTests/cpp/Reference.cpp
===================================================================
--- pkg/Rcpp/inst/unitTests/cpp/Reference.cpp (rev 0)
+++ pkg/Rcpp/inst/unitTests/cpp/Reference.cpp 2013-05-30 16:01:04 UTC (rev 4325)
@@ -0,0 +1,30 @@
+// -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; tab-width: 8 -*-
+//
+// Reference.cpp: Rcpp R/C++ interface class library -- Reference unit tests
+//
+// Copyright (C) 2013 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/>.
+
+#include <Rcpp.h>
+using namespace Rcpp ;
+
+// [[Rcpp::export]]
+std::string runit_Reference_getId(Reference obj) {
+ std::string txt = obj.field("id");
+ return txt;
+}
+
Added: pkg/Rcpp/inst/unitTests/cpp/S4.cpp
===================================================================
--- pkg/Rcpp/inst/unitTests/cpp/S4.cpp (rev 0)
+++ pkg/Rcpp/inst/unitTests/cpp/S4.cpp 2013-05-30 16:01:04 UTC (rev 4325)
@@ -0,0 +1,82 @@
+// -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; tab-width: 8 -*-
+//
+// S4.cpp: Rcpp R/C++ interface class library -- S4 unit tests
+//
+// Copyright (C) 2013 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/>.
+
+#include <Rcpp.h>
+using namespace Rcpp ;
+
+// [[Rcpp::export]]
+List S4_methods( RObject y ){
+ 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 ;
+}
+
+// [[Rcpp::export]]
+void S4_getslots( S4 y){
+ y.slot( "x" ) = 10.0 ;
+ y.slot( "y" ) = 20.0 ;
+}
+
+// [[Rcpp::export]]
+void S4_setslots( S4 y ){
+ y.slot( "foo" ) = 10.0 ;
+}
+
+// [[Rcpp::export]]
+void S4_setslots_2( S4 y){
+ y.slot( "foo" ) ;
+}
+
+// [[Rcpp::export]]
+S4 S4_ctor( std::string cl){
+ return S4( cl );
+}
+
+// [[Rcpp::export]]
+bool S4_is_track(S4 tr){
+ return tr.is("track") ;
+}
+
+// [[Rcpp::export]]
+bool S4_is_trackCurve(S4 tr){
+ return tr.is("trackCurve") ;
+}
+
+// [[Rcpp::export]]
+NumericVector S4_get_slot_x(S4 o){
+ return NumericVector(o.slot("x")) ;
+}
+
+// [[Rcpp::export]]
+CharacterVector S4_get_attr_x(IntegerVector o){
+ return CharacterVector(o.attr("foo")) ;
+}
+
+// [[Rcpp::export]]
+S4 S4_dotdata(S4 foo){
+ foo.slot( ".Data" ) = "foooo" ;
+ return foo ;
+}
+
Added: pkg/Rcpp/inst/unitTests/runit.Reference.R
===================================================================
--- pkg/Rcpp/inst/unitTests/runit.Reference.R (rev 0)
+++ pkg/Rcpp/inst/unitTests/runit.Reference.R 2013-05-30 16:01:04 UTC (rev 4325)
@@ -0,0 +1,41 @@
+#!/usr/bin/r -t
+#
+# Copyright (C) 2013 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) {
+
+.setUp <- function() {
+ sourceCpp(file.path(pathRcppTests, "cpp/Reference.cpp"))
+}
+
+test.Reference <- function(){
+ Instrument <-setRefClass(
+ Class="Instrument",
+ fields=list("id"="character", "description"="character")
+ )
+ Instrument$accessors(c("id", "description"))
+
+ instrument <- Instrument$new(id="AAPL", description="Apple")
+
+ checkEquals( runit_Reference_getId(instrument), "AAPL", msg = ".field" )
+}
+
+
+}
Modified: pkg/Rcpp/inst/unitTests/runit.S4.R
===================================================================
--- pkg/Rcpp/inst/unitTests/runit.S4.R 2013-05-30 14:13:18 UTC (rev 4324)
+++ pkg/Rcpp/inst/unitTests/runit.S4.R 2013-05-30 16:01:04 UTC (rev 4325)
@@ -1,6 +1,6 @@
#!/usr/bin/r -t
#
-# Copyright (C) 2010 -2012 Dirk Eddelbuettel and Romain Francois
+# Copyright (C) 2010 - 2013 Dirk Eddelbuettel and Romain Francois
#
# This file is part of Rcpp.
#
@@ -21,135 +21,40 @@
if (.runThisTest) {
-definitions <- function(){
- 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")); '
- ),
- "S4_dotdata" = list(
- signature( x = "ANY" ),
- '
- S4 foo( x ) ;
- foo.slot( ".Data" ) = "foooo" ;
- return foo ;
- '
- )
- )
-
-}
-
-cxxargs <- function(){
- ifelse(Rcpp:::capabilities()[["initializer lists"]],"-std=c++0x","")
-}
-
.setUp <- function() {
- tests <- ".rcpp.S4"
- if( ! exists( tests, globalenv() )) {
- fun <- Rcpp:::compile_unit_tests(
- definitions(),
- cxxargs = cxxargs()
- )
- assign( tests, fun, globalenv() )
- }
+ sourceCpp(file.path(pathRcppTests, "cpp/S4.cpp"))
}
test.RObject.S4methods <- function(){
- fx <- .rcpp.S4$S4_methods
- setClass("track",
- representation(x="numeric", y="numeric"))
+ setClass("track", representation(x="numeric", y="numeric"))
tr <- new( "track", x = 2, y = 2 )
- checkEquals( fx(tr),
- list( TRUE, TRUE, FALSE, 2.0, 2.0 )
- , msg = "slot management" )
+ checkEquals(
+ S4_methods(tr),
+ list( TRUE, TRUE, FALSE, 2.0, 2.0 ),
+ msg = "slot management" )
- fx <- .rcpp.S4$S4_getslots
- fx( tr )
+ S4_getslots( tr )
checkEquals( tr at x, 10.0 , msg = "slot('x') = 10" )
checkEquals( tr at y, 20.0 , msg = "slot('y') = 20" )
- fx <- .rcpp.S4$S4_setslots
- checkException( fx( tr ), msg = "slot does not exist" )
+ checkException( S4_setslots( tr ), msg = "slot does not exist" )
+ checkException( S4_setslots_2( 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 )
- fx <- cxxfunction( signature( x = "ANY" ),
- 'S4 o(x); return o.slot( "x" ) ;', plugin = "Rcpp" )
- checkEquals( fx( tr ), 2, msg = "S4( SEXP )" )
+ checkEquals( S4_get_slot_x( tr ), 2, msg = "S4( SEXP )" )
+ checkException( S4_get_slot_x( list( x = 2, y = 3 ) ), msg = "not S4" )
+ checkException( S4_get_slot_x( structure( list( x = 2, y = 3 ), class = "track" ) ), msg = "S3 is not S4" )
- 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 <- .rcpp.S4$S4_ctor
- tr <- fx( "track" )
+ tr <- S4_ctor( "track" )
checkTrue( inherits( tr, "track" ) )
checkEquals( tr at x, numeric(0) )
checkEquals( tr at y, numeric(0) )
- checkException( fx( "someclassthatdoesnotexist" ) )
+ checkException( S4_ctor( "someclassthatdoesnotexist" ) )
}
@@ -160,13 +65,11 @@
tr1 <- new( "track", x = 2, y = 3 )
tr2 <- new( "trackCurve", x = 2, y = 3, smooth = 5 )
- fx <- .rcpp.S4$S4_is
- checkTrue( fx( tr1 ), msg = 'track is track' )
- checkTrue( fx( tr2 ), msg = 'trackCurve is track' )
+ checkTrue( S4_is_track( tr1 ), msg = 'track is track' )
+ checkTrue( S4_is_track( tr2 ), msg = 'trackCurve is track' )
- fx <- .rcpp.S4$S4_is_2
- checkTrue( !fx( tr1 ), msg = 'track is not trackCurve' )
- checkTrue( fx( tr2 ), msg = 'trackCurve is trackCurve' )
+ checkTrue( !S4_is_trackCurve( tr1 ), msg = 'track is not trackCurve' )
+ checkTrue( S4_is_trackCurve( tr2 ), msg = 'trackCurve is trackCurve' )
}
@@ -175,8 +78,7 @@
setClass("trackCurve", representation(smooth = "numeric"), contains = "track")
tr1 <- new( "track", x = 2, y = 3 )
- fx <- .rcpp.S4$S4_slotproxy
- checkEquals( fx(tr1), 2, "Vector( SlotProxy ) ambiguity" )
+ checkEquals( S4_get_slot_x(tr1), 2, "Vector( SlotProxy ) ambiguity" )
}
@@ -184,15 +86,13 @@
x <- 1:10
attr( x, "foo" ) <- "bar"
- fx <- .rcpp.S4$S4_attrproxy
- checkEquals( fx(x), "bar", "Vector( AttributeProxy ) ambiguity" )
+ checkEquals( S4_get_attr_x(x), "bar", "Vector( AttributeProxy ) ambiguity" )
}
test.S4.dotdataslot <- function(){
setClass( "Foo", contains = "character", representation( x = "numeric" ) )
- fx <- .rcpp.S4$S4_dotdata
- foo <- fx( new( "Foo", "bla", x = 10 ) )
+ foo <- S4_dotdata( new( "Foo", "bla", x = 10 ) )
checkEquals( as.character( foo) , "foooo" )
}
More information about the Rcpp-commits
mailing list