Related
I'd like to perform the following operation more quickly.
Logic: I have a vector big of 4 elements 1, 2, 3, 4. I also have a same-length vector of thresholds 1.1, 3.1, 4.1, 5.1. I want for each element to find the index of the first next element to be above the corresponding threshold. In this case my expected output is
2, 3, NA, NA:
the first element after the first one (included) which is above the threshold of 1.1 is at index 2 (value of 2).
The first element above the second threshold of 3.1 is of value 4, and is the third element after the current one at index 2 (included).
Base implementation
start <- Sys.time()
bigg <- rnorm(25000)
thresh <- bigg+0.5
result <- rep(NA, length(bigg))
for(i in 1:length(bigg)) {
result[i] <- which(bigg[(i+1):length(bigg)]>thresh[i])[1] # the first next element that is higher than thresh
if(i%%1000==0) print(paste0(i, " ", round(i/length(bigg),3)))
}
end <- Sys.time()
end-start
head(result)
Basically, taking the first element of the vector x after the current one that satisfies a threshold condition.
I tried using Rcpp
// [[Rcpp::export]]
int cppnextup_(NumericVector x, double thresh, bool is_up = true) {
int n = x.size();
//int idx = 0;
int res = -1;
for(int idx = 0; idx < n; ++idx) {
if(x[idx]>thresh && is_up == true) {
res = idx;
//Rcout << "The value of idx : " << idx <<" "<< x[idx]<<"\n";
break;
}
if(x[idx]<thresh && is_up == false) {
res = idx;
//Rcout << "The value of idx : " << idx <<" "<< x[idx]<<"\n";
break;
}
}
return res;
}
Benchmarking:
# base --------------------------------------------------------------------
base_ <- function() {
for(i in 1:length(bigg)) {
result[i] <- which(bigg[(i+1):length(bigg)]>thresh[i])[1] # the first next element that is higher than thresh
if(i%%1000==0) print(paste0(i, " ", round(i/length(bigg),3)))
}
}
# cpp ----------------------------------------------------------------
result_cpp <- rep(NA, length(bigg))
cpp_ <- function() {
for(i in 1:length(bigg)) {
result_cpp[i] <- cppnextup_(bigg[(i+1):length(bigg)], thresh[i]) # the first next element that is higher than thresh
if(i%%1000==0) print(paste0(i, " ", round(i/length(bigg),3)))
}
}
#result_cpp <- ifelse(result_cpp==-1, NA, result_cpp)
#result_cpp <- result_cpp+1
#all.equal(result, result_cpp)
#[1] TRUE
# benchmark ---------------------------------------------------------------
microbenchmark::microbenchmark(base_(),
cpp_(), times=3)
Unit: milliseconds
expr min lq mean median uq max neval
base_() 2023.510 2030.3154 2078.7867 2037.1211 2106.4252 2175.7293 3
cpp_() 661.277 665.3456 718.8851 669.4141 747.6891 825.9641 3
My Rcpp implementation reduces base time by 65%, is there a better (vectorized) way? Looking for any backend, be it Rcpp, data.table, dtplyr etc.
My dtplyr attempt yields all NA's:
library(dtplyr)
nx <- length(bigg)
df <- tibble(bigg, thresh)
bigg %>% lazy_dt() %>% mutate(res = which(bigg[row_number():nx]>thresh)[1])
Warning message:
In seq_len(.N):..nx :
numerical expression has 25000 elements: only the first used
Cheers
Btw, my real vector has 8,406,600 elements.
EDIT: vectorized Rcpp
I also have another, faster Rcpp function which relies on the first one:
// [[Rcpp::export]]
NumericVector cppnextup(NumericVector x, double threshup, bool is_up = true) {
int n = x.size();
NumericVector up(n);
if(is_up == true) {
up = x + threshup;
} else {
up = x - threshup;
}
// Rcout << "The value of up : " << up[0] <<" "<< up[1] <<"\n";
NumericVector result(n);
int idx = 0;
for(int i = 0; i < n; ++i) {
double thisup = up[idx];
NumericVector thisvect = x[Rcpp::Range((idx), (n-1))];
//Rcout <<idx<< " " << "thisvect : " << thisvect[0] <<" thisup: "<< thisup <<" buy " << buy << "\n";
int resi = cppnextup_(thisvect, thisup, is_up = is_up);
if(resi != 0) {
result[idx] = resi+1;
} else {
result[idx] = resi;
}
//Rcout << "RESI: " << resi <<" "<< up[1] <<"\n";
idx = idx + 1;
}
return result;
}
As you can see it is faster than the previous two:
# cpp_vectorized ----------------------------------------------------------
cpp_vect <- function(bigg) {
res_cppvect <- cppnextup(bigg, 0.5)
}
# benchmark ---------------------------------------------------------------
microbenchmark::microbenchmark(base_(),
cpp_(),
cpp_vect(),
times=3)
expr min lq mean median uq max neval
base_() 2014.7211 2016.8679 2068.9869 2019.0146 2096.1198 2173.2250 3
cpp_() 663.0874 666.1540 718.5863 669.2207 746.3357 823.4507 3
cpp_vect() 214.1745 221.2103 223.9532 228.2460 228.8426 229.4392 3
BUT when I pass a larger vector in argument, it freezes and never returns a result.
res <- cpp_vect(bigg=rnorm(1000000)) # freezes
Any help welcome.
A data.table non-equi join with mult = "first" works well. It won't be as fast as an optimized Rcpp function, though.
library(data.table)
bigg <- rnorm(25000)
thresh <- bigg+0.5
f1 <- function(bigg, thresh) {
result <- rep(NA, length(bigg))
for(i in 1:length(bigg)) {
result[i] <- which(bigg[(i+1):length(bigg)]>thresh[i])[1] # the first next element that is higher than thresh
}
result
}
f2 <- function(bigg, thresh) {
data.table(
val = bigg,
r = seq_along(bigg)
)[
data.table(
val = thresh,
r = seq_along(thresh)
),
on = .(val > val, r > r),
.(result = x.r - i.r),
mult = "first"
]$result
}
microbenchmark::microbenchmark(f1 = f1(bigg, thresh),
f2 = f2(bigg, thresh),
times = 10,
check = "identical")
#> Unit: milliseconds
#> expr min lq mean median uq max neval
#> f1 2167.139 2199.801 2217.6945 2222.4937 2233.254 2250.1693 10
#> f2 605.999 610.576 612.0431 611.1439 614.195 618.6248 10
bigg <- rnorm(1e6)
thresh <- bigg+0.5
system.time(f2(bigg, thresh))
#> user system elapsed
#> 375.71 0.15 375.81
Although this Rcpp code isn't optimized, it performs quite well on a 1e7 vector (less than 1 second, probably due to the normal distribution of test data):
#include <Rcpp.h>
using namespace Rcpp;
// [[Rcpp::export]]
IntegerVector cppnextup_(NumericVector x, NumericVector thresh, bool is_up = true) {
int n = x.size();
IntegerVector res(n);
std::fill(res.begin(), res.end(), NA_INTEGER);
for(int i = 0; i < n; i++) {
for (int j = i+1; j < n; j++){
if(x[j]>thresh[i] && is_up == true) {
res[i] = j-i;
//Rcout << "The value of idx : " << idx <<" "<< x[idx]<<"\n";
break;
}
if(x[j]<thresh[i] && is_up == false) {
res[i] = j-i;
//Rcout << "The value of idx : " << idx <<" "<< x[idx]<<"\n";
break;
}
}
}
return res;
}
Speed comparison on a 1e5 vector (a longer vector would take too much time for comparison):
bigg <- rnorm(1e5)
thresh <- bigg+0.5
f1 <- function(bigg, thresh) {
result <- rep(NA, length(bigg))
for(i in 1:length(bigg)) {
result[i] <- which(bigg[(i+1):length(bigg)]>thresh[i])[1] # the first next element that is higher than thresh
}
result
}
f_cpp <- function(bigg, thresh){
cppnextup_(bigg, thresh)
}
microbenchmark::microbenchmark(f1 = f1(bigg, thresh),
f_cpp = f_cpp(bigg, thresh),
times = 1,
check="identical")
Unit: milliseconds
expr min lq mean median uq max neval
f1 59614.42 59614.42 59614.42 59614.42 59614.42 59614.42 1
f_cpp 5.56 5.56 5.56 5.56 5.56 5.56 1
In a worst case scenario where the threshold is reached in the last values of the vector, the data.table approach shows its effectiveness :
bigg <- rep(0,1e5)
thresh <- bigg+0.5
bigg[(1e5-2):1e5] <- 1
microbenchmark::microbenchmark( f1 = f1(bigg, thresh),
f2 = f2(bigg, thresh),
f_cpp = f_cpp(bigg, thresh),
times = 1)
Unit: milliseconds
expr min lq mean median uq max neval
f1 48546.2250 48546.2250 48546.2250 48546.2250 48546.2250 48546.2250 1
f2 40.0642 40.0642 40.0642 40.0642 40.0642 40.0642 1
f_cpp 4521.9461 4521.9461 4521.9461 4521.9461 4521.9461 4521.9461 1
I want to c() 2 lists in Rcpp, but I'm struggling to get the same structure as I would in R.
Here is some simple data + example:
rlist = list(a = "123")
listadd = list(typ = "fdb")
c(rlist, listadd)
which gives me this:
$a
[1] "123"
$typ
[1] "fdb"
With Rcpp I only found push_back to do more or less what I want but the structure is a bit different. I also tried to use emplace_back based on this reference but it doesnt seem to be implemented in Rcpp.
cppFunction('
List cLists(List x, List y) {
x.push_back(y);
return(x);
}')
which gives me:
cLists(rlist, listadd)
$a
[1] "123"
[[2]]
[[2]]$typ
[1] "fdb"
Based on this question I know that I could use Language("c",x,y).eval(); to use R's c() function and get the correct result, but that doesn't seem to be the right way.
So I was wondering how can I concatenate lists in Rcpp correctly?
EDIT:
Based on #Dirk's comment, I tried to create a new list and fill them with the other lists elements, but then I loose the element names.
cppFunction('
List cLists(List x, List y) {
int nsize = x.size();
int msize = y.size();
List out(nsize + msize);
for(int i = 0; i < nsize; i++) {
out[i] = x[i];
}
for(int i = 0; i < msize; i++) {
out[nsize+i] = y[i];
}
return(out);
}')
Output:
cLists(rlist, listadd)
[[1]]
[1] "123"
[[2]]
[1] "fdb"
The performance hit for your implementation seems to come from copying the name attribute to stl string vectors. You can avoid it like so:
library(Rcpp)
library(microbenchmark)
cppFunction('
List cLists(List x, List y) {
int nsize = x.size();
int msize = y.size();
List out(nsize + msize);
CharacterVector xnames = x.names();
CharacterVector ynames = y.names();
CharacterVector outnames(nsize + msize);
out.attr("names") = outnames;
for(int i = 0; i < nsize; i++) {
out[i] = x[i];
outnames[i] = xnames[i];
}
for(int i = 0; i < msize; i++) {
out[nsize+i] = y[i];
outnames[nsize+i] = ynames[i];
}
return(out);
}')
x <- as.list(runif(1e6)); names(x) <- sample(letters, 1e6, T)
y <- as.list(runif(1e6)); names(y) <- sample(letters, 1e6, T)
microbenchmark(cLists(x,y), c(x,y), times=3)
Unit: milliseconds
expr min lq mean median uq max neval cld
cLists(x, y) 31.70104 31.86375 32.09983 32.02646 32.29922 32.57198 3 a
c(x, y) 47.31037 53.21409 56.41159 59.11781 60.96220 62.80660 3 b
Note: by copying to std::string you're also losing possible character encoding information, whereas working with just R/Rcpp preserves.
This is what I came up with. The output is correct, but unfortunately it is also much less performant than the R version.
library(Rcpp)
cppFunction('
List cLists(List x, List y) {
int nsize = x.size();
int msize = y.size();
List out(nsize + msize);
CharacterVector xnames = x.names();
CharacterVector ynames = y.names();
for(int i = 0; i < nsize; i++) {
out[i] = x[i];
}
for(int i = 0; i < msize; i++) {
out[nsize+i] = y[i];
}
std::vector<std::string> z(x.size() + y.size());
std::copy(xnames.begin(), xnames.end(), z.begin());
std::copy(ynames.begin(), ynames.end(), z.begin() + x.size());
out.attr("names") = z;
return(out);
}')
Output:
cLists(rlist, listadd)
$a
[1] "123"
$typ
[1] "fdb"
I am converting some code over from Excel in which we calculate the values in a matrix based on the element that came before it. This is easy and straightforward in Excel. But in R, I define the first row of the matrix and each subsequent row is calculated based on the one before with the following equation in a nested for loop.
step1 <- c(0.0013807009, 0.0005997510, 0.0011314072, 0.0016246001, 0.0014240778)
A <- c( 34.648458, 1.705335, 0.000010, 11.312707, 9.167534)
n <- 10
tau <- matrix(0,nrow=n+1,ncol=5)
tau[1,] <- A
for(j in 1:5){
for(i in 2:nrow(tau)){
tau[i,j] <- tau[i-1,j] + step1[j]*1.0025^(i-2)
}
}
My matrices are very large, thousands of rows and columns, so my guess is this is not a very efficient way to make these calculations. I looked into sapply and vapply, but didn't understand how to perform the sequential step of calculating each row based on the previous row.
Just implementing your code in Rcpp:
#include <Rcpp.h>
using namespace Rcpp;
// [[Rcpp::export]]
NumericMatrix to_col_cumsum(const NumericVector& step1,
const NumericVector& A,
int n) {
int m = step1.length();
NumericMatrix tau(n + 1, m);
int i, j;
// precomputing this is important
NumericVector pows(n + 1);
for (i = 1; i < (n + 1); i++) pows[i] = pow(1.0025, i - 1);
for (j = 0; j < m; j++) {
tau(0, j) = A[j];
for (i = 1; i < (n + 1); i++) {
tau(i, j) = tau(i - 1, j) + step1[j] * pows[i];
}
}
return tau;
}
Verification:
step1 <- c(0.0013807009, 0.0005997510, 0.0011314072, 0.0016246001, 0.0014240778)
A <- c( 34.648458, 1.705335, 0.000010, 11.312707, 9.167534)
n <- 10
# OP
f1 <- function(step1, A, n) {
m <- length(step1)
tau <- matrix(0,nrow=n+1,ncol=m)
tau[1,] <- A
for(j in 1:m){
for(i in 2:nrow(tau)){
tau[i,j] <- tau[i-1,j] + step1[j]*1.0025^(i-2)
}
}
tau
}
# Hayden
f2 <- function(step1, A, n) {
calc_next_row <- function(tau, row_idx) {
tau + step1 * 1.0025 ^ row_idx
}
do.call(rbind, Reduce(calc_next_row,
init = A,
x = 0:(n - 1),
accumulate = TRUE))
}
all.equal(f2(step1, A, n), f1(step1, A, n))
all.equal(to_col_cumsum(step1, A, n), f1(step1, A, n))
Benchmark:
step1 <- runif(1000)
A <- rnorm(1000)
n <- 2000
microbenchmark::microbenchmark(
HR = f2(step1, A, n),
FP = to_col_cumsum(step1, A, n),
times = 100
)
Results:
Unit: milliseconds
expr min lq mean median uq max neval cld
HR 10.907345 13.127121 18.337656 14.680584 16.419786 131.97709 100 b
FP 6.516132 7.308756 9.140994 9.139504 9.841078 17.28872 100 a
The R code of Hayden Rabel is fairly fast!
I'm looking for efficiency gains in calculating the (auto)covariance matrix from individual measurements over time t with t, t-1, etc..
In the data matrix, each row represents an individual and each column represents monthly measurements (the columns are in time order). Similar to the following data (although with some more co-variance).
# simulate data
set.seed(1)
periods <- 70L
ind <- 90000L
mat <- sapply(rep(ind, periods), rnorm)
Below is the (ugly) code I came up with to get the covariance matrix for measurements/ lagged measurements. It takes almost 4 seconds to run. I'm sure that by moving to data.table, thinking more and not relying on loops I could cut the time by a big amount. But since covariance matrices are ubiquitous I suspect there already exists a standard (and efficient) way to do this in R that I should know about first.
# Get variance covariance matrix for 0-5 lags
n_lags <- 5L # Number of lags
vcov <- matrix(0, nrow = n_lags + 1L, ncol = n_lags + 1)
for (i in 0L:n_lags) {
for (j in i:n_lags) {
vcov[j + 1L, i + 1L] <-
sum(mat[, (1L + (j - i)):(periods - i)] *
mat[, 1L:(periods - j)]) /
(ind * (periods - j) - 1)
}
}
round(vcov, 3)
[,1] [,2] [,3] [,4] [,5] [,6]
[1,] 1.001 0.000 0.000 0.000 0.000 0.000
[2,] 0.000 1.001 0.000 0.000 0.000 0.000
[3,] 0.000 0.000 1.001 0.000 0.000 0.000
[4,] 0.000 0.000 0.000 1.001 0.000 0.000
[5,] -0.001 0.000 0.000 0.000 1.001 0.000
[6,] 0.000 -0.001 0.000 0.000 0.000 1.001
#F. Privé's Rcpp implementation is a good starting place, but we can do better. You will notice in the main algorithm supplied by the OP that there are many replicated fairly expensive calculations. Observe:
OPalgo <- function(m, p, ind1, n) {
vcov <- matrix(0, nrow = n + 1L, ncol = n + 1)
for (i in 0L:n) {
for (j in i:n) {
## lower and upper range for the first & second multiplicand
print(paste(c((1L + (j - i)),":",(periods - i),"
",1L,":",(periods - j)), collapse = ""))
vcov[j + 1L, i + 1L] <-
sum(mat[, (1L + (j - i)):(periods - i)] *
mat[, 1L:(periods - j)]) /
(ind * (periods - j) - 1)
}
}
vcov
}
OPalgo(mat, periods, ind, n_lags)
[1] "1:70 1:70" ## contains "1:65 1:65"
[1] "2:70 1:69"
[1] "3:70 1:68"
[1] "4:70 1:67"
[1] "5:70 1:66"
[1] "6:70 1:65"
[1] "1:69 1:69" ## contains "1:65 1:65"
[1] "2:69 1:68"
[1] "3:69 1:67"
[1] "4:69 1:66"
[1] "5:69 1:65"
[1] "1:68 1:68" ## contains "1:65 1:65"
[1] "2:68 1:67"
[1] "3:68 1:66"
[1] "4:68 1:65"
[1] "1:67 1:67" ## contains "1:65 1:65"
[1] "2:67 1:66"
[1] "3:67 1:65"
[1] "1:66 1:66" ## contains "1:65 1:65"
[1] "2:66 1:65"
[1] "1:65 1:65"
As you can see, the product mat[,1:65] * mat[,1:65] is performed 6 times above. The only difference between the first occurrence and the last occurrence is that the first occurrence has an additional 5 columns. So instead of computing:
sum(mat[ , 1:70] * mat[ , 1:70])
sum(mat[ , 1:69] * mat[ , 1:69])
sum(mat[ , 1:68] * mat[ , 1:68])
sum(mat[ , 1:67] * mat[ , 1:67])
sum(mat[ , 1:66] * mat[ , 1:66])
sum(mat[ , 1:65] * mat[ , 1:65])
We can compute preCalc[1] <- sum(mat[ , 1:65] * mat[ , 1:65]) one time and use this in the other 5 calculations like so:
preCalc[1] + sum(mat[ , 66:70] * mat[ , 66:70])
preCalc[1] + sum(mat[ , 66:69] * mat[ , 66:69])
preCalc[1] + sum(mat[ , 66:68] * mat[ , 66:68])
preCalc[1] + sum(mat[ , 66:67] * mat[ , 66:67])
preCalc[1] + sum(mat[ , 66:66] * mat[ , 66:66])
In each of the above, we have reduce the number of multiplications by 90000 * 65 = 5,850,000 and the number of additions by 5,850,000 - 1 = 5,849,999 for a total of 11,699,999 arithmetic operations saved. The function below achieves this very thing.
fasterAlgo <- function(m, p, ind1, n) {
vcov <- matrix(0, nrow = n + 1L, ncol = n + 1)
preCals <- vapply(1:(n + 1L), function(x) sum(m[ , x:(p - n + x - 2L)] *
m[ , 1L:(p - n - 1L)]), 42.42)
for (i in 0L:n) {
for (j in i:n) {
myNum <- preCals[1L + j - i] + sum(m[, (p - n + j - i):(p - i)] * m[, (p - n):(p - j)])
vcov[j + 1L, i + 1L] <- myNum / (ind * (p - j) - 1)
}
}
vcov
}
## outputs same results
all.equal(OPalgo(mat, periods, ind, n_lags), fasterAlgo(mat, periods, ind, n_lags))
[1] TRUE
Benchmarks:
## I commented out the print statements of the OPalgo before benchmarking
library(microbenchmark)
microbenchmark(OP = OPalgo(mat, periods, ind, n_lags),
fasterBase = fasterAlgo(mat, periods, ind, n_lags),
RcppOrig = compute_vcov(mat, n_lags), times = 5)
Unit: milliseconds
expr min lq mean median uq max neval cld
OP 2775.6110 2780.7207 2843.6012 2784.976 2899.7621 2976.9356 5 c
fasterBase 863.3897 863.9681 865.5576 865.593 866.7962 868.0409 5 b
RcppOrig 160.1040 161.8922 162.0153 162.235 162.4756 163.3697 5 a
As you can see, with this modification we see at least a 3 fold improvement but the Rcpp is still much faster. Let's implement the above concept in Rcpp.
// [[Rcpp::export]]
NumericMatrix compute_vcov2(const NumericMatrix& mat, int n_lags) {
NumericMatrix vcov(n_lags + 1, n_lags + 1);
std::vector<double> preCalcs;
preCalcs.reserve(n_lags + 1);
double myCov;
int i, j, k1, k2, l;
int n = mat.nrow();
int m = mat.ncol();
for (i = 0; i <= n_lags; i++) {
myCov = 0;
for (k1 = i, k2 = 0; k2 < (m - n_lags - 1); k1++, k2++) {
for (l = 0; l < n; l++) {
myCov += mat(l, k1) * mat(l, k2);
}
}
preCalcs.push_back(myCov);
}
for (i = 0; i <= n_lags; i++) {
for (j = i; j <= n_lags; j++) {
myCov = preCalcs[j - i];
for (k1 = m - n_lags + j - i - 1, k2 = m - n_lags - 1; k2 < (m - j); k1++, k2++) {
for (l = 0; l < n; l++) {
myCov += mat(l, k1) * mat(l, k2);
}
}
myCov /= n * (m - j) - 1;
vcov(i, j) = vcov(j, i) = myCov;
}
}
return vcov;
}
## gives same results
all.equal(compute_vcov2(mat, n_lags), compute_vcov(mat, n_lags))
[1] TRUE
New benchmarks:
microbenchmark(OP = OPalgo(mat, periods, ind, n_lags),
fasterBase = fasterAlgo(mat, periods, ind, n_lags),
RcppOrig = compute_vcov(mat, n_lags),
RcppModified = compute_vcov2(mat, n_lags), times = 5)
Unit: milliseconds
expr min lq mean median uq max neval cld
OP 2785.4789 2786.67683 2811.02528 2789.37719 2809.61270 2883.98073 5 d
fasterBase 866.5601 868.25555 888.64418 869.31796 870.92308 968.16417 5 c
RcppOrig 160.3467 161.37992 162.74899 161.73009 164.38653 165.90174 5 b
RcppModified 51.1641 51.67149 52.87447 52.56067 53.06273 55.91334 5 a
Now the enhanced Rcpp solution is around 3x faster the original Rcpp solution and around 50x faster than the original algorithm provided by the OP.
Update
We can do even better. We can reverse the ranges of the indices i/j so as to continuously update preCalcs. This allows up to only compute the product of one new column every iteration. This really comes into play as n_lags increases. Observe:
// [[Rcpp::export]]
NumericMatrix compute_vcov3(const NumericMatrix& mat, int n_lags) {
NumericMatrix vcov(n_lags + 1, n_lags + 1);
std::vector<double> preCalcs;
preCalcs.reserve(n_lags + 1);
int i, j, k1, k2, l;
int n = mat.nrow();
int m = mat.ncol();
for (i = 0; i <= n_lags; i++) {
preCalcs.push_back(0);
for (k1 = i, k2 = 0; k2 < (m - n_lags); k1++, k2++) {
for (l = 0; l < n; l++) {
preCalcs[i] += mat(l, k1) * mat(l, k2);
}
}
}
for (i = n_lags; i >= 0; i--) { ## reverse range
for (j = n_lags; j >= i; j--) { ## reverse range
vcov(i, j) = vcov(j, i) = preCalcs[j - i] / (n * (m - j) - 1);
if (i > 0 && i > 0) {
for (k1 = m - i, k2 = m - j; k2 <= (m - j); k1++, k2++) {
for (l = 0; l < n; l++) {
## updating preCalcs vector
preCalcs[j - i] += mat(l, k1) * mat(l, k2);
}
}
}
}
}
return vcov;
}
all.equal(compute_vcov(mat, n_lags), compute_vcov3(mat, n_lags))
[1] TRUE
Rcpp benchmarks only:
n_lags <- 50L
microbenchmark(RcppOrig = compute_vcov(mat, n_lags),
RcppModified = compute_vcov2(mat, n_lags),
RcppExtreme = compute_vcov3(mat, n_lags), times = 5)
Unit: milliseconds
expr min lq mean median uq max neval cld
RcppOrig 7035.7920 7069.7761 7083.4961 7070.3395 7119.028 7122.5446 5 c
RcppModified 3608.8986 3645.8585 3653.0029 3654.7209 3663.716 3691.8202 5 b
RcppExtreme 324.8252 330.7381 332.9657 333.5919 335.168 340.5054 5 a
The newest implementation is now over 20x faster than the original Rcpp version and well over 300x faster than the original algorithm when n-lags is large.
Just translating your code in Rcpp:
#include <Rcpp.h>
using namespace Rcpp;
// [[Rcpp::export]]
NumericMatrix compute_vcov(const NumericMatrix& mat, int n_lags) {
NumericMatrix vcov(n_lags + 1, n_lags + 1);
double myCov;
int i, j, k1, k2, l;
int n = mat.nrow();
int m = mat.ncol();
for (i = 0; i <= n_lags; i++) {
for (j = i; j <= n_lags; j++) {
myCov = 0;
for (k1 = j - i, k2 = 0; k2 < (m - j); k1++, k2++) {
for (l = 0; l < n; l++) {
myCov += mat(l, k1) * mat(l, k2);
}
}
myCov /= n * (m - j) - 1;
vcov(i, j) = vcov(j, i) = myCov;
}
}
return vcov;
}
This is at least 10 times as fast as the R algorithm.
Yet, I feel like it could be optimized further.
My reproducible R example:
f = runif(1500,10,50)
p = matrix(0, nrow=1250, ncol=250)
count = rep(0, 1250)
for(i in 1:1250) {
ref=f[i]
for(j in 1:250) {
p[i,j] = f[i + j - 1] / ref-1
if(p[i,j] == "NaN") {
count[i] = count[i]
}
else if(p[i,j] > (0.026)) {
count[i] = (count[i] + 1)
ref = f[i + j - 1]
}
}
}
To be more precise, I have a set of 600 f-series and this code runs 200 times for each f-series. Currently I am doing the iterations in loops and most of the operations are element-wise. My random variables are f, the condition if(p[i,j] > (0.026)), and the number 0.026 in itself.
One can drastically reduce the run-time by vectorizing my code and using functions, specifically the apply family, but I am rusty with apply and looking for some advice to proceed in the right direction.
It is quite easy to put for loops in Rcpp. I just copy-pasted your code to Rcpp and haven't checked the validity. In case of discrepancy, let me know. fCpp returns the list of p and c.
cppFunction('List fCpp(NumericVector f) {
const int n=1250;
const int k=250;
NumericMatrix p(n, k);
NumericVector c(n);
for(int i = 0; i < n; i++) {
double ref=f[i];
for(int j = 0; j < k; j++) {
p(i,j) = f[i+j+1]/ref-1;
if(p(i,j) == NAN){
c[i]=c[i];
}
else if(p(i,j) > 0.026){
c[i] = c[i]+1;
ref = f[i+j+1];
}
}
}
return List::create(p, c);
}')
Benchmark
set.seed(1)
f = runif(1500,10,50)
f1 <- function(f){
p = matrix(0, nrow=1250, ncol=250)
count = rep(0, 1250)
for(i in 1:1250) {
ref=f[i]
for(j in 1:250) {
p[i,j] = f[i + j - 1] / ref-1
if(p[i,j] == "NaN") {
count[i] = count[i]
}
else if(p[i,j] > (0.026)) {
count[i] = (count[i] + 1)
ref = f[i + j - 1]
}
}
}
list(p, count)
}
microbenchmark::microbenchmark(fCpp(f), f1(f), times=10L, unit="relative")
Unit: relative
expr min lq mean median uq max neval
fCpp(f) 1.0000 1.0000 1.0000 1.0000 1.0000 1.0000 10
f1(f) 785.8484 753.7044 734.4243 764.5883 718.0868 644.9022 10
Values returned by fCpp(f) and f1(f) are essentially identical, apart from column 1 of p matrix returned by f1 is filled with 0s.
system.time(a <- f1(f))[3]
#elapsed
# 2.8
system.time(a1 <- fCpp(f))[3]
#elapsed
# 0
all.equal( a[[1]], a1[[1]])
#[1] "Mean relative difference: 0.7019406"
all.equal( a[[2]], a1[[2]])
#[1] TRUE
Here is an implementation using while, although it is taking much longer than nested for loops which is a bit counter intuitive.
f1 <- function() {
n <- 1500
d <- 250
f = runif(n,1,5)
f = embed(f, d)
f = f[-(n-d+1),]
count = rep(0, n-d)
for(i in 1:(n-d)) {
tem <- f[i,]/f[i,1] - 1
ti <- which(t[-d] > 0.026)[1]
while(ti < d & !is.na(ti)) {
ti.plus = ti+1
tem[ti.plus:d] = f[i, ti.plus:d] / tem[ti]
count[i] = count[i] + 1
ti <- ti + which(tem[ti.plus:d-1] > 0.026)[1]
}
f[i] = tem
}
list(f, count)
}
system.time(f1())
#elapsed
#6.365
#ajmartin, your logic was better and reduced the number of iterations I was attempting. Here is the improved version of your code in R:
f1 <- function() {
n <- 1500
d <- 250
f = runif(n,1,5)
count = rep(0, n-d)
for(i in 1:(n-d)) {
tem <- f[i:(i+d-1)] / f[i] - 1
ind = which(tem>0.026)[1]
while(length(which(tem>0.026))){
count[i] = count[i] + 1
tem[ind:d] = f[ind:d] / tem[ind] - 1
ind = ind - 1 + (which(tem[ind:d] > 0.026)[1])
}
}
list(f, count)
}
system.time(f1())[3]
# elapsed
# 0.09
Implementing this in Rcpp will further reduce system-time but I can't install Rtools as my current machine does not have admin rights. Meanwhile this helps.