I want to use the R stats::optimize function in Rcpp because I haven't been able to find an Rcpp equivalent. The code below is my attempt at a simple example based on the Example in the optimize help, but fails.
Here's the R function and results
f <- function (x) (x - .33)^2
xmin <- optimize(f, c(0, 1), tol = 0.0001)
xmin
This returns
$minimum
[1] 0.333
$objective
[1] 0
Here's the Rcpp code that fails when sourcing it.
#include <Rcpp.h>
const double tolerance = 1e-0;
// [[Rcpp::export]]
Rcpp::NumericVector f(Rcpp::NumericVector x) {
return pow(x-0.33, 2);
}
Rcpp::List fTg_opt(const double optmin, const double optmax) {
Rcpp::Environment base("package:stats");
Rcpp::Function optimize_r = base["optimize"];
Rcpp::NumericVector interval = {optmin,optmax};
return optimize_r(f, interval, tolerance);
}
The Rstudio console has the following error messages.
> Rcpp::sourceCpp("R/cpp/testopt.cpp")
In file included from testopt.cpp:1:
In file included from /Library/Frameworks/R.framework/Versions/4.1/Resources/library/Rcpp/include/Rcpp.h:27:
In file included from /Library/Frameworks/R.framework/Versions/4.1/Resources/library/Rcpp/include/RcppCommon.h:157:
In file included from /Library/Frameworks/R.framework/Versions/4.1/Resources/library/Rcpp/include/Rcpp/traits/traits.h:45:
/Library/Frameworks/R.framework/Versions/4.1/Resources/library/Rcpp/include/Rcpp/traits/is_convertible.h:35:10: error: function cannot return function type 'Rcpp::Vector<14> (Rcpp::Vector<14>)'
static T MakeT() ;
^
/Library/Frameworks/R.framework/Versions/4.1/Resources/library/Rcpp/include/Rcpp/internal/wrap.h:770:75: note: in instantiation of template class 'Rcpp::traits::is_convertible<Rcpp::Vector<14> (Rcpp::Vector<14>), SEXPREC *>' requested here
return wrap_dispatch_unknown(object, typename ::Rcpp::traits::is_convertible<T,SEXP>::type());
^
/Library/Frameworks/R.framework/Versions/4.1/Resources/library/Rcpp/include/Rcpp/internal/wrap.h:787:20: note: in instantiation of function template specialization 'Rcpp::internal::wrap_dispatch_eigen<Rcpp::Vector<14> (Rcpp::Vector<14>)>' requested here
return wrap_dispatch_eigen(object, typename traits::is_eigen_base<T>::type());
^
/Library/Frameworks/R.framework/Versions/4.1/Resources/library/Rcpp/include/Rcpp/internal/wrap.h:807:20: note: in instantiation of function template specialization 'Rcpp::internal::wrap_dispatch_unknown_importable<Rcpp::Vector<14> (Rcpp::Vector<14>)>' requested here
return wrap_dispatch_unknown_importable(object, typename ::Rcpp::traits::is_importer<T>::type());
^
/Library/Frameworks/R.framework/Versions/4.1/Resources/library/Rcpp/include/Rcpp/internal/wrap_end.h:30:25: note: in instantiation of function template specialization 'Rcpp::internal::wrap_dispatch<Rcpp::Vector<14> (Rcpp::Vector<14>)>' requested here
return internal::wrap_dispatch( object, typename ::Rcpp::traits::wrap_type_traits<T>::wrap_category() ) ;
^
/Library/Frameworks/R.framework/Versions/4.1/Resources/library/Rcpp/include/Rcpp/grow.h:44:26: note: in instantiation of function template specialization 'Rcpp::wrap<Rcpp::Vector<14> (Rcpp::Vector<14>)>' requested here
return grow( wrap(head), tail ) ;
^
/Library/Frameworks/R.framework/Versions/4.1/Resources/library/Rcpp/include/Rcpp/grow.h:65:26: note: in instantiation of function template specialization 'Rcpp::internal::grow__dispatch<Rcpp::Vector<14> (Rcpp::Vector<14>)>' requested here
return internal::grow__dispatch(typename traits::is_named<T>::type(), head, y);
^
/Library/Frameworks/R.framework/Versions/4.1/Resources/library/Rcpp/include/Rcpp/generated/grow__pairlist.h:45:9: note: in instantiation of function template specialization 'Rcpp::grow<Rcpp::Vector<14> (Rcpp::Vector<14>)>' requested here
return grow( t1, grow( t2, grow( t3, R_NilValue ) ) ) ;
^
/Library/Frameworks/R.framework/Versions/4.1/Resources/library/Rcpp/include/Rcpp/generated/Function__operator.h:45:20: note: in instantiation of function template specialization 'Rcpp::pairlist<Rcpp::Vector<14> (Rcpp::Vector<14>), Rcpp::Vector<14>, double>' requested here
return invoke(pairlist(t1, t2, t3), R_GlobalEnv);
^
testopt.cpp:13:20: note: in instantiation of function template specialization 'Rcpp::Function_Impl<PreserveStorage>::operator()<Rcpp::Vector<14> (Rcpp::Vector<14>), Rcpp::Vector<14>, double>' requested here
return optimize_r(f, interval, tolerance);
^
1 error generated.
make: *** [testopt.o] Error 1
clang++ -mmacosx-version-min=10.13 -std=gnu++14 -I"/Library/Frameworks/R.framework/Resources/include" -DNDEBUG -I"/Library/Frameworks/R.framework/Versions/4.1/Resources/library/Rcpp/include" -I"/Users/gcn/Documents/workspace/ISIMIPData/R/cpp" -I/usr/local/include -fPIC -Wall -g -O2 -c testopt.cpp -o testopt.o
Error in Rcpp::sourceCpp("R/cpp/testopt.cpp") :
Error 1 occurred building shared library.
One of your problems here is that you assume that becomes a function you submit to compilation under Rcpp::sourceCpp() is callable under its exported name.
It is not. Try Rcpp::sourceCpp(..., verbose=TRUE), i.e. add that arguments, to see what is really called. Those you could pass around (using SEXP argunments and results, but they are unwieldy).
To prove, here is a 'working but useless' version of your code. If we pass f() from R too, everything is callable.
Morale: The interface still is SEXP .Call("name", SEXP a, SEXP b, ...) even if Rcpp hides that. No Free Lunch (TM). But as my comment hinted, there are optimization packages you can use with Rcpp.
Code
#include <Rcpp.h>
// [[Rcpp::export]]
Rcpp::List fTg_opt(Rcpp::Function f, const double optmin, const double optmax) {
Rcpp::Environment base("package:stats");
Rcpp::Function optimize_r = base["optimize"];
Rcpp::NumericVector interval = {optmin,optmax};
Rcpp::List res = optimize_r(f, interval);
return res;
}
/*** R
f <- function (x) (x - .33)^2
xmin <- optimize(f, c(0, 1), tol = 0.0001)
xmin
fTg_opt(f, 0, 1)
*/
Output
> Rcpp::sourceCpp("~/git/stackoverflow/68674076/question.cpp")
> f <- function (x) (x - .33)^2
> xmin <- optimize(f, c(0, 1), tol = 0.0001)
> xmin
$minimum
[1] 0.33
$objective
[1] 0
> fTg_opt(f, 0, 1)
$minimum
[1] 0.33
$objective
[1] 0
Related
Recently I am trying to add a Fortran function into an existing R package that contains C++ code and is build under Rcpp package. I have successfully added the Fortran function and build the R package. But when I try to run an example for the R package for different times, each time the function returns a different value, which a bit confusing since the Fortran function I added has no undeterministic parameter or contains self iteration. Also sometimes when I try to run the function, R crashes.
This is a part of the Fortran function that are in the file "src/k2s.f95"
REAL*8 FUNCTION k2(n1,n2,n3,vec1,length1,a1,vec2,length2,a2)
integer :: n1,n2,n3,length1,length2
integer, dimension(length1) :: vec1
double precision :: a1,a2
double precision, dimension(length2):: vec2
double precision :: P(n1+2)
...
k2 = -1.0
IF ((n1<1) .OR. (n2<1) .OR. (length2 .NE. n1+n2-1) .OR. (n3<1) .OR. (n3 > 3)) RETURN
k2 = -2.0
IF(MINVAL(vec1).LE.0) RETURN
IF(SUM(vec1).NE.(n1+n2)) RETURN
IF(MINVAL(vec2).LE.0) RETURN
...
END FUNCTION K2
And I have used this answer Integrate Fortran, C++ with R to construct the package. Therefore I have written the following C++ file under src dictionary. This is the content of C++ file "k2s2.cpp"
#include "Rcpp.h"
extern "C" {
double k2_(int *n1, int *n2, int *n3, int vec1[], int *length1, double *a1, double vec2[], int *length2, double *a2);
}
// [[Rcpp::export]]
double K2_fortran(int n1, int n2, int n3, Rcpp::IntegerVector vec1, double a1, Rcpp::NumericVector vec2, double a2)
{
int length1 = vec1.size();
int length2 = vec2.size();
double q = 0;
pval = k2_(&n1,&n2,&n3,vec1.begin(),&length1,&a1,vec2.begin(),&length2,&a2);
return q;
}
I think it should be fine. Then I build the package (with Rcpp automatically generates the file "src/RcppExports.cpp" and "R/RcppExports.R" to link the cpp function K2_fortran to R) and load all the functions, then I get the R function K2_fortran. And I run the following example.
K2_fortran(120, 150, 1, c(80,70,40,80), 0.1, rep(1,269), 1e-6)
And the result is -2. Then I rerun the code for the second time, I got the expected result 0.175. For the third time, I got 1(some other returned value when there is an error). Then I run it again, a fatal error occurs in R and closes the R.
If I reopen it and run this example 4 times again. The result will be again -2, 0.175, 1 and a fatal error. I am not sure what has happened.
I guess the function gamma only works for a vector as the input. Is there a way to apply it to a scalar, say,gamma(3)`?
Actually, I would get the correct output if I include gamma(3) as part of my code, but there's a warning message....
#include <Rcpp.h>
using namespace Rcpp;
// [[Rcpp::export]]
List fool(NumericVector vec){
double res = 0;
res = sum(gamma(vec)) + gamma(3);
List result;result["num"] = res;
return result;
}
Here is the warning messgae:
exp.cpp:7:27: warning: 'gamma' is deprecated: first deprecated in OS X 10.9 [-Wdeprecated-declarations]
res = sum(gamma(vec)) + gamma(3);
^
/usr/include/math.h:720:15: note: 'gamma' has been explicitly marked deprecated here
extern double gamma(double) __OSX_AVAILABLE_BUT_DEPRECATED(__MAC_10_0, __MAC_10_9, __IPHONE_NA, __IPHONE_NA);
^
1 warning generated.
Thanks for posting code. You fell victim of being careless with namespaces. There is a (vectorized) gamma() in the Rcpp namespace -- the first argument and there is (was) a scalar gamma() (preferred: tgamma()) in the C math library. And it is better to be explicit.
Corrected code below:
#include <Rcpp.h>
// [[Rcpp::export]]
double fool(Rcpp::NumericVector vec){
double res =
Rcpp::sum(Rcpp::gamma(vec)) + // Rcpp sugar sum() and gamma() on vector
::tgamma(3.0); // math library tgamma of double
return res;
}
/*** R
v <- 1:5
fool(v)
sum(gamma(v)) + gamma(3)
*/
Output
R> sourceCpp("/tmp/shuang.cpp")
R> v <- 1:5
R> fool(v)
[1] 36
R> sum(gamma(v)) + gamma(3)
[1] 36
R>
I have a cpp function which has an R function as one of its arguments like below:
void mycppfunction(SEXP x, Rcpp::Function func)
func can be a function, or it can be NULL. How can I implement this? If I do this:
void mycppfunction(SEXP x, Rcpp::Nullable<Rcpp::Function> func)
then, the line:
func(x)
gives me the error:
error: no match for call to ‘(Rcpp::Nullable<Rcpp::Function_Impl<Rcpp::PreserveStorage> >) (SEXP)’
On the other hand, if I just define mycppfunction as:
void mycppfunction(SEXP x, Rcpp::Function func)
then running the code with a NULL value for func results in a segfault: "memory not mapped".
Yes you can do this but I would advise that you are careful about verifying the compatibility of the function passed in and the argument. Here's a small example, with minimal defensive code to ensure that f is a valid function:
#include <Rcpp.h>
typedef Rcpp::Nullable<Rcpp::Function> nullable_t;
// [[Rcpp::export]]
SEXP null_fun(Rcpp::NumericVector x, nullable_t f = R_NilValue) {
if (f.isNotNull()) {
return Rcpp::as<Rcpp::Function>(f)(x);
}
return Rcpp::wrap((double)Rcpp::sum(x));
}
/*** R
null_fun(1:5)
#[1] 15
null_fun(1:5, mean)
#[1] 3
null_fun(1:5, min)
#[1] 1
null_fun(1:5, max)
#[1] 5
*/
Note that the use of SEXP as a return type and the Rcpp::wrap((double)...) was just to quiet the compiler in this specific example, and won't necessarily apply to your use case(s).
I need to find the source code of the nlm function.
When I use
edit(nlm)
below code appears
function (f, p, ..., hessian = FALSE, typsize = rep(1, length(p)),
fscale = 1, print.level = 0, ndigit = 12, gradtol = 1e-06,
stepmax = max(1000 * sqrt(sum((p/typsize)^2)), 1000), steptol = 1e-06,
iterlim = 100, check.analyticals = TRUE)
{
print.level <- as.integer(print.level)
if (print.level < 0 || print.level > 2)
stop("'print.level' must be in {0,1,2}")
msg <- (1 + c(8, 0, 16))[1 + print.level]
if (!check.analyticals)
msg <- msg + (2 + 4)
.External2(C_nlm, function(x) f(x, ...), p, hessian, typsize,
fscale, msg, ndigit, gradtol, stepmax, steptol, iterlim)
}
now when I want to see what is insode C_nlm
I tried
stats:::C_nlm
and I get
$name
[1] "nlm"
$address
<pointer: 0x0000000004a83920>
attr(,"class")
[1] "RegisteredNativeSymbol"
$dll
DLL name: stats
Filename: C:/Program Files/R/R-3.1.2/library/stats/libs/x64/stats.dll
Dynamic lookup: FALSE
$numParameters
[1] 11
attr(,"class")
[1] "ExternalRoutine" "NativeSymbolInfo"
After some web search I found out that I need to use grep after this.
But I am not getting how to use it.
I tried these references
How to locate code called by .External2()?
How can I view the source code for a function?
Can anyone please tell me how to proceed further?
You can browse the R source code at this GitHub repo: r-source.
Search it for the term "SEXP nlm" since stats:::C_nlm points to a function with the name "nlm" and all functions returning data to R use a datatype called SEXP (S expression).
You'll get two hits in the files statsR.h and optimize.c. The c-file is what you are looking for, so go down to the line starting with SEXP nlm and you got it.
SEXP nlm(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP value, names, v, R_gradientSymbol, R_hessianSymbol;
double *x, *typsiz, fscale, gradtl, stepmx,
steptol, *xpls, *gpls, fpls, *a, *wrk, dlt;
int code, i, j, k, itnlim, method, iexp, omsg, msg,
n, ndigit, iagflg, iahflg, want_hessian, itncnt;
/* .Internal(
* nlm(function(x) f(x, ...), p, hessian, typsize, fscale,
* msg, ndigit, gradtol, stepmax, steptol, iterlim)
*/
function_info *state;
The title basically says it all.
If I do this ...
makeActiveBinding("x", function() runif(2), .GlobalEnv)
x
# [1] 0.7332872 0.4707796
x
# [1] 0.5500310 0.5013099
... is there then any way for me to examine x to learn what function it is linked to (and if not, why not)?
(In this case, I'd like to be able to learn that x was defined to be function() runif(2).)
With a bit of noodling around in envir.c, I can get this to work:
#include <Rcpp.h>
using namespace Rcpp ;
#define HASHSIZE(x) LENGTH(x)
#define HASHVALUE(x) TRUELENGTH(x)
// [[Rcpp::export]]
SEXP get_binding_fun( std::string name, Environment env){
SEXP symbol = Rf_install( name.c_str() );
SEXP tab = HASHTAB(env) ;
SEXP c = PRINTNAME(symbol);
// finding the hash code for the symbol
int hashcode = HASHVALUE(c) % HASHSIZE(tab);
// get the value there from the hash table
SEXP res = CAR( VECTOR_ELT(tab, hashcode ) ) ;
return res ;
}
Save this into a .cpp file, sourceCpp it and use it with this R code:
> makeActiveBinding("x", function() runif(2), .GlobalEnv)
> get_binding_fun("x", .GlobalEnv)
# function ()
# runif(2)