[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}
+



More information about the Rcpp-commits mailing list