r - data.table : how to improve performance 中的扩展窗口(累积计算)

Question

我对在不同时间步长收集的数据进行了分组。在每个时间步内，有几个值的注册。每个值可能在时间步长内和时间步长之间出现一次或多次。

一些玩具数据:

df <- data.frame(grp = rep(1:2, each = 8),
                 time = c(rep(1, 3), rep(2, 2), rep(3, 3)),
                 val = c(1, 2, 1,  2, 3,  2, 3, 4,  1, 2, 3,  1, 1,  1, 2, 3))

df
#    grp time val
# 1    1    1   1
# 2    1    1   2
# 3    1    1   1
# 4    1    2   2
# 5    1    2   3
# 6    1    3   2
# 7    1    3   3
# 8    1    3   4
# 9    2    1   1
# 10   2    1   2
# 11   2    1   3
# 12   2    2   1
# 13   2    2   1
# 14   2    3   1
# 15   2    3   2
# 16   2    3   3

目标

我希望在扩展的时间窗口内进行一些计算，即在时间步长 1 内，在时间 1 和 2 内，在 1、2 和 3 内，等等。在每个窗口中，我希望计算唯一值的数量、出现多次的值的数量以及出现多次的值的比例。

例如，在我的玩具数据中，在组 (grp) 1 中，在第二个时间窗口(时间 = 1 和 2 一起)中注册了三个唯一值(val 1、2、3)(n_val = 3)。其中两个 (1, 2) 出现不止一次 (n_re = 2)，导致“re_rate”为 0.67(见下文)。

我的 data.table 代码产生了想要的结果。在小数据集上它比我的 base 慢考虑到 data.table 代码中的一些可能的开销，我认为这是足够公平的尝试。有了更大的数据集， data.table代码 catch 了，但仍然较慢。我期望(希望)好处会更早出现。

因此，让我发布这个问题的原因是我相信 我的代码的相对性能是我滥用数据的有力指标。表 (我确定原因不是 data.table 性能本身)。因此，我的问题的主要目的是在 上获得一些建议。如何以更像 data.table 的方式对此进行编码 .例如，是否可以通过对计算进行矢量化来完全避免时间窗口上的循环，如图所示。在@Khashaa here 的好回答中.如果没有，有没有办法使循环和分配更有效？

我的 data.table代码:

library(data.table)

f_dt <- function(df){
  setDT(df, key = c("grp", "time", "val"))[ , {
  # key or not only affects speed marginally

    # unique time steps
    times <- .SD[ , unique(time)]

    # index vector to loop over
    idx <- seq_along(times)

    # pre-allocate data table
    d2 <- data.table(time = times,
                     n_val = integer(1),
                     n_re = integer(1),
                     re_rate = numeric(1))

    # loop to generate expanding window
    for(i in idx){

      # number of registrations per val
      n <- .SD[time %in% times[seq_len(i)], .(n = .N), by = val][ , n]

      # number of unique val
      set(x = d2, i = i, j = 2L, length(n))

      # number of val registered more than once
      set(x = d2, i = i, j = 3L, sum(n > 1))
    }
    # proportion values registered more than once
    d2[ , re_rate := round(n_re / n_val, 2)]
    d2
  }
  , by = grp]
}

...这给出了预期的结果:

f_dt(df)

#    grp time n_val n_re re_rate
# 1:   1    1     2    1    0.50
# 2:   1    2     3    2    0.67
# 3:   1    3     4    3    0.75
# 4:   2    1     3    0    0.00
# 5:   2    2     3    1    0.33
# 6:   2    3     3    3    1.00

通讯录 base代码:

f_by <- function(df){
  do.call(rbind,
          by(data = df, df$grp, function(d){

            times <- unique(d$time)
            idx <- seq_along(times)
            d2 <- data.frame(grp = d$grp[1],
                             time = times,
                             n_val = integer(1),
                             n_re = integer(1),
                             re_rate = numeric(1))

            for(i in idx){

              dat <- d[d$time %in% times[seq_len(i)], ]
              tt <- table(dat$val)
              n_re <- sum(tt > 1)
              n_val <- length(tt)
              re_rate <- round(n_re / n_val, 2)

              d2[i, ] <- data.frame(d2$grp[1], time = times[i], n_val, n_re, re_rate)
            }
            d2
          })
  )
}

时间:

上面的小玩具数据:

library(microbenchmark)
microbenchmark(f_by(df),
               f_dt(df),
               times = 10,
               unit = "relative")

# Unit: relative
#     expr      min       lq     mean   median       uq      max neval
# f_by(df) 1.000000 1.000000 1.000000 1.000000 1.000000 1.000000    10
# f_dt(df) 1.481724 1.450203 1.474037 1.452887 1.521378 1.502686    10

一些更大的数据:

set.seed(123)
df <- data.frame(grp = sample(1:100, 100000, replace = TRUE),
                 time = sample(1:100, 100000, replace = TRUE),
                 val = sample(1:100, 100000, replace = TRUE))

microbenchmark(f_by(df),
               f_dt(df),
               times = 10,
               unit = "relative")

# Unit: relative
#     expr      min       lq     mean   median       uq      max neval
# f_by(df) 1.000000 1.000000 1.000000 1.000000 1.000000 1.000000    10
# f_dt(df) 1.094424 1.099642 1.107821 1.096997 1.097693 1.194983    10

不，数据仍然不大，但我希望 data.table 现在能 catch 。如果编码正确......我相信这表明我的代码有很大的改进潜力。任何建议都非常感谢。

Answer 1

f <- function(df){
  setDT(df)[, n_val := cumsum(!duplicated(val)), grp
   ][, occ := 1:.N, .(grp, val)
     ][, occ1 := cumsum(occ == 1) - cumsum(occ == 2), grp
       ][, n_re := n_val - occ1,
         ][, re_rate := round(n_re/n_val, 2),
           ][, .(n_val = n_val[.N], n_re = n_re[.N], re_rate =re_rate[.N]), .(grp, time)]
}

在哪里

cumsum(!duplicated(val))计算唯一值的(累积)出现次数，n_val ,

occ计算每个值的累积出现次数(请注意，它按 val 分组)。

occ1然后计算 val 中的元素数到目前为止只发生过一次。
当 occ==1 时，仅出现一次的值数增加 1 , 当 occ==2 时减 1 ;因此 cumsum(occ == 1) - cumsum(occ == 2) .

多次出现的值的数量是 n_val-occ1

速度对比

set.seed(123)
df <- data.frame(grp = sample(1:100, 100000, replace = TRUE),
                 time = sample(1:100, 100000, replace = TRUE),
                 val = sample(1:100, 100000, replace = TRUE))


system.time(f(df))
# user  system elapsed 
# 0.038   0.000   0.038 

system.time(f_dt(df))
# user  system elapsed 
# 16.617   0.013  16.727

system.time(f_by(df))
# user  system elapsed 
# 16.077   0.040  16.122 

希望这可以帮助。