While C++ and specifically the Rcpp package have been tremendously helpful to me in speeding up my codes, I noticed that my C++ functions which have a list or data frame input argument(arguments of the form Rcpp::DataFrame and Rcpp::List) are very slower compared to my other C++ functions. I wrote a sample code and I wanted to ask for tricks that can make my code faster:
First, let's simulate a List in R that contains two Lists inside of it. Consider myList as a list that includes two lists - measure1 and measure2. measure1 and measure2 are lists themselves each include vectors of measurements for subjects. Here is the R code:
lappend <- function(lst, ...){
lst <- c(lst, list(...))
return(lst)
}
nSub <- 30
meas1 <- list()
meas2 <- list()
for (i in 1:nSub){
meas1 <- lappend(meas1, rnorm(10))
meas2 <- lappend(meas2, rnorm(10))
}
myList <- list(meas1 = meas1, meas2 = meas2)
Now, suppose I want a C++ function that for each subject, finds summation of measure1 and summation of measure 2 and then creates two new measurements based on these two summation. Finally the function should return these new measurements as a list.
// [[Rcpp::depends(RcppArmadillo)]]
#include <RcppArmadillo.h>
#include <Rcpp.h>
// [[Rcpp::export]]
Rcpp::List mySlowListFn(Rcpp::List myList, int nSub){
arma::vec myMult(nSub);
arma::vec myDiv(nSub);
for (int i = 0; i < nSub; i++){
arma::vec meas1_i = Rcpp::as<arma::vec>(Rcpp::as<Rcpp::List>(myList["meas1"])[i]);
arma::vec meas2_i = Rcpp::as<arma::vec>(Rcpp::as<Rcpp::List>(myList["meas2"])[i]);
myMult[i] = arma::sum(meas1_i)*arma::sum(meas2_i);
myDiv[i] = arma::sum(meas1_i)/arma::sum(meas2_i);
}
return Rcpp::List::create(Rcpp::Named("myMult") = myMult,
Rcpp::Named("myDiv") = myDiv);
}
How can I make the function above faster? I'm particularly looking for ideas that keep the input and output lists in the code (since in my own program dealing with lists is inevitable), but with some tricks to reduce some overhead time. One thing that I thought of was:
Rcpp::List mySlowListFn(const Rcpp::List& myList, int nSub)
Thanks very much for your help.
First, note that copying semantics for lists have changed in recent versions of R (definitely in latest R-devel, not sure if it made it into R 3.1.0), whereby shallow copies of lists are made, and elements within are later copied if they are modified. There is a big chance that if you are running an older version of R, then its more expensive list copying semantics are getting in the way.
That said, here's how I would re-write your function for some extra speed, with a benchmark. sourceCpp it to compare on your own machine.
// [[Rcpp::depends(RcppArmadillo)]]
#include <RcppArmadillo.h>
#include <Rcpp.h>
// [[Rcpp::export]]
Rcpp::List mySlowListFn(Rcpp::List myList, int nSub){
arma::vec myMult(nSub);
arma::vec myDiv(nSub);
for (int i = 0; i < nSub; i++){
arma::vec meas1_i = Rcpp::as<arma::vec>(Rcpp::as<Rcpp::List>(myList["meas1"])[i]);
arma::vec meas2_i = Rcpp::as<arma::vec>(Rcpp::as<Rcpp::List>(myList["meas2"])[i]);
myMult[i] = arma::sum(meas1_i)*arma::sum(meas2_i);
myDiv[i] = arma::sum(meas1_i)/arma::sum(meas2_i);
}
return Rcpp::List::create(Rcpp::Named("myMult") = myMult,
Rcpp::Named("myDiv") = myDiv);
}
// [[Rcpp::export]]
Rcpp::List myFasterListFn(Rcpp::List myList, int nSub) {
Rcpp::NumericVector myMult = Rcpp::no_init(nSub);
Rcpp::NumericVector myDiv = Rcpp::no_init(nSub);
Rcpp::List meas1 = myList["meas1"];
Rcpp::List meas2 = myList["meas2"];
for (int i = 0; i < nSub; i++) {
arma::vec meas1_i(
REAL(VECTOR_ELT(meas1, i)), Rf_length(VECTOR_ELT(meas1, i)), false, true
);
arma::vec meas2_i(
REAL(VECTOR_ELT(meas2, i)), Rf_length(VECTOR_ELT(meas2, i)), false, true
);
myMult[i] = arma::sum(meas1_i) * arma::sum(meas2_i);
myDiv[i] = arma::sum(meas1_i) / arma::sum(meas2_i);
}
return Rcpp::List::create(
Rcpp::Named("myMult") = myMult,
Rcpp::Named("myDiv") = myDiv
);
}
/*** R
library(microbenchmark)
lappend <- function(lst, ...){
lst <- c(lst, list(...))
return(lst)
}
nSub <- 30
n <- 10
meas1 <- list()
meas2 <- list()
for (i in 1:nSub){
meas1 <- lappend(meas1, rnorm(n))
meas2 <- lappend(meas2, rnorm(n))
}
myList <- list(meas1 = meas1, meas2 = meas2)
x1 <- mySlowListFn(myList, nSub)
x2 <- myFasterListFn(myList, nSub)
microbenchmark(
mySlowListFn(myList, nSub),
myFasterListFn(myList, nSub)
)
*/
gives me
> library(microbenchmark)
> lappend <- function(lst, ...){
+ lst <- c(lst, list(...))
+ return(lst)
+ }
> nSub <- 30
> n <- 10
> meas1 <- list()
> meas2 <- list()
> for (i in 1:nSub){
+ meas1 <- lappend(meas1, rnorm(n))
+ meas2 <- lappend(meas2, rnorm(n))
+ }
> myList <- list(meas1 = meas1, meas2 = meas2)
> x1 <- mySlowListFn(myList, nSub)
> x2 <- myFasterListFn(myList, nSub)
> microbenchmark(
+ mySlowListFn(myList, nSub),
+ myFasterListFn(myList, nSub)
+ )
Unit: microseconds
expr min lq median uq max neval
mySlowListFn(myList, nSub) 14.772 15.4570 16.0715 16.7520 42.628 100
myFasterListFn(myList, nSub) 4.502 5.0675 5.2470 5.8515 18.561 100
Future versions of Rcpp and Rcpp11 will have the ListOf<T> class which will make it much easier to interact with lists where we know the inner type beforehand, after the proper semantics have been ironed out.
Related
I'm working on an Rcpp function that involves sampling a large vector with unequal probability in a loop. I noticed that the code runs much slower when I provide the probs argument to the Rcpp sample function. Why is that?
Here are simplified functions for comparing performance with and without specifying probs to sample(). I know that the loops are not needed here in this simple example, but the question is why is one loop so much slower than the other?
library(Rcpp)
# Rcpp function for sampling without probabilities
cppFunction('IntegerVector samp_no_probs(IntegerVector x) {
IntegerVector res (x.size());
for(int i=0; i<x.size();i++){
res[i] = sample(x, 1, true)[0];
}
return res;
}')
# Rcpp function for sampling with probabilities
cppFunction('IntegerVector samp_with_probs(IntegerVector x, NumericVector probs) {
IntegerVector res (x.size());
for(int i=0; i<x.size();i++){
res[i] = sample(x, 1, true, probs)[0];
}
return res;
}')
# benchmarking
library(rbenchmark)
n <- 10000
x <- sample(1:n)
probs <- sample(runif(1:100), n, replace = T)
res <- benchmark(with_probs = samp_with_probs(x = x, probs = probs),
no_probs= samp_no_probs(x = x),
replications = 10)
And here is the result:
test replications elapsed relative
2 no_probs 10 0 NA
1 with_probs 10 17 NA
I'm currently computing a quadratic form by taking a known vector and using the element wise multiplication of two outer products as the input matrix. To be specific, my code looks something like this
set.seed(42) # for sake of reproducibility
library(emulator)
Fun <- function(a,b) sqrt((1/(2*pi)))*exp(-0.5*(a-b)^2)
n <- 5000
x <- rnorm(n)
y <- rnorm(n)
u <- rnorm(n)
I <- quad.form(outer(x,x,Fun)*outer(y,y,Fun),u)
This is quite slow and the problem gets significantly worse as n increases. As far as I can make out, the part that causes the problem is the outer(x,x,Fun)*outer(y,y,Fun) term inside the quadratic form.
Is there any way to speed this up?
You can half the timings by making use of the symmetry. I find it easiest to quickly write an Rcpp function:
#include <Rcpp.h>
using namespace Rcpp;
// [[Rcpp::export]]
NumericMatrix foo(NumericVector x, NumericVector y) {
double n = x.size();
NumericMatrix M(n, n);
for(double i = 0; i < n; i++) {
for(double j = 0; j <= i; j++) {
M(i,j) = ((1/(2*M_PI))) *
(exp(-0.5*(pow(x(i)-x(j), 2) + pow(y(i)-y(j), 2))));
M(j,i) = M(i,j);
}
}
return M;
}
Timings:
set.seed(42) # for sake of reproducibility
library(emulator)
Fun <- function(a,b) sqrt((1/(2*pi)))*exp(-0.5*(a-b)^2)
n <- 1e4
x <- rnorm(n)
y <- rnorm(n)
u <- rnorm(n)
system.time({
I <- quad.form(outer(x,x,Fun)*outer(y,y,Fun),u)
})
# user system elapsed
# 4.287 1.373 5.687
system.time({
J <- quad.form(foo(x, y),u)
})
# user system elapsed
# 2.232 0.168 2.409
all.equal(I, J)
#[1] TRUE
Further improvements would require parallelization (or possibly use of some maths).
I'm trying to calculate the weighted euclidean distance (squared) between twoo data frames that have the same number of columns (variables) and different number of rows (observations).
The calculation follows the formula:
DIST[m,i] <- sum(((DATA1[m,] - DATA2[i,]) ^ 2) * lambda[1,])
I specifically need to multiply each parcel of the somatory by a specific weight (lambda).
The code provided bellow runs correctly, but if I use it in hundreds of iterations it takes a lot of processing time. Yesterday it took me 18 hours to create a graphic using multiple iterations of a function that contains this calculation. Using library(profvis) profvis({ my code }) I saw that this specific part of the code is taking up like 80% of the processing time.
I read a lot about how to reduce the processing time using parallel and vectorized operations, but I don't know how to implement them in this particular case, because of the weight lamb#.
Can some one help me reduce my processing time with this code?
More information about the code and the structure of the data can be found in the code provided bellow as comments.
# Data frames used to calculate the euclidean distances between each observation
# from DATA1 and each observation from DATA2.
# The euclidean distance is between a [600x50] and a [8X50] dataframes, resulting
# in a [600X8] dataframe.
DATA1 <- matrix(rexp(30000, rate=.1), ncol=50) #[600x50]
DATA2 <- matrix(rexp(400, rate=.1), ncol=50) #[8X50]
# Weights used for each of the 50 variables to calculate the weighted
# euclidean distance.
# Can be a vector of different weights or a scalar of the same weight
# for all variables.
lambda <- runif(n=50, min=0, max=10) ## length(lambda) > 1
# lambda=1 ## length(lambda) == 1
if (length(lambda) > 1) {
as.numeric(unlist(lambda))
lambda <- as.matrix(lambda)
lambda <- t(lambda)
}
nrows1 <- nrow(DATA1)
nrows2 <- nrow(DATA2)
# Euclidean Distance calculation
DIST <- matrix(NA, nrow=nrows1, ncol=nrows2 )
for (m in 1:nrows1) {
for (i in 1:nrows2) {
if (length(lambda) == 1) {
DIST[m, i] <- sum((DATA1[m, ] - DATA2[i, ])^2)
}
if (length(lambda) > 1){
DIST[m, i] <- sum(((DATA1[m, ] - DATA2[i, ])^2) * lambda[1, ])
}
next
}
next
}
After all the sugestions, combining the answers from #MDWITT (for length(lambda > 1) and #F. Privé (for length(lambda == 1) the final solution took only one minute to run, whilst the original one took me an hour and a half to run, in a bigger code that has that calculation. The final code for this problem, for those interested, is:
#Data frames used to calculate the euclidean distances between each observation from DATA1 and each observation from DATA2.
#The euclidean distance is between a [600x50] and a [8X50] dataframes, resulting in a [600X8] dataframe.
DATA1 <- matrix(rexp(30000, rate=.1), ncol=50) #[600x50]
DATA2 <- matrix(rexp(400, rate=.1), ncol=50) #[8X50]
#Weights used for each of the 50 variables to calculate the weighted euclidean distance.
#Can be a vector of different weights or a scalar of the same weight for all variables.
#lambda <- runif(n = 50, min = 0, max = 10) ##length(lambda) > 1
lambda = 1 ##length(lambda) == 1
nrows1 <- nrow(DATA1)
nrows2 <- nrow(DATA2)
#Euclidean Distance calculation
DIST <- matrix(NA, nrow = nrows1, ncol = nrows2)
if (length(lambda) > 1){
as.numeric(unlist(lambda))
lambda <- as.matrix(lambda)
lambda <- t(lambda)
library(Rcpp)
cppFunction('NumericMatrix weighted_distance (NumericMatrix x, NumericMatrix y, NumericVector lambda){
int n_x = x.nrow();
int n_y = y.nrow();
NumericMatrix DIST(n_x, n_y);
//begin the loop
for (int i = 0 ; i < n_x; i++){
for (int j = 0 ; j < n_y ; j ++) {
double d = sum(pow(x.row(i) - y.row(j), 2)*lambda);
DIST(i,j) = d;
}
}
return (DIST) ;
}')
DIST <- weighted_distance(DATA1, DATA2, lambda = lambda)}
if (length(lambda) == 1) {
DIST <- outer(rowSums(DATA1^2), rowSums(DATA2^2), '+') - tcrossprod(DATA1, 2 * DATA2)
}
Rewrite the problem to use linear algebra and vectorization, which is much faster than loops.
If you don't have lambda, this is just
outer(rowSums(DATA1^2), rowSums(DATA2^2), '+') - tcrossprod(DATA1, 2 * DATA2)
With lambda, it becomes
outer(drop(DATA1^2 %*% lambda), drop(DATA2^2 %*% lambda), '+') -
tcrossprod(DATA1, sweep(DATA2, 2, 2 * lambda, '*'))
Here an alternate way using Rcpp just to have this concept documents. In a file called euclidean.cpp in it I have
#include <Rcpp.h>
#include <cmath>
using namespace Rcpp;
// [[Rcpp::export]]
NumericMatrix weighted_distance (NumericMatrix x, NumericMatrix y, NumericVector lambda){
int n_x = x.nrow();
int n_y = y.nrow();
NumericMatrix out(n_x, n_y);
//begin the loop
for (int i = 0 ; i < n_x; i++){
for (int j = 0 ; j < n_y ; j ++) {
double d = sum(pow(x.row(i) - y.row(j), 2)*lambda);
out(i,j) = d;
}
}
return (out) ;
}
In R, then I have
library(Rcpp)
sourceCpp("libs/euclidean.cpp")
# Generate Data
DATA1 <- matrix(rexp(30000, rate=.1), ncol=50) #[600x50]
DATA2 <- matrix(rexp(400, rate=.1), ncol=50) #[8X50]
lambda <- runif(n=50, min=0, max=10)
# Run the program
out <- weighted_distance(DATA1, DATA2, lambda = lambda)
When I test the speed using:
microbenchmark(
Rcpp_way = weighted_distance(DATA1, DATA2, lambda = lambda),
other = {DIST <- matrix(NA, nrow=nrows1, ncol=ncols)
for (m in 1:nrows1) {
for (i in 1:nrows2) {
if (length(lambda) == 1) {
DIST[m, i] <- sum((DATA1[m, ] - DATA2[i, ])^2)
}
if (length(lambda) > 1){
DIST[m, i] <- sum(((DATA1[m, ] - DATA2[i, ])^2) * lambda[1, ])
}
next
}
next
}}, times = 100)
You can see that it is a good clip faster:
Unit: microseconds
expr min lq mean median uq max neval
Rcpp_way 446.769 492.308 656.9849 562.667 846.9745 1169.231 100
other 24688.821 30681.641 44153.5264 37511.385 50878.3585 200843.898 100
I have to calculate the following in R
where kip, c are constants. One way of doing this is like:
xfun<- function(x,k,p,c){
ghhh<-numeric()
for(i in 1: length(x)){
ghhh[i]<-sum(k/(x[i]-x[1:(i-1)]+c)^p)
}
res<-sum(log(ghhh))
return(res)
}
. But can I calculate this using "outer" ? So that it becomes faster?
The data is like:
t <- numeric(2000)
t[1]<-0
for (i in 2:2000){
t[i]<- t[i-1]+rexp(1, 0.2)
}
k=0.5; p=1.2; c=0.02
Your equation is a bit confusing. I'm not sure what should happen in the inner sum if i == 1. Sum from 1 to zero?
Based on some guessing (if I guessed wrong, you need to adjust the following), I suspect your function should be corrected to this:
xfun<- function(x,k,p,c){
ghhh<-numeric() # it would be better practice to use numeric(length(x) - 1)
for(i in 1: (length(x) - 1)){
ghhh[i]<-sum(k/(x[i+1]-x[1:i]+c)^p)
}
res<-sum(log(ghhh))
return(res)
}
t <- numeric(2000)
t[1]<-0
set.seed(42)
for (i in 2:2000){
t[i]<- t[i-1]+rexp(1, 0.2)
}
k=0.5; p=1.2; c=0.02
xfun(t, k, p, c)
#[1] -1526.102
Rewritten with outer:
xfun1 <- function(x ,k ,p ,c){
o <- outer(seq_along(x), seq_along(x), function(i, j) {
res <- numeric(length(i))
test <- j < i
res[test] <- k / (x[i[test]] - x[j[test]] + c) ^ p
res
})
sum(log(rowSums(o)[-1]))
}
xfun1(t, k, p, c)
#[1] -1526.102
Benchmarking:
library(microbenchmark)
microbenchmark(loop = xfun(t, k, p, c),
outer = xfun1(t, k, p, c),
times = 10)
#Unit: milliseconds
# expr min lq mean median uq max neval cld
# loop 186.0454 186.2375 188.9567 187.4005 189.0597 196.6992 10 a
# outer 263.4137 274.6610 346.4505 344.6918 423.3651 425.2885 10 b
As you see, the solution with outer is not faster for data of this size. The main reasons are that R needs to allocate memory for a vector of length 2000^2 and work on this large vector. Also, your simple loop is optimized by the JIT bytecode compiler.
If you want to be faster, you need to switch to a compiled language. Luckily, this is rather easy with Rcpp:
library(Rcpp)
library(inline)
cppFunction(
'double xfun2(const NumericVector x, const double k, const double p, const double c) {
int n = x.length() - 1;
NumericVector ghhh(n);
for (int i = 0; i < n; ++i) {
for (int j = 0; j <= i ; ++j) {
ghhh(i) += k / pow(x(i + 1) - x(j) + c, p);
}
}
ghhh = log(ghhh);
double res;
res = sum(ghhh);
return res;
}')
xfun2(t, k, p, c)
#[1] -1526.102
microbenchmark(loop = xfun(t, k, p, c),
outer = xfun1(t, k, p, c),
Rcpp = xfun2(t, k, p, c),
times = 10)
#Unit: milliseconds
# expr min lq mean median uq max neval cld
# loop 186.0395 188.7875 189.7487 189.9298 191.6967 192.7213 10 b
# outer 408.4452 416.7730 432.3356 419.7510 422.4000 559.4279 10 c
# Rcpp 136.1496 136.1606 136.1929 136.1762 136.2129 136.3089 10 a
As you see, speed gains are minimal for data of this size (JIT compilation is truly marvelous). I suggest to stay with your R loop.
Considering that the logic you implement is the correct one you could try the parallel R functionalities:
library(foreach)
library(doParallel)
xfun2<- function(x,k,p,c){
no_cores <- detectCores() - 1
cl<-makeCluster(no_cores)
registerDoParallel(cl)
ghhh <- foreach(i = 1: length(x), .combine = c) %dopar% sum(k/(x[i]-x[1:(i-1)]+c)^p)
res <- sum(log(ghhh))
}
I ran it with x <- rnorm(100000, 1, 0.5) and the parallel version was almost twice as fast.
You can read more about the doParallel package here
I want to have a very quick search and it seems, that using hashes (via environments) is the best way. Now, I got an example to run with environments, but it does not return what I need.
Here is an example:
a <- data.table::data.table(a=c(1, 3, 5), b=c(2, 4, 6), time=c(10, 20, 30))
my_env <- list2env(a)
x <- a[2, .(a, b)] # x=c(3,4)
found <- get("x", envir = my_env)
I would expect found = c(3, 4, 20) but receive found = c(3, 4)
(I want the whole row to be returned instead of the unknown row subset)
Backround: I have a huge list containing source and destination of routes calculated with osrm, e.g.
lattitude1, longitude1, lattitude2, longitude2, travel-time
46.12, 8.32, 47.87, 9.92, 1036
...
The list contains in a first example about 100000 rows. Using binary search in a data.table speeded up my code by a factor 100, but one search still takes 1 ms. As I have to search for many routes during a simulation (About 2e5 searches) I would like to get even faster.
#Gregor: I am a beginner in R, but I don't think my question is a duplicate:
I knew the second link , which is an abstract overview for experts listing possibilities. Furthermore, it is 4 years old.
I didn't know the first link, but from those answers I can't see whether I should switch to environments and how an implementation could work at all. There is also no discussion about searching a part of a huge list.
Summary (Thanks to DigEmAll for his running example below):
Using Rcpp on integers, the search is less memory consuming without any loss of quality. Futhermore, it is about a factor of 3 faster.
Do not use hashed environments when you want to look up doubles (which have to be converted to strings).
Implementation in existing code should be easy.
Here's an example using enviroment and data.table, the code is pretty self-explanatory :
library(data.table)
# create a big random example (160k rows)
set.seed(123)
fromTo <- expand.grid(1:400,1:400)
colnames(fromTo) <- c('a','b')
DF <- as.data.frame(cbind(fromTo,time=as.integer(runif(nrow(fromTo), min = 1, max=500))))
# setup the environment to use it as hashtable:
# we simply put the times inside an enviroment using
# a|b (concatenation of a with b) as key
timesList <- as.list(DF$time)
names(timesList) <- paste(DF$a,DF$b,sep='|')
timesEnv <- list2env(timesList)
# setup the data.table to use it as hashtable
DT <- setDT(DF,key=c('a','b'))
# create search functions
searchUsingEnv <- function(a,b){
time <- get(paste(a,b,sep='|'),envir=timesEnv,inherits=FALSE)
return(time)
}
searchUsingDataTable <- function(from,to){
time <- DT[.(from,to),time]
return(time)
}
Benchmark :
# benchmark functions
# i.e. we try to search ~16K rows in ourtwo kind of hashtables
benchEnv <- function(){
n <- nrow(fromTo)
s <- as.integer(n * 0.9)
for(i in s:n){
searchUsingEnv(fromTo[i,'a'],fromTo[i,'b'])
}
}
benchDT <- function(){
n <- nrow(fromTo)
s <- as.integer(n * 0.9)
for(i in s:n){
searchUsingDataTable(fromTo[i,'a'],fromTo[i,'b'])
}
}
# let's measure the performances
> system.time(benchEnv(), gcFirst = TRUE)
user system elapsed
2.26 0.00 2.30
> system.time(benchDT(), gcFirst = TRUE)
user system elapsed
42.34 0.00 42.56
Conclusions:
environment seems much faster then data.table for repeated single key access, so you can try to use it.
EDIT :
Enviroments have fast access but they can only have string keys which occupy more memory than doubles. So, I've added an example using Rcpp and std::map<> with a multiple values map :
(note: if you are on Windows you need to install RTools in order to make Rcpp work)
library(data.table)
library(Rcpp)
library(inline)
nRows <- 1e7
############# create data.table "DT" containing coordinates and times
generate_routes_dt <- function(nmax) {
set.seed(123)
routes <- data.table(lat1 = numeric(nmax),
lng1 = numeric(nmax),
lat2 = numeric(nmax),
lng2 = numeric(nmax),
time = numeric(nmax))
tmp <- sample(seq(46, 49, length.out = nmax), nmax)
routes$lat1 <- tmp
tmp <- sample(seq(8, 10, length.out = nmax), nmax)
routes$lng1 <- tmp
tmp <- sample(seq(46, 49, length.out = nmax), nmax)
routes$lat2 <- tmp
tmp <- sample(seq(8, 10, length.out = nmax), nmax)
routes$lng2 <- tmp
tmp <- sample(seq(0, 1e7, length.out = nmax), nmax)
routes$time <- as.integer(tmp)
data.table::setkey(routes, lat1, lng1, lat2, lng2)
return(routes)
}
DT <- generate_routes_dt(nRows)
############# create data.table search function
searchUsingDataTable <- function(lat_1,lng_1,lat_2,lng_2){
time <- DT[.(lat_1,lng_1,lat_2,lng_2),time]
return(time)
}
#############
############# create Rcpp search function
# the following code create 2 functions: createMap and getTime
# usage:
# map <- createMap(lat1Vec,lng1Vec,lat2Vec,lng2Vec,timesVec)
# t <- getTime(map,lat1,lng1,lat2,lng2)
sourceCpp(code=
'
#include <Rcpp.h>
class MultiKey {
public:
double lat1;
double lng1;
double lat2;
double lng2;
MultiKey(double la1, double ln1, double la2, double ln2)
: lat1(la1), lng1(ln1), lat2(la2), lng2(ln2) {}
bool operator<(const MultiKey &right) const
{
if ( lat1 == right.lat1 ) {
if ( lng1 == right.lng1 ) {
if ( lat2 == right.lat2 ) {
return lng2 < right.lng2;
}
else {
return lat2 < right.lat2;
}
}
else {
return lng1 < right.lng1;
}
}
else {
return lat1 < right.lat1;
}
}
};
// [[Rcpp::export]]
SEXP createMap(Rcpp::NumericVector lat1,
Rcpp::NumericVector lng1,
Rcpp::NumericVector lat2,
Rcpp::NumericVector lng2,
Rcpp::NumericVector times){
std::map<MultiKey, double>* map = new std::map<MultiKey, double>;
int n1 = lat1.size();
int n2 = lng1.size();
int n3 = lat2.size();
int n4 = lng2.size();
int n5 = times.size();
if(!(n1 == n2 && n2 == n3 && n3 == n4 && n4 == n5)){
throw std::range_error("input vectors lengths are different");
}
for(int i = 0; i < n1; i++){
MultiKey key(lat1[i],lng1[i],lat2[i],lng2[i]);
map->insert(std::pair<MultiKey, double>(key, times[i]));
}
Rcpp::XPtr< std::map<MultiKey, double> > p(map, true);
return( p );
}
// [[Rcpp::export]]
Rcpp::NumericVector getTime(SEXP mapPtr,
double lat1,
double lng1,
double lat2,
double lng2){
Rcpp::XPtr< std::map<MultiKey, double> > ptr(mapPtr);
MultiKey key(lat1,lng1,lat2,lng2);
std::map<MultiKey,double>::iterator it = ptr->find(key);
if(it == ptr->end())
return R_NilValue;
return Rcpp::wrap(it->second);
}
')
map <- createMap(DT$lat1,DT$lng1,DT$lat2,DT$lng2,DT$time)
searchUsingRcpp <- function(lat_1,lng_1,lat_2,lng_2){
time <- getTime(map,lat_1,lng_1,lat_2,lng_2)
return(time)
}
#############
############# benchmark
set.seed(1234)
rowsToSearchOneByOne <- DT[sample.int(nrow(DT),size=nrow(DT),replace=FALSE),]
bench <- function(searchFun2Use){
for(i in nrow(rowsToSearchOneByOne)){
key <- rowsToSearchOneByOne[i,]
searchFun2Use(key$lat1,key$lng1,key$lat2,key$lng2)
}
}
microbenchmark::microbenchmark(
bench(searchUsingRcpp),
bench(searchUsingDataTable),
times=100)
#############
Benchmark result :
Unit: microseconds
expr min lq mean median uq max neval
bench(searchUsingRcpp) 360.959 381.7585 400.4466 391.999 403.9985 665.597 100
bench(searchUsingDataTable) 1103.034 1138.0740 1214.3008 1163.514 1224.9530 2035.828 100
Note:
I really don't think that using double as keys is a good idea... floating point values should be used to search using a certain tolerance or inside a range, not to look up for perfect match inside a map.