[Rcpp-commits] r2124 - in pkg/Rcpp: . R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Sep 17 10:28:20 CEST 2010
Author: romain
Date: 2010-09-17 10:28:20 +0200 (Fri, 17 Sep 2010)
New Revision: 2124
Modified:
pkg/Rcpp/NEWS
pkg/Rcpp/R/Module.R
Log:
moving initializer out and deal with consequences
Modified: pkg/Rcpp/NEWS
===================================================================
--- pkg/Rcpp/NEWS 2010-09-16 19:41:50 UTC (rev 2123)
+++ pkg/Rcpp/NEWS 2010-09-17 08:28:20 UTC (rev 2124)
@@ -1,3 +1,11 @@
+0.8.7 (future)
+
+ o new Rcpp::Reference class, that allows internal manipulation of R 2.12.0
+ reference classes. The class exposes a constructor that takes the name
+ of the target reference class and a field(string) method that implements
+ the proxy pattern to get/set reference fields using callbacks to the
+ R operators "$" and "$<-" in order to preserve the R-level encapsulation
+
0.8.6 2010-09-09
o new macro RCPP_VERSION and Rcpp_Version to allow conditional compiling
Modified: pkg/Rcpp/R/Module.R
===================================================================
--- pkg/Rcpp/R/Module.R 2010-09-16 19:41:50 UTC (rev 2123)
+++ pkg/Rcpp/R/Module.R 2010-09-17 08:28:20 UTC (rev 2124)
@@ -126,15 +126,7 @@
## .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
- if( ! cl %in% names( known_cpp_classes ) ){
- cl <- "C++Object"
- }
- list( cl = cl, xp = xp )
+ .External( "class__newInstance", module, pointer, ..., PACKAGE = "Rcpp" )
}
## [John] making new() a generic is bad: a commonly used pardigm assumes that all relevant methods come from initialize()
@@ -155,6 +147,72 @@
.emptyPointer <- new("externalptr") # used in initializer method for C++ objects
+cpp_object_initializer <- function(CLASS){
+ function(.Object, ...){
+ if(identical(.Object at pointer, .emptyPointer)) {
+ ## [John] is this different: .Call( "CppObject__needs_init", .Object at pointer, PACKAGE = "Rcpp" )
+ ## [Romain] internally it checks against 0
+ ## RCPP_FUNCTION_1( bool, CppObject__needs_init, SEXP xp ){
+ ## return EXTPTR_PTR(xp) == 0 ;
+ ## }
+ ## and since
+ ## > new( "externalptr" )
+ ## <pointer: 0x0>
+ ## I guess this is the same
+
+ fields <- getClass(class(.Object))@fieldPrototypes
+ .Object at module <- fields$.module
+ .Object at cppclass <- fields$.pointer
+ .Object at pointer <- new_CppObject_xp(fields$.module, fields$.pointer, ...)
+ }
+ ## why was this here? [John] .Object <- callNextMethod()
+ ## [Romain] not sure
+
+ # why is this not already done? [Because the commented line above just picked up the class prototype - John]
+ # [romain] ouch !
+ selfEnv <- .Object at .xData
+ assign( ".self", .Object, envir = selfEnv )
+
+ # <hack>
+ # we replace the prototypes by active bindings that
+ # call the internal accessors
+ fields <- CLASS at fields
+ fields_names <- names( fields )
+ tryCatch( rm( list = fields_names, envir = selfEnv ), warning = function(e)e, error = function(e) e)
+ binding_maker <- function( FIELD ){
+ function( x ){
+ .self <- get( ".self", get("envir", sys.frame(-1L) ) )
+ if( missing( x ) ){
+ FIELD$get( .self at pointer )
+ } else {
+ FIELD$set( .self at pointer, x )
+ }
+ }
+ }
+ for( i in seq_along(fields) ){
+ makeActiveBinding( fields_names[i], binding_maker( fields[[i]] ) , selfEnv )
+ }
+ # </hack>
+ ## [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]
+ ## [Romain] Ooops. That exposes a problem in how I test this : with only one class ...
+ ## I guess we can move initializer out
+ ## Done !
+ ## 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
+ }
+}
+
Module <- function( module, PACKAGE = getPackageName(where), where = topenv(parent.frame()), mustStart = FALSE ){
if(is(module, "Module")) {
xp <- .getModulePointer(module, FALSE)
@@ -216,21 +274,18 @@
virtual = TRUE, versionKey = cdef at versionKey,
package = cdef at package,
sealed = cdef at sealed
- # anything else
+ # anything else ?
)
fc <- .Call( "CppClass__property_classes", CLASS at pointer, PACKAGE = "Rcpp" )
class_names <- names( fc )
- fieldClasses <- fieldPrototypes <- fc
- for( f in class_names ){
- # fieldClasses[[ f ]] <- sprintf( "C++Property__%s__%s", clname, fc[[f]] )
- # if( is.null( getClassDef( fieldClasses[[ f ]] ) ) ){
- # setClass( fieldClasses[[ f ]], contains = "C++Property", where = where )
- # }
- # fieldPrototypes[[ f ]] <- new( fieldClasses[[ f ]] )
- fieldPrototypes[[ f ]] <- NA
- fieldClasses[[ f ]] <- "ANY"
- }
+
+ fieldClasses <- rep( list( "ANY" ), length( class_names ) )
+ names( fieldClasses ) <- class_names
+
+ fieldPrototypes <- rep( list( NA ), length( class_names ) )
+ names( fieldPrototypes ) <- class_names
+
generator <- setRefClass( clname,
fieldClasses = fieldClasses,
fieldPrototypes = fieldPrototypes ,
@@ -249,73 +304,7 @@
imethods <- referenceMethods( classRep )
- initializer <- function(.Object, ...){
- if(identical(.Object at pointer, .emptyPointer)) {
- ## [John] is this different: .Call( "CppObject__needs_init", .Object at pointer, PACKAGE = "Rcpp" )
- ## [Romain] internally it checks against 0
- ## RCPP_FUNCTION_1( bool, CppObject__needs_init, SEXP xp ){
- ## return EXTPTR_PTR(xp) == 0 ;
- ## }
- ## and since
- ## > new( "externalptr" )
- ## <pointer: 0x0>
- ## I guess this is the same
-
- 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()
- ## [Romain] not sure
-
- # why is this not already done? [Because the commented line above just picked up the class prototype - John]
- # [romain] ouch !
- selfEnv <- .Object at .xData
- assign( ".self", .Object, envir = selfEnv )
-
- # <hack>
- # we replace the prototypes by active bindings that
- # call the internal accessors
- 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){
- if( missing(x) ){
- GET( )
- } else {
- SET( x )
- }
- }
- e <- new.env()
- e[[ "GET" ]] <- imethods[[ caps$get ]]
- e[[ "SET" ]] <- imethods[[ caps$set ]]
- environment( e[["GET"]] ) <- selfEnv
- environment( e[["SET"]] ) <- selfEnv
- environment( binding_fun ) <- e
-
- makeActiveBinding( prop, binding_fun , selfEnv )
- }
- # </hack>
- ## [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]
- ## [Romain] Ooops. That exposes a problem in how I test this : with only one class ...
- ## I guess we can move initializer out
- ## 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 )
+ setMethod( "initialize",clname, cpp_object_initializer(CLASS) , where = where )
# METHODS <- .Call( "CppClass__methods" , CLASS at pointer , PACKAGE = "Rcpp" )
# if( "[[" %in% METHODS ){
@@ -455,28 +444,34 @@
f
} )
-
- props <- .Call( "CppClass__properties", xp, PACKAGE = "Rcpp" )
- accesors <- lapply( props, function(p){
-
- getter <- function(){
- .Call( "CppClass__get", .self at cppclass, .self at pointer, p, PACKAGE = "Rcpp" )
- }
- body( getter )[[2]][[5]] <- p
-
- setter <- function(value){
- .Call( "CppClass__set", .self at cppclass, .self at pointer, p, value, PACKAGE = "Rcpp" )
- invisible( NULL )
- }
- body( setter )[[2]][[5]] <- p
-
- res <- list( get = getter, set = setter )
- names( res ) <- methods:::firstCap( p )
- res
- } )
-
- c( mets, accesors, recursive = TRUE )
-
+
+ # [romain] commenting out fields get/set
+ # because they are not used anyway, they lose over the default
+ # getters and setters installed by setRefClass
+ # The cpp_object_initializer takes care of setting the field as an
+ # active binding that hooks back internally
+ #
+ # props <- .Call( "CppClass__properties", xp, PACKAGE = "Rcpp" )
+ # accesors <- lapply( props, function(p){
+ #
+ # getter <- function(){
+ # .Call( "CppClass__get", .self at cppclass, .self at pointer, p, PACKAGE = "Rcpp" )
+ # }
+ # body( getter )[[2]][[5]] <- p
+ #
+ # setter <- function(value){
+ # .Call( "CppClass__set", .self at cppclass, .self at pointer, p, value, PACKAGE = "Rcpp" )
+ # invisible( NULL )
+ # }
+ # body( setter )[[2]][[5]] <- p
+ #
+ # res <- list( get = getter, set = setter )
+ # names( res ) <- methods:::firstCap( p )
+ # res
+ # } )
+ #
+ # c( mets, accesors, recursive = TRUE )
+ mets
}
setMethod( "referenceMethods", "C++ClassRepresentation", .referenceMethods__cppclass )
More information about the Rcpp-commits
mailing list