[Rcpp-commits] r2129 - in pkg/Rcpp: . R inst inst/include/Rcpp src
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Sep 17 13:30:38 CEST 2010
Author: romain
Date: 2010-09-17 13:30:37 +0200 (Fri, 17 Sep 2010)
New Revision: 2129
Modified:
pkg/Rcpp/NAMESPACE
pkg/Rcpp/R/00_classes.R
pkg/Rcpp/R/Module.R
pkg/Rcpp/inst/ChangeLog
pkg/Rcpp/inst/include/Rcpp/Module.h
pkg/Rcpp/src/Module.cpp
pkg/Rcpp/src/Reference.cpp
Log:
introducing C++Method class at the R level
Modified: pkg/Rcpp/NAMESPACE
===================================================================
--- pkg/Rcpp/NAMESPACE 2010-09-17 09:07:17 UTC (rev 2128)
+++ pkg/Rcpp/NAMESPACE 2010-09-17 11:30:37 UTC (rev 2129)
@@ -1,21 +1,14 @@
useDynLib(Rcpp)
import( methods )
-export(Rcpp.package.skeleton)
+importFrom( utils, capture.output, assignInNamespace, .DollarNames, prompt, packageDescription )
-importFrom( utils, capture.output, assignInNamespace )
-
-exportClasses( Module, "C++Field", "C++Class", "C++Object", "C++Function",
+exportClasses( Module, "C++Field", "C++Method", "C++Class", "C++Object", "C++Function",
"C++Property", "C++ClassRepresentation" )
-export( Module )
-importFrom( utils, .DollarNames, prompt, packageDescription )
S3method( .DollarNames, "C++Object" )
S3method( .DollarNames, "Module" )
-exportMethods( prompt, show )
-## exportMethods( new, .DollarNames )
-exportMethods(.DollarNames)
-exportMethods( referenceMethods )
+exportMethods( prompt, show, .DollarNames, referenceMethods )
-export(setRCppClass)
+export( Module, setRCppClass, Rcpp.package.skeleton )
Modified: pkg/Rcpp/R/00_classes.R
===================================================================
--- pkg/Rcpp/R/00_classes.R 2010-09-17 09:07:17 UTC (rev 2128)
+++ pkg/Rcpp/R/00_classes.R 2010-09-17 11:30:37 UTC (rev 2129)
@@ -38,16 +38,38 @@
)
)
+setRefClass( "C++Method",
+ fieldClasses = 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(
+ invoke = function(obj_xp, ...){
+ .External( "CppMethod__invoke", class_pointer, pointer, obj_xp, ..., PACKAGE = "Rcpp" )
+ }
+ )
+)
+
+
setClass( "C++Class",
representation(
pointer = "externalptr",
module = "externalptr",
- fields = "list"
+ fields = "list",
+ methods = "list"
),
contains = "character"
)
setClass( "C++ClassRepresentation",
- representation( pointer = "externalptr", generator = "refObjectGenerator" ),
+ representation(
+ pointer = "externalptr",
+ generator = "refObjectGenerator",
+ cpp_fields = "list",
+ cpp_methods = "list"
+ ),
contains = "classRepresentation" )
# might not actually use this
Modified: pkg/Rcpp/R/Module.R
===================================================================
--- pkg/Rcpp/R/Module.R 2010-09-17 09:07:17 UTC (rev 2128)
+++ pkg/Rcpp/R/Module.R 2010-09-17 11:30:37 UTC (rev 2129)
@@ -97,6 +97,9 @@
.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, ...){
if(identical(.Object at pointer, .emptyPointer)) {
@@ -185,117 +188,123 @@
return(module)
}
classes <- .Call( "Module__classes_info", xp, PACKAGE = "Rcpp" )
- if( length( classes ) ){
- 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 <- 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 ?
- )
-
- fc <- .Call( "CppClass__property_classes", CLASS at pointer, PACKAGE = "Rcpp" )
- class_names <- names( fc )
-
- # [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
- 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,
- 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 )
-
- setMethod( "initialize",clname, cpp_object_initializer(CLASS) , 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 )
- # }
-
- }
+
+ 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,
+ 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)
+
+ setMethod( "initialize", clname, cpp_object_initializer(CLASS) , where = where )
+
}
module
}
.referenceMethods__cppclass <- function( classDef, where ){
xp <- classDef at pointer
+ cpp_methods <- classDef at cpp_methods
- met <- .Call( "CppClass__methods", xp, PACKAGE = "Rcpp" )
- arity <- .Call( "CppClass__methods_arity", xp, PACKAGE = "Rcpp" )
- voidness <- .Call( "CppClass__methods_voidness", xp, PACKAGE = "Rcpp" )
+ # met <- .Call( "CppClass__methods", xp, PACKAGE = "Rcpp" )
+ # arity <- .Call( "CppClass__methods_arity", xp, PACKAGE = "Rcpp" )
+ # voidness <- .Call( "CppClass__methods_voidness", xp, PACKAGE = "Rcpp" )
- mets <- sapply( met, function( m ){
- # skeleton that gets modified below
- f <- function( ){
- res <- .External( "Class__invoke_method", .self at cppclass , m, .self at pointer, PACKAGE = "Rcpp" )
- res
- }
- 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", .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 = "" ) )
- }
- b[[2]][[3]] <- ext.call
- body( f ) <- b
- }
-
- if( voidness[[m]] ){
- b <- body( f )
- b[[3]] <- quote( invisible( NULL ) )
- body( f ) <- b
- }
-
- f
- } )
+ method_wrapper <- function( METHOD ){
+ here <- environment()
+ eval( substitute(
+ function(...) {
+ res <- MET$invoke( .self at pointer, ... )
+ RES
+ },
+ list(
+ MET = METHOD,
+ RES = if( METHOD$void ) quote(invisible(NULL)) else as.name("res")
+ )
+ ), here )
+ }
+ mets <- sapply( cpp_methods, method_wrapper )
+
+ # mets <- sapply( cpp_methods, function( m ){
+ # # skeleton that gets modified below
+ # f <- function( ){
+ # res <- .External( "Class__invoke_method", .self at cppclass , m, .self at pointer, PACKAGE = "Rcpp" )
+ # res
+ # }
+ # 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", .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 = "" ) )
+ # }
+ # b[[2]][[3]] <- ext.call
+ # body( f ) <- b
+ # }
+ #
+ # if( voidness[[m]] ){
+ # b <- body( f )
+ # b[[3]] <- quote( invisible( NULL ) )
+ # body( f ) <- b
+ # }
+ #
+ # f
+ # } )
# [romain] commenting out fields get/set
# because they are not used anyway, they lose over the default
Modified: pkg/Rcpp/inst/ChangeLog
===================================================================
--- pkg/Rcpp/inst/ChangeLog 2010-09-17 09:07:17 UTC (rev 2128)
+++ pkg/Rcpp/inst/ChangeLog 2010-09-17 11:30:37 UTC (rev 2129)
@@ -1,5 +1,16 @@
2010-09-16 Romain Francois <romain at r-enthusiasts.com>
+ * src/Reference.cpp: new objects are created via a callback to R's new
+ function, as R_do_new_object did always return the same environment
+
+ * R/00_classes.R: new ref class C++Method to represent C++ methods and holding
+ their external pointers directly (same idea as C++Field)
+
+ * inst/include/Rcpp/Module.h: internal support for C++Method (template class
+ S4_CppMethod)
+
+2010-09-16 Romain Francois <romain at r-enthusiasts.com>
+
* R/00_classes.R: moving classes definition here
* inst/Rcpp/Module.h: added C++ class S4_field that builds S4 objects of
Modified: pkg/Rcpp/inst/include/Rcpp/Module.h
===================================================================
--- pkg/Rcpp/inst/include/Rcpp/Module.h 2010-09-17 09:07:17 UTC (rev 2128)
+++ pkg/Rcpp/inst/include/Rcpp/Module.h 2010-09-17 11:30:37 UTC (rev 2129)
@@ -54,6 +54,8 @@
class_Base(const char* name_) : name(name_){} ;
virtual Rcpp::List fields(SEXP){ return Rcpp::List(0); }
+ virtual Rcpp::List getMethods(SEXP){ return Rcpp::List(0); }
+
virtual bool has_method( const std::string& ){
return false ;
}
@@ -66,6 +68,10 @@
virtual SEXP invoke( const std::string&, SEXP, SEXP *, int ){
return R_NilValue ;
}
+ virtual SEXP invoke__( SEXP, SEXP, SEXP *, int ){
+ return R_NilValue ;
+ }
+
virtual Rcpp::CharacterVector method_names(){ return Rcpp::CharacterVector(0) ; }
virtual Rcpp::CharacterVector property_names(){ return Rcpp::CharacterVector(0) ; }
virtual bool property_is_readonly(const std::string& ) throw(std::range_error) { return false ; }
@@ -150,6 +156,18 @@
virtual bool is_void(){ return false ; }
} ;
+template <typename Class>
+class S4_CppMethod : public Rcpp::Reference {
+public:
+ S4_CppMethod( CppMethod<Class>* m, SEXP class_xp ) : Reference( "C++Method" ){
+ field( "void" ) = m->is_void() ;
+ field( "pointer" ) = Rcpp::XPtr< CppMethod<Class> >( m, false ) ;
+ field( "class_pointer" ) = class_xp ;
+
+ }
+} ;
+
+
#include <Rcpp/module/Module_generated_CppMethod.h>
#include <Rcpp/module/Module_generated_Pointer_CppMethod.h>
@@ -173,6 +191,8 @@
field( "cpp_class" ) = p->get_class();
field( "pointer" ) = Rcpp::XPtr< CppProperty<Class> >( p, false ) ;
field( "class_pointer" ) = class_xp ;
+
+
}
} ;
@@ -219,6 +239,19 @@
END_RCPP
}
+ SEXP invoke__( SEXP method_xp, SEXP object, SEXP *args, int nargs ){
+ BEGIN_RCPP
+ method_class* met = reinterpret_cast< method_class* >( EXTPTR_PTR( method_xp ) ) ;
+ // maybe this is not needed as the R side handles it
+ if( met->nargs() > nargs ){
+ Rprintf( "met->nargs() = %d\nnargs=%d\n", met->nargs(), nargs ) ;
+ throw std::range_error( "incorrect number of arguments" ) ;
+ }
+ return met->operator()( XP(object), args );
+ END_RCPP
+ }
+
+
self& AddMethod( const char* name_, method_class* m){
singleton->methods.insert( PAIR( name_,m ) ) ;
if( *name_ == '[' ) singleton->specials++ ;
@@ -362,6 +395,19 @@
return out ;
}
+ Rcpp::List getMethods( SEXP class_xp ){
+ int n = methods.size() ;
+ Rcpp::CharacterVector pnames(n) ;
+ Rcpp::List out(n) ;
+ typename METHOD_MAP::iterator it = methods.begin( ) ;
+ for( int i=0; i<n; i++, ++it){
+ pnames[i] = it->first ;
+ out[i] = S4_CppMethod<Class>( it->second, class_xp ) ;
+ }
+ out.names() = pnames ;
+ return out ;
+ }
+
#include <Rcpp/module/Module_Field.h>
#include <Rcpp/module/Module_Add_Property.h>
Modified: pkg/Rcpp/src/Module.cpp
===================================================================
--- pkg/Rcpp/src/Module.cpp 2010-09-17 09:07:17 UTC (rev 2128)
+++ pkg/Rcpp/src/Module.cpp 2010-09-17 11:30:37 UTC (rev 2129)
@@ -149,6 +149,7 @@
return clazz->newInstance(cargs, nargs ) ;
}
+// Deprecated in favour of the CppMethod__invoke
extern "C" SEXP Class__invoke_method(SEXP args){
SEXP p = CDR(args) ;
@@ -167,6 +168,32 @@
return clazz->invoke( met, obj, cargs, nargs ) ;
}
+extern "C" SEXP CppMethod__invoke(SEXP args){
+ SEXP p = CDR(args) ;
+
+ // the external pointer to the class
+ XP_Class clazz( CAR(p) ) ; p = CDR(p);
+
+ // the external pointer to the method
+ SEXP met = CAR(p) ; p = CDR(p) ;
+
+ // the external pointer to the object
+ SEXP obj = CAR(p); p = CDR(p) ;
+
+ // additional arguments, processed the same way as .Call does
+ SEXP cargs[MAX_ARGS] ;
+ int nargs = 0 ;
+ for(; nargs<MAX_ARGS; nargs++){
+ if( p == R_NilValue ) break ;
+ cargs[nargs] = CAR(p) ;
+ p = CDR(p) ;
+ }
+
+ return clazz->invoke__( met, obj, cargs, nargs ) ;
+}
+
+
+
namespace Rcpp{
static Module* current_scope ;
}
@@ -278,7 +305,7 @@
slot( ".Data" ) = mangled_name ;
slot( "fields" ) = cl->fields( clxp.asSexp() ) ;
-
+ slot( "methods" ) = cl->getMethods( clxp.asSexp() ) ;
}
CppObject::CppObject( Module* p, class_Base* clazz, SEXP xp ) : S4("C++Object") {
Modified: pkg/Rcpp/src/Reference.cpp
===================================================================
--- pkg/Rcpp/src/Reference.cpp 2010-09-17 09:07:17 UTC (rev 2128)
+++ pkg/Rcpp/src/Reference.cpp 2010-09-17 11:30:37 UTC (rev 2129)
@@ -52,8 +52,16 @@
return *this ;
}
- Reference::Reference( const std::string& klass ) throw(S4_creation_error,reference_creation_error) : S4(klass){
- // TODO: check that klass is indeed a reference class
+ Reference::Reference( const std::string& klass ) throw(S4_creation_error,reference_creation_error) : S4(){
+ // using callback to R as apparently R_do_new_object always makes the same environment
+ SEXP call = Rf_lcons(
+ Rf_install( "new" ),
+ Rf_cons(
+ Rf_mkString( klass.c_str() ),
+ R_NilValue
+ )
+ ) ;
+ setSEXP( Rcpp::internal::try_catch( call ) ) ;
}
void Reference::set( SEXP x) throw(not_reference) {
More information about the Rcpp-commits
mailing list