我该如何在R中的连续的行中做一个滚动的cumsum

Question

我有一个玩具的例子。 什么是总结通过X分组Y的两个连续行

library(tibble) 
l = list(x = c("a", "b", "a", "b", "a", "b"), y = c(1, 4, 3, 3, 7, 0)) 

df <- as_tibble(l) 
df 
#> # A tibble: 6 x 2 
#>  x  y 
#> <chr> <dbl> 
#> 1  a  1 
#> 2  b  4 
#> 3  a  3 
#> 4  b  3 
#> 5  a  7 
#> 6  b  0 

所以输出会是这样的

group sum seq 
    a  4  1 
    a  10  2 
    b  7  1 
    b  3  2 

我想最有效的方法请使用RcppRoll包 中的tidyverse和可能的roll_sum（），并使用代码，以便可变长度的连续行可用于真实世界的数据，其中将会有很多组

TIA

Answer 1

的一种方法是使用group_by %>% do在这里你可以自定义do返回的数据帧：

library(RcppRoll); library(tidyverse) 

n = 2 
df %>% 
    group_by(x) %>% 
    do(
     data.frame(
      sum = roll_sum(.$y, n), 
      seq = seq_len(length(.$y) - n + 1) 
     ) 
    ) 

# A tibble: 4 x 3 
# Groups: x [2] 
#  x sum seq 
# <chr> <dbl> <int> 
#1  a  4  1 
#2  a 10  2 
#3  b  7  1 
#4  b  3  2 

---

编辑：由于这是效率不高，可能是由于数据帧构建头和绑定数据帧在旅途中，这里是一个改进版本（仍然比data.table慢一些，但现在没有那么多）：

df %>% 
    group_by(x) %>% 
    summarise(sum = list(roll_sum(y, n)), seq = list(seq_len(n() -n + 1))) %>% 
    unnest() 

---

时序，使用@马特的数据和设置：

library(tibble) 
library(dplyr) 
library(RcppRoll) 
library(stringi) ## Only included for ability to generate random strings 

## Generate data with arbitrary number of groups and rows -------------- 
rowCount <- 100000 
groupCount <- 10000 
sumRows <- 2L 
set.seed(1) 

l <- tibble(x = sample(stri_rand_strings(groupCount,3),rowCount,rep=TRUE), 
      y = sample(0:10,rowCount,rep=TRUE)) 

## Using dplyr and tibble ----------------------------------------------- 

ptm <- proc.time() ## Start the clock 

dplyr_result <- l %>% 
    group_by(x) %>% 
    summarise(sum = list(roll_sum(y, n)), seq = list(seq_len(n() -n + 1))) %>% 
    unnest() 


dplyr_time <- proc.time() - ptm ## Stop the clock 

## Using data.table instead ---------------------------------------------- 

library(data.table) 

ptm <- proc.time() ## Start the clock 

setDT(l) ## Convert l to a data.table 
dt_result <- l[,.(sum = RcppRoll::roll_sum(y, n = sumRows, fill = NA, align = "left"), 
        seq = seq_len(.N)), 
       keyby = .(x)][!is.na(sum)] 

data.table_time <- proc.time() - ptm 

结果是：

dplyr_time 
# user system elapsed 
# 0.688 0.003 0.689 
data.table_time 
# user system elapsed 
# 0.422 0.009 0.430 

Answer 2

这是您的一种方法。既然你想总结两个连续的行，你可以使用lead()并为sum做计算。对于seq，我想你可以简单地拿行数，看看你的预期结果。完成这些操作后，您可以按照x（如有必要，请按照x和seq）安排您的数据。最后，你用NAs删除行。如有必要，您可以在代码末尾写入select(-y)以删除y。要做到这一点

group_by(df, x) %>% 
mutate(sum = y + lead(y), 
     seq = row_number()) %>% 
arrange(x) %>% 
ungroup %>% 
filter(complete.cases(.)) 

#  x  y sum seq 
# <chr> <dbl> <dbl> <int> 
#1  a  1  4  1 
#2  a  3 10  2 
#3  b  4  7  1 
#4  b  3  3  2 

Answer 3

使用tidyverse和zoo溶液。这与Psidom的方法类似。

library(tidyverse) 
library(zoo) 

df2 <- df %>% 
    group_by(x) %>% 
    do(data_frame(x = unique(.$x), 
       sum = rollapplyr(.$y, width = 2, FUN = sum))) %>% 
    mutate(seq = 1:n()) %>% 
    ungroup() 
