How is noNA used in Rcpp? - r

In his "Advanced R" book, Hadley Wickham says "noNA(x) asserts that the vector x does not contain any missing values." However I still don't know how to use it. I can't do
if (noNA(x))
do this
so how am I supposed to use it?
http://adv-r.had.co.nz/Rcpp.html#rcpp-sugar

Many of the Rcpp sugar expressions are implemented through template classes which have specializations for cases when the input object is known to be free of missing values, thereby allowing the underlying algorithm to avoid having to perform the extra work of dealing with NA values (e.g. calls to is_na). This is only possible because the VectorBase class has a boolean parameter indicating whether the underlying object can (can, not that it necessarily does) have NA values, or not.
noNA returns (when called on a VectorBase object) an instance of the Nona template class. Note that Nona itself derives from
Rcpp::VectorBase<RTYPE, false, Nona<RTYPE,NA,VECTOR>>
// ^^^^^
meaning that the returned object gets encoded with information that essentially says "you can assume that this data is free of NA values".
As an example, Rcpp::sum is implemented via the Sum class in the Rcpp::sugar namespace. In the default case, we see that there is extra work to manage the possibility of missing values:
STORAGE get() const {
STORAGE result = 0 ;
R_xlen_t n = object.size() ;
STORAGE current ;
for( R_xlen_t i=0; i<n; i++){
current = object[i] ;
if( Rcpp::traits::is_na<RTYPE>(current) ) // here
return Rcpp::traits::get_na<RTYPE>() ; // here
result += current ;
}
return result ;
}
On the other hand, there is also a specialization for cases when the input does not have missing values, in which the algorithm does less work:
STORAGE get() const {
STORAGE result = 0 ;
R_xlen_t n = object.size() ;
for( R_xlen_t i=0; i<n; i++){
result += object[i] ;
}
return result ;
}
To answer your question of "how do I apply this in practice?", here is an example:
#include <Rcpp.h>
using namespace Rcpp;
// [[Rcpp::export]]
int Sum(IntegerVector x) {
return sum(x);
}
// [[Rcpp::export]]
int SumNoNA(IntegerVector x) {
return sum(noNA(x));
}
Benchmarking these two functions,
set.seed(123)
x <- as.integer(rpois(1e6, 25))
all.equal(Sum(x), SumNoNA(x))
# [1] TRUE
microbenchmark::microbenchmark(
Sum(x),
SumNoNA(x),
times = 500L
)
# Unit: microseconds
# expr min lq mean median uq max neval
# Sum(x) 577.386 664.620 701.2422 677.1640 731.7090 1214.447 500
# SumNoNA(x) 454.990 517.709 556.5783 535.1935 582.7065 1138.426 500
the noNA version is indeed faster.

Related

How to apply lgamma to a matrix using Rcpp (and will it be faster)?

