需要帮助加速dplyr聚合

tl.dr.我有一个聚合问题,我之前没有在文档中看到过.我设法完成它,但它对于预期的应用程序来说太慢了.我通常使用的数据有大约500行(我的直觉告诉我这对于dplyr来说并不多)并且根据system.time它运行大约4秒.我的困境是我想反复进行优化运行,目前我正在考虑运行时间.

你有没有看到我可以刮胡子的东西？

如果需要,我也可以发送一些我使用的数据.

算法
我有一个数据集：

sample_dataset <- data_frame( starts = c(1000,1008,1017,2000,2020,3000),ends   = c(1009,1015,1020,2015,2030,3010),v = list(rep(1,10),rep(2,8),rep(3,4),rep(4,16),rep(5,11),rep(6,11)) )

所以每一行都编码一个信号和一个开始和结束索引.我想将所有具有小于接近度(例如10)距离的线聚合成一条线.如果重要,开始订购.

输出应该是：

structure(list(inds = 1:3,starts = c(1000,ends = c(1020,v = list(c(1,1,3,2,3),c(4,4,5,5),c(6,6,6))),class = c("tbl_df","tbl","data.frame"
),row.names = c(NA,-3L),.Names = c("inds","starts","ends","v"))

因此,原始数据集中的前三行是聚合的,第4行和第5行是聚合的,6是未更改的.对于重叠,应该添加数字,填充空白零.更新的开始值是第一次开始,更新的结束应该是最后的结束(假设我应该将其修复到最大值).但顺便说一下这些生成结束也应该排序.不应发生一个块完全被另一个块包围的情况.

我通过以下代码实现了这一点：

码

library(dplyr)

join_lines <- function(dfi) {
  if (nrow(dfi)==1) return(select(dfi,starts,ends,v))
  else 
    with(dfi,{ 
             start <- starts[[1]]
             end <- ends[[length(ends)]]
             vals <- numeric(end-start+1)
             add_val <- function(ddf)
               with(ddf,{ 
                      vals[(starts-start+1) : (ends-start+1)] <<- 
                        vals[(starts-start+1) : (ends-start+1)] + v })
             dfi %>% rowwise() %>% do(tmp=add_val(.))
             data_frame(starts=start,ends=end,v=list(vals))})
}

simplify_semisparse <- function(aframe,closeness = 10){
  aframe %>% 
    mutate( join_pre = lag(ends,default=0)+closeness >= (starts),inds = cumsum(!join_pre)
           ) %>%
  group_by(inds) %>% do(join_lines(.)) %>% ungroup()
}    

res <- simplify_semisparse(sample_dataset)

dput(res) # see above

背景

我正在处理的数据来自质谱.非常特殊的是,矢量有大约500,000个条目,其中不到10％不是零,典型的光谱有大约500个这样的密集区块.我需要快速插入这样的光谱值 – 我的想法是在“密集”区域中使用约.

比较建议

我有机会比较你的建议.

@ matt-jewett解决方案产生的结果与我的预期结果不一致,所以我确实排除了它.

@jeremycgs解决方案最接近我原来的方法,但也没有产生完全相同的结果.

最重要的是我的运行时,我正在使用生产数据进行比较.我的原始解决方案需要2.165秒. @tjeremy的建议耗时0.532秒,@ uwe-block 0.012秒.

哇 – 我需要学习data.table.

library(data.table)   # CRAN versio 1.10.4 used
# define threshold: closeness as defined by OP,max_gap used in code 
closeness <- 10L
max_gap <- closeness - 1L
# coerce to data.table,and key,i.e.,sort by starts and ends
DT <- data.table(sample_dataset,key = c("starts","ends"))
# compute gaps between ends and starts of next row
# identify rows which belong together: inds is advanced if gap is greater threshhold
DT[,gap := starts - shift(ends,fill = -Inf)][,inds := cumsum(gap > max_gap)][]
# close gaps but only within groups
DT0 <- DT[between(gap,2L,max_gap),.(starts = starts - (gap - 1L),ends = starts - 1L,v = Vectorize(rep.int)(0L,gap - 1L),gap,inds)]
# bind rowwise (union in SQL),setkey on result to maintain sort order,# remove column gap as no longer needed
DT2 <- setkey(rbind(DT,DT0),ends)[,gap := NULL][]
# aggregate groupwise,pick min/max,combine lists
result <- DT2[,.(starts = min(starts),ends = max(ends),v = list(Reduce(c,v))),by = inds]
# alternative code: pick first/last
result <- DT2[,.(starts = first(starts),ends = last(ends),by = inds]
result

result$v

# test that all v values are included
# original
sum(lengths(sample_dataset$v))
#[1] 60
# result with additional zeros removed
sum(sapply(result$v,function(x) sum(x > 0)))
#[1] 60

sample_dataset <- dplyr::data_frame( starts = c(1000,11)) )