时间间隔不均匀的组的滚动总和

Rolling sums for groups with uneven time gaps

这是对我的 的调整。这是我的数据:

set.seed(3737)
DF2 = data.frame(user_id = c(rep(27, 7), rep(11, 7)),
            date = as.Date(rep(c('2016-01-01', '2016-01-03', '2016-01-05', '2016-01-07', '2016-01-10', '2016-01-14', '2016-01-16'), 2)),
            value = round(rnorm(14, 15, 5), 1))

 user_id  date        value
 27       2016-01-01  15.0
 27       2016-01-03  22.4
 27       2016-01-05  13.3
 27       2016-01-07  21.9
 27       2016-01-10  20.6
 27       2016-01-14  18.6
 27       2016-01-16  16.4
 11       2016-01-01   6.8
 11       2016-01-03  21.3
 11       2016-01-05  19.8
 11       2016-01-07  22.0
 11       2016-01-10  19.4
 11       2016-01-14  17.5
 11       2016-01-16  19.3

这次,我想为指定时间段内的每个user_id计算一个value的累计和';例如最后 7、14 天。理想的解决方案如下所示:

 user_id  date        value    v_minus7 v_minus14
 27       2016-01-01  15.0     15.0      15.0
 27       2016-01-03  22.4     37.4      37.4
 27       2016-01-05  13.3     50.7      50.7
 27       2016-01-07  21.9     72.6      72.6
 27       2016-01-10  20.6     78.2      93.2
 27       2016-01-14  18.6     61.1     111.8
 27       2016-01-16  16.4     55.6     113.2
 11       2016-01-01   6.8      6.8       6.8
 11       2016-01-03  21.3     28.1      28.1
 11       2016-01-05  19.8     47.9      47.9
 11       2016-01-07  22.0     69.9      69.9
 11       2016-01-10  19.4     82.5      89.3
 11       2016-01-14  17.5     58.9     106.8
 11       2016-01-16  19.3     56.2     119.3

理想情况下,我想为此使用 dplyr,但其他软件包也可以。

一旦您先填写缺失的日期,您就可以使用 zoo 中的 rollapply

library(dplyr)
library(zoo)

set.seed(3737)
DF2 = data.frame(user_id = c(rep(27, 7), rep(11, 7)),
             date = as.Date(rep(c('2016-01-01', '2016-01-03', '2016-01-05', '2016-01-07', '2016-01-10', '2016-01-14', '2016-01-16'), 2)),
             value = round(rnorm(14, 15, 5), 1))

all_combinations <- expand.grid(user_id=unique(DF2$user_id), 
                            date=seq(min(DF2$date), max(DF2$date), by="day"))

res <- DF2 %>% 
    merge(all_combinations, by=c('user_id','date'), all=TRUE) %>%
    group_by(user_id) %>% 
    arrange(date) %>% 
    mutate(v_minus7=rollapply(value, width=8, FUN=function(x) sum(x, na.rm=TRUE), partial=TRUE, align='right'),
           v_minus14=rollapply(value, width=15, FUN=function(x) sum(x, na.rm=TRUE), partial=TRUE, align='right')) %>%
    filter(!is.na(value))

逻辑:第一组 user_id,然后是 date。现在,对于每个数据子集,我们使用 between() 检查哪些所有日期都在当前日期和 7/14 天之前,其中 returns 是一个逻辑向量。

基于这个逻辑向量,我添加了 value

library(data.table)
setDT(DF2)[, `:=`(v_minus7 = sum(DF2$value[DF2$user_id == user_id][between(DF2$date[DF2$user_id == user_id], date-7, date, incbounds = TRUE)]), 
                 v_minus14 = sum(DF2$value[DF2$user_id == user_id][between(DF2$date[DF2$user_id == user_id], date-14, date, incbounds = TRUE)])),
           by = c("user_id", "date")][]
 #   user_id       date value v_minus7 v_minus14
 #1:      27 2016-01-01  15.0     15.0      15.0
 #2:      27 2016-01-03  22.4     37.4      37.4
 #3:      27 2016-01-05  13.3     50.7      50.7
 #4:      27 2016-01-07  21.9     72.6      72.6
 #5:      27 2016-01-10  20.6     78.2      93.2
 #6:      27 2016-01-14  18.6     61.1     111.8
 #7:      27 2016-01-16  16.4     55.6     113.2
 #8:      11 2016-01-01   6.8      6.8       6.8
 #9:      11 2016-01-03  21.3     28.1      28.1
