[Rcpp-devel] Additional parameters for an objective function, e.g. in RcppDE

Dirk Eddelbuettel edd at debian.org
Thu May 2 22:15:20 CEST 2013


Hi Christoph,

On 30 April 2013 at 10:20, Christoph Bergmeir wrote:
| Hi Dirk (and the rest of the list),
| 
| I think I have it working; attached is a patch that adds this 
| functionality to RcppDE. I also came along something which is probably a 
| bug: The passed environment is never used. In line 75 of DEoptim.R you 
| just create one. I changed this to
| 
| if(!hasArg(env)) env <- new.env()

>From the look of it, this seems right.  

I remember checking a few things with Josh regarding the use of the
environment.  As DEoption does not permit compiled functions, we may not have
tested this variant.  I need to get a few things off my plate and get back to
this. 
 
| Now you can use it like this:
| 
| #--------------------------
| # RcppDE example
| #--------------------------
| library(inline)
| library(RcppDE)
| 
| inc <- 'double rastrigin(SEXP xs, SEXP env) {
|    Rcpp::NumericVector x(xs);
|    Rcpp::Environment e(env);
| 
|    std::vector<double> param = e["x"];
| 
|    int n = x.size();
|    double sum = 20.0;
|    for (int i=0; i<n; i++) {
|    sum += x[i]+2 - 10*cos(2*M_PI*x[i]);
| 
|    Rprintf("ap: %f\\n", param[0]);
| }
| return(sum);
| }
| '
| 
| ## now via a class returning external pointer
| src.xptr <- '
|      typedef double (*funcPtr)(SEXP, SEXP);
|      return(XPtr<funcPtr>(new funcPtr(&rastrigin)));
|      '
| create_xptr <- cxxfunction(signature(), body=src.xptr, inc=inc, 
| plugin="Rcpp")
| 
| n <- 10
| maxIt <- 100
| 
| env <- new.env()
| env[["x"]] <- 1:4
| 
| res <- RcppDE::DEoptim(fn=create_xptr(), env=env, lower=rep(-25, n), 
| upper=rep(25, n),
|        control=list(NP=10*n, itermax=maxIt, trace=FALSE))
| 
| res$optim
| #------------------------------------------------
| 
| Regards and thanks for the help,

Thanks for the example.  Maybe I'll make this another demo...

Are you all set on your side of things then?

Dirk



| Christoph
| 
| 
| On 04/29/2013 02:41 PM, Dirk Eddelbuettel wrote:
| >
| > On 29 April 2013 at 14:22, Christoph Bergmeir wrote:
| > | Hi,
| > |
| > | ok, that's exactly the file I was looking at right now. The problem is
| > | that my objective function is implemented in C++, and passed as an
| > | external pointer. So in evaluate.h, instead of in the EvalStandard case
| > | I'm in the EvalCompiled case, where the environment is not used. My
| > | question now is if I can include it there somehow..
| >
| > Right.  Just how EvalBase and EvalStandard extend the basic interface, we
| > "just" need to create something that lets an XPtr be evaluation along with an
| > environment.
| >
| > Anyway, past bedtime here so no more from me...
| >
| > Dirk
| >
| > | Regards,
| > | Christoph
| > |
| > | On 04/29/2013 02:16 PM, Dirk Eddelbuettel wrote:
| > | >
| > | > On 29 April 2013 at 13:55, Christoph Bergmeir wrote:
| > | > | Hi,
| > | > |
| > | > | thanks Dirk for the prompt reply. Ok, this was also the solution I had
| > | > | in mind. I'll try to find the code in RcppDE or try to implement it
| > | > | myself..I'll keep you posted with any advances.
| > | >
| > | > I think this may do the trick:  demo/environment.R in the RcppDE package:
| > | >
| > | >
| > | > suppressMessages(library(RcppDE))
| > | >
| > | > ## somewhat pathodological example with nuisance parameter mul
| > | > Rastrigin <- function(x) {
| > | >      mul * (sum(x+2 - 10 * cos(2*pi*x)) + 20)
| > | > }
| > | >
| > | > ## create a new environment associated with the function
| > | > funenv <- environment(fun=Rastrigin)
| > | > assign("mul", 2, envir=funenv)        ## set value
| > | >
| > | > out <- DEoptim(Rastrigin, -25, 25,
| > | >                 control=list(NP=10, trace=0),
| > | >                 env=funenv)
| > | > summary(out)
| > | >
| > | >
| > | >
| > | > Hth,  Dirk
| > | >
| > | > |
| > | > | Regards,
| > | > | Christoph
| > | > |
| > | > | On 04/29/2013 01:44 PM, Dirk Eddelbuettel wrote:
| > | > | >
| > | > | > On 29 April 2013 at 12:37, Christoph Bergmeir wrote:
| > | > | > | Dear list,
| > | > | > |
| > | > | > | I'm looking for some advice on a specific problem. Using RcppDE there is
| > | > | > | the possibility to give the optimizer directly an external pointer to
| > | > | > | the C++ function it will use as the objective function. I found this
| > | > | > | mechanism pretty useful as it may speed up things quite a lot (I have a
| > | > | > | problem where the speedup is from 17 minutes to some seconds), so that I
| > | > | > | use the same mechanism as RcppDE in our package Rmalschains and in the
| > | > | > | Rdonlp2 package, which is available from Rmetrics on Rforge.
| > | > | > |
| > | > | > | The problem that this mechanism has is that it cannot handle additional
| > | > | > | parameters to the objective function. Having additional parameters is
| > | > | >
| > | > | > I think it can. The DEoptim folks, particularly Josh, pointed this out and
| > | > | > the best general way is to assign all you need in a new environment -- which
| > | > | > you can assign to from R and (thanks to Rcpp) from C++.  Then pass that down.
| > | > | >
| > | > | > I think I have an example of that in the package but I don't have time right
| > | > | > now to chase this.
| > | > | >
| > | > | > But yes, this _is_ a very neat feature and something that needs broader
| > | > | > exposure.
| > | > | >
| > | > | > Maybe I can help in a few days.
| > | > | >
| > | > | > Dirk
| > | > | >
| > | > | > | often essential, because if you fit a model to data you need the data
| > | > | > | available in the target function. I illustrate the problem with an
| > | > | > | example I took from the RcppDE tests:
| > | > | > |
| > | > | > | #-----------------------------------------
| > | > | > |
| > | > | > | library(inline)
| > | > | > | library(RcppDE)
| > | > | > |
| > | > | > | inc <- 'double rastrigin(SEXP xs) { //here I want to give it an
| > | > | > | additional parameter: SEXP additional_parameter
| > | > | > |
| > | > | > |    //Do something with the parameter, e.g. use it for result
| > | > | > | calculation. Here we just want to print it
| > | > | > |    //double my_additional_parameter =
| > | > | > | Rcpp::as<double>(additional_parameter);
| > | > | > |    //Rprintf("ap: %f\\n", my_additional_parameter);
| > | > | > |
| > | > | > |    Rcpp::NumericVector x(xs);
| > | > | > |    int n = x.size();
| > | > | > |    double sum = 20.0;
| > | > | > |    for (int i=0; i<n; i++) {
| > | > | > |    sum += x[i]+2 - 10*cos(2*M_PI*x[i]);
| > | > | > |
| > | > | > | }
| > | > | > | return(sum);
| > | > | > | }
| > | > | > | '
| > | > | > |
| > | > | > | src.xptr <- '
| > | > | > |      typedef double (*funcPtr)(SEXP);
| > | > | > |      return(XPtr<funcPtr>(new funcPtr(&rastrigin)));
| > | > | > |      '
| > | > | > | create_xptr <- cxxfunction(signature(), body=src.xptr, inc=inc,
| > | > | > | plugin="Rcpp")
| > | > | > |
| > | > | > | n <- 10
| > | > | > | maxIt <- 100
| > | > | > |
| > | > | > | res <- RcppDE::DEoptim(fn=create_xptr(), lower=rep(-25, n),
| > | > | > | upper=rep(25, n),
| > | > | > |        control=list(NP=10*n, itermax=maxIt, trace=FALSE)) #,
| > | > | > | additional_paramater=25)
| > | > | > |
| > | > | > | res$optim
| > | > | > |
| > | > | > | #-----------------------------------------
| > | > | > |
| > | > | > | I currently get around this by having a global singleton object which
| > | > | > | holds these parameters. This works but of course is not very nice when
| > | > | > | it comes to parallelization. The code is more or less like this:
| > | > | > |
| > | > | > | //----------------------------------------------
| > | > | > | class TargetFunction {
| > | > | > |
| > | > | > |    private:
| > | > | > |
| > | > | > |    static TargetFunction *TargetFunctionSingleton;
| > | > | > |    std::vector<double> param;
| > | > | > |    double objval;
| > | > | > |
| > | > | > |    public:
| > | > | > |
| > | > | > |    void eval(const double* x, int n) {
| > | > | > |      double sum = 20.0;
| > | > | > |      for (int i=0; i<n; i++) {
| > | > | > |        sum += x[i]+2 - 10*cos(2*M_PI*x[i]);
| > | > | > |      };
| > | > | > |
| > | > | > | //here I can use the parameter now!!
| > | > | > |      Rprintf("ap: %f\\n", param[0]);
| > | > | > |
| > | > | > |      this->objval = sum;
| > | > | > |    };
| > | > | > |
| > | > | > |    void init(std::vector<double> & p_param) {
| > | > | > | 	  this->param = p_param;
| > | > | > |    };
| > | > | > |
| > | > | > |    static TargetFunction* getTargetFunctionSingleton() {
| > | > | > | 	  if( TargetFunctionSingleton == 0 )
| > | > | > | 		  TargetFunctionSingleton = new TargetFunction();
| > | > | > | 	  return TargetFunctionSingleton;
| > | > | > |    };
| > | > | > |
| > | > | > |    static void deleteTargetFunctionSingleton(){
| > | > | > | 	  if( TargetFunctionSingleton == 0 ) return;
| > | > | > | 	  else {
| > | > | > | 		  delete TargetFunctionSingleton;
| > | > | > | 		  TargetFunctionSingleton = 0;
| > | > | > | 	  }
| > | > | > | 	  return;
| > | > | > |    };
| > | > | > |
| > | > | > |    double getObjVal() {
| > | > | > |      return(objval);
| > | > | > |    };
| > | > | > |
| > | > | > |
| > | > | > | };
| > | > | > |
| > | > | > | TargetFunction* TargetFunction::TargetFunctionSingleton = 0;
| > | > | > |
| > | > | > | RcppExport SEXP targetFunction(SEXP p_par)
| > | > | > | {
| > | > | > | 	Rcpp::NumericVector par(p_par);
| > | > | > |
| > | > | > | 	TargetFunction* sp = TargetFunction::getTargetFunctionSingleton();
| > | > | > |
| > | > | > | 	sp->eval(par.begin(), par.size());
| > | > | > |
| > | > | > | 	return Rcpp::wrap(sp->getObjVal());
| > | > | > |
| > | > | > | }
| > | > | > |
| > | > | > | RcppExport SEXP targetFunctionInit(SEXP p_param) {
| > | > | > |
| > | > | > | 	TargetFunction::deleteTargetFunctionSingleton();
| > | > | > |
| > | > | > | 	TargetFunction* sp = TargetFunction::getTargetFunctionSingleton();
| > | > | > |
| > | > | > |    std::vector<double> param = Rcpp::as< std::vector<double> >(p_param);
| > | > | > |
| > | > | > | 	sp->init(param);
| > | > | > |
| > | > | > | 	return R_NilValue;
| > | > | > |
| > | > | > | }
| > | > | > |
| > | > | > | RcppExport SEXP GetTargetFunctionPtr() {
| > | > | > |
| > | > | > | 	typedef SEXP (*funcPtr)(SEXP);
| > | > | > |
| > | > | > | 	return (Rcpp::XPtr<funcPtr>(new funcPtr(&targetFunction)));
| > | > | > | }
| > | > | > | //-----------------------------------------------------
| > | > | > |
| > | > | > | Now, before doing the optimization, I call targetFunctionInit and set
| > | > | > | the additional parameters. Afterwards, everything is as in the example
| > | > | > | above, and I have the additional parameters available in the target
| > | > | > | function. Now the question is how I could solve this more elegantly, or
| > | > | > | more R like. The first thing that comes to mind is to use an R
| > | > | > | environment instead of the singleton.  However, how can I do this? I
| > | > | > | could have a singleton list of objects and then use the address of the R
| > | > | > | environment as a hash to find the right object in the list. But this is
| > | > | > | probably not really the way R environments should be used, and I wonder
| > | > | > | if this will cause any trouble.
| > | > | > |
| > | > | > | Any advise is highly appreciated.
| > | > | > |
| > | > | > | Regards,
| > | > | > | Christoph
| > | > | > |
| > | > | > | --
| > | > | > | Christoph Bergmeir
| > | > | > | e-mail: c.bergmeir at decsai.ugr.es
| > | > | > | Grupo SCI2S, DiCITS Lab          (http://sci2s.ugr.es/DiCITS)
| > | > | > | Dpto. de Ciencias de la Computacion e Inteligencia Artificial
| > | > | > | E.T.S. Ingenierias de Informatica y Telecomunicacion
| > | > | > | Universidad de Granada
| > | > | > | 18071 - GRANADA (Spain)
| > | > | > | _______________________________________________
| > | > | > | Rcpp-devel mailing list
| > | > | > | Rcpp-devel at lists.r-forge.r-project.org
| > | > | > | https://lists.r-forge.r-project.org/cgi-bin/mailman/listinfo/rcpp-devel
| > | > | >
| > | > |
| > | > | --
| > | > | Christoph Bergmeir
| > | > | e-mail: c.bergmeir at decsai.ugr.es
| > | > | Grupo SCI2S, DiCITS Lab          (http://sci2s.ugr.es/DiCITS)
| > | > | Dpto. de Ciencias de la Computacion e Inteligencia Artificial
| > | > | E.T.S. Ingenierias de Informatica y Telecomunicacion
| > | > | Universidad de Granada
| > | > | 18071 - GRANADA (Spain)
| > | >
| > |
| > | --
| > | Christoph Bergmeir
| > | e-mail: c.bergmeir at decsai.ugr.es
| > | Grupo SCI2S, DiCITS Lab          (http://sci2s.ugr.es/DiCITS)
| > | Dpto. de Ciencias de la Computacion e Inteligencia Artificial
| > | E.T.S. Ingenierias de Informatica y Telecomunicacion
| > | Universidad de Granada
| > | 18071 - GRANADA (Spain)
| >
| 
| -- 
| Christoph Bergmeir
| e-mail: c.bergmeir at decsai.ugr.es
| Grupo SCI2S, DiCITS Lab          (http://sci2s.ugr.es/DiCITS)
| Dpto. de Ciencias de la Computacion e Inteligencia Artificial
| E.T.S. Ingenierias de Informatica y Telecomunicacion
| Universidad de Granada
| 18071 - GRANADA (Spain)
| 
| ----------------------------------------------------------------------
| diff -rupN RcppDE_orig/R/DEoptim.R RcppDE/R/DEoptim.R
| --- RcppDE_orig/R/DEoptim.R	2012-04-09 05:43:24.000000000 +1000
| +++ RcppDE/R/DEoptim.R	2013-04-30 10:01:44.686949637 +1000
| @@ -72,7 +72,7 @@ DEoptim <- function(fn, lower, upper, co
|    else
|      nam <- paste("par", 1:length(lower), sep = "")
|  
| -  env <- new.env()
| +  if(!hasArg(env)) env <- new.env()
|  
|    ctrl <- do.call(DEoptim.control, as.list(control))
|    ctrl$npar <- length(lower)
| Binary files RcppDE_orig/src/deoptim.o and RcppDE/src/deoptim.o differ
| diff -rupN RcppDE_orig/src/devol.cpp RcppDE/src/devol.cpp
| --- RcppDE_orig/src/devol.cpp	2012-04-09 06:24:02.000000000 +1000
| +++ RcppDE/src/devol.cpp	2013-04-29 14:52:15.434839798 +1000
| @@ -26,7 +26,7 @@ void devol(double VTR, double f_weight,
|      //ProfilerStart("/tmp/RcppDE.prof");
|      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
| +	ev = new Rcpp::DE::EvalCompiled(fcall, rho); // 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
|      }
| Binary files RcppDE_orig/src/devol.o and RcppDE/src/devol.o differ
| diff -rupN RcppDE_orig/src/evaluate.h RcppDE/src/evaluate.h
| --- RcppDE_orig/src/evaluate.h	2012-04-09 06:24:02.000000000 +1000
| +++ RcppDE/src/evaluate.h	2013-04-29 14:56:38.735580878 +1000
| @@ -13,7 +13,7 @@
|  namespace Rcpp {
|      namespace DE {
|  
| -	double genrose(SEXP xs) {	// genrose function in C++
| +	double genrose(SEXP xs, SEXP env) {	// genrose function in C++
|  	    Rcpp::NumericVector x(xs);
|  	    int n = x.size();
|  	    double sum = 1.0;
| @@ -23,7 +23,7 @@ namespace Rcpp {
|  	    return(sum);
|  	}
|  
| -	double wild(SEXP xs) {		// wild function in C++
| +	double wild(SEXP xs, SEXP env) {		// wild function in C++
|  	    Rcpp::NumericVector x(xs);
|  	    int n = x.size();
|  	    double sum = 0.0;
| @@ -35,7 +35,7 @@ namespace Rcpp {
|  	    return(sum);
|  	}
|  
| -	double rastrigin(SEXP xs) {	// rastrigin function in C++
| +	double rastrigin(SEXP xs, SEXP env) {	// rastrigin function in C++
|  	    Rcpp::NumericVector x(xs);
|  	    int n = x.size();
|  	    double sum = 20.0;
| @@ -73,22 +73,25 @@ namespace Rcpp {
|  	    }
|  	};
|  
| -	typedef double (*funcPtr)(SEXP);
| +	typedef double (*funcPtr)(SEXP, SEXP);
|  	class EvalCompiled : public EvalBase {
|  	public:
| -	    EvalCompiled( Rcpp::XPtr<funcPtr> xptr ) {
| +	    EvalCompiled( Rcpp::XPtr<funcPtr> xptr, SEXP env_ ) {
|  		funptr = *(xptr);
| +                env = env_;
|  	    };
| -	    EvalCompiled( SEXP xps ) {
| +	    EvalCompiled( SEXP xps, SEXP env_ ) {
|  		Rcpp::XPtr<funcPtr> xptr(xps);
|  		funptr = *(xptr);
| +                env = env_;
|  	    };
|  	    double eval(SEXP par) {
|  		neval++;
| -		return funptr(par);
| +		return funptr(par, env);
|  	    }
|  	private:
|  	    funcPtr funptr;
| +            SEXP env;
|  	};
|  
|  	RcppExport SEXP putFunPtrInXPtr(SEXP funname) {
| Binary files RcppDE_orig/src/permute.o and RcppDE/src/permute.o differ
| Binary files RcppDE_orig/src/RcppDE.so and RcppDE/src/RcppDE.so differ

-- 
Dirk Eddelbuettel | edd at debian.org | http://dirk.eddelbuettel.com


More information about the Rcpp-devel mailing list