Rcpp Gallery

Using RcppProgress to control the long computations in C++

Thu, 16 May 2013 00:00:00 -0700

Usually you write c++ code with R when you want to speedup some calculations. Depending on the parameters, and especially during the development, it is difficult to anticipate the execution time of your computation, so that you do not know if you have to wait for 1 minute or hours.

RcppProgress is a tool to help you monitor the execution time of your C++ code, by providing a way to interrupt the execution inside the c++ code, and also to display a progress bar indicative of the state of your computation.

Additionally, it is compatible with multithreaded code, for example using OpenMP, which is not as trivial as it may seem since you cannot just stop the execution in one thread, and not all threads should be writing in the console to avoid a garbled output.

// [[Rcpp::depends(RcppProgress)]]
#include <progress.hpp>
// [[Rcpp::export]]
double long_computation(int nb) {
  double sum = 0;
  for (int i = 0; i < nb; ++i) {
  	for (int j = 0; j < nb; ++j) {
			sum += Rf_dlnorm(i+j, 0.0, 1.0, 0);
		}
	}
  return sum + nb;
}

  system.time(s  <- long_computation(1000))

   user  system elapsed 
  0.096   0.000   0.095

[1] 1002

checking interruption

Let’s modify our code to add user interruption check, by calling Progress::check_abort.
Note the Rcpp::depends(RcppProgress) attribute in the header part that takes care of the include path for the progress.hpp header.

Now the long_computation2 call should be interruptible (with CTRL+C in the classic R console).

// [[Rcpp::depends(RcppProgress)]]
#include <progress.hpp>
// [[Rcpp::export]]
double long_computation2(int nb) {
  double sum = 0;
  Progress p(0, false); // in any case, we need to build an instance, should be improved in the next version
  for (int i = 0; i < nb; ++i) {
    if (Progress::check_abort() )
        return -1.0;
  	for (int j = 0; j < nb; ++j) {
			sum += Rf_dlnorm(i+j, 0.0, 1.0, 0);
		}
	}
  return sum + nb;
}

  system.time(s  <- long_computation2(3000)) # interrupt me

   user  system elapsed 
  0.840   0.000   0.838

[1] 3002

You may wonder Why do we put the check_abort call in the first loop instead that in the second ? The check_abort call is not neglectable, so it should be put in a place called often enough (once per second) but not too often.

adding a progress bar

Time to add the progress bar. The increment function is quite fast, so we can put it in the second loop. In real life example, it is sufficient to put it at a place called at least every second.

// [[Rcpp::depends(RcppProgress)]]
#include <progress.hpp>
// [[Rcpp::export]]
double long_computation3(int nb, bool display_progress=true) {
  double sum = 0;
  Progress p(nb*nb, display_progress);
  for (int i = 0; i < nb; ++i) {
    if (Progress::check_abort() )
    return -1.0;
    for (int j = 0; j < nb; ++j) {
      p.increment(); // update progress
			sum += Rf_dlnorm(i+j, 0.0, 1.0, 0);
		}
	}
  return sum + nb;
}

  system.time(s  <- long_computation3(3000)) # interrupt me

   user  system elapsed 
  0.848   0.000   0.848

[1] 3002

openMP support

First we need this to enable gcc openMP support:

Sys.setenv("PKG_CXXFLAGS"="-fopenmp")
Sys.setenv("PKG_LIBS"="-fopenmp")

Here’s an openMP version of our function:

#ifdef _OPENMP
#include <omp.h>
#endif
// [[Rcpp::depends(RcppProgress)]]
#include <progress.hpp>
// [[Rcpp::export]]
double long_computation_omp(int nb, int threads=1) {
 #ifdef _OPENMP
        if ( threads > 0 )
                omp_set_num_threads( threads );
        REprintf("Number of threads=%i\n", omp_get_max_threads());
#endif
 
  double sum = 0;
#pragma omp parallel for schedule(dynamic)   
  for (int i = 0; i < nb; ++i) {
    double thread_sum = 0;
  	for (int j = 0; j < nb; ++j) {
			thread_sum += Rf_dlnorm(i+j, 0.0, 1.0, 0);
		}
    sum += thread_sum;
	}
  
  return sum + nb;
}

Now check that it is parallelized:

  system.time(s4 <- long_computation_omp(5000, 4))

   user  system elapsed 
  2.264   0.000   0.572

s4

[1] 5002

  system.time(s1 <- long_computation_omp(5000, 1))

   user  system elapsed 
  2.248   0.000   2.247

s1

[1] 5002

adding progress monitoring to the openMP function

#ifdef _OPENMP
#include <omp.h>
#endif
// [[Rcpp::depends(RcppProgress)]]
#include <progress.hpp>
// [[Rcpp::export]]
double long_computation_omp2(int nb, int threads=1) {
#ifdef _OPENMP
  if ( threads > 0 )
    omp_set_num_threads( threads );
 
#endif
  Progress p(nb, true);
  double sum = 0;
#pragma omp parallel for schedule(dynamic)   
  for (int i = 0; i < nb; ++i) {
    double thread_sum = 0;
    if ( ! Progress::check_abort() ) {
      p.increment(); // update progress
      for (int j = 0; j < nb; ++j) {
          thread_sum += Rf_dlnorm(i+j, 0.0, 1.0, 0);
        }
    }
    sum += thread_sum;
  }
  
  return sum + nb;
}

  system.time(s <- long_computation_omp2(5000, 4))

   user  system elapsed 
  2.268   0.008   0.582

Test it now

If you want to test it now in your R console, just paste the following code (after installing RcppProgress of course):

library(Rcpp)
Sys.setenv("PKG_CXXFLAGS"="-fopenmp")
Sys.setenv("PKG_LIBS"="-fopenmp")

code='
#ifdef _OPENMP
#include <omp.h>
#endif
// [[Rcpp::depends(RcppProgress)]]
#include <progress.hpp>

// [[Rcpp::export]]
double long_computation_omp2(int nb, int threads=1) {
#ifdef _OPENMP
  if ( threads > 0 )
    omp_set_num_threads( threads );
    REprintf("Number of threads=%i\\n", omp_get_max_threads());
#endif
  Progress p(nb, true);
  double sum = 0;
#pragma omp parallel for schedule(dynamic)   
  for (int i = 0; i < nb; ++i) {
    double thread_sum = 0;
    if ( ! Progress::check_abort() ) {
      p.increment(); // update progress
      for (int j = 0; j < nb; ++j) {
          thread_sum += Rf_dlnorm(i+j, 0.0, 1.0, 0);
        }
    }
    sum += thread_sum;
  }
  
  return sum + nb;
}
'

sourceCpp(code=code)
s <- long_computation_omp2(10000, 4)

Karl Forner
Quartz Bio

An accept-reject sampler using RcppArmadillo::sample()

Wed, 08 May 2013 00:00:00 -0700

The recently added RcppArmadillo::sample() functionality provides the same algorithm used in R’s sample() to Rcpp-level code. Because R’s own sample() is written in C with minimal work done in R, writing a wrapper around RcppArmadillo::sample() to then call in R won’t get you much of a performance boost. However, if you need to repeatedly call sample(), then calling a single function which performs everything in Rcpp-land (including multiple calls to sample()) before returning to R can produce a noticeable speedup over a purely R-based solution.

Accept-Reject Sampler Example

One place where this situation arises is in an accept-reject sampler where the candidate “draw” is the output of a call to sample(). Concretely, let’s suppose we want to sample 20 integers (without replacement) from 1 to 50 such that the sum of the 20 integers is less than 400. Far fewer than 10% of randomly drawn samples will meet this constraint.

require(RcppArmadillo)

Loading required package: RcppArmadillo

Loading required package: Rcpp

require(rbenchmark)

Loading required package: rbenchmark

The R code is straightforward enough. It has been written to mirror the logic of the C++ code, although that doesn’t come at the cost of much performance.

r_getInts <- function(samples) {
    thresh <- 400
    results <- matrix(0, 20, samples) ;
    cnt <-  0

    while(cnt < samples) {
        candidate = sample(1:50, 20)

        if (sum(candidate) < thresh) {
            results[, cnt + 1] <- candidate
            cnt <- cnt + 1
        }
    }

    return(results)
}

Although it is a bit longer, the logic of the C++ code is similar.

#include <RcppArmadilloExtensions/sample.h>
// [[Rcpp::depends(RcppArmadillo)]]

using namespace Rcpp ;

