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

From: Dirk Eddelbuettel <edd_at_debian.org>
Date: Tue, 20 Sep 2011 13:35:39 -0500

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

______________________________________________
R-devel_at_r-project.org mailing list
https://stat.ethz.ch/mailman/listinfo/r-devel
Received on Tue 20 Sep 2011 - 18:39:08 GMT

This quarter's messages: by month, or sorted: [ by date ] [ by thread ] [ by subject ] [ by author ]

All messages

Archive maintained by Robert King, hosted by the discipline of statistics at the University of Newcastle, Australia.
Archive generated by hypermail 2.2.0, at Tue 20 Sep 2011 - 19:40:33 GMT.

Mailing list information is available at https://stat.ethz.ch/mailman/listinfo/r-devel. Please read the posting guide before posting to the list.

list of date sections of archive