有效地找到 R 中两个时间间隔之间的重叠

Question

我使用combn() 来查找使用lubridate package 的两个日期/时间之间的重叠。但是combn() 太slow 无法处理我正在处理的大型数据集。我正在尝试使用来自RcppAlgos 包的comboGeneral()，但我无法让它工作。任何帮助，将不胜感激。如果您知道我应该查看的任何其他包/功能，请也告诉我。

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 

这是我使用 comboGeneral() 失败的尝试。

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

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

这是数据集：

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"))

更新：

感谢您迄今为止提出的所有重要建议！我使用我写得不好的函数做了一些基准测试。如果你能帮助进一步改进它，那就太好了。我会根据反馈再次更新。

请注意，comboIter 是comboIter_vector 的一部分，其中我包含了一种从C++ object 对象中提取值的机制。我想了解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  

代码如下：

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)

Answer 1

也许试试data.tablefoverlaps函数：

library(data.table)
setDT(dat)
setkey(dat, start, end)
foverlaps(dat, dat)[id != i.id]

Answer 2

另一种处理间隔的方法是“IRanges”包：

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