// [[Rcpp::export]]
IntegerMatrix cpp_getInts(int samples
                          ) {
  
    RNGScope scope;
  
    int cnt = 0 ;
    IntegerMatrix results(20, samples) ;
    IntegerVector frame = seq_len(50) ;
    IntegerVector candidate(20) ;
    int thresh = 400 ;
  
    while (cnt < samples) {
        candidate = RcppArmadillo::sample(frame, 
                                          20, 
                                          FALSE, NumericVector::create()
                                          ) ;
        double sum = std::accumulate(candidate.begin(), candidate.end(), 0.0) ;
    
        if (sum < thresh) {
            results(_, cnt) = candidate ;
            cnt++ ;
        }
    }
  
    return results ;
}

Performance

The Rcpp code tends to be about 7-9 times faster and this boost increases as the constraint becomes more complicated (and necessarily more costly in R).

benchmark(r = {set.seed(1); r_getInts(50)},
          cpp = {set.seed(1); cpp_getInts(50)},
          replications = 10,
          order = 'relative',
          columns = c("test", "replications", "relative", "elapsed")
          )

  test replications relative elapsed
2  cpp           10     1.00   0.036
1    r           10    11.97   0.431

In the Real World …

Where might the structure in this problem arise in practice? One set of instances are those where “space” matters:

sampling US cities such that no more than two are in any one state
sampling cellphone towers such that no two are closer than X miles apart
sampling nodes in a graph/network such that no one has more than K edges

In these situations, R code to check the acceptance condition will likely be less efficient relative to the corresponding C++ code and so even larger speed-ups are realized.

Using the RcppArmadillo-based Implementation of R's sample()

Fri, 12 Apr 2013 00:00:00 -0700

Overview and Motivation

All of R’s (r*, p*, q*, d*) distribution functions are available in C++ via the R API. R is written in C, and the R API has no concept of a vector (at least not in the STL sense). Consequently, R’s sample() function can’t just be exported via the R API, despite its importance and usefulness. The purpose of RcppArmadilloExtensions/sample.h (written by Christian Gunning) is to provide this functionaility within C++ programs.

Given sampling’s central role in statistical programming, it is surprising that no standard library implementation for C or C++ is commonly available. There have been repeated questions about this on the Rcpp mailing list. StackExchange contains an extensive discussion of this question, but there is no “canonical” implementation.

In general, it’s best to use R’s tried-and-true RNG-related functions leaving the praise (and blame) for their performance to others. R’s C routines for sampling can be found in src/main/random.c, with a discussion of the associated algorithms in Ripley 87.

Goal

The goal is to exactly reproduce the behavior of R’s sample() function in a templated C++/Rcpp function. So far, we’ve reproduced everything but R’s implementation of the Walker Alias method (used only when sampling with replacement using >200 non-zero weights). It uses convenience functions from Armadillo, and thus is added to RcppArmadillo as an extension. (The hope is that future extensions will follow!) All you need is this simple call, which should work for any Rcpp Vector: RcppArmadillo::sample(x, size, replace, prob).

Dependencies

Make sure you have a recent version of RcppArmadillo. The earliest adequate release is 3.800.1 or preferably release 0.3.810.0. The usual install.packages("RcppArmadillo") command will help if you need to update. You are ready to go from there:

require(RcppArmadillo)

Loading required package: RcppArmadillo

Loading required package: Rcpp

Quick Example

Here’s a quick test to make sure it works.

Some C++ code that can be hooked into with sourceCpp():

// [[Rcpp::depends(RcppArmadillo)]]

#include <RcppArmadilloExtensions/sample.h>

using namespace Rcpp ;

// [[Rcpp::export]]
CharacterVector csample_char( CharacterVector x, 
                              int size,
                              bool replace, 
                              NumericVector prob = NumericVector::create()
                              ) {
  RNGScope scope ;
  CharacterVector ret = RcppArmadillo::sample(x, size, replace, prob) ;
  return ret ;
}

Notice that we only need #include <RcppArmadilloExtensions/sample.h> because sample.h then #include-s RcppArmadillo.

We invoke the (automatically defined) csample_char() R function:

N <- 10
set.seed(7)

sample.r <- sample(letters, N, replace=T)

set.seed(7)
sample.c <- csample_char(letters, N, replace=T)

print(identical(sample.r, sample.c))

[1] TRUE

Of course, R’s sample() function is “internally” vectorized and already fast. This functionality was not added to speed up sample()! Instead, this lets you stay in C++ when you need to sample from an Rcpp Vector, be it Numeric, Character, or whatever else.

Performance

That said, performance is still a concern. A quick test shows a dead-heat for sampling with replacement when compared to vanilla R:

#include <RcppArmadilloExtensions/sample.h>
// [[Rcpp::depends(RcppArmadillo)]]

using namespace Rcpp ;

// [[Rcpp::export]]
NumericVector csample_num( NumericVector x,
                           int size,
                           bool replace,
                           NumericVector prob = NumericVector::create()
                           ) {
  RNGScope scope;
  NumericVector ret = RcppArmadillo::sample(x, size, replace, prob);
  return ret;
}

Consider the following timing where we compare vanilla R’s sample() to RcppArmadillo::sample(). See the results for sampling with replacement with and without probability weights.

require(rbenchmark)

Loading required package: rbenchmark

set.seed(7)

## Definition of Sampling Frame
n.elem <- 1e2
frame1 <- rnorm(n.elem)
probs1 <- runif(n.elem)

## Definition of sampling regime
## Use replacement throughout
.replace <- TRUE
## Samplesize
n.samples1 <- 1e4

## Without probabilities
benchmark(r = sample(frame1, n.samples1, replace=.replace),        
          cpp = csample_num(frame1, n.samples1, replace=.replace),
          replications = 1e3,
          order = 'relative',
          columns = c("test", "replications", "relative", "elapsed")
          )

  test replications relative elapsed
2  cpp         1000    1.000   0.186
1    r         1000    1.188   0.221

## With probabilities
benchmark(r.prob = sample(frame1, n.samples1, prob = probs1, replace = .replace),
          cpp.prob = csample_num(frame1, n.samples1, prob = probs1, replace = .replace),
          replications = 1e3,
          order = 'relative',
          columns = c("test", "replications", "relative", "elapsed")
          )

      test replications relative elapsed
1   r.prob         1000    1.000   0.759
2 cpp.prob         1000    1.009   0.766

The two perform equally well.

Next we look at the performance of sampling without replacement. The number of draws can be no larger than the number of elements. Thus we’re sampling fewer elements. Otherwise, the code is identical.

## Use the same sampling frame as before
## Definition of sampling regime
## No replacement
.replace <- FALSE
## Since sample size can't exceed number elements, set them equal
n.samples2 <- n.elem

## Without probabilities
benchmark(r = sample(frame1, n.samples2, replace=.replace),        
          cpp = csample_num(frame1, n.samples2, replace=.replace),
          replications = 1e3,
          order = 'relative',
          columns = c("test", "replications", "relative", "elapsed")
          )

  test replications relative elapsed
2  cpp         1000    1.000   0.011
1    r         1000    1.364   0.015

## With probabilities
benchmark(r.prob = sample(frame1, n.samples2, prob = probs1, replace = .replace),
          cpp.prob = csample_num(frame1, n.samples2, prob = probs1, replace = .replace),
          replications = 1e3,
          order = 'relative',
          columns = c("test", "replications", "relative", "elapsed")
          )

      test replications relative elapsed
1   r.prob         1000        1   0.029
2 cpp.prob         1000        1   0.029

Finally, what we haven’t done. For sampling with replacement and more than 200 non-zero weights, R uses Walker’s Alias method. This method can be substantially faster than the vanilla sampling method (with replacement, less than 200 non-zero weights). Rather than risk leading users astray with inefficient and inappropriate methods, we throw an error.

## Definition of Sampling Frame
n.elem <- 1e3
frame2 <- rnorm(n.elem)
probs2 <- runif(n.elem)

## Definition of sampling regime
## Use replacement throughout
.replace <- TRUE
## Samplesize
n.samples1 <- 1e4

## With probabilities
r.prob <- sample(frame2, n.samples1, prob = probs2, replace = .replace)

Warning: Walker's alias method used: results are different from R < 2.2.0

cpp.prob <- csample_num(frame2, n.samples1, prob = probs2, replace = .replace)

Error: Walker Alias method not implemented. R-core sample() is likely
faster for this problem.

Dynamic Wrapping and Recursion with Rcpp

Mon, 08 Apr 2013 00:00:00 -0700

We can leverage small parts of the R’s C API in order to infer the type of objects directly at the run-time of a function call, and use this information to dynamically wrap objects as needed. We’ll also present an example of recursing through a list.

To get a basic familiarity with the main functions exported from R API, I recommend reading Hadley’s guide to R’s C internals guide here first, as we will be using some of these functions for navigating native R SEXPs. (Reading it will also give you an appreciation for just how much work Rcpp does in insulating us from the ugliness of the R API.)

