[Rcpp-commits] r2279 - / tests tests/rcppFunctionEval
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Oct 6 23:41:34 CEST 2010
Author: edd
Date: 2010-10-06 23:41:34 +0200 (Wed, 06 Oct 2010)
New Revision: 2279
Added:
tests/
tests/rcppFunctionEval/
tests/rcppFunctionEval/bm.cpp
tests/rcppFunctionEval/bm.r
tests/rcppFunctionEval/evaluate1.c
tests/rcppFunctionEval/evaluate2.cpp
tests/rcppFunctionEval/evaluate3.cpp
tests/rcppFunctionEval/evaluate4.cpp
tests/rcppFunctionEval/makeAndRun.sh
Log:
added function eval benchmark
Added: tests/rcppFunctionEval/bm.cpp
===================================================================
--- tests/rcppFunctionEval/bm.cpp (rev 0)
+++ tests/rcppFunctionEval/bm.cpp 2010-10-06 21:41:34 UTC (rev 2279)
@@ -0,0 +1,81 @@
+
+#include <Rcpp.h>
+
+class Timer {
+public:
+ Timer() : sys_time("Sys.time") { Reset(); }
+ void Start() { start_t = getFractionalSeconds() ; }
+ void Stop() {
+ end_t = getFractionalSeconds();
+ elapsed = end_t - start_t; // Calculate elapsed time in seconds
+ cumul += elapsed;
+ }
+ void Reset() { end_t = start_t = elapsed = cumul = 0.0; }
+ double ElapsedTime() { return elapsed; }
+ double CumulativeTime() { return cumul; }
+
+
+private:
+ Rcpp::Function sys_time ;
+ double start_t, end_t, elapsed, cumul;
+
+ double getFractionalSeconds(void) {
+ return Rcpp::as<double>( sys_time() ) ;
+ }
+};
+
+RcppExport double evaluate1(long *l_nfeval, double *param, int i_D, SEXP fcall, SEXP env);
+RcppExport double evaluate2(long *l_nfeval, double *param, int i_D, SEXP fcall, SEXP env);
+RcppExport double evaluate3(long *l_nfeval, double *param, int i_D,
+ const Rcpp::Function & fun, const Rcpp::Environment & env);
+RcppExport double evaluate4(long *l_nfeval, double *param, int i_D,
+ const Rcpp::Function & fun, const Rcpp::Environment & env);
+
+RcppExport SEXP benchmarkEvals(SEXP bmS, SEXP parS, SEXP funS, SEXP envS) {
+
+ Rcpp::List bm(bmS);
+ int nsim = Rcpp::as<int>(bm["nsim"]);
+
+ long neval = 0;
+ Rcpp::NumericVector x(parS);
+
+ Timer t;
+ double v1 = 0, v2 = 0, v3 = 0, v4 = 0;
+ t.Start();
+ for (int i=0; i<nsim; i++)
+ v1 = evaluate1(&neval, x.begin(), x.size(), funS, envS);
+ t.Stop();
+ double t1 = t.ElapsedTime();
+
+ t.Reset();
+ neval = 0;
+ t.Start();
+ for (int i=0; i<nsim; i++)
+ v2 = evaluate2(&neval, x.begin(), x.size(), funS, envS);
+ t.Stop();
+ double t2 = t.ElapsedTime();
+
+ Rcpp::Function fun(funS);
+ Rcpp::Environment env(envS);
+
+ t.Reset();
+ neval = 0;
+ t.Start();
+ for (int i=0; i<nsim; i++)
+ v3 = evaluate3(&neval, x.begin(), x.size(), fun, env);
+ t.Stop();
+ double t3 = t.ElapsedTime();
+
+ t.Reset();
+ neval = 0;
+ t.Start();
+ for (int i=0; i<nsim; i++)
+ v4 = evaluate4(&neval, x.begin(), x.size(), fun, env);
+ t.Stop();
+ double t4 = t.ElapsedTime();
+
+
+ return Rcpp::DataFrame::create(Rcpp::Named("times", Rcpp::NumericVector::create(t1, t2, t3, t4)),
+ Rcpp::Named("values", Rcpp::NumericVector::create(v1, v2, v3, v4)));
+
+}
Added: tests/rcppFunctionEval/bm.r
===================================================================
--- tests/rcppFunctionEval/bm.r (rev 0)
+++ tests/rcppFunctionEval/bm.r 2010-10-06 21:41:34 UTC (rev 2279)
@@ -0,0 +1,17 @@
+#!/usr/bin/r -ti
+
+genroseFunction <- function(x) {
+ ## One generalization of the Rosenbrock banana valley function (n parameters)
+ n <- length(x)
+ #1.0 + sum (100 * (x[1:(n-1)]^2 - x[2:n])^2 + (x[2:n] - 1)^2)
+ 1.0 + sum (100 * (x[-n]^2 - x[-1])^2 + (x[-1] - 1)^2)
+}
+
+dyn.load("bm.so")
+res <-.Call("benchmarkEvals",
+ list("nsim"=5000), # bmpar list
+ rep(1,2), # parameter vec.
+ genroseFunction, # function
+ new.env()) # environment
+
+print(res)
Property changes on: tests/rcppFunctionEval/bm.r
___________________________________________________________________
Added: svn:executable
+ *
Added: tests/rcppFunctionEval/evaluate1.c
===================================================================
--- tests/rcppFunctionEval/evaluate1.c (rev 0)
+++ tests/rcppFunctionEval/evaluate1.c 2010-10-06 21:41:34 UTC (rev 2279)
@@ -0,0 +1,33 @@
+#include <R.h>
+#include <Rdefines.h>
+
+// version from DEoptim
+
+//------objective function---------------------------------------
+
+double evaluate1(long *l_nfeval, double *param, int i_D, SEXP fcall, SEXP env)
+{
+ int i;
+ SEXP par;
+ SEXP sexp_fvec, fn;
+ double f_result;
+
+ PROTECT(par = NEW_NUMERIC(i_D));
+ for (i = 0; i < i_D; i++) {
+ NUMERIC_POINTER(par)[i] = param[i];
+ }
+ PROTECT(fn = lang2(fcall, par));
+ (*l_nfeval)++; //increment function evaluation count
+
+ SETCADR(fn, par);
+
+ PROTECT(sexp_fvec = eval(fn, env));
+ f_result = NUMERIC_POINTER(sexp_fvec)[0];
+
+ UNPROTECT(3);
+
+ if(ISNAN(f_result))
+ error("NaN value of objective function! \nPerhaps adjust the bounds.");
+
+ return(f_result);
+}
Added: tests/rcppFunctionEval/evaluate2.cpp
===================================================================
--- tests/rcppFunctionEval/evaluate2.cpp (rev 0)
+++ tests/rcppFunctionEval/evaluate2.cpp 2010-10-06 21:41:34 UTC (rev 2279)
@@ -0,0 +1,28 @@
+
+#include <Rcpp.h>
+
+/*------General functions-----------------------------------------*/
+
+RcppExport double evaluate2(long *l_nfeval,
+ double *param, int i_D,
+ SEXP fcall, SEXP rho)
+{
+ (*l_nfeval)++; //increment function evaluation count
+ Rcpp::NumericVector par(i_D);
+ for (int i = 0; i < i_D; i++)
+ par[i] = param[i];
+
+ Rcpp::Function fun(fcall);
+ Rcpp::Environment env(rho);
+
+ Rcpp::Language funcall(fun, par);
+ double f_result = Rcpp::as<double>( Rcpp::Evaluator::run( funcall, env) );
+ // or: Rcpp::NumericVector v = funcall.eval(env);
+
+ if (ISNAN(f_result))
+ ::Rf_error("NaN value of objective function! \nPerhaps adjust the bounds.");
+
+ return(f_result);
+}
+
+
Added: tests/rcppFunctionEval/evaluate3.cpp
===================================================================
--- tests/rcppFunctionEval/evaluate3.cpp (rev 0)
+++ tests/rcppFunctionEval/evaluate3.cpp 2010-10-06 21:41:34 UTC (rev 2279)
@@ -0,0 +1,23 @@
+
+#include <Rcpp.h>
+
+/*------General functions-----------------------------------------*/
+
+RcppExport double evaluate3(long *l_nfeval,
+ double *param, int i_D,
+ const Rcpp::Function & fun, const Rcpp::Environment & env)
+{
+ (*l_nfeval)++; //increment function evaluation count
+ Rcpp::NumericVector par(i_D);
+ for (int i = 0; i < i_D; i++)
+ par[i] = param[i];
+
+ Rcpp::Language funcall(fun, par);
+ double f_result = Rcpp::as<double>( Rcpp::Evaluator::run( funcall, env) );
+ // or: Rcpp::NumericVector v = funcall.eval(env);
+
+ if (ISNAN(f_result))
+ ::Rf_error("NaN value of objective function! \nPerhaps adjust the bounds.");
+
+ return(f_result);
+}
Added: tests/rcppFunctionEval/evaluate4.cpp
===================================================================
--- tests/rcppFunctionEval/evaluate4.cpp (rev 0)
+++ tests/rcppFunctionEval/evaluate4.cpp 2010-10-06 21:41:34 UTC (rev 2279)
@@ -0,0 +1,21 @@
+
+#include <Rcpp.h>
+
+RcppExport double evaluate4(long *l_nfeval,
+ double *param, int i_D,
+ const Rcpp::Function & fun, const Rcpp::Environment & env)
+{
+ (*l_nfeval)++; //increment function evaluation count
+ Rcpp::NumericVector par(i_D);
+ for (int i = 0; i < i_D; i++)
+ par[i] = param[i];
+
+ Rcpp::Language funcall(fun, par);
+ Rcpp::NumericVector v = funcall.eval(env);
+ double f_result = v[0];
+
+ if (ISNAN(f_result))
+ ::Rf_error("NaN value of objective function! \nPerhaps adjust the bounds.");
+
+ return(f_result);
+}
Added: tests/rcppFunctionEval/makeAndRun.sh
===================================================================
--- tests/rcppFunctionEval/makeAndRun.sh (rev 0)
+++ tests/rcppFunctionEval/makeAndRun.sh 2010-10-06 21:41:34 UTC (rev 2279)
@@ -0,0 +1,7 @@
+#!/bin/bash
+
+export PKG_CPPFLAGS=`r -e'Rcpp:::CxxFlags()'`
+export PKG_LIBS=`r -e'Rcpp:::LdFlags()'`
+R CMD SHLIB bm.cpp evaluate*.c evaluate*.cpp
+
+./bm.r
\ No newline at end of file
Property changes on: tests/rcppFunctionEval/makeAndRun.sh
___________________________________________________________________
Added: svn:executable
+ *
More information about the Rcpp-commits
mailing list