加权 cumsum 与另一列滚动

Question

有一个如下所示的 data.frame：

library(dplyr)
test <- data.frame("name" = c("Scott","Scott","Scott","Scott","Scott","Scott"),
                   "minutes" = c(100, 50, 150, 200, 100, 250),
                   "grade" = c(2, 1.5, 2.5, 3, 2.2, 2.8))

我想使用 cumsum 为每一行做一个加权成绩，它显示了他们的平均成绩加权分钟数 - 但是我希望样本只包括占 400 分钟的最新行。

这是一个使用 cumsum 的 weighted_grade 代码示例：

test <- test %>%
  mutate(weighted_grade = cumsum(grade*minutes)/cumsum(minutes))

这对整个样本进行了很好的加权评分，但我只寻找占 400 分钟的最新行。我研究了滚动总和，但这些是基于行数而不是小时数。

明确地说，我希望新列的前 3 行返回 NA（因为前 3 行加起来为 300 分钟，因此不相关）；第 4 行将返回第 2、3 和 4 行的 weighted_grade（总共 400 分钟，因此第 1 行无关紧要）；第 5 行将返回第 3、4 和 5 行的 weighted_grade（450 分钟）；等等……

Answer 1

1) rollapplyr 按名称分组，然后为每个名称使用rollapplyr。请注意，宽度可以是我们使用findInterval 设置的向量。

library(dplyr, exclude = c("filter", "lag"))
library(zoo)

test %>%
  group_by(name) %>%
  mutate(
    minutes0 = ifelse(is.na(minutes), 0, minutes),
    cumsum = cumsum(minutes0),
    mean = rollapplyr(1:n(),
      width = 1:n() - findInterval(cumsum - 400, cumsum),
      FUN = function(ix) if (sum(minutes0[ix]) < 400) NA
        else weighted.mean(grade[ix], minutes0[ix]),
      fill = NA)) %>%
  ungroup %>%
  select(name, minutes, grade, mean)

给予：

# A tibble: 6 x 4
  name  minutes grade  mean
  <chr>   <dbl> <dbl> <dbl>
1 Scott     100   2   NA   
2 Scott      50   1.5 NA   
3 Scott     150   2.5 NA   
4 Scott     200   3    2.62
5 Scott     100   2.2  2.66
6 Scott     250   2.8  2.76

2) sqldf 使用sql的一种方法是：

library(sqldf)

sqldf("with t1 as (
    select rowid id, *, sum(minutes) over (partition by name rows unbounded preceding) as cum from test
  )   
  select 
      a.name, 
      a.minutes, 
      a.grade, 
      iif (sum(b.minutes) < 400, Null, sum(b.grade * b.minutes) / sum(b.minutes)) as mean
    from t1 a 
    left join t1 b on b.cum > a.cum  - 400 and b.cum <= a.cum and a.name = b.name
    group by a.id")

给予：

   name minutes grade     mean
1 Scott     100   2.0       NA
2 Scott      50   1.5       NA
3 Scott     150   2.5       NA
4 Scott     200   3.0 2.625000
5 Scott     100   2.2 2.655556
6 Scott     250   2.8 2.763636

更新

小幅代码改进。

Answer 2

如果我理解正确

library(tidyverse)
library(zoo)
#> 
#> 
#>     as.Date, as.Date.numeric
test <- data.frame("name" = c("Scott","Scott","Scott","Scott","Scott","Scott"),
                   "minutes" = c(100, 50, 150, 200, 100, 250),
                   "grade" = c(2, 1.5, 2.5, 3, 2.2, 2.8))
test %>%
  mutate(numerator = grade * minutes,
         cs_numerator = rollapply(numerator,
                                  width = 3,
                                  FUN = sum,
                                  partial = T,
                                  align = "right"),
         cs_denominator = rollapply(minutes,
                                    width = 3,
                                    FUN = sum,
                                    partial = T,
                                    align = "right"),
         res = ifelse(cs_denominator >= 400, cs_numerator / cs_denominator, NA))
#>    name minutes grade numerator cs_numerator cs_denominator      res
#> 1 Scott     100   2.0       200          200            100       NA
#> 2 Scott      50   1.5        75          275            150       NA
#> 3 Scott     150   2.5       375          650            300       NA
#> 4 Scott     200   3.0       600         1050            400 2.625000
#> 5 Scott     100   2.2       220         1195            450 2.655556
#> 6 Scott     250   2.8       700         1520            550 2.763636

^{由reprex package (v0.3.0) 于 2020 年 11 月 30 日创建}