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

编程问答 2022-04-23

问题描述

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

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,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,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
),"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,function(x) paste(x,collapse = "-"))
  setNames(combn(interval(.data$start,.data$end),function(x) intersect(x[1],x[2])),names)
}

get_overlap_combn(dat)


# comboGeneral
get_overlap_cpp1 <- function(.data) {
  names <- unlist(comboGeneral(dat$id,FUN = function(x) paste(x,collapse = "-")))
  int <- interval(.data$start,.data$end)
  setNames(unlist(comboGeneral(seq_along(int),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),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,collapse = "-"))
  obj_int <- comboIter(seq_along(int),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)

解决方法

也许试试 data.table foverlaps 函数：

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

处理间隔的另一种选择是“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
combnlubridaterr