Related
I have an issue with the Valgrind check on CRAN for a package. While I cannot reproduce the issue, I suspect I know what the issue is. A simplified example is this C++ file:
#include <Rcpp.h>
using namespace Rcpp;
// what I currently do
// call a R function with 1 argument
SEXP do_work1(SEXP x, SEXP fn, SEXP env){
SEXP R_fcall, out;
PROTECT(R_fcall = Rf_lang2(fn, x));
PROTECT(out = Rf_eval(R_fcall, env));
UNPROTECT(2);
return out;
}
bool not_ok(SEXP x, R_len_t const ex_len){
return !Rf_isReal(x) or !Rf_isVector(x) or Rf_xlength(x) != ex_len or
Rf_isNull(x);
}
// [[Rcpp::export(rng = false)]]
double use_do_worka(SEXP x, SEXP fn, SEXP env){
SEXP res = do_work1(x, fn, env);
CharacterVector what("y");
SEXP y = Rf_getAttrib(res, what);
if(not_ok(res, 2) or not_ok(y, 1))
throw std::invalid_argument("not ok");
double out = *REAL(res) + REAL(res)[1] + *REAL(y);
return out;
}
// what I could do instead?
// [[Rcpp::export(rng = false)]]
double use_do_workb(SEXP x, SEXP fn, SEXP env){
SEXP res = PROTECT(do_work1(x, fn, env)); // added PROTECT
CharacterVector what("y");
SEXP y = PROTECT(Rf_getAttrib(res, what)); // added PROTECT
if(not_ok(res, 2) or not_ok(y, 1)){
UNPROTECT(2); // added UNPROTECT
throw std::invalid_argument("not ok");
}
double out = *REAL(res) + REAL(res)[1] + *REAL(y);
UNPROTECT(2); // added UNPROTECT
return out;
}
// or maybe?
SEXP do_work2(SEXP x, SEXP fn, SEXP env){
SEXP R_fcall, out;
PROTECT(R_fcall = Rf_lang2(fn, x));
PROTECT(out = Rf_eval(R_fcall, env));
// removed UNPROTECT
return out;
}
// [[Rcpp::export(rng = false)]]
double use_do_workc(SEXP x, SEXP fn, SEXP env){
SEXP res = do_work2(x, fn, env);
CharacterVector what("y");
SEXP y = PROTECT(Rf_getAttrib(res, what)); // added PROTECT
if(not_ok(res, 2) or not_ok(y, 1)){
UNPROTECT(3); // added UNPROTECT
throw std::invalid_argument("not ok");
}
double out = *REAL(res) + REAL(res)[1] + *REAL(y);
UNPROTECT(3); // added UNPROTECT
return out;
}
/*** R
f <- function(x) {
x1 <- x[1]
x2 <- x[2]
out <- c(-400 * x1 * (x2 - x1 * x1) - 2 * (1 - x1),
200 * (x2 - x1 * x1))
attr(out, "y") <- 100 * (x2 - x1 * x1)^2 + (1 - x1)^2
out
}
for(i in 1:1000000){
use_do_worka(1, f, .GlobalEnv)
use_do_workb(1, f, .GlobalEnv)
use_do_workc(1, f, .GlobalEnv)
}
*/
which one can compile and run the examples using Rcpp::sourceCpp. do_work1 and use_do_worka is very similar to what I currently do. However, I suspect that res and y may be garbage collected in use_do_worka. Is this true?
If so then use_do_workb PROTECT both of them again. Is this a good and correct way to pass SEXP objects between C functions? That is, re-protect the returned object from another C function?
Lastly, do_work2 and use_do_workc is very similar use_do_workb but save one PROTECT call. However, it adds the burden that one has to remember to UNPROTECT which I gather can easily lead to a bug. Is this version still valid?
Remarks
I have tried to run
R -d valgrind -e "Rcpp::sourceCpp('[name-of-file-w-above-code].cpp')"
but this does not cause any issues. I have also tried to R CMD check --use-valgrind the package but I cannot reproduce the issue on CRAN.
The actually error I get from CRAN is:
==4144090== Invalid read of size 8
==4144090== at 0x483EDED: memcpy#GLIBC_2.2.5 (/builddir/build/BUILD/valgrind-3.16.1/memcheck/../shared/vg_replace_strmem.c:1032)
==4144090== by 0x1736C2AC: copy (packages/tests-vg/psqn/src/../inst/include/lp.h:12)
==4144090== by 0x1736C2AC: r_worker_bfgs::grad(double const*, double*) (packages/tests-vg/psqn/src/r-api.cpp:353)
==4144090== by 0x17367754: PSQN::optim_info PSQN::bfgs<PSQN::R_reporter, PSQN::R_interrupter>(PSQN::problem&, double*, double, unsigned long, double, double, int)::{lambda(double, double*, double*, double*, double&)#4}::operator()(double, double*, double*, double*, double&) const (packages/tests-vg/psqn/src/../inst/include/psqn-bfgs.h:148)
with
packages/tests-vg/psqn/src/../inst/include/lp.h:12.
packages/tests-vg/psqn/src/r-api.cpp:353.
where I know that the vector has the right length which makes me suspect that it has been garbage collected because of the invalid read of size 8 error. The vector is created with very similar code as in my example above.
I am trying to convert my R function to C++ using Rcpp, but I came around errors that I don't understand quite well.
The following code gives my R function, my (poor) attempt to translate it and some examples of uses at the end (testing that the two function return the same thing...)
My R Code function:
intersect_rectangles <- function(x_min, x_max, y_min, y_max) {
rez <- list()
rez$min <- pmax(x_min, y_min)
rez$max <- pmin(x_max, y_max)
if (any(rez$min > rez$max)) {
return(list(NULL))
}
return(rez)
}
My attempt to create the same function with Rcpp.
#include <Rcpp.h>
using namespace Rcpp;
// [[Rcpp::export]]
List Cpp_intersect_rectangles(NumericVector x_min,NumericVector
x_max,NumericVector y_min,NumericVector y_max) {
// Create a list :
NumericVector min = pmax(x_min,y_min);
NumericVector max = pmin(x_max,y_max);
List L = List::create(R_NilValue);
if (! any(min > max)) {
L = List::create(Named("min") = min , _["max"] = max);
}
return(L);
}
I receive the following error messages:
/Library/Frameworks/R.framework/Versions/3.5/Resources/library/Rcpp/include/Rcpp/sugar/logical/SingleLogicalResult.h:36:2: error: implicit instantiation of undefined template 'Rcpp::sugar::forbidden_conversion<false>'
forbidden_conversion<x>{
^
/Library/Frameworks/R.framework/Versions/3.5/Resources/library/Rcpp/include/Rcpp/sugar/logical/SingleLogicalResult.h:74:40: note: in instantiation of template class 'Rcpp::sugar::conversion_to_bool_is_forbidden<false>' requested here
conversion_to_bool_is_forbidden<!NA> x ;
^
file637e53281965.cpp:13:9: note: in instantiation of member function 'Rcpp::sugar::SingleLogicalResult<true, Rcpp::sugar::Negate_SingleLogicalResult<true, Rcpp::sugar::Any<true, Rcpp::sugar::Comparator<14, Rcpp::sugar::greater<14>, true, Rcpp::Vector<14, PreserveStorage>, true, Rcpp::Vector<14, PreserveStorage> > > > >::operator bool' requested here
if (! any(min > max))
If the Rcpp function is implemented correctly, then the following should work:
u = rep(0,4)
v = rep(1,4)
w = rep(0.3,4)
x = c(0.8,0.8,3,3)
all.equal(intersect_rectangles(u,v,w,x), Cpp_intersect_rectangles(u,v,w,x))
all.equal(intersect_rectangles(u,v,w,w), Cpp_intersect_rectangles(u,v,w,w))
What's wrong with my cpp code?
The reason the code isn't translating correctly is due to how the any() Rcpp sugar implementation was created. In particular, we have that:
The actual return type of any(X) is an instance of the
SingleLogicalResult template class, but the functions is_true
and is_false may be used to convert the return value to bool.
Per https://thecoatlessprofessor.com/programming/unofficial-rcpp-api-documentation/#any
Therefore, the solution is to add .is_true() to the any() function call, e.g. !any(condition).is_true().
#include <Rcpp.h>
using namespace Rcpp;
// [[Rcpp::export]]
List Cpp_intersect_rectangles(NumericVector x_min, NumericVector x_max,
NumericVector y_min, NumericVector y_max) {
// Create a list :
NumericVector min = pmax(x_min, y_min);
NumericVector max = pmin(x_max, y_max);
List L = List::create(R_NilValue);
if (! any(min > max).is_true()) {
// ^^^^^^^^^ Added
L = List::create(Named("min") = min , _["max"] = max);
}
return(L);
}
Then, through testing we get:
u = rep(0,4)
v = rep(1,4)
w = rep(0.3,4)
x = c(0.8,0.8,3,3)
all.equal(intersect_rectangles(u,v,w,x), Cpp_intersect_rectangles(u,v,w,x))
# [1] TRUE
all.equal(intersect_rectangles(u,v,w,w), Cpp_intersect_rectangles(u,v,w,w))
# [1] TRUE
I am trying to call R function optim() in Rcpp. I saw an example in Calling R's optim function from within C++ using Rcpp, but I am unable to modify it correctly for my use case. Basically, the objective function depends on the x and y but I want to optimize it with respect to b.
Here is the R code that does what I want:
example_r = function(b, x, y) {
phi = rnorm(length(x))
tar_val = (x ^ 2 + y ^ 2) * b * phi
objftn_r = function(beta, x, y) {
obj_val = (x ^ 2 + y ^ 2) * beta
return(obj_val)
}
b1 = optim(b, function(beta) {
sum((objftn_r(beta, x, y) - tar_val) ^ 2)
}, method = "BFGS")$par
result = (x ^ 2 + y ^ 2) * b1
return(b1)
}
Here's is my attempt to translate it to _RcppArmadillo:
#include <RcppArmadillo.h>
using namespace Rcpp;
// [[Rcpp::depends(RcppArmadillo)]]
arma::vec example_rcpp(arma::vec b, arma::vec x, arma::vec y){
arma::vec tar_val = pow(x,2)%b-pow(y,2);
return tar_val;
}
// [[Rcpp::export]]
arma::vec optim_rcpp(const arma::vec& init_val, arma::vec& x, arma::vec& y){
Rcpp::Environment stats("package:stats");
Rcpp::Function optim = stats["optim"];
Rcpp::List opt_results = optim(Rcpp::_["par"] = init_val,
Rcpp::_["fn"] = Rcpp::InternalFunction(&example_rcpp),
Rcpp::_["method"] = "BFGS");
arma::vec out = Rcpp::as<arma::vec>(opt_results[0]);
return out;
}
However, this code is returning:
> optim_rcpp(1:3,2:4,3:5)
Error in optim_rcpp(1:3, 2:4, 3:5) : not compatible with requested type
I'm not sure what the error is here.
Before we begin, I have a few remarks:
Please show all of your attempt.
In particular, make sure your example is a minimal reproducible example
Do not delete or shorten code unless asked.
Keep the scope of your question narrow.
Using optim from R in C++ is very different than using in C++ the underlying C++ code for opt() from nlopt.
Avoid spamming questions.
If you find yourself asking more than 3 questions in rapid succession, please read the documentation or talk in person with someone familiar with the content.
I've cleaned up your question as a result... But, in the future, this likely will not happen.
Data Generation Process
The data generation process seems to be done in 2 steps: First, outside of the example_r function, and, then inside the function.
This should be simplified so that it is done outside of the optimization function. For example:
generate_data = function(n, x_mu = 0, y_mu = 1, beta = 1.5) {
x = rnorm(n, x_mu)
y = rnorm(n, y_mu)
phi = rnorm(length(x))
tar_val = (x ^ 2 + y ^ 2) * beta * phi
simulated_data = list(x = x, y = y, beta = beta, tar_val = tar_val)
return(simulated_data)
}
Objective Functions and R's optim
Objective functions must return a single value, e.g. a scalar, in R. Under the posted R code, there was effectively two functions designed to act as an objective function in sequence, e.g.
objftn_r = function(beta, x, y) {
obj_val = (x ^ 2 + y ^ 2) * beta
return(obj_val)
}
b1 = optim(b, function(beta) {
sum((objftn_r(beta, x, y) - tar_val) ^ 2)
}, method = "BFGS")$par
This objective function should therefore be re-written as:
objftn_r = function(beta_hat, x, y, tar_val) {
# The predictions generate will be a vector
est_val = (x ^ 2 + y ^ 2) * beta_hat
# Here we apply sum of squares which changes it
# from a vector into a single "objective" value
# that optim can work with.
obj_val = sum( ( est_val - tar_val) ^ 2)
return(obj_val)
}
From there, the calls should align as:
sim_data = generate_data(10, 1, 2, .3)
b1 = optim(sim_data$beta, fn = objftn_r, method = "BFGS",
x = sim_data$x, y = sim_data$y, tar_val = sim_data$tar_val)$par
RcppArmadillo Objective Functions
Having fixed the scope and behavior of the R code, let's focus on translating it into RcppArmadillo.
In particular, notice that the objection function defined after the translation returns a vector and not a scalar into optim, which is not a single value. Also of concern is the lack of a tar_val parameter in the objective function. With this in mind, the objective function will translate to:
// changed function return type and
// the return type of first parameter
double obj_fun_rcpp(double& beta_hat,
arma::vec& x, arma::vec& y, arma::vec& tar_val){
// Changed from % to * as it is only appropriate if
// `beta_hat` is the same length as x and y.
// This is because it performs element-wise multiplication
// instead of a scalar multiplication on a vector
arma::vec est_val = (pow(x, 2) - pow(y, 2)) * beta_hat;
// Compute objective value
double obj_val = sum( pow( est_val - tar_val, 2) );
// Return a single value
return obj_val;
}
Now, with the objective function set, let's address the Rcpp call into R for optim() from C++. In this function, the parameters of the
function must be explicitly supplied. So, x, y, and tar_val must be present in the optim call. Thus, we will end up with:
// [[Rcpp::export]]
arma::vec optim_rcpp(double& init_val,
arma::vec& x, arma::vec& y, arma::vec& tar_val){
// Extract R's optim function
Rcpp::Environment stats("package:stats");
Rcpp::Function optim = stats["optim"];
// Call the optim function from R in C++
Rcpp::List opt_results = optim(Rcpp::_["par"] = init_val,
// Make sure this function is not exported!
Rcpp::_["fn"] = Rcpp::InternalFunction(&obj_fun_rcpp),
Rcpp::_["method"] = "BFGS",
// Pass in the other parameters as everything
// is scoped environmentally
Rcpp::_["x"] = x,
Rcpp::_["y"] = y,
Rcpp::_["tar_val"] = tar_val);
// Extract out the estimated parameter values
arma::vec out = Rcpp::as<arma::vec>(opt_results[0]);
// Return estimated values
return out;
}
All together
The full functioning code can be written in test_optim.cpp and compiled via sourceCpp() as:
#include <RcppArmadillo.h>
// [[Rcpp::depends(RcppArmadillo)]]
// changed function return type and
// the return type of first parameter
// DO NOT EXPORT THIS FUNCTION VIA RCPP ATTRIBUTES
double obj_fun_rcpp(double& beta_hat,
arma::vec& x, arma::vec& y, arma::vec& tar_val){
// Changed from % to * as it is only appropriate if
// `beta_hat` is the same length as x and y.
// This is because it performs element-wise multiplication
// instead of a scalar multiplication on a vector
arma::vec est_val = (pow(x, 2) - pow(y, 2)) * beta_hat;
// Compute objective value
double obj_val = sum( pow( est_val - tar_val, 2) );
// Return a single value
return obj_val;
}
// [[Rcpp::export]]
arma::vec optim_rcpp(double& init_val,
arma::vec& x, arma::vec& y, arma::vec& tar_val){
// Extract R's optim function
Rcpp::Environment stats("package:stats");
Rcpp::Function optim = stats["optim"];
// Call the optim function from R in C++
Rcpp::List opt_results = optim(Rcpp::_["par"] = init_val,
// Make sure this function is not exported!
Rcpp::_["fn"] = Rcpp::InternalFunction(&obj_fun_rcpp),
Rcpp::_["method"] = "BFGS",
// Pass in the other parameters as everything
// is scoped environmentally
Rcpp::_["x"] = x,
Rcpp::_["y"] = y,
Rcpp::_["tar_val"] = tar_val);
// Extract out the estimated parameter values
arma::vec out = Rcpp::as<arma::vec>(opt_results[0]);
// Return estimated values
return out;
}
Test Case
# Setup some values
beta = 2
x = 2:4
y = 3:5
# Set a seed for reproducibility
set.seed(111)
phi = rnorm(length(x))
tar_val = (x ^ 2 + y ^ 2) * beta * phi
optim_rcpp(beta, x, y, tar_val)
# [,1]
# [1,] 2.033273
Note: If you would like to avoid a matrix of size 1 x1 from being returned please use double as the return parameter of optim_rcpp and switch Rcpp::as<arma::vec> to Rcpp::as<double>
I have this C++ code:
#include <R.h>
#include <Rcpp.h>
using namespace Rcpp;
extern "C" {
SEXP gensampleRcpp2( Function rlawfunc, SEXP n) {
Rcpp::RNGScope __rngScope;
return Rcpp::List::create(Rcpp::Named("sample") = rlawfunc(n),
Rcpp::Named("law.name") = " ",
Rcpp::Named("law.pars") = R_NilValue);
}
RcppExport SEXP gensampleRcpp(SEXP rlawfuncSEXP, SEXP nSEXP) {
BEGIN_RCPP
Function rlawfunc = Rcpp::as<Function >(rlawfuncSEXP);
IntegerVector n = Rcpp::as<IntegerVector >(nSEXP);
SEXP __result = gensampleRcpp2(rlawfunc, n);
return Rcpp::wrap(__result);
END_RCPP
}
SEXP compquantRcpp2(IntegerVector n, IntegerVector M, Function Rlaw) {
int i;
GetRNGstate();
for (i=1;i<=M[0];i++) {
List resultsample = gensampleRcpp2(Rlaw, n);
NumericVector mysample = Rcpp::as<NumericVector >(resultsample["sample"]);
}
PutRNGstate();
return Rcpp::List::create(Rcpp::Named("law.pars") = "");
}
RcppExport SEXP compquantRcpp(SEXP nSEXP, SEXP MSEXP, SEXP RlawSEXP) {
BEGIN_RCPP
IntegerVector n = Rcpp::as<IntegerVector >(nSEXP);
IntegerVector M = Rcpp::as<IntegerVector >(MSEXP);
Function Rlaw = Rcpp::as<Function >(RlawSEXP);
SEXP __result = compquantRcpp2(n, M, Rlaw);
return Rcpp::wrap(__result);
END_RCPP
}
}
and this R code:
compquant <- function(n=50,M=10^3,Rlaw=rnorm) {
out <- .Call("compquantRcpp",n=as.integer(n),M=as.integer(M),as.function(Rlaw),PACKAGE="PoweR")
return(out)
}
in a package called PoweR (in fact the above codes are simplifications of my own code so do no try to understand the purpose of it). When I compile my package (under Linux and R version 3.1.0) and issue the following R command in the console:
require(PoweR)
compquant()
I get the following error:
Error: not compatible with requested type
Do you have any idea on what could be the problem and how to solve it?
Thank you.
I just had to remove the 6th line:
Rcpp::RNGScope __rngScope;
to solve the problem. This being said, Dirk Eddelbuettel gave very good hints on rcpp-devel on how to greatly simplify the whole process. So thank you very much Dirk.
Consider the following R code,
## ----------- R version -----------
caller <- function(x=1:3, fun = "identity", ...){
## do some other stuff
## ...
## then call the function
eval(call(fun, x))
}
fun1 <- function(x, ...){
x + x
}
fun2 <- function(x, a = 10) a * x
caller(fun = "fun1")
caller(fun = "fun2")
The user can pass a function name "fun", that is used by caller. I wish to perform the same task with RcppArmadillo objects (as part of a more complex task, obviously). The function would be defined in C++, and the user selects it at the R level by referring to its name:
caller_cpp(1:3, "fun1_cpp")
or
caller_cpp(1:3, "fun2_cpp")
etc.
Here's my naive attempt for the caller function, that even fails to compile:
## ----------- C++ version -----------
library(Rcpp)
require( RcppArmadillo )
sourceCpp( code = '
// [[Rcpp::depends("RcppArmadillo")]]
#include <RcppArmadillo.h>
using namespace arma ;
using namespace Rcpp ;
colvec fun1_cpp(const colvec x)
{
colvec y ;
y = x + x;
return (y);
}
colvec fun2_cpp(const colvec x)
{
colvec y ;
y = 10*x;
return (y);
}
// mysterious pointer business in an attempt
// to select a compiled function by its name
typedef double (*funcPtr)(SEXP);
SEXP putFunPtrInXPtr(SEXP funname) {
std::string fstr = Rcpp::as<std::string>(funname);
if (fstr == "fun1")
return(Rcpp::XPtr<funcPtr>(new funcPtr(&fun1_cpp)));
else if (fstr == "fun2")
return(Rcpp::XPtr<funcPtr>(new funcPtr(&fun2_cpp)));
}
// [[Rcpp::export]]
colvec caller_cpp(const colvec x, character funname)
{
Rcpp::XPtr fun = putFunPtrInXPtr(funname);
colvec y ;
y = fun(x);
return (y);
}
')
Edit: adapted the example after following Dirk's suggestion to look at RcppDE.
(Sometime you need to use svn log ... on files to see how dated they are...)
I think a better use case is in my "port" of the C-based DEoptim to Rcpp / RcppArmadillo: RcppDE. In it, I allow the optimization routine to use either an R function (as DEoptim does) or a user-supplied compiled function -- which is what you want here as I understand it.
There is a tiny bit of C++ scaffolding, but you should have no problem following that.
Edit on 2013-01-21 Below is a complete solution which I have also justed posted as this new post at the Rcpp Gallery -- including some comments and sample usage.
// [[Rcpp::depends(RcppArmadillo)]]
#include <RcppArmadillo.h>
using namespace arma;
using namespace Rcpp;
vec fun1_cpp(const vec& x) { // a first function
vec y = x + x;
return (y);
}
vec fun2_cpp(const vec& x) { // and a second function
vec y = 10*x;
return (y);
}
typedef vec (*funcPtr)(const vec& x);
// [[Rcpp::export]]
XPtr<funcPtr> putFunPtrInXPtr(std::string fstr) {
if (fstr == "fun1")
return(XPtr<funcPtr>(new funcPtr(&fun1_cpp)));
else if (fstr == "fun2")
return(XPtr<funcPtr>(new funcPtr(&fun2_cpp)));
else
return XPtr<funcPtr>(R_NilValue); // runtime error as NULL no XPtr
}
// [[Rcpp::export]]
vec callViaString(const vec x, std::string funname) {
XPtr<funcPtr> xpfun = putFunPtrInXPtr(funname);
funcPtr fun = *xpfun;
vec y = fun(x);
return (y);
}
// [[Rcpp::export]]
vec callViaXPtr(const vec x, SEXP xpsexp) {
XPtr<funcPtr> xpfun(xpsexp);
funcPtr fun = *xpfun;
vec y = fun(x);
return (y);
}