[Rcpp-devel] Pointer troubles

[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ó:

>
>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/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