“平滑”时间数据 - 可以更有效地完成吗？答案

【问题标题】："smoothing" time data - can it be done more efficient?“平滑”时间数据 - 可以更有效地完成吗？
【发布时间】：2011-06-21 13:07:04
【问题描述】：

我有一个包含 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 的数据类型为“日期”，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))

【问题讨论】：

dput() 的输出更有用，因为我们需要对象是日期。

标签： function r datetime performance

【解决方案1】：

我建议的第一个 [没有真正考虑过您要做什么] 优化是为 theOutput 分配存储空间。目前，您在循环的每次迭代中都在增长theOutput。在 R 中，这是绝对的 no no！这是你永远不会做的事情，除非你喜欢非常慢的代码。 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 在 cmets 中提醒我的那样，还有 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

50% 加速。不是戏剧性的，但很容易通过在每次迭代中不增长一个对象来实现。

【讨论】：

感谢您的提示！事实上，输出可能有 1 到 nrow(theData) 行。但是，您对列是正确的。如果我用 nrow(theData) 初始化 theOutput，最后有没有办法摆脱空行？
@Marcel 是的，我刚刚发布的示例与此有关。其中，res1 和 res2 是相等的，除了行名。
@Dirk - 好点，我忘记了。我提到哈德利的教授并不是一种认可。我没用过，所以无法给出明智的意见。

【解决方案2】：

为了避免最后删除空行，我做了些许不同：

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
}

对我原来的版本有很大的改进！

【讨论】：

想给你点数:) 我想任何读过这个帖子的人（我猜不会有太多人）都可以向下滚动。
那么您非常客气，先生。
:-) 无论如何我都需要编写这个脚本——像你这样关心别人问题的人当然更亲切。另一件事：虽然这样的函数可以在 SQL 中实现，但过程实现（如这个 R 实现）要快得多。在这个例子中可以看到，编程范式对运行时效率有很大的影响

【解决方案3】：

Marcel，我想我只是想稍微改进一下你的代码。下面的版本大约快 30 倍（从 3 秒到 0.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 )

【讨论】：

哇，刚刚试了一下 - 这简直太棒了！不敢相信这仅仅是因为将[ ... ] 更改为[[ ... ]]。为什么会有这么大的不同？
提供速度提升的不是 [[ 更改 - 它是在循环之前提取列并将日期列强制为数字。从 data.frame 中提取元素需要相当多的开销。从日期向量中提取元素也有相当多的开销。加起来有很多（30 倍的差异）！