I want to apply a function to progressive subsets of a vector in R. I have looked at what i could find, and the apply and friends aren't quite there, and rollapply does not work on straight vectors, only zoo/ts objects.
vapply <- function(x, n, FUN=sd) {
v <- c(rep(NA, length(x)))
for (i in n:length(x) ) {
v[i] <- FUN(x[(i-n+1):i])
}
return(v)
}
Is there something built in that is equivalent? Is there a better way to do it? I am trying to avoid dependencies on 3rd party libraries as I the code needs to be standalone for distribution.
With your choice of function name, I just HAD to make a version that actually uses vapply internally :)
...it turns out to be about 50% faster in the example below. But that of course depends a lot on how much work is done in FUN...
# Your original version - renamed...
slideapply.org <- function(x, n, FUN=sd) {
v <- c(rep(NA, length(x)))
for (i in n:length(x) ) {
v[i] <- FUN(x[(i-n+1):i])
}
return(v)
}
slideapply <- function(x, n, FUN=sd, result=numeric(1)) {
stopifnot(length(x) >= n)
FUN <- match.fun(FUN)
nm1 <- n-1L
y <- vapply(n:length(x), function(i) FUN(x[(i-nm1):i]), result)
c(rep(NA, nm1), y) # Why do you want NA in the first entries?
}
x <- 1:2e5+0 # A double vector...
system.time( a <- slideapply.org(x, 50, sum) ) # 1.25 seconds
system.time( b <- slideapply(x, 50, sum) ) # 0.80 seconds
identical(a, b) # TRUE
Related
So, I'm trying to write a function that builds a large complicated formula recursively. Basically, what I would love to work simply, is the following:
f <- function(x) {
g <- function(y) y
for( i in 1:4 ) {
h <- g
g <- function(y) h(y)^2
}
g(x)
}
Please refrain from laughing at this insane motivation. Now what I would like to get, is a function that returns ((((x^2)^2)^2)^2), but what actually happens is that my runtime just crashes immediately, probably because there's some sort of call to an unreferenced function or something, since I'm overwriting the expression for g every time (obviously I don't really know how r works in this scenario).
How can I achieve this idea of retaining the information from the older g references?
1) Recursion We can use recursion like this:
h1 <- function(f, n) if (n == 1) f else function(x) f(h1(f, n-1)(x))
# test using g from questioun
h1(g, 4)(3)
## [1] 43046721
(((3^2)^2)^2)^2
## [1] 43046721
2) Reduce This uses Reduce to compose a function f with itself iteratively n times.
h2 <- function(f, n) function(y) Reduce(function(x, f) f(x), rep(list(f), n), y)
h2(g, 4)(3)
## [1] 43046721
3) for
h3 <- function(f, n) {
function(x) {
for(i in 1:n) x <- f(x)
x
}
}
h3(g, 4)(3)
## [1] 43046721
4) Fixed If there are a small fixed number we could just write it out
explicitly:
h4 <- function(x) g(g(g(g(x))))
h4(3)
## [1] 43046721
5) Compose We could slightly simplify any of the above using Compose from the functional package. (The purrr package also has a compose function. Use that if you are already using purrr; otherwise, functional has a smaller footprint.)
library(functional)
h1a <- function(f, n) if (n == 1) f else Compose(f, h(f, n-1))
h2a <- function(f, n) Reduce(Compose, rep(list(f), n))
h2b <- function(f, n) do.call(Compose, rep(list(f), n))
h3a <- function(f, n) {
for(i in 1:n) ff <- if (i == 1) f else Compose(ff, f)
ff
}
h4a <- Compose(g, g, g, g)
I want to optimize the implementation of this formula.
Here is the formula:
x is an array of values. i goes from 1 to N where N > 2400000.
For i=0, i-1 is the last element and for i=lastElement, i+1 is the first element. Here is the code which I have written:
x <- 1:2400000
re <- array(data=NA, dim = NROW(x))
lastIndex = NROW(x)
for(i in 1:lastIndex){
if (i==1) {
re[i] = x[i]*x[i] - x[lastIndex]*x[i+1]
} else if(i==lastIndex) {
re[i] = x[i]*x[i] - x[i-1]*x[1]
} else {
re[i] = x[i]*x[i] - x[i-1]*x[i+1]
}
}
Can it be done by apply in R?
We can use direct vectorization for this
# Make fake data
x <- 1:10
n <- length(x)
# create vectors for the plus/minus indices
xminus1 <- c(x[n], x[-n])
xplus1 <- c(x[-1], x[1])
# Use direct vectorization to get re
re <- x^2 - xminus1*xplus1
If really each x[i] is equal to i then you can do a little math:
xi^2 - (xi-1)*(xi+1) = 1
so all elements of the result are 1 (only the first and the last are not 1).
The result is:
c(1-2*N, rep(1, N-2), N*N-(N-1))
In the general case (arbitrary values in x) you can do (as in the answer from Dason):
x*x - c(x[N], x[-N])*c(x[-1], x[1])
Here is a solution with rollapply() from zoo:
library("zoo")
rollapply(c(x[length(x)],x, x[1]), width=3, function(x) x[2]^2 - x[1]*x[3]) # or:
rollapply(c(tail(x,1), x, x[1]), width=3, function(x) x[2]^2 - x[1]*x[3])
Here is the benchmark:
library("microbenchmark")
library("zoo")
N <- 10000
x <- 1:N
microbenchmark(
math=c(1-2*N, rep(1, N-2), N*N-(N-1)), # for the data from the question
vect.i=x*x - c(x[N], x[-N])*c(x[-1], x[1]), # general data
roll.i=rollapply(c(x[length(x)],x, x[1]), width=3, function(x) x[2]^2 - x[1]*x[3]), # or:
roll.tail=rollapply(c(tail(x,1), x, x[1]), width=3, function(x) x[2]^2 - x[1]*x[3])
)
# Unit: microseconds
# expr min lq mean median uq max neval cld
# math 33.613 34.4950 76.18809 36.9130 38.0355 2002.152 100 a
# vect.i 188.928 192.5315 732.50725 197.1955 198.5245 51649.652 100 a
# roll.i 56748.920 62217.2550 67666.66315 68195.5085 71214.9785 109195.049 100 b
# roll.tail 57661.835 63855.7060 68815.91001 67315.5425 71339.6045 119428.718 100 b
An lapply implementation of your formula would look like this:
x <- c(1:2400000)
last <- length(x)
re <- lapply(x, function(i) {
if(i == 1) {
x[i]*x[i] - x[last]*x[i+1]
} else if (i == last) {
x[i]*x[i] - x[i-1]*x[1]
} else {
x[i]*x[i] - x[i-1]*x[i+1]
}
})
re <- unlist(re)
lapply will return a list, so conversion to a vector is done using unlist()
1) You can avoid all the special-casing in the computation by padding the start and end of array x with copies of the last and first rows; something like this:
N <- NROW(x)
x <- rbind(x[N], x, x[1]) # pad start and end to give wraparound
re <- lapply(2:N, function(i) { x[i]*x[i] - x[i-1]*x[i+1] } )
#re <- unlist(re) as andbov wrote
# and remember not to use all of x, just x[2:N], elsewhere
2) Directly vectorize, as #Dason's answer:
# Do the padding trick on x , then
x[2:N]^2 - x[1:N-1]*x[3:N+1]
3) If performance matters, I suspect using data.table or else for-loop on i will be faster, since it references three consecutive rows.
4) For more performance, use byte-compiling
5) If you need even more speed, use Rcpp extension (C++ under the hood) How to use Rcpp to speed up a for loop?
See those questions I cited for good examples of using lineprof and microbenchmarking to figure out where your bottleneck is.
I have a matrix of size 10000 x 100 and a vector of length 100. I'd like to apply a custom function, percentile, which takes in a vector argument and a scalar argument, to each column of the matrix such that on iteration j, the arguments used with percentile are column j of the matrix and entry j of the vector. Is there a way to use one of the apply functions to do this?
Here's my code. It runs, but doesn't return the correct result.
percentile <- function(x, v){
length(x[x <= v]) / length(x)
}
X <- matrix(runif(10000 * 100), nrow = 10000, ncol = 100)
y <- runif(100)
result <- apply(X, 2, percentile, v = y)
The workaround that I've been using has been to just append y to X, and re-write the percentile function, as shown below.
X <- rbind(X, y)
percentile2 <- function(x){
v <- x[length(x)]
x <- x[-length(x)]
length(x[x <= v]) / length(x)
}
result <- apply(X, 2, percentile2)
This code does return the correct result, but I would prefer something a bit more elegant.
If you understand that R is vectorised and know the right functions you can avoid loops entirely, and do the whole thing in one relatively simple line...
colSums( t( t( X ) <= y ) ) / nrow( X )
Through vectorisation R will recycle each element in y across each column of X (by default it will do this across the rows, so we use the transpose function t to turn the columns to rows, apply the logical comparison <= and then transpose back again.
Since TRUE and FALSE evaluate to 1 and 0 respectively we can use colSums to effectively get the number of rows in each column which met the condition and then divde each column by the total number of rows (remember the recycling rule!). It is the exact same result....
res1 <- apply(X2, 2, percentile2)
res2 <- colSums( t( t( X ) <= y ) ) / nrow( X )
identical( res1 , res2 )
[1] TRUE
Obviously as this doesn't use any R loops it's a lot quicker (~10 times on this small matrix).
Even better would be to use rowMeans like this (thanks to #flodel):
rowMeans( t(X) <= y )
I think the easiest and clearest way is to use a for loop:
result2 <- numeric(ncol(X))
for (i in seq_len(ncol(X))) {
result2[i] <- sum(X[,i] <= y[i])
}
result2 <- result2 / nrow(X)
the fastest and shortest solution I can think of is:
result1 <- rowSums(t(X) <= y) / nrow(X)
SimonO101 has an explanation in his answer how this works. As I said, it is fast. However, the disadvantage is that it is less clear what exactly is calculated here, although you could solve this by placing this piece of code in a well-named function.
flodel also suggester a solution using mapply which is an apply that can work on multiple vectors. However, for that to work you first need to put each of your columns or your matrix in a list or data.frame:
result3 <- mapply(percentile, as.data.frame(X), y)
Speed wise (see below for some benchmarking) the for-loop doesn't do that bad and it's faster than using apply (in this case at least). The trick with rowSums and vector recycling is faster, over 10 times as fast as the solution using apply.
> X <- matrix(rnorm(10000 * 100), nrow = 10000, ncol = 100)
> y <- runif(100)
>
> system.time({result1 <- rowSums(t(X) <= y) / nrow(X)})
user system elapsed
0.020 0.000 0.018
>
> system.time({
+ X2 <- rbind(X, y)
+ percentile2 <- function(x){
+ v <- x[length(x)]
+ x <- x[-length(x)]
+ length(x[x <= v]) / length(x)
+ }
+ result <- apply(X2, 2, percentile2)
+ })
user system elapsed
0.252 0.000 0.249
>
>
> system.time({
+ result2 <- numeric(ncol(X))
+ for (i in seq_len(ncol(X))) {
+ result2[i] <- sum(X[,i] <= y[i])
+ }
+ result2 <- result2 / nrow(X)
+ })
user system elapsed
0.024 0.000 0.024
>
> system.time({
+ result3 <- mapply(percentile, as.data.frame(X), y)
+ })
user system elapsed
0.076 0.000 0.073
>
> all(result2 == result1)
[1] TRUE
> all(result2 == result)
[1] TRUE
> all(result3 == result)
[1] TRUE
The problem with my R script is that it takes too much time and the main solution that I consider is to parallelize it. I don't know where to start.
My code look like this:
n<- nrow (aa)
output <- matrix (0, n, n)
akl<- function (dii){
ddi<- as.matrix (dii)
m<- rowMeans(ddi)
M<- mean(ddi)
r<- sweep (ddi, 1, m)
b<- sweep (r, 2, m)
return (b + M)
}
for (i in 1:n)
{
A<- akl(dist(aa[i,]))
dVarX <- sqrt(mean (A * A))
for (j in i:n)
{
B<- akl(dist(aa[j,]))
V <- sqrt (dVarX * (sqrt(mean(B * B))))
output[i,j] <- (sqrt(mean(A * B))) / V
}
}
I would like to parallelize on different cpus. How can I do that?
I saw the SNOW package, is it suitable for my purpose?
Thank you for suggestions,
Gab
There are two ways in which your code could be made to run faster that I could think of:
First: As #Dwin was saying (with a small twist), you could precompute akl (yes, not necesarily dist, but the whole of akl).
# a random square matrix
aa <- matrix(runif(100), ncol=10)
n <- nrow(aa)
output <- matrix (0, n, n)
akl <- function(dii) {
ddi <- as.matrix(dii)
m <- rowMeans(ddi)
M <- mean(m) # mean(ddi) == mean(m)
r <- sweep(ddi, 1, m)
b <- sweep(r, 2, m)
return(b + M)
}
# precompute akl here
require(plyr)
akl.list <- llply(1:nrow(aa), function(i) {
akl(dist(aa[i, ]))
})
# Now, apply your function, but index the list instead of computing everytime
for (i in 1:n) {
A <- akl.list[[i]]
dVarX <- sqrt(mean(A * A))
for (j in i:n) {
B <- akl.list[[j]]
V <- sqrt (dVarX * (sqrt(mean(B * B))))
output[i,j] <- (sqrt(mean(A * B))) / V
}
}
This should already get your code to run faster than before (as you compute akl everytime in the inner loop) on larger matrices.
Second: In addition to that, you can get it faster by parallelising as follows:
# now, the parallelisation you require can be achieved as follows
# with the help of `plyr` and `doMC`.
# First step of parallelisation is to compute akl in parallel
require(plyr)
require(doMC)
registerDoMC(10) # 10 Cores/CPUs
akl.list <- llply(1:nrow(aa), function(i) {
akl(dist(aa[i, ]))
}, .parallel = TRUE)
# then, you could write your for-loop using plyr again as follows
output <- laply(1:n, function(i) {
A <- akl.list[[i]]
dVarX <- sqrt(mean(A * A))
t <- laply(i:n, function(j) {
B <- akl.list[[j]]
V <- sqrt(dVarX * (sqrt(mean(B*B))))
sqrt(mean(A * B))/V
})
c(rep(0, n-length(t)), t)
}, .parallel = TRUE)
Note that I have added .parallel = TRUE only on the outer loop. This is because, you assign 10 processors to the outer loop. Now, if you add it to both outer and inner loops, then the total number of processers will be 10 * 10 = 100. Please take care of this.
I want to use arms() to get one sample each time and make a loop like the following one in my function. It runs very slowly. How could I make it run faster? Thanks.
library(HI)
dmat <- matrix(0, nrow=100,ncol=30)
system.time(
for (d in 1:100){
for (j in 1:30){
y <- rep(0, 101)
for (i in 2:100){
y[i] <- arms(0.3, function(x) (3.5+0.000001*d*j*y[i-1])*log(x)-x,
function(x) (x>1e-4)*(x<20), 1)
}
dmat[d, j] <- sum(y)
}
}
)
This is a version based on Tommy's answer but avoiding all loops:
library(multicore) # or library(parallel) in 2.14.x
set.seed(42)
m = 100
n = 30
system.time({
arms.C <- getNativeSymbolInfo("arms")$address
bounds <- 0.3 + convex.bounds(0.3, dir = 1, function(x) (x>1e-4)*(x<20))
if (diff(bounds) < 1e-07) stop("pointless!")
# create the vector of z values
zval <- 0.00001 * rep(seq.int(n), m) * rep(seq.int(m), each = n)
# apply the inner function to each grid point and return the matrix
dmat <- matrix(unlist(mclapply(zval, function(z)
sum(unlist(lapply(seq.int(100), function(i)
.Call(arms.C, bounds, function(x) (3.5 + z * i) * log(x) - x,
0.3, 1L, parent.frame())
)))
)), m, byrow=TRUE)
})
On a multicore machine this will be really fast since it spreads the loads across cores. On a single-core machine (or for poor Windows users) you can replace mclapply above with lapply and get only a slight speedup compared to Tommy's answer. But note that the result will be different for parallel versions since it will use different RNG sequences.
Note that any C code that needs to evaluate R functions will be inherently slow (because interpreted code is slow). I have added the arms.C just to remove all R->C overhead to make moli happy ;), but it doesn't make any difference.
You could squeeze out a few more milliseconds by using column-major processing (the question code was row-major which requires re-copying as R matrices are always column-major).
Edit: I noticed that moli changed the question slightly since Tommy answered - so instead of the sum(...) part you have to use a loop since y[i] are dependent, so the function(z) would look like
function(z) { y <- 0
for (i in seq.int(99))
y <- y + .Call(arms.C, bounds, function(x) (3.5 + z * y) * log(x) - x,
0.3, 1L, parent.frame())
y }
Well, one effective way is to get rid of the overhead inside arms. It does some checks and calls the indFunc every time even though the result is always the same in your case.
Some other evaluations can be also be done outside the loop. These optimizations bring down the time from 54 secs to around 6.3 secs on my machine. ...and the answer is identical.
set.seed(42)
#dmat2 <- ##RUN ORIGINAL CODE HERE##
# Now try this:
set.seed(42)
dmat <- matrix(0, nrow=100,ncol=30)
system.time({
e <- new.env()
bounds <- 0.3 + convex.bounds(0.3, dir = 1, function(x) (x>1e-4)*(x<20))
f <- function(x) (3.5+z*i)*log(x)-x
if (diff(bounds) < 1e-07) stop("pointless!")
for (d in seq_len(nrow(dmat))) {
for (j in seq_len(ncol(dmat))) {
y <- 0
z <- 0.00001*d*j
for (i in 1:100) {
y <- y + .Call("arms", bounds, f, 0.3, 1L, e)
}
dmat[d, j] <- y
}
}
})
all.equal(dmat, dmat2) # TRUE
why not like this?
dat <- expand.grid(d=1:10, j=1:3, i=1:10)
arms.func <- function(vec) {
require(HI)
dji <- vec[1]*vec[2]*vec[3]
arms.out <- arms(0.3,
function(x,params) (3.5 + 0.00001*params)*log(x) - x,
function(x,params) (x>1e-4)*(x<20),
n.sample=1,
params=dji)
return(arms.out)
}
dat$arms <- apply(dat,1,arms.func)
library(plyr)
out <- ddply(dat,.(d,j),summarise, arms=sum(arms))
matrix(out$arms,nrow=length(unique(out$d)),ncol=length(unique(out$j)))
However, its still single core and time consuming. But that isn't R being slow, its the arms function.