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.
虽然OP要求加速dplyr代码,但我想建议一个data.table解决方案,以提高性能.此外,迄今为止发布的其他答案中没有一个完全解决OP的要求,即
>使用开始,结束和v值列表保持sample_data的结构,
>将具有小于接近度(例如10)距离的所有线聚合成一条线.
以下代码尝试符合所有要求：
- 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
产生
06001
同
- result$v
06003
可以验证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)) )
