r - 如何从数据框中为 case_when 构造参数？

Question

我正在尝试根据温度创建许多不同的可能加权方案。

我创建了一个数据框，其中包含 8 个向量的所有可能组合(每个向量代表一个温度范围)。所以数据框的列是特定的温度范围，行是权重。

我想将温度范围作为参数传递给 case_when ，并循环遍历权重数据帧的每一行，根据实际温度为每一行创建一个新变量，并根据权重数据帧中的信息为该温度创建相关权重。

使用以下帖子，我能够创建一个函数来生成权重数据框:

Use dplyr::case_when with arguments programmatically

但我不知道如何构建case_when使用权重数据框的参数。

创建所有可能权重的数据框的函数

library(rlang)
library(tidyverse)

create_temp_weights <- function(
  from = 31,
  to = 100,
  by = 10,
  weights = exprs(between(., 31, 40) ~ c(0, 0.2),
                  between(., 41, 50) ~ c(0.5, 0.8),
                  between(., 51, 90) ~ c(0.8, 1),
                  between(., 91, 100) ~ c(0.2, 0.8),
                  TRUE ~ c(-0.1, 0))
) {

  # use 999 to map other temperatures to last case
  map(c(seq(from, to, by), 999), ~ case_when(!!!weights)) %>%
    set_names(c(map_chr(seq(from, to, by),
                      ~ str_c("temp_", ., "_", . + by - 1)), "temp_other")) %>%
  cross_df(.)

}

temp_weights <- create_temp_weights()

使用用于构建权重的温度向量创建 tibble

test_tibble <- tibble(temp = seq_len(100))

head(test_tibble)

以下 case_when是我试图使用权重数据框以编程方式生成的东西。

# Now I want to create a function that will produce the following
# case_when from the temp_weight data frame so I don't have to
# manually edit the following each time I create a new weights data frame

test_tibble2 <- map_dfc(.x = seq_len(nrow(temp_weights)),
    ~ transmute(
      test_tibble,
      temp =
        case_when(
          temp >= 31   & temp  <= 40   ~  temp_weights$temp_31_40[.x],
          temp >= 41   & temp  <= 50   ~  temp_weights$temp_41_50[.x],
          temp >= 51   & temp  <= 60   ~  temp_weights$temp_51_60[.x],
          temp >= 61   & temp  <= 70   ~  temp_weights$temp_61_70[.x],
          temp >= 71   & temp  <= 80   ~  temp_weights$temp_71_80[.x],
          temp >= 81   & temp  <= 90   ~  temp_weights$temp_81_90[.x],
          temp >= 91   & temp  <= 100  ~  temp_weights$temp_91_100[.x],
          TRUE & !is.na(temp)          ~  temp_weights$temp_other[.x]
        )
      ) %>% set_names(paste0("temp_wt_", .x))
    ) 

head(test_tibble2)

所以我正在寻找的是一个构造 case_when 的函数。来自权重数据框的参数。

Answer 1

密切模仿OP:

windows <- 
  str_extract_all(names(temp_weights), "\\d+") %>% 
  modify(as.integer) %>% 
  modify_if(negate(length), ~ c(-Inf, Inf)) %>% 
  set_names(names(temp_weights))

temp <- test_tibble$temp

res <-
  map_dfc(
    seq_len(nrow(temp_weights)), 
    ~ {
      row <- .
      rlang::eval_tidy(expr(case_when(
        !!! imap(
          windows, 
          ~ expr(
            between(temp, !! .x[1], !! .x[2]) ~ !! temp_weights[[.y]][row]
          )
        )
      )))
    }
  ) %>% 
  set_names(paste0("temp_wt_", seq_along(.)))

all.equal(res, test_tibble2)
#> [1] TRUE 

稍微更有效(不为每个重量组合重复 case_when):

res2 <- 
  rlang::eval_tidy(expr(case_when(
    !!! imap(
      windows, 
      ~ expr(
        between(temp, !! .x[1], !! .x[2]) ~ list(!! temp_weights[[.y]])
      )
    )
  ))) %>% 
  do.call(what = rbind) %>% 
  as_tibble() %>% 
  set_names(paste0("temp_wt_", seq_along(.)))

all.equal(res2, test_tibble2)
#> [1] TRUE