Comment faire un cumsum de roulement sur des rangées consécutives d'un carré dans R

Question

J'ai un jouet d'exemple d'un dibble. Quel est le moyen le plus efficace pour résumer deux lignes consécutives de y groupées par 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 

Ainsi, la sortie serait quelque chose comme ça

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

Je voudrais utiliser le tidyverse et éventuellement roll_sum() du paquet RcppRoll et avoir le code de sorte qu'une longueur variable de lignes consécutives puisse être utilisée pour des données réelles dans lesquelles il y aurait beaucoup groupes

TIA

Answer 1

Une façon de le faire est d'utiliser group_by %>% do où vous pouvez personnaliser la trame de données retournées dans 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 

---

Modifier: Étant donné que ce n'est pas aussi efficace, probablement en raison de l'en-tête de construction de trame de données et les cadres de données de liaison sur la route, voici une version améliorée (encore un peu plus lent que data.table mais pas autant maintenant):

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

---

Timing, utilisez @ données de Matt et configuration:

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 

Le résultat est:

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

Voici une approche pour vous. Puisque vous voulez résumer deux lignes consécutives, vous pouvez utiliser lead() et faire le calcul pour sum. Pour seq, je pense que vous pouvez simplement prendre des numéros de rangée, voir votre résultat attendu. Une fois que vous avez terminé ces opérations, vous organisez vos données par x (si nécessaire, x et seq). Enfin, vous déposez des lignes avec NAs. Si nécessaire, vous pouvez supprimer y en écrivant select(-y) à la fin du code.

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

Une solution à l'aide tidyverse et zoo. Ceci est similaire à l'approche de 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 

Si la fenêtre mobile ne égale à 2 en utilisant 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 

EDIT:

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

Je vous remarqué que ked pour le le plus efficace way-- si vous cherchez à mettre à l'échelle ceci à un ensemble beaucoup plus grand, je recommande fortement data.table. Une comparaison approximative de ce résultat comparé à une réponse utilisant les paquets tidyverse avec 100 000 lignes et 10 000 groupes illustre la différence significative.

(j'ai utilisé la réponse de Psidom au lieu de celui de jazzurro depuis jazzuro de ne permettait pas un nombre arbritary de lignes à sommées.)

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 

Résultats:

> 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

Une petite variante des réponses existantes : convertit d'abord les données au format liste-colonne, puis utilise purrr à map()roll_sum() sur les données.

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

Je pense que si vous avez la dernière version de purrr vous pouvez vous débarrasser des deux dernières lignes (la group_by() finale et mutate()) en utilisant imap() au lieu de la carte.