5

I have used combn() to find the overlap between two dates/times using lubridate package. But combn() is too slow to process the large dataset I am working on. I am trying to use comboGeneral() from RcppAlgos package but I can't get it to work. Any help would be appreciated. If you know any other package/function I should look at, please let me know too.

get_overlap <- function(.data, .id, .start, .end) {
  id <- .data[[.id]]
  int <- interval(.data[[.start]], .data[[.end]])
  names <- combn(id, 2, FUN = function(.) paste(., collapse = "-"))
  setNames(combn(int, 2, function(.) intersect(.[1], .[2])), names)
}

get_overlap(dat, "id", "start", "end")
# a-b a-c a-d a-e b-c b-d b-e c-d c-e d-e 
#  49   1   4  17  23  14  18  NA   2  NA

Here is my failed attempt using comboGeneral().

comboGeneral(dat$int, 2, FUN = function(.) intersect(.[1], .[2]))

# Output:
# [[1]]
# numeric(0)
# 
# [[2]]
# numeric(0)
# 
# [[3]]
# numeric(0)
# <omitted>

Here is the dataset:

dat <- structure(list(id = c("a", "b", "c", "d", "e"), start = structure(c(1623903457.7771, 
1623903447.7771, 1623903505.7771, 1623903406.7771, 1623903489.7771
), class = c("POSIXct", "POSIXt")), end = structure(c(1623903506.7771, 
1623903528.7771, 1623903543.7771, 1623903461.7771, 1623903507.7771
), class = c("POSIXct", "POSIXt"))), row.names = c(NA, -5L), class = c("tbl_df", 
"tbl", "data.frame"))

Update:

Thank you for all the great suggestions so far! I did some benchmarking using my inelegantly written functions. If you could help further improve it, that would be great. I will update this again based on feedback.

Note that comboIter is part of comboIter_vector in which I included a mechanism for extracting the values from the C++ object object. I wanted to find out the lean efficiency of comboIter().

# Unit: microseconds
#              expr       min        lq       mean    median         uq        max neval  cld
#             combn 36092.801 37000.251 40356.8080 37311.901 38112.1010 226049.201   100    d
#      comboGeneral 33744.301 34608.702 36756.3749 35099.851 38738.6010  49378.301   100   c 
#         comboIter   447.401   568.601   634.2019   580.901   606.0505   5866.501   100 a   
#  comboIter_vector 38037.201 38823.301 39919.0570 39108.952 39562.5505  49880.101   100   cd
#        data.table  7816.001  8007.201  8289.0060  8113.401  8230.5510  15489.201   100  b  
#           IRanges  6451.001  6806.751  7104.0659  6879.651  6994.9005  14415.301   100  b

Here is the code:

library(lubridate)
library(RcppAlgos)
library(data.table)
library(IRanges)

# combn
get_overlap_combn <- function(.data) {
  names <- combn(.data$id, 2, function(x) paste(x, collapse = "-"))
  setNames(combn(interval(.data$start, .data$end), 2, function(x) intersect(x[1], x[2])), names)
}

get_overlap_combn(dat)


# comboGeneral
get_overlap_cpp1 <- function(.data) {
  names <- unlist(comboGeneral(dat$id, 2,
                               FUN = function(x) paste(x, collapse = "-")))
  int <- interval(.data$start, .data$end)
  setNames(unlist(comboGeneral(seq_along(int), 2,
                               FUN = function(x) intersect(int[x[1]], int[x[2]]))), names)
}

get_overlap_cpp1(dat)


# comboIter
get_overlap_cpp2 <- function(.data) {
  int <- interval(.data$start, .data$end)
  comboIter(seq_along(int), 2,
            FUN = function(x) as.double(intersect(int[x[1]], int[x[2]])))
}

get_overlap_cpp2(dat)
# C++ object <000002c2b172ee90> of class 'ComboFUN' <000002c2b16fcc90>

# comboIter_vector
get_overlap_cpp3 <- function(.data) {
  int <- interval(.data$start, .data$end)
  obj_name <- comboIter(.data$id, 2,
                       FUN = function(x) paste(x, collapse = "-"))
  obj_int <- comboIter(seq_along(int), 2,
                       FUN = function(x) as.double(intersect(int[x[1]], int[x[2]])))

  obj_length <- obj_int$summary()$totalResults
  v <- vector("double", obj_length)
  name <- vector("character", obj_length)
  i <- 1

  while (i <= obj_length) {
    v[i] <- obj_int$nextIter()
    name[i] <- obj_name$nextIter()
    i <- i + 1
  }

  setNames(v, name)
}

get_overlap_cpp3(dat)


# data.table
get_overlap_dt <- function(.data) {
  data <- .data
  setDT(data)
  setkey(data, start, end)

  data <- foverlaps(data, data)[id != i.id]
  dup <- duplicated(t(apply(data[, c("id", "i.id")], 1, sort)))

  data <-
    data[dup
    ][, `:=`(
      overlap = as.double(intersect(interval(start, end), interval(i.start, i.end))),
      name = paste(id, i.id, sep = "-")
    )]
  setNames(data$overlap, data$name)
}