From the R API, we’ll be using the TYPEOF macro, as well as referencing the internal R types:

REALSXP for numeric vectors,
INTSXP for integer vectors,
VECSXP for lists

We’ll start with a simple example: an Rcpp function that takes a list, loops through it, and:

if we encounter a numeric vector, double each element in it;
if we encounter an integer vector, add 1 to each element in it

#include <Rcpp.h>
using namespace Rcpp;
 
// [[Rcpp::export]]
List do_stuff( List x_ ) {
    List x = clone(x_);
    for( List::iterator it = x.begin(); it != x.end(); ++it ) {
        switch( TYPEOF(*it) ) {
            case REALSXP: {
                NumericVector tmp = as<NumericVector>(*it);
          	tmp = tmp * 2;
		break;    
            }
      	    case INTSXP: {
                if( Rf_isFactor(*it) ) break; // factors have internal type INTSXP too
        	IntegerVector tmp = as<IntegerVector>(*it);
		tmp = tmp + 1;
                break;
      	    }
      	    default: {
                stop("incompatible SEXP encountered; only accepts lists with REALSXPs and INTSXPs");
      	    }
       }
  }  
  return x;
}

A quick test:

dat <- list( 
    1:5, ## integer
    as.numeric(1:5) ## numeric
)
tmp <- do_stuff(dat)
print(tmp)

[[1]]
[1] 2 3 4 5 6

[[2]]
[1]  2  4  6  8 10

Some notes on the above:

We clone the list passed through to ensure we work with a copy, rather than the original list passed in,
We switch over the internal R type using TYPEOF, and do something for the case of numeric vectors (REALSXP), and integer vectors (INTSXP),
After we’ve figured out what kind of object we have, we can use Rcpp::as to wrap the R object with the appropriate container,
Because Rcpp’s wrappers point to the internal R structures, any changes made to them are reflected in the R object wrapped,
We use Rcpp sugar to easily add and multiply each element in a vector,
We throw an error if a non-numeric / non-integer object is encountered. One could leave the default: switch just to do nothing or fall through, or handle other SEXPs as needed as well.

We also check that we fail gracefully when we encounter a non-accepted SEXP:

do_stuff( list(new.env()) )

Error: incompatible SEXP encountered; only accepts lists with REALSXPs and
INTSXPs

However, this only operates on top-level objects within the list. What if your list contains other lists, and you want to recurse through those lists as well?

It’s actually quite simple: if the internal R type of the object encountered is a VECSXP, then we just call our recursive function on that element itself!

#include <Rcpp.h>
using namespace Rcpp;
 
// [[Rcpp::export]]
List recurse(List x_) {
    List x = clone(x_);
    for( List::iterator it = x.begin(); it != x.end(); ++it ) {
        switch( TYPEOF(*it) ) {
            case VECSXP: {
                *it = recurse(*it);
        	break;
            }
            case REALSXP: {
                NumericVector tmp = as<NumericVector>(*it);
        	tmp = tmp * 2;
            	break;
      	    }
      	    case INTSXP: {
            	if( Rf_isFactor(*it) ) break; // factors have internal type INTSXP too
        	IntegerVector tmp = as<IntegerVector>(*it);
        	tmp = tmp + 1;
        	break;
      	    }
      	    default: {
                stop("incompatible SEXP encountered; only accepts lists containing lists, REALSXPs, and INTSXPs");
      	    }
        }
    }
    return x;
}

A test case:

dat <- list( 
    x=1:5, ## integer
    y=as.numeric(1:5), ## numeric
    z=list( ## another list to recurse into
        zx=10L, ## integer
        zy=20 ## numeric
    )
)
out <- recurse(dat)
print(out)

$x
[1] 2 3 4 5 6

$y
[1]  2  4  6  8 10

$z
$z$zx
[1] 11

$z$zy
[1] 40

Note that all we had to do was add a VECSXP case in our switch statement. If we see a list, we call the same recurse function on that list, and then re-assign the result of that recursive call. Neat!

Hence, by using TYPEOF to query the internal R type of objects pre-wrap, we can wrap objects as needed into an appropriate container, and then use Rcpp / C++ code as necessary to modify them.

Using bigmemory with Rcpp

Thu, 14 Mar 2013 00:00:00 -0700

The bigmemory package allows users to create matrices that are stored on disk, rather than in RAM. When an element is needed, it is read from the disk and cached in RAM. These objects can be much larger than native R matrices. Objects stored as such larger-than-RAM matrices are defined in the big.matrix class and they are designed to behave similar to R matrices. However, they are actually implemented in C++ and can be easily accessed and manipulated directly from Rcpp as this example shows.

#include <Rcpp.h>

// The next line is all it takes to find the bigmemory
// headers -- thanks to the magic of Rcpp attributes

// [[Rcpp::depends(bigmemory)]]
#include <bigmemory/MatrixAccessor.hpp>
#include <numeric>

// [[Rcpp::export]]
Rcpp::NumericVector BigColSums(Rcpp::XPtr<BigMatrix> pBigMat) {

    // Create the matrix accessor so we can get at the elements of the matrix.
    MatrixAccessor<double> ma(*pBigMat);
  
    // Create the vector we'll store the column sums in.
    Rcpp::NumericVector colSums(pBigMat->ncol());
    for (size_t i=0; i < pBigMat->ncol(); ++i)
        colSums[i] = std::accumulate(ma[i], ma[i]+pBigMat->nrow(), 0.0);
    return colSums;
}

A BigMatrix object stores elements in a column major format, meaning that values are accessed and filled in by column, rather than by row. The MatrixAccessor implements the bracket operator, returning a pointer to the first element of a column. As a result, for a MatrixAccessor ma, the i-th row and j-th column is accessed with ma[j][i] rather than m[i, j], which R users are more familiar with.

The code above defines a function BigColSums that takes as an argument the address of the external pointer associated with a big.matrix object. The function starts by creating a MatrixAccessor to provide direct access to the matrix elements. The MatrixAccessor constructor takes the type of elements as a template parameter and a BigMatrix object as function parameter. Along with the MatrixAccessor, a NumericVector is created to hold the return value. Next, the function loops through the columns. For each iteration of the loop the values in a single column are accumulated and stored at the appropriate location in the colSum vector. Finally, the columns sums are returned to R.

The code below shows how to use the new Rcpp function. A big.matrix object is created, named bigmat, with 10000 rows and 3 columns. Matrix elements are stored on disk in a “backingfile” named bigmat.bk. After creating the big.matrix object, the column values are filled in and then the big.matrix’s external pointer, which is references with the address slot, is passed to the Rcpp BigColSums function. The corresponding R function is shown below so that you can verify that our new function returns the correct value.

suppressMessages(require(bigmemory))

# set up big.matrix
nrows <- 10000
setwd("/tmp")
bkFile <- "bigmat.bk"
descFile <- "bigmatk.desc"
bigmat <- filebacked.big.matrix(nrow=nrows, ncol=3, type="double",  
       	  			backingfile=bkFile, backingpath=".", 
				descriptorfile=descFile,
				dimnames=c(NULL,NULL))
  
# Each column value with be the column number multiplied by 
# samples from a standard normal distribution.
set.seed(123)
for (i in 1:3) bigmat[,i] = rnorm(nrows)*i

# Call the Rcpp function.
res <- BigColSums(bigmat@address) 
print(res)

[1]  -23.72 -182.13 -212.98

  
# Verify that it is that same as running colSums on a matrix with equal values.
print(all.equal(res, colSums(bigmat[,])))

[1] TRUE

Generating a multivariate gaussian distribution using RcppArmadillo

Tue, 12 Mar 2013 00:00:00 -0700

There are many ways to simulate a multivariate gaussian distribution assuming that you can simulate from independent univariate normal distributions. One of the most popular method is based on the Cholesky decomposition. Let’s see how Rcpp and Armadillo perform on this task.

#include <RcppArmadillo.h>
// [[Rcpp::depends(RcppArmadillo)]]

using namespace Rcpp;

// [[Rcpp::export]]
arma::mat mvrnormArma(int n, arma::vec mu, arma::mat sigma) {
   int ncols = sigma.n_cols;
   arma::mat Y = arma::randn(n, ncols);
   return arma::repmat(mu, 1, n).t() + Y * arma::chol(sigma);
}

The easiest way to perform a Cholesky distribution in R is to use the chol function in R which interface some fast LAPACK routines.

### naive implementation in R
mvrnormR <- function(n, mu, sigma) {
    ncols <- ncol(sigma)
    mu <- rep(mu, each = n) ## not obliged to use a matrix (recycling)
    mu + matrix(rnorm(n * ncols), ncol = ncols) %*% chol(sigma)
}

