Skip to content

[Rcpp-devel] Pointer troubles

3 messages · Christian Gunning, Dirk Eddelbuettel, Manuel Castejón Limas

Christian Gunning
# 
On Wed, Aug 3, 2011 at 10:22 AM,
<rcpp-devel-request at r-forge.wu-wien.ac.at> wrote:
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.
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/CompiledBenchmark.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]

-Christian
Dirk Eddelbuettel
#
On 3 August 2011 at 14:48, Christian Gunning wrote:
| On Wed, Aug 3, 2011 at 10:22 AM,
| <rcpp-devel-request at 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/CompiledBenchmark.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
Manuel Castejón Limas
# 
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" <edd at debian.org> escribi?: