[Rd] Is it possible to pass a function argument from R to compiled code in C?

[Dirk Eddelbuettel]

On 20 September 2011 at 10:26, Alireza Mahani wrote:
| I have a function in R that takes another function as argument:
| 
| f <- function(g, ...) { #g is expected to be a function
| }
| 
| I want to see if there is a way to implement "f" in C and calling it from R
| using ".C" interface. I know that I can use function pointers for my C
| implementation, but I imagine it's going to be nearly impossible to pass a
| function from R to C. Are there any exact or approximate solutions
| available?

Yes you can -- using .Call() with can receive/return SEXP-typed variable, and
you can use an external pointer wrapped up in a SEXP.  The standard C API to
R supports it.

Now, Romain and I argue that the Rcpp interface for C++ makes it easier.
So what I am showing you now uses C++. You could do all that in C as well,
but you'd need to add a lot more hand-holding code which we hide behind the
C++ type system.

To keep this concrete, I have a full example in the Rcpp-using variant of
DEoptim, the RcppDE package which is on CRAN and R-Forge.  Here are some core
pieces of what demo(CompiledBenchmark) does:

R function:

    Wild <- function(x) { 		## 'Wild' function, global minimum at about -15.81515
        sum(10 * sin(0.3 * x) * sin(1.3 * x^2) + 0.00001 * x^4 + 0.2 * x + 80)/length(x)
    }

C++ variant of same function:


    double wild(SEXP xs) {
       Rcpp::NumericVector x(xs);
       int n = x.size();
       double sum = 0.0;
       for (int i=0; i<n; i++) {
          sum += 10 * sin(0.3 * x[i]) * sin(1.3 * x[i]*x[i]) + 0.00001 * x[i]*x[i]*x[i]*x[i] + 0.2 * x[i] + 80;
       }
       sum /= n;
       return(sum);
    }

and the key is then to (using the inline package, wrapping C++ code) create
an external pointer object (using the Rcpp::XPtr type) pointing at this C++
function just shown (and the real version does this for three different
functions with a switch, but the essence is just this):

    ## now via a class returning external pointer
    src.xptr <- 'return(XPtr<funcPtr>(new funcPtr(&wild)));'
    create_xptr <- cxxfunction(signature(funname="character"), body=src.xptr, inc=inc, plugin="Rcpp")

Calling create_xptr() in R gives us the XPtr in R --- and there we just pass
it down to the optimising function which then has a simple switch on the type
it receives to see whether it evaluates an R function, or a C++ function.  So
in the C++ function implementing the inner core of the optimisation (in
devol.cpp), we do

    if (TYPEOF(fcall) == EXTPTRSXP) { 		// non-standard mode: we are being passed an external pointer
	ev = new Rcpp::DE::EvalCompiled(fcall); // so assign a pointer using external pointer in fcall SEXP
    } else {					// standard mode: env_ is an env, fcall_ is a function 
	ev = new Rcpp::DE::EvalStandard(fcall, rho);	// so assign R function and environment
    }

and that simple branches between two cases of evaluator helper class.

To evaluate the R function at the C++ level we do

    double eval(SEXP par) {
	neval++;
	return defaultfun(par);
    }

with

    double defaultfun(SEXP par) { 			// essentialy same as the old evaluate
	SEXP fn = ::Rf_lang3(fcall, par, R_DotsSymbol); 
	SEXP sexp_fvec = ::Rf_eval(fn, env);		
	double f_result = REAL(sexp_fvec)[0];
	if (ISNAN(f_result)) 
	    ::Rf_error("NaN value of objective function! \nPerhaps adjust the bounds.");
	return(f_result); 
    }

whereas to evaluate the C++ function passed in, we do

    EvalCompiled( SEXP xps ) {				// get funptr from external pointer
	Rcpp::XPtr<funcPtr> xptr(xps);
	funptr = *(xptr);
    };
    double eval(SEXP par) {
	neval++;
	return funptr(par);
    }

This can probably be refined further, as it was mostly just one big proof of
concept.  But it works fine, do

   library(RcppDE)
   demo(CompiledBenchmark)

and several R-vs-C++ comparison of objective funtions should be timed for you.

If you're interested, we're always happy to take on Rcpp-specific questions
on the rcpp-devel list.

Hope this helps,  Dirk


-- 
New Rcpp master class for R and C++ integration is scheduled for 
San Francisco (Oct 8), more details / reg.info available at
http://www.revolutionanalytics.com/products/training/public/rcpp-master-class.php