在R中的范围列表中查找值列表

我有两个数据帧：

set.seed（123）
myData您可以尝试：

myData$newColumn = lapply(myData$pos, 
                 function(x) {paste(refData$id[abs(refData$pos-x)<3],collapse=', ')})

希望这有帮助
 另一个选择是

myData$newColumn <- sapply(myData$pos, function(x) paste(refData$id[refData$pos >= x-2 & refData$pos <= x+2], collapse = ", "))

myData$newColumn=x-2&refData$pos您当前的问题有两个主要瓶颈：1）计算
nrow（myData）*nrow（refData）
，2）通过连接
refData$id
创建可能较大的字符向量

为了克服第一个问题，一种方法（因为
myData$pos
是/可以排序的）是使用
findInterval
定位每个
refData$pos
相对于
myData$pos
+/-允许的距离（此处为2）的范围。通过这种方式，计算复杂度降低到
nrow（refData）*log（nrow（myData））
甚至更低

要保存一些键入内容，请执行以下操作：

a = myData$pos
b = refData$pos 

首先，我们需要找到
a+2
的间隔，其中每个
b
都可以找到：

i = findInterval(b, a + 2L, all.inside = TRUE, left.open = TRUE)
#> i
# [1] 1 9 1 9 9 1 1 8 1 1 7 1 9 9 9

我们将间隔指定为
（下，上）
，并避免超出
1:（长度（a）-1）
范围，因此我们可以轻松计算
b
距离
a
2个单位的第一个指数：

i1 = ifelse(abs(b - a[i + 1L]) <= 2, i + 1L, NA)
i2 = ifelse(abs(b - a[i]) <= 2, i, NA)
ii = pmin(i1, i2, na.rm = TRUE)
#> ii
# [1] NA NA  1 NA NA NA  1  9  1  1  8  1 10 NA NA

现在，我们只剩下
myData$pos
（
a
）的第一个（
ii
）和最后一个（
jj
）索引的位置，其中每个
refData$pos
（
b
）位于+/-2个单位之外（缺失的值表示不匹配）

克服第二个瓶颈的一种方法是，如果我们能够利用上述格式继续下去，就可以从整体上避免第二个瓶颈

尽管如此，为了进一步将匹配表示为串联的
refData$id
s，我们可以从这里开始利用
IRanges
包，希望得到一些有效的东西：

library(IRanges)
nr = 1:nrow(myData)
myrng = IRanges(nr, nr)
refrng = IRanges(ifelse(is.na(ii), 0L, ii), ifelse(is.na(jj), 0L, jj))  ## replace NA with 0
ovrs = findOverlaps(myrng, refrng)
tapply(refData$id[subjectHits(ovrs)], factor(queryHits(ovrs), nr), toString)
#              1               2               3               4               5 
#"c, g, i, j, l"    "c, g, i, j"       "c, g, i"          "g, i"             "g" 
#              6               7               8               9              10 
#             NA              NA             "k"          "h, k"       "h, k, m" 

您是否尝试过将for循环重新设计成可以与lappy、purr或类似于mcapply的可并行化的东西？谢谢您的回答。不，我还没有尝试过，但我现在会考虑一下！我会让您知道这是否对我有效！感谢您提供的友好且简单的代码！我一定会尝试并报告结果运行时间。我还将尝试按照RoberMc的建议在mclapply中使用您的想法。我使用您的解决方案，但使用McApp（6核）。它仍然运行了4个多小时，但这是迄今为止最好的结果。再次感谢您和RobertMc！感谢您的建议和良好的比较！首先，感谢您提供了详细的答案。对于我的最小示例，这很好，但如果我像这样扩展示例，它会给出错误的结果：myData@lWei当前位置我终于找到了有时间再次检查并编辑这篇文章。现在，它似乎对您的原始示例和评论中的示例都有效。希望对您有所帮助。
set.seed(123)
myData<-data.frame(id=1:1000, pos=sample(21:30, 1000, replace = T))
refData<-data.frame(id=sample(letters[1:15], 1000, replace = T), pos=sample(10:40, 1000, replace = T))

myData$newColumn<-rep(NA, nrow(myData))

library(microbenchmark)
microbenchmark(for(i in 1:nrow(myData)){
  ww<-which(abs(refData$pos - myData$pos[i]) <=  2)
  myData$newColumn[i]<-paste(refData[ww, "id"],collapse=", ")
},
myData$newColumn2 <- sapply(myData$pos, function(x) paste(refData$id[refData$pos >= x-2 & refData$pos <= x+2], collapse = ", ")),
myData$newColumn3 <- lapply(myData$pos, function(x) paste(refData$id[abs(refData$pos - x) <  3], collapse = ", ")))

Unit: milliseconds

    expr
 for (i in 1:nrow(myData)) {     ww <- which(abs(refData$pos - myData$pos[i]) <= 2)     myData$newColumn[i] <- paste(refData[ww, "id"], collapse = ", ") }
                 myData$newColumn2 <- sapply(myData$pos, function(x) paste(refData$id[refData$pos >=      x - 2 & refData$pos <= x + 2], collapse = ", "))
                                    myData$newColumn3 <- lapply(myData$pos, function(x) paste(refData$id[abs(refData$pos -      x) < 3], collapse = ", "))
      min       lq     mean   median       uq       max neval cld
 62.97657 64.74155 70.01541 68.81024 71.02023 206.80477   100   c
 46.55872 47.90585 50.75397 50.42333 53.42990  58.01813   100  b 
 36.69362 37.34244 39.70480 38.54905 42.49614  46.27513   100 a  

a = myData$pos
b = refData$pos 

i = findInterval(b, a + 2L, all.inside = TRUE, left.open = TRUE)
#> i
# [1] 1 9 1 9 9 1 1 8 1 1 7 1 9 9 9

i1 = ifelse(abs(b - a[i + 1L]) <= 2, i + 1L, NA)
i2 = ifelse(abs(b - a[i]) <= 2, i, NA)
ii = pmin(i1, i2, na.rm = TRUE)
#> ii
# [1] NA NA  1 NA NA NA  1  9  1  1  8  1 10 NA NA

j = findInterval(b, a - 2L, all.inside = TRUE, left.open = FALSE)
j1 = ifelse(abs(b - a[j + 1L]) <= 2, j + 1L, NA)
j2 = ifelse(abs(b - a[j]) <= 2, j, NA)
jj = pmax(j1, j2, na.rm = TRUE)
#> jj
# [1] NA NA  3 NA NA NA  5 10  4  2 10  1 10 NA NA

library(IRanges)
nr = 1:nrow(myData)
myrng = IRanges(nr, nr)
refrng = IRanges(ifelse(is.na(ii), 0L, ii), ifelse(is.na(jj), 0L, jj))  ## replace NA with 0
ovrs = findOverlaps(myrng, refrng)
tapply(refData$id[subjectHits(ovrs)], factor(queryHits(ovrs), nr), toString)
#              1               2               3               4               5 
#"c, g, i, j, l"    "c, g, i, j"       "c, g, i"          "g, i"             "g" 
#              6               7               8               9              10 
#             NA              NA             "k"          "h, k"       "h, k, m"