I am wondering if I can apply lgamma on all entries of a large matrix using Rcpp. I tried using a vector:
// lgammaRcpp.cpp
#include <Rcpp.h>
using namespace Rcpp;
// [[Rcpp::export]]
NumericVector lgammaRcpp(NumericVector v){
NumericVector out;
out = lgamma(v);
return(out);
}
I did a simple microbenchmarking:
library("microbenchmark")
x <- round(runif(100000)+50000);
microbenchmark(
lgammaRcpp(x),
lgamma(x)
)
and the Rcpp is slightly faster:
Unit: milliseconds
expr min lq mean median uq max neval
lgammaRcpp(x) 5.405556 5.416283 5.810254 5.436139 5.511993 8.650419 100
lgamma(x) 5.613717 5.628769 6.114942 5.644215 6.872677 9.947497 100
When I try using a "NumericMatrix", however:
// [[Rcpp::export]]
NumericMatrix lgammaRcpp(NumericMatrix v){
NumericMatrix out;
out = lgamma(v);
return(out);
}
there are errors that I don't understand, e.g.
/home/canghel/R/x86_64-pc-linux-gnu-library/3.4/Rcpp/include/Rcpp/vector /Matrix.h:83:13: note: Rcpp::Matrix<RTYPE, StoragePolicy>& Rcpp::Matrix<RTYPE, StoragePolicy>::operator=(const Rcpp::Matrix<RTYPE, StoragePolicy>&) [with int RTYPE = 14; StoragePolicy = Rcpp::PreserveStorage]
Matrix& operator=(const Matrix& other) {
My questions are: 1) Is there a way to modify my function to apply lgamma over all entries to a matrix? and 2) Is it worth it, or is the underlying library that is called for the lgamma function the same for C++ and R?
It seems better (i.e. faster) to apply functions like lgamma/digamma to a matrix using the Rfast package.
library("microbenchmark");
library("RcppArmadillo");
library("Rfast");
sourceCpp("lgammaRcpp.cpp");
x <- matrix(round(runif(100000)+50000), 100, 1000);
microbenchmark(
lgammaRcpp(x),
lgamma(x),
Rfast::Lgamma(x)
)
Unit: milliseconds
expr min lq mean median uq max neval
lgammaRcppArma(x) 4.654526 4.919831 5.577843 5.413790 5.888895 9.258325 100
lgamma(x) 5.572671 5.840268 6.582007 6.131651 7.280895 8.779301 100
Rfast::Lgamma(x) 4.450824 4.588596 5.128323 4.791287 5.608678 6.865331 100
where I had:
#include<RcppArmadillo.h>
// [[Rcpp::depends(RcppArmadillo)]]
// [[Rcpp::export]]
arma::mat lgammaRcpp(arma::mat m) {
arma::mat out = lgamma(m);
return(out);
}
Rcpp Sugar tends to return Vectors unless otherwise specified. Thus, you will always get back in this case a Vector of type Numeric e.g. NumericVector. See my notes on different sugar functions here: https://github.com/coatless/rcpp-api
The following allows for a compilation under the above note:
#include <Rcpp.h>
// [[Rcpp::export]]
NumericVector lgammaRcpp(NumericMatrix v) {
NumericVector out;
out = lgamma(v);
return(out);
}
It is highly unlikely you will see a large speed up as the functions being used are the same. This is partially indicated with your above benchmarks and can be verified by looking at Rcpp Math defines. Now, this isn't to say a benefit is not available. In particular, the main benefit here is if you are encapsulating a routine completely in C++. In which case, your routine will be significantly quicker if you use Sugar functions if compared to calling an R function from C++.

memory efficient method to calculate distance matrix [duplicate]