#10:      11 2016-01-05  19.8     47.9      47.9
#11:      11 2016-01-07  22.0     69.9      69.9
#12:      11 2016-01-10  19.4     82.5      89.3
#13:      11 2016-01-14  17.5     58.9     106.8
#14:      11 2016-01-16  19.3     56.2     119.3

# from alexis_laz answer.
ff = function(date, value, minus){
  cs = cumsum(value)  
  i = findInterval(date - minus, date, rightmost.closed = TRUE) 
  w = which(as.logical(i))
  i[w] = cs[i[w]]
  cs - i
} 
setDT(DF2)
DF2[, `:=`( v_minus7 = ff(date, value, 7), 
            v_minus14 = ff(date, value, 14)), by = c("user_id")]

这里有一些使用 zoo 的方法。

1) 定义一个函数sum_last,给定一个动物园对象,取该系列最后一天的时间在 k 天内的值的总和,并且定义一个 roll 函数,将其应用于整个系列。然后使用 averoll 应用于每个 user_id 一次(k=7)和一次(k=14)。

请注意,这使用了最新版本的 zoo 中引入的 rollapplycoredata 参数,因此请确保您没有较早的版本。

library(zoo)

# compute sum of values within k time units of last time point
sum_last <- function(z, k) {
  tt <- time(z)
  sum(z[tt > tail(tt, 1) - k])
}

# given indexes ix run rollapplyr on read.zoo(DF2[ix, -1])
roll <- function(ix, k) {
 rollapplyr(read.zoo(DF2[ix, -1]), k, sum_last, coredata = FALSE, partial = TRUE, k = k)
}

nr <- nrow(DF2)
transform(DF2, 
  v_minus7 = ave(1:nr, user_id, FUN = function(x) roll(x, 7)),
  v_minus14 = ave(1:nr, user_id, FUN = function(x) roll(x, 14)))

2) 另一种方法是用下面显示的版本替换 roll。这会将 DF2[ix, -1] 转换为 "zoo" 并将其与具有 filled-in 间隙的零宽度网格合并。然后 rollapply 应用于它,我们使用 window 将其子集化回原始时间。

roll <- function(ix, k) {
   z <- read.zoo(DF2[ix, -1])
   g <- zoo(, seq(start(z), end(z), "day"))
   m <- merge(z, g, fill = 0)
   r <- rollapplyr(m, k, sum, partial = TRUE)
   window(r, time(z))
}

这里有另一个想法findInterval,尽量减少比较和运算。首先定义一个函数来容纳忽略分组的基本部分。以下函数计算累计总和,并从其各自过去日期的累计总和中减去每个位置的累计总和:

ff = function(date, value, minus)
{
    cs = cumsum(value)  
    i = findInterval(date - minus, date, left.open = TRUE) 
    w = which(as.logical(i))
    i[w] = cs[i[w]]
    cs - i
}

并分组申请:

do.call(rbind, 
        lapply(split(DF2, DF2$user_id), 
               function(x) data.frame(x, 
                         minus7 = ff(x$date, x$value, 7), 
                         minus14 = ff(x$date, x$value, 14))))
#      user_id       date value minus7 minus14
#11.8       11 2016-01-01   6.8    6.8     6.8
#11.9       11 2016-01-03  21.3   28.1    28.1
#11.10      11 2016-01-05  19.8   47.9    47.9
#11.11      11 2016-01-07  22.0   69.9    69.9
#11.12      11 2016-01-10  19.4   82.5    89.3
#11.13      11 2016-01-14  17.5   58.9   106.8
#11.14      11 2016-01-16  19.3   56.2   119.3
#27.1       27 2016-01-01  15.0   15.0    15.0
#27.2       27 2016-01-03  22.4   37.4    37.4
#27.3       27 2016-01-05  13.3   50.7    50.7
#27.4       27 2016-01-07  21.9   72.6    72.6
#27.5       27 2016-01-10  20.6   78.2    93.2
#27.6       27 2016-01-14  18.6   61.1   111.8
#27.7       27 2016-01-16  16.4   55.6   113.2

以上apply-by-group操作当然可以用任何方法代替。

这是一个使用 dplyrtbrf

的新选项
library(tbrf)
library(dplyr)
set.seed(3737)
DF2 = data.frame(user_id = c(rep(27, 7), rep(11, 7)),
                 date = as.Date(rep(c('2016-01-01', '2016-01-03', '2016-01-05', '2016-01-07', '2016-01-10', '2016-01-14', '2016-01-16'), 2)),
                 value = round(rnorm(14, 15, 5), 1))

