Rolling min without replacement - r

Question

Given a vector (vec) and a window size of 5,
winsz <- 5L
vec <- c(9, 3, 10, 5, 6, 2, 4, 8, 7, 1)
Is there a faster way to calculate rolling minimum without replacement?
Rolling min w/o replacement: Using vec as an example and window size of 5.
In the first pass, the min is extracted from first 5 elements (9, 3, 10, 5, 6). Min is 3 in the first pass.
In the 2nd pass, the min is extracted from 4 elements left over from the first pass (9, 10, 5, 6) and the new windowed element (2). Min is 2 in the second pass.
In the 3rd pass, the min is extracted from elements left over from the previous pass (9, 10, 5, 6) and the new windowed element (4). Min is 4 in the third pass. So on and so forth.
The result from the example is
[1] 3 2 4 5 6 1 7 8 9 10
Please kindly exclude Rcpp implementation for now.
Current implementation and timing code:
#rolling min without replacement
set.seed(0L)
N <- 10e5
winsz <- 5L
vec <- sample(N)
mtd0 <- compiler::cmpfun(function(x) {
subx <- x[seq_len(winsz)]
n <- 1L
drawn <- rep(NA_integer_, length(x))
while (n <= length(x)-winsz) {
idx <- which.min(subx)
drawn[n] <- subx[idx]
subx[idx] <- x[n+winsz]
n <- n + 1
}
drawn[tail(seq_along(drawn), winsz)] <- sort(subx)
drawn
})
library(microbenchmark)
microbenchmark(mtd0(vec), times=3L)
Around 8s for a window size of 5 and vector of length 1e6.

Answer 1

Not sure how this is going to clock in but here is another option
f <- function(x, window = 5) {
ret <- numeric(length = length(x))
i <- 1L
while (length(x) > 0) {
idx.min <- which.min(x[1:window])
ret[i] <- x[idx.min]
x <- x[-idx.min]
i <- i + 1
}
return(ret)
}
f(vec)
# [1] 3 2 4 5 6 1 7 8 9 10
Or
f2 <- function(x, window = 5) {
ret <- numeric(length = length(x))
i <- 1L
while (i <= length(x)) {
idx.min <- which.min(x[1:(window + i - 1)])
ret[i] <- x[idx.min]
x[idx.min] <- NA
i <- i + 1
}
return(ret)
}
On a side note...
Kudos for the numeric(length = length(x)) part goes to #RonakShah; it's interesting that numeric(length = length(x)) is much faster than rep(0, length(x)) (which is what I wrote originally;-)
res <- microbenchmark(
rep = rep(0, 10^6),
numeric = numeric(length = 10^6)
)
#Unit: microseconds
# expr min lq mean median uq max neval cld
# rep 1392.582 2549.219 3682.897 2694.137 3098.073 14726.81 100 a
# numeric 424.257 1592.110 2902.232 1727.431 2174.159 11747.87 100 a

Answer 2

Timings so far:
#rolling min without replacement
set.seed(0L)
N <- 10e4
winsz <- 5L
vec <- sample(N)
f <- compiler::cmpfun(function(x, window = 5) {
ret <- numeric(length = length(x))
i <- 1L
while (length(x) > 0) {
idx.min <- which.min(x[1:window])
ret[i] <- x[idx.min]
x <- x[-idx.min]
i <- i + 1
}
return(ret)
})
mtd0 <- compiler::cmpfun(function(x) {
subx <- x[seq_len(winsz)]
n <- 1L
drawn <- rep(NA_integer_, length(x))
while (n <= length(x)-winsz) {
idx <- which.min(subx)
drawn[n] <- subx[idx]
subx[idx] <- x[n+winsz]
n <- n + 1
}
drawn[tail(seq_along(drawn), winsz)] <- sort(subx)
drawn
})
mtd1 <- compiler::cmpfun(function(x) {
res <- Reduce(function(ans, s) {
v <- ans$students
idx <- which.min(v)
list(students=c(v[-idx], s), drawn=v[idx])
},
x=as.list(x[seq_along(x)[-seq_len(winsz)]]),
init=list(students=x[seq_len(winsz)], drawn=NULL),
accumulate=TRUE)
c(unlist(lapply(res, `[[`, "drawn")), sort(res[[length(res)]]$students))
})
#all.equal(f(vec), mtd0(vec))
# [1] TRUE
#all.equal(mtd0(vec), mtd1(vec))
# [1] TRUE
library(microbenchmark)
microbenchmark(f(vec), mtd0(vec), mtd1(vec), times=3L)
timings:
Unit: milliseconds
expr min lq mean median uq max neval cld
f(vec) 16234.97047 16272.00705 16457.05138 16309.04363 16568.092 16827.1400 3 b
mtd0(vec) 75.18676 83.34443 96.03222 91.50209 106.455 121.4078 3 a
mtd1(vec) 301.56747 342.36437 427.33052 383.16127 490.212 597.2628 3 a