[Rcpp-commits] r1847 - in pkg/Rcpp: . R inst inst/include/Rcpp inst/unitTests man src
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Jul 9 14:04:22 CEST 2010
Author: romain
Date: 2010-07-09 14:04:21 +0200 (Fri, 09 Jul 2010)
New Revision: 1847
Modified:
pkg/Rcpp/NEWS
pkg/Rcpp/R/Module.R
pkg/Rcpp/R/help.R
pkg/Rcpp/inst/ChangeLog
pkg/Rcpp/inst/include/Rcpp/RObject.h
pkg/Rcpp/inst/unitTests/runit.Module.R
pkg/Rcpp/inst/unitTests/runit.S4.R
pkg/Rcpp/man/CppClass-class.Rd
pkg/Rcpp/src/Module.cpp
pkg/Rcpp/src/RObject.cpp
Log:
deal with the .Data slot
Modified: pkg/Rcpp/NEWS
===================================================================
--- pkg/Rcpp/NEWS 2010-07-09 10:49:56 UTC (rev 1846)
+++ pkg/Rcpp/NEWS 2010-07-09 12:04:21 UTC (rev 1847)
@@ -18,6 +18,8 @@
historical Longley data set has been added
o RcppStringVector now uses std::vector<std::string> internally
+
+ o setting the .Data slot of S4 objects did not work properly
0.8.3 2010-06-27
Modified: pkg/Rcpp/R/Module.R
===================================================================
--- pkg/Rcpp/R/Module.R 2010-07-09 10:49:56 UTC (rev 1846)
+++ pkg/Rcpp/R/Module.R 2010-07-09 12:04:21 UTC (rev 1847)
@@ -19,7 +19,10 @@
setOldClass( "C++ObjectS3" )
setClass( "Module", representation( pointer = "externalptr" ) )
-setClass( "C++Class", representation( pointer = "externalptr", module = "externalptr" ) )
+setClass( "C++Class",
+ representation( pointer = "externalptr", module = "externalptr" ),
+ contains = "character"
+ )
setClass( "C++Object",
representation(
module = "externalptr",
Modified: pkg/Rcpp/R/help.R
===================================================================
--- pkg/Rcpp/R/help.R 2010-07-09 10:49:56 UTC (rev 1846)
+++ pkg/Rcpp/R/help.R 2010-07-09 12:04:21 UTC (rev 1847)
@@ -40,4 +40,4 @@
assign( ".tryHelp", th, utils )
lockBinding( ".tryHelp", utils )
}
-
+
Modified: pkg/Rcpp/inst/ChangeLog
===================================================================
--- pkg/Rcpp/inst/ChangeLog 2010-07-09 10:49:56 UTC (rev 1846)
+++ pkg/Rcpp/inst/ChangeLog 2010-07-09 12:04:21 UTC (rev 1847)
@@ -1,3 +1,14 @@
+2010-07-09 Romain Francois <romain at r-enthusiasts.com>
+
+ * src/RObject.cpp: adapt the SlotProxy class to deal with the special
+ case of the .Data slot (slot<- changes the internal SEXP)
+
+ * R/Module.R: the C++Class now inherits from "character", to facilitate
+ S4 method dispatch
+
+ * src/Module.cpp: The CppClass ctor sets the .Data of the C++Class object
+ to an obfuscated name to avoid class names clashes at the R level.
+
2010-07-08 Romain Francois <romain at r-enthusiasts.com>
* inst/include/Rcpp/sugar/functions/head.h: new sugar function : head
Modified: pkg/Rcpp/inst/include/Rcpp/RObject.h
===================================================================
--- pkg/Rcpp/inst/include/Rcpp/RObject.h 2010-07-09 10:49:56 UTC (rev 1846)
+++ pkg/Rcpp/inst/include/Rcpp/RObject.h 2010-07-09 12:04:21 UTC (rev 1847)
@@ -184,7 +184,7 @@
SEXP get() const ;
void set(SEXP x ) const;
} ;
-
+ friend class SlotProxy ;
/**
* extract or set the given attribute
Modified: pkg/Rcpp/inst/unitTests/runit.Module.R
===================================================================
--- pkg/Rcpp/inst/unitTests/runit.Module.R 2010-07-09 10:49:56 UTC (rev 1846)
+++ pkg/Rcpp/inst/unitTests/runit.Module.R 2010-07-09 12:04:21 UTC (rev 1847)
@@ -84,7 +84,7 @@
}
'
- fx <- cppfunction( signature(), "" , include = inc )
+ fx <- cxxfunction( signature(), "" , include = inc, plugin = "Rcpp" )
mod <- Module( "yada", getDynLib(fx) )
checkEquals( mod$bar( 2L ), 4L )
Modified: pkg/Rcpp/inst/unitTests/runit.S4.R
===================================================================
--- pkg/Rcpp/inst/unitTests/runit.S4.R 2010-07-09 10:49:56 UTC (rev 1846)
+++ pkg/Rcpp/inst/unitTests/runit.S4.R 2010-07-09 12:04:21 UTC (rev 1847)
@@ -82,6 +82,14 @@
"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 ;
+ '
)
)
@@ -173,3 +181,10 @@
}
+test.S4.dotdataslot <- function(){
+ setClass( "Foo", contains = "character", representation( x = "numeric" ) )
+ fx <- .rcpp.S4$S4_dotdata
+ foo <- fx( new( "Foo", "bla", x = 10 ) )
+ checkEquals( as.character( foo) , "foooo" )
+}
+
Modified: pkg/Rcpp/man/CppClass-class.Rd
===================================================================
--- pkg/Rcpp/man/CppClass-class.Rd 2010-07-09 10:49:56 UTC (rev 1846)
+++ pkg/Rcpp/man/CppClass-class.Rd 2010-07-09 12:04:21 UTC (rev 1847)
@@ -15,6 +15,7 @@
}
\section{Slots}{
\describe{
+ \item{\code{.Data}:}{mangled name of the class}
\item{\code{pointer}:}{external pointer to the internal infomation}
\item{\code{module}:}{external pointer to the module}
}
Modified: pkg/Rcpp/src/Module.cpp
===================================================================
--- pkg/Rcpp/src/Module.cpp 2010-07-09 10:49:56 UTC (rev 1846)
+++ pkg/Rcpp/src/Module.cpp 2010-07-09 12:04:21 UTC (rev 1847)
@@ -237,8 +237,19 @@
CppClass::CppClass( SEXP x) : S4(x){}
CppClass::CppClass( Module* p, class_Base* cl ) : S4("C++Class") {
+ XP_Class clxp( cl ) ;
+
slot( "module" ) = XP( p, false ) ;
- slot( "pointer" ) = XP_Class( cl ) ;
+ slot( "pointer" ) = clxp ;
+
+ std::string mangled_name( "rcpp_" ) ;
+ char buffer[20] ;
+ sprintf( buffer, "%p", (void*)EXTPTR_PTR(clxp) ) ;
+
+ mangled_name += (const char*) buffer ;
+ mangled_name += "_" ;
+ mangled_name += cl->name ;
+ slot( ".Data" ) = mangled_name ;
}
CppObject::CppObject( Module* p, class_Base* clazz, SEXP xp ) : S4("C++Object") {
Modified: pkg/Rcpp/src/RObject.cpp
===================================================================
--- pkg/Rcpp/src/RObject.cpp 2010-07-09 10:49:56 UTC (rev 1846)
+++ pkg/Rcpp/src/RObject.cpp 2010-07-09 12:04:21 UTC (rev 1847)
@@ -108,11 +108,14 @@
}
void RObject::SlotProxy::set( SEXP x) const {
- internal::try_catch(
- Rf_lcons( Rf_install("slot<-"),
- Rf_cons( parent, Rf_cons( Rf_mkString(slot_name.c_str()),
- Rf_cons( Rf_ScalarLogical(TRUE) ,
- Rf_cons( x , R_NilValue) ) )))) ;
+ SEXP new_obj = PROTECT(
+ internal::try_catch(
+ Rf_lcons( Rf_install("slot<-"),
+ Rf_cons( parent, Rf_cons( Rf_mkString(slot_name.c_str()),
+ Rf_cons( Rf_ScalarLogical(TRUE) ,
+ Rf_cons( x , R_NilValue) ) ))))) ;
+ const_cast<RObject&>(parent).setSEXP( new_obj ) ;
+ UNPROTECT(1) ;
}
SEXP RObject::AttributeProxy::get() const {
More information about the Rcpp-commits
mailing list