[Rcpp-commits] r3576 - in pkg/Rcpp: . R inst/unitTests inst/unitTests/testRcppClass inst/unitTests/testRcppClass/R inst/unitTests/testRcppClass/man inst/unitTests/testRcppClass/src inst/unitTests/testRcppClass/tests man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Apr 19 01:14:47 CEST 2012
Author: jmc
Date: 2012-04-19 01:14:46 +0200 (Thu, 19 Apr 2012)
New Revision: 3576
Added:
pkg/Rcpp/R/loadModule.R
pkg/Rcpp/inst/unitTests/testRcppClass/
pkg/Rcpp/inst/unitTests/testRcppClass/DESCRIPTION
pkg/Rcpp/inst/unitTests/testRcppClass/NAMESPACE
pkg/Rcpp/inst/unitTests/testRcppClass/R/
pkg/Rcpp/inst/unitTests/testRcppClass/R/load.R
pkg/Rcpp/inst/unitTests/testRcppClass/R/rcpp_hello_world.R
pkg/Rcpp/inst/unitTests/testRcppClass/R/yada.R
pkg/Rcpp/inst/unitTests/testRcppClass/man/
pkg/Rcpp/inst/unitTests/testRcppClass/man/rcpp_hello_world.Rd
pkg/Rcpp/inst/unitTests/testRcppClass/man/testRcppClass-package.Rd
pkg/Rcpp/inst/unitTests/testRcppClass/src/
pkg/Rcpp/inst/unitTests/testRcppClass/src/Makevars
pkg/Rcpp/inst/unitTests/testRcppClass/src/Makevars.win
pkg/Rcpp/inst/unitTests/testRcppClass/src/Num.cpp
pkg/Rcpp/inst/unitTests/testRcppClass/src/rcpp_hello_world.cpp
pkg/Rcpp/inst/unitTests/testRcppClass/src/rcpp_hello_world.h
pkg/Rcpp/inst/unitTests/testRcppClass/src/rcpp_module.cpp
pkg/Rcpp/inst/unitTests/testRcppClass/src/stdVector.cpp
pkg/Rcpp/inst/unitTests/testRcppClass/tests/
pkg/Rcpp/inst/unitTests/testRcppClass/tests/classes.R
pkg/Rcpp/man/loadModule.Rd
Modified:
pkg/Rcpp/DESCRIPTION
pkg/Rcpp/NAMESPACE
pkg/Rcpp/R/Module.R
pkg/Rcpp/R/RcppClass.R
pkg/Rcpp/R/loadRcppModules.R
pkg/Rcpp/man/Module.Rd
pkg/Rcpp/man/setRcppClass.Rd
Log:
Revised version of setRcppClass and new function loadModule. Designed (and now succeeding most of the time) to allow R classes to extend
C++ Classes in modules. Also no longer requires packages to insert code into .onLoad(); the load actions added to R in 2.15.0 are used.
(For that reason, these features require at least that version; OTOH setRcppClass never worked before.)
Modified: pkg/Rcpp/DESCRIPTION
===================================================================
--- pkg/Rcpp/DESCRIPTION 2012-04-17 12:36:07 UTC (rev 3575)
+++ pkg/Rcpp/DESCRIPTION 2012-04-18 23:14:46 UTC (rev 3576)
@@ -38,7 +38,8 @@
been factored out of Rcpp into the package RcppClassic, and it is still
available for code relying on the older interface. New development should
use alwayse use this Rcpp package instead.
-Depends: R (>= 2.12.0), methods
+Depends: R (>= 2.12.0)
+Imports: methods
Suggests: RUnit, inline, rbenchmark
URL: http://dirk.eddelbuettel.com/code/rcpp.html, http://romainfrancois.blog.free.fr/index.php?category/R-package/Rcpp
License: GPL (>= 2)
Modified: pkg/Rcpp/NAMESPACE
===================================================================
--- pkg/Rcpp/NAMESPACE 2012-04-17 12:36:07 UTC (rev 3575)
+++ pkg/Rcpp/NAMESPACE 2012-04-18 23:14:46 UTC (rev 3576)
@@ -15,7 +15,8 @@
exportMethods( prompt, show, .DollarNames, initialize, "formals<-" )
export(
- Module, Rcpp.package.skeleton, populate, loadRcppModules, setRcppClass
+ Module, Rcpp.package.skeleton, populate, loadRcppModules, setRcppClass,
+ loadModule
)
exportClass(RcppClass)
Modified: pkg/Rcpp/R/Module.R
===================================================================
--- pkg/Rcpp/R/Module.R 2012-04-17 12:36:07 UTC (rev 3575)
+++ pkg/Rcpp/R/Module.R 2012-04-18 23:14:46 UTC (rev 3576)
@@ -56,7 +56,7 @@
moduleName = "UNKNOWN",
packageName = "",
pointer = .badModulePointer, ...) {
- env <- new.env(TRUE, emptyenv())
+ env <- new.env(TRUE, emptyenv())
as(.Object, "environment") <- env
assign("pointer", pointer, envir = env)
assign("packageName", packageName, envir = env)
@@ -79,12 +79,12 @@
body(f) <- if( info[[2]] ) {
substitute( {
.External( InternalFunction_invoke, fun_pointer, ... )
- invisible(NULL)
- }, stuff )
+ invisible(NULL)
+ }, stuff )
} else {
substitute( {
.External( InternalFunction_invoke, fun_pointer, ... )
- }, stuff )
+ }, stuff )
}
out <- new( "C++Function", f, pointer = fun_ptr, docstring = doc, signature = sign )
if( ! is.null( formal_args ) ){
@@ -98,11 +98,11 @@
value at generator <- get("refClassGenerators",envir=x)[[as.character(value)]]
value
}
-
+
setMethod( "$", "Module", function(x, name){
pointer <- .getModulePointer(x)
storage <- get( "storage", envir = as.environment(x) )
- storage[[ name ]]
+ storage[[ name ]]
} )
new_CppObject_xp <- function(module, pointer, ...) {
@@ -136,16 +136,16 @@
assign(".pointer", pointer, envir = selfEnv)
assign(".cppclass", fields$.pointer, envir = selfEnv)
.self
-}
+}
cpp_object_maker <- function(typeid, pointer){
Class <- Rcpp:::.classes_map[[ typeid ]]
new( Class, .object_pointer = pointer )
}
-Module <- function( module, PACKAGE = getPackageName(where), where = topenv(parent.frame()), mustStart = FALSE ) {
- if(is(module, "DLLInfo") && missing(mustStart)) mustStart <- TRUE
- if(is(module, "Module")) {
+Module <- function( module, PACKAGE = methods::getPackageName(where), where = topenv(parent.frame()), mustStart = FALSE ) {
+ if(inherits(module, "DLLInfo") && missing(mustStart)) mustStart <- TRUE
+ if(inherits(module, "Module")) {
xp <- .getModulePointer(module, FALSE)
if(!missing(PACKAGE))
warning("ignoring PACKAGE argument in favor of internal package from Module object")
@@ -164,12 +164,12 @@
## 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,
+ module <- methods::new("Module", pointer = xp, packageName = PACKAGE,
moduleName = moduleName)
- } else if(is(module, "character")) {
+ } else if(is.character(module)) {
moduleName <- module
xp <- .badModulePointer
- module <- new("Module", pointer = xp, packageName = PACKAGE,
+ module <- methods::new("Module", pointer = xp, packageName = PACKAGE,
moduleName = moduleName)
}
if(identical(xp, .badModulePointer)) {
@@ -177,7 +177,7 @@
name <- sprintf( "_rcpp_module_boot_%s", moduleName )
symbol <- tryCatch(getNativeSymbolInfo( name, PACKAGE ),
error = function(e)e)
- if(is(symbol, "error"))
+ if(inherits(symbol, "error"))
stop(gettextf("Failed to initialize module pointer: %s",
symbol), domain = NA)
xp <- .Call( symbol )
@@ -194,17 +194,17 @@
if(environmentIsLocked(where))
where <- .GlobalEnv # or???
generators <- list()
-
+
storage <- new.env()
-
+
for( i in seq_along(classes) ){
CLASS <- classes[[i]]
-
+
clname <- as.character(CLASS)
fields <- cpp_fields( CLASS, where )
methods <- cpp_refMethods(CLASS, where)
- generator <- setRefClass( clname,
+ generator <- methods::setRefClass( clname,
fields = fields,
contains = "C++Object",
methods = methods,
@@ -221,10 +221,10 @@
else Rcpp:::cpp_object_dummy(.self, .refClassDef)
}
)
-
+
rm( .self, .refClassDef )
-
- classDef <- getClass(clname)
+
+ classDef <- methods:::getClass(clname)
## non-public (static) fields in class representation
## <fixme> Should these become real fields? </fixme>
fields <- classDef at fieldPrototypes
@@ -232,43 +232,43 @@
assign(".module", xp, envir = fields)
assign(".CppClassName", clname, envir = fields)
generators[[clname]] <- generator
-
+
# [romain] : should this be promoted to reference classes
# perhaps with better handling of j and ... arguments
if( any( grepl( "^[[]", names(CLASS at methods) ) ) ){
if( "[[" %in% names( CLASS at methods ) ){
- setMethod( "[[", clname, function(x, i, j, ..., exact = TRUE){
+ methods::setMethod( "[[", clname, function(x, i, j, ..., exact = TRUE){
x$`[[`( i )
}, where = where )
}
-
+
if( "[[<-" %in% names( CLASS at methods ) ){
- setReplaceMethod( "[[", clname, function(x, i, j, ..., exact = TRUE, value){
+ methods::setReplaceMethod( "[[", clname, function(x, i, j, ..., exact = TRUE, value){
x$`[[<-`( i, value )
x
} , where = where )
}
-
+
}
-
+
}
if(length(classes)) {
module$refClassGenerators <- generators
}
-
+
for( i in seq_along(classes) ){
CLASS <- classes[[i]]
clname <- as.character(CLASS)
demangled_name <- sub( "^Rcpp_", "", clname )
.classes_map[[ CLASS at typeid ]] <- storage[[ demangled_name ]] <- .get_Module_Class( module, demangled_name, xp )
}
-
+
# functions
functions <- .Call( Module__functions_names, xp )
for( fun in functions ){
storage[[ fun ]] <- .get_Module_function( module, fun, xp )
}
-
+
assign( "storage", storage, envir = as.environment(module) )
module
}
@@ -277,37 +277,37 @@
method_wrapper <- function( METHOD, where ){
f <- function(...) NULL
-
+
stuff <- list(
class_pointer = METHOD$class_pointer,
pointer = METHOD$pointer,
CppMethod__invoke = CppMethod__invoke,
CppMethod__invoke_void = CppMethod__invoke_void,
CppMethod__invoke_notvoid = CppMethod__invoke_notvoid,
- dealWith = dealWith,
+ dealWith = dealWith,
docstring = METHOD$info("")
)
-
+
extCall <- if( all( METHOD$void ) ){
# all methods are void, so we know we want to return invisible(NULL)
- substitute(
+ substitute(
{
docstring
.External(CppMethod__invoke_void, class_pointer, pointer, .pointer, ...)
invisible(NULL)
} , stuff )
} else if( all( ! METHOD$void ) ){
- # none of the methods are void so we always return the result of
+ # none of the methods are void so we always return the result of
# .External
- substitute(
+ substitute(
{
docstring
.External(CppMethod__invoke_notvoid, class_pointer, pointer, .pointer, ...)
} , stuff )
} else {
- # some are void, some are not, so the voidness is part of the result
+ # some are void, some are not, so the voidness is part of the result
# we get from internally and we need to deal with it
- substitute(
+ substitute(
{
docstring
dealWith( .External(CppMethod__invoke, class_pointer, pointer, .pointer, ...) )
@@ -319,17 +319,17 @@
## create a named list of the R methods to invoke C++ methods
## from the C++ class with pointer xp
cpp_refMethods <- function(CLASS, where) {
- finalizer <- eval( substitute(
+ finalizer <- eval( substitute(
function(){
.Call( CppObject__finalize, class_pointer , .pointer )
- },
- list(
- CLASS = CLASS at pointer,
- CppObject__finalize = CppObject__finalize,
+ },
+ list(
+ CLASS = CLASS at pointer,
+ CppObject__finalize = CppObject__finalize,
class_pointer = CLASS at pointer
)
) )
- mets <- c(
+ mets <- c(
sapply( CLASS at methods, method_wrapper, where = where ),
"finalize" = finalizer
)
@@ -348,14 +348,16 @@
else
.Call( CppField__set, class_pointer, pointer, .pointer, x)
}, list(class_pointer = FIELD$class_pointer,
- pointer = FIELD$pointer,
- CppField__get = CppField__get,
+ pointer = FIELD$pointer,
+ CppField__get = CppField__get,
CppField__set = CppField__set ))
environment(f) <- where
f
}
-
+
cpp_fields <- function( CLASS, where){
sapply( CLASS at fields, binding_maker, where = where )
}
+.CppClassName <- function(name)
+ paste0("Rcpp_",name)
Modified: pkg/Rcpp/R/RcppClass.R
===================================================================
--- pkg/Rcpp/R/RcppClass.R 2012-04-17 12:36:07 UTC (rev 3575)
+++ pkg/Rcpp/R/RcppClass.R 2012-04-18 23:14:46 UTC (rev 3576)
@@ -1,66 +1,157 @@
-.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)
- }
- )
- )
+# Copyright (C) 2010 - 2012 John Chambers, Dirk Eddelbuettel and Romain Francois
+#
+# This file is part of Rcpp.
+#
+# Rcpp is free software: you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 2 of the License, or
+# (at your option) any later version.
+#
+# Rcpp is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with Rcpp. If not, see <http://www.gnu.org/licenses/>.
-## <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"))
+setRcppClass <- function(Class, CppClass,
+ module,
+ fields = list(),
+ contains = character(),
+ methods = list(),
+ saveAs = Class,
+ where = topenv(parent.frame()),
+ ...) {
+ myCall <- match.call()
+ myCall[[1]] <- quote(Rcpp:::loadRcppClass)
+ if(!missing(module) && moduleIsLoaded(module, where)) # eval now
+ eval.parent(myCall)
+ else {
+ f <- function(NS)NULL
+ myCall$where = as.name("NS")
+ body(f, where) <- myCall
+ setLoadAction(f, where = where)
+ }
+}
-.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)
+loadRcppClass <- function(Class, CppClass = Class,
+ module,
+ fields = character(),
+ contains = character(),
+ methods = list(),
+ saveAs = Class,
+ where = topenv(parent.frame()),
+ ...) {
+
+ if(isBotchedSession()) {
+ value <- setRefClass(Class, fields = fields, methods = methods, contains = contains, where = where, ...) # kludge -- see loadModule.R
+ if(is.character(saveAs) && length(saveAs) == 1)
+ assign(saveAs, value, envir = where)
+ return(value)
+ }
+ if(!missing(module)) {
+ mod <- loadModule(module, NULL, env = where, loadNow = TRUE)
+ storage <- get("storage", envir = as.environment(mod))
+ if(exists(CppClass, envir = storage, inherits = FALSE)) {
+ cppclassinfo <- get(CppClass, envir = storage)
+ if(!is(cppclassinfo, "C++Class"))
+ stop(gettextf("Object \"%s\" in module \"%s\" is not a C++ class description", CppClass, module))
+ }
+ else
+ stop(gettextf("No object \"%s\" in module \"%s\"", CppClass, module))
+ }
+ else {
+ if(!is(cppclassinfo, "C++Class"))
+ stop("If argument \"module\" is missing, CppClass must be a \"C++Class\" object")
+ CppClass <- .CppClassName(cppclassinfo)
+ }
+ allmethods <- .makeCppMethods(methods, cppclassinfo, where)
+ allfields <- .makeCppFields(fields, cppclassinfo, where)
+ value <- setRefClass(Class, fields = allfields,
+ contains = c(contains, "RcppClass"),
+ methods = allmethods, where=where, ...)
+ if(is.character(saveAs) && length(saveAs) == 1)
+ assign(saveAs, value, envir = where)
+ value
}
+.makeCppMethods <- function(methods, cppclassinfo, env) {
+ cppMethods <- names(cppclassinfo at methods)
+ newMethods <- names(methods)
+ for(what in cppMethods[! cppMethods %in% newMethods])
+ methods[[what]] <- eval(substitute(
+ function(...) .CppObject$WHAT(...), list(WHAT = as.name(what))),
+ env)
+ methods
+}
-.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)
+.makeFieldsList <- function(fields) {
+ fnames <- allNames(fields)
+ any_s <- !nzchar(fnames)
+ fnames[any_s] <- fields[any_s]
+ fields[any_s] <- "ANY"
+ fields <- as.list(fields)
+ names(fields) <- fnames
+ fields
}
-)
+.makeCppFields <- function(fields, cppclassinfo, env) {
+ if(is.character(fields))
+ fields <- .makeFieldsList(fields)
+ cppFields <- names(cppclassinfo at fields)
+ newFields <- names(fields)
+ for(what in cppFields[! cppFields %in% newFields])
+ fields[[what]] <- eval(substitute(
+ function(value) if(missing(value)) .CppObject$WHAT else .cppObject$WHAT <- value,
+ list(WHAT = as.name(what))), env)
+ ## insert the generator and cppclass def as constants
+ cppgenerator <- getRefClass(cppclassinfo)
+ fields[[".CppClassDef"]] <- eval(substitute(
+ function(value) if(missing(value)) DEF else stop("this field is a constant"),
+ list(DEF = cppclassinfo)), env)
+ fields[[".CppGenerator"]] <- eval(substitute(
+ function(value) if(missing(value)) DEF else stop("this field is a constant"),
+ list(DEF = cppgenerator)), env)
+ fields
+}
+
+.RcppClass <- setRefClass("RcppClass",
+ methods = list(
+ initialize = function(...){
+ args <- list(...)
+ argNames <- allNames(args)
+ cppArgs <- !nzchar(argNames)
+ .CppObject <<- do.call(.CppGenerator$new, args[cppArgs])
+ for(i in seq_along(args)[!cppArgs])
+ field(argNames[[i]], args[[i]])
+ }
+ ),
+ fields = list(
+ .CppObject = "C++Object"
+ ),
+ contains = "VIRTUAL"
+ )
+
+.RcppClass$methods(show = function ()
+ {
+ cat("Rcpp class object of class ", classLabel(class(.self)),
+ "\n", sep = "")
+ fields <- names(.refClassDef at fieldClasses)
+ if(".CppObject" %in% fields) {
+ cat("\n")
+ methods::show(field(".CppObject"))
+ cat("\n")
+ }
+ fields <- fields[ ! fields %in% c(".CppObject", ".CppClassDef", ".CppGenerator")]
+ for (fi in fields) {
+ cat("Field \"", fi, "\":\n", sep = "")
+ methods::show(field(fi))
+ }
+ }
+ )
+
+
## </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/R/loadModule.R
===================================================================
--- pkg/Rcpp/R/loadModule.R (rev 0)
+++ pkg/Rcpp/R/loadModule.R 2012-04-18 23:14:46 UTC (rev 3576)
@@ -0,0 +1,121 @@
+# Copyright (C) 2010 - 2012 John Chambers, Dirk Eddelbuettel and Romain Francois
+#
+# This file is part of Rcpp.
+#
+# Rcpp is free software: you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 2 of the License, or
+# (at your option) any later version.
+#
+# Rcpp is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with Rcpp. If not, see <http://www.gnu.org/licenses/>.
+
+## the following items are to get around some insanity in the
+## CMD check of packages using Rcpp that dies in loadModule()
+## because some code somewhere can't find the methods package
+isBotchedSession <- function()
+ ! ("package:methods" %in% search())
+
+.moduleNames <- function(what) {
+ assignAs <- allNames(what)
+ sameNames <- !nzchar(assignAs)
+ assignAs[sameNames] <- what[sameNames]
+ assignAs
+}
+
+.DummyModule <- function(name, what) {
+ value <- new.env()
+ storage <- new.env()
+ assign("storage", storage, envir = value)
+ assign("moduleName", name, envir = value)
+ allNames <- names(.moduleNames(what))
+ for(el in allNames)
+ assign(el, NULL, envir = storage)
+ value
+}
+
+.moduleMetaName <- function(name)
+ methods::methodsPackageMetaName("Mod",name)
+
+moduleIsLoaded <- function(name, env)
+ exists(.moduleMetaName(name), envir = env, inherits = FALSE)
+
+loadModule <- function( module, what = character(), loadNow,
+ env = topenv(parent.frame())) {
+
+ if(is(module, "character")) {
+ loadM <- NULL
+ metaName <- .moduleMetaName(module)
+ if(exists(metaName, envir = env, inherits = FALSE))
+ loadM <- get(metaName, envir = env)
+ }
+ else if(is(module, "Module")) {
+ loadM <- as.environment(module)
+ module <- get(loadM, "moduleName")
+ }
+ else
+ stop(gettextf("Argument \"module\" should be a module or the name of a module: got an object of class \"%s\"", class(module)))
+ if(missing(loadNow)) { # test it
+ if(is.null(loadM))
+ loadM <- tryCatch(Module( module, mustStart = TRUE, where = env ),
+ error = function(e)e)
+ loadNow <- !is(loadM, "error")
+ }
+ if(loadNow) {
+ .botched <- isBotchedSession()
+ if(is.null(loadM))
+ loadM <- tryCatch(Module( module, mustStart = TRUE, where = env ),
+ error = function(e)e)
+ if(is(loadM, "error")) {
+ if(.botched)
+ return(.DummyModule(module, what))
+ stop(gettextf("Unable to load module \"%s\": %s (and not botched session)",
+ as(module, "character"), loadM$message))
+ }
+ if(!exists(metaName, envir = env, inherits =FALSE))
+ assign(metaName, loadM, envir = env)
+ if(!length(what)) # no assignments
+ return(loadM)
+ env <- as.environment(env)
+ ## get the storage environment, for what=TRUE
+ storage <- as.environment(get( "storage", as.environment(loadM ) ))
+ if(identical(what, TRUE))
+ what <- objects(storage)
+ missingObjs <- !sapply(what, function(symb) exists(symb, envir = storage, inherits = FALSE))
+ if(any(missingObjs)) {
+ if(.botched) {
+ for(el in what[missingObjs])
+ assign(el, NULL, envir = storage)
+ }
+ else {
+ warning(gettextf("%s not found in module \"%s\"",
+ paste0('"', what[missingObjs], '"', collapse = ", "),
+ as.character(module)))
+ what <- what[!missingObjs]
+ }
+ }
+ assignAs <- .moduleNames(what)
+ for( i in seq_along(what) ) {
+ if(.botched)
+ assign(assignAs[[i]], NULL, envir = storage)
+ else
+ assign(assignAs[[i]], get(what[[i]], envir = storage), envir = env)
+ }
+ loadM
+ }
+ else { # create a load action to recall this function
+ myCall <- match.call()
+ f <- function(ns) NULL
+ myCall$env <- as.name("ns")
+ myCall$loadNow <- TRUE
+ body(f, envir = env) <- myCall
+ setLoadAction(f, where = env)
+ invisible(myCall)
+ }
+}
+
Modified: pkg/Rcpp/R/loadRcppModules.R
===================================================================
--- pkg/Rcpp/R/loadRcppModules.R 2012-04-17 12:36:07 UTC (rev 3575)
+++ pkg/Rcpp/R/loadRcppModules.R 2012-04-18 23:14:46 UTC (rev 3576)
@@ -46,6 +46,7 @@
} else {
forceAssignInNamespace( m, mod, ns )
}
+ assign(.moduleMetaName(m), mod, envir = ns)
}, error = function(e){
stop( sprintf( "failed to load module %s from package %s\n%s", m, pkg, conditionMessage(e) ) )
})
Added: pkg/Rcpp/inst/unitTests/testRcppClass/DESCRIPTION
===================================================================
--- pkg/Rcpp/inst/unitTests/testRcppClass/DESCRIPTION (rev 0)
+++ pkg/Rcpp/inst/unitTests/testRcppClass/DESCRIPTION 2012-04-18 23:14:46 UTC (rev 3576)
@@ -0,0 +1,17 @@
+Package: testRcppClass
+Type: Package
+Title: Some examples using Rcpp classes and loadModule()
+Version: 0.1
+Date: 2012-04-06
+Author: JMC
+Maintainer: <jmc at stat.stanford.edu>
+Description: Some examples from the Rcpp Modules documentation, with
+ load-time creation of classes that extend C++ classes and with
+ explicit loading of some objects.
+License: GPL(>=2)
+LazyLoad: yes
+Depends: R (>= 2.15.0), Rcpp, methods
+Imports: Rcpp (>= 0.8.5), methods
+LinkingTo: Rcpp
+Packaged: 2012-04-14 18:42:28 UTC; jmc
+
Added: pkg/Rcpp/inst/unitTests/testRcppClass/NAMESPACE
===================================================================
--- pkg/Rcpp/inst/unitTests/testRcppClass/NAMESPACE (rev 0)
+++ pkg/Rcpp/inst/unitTests/testRcppClass/NAMESPACE 2012-04-18 23:14:46 UTC (rev 3576)
@@ -0,0 +1,9 @@
+useDynLib(testRcppClass)
+## until 2.15.1 the namespace load fails to find patterns at load time
+## exportPattern("^[[:alpha:]]+")
+import(Rcpp)
+
+export(genWorld, stdNumeric, rcpp_hello_world,
+ bar, foo, baz, baz1)
+
+exportClass(World, stdNumeric)#, NumEx)
Added: pkg/Rcpp/inst/unitTests/testRcppClass/R/load.R
===================================================================
--- pkg/Rcpp/inst/unitTests/testRcppClass/R/load.R (rev 0)
+++ pkg/Rcpp/inst/unitTests/testRcppClass/R/load.R 2012-04-18 23:14:46 UTC (rev 3576)
@@ -0,0 +1,43 @@
+setRcppClass("World", module = "yada", fields = list(more = "character"),
+ methods = list(test = function(what) message("Testing: ", what, "; ", more)),
+ saveAs = "genWorld"
+ )
+
+setRcppClass("stdNumeric", "vec", "stdVector")
+
+## some methods that use C++ methods
+evalqOnLoad({
+ library(methods)
+ stdNumeric$methods(
+ getEl = function(i) {
+ i <- as.integer(i)
+ if(i < 1 || i > size())
+ NA_real_
+ else
+ at(i-1L)
+ },
+ setEl = function(i, value) {
+ value <- as.numeric(value)
+ if(length(value) != 1)
+ stop("Only assigns single values")
+ i <- as.integer(i)
+ if(i < 1 || i > size())
+ stop("index out of bounds")
+ else
+ set(i-1L, value)
+ },
+ initialize = function(data = numeric()) {
+ callSuper()
+ data <- as.double(data)
+ n <- as.integer(max(50, length(data) * 2))
+ reserve(n)
+ assign(data)
+ }
+ )
+})
+
+## loadModule("NumEx")
+
+## loading the module should have defined the C++ class
+
+## setRcppClass("NumEx", "Num")
Added: pkg/Rcpp/inst/unitTests/testRcppClass/R/rcpp_hello_world.R
===================================================================
--- pkg/Rcpp/inst/unitTests/testRcppClass/R/rcpp_hello_world.R (rev 0)
+++ pkg/Rcpp/inst/unitTests/testRcppClass/R/rcpp_hello_world.R 2012-04-18 23:14:46 UTC (rev 3576)
@@ -0,0 +1,5 @@
+
+rcpp_hello_world <- function(){
+ .Call( "rcpp_hello_world", PACKAGE = "testLoadModule" )
+}
+
Added: pkg/Rcpp/inst/unitTests/testRcppClass/R/yada.R
===================================================================
--- pkg/Rcpp/inst/unitTests/testRcppClass/R/yada.R (rev 0)
+++ pkg/Rcpp/inst/unitTests/testRcppClass/R/yada.R 2012-04-18 23:14:46 UTC (rev 3576)
@@ -0,0 +1 @@
+loadModule("yada", c("bar", baz = "bla", baz1 = "bla1", "foo"))
Added: pkg/Rcpp/inst/unitTests/testRcppClass/man/rcpp_hello_world.Rd
===================================================================
--- pkg/Rcpp/inst/unitTests/testRcppClass/man/rcpp_hello_world.Rd (rev 0)
+++ pkg/Rcpp/inst/unitTests/testRcppClass/man/rcpp_hello_world.Rd 2012-04-18 23:14:46 UTC (rev 3576)
@@ -0,0 +1,17 @@
+\name{rcpp_hello_world}
+\alias{rcpp_hello_world}
+\docType{package}
+\title{
+Simple function using Rcpp
+}
+\description{
+Simple function using Rcpp
+}
+\usage{
+rcpp_hello_world()
+}
+\examples{
+\dontrun{
+rcpp_hello_world()
+}
+}
Added: pkg/Rcpp/inst/unitTests/testRcppClass/man/testRcppClass-package.Rd
===================================================================
--- pkg/Rcpp/inst/unitTests/testRcppClass/man/testRcppClass-package.Rd (rev 0)
+++ pkg/Rcpp/inst/unitTests/testRcppClass/man/testRcppClass-package.Rd 2012-04-18 23:14:46 UTC (rev 3576)
@@ -0,0 +1,22 @@
+\name{testRcppClass-package}
+\alias{testRcppClass-package}
+\alias{testRcppClass}
+\docType{package}
+\title{
+Dummy package part of Rcpp unit testing
+}
+\description{
+Dummy package part of Rcpp unit testing
+}
+\details{
+\tabular{ll}{
+Package: \tab testRcppClass\cr
+Type: \tab Package\cr
+Version: \tab 1.0\cr
+Date: \tab 2010-09-06\cr
+License: \tab GPL (>=2)\cr
+LazyLoad: \tab yes\cr
+}
+}
+\keyword{ package }
+
Added: pkg/Rcpp/inst/unitTests/testRcppClass/src/Makevars
===================================================================
--- pkg/Rcpp/inst/unitTests/testRcppClass/src/Makevars (rev 0)
+++ pkg/Rcpp/inst/unitTests/testRcppClass/src/Makevars 2012-04-18 23:14:46 UTC (rev 3576)
@@ -0,0 +1,27 @@
+## Use the R_HOME indirection to support installations of multiple R version
+PKG_LIBS = `$(R_HOME)/bin/Rscript -e "Rcpp:::LdFlags()"`
+
+## As an alternative, one can also add this code in a file 'configure'
+##
+## PKG_LIBS=`${R_HOME}/bin/Rscript -e "Rcpp:::LdFlags()"`
+##
+## sed -e "s|@PKG_LIBS@|${PKG_LIBS}|" \
+## src/Makevars.in > src/Makevars
+##
+## which together with the following file 'src/Makevars.in'
+##
+## PKG_LIBS = @PKG_LIBS@
+##
+## can be used to create src/Makevars dynamically. This scheme is more
+## powerful and can be expanded to also check for and link with other
+## libraries. It should be complemented by a file 'cleanup'
+##
+## rm src/Makevars
+##
+## which removes the autogenerated file src/Makevars.
+##
+## Of course, autoconf can also be used to write configure files. This is
+## done by a number of packages, but recommended only for more advanced users
+## comfortable with autoconf and its related tools.
+
+
Added: pkg/Rcpp/inst/unitTests/testRcppClass/src/Makevars.win
===================================================================
--- pkg/Rcpp/inst/unitTests/testRcppClass/src/Makevars.win (rev 0)
+++ pkg/Rcpp/inst/unitTests/testRcppClass/src/Makevars.win 2012-04-18 23:14:46 UTC (rev 3576)
@@ -0,0 +1,4 @@
+
+## Use the R_HOME indirection to support installations of multiple R version
+PKG_LIBS = $(shell "${R_HOME}/bin${R_ARCH_BIN}/Rscript.exe" -e "Rcpp:::LdFlags()")
+
Added: pkg/Rcpp/inst/unitTests/testRcppClass/src/Num.cpp
===================================================================
--- pkg/Rcpp/inst/unitTests/testRcppClass/src/Num.cpp (rev 0)
+++ pkg/Rcpp/inst/unitTests/testRcppClass/src/Num.cpp 2012-04-18 23:14:46 UTC (rev 3576)
@@ -0,0 +1,30 @@
+#include "rcpp_hello_world.h"
+
+class Num{
+public:
+ Num() : x(0.0), y(0){} ;
+
+ double getX() { return x ; }
+ void setX(double value){ x = value ; }
+
+ int getY() { return y ; }
+
+private:
+ double x ;
+ int y ;
+};
+
+RCPP_MODULE(NumEx){
+ using namespace Rcpp ;
+
+ class_<Num>( "Num" )
+
+ .default_constructor()
+
+ // read and write property
+ .property( "x", &Num::getX, &Num::setX )
+
+ // read-only property
+ .property( "y", &Num::getY )
+ ;
+}
Added: pkg/Rcpp/inst/unitTests/testRcppClass/src/rcpp_hello_world.cpp
===================================================================
--- pkg/Rcpp/inst/unitTests/testRcppClass/src/rcpp_hello_world.cpp (rev 0)
+++ pkg/Rcpp/inst/unitTests/testRcppClass/src/rcpp_hello_world.cpp 2012-04-18 23:14:46 UTC (rev 3576)
@@ -0,0 +1,11 @@
+#include "rcpp_hello_world.h"
+
+SEXP rcpp_hello_world(){
+ using namespace Rcpp ;
+
+ CharacterVector x = CharacterVector::create( "foo", "bar" ) ;
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/rcpp -r 3576
More information about the Rcpp-commits
mailing list