2017-09-27 24 views
11

Mam zabawny przykład gryzła. Jaki jest najskuteczniejszy sposób, aby podsumować dwa kolejne rzędy y pogrupowane przez xW jaki sposób mogę wykonać toczący się suma po kolejnych wierszach gry w R


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 

więc wyjście byłoby coś takiego

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

Chciałbym użyj tidyverse i być może roll_sum() z pakietu RcppRoll i zastosuj kod, aby zmienna długość kolejnych wierszy mogła być użyta dla danych rzeczywistych, w których byłoby wiele grupy

TIA

Odpowiedz

7

Jednym ze sposobów, aby to zrobić, to użyć group_by %>% do gdzie można dostosować wracającą ramki danych w 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 

Edit: Ponieważ to nie jest tak skuteczny, prawdopodobnie ze względu na nagłówek budowy ramek danych i ramki danych wiążących w ruchu, tutaj jest ulepszona wersja (nadal nieco wolniejsza niż data.table, ale nie tak dużo teraz):

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

Timing, użyj @ danych Matta i konfiguracja:

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 

wynikiem jest:

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

Oto jedno podejście dla Ciebie. Ponieważ chcesz podsumować dwa kolejne wiersze, możesz użyć lead() i wykonać obliczenia dla sum. Dla seq, myślę, że możesz po prostu wziąć numery wierszy, widząc oczekiwany wynik. Po zakończeniu tych operacji dane są uporządkowane według x (jeśli to konieczne, x i seq). Na koniec upuszczasz wiersze z NA. W razie potrzeby możesz zrzucić kod y, pisząc na końcu kodu 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 
4

Roztwór stosując tidyverse i zoo. Jest to podobne do podejścia Psidoma.

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 
+0

Jedna literówka :) 'rollapply' – Wen

+0

@Wen Dzięki. 'rollapplyr' również działa. Domyślne wyrównanie jest ustawione na "prawo". Dlatego jest nazywany 'rollapplyr'. – www

+0

przegłosowano na moje głupie pytanie i uczę się czegoś nowego :) – Wen

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 

Jeśli okno ruchu równa się jedynie do 2 stosując 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() 
+1

Tak, użyłem wcześniej metody lag, ale gdy minę 3, to jest brzydka – pssguy

+0

@pssguy tak, masz rację. Podświetlam kiedy twoje ruchome okna to 2, możesz użyć 'lag' lub' shift' – Wen

+0

Kiedy stosujesz do prawdziwych danych o długości sekwencji 17, otrzymuję komunikat Kolumna 'sum' musi mieć długość 32 (wielkość grupy) lub jedną, nie 17, co nie ma miejsca w przypadku innych rozwiązań. Każdy pomysł, dlaczego? Wydaje się, że szybko inaczej – pssguy

5

Zauważyłem, że jak ked dla najskuteczniejszy sposób-- jeśli szukasz skalowania tego do znacznie większego zestawu, zdecydowanie polecam 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)] 

Surowe porównanie benchmarków z odpowiedziami za pomocą pakietów tidyverse z 100 000 wierszy i 10 000 grup ilustruje znaczącą różnicę.

(użyłem odpowiedź Psidom zamiast z jazzurro-tych ponieważ nie pozwalają na numer arbritary wierszy należy zsumować jazzuro Użytkownika).

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 

Wyniki:

> 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 
+0

Tak, to wygląda jak najlepsze podejście. Mam tendencję do pracy z mniejszymi zestawami danych i mniej intensywnym przetwarzaniem, ale z tym jest 250 000 wierszy i 2500 grup tak bardzo podobnych do twojego przykładu.Mam jeszcze większą rozbieżność czasową, podałem odpowiedź @Psidom, ponieważ specjalnie wspomniałem o tidyverse, ale użyję twojego w produkcji – pssguy

0

Niewielka odmiana o istniejące odpowiedzi : najpierw przekonwertuj dane na format kolumny-kolumny, a następnie użyj danych purrr do 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()) 

myślę, że jeśli masz najnowszą wersję purrr można pozbyć się ostatnich dwóch linii (ostateczna group_by() i mutate()) za pomocą imap() zamiast mapie.

Powiązane problemy