rcpp-0.11.0/ 0000755 0000000 0000000 00000000000 12273705472 007434 5 ustar rcpp-0.11.0/cleanup 0000755 0000000 0000000 00000002503 12253723677 011016 0 ustar
#cd inst/doc && rm -f index.html *.tex *.bbl *.blg *.aux *.out *.log && cd -
rm -f confdefs.h config.log config.status \
src/*.o src/*.so src/*.a src/*.d src/*.dll src/*.rc \
RcppSrc/*.o RcppSrc/*.a inst/Rcpp-version.txt \
inst/lib/libRcpp.so inst/lib/Rcpp*.h inst/lib/libRcpp.a \
inst/doc/*.cpp inst/doc/*.hpp \
inst/doc/*.out \
inst/doc/.build.timestamp \
inst/doc/*.Rd inst/doc/*.aux inst/doc/*.log inst/doc/*.tex \
inst/doc/latex/*.aux inst/doc/latex/*.log \
inst/examples/ConvolveBenchmarks/*.o \
inst/examples/ConvolveBenchmarks/*.so \
inst/examples/functionCallback/*.so \
inst/examples/functionCallback/*.o \
inst/examples/OpenMP/piWithInterrupts.o \
inst/examples/OpenMP/piWithInterrupts.so \
inst/discovery/cxx0x.Rout \
inst/unitTests/testRcppModule/src/*.o \
inst/unitTests/testRcppModule/src/*.so \
inst/unitTests/testRcppClass/src/*.o \
inst/unitTests/testRcppClass/src/*.so \
src/Makedeps libRcpp.a \
build/Rcpp.pdf \
src/symbols.rds \
inst/unitTests/testRcppClass/src/symbols.rds \
vignettes/*.aux vignettes/*.log vignettes/*.out \
vignettes/*.tex vignettes/*.bbl vignettes/*.blg
rm -rf autom4te.cache inst/lib/ inst/doc/man/ inst/doc/html/ inst/doc/latex/ \
inst/doc/auto inst/doc/Rcpp-*/auto/ src-* vignettes/auto
find . -name \*~ -exec rm {} \;
find . -name \*.flc -exec rm {} \;
rcpp-0.11.0/R/ 0000755 0000000 0000000 00000000000 12273452010 007620 5 ustar rcpp-0.11.0/R/00_classes.R 0000644 0000000 0000000 00000006325 12253723677 011727 0 ustar # 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 .
# anticipating a change in R 2.16.0
setClass( "refClassGeneratorFunction" )
setClassUnion("refGenerator", c("refObjectGenerator", "refClassGeneratorFunction"))
## "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",
fields = list(
pointer = "externalptr",
cpp_class = "character",
read_only = "logical",
class_pointer = "externalptr",
docstring = "character"
)
)
setRefClass( "C++OverloadedMethods",
fields = list(
pointer = "externalptr",
class_pointer = "externalptr",
size = "integer",
void = "logical",
const = "logical",
docstrings = "character",
signatures = "character",
nargs = "integer"
),
methods = list(
info = function(prefix = " " ){
paste(
paste( prefix, signatures, ifelse(const, " const", "" ), "\n", prefix, prefix,
ifelse( nchar(docstrings), paste( "docstring :", docstrings) , "" )
) , collapse = "\n" )
}
)
)
setRefClass( "C++Constructor",
fields = list(
pointer = "externalptr",
class_pointer = "externalptr",
nargs = "integer",
signature = "character",
docstring = "character"
)
)
setClass( "C++Class",
representation(
pointer = "externalptr",
module = "externalptr",
fields = "list",
methods = "list",
constructors = "list",
generator = "refGenerator",
docstring = "character",
typeid = "character",
enums = "list",
parents = "character"
),
contains = "character"
)
setClass( "C++Object")
setClass( "C++Function",
representation(
pointer = "externalptr",
docstring = "character",
signature = "character"
),
contains = "function"
)
.cppfunction_formals_gets <- function (fun, envir = environment(fun), value) {
bd <- body(fun)
b2 <- bd[[2L]]
for( i in seq_along(value) ){
b2[[3L+i]] <- as.name( names(value)[i] )
}
bd[[2]] <- b2
f <- fun@.Data
formals(f) <- value
body(f) <- bd
fun@.Data <- f
fun
}
setGeneric( "formals<-" )
setMethod( "formals<-", "C++Function", .cppfunction_formals_gets )
rcpp-0.11.0/R/populate.R 0000644 0000000 0000000 00000002056 12253723677 011621 0 ustar # Copyright (C) 2010 - 2011 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 .
populate <- function( module, env ){
# make sure the module is loaded
module <- Module( module, mustStart = TRUE )
storage <- get( "storage", as.environment(module ) )
symbols <- ls( storage )
is_ns <- isNamespace( env )
for( x in symbols ){
forceAssignInNamespace( x, storage[[x]], env )
}
}
rcpp-0.11.0/R/loadModule.R 0000644 0000000 0000000 00000010603 12253723677 012052 0 ustar # 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 .
## 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",
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)
}
}
rcpp-0.11.0/R/RcppLdpath.R 0000644 0000000 0000000 00000005434 12266347221 012023 0 ustar # Copyright (C) 2010 - 2013 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 .
## make sure system.file returns an absolute path
Rcpp.system.file <- function(...){
tools::file_path_as_absolute( base::system.file( ..., package = "Rcpp" ) )
}
## Use R's internal knowledge of path settings to find the lib/ directory
## plus optinally an arch-specific directory on system building multi-arch
RcppLdPath <- function() {
""
}
## Provide linker flags -- i.e. -L/path/to/libRcpp -- as well as an
## optional rpath call needed to tell the Linux dynamic linker about the
## location. This is not needed on OS X where we encode this as library
## built time (see src/Makevars) or Windows where we use a static library
## Updated Jan 2010: We now default to static linking but allow the use
## of rpath on Linux if static==FALSE has been chosen
## Note that this is probably being called from LdFlags()
## Updated Nov 2013: We no longer build a library. This should be deprecated.
RcppLdFlags <- function() { "" }
# indicates if Rcpp was compiled with GCC >= 4.3
canUseCXX0X <- function() .Call( "canUseCXX0X", PACKAGE = "Rcpp" )
## Provide compiler flags -- i.e. -I/path/to/Rcpp.h
RcppCxxFlags <- function(cxx0x=FALSE) {
# path <- RcppLdPath()
path <- Rcpp.system.file( "include" )
if (.Platform$OS.type=="windows") {
path <- asBuildPath(path)
}
paste("-I", path, if (cxx0x && canUseCXX0X()) " -std=c++0x" else "", sep="")
}
## Shorter names, and call cat() directly
## CxxFlags defaults to no using c++0x extensions are these are considered non-portable
CxxFlags <- function(cxx0x=FALSE) {
cat(RcppCxxFlags(cxx0x=cxx0x))
}
## LdFlags defaults to static linking on the non-Linux platforms Windows and OS X
LdFlags <- function() {
cat(RcppLdFlags())
}
# capabilities
RcppCapabilities <- capabilities <- function() .Call( rcpp_capabilities )
# compile, load and call the cxx0x.c script to identify whether
# the compiler is GCC >= 4.3
RcppCxx0xFlags <- function(){
script <- Rcpp.system.file( "discovery", "cxx0x.R" )
flag <- capture.output( source( script ) )
flag
}
Cxx0xFlags <- function() cat( RcppCxx0xFlags() )
rcpp-0.11.0/R/RcppClass.R 0000644 0000000 0000000 00000014507 12253723677 011666 0 ustar # 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 .
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)
}
}
loadRcppClass <- function(Class, CppClass = Class,
module = paste0("class_",Class),
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)
}
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))
allmethods <- .makeCppMethods(methods, cppclassinfo, where)
allfields <- .makeCppFields(fields, cppclassinfo, where)
value <- setRefClass(Class, fields = allfields,
contains = c(contains, "RcppClass"),
methods = allmethods, where=where, ...)
## declare the fields and methods to shut up codetools
## the R level fields and methods were declared by setRefClass
## but we declare them again; globalVariables() applies unique()
if(exists("globalVariables", envir = asNamespace("utils"))) # >=2.15.1
utils::globalVariables(c(names(allfields), names(allmethods)),
where)
if(is.character(saveAs) && length(saveAs) == 1)
assign(saveAs, value, envir = where)
value
}
.makeCppMethods <- function(methods, cppclassinfo, env) {
cppMethods <- names(cppclassinfo@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
}
.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@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@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))
}
},
objectPointer = function()
.CppObject$.pointer
)
rcpp-0.11.0/R/Rcpp.package.skeleton.R 0000644 0000000 0000000 00000016572 12270352603 014103 0 ustar # -*- tab-width: 4; -*-
# Copyright (C) 2009 - 2014 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 .
Rcpp.package.skeleton <- function(name = "anRpackage", list = character(),
environment = .GlobalEnv,
path = ".", force = FALSE,
code_files = character(), cpp_files = character(),
example_code = TRUE, attributes = TRUE, module = FALSE,
author = "Who wrote it",
maintainer = if (missing(author)) "Who to complain to"
else author,
email = "yourfault@somewhere.net",
license = "What Licence is it under ?") {
call <- match.call()
call[[1]] <- as.name("package.skeleton")
env <- parent.frame(1)
if (!is.character(cpp_files))
stop("'cpp_files' must be a character vector")
if (!length(list)) {
fake <- TRUE
assign("Rcpp.fake.fun", function() {}, envir = env)
if (example_code && !isTRUE(attributes)) {
assign("rcpp_hello_world", function() {}, envir = env)
remove_hello_world <- TRUE
} else {
remove_hello_world <- FALSE
}
} else {
if (example_code && !isTRUE(attributes)) {
if (!"rcpp_hello_world" %in% list) {
assign( "rcpp_hello_world", function() {}, envir = env)
call[["list"]] <- as.call(c(as.name("c"),
as.list(c("rcpp_hello_world", list))))
}
remove_hello_world <- TRUE
} else {
remove_hello_world <- FALSE
}
fake <- FALSE
}
## first let the traditional version do its business
## remove Rcpp specific arguments
call <- call[ c(1L, which(names(call) %in% names(formals(package.skeleton)))) ]
if (fake) {
call[["list"]] <- c(if(isTRUE(example_code)
&& !isTRUE(attributes)) "rcpp_hello_world", "Rcpp.fake.fun")
}
tryCatch(eval(call, envir = env), error = function(e){
stop(sprintf("error while calling `package.skeleton` : %s", conditionMessage(e)))
})
message("\nAdding Rcpp settings")
## now pick things up
root <- file.path(path, name)
# Add Rcpp to the DESCRIPTION
DESCRIPTION <- file.path(root, "DESCRIPTION")
if (file.exists(DESCRIPTION)) {
imports <- c(if (isTRUE(module)) "methods",
sprintf("Rcpp (>= %s)", packageDescription("Rcpp")[["Version"]]))
x <- cbind(read.dcf(DESCRIPTION),
"Imports" = paste(imports, collapse = ", "),
"LinkingTo" = "Rcpp")
if (isTRUE(module)) {
x <- cbind(x, "RcppModules" = "yada, stdVector, NumEx")
message(" >> added RcppModules: yada, stdVector, NumEx")
}
x[, "Author"] <- author
x[, "Maintainer"] <- sprintf("%s <%s>", maintainer, email)
x[, "License"] <- license
message( " >> added Imports: Rcpp" )
message( " >> added LinkingTo: Rcpp" )
write.dcf(x, file = DESCRIPTION)
}
## add useDynLib and importFrom to NAMESPACE
NAMESPACE <- file.path(root, "NAMESPACE")
lines <- readLines(NAMESPACE)
ns <- file(NAMESPACE, open="w")
if (! grepl("useDynLib", lines)) {
lines <- c(sprintf( "useDynLib(%s)", name), lines)
writeLines(lines, con = ns)
message(" >> added useDynLib directive to NAMESPACE" )
}
if (isTRUE(module)) {
writeLines('import(methods)', ns)
}
writeLines('importFrom(Rcpp, evalCpp)', ns)
message(" >> added importFrom(Rcpp, evalCpp) directive to NAMESPACE" )
close( ns )
## update the package description help page
package_help_page <- file.path(root, "man", sprintf( "%s-package.Rd", name))
if (file.exists(package_help_page)) {
lines <- readLines(package_help_page)
lines <- gsub("What license is it under?", license, lines, fixed = TRUE)
lines <- gsub("Who to complain to ",
sprintf( "%s <%s>", maintainer, email),
lines, fixed = TRUE)
lines <- gsub( "Who wrote it", author, lines, fixed = TRUE)
writeLines(lines, package_help_page)
}
## lay things out in the src directory
src <- file.path(root, "src")
if (!file.exists(src)) {
dir.create(src)
}
skeleton <- system.file("skeleton", package = "Rcpp")
if (length(cpp_files) > 0L) {
for (file in cpp_files) {
file.copy(file, src)
message(" >> copied ", file, " to src directory" )
}
compileAttributes(root)
}
if (example_code) {
if (isTRUE(attributes)) {
file.copy(file.path( skeleton, "rcpp_hello_world_attributes.cpp"),
file.path( src, "rcpp_hello_world.cpp"))
message(" >> added example src file using Rcpp attributes")
compileAttributes(root)
message(" >> compiled Rcpp attributes")
} else {
header <- readLines(file.path(skeleton, "rcpp_hello_world.h"))
header <- gsub("@PKG@", name, header, fixed = TRUE)
writeLines(header , file.path(src, "rcpp_hello_world.h"))
message(" >> added example header file using Rcpp classes")
file.copy(file.path(skeleton, "rcpp_hello_world.cpp"), src)
message(" >> added example src file using Rcpp classes")
rcode <- readLines(file.path( skeleton, "rcpp_hello_world.R"))
rcode <- gsub("@PKG@", name, rcode, fixed = TRUE)
writeLines( rcode , file.path( root, "R", "rcpp_hello_world.R"))
message(" >> added example R file calling the C++ example")
}
hello.Rd <- file.path(root, "man", "rcpp_hello_world.Rd")
unlink(hello.Rd)
file.copy(system.file("skeleton", "rcpp_hello_world.Rd", package = "Rcpp"), hello.Rd)
message( " >> added Rd file for rcpp_hello_world")
}
if (isTRUE( module)) {
file.copy(system.file("skeleton", "rcpp_module.cpp", package="Rcpp"),
file.path(root, "src"))
file.copy(system.file("skeleton", "Num.cpp", package="Rcpp"),
file.path(root, "src"))
file.copy(system.file("skeleton", "stdVector.cpp", package="Rcpp"),
file.path(root, "src"))
file.copy(system.file( "skeleton", "zzz.R", package ="Rcpp"),
file.path(root, "R"))
message(" >> copied the example module file ")
}
lines <- readLines(package.doc <- file.path( root, "man", sprintf("%s-package.Rd", name)))
lines <- sub("~~ simple examples", "%% ~~ simple examples", lines)
lines <- lines[! grepl("~~ package title", lines)]
lines <- lines[! grepl("~~ The author and", lines)]
lines <- sub("Who wrote it", author, lines )
lines <- sub("Who to complain to.*", sprintf("%s <%s>", maintainer, email), lines)
writeLines(lines, package.doc)
if (fake) {
rm("Rcpp.fake.fun", envir = env)
unlink(file.path(root, "R" , "Rcpp.fake.fun.R"))
unlink(file.path(root, "man", "Rcpp.fake.fun.Rd"))
}
if (isTRUE(remove_hello_world)) {
rm("rcpp_hello_world", envir = env)
}
invisible(NULL)
}
rcpp-0.11.0/R/zzz.R 0000644 0000000 0000000 00000001567 12253723677 010633 0 ustar # Copyright (C) 2009 - 2013 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 .
.dummyInstancePointer <- new.env() # just something permanent
.classes_map <- new.env()
.onLoad <- function(libname, pkgname){
new_dummyObject(.dummyInstancePointer);
}
rcpp-0.11.0/R/Module.R 0000644 0000000 0000000 00000037051 12273307750 011210 0 ustar # 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 .
internal_function <- function(pointer){
f <- function(xp){
force(xp)
function(...){
.External( InternalFunction_invoke, xp, ... )
}
}
o <- new( "C++Function", f(pointer) )
o@pointer <- pointer
o
}
setMethod("$", "C++Class", function(x, name) {
x <- x@generator
eval.parent(substitute(x$name))
})
.badModulePointer <- NULL
.setModulePointer <- function(module, value) {
assign("pointer", value, envir = as.environment(module))
value
}
.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())
## 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",
packageName = "",
pointer = .badModulePointer, ...) {
env <- new.env(TRUE, emptyenv())
as(.Object, "environment") <- env
assign("pointer", pointer, envir = env)
assign("packageName", packageName, envir = env)
assign("moduleName", moduleName, envir = env)
if(length(list(...)) > 0) {
.Object <- callNextMethod(.Object, ...)
}
.Object
})
.get_Module_function <- function(x, name, pointer = .getModulePointer(x) ){
pointer <- .getModulePointer(x)
info <- .Call( Module__get_function, pointer, name )
fun_ptr <- info[[1L]]
is_void <- info[[2L]]
doc <- info[[3L]]
sign <- info[[4L]]
formal_args <- info[[5L]]
nargs <- info[[6L]]
f <- function(...) NULL
if( nargs == 0L ) formals(f) <- NULL
stuff <- list( fun_pointer = fun_ptr, InternalFunction_invoke = InternalFunction_invoke )
body(f) <- if( nargs == 0L ){
if( is_void ) {
substitute( {
.External( InternalFunction_invoke, fun_pointer)
invisible(NULL)
}, stuff )
} else {
substitute( {
.External( InternalFunction_invoke, fun_pointer)
}, stuff )
}
} else {
if( is_void ) {
substitute( {
.External( InternalFunction_invoke, fun_pointer, ... )
invisible(NULL)
}, stuff )
} else {
substitute( {
.External( InternalFunction_invoke, fun_pointer, ... )
}, stuff )
}
}
out <- new( "C++Function", f, pointer = fun_ptr, docstring = doc, signature = sign )
if( ! is.null( formal_args ) ){
formals( out ) <- formal_args
}
out
}
.get_Module_Class <- function( x, name, pointer = .getModulePointer(x) ){
value <- .Call( Module__get_class, pointer, name )
value@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 ]]
} )
new_CppObject_xp <- function(module, pointer, ...) {
.External( class__newInstance, module, pointer, ... )
}
new_dummyObject <- function(...)
.External( "class__dummyInstance", ...)
# class method for $initialize
cpp_object_initializer <- function(.self, .refClassDef, ..., .object_pointer){
selfEnv <- as.environment(.self)
## generate the C++-side object and store its pointer, etc.
## access the private fields in the fieldPrototypes env.
fields <- .refClassDef@fieldPrototypes
pointer <- if(missing(.object_pointer)) new_CppObject_xp(fields$.module, fields$.pointer, ...) else .object_pointer
assign(".module", fields$.module, envir = selfEnv)
assign(".pointer", pointer, envir = selfEnv)
assign(".cppclass", fields$.pointer, envir = selfEnv)
.self
}
cpp_object_dummy <- function(.self, .refClassDef) {
selfEnv <- as.environment(.self)
## like initializer but a dummy for the case of no default
## constructor. Will throw an error if the object is used.
fields <- .refClassDef@fieldPrototypes
pointer <- new_dummyObject()
assign(".module", fields$.module, envir = selfEnv)
assign(".pointer", pointer, envir = selfEnv)
assign(".cppclass", fields$.pointer, envir = selfEnv)
.self
}
cpp_object_maker <- function(typeid, pointer){
Class <- .classes_map[[ typeid ]]
new( Class, .object_pointer = pointer )
}
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")
env <- as.environment(module) # not needed from R 2.12.0
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 <- methods::new("Module", pointer = xp, packageName = PACKAGE,
moduleName = moduleName)
} else if(is.character(module)) {
moduleName <- module
xp <- .badModulePointer
module <- methods::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(inherits(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 )
## 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()
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 <- methods::setRefClass( clname,
fields = fields,
contains = "C++Object",
methods = methods,
where = where
)
# just to make codetools happy
.self <- .refClassDef <- NULL
generator$methods(initialize =
if(cpp_hasDefaultConstructor(CLASS))
function(...) cpp_object_initializer(.self,.refClassDef, ...)
else
function(...) {
if(nargs()) cpp_object_initializer(.self,.refClassDef, ...)
else cpp_object_dummy(.self, .refClassDef)
}
)
rm( .self, .refClassDef )
classDef <- methods::getClass(clname)
## non-public (static) fields in class representation
## Should these become real fields?
fields <- classDef@fieldPrototypes
assign(".pointer", CLASS@pointer, envir = fields)
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@methods) ) ) ){
if( "[[" %in% names( CLASS@methods ) ){
methods::setMethod( "[[", clname, function(x, i, j, ..., exact = TRUE){
x$`[[`( i )
}, where = where )
}
if( "[[<-" %in% names( CLASS@methods ) ){
methods::setReplaceMethod( "[[", clname, function(x, i, j, ..., exact = TRUE, value){
x$`[[<-`( i, value )
x
} , where = where )
}
}
# promoting show to S4
if( any( grepl( "show", names(CLASS@methods) ) ) ){
setMethod( "show", clname, function(object) object$show(), 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@typeid ]] <- storage[[ demangled_name ]] <- .get_Module_Class( module, demangled_name, xp )
# exposing enums values as CLASS.VALUE
# (should really be CLASS$value but I don't know how to do it)
if( length( CLASS@enums ) ){
for( enum in CLASS@enums ){
for( i in 1:length(enum) ){
storage[[ paste( demangled_name, ".", names(enum)[i], sep = "" ) ]] <- enum[i]
}
}
}
}
# functions
functions <- .Call( Module__functions_names, xp )
for( fun in functions ){
storage[[ fun ]] <- .get_Module_function( module, fun, xp )
# register as(FROM, TO) methods
converter_rx <- "^[.]___converter___(.*)___(.*)$"
if( length( matches <- grep( converter_rx, functions ) ) ){
for( i in matches ){
fun <- functions[i]
from <- sub( converter_rx, "\\1", fun )
to <- sub( converter_rx, "\\2", fun )
converter <- function( from ){}
body( converter ) <- substitute( { CONVERT(from) },
list( CONVERT = storage[[fun]] )
)
setAs( from, to, converter, where = where )
}
}
}
assign( "storage", storage, envir = as.environment(module) )
module
}
dealWith <- function( x ) if(isTRUE(x[[1]])) invisible(NULL) else x[[2]]
method_wrapper <- function( METHOD, where ){
noargs <- all( METHOD$nargs == 0 )
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,
docstring = METHOD$info("")
)
f <- function(...) NULL
if( noargs ){
formals(f) <- NULL
}
extCall <- if( noargs ) {
if( all( METHOD$void ) ){
# all methods are void, so we know we want to return invisible(NULL)
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
# .External
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
# we get from internally and we need to deal with it
substitute(
{
docstring
dealWith( .External(CppMethod__invoke, class_pointer, pointer, .pointer ) )
} , stuff )
}
} else {
if( all( METHOD$void ) ){
# all methods are void, so we know we want to return invisible(NULL)
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
# .External
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
# we get from internally and we need to deal with it
substitute(
{
docstring
dealWith( .External(CppMethod__invoke, class_pointer, pointer, .pointer, ...) )
} , stuff )
}
}
body(f, where) <- extCall
f
}
## 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(
function(){
.Call( CppObject__finalize, class_pointer , .pointer )
},
list(
CLASS = CLASS@pointer,
CppObject__finalize = CppObject__finalize,
class_pointer = CLASS@pointer
)
) )
mets <- c(
sapply( CLASS@methods, method_wrapper, where = where ),
"finalize" = finalizer
)
mets
}
cpp_hasDefaultConstructor <- function(CLASS) {
.Call( Class__has_default_constructor, CLASS@pointer )
}
binding_maker <- function( FIELD, where ){
f <- function( x ) NULL
body(f) <- substitute({
if( missing( x ) )
.Call( CppField__get, class_pointer, pointer, .pointer)
else
.Call( CppField__set, class_pointer, pointer, .pointer, x)
}, list(class_pointer = FIELD$class_pointer,
pointer = FIELD$pointer,
CppField__get = CppField__get,
CppField__set = CppField__set ))
environment(f) <- where
f
}
cpp_fields <- function( CLASS, where){
sapply( CLASS@fields, binding_maker, where = where )
}
.CppClassName <- function(name)
paste0("Rcpp_",name)
rcpp-0.11.0/R/02_completion.R 0000644 0000000 0000000 00000003234 12253723677 012441 0 ustar # Copyright (C) 2010 - 2011 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 .
setGeneric( ".DollarNames" )
.DollarNames.Module <- function(x, pattern){
pointer <- .getModulePointer( x )
if(identical(pointer, .badModulePointer)) {
stop( "unitialized module" )
}
grep( pattern , .Call( Module__complete, pointer), value = TRUE )
}
setMethod( ".DollarNames", "Module", .DollarNames.Module )
# completion for C++ objects
# 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))
# FIXME: implement another test
# if(identical(xp, .emptyPointer))
# stop("C++ object with unset pointer to C++ class")
.Call( CppClass__complete , xp )
} )
".DollarNames.C++Object" <- function( x, pattern ){
grep( pattern, complete(x), value = TRUE )
}
setMethod( ".DollarNames", "C++Object", `.DollarNames.C++Object` )
rcpp-0.11.0/R/unit.tests.R 0000644 0000000 0000000 00000003303 12273213514 012066 0 ustar # Copyright (C) 2010 - 2014 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 .
test <- function(output=if(file.exists("/tmp")) "/tmp" else getwd()) {
if (require(RUnit)) {
testSuite <- defineTestSuite(name="Rcpp Unit Tests",
dirs=system.file("unitTests", package = "Rcpp"),
testFuncRegexp = "^[Tt]est.+")
## if someoone calls Rcpp::test(), he/she wants all tests
Sys.setenv("RunAllRcppTests"="yes")
## Run tests
tests <- runTestSuite(testSuite)
## Print results
printTextProtocol(tests)
return(tests)
}
stop("Running unit tests requires the 'RUnit' package.")
}
unitTestSetup <- function(file, packages=NULL,
pathToRcppTests=system.file("unitTests", package = "Rcpp")) {
function() {
if (! is.null(packages)) {
for (p in packages) {
suppressMessages(require(p, character.only=TRUE))
}
}
sourceCpp(file.path(pathToRcppTests, "cpp", file))
}
}
rcpp-0.11.0/R/loadRcppModules.R 0000644 0000000 0000000 00000004257 12253723677 013072 0 ustar # 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 .
loadRcppModules <- function(direct=TRUE){
## hunt for the namespace of the package that calls this
calls <- sys.calls()
w <- which( sapply( calls, function(call){
identical( call[[1L]], as.name( "runHook" ) )
} ) )
if( !length(w) )
stop( "loadRcppModules can only be used within a .onLoad function" )
w <- w[ length(w) ]
call <- calls[[w]]
if( !identical( call[[2L]], ".onLoad" ) )
stop( "loadRcppModules can only be used within a .onLoad function" )
f <- sys.frame( w )
ns <- get("env", f )
if( !isNamespace( ns ) )
stop( "loadRcppModules not called from a namespace" )
pkg <- get( "pkgname", f )
lib <- get( "libname", f )
## look for declared modules in the DESCRIPTION fields
description <- packageDescription(pkg, lib.loc=lib)
modules <- description[["RcppModules"]]
if( !is.null( modules ) ){
modules <- strsplit( modules, "[[:space:]]*,[[:space:]]*")[[1L]]
for( m in modules ){
tryCatch( {
mod <- Module( m, pkg, mustStart = TRUE)
if(isTRUE(direct)){
populate( mod, ns )
} 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) ) )
})
}
}
}
rcpp-0.11.0/R/bib.R 0000644 0000000 0000000 00000001451 12253723677 010522 0 ustar # Copyright (C) 2010 - 2012 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 .
bib <- function() {
sub("\\.bib$", "", system.file( "doc", "Rcpp.bib", package = "Rcpp" ) )
}
rcpp-0.11.0/R/03_prompt.R 0000644 0000000 0000000 00000004471 12253723677 011616 0 ustar # Copyright (C) 2010 - 2011 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 .
setGeneric( "functions", function(object, ...) standardGeneric( "functions" ) )
setMethod( "functions", "Module", function(object, ...){
pointer <- .getModulePointer(object)
if(identical(pointer, .badModulePointer))
stop(gettextf("Module \"%s\" has not been intialized: try Module(object)",
get("moduleName", envir = as.environment(object))), domain = NA)
else
.Call( Module__functions_arity, pointer )
} )
setGeneric( "prompt" )
setMethod( "prompt", "Module", function(object, filename = NULL, name = NULL, ...){
lines <- readLines( system.file( "prompt", "module.Rd", package = "Rcpp" ) )
pointer <- .getModulePointer(object)
if( is.null(name) )
name <- .Call( Module__name, pointer )
if( is.null(filename) ) filename <- sprintf( "%s-module.Rd", name )
lines <- gsub( "NAME", name, lines )
info <- functions( object )
f.txt <- if( length( info ) ){
sprintf( "functions: \\\\describe{
%s
}", paste( sprintf( " \\\\item{%s}{ ~~ description of function %s ~~ }", names(info), names(info) ), collapse = "\n" ) )
} else {
""
}
lines <- sub( "FUNCTIONS", f.txt, lines )
## at this point functions() would have failed if the
## pointer in object was not valid
classes <- .Call( Module__classes_info, pointer )
c.txt <- if( length( classes ) ){
sprintf( "classes: \\\\describe{
%s
}", paste( sprintf( " \\\\item{%s}{ ~~ description of class %s ~~ }", names(classes), names(classes) ), collapse = "\n" ) )
} else {
""
}
lines <- sub( "CLASSES", c.txt, lines )
writeLines( lines, filename )
invisible(NULL)
} )
rcpp-0.11.0/R/Attributes.R 0000644 0000000 0000000 00000076363 12273452010 012110 0 ustar # Copyright (C) 2012 JJ Allaire, 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 .
# Source C++ code from a file
sourceCpp <- function(file = "",
code = NULL,
env = globalenv(),
embeddedR = TRUE,
rebuild = FALSE,
showOutput = verbose,
verbose = getOption("verbose")) {
# resolve code into a file if necessary. also track the working
# directory to source the R embedded code chunk within
if (!missing(code)) {
rWorkingDir <- getwd()
file <- tempfile(fileext = ".cpp")
con <- file(file, open = "w")
writeLines(code, con)
close(con)
} else {
rWorkingDir <- dirname(file)
}
# resolve the file path
file <- normalizePath(file, winslash = "/")
# error if the file extension isn't one supported by R CMD SHLIB
if (! tools::file_ext(file) %in% c("cc", "cpp")) {
stop("The filename '", basename(file), "' does not have an ",
"extension of .cc or .cpp so cannot be compiled.")
}
# validate that there are no spaces in the path on windows
if (.Platform$OS.type == "windows") {
if (grepl(' ', basename(file), fixed=TRUE)) {
stop("The filename '", basename(file), "' contains spaces. This ",
"is not permitted.")
}
}
# get the context (does code generation as necessary)
context <- .Call("sourceCppContext", PACKAGE="Rcpp",
file, code, rebuild, .Platform)
# perform a build if necessary
if (context$buildRequired || rebuild) {
# print output for verbose mode
if (verbose)
.printVerboseOutput(context)
# variables used to hold completed state (passed to completed hook)
succeeded <- FALSE
output <- NULL
# build dependency list
depends <- .getSourceCppDependencies(context$depends, file)
# validate packages (error if package not found)
.validatePackages(depends, context$cppSourceFilename)
# temporarily modify environment for the build
envRestore <- .setupBuildEnvironment(depends, context$plugins, file)
# temporarily setwd to build directory
cwd <- getwd()
setwd(context$buildDirectory)
# call the onBuild hook. note that this hook should always be called
# after .setupBuildEnvironment so subscribers are able to examine
# the build environment
fromCode <- !missing(code)
if (!.callBuildHook(context$cppSourcePath, fromCode, showOutput)) {
.restoreEnvironment(envRestore)
setwd(cwd)
return (invisible(NULL))
}
# on.exit handler calls hook and restores environment and working dir
on.exit({
if (!succeeded)
.showBuildFailureDiagnostics()
.callBuildCompleteHook(succeeded, output)
setwd(cwd)
.restoreEnvironment(envRestore)
})
# unload and delete existing dylib if necessary
if (file.exists(context$previousDynlibPath)) {
try(silent=T, dyn.unload(context$previousDynlibPath))
file.remove(context$previousDynlibPath)
}
# prepare the command (output if we are in showOutput mode)
cmd <- paste(R.home(component="bin"), .Platform$file.sep, "R ",
"CMD SHLIB ",
"-o ", shQuote(context$dynlibFilename), " ",
ifelse(rebuild, "--preclean ", ""),
shQuote(context$cppSourceFilename), sep="")
if (showOutput)
cat(cmd, "\n")
# execute the build -- suppressWarnings b/c when showOutput = FALSE
# we are going to explicitly check for an error and print the output
result <- suppressWarnings(system(cmd, intern = !showOutput))
# check build results
if(!showOutput) {
# capture output
output <- result
attributes(output) <- NULL
# examine status
status <- attr(result, "status")
if (!is.null(status)) {
cat(result, "\n")
succeeded <- FALSE
stop("Error ", status, " occurred building shared library.")
} else if (!file.exists(context$dynlibFilename)) {
cat(result, "\n")
succeeded <- FALSE
stop("Error occurred building shared library.")
} else {
succeeded <- TRUE
}
}
else if (!identical(as.character(result), "0")) {
succeeded <- FALSE
stop("Error ", result, " occurred building shared library.")
} else {
succeeded <- TRUE
}
}
else {
if (verbose)
cat("\nNo rebuild required (use rebuild = TRUE to ",
"force a rebuild)\n\n", sep="")
}
# load the module if we have exported symbols
if (length(context$exportedFunctions) > 0 || length(context$modules) > 0) {
# remove existing objects of the same name from the environment
exports <- c(context$exportedFunctions, context$modules)
removeObjs <- exports[exports %in% ls(envir = env, all.names = T)]
remove(list = removeObjs, envir = env)
# source the R script
scriptPath <- file.path(context$buildDirectory, context$rSourceFilename)
source(scriptPath, local = env)
} else if (getOption("rcpp.warnNoExports", default=TRUE)) {
warning("No Rcpp::export attributes or RCPP_MODULE declarations ",
"found in source")
}
# source the embeddedR
if (embeddedR && (length(context$embeddedR) > 0)) {
srcConn <- textConnection(context$embeddedR)
setwd(rWorkingDir) # will be reset by previous on.exit handler
source(file=srcConn, echo=TRUE)
}
# return (invisibly) a list containing exported functions and modules
invisible(list(functions = context$exportedFunctions,
modules = context$modules))
}
# Define a single C++ function
cppFunction <- function(code,
depends = character(),
plugins = character(),
includes = character(),
env = parent.frame(),
rebuild = FALSE,
showOutput = verbose,
verbose = getOption("verbose")) {
# process depends
if (!is.null(depends) && length(depends) > 0) {
depends <- paste(depends, sep=", ")
scaffolding <- paste("// [[Rcpp::depends(", depends, ")]]", sep="")
scaffolding <- c(scaffolding, "", .linkingToIncludes(depends, FALSE),
recursive=TRUE)
}
else {
scaffolding <- "#include "
}
# process plugins
if (!is.null(plugins) && length(plugins) > 0) {
plugins <- paste(plugins, sep=", ")
pluginsAttrib <- paste("// [[Rcpp::plugins(", plugins, ")]]", sep="")
scaffolding <- c(scaffolding, pluginsAttrib)
# append plugin includes
for (pluginName in plugins) {
plugin <- .findPlugin(pluginName)
settings <- plugin()
scaffolding <- c(scaffolding, settings$includes, recursive=TRUE)
}
}
# remainder of scaffolding
scaffolding <- c(scaffolding,
"",
"using namespace Rcpp;",
"",
includes,
"// [[Rcpp::export]]",
recursive = T)
# prepend scaffolding to code
code <- paste(c(scaffolding, code, recursive = T), collapse="\n")
# print the generated code if we are in verbose mode
if (verbose) {
cat("\nGenerated code for function definition:",
"\n--------------------------------------------------------\n\n")
cat(code)
cat("\n")
}
# source cpp into specified environment. if env is set to NULL
# then create a new one (the caller can get a hold of the function
# via the return value)
if (is.null(env))
env <- new.env()
exported <- sourceCpp(code = code,
env = env,
rebuild = rebuild,
showOutput = showOutput,
verbose = verbose)
# verify that a single function was exported and return it
if (length(exported$functions) == 0)
stop("No function definition found")
else if (length(exported$functions) > 1)
stop("More than one function definition")
else {
functionName <- exported$functions[[1]]
invisible(get(functionName, env))
}
}
.type_manipulate <- function( what = "DEMANGLE", class = NULL ) {
function( type = "int", ... ){
code <- sprintf( '
SEXP manipulate_this_type(){
typedef %s type ;
return wrap( %s(type) ) ;
}', type, what )
dots <- list( code, ... )
dots[["env"]] <- environment()
manipulate_this_type <- do.call( cppFunction, dots )
res <- manipulate_this_type()
if( ! is.null(class) ){
class(res) <- class
}
res
}
}
demangle <- .type_manipulate( "DEMANGLE" )
sizeof <- .type_manipulate( "sizeof", "bytes" )
print.bytes <- function( x, ...){
writeLines( sprintf( "%d bytes (%d bits)", x, 8 * x ) )
invisible( x )
}
# Evaluate a simple c++ expression
evalCpp <- function(code,
depends = character(),
includes = character(),
rebuild = FALSE,
showOutput = verbose,
verbose = getOption( "verbose" ) ){
code <- sprintf( "SEXP get_value(){ return wrap( %s ) ; }", code )
env <- new.env()
cppFunction(code, depends = depends, includes = includes, env = env,
rebuild = rebuild, showOutput = showOutput, verbose = verbose )
fun <- env[["get_value"]]
fun()
}
areMacrosDefined <- function(names,
depends = character(),
includes = character(),
rebuild = FALSE,
showOutput = verbose,
verbose = getOption( "verbose" ) ){
code <- sprintf( '
LogicalVector get_value(){
return LogicalVector::create(
%s
) ;
}',
paste( sprintf( ' _["%s"] =
#if defined(%s)
true
#else
false
#endif
', names, names ), collapse = ",\n" )
)
env <- new.env()
cppFunction(code, depends = depends, includes = includes, env = env,
rebuild = rebuild, showOutput = showOutput, verbose = verbose )
fun <- env[["get_value"]]
fun()
}
# Scan the source files within a package for attributes and generate code
# based on the attributes.
compileAttributes <- function(pkgdir = ".", verbose = getOption("verbose")) {
# verify this is a package and read the DESCRIPTION to get it's name
pkgdir <- normalizePath(pkgdir, winslash = "/")
descFile <- file.path(pkgdir,"DESCRIPTION")
if (!file.exists(descFile))
stop("pkgdir must refer to the directory containing an R package")
pkgDesc <- read.dcf(descFile)[1,]
pkgname = .readPkgDescField(pkgDesc, "Package")
depends <- .readPkgDescField(pkgDesc, "Depends", character())
depends <- unique(.splitDepends(depends))
depends <- depends[depends != "R"]
# determine source directory
srcDir <- file.path(pkgdir, "src")
if (!file.exists(srcDir))
return (FALSE)
# create R directory if it doesn't already exist
rDir <- file.path(pkgdir, "R")
if (!file.exists(rDir))
dir.create(rDir)
# get a list of all source files
cppFiles <- list.files(srcDir, pattern="\\.c(c|pp)$")
# derive base names (will be used for modules)
cppFileBasenames <- tools::file_path_sans_ext(cppFiles)
# expend them to their full paths
cppFiles <- file.path(srcDir, cppFiles)
cppFiles <- normalizePath(cppFiles, winslash = "/")
# generate the includes list based on LinkingTo. Specify plugins-only
# because we only need as/wrap declarations
linkingTo <- .readPkgDescField(pkgDesc, "LinkingTo")
includes <- .linkingToIncludes(linkingTo, TRUE)
# if a master include file is defined for the package then include it
pkgHeader <- paste(pkgname, ".h", sep="")
pkgHeaderPath <- file.path(pkgdir, "inst", "include", pkgHeader)
if (file.exists(pkgHeaderPath)) {
pkgInclude <- paste("#include \"../inst/include/",
pkgHeader, "\"", sep="")
includes <- c(pkgInclude, includes)
}
# generate exports
invisible(.Call("compileAttributes", PACKAGE="Rcpp",
pkgdir, pkgname, depends, cppFiles, cppFileBasenames,
includes, verbose, .Platform))
}
# setup plugins environment
.plugins <- new.env()
# built-in C++11 plugin
.plugins[["cpp11"]] <- function() {
list(env = list(PKG_CXXFLAGS ="-std=c++11"))
}
## built-in OpenMP++11 plugin
.plugins[["openmp"]] <- function() {
list(env = list(PKG_CXXFLAGS="-fopenmp",
PKG_LIBS="-fopenmp"))
}
# register a plugin
registerPlugin <- function(name, plugin) {
.plugins[[name]] <- plugin
}
# Take an empty function body and connect it to the specified external symbol
sourceCppFunction <- function(func, isVoid, dll, symbol) {
args <- names(formals(func))
body <- quote( CALL_PLACEHOLDER ( EXTERNALNAME, ARG ) )[ c(1:2, rep(3, length(args))) ]
for (i in seq(along = args))
body[[i+2]] <- as.symbol(args[i])
body[[1L]] <- .Call
body[[2L]] <- getNativeSymbolInfo(symbol, dll)$address
if (isVoid)
body <- call("invisible", body)
body(func) <- body
func
}
# Print verbose output
.printVerboseOutput <- function(context) {
cat("\nGenerated extern \"C\" functions",
"\n--------------------------------------------------------\n")
cat(context$generatedCpp, sep="")
cat("\nGenerated R functions",
"\n-------------------------------------------------------\n\n")
cat(readLines(file.path(context$buildDirectory,
context$rSourceFilename)),
sep="\n")
cat("\nBuilding shared library",
"\n--------------------------------------------------------\n",
"\nDIR: ", context$buildDirectory, "\n\n", sep="")
}
# Add LinkingTo dependencies if the sourceFile is in a package
.getSourceCppDependencies <- function(depends, sourceFile) {
# If the source file is in a package then simulate it being built
# within the package by including it's LinkingTo dependencies,
# the src directory (.), and the inst/include directory
if (.isPackageSourceFile(sourceFile)) {
descFile <- file.path(dirname(sourceFile), "..", "DESCRIPTION")
DESCRIPTION <- read.dcf(descFile, all = TRUE)
linkingTo <- .parseLinkingTo(DESCRIPTION$LinkingTo)
unique(c(depends, linkingTo))
} else {
depends
}
}
# Check whether a source file is in a package
.isPackageSourceFile <- function(sourceFile) {
file.exists(file.path(dirname(sourceFile), "..", "DESCRIPTION"))
}
# Error if a package is not currently available
.validatePackages <- function(depends, sourceFilename) {
unavailable <- depends[!depends %in% .packages(all.available=TRUE)]
if (length(unavailable) > 0) {
stop(paste("Package '", unavailable[[1]], "' referenced from ",
"Rcpp::depends in source file ",
sourceFilename, " is not available.",
sep=""),
call. = FALSE)
}
}
# Split the depends field of a package description
.splitDepends <- function(x) {
if (!length(x))
return(character())
x <- unlist(strsplit(x, ","))
x <- sub("[[:space:]]+$", "", x)
x <- unique(sub("^[[:space:]]*(.*)", "\\1", x))
sub("^([[:alnum:].]+).*$", "\\1", x)
}
# read a field from a named package description character vector
.readPkgDescField <- function(pkgDesc, name, default = NULL) {
if (name %in% names(pkgDesc))
pkgDesc[[name]]
else
default
}
# Get the inline plugin for the specified package (return NULL if none found)
.getInlinePlugin <- function(package) {
tryCatch(get("inlineCxxPlugin", asNamespace(package)),
error = function(e) NULL)
}
# Lookup a plugin
.findPlugin <- function(pluginName) {
plugin <- .plugins[[pluginName]]
if (is.null(plugin))
stop("Inline plugin '", pluginName, "' could not be found ",
"within the Rcpp package. You should be ",
"sure to call registerPlugin before using a plugin.")
return(plugin)
}
# Setup the build environment based on the specified dependencies. Returns an
# opaque object that can be passed to .restoreEnvironment to reverse whatever
# changes that were made
.setupBuildEnvironment <- function(depends, plugins, sourceFile) {
# setup
buildEnv <- list()
linkingToPackages <- c("Rcpp")
# merge values into the buildEnv
mergeIntoBuildEnv <- function(name, value) {
# protect against null or empty string
if (is.null(value) || !nzchar(value))
return;
# if it doesn't exist already just set it
if (is.null(buildEnv[[name]])) {
buildEnv[[name]] <<- value
}
# if it's not identical then append
else if (!identical(buildEnv[[name]], value)) {
buildEnv[[name]] <<- paste(buildEnv[[name]], value);
}
else {
# it already exists and it's the same value, this
# likely means it's a flag-type variable so we
# do nothing rather than appending it
}
}
# update dependencies from a plugin
setDependenciesFromPlugin <- function(plugin) {
# get the plugin settings
settings <- plugin()
# merge environment variables
pluginEnv <- settings$env
for (name in names(pluginEnv)) {
mergeIntoBuildEnv(name, pluginEnv[[name]])
}
# capture any LinkingTo elements defined by the plugin
linkingToPackages <<- unique(c(linkingToPackages,
settings$LinkingTo))
}
# add packages to linkingTo and introspect for plugins
for (package in depends) {
# add a LinkingTo for this package
linkingToPackages <- unique(c(linkingToPackages, package))
# see if the package exports a plugin
plugin <- .getInlinePlugin(package)
if (!is.null(plugin))
setDependenciesFromPlugin(plugin)
}
# process plugins
for (pluginName in plugins) {
plugin <- .findPlugin(pluginName)
setDependenciesFromPlugin(plugin)
}
# if there is no buildEnv from a plugin then use the Rcpp plugin
if (length(buildEnv) == 0) {
buildEnv <- inlineCxxPlugin()$env
}
# set CLINK_CPPFLAGS based on the LinkingTo dependencies
buildEnv$CLINK_CPPFLAGS <- .buildClinkCppFlags(linkingToPackages)
# if the source file is in a package then add src and inst/include
if (.isPackageSourceFile(sourceFile)) {
srcDir <- dirname(sourceFile)
srcDir <- asBuildPath(srcDir)
incDir <- file.path(dirname(sourceFile), "..", "inst", "include")
incDir <- asBuildPath(incDir)
dirFlags <- paste0('-I"', c(srcDir, incDir), '"', collapse=" ")
buildEnv$CLINK_CPPFLAGS <- paste(buildEnv$CLINK_CPPFLAGS,
dirFlags,
collapse=" ")
}
# merge existing environment variables
for (name in names(buildEnv))
mergeIntoBuildEnv(name, Sys.getenv(name))
# add cygwin message muffler
buildEnv$CYGWIN = "nodosfilewarning"
# on windows see if we need to add Rtools to the path
# (don't do this for RStudio since it has it's own handling)
if (identical(Sys.info()[['sysname']], "Windows") &&
!nzchar(Sys.getenv("RSTUDIO"))) {
path <- .pathWithRtools()
if (!is.null(path))
buildEnv$PATH <- path
}
# create restore list
restore <- list()
for (name in names(buildEnv))
restore[[name]] <- Sys.getenv(name, unset = NA)
# set environment variables
do.call(Sys.setenv, buildEnv)
# return restore list
return (restore)
}
# If we don't have the GNU toolchain already on the path then see if
# we can find Rtools and add it to the path
.pathWithRtools <- function() {
# Only proceed if we don't have the required tools on the path
hasRtools <- nzchar(Sys.which("ls.exe")) && nzchar(Sys.which("gcc.exe"))
if (!hasRtools) {
# Read the Rtools registry key
key <- NULL
try(key <- utils::readRegistry("SOFTWARE\\R-core\\Rtools",
hive = "HLM", view = "32-bit"),
silent = TRUE)
# If we found the key examine it
if (!is.null(key)) {
# Check version -- we only support 2.15 and 2.16 right now
ver <- key$`Current Version`
if (identical("2.15", ver) || identical("2.16", ver) ||
identical("3.0", ver) || identical("3.1", ver)) {
# See if the InstallPath leads to the expected directories
rToolsPath <- key$`InstallPath`
if (!is.null(rToolsPath)) {
# Return modified PATH if execpted directories exist
binPath <- file.path(rToolsPath, "bin", fsep="\\")
gccPath <- file.path(rToolsPath, "gcc-4.6.3", "bin", fsep="\\")
if (file.exists(binPath) && file.exists(gccPath))
return(paste(binPath,
gccPath,
Sys.getenv("PATH"),
sep=.Platform$path.sep))
}
}
}
}
return(NULL)
}
# Build CLINK_CPPFLAGS from include directories of LinkingTo packages
.buildClinkCppFlags <- function(linkingToPackages) {
pkgCxxFlags <- NULL
for (package in linkingToPackages) {
packagePath <- find.package(package, NULL, quiet=TRUE)
packagePath <- asBuildPath(packagePath)
pkgCxxFlags <- paste(pkgCxxFlags,
paste0('-I"', packagePath, '/include"'),
collapse=" ")
}
return (pkgCxxFlags)
}
.restoreEnvironment <- function(restore) {
# variables to reset
setVars <- restore[!is.na(restore)]
if (length(setVars))
do.call(Sys.setenv, setVars)
# variables to remove
removeVars <- names(restore[is.na(restore)])
if (length(removeVars))
Sys.unsetenv(removeVars)
}
# Call the onBuild hook. This hook is provided so that external tools
# can perform processing (e.g. lint checking or other diagnostics) prior
# to the execution of a build). The showOutput flag is there to inform the
# subscriber whether they'll be getting output in the onBuildComplete hook
# or whether it will need to be scraped from the console (for verbose=TRUE)
# The onBuild hook is always called from within the temporary build directory
.callBuildHook <- function(file, fromCode, showOutput) {
for (fun in .getHooksList("sourceCpp.onBuild")) {
if (is.character(fun))
fun <- get(fun)
# allow the hook to cancel the build (errors in the hook explicitly
# do not cancel the build since they are unexpected bugs)
continue <- tryCatch(fun(file, fromCode, showOutput),
error = function(e) TRUE)
if (!continue)
return (FALSE)
}
return (TRUE)
}
# Call the onBuildComplete hook. This hook is provided so that external tools
# can do analysis of build errors and (for example) present them in a
# navigable list. Note that the output parameter will be NULL when showOutput
# is TRUE. Tools can try to scrape the output from the console (in an
# implemenentation-dependent fashion) or can simply not rely on output
# processing in that case (since the user explicitly asked for output to be
# printed to the console). The onBuildCompleted hook is always called within
# the temporary build directory.
.callBuildCompleteHook <- function(succeeded, output) {
# Call the hooks in reverse order to align sequencing with onBuild
for (fun in .getHooksList("sourceCpp.onBuildComplete")) {
if (is.character(fun))
fun <- get(fun)
try(fun(succeeded, output))
}
}
# The value for getHooks can be a single function or a list of functions,
# This function ensures that the result can always be processed as a list
.getHooksList <- function(name) {
hooks <- getHook(name)
if (!is.list(hooks))
hooks <- list(hooks)
hooks
}
# Generate list of includes based on LinkingTo. The pluginsOnly parameter
# to distinguish the case of capturing all includes needed for a compiliation
# (e.g. cppFunction) verses only needing to capture as/wrap converters which
# is the case for generation of shims (RcppExports.cpp) and Rcpp::interfaces
# package header files.
.linkingToIncludes <- function(linkingTo, pluginsOnly) {
# This field can be NULL or empty -- in that case just return Rcpp.h
if (is.null(linkingTo) || !nzchar(linkingTo))
return (c("#include "))
# Look for Rcpp inline plugins within the list or LinkedTo packages
include.before <- character()
include.after <- character()
linkingToPackages <- .parseLinkingTo(linkingTo)
for (package in linkingToPackages) {
# We already handle Rcpp internally
if (identical(package, "Rcpp"))
next
# see if there is a plugin that we can extract includes from
plugin <- .getInlinePlugin(package)
if (!is.null(plugin)) {
includes <- .pluginIncludes(plugin)
if (!is.null(includes)) {
include.before <- c(include.before, includes$before)
include.after <- c(include.after, includes$after)
}
}
# otherwise check for standard Rcpp::interfaces generated include
else if (!pluginsOnly) {
pkgPath <- find.package(package, NULL, quiet=TRUE)
pkgHeader <- paste(package, ".h", sep="")
pkgHeaderPath <- file.path(pkgPath, "include", pkgHeader)
if (file.exists(pkgHeaderPath)) {
pkgInclude <- paste("#include <", pkgHeader, ">", sep="")
include.after <- c(include.after, pkgInclude)
}
}
}
# return the includes
c(include.before, "#include ", include.after)
}
# Analyze the plugin's includes field to determine include.before and
# include.after. We are ONLY interested in plugins that work with Rcpp since
# the only types we need from includes are as/wrap marshallers. Therefore,
# we verify that the plugin was created using Rcpp.plugin.maker and then
# use that assumption to correctly extract include.before and include.after
.pluginIncludes <- function(plugin) {
# First determine the standard suffix of an Rcpp plugin by calling
# Rcpp.plugin.maker. If the plugin$includes has this suffix we know
# it's an Rcpp plugin
token <- "include_after_token"
stockRcppPlugin <- Rcpp.plugin.maker(include.after=token)
includes <- stockRcppPlugin()$includes
suffix <- strsplit(includes, token)[[1]][[2]]
# now ask the plugin for it's includes, ensure that the plugin includes
# are not null, and verify they have the Rcpp suffix before proceeding
pluginIncludes <- plugin()$includes
if (is.null(pluginIncludes))
return (NULL)
if (!grepl(suffix, pluginIncludes))
return (NULL)
# strip the suffix then split on stock Rcpp include to get before and after
pluginIncludes <- strsplit(pluginIncludes, suffix)[[1]][[1]]
pluginIncludes <- strsplit(pluginIncludes, c("#include "))[[1]]
# extract before and after and nix empty lines
before <- pluginIncludes[[1]]
before <- strsplit(before, "\n")[[1]]
before <- before[nzchar(before)]
after <- pluginIncludes[[2]]
after <- strsplit(after, "\n")[[1]]
after <- after[nzchar(after)]
# return before and after
list(before = before, after = after)
}
# Parse a LinkingTo field into a character vector
.parseLinkingTo <- function(linkingTo) {
if (is.null(linkingTo))
return (character())
linkingTo <- strsplit(linkingTo, "\\s*\\,")[[1]]
gsub("\\s", "", linkingTo)
}
# show diagnostics for failed builds
.showBuildFailureDiagnostics <- function() {
# RStudio does it's own diagnostics so only do this for other environments
if (nzchar(Sys.getenv("RSTUDIO")))
return();
# if we can't call R CMD SHLIB then notify the user they should
# install the appropriate development tools
if (!.checkDevelTools()) {
msg <- paste("\nWARNING: The tools required to build C++ code for R ",
"were not found.\n\n", sep="")
sysName <- Sys.info()[['sysname']]
if (identical(sysName, "Windows")) {
msg <- paste(msg, "Please download and install the appropriate ",
"version of Rtools:\n\n",
"http://cran.r-project.org/bin/windows/Rtools/\n",
sep="");
} else if (identical(sysName, "Darwin")) {
msg <- paste(msg, "Please install Command Line Tools for XCode ",
"(or equivalent).\n", sep="")
} else {
msg <- paste(msg, "Please install GNU development tools ",
"including a C++ compiler.\n", sep="")
}
message(msg)
}
}
# check if R development tools are installed (cache successful result)
.hasDevelTools <- FALSE
.checkDevelTools <- function() {
if (!.hasDevelTools) {
# create temp source file
tempFile <- file.path(tempdir(), "foo.c")
cat("void foo() {}\n", file = tempFile)
on.exit(unlink(tempFile))
# set working directory to tempdir (revert on exit)
oldDir <- setwd(tempdir())
on.exit(setwd(oldDir), add = TRUE)
# attempt the compilation and note whether we succeed
cmd <- paste(R.home(component="bin"), .Platform$file.sep, "R ",
"CMD SHLIB foo.c", sep = "")
result <- suppressWarnings(system(cmd,
ignore.stderr = TRUE,
intern = TRUE))
assignInMyNamespace(".hasDevelTools", is.null(attr(result, "status")))
# if we build successfully then remove the shared library
if (.hasDevelTools) {
lib <- file.path(tempdir(),
paste("foo", .Platform$dynlib.ext, sep=''))
unlink(lib)
}
}
.hasDevelTools
}
rcpp-0.11.0/R/exposeClass.R 0000644 0000000 0000000 00000016221 12253723677 012260 0 ustar .stdHeader <- c(
"#include ",
"using namespace Rcpp ;"
)
.asString <- function(what) if(is.character(what)) what else deparse(what)
.strings <- function(expr) {
if(is.call(expr) && ! identical(expr[[1]], quote(`::`)))
lapply(as.list(expr)[-1], .strings)
else
.asString(expr)
}
.specifyItems <- function(what) {
what <- as.list(what)
wn <- allNames(what)
simple <- !nzchar(wn)
## todo: error checking here that unnamed elements are single strings
wn[simple] <- as.character(what[simple])
names(what) <- wn
what[simple] <- list(character())
what
}
.writeFieldFunction <- function(fldi, typei, CppClass, readOnly, ns, con){
rootName <- paste0("field_", fldi)
writeLines(sprintf(" %s %s_get(%s *obj) { return obj->%s; }\n",
typei, rootName, CppClass, fldi), con)
value <- "_get"
if(!readOnly) {
writeLines(sprintf(" void %s_set(%s *obj, %s value) { obj->%s = value; }\n",
rootName, CppClass, typei, fldi), con)
value <- c(value, "_set")
}
paste0(ns, "::field_", fldi, value)
}
.writeMethodFunction <- function(mdi, sigi, CppClass, ns, con) {
mName <- paste0("method_", mdi)
if(length(sigi) < 1)
stop(gettextf("The type signature for method %s for class %s was of length 0: Must at least include the return type",
mdi, CppClass))
rtnType <- sigi[[1]]
sigi <- sigi[-1]
if(length(sigi)) {
argNames <- paste0("a", seq_along(sigi))
args <- paste(" ,", paste(sigi, argNames, collapse = ", "))
}
else argNames <- args <- ""
writeLines(sprintf(" %s %s(%s *obj%s){ return obj->%s(%s); }\n",
rtnType, mName, CppClass, args, mdi, argNames), con)
paste0(ns, "::",mName)
}
exposeClass <- function(class, constructors, fields, methods,
file = paste0(CppClass, "Module.cpp"),
header = character(),
module = paste0("class_",class), CppClass = class,
readOnly = character(), rename = character(),
Rfile = TRUE) {
## some argument checks
## TODO: checks on constructors, fields, methods
if(length(readOnly)) {
readOnly <- as.character(readOnly)
if(!all(nzchar(readOnly)))
stop("argument readOnly should be a vector of non-empty strings")
}
newnames <- allNames(rename)
if(length(rename)) {
if(!all(sapply(rename, function(x) is.character(x) && length(x) == 1 && nzchar(x))))
stop("argument rename should be a vector of single, non-empty strings")
if(!all(nzchar(newnames)))
stop("all the elements of argument rename should be non-empty strings")
}
if(is.character(file)) {
## are we in a package directory? Writable, searchable src subdirectory:
if(file.access("src",3)==0)
cfile <- file.path("src", file)
else
cfile <- file
con <- file(cfile, "w")
on.exit({message(sprintf("Wrote C++ file \"%s\"", cfile)); close(con)})
}
else
con <- file
## and for the R code:
if(identical(Rfile, FALSE)) {}
else {
if(identical(Rfile, TRUE))
Rfile <- sprintf("%sClass.R",class)
if(is.character(Rfile)) {
if(file.access("R",3)==0) # in a package directory
Rfile <- file.path("R", Rfile)
Rcon <- file(Rfile, "w")
msg <- sprintf("Wrote R file \"%s\"",Rfile)
on.exit({message(msg); close(Rcon)}, add = TRUE)
}
else
Rcon <- Rfile
Rfile <- TRUE
}
mfile <- tempfile()
mcon <- file(mfile, "w")
writeLines(.stdHeader, con)
if(length(header))
writeLines(header, con)
writeLines(c("", sprintf("RCPP_MODULE(%s) {\n",module), ""), mcon)
writeLines(sprintf(" class_<%s>(\"%s\")\n", CppClass, class), mcon)
## the constructors argument defines a list of vectors of types
for( cons in constructors) {
if(length(cons) > 1 ||
(length(cons) == 1 && nzchar(cons) && !identical(cons, "void")))
cons <- paste0("<", paste(cons, collapse = ","),">")
else
cons = ""
writeLines(paste0(" .constructor",cons,"()"),mcon)
}
writeLines("", mcon)
flds <- .specifyItems(fields)
nm <- names(flds)
rdOnly <- nm %in% readOnly
macros <- ifelse(rdOnly, ".field_readonly", ".field")
test <- nm %in% rename
if(any(test))
nm[test] <- newnames[match(nm[test], newnames)]
ns <- NULL
for(i in seq_along(nm)) {
typei <- flds[[i]]
nmi <- fldi <- nm[[i]]
macroi <- macros[[i]]
if(!length(typei) || identical(typei, "")) ## direct field
writeLines(sprintf(" %s(\"%s\", &%s::%s)",
macroi, nmi, CppClass, fldi), mcon)
else { # create a free function, e.g. for an inherited field
if(is.null(ns)) { # enclose in a namespace
ns <- paste("module",class,"NS", sep = "_")
writeLines(sprintf("\nnamespace %s {\n", ns),
con)
}
fldFuns <- .writeFieldFunction(fldi, typei, CppClass, rdOnly[[i]], ns, con)
if(rdOnly[[i]])
## NOTE: string 3rd arg. required by problem w. module parsing 10/3/13
writeLines(sprintf(" .property(\"%s\", &%s, \"read-only field\")",
nmi, fldFuns[[1]]), mcon)
else
writeLines(sprintf(" .property(\"%s\", &%s, &%s)",
nmi, fldFuns[[1]], fldFuns[[2]]), mcon)
}
}
writeLines("", mcon)
sigs <- .specifyItems(methods)
nm <- mds <- names(sigs)
test <- nm %in% rename
if(any(test))
nm[test] <- newnames[match(nm[test], newnames)]
for(i in seq_along(nm)) {
sigi <- sigs[[i]]
nmi <- nm[[i]]
mdi <- mds[[i]]
if(!length(sigi) || identical(sigi, "")) # direct method
writeLines(sprintf(" .method(\"%s\", &%s::%s)",
nmi, CppClass, mdi), mcon)
else { # create a free function, e.g. for an inherited method
if(is.null(ns)) { # enclose in a namespace
ns <- paste("module",class,"NS", sep = "_")
writeLines(sprintf("\nnamespace %s {\n", ns),
con)
}
mFun <- .writeMethodFunction(mdi, sigi, CppClass, ns, con)
writeLines(sprintf(" .method(\"%s\", &%s)",
nmi, mFun), mcon)
}
}
writeLines(" ;\n}", mcon)
close(mcon)
if(!is.null(ns))
writeLines(sprintf("} // %s", ns), con) # close namespace
writeLines(readLines(mfile), con)
if(Rfile) {
if(missing(CppClass))
CppString <- ""
else
CppString <- paste(",",dQuote(CppClass))
if(missing(module))
ModString <- ""
else
ModString <- paste(", module =", dQuote(module))
writeLines(sprintf("%s <- setRcppClass(\"%s\"%s%s)",
class, class, CppString,ModString), Rcon)
}
}
rcpp-0.11.0/R/01_show.R 0000644 0000000 0000000 00000010126 12253723677 011245 0 ustar # 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 .
setMethod( "show", "C++Object", 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 )
} )
setMethod( "show", "C++Class", function(object){
doc <- object@docstring
txt <- sprintf( "C++ class '%s' <%s>%s",
.Call( Class__name, object@pointer ),
externalptr_address(object@pointer),
if( length(doc) && nchar(doc) ) sprintf( "\n docstring : %s", doc ) else ""
)
writeLines( txt )
ctors <- object@constructors
nctors <- length( ctors )
txt <- character( nctors )
for( i in seq_len(nctors) ){
ctor <- ctors[[i]]
doc <- ctor$docstring
txt[i] <- sprintf( " %s%s", ctor$signature, if( nchar(doc) ) sprintf( "\n docstring : %s", doc) else "" )
}
writeLines( "Constructors:" )
writeLines( paste( txt, collapse = "\n" ) )
fields <- object@fields
nfields <- length(fields)
if( nfields ){
names <- names(fields)
txt <- character(nfields)
writeLines( "\nFields: " )
for( i in seq_len(nfields) ){
f <- fields[[i]]
doc <- f$docstring
txt[i] <- sprintf( " %s %s%s%s",
f$cpp_class,
names[i],
if( f$read_only ) " [readonly]" else "",
if( nchar(doc) ) sprintf( "\n docstring : %s", doc ) else ""
)
}
writeLines( paste( txt, collapse = "\n" ) )
} else {
writeLines( "\nFields: No public fields exposed by this class" )
}
mets <- object@methods
nmethods <- length(mets)
if( nmethods ){
writeLines( "\nMethods: " )
txt <- character( nmethods )
for( i in seq_len(nmethods) ){
txt[i] <- mets[[i]]$info(" ")
}
writeLines( paste( txt, collapse = "\n" ) )
} else {
writeLines( "\nMethods: no methods exposed by this class" )
}
} )
setMethod( "show", "C++Function", function(object){
txt <- sprintf( "internal C++ function <%s>", externalptr_address(object@pointer) )
writeLines( txt )
doc <- object@docstring
if( length(doc) && nchar( doc ) ){
writeLines( sprintf( " docstring : %s", doc ) )
}
sign <- object@signature
if( length(sign) && nchar( sign ) ){
writeLines( sprintf( " signature : %s", sign ) )
}
} )
setMethod( "show", "Module", function( object ){
pointer <- .getModulePointer(object, FALSE)
if(identical(pointer, .badModulePointer)) {
object <- as.environment(object) ## not needed when 2.12.0 arrives
txt <- sprintf("Uninitialized module named \"%s\" from package \"%s\"",
get("moduleName", envir = object),
get("packageName", envir = object))
writeLines(txt)
}
else {
info <- .Call( Module__functions_arity, pointer )
name <- .Call( Module__name, pointer )
txt <- sprintf( "Rcpp module '%s' \n\t%d functions: ", name, length(info) )
writeLines( txt )
txt <- sprintf( "%15s : %d arguments", names(info), info )
writeLines( txt )
info <- .Call( Module__classes_info, pointer )
txt <- sprintf( "\n\t%d classes : ", length(info) )
writeLines( txt )
txt <- sprintf( "%15s ", names(info) )
writeLines( txt )
}
} )
rcpp-0.11.0/R/tools.R 0000644 0000000 0000000 00000003376 12253723677 011136 0 ustar # Copyright (C) 2010 - 2012 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 .
externalptr_address <- function(xp){
.Call( as_character_externalptr, xp )
}
# just like assignInNamespace but first checks that the binding exists
forceAssignInNamespace <- function( x, value, env ){
is_ns <- isNamespace( env )
unlocker <- get( "unlockBinding", baseenv() )
if( is_ns && exists( x, env ) && bindingIsLocked(x, env ) ){
unlocker( x, env )
}
assign( x, value, env )
if( is_ns ){
lockBinding( x, env )
}
}
# Transform a path for passing to the build system on the command line.
# Leave paths alone for posix. For Windows, mirror the behavior of the
# R package build system by starting with the fully resolved absolute path,
# transforming it to a short path name if it contains spaces, and then
# converting backslashes to forward slashes
asBuildPath <- function(path) {
if (.Platform$OS.type == "windows") {
path <- normalizePath(path)
if (grepl(' ', path, fixed=TRUE))
path <- utils::shortPathName(path)
path <- gsub("\\\\", "/", path)
}
return(path)
}
rcpp-0.11.0/R/exceptions.R 0000644 0000000 0000000 00000001441 12253723677 012146 0 ustar # Copyright (C) 2009 - 2012 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 .
.rcpp_error_recorder <- function(e){
invisible( .Call( rcpp_error_recorder, e ) )
}
rcpp-0.11.0/R/inline.R 0000644 0000000 0000000 00000003017 12253723677 011244 0 ustar # Copyright (C) 2009 - 2013 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 .
Rcpp.plugin.maker <- function(
include.before = "",
include.after = "",
LinkingTo = unique( c( package, "Rcpp" ) ),
Depends = unique( c( package, "Rcpp" ) ),
libs = "",
Makevars = NULL ,
Makevars.win = NULL,
package = "Rcpp"
){
function( ... ){
includes <- sprintf( "%s
#include
%s
#ifndef BEGIN_RCPP
#define BEGIN_RCPP
#endif
#ifndef END_RCPP
#define END_RCPP
#endif
using namespace Rcpp;
", include.before, include.after )
out <- list(
env = list( PKG_LIBS = libs ),
includes = includes,
LinkingTo = LinkingTo ,
body = function( x ){
sprintf( "BEGIN_RCPP\n%s\nEND_RCPP", x )
},
Depends = Depends
)
if( !is.null(Makevars ) ) out$Makevars <- Makevars
if( !is.null(Makevars.win ) ) out$Makevars.win <- Makevars.win
out
}
}
inlineCxxPlugin <- Rcpp.plugin.maker()
rcpp-0.11.0/README.md 0000644 0000000 0000000 00000010264 12273300210 010673 0 ustar Rcpp: Seamless R and C++ Integration
====================================
[](https://travis-ci.org/RcppCore/Rcpp)
The [Rcpp package](http://cran.r-project.org/package=Rcpp) provides R functions as well as a C++ library
which facilitate the integration of R and C++
R data types (`SEXP`) are matched to C++ objects in a class hierarchy. All R
types are supported (vectors, functions, environment, etc ...) and each
type is mapped to a dedicated class. For example, numeric vectors are
represented as instances of the Rcpp::NumericVector class, environments are
represented as instances of Rcpp::Environment, functions are represented as
Rcpp::Function, etc ...
The
[Rcpp-introduction](http://cran.r-project.org/web/packages/Rcpp/vignettes/Rcpp-introduction.pdf)
vignette (also published as a [JSS paper](http://www.jstatsoft.org/v40/i08/)) provides a good
entry point to Rcpp as do the [Rcpp website](http://www.rcpp.org), the
[Rcpp page](http://dirk.eddelbuettel.com/code/rcpp.html) and the
[Rcpp Gallery](http://gallery.rcpp.org). Full documentation
is provided by the [Rcpp book](http://www.rcpp.org/book/).
Conversion from C++ to R and back is driven by the templates `Rcpp::wrap`
and `Rcpp::as` which are highly flexible and extensible, as documented
in the [Rcpp-extending](http://cran.r-project.org/web/packages/Rcpp/vignettes/Rcpp-extending.pdf) vignette.
Rcpp also provides Rcpp modules, a framework that allows exposing
C++ functions and classes to the R level. The [Rcpp-modules]((http://cran.r-project.org/web/packages/Rcpp/vignettes/Rcpp-modules.pdf) vignette
details the current set of features of Rcpp-modules.
Rcpp includes a concept called Rcpp sugar that brings many R functions
into C++. Sugar takes advantage of lazy evaluation and expression templates
to achieve great performance while exposing a syntax that is much nicer
to use than the equivalent low-level loop code. The [Rcpp-sugar]((http://cran.r-project.org/web/packages/Rcpp/vignettes/Rcpp-sugar.pdf)
gives an overview of the feature.
Rcpp attributes provide a high-level syntax for declaring C++
functions as callable from R and automatically generating the code
required to invoke them. Attributes are intended to facilitate both
interactive use of C++ within R sessions as well as to support R
package development. Attributes are built on top of Rcpp modules and
their implementation is based on previous work in the inline package.
See the [Rcpp-atttributes]((http://cran.r-project.org/web/packages/Rcpp/vignettes/Rcpp-attributes.pdf) vignettes for more details.
## Documentation
The package ships with nine pdf vignettes.
Additional documentation is available via the
[JSS paper](http://www.jstatsoft.org/v40/i08/) by Eddelbuettel and
Francois (2011, JSS) paper (corresponding to the 'intro' vignette)
and the [book](http://www.rcpp.org/book) by Eddelbuettel (2013, Springer);
see 'citation("Rcpp")' for details.
## Examples
The [Rcpp Gallery](http://gallery.rcpp.org) showcases over 70 fully documented
and working examples.
A number of examples are included as are over 800 unit tests in over 400 unit
test functions provide additional usage examples.
The [CRAN](http://cran.r-project.org) network contains
(as over early 2014) over 160 packages which also provide usage examples.
An earlier version of Rcpp, containing what we now call the 'classic Rcpp
API' was written during 2005 and 2006 by Dominick Samperi. This code has
been factored out of Rcpp into the package RcppClassic, and it is still
available for code relying on the older interface. New development should
always use this Rcpp package instead.
## Installation
Released and tested versions of Rcpp are available via the
[CRAN](http://cran.r-project.org) network, and can be installed from within R via
```R
install.packages("Rcpp")
```
To install from source, ensure you have a
[complete package development environment](http://www.rstudio.com/ide/docs/packages/prerequisites).
Also see questions 1.2 and 1.3 in the [Rcpp-FAQ](http://cran.r-project.org/web/packages/Rcpp/vignettes/Rcpp-FAQ.pdf).
## Authors
Dirk Eddelbuettel, Romain Francois, JJ Allaire, Doug Bates, John Chamber and
Kevin Ushey
## License
GPL (>= 2)
rcpp-0.11.0/build/ 0000755 0000000 0000000 00000000000 12273452733 010532 5 ustar rcpp-0.11.0/build/vignette.rds 0000644 0000000 0000000 00000000731 12273452733 013072 0 ustar TMS0Oj^h)
ެœ0ײ,rIJu1k&eY $609#ǹBcY٧a/j