Создание программных столбцов с помощью dplyr со ссылкой на другие столбцы таблицы

Question

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

Давайте возьмем набор данных mtcars.Теперь, как я это настроил, я программно определил некоторые функции, которые я хочу сделать новыми столбцами.Например, это работает:

# everything below I've defined programmatically:
cyl_lag_2 <- function(x) lag(x, 2)
cyl_lag_3 <- function(x) lag(x, 3)

lag_model_vars <- c("cyl_lag_2", "cyl_lag_3")

stem_col <- function(.f, ...) .f(...)

# here I apply these to the dataset by hard-coding the lag column in two ways

# this works
mtcars %>% 
  mutate_at(lag_model_vars, funs(stem_col(., cyl)))

# also this does
mtcars %>% 
  mutate_at(lag_model_vars, funs(stem_col(., .data[["cyl"]])))

Но у меня вопрос: а что если я хочу, чтобы он ссылался на несколько столбцов?Например:

# everything below I've defined programmatically:
cyl_lag_2 <- function(x) lag(x, 2)
hp_lag_3 <- function(x) lag(x, 3)

lag_model_vars <- c("cyl_lag_2", "hp_lag_3")
lag_cols <- sub("(.*?)_(.*)", "\\1", c("cyl_lag_2", "hp_lag_3"))
stem_col <- function(.f, ...) .f(...)

# this does not work at all
mtcars %>% 
  mutate_at(lag_model_vars, funs(stem_col(., .data[[lag_cols]])))

# nor this
mtcars %>% 
  mutate_at(lag_model_vars, 
            funs(stem_col(., .data[[sub("(.*?)_(.*)", "\\1", expr(.))]])))

Идеи?Я чувствую, что я рядом.Решение также должно работать, если входящий фрейм данных сгруппирован, поэтому обращение к mtcars недопустимо.

mtcars %>% 
      mutate_at(lag_model_vars, funs(stem_col(., mtcars[[lag_cols]])))

Answer 1

Мы можем использовать map2 от purrr

library(tidyverse)
map2(lag_model_vars, lag_cols, ~ 
           mtcars %>%
              transmute_at(.x, funs(stem_col(.,  !! rlang::sym(.y))))) %>% 
         bind_cols(mtcars, .)
#     mpg cyl  disp  hp drat    wt  qsec vs am gear carb cyl_lag_2 hp_lag_3
#1  21.0   6 160.0 110 3.90 2.620 16.46  0  1    4    4        NA       NA
#2  21.0   6 160.0 110 3.90 2.875 17.02  0  1    4    4        NA       NA
#3  22.8   4 108.0  93 3.85 2.320 18.61  1  1    4    1         6       NA
#4  21.4   6 258.0 110 3.08 3.215 19.44  1  0    3    1         6      110
#5  18.7   8 360.0 175 3.15 3.440 17.02  0  0    3    2         4      110
#6  18.1   6 225.0 105 2.76 3.460 20.22  1  0    3    1         6       93
#7  14.3   8 360.0 245 3.21 3.570 15.84  0  0    3    4         8      110
#8  24.4   4 146.7  62 3.69 3.190 20.00  1  0    4    2         6      175
#9  22.8   4 140.8  95 3.92 3.150 22.90  1  0    4    2         8      105
#...