We will also use MASS:mvrnorm which implements it differently:

require(MASS)

Loading required package: MASS

### Covariance matrix and mean vector
sigma <- matrix(c(1, 0.9, -0.3, 0.9, 1, -0.4, -0.3, -0.4, 1), ncol = 3)
mu <- c(10, 5, -3)

require(MASS)
### checking variance
set.seed(123)
cor(mvrnormR(100, mu,  sigma))

        [,1]    [,2]    [,3]
[1,]  1.0000  0.8851 -0.3830
[2,]  0.8851  1.0000 -0.4675
[3,] -0.3830 -0.4675  1.0000

cor(MASS::mvrnorm(100, mu, sigma))

        [,1]    [,2]    [,3]
[1,]  1.0000  0.9106 -0.3016
[2,]  0.9106  1.0000 -0.4599
[3,] -0.3016 -0.4599  1.0000

cor(mvrnormArma(100, mu, sigma))

       [,1]    [,2]    [,3]
[1,]  1.000  0.9020 -0.3530
[2,]  0.902  1.0000 -0.4889
[3,] -0.353 -0.4889  1.0000

## checking means
colMeans(mvrnormR(100, mu, sigma))

[1]  9.850  4.911 -2.902

colMeans(MASS::mvrnorm(100, mu, sigma))

[1] 10.051  5.046 -2.914

colMeans(mvrnormArma(100, mu, sigma))

[1]  9.825  4.854 -2.873

Now, let’s benchmark the different versions:

require(rbenchmark)

Loading required package: rbenchmark

benchmark(mvrnormR(1e4, mu, sigma),
          MASS::mvrnorm(1e4, mu, sigma),
          mvrnormArma(1e4, mu, sigma),
          columns = c('test', 'replications', 'relative', 'elapsed'),
          order = 'elapsed')

                             test replications relative elapsed
3   mvrnormArma(10000, mu, sigma)          100    1.000   0.219
1      mvrnormR(10000, mu, sigma)          100    1.913   0.419
2 MASS::mvrnorm(10000, mu, sigma)          100    2.046   0.448

The RcppArmadillo function outperforms the MASS implementation and the naive R code, but more surprisinugly mvrnormR is slightly faster than mvrnorm in this benchmark.

To be fair, while digging into the MASS::mvrnorm code it appears that there are few code sanity checks ( such as the positive definiteness of Sigma ).

Using Rcpp with Boost.Regex for regular expression

Fri, 01 Mar 2013 00:00:00 -0800

Gabor asked about Rcpp use with regular expression libraries. This post shows a very simple example, based on
one of the Boost.RegEx examples.

We need to set linker options. This can be as simple as

Sys.setenv("PKG_LIBS"="-lboost_regex")

With that, the following example can be built:

// cf www.boost.org/doc/libs/1_53_0/libs/regex/example/snippets/credit_card_example.cpp

#include <Rcpp.h>

#include <string>
#include <boost/regex.hpp>

bool validate_card_format(const std::string& s) {
   static const boost::regex e("(\\d{4}[- ]){3}\\d{4}");
   return boost::regex_match(s, e);
}

const boost::regex e("\\A(\\d{3,4})[- ]?(\\d{4})[- ]?(\\d{4})[- ]?(\\d{4})\\z");
const std::string machine_format("\\1\\2\\3\\4");
const std::string human_format("\\1-\\2-\\3-\\4");

std::string machine_readable_card_number(const std::string& s) {
   return boost::regex_replace(s, e, machine_format, boost::match_default | boost::format_sed);
}

std::string human_readable_card_number(const std::string& s) {
   return boost::regex_replace(s, e, human_format, boost::match_default | boost::format_sed);
}

// [[Rcpp::export]]
Rcpp::DataFrame regexDemo(std::vector<std::string> s) {
    int n = s.size();
    
    std::vector<bool> valid(n);
    std::vector<std::string> machine(n);
    std::vector<std::string> human(n);
    
    for (int i=0; i<n; i++) {
        valid[i]  = validate_card_format(s[i]);
        machine[i] = machine_readable_card_number(s[i]);
        human[i] = human_readable_card_number(s[i]);
    }
    return Rcpp::DataFrame::create(Rcpp::Named("input") = s,
                                   Rcpp::Named("valid") = valid,
                                   Rcpp::Named("machine") = machine,
                                   Rcpp::Named("human") = human);
}

We can test the function using the same input as the Boost example:

s <- c("0000111122223333", "0000 1111 2222 3333", "0000-1111-2222-3333", "000-1111-2222-3333")
regexDemo(s)

                input valid          machine               human
1    0000111122223333 FALSE 0000111122223333 0000-1111-2222-3333
2 0000 1111 2222 3333  TRUE 0000111122223333 0000-1111-2222-3333
3 0000-1111-2222-3333  TRUE 0000111122223333 0000-1111-2222-3333
4  000-1111-2222-3333 FALSE  000111122223333  000-1111-2222-3333

Fast factor generation with Rcpp

Wed, 27 Feb 2013 00:00:00 -0800

Recall that factors are really just integer vectors with ‘levels’, i.e., character labels that get mapped to each integer in the vector. How can we take an arbitrary character, integer, numeric, or logical vector and coerce it to a factor with Rcpp? It’s actually quite easy with Rcpp sugar:

#include <Rcpp.h>
using namespace Rcpp;

template <int RTYPE>
IntegerVector fast_factor_template( const Vector<RTYPE>& x ) {
  Vector<RTYPE> levs = sort_unique(x);
  IntegerVector out = match(x, levs);
  out.attr("levels") = as<CharacterVector>(levs);
  out.attr("class") = "factor";
  return out;
}

// [[Rcpp::export]]
SEXP fast_factor( SEXP x ) {
  switch( TYPEOF(x) ) {
    case INTSXP: return fast_factor_template<INTSXP>(x);
    case REALSXP: return fast_factor_template<REALSXP>(x);
    case STRSXP: return fast_factor_template<STRSXP>(x);
  }
  return R_NilValue;
}

Note a few things:

We template over the RTYPE; i.e., the internal type that R assigns to its objects. For this example, we just need to know that the R types (as exposed in an R session) map to internal C types as integer -> INTSXP, numeric -> REALSXP, and character -> STRSXP.
We return an IntegerVector. Remember that factors are just integer vectors with a levels attribute and class factor.
To generate our factor, we simply need to calculate the sorted unique values (the levels), and then match our vector back to those levels.
Next, we can just set the attributes on the object so that R will interpret it as a factor, rather than a plain old integer vector, when it’s returned.

And a quick test:

library(microbenchmark)
all.equal( factor( 1:10 ), fast_factor( 1:10 ) )

[1] TRUE

all.equal( factor( letters ), fast_factor( letters ) )

[1] TRUE

lets <- sample( letters, 1E5, replace=TRUE )
microbenchmark( factor(lets), fast_factor(lets) )

Unit: milliseconds
               expr   min    lq median    uq   max
1      factor(lets) 5.315 5.766  5.930 6.069 32.93
2 fast_factor(lets) 1.420 1.458  1.474 1.486 28.85

(However, note that this doesn’t handle NAs – fixing that is left as an exercise. Similarily for logical vectors – it’s not quite as simple as just adding a call to a LGLSXP templated call, but it’s still not tough – use INTSXP and set set the levels to FALSE and TRUE.)

We can demonstrate a simple example of where this might be useful with tapply. tapply(x, group, FUN) is really just a wrapper to lapply( split(x, group), FUN ), and split relies on coercing ‘group’ to a factor. Otherwise, split calls .Internal( split(x, group) ), and trying to do better than an internal C function is typically a bit futile. So, now that we’ve written this, we can test a couple ways of performing a tapply-like function:

x <- rnorm(1E5)
gp <- sample( 1:1000, 1E5, TRUE )
all( tapply(x, gp, mean) == unlist( lapply( split(x, fast_factor(gp)), mean ) ) )

[1] TRUE

all( tapply(x, gp, mean) == unlist( lapply( split(x, gp), mean ) ) )

[1] TRUE

rbenchmark::benchmark( replications=20, order="relative",
                tapply(x, gp, mean), 
                unlist( lapply( split(x, fast_factor(gp)), mean) ),
                unlist( lapply( split(x, gp), mean ) )
                )[,1:4]

                                             test replications elapsed
2 unlist(lapply(split(x, fast_factor(gp)), mean))           20   0.200
3              unlist(lapply(split(x, gp), mean))           20   0.731
1                             tapply(x, gp, mean)           20   1.444
  relative
