R Создайте несколько столбцов на основе двух разных параметров.

Question

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

var= ifelse(lag(return, n= lag_day)>threshold,return, NA))

Если lag(return) выше порогового значения, чем дать мне значение return, в противном случае укажите NA.

Вот значения пороговых значений и дней лагов:

threshold=c(2,4,6)
lag_day=c(1,2,3)

Здесь я решаю свою проблему вручную:

test<-df%>%
  mutate(var_t1_lag1= ifelse(lag(return, n= lag_day[1] )>threshold[1],return, NA))%>%
  mutate(var_t2_lag1= ifelse(lag(return, n= lag_day[1] )>threshold[2],return, NA))%>%
  mutate(var_t3_lag1= ifelse(lag(return, n= lag_day[1] )>threshold[3],return, NA))%>%
  mutate(var_t1_lag2= ifelse(lag(return, n= lag_day[2] )>threshold[1],return, NA))%>%
  mutate(var_t2_lag2= ifelse(lag(return, n= lag_day[2] )>threshold[2],return, NA))%>%
  mutate(var_t3_lag2= ifelse(lag(return, n= lag_day[2] )>threshold[3],return, NA))%>%
  mutate(var_t1_lag3= ifelse(lag(return, n= lag_day[3] )>threshold[1],return, NA))%>%
  mutate(var_t2_lag3= ifelse(lag(return, n= lag_day[3] )>threshold[2],return, NA))%>%
  mutate(var_t3_lag3= ifelse(lag(return, n= lag_day[3] )>threshold[3],return, NA))

Но есть ли решение, которое облегчит эту задачу?Может быть, с одной или двумя функциями apply?

Вот мой пример dataframe:

df <- tibble(
  date= today()+0:12,
  return=c(1,2.5,2,3,5,6.5,1,9,3,2,4,7,2)
)

Answer 1

Можно было бы получить все комбинации 'threshold', 'lag_day' с crossing, затем выполнить цикл по строкам (pmap), transmute, чтобы создать интересующие столбцы и связать их с оригиналом. набор данных. При этом используется одна функция из base R (seq_along)

library(tidyverse)
crossing(threshold = seq_along(threshold), lag_day) %>%
    pmap_dfc(~  
             df %>%
               transmute(!! str_c("var_t", ..1, "_lag", ..2) := 
                  case_when(lag(return, n = ..2) > threshold[..1] ~ return, 
                            TRUE ~ NA_real_))) %>% 
   bind_cols(df, .)

Answer 2

Базовый подход R с использованием двух циклов наложения с dplyr::lag

df[paste0("var_t", outer(seq_along(lag_day), seq_along(threshold),
   FUN = paste, sep = "_"))] <-  do.call(cbind, 
     lapply(lag_day, function(x) sapply(threshold, function(y) 
            ifelse(dplyr::lag(df$return, n = x) > y, df$return, NA))))


#   date       return var_t1_1 var_t2_1 var_t3_1 var_t1_2 var_t2_2 var_t3_2 var_t1_3 var_t2_3 var_t3_3
#   <date>      <dbl>    <dbl>    <dbl>    <dbl>    <dbl>    <dbl>    <dbl>    <dbl>    <dbl>    <dbl>
# 1 2019-05-21    1       NA       NA         NA     NA         NA       NA       NA       NA       NA
# 2 2019-05-22    2.5     NA       NA         NA     NA         NA       NA       NA       NA       NA
# 3 2019-05-23    2        2       NA         NA     NA         NA       NA       NA       NA       NA
# 4 2019-05-24    3       NA       NA         NA      3         NA       NA       NA       NA       NA
# 5 2019-05-25    5        5       NA         NA     NA         NA       NA        5       NA       NA
# 6 2019-05-26    6.5      6.5      6.5       NA      6.5       NA       NA       NA       NA       NA
# 7 2019-05-27    1        1        1          1      1          1       NA        1       NA       NA
# 8 2019-05-28    9       NA       NA         NA      9          9        9        9        9       NA
# 9 2019-05-29    3        3        3          3     NA         NA       NA        3        3        3
#10 2019-05-30    2        2       NA         NA      2          2        2       NA       NA       NA
#11 2019-05-31    4       NA       NA         NA      4         NA       NA        4        4        4
#12 2019-06-01    7        7       NA         NA     NA         NA       NA        7       NA       NA
#13 2019-06-02    2        2        2          2      2         NA       NA       NA       NA       NA