[Rcpp-commits] r2109 - in pkg/Rcpp: . R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Sep 15 10:45:09 CEST 2010
Author: romain
Date: 2010-09-15 10:45:09 +0200 (Wed, 15 Sep 2010)
New Revision: 2109
Modified:
pkg/Rcpp/NAMESPACE
pkg/Rcpp/R/Module.R
Log:
introducing C++ClassRepresentation and silly hacks :-(
Modified: pkg/Rcpp/NAMESPACE
===================================================================
--- pkg/Rcpp/NAMESPACE 2010-09-14 20:30:51 UTC (rev 2108)
+++ pkg/Rcpp/NAMESPACE 2010-09-15 08:45:09 UTC (rev 2109)
@@ -5,7 +5,8 @@
importFrom( utils, capture.output, assignInNamespace )
-exportClasses( Module, "C++Class", "C++Object", "C++Function" )
+exportClasses( Module, "C++Class", "C++Object", "C++Function",
+ "C++Property", "C++ClassRepresentation" )
export( Module )
importFrom( utils, .DollarNames, prompt, packageDescription )
Modified: pkg/Rcpp/R/Module.R
===================================================================
--- pkg/Rcpp/R/Module.R 2010-09-14 20:30:51 UTC (rev 2108)
+++ pkg/Rcpp/R/Module.R 2010-09-15 08:45:09 UTC (rev 2109)
@@ -24,6 +24,10 @@
representation( pointer = "externalptr", module = "externalptr" ),
contains = "character"
)
+setClass( "C++ClassRepresentation",
+ representation( pointer = "externalptr" ),
+ contains = "classRepresentation" )
+setClass( "C++Property" )
setClass( "C++Object",
representation(
module = "externalptr",
@@ -160,27 +164,27 @@
}
}
-dollar_cppobject <- function(x, name){
- if( .Call( "Class__has_method", x at cppclass, name, PACKAGE = "Rcpp" ) ){
- MethodInvoker( x, name )
- } else if( .Call("Class__has_property", x at cppclass, name, PACKAGE = "Rcpp" ) ) {
- .Call( "CppClass__get", x at cppclass, x at pointer, name, PACKAGE = "Rcpp" )
- } else {
- stop( "no such method or property" )
- }
-}
+# dollar_cppobject <- function(x, name){
+# if( .Call( "Class__has_method", x at cppclass, name, PACKAGE = "Rcpp" ) ){
+# MethodInvoker( x, name )
+# } else if( .Call("Class__has_property", x at cppclass, name, PACKAGE = "Rcpp" ) ) {
+# .Call( "CppClass__get", x at cppclass, x at pointer, name, PACKAGE = "Rcpp" )
+# } else {
+# stop( "no such method or property" )
+# }
+# }
+#
+# setMethod( "$", "C++Object", dollar_cppobject )
+#
+# dollargets_cppobject <- function(x, name, value){
+# if( .Call("Class__has_property", x at cppclass, name, PACKAGE = "Rcpp" ) ){
+# .Call( "CppClass__set", x at cppclass, x at pointer, name, value, PACKAGE = "Rcpp" )
+# }
+# x
+# }
+#
+# setReplaceMethod( "$", "C++Object", dollargets_cppobject )
-setMethod( "$", "C++Object", dollar_cppobject )
-
-dollargets_cppobject <- function(x, name, value){
- if( .Call("Class__has_property", x at cppclass, name, PACKAGE = "Rcpp" ) ){
- .Call( "CppClass__set", x at cppclass, x at pointer, name, value, PACKAGE = "Rcpp" )
- }
- x
-}
-
-setReplaceMethod( "$", "C++Object", dollargets_cppobject )
-
Module <- function( module, PACKAGE = getPackageName(where), where = topenv(parent.frame()), mustStart = FALSE ){
if(is(module, "Module")) {
xp <- .getModulePointer(module, FALSE)
@@ -231,31 +235,90 @@
where <- .GlobalEnv # or???
CLASS <- classes[[i]]
clname <- as.character(CLASS)
- setClass( clname, contains = "C++Object", where = where )
- setMethod( "initialize",clname, function(.Object, ...){
+
+ interface <- sprintf( "interface_%s", clname )
+ setClass( interface, where = where )
+ cdef <- getClassDef( interface, where = where )
+ classRep <- new( "C++ClassRepresentation",
+ pointer = CLASS at pointer, className = cdef at className,
+ virtual = TRUE, versionKey = cdef at versionKey,
+ package = cdef at package,
+ sealed = cdef at sealed
+ # anything else
+ )
+ assignClassDef( interface, classRep, where)
+
+ 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 ]] )
+ }
+ setRefClass( clname,
+ fieldClasses = fieldClasses,
+ fieldPrototypes = fieldPrototypes ,
+ contains = "C++Object",
+ interfaceClasses = classRep,
+ where = where
+ )
+
+ imethods <- referenceMethods( classRep )
+
+ initializer <- function(.Object, ...){
.Object <- callNextMethod()
+
+ # why is this not already done ?
+ selfEnv <- .Object at .xData
+ assign( ".self", .Object, envir = selfEnv )
+
+ # <hack>
+ rm( list = names(fieldClasses), envir = selfEnv )
+ 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>
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
+ .Object at pointer <- out$xp
+ .Object at cppclass <- CLASS at pointer
+ .Object at module <- CLASS at module
}
.Object
- } , where = where )
-
- METHODS <- .Call( "CppClass__methods" , CLASS at pointer , PACKAGE = "Rcpp" )
- if( "[[" %in% METHODS ){
- setMethod( "[[", clname, function(x, i, j, ...){
- MethodInvoker( x, "[[" )( i )
- }, where = where )
}
+ setMethod( "initialize",clname, initializer, where = where )
- if( "[[<-" %in% METHODS ){
- setReplaceMethod( "[[", clname, function(x, i, j, ..., exact = TRUE, value ){
- MethodInvoker( x, "[[<-" )( i, value )
- x
- }, where = where )
- }
+ # METHODS <- .Call( "CppClass__methods" , CLASS at pointer , PACKAGE = "Rcpp" )
+ # if( "[[" %in% METHODS ){
+ # setMethod( "[[", clname, function(x, i, j, ...){
+ # MethodInvoker( x, "[[" )( i )
+ # }, where = where )
+ # }
+ #
+ # if( "[[<-" %in% METHODS ){
+ # setReplaceMethod( "[[", clname, function(x, i, j, ..., exact = TRUE, value ){
+ # MethodInvoker( x, "[[<-" )( i, value )
+ # x
+ # }, where = where )
+ # }
}
}
@@ -350,19 +413,22 @@
mets <- sapply( met, function( m ){
# skeleton
f <- function( ){
- res <- .External( "Class__invoke_method", xp , m, .self at pointer, PACKAGE = "Rcpp" )
+ res <- .External( "Class__invoke_method", .self at cppclass , m, .self at pointer, PACKAGE = "Rcpp" )
# TODO: update Class__invoke_method so that it does not create a list
# list( void, result ) since we already know that information
res$result
}
+ body( f )[[2]][[3]][[4]] <- m
+
if( ar <- arity[[ m ]] ){
# change the formal arguments
formals( f ) <- structure( rep( alist( . = ), ar ), names = sprintf( "x%d", seq_len(ar) ) )
# change the body
b <- body( f )
- ext.call <- quote( .External( "Class__invoke_method", PACKAGE="Rcpp", xp, m, .self at pointer, ARG) )[ c(1:6, rep(7L, ar )) ]
+ ext.call <- quote( .External( "Class__invoke_method", PACKAGE="Rcpp", .self at cppclass, m, .self at pointer, ARG) )[ c(1:6, rep(7L, ar )) ]
+ ext.call[[5]] <- m
for( i in seq_len(ar) ){
ext.call[[ 6 + i ]] <- as.name( paste( "x", i, sep = "" ) )
}
@@ -383,13 +449,15 @@
accesors <- lapply( props, function(p){
getter <- function(){
- .Call( "CppClass__get", xp, .self at pointer, p, PACKAGE = "Rcpp" )
+ .Call( "CppClass__get", .self at cppclass, .self at pointer, p, PACKAGE = "Rcpp" )
}
+ body( getter )[[2]][[5]] <- p
setter <- function(value){
- .Call( "CppClass__set", xp, .self at pointer, p, value, PACKAGE = "Rcpp" )
+ .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 )
@@ -399,7 +467,5 @@
c( mets, accesors, recursive = TRUE )
}
-setMethod( "referenceMethods", "C++Class", .referenceMethods__cppclass )
+setMethod( "referenceMethods", "C++ClassRepresentation", .referenceMethods__cppclass )
-
-
More information about the Rcpp-commits
mailing list