DF2 %>%
  group_by(user_id) %>%
  tbrf::tbr_sum(value, date, unit = "days", n = 7) %>%
  arrange(user_id, date) %>%
  rename(v_minus7 = sum) %>%
  tbrf::tbr_sum(value, date, unit = "days", n = 14) %>%
  rename(v_minus14 = sum)

创建小标题:

# A tibble: 14 x 5
   user_id date       value v_minus7 v_minus14
     <dbl> <date>     <dbl>    <dbl>     <dbl>
 1      11 2016-01-01   6.8      6.8      21.8
 2      27 2016-01-01  15       15        21.8
 3      11 2016-01-03  21.3     28.1      65.5
 4      27 2016-01-03  22.4     37.4      65.5
 5      11 2016-01-05  19.8     47.9      98.6
 6      27 2016-01-05  13.3     50.7      98.6
 7      11 2016-01-07  22       69.9     142. 
 8      27 2016-01-07  21.9     72.6     142. 
 9      11 2016-01-10  19.4     82.5     182. 
10      27 2016-01-10  20.6     78.2     182. 
11      11 2016-01-14  17.5     58.9     219. 
12      27 2016-01-14  18.6     61.1     219. 
13      11 2016-01-16  19.3     56.2     232. 
14      27 2016-01-16  16.4     55.6     232. 

我怀疑这不是处理较大数据集的最快解决方案,但它在 dplyr 链中运行良好。

尝试 runner package if you want to calculate on time/date windows. Go to github documentation 并检查 Windows depending on date 部分。

library(runner)
DF2 %>%
    group_by(user_id) %>%
    mutate(
      v_minus7 = sum_run(value, 7, idx = date),
      v_minus14 = sum_run(value, 14, idx = date)
    )

此处为基准

library(data.table)
library(dplyr)
library(zoo)
library(tbrf)
set.seed(3737)
DF2 = data.frame(user_id = c(rep(27, 7), rep(11, 7)),
                 date = as.Date(rep(c('2016-01-01', '2016-01-03', '2016-01-05', '2016-01-07', '2016-01-10', '2016-01-14', '2016-01-16'), 2)),
                 value = round(rnorm(14, 15, 5), 1))



# example 1
data_table <- function(DF2) {
  setDT(DF2)[, `:=`(v_minus7 = sum(DF2$value[DF2$user_id == user_id][data.table::between(DF2$date[DF2$user_id == user_id], date-7, date, incbounds = TRUE)]),
                    v_minus14 = sum(DF2$value[DF2$user_id == user_id][data.table::between(DF2$date[DF2$user_id == user_id], date-14, date, incbounds = TRUE)])),
             by = c("user_id", "date")][]
}


# example 2
dplyr_grid <- function(DF2) {
  all_combinations <- expand.grid(user_id=unique(DF2$user_id),
                                  date=seq(min(DF2$date), max(DF2$date), by="day"))

  DF2 %>%
    merge(all_combinations, by=c('user_id','date'), all=TRUE) %>%
    group_by(user_id) %>%
    arrange(date) %>%
    mutate(v_minus7=rollapply(value, width=8, FUN=function(x) sum(x, na.rm=TRUE), partial=TRUE, align='right'),
           v_minus14=rollapply(value, width=15, FUN=function(x) sum(x, na.rm=TRUE), partial=TRUE, align='right')) %>%
    filter(!is.na(value))
}

# example 3
dplyr_tbrf <- function(DF2) {
  DF2 %>%
    group_by(user_id) %>%
    tbrf::tbr_sum(value, date, unit = "days", n = 7) %>%
    arrange(user_id, date) %>%
    rename(v_minus7 = sum) %>%
    tbrf::tbr_sum(value, date, unit = "days", n = 14) %>%
    rename(v_minus14 = sum)
}

# example 4
runner <- function(DF2) {
  DF2 %>%
    group_by(user_id) %>%
    mutate(
      v_minus7 = sum_run(value, 7, idx = date),
      v_minus14 = sum_run(value, 14, idx = date)
    )
}


microbenchmark::microbenchmark(
  runner = runner(DF2),
  data.table = data_table(DF2),
  dplyr = dplyr_tbrf(DF2),
  dplyr_tbrf = dplyr_tbrf(DF2),
  times = 100L
)

# Unit: milliseconds
#       expr       min        lq      mean    median        uq        max neval
#     runner  1.478331  1.797512  2.350416  2.083680  2.559875   9.181675   100
# data.table  5.432618  5.970619  7.107540  6.424862  7.563405  13.674661   100
#      dplyr 63.841710 73.652023 86.228112 79.861760 92.304231 256.841078   100
# dplyr_tbrf 60.582381 72.511075 90.175891 80.435700 92.865997 307.454643   100