Ищете решение для применения, тидира или dplyr для вложенной для l oop ситуации в R

Question

Странно для этого, я думаю, что легче начать с просмотра df.

#reproducible data
quantiles<-c("50","90")
var=c("w","d")
df=data.frame(a=runif(20,0.01,.5),b=runif(20,0.02,.5),c=runif(20,0.03,.5),e=runif(20,0.04,.5),
           q50=runif(20,1,5),q90=runif(20,10,50))
head(df)

Я хочу автоматизировать созданную мной функцию (ниже) для вычисления vars, используя различные комбинации значений из моего df. Например, для вычисления w необходимо использовать a и b, а для d необходимо использовать c и e, чтобы w = a *q ^ b и d = c * q ^ e. Далее, q - это квантиль, поэтому я на самом деле хочу w50, w90, et c., Что будет соответствовать q50, q90 et c. от дф.

Сложная часть, как я вижу, это установка условия для использования a & b против c & d без использования вложенных циклов. У меня есть функция для вычисления vars с использованием соответствующих столбцов, однако я не могу эффективно собрать все части вместе.

#function to calculate the w, d
calc_wd <- function(df,col_name,col1,col2,col3){
  #Calculate and create new column col_name for each combo of var and quantile, e.g. "w_50", "d_50", etc.
  df[[col_name]] <- df[[col1]] * (df[[col2]] ^ (df[[col3]]))
  df
}

Я могу заставить это работать для одного случая, но не автоматизируя поменять коэффициент ... вы увидите, я задаю "a" и "b" ниже.

wd<-c("w_","d_")
make_wd_list<-apply(expand.grid(wd, quantiles), 1, paste,collapse="")
calc_wdv(df,make_wd_list[1],"a",paste0("q",sapply(strsplit(make_wd_list[1],"_"),tail,1)),"b")

В качестве альтернативы, я попытался сделать эту работу, используя вложенные циклы for, но, похоже, не могу добавить данные правильно. И это уродливо.

var=c("w","d")

dataf<-data.frame()
for(j in unique(var)){
    if(j=="w"){
      coeff1="a"
      coeff2="b"
    }else if(j=="d"){
      coeff1="c"
      coeff1="e"
    }
  print(coeff1)
  print(coeff2)
  for(k in unique(quantiles)){
    dataf<-calc_wd(df,paste0(j,k),coeff1,paste0("q",k),coeff2)
    dataf[k,j]=rbind(df,dataf) #this aint right.  tried to do.call outside, etc.
  }

}

В конце я ищу новые столбцы с w_50, w_90, et c., Которые используют q50, q90 и соответствующие коэффициенты, как определено изначально.

Answer 1

Один из подходов, который я считаю простым для ввода, - это purrr::pmap. Мне это нравится, потому что когда вы используете with(list(...),), вы можете получить доступ к именам столбцов вашего data.frame по имени. Кроме того, вы можете предоставить дополнительные аргументы.

library(purrr)
pmap_df(df, quant = "q90", ~with(list(...),{
  list(w = a * get(quant) ^ b, d = c * get(quant) ^ e)
  }))
## A tibble: 20 x 2
#        w     d
#    <dbl> <dbl>
# 1 0.239  0.295
# 2 0.152  0.392
# 3 0.476  0.828
# 4 0.344  0.236
# 5 0.439  1.00 

Вы можете комбинировать это, например, со вторым вызовом map для перебора квантилей.

library(dplyr)
map(setNames(quantiles,quantiles),
    ~ pmap_df(df, quant = paste0("q",.x), 
              ~ with(list(...),{list(w = a * get(quant) ^ b, d = c * get(quant) ^ e)}))
    ) %>% do.call(cbind,.)
#         50.w       50.d      90.w      90.d
#1  0.63585897 0.11045837 1.7276019 0.1784987
#2  0.17286184 0.22033649 0.2333682 0.5200265
#3  0.32437528 0.72502654 0.5722203 1.4490065
#4  0.68020897 0.33797621 0.8749206 0.6179557
#5  0.73516886 0.38481785 1.2782923 0.4870877

Тогда назначение пользовательской функции тривиально.

calcwd <- function(df,quantiles){
  map(setNames(quantiles,quantiles),
    ~ pmap_df(df, quant = paste0("q",.x), 
              ~ with(list(...),{list(w = a * get(quant) ^ b, d = c * get(quant) ^ e)}))
    ) %>% do.call(cbind,.)
}  

Answer 2

