[Rcpp-commits] r2120 - in pkg/Rcpp: . R tests
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Sep 16 20:37:11 CEST 2010
Author: jmc
Date: 2010-09-16 20:37:11 +0200 (Thu, 16 Sep 2010)
New Revision: 2120
Added:
pkg/Rcpp/tests/modref.R
Modified:
pkg/Rcpp/NAMESPACE
pkg/Rcpp/R/Module.R
Log:
changes to Module(): no new() method; return a generator object for C++ classes, etc.
Modified: pkg/Rcpp/NAMESPACE
===================================================================
--- pkg/Rcpp/NAMESPACE 2010-09-16 18:36:05 UTC (rev 2119)
+++ pkg/Rcpp/NAMESPACE 2010-09-16 18:37:11 UTC (rev 2120)
@@ -13,7 +13,9 @@
S3method( .DollarNames, "C++Object" )
S3method( .DollarNames, "Module" )
exportMethods( prompt, show )
-exportMethods( new, .DollarNames )
+## exportMethods( new, .DollarNames )
+exportMethods(.DollarNames)
exportMethods( referenceMethods )
+export(setRCppClass)
Modified: pkg/Rcpp/R/Module.R
===================================================================
--- pkg/Rcpp/R/Module.R 2010-09-16 18:36:05 UTC (rev 2119)
+++ pkg/Rcpp/R/Module.R 2010-09-16 18:37:11 UTC (rev 2120)
@@ -22,8 +22,31 @@
.Call( "CppField__set", class_xp, field_xp, obj_xp, value, PACKAGE = "Rcpp" )
}
-setGeneric( "new" )
+## setGeneric( "new" )
+## "Module" class as an environment with "pointer", "moduleName", and "packageName"
+## Stands in for a reference class with those fields.
+setClass( "Module", contains = "environment" )
+setClass( "C++Class",
+ representation( pointer = "externalptr", module = "externalptr" ),
+ contains = "character"
+ )
+setClass( "C++ClassRepresentation",
+ representation( pointer = "externalptr", generator = "refObjectGenerator" ),
+ contains = "classRepresentation" )
+setClass( "C++Property" )
+setClass( "C++Object",
+ representation(
+ module = "externalptr",
+ cppclass = "externalptr",
+ pointer = "externalptr"
+ )
+ )
+setClass( "C++Function",
+ representation( pointer = "externalptr" ),
+ contains = "function"
+)
+
internal_function <- function(pointer){
f <- function(xp){
force(xp)
@@ -39,6 +62,11 @@
writeLines( sprintf( "internal C++ function <%s>", externalptr_address(object at pointer) ) )
} )
+setMethod("$", "C++Class", function(x, name) {
+ x <- .getCppGenerator(x)
+ eval.parent(substitute(x$name))
+})
+
## FIXME: should be set to something that will not segfault if accidentally
## called as a module pointer (but one hopes to intercept any such call)
## AND:: curently a bug in identical() fails to return TRUE on externalptr's
@@ -87,7 +115,7 @@
if( isTRUE( res$void ) ) invisible(NULL) else res$result
}
} else if( .Call("Module__has_class", pointer, name, PACKAGE = "Rcpp" ) ){
- .Call( "Module__get_class", pointer, name, PACKAGE = "Rcpp" )
+ .Call( "Module__get_class", pointer, name, PACKAGE = "Rcpp" )
} else{
stop( "no such method or class in module" )
}
@@ -124,9 +152,12 @@
}
setMethod( ".DollarNames", "Module", .DollarNames.Module )
-new_CppObject_xp <- function(Class, ...){
- xp <- .External( "class__newInstance", Class at module, Class at pointer, ..., PACKAGE = "Rcpp" )
- cl <- .Call( "Class__name", Class at pointer, PACKAGE = "Rcpp" )
+## new_CppObject_temp <- function(Class, ...)
+## .new_CppObject_xp(Class at pointer, Class at module, ...)
+
+new_CppObject_xp <- function(module, pointer, ...) {
+ xp <- .External( "class__newInstance", module, pointer, ..., PACKAGE = "Rcpp" )
+ cl <- .Call( "Class__name", pointer, PACKAGE = "Rcpp" )
cpp <- getClass( "C++Object" )
known_cpp_classes <- cpp at subclasses
@@ -136,10 +167,14 @@
list( cl = cl, xp = xp )
}
-setMethod( "new", "C++Class", function(Class,...){
- out <- new_CppObject_xp( Class, ... )
- new( as.character(Class), pointer = out$xp, cppclass = Class at pointer, module = Class at module )
-} )
+## [John] making new() a generic is bad: a commonly used pardigm assumes that all relevant methods come from initialize()
+## Breaks the reference class new() method, & plausibly could fail if a C++ object was a slot of another class
+## changes to initializer below should achieve the desired effect. At some point, we should clean up the 3(!) different class objects
+## associated with each C++ class object. But no rush.
+## setMethod( "new", "C++Class", function(Class,...){
+## out <- new_CppObject_temp( Class, ... )
+## new( as.character(Class), pointer = out$xp, cppclass = Class at pointer, module = Class at module )
+## } )
# MethodInvoker <- function( x, name ){
# function(...){
@@ -148,6 +183,8 @@
# }
# }
+.emptyPointer <- new("externalptr") # used in initializer method for C++ objects
+
Module <- function( module, PACKAGE = getPackageName(where), where = topenv(parent.frame()), mustStart = FALSE ){
if(is(module, "Module")) {
xp <- .getModulePointer(module, FALSE)
@@ -164,6 +201,8 @@
## [romain] I don't think we actually can, external pointers
## are stored as void*, they don't know what they are. Or we could
## perhaps keep a vector of all known module pointers
+ ## [John] One technique is to initialize the pointer to a known value
+ ## and just check whether it's been reset from that (bad) value
xp <- module
moduleName <- .Call( "Module__name", xp )
module <- new("Module", pointer = xp, packageName = PACKAGE,
@@ -209,7 +248,6 @@
sealed = cdef at sealed
# anything else
)
- assignClassDef( interface, classRep, where)
fc <- .Call( "CppClass__property_classes", CLASS at pointer, PACKAGE = "Rcpp" )
class_names <- names( fc )
@@ -223,27 +261,43 @@
fieldPrototypes[[ f ]] <- NA
fieldClasses[[ f ]] <- "ANY"
}
- setRefClass( clname,
+ generator <- setRefClass( clname,
fieldClasses = fieldClasses,
fieldPrototypes = fieldPrototypes ,
contains = "C++Object",
interfaceClasses = classRep,
where = where
)
+ classRep at generator <- generator
+ classDef <- getClass(clname)
+ ## non-public (static) fields in class representation
+ fields <- classDef at fieldPrototypes
+ assign(".pointer", CLASS at pointer, envir = fields)
+ assign(".module", xp, envir = fields)
+ assign(".CppClassName", clname, envir = fields)
+ assignClassDef( interface, classRep, where)
imethods <- referenceMethods( classRep )
-
+
initializer <- function(.Object, ...){
- .Object <- callNextMethod()
+ if(identical(.Object at pointer, .emptyPointer)) {
+ ## [John] is this different: .Call( "CppObject__needs_init", .Object at pointer, PACKAGE = "Rcpp" )
+ fields <- getClass(class(.Object))@fieldPrototypes
+ xp <- new_CppObject_xp(fields$.module, fields$.pointer, ...)
+ .Object at module <- fields$.module
+ .Object at cppclass <- fields$.pointer
+ .Object at pointer <- xp$xp # this doesn't need to be a list; only the xp component is used ? [John]
+ }
+ ## why was this here? [John] .Object <- callNextMethod()
- # why is this not already done ?
+ # why is this not already done? [Because the commented line above just picked up the class prototype - John]
selfEnv <- .Object at .xData
assign( ".self", .Object, envir = selfEnv )
# <hack>
# we replace the prototypes by active bindings that
# call the internal accessors
- try( rm( list = names(fieldClasses), envir = selfEnv ), silent = TRUE )
+ tryCatch( rm( list = names(fieldClasses), envir = selfEnv ), warning = function(e)e, error = function(e) e)
for( prop in names(fieldClasses) ){
caps <- methods:::firstCap( prop )
binding_fun <- function(x){
@@ -263,12 +317,19 @@
makeActiveBinding( prop, binding_fun , selfEnv )
}
# </hack>
- if( .Call( "CppObject__needs_init", .Object at pointer, PACKAGE = "Rcpp" ) ){
- out <- new_CppObject_xp( CLASS, ... )
- .Object at pointer <- out$xp
- .Object at cppclass <- CLASS at pointer
- .Object at module <- CLASS at module
- }
+ ## [John] ?? was the call below supposed to work by picking up the environment
+ ## from the call to Module() and preserving it as the environment of the method so CLASS is defined?
+ ## But the environment will be modified during the call, so CLASS will end up corresponding
+ ## to the last class in the module. Even if that worked, having the test this late means that the version of .Object
+ ## assigned to selfEnv above will not be initialized. (And wasn't) I put a different test at the top
+ ## of Module(), which seems to work. If so, it's
+ ## probablly cleaner to define initializer outside, so its environment is the namespace of Rcpp [John]
+ ## if( .Call( "CppObject__needs_init", .Object at pointer, PACKAGE = "Rcpp" ) ){
+ ## out <- new_CppObject_temp( CLASS, ... )
+ ## .Object at pointer <- out$xp
+ ## .Object at cppclass <- CLASS at pointer
+ ## .Object at module <- CLASS at module
+ ## }
.Object
}
setMethod( "initialize",clname, initializer, where = where )
@@ -436,3 +497,29 @@
}
setMethod( "referenceMethods", "C++ClassRepresentation", .referenceMethods__cppclass )
+
+#### alternative generator
+setRCppClass <- function(cppClass, className, ...,
+ where = topenv(parent.frame())) {
+ pointer <- cppClass at pointer
+ setRefClass(className,
+ fieldClasses = list(pointer = "externalptr",
+ cppClass = "C++Class"),
+ fieldPrototypes = list(pointer = pointer,
+ cppClass = cppClass),
+ fieldReadOnly = c("pointer", "cppClass"),
+ interfaceClasses = cppClass,
+ where = where
+ )
+}
+
+cppInterfaceClass <- function(cppClass)
+ paste("interface", as.character(cppClass), sep = "_")
+
+.getCppGenerator <- function(cppClass) {
+ ## Requires the interface class to exist
+ ## We should guarantee that constructing the C++Class object
+ ## creates the interface class as well.
+ cc = getClass(cppInterfaceClass(cppClass))
+ cc at generator
+}
Added: pkg/Rcpp/tests/modref.R
===================================================================
--- pkg/Rcpp/tests/modref.R (rev 0)
+++ pkg/Rcpp/tests/modref.R 2010-09-16 18:37:11 UTC (rev 2120)
@@ -0,0 +1,46 @@
+ require( Rcpp )
+ if(require( inline )) {
+
+ inc <- '
+
+ class World {
+ public:
+ World() : foo(1), msg("hello") {}
+ void set(std::string msg_) { this->msg = msg_; }
+ std::string greet() { return msg; }
+
+ int foo ;
+ double bar ;
+
+ private:
+ std::string msg;
+ };
+
+ void clearWorld( World* w ){
+ w->set( "" );
+ }
+
+ RCPP_MODULE(yada){
+ using namespace Rcpp ;
+
+ class_<World>( "World" )
+ .method( "greet", &World::greet )
+ .method( "set", &World::set )
+ .method( "clear", &clearWorld )
+
+ .field( "foo", &World::foo )
+ .field_readonly( "bar", &World::bar )
+ ;
+
+ }
+
+ '
+ fx <- inline::cxxfunction( signature(), "" , include = inc, plugin = "Rcpp" )
+
+ mod <- Module( "yada", getDynLib(fx) )
+ World <- mod$World
+
+ww = new(World)
+wg = World$new()
+
+ }
More information about the Rcpp-commits
mailing list