I have an object of class big.matrix in R with dimension 778844 x 2. The values are all integers (kilometres). My objective is to calculate the Euclidean distance matrix using the big.matrix and have as a result an object of class big.matrix. I would like to know if there is an optimal way of doing that.
The reason for my choice of using the class big.matrix is memory limitation. I could transform my big.matrix to an object of class matrix and calculate the Euclidean distance matrix using dist(). However, dist() would return an object of size that would not be allocated in the memory.
Edit
The following answer was given by John W. Emerson, author and maintainer of the bigmemory package:
You could use big algebra I expect, but this would also be a very nice use case for Rcpp via sourceCpp(), and very short and easy. But in short, we don't even attempt to provide high-level features (other than the basics which we implemented as proof-of-concept). No single algorithm could cover all use cases once you start talking out-of-memory big.
Here is a way using RcppArmadillo. Much of this is very similar to the RcppGallery example. This will return a big.matrix with the associated pairwise (by row) euclidean distances. I like to wrap my big.matrix functions in a wrapper function to create a cleaner syntax (i.e. avoid the #address and other initializations.
Note - as we are using bigmemory (and therefore concerned with RAM usage) I have this example returned the N-1 x N-1 matrix of only lower triangular elements. You could modify this but this is what I threw together.
euc_dist.cpp
// To enable the functionality provided by Armadillo's various macros,
// simply include them before you include the RcppArmadillo headers.
#define ARMA_NO_DEBUG
#include <RcppArmadillo.h>
// [[Rcpp::depends(RcppArmadillo, BH, bigmemory)]]
using namespace Rcpp;
using namespace arma;
// The following header file provides the definitions for the BigMatrix
// object
#include <bigmemory/BigMatrix.h>
// C++11 plugin
// [[Rcpp::plugins(cpp11)]]
template <typename T>
void BigArmaEuclidean(const Mat<T>& inBigMat, Mat<T> outBigMat) {
int W = inBigMat.n_rows;
for(int i = 0; i < W - 1; i++){
for(int j=i+1; j < W; j++){
outBigMat(j-1,i) = sqrt(sum(pow((inBigMat.row(i) - inBigMat.row(j)),2)));
}
}
}
// [[Rcpp::export]]
void BigArmaEuc(SEXP pInBigMat, SEXP pOutBigMat) {
// First we tell Rcpp that the object we've been given is an external
// pointer.
XPtr<BigMatrix> xpMat(pInBigMat);
XPtr<BigMatrix> xpOutMat(pOutBigMat);
int type = xpMat->matrix_type();
switch(type) {
case 1:
BigArmaEuclidean(
arma::Mat<char>((char *)xpMat->matrix(), xpMat->nrow(), xpMat->ncol(), false),
arma::Mat<char>((char *)xpOutMat->matrix(), xpOutMat->nrow(), xpOutMat->ncol(), false)
);
return;
case 2:
BigArmaEuclidean(
arma::Mat<short>((short *)xpMat->matrix(), xpMat->nrow(), xpMat->ncol(), false),
arma::Mat<short>((short *)xpOutMat->matrix(), xpOutMat->nrow(), xpOutMat->ncol(), false)
);
return;
case 4:
BigArmaEuclidean(
arma::Mat<int>((int *)xpMat->matrix(), xpMat->nrow(), xpMat->ncol(), false),
arma::Mat<int>((int *)xpOutMat->matrix(), xpOutMat->nrow(), xpOutMat->ncol(), false)
);
return;
case 8:
BigArmaEuclidean(
arma::Mat<double>((double *)xpMat->matrix(), xpMat->nrow(), xpMat->ncol(), false),
arma::Mat<double>((double *)xpOutMat->matrix(), xpOutMat->nrow(), xpOutMat->ncol(), false)
);
return;
default:
// We should never get here, but it resolves compiler warnings.
throw Rcpp::exception("Undefined type for provided big.matrix");
}
}
My little wrapper
bigMatrixEuc <- function(bigMat){
zeros <- big.matrix(nrow = nrow(bigMat)-1,
ncol = nrow(bigMat)-1,
init = 0,
type = typeof(bigMat))
BigArmaEuc(bigMat#address, zeros#address)
return(zeros)
}
The test
library(Rcpp)
sourceCpp("euc_dist.cpp")
library(bigmemory)
set.seed(123)
mat <- matrix(rnorm(16), 4)
bm <- as.big.matrix(mat)
# Call new euclidean function
bm_out <- bigMatrixEuc(bm)[]
# pull out the matrix elements for out purposes
distMat <- as.matrix(dist(mat))
distMat[upper.tri(distMat, diag=TRUE)] <- 0
distMat <- distMat[2:4, 1:3]
# check if identical
all.equal(bm_out, distMat, check.attributes = FALSE)
[1] TRUE

Rcpp Function slower than Rf_eval

I have been working on a package that uses Rcpp to apply arbitrary R code over a group of large medical imaging files. I noticed that my Rcpp implementation is considerably slower than the original pure C version. I traced the difference to calling a function via Function, vs the original Rf_eval. My question is why is there a close to 4x performance degradation, and is there a way to speed up the function call to be closer in performance to Rf_eval?
Example:
library(Rcpp)
library(inline)
library(microbenchmark)
cpp_fun1 <-
'
Rcpp::List lots_of_calls(Function fun, NumericVector vec){
Rcpp::List output(1000);
for(int i = 0; i < 1000; ++i){
output[i] = fun(NumericVector(vec));
}
return output;
}
'
cpp_fun2 <-
'
Rcpp::List lots_of_calls2(SEXP fun, SEXP env){
Rcpp::List output(1000);
for(int i = 0; i < 1000; ++i){
output[i] = Rf_eval(fun, env);
}
return output;
}
'
lots_of_calls <- cppFunction(cpp_fun1)
lots_of_calls2 <- cppFunction(cpp_fun2)
microbenchmark(lots_of_calls(mean, 1:1000),
lots_of_calls2(quote(mean(1:1000)), .GlobalEnv))
Results
Unit: milliseconds
expr min lq mean median uq max neval
lots_of_calls(mean, 1:1000) 38.23032 38.80177 40.84901 39.29197 41.62786 54.07380 100
lots_of_calls2(quote(mean(1:1000)), .GlobalEnv) 10.53133 10.71938 11.08735 10.83436 11.03759 18.08466 100
Rcpp is great because it makes things look absurdly clean to the programmer. The cleanliness has a cost in the form of templated responses and a set of assumptions that weigh down the execution time. But, such is the case with a generalized vs. specific code setup.
Take for instance the call route for an Rcpp::Function. The initial construction and then outside call to a modified version of Rf_reval requires a special Rcpp specific eval function given in Rcpp_eval.h. In turn, this function is wrapped in protections to protect against a function error when calling into R via a Shield associated with it. And so on...
In comparison, Rf_eval has neither. If it fails, you will be up the creek without a paddle. (Unless, of course, you implement error catching via R_tryEval for it.)
With this being said, the best way to speed up the calculation is to simply write everything necessary for the computation in C++.
Besides the points made by #coatless, you aren't even comparing apples with apples. Your Rf_eval example does not pass the vector to the function, and, more importantly, plays tricks on the function via quote().
In short, it is all a little silly.
Below is a more complete example using the sugar function mean().
#include <Rcpp.h>
using namespace Rcpp;
// [[Rcpp::export]]
List callFun(Function fun, NumericVector vec) {
List output(1000);
for(int i = 0; i < 1000; ++i){
output[i] = fun(NumericVector(vec));
}
return output;
}
// [[Rcpp::export]]
List callRfEval(SEXP fun, SEXP env){
List output(1000);
for(int i = 0; i < 1000; ++i){
output[i] = Rf_eval(fun, env);
}
return output;
}
// [[Rcpp::export]]
List callSugar(NumericVector vec) {
List output(1000);
for(int i = 0; i < 1000; ++i){
double d = mean(vec);
output[i] = d;
}
return output;
}
/*** R
library(microbenchmark)
microbenchmark(callFun(mean, 1:1000),
callRfEval(quote(mean(1:1000)), .GlobalEnv),
callSugar(1:1000))
*/
You can just sourceCpp() this:
R> sourceCpp("/tmp/ch.cpp")
R> library(microbenchmark)
R> microbenchmark(callFun(mean, 1:1000),
+ callRfEval(quote(mean(1:1000)), .GlobalEnv),
+ callSugar(1:1000))
Unit: milliseconds
expr min lq mean median uq max neval
callFun(mean, 1:1000) 14.87451 15.54385 18.57635 17.78990 18.29127 114.77153 100
callRfEval(quote(mean(1:1000)), .GlobalEnv) 3.35954 3.57554 3.97380 3.75122 4.16450 6.29339 100
callSugar(1:1000) 1.50061 1.50827 1.62204 1.51518 1.76683 1.84513 100
R>

How to prevent Rcpp from evaluating 'call' objects

I need to simple wrapper to serialize arbitrary R objects from within Rcpp code. Below a simplified version of my code:
// [[Rcpp::export]]
Rcpp::RawVector cpp_serialize(RObject x) {
Rcpp::Function serialize = Rcpp::Environment::namespace_env("base")["serialize"];
return serialize(x, R_NilValue);
}
This works great, however I found that for objects of class call the call gets evaluated before being serialized. How can I prevent this from happening? I just want to mimic serialize() in R.
# Works as intended
identical(serialize(iris, NULL), cpp_serialize(iris))
# Does not work: call is evaluated
call_object <- call("rnorm", 1000)
identical(serialize(call_object, NULL), cpp_serialize(call_object))
Update: I have a workaround in place (see below) but I am still very interested in a proper solution.
Rcpp::RawVector cpp_serialize(RObject x) {
Rcpp::Environment env;
env["MY_R_OBJECT"] = x;
Rcpp::ExpressionVector expr("serialize(MY_R_OBJECT, NULL)");
Rcpp::RawVector buf = Rcpp::Rcpp_eval(expr, env);
}
I think you've found an unexpected behavior in the Rcpp::Function class. An MRE:
#include <Rcpp.h>
using namespace Rcpp;
// [[Rcpp::export]]
RObject cpp_identity(RObject x) {
Rcpp::Function identity("identity");
return identity(x);
}
/*** R
quoted <- quote(print(1));
identity(quoted)
cpp_identity(quoted)
*/
gives
> quoted <- quote(print(1));
> identity(quoted)
print(1)
> cpp_identity(quoted)
[1] 1
[1] 1
This happens because Rcpp effectively performs this evaluation behind the scenes:
Rcpp_eval(Rf_lang2(Rf_install("identity"), x))
which is basically like
eval(call("identity", quoted))
but the call object is not 'protected' from evaluation.
tl;dr: The question was How does one serialize to Raw vectors from C? The (compiled C) function serializeToRaw() in the RApiSerialization package providing R's own serialization code. As the benchmark below shows, it is about three times faster than what was suggested above.
Longer Answer: I would not recommend mucking around with Rcpp::Function() for this.. We do in fact provide a proper package for R which access to serialization: RApiSerialization. It does not do much, but it exports exactly two function to serialize, and deserialize, from and to RAW which the RcppRedis package needs and uses.
So we can do the same here. I just called Rcpp.package.skeleton() to have a package 'jeroen' created, added the LinkingTo: and Imports: to DESCRIPTION and the imports() to NAMESPACE, and then this works:
#include <Rcpp.h>
#include <RApiSerializeAPI.h> // provides C API with serialization
// [[Rcpp::export]]
Rcpp::RawVector cpp_serialize(SEXP s) {
Rcpp::RawVector x = serializeToRaw(s); // from RApiSerialize
return x;
}
It is basically a simpler version of what you have above.
And we can call that as you do:
testJeroen <- function() {
## Works as intended
res <- identical(serialize(iris, NULL), cpp_serialize(iris))
## Didn't work above, works now
call_object <- call("rnorm", 1000)
res <- res &&
identical(serialize(call_object, NULL), cpp_serialize(call_object))
res
}
and lo and behold, it works:
R> library(jeroen)
Loading required package: RApiSerialize
R> testJeroen()
[1] TRUE
R>
So in short: if you don't want to muck with R, don't work with Rcpp::Function() objects.
Benchmark: Using a simple
library(jeroen) # package containing both functions from here
library(microbenchmark)
microbenchmark(cpp=cpp_serialize(iris), # my suggestion
env=env_serialize(iris)) # OP's suggestion, renamed
we get
edd#max:/tmp/jeroen$ Rscript tests/quick.R
Loading required package: RApiSerialize
Unit: microseconds
expr min lq mean median uq max neval cld
cpp 17.471 22.1225 28.0987 24.4975 26.4795 420.001 100 a
env 85.028 91.0055 94.8772 92.9465 94.9635 236.710 100 b
edd#max:/tmp/jeroen$
showing that the answer by OP is nearly three times slower.

Remove NA values efficiently

I need to remove NA values efficiently from vectors inside a function which is implemented with RcppEigen. I can of course do it using a for loop, but I wonder if there is a more efficient way.
Here is an example:
library(RcppEigen)
library(inline)
incl <- '
using Eigen::Map;
using Eigen::VectorXd;
typedef Map<VectorXd> MapVecd;
'
body <- '
const MapVecd x(as<MapVecd>(xx)), y(as<MapVecd>(yy));
VectorXd x1(x), y1(y);
int k(0);
for (int i = 0; i < x.rows(); ++i) {
if (x.coeff(i)==x.coeff(i) && y.coeff(i)==y.coeff(i)) {
x1(k) = x.coeff(i);
y1(k) = y.coeff(i);
k++;
};
};
x1.conservativeResize(k);
y1.conservativeResize(k);
return Rcpp::List::create(Rcpp::Named("x") = x1,
Rcpp::Named("y") = y1);
'
na.omit.cpp <- cxxfunction(signature(xx = "Vector", yy= "Vector"),
body, "RcppEigen", incl)
na.omit.cpp(c(1.5, NaN, 7, NA), c(7.0, 1, NA, 3))
#$x
#[1] 1.5
#
#$y
#[1] 7
In my use case I need to do this about one million times in a loop (inside the Rcpp function) and the vectors could be quite long (let's assume 1000 elements).
PS: I've also investigated the route to find all NA/NaN values using x.array()==x.array(), but was unable to find a way to use the result for subsetting with Eigen.
Perhaps I am not understanding the question correctly, but within Rcpp, I don't see how you could possibly do this more efficiently than a for loop. for loops are generally inefficient in R only because iterating through a loop in R requires a lot of heavy interpreted machinery. But this is not the case once you are down at the C++ level. Even natively vectorized R functions ultimately are implemented with for loops in C. So the only way I can think to make this more efficient is to try to do it in parallel.
For example, here's a simple na.omit.cpp function that omits NA values from a single vector:
rcppfun<-"
Rcpp::NumericVector naomit(Rcpp::NumericVector x){
std::vector<double> r(x.size());
int k=0;
for (int i = 0; i < x.size(); ++i) {
if (x[i]==x[i]) {
r[k] = x[i];
k++;
}
}
r.resize(k);
return Rcpp::wrap(r);
}"
na.omit.cpp<-cppFunction(rcppfun)
This runs even more quickly than R's built in na.omit:
> set.seed(123)
> x<-1:10000
> x[sample(10000,1000)]<-NA
> y1<-na.omit(x)
> y2<-na.omit.cpp(x)
> all(y1==y2)
[1] TRUE
> require(microbenchmark)
> microbenchmark(na.omit(x),na.omit.cpp(x))
Unit: microseconds
expr min lq median uq max neval
na.omit(x) 290.157 363.9935 376.4400 401.750 6547.447 100
na.omit.cpp(x) 107.524 168.1955 173.6035 210.524 222.564 100
I do not know if I understand the problem correctly or not but you can use the following arguments:
a = c(1.5, NaN, 7, NA)
a[-which(is.na(a))]
[1] 1.5 7.0
It might be useful to use `rinside' if you want to use it in C++.

Resources