2    1.000
3    3.655
1    7.220

To be fair, tapply actually returns a 1-dimensional array rather than a vector, and also can operate on more general arrays. However, we still do see a modest speedup both for using lapply, and for taking advantage of our fast factor generator.

Using Boost via the new BH package

Thu, 31 Jan 2013 00:00:00 -0800

Earlier today the new BH package arrived on CRAN. Over the years, Jay Emerson, Michael Kane and I had numerous discussions about a basic Boost infrastructure package providing Boost headers for other CRAN packages. JJ and Romain chipped in as well, and Jay finally took the lead by first creating a repo on R-Forge. And now the package is out, so what follows is a little demo.

This example borrows something already implemented in my RcppBDT package which wraps code from Boost Date_Time for R.
Here, we compute the so-called IMM Date – generally the the third Wednesday of the month (in the last month of the quarter). Boost has a function computing the Nth day of the Mth week for a given month in a given year: we use that here with Wednesday and the third week.

The kicker is that Boost uses templates almost exclusively. So by declaring an depends attribute on BH, we ensure that the compilation will see the headers files provided by BH. Which happen to be the Boost headers, as that is what the package does. And that is all it takes.

// Use brandnew CRAN package BH for Boost headers

// [[Rcpp::depends(BH)]]
#include <Rcpp.h>

// One include file from Boost
#include <boost/date_time/gregorian/gregorian_types.hpp>

using namespace boost::gregorian;

// [[Rcpp::export]]
Rcpp::Date getIMMDate(int mon, int year) {
    // compute third Wednesday of given month / year
    date d = nth_day_of_the_week_in_month(nth_day_of_the_week_in_month::third,
                                          Wednesday, mon).get_date(year);
    date::ymd_type ymd = d.year_month_day();
    return Rcpp::wrap(Rcpp::Date(ymd.year, ymd.month, ymd.day));
}

We can test this from R for 2013 by computing the first two:

getIMMDate(3, 2013)

[1] "2013-03-20"

getIMMDate(6, 2013)

[1] "2013-06-19"

And for kicks, the same for 2033:

getIMMDate(3, 2033)

[1] "2033-03-16"

getIMMDate(6, 2033)

[1] "2033-06-15"

The BH package is still pretty raw. For example, yesterday’s Rcpp Gallery post on Boost foreach] does not build as we have not yet included the relevant Boost library. So far, BH reflects the needs of Jay and Mike in their (awesome) bigmemory project and my needs in RcppBDT, and then some. For the rest, let us know what may be missing.

Sorting Numeric Vectors in C++ and R

Thu, 31 Jan 2013 00:00:00 -0800

Consider the problem to sort all elements of the given vector in ascending order. We can simply use the function std::sort from the C++ STL.

#include <Rcpp.h>
using namespace Rcpp;

// [[Rcpp::export]]
NumericVector stl_sort(NumericVector x) {
   NumericVector y = clone(x);
   std::sort(y.begin(), y.end());
   return y;
}

library(rbenchmark)
set.seed(123)
z <- rnorm(100000)
x <- rnorm(100)

# check that stl_sort is the same as sort
stopifnot(all.equal(stl_sort(x), sort(x)))

# benchmark stl_sort and sort
benchmark(stl_sort(z), sort(z), order="relative")[,1:4]

         test replications elapsed relative
1 stl_sort(z)          100   0.632    1.000
2     sort(z)          100   1.164    1.842

Consider the problem of sorting the first n elements of a given vector. The function std::partial_sort from the C++ STL does just this.

// [[Rcpp::export]]
NumericVector stl_partial_sort(NumericVector x, int n) {
   NumericVector y = clone(x);
   std::partial_sort(y.begin(), y.begin()+n, y.end());
   return y;
}

An alternate implementation of a partial sort algorithm is to use std::nth_element to partition the given vector at the nth sorted element and then use std::sort, both from the STL, to sort the vector from the beginning to the nth element.

For an equivalent implementation in R, we can use the sort function by specifying a vector of 1:n for the partial argument (i.e. partial=1:n).

// [[Rcpp::export]]
NumericVector nth_partial_sort(NumericVector x, int nth) {
   NumericVector y = clone(x);
   std::nth_element(y.begin(), y.begin()+nth, y.end());
   std::sort(y.begin(), y.begin()+nth);
   return y;
}

n <- 25000

# check that stl_partial_sort is equal to nth_partial_sort
stopifnot(all.equal(stl_partial_sort(x, 50)[1:50], 
                    nth_partial_sort(x, 50)[1:50]))

# benchmark stl_partial_sort, nth_element_sort, and sort
benchmark(stl_partial_sort(z, n),
          nth_partial_sort(z, n),
          sort(z, partial=1:n),
          order="relative")[,1:4]

                    test replications elapsed relative
2 nth_partial_sort(z, n)          100   0.208    1.000
1 stl_partial_sort(z, n)          100   0.516    2.481
3 sort(z, partial = 1:n)          100   0.796    3.827

An interesting result to note is the gain in speed of nth_partial_sort over stl_partial_sort. In this case, for the given data, it is faster to use the combination ofstd::nth_element and std::sort rather than std::partial_sort to sort the first n elements of a vector.

// [[Rcpp::export]]
NumericVector stl_nth_element(NumericVector x, int n) {
   NumericVector y = clone(x);
   std::nth_element(y.begin(), y.begin()+n, y.end());
   return y;
}

Finally, consider a problem where you only need a single element of a sorted vector. The function std::nth_element from the C++ STL does just this. An example of this type of problem is computing the median of a given vector.

For an equivalent implementation in R, we can use the sort function by specifying a scalar value for the argument partial (i.e. partial=n).

# check that the nth sorted elements of the vectors are equal
stopifnot(all.equal(stl_nth_element(x, 43)[43], sort(x, partial=43)[43]))

# benchmark nth_element and sort
benchmark(stl_nth_element(z, n),
         sort(z, partial=n),
         order="relative")[,1:4]

                   test replications elapsed relative
1 stl_nth_element(z, n)          100   0.089    1.000
2  sort(z, partial = n)          100   0.238    2.674

While these are not huge speed improvements over the base R sort function, this post demonstrates how to easily access sorting functions in the C++ STL and is a good exercise to better understand the differences and performance of the sorting algorithms available in C++ and R.

Using Boost's foreach macro

Wed, 30 Jan 2013 00:00:00 -0800

Boost provides a macro, BOOST_FOREACH, that allows us to easily iterate over elements in a container, similar to what we might do in R with sapply. In particular, it frees us from having to deal with iterators as we do with std::for_each and std::transform. The macro is also compatible with the objects exposed by Rcpp.

Side note: C++11 has introduced a similar for-each looping construct of the form

for (T &elem : X) { /*do stuff*/ }

However, CRAN does not (at the time of this posting) allow C++11 in uploads and hence this Boost solution might be preferred if you want to use a for-each construct in a package.

The BOOST_FOREACH macro is exposed when we use #include <boost/foreach.hpp>. Make sure the Boost libraries are in your includepath so that they can be found and included easily. Because it’s a header-only library we don’t have to worry about external dependencies or linking.

We’ll use a simple example where we square each element in a vector.

#include <Rcpp.h>
#include <boost/foreach.hpp>
using namespace Rcpp;
 
// the C-style upper-case macro name is a bit ugly; let's change it
// note: this could cause compiler errors if it conflicts with other includes
#define foreach BOOST_FOREACH
 
// [[Rcpp::export]]
NumericVector square( NumericVector x ) {
  
  // elem is a reference to each element in x
  // we can re-assign to these elements as well
  foreach( double& elem, x ) {
    elem = elem*elem;
  }
  
  return x;
}

square( 1:10 )

 [1]   1   4   9  16  25  36  49  64  81 100

square( matrix(1:16, nrow=4) )

     [,1] [,2] [,3] [,4]
[1,]    1   25   81  169
[2,]    4   36  100  196
[3,]    9   49  121  225
[4,]   16   64  144  256

## we check that the function handles various 'special' values
x <- c(1, 2, NA, 4, NaN, Inf, -Inf)
square(x)

[1]   1   4  NA  16 NaN Inf Inf

And a quick benchmark:

x <- rnorm(1E5)
library(microbenchmark)
microbenchmark(
  square(x),
  x^2
  )

Unit: microseconds
       expr    min     lq median     uq  max
1 square(x)  71.04  71.64  71.89  74.14 1518
2       x^2 346.36 350.70 359.18 433.33 1842

all.equal( square(x), x^2 )

[1] TRUE

If you are defining your own classes / containers and want them to be compatible with one of these for-each constructs, you will need to define some methods for iteration across these objects. See this post on SO for more details.

