[Rcpp-commits] r3408 - in pkg/Rcpp: . R man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Mon Dec 12 18:35:59 CET 2011
Author: jmc
Date: 2011-12-12 18:35:59 +0100 (Mon, 12 Dec 2011)
New Revision: 3408
Added:
pkg/Rcpp/R/RcppClass.R
pkg/Rcpp/man/setRcppClass.Rd
Modified:
pkg/Rcpp/NAMESPACE
Log:
setRcppClass for classes that extend C++ classes
Modified: pkg/Rcpp/NAMESPACE
===================================================================
--- pkg/Rcpp/NAMESPACE 2011-12-07 16:08:27 UTC (rev 3407)
+++ pkg/Rcpp/NAMESPACE 2011-12-12 17:35:59 UTC (rev 3408)
@@ -15,6 +15,9 @@
exportMethods( prompt, show, .DollarNames, initialize, "formals<-" )
export(
- Module, Rcpp.package.skeleton, populate, loadRcppModules
+ Module, Rcpp.package.skeleton, populate, loadRcppModules, setRcppClass
)
+exportClass(RcppClass)
+
+
Added: pkg/Rcpp/R/RcppClass.R
===================================================================
--- pkg/Rcpp/R/RcppClass.R (rev 0)
+++ pkg/Rcpp/R/RcppClass.R 2011-12-12 17:35:59 UTC (rev 3408)
@@ -0,0 +1,66 @@
+.RcppClass <- setRefClass("RcppClass",
+ methods = list(
+ initialize = function(...){
+ args <- list(...)
+ argNames <- allNames(args)
+ cppArgs <- !nzchar(argNames)
+ if(any(cppArgs)) {
+ do.call(Rcpp:::cpp_object_initializer, c(list(.self, .refClassDef), args[cppArgs]))
+ args <- args[!cppArgs]
+ }
+ else
+ Rcpp:::cpp_object_dummy(.self, .refClassDef)
+ ## <FIXME>
+ ## should be a way to have both superclasses & Cpp args
+ ## </FIXME>
+ if(any(args))
+ initRefFields(cppObj, def, as.environemnt(cppObj), args)
+ }
+ )
+ )
+
+## <Temporary:> currently class "C++Object" redefines the S4 method for show,
+## preventing subclasses from having a $show() method. It should define a $show()
+## method instead. Meanwhile, we restore the standard reference class method
+
+setMethod("show", "RcppClass", selectMethod("show", "envRefClass"))
+
+.showCpp <- function (object)
+{
+ env <- as.environment(object)
+ pointer <- get(".pointer", envir = env)
+ cppclass <- get(".cppclass", envir = env)
+ txt <- sprintf("C++ object <%s> of class '%s' <%s>", externalptr_address(pointer),
+ .Call(Class__name, cppclass), externalptr_address(cppclass))
+ writeLines(txt)
+}
+
+
+.RcppClass$methods(show = function ()
+{
+ cat("Rcpp class object of class ", classLabel(class(.self)),
+ "\n", sep = "")
+ fields <- names(.refClassDef at fieldClasses)
+ for (fi in fields) {
+ cat("Field \"", fi, "\":\n", sep = "")
+ methods::show(field(fi))
+ }
+ cat("Extending "); Rcpp:::.showCpp(.self)
+}
+)
+
+## </Temporary:>
+
+setRcppClass <- function(Class, CppClass = "<UNDEFINED>", fields = list(),
+ contains = character(),
+ methods = list(),
+ where = topenv(parent.frame()),
+ ...) {
+ if(!is(CppClass, "C++Class"))
+ stop(gettextf("\"%s\" is not a C++ Class", "RcppClass", CppClass))
+ setRefClass(Class, fields = fields,
+ contains = c(contains, "RcppClass", as.character(CppClass)),
+ methods = methods,
+ where = where,
+ ...)
+}
Added: pkg/Rcpp/man/setRcppClass.Rd
===================================================================
--- pkg/Rcpp/man/setRcppClass.Rd (rev 0)
+++ pkg/Rcpp/man/setRcppClass.Rd 2011-12-12 17:35:59 UTC (rev 3408)
@@ -0,0 +1,81 @@
+\name{setRcppClass}
+\alias{setRcppClass}
+\alias{RcppClass-class}
+\title{
+Define a Reference Class containing a C++ Class
+}
+\description{
+Function \code{setRcppClass} creates an extended reference class that
+contains an interface to a C++ class, typically as exposed by an Rcpp
+\code{\link{Module}}. The Rcpp class can have R-based fields and
+methods in addition to those from the C++ class.
+}
+\usage{
+setRcppClass(Class, CppClass = , fields = list(), contains = character(), methods = list(), where = topenv(parent.frame()), ...)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{Class}{
+The name of the class to be defined.
+}
+ \item{CppClass}{
+The C++ class extended by this class, usually a class specified in an
+Rcpp \code{\link{Module}}.
+}
+ \item{fields, contains, methods, where, \dots}{
+Arguments to \code{\link{setRefClass}}, extended in the case of
+\code{contains=} to include the C++ class.
+}
+}
+\value{
+A generator object for the reference class. The generator object is
+from class \code{"rcppObjectGenerator"}, with some extra slots to hold
+information about the contained C++ class.
+}
+\author{
+John Chambers
+}
+\examples{
+\dontrun{
+### Following the vignette for Module exporting C++ class Uniform
+### The class randU extends the C++ class to maintain seed for the RNG
+### (An example of a reproducible simulation utility, protected
+### from any other random number generation. Class "Rseed", not shown,
+### mainly exists to print random seeds in a user-readable form.)
+randU <- setRcppClass("randU", Uniform,
+ fields = list(startSeed = "Rseed", currentSeed = "Rseed"),
+ methods = list(
+ set.seed = function(seed) {
+ base::set.seed(seed)
+ startSeed <<- as(.Random.seed, "Rseed")
+ currentSeed <<- startSeed
+ invisible(currentSeed)
+ },
+ draw = function(...) {
+ if(exists(".Random.seed",envir = .GlobalEnv)) {
+ previous <- get(".Random.seed", envir= .GlobalEnv)
+ on.exit(assign(".Random.seed", previous, envir = .GlobalEnv))
+ }
+ else
+ on.exit(remove(".Random.seed", envir = .GlobalEnv))
+ assign(".Random.seed", currentSeed, envir = .GlobalEnv)
+ value <- callSuper(...)
+ currentSeed <<- as(get(".Random.seed", envir = .GlobalEnv),
+ "Rseed")
+ value
+ }
+ )
+)
+randU$lock("startSeed")
+}
+\dontrun{
+
+## This class can be used with mixed R/C++ methods:
+
+ru <- randU$new(0,10)
+ru$set.seed(429)
+ru$draw(10)
+}
+}
+\keyword{ programming }
+\keyword{ classes }
More information about the Rcpp-commits
mailing list