R/rcpp_apply_generator.R

In GarrettMooney/moonmisc: Personal Utility Functions

##' 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