Как мне сделать скользящую cumsum над последовательными рядами кусочка в R

У меня есть игрушечный пример кусочка. Каков наиболее эффективный способ суммирования двух последовательных строк y, сгруппированных по x

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

Я хотел бы использовать tidyverse и, возможно, roll_sum() из пакета RcppRoll и иметь код, чтобы переменная длина последовательных строк могла использоваться для данных реального мира, в которых было бы много групп

TIA

Ответы

Ответ 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()

Сроки, используйте данные и настройку @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

Ответ 2

Вот вам один подход. Поскольку вы хотите суммировать две последовательные строки, вы можете использовать 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

Ответ 3

Я заметил, что вы попросили наиболее эффективный способ - если вы посмотрите на масштабирование этого набора до гораздо большего набора, я настоятельно рекомендую 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)]

Сравнительное сравнение этого сравнения с ответом с использованием пакетов tidyverse со 100 000 строк и 10 000 групп иллюстрирует значительную разницу.

(Я использовал ответ Psidom вместо jazzurro, так как джаззуро не позволял суммировать количество строк.)

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

Ответ 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

Ответ 5

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()

Ответ 6

Небольшой вариант для существующих ответов: сначала преобразуйте данные в формат списка-столбца, затем используйте purrr to 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, вы можете избавиться от последних двух строк (окончательный group_by() и mutate()), используя imap() вместо карты.