[Rcpp-commits] r1360 - in pkg/Rcpp: . R inst man src

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

Author: romain
Date: 2010-05-29 10:15:46 +0200 (Sat, 29 May 2010)
New Revision: 1360

Modified:
   pkg/Rcpp/NAMESPACE
   pkg/Rcpp/R/Module.R
   pkg/Rcpp/inst/ChangeLog
   pkg/Rcpp/man/Module.Rd
   pkg/Rcpp/src/Module.cpp
Log:
enable S4 dispatch based on the internal class

Modified: pkg/Rcpp/NAMESPACE
===================================================================
--- pkg/Rcpp/NAMESPACE	2010-05-29 06:36:02 UTC (rev 1359)
+++ pkg/Rcpp/NAMESPACE	2010-05-29 08:15:46 UTC (rev 1360)
@@ -1,9 +1,9 @@
 useDynLib(Rcpp)
 
+import( methods )
 export(Rcpp.package.skeleton)
 
 importFrom( utils, capture.output )
-importFrom( methods, new )
 
 exportClasses( Module, "C++Class", "C++Object" )
 export( Module )

Modified: pkg/Rcpp/R/Module.R
===================================================================
--- pkg/Rcpp/R/Module.R	2010-05-29 06:36:02 UTC (rev 1359)
+++ pkg/Rcpp/R/Module.R	2010-05-29 08:15:46 UTC (rev 1360)
@@ -21,13 +21,6 @@
 setClass( "C++Class", representation( pointer = "externalptr", module = "externalptr" ) )
 setClass( "C++Object", representation( module = "externalptr", cppclass = "externalptr", pointer = "externalptr" ) )
 
-Module <- function( module, PACKAGE ){
-	name <- sprintf( "_rcpp_module_boot_%s", module )
-	symbol <- getNativeSymbolInfo( name, PACKAGE )
-	xp  <- .Call( symbol )
-	new( "Module", pointer = xp ) 
-}
-
 setMethod( "$", "Module", function(x, name){
 	if( .Call( "Module__has_function", x at pointer, name, PACKAGE = "Rcpp" ) ){
 		function( ... ) {
@@ -57,10 +50,18 @@
 } )
 
 setMethod( "new", "C++Class", function(Class, ...){
-	.External( "class__newInstance", Class at module, Class at pointer, ..., PACKAGE = "Rcpp" )
+	xp <- .External( "class__newInstance", Class at module, Class at pointer, ..., PACKAGE = "Rcpp" )
+	cl <- .Call( "Class__name", Class at pointer, PACKAGE = "Rcpp" )
+	
+	cpp <- getClass( "C++Object" )
+	known_cpp_classes <- cpp at subclasses
+	if( ! cl %in% names( known_cpp_classes ) ){
+		cl <- "C++Object"
+	}
+	new( cl, pointer = xp, cppclass = Class at pointer, module = Class at module )
 } )
 
-setMethod( "$", "C++Object", function(x, name){
+dollar_cppobject <- function(x, name){
 	if( .Call( "Class__has_method", x at cppclass, name, PACKAGE = "Rcpp" ) ){
 		function(...){
 			res <- .External( "Class__invoke_method", x at cppclass, name, x at pointer, ..., PACKAGE = "Rcpp" )
@@ -69,5 +70,23 @@
 	} else{
 		stop( "no such method" )
 	}
-} )
+}
 
+setMethod( "$", "C++Object", dollar_cppobject )
+
+Module <- function( module, PACKAGE = getPackageName(where), where = topenv(parent.frame()) ){
+	name <- sprintf( "_rcpp_module_boot_%s", module )
+	symbol <- getNativeSymbolInfo( name, PACKAGE )
+	xp  <- .Call( symbol )
+	classes <- .Call( "Module__classes_info", xp, PACKAGE = "Rcpp" )
+	if( length( classes ) ){
+		clnames <- names( classes )
+		for( i in seq_along(classes) ){
+			setClass( clnames[i], contains = "C++Object", where = where )
+		}
+	}
+	new( "Module", pointer = xp ) 
+}
+
+
+

Modified: pkg/Rcpp/inst/ChangeLog
===================================================================
--- pkg/Rcpp/inst/ChangeLog	2010-05-29 06:36:02 UTC (rev 1359)
+++ pkg/Rcpp/inst/ChangeLog	2010-05-29 08:15:46 UTC (rev 1360)
@@ -1,3 +1,8 @@
+2010-05-29  Romain Francois <romain at r-enthusiasts.com>
+
+	* R/Module.R: when a Module is loaded, it creates extensions of the 
+	class C++Object for each internal class to enable S4 dispatch
+
 2010-05-28  Romain Francois <romain at r-enthusiasts.com>
 
 	* R/cppfunction.R: withdrawn, we now use inline::cxxfunction which is

Modified: pkg/Rcpp/man/Module.Rd
===================================================================
--- pkg/Rcpp/man/Module.Rd	2010-05-29 06:36:02 UTC (rev 1359)
+++ pkg/Rcpp/man/Module.Rd	2010-05-29 08:15:46 UTC (rev 1360)
@@ -8,12 +8,15 @@
 package.
 }
 \usage{
-Module(module, PACKAGE)
+Module(module, PACKAGE = getPackageName(where), where = topenv(parent.frame()) )
 }
 \arguments{
 \item{module}{Name of the module, as declared in the \code{RCPP_MODULE} macro internally}
 \item{PACKAGE}{Passed to \code{\link{getNativeSymbolInfo}}}
+\item{where}{When the module is loaded, S4 classes are defined based on the 
+	internal classes. This argument is passed to \code{\link{setClass}}
 }
+}
 \value{
 	An object of class \linkS4class{Module} collecting functions 
 	and classes declared in the module. 

Modified: pkg/Rcpp/src/Module.cpp
===================================================================
--- pkg/Rcpp/src/Module.cpp	2010-05-29 06:36:02 UTC (rev 1359)
+++ pkg/Rcpp/src/Module.cpp	2010-05-29 08:15:46 UTC (rev 1360)
@@ -31,6 +31,9 @@
 RCPP_FUNCTION_2( bool, Class__has_method, XP_Class cl, std::string m){
 	return cl->has_method(m) ;
 }
+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 ) ;
@@ -87,7 +90,7 @@
    		cargs[nargs] = CAR(p) ;
    		p = CDR(p) ;
    	}
-   	return Rcpp::CppObject( module, clazz, clazz->newInstance(cargs, nargs ) ) ;
+   	return clazz->newInstance(cargs, nargs ) ;
 }
 
 extern "C" SEXP Class__invoke_method(SEXP args){