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______________________________________________
[hidden email] mailing list
https://stat.ethz.ch/mailman/listinfo/r-devel
Locked
