##' Rcpp Apply Generator
##'
##' Use this function as a generator for your own \code{apply} functions;
##' that is, functions you would like to apply over rows or columns of a
##' matrix.
##'
##' @importFrom Rcpp sourceCpp
##' @param fun A character string defining the C++ function. It must be
##' in terms of a variable \code{x}, and it must return a \code{double}.
##' \code{x} is a reference to the current row/column being iterated over.
##' @param includes Other C++ libraries to include. For example, to include boost/math.hpp,
##' you could pass c("<boost/math.hpp>"). Rcpp is included by default, unless RcppArmadillo
##' is included as well (since Rcpp is included as part of the RcppArmadillo include)
##' @param depends Other libraries to link to. Linking is done through Rcpp attributes.
##' @param inline boolean; mark this function as inline? This may or may not
##' increase execution speed.
##' @param returnType The return type of your function; must be a scalar that
##' is \code{wrap}pable by Rcpp. Currently, the supported choices are \code{double},
##' \code{int}, and \code{bool}.
##' @param name An internal name for the function.
##' @param file A location to output the file. Defaults to a temporary
##' file as generated by \code{\link{tempfile}()}.
##' @param additional Other C++ code you want to include; e.g. helper functions.
##' This code will be inserted as-is above the code in \code{fun}.
##' @export
##' @examples \dontrun{
##' x <- matrix(1:16, nrow=4)
##' cvApply <- rcpp_apply_generator("return mean(x) / sd(x);")
##' squaredSumApply <- rcpp_apply_generator("
##' double out = 0;
##' for( int i=0; i < x.size(); i++ ) {
##' out += x[i];
##' }
##' out = out*out;
##' return out;
##' ")
##' cvApply(x, 2)
##' apply(x, 2, mean) / apply(x, 2, sd)
##' ## example with bool
##' anyBig <- rcpp_apply_generator( returnType="bool", '
##' return is_true( any( x > 10 ) );
##' ')
##' anyBig(x, 2)
##' anyBig(x, 1)
##' ## example with boost's gcd. silly but demonstrative.
##' ## intended to be applied to matrices with 2 rows and n columns
##' gcdApply <- rcpp_apply_generator( returnType="int",
##' includes="<boost/math/common_factor.hpp>",
##' fun='
##' return boost::math::gcd( (int)x[0], (int)x[1] );
##' ')
##' M <- matrix( c(4, 6, 20, 25, 10, 100), nrow=2 )
##' gcdApply(M, 2)
##' }
rcpp_apply_generator <- function( fun,
includes=NULL,
depends=NULL,
inline=TRUE,
returnType="double",
name=NULL,
file=NULL,
additional=NULL ) {
if( getRversion() < "2.15.1" ||
packageVersion("Rcpp") < "0.10.1"
) {
message("Error: This function requires Rcpp > 0.10.1 and R > 2.15.1")
return( invisible(NULL) )
}
## generate a C++ source file based on 'fun'
if( is.null(file) ) {
cpp_source <- paste( sep="", tempfile(), ".cpp" )
} else {
if( length( grep( "\\.cpp", file ) ) == 0 ) {
file <- paste( sep="", file, ".cpp" )
}
cpp_source <- file
}
cat("C++ source code will be written to", cpp_source, ".\n")
## an environment for the cppSource-exported functions to live in
cpp_env <- new.env()
## internal name for the function
if( is.null(name) ) {
name <- paste( collapse="",
sample( c(letters, LETTERS), size=20, replace=TRUE)
)
}
## open a connection to the file, and ensure we close it after
conn <- file( cpp_source, 'w' )
on.exit( close(conn) )
## determine the Rcpp return type
rcpp_returnType <- switch( returnType,
double="NumericVector",
int="IntegerVector",
bool="LogicalVector",
warning("unrecognized return type")
)
## process the 'depends' argument
include_Rcpp <- TRUE
if( !is.null(depends) ) {
if( "RcppArmadillo" %in% depends ) {
include_Rcpp <- FALSE
}
depends <- paste("// [[Rcpp::depends(", paste(depends, collapse=", "), ")]]",
sep="" )
depends <- paste( sep="", depends, "\n" )
}
## process the 'includes' argument
if( !is.null(includes) ) {
includes <- paste( paste("#include", includes), collapse="\n" )
includes <- paste( includes, "\n", sep="" )
}
## 'cat' our source code out to a file, to later be sourced
cat( file=conn, sep="", paste( sep="", collapse="",
depends,
if( include_Rcpp ) "#include <Rcpp.h>\n",
includes, "\n",
"using namespace Rcpp;\n",
additional,
"\n",
"inline ", returnType, " do_", name, "( const NumericMatrix::Column& x ) {\n", fun, "\n }
// [[Rcpp::export]]
", rcpp_returnType, " ", name, "( NumericMatrix& X ) {
int nCols = X.ncol();
", rcpp_returnType, " out = no_init(nCols);
for( int j=0; j < nCols; j++ ) {
NumericMatrix::Column tmp = X(_, j);
out[j] = do_", name, "( tmp );
}
return out;
}") )
## source the file into the 'cpp_env' environment
cat("Compiling...\n")
sourceCpp( cpp_source, env=cpp_env )
cat("Done!")
## return a function that exposes the compiled code to the user
return( function(X, dim) {
force( cpp_source )
if( dim == 1 ) {
X <- t(X)
}
call <- call(name, X)
return( eval( call, envir=cpp_env) )
})
}
##' @rdname rcpp_apply_generator
##' @export
Rcpp_apply_generator <- rcpp_apply_generator
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.