For more information on BOOST_FOREACH, check the documentation here.

Quick conversion of a list of lists into a data frame

Tue, 22 Jan 2013 00:00:00 -0800

Data frames are one of R’s distinguishing features. Exposing a list of lists as an array of cases, they make many formal operations such as regression or optimization easy to represent.

The R data.frame operation for lists is quite slow, in large part because it exposes a vast amount of functionality. This sample shows one way to write a much faster data.frame creator in C++ if one is willing to forego that generality.

#include <Rcpp.h>

using namespace Rcpp;

// [[Rcpp::export]]
List CheapDataFrameBuilder(List a) {
    List returned_frame = clone(a);
    GenericVector sample_row = returned_frame(0);

    StringVector row_names(sample_row.length());
    for (int i = 0; i < sample_row.length(); ++i) {
        char name[5];
        sprintf(&(name[0]), "%d", i);
        row_names(i) = name;
    }
    returned_frame.attr("row.names") = row_names;

    StringVector col_names(returned_frame.length());
    for (int j = 0; j < returned_frame.length(); ++j) {
        char name[6];
        sprintf(&(name[0]), "X.%d", j);
        col_names(j) = name;
    }
    returned_frame.attr("names") = col_names;
    returned_frame.attr("class") = "data.frame";

    return returned_frame;
}

Here is the result of comparing the native function to this version.

library(rbenchmark)
a <- replicate(250, 1:100, simplify=FALSE)

res <- benchmark(as.data.frame(a), 
                 CheapDataFrameBuilder(a), 
                 order="relative", replications=500)
res[,1:4]

                      test replications elapsed relative
2 CheapDataFrameBuilder(a)          500   0.104      1.0
1         as.data.frame(a)          500  16.730    160.9

There are some subtleties in this code:

— It turns out that one can’t send super-large data frames to it because of possible buffer overflows. I’ve never seen that problem when I’ve written Rcpp functions which exchanged SEXPs with R, but this one uses Rcpp:export in order to use sourceCpp.

— Notice the invocation of clone() in the first line of the code. If you don’t do that, you wind up side-effecting the parameter, which is not what most people would expect.

Passing user-supplied C++ functions

Mon, 21 Jan 2013 00:00:00 -0800

Baptiste asked on StackOverflow about letting users supply C++ functions for use with Armadillo / RcppArmadillo. This posts helps with an extended answer. There is nothing specific about Armadillo here, this would the same way with Eigen, the GSL or any other library a user wants to support (and provides his or her own as<>() and wrap() converters which we already have for Armadillo, Eigen and the GSL).

To set the stage, let us consider two simple functions of a vector

// [[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);
}

These are pretty boring and standard functions, and we could simple switch between them via if/else statements. Where it gets interesting is via the SEXP wrapping offered by XPtr below.

But before we get there, let us do this one step at a time.

This typdef is important and just says that funcPtr will take a const reference to a vec and return a vector – just like our two functions above

typedef vec (*funcPtr)(const vec& x);

The following function takes a string argument, picks a function and returns it wrapped as an external pointer SEXP. We could return this to R as well.

// [[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
}

A simple test of this function follows. First a function using it:

// [[Rcpp::export]]
vec callViaString(const vec x, std::string funname) {
    XPtr<funcPtr> xpfun = putFunPtrInXPtr(funname);
    funcPtr fun = *xpfun;
    vec y = fun(x);
    return (y);
}

And then a call, showing access to both functions:

callViaString(1:3, "fun1")

     [,1]
[1,]    2
[2,]    4
[3,]    6

callViaString(1:3, "fun2")

     [,1]
[1,]   10
[2,]   20
[3,]   30

But more interestingly, we can also receive a function pointer via the SEXP wrapping:

fun <- putFunPtrInXPtr("fun1")

And use it in this function which no longer switches:

// [[Rcpp::export]]
vec callViaXPtr(const vec x, SEXP xpsexp) {
    XPtr<funcPtr> xpfun(xpsexp);
    funcPtr fun = *xpfun;
    vec y = fun(x);
    return (y);
}

As seen here:

callViaXPtr(1:4, fun)

     [,1]
[1,]    2
[2,]    4
[3,]    6
[4,]    8

This is a reasonably powerful and generic framework offered by Rcpp and sitting on top of R’s external pointers.

Coercion of matrix to sparse matrix (dgCMatrix) and maintaining dimnames.

Sun, 20 Jan 2013 00:00:00 -0800

Consider the following matrix

nr <- nc <- 6
set.seed <- 123
m  <- matrix(sample(c(rep(0,9), 1),nr*nc, replace=T), nrow=nr, ncol=nc)
sum(m)/length(m)

[1] 0.1667

dimnames(m) <- list(letters[1:nr], letters[1:nc])
m

  a b c d e f
a 0 0 0 0 0 1
b 0 0 0 1 0 1
c 0 0 0 0 0 0
d 0 0 0 0 0 0
e 1 1 0 0 0 0
f 0 0 0 1 0 0

This matrix can be coerced to a sparse matrix with

library("Matrix")

Loading required package: methods

Loading required package: lattice

M1 <- as(m, "dgCMatrix")
M1

6 x 6 sparse Matrix of class "dgCMatrix"
  a b c d e f
a . . . . . 1
b . . . 1 . 1
c . . . . . .
d . . . . . .
e 1 1 . . . .
f . . . 1 . .

str(M1)

Formal class 'dgCMatrix' [package "Matrix"] with 6 slots
  ..@ i       : int [1:6] 4 4 1 5 0 1
  ..@ p       : int [1:7] 0 1 2 2 4 4 6
  ..@ Dim     : int [1:2] 6 6
  ..@ Dimnames:List of 2
  .. ..$ : chr [1:6] "a" "b" "c" "d" ...
  .. ..$ : chr [1:6] "a" "b" "c" "d" ...
  ..@ x       : num [1:6] 1 1 1 1 1 1
  ..@ factors : list()

Using Eigen via RcppEigen we can obtain the coercion as:

// [[Rcpp::depends(RcppEigen)]]

#include <RcppEigen.h>
#include <Rcpp.h>

using namespace Rcpp;
// [[Rcpp::export]]
SEXP asdgCMatrix_( SEXP XX_ ){
  typedef Eigen::SparseMatrix<double> SpMat;   
  typedef Eigen::Map<Eigen::MatrixXd> MapMatd; // Input: must be double
  MapMatd X(Rcpp::as<MapMatd>(XX_));
  SpMat Xsparse = X.sparseView();              // Output: sparse matrix
  S4 Xout(wrap(Xsparse));                      // Output: as S4 object
  NumericMatrix Xin(XX_);                      // Copy dimnames
  Xout.slot("Dimnames") = clone(List(Xin.attr("dimnames")));
  return(Xout);
}

(M2 <- asdgCMatrix_(m * 1.0))

6 x 6 sparse Matrix of class "dgCMatrix"
  a b c d e f
a . . . . . 1
b . . . 1 . 1
c . . . . . .
d . . . . . .
e 1 1 . . . .
f . . . 1 . .

str(M2)

Formal class 'dgCMatrix' [package "Matrix"] with 6 slots
  ..@ i       : int [1:6] 4 4 1 5 0 1
  ..@ p       : int [1:7] 0 1 2 2 4 4 6
  ..@ Dim     : int [1:2] 6 6
  ..@ Dimnames:List of 2
  .. ..$ : chr [1:6] "a" "b" "c" "d" ...
  .. ..$ : chr [1:6] "a" "b" "c" "d" ...
  ..@ x       : num [1:6] 1 1 1 1 1 1
  ..@ factors : list()

identical(M1, M2)

[1] TRUE

Compare the performance:

cols <- c("test", "replications", "elapsed", "relative", "user.self", "sys.self")	
rbenchmark::benchmark(asdgCMatrix_(m * 1.0), as(m, "dgCMatrix"),	
                      columns=cols, order="relative", replications=1000)

                 test replications elapsed relative user.self sys.self
1 asdgCMatrix_(m * 1)         1000   0.025     1.00     0.024    0.000
2  as(m, "dgCMatrix")         1000   0.246     9.84     0.240    0.004

For larger matrices the difference in performance gain is smaller:

## 100 x 100 matrix
nr <- nc <- 100
set.seed <- 123
m  <- matrix(sample(c(rep(0,9), 1),nr*nc, replace=T), nrow=nr, ncol=nc)
rbenchmark::benchmark(asdgCMatrix_(m * 1.0), as(m, "dgCMatrix"),	
                      columns=cols, order="relative", replications=1000)

                 test replications elapsed relative user.self sys.self
