11

我有一个 tibble 的玩具示例。将按 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

4

6 回答 6

7

一种方法是使用group_by %>% dowhere 您可以自定义返回的数据框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()

计时，使用@Matt 的数据和设置：

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
于 2017-09-27T01:53:16.003 回答
6

这是适合您的一种方法。由于您想总结两个连续的行，您可以使用lead()并计算sum. 对于seq，我认为您可以简单地获取行号，看看您的预期结果。完成这些操作后，您可以按x（如有必要，x和seq）排列数据。最后，您删除带有 NA 的行。如有必要，您可能想在代码末尾y写下。select(-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
于 2017-09-27T01:51:37.253 回答
6

我注意到您要求最有效的方法——如果您正在考虑将其扩展到更大的集合，我强烈建议您使用 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)]

将此与使用具有 100,000 行和 10,000 组的 tidyverse 包的答案进行粗略的基准比较说明了显着差异。

（我使用 Psidom 的答案而不是 jazzurro 的答案，因为 jazzuro 不允许对任意数量的行求和。）

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
于 2017-09-27T12:50:03.120 回答
4

使用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
于 2017-09-27T02:00:29.363 回答
1

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()
于 2017-09-27T02:33:30.573 回答
0

现有答案的一个小变体：首先将数据转换为列表列格式，然后使用purrrtomap() 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())

我认为，如果您拥有最新版本，则可以通过使用而不是 map 来purrr摆脱最后两行（最后的group_by()和）。mutate()imap()

于 2017-11-07T07:07:55.243 回答