CODEWITHSUNDEEP
rdplyrtidyversepurrr
Zafar
Zafar

Reputation: 2016

Programmatic column creation with dplyr referring to other table columns

I'm trying to create a very programmatic piece of code that lets me grab model vars based on the model formula I submit to the function. Some of the features I need must be calculated on the fly. I can't figure out how to do some of these. I'm almost there but need to figure out this last little bit. Here is my reprex:

Let's take the mtcars dataset. Now the way I've set it up I've programmatically defined some functions that I want to become new columns. For instance, this works:

# 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"]])))

But my question is, what if I want it to refer to multiple columns? For instance:

# 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(.))]])))

Ideas? I feel like I'm close. The solution should also work if the incoming data frame is grouped, so referring to mtcars is not acceptable. 

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

Upvotes: 2

Views: 51

Answers (1)

akrun
akrun

Reputation: 887118

We can use map2 from 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
#...

Upvotes: 1

Related Questions