[Rcpp-commits] r1361 - in pkg/Rcpp: R src

[noreply at r-forge.r-project.org]

Author: romain
Date: 2010-05-29 11:21:00 +0200 (Sat, 29 May 2010)
New Revision: 1361

Modified:
   pkg/Rcpp/R/Module.R
   pkg/Rcpp/src/Module.cpp
Log:
support for creating a C++Object using the name of the class instead of the C++Class object

Modified: pkg/Rcpp/R/Module.R
===================================================================
--- pkg/Rcpp/R/Module.R	2010-05-29 08:15:46 UTC (rev 1360)
+++ pkg/Rcpp/R/Module.R	2010-05-29 09:21:00 UTC (rev 1361)
@@ -17,6 +17,8 @@
 
 setGeneric( "new" )
 
+internal.classes <- environment()
+
 setClass( "Module", representation( pointer = "externalptr" ) )
 setClass( "C++Class", representation( pointer = "externalptr", module = "externalptr" ) )
 setClass( "C++Object", representation( module = "externalptr", cppclass = "externalptr", pointer = "externalptr" ) )
@@ -49,7 +51,7 @@
 	writeLines( txt )
 } )
 
-setMethod( "new", "C++Class", function(Class, ...){
+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" )
 	
@@ -58,7 +60,12 @@
 	if( ! cl %in% names( known_cpp_classes ) ){
 		cl <- "C++Object"
 	}
-	new( cl, pointer = xp, cppclass = Class at pointer, module = Class at module )
+	list( cl = cl, xp = xp )
+}
+
+setMethod( "new", "C++Class", function(Class,...){
+	out <- new_CppObject_xp( Class, ... )
+	new( out$cl, pointer = out$xp, cppclass = Class at pointer, module = Class at module )
 } )
 
 dollar_cppobject <- function(x, name){
@@ -83,10 +90,19 @@
 		clnames <- names( classes )
 		for( i in seq_along(classes) ){
 			setClass( clnames[i], contains = "C++Object", where = where )
+			init <- function(.Object, ...){
+				if( .Call( "CppObject__needs_init", .Object at pointer, PACKAGE = "Rcpp" ) ){
+					CLASS <- classes[[i]]
+					out <- new_CppObject_xp( CLASS, ... )
+					.Object at pointer <- out$xp
+					.Object at cppclass <- CLASS at pointer
+					.Object at module <- CLASS at module
+				}
+				.Object
+			}
+			setMethod( "initialize", clnames[i], init , where = where )
 		}
 	}
 	new( "Module", pointer = xp ) 
 }
 
-
-

Modified: pkg/Rcpp/src/Module.cpp
===================================================================
--- pkg/Rcpp/src/Module.cpp	2010-05-29 08:15:46 UTC (rev 1360)
+++ pkg/Rcpp/src/Module.cpp	2010-05-29 09:21:00 UTC (rev 1361)
@@ -34,7 +34,6 @@
 RCPP_FUNCTION_1( std::string, Class__name, XP_Class cl){
 	return cl->name ;
 }
-
 RCPP_FUNCTION_2( bool, Module__has_function, XP_Module module, std::string met ){
 	return module->has_function( met ) ;
 }
@@ -44,6 +43,9 @@
 RCPP_FUNCTION_2( Rcpp::CppClass, Module__get_class, XP_Module module, std::string cl ){
 	return module->get_class( cl ) ;
 }
+RCPP_FUNCTION_1( bool, CppObject__needs_init, SEXP xp ){
+	return EXTPTR_PTR(xp) == 0 ;
+}
 
 extern "C" SEXP Module__funtions_arity( SEXP mod_xp ){
 	Rcpp::XPtr<Rcpp::Module> module(mod_xp) ;