Мне нравится ответ @ Ian за полноту и использование классики, такой как with и do.call. Я опаздываю на сцену с моим решением, но так как я пытаюсь поправиться с помощью операций с рядами (включая использование rowwise, думал, что предложу менее элегантное, но более простое и быстрое решение, используя только mutate, formula.tools и map_dfc

library(dplyr)
library(purrr)
require(formula.tools)

# same type example data plus a much larger version in df2 for
# performance testing

df <- data.frame(a = runif(20, 0.01, .5),
                 b = runif(20, 0.02, .5),
                 c = runif(20, 0.03, .5),
                 e = runif(20, 0.04, .5),
                 q50 = runif(20,1,5),
                 q90 = runif(20,10,50)
)

df2 <- data.frame(a = runif(20000, 0.01, .5),
                  b = runif(20000, 0.02, .5),
                  c = runif(20000, 0.03, .5),
                  e = runif(20000, 0.04, .5),
                  q50 = runif(20000,1,5),
                  q90 = runif(20000,10,50)
)

# from your original post

quantiles <- c("q50", "q90")
wd <- c("w_", "d_")
make_wd_list <- apply(expand.grid(wd, quantiles), 
                      1, 
                      paste, collapse = "")
make_wd_list
#> [1] "w_q50" "d_q50" "w_q90" "d_q90"


# an empty list to hold our formulas
eqn_list <- vector(mode = "list", 
                   length = length(make_wd_list)
                   )

# populate the list makes it very extensible to more outcomes
# or to more quantile levels

for (i in seq_along(make_wd_list)) {
  if (substr(make_wd_list[[i]], 1, 1) == "w") {
    eqn_list[[i]] <- as.formula(paste(make_wd_list[[i]], "~ a * ", substr(make_wd_list[[i]], 3, 5), " ^ b"))
  } else if (substr(make_wd_list[[i]], 1, 1) == "d") {
    eqn_list[[i]] <- as.formula(paste(make_wd_list[[i]], "~ c * ", substr(make_wd_list[[i]], 3, 5), " ^ e"))
  }
}

# formula.tools helps us grab both left and right sides

add_column <- function(df, equation){
  df <- transmute_(df, rhs(equation))
  colnames(df)[ncol(df)] <- as.character(lhs(equation))
  return(df)
}

result <- map_dfc(eqn_list, ~ add_column(df = df, equation = .x))

#>         w_q50      d_q50      w_q90     d_q90
#> 1  0.10580863 0.29136904 0.37839737 0.9014040
#> 2  0.34798729 0.35185585 0.64196417 0.4257495
#> 3  0.79714122 0.37242915 1.57594506 0.6198531
#> 4  0.56446922 0.43432160 1.07458217 1.1082825
#> 5  0.26896574 0.07374273 0.28557366 0.1678035
#> 6  0.36840408 0.72458466 0.72741030 1.2480547
#> 7  0.64484009 0.69464045 1.93290705 2.1663690
#> 8  0.43336109 0.21265672 0.46187366 0.4365486
#> 9  0.61340404 0.47528697 0.89286358 0.5383290
#> 10 0.36983212 0.53292900 0.53996112 0.8488402
#> 11 0.11278412 0.12532491 0.12486156 0.2413191
#> 12 0.03599639 0.25578020 0.04084221 0.3284659
#> 13 0.26308183 0.05322304 0.87057854 0.1817630
#> 14 0.06533586 0.22458880 0.09085436 0.3391683
#> 15 0.11625845 0.32995233 0.12749040 0.4730407
#> 16 0.81584442 0.07733376 2.15108243 0.1041342
#> 17 0.38198254 0.60263861 0.68082354 0.8502999
#> 18 0.51756058 0.43398089 1.06683204 1.3397900
#> 19 0.34490492 0.13790601 0.69168711 0.1580659
#> 20 0.39771037 0.33286225 1.32578056 0.4141457

microbenchmark::microbenchmark(result <- map_dfc(eqn_list, ~ add_column(df = df2, equation = .x)), times = 10)
#> Unit: milliseconds
#>                                                               expr      min
#>  result <- map_dfc(eqn_list, ~add_column(df = df2, equation = .x)) 10.58004
#>        lq     mean  median       uq      max neval
#>  11.34603 12.56774 11.6257 13.24273 16.91417    10

Решение mutate и formula работает примерно в пятьдесят раз быстрее, хотя оба из них пробираются через 20 000 строк менее чем за секунду

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