df2 
# A tibble: 4 x 3 
     x sum seq 
    <chr> <dbl> <int> 
1  a  4  1 
2  a 10  2 
3  b  7  1 
4  b  3  2 

Answer 4

zoo + dplyr

library(zoo) 
library(dplyr) 

df %>% 
    group_by(x) %>% 
    mutate(sum = c(NA, rollapply(y, width = 2, sum)), 
      seq = row_number() - 1) %>% 
    drop_na() 

# A tibble: 4 x 4 
# Groups: x [2] 
     x  y sum seq 
    <chr> <dbl> <dbl> <dbl> 
1  a  3  4  1 
2  b  3  7  1 
3  a  7 10  2 
4  b  0  3  2 

如果移动窗口只等于2使用lag

df %>% 
    group_by(x) %>% 
    mutate(sum = y + lag(y), 
    seq = row_number() - 1) %>% 
    drop_na() 
# A tibble: 4 x 4 
# Groups: x [2] 
     x  y sum seq 
    <chr> <dbl> <dbl> <dbl> 
1  a  3  4  1 
2  b  3  7  1 
3  a  7 10  2 
4  b  0  3  2 

编辑：

n = 3 # your moving window 
df %>% 
    group_by(x) %>% 
    mutate(sum = c(rep(NA, n - 1), rollapply(y, width = n, sum)), 
      seq = row_number() - n + 1) %>% 
    drop_na() 

Answer 5

我注意到你的ked为效率最高的方式 - 如果您正在考虑扩展到更大的集合，我会强烈建议data.table。

library(data.table) 
library(RcppRoll) 

l[, .(sum = RcppRoll::roll_sum(y, n = 2L, fill = NA, align = "left"), 
     seq = seq_len(.N)), 
    keyby = .(x)][!is.na(sum)] 

这方面的一个粗略的基准比较VS使用tidyverse包10万行和10,000个组的回答说明了显著差异。

（我用Psidom的答案，而不是jazzurro的，因为jazzuro的不容许被概括行的arbritary号）。

library(tibble) 
library(dplyr) 
library(RcppRoll) 
library(stringi) ## Only included for ability to generate random strings 

## Generate data with arbitrary number of groups and rows -------------- 
rowCount <- 100000 
groupCount <- 10000 
sumRows <- 2L 
set.seed(1) 

l <- tibble(x = sample(stri_rand_strings(groupCount,3),rowCount,rep=TRUE), 
      y = sample(0:10,rowCount,rep=TRUE)) 

## Using dplyr and tibble ----------------------------------------------- 

ptm <- proc.time() ## Start the clock 

dplyr_result <- l %>% 
    group_by(x) %>% 
    do(
     data.frame(
      sum = roll_sum(.$y, sumRows), 
      seq = seq_len(length(.$y) - sumRows + 1) 
     ) 
    ) 
|========================================================0% ~0 s remaining  

dplyr_time <- proc.time() - ptm ## Stop the clock 

## Using data.table instead ---------------------------------------------- 

library(data.table) 

ptm <- proc.time() ## Start the clock 

setDT(l) ## Convert l to a data.table 
dt_result <- l[,.(sum = RcppRoll::roll_sum(y, n = sumRows, fill = NA, align = "left"), 
        seq = seq_len(.N)), 
       keyby = .(x)][!is.na(sum)] 

data.table_time <- proc.time() - ptm ## Stop the clock 

结果：

> dplyr_time 
    user system elapsed 
    10.28 0.04 10.36 
> data.table_time 
    user system elapsed 
    0.35 0.02 0.36 

> all.equal(dplyr_result,as.tibble(dt_result)) 
[1] TRUE 

Answer 6

现有的答案一个小的变体：首先将数据转换为列表格式，然后使用purrr至map()roll_sum()到数据上。

l = list(x = c("a", "b", "a", "b", "a", "b"), y = c(1, 4, 3, 3, 7, 0)) 
as.tibble(l) %>% 
    group_by(x) %>% 
    summarize(list_y = list(y)) %>% 
    mutate(rollsum = map(list_y, ~roll_sum(.x, 2))) %>% 
    select(x, rollsum) %>% 
    unnest %>% 
    group_by(x) %>% 
    mutate(seq = row_number()) 

我觉得如果你有最新版本的purrr您可以通过使用imap()而不是地图摆脱最后两行（最终group_by()和mutate()）的。