[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