1 asdgCMatrix_(m * 1)         1000   0.137    1.000     0.136    0.000
2  as(m, "dgCMatrix")         1000   0.443    3.234     0.432    0.008

## 1000 x 1000 matrix
nr <- nc <- 1000
set.seed <- 123
m  <- matrix(sample(c(rep(0,9), 1),nr*nc, replace=T), nrow=nr, ncol=nc)
rbenchmark::benchmark(asdgCMatrix_(m * 1.0), as(m, "dgCMatrix"),	
                      columns=cols, order="relative", replications=100)

                 test replications elapsed relative user.self sys.self
1 asdgCMatrix_(m * 1)          100   1.193    1.000     1.180    0.008
2  as(m, "dgCMatrix")          100   2.201    1.845     2.064    0.128

## 3000 x 3000 matrix
nr <- nc <- 3000
set.seed <- 123
m  <- matrix(sample(c(rep(0,9), 1),nr*nc, replace=T), nrow=nr, ncol=nc)
rbenchmark::benchmark(asdgCMatrix_(m * 1.0), as(m, "dgCMatrix"),	
                      columns=cols, order="relative", replications=100)

                 test replications elapsed relative user.self sys.self
1 asdgCMatrix_(m * 1)          100   8.911    1.000     6.024    2.828
2  as(m, "dgCMatrix")          100  21.557    2.419    16.930    4.500

Thanks to Doug Bates for illustrating to me how set the dimnames attribute.

Robust Estimators of Location and Scale

Sun, 20 Jan 2013 00:00:00 -0800

First, the median_Rcpp function is defined to compute the median of the given input vector. It is assumed that the input vector is unsorted, so a copy of the input vector is made using clone and then std::nth_element is used to access the nth sorted element. Since we only care about accessing one sorted element of the vector for an odd length vector and two sorted elements for an even length vector, it is faster to use std::nth_element than either std::sort or std::partial_sort.

#include <Rcpp.h>
using namespace Rcpp;

// [[Rcpp::export]]
double median_rcpp(NumericVector x) {
   NumericVector y = clone(x);
   int n, half;
   double y1, y2;
   n = y.size();
   half = n / 2;
   if(n % 2 == 1) {
      // median for odd length vector
      std::nth_element(y.begin(), y.begin()+half, y.end());
      return y[half];
   } else {
      // median for even length vector
      std::nth_element(y.begin(), y.begin()+half, y.end());
      y1 = y[half];
      std::nth_element(y.begin(), y.begin()+half-1, y.begin()+half);
      y2 = y[half-1];
      return (y1 + y2) / 2.0;
   }
}

library(rbenchmark)
set.seed(123)
z <- rnorm(1000000)

median_rcpp(1:10)

[1] 5.5

median_rcpp(1:9)

[1] 5

# benchmark median_rcpp and median
benchmark(median_rcpp(z), median(z), order="relative")[,1:4]

            test replications elapsed relative
1 median_rcpp(z)          100   1.747    1.000
2      median(z)          100   5.991    3.429

Next, the mad_rcpp function is defined to compute the median absolute deviation. This is a simple one-liner thanks to the sugar function abs, the vectorized operators, and the median_rcpp function defined above. Note that a default value is specified for the scale_factor argument.

// [[Rcpp::export]]
double mad_rcpp(NumericVector x, double scale_factor = 1.4826) {
   // scale_factor = 1.4826; default for normal distribution consistent with R
   return median_rcpp(abs(x - median_rcpp(x))) * scale_factor;
}

# benchmark mad_rcpp and mad
benchmark(mad_rcpp(z), mad(z), order="relative")[,1:4]

         test replications elapsed relative
1 mad_rcpp(z)          100   3.678    1.000
2      mad(z)          100  13.443    3.655

Custom as and wrap converters example

Sun, 20 Jan 2013 00:00:00 -0800

The RcppBDT package interfaces Boost.Date_Time with R. Both systems have their own date representations—and this provides a nice example of custom as<>() and wrap() converters. Here, we show a simplified example.

We start with the forward declarations:

#include <RcppCommon.h>

#include <boost/date_time/gregorian/gregorian_types.hpp> 	// Gregorian calendar types, no I/O

namespace Rcpp {

    // 'date' class boost::gregorian::date
    //
    // non-intrusive extension via template specialisation
    template <> boost::gregorian::date as(SEXP dt);
    //
    // non-intrusive extension via template specialisation
    template <> SEXP wrap(const boost::gregorian::date &d);
}

Given these forward declarations, we can now define the converters.

For as(), we first instantiate a date object and use it to obtain the year, month and day fields to create a boost::gregorian date.

Similarly, for the inverse operation, we construct an Rcpp date from these components.

#include <Rcpp.h>

// define template specialisations for as and wrap
namespace Rcpp {
    template <> boost::gregorian::date as(SEXP dtsexp) {
        Rcpp::Date dt(dtsexp);
        return boost::gregorian::date(dt.getYear(), dt.getMonth(), dt.getDay());
    }

    template <> SEXP wrap(const boost::gregorian::date &d) {
        boost::gregorian::date::ymd_type ymd = d.year_month_day();     // convert to y/m/d struct
        return Rcpp::wrap( Rcpp::Date( ymd.year, ymd.month, ymd.day ));
    }
}

With these converters, we can now use a Boost Date_Time function. As a simple example, we use the compute the first given weekday after a date function.

// [[Rcpp::export]]
Rcpp::Date getFirstDayOfWeekAfter(int weekday, SEXP date) {
    boost::gregorian::first_day_of_the_week_after fdaf(weekday);
    boost::gregorian::date dt = Rcpp::as<boost::gregorian::date>(date);
    return Rcpp::wrap( fdaf.get_date(dt) );
}

We can use this to, say, find the first Monday after New Year in 2020:

getFirstDayOfWeekAfter(1, as.Date("2020-01-01"))

[1] "2020-01-06"

Using Rcpp to access the C API of xts

Sat, 19 Jan 2013 00:00:00 -0800

The xts package by Jeff Ryan and Josh Ulrich is an immensely powerful tool that is widely used for timeseries work with R. Recently, the question about how to use it from Rcpp came up on StackOverflow and in a thread on the rcpp-devel list.

In fact, xts has had an exposed API since 2008, but it wasn’t used and as I found out also not quite for two key functions. Jeff kindly gave me SVN access, and I updated init.c (to export) and a new xtsAPI.h header (access these).

This short post will show how to access this functionality using the new RcppXts package.

We start by repeating the (updated) createXts() function from the previous post on xts and Rcpp. This helper function (or an improved version of it) should probably go into RcppXts.

#include <Rcpp.h>

using namespace Rcpp;

// [[Rcpp::export]]
Rcpp::NumericVector createXts(int sv, int ev) {

    IntegerVector ind = seq(sv, ev);     // values

    NumericVector dv(ind);               // date(time)s are real values
    dv = dv * 86400;                     // scaled to days
    dv.attr("tzone")    = "UTC";         // the index has attributes
    dv.attr("tclass")   = "Date";

    NumericVector xv(ind);               // data her same index
    xv.attr("dim")         = IntegerVector::create(ev-sv+1,1);
    xv.attr("index")       = dv;
    CharacterVector klass  = CharacterVector::create("xts", "zoo");
    xv.attr("class")       = klass;
    xv.attr(".indexCLASS") = "Date";
    xv.attr("tclass")      = "Date";
    xv.attr(".indexTZ")    = "UTC";
    xv.attr("tzone")       = "UTC";
    
    return xv;

}

createXts(2,5)

           [,1]
1970-01-03    2
1970-01-04    3
1970-01-05    4
1970-01-06    5

Next, we show how to use this. Rcpp attributes will find the xts header file if use a depends() attribute, and as the functions we access are registered with the surrounding R process, no linking is needed.

#include <Rcpp.h>

// next two lines connect us to the xts API
#include <xtsAPI.h>
// [[Rcpp::depends(xts)]]

using namespace Rcpp;

// [[Rcpp::export]]
Rcpp::NumericVector rbindXts(NumericMatrix ma, NumericMatrix mb, bool dup=true) {
  NumericMatrix mc = xtsRbind(ma, mb, wrap(dup));
  return mc;
}

Thanks to this new (tree-line !!) function, we can combine xts object at the source level.

x1 <- createXts(2,5)
x2 <- createXts(4,9)
rbindXts(x1, x2)

           [,1]
1970-01-03    2
1970-01-04    3
1970-01-05    4
1970-01-06    5
1970-01-07    6
1970-01-08    7
1970-01-09    8
1970-01-10    9

rbindXts(x1, x2, FALSE)

           [,1]
