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.bergm...@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@lists.r-forge.r-project.org
| > | > | > |
https://lists.r-forge.r-project.org/cgi-bin/mailman/listinfo/rcpp-devel
| > | > | >
| > | > |
| > | > | --
| > | > | Christoph Bergmeir
| > | > | e-mail: c.bergm...@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.bergm...@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.bergm...@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 | e...@debian.org | http://dirk.eddelbuettel.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
