[Rcpp-devel] [Rcpp-commits] r184 - in pkg: . R inst inst/examples inst/examples/RcppInline man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Dec 11 20:26:58 CET 2009
Author: edd
Date: 2009-12-11 20:26:57 +0100 (Fri, 11 Dec 2009)
New Revision: 184
Added:
pkg/R/RcppInline.R
pkg/inst/examples/RcppInline/
pkg/inst/examples/RcppInline/RcppInlineExample.r
pkg/man/RcppInline.Rd
Modified:
pkg/NAMESPACE
pkg/inst/ChangeLog
Log:
added cfunction from inline with a small patch to use it directly for Rcpp -- now we can extend R with C++ code straight from the R prompt
patch sent upstream as well for inclusion in Rcpp -- if Oleg integrates this we will probably remove it here
Modified: pkg/NAMESPACE
===================================================================
--- pkg/NAMESPACE 2009-12-11 16:19:19 UTC (rev 183)
+++ pkg/NAMESPACE 2009-12-11 19:26:57 UTC (rev 184)
@@ -5,3 +5,14 @@
RcppDateExample,
RcppParamsExample,
RcppVectorExample)
+
+## from inline
+import("methods")
+
+export(
+ "cfunction"
+)
+
+exportMethods(
+ "setCMethod"
+)
Added: pkg/R/RcppInline.R
===================================================================
--- pkg/R/RcppInline.R (rev 0)
+++ pkg/R/RcppInline.R 2009-12-11 19:26:57 UTC (rev 184)
@@ -0,0 +1,284 @@
+## Taken from inline 0.3.3, and includes the patch I sent to Oleg with a request for inclusion
+
+## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+## CFunc is an S4 class derived from 'function'. This inheritance allows objects
+## to behave exactly as functions do, but it provides a slot @code that keeps the
+## source C or Fortran code used to create the inline call
+setClass("CFunc",
+ representation(
+ code="character"
+ ),
+ contains="function"
+)
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+cfunction <- function(sig=character(), body=character(), includes=character(), otherdefs=character(),
+ language=c("C++", "C", "Fortran", "F95", "ObjectiveC", "ObjectiveC++"),
+ verbose=FALSE, convention=c(".Call", ".C", ".Fortran"), Rcpp=FALSE) {
+
+ convention <- match.arg(convention)
+
+ if ( missing(language) ) language <- ifelse(convention == ".Fortran", "Fortran", "C++")
+ else language <- match.arg(language)
+
+ language <- switch(EXPR=tolower(language), cpp="C++", f="Fortran", f95="F95",
+ objc="ObjectiveC", objcpp= ,"objc++"="ObjectiveC++", language)
+
+ f <- basename(tempfile())
+
+ if ( !is.list(sig) ) {
+ sig <- list(sig)
+ names(sig) <- f
+ 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'")
+
+ if (Rcpp) {
+ includes <- paste(includes, "\n#include <Rcpp.h>\n", sep="")
+ cxxflags <- paste("PKG_CXXFLAGS=\"", Rcpp:::RcppCxxFlags(), "\"", sep="")
+ ldflags <- paste("PKG_LIBS=\"", Rcpp:::RcppLdFlags(), "\"", sep="")
+ pkgargs <- paste(cxxflags, ldflags, " ", sep=" ")
+ } else {
+ pkgargs <- character()
+ }
+
+ ## GENERATE THE CODE
+ for ( i in seq_along(sig) ) {
+ ## C/C++ with .Call convention *********************************************
+ if ( convention == ".Call" ) {
+ ## include R includes, also error
+ if (i == 1) {
+ code <- paste("#include <R.h>\n#include <Rdefines.h>\n",
+ "#include <R_ext/Error.h>\n", sep="");
+ ## include further includes
+ code <- paste(c(code, includes, ""), collapse="\n")
+ ## include further definitions
+ code <- paste(c(code, otherdefs, ""), collapse="\n")
+ }
+ ## generate C-function sig from the original sig
+ if ( length(sig[[i]]) > 0 ) {
+ funCsig <- paste("SEXP", names(sig[[i]]), collapse=", " )
+ }
+ else funCsig <- ""
+ funCsig <- paste("SEXP", names(sig)[i], "(", funCsig, ")", sep=" ")
+ ## add C export of the function
+ if ( language == "C++" || language == "ObjectiveC++")
+ code <- paste( code, "extern \"C\" {\n ", funCsig, ";\n}\n\n", sep="")
+ ## OPEN function
+ code <- paste( code, funCsig, " {\n", sep="")
+ ## add code, split lines
+ code <- paste( code, paste(body[[i]], collapse="\n"), sep="")
+ ## CLOSE function, add return and warning in case the user forgot it
+ code <- paste( code, "\n warning(\"your C program does not return anything!\");\n return R_NilValue;\n}\n", sep="");
+ }
+
+ ## C/C++ with .C convention ************************************************
+ else if ( convention == ".C" ) {
+ if (i == 1) {
+ ## include only basic R includes
+ code <- "#include <R.h>\n"
+ ## include further includes
+ code <- paste(c(code, includes, ""), collapse="\n")
+ ## include further definitions
+ code <- paste(c(code, otherdefs, ""), collapse="\n")
+ }
+ ## determine function header
+ if ( length(sig[[i]]) > 0 ) {
+ types <- pmatch(sig[[i]], c("logical", "integer", "double", "complex",
+ "character", "raw", "numeric"), duplicates.ok = TRUE)
+ if ( any(is.na(types)) ) stop( paste("Unrecognized type", sig[[i]][is.na(types)]) )
+ decls <- c("int *", "int *", "double *", "Rcomplex *", "char **",
+ "unsigned char *", "double *")[types]
+ funCsig <- paste(decls, names(sig[[i]]), collapse=", ")
+ }
+ else funCsig <- ""
+ funCsig <- paste("void", names(sig)[i], "(", funCsig, ")", sep=" ")
+ if ( language == "C++" || language == "ObjectiveC++" )
+ code <- paste( code, "extern \"C\" {\n ", funCsig, ";\n}\n\n", sep="")
+ ## OPEN function
+ code <- paste( code, funCsig, " {\n", sep="")
+ ## add code, split lines
+ code <- paste( code, paste(body[[i]], collapse="\n"), sep="")
+ ## CLOSE function
+ code <- paste( code, "\n}\n", sep="")
+ }
+ ## .Fortran convention *****************************************************
+ else {
+ if (i == 1) {
+ ## no default includes, include further includes
+ code <- paste(includes, collapse="\n")
+ ## include further definitions
+ code <- paste(c(code, otherdefs, ""), collapse="\n")
+ }
+ ## determine function header
+ if ( length(sig[[i]]) > 0 ) {
+ types <- pmatch(sig[[i]], c("logical", "integer", "double", "complex",
+ "character", "raw", "numeric"), duplicates.ok = TRUE)
+ if ( any(is.na(types)) ) stop( paste("Unrecognized type", sig[[i]][is.na(types)]) )
+ if (6 %in% types) stop( "raw type unsupported by .Fortran()" )
+ decls <- c("INTEGER", "INTEGER", "DOUBLE PRECISION", "DOUBLE COMPLEX",
+ "CHARACTER*255", "Unsupported", "DOUBLE PRECISION")[types]
+ decls <- paste(" ", decls, " ", names(sig[[i]]), "(*)", sep="", collapse="\n")
+ funCsig <- paste(names(sig[[i]]), collapse=", ")
+ }
+ else {
+ decls <- ""
+ funCsig <- ""
+ }
+ funCsig <- paste(" SUBROUTINE", names(sig)[i], "(", funCsig, ")\n", sep=" ")
+ ## OPEN function
+ code <- paste( code, funCsig, decls, collapse="\n")
+ ## add code, split lines
+ code <- paste( code, paste(body[[i]], collapse="\n"), sep="")
+ ## CLOSE function
+ code <- paste( code, "\n RETURN\n END\n", sep="")
+ }
+ } ## for along signatures
+
+ ## WRITE AND COMPILE THE CODE
+ libLFile <- compileCode(f, code, language, verbose, pkgargs)
+
+ ## 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)
+
+ res <- vector("list", length(sig))
+ names(res) <- names(sig)
+
+ ## GENERATE R FUNCTIONS
+ for ( i in seq_along(sig) ) {
+ ## 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[[i]] <- new("CFunc", code = code)
+
+ ## this is the skeleton of the function, the external call is added below using 'body'
+ ## important here: all variables are kept in the local environment
+ fn <- function(arg) {
+ if ( !file.exists(libLFile) )
+ libLFile <<- compileCode(f, code, language, verbose, pkgargs)
+ if ( !( f %in% names(getLoadedDLLs()) ) ) dyn.load(libLFile)
+ }
+
+ ## 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 .C/.Call function call that will be added to 'fn'
+ if (convention == ".Call") {
+ body <- quote( CONVENTION("EXTERNALNAME", PACKAGE=f, ARG) )[ c(1:3, rep(4, length(sig[[i]]))) ]
+ for ( j in seq(along = sig[[i]]) ) body[[j+3]] <- as.name(names(sig[[i]])[j])
+ }
+ else {
+ body <- quote( CONVENTION("EXTERNALNAME", PACKAGE=f, as.logical(ARG), as.integer(ARG),
+ as.double(ARG), as.complex(ARG), as.character(ARG),
+ as.character(ARG), as.double(ARG)) )[ c(1:3,types+3) ]
+ names(body) <- c( NA, "name", "PACKAGE", names(sig[[i]]) )
+ for ( j in seq(along = sig[[i]]) ) body[[j+3]][[2]] <- as.name(names(sig[[i]])[j])
+ }
+ body[[1]] <- as.name(convention)
+ body[[2]] <- names(sig)[i]
+ ## update the body of 'fn'
+ body(fn)[[4]] <- body
+ ## set fn as THE function in CFunc of res[[i]]
+ res[[i]]@.Data <- fn
+ }
+
+ ## OUTPUT PROGRAM CODE IF DESIRED
+ if ( verbose ) {
+ cat("Program source:\n")
+ lines <- strsplit(code, "\n")
+ for ( i in 1:length(lines[[1]]) )
+ cat(format(i,width=3), ": ", lines[[1]][i], "\n", sep="")
+ }
+
+ ## Remove unnecessary objects from the local environment
+ remove(list = c("args", "body", "convention", "fn", "funCsig", "i", "includes", "j"))
+
+ ## RETURN THE FUNCTION
+ if (length(res) == 1 && names(res) == f) return( res[[1]] )
+ else return( res )
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+compileCode <- function(f, code, language, verbose, pkgargs="") {
+ ## Prepare temp file names
+ if ( .Platform$OS.type == "windows" ) {
+ ## windows files
+ dir <- gsub("\\\\", "/", tempdir())
+ libCFile <- paste(dir, "/", f, ".EXT", sep="")
+ libLFile <- paste(dir, "/", f, ".dll", sep="")
+ libLFile2 <- paste(dir, "/", f, ".dll", sep="")
+ }
+ else {
+ ## UNIX-alike build
+ libCFile <- paste(tempdir(), "/", f, ".EXT", sep="")
+ libLFile <- paste(tempdir(), "/", f, ".so", sep="")
+ libLFile2 <- paste(tempdir(), "/", f, ".sl", sep="")
+ }
+ extension <- switch(language, "C++"=".cpp", C=".c", Fortran=".f", F95=".f95",
+ ObjectiveC=".m", "ObjectiveC++"=".mm")
+ libCFile <- sub(".EXT$", extension, libCFile)
+
+ ## Write the code to the temp file for compilation
+ write(code, libCFile)
+
+ ## Compile the code using the running version of R if several available
+ if ( file.exists(libLFile) ) file.remove( libLFile )
+ if ( file.exists(libLFile2) ) file.remove( libLFile2 )
+
+ compiled <- system(paste(pkgargs, R.home(component="bin"), "/R CMD SHLIB ", libCFile, sep=""), intern=!verbose)
+
+ if ( !file.exists(libLFile) && file.exists(libLFile2) ) libLFile <- libLFile2
+ if ( !file.exists(libLFile) ) {
+ cat("\nERROR(s) during compilation: source code errors or compiler configuration errors!\n")
+ cat("\nProgram source:\n")
+ code <- strsplit(code, "\n")
+ for (i in 1:length(code[[1]])) cat(format(i,width=3), ": ", code[[1]][i], "\n", sep="")
+ stop( "Compilation ERROR, function(s)/method(s) not created!" )
+ }
+ return( libLFile )
+}
+
+
+## -- also include cmethods.R here
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+setGeneric( "setCMethod", function(f, sig, body, ...) standardGeneric("setCMethod") )
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+setMethod( "setCMethod", signature(f="character", sig="list", body="list"),
+ function(f, sig, body, includes="", otherdefs="",
+ language=c("C++", "C", "Fortran", "F95", "ObjectiveC", "ObjectiveC++"),
+ verbose=FALSE, convention=c(".Call", ".C", ".Fortran"),
+ where=topenv(.GlobalEnv), ...) {
+ if ( length(f) != length(sig) || length(sig) != length(body) )
+ stop("number of signatures does not correspond to the number of code chunks")
+
+ names(sig) <- f
+ fns <- cfunction(sig, body, includes, otherdefs, language, verbose, convention)
+
+ if ( verbose )
+ cat("\nThe following methods are now defined:\n")
+ ## Let's try to create generics
+ for ( i in 1:length(f) ) {
+ generic <- paste( "setGeneric(\"", f[i], "\", function(",
+ paste(names(sig[[i]]),collapse=", "), ") standardGeneric(\"",
+ f[i], "\"),where=where )", sep="")
+ eval(parse(text=generic))
+ setMethod(f[i], sig[[i]], fns[[i]], where=where)
+ if ( verbose ) showMethods(f[i])
+ }
+ }
+)
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+setMethod( "setCMethod", signature(f="character", sig="character", body="character"),
+ function(f, sig, body, includes="", otherdefs="", language=c("C++", "C", "Fortran", "F95", "ObjectiveC", "ObjectiveC++"),
+ verbose=FALSE, convention=c(".Call", ".C", ".Fortran"), where=topenv(.GlobalEnv), ...)
+ setCMethod(f, list(sig), list(body), includes, otherdefs, language, verbose, convention, where=topenv(.GlobalEnv), ...)
+)
+
Modified: pkg/inst/ChangeLog
===================================================================
--- pkg/inst/ChangeLog 2009-12-11 16:19:19 UTC (rev 183)
+++ pkg/inst/ChangeLog 2009-12-11 19:26:57 UTC (rev 184)
@@ -1,5 +1,13 @@
2009-12-11 Dirk Eddelbuettel <edd at debian.org>
+ * R/RcppInline.R: Imported function 'cfunction' from the inline
+ package, along with small patch to directly support Rcpp. The
+ inclusion may be temporary -- if our patch is integrated into
+ inline we may just depend on that package
+ * man/RcppInline.Rd: Imported from inline, plus change for Rcpp
+ * inst/examples/RcppInline/RcppInlineExample.r: Small example
+ taken from the 'Intro to HPC with R' tutorials
+
* R/RcppVersion.R: Removed as unused as redundant given read.dcf() in R
* man/RcppVersion.R: idem
* NAMESPACE: updated accordingly
Added: pkg/inst/examples/RcppInline/RcppInlineExample.r
===================================================================
--- pkg/inst/examples/RcppInline/RcppInlineExample.r (rev 0)
+++ pkg/inst/examples/RcppInline/RcppInlineExample.r 2009-12-11 19:26:57 UTC (rev 184)
@@ -0,0 +1,43 @@
+#!/usr/bin/r
+
+suppressMessages(library(Rcpp))
+
+foo <- '
+ SEXP rl = R_NilValue; // Use this when there is nothing to be returned.
+ char* exceptionMesg = NULL; // msg var in case of error
+
+ try {
+ RcppVector<int> vec(v); // vec parameter viewed as vector of ints.
+ int n = vec.size(), i = 0;
+ if (n != 10000) throw std::length_error("Wrong vector size");
+ for (int a = 0; a < 9; a++)
+ for (int b = 0; b < 9; b++)
+ for (int c = 0; c < 9; c++)
+ for (int d = 0; d < 9; d++)
+ vec(i++) = a*b - c*d;
+
+ RcppResultSet rs; // Build result set to be returned as a list to R.
+ rs.add("vec", vec); // vec as named element with name "vec"
+ rl = rs.getReturnList(); // Get the list to be returned to R.
+ } catch(std::exception& ex) {
+ exceptionMesg = copyMessageToR(ex.what());
+ } catch(...) {
+ exceptionMesg = copyMessageToR("unknown reason");
+ }
+
+ if (exceptionMesg != NULL) Rf_error(exceptionMesg);
+
+ return rl;
+'
+
+funx <- cfunction(signature(v="numeric"), foo, Rcpp=TRUE)
+
+dd.inline.rcpp <- function() {
+ x <- integer(10000)
+ res <- funx(v=x)[[1]]
+ tabulate(res)
+}
+
+print(mean(replicate(100,system.time(dd.inline.rcpp())["elapsed"]),trim=0.05))
+
+
Property changes on: pkg/inst/examples/RcppInline/RcppInlineExample.r
___________________________________________________________________
Name: svn:executable
+ *
Added: pkg/man/RcppInline.Rd
===================================================================
--- pkg/man/RcppInline.Rd (rev 0)
+++ pkg/man/RcppInline.Rd 2009-12-11 19:26:57 UTC (rev 184)
@@ -0,0 +1,224 @@
+\name{cfunction}
+
+\alias{cfunction}
+\alias{setCMethod}
+\alias{inline}
+
+\concept{inline function call}
+
+\title{ Inline C, C++, Fortran function calls from R }
+
+\description{
+ Functionality to dynamically define R functions and S4 methods with in-lined C,
+ C++ or Fortran code supporting .C and .Call calling conventions.
+}
+
+\usage{
+ cfunction(sig=character(), body=character(), includes=character(),
+ otherdefs=character(),
+ language=c("C++", "C", "Fortran", "F95", "ObjectiveC", "ObjectiveC++"),
+ verbose=FALSE,
+ convention=c(".Call", ".C", ".Fortran"),
+ Rcpp=FALSE)
+
+ ## S4 methods for signatures
+ # f='character', sig='list', body='list'
+ # f='character', sig='character', body='character'
+
+ setCMethod(f, sig, body, ...)
+
+ ## Further arguments:
+ # setCMethod(f, sig, body, includes="", otherdefs="", cpp=TRUE, verbose=FALSE, where=topenv(.GlobalEnv), ...)
+}
+
+\arguments{
+ \item{f}{A single character value if \code{sig} and \code{body} are character vectors
+ or a character vector of the same length and the length of \code{sig} or
+ \code{body} with the name(s) of methods to create.}
+
+ \item{sig}{A match of formal argument names for the function with the
+ character-string names of corresponding classes. Alternatively,
+ a list of such character vectors. }
+
+ \item{body}{ A character vector with C, C++ or Fortran code omitting function
+ declaration (only the body, i.e. in case of C starting after the function
+ opening curly bracket and ending before the closing curly bracket,
+ brackets excluded). In case of \code{setCMethod} with signature
+ \code{list} -- a list of such character vectors. }
+
+ \item{includes}{ A character vector of additional includes and preprocessor
+ statements etc that will be put between the R includes and the user function(s).}
+
+ \item{otherdefs}{ A characted vector with the code for any further definitions of
+ functions, classes, types, forward declarations, namespace usage clauses etc
+ which is inserted between the includes and the declarations of the functions
+ defined in \code{sig}.}
+
+ \item{language}{ A character value that specifies the source language of the
+ inline code. The possible values for \code{language} include all those
+ supported by \code{R CMD SHLIB} on any platform, which are currently C,
+ C++, Fortran, F95, ObjectiveC and ObjectiveC++; they may not all be supported
+ on your platform. One can specify the language either in full as above, or
+ using any of the following case insensitive shortened forms: \code{c, cpp,
+ c++, f, f95, objc, objcpp, objc++}. Defaults to \code{C++}.}
+
+ \item{verbose}{ If \code{TRUE} prints the compilation output, the source
+ code of the resulting program and the definitions of all declared
+ methods. If \code{FALSE}, the function is silent, but it prints compiler
+ warning and error messages and the source code if compilation fails. }
+
+ \item{convention}{ Which calling convention to use? See the Details section.}
+
+ \item{Rcpp}{If \code{TRUE} adds inclusion of \code{Rcpp.h} to
+ \code{includes}, also queries the \code{Rcpp} package about
+ the location of header and library files and sets environment
+ variables \code{PKG_CXXFLAGS} and \code{PKG_LIBS} accordingly so that
+ the R / C++ interface provided by the \code{Rcpp} package can be
+ used. Default value is \code{FALSE}.}
+
+ \item{...}{ Reserved.}
+}
+
+\value{
+ If \code{sig} is a single character vector, \code{cfunction} returns a single
+ \code{\link{function}}; if it is a list, it returns a list of functions.
+
+ \code{setCMethod} declares new methods with given names and signatures and
+ returns invisible \code{NULL}.
+}
+
+\details{
+
+ To declare multiple functions in the same library one can use \code{setCMethod}
+ supplying lists of signatures and implementations. In this case, provide as
+ many method names in \code{f} as you define methods. Avoid clashes when selecting
+ names of the methods to declare, i.e. if you provide the same name several times
+ you must ensure that signatures are different but can share the same generic!
+
+ The source code in the \code{body} should not include the header or
+ "front-matter" of the function or the close, e.g. in C or C++ it
+ must start after the C-function opening curly bracket and end before
+ the C-function closing curly bracket, brackets should not be
+ included. The header will be automatically generated from the R-\code{signature}
+ argument. Arguments will will carry the same name as used in the signature,
+ so avoid variable names that are not legal in the target language
+ (e.g. names with dots).
+
+ C/C++: If \code{convention == ".Call"} (the default), the \code{\link{.Call}} mechanism
+ is used and its result is returned directly as the result of the call of the
+ generated function. As the last line of the generated C/C++ code a
+ \code{return R_NilValue;} is added in this case and a warning is generated
+ in case the user has forgotten to provide a return value. To suppress the
+ warning and still return NULL, add \code{return R_NilValue;} explicitly.
+
+ Special care is needed with types, memory allocation and protection
+ -- exactly the same as if the code was not inline: see the
+ Writing R Extension manual for information on \code{\link{.Call}}.
+
+ If \code{convention == ".C"} or \code{convention == ".Fortran"}, the
+ \code{\link{.C}} or \code{\link{.Fortran}} mechanism respectively is
+ used, and the return value is a list containing all arguments.
+
+ Attached R includes include \code{R.h} for \code{".C"}, and
+ additionally \code{Rdefines.h} and \code{R_ext\\Error.h} for
+ \code{".Call"}.
+
+ Note: This has been adapted from the \code{inline} package, and a
+ patch has been submitted to Oleg Sklyar, its principal author. If the
+ patch is included in \code{inline} the functionality will likely be
+ removed here.
+}
+
+\seealso{ \code{
+ \link{Foreign} Function Interface
+}}
+
+\examples{
+
+## A simple Fortran example
+code <- "
+ integer i
+ do 1 i=1, n(1)
+ 1 x(i) = x(i)**3
+"
+cubefn <- cfunction(signature(n="integer", x="numeric"), code, convention=".Fortran")
+
+x <- as.numeric(1:10)
+n <- as.integer(10)
+cubefn(n, x)$x
+
+## Use of .C convention with C code
+## Defining two functions, one of which calls the other
+sigSq <- signature(n="integer", x="numeric")
+codeSq <- "
+ for (int i=0; i < *n; i++) {
+ x[i] = x[i]*x[i];
+ }"
+sigQd <- signature(n="integer", x="numeric")
+codeQd <- "
+ squarefn(n, x);
+ squarefn(n, x);
+"
+
+fns <- cfunction( list(squarefn=sigSq, quadfn=sigQd),
+ list(codeSq, codeQd),
+ convention=".C")
+
+squarefn <- fns[["squarefn"]]
+quadfn <- fns[["quadfn"]]
+
+squarefn(n, x)$x
+quadfn(n, x)$x
+
+## Alternative declaration using 'setCMethod'
+setCMethod(c("squarefn", "quadfn"), list(sigSq, sigQd),
+ list(codeSq, codeQd), convention=".C")
+
+squarefn(n, x)$x
+quadfn(n, x)$x
+
+## Use of .Call convention with C code
+## Multyplying each image in a stack with a 2D Gaussian at a given position
+code <- "
+ SEXP res;
+ int nprotect = 0, nx, ny, nz, x, y;
+ PROTECT(res = Rf_duplicate(a)); nprotect++;
+ nx = INTEGER(GET_DIM(a))[0];
+ ny = INTEGER(GET_DIM(a))[1];
+ nz = INTEGER(GET_DIM(a))[2];
+ double sigma2 = REAL(s)[0] * REAL(s)[0], d2 ;
+ double cx = REAL(centre)[0], cy = REAL(centre)[1], *data, *rdata;
+ for (int im = 0; im < nz; im++) {
+ data = &(REAL(a)[im*nx*ny]); rdata = &(REAL(res)[im*nx*ny]);
+ for (x = 0; x < nx; x++)
+ for (y = 0; y < ny; y++) {
+ d2 = (x-cx)*(x-cx) + (y-cy)*(y-cy);
+ rdata[x + y*nx] = data[x + y*nx] * exp(-d2/sigma2);
+ }
+ }
+ UNPROTECT(nprotect);
+ return res;
+"
+funx <- cfunction(signature(a="array", s="numeric", centre="numeric"), code)
+
+x <- array(runif(50*50), c(50,50,1))
+res <- funx(a=x, s=10, centre=c(25,15))
+if (interactive()) image(res[,,1])
+
+## Same but done by registering an S4 method
+setCMethod("funy", signature(a="array", s="numeric", centre="numeric"), code, verbose=TRUE)
+
+res <- funy(x, 10, c(35,35))
+if (interactive()) { x11(); image(res[,,1]) }
+
+}
+
+\author{
+ Oleg Sklyar <\email{osklyar at ebi.ac.uk}>
+ Duncan Murdoch
+ Mike Smith;
+ Dirk Eddelbuettel for the Rcpp adatation
+}
+
+\keyword{file}
+
_______________________________________________
Rcpp-commits mailing list
Rcpp-commits at lists.r-forge.r-project.org
https://lists.r-forge.r-project.org/cgi-bin/mailman/listinfo/rcpp-commits
More information about the Rcpp-devel
mailing list