1970-01-03    2
1970-01-04    3
1970-01-05    4
1970-01-05    4
1970-01-06    5
1970-01-06    5
1970-01-07    6
1970-01-08    7
1970-01-09    8
1970-01-10    9

Notice the difference between the results driven by the third argument about removal of duplicates which has a default value of TRUE.

While this example was obviously very simple, we can see the power and promise of this. It derives from being able to work on large numbers of xts objects directly at the C++ level without having to call back to R. So even though xts is about as efficient as it gets, we should be able to make nice gains (for simple enough tasks) by doing them at the C++ level.

Using the GSL to compute eigenvalues

Fri, 18 Jan 2013 00:00:00 -0800

Two posts showed how to compute eigenvalues using Armadillo and using Eigen. As we also looked at using the
GNU GSL, this post will show how to conpute eigenvalues using GSL.

As mentioned in the previous GSL post, we instantiate C language pointers suitable for GSL (here the matrix M). Those must be freed manually, as shown before the return statement.

// [[Rcpp::depends(RcppGSL)]]

#include <RcppGSL.h>
#include <gsl/gsl_matrix.h>
#include <gsl/gsl_eigen.h>

// [[Rcpp::export]]
Rcpp::NumericVector getEigenValues(Rcpp::NumericMatrix sM) {

    RcppGSL::matrix<double> M(sM); 	// create gsl data structures from SEXP
    int k = M.ncol();

    RcppGSL::vector<double> ev(k);  	// instead of gsl_vector_alloc(k);
    gsl_eigen_symm_workspace *w = gsl_eigen_symm_alloc(k);
    gsl_eigen_symm (M, ev, w);
    gsl_eigen_symm_free (w);

    // we need to invoke wrap() here to help the compiler, but at least we save a loop
    // we also need to create a new Rcpp object as the RcppGSL one needs to be free'd.
    Rcpp::NumericVector res(Rcpp::wrap(ev));

    M.free();               		// important: GSL wrappers use C structure
    ev.free();

    return res;				// return results vector  
}

We can illustrate this easily via a random sample matrix.

set.seed(42)
X <- matrix(rnorm(4*4), 4, 4)
Z <- X %*% t(X)

getEigenValues(Z)

[1] 14.2100  2.4099  1.6856  0.3319

In comparison, R gets the same results (in reverse order) and also returns the eigenvectors.

eigen(Z)

$values
[1] 14.2100  2.4099  1.6856  0.3319

$vectors
         [,1]     [,2]    [,3]     [,4]
[1,]  0.69988 -0.55799  0.4458 -0.00627
[2,] -0.06833 -0.08433  0.0157  0.99397
[3,]  0.44100 -0.15334 -0.8838  0.03127
[4,]  0.55769  0.81118  0.1413  0.10493

Creating xts objects from source

Thu, 17 Jan 2013 00:00:00 -0800

A recent post showed how to access the attributes of an xts object. We used an xts object as these are powerful and popular—but any R object using attributed could be used to illustrate the point.

In this short post, we show how one can also do the inverse in order to create an xts object at the C++ source level.

We use a somewhat useless object with values from 1:10 index by dates in the same range. As zero corresponds to the epoch, these will be early 1970-dates. But the values do not matter when showing the principle.

#include <Rcpp.h>

using namespace Rcpp;

// [[Rcpp::export]]
Rcpp::NumericVector createXts(int sv, int ev) {

    IntegerVector ind = seq(sv, ev);     // values

    NumericVector dv(ind);               // date(time)s are real values
    dv = dv * 86400;                     // scaled to days
    dv.attr("tzone")    = "UTC";         // the index has attributes
    dv.attr("tclass")   = "Date";

    NumericVector xv(ind);               // data her same index
    xv.attr("dim")         = IntegerVector::create(ev-sv+1,1);
    xv.attr("index")       = dv;
    CharacterVector klass  = CharacterVector::create("xts", "zoo");
    xv.attr("class")       = klass;
    xv.attr(".indexCLASS") = "Date";
    xv.attr("tclass")      = "Date";
    xv.attr(".indexTZ")    = "UTC";
    xv.attr("tzone")       = "UTC";
    
    return xv;

}

We can run this function, and look at the (numerous) attributes in the generated object:

suppressMessages(library(xts))
foo <- createXts(1, 10) 
foo

           [,1]
1970-01-02    1
1970-01-03    2
1970-01-04    3
1970-01-05    4
1970-01-06    5
1970-01-07    6
1970-01-08    7
1970-01-09    8
1970-01-10    9
1970-01-11   10

attributes(foo)

$dim
[1] 10  1

$index
 [1]  86400 172800 259200 345600 432000 518400 604800 691200 777600 864000
attr(,"tzone")
[1] "UTC"
attr(,"tclass")
[1] "Date"

$class
[1] "xts" "zoo"

$.indexCLASS
[1] "Date"

$tclass
[1] "Date"

$.indexTZ
[1] "UTC"

$tzone
[1] "UTC"

It turns out that creating an xts object the usual way creates an object that is equal:

bar <- xts(1:10, order.by=as.Date(1:10)) 
all.equal(foo, bar)

[1] TRUE

So now we can create xts objects at the source level.

Upated to add sv and ev start and end values.

Timing normal RNGs

Wed, 16 Jan 2013 00:00:00 -0800

In previous articles, we have seen that Rcpp can be particularly useful for simulations as it executes code at C++ speed. A very useful feature the API provided by R is the access to the R RNGs so that simulations at the C++ level can get precisely the same stream of random numbers as an R application would.

But sometimes that is not a requirement, and here will look into drawing normals from R, from the random number generator in Boost and the new one in C++11.

A first approach is by far the easiest: using Rcpp and its sugar function which reduces this to a single statement.

#include <Rcpp.h>

using namespace Rcpp;

// [[Rcpp::export]]
NumericVector rcppNormals(int n) {
    RNGScope scope;             // also done by sourceCpp()
    return rnorm(n);
}

A quick test:

set.seed(42)
rcppNormals(10)

 [1]  1.37096 -0.56470  0.36313  0.63286  0.40427 -0.10612  1.51152
 [8] -0.09466  2.01842 -0.06271

Next, the same via Boost. The caveats from the previous two Boost pieces apply: on some systems you may have to ensure access to the Boost headers, on some (such as my Linux system) it just works.

#include <Rcpp.h>

#include <boost/random.hpp>
#include <boost/generator_iterator.hpp>
#include <boost/random/normal_distribution.hpp>

using namespace std;
using namespace Rcpp;

// [[Rcpp::export]]
NumericVector boostNormals(int n) {
    
    typedef boost::mt19937 RNGType; 	// select a generator, MT good default
    RNGType rng(123456);			// instantiate and seed

    boost::normal_distribution<> n01(0.0, 1.0);
    boost::variate_generator< RNGType, boost::normal_distribution<> > rngNormal(rng, n01);

    NumericVector V(n);
    for ( int i = 0; i < n; i++ ) {
        V[i] = rngNormal();
    };
  
    return V;
}

A second test:

boostNormals(10)

 [1]  0.8400  0.8610  2.0907 -0.4437 -0.1029  1.5609  1.3874 -1.0453
 [9] -1.6558  1.6198

And now for the same using the random number generator added to C++11. Here, the same caveats apply as before: we need to enable the C++11 extensions:

Sys.setenv("PKG_CXXFLAGS"="-std=c++11")
# or
# Sys.setenv("PKG_CXXFLAGS"="-std=c++0x")

That way, we can compile this code:

#include <Rcpp.h>
#include <random>

using namespace Rcpp;

// [[Rcpp::export]]
NumericVector cxx11Normals(int n) {

    std::mt19937 engine(42);
    std::normal_distribution<> normal(0.0, 1.0);

    NumericVector V(n);
    for ( int i = 0; i < n; i++ ) {
        V[i] = normal(engine);
    };

    return V;
}

And run it:

cxx11Normals(10)

 [1] -0.5502  0.5154  0.4739  1.3685 -0.9168 -0.1241 -2.0110 -0.4928
 [9]  0.3926 -0.9292

Lastly, we can compare the runtime for these three in a quick benchmark study.

library(rbenchmark)

n <- 1e5

res <- benchmark(rcppNormals(n),
                 boostNormals(n),
                 cxx11Normals(n),
                 order="relative",
                 replications = 500)
print(res[,1:4])

             test replications elapsed relative
3 cxx11Normals(n)          500   3.764    1.000
1  rcppNormals(n)          500   4.102    1.090
2 boostNormals(n)          500   4.353    1.156

In this particularly example, all the RNGs take roughly the same time. It would be interesting to see how the Ziggurat algorithm (which is known to produce Normals rather fast) would fare.