[Rcpp-commits] r2134 - in pkg/Rcpp: R man tests

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

Author: jmc
Date: 2010-09-18 04:54:56 +0200 (Sat, 18 Sep 2010)
New Revision: 2134

Modified:
   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/man/CppObject-class.Rd
   pkg/Rcpp/tests/modref.R
Log:
simpler/faster implementation of C++Object using environment

Modified: pkg/Rcpp/R/00_classes.R
===================================================================
--- pkg/Rcpp/R/00_classes.R	2010-09-17 22:54:36 UTC (rev 2133)
+++ pkg/Rcpp/R/00_classes.R	2010-09-18 02:54:56 UTC (rev 2134)
@@ -75,13 +75,8 @@
 # # might not actually use this
 # setClass( "C++Property" )	
 
-setClass( "C++Object", 
-	representation( 
-		module = "externalptr", 
-		cppclass = "externalptr", 
-		pointer = "externalptr"
-		)
-	)
+setClass( "C++Object")
+
 setClass( "C++Function", 
 	representation( pointer = "externalptr" ), 
 	contains = "function"

Modified: pkg/Rcpp/R/01_show.R
===================================================================
--- pkg/Rcpp/R/01_show.R	2010-09-17 22:54:36 UTC (rev 2133)
+++ pkg/Rcpp/R/01_show.R	2010-09-18 02:54:56 UTC (rev 2134)
@@ -16,10 +16,17 @@
 # along with Rcpp.  If not, see <http://www.gnu.org/licenses/>.
 
 setMethod( "show", "C++Object", function(object){
+    env <- as.environment(object)
+    pointer <- get(".pointer", envir = env)
+    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")
 	txt <- sprintf( "C++ object <%s> of class '%s' <%s>", 
-		externalptr_address(object at pointer), 
-		.Call( "Class__name", object at cppclass, PACKAGE = "Rcpp" ), 
-		externalptr_address(object at cppclass)
+		externalptr_address(pointer), 
+		.Call( "Class__name", cppclass, PACKAGE = "Rcpp" ), 
+		externalptr_address(cppclass)
 	)
 	writeLines( txt )
 } )

Modified: pkg/Rcpp/R/02_completion.R
===================================================================
--- pkg/Rcpp/R/02_completion.R	2010-09-17 22:54:36 UTC (rev 2133)
+++ pkg/Rcpp/R/02_completion.R	2010-09-18 02:54:56 UTC (rev 2134)
@@ -25,7 +25,9 @@
 # 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 <- x at cppclass
+	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" )
 } )
 

Modified: pkg/Rcpp/R/Module.R
===================================================================
--- pkg/Rcpp/R/Module.R	2010-09-17 22:54:36 UTC (rev 2133)
+++ pkg/Rcpp/R/Module.R	2010-09-18 02:54:56 UTC (rev 2134)
@@ -104,17 +104,19 @@
     function(.Object, ...){
     	selfEnv <- as.environment(.Object)
         ## generate the C++-side object and store its pointer, etc.
-        if(identical(.Object at pointer, .emptyPointer)) {
+        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)
-            ## <fixme> these should not be needed
-            .Object at module <- fields$.module
-            .Object at cppclass <- fields$.pointer
-            .Object at pointer <- pointer
-            ##</fixme>
+            ## </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

Modified: pkg/Rcpp/man/CppObject-class.Rd
===================================================================
--- pkg/Rcpp/man/CppObject-class.Rd	2010-09-17 22:54:36 UTC (rev 2133)
+++ pkg/Rcpp/man/CppObject-class.Rd	2010-09-18 02:54:56 UTC (rev 2134)
@@ -11,16 +11,8 @@
 C++ internal objects instanciated from a class exposed in an Rcpp module
 }
 \section{Objects from the Class}{
-	Objects can be created by the \code{new} method of the
-	\linkS4class{C++Class} class.
+	This is a virtual class.  Actual C++ classes are subclasses.
 }
-\section{Slots}{
-  \describe{
-    \item{\code{module}:}{external pointer to the module}
-    \item{\code{cppclass}:}{external pointer to the c++ class}
-    \item{\code{pointer}:}{external pointer to the c++ object}
-  }
-}
 \section{Methods}{
   \describe{
     \item{$}{\code{signature(x = "C++Object")}: invokes a method on the object, or retrieves the value of a property }

Modified: pkg/Rcpp/tests/modref.R
===================================================================
--- pkg/Rcpp/tests/modref.R	2010-09-17 22:54:36 UTC (rev 2133)
+++ pkg/Rcpp/tests/modref.R	2010-09-18 02:54:56 UTC (rev 2134)
@@ -1,5 +1,6 @@
     require( Rcpp )
-    if(require( inline )) {
+    if(!require( inline ))
+     q("no")
 
 	inc  <- '
 
@@ -43,4 +44,15 @@
 ww = new(World)
 wg = World$new()
 
-    }
+stopifnot(all.equal(ww$greet(), wg$greet()))
+wgg <- wg$greet()
+
+ww$set("Other")
+
+stopifnot(all.equal(ww$greet(), "Other"),
+          all.equal(wg$greet(), "Other"))
+
+World$methods(
+     twice = function() paste(greet(), greet()))
+
+stopifnot(all.equal(ww$twice(), paste(ww$greet(), ww$greet())))