我有一个包含ID，开始日期和结束日期的数据框。我的数据按ID，开始，结束（按此顺序）排序。
现在我希望所有具有相同ID的行具有重叠的时间跨度（或者具有在另一行的结束日期之后的第二天的开始日期）才能合并在一起。
合并它们意味着它们最终排成一行，具有相同的ID，最小值（开始日期）和最大值（结束日期）（我希望你理解我的意思）。
我已经为此编写了一个函数（它没有经过全面测试，但目前看起来还不错）。问题是，由于我的数据框有近100.000个观测值，因此功能非常慢。
你能帮助我提高效率吗？
这是函数
smoothingEpisodes <- function (theData) {
theOutput <- data.frame()
curId <- theData[1, "ID"]
curStart <- theData[1, "START"]
curEnd <- theData[1, "END"]
for(i in 2:nrow(theData)) {
nextId <- theData[i, "ID"]
nextStart <- theData[i, "START"]
nextEnd <- theData[i, "END"]
if (curId != nextId | (curEnd + 1) < nextStart) {
theOutput <- rbind(theOutput, data.frame("ID" = curId, "START" = curStart, "END" = curEnd))
curId <- nextId
curStart <- nextStart
curEnd <- nextEnd
} else {
curEnd <- max(curEnd, nextEnd, na.rm = TRUE)
}
}
theOutput <- rbind(theOutput, data.frame("ID" = curId, "START" = curStart, "END" = curEnd))
theOutput
}
谢谢！
[编辑]
测试数据：
ID START END
1 1 2000-01-01 2000-03-31
2 1 2000-04-01 2000-05-31
3 1 2000-04-15 2000-07-31
4 1 2000-09-01 2000-10-31
5 2 2000-01-15 2000-03-31
6 2 2000-02-01 2000-03-15
7 2 2000-04-01 2000-04-15
8 3 2000-06-01 2000-06-15
9 3 2000-07-01 2000-07-15
（START和END的数据类型为“Date”，ID为数字）
数据的输入：
structure(list(ID = c(1L, 1L, 1L, 1L, 2L, 2L, 2L, 3L, 3L), START = structure(c(10957,
11048, 11062, 11201, 10971, 10988, 11048, 11109, 11139), class = "Date"),
END = structure(c(11047, 11108, 11169, 11261, 11047, 11031,
11062, 11123, 11153), class = "Date")), .Names = c("ID",
"START", "END"), class = "data.frame", row.names = c(NA, 9L))
答案 0 :(得分：2)
第一个[没有真正考虑到你想要做的事情]我建议的优化是为theOutput分配存储空间。目前，您在循环的每次迭代中都在增长theOutput。在R中这绝对是不是否 !!这是你永远不会做的事情，除非你喜欢糟糕的代码。 R必须复制对象并在每次迭代期间展开它，这很慢。
查看代码，我们知道theOutput需要有nrow(theData) - 1行和3列。所以在循环开始之前创建它：
theOutput <- data.frame(matrix(ncol = 3, nrow = nrow(theData) - 1))
然后在循环期间填写此对象：
theOutput[i, ] <- data.frame("ID" = curId, "START" = curStart, "END" = curEnd))
例如。
目前尚不清楚START和END是什么？如果这些是数字，那么使用矩阵而不是数据框也可以提高速度效率。
此外，每次迭代创建数据帧都会很慢。我不能花费很多时间来计算时间，但你可以直接填写你想要的位，而不会在每次迭代期间招致data.frame()调用：
theOutput[i, "ID"] <- curId
theOutput[i, "START"] <- curStart
theOutput[i, "END"] <- curEnd
然而，我能给你的最好的提示是分析你的代码。查看瓶颈所在并加快这些瓶颈。在较小的数据子集上运行您的函数;其大小足以为您提供一些运行时来收集有用的分析数据，而无需等待很长时间才能完成分析运行。要在R中进行分析，请使用Rprof()：
Rprof(filename = "my_fun_profile.Rprof")
## run your function call here on a subset of the data
Rprof(NULL)
您可以使用
查看输出summaryRprof("my_fun_profile.Rprof")
Hadley Wickham（@hadley）有一个方案可以让这个更容易一些。它被称为profr。正如Dirk在评论中提醒我的那样，还有Luke Tierney的proftools包。
编辑，因为OP提供了一些测试数据，我快速敲了一下，通过遵循良好的循环练习来显示速度提升：
smoothingEpisodes2 <- function (theData) {
curId <- theData[1, "ID"]
curStart <- theData[1, "START"]
curEnd <- theData[1, "END"]
nr <- nrow(theData)
out1 <- integer(length = nr)
out2 <- out3 <- numeric(length = nr)
for(i in 2:nrow(theData)) {
nextId <- theData[i, "ID"]
nextStart <- theData[i, "START"]
nextEnd <- theData[i, "END"]
if (curId != nextId | (curEnd + 1) < nextStart) {
out1[i-1] <- curId
out2[i-1] <- curStart
out3[i-1] <- curEnd
curId <- nextId
curStart <- nextStart
curEnd <- nextEnd
} else {
curEnd <- max(curEnd, nextEnd, na.rm = TRUE)
}
}
out1[i] <- curId
out2[i] <- curStart
out3[i] <- curEnd
theOutput <- data.frame(ID = out1,
START = as.Date(out2, origin = "1970-01-01"),
END = as.Date(out3, origin = "1970-01-01"))
## drop empty
theOutput <- theOutput[-which(theOutput$ID == 0), ]
theOutput
}
使用对象testData中提供的测试数据集，我得到：
> res1 <- smoothingEpisodes(testData)
> system.time(replicate(100, smoothingEpisodes(testData)))
user system elapsed
1.091 0.000 1.131
> res2 <- smoothingEpisodes2(testData)
> system.time(replicate(100, smoothingEpisodes2(testData)))
user system elapsed
0.506 0.004 0.517
答案 1 :(得分：1)
我做的略有不同，以避免最后删除空行：
smoothingEpisodes <- function (theData) {
curId <- theData[1, "ID"]
curStart <- theData[1, "START"]
curEnd <- theData[1, "END"]
theLength <- nrow(theData)
out.1 <- integer(length = theLength)
out.2 <- out.3 <- numeric(length = theLength)
j <- 1
for(i in 2:nrow(theData)) {
nextId <- theData[i, "ID"]
nextStart <- theData[i, "START"]
nextEnd <- theData[i, "END"]
if (curId != nextId | (curEnd + 1) < nextStart) {
out.1[j] <- curId
out.2[j] <- curStart
out.3[j] <- curEnd
j <- j + 1
curId <- nextId
curStart <- nextStart
curEnd <- nextEnd
} else {
curEnd <- max(curEnd, nextEnd, na.rm = TRUE)
}
}
out.1[j] <- curId
out.2[j] <- curStart
out.3[j] <- curEnd
theOutput <- data.frame(ID = out.1[1:j], START = as.Date(out.2[1:j], origin = "1970-01-01"), END = as.Date(out.3[1:j], origin = "1970-01-01"))
theOutput
}
对我的原始版本有很大改进！
答案 2 :(得分：1)
作为旁注，我尝试在适用的地方使用[[，并尝试通过编写j <- j + 1L等将整数保持为整数。这在这里没有任何区别，但有时在整数和双打可能需要一段时间。
smoothingEpisodes3 <- function (theData) {
theLength <- nrow(theData)
if (theLength < 2L) return(theData)
id <- as.integer(theData[["ID"]])
start <- as.numeric(theData[["START"]])
end <- as.numeric(theData[["END"]])
curId <- id[[1L]]
curStart <- start[[1L]]
curEnd <- end[[1L]]
out.1 <- integer(length = theLength)
out.2 <- out.3 <- numeric(length = theLength)
j <- 1L
for(i in 2:nrow(theData)) {
nextId <- id[[i]]
nextStart <- start[[i]]
nextEnd <- end[[i]]
if (curId != nextId | (curEnd + 1) < nextStart) {
out.1[[j]] <- curId
out.2[[j]] <- curStart
out.3[[j]] <- curEnd
j <- j + 1L
curId <- nextId
curStart <- nextStart
curEnd <- nextEnd
} else {
curEnd <- max(curEnd, nextEnd, na.rm = TRUE)
}
}
out.1[[j]] <- curId
out.2[[j]] <- curStart
out.3[[j]] <- curEnd
theOutput <- data.frame(ID = out.1[1:j], START = as.Date(out.2[1:j], origin = "1970-01-01"), END = as.Date(out.3[1:j], origin = "1970-01-01"))
theOutput
}
然后，以下代码将显示速度差异。我刚拿走你的数据并将其复制了1000次......
x <- structure(list(ID = c(1L, 1L, 1L, 1L, 2L, 2L, 2L, 3L, 3L), START = structure(c(10957,
11048, 11062, 11201, 10971, 10988, 11048, 11109, 11139), class = "Date"),
END = structure(c(11047, 11108, 11169, 11261, 11047, 11031,
11062, 11123, 11153), class = "Date")), .Names = c("ID",
"START", "END"), class = "data.frame", row.names = c(NA, 9L))
r <- 1000
y <- data.frame(ID=rep(x$ID, r) + rep(1:r, each=nrow(x))-1, START=rep(x$START, r), END=rep(x$END, r))
system.time( a1 <- smoothingEpisodes(y) ) # 2.95 seconds
system.time( a2 <- smoothingEpisodes3(y) ) # 0.10 seconds
all.equal( a1, a2 )