[Rcpp-commits] r2141 - in pkg/Rcpp: . R man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Sep 22 12:29:50 CEST 2010
Author: romain
Date: 2010-09-22 12:29:48 +0200 (Wed, 22 Sep 2010)
New Revision: 2141
Modified:
pkg/Rcpp/DESCRIPTION
pkg/Rcpp/NAMESPACE
pkg/Rcpp/R/00_classes.R
pkg/Rcpp/R/01_show.R
pkg/Rcpp/R/02_completion.R
pkg/Rcpp/R/Module.R
pkg/Rcpp/R/zzz.R
pkg/Rcpp/man/CppClass-class.Rd
Log:
commiting john's changes related to rev 52961
Modified: pkg/Rcpp/DESCRIPTION
===================================================================
--- pkg/Rcpp/DESCRIPTION 2010-09-21 15:46:45 UTC (rev 2140)
+++ pkg/Rcpp/DESCRIPTION 2010-09-22 10:29:48 UTC (rev 2141)
@@ -39,4 +39,4 @@
License: GPL (>= 2)
BugReports: http://r-forge.r-project.org/tracker/?atid=637&group_id=155&func=browse
MailingList: Please send questions and comments regarding Rcpp to rcpp-devel at lists.r-forge.r-project.org
-MinimumSvnRev: 52905
+MinimumSvnRev: 52961
Modified: pkg/Rcpp/NAMESPACE
===================================================================
--- pkg/Rcpp/NAMESPACE 2010-09-21 15:46:45 UTC (rev 2140)
+++ pkg/Rcpp/NAMESPACE 2010-09-22 10:29:48 UTC (rev 2141)
@@ -9,7 +9,7 @@
S3method( .DollarNames, "C++Object" )
S3method( .DollarNames, "Module" )
-exportMethods( prompt, show, .DollarNames, referenceMethods )
+exportMethods( prompt, show, .DollarNames )
export(
Module, Rcpp.package.skeleton # , setRCppClass
Modified: pkg/Rcpp/R/00_classes.R
===================================================================
--- pkg/Rcpp/R/00_classes.R 2010-09-21 15:46:45 UTC (rev 2140)
+++ pkg/Rcpp/R/00_classes.R 2010-09-22 10:29:48 UTC (rev 2141)
@@ -16,18 +16,19 @@
# along with Rcpp. If not, see <http://www.gnu.org/licenses/>.
-## "Module" class as an environment with "pointer", "moduleName", and "packageName"
+## "Module" class as an environment with "pointer", "moduleName",
+## "packageName" and "refClassGenerators"
## Stands in for a reference class with those fields.
setClass( "Module", contains = "environment" )
setRefClass( "C++Field",
- fieldClasses = list(
+ fields = list(
pointer = "externalptr",
cpp_class = "character",
read_only = "logical",
class_pointer = "externalptr"
),
- refMethods = list(
+ methods = list(
get = function(obj_xp){
.Call( "CppField__get", class_pointer, pointer, obj_xp, PACKAGE = "Rcpp" )
},
@@ -39,14 +40,14 @@
)
setRefClass( "C++Method",
- fieldClasses = list(
+ fields = list(
pointer = "externalptr",
class_pointer = "externalptr",
void = "logical"
# perhaps something to deal with classes of input and output
# but this needs some work internally before
),
- refMethods = list(
+ methods = list(
invoke = function(obj_xp, ...){
.External( "CppMethod__invoke", class_pointer, pointer, obj_xp, ..., PACKAGE = "Rcpp" )
}
@@ -59,7 +60,8 @@
pointer = "externalptr",
module = "externalptr",
fields = "list",
- methods = "list"
+ methods = "list",
+ generator = "refObjectGenerator"
),
contains = "character"
)
Modified: pkg/Rcpp/R/01_show.R
===================================================================
--- pkg/Rcpp/R/01_show.R 2010-09-21 15:46:45 UTC (rev 2140)
+++ pkg/Rcpp/R/01_show.R 2010-09-22 10:29:48 UTC (rev 2141)
@@ -18,11 +18,13 @@
setMethod( "show", "C++Object", function(object){
env <- as.environment(object)
pointer <- get(".pointer", envir = env)
- if(identical(pointer, .emptyPointer))
- stop("Uninitialized C++ object")
+ # FIXME: .emptyPointer is gone
+ # if(identical(pointer, .emptyPointer))
+ # stop("Uninitialized C++ object")
cppclass <- get(".cppclass", envir = env)
- if(identical(cppclass, .emptyPointer))
- stop("C++ object with unset C++ class pointer")
+ # FIXME: .emptyPointer is gone
+ # if(identical(cppclass, .emptyPointer))
+ # stop("C++ object with unset C++ class pointer")
txt <- sprintf( "C++ object <%s> of class '%s' <%s>",
externalptr_address(pointer),
.Call( "Class__name", cppclass, PACKAGE = "Rcpp" ),
Modified: pkg/Rcpp/R/02_completion.R
===================================================================
--- pkg/Rcpp/R/02_completion.R 2010-09-21 15:46:45 UTC (rev 2140)
+++ pkg/Rcpp/R/02_completion.R 2010-09-22 10:29:48 UTC (rev 2141)
@@ -25,10 +25,11 @@
# do we actually need this or do we get it for free via setRefClass, etc ...
setGeneric( "complete", function(x) standardGeneric("complete") )
setMethod( "complete", "C++Object", function(x){
- xp <- get(".cppclass", envir = as.environment(x))
- if(identical(xp, .emptyPointer))
- stop("C++ object with unset pointer to C++ class")
- .Call( "CppClass__complete" , xp , PACKAGE = "Rcpp" )
+ xp <- get(".cppclass", envir = as.environment(x))
+ # FIXME: implement another test
+ # if(identical(xp, .emptyPointer))
+ # stop("C++ object with unset pointer to C++ class")
+ .Call( "CppClass__complete" , xp , PACKAGE = "Rcpp" )
} )
".DollarNames.C++Object" <- function( x, pattern ){
Modified: pkg/Rcpp/R/Module.R
===================================================================
--- pkg/Rcpp/R/Module.R 2010-09-21 15:46:45 UTC (rev 2140)
+++ pkg/Rcpp/R/Module.R 2010-09-22 10:29:48 UTC (rev 2141)
@@ -28,14 +28,10 @@
}
setMethod("$", "C++Class", function(x, name) {
- x <- .getCppGenerator(x)
+ x <- x at generator
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
-## so for now we initialize the "pointer" to a NULL (!)
.badModulePointer <- NULL
.setModulePointer <- function(module, value) {
@@ -46,15 +42,15 @@
.getModulePointer <- function(module, mustStart = TRUE) {
pointer <- get("pointer", envir = as.environment(module))
if(is.null(pointer) && mustStart) {
-## should be (except for bug noted in identical())
+## should be (except for bug noted in identical())
## if(identical(pointer, .badModulePointer) && mustStart) {
Module(module, mustStart = TRUE) # will either initialize pointer or throw error
pointer <- get("pointer", envir = as.environment(module))
}
pointer
}
-
+
setMethod("initialize", "Module",
function(.Object,
moduleName = "UNKNOWN",
@@ -70,17 +66,19 @@
}
.Object
})
-
+
setMethod( "$", "Module", function(x, name){
pointer <- .getModulePointer(x)
if( .Call( "Module__has_function", pointer, name, PACKAGE = "Rcpp" ) ){
function( ... ) {
res <- .External( "Module__invoke" , pointer, name, ..., PACKAGE = "Rcpp" )
- if( isTRUE( res$void ) ) invisible(NULL) else res$result
+ 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" )
+ value <- .Call( "Module__get_class", pointer, name, PACKAGE = "Rcpp" )
+ value at generator <- get("refClassGenerators",envir=x)[[as.character(value)]]
+ value
} else{
stop( "no such method or class in module" )
}
@@ -90,59 +88,21 @@
.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()
-## 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.
-.emptyPointer <- new("externalptr") # used in initializer method for C++ objects
-
-# [romain] this uses scoping to get access to the fields, but it might not be
-# necessary, we can get them from the C++ClassRepresentation $ cpp_fields
-# field
-cpp_object_initializer <- function(CLASS){
- function(.Object, ...){
- .Object <- callNextMethod(.Object)
- selfEnv <- as.environment(.Object)
- ## generate the C++-side object and store its pointer, etc.
- pointer <- selfEnv$.pointer
- if(is.null(pointer) || identical(pointer, .emptyPointer)) {
- fields <- getClass(class(.Object))@fieldPrototypes
- pointer <- new_CppObject_xp(fields$.module, fields$.pointer, ...)
- assign(".module", fields$.module, envir = selfEnv)
- assign(".pointer", pointer, envir = selfEnv)
- assign(".cppclass", fields$.pointer, envir = selfEnv)
- ## </note> these should not be needed and are being
- ## dropped from the object class
- ## .Object at module <- fields$.module
- ## .Object at cppclass <- fields$.pointer
- ## .Object at pointer <- pointer
- ##</note>
- }
- ## for the C++ fields (only), create active bindings
- fields <- CLASS at fields
- fields_names <- names( fields )
- binding_maker <- function( FIELD ){
- f <- function( x ) NULL
- body(f) <- substitute({
- fieldPtr <- FIELD
- if( missing( x ) ){
- fieldPtr$get( .pointer )
- } else {
- fieldPtr$set( .pointer, x )
- }
- }, list(FIELD = FIELD))
- environment(f) <- selfEnv
- f
- }
- for( i in seq_along(fields) ){
- makeActiveBinding( fields_names[i], binding_maker( fields[[i]] ) , selfEnv )
- }
- .Object
- }
+# class method for $initialize
+cpp_object_initializer <- function(.self, .refClassDef, ...){
+ selfEnv <- as.environment(.self)
+ ## generate the C++-side object and store its pointer, etc.
+ ## access the private fields in the fieldPrototypes env.
+ fields <- .refClassDef at fieldPrototypes
+ pointer <- new_CppObject_xp(fields$.module, fields$.pointer, ...)
+ assign(".module", fields$.module, envir = selfEnv)
+ assign(".pointer", pointer, envir = selfEnv)
+ assign(".cppclass", fields$.pointer, envir = selfEnv)
+ .self
}
-Module <- function( module, PACKAGE = getPackageName(where), where = topenv(parent.frame()), mustStart = FALSE ){
+Module <- function( module, PACKAGE = getPackageName(where), where = topenv(parent.frame()), mustStart = FALSE ) {
if(is(module, "Module")) {
xp <- .getModulePointer(module, FALSE)
if(!missing(PACKAGE))
@@ -151,106 +111,76 @@
PACKAGE <- get("packageName", envir = env)
moduleName <- get("moduleName", envir = env)
}
- else if( identical( typeof( module ), "externalptr" ) ){
- ## [john] Should Module() ever be called with a pointer as argument?
- ## If so, we need a safe check of the pointer's validity
-
- ## [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,
- moduleName = moduleName)
- } else if(is(module, "character")) {
- moduleName <- module
- xp <- .badModulePointer
- module <- new("Module", pointer = xp, packageName = PACKAGE,
- moduleName = moduleName)
+ else if( identical( typeof( module ), "externalptr" ) ){
+ ## [john] Should Module() ever be called with a pointer as argument?
+ ## If so, we need a safe check of the pointer's validity
+
+ ## [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,
+ moduleName = moduleName)
+ } else if(is(module, "character")) {
+ moduleName <- module
+ xp <- .badModulePointer
+ module <- new("Module", pointer = xp, packageName = PACKAGE,
+ moduleName = moduleName)
+ }
+ if(identical(xp, .badModulePointer)) {
+ if(mustStart) {
+ name <- sprintf( "_rcpp_module_boot_%s", moduleName )
+ symbol <- tryCatch(getNativeSymbolInfo( name, PACKAGE ),
+ error = function(e)e)
+ if(is(symbol, "error"))
+ stop(gettextf("Failed to initialize module pointer: %s",
+ symbol), domain = NA)
+ xp <- .Call( symbol )
+ .setModulePointer(module, xp)
}
- if(identical(xp, .badModulePointer)) {
- if(mustStart) {
- name <- sprintf( "_rcpp_module_boot_%s", moduleName )
- symbol <- tryCatch(getNativeSymbolInfo( name, PACKAGE ),
- error = function(e)e)
- if(is(symbol, "error"))
- stop(gettextf("Failed to initialize module pointer: %s",
- symbol), domain = NA)
- xp <- .Call( symbol )
- .setModulePointer(module, xp)
- }
- else
- return(module)
- }
- classes <- .Call( "Module__classes_info", xp, PACKAGE = "Rcpp" )
-
+ else
+ return(module)
+ }
+ classes <- .Call( "Module__classes_info", xp, PACKAGE = "Rcpp" )
+
+ ## We need a general strategy for assigning class defintions
+ ## since delaying the initialization of the module causes
+ ## where to be the Rcpp namespace:
+ if(environmentIsLocked(where))
+ where <- .GlobalEnv # or???
+ generators <- list()
for( i in seq_along(classes) ){
- ## We need a general strategy for assigning class defintions
- ## since delaying the initialization of the module causes
- ## where to be the Rcpp namespace:
- if(environmentIsLocked(where))
- where <- .GlobalEnv # or???
CLASS <- classes[[i]]
clname <- as.character(CLASS)
-
- interface <- cppInterfaceClass( clname )
- setClass( interface, where = where )
- cdef <- getClassDef( interface, where = where )
- classRep <- new( "C++ClassRepresentation",
- # grab the data from the generated classRepresentation
- className = cdef at className,
- virtual = TRUE,
- versionKey = cdef at versionKey,
- package = cdef at package,
- sealed = cdef at sealed,
-
- # Rcpp specific information
- pointer = CLASS at pointer,
- cpp_fields = CLASS at fields,
- cpp_methods = CLASS at methods
- # anything else ?
- )
-
- ## [romain] perhaps we should have something like "C++Property"
- ## instead of "ANY" with appropriate setAs/setIs methods
- ## or maybe change setRefClass so that it takes a "refFields"
- ## argument instead of the trio fieldClasses, fieldPrototypes, fieldReadOnly
- fc <- .Call( "CppClass__property_classes", CLASS at pointer, PACKAGE = "Rcpp" )
- class_names <- names( fc )
-
- 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 ,
- contains = "C++Object",
- interfaceClasses = classRep,
+
+ fields <- cpp_fields( CLASS, where )
+ methods <- cpp_refMethods(CLASS at pointer, CLASS at methods, where)
+ generator <- setRefClass( clname,
+ fields = fields,
+ contains = "C++Object",
+ methods = methods,
where = where
)
- classRep at generator <- generator
+ generator$methods(initialize = function(...) Rcpp:::cpp_object_initializer(.self,.refClassDef, ...))
classDef <- getClass(clname)
## non-public (static) fields in class representation
+ ## <fixme> Should these become real fields? </fixme>
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)
-
- setMethod( "initialize", clname, cpp_object_initializer(CLASS) , where = where )
-
+ generators[[clname]] <- generator
}
+ module$refClassGenerators <- generators
module
}
-.referenceMethods__cppclass <- function( classDef, where ){
- xp <- classDef at pointer
- cpp_methods <- classDef at cpp_methods
+## create a named list of the R methods to invoke C++ methods
+## from the C++ class with pointer xp
+cpp_refMethods <- function(xp, cpp_methods, where) {
method_wrapper <- function( METHOD ){
here <- environment()
@@ -258,68 +188,32 @@
function(...) {
res <- MET$invoke( .pointer, ... )
RES
- },
- list(
- MET = METHOD,
+ },
+ list(
+ MET = METHOD,
RES = if( METHOD$void ) quote(invisible(NULL)) else as.name("res")
)
), here )
}
mets <- sapply( cpp_methods, method_wrapper )
-
- # [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 )
-
-#### 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
- )
+binding_maker <- function( FIELD, where ){
+ f <- function( x ) NULL
+ body(f) <- substitute({
+ fieldPtr <- FIELD
+ if( missing( x ) ){
+ fieldPtr$get( .pointer )
+ } else {
+ fieldPtr$set( .pointer, x )
+ }
+ }, list(FIELD = FIELD))
+ environment(f) <- where
+ f
}
-
-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
+
+cpp_fields <- function( CLASS, where){
+ sapply( CLASS at fields, binding_maker, where = where )
}
+
Modified: pkg/Rcpp/R/zzz.R
===================================================================
--- pkg/Rcpp/R/zzz.R 2010-09-21 15:46:45 UTC (rev 2140)
+++ pkg/Rcpp/R/zzz.R 2010-09-22 10:29:48 UTC (rev 2141)
@@ -19,7 +19,7 @@
install_help_workaround()
minimum_svn_rev <- as.integer( packageDescription( pkgname )[["MinimumSvnRev"]] )
- if( minimum_svn_rev < R.version[["svn rev"]] ){
+ if( R.version[["svn rev"]] < minimum_svn_rev ){
packageStartupMessage("R version too old for full use of reference methods" )
}
}
Modified: pkg/Rcpp/man/CppClass-class.Rd
===================================================================
--- pkg/Rcpp/man/CppClass-class.Rd 2010-09-21 15:46:45 UTC (rev 2140)
+++ pkg/Rcpp/man/CppClass-class.Rd 2010-09-22 10:29:48 UTC (rev 2141)
@@ -20,6 +20,7 @@
\item{\code{module}:}{external pointer to the module}
\item{\code{fields}:}{list of \linkS4class{C++Field} objects}
\item{\code{methods}:}{list of \linkS4class{C++Method} objects}
+ \item{generator}{the generator object for the class}
}
}
\section{Methods}{
More information about the Rcpp-commits
mailing list