This question already has answers here:
max and min functions that are similar to colMeans
(5 answers)
Closed 9 years ago.
What is the fastest way to obtain a vector consisting of the maximum value from each column of a matrix-like object? Is there a faster alternative to apply(A, 2, max) in base R?
?colSums says it is "equivalent to use of apply with FUN = sum with appropriate margins, but a lot faster". Unfortunately there seems to be no colMax. Or am I missing something?
You can write your own c++ function using Rcpp:
#include <Rcpp.h>
using namespace Rcpp;
// [[Rcpp::export]]
NumericVector colMaxRcpp(NumericMatrix X) {
int ncol = X.ncol();
Rcpp::NumericVector out(ncol);
for (int col = 0; col < ncol; col++){
out[col]=Rcpp::max(X(_, col));
}
return wrap(out);
}
Here some benchmarking:
A <- matrix(rnorm(1e6),ncol=10000)
apply.max <- function(A) apply(A, 2, max)
identical(colMaxRcpp(A),apply.max(A))
[1] TRUE
library(microbenchmark)
microbenchmark(colMaxRcpp(A),apply.max(A),times=1)
Unit: milliseconds
expr min lq median uq max neval
colMaxRcpp(A) 11.57765 11.57765 11.57765 11.57765 11.57765 1
apply.max(A) 79.66040 79.66040 79.66040 79.66040 79.66040 1
EDIT add benchmarking for a matrix 30*30. Rcpp is ate least 12 times faster.
A <- matrix(rnorm(30*30),ncol=30)
Unit: microseconds
expr min lq median uq max neval
colMaxRcpp(A) 13.274 14.033 15.1715 18.584 32.238 10
apply.max(A) 162.702 166.495 174.0805 189.251 1310.716 10
Related
As we learn from this answer, there's a substantial performance increase when using anyNA() over any(is.na()) to detect whether a vector has at least one NA element. This makes sense, as the algorithm of anyNA() stops after the first NA value it finds, whereas any(is.na()) has to first run over the entire vector with is.na().
By contrast, I want to know whether a vector has at least 1 non-NA value. This means that I'm looking for an implementation that would stop after the first encounter with a non-NA value. Yes, I can use any(!is.na()), but then I face the issue with having is.na() run over the entire vector first.
Is there a performant opposite equivalent to anyNA(), i.e., "anyNonNA()"?
I'm not aware of a native function that stops if it comes across a non-NA value, but we can write a simple one using Rcpp:
Rcpp::cppFunction("bool any_NonNA(NumericVector v) {
for(size_t i = 0; i < v.length(); i++) {
if(!(Rcpp::traits::is_na<REALSXP>(v[i]))) return true;
}
return false;
}")
This creates an R function called any_NonNA which does what we need. Let's test it on a large vector of 100,000 NA values:
test <- rep(NA, 1e5)
any_NonNA(test)
#> [1] FALSE
any(!is.na(test))
#> [1] FALSE
Now let's make the first element a non-NA:
test[1] <- 1
any_NonNA(test)
#> [1] TRUE
any(!is.na(test))
#> [1] TRUE
So it gives the correct result, but is it faster?
Certainly, in this example, since it should stop after the first element, it should be much quicker. This is indeed the case if we do a head-to-head comparison:
microbenchmark::microbenchmark(
baseR = any(!is.na(test)),
Rcpp = any_NonNA(test)
)
#> Unit: microseconds
#> expr min lq mean median uq max neval cld
#> baseR 275.1 525.0 670.948 533.05 568.7 13029.9 100 b
#> Rcpp 1.6 2.1 4.319 3.30 5.1 33.7 100 a
As expected, this is a couple of orders of magnitude faster. What about if our first non-NA value is mid-way through the vector?
test[1] <- NA
test[50000] <- 1
microbenchmark::microbenchmark(
baseR = any(!is.na(test)),
Rcpp = any_NonNA(test)
)
#> Unit: microseconds
#> expr min lq mean median uq max neval cld
#> baseR 332.1 579.35 810.948 597.95 624.40 12010.4 100 b
#> Rcpp 299.4 300.70 311.516 305.10 309.25 370.1 100 a
Still faster, but not by much.
If we put our non-NA value at the end we shouldn't see much difference:
test[50000] <- NA
test[100000] <- 1
microbenchmark::microbenchmark(
baseR = any(!is.na(test)),
Rcpp = any_NonNA(test)
)
#> Unit: microseconds
#> expr min lq mean median uq max neval cld
#> baseR 395.6 631.65 827.173 642.6 663.8 11357.0 100 a
#> Rcpp 596.3 602.25 608.011 605.8 612.6 632.6 100 a
So this does indeed look to be faster than the base R solution (at least for large vectors).
anyNA() seems to be a collaboration by google. I think to check wether there are any NA is far common than the opposite, thus justifying the existene of that "special" function.
Here my attemp for numeric only:
anyNonNA <- Rcpp::cppFunction(
'bool anyNonNA(NumericVector x){
for (double i:x) if (!Rcpp::NumericVector::is_na(i)) return TRUE;
return FALSE;}
')
var <- rep(NA_real_, 1e7)
any(!is.na(var)) #FALSE
anyNonNA(var) #FALSE
var[5e6] <- 0
any(!is.na(var)) #TRUE
anyNonNA(var) #TRUE
microbenchmark::microbenchmark(any(!is.na(var)))
#Unit: milliseconds
# expr min lq mean median uq max neval
# any(!is.na(var)) 41.1922 46.6087 55.57655 59.1408 61.87265 74.4424 100
microbenchmark::microbenchmark(anyNonNA(var))
#Unit: milliseconds
# expr min lq mean median uq max neval
# anyNonNA(var) 10.6333 10.71325 11.05704 10.8553 11.2082 14.871 100
I am struggling with translating this function into R using via vectorization technique:
Where all I have been able to do so far is this:
c <- matrix(1:9, 3)
z <- 1:3
sum(abs(outer(z, z,"-")) * c)/sum(c)
But I don't think its necessarily correct. I tried a for-loop version but that is too long and my answer is likely wrong anyway. Anyone keen on this? What am I missing (or doing wrong)? Any help would be appreciated.
Here's a double-loop version:
q =
function(z,c){
num = 0
for(i in 1:length(z)){
for(j in 1:length(z)){
num = num + abs(z[i]-z[j]) * c[i,j]
}
}
num/sum(c)
}
Here's your vectorised version, functionised:
q2 =
function(z,c){sum(c*abs(outer(z,z,'-')) /sum(c))}
Not a great difference in timing between them really for a small matrix:
> microbenchmark::microbenchmark(q(z,c), q2(z,c))
Unit: microseconds
expr min lq mean median uq max neval cld
q(z, c) 15.368 15.7505 16.59644 16.0225 16.6290 30.346 100 b
q2(z, c) 12.232 12.8885 13.79178 13.2225 13.6585 44.085 100 a
But for a larger test it's a big win:
> c2 = matrix(runif(100*100),100,100)
> z2 = runif(100)
> microbenchmark::microbenchmark(q(z2,c2), q2(z2,c2))
Unit: microseconds
expr min lq mean median uq max neval cld
q(z2, c2) 7437.031 7588.131 8046.92272 7794.927 8332.104 10729.799 100 b
q2(z2, c2) 74.742 78.647 94.20153 86.113 100.125 188.428 100 a
>
Numeric difference is within floating point tolerance:
> q(z2,c2) - q2(z2,c2)
[1] 6.661338e-16
So unless anyone has faster code, I'd stick with what you've got.
As perfectly explained by #Spacedman, your approach is very efficient, but if you still want to go faster you could try Rcpp :
library(Rcpp)
sourceCpp(code='
#include <Rcpp.h>
// [[Rcpp::export]]
double qRcpp(const Rcpp::NumericVector z, const Rcpp::NumericMatrix cm){
int zlen = z.length();
if(!(zlen == cm.nrow() && cm.nrow() == cm.ncol()))
Rcpp::stop("Invalid sizes");
double num = 0;
for(int i = 0 ; i < zlen ; i++){
for(int j = 0 ; j < zlen ; j++){
num = num + std::abs(z[i]-z[j]) * cm(i,j);
}
}
return num / Rcpp::sum(cm);
}
')
Benchmark :
c2 = matrix(runif(100*100),100,100)
z2 = runif(100)
microbenchmark::microbenchmark(q(z2,c2), q2(z2,c2),qRcpp(z2,c2))
# Unit: microseconds
# expr min lq mean median uq max neval
# q(z2, c2) 10273.035 10976.3050 11680.85554 11348.763 11765.2010 44115.632 100
# q2(z2, c2) 64.292 67.9455 80.56427 75.543 86.3565 244.019 100
# qRcpp(z2, c2) 21.042 21.9180 25.30515 24.256 26.8860 56.403 100
I am attempting to copy one vector to another using the following syntax:
data<-NULL
for( i in 1:nrow(line)){
data=append(data,line[i*4])
}
From what I have seen, the use of append in this way results in a lot of copying of data, which makes R very slow. What is the syntax for copying the 4th element of one array to another, given that the list you are copying from is of a given size?
Here are three methods with their benchmarks. You can see that preallocating the vector as in the method2 function is quite a bit faster, while the lapply method is middle, and your function is the slowest.
Of course, these are 1D vectors as opposed to arrays of n-D, but I would expected the benchmarks would be similar or even more pronounced.
method1 <- function(line) {
data<-NULL
for( i in 1:length(line)){
data=append(data,line[i])
}
}
method2 <- function(line) {
data <- vector(mode="numeric", length = length(line))
for (i in 1:length(line)) {
data[i] <- line[i]
}
}
library(microbenchmark)
r <- rnorm(1000)
microbenchmark(method2(r), unit="ms")
#> Unit: milliseconds
#> expr min lq mean median uq max neval
#> method2(r) 2.18085 2.279676 2.428731 2.371593 2.500495 5.24888 100
microbenchmark(lapply(r, function(x) { data<-append(data, x) }), unit="ms")
#> Unit: milliseconds
#> expr min lq
#> lapply(r, function(x) { data <- append(data, x) }) 3.014673 3.091299
#> mean median uq max neval
#> 3.287216 3.150052 3.260199 6.036501 100
microbenchmark(method1(r), unit="ms")
#> Unit: milliseconds
#> expr min lq mean median uq max neval
#> method1(r) 3.938684 3.978002 5.71831 4.020001 4.280521 98.58584 100
Didn't realize OP wanted only every fourth. Why not just use a data frame or data.table?
d <- data.frame(matrix(rnorm(1000), ncol=1))
microbenchmark(d2 <- d[seq(1,nrow(d), 4),])
#> Unit: microseconds
#> expr min lq mean median uq
#> d2 <- d[seq(1, nrow(d), 4), ] 64.846 65.9915 73.08007 67.225 73.8225
#> max neval
#> 220.438 100
library(data.table)
dt <- data.table(d)
microbenchmark(d2 <- dt[seq(1,nrow(d), 4),])
#> Unit: microseconds
#> expr min lq mean median uq
#> d2 <- dt[seq(1, nrow(d), 4), ] 298.163 315.2025 324.8793 320.554 330.416
#> max neval
#> 655.124 100
If you're trying to extract every fourth element from a vector, you could index using seq to grab the correct elements:
data <- letters[seq(4, length(letters), by=4)]
data
# [1] "d" "h" "l" "p" "t" "x"
Growing the vector one at a time as you show in your question will be slow because you will need to keep re-allocating your vector (see the second circle of The R Inferno for details). However, even pre-allocating your vector and constructing it with a for loop will be slow compared to constructing it in a single vectorized indexing operation.
To get a sense of the speed improvements, consider a comparison to the sort of method you've described, except using pre-allocation:
for.prealloc <- function(x) {
data <- vector(mode="numeric", length = floor(length(x)/4))
for (i in 1:floor(length(x)/4)) {
data[i] <- x[i*4]
}
data
}
josilber <- function(x) x[seq(4, length(x), by=4)]
r <- rnorm(10000)
all.equal(for.prealloc(r), josilber(r))
# [1] TRUE
library(microbenchmark)
microbenchmark(for.prealloc(r), josilber(r))
# Unit: microseconds
# expr min lq mean median uq max neval
# for.prealloc(r) 1846.014 2035.7890 2351.9681 2094.804 2244.56 5283.285 100
# josilber(r) 95.757 97.4125 125.9877 113.179 138.96 259.606 100
The approach I propose is 20x faster than using for and a pre-allocated vector (and it will be even faster than using append and a non-pre-allocated vector).
I'm trying to take cumulative sums for each column of a matrix. Here's my code in R:
testMatrix = matrix(1:65536, ncol=256);
microbenchmark(apply(testMatrix, 2, cumsum), times=100L);
Unit: milliseconds
expr min lq mean median uq max neval
apply(testMatrix, 2, cumsum) 1.599051 1.766112 2.329932 2.15326 2.221538 93.84911 10000
I used Rcpp for comparison:
cppFunction('NumericMatrix apply_cumsum_col(NumericMatrix m) {
for (int j = 0; j < m.ncol(); ++j) {
for (int i = 1; i < m.nrow(); ++i) {
m(i, j) += m(i - 1, j);
}
}
return m;
}');
microbenchmark(apply_cumsum_col(testMatrix), times=10000L);
Unit: microseconds
expr min lq mean median uq max neval
apply_cumsum_col(testMatrix) 205.833 257.719 309.9949 265.986 276.534 96398.93 10000
So the C++ code is 7.5 times as fast. Is it possible to do better than apply(testMatrix, 2, cumsum) in pure R? It feels like I have an order of magnitude overhead for no reason.
It is difficult to beat C++ with just R code. The fastest way I can think of doing it is if you are willing to split your matrix in to a list. That way, R is using primitive functions and doesn't copy the object with each iteration (apply is essentially a pretty loop). You can see that C++ still wins out but there is a significant speedup with the list approach if you really just want to use R code.
fun1 <- function(){
apply(testMatrix, 2, cumsum)
}
testList <- split(testMatrix, col(testMatrix))
fun2 <- function(){
lapply(testList, cumsum)
}
microbenchmark(fun1(),
fun2(),
apply_cumsum_col(testMatrix),
times=100L)
Unit: microseconds
expr min lq mean median uq max neval
fun1() 3298.534 3411.9910 4376.4544 3477.608 3699.2485 9249.919 100
fun2() 558.800 596.0605 766.2377 630.841 659.3015 5153.100 100
apply_cumsum_col(testMatrix) 219.651 282.8570 576.9958 311.562 339.5680 4915.290 100
EDIT
Please note that this method is slower than fun1 if you include the time to split the matrix in to a list.
Using a byte-compiled for loop is slightly faster than the apply call on my system. I expected it to be faster because it does less work than apply. As expected, the R loop is still slower than the simple C++ function you wrote.
colCumsum <- compiler::cmpfun(function(x) {
for (i in 1:ncol(x))
x[,i] <- cumsum(x[,i])
x
})
testMatrix <- matrix(1:65536, ncol=256)
m <- testMatrix
require(microbenchmark)
microbenchmark(colCumsum(m), apply_cumsum_col(m), apply(m, 2, cumsum), times=100L)
# Unit: microseconds
# expr min lq median uq max neval
# matrixCumsum(m) 1478.671 1540.5945 1586.1185 2199.9530 37377.114 100
# apply_cumsum_col(m) 178.214 192.4375 204.3905 234.8245 1616.030 100
# apply(m, 2, cumsum) 1879.850 1940.1615 1991.3125 2745.8975 4346.802 100
all.equal(colCumsum(m), apply(m, 2, cumsum))
# [1] TRUE
Maybe it is to late but I will write my answer so anyone else can see it.
First of all, in your C++ code you need to clone you matrix otherwise you are write into R's memory and it is forbiden by CRAN. So your code becomes:
rcpp_apply<-cppFunction('NumericMatrix apply_cumsum_col(NumericMatrix m) {
NumericMatrix g=clone(m);
for (int j = 0; j < m.ncol(); ++j) {
for (int i = 1; i < m.nrow(); ++i) {
g(i, j) += g(i - 1, j);
}
}
return g;
}');
Since your matrix is typeof integer then you can change your C++'s argument to be IntegerMatrix.
rcpp_apply_integer<-cppFunction('IntegerMatrix apply_cumsum_col(IntegerMatrix m) {
NumericMatrix g=clone(m);
for (int j = 0; j < m.ncol(); ++j) {
for (int i = 1; i < m.nrow(); ++i) {
g(i, j) += g(i - 1, j);
}
}
return g;
}');
This impoved the code about 2 times. Here is a benchmark:
microbenchmark::microbenchmark(R=apply(testMatrix, 2, cumsum),Rcpp=rcpp_apply(testMatrix),Rcpp_integer=rcpp_apply_integer(testMatrix), times=10)
Unit: microseconds
expr min lq mean median uq max neval
R 1552.217 1706.165 1770.1264 1740.0345 1897.884 1940.989 10
Rcpp 502.900 523.838 637.7188 665.0605 699.134 743.471 10
Rcpp_integer 220.455 274.645 274.9327 275.8770 277.930 316.109 10
all.equal(rcpp_apply(testMatrix),rcpp_apply_integer(testMatrix))
[1] TRUE
If your matrix has large values then you have to use NumericMatrix.
Is there an implementation of colMeans in R that includes an alpha trimmed mean parameter?
If not, how could I make one?
The original question has been answered in the comments below.
apply(x, 2, mean, trim=.05) is not as optimized as colMeans;
what is an implementation of equal efficiency?
Here are some examples of different ways to calculate trimmed colMeans, with a comparison of their performance.
m <- matrix(runif(1000000), nc=1000)
trim <- 0.1
Using apply:
out1 <- apply(m, 2, mean, trim=trim)
Using sapply:
out2 <- sapply(seq_len(ncol(m)), function(i) mean(m[, i], trim=trim))
Using Rcpp:
library(inline)
library(RcppArmadillo)
f <- 'using namespace arma;
mat x = sort(as<mat>(x_));
double trim = as<double>(trim_);
int low;
if(x.n_rows % 2 == 1) {
low = ceil(trim * x.n_rows) - 1;
} else {
low = ceil(trim * x.n_rows);
}
int high = ceil((1 - trim) * x.n_rows) - 1;
return(wrap(mean(x.rows(low, high))));'
trim.colMeans <- cxxfunction(signature(x_='matrix', trim_='numeric'),
f, plugin="RcppArmadillo")
out3 <- trim.colMeans(m, trim)
Comparison
identical(out1, out2)
[1] TRUE
identical(out1, c(out3))
[1] TRUE
library(microbenchmark)
microbenchmark(apply=apply(m, 2, mean, trim=trim),
sapply=sapply(seq_len(ncol(m)), function(i) mean(m[, i], trim=trim)),
Rcpp=trim.colMeans(m, trim),
colMeans=colMeans(m))
Unit: microseconds
expr min lq median uq max neval
apply 68907.162 100439.4775 102555.396 109044.4025 136034.067 100
sapply 64675.928 66383.6010 66937.615 68152.1115 98680.906 100
Rcpp 43614.629 44297.6980 44761.360 45164.4850 46883.602 100
colMeans 782.458 805.7995 828.538 988.4625 1452.877 100
I'm sure my Rcpp implementation is sub-optimal, so feel free to chime in with improvements. As you can see, none of these methods is as efficient as an untrimmed calculation of colMeans, yet I suspect equivalent efficiency is impossible, since additional calculations must be made, including sorting and subsetting of the matrix. This penalty for trimming data is evident when benchmarking the mean of a vector vs. the trimmed counterpart:
v <- runif(1000)
microbenchmark(mean(v), mean(v, trim=0.1))
Unit: microseconds
expr min lq median uq max neval
mean(v) 5.722 6.325 6.927 7.229 124.989 100
mean(v, trim = 0.1) 42.165 43.671 44.574 44.876 84.630 100