добавление нескольких лагов / сдвигов в список столбцов

Question

Я бы хотел отложить несколько столбцов (например, value_1 + value_2 + x - см. Ниже), определить их количество лагов (например, 3) и присвоить им имена. Это некоторый рабочий утомительный / ручной код:

library(dplyr)
library(lubridate)
library(data.table)

haves <- data.frame(
      id = c("a", "a", "a", "a", "a", "a", "b", "b", "b", "b", "b", "b")
    , date = as.Date(c("2015-01-01", "2015-02-01", "2015-03-01", "2015-04-01", "2015-05-01", "2015-06-01", "2015-01-01", "2015-02-01", "2015-03-01", "2015-04-01", "2015-05-01", "2015-06-01"))
    , value_1 = c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12)
    , value_2 = c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12)
    , x = c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12)
) 
haves$value_2 <- haves$value_2 + 1
haves$x <- haves$x + 2

haves

wants <- haves %>%
    group_by(id) %>% 
    mutate(
        value_1_lag_1 = lag(value_1, n = 1, order_by = date)
        , value_1_lag_2 = lag(value_1, n = 2, order_by = date)
        , value_1_lag_3 = lag(value_1, n = 3, order_by = date)

        , value_2_lag_1 = lag(value_2, n = 1, order_by = date)
        , value_2_lag_2 = lag(value_2, n = 2, order_by = date)
        , value_2_lag_3 = lag(value_2, n = 3, order_by = date)

        , x_lag_1 = lag(x, n = 1, order_by = date)
        , x_lag_2 = lag(x, n = 2, order_by = date)
        , x_lag_3 = lag(x, n = 3, order_by = date)
    )

wants

Кто-то предположил, что this предлагает решение, поэтому я безуспешно попробовал подход с таблицей данных:

setDT(haves)
haves[, sapply(1:3, function(x){paste0('', x, '_lag_', 1:3)}) := shift(.SD, 1:3), 
   by = id, .SDcols = value_1:x][]

Это не производит мои желания. Это ближе:

colnames <- colnames(haves)

setDT(haves)
haves[, sapply(1:3, function(x){paste0(colnames[x + 2], x, '_lag_', 1:3)}) := shift(.SD, 1:3), by = id, .SDcols = value_1:x][]

В качестве альтернативы, я могу просто использовать al oop и функцию, подобную этой:

appender <- function(df, column, lag){

    df %>%
        group_by(
            id
        ) %>%
        mutate(
            !!paste0(column, "_lag_", lag) := lag(!!rlang::sym(column), n = lag, order_by = date) 
        )
}

temp <- appender(haves, "value_2", 3)

Любая помощь будет очень признательна. Спасибо!

Answer 1

Здесь представлен альтернативный путь через data.table .

library(data.table)
library(lubridate)
#> 
#> Attaching package: 'lubridate'
#> The following objects are masked from 'package:data.table':
#> 
#>     hour, isoweek, mday, minute, month, quarter, second, wday, week,
#>     yday, year
#> The following object is masked from 'package:base':
#> 
#>     date
library(stringr)

haves <- data.frame(
  id = c("a", "a", "a", "a", "a", "a", "b", "b", "b", "b", "b", "b")
  , date = as.Date(c("2015-01-01", "2015-02-01", "2015-03-01", "2015-04-01", "2015-05-01", "2015-06-01", "2015-01-01", "2015-02-01", "2015-03-01", "2015-04-01", "2015-05-01", "2015-06-01"))
  , value_1 = c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12)
  , value_2 = c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12)
  , value_3 = c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12)
) 

setDT(haves)
setorder(haves, date)

N_vars = 3
N_lags = 3
current_vars = paste0( "value_", rep(1:N_vars, each = 1) )
new_vars = paste0( "value_", rep(1:N_vars, each = N_lags), "_lag_", 1:N_lags )

to_define = new_vars[ str_detect(new_vars, "lag_1") ]
haves[ , (new_vars) := shift( .SD, 1:N_lags ), .SDcols = current_vars]
haves
#>     id       date value_1 value_2 value_3 value_1_lag_1 value_1_lag_2
#>  1:  a 2015-01-01       1       1       1            NA            NA
#>  2:  b 2015-01-01       7       7       7             1            NA
#>  3:  a 2015-02-01       2       2       2             7             1
#>  4:  b 2015-02-01       8       8       8             2             7
#>  5:  a 2015-03-01       3       3       3             8             2
#>  6:  b 2015-03-01       9       9       9             3             8
#>  7:  a 2015-04-01       4       4       4             9             3
#>  8:  b 2015-04-01      10      10      10             4             9
#>  9:  a 2015-05-01       5       5       5            10             4
#> 10:  b 2015-05-01      11      11      11             5            10
#> 11:  a 2015-06-01       6       6       6            11             5
#> 12:  b 2015-06-01      12      12      12             6            11
#>     value_1_lag_3 value_2_lag_1 value_2_lag_2 value_2_lag_3 value_3_lag_1
#>  1:            NA            NA            NA            NA            NA
#>  2:            NA             1            NA            NA             1
#>  3:            NA             7             1            NA             7
#>  4:             1             2             7             1             2
#>  5:             7             8             2             7             8
#>  6:             2             3             8             2             3
#>  7:             8             9             3             8             9
#>  8:             3             4             9             3             4
#>  9:             9            10             4             9            10
#> 10:             4             5            10             4             5
#> 11:            10            11             5            10            11
#> 12:             5             6            11             5             6
#>     value_3_lag_2 value_3_lag_3
#>  1:            NA            NA
#>  2:            NA            NA
#>  3:             1            NA
#>  4:             7             1
#>  5:             2             7
#>  6:             8             2
#>  7:             3             8
#>  8:             9             3
#>  9:             4             9
#> 10:            10             4
#> 11:             5            10
#> 12:            11             5

^{Создан в 2020-05-04 пакетом Представить (v0 .3.0)}

Answer 2

Вот адаптированное решение dplyr из связанного ответа.

haves %>%
  group_by(id) %>%
  nest %>%
  mutate(data = map(data, ~arrange(., date))) %>%
  mutate(lags = map(data, function(dat) {
    imap_dfc(dat[-1], ~set_names(map(1:3, lag, x = .x),
                                 paste0(.y, "_lag_", 1:3)))
  })) %>%
  unnest(c(data, lags))

Это то, что вы ищете?