get_overlap_dt(dat)

get_overlap_iranges <- function(.data) {
  # setup the IRanges object
  ir <- IRanges(as.numeric(.data$start), as.numeric(.data$end), names = .data$id)
  
  # find which ids overlap with each other
  ovrlp <- findOverlaps(ir, drop.self = TRUE, drop.redundant = TRUE) 
  
  # store id indices for further use    
  hit1 <- queryHits(ovrlp)
  hit2 <- subjectHits(ovrlp)
  
  # width of overlaps between ids    
  widths <- width(pintersect(ir[hit1], ir[hit2])) - 1
  names(widths) <- paste(names(ir)[hit1], names(ir)[hit2], sep = "-")
  
  widths
}

get_overlap_iranges(dat)
Zaw
  • 1,434
  • 7
  • 15
  • 1
    `RcppAlgos` author here. The short answer is that the values from `lubridate` are being converted to a number and are being stripped of any additional classes. For a fix, you explicitly subset the `lubridate` object like so: `comboGeneral(seq_along(int), 2, FUN = function(x) intersect(int[x[1]], int[x[2]]))`. I must point out that when the `FUN` argument is employed, there is a massive speed penalty. This functionality is strictly for convenience. This is pointed out here: https://jwood000.github.io/RcppAlgos/articles/GeneralCombinatorics.html#user-defined-functions – Joseph Wood Jun 17 '21 at 04:57
  • Also of interest, in the `combn` solution, it appears that the final result is being converted to a number. – Joseph Wood Jun 17 '21 at 04:59
  • 1
    To actually address your question. Since your data is large, iterators could be useful here. You could do something like `overlap_iter <- comboIter(seq_along(int), 2, FUN = function(x) intersect(int[x[1]], int[x[2]]))` and iterate over a handful of combinations at a time using `overlap_iter$nextNIter(n)`. This will keep memory usage low. See more here: https://jwood000.github.io/RcppAlgos/articles/CombinatoricsIterators.html – Joseph Wood Jun 17 '21 at 05:08
  • Many thanks for the explanation @JosephWood . Very helpful! I was quite excited when I tested `comboIter()` but the performance turned out to be similar to `comboGeneral()` when I added the mechanism for extracting the vectors from the output. I probably didn't do it properly. I added an answer with some benchmarking. It would be great if you could give me some pointers. Thanks again. – Zaw Jun 17 '21 at 08:36
  • Oh, yes - I wanted the amount of overlap time as the final result, rather than the interval, for memory efficiency. – Zaw Jun 17 '21 at 08:46

2 Answers2

3

Maybe try data.table foverlaps function:

library(data.table)
setDT(dat)
setkey(dat, start, end)
foverlaps(dat, dat)[id != i.id]
det
  • 5,013
  • 1
  • 8
  • 16
  • Thank you. I inelegantly wrote a function with `foverlaps()` and added it to the benchmark in my answer. I am not familiar with `data.table`; if you could give some suggestion to improve the performance, that would be great. – Zaw Jun 17 '21 at 08:44
  • Although `IRanges` is slightly faster, I accepted @det 's answer because this approach is more aligned with my workflow. – Zaw Jun 22 '21 at 02:40
  • `https://cran.r-project.org/web/packages/data.table/vignettes/datatable-benchmarking.html` – det Jun 22 '21 at 08:07
  • i'm not exactly sure what you want to do in the function but it seems that it can be improved. – det Jun 22 '21 at 08:10
  • Thanks for the link! I guess I need learn more about data.table. – Zaw Jun 22 '21 at 10:17
2

Another alternative for working on intervals is the "IRanges" package:

library(IRanges)

# setup the IRanges object
ir = IRanges(as.numeric(dat$start), as.numeric(dat$end), names = dat$id)

# find which ids overlap with each other
ovrlp = findOverlaps(ir, drop.self = TRUE, drop.redundant = TRUE) 

# store id indices for further use    
hit1 = queryHits(ovrlp)
hit2 = subjectHits(ovrlp)

# width of overlaps between ids    
widths = width(pintersect(ir[hit1], ir[hit2])) - 1

# result    
data.frame(id1 = names(ir)[hit1], id2 = names(ir)[hit2], widths)
#  id1 id2 widths
#1   a   d      4
#2   a   b     49
#3   a   e     17
#4   a   c      1
#5   b   d     14
#6   b   e     18
#7   b   c     23
#8   c   e      2
alexis_laz
  • 12,884
  • 4
  • 27
  • 37
  • Thanks! I added IRanges to the benchmark and it is fast! Based on my current code, IRanges seems to be faster than data.table approach. – Zaw Jun 18 '21 at 07:44