加速简单的R代码（矢量化？）

Question

I have two positive integer vectors specifying start and end "positions" of ranges

starts <- sample(10^6,replace = T)
ends <- starts+sample(100:1000,length(starts),replace=T)

So these specify 1000000 ranges that are 100 to 1000 units long. Now I want to know how many times a position (positive integer) is "covered" by a range. For this I do:

coverage <- integer(max(ends))
for(i in seq(length(starts))) {
      coverage[starts[i]:ends[i]] <- coverage[starts[i]:ends[i]] + 1 
}

But because of the for loop, it's relatively slow. For billions of ranges, it can take a very long time. I cannot find a way to vectorize this code. I could split the work and use multiple CPUs, but the speed gain would be marginal. apply, lapply and other meta-functions do not improve speed (as expected). For instance

coverage <- tabulate(unlist(Map(':', starts,ends)))

is also slow because of the "Map" part. I fear it also takes more memory.

Any ideas?

Answer 1

You could keep a count of ranges that start and end at any specific index and then apply a cumulative sum over the difference of these.

1. Aggregate the number of ranges that start at each index
2. Aggregate the number of ranges that end at one position before each index (if ends are inclusive)
3. Calculate the net change: count of starts - count of ends
4. Loop over indexes and sum up the net changes cumulatively. This will give the number ranges that started earlier than this index and not ended yet at this index.

The "covered" number is equal to this cumulative sum at each index.

I tried this approach using sparse vectors to cut down on memory usage. Although it may be faster with normal vectors, not sure. With sparseVector it was 5.7x faster than the loop approach for the given example.

library(Matrix)

set.seed(123)

starts <- sample(10^6,replace = T)
ends <- starts+sample(100:1000,length(starts),replace=T)

v.cov <- NULL
fun1 <- function() {
  coverage <- integer(max(ends))
  for(i in seq(length(starts))) {
    coverage[starts[i]:ends[i]] <- coverage[starts[i]:ends[i]] + 1 
  }
  v.cov <<- coverage
}
# Testing "for loop" approach
system.time(fun1())
# user  system elapsed 
# 21.84    0.00   21.83 

v.sum <- NULL
fun2 <- function() {      
  # 1. Aggregate the number of ranges that start at each index
  t.starts <- table(starts)
  i.starts <- strtoi(names(t.starts))
  x.starts <- as.vector(t.starts)
  sv.starts <- sparseVector(x=x.starts, i=i.starts, length=max(ends)+1)  # to match length of sv.ends below
  # 2. Aggregate the number of ranges that end at one position before each index
  t.ends <- table(ends)
  i.ends <- strtoi(names(t.ends))+1  # because "ends" are inclusive 
  x.ends <- as.vector(t.ends)
  sv.ends <- sparseVector(x=x.ends, i=i.ends, length=max(ends)+1)

  sv.diff <- sv.starts - sv.ends
  v.sum <<- cumsum(sv.diff)[1:max(ends)]  # drop last element
}
# Testing "cumulative sum" approach
system.time(fun2())
# user  system elapsed 
# 3.828   0.000   3.823

identical(v.cov, v.sum)
# TRUE

Also, there is probably a better way to extract x's and i's for sparseVector constructor than using table and strtoi(names(x)) that may boost speed further.

EDIT

Avoid strtoi using a 1-column sparseMatrix instead

v.sum.mat <- NULL
fun3 <- function() {
  v.ones <- rep(1, length(starts))
  m.starts <- sparseMatrix(i=starts, j=v.ones, x=v.ones, dims=c(max(ends)+1,1))
  m.ends <- sparseMatrix(i=ends+1, j=v.ones, x=v.ones, dims=c(max(ends)+1,1))
  m.diff <- m.starts - m.ends
  v.sum.mat <<- cumsum(m.diff[,1])[1:max(ends)]
}
# Testing "cumulative sum" approach using matrix
system.time(fun3())
#   user  system elapsed 
#  0.456   0.028   0.486 

identical(v.cov, v.sum.mat)
# TRUE

EDIT 2 - super fast, super short

Based on comment by @alexis_laz, thank you!

fun4 <- function() {
  cumsum(tabulate(starts, max(ends) + 1L) - tabulate(ends + 1L, max(ends) + 1L))[1:max(ends)]
}
system.time(v.sum.tab <- fun4())
# user  system elapsed 
# 0.040   0.000   0.041 

identical(as.integer(v.cov), v.sum.tab)
# TRUE