[Rcpp-commits] r608 - pkg/inst/examples/functionCallback
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sat Feb 6 19:04:20 CET 2010
Author: edd
Date: 2010-02-06 19:04:20 +0100 (Sat, 06 Feb 2010)
New Revision: 608
Modified:
pkg/inst/examples/functionCallback/README
pkg/inst/examples/functionCallback/RcppFunctionCallExample.cpp
Log:
updated
Modified: pkg/inst/examples/functionCallback/README
===================================================================
--- pkg/inst/examples/functionCallback/README 2010-02-06 17:54:14 UTC (rev 607)
+++ pkg/inst/examples/functionCallback/README 2010-02-06 18:04:20 UTC (rev 608)
@@ -1,4 +1,11 @@
+A much simpler version of the example is provided in the file newApiExample.r.
+With littler installed, it can be run 'as is' as a shell script; else it can
+be sourced into R.
+
+ -- Dirk Eddelbuettel and Romain Francois, 06 Feb 2010
+
+
This directory provides a simple example of how an R function
can be passed back and forth between R and C++.
Modified: pkg/inst/examples/functionCallback/RcppFunctionCallExample.cpp
===================================================================
--- pkg/inst/examples/functionCallback/RcppFunctionCallExample.cpp 2010-02-06 17:54:14 UTC (rev 607)
+++ pkg/inst/examples/functionCallback/RcppFunctionCallExample.cpp 2010-02-06 18:04:20 UTC (rev 608)
@@ -1,11 +1,35 @@
+// -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; tab-width: 8 -*-
+//
+// Rcpp.h: R/C++ interface class library
+//
+// Copyright (C) 2009 - 2010 Dirk Eddelbuettel and Romain Francois
+//
+// This file is part of Rcpp.
+//
+// Rcpp is free software: you can redistribute it and/or modify it
+// under the terms of the GNU General Public License as published by
+// the Free Software Foundation, either version 2 of the License, or
+// (at your option) any later version.
+//
+// Rcpp is distributed in the hope that it will be useful, but
+// WITHOUT ANY WARRANTY; without even the implied warranty of
+// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+// GNU General Public License for more details.
+//
+// You should have received a copy of the GNU General Public License
+// along with Rcpp. If not, see <http://www.gnu.org/licenses/>.
#include "Rcpp.h"
-// Define a (file-local) class that can be used to call an R function that expects a
-// real vector argument and returns a vector.
+// This file shows how to use an R function in a callback from C++. It
+// is implemented using the 'classic Rcpp' API. A simpler alternative
+// using the 'new Rcpp' API is provided in the file 'newApiExample.r'/
+
+// Define a (file-local) class that can be used to call an R function
+// that expects a real vector argument and returns a vector.
//
-// We define this class by inhereting from Rcpp's RcppFunction class and adding a
-// single function 'transformVector'
+// We define this class by inhereting from Rcpp's RcppFunction class
+// and adding a single function 'transformVector'
//
// The R function being used is defined in the R script calling this
//
@@ -13,22 +37,21 @@
public:
RVectorFuncCall(SEXP fn) : RcppFunction(fn) {}
- // This function will use an R function to operate on all elements of vector v
- std::vector<double> transformVector(std::vector<double>& v) {
+ // This function uses an R function to operate on all elements of vector v
+ std::vector<double> transformVector(std::vector<double>& v) {
+ setRVector(v); // Turn vector into a SEXP to be passed to R
- setRVector(v); // Turn vector into a SEXP that can be passed to R as an argument.
+ // Call the R function passed in as the paramter fn,
+ // with SEXP vector that was just set as its argument.
+ SEXP result = vectorCall();
- // Call the R function passed in as the paramter fn,
- // with SEXP vector that was just set as its argument.
- SEXP result = vectorCall();
+ // Turn returned R vector into a C++ vector, clear protection stack, and return.
+ std::vector<double> vec( RcppVector<double>(result).stlVector() );
- // Turn returned R vector into a C++ vector, clear protection stack, and return.
- std::vector<double> vec( RcppVector<double>(result).stlVector() );
-
- // Safe now to clear the contribution of this function to the protection stack.
- clearProtectionStack();
+ // Safe now to clear the contribution of this function to the protection stack.
+ clearProtectionStack();
- return vec;
+ return vec;
}
};
@@ -36,39 +59,38 @@
// Standard wrapper C++ function using Rcpp interface, this function will be called from R
RcppExport SEXP RCppFunctionCallWrapper(SEXP params, SEXP numvec, SEXP fnvec) {
- SEXP rl = R_NilValue; // Use this when there is nothing to be returned.
- char* exceptionMesg=NULL;
+ SEXP rl = R_NilValue; // Use this when there is nothing to be returned.
+ char* exceptionMesg = NULL;
- try {
+ try {
+ RcppParams rparam(params); // Get parameters in params.
+ int N = rparam.getIntValue("N");
- RcppParams rparam(params); // Get parameters in params.
- int N = rparam.getIntValue("N");
+ std::vector<double> vec( RcppVector<double>(numvec).stlVector());
- std::vector<double> vec( RcppVector<double>(numvec).stlVector());
+ for (int i=0; i<N; i++) {
- for (int i=0; i<N; i++) {
+ // Test RVectorFuncCall defined above, init'ed with the supplied function
+ RVectorFuncCall vfunc(fnvec);
- // Test RVectorFuncCall defined above, init'ed with the supplied function
- RVectorFuncCall vfunc(fnvec);
-
- // transform vec with the R function given to vfunc
- vec = vfunc.transformVector(vec);
+ // transform vec with the R function given to vfunc
+ vec = vfunc.transformVector(vec);
- }
- // Build result set to be returned as a list to R.
- RcppResultSet rs;
- rs.add("vec", vec);
+ }
+ // Build result set to be returned as a list to R.
+ RcppResultSet rs;
+ rs.add("vec", vec);
+
+ rl = rs.getReturnList(); // Get the list to be returned to R.
- rl = rs.getReturnList(); // Get the list to be returned to R.
-
- } catch(std::exception& ex) {
- exceptionMesg = copyMessageToR(ex.what());
- } catch(...) {
- exceptionMesg = copyMessageToR("unknown reason");
- }
+ } catch(std::exception& ex) {
+ exceptionMesg = copyMessageToR(ex.what());
+ } catch(...) {
+ exceptionMesg = copyMessageToR("unknown reason");
+ }
- if(exceptionMesg != NULL)
- Rf_error(exceptionMesg);
+ if(exceptionMesg != NULL)
+ Rf_error(exceptionMesg);
- return rl;
+ return rl;
}
More information about the Rcpp-commits
mailing list