This is a toy example:
# ----------------------- Creating the pointers to C++ functions --------
otherCode <- ' // -------------------------- function definitions ---
double f0(double x) {
return( tanh(x) );
}
double f1(double x) {
return( 1-tanh(x)*tanh(x) );
}
'
testCode <- ' // --------------- return a couple of Xptr to f0 and f1
typedef double (*funcPtr)(double);
return List::create( _["f0"]=XPtr<funcPtr>(new
funcPtr(&f0)),
_["f1"]=XPtr<funcPtr>(new
funcPtr(&f1)) ) ;
'
testCodefun <- cxxfunction(sig = character(), body = testCode, includes
=
otherCode, plugin="Rcpp")
functionPointers <- testCodefun()
functionPointers
# $f0
# <pointer: 0x10043eca0>
#
# $f1
# <pointer: 0x10043f420>
# ----------------------- Using the pointers to C++ functions --------
testCode <- '
typedef double (*funcPtr)(double);
List functionPointers(listOfFunctionPointers);
double xx=as<double>(x);
XPtr<funcPtr> f0XPtr = functionPointers["f0"];
XPtr<funcPtr> f1XPtr = functionPointers["f1"];
return NumericVector::create( _["f0(x)"]=(*f0XPtr)(xx) ,
_["f1(x)"]=(*f1XPtr)(xx) ) ;
'
testCodefun <- cxxfunction(sig =
signature(listOfFunctionPointers="externalpointer", x="numeric"), body =
testCode, includes = otherCode, plugin="Rcpp")
result <-testCodefun(listOfFunctionPointers=functionPointers, x=0.1)
result
# f0(x) f1(x)
# 0.09966799 0.99006629
El 04/08/11 00:18, "Dirk Eddelbuettel" <e...@debian.org> escribió:
>
>On 3 August 2011 at 14:48, Christian Gunning wrote:
>| On Wed, Aug 3, 2011 at 10:22 AM,
>| <rcpp-devel-requ...@r-forge.wu-wien.ac.at> wrote:
>| > Simple examples are in a demo file in the
>| > package, see demo(CompiledBenchmark) -- or more importantly, see its
>source
>| > and the RcppDE source.
>|
>| I'm now cobbling together a small XPtr section in Rcpp-quickref based
>| on these 2 related threads, which have been enormously helpful to me.
>
>You are the man! Much appreciated. But we should really make sure we
>settle
>on something simple yet complete. Maybe feeding R's optim or something
>simpler.
>
>| Thanks, I think I finally get it.
>|
>| In the meantime, for the inveterately lazy and/or confused, here's the
>| horse's mouth, with some key lines therein to trace up from:
>|
>|
>https://r-forge.r-project.org/scm/viewvc.php/pkg/RcppDE/demo/CompiledBench
>mark.R?view=markup&root=rcpp
>|
>| create_xptr <- cxxfunction(signature(funname="character"),
>| body=src.xptr, inc=inc, plugin="Rcpp")
>| ## ...
>| cppDE <- function(n, maxIt, fun) RcppDE::DEoptim(fn=fun,
>| lower=rep(-25, n),
>| upper=rep(25, n), control=list(NP=10*n, itermax=maxIt,
>| trace=FALSE))#, bs=TRUE))
>| ## ...
>| xptr <- create_xptr(funname)
>| ct <- system.time(invisible(cppDE(n, maxIt, xptr)))[3]
>
>What I didn't show was the receiving end. In the C++ function doing the
>optimisation setip, we switch based on what the user gives us (R
>function, or
>inline-created XPtr SEXP with a C function):
>
> Rcpp::DE::EvalBase *ev = NULL; // pointer to abstract base
> class
> 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 this 'ev' object is then evaluated with the parameters:
>
> double t_tmpC = ev->eval(par); // Evaluate
> mutant in t_tmpP
>
>It is implemented as some quick classes wrapped in a header file
>evaluate.h:
>
>
> class EvalBase {
> public:
> EvalBase() : neval(0) {};
> virtual double eval(SEXP par) = 0;
> unsigned long getNbEvals() { return neval; }
> protected:
> unsigned long int neval;
> };
>
> class EvalStandard : public EvalBase {
> public:
> EvalStandard(SEXP fcall_, SEXP env_) : fcall(fcall_), env(env_) {}
> double eval(SEXP par) {
> neval++;
> return defaultfun(par);
> }
> private:
> SEXP fcall, env;
> double defaultfun(SEXP par) { // essentialy
> same as the old
>evaluate
> SEXP fn = ::Rf_lang3(fcall, par, R_DotsSymbol); // this could
> be done
>with Rcpp
> SEXP sexp_fvec = ::Rf_eval(fn, env); // but is still
> a lot slower
>right now
> 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);
> }
> };
>
> typedef double (*funcPtr)(SEXP);
> class EvalCompiled : public EvalBase {
> public:
> EvalCompiled( Rcpp::XPtr<funcPtr> xptr ) {
> funptr = *(xptr);
> };
> EvalCompiled( SEXP xps ) {
> Rcpp::XPtr<funcPtr> xptr(xps);
> funptr = *(xptr);
> };
> double eval(SEXP par) {
> neval++;
> return funptr(par);
> }
> private:
> funcPtr funptr;
> };
>
>EvalBase is the abstract base class, EvalStandard uses standard R and
>EvalCompiled uses the compiled function.
>
>It all looks mighty complicated but once you squint at it for a few
>minutes
>it starts to make sense. And I share Manuel's excitement for doing
>something
>like this for Amore -- it make sense.
>
>But we need to clean it up into a simpler selfcontained example.
>Volunteers?
>
>Dirk
>
>--
>Gauss once played himself in a zero-sum game and won $50.
> -- #11 at http://www.gaussfacts.com
_______________________________________________
Rcpp-devel mailing list
Rcpp-devel@lists.r-forge.r-project.org
https://lists.r-forge.r-project.org/cgi-bin/mailman/listinfo/rcpp-devel
