Nothing
plugins <- new.env()
plugins[["default"]] <- function() {
includes = '
#include <R.h>
#include <Rdefines.h>
#include <R_ext/Error.h>
'
list(includes = includes,
body = function(x) {
paste0(x,
'\nRf_warning("your C++ program does not return anything");',
'\nreturn R_NilValue;')})
}
registerPlugin <- function(name, plugin) {
plugins[[ name ]] <- plugin
}
getPlugin <- function(name, ...) {
if (name %in% ls(plugins)) {
plugins[[ name ]](...)
} else if (sprintf("package:%s", name) %in% search() || requireNamespace(name, quietly = TRUE)) {
plugin <- get("inlineCxxPlugin", asNamespace(name))
if (is.null(plugin)) {
stop(sprintf("package '%s' does not define an inline plugin", name))
}
registerPlugin(name, plugin)
plugin(...)
} else {
stop(sprintf("could not find plugin '%s'", name))
}
}
paste0 <- function(...) paste(..., sep="")
addLineNumbers <- function(code) {
code <- strsplit(paste(code, collapse = "\n" ), "\n")[[1]]
sprintf("%4d : %s", 1:length(code), code)
}
cxxfunction <- function(sig = character(), body = character(),
plugin = "default", includes = "",
settings = getPlugin(plugin),
..., verbose = FALSE) {
f <- basename(tempfile())
if (!is.list(sig)) {
sig <- list(sig)
names(sig) <- f
if (!length(body)) body <- ""
names(body) <- f
}
if (length(sig) != length(body))
stop("mismatch between the number of functions declared in 'sig' and the number of function bodies provided in 'body'")
signature <- lapply( sig, function(x) {
if (!length(x)){
""
} else {
paste(sprintf("SEXP %s", names(x) ), collapse = ", ")
}
})
decl <- lapply(1:length(sig) , function(index) {
sprintf('SEXP %s( %s) ;', names(signature)[index], signature[[index]])
} )
def <- lapply(1:length(sig), function(index){
sprintf('SEXP %s(%s) {\n%s\n}',
names(signature)[index],
signature[[index]],
if (is.null(settings$body)) body[[index]] else settings$body(body[[index]]) )
})
settings_includes <- if (is.null(settings$includes)) "" else paste(settings$includes, collapse = "\n")
code <- sprintf('
// includes from the plugin
%s
// user includes
%s
// declarations
extern "C" {
%s
}
// definition
%s
',
settings_includes,
paste(includes, collapse = "\n"),
paste(decl, collapse = "\n"),
paste(def, collapse = "\n"))
if (!is.null(env <- settings$env)) {
do.call(Sys.setenv, env)
if (isTRUE(verbose)) {
cat(" >> setting environment variables: \n")
writeLines(sprintf("%s = %s", names(env), env))
}
}
LinkingTo <- settings$LinkingTo
if (!is.null(LinkingTo)) {
paths <- find.package(LinkingTo, quiet=TRUE)
if (length(paths)) {
flag <- paste(paste0('-I"', paths, '/include"'), collapse = " ")
Sys.setenv(CLINK_CPPFLAGS = flag)
if (isTRUE(verbose)) {
cat(sprintf("\n >> LinkingTo : %s\n", paste(LinkingTo, collapse = ", ")))
cat("CLINK_CPPFLAGS = ", flag, "\n\n")
}
}
}
if (isTRUE(verbose)) {
writeLines(" >> Program source :\n")
writeLines(addLineNumbers(code))
}
language <- "C++"
## WRITE AND COMPILE THE CODE
libLFile <- compileCode(f, code, language = language, verbose = verbose)
## SET A FINALIZER TO PERFORM CLEANUP
cleanup <- function(env) {
if (f %in% names(getLoadedDLLs())) dyn.unload(libLFile)
unlink(libLFile)
}
reg.finalizer(environment(), cleanup, onexit=TRUE)
## Create new objects of class CFunc, each containing the code of ALL inline
## functions. This will be used to recompile the whole shared lib when needed
res <- vector("list", length(sig))
names(res) <- names(sig)
res <- new("CFuncList", res)
DLL <- dyn.load(libLFile)
for (i in seq_along(sig)) {
res[[i]] <- new("CFunc", code = code)
fn <- function(arg) {
NULL
}
## Modify the function formals to give the right argument list
args <- formals(fn)[ rep(1, length(sig[[i]])) ]
names(args) <- names(sig[[i]])
formals(fn) <- args
## create .Call function call that will be added to 'fn'
body <- quote(.Call(EXTERNALNAME, ARG))[ c(1:2, rep(3, length(sig[[i]]))) ]
for (j in seq_along(sig[[i]])) body[[j+2]] <- as.name(names(sig[[i]])[j])
body[[1L]] <- .Call
body[[2L]] <- getNativeSymbolInfo(names(sig)[[i]], DLL)$address
## update the body of 'fn'
body(fn) <- body
## set fn as THE function in CFunc of res[[i]]
res[[i]]@.Data <- fn
}
## clear the environment
rm(j)
convention <- ".Call"
if (identical(length(sig), 1L)) res[[1L]] else res
}
rcpp <- function(..., plugin="Rcpp") cxxfunction(..., plugin=plugin)
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.