dplyr tidyr – 如何在动态条件下生成 case_when？

Question

有没有办法 dynamically/programmatically 在 dplyr 中使用不同的列名 and/or 不同数量的条件生成 case_when 条件？我有一个交互式脚本，我正试图将其转换为一个函数。 case_when 语句中有很多重复的代码，我想知道它是否可以以某种方式自动化，而不需要我一次又一次地从头开始编写所有内容。

这是一个虚拟数据集：

test_df = tibble(low_A=c(5, 15, NA),
                 low_TOT=c(NA, 10, NA),
                 low_B=c(20, 25, 30),
                 high_A=c(NA, NA, 10),
                 high_TOT=c(NA, 40, NA),
                 high_B=c(60, 20, NA))

expected_df = tibble(low_A=c(5, 15, NA),
                     low_TOT=c(NA, 10, NA),
                     low_B=c(20, 25, 30),
                     ans_low=c(5, 10, 30),
                     high_A=c(NA, NA, 10),
                     high_TOT=c(NA, 40, NA),
                     high_B=c(60, 20, NA),
                     ans_high=c(60, 40, 10))

> expected_df
# A tibble: 3 x 8
  low_A low_TOT low_B ans_low high_A high_TOT high_B ans_high
  <dbl>   <dbl> <dbl>   <dbl>  <dbl>    <dbl>  <dbl>    <dbl>
1     5      NA    20       5     NA       NA     60       60
2    15      10    25      10     NA       40     20       40
3    NA      NA    30      30     10       NA     NA       10

我想要的逻辑是，如果 ._TOT 列有值，则使用该值。如果不是，则尝试列 ._A，如果不是，则尝试列 ._B。请注意，我有意没有将 ._TOT 作为组的第一列。在那种情况下我可以只使用 coalesce() ，但我想要一个通用的解决方案，而不考虑列顺序。

当然，所有这些都可以通过几个 case_when 语句轻松完成。我的问题是：

我正在尝试制作一个通用函数，所以不想 interactive/tidy 评估。
我有一大堆这样的专栏。全部以 _TOT, _A, _B 之一结尾，但前缀不同（例如，low_TOT, low_A, low_B, high_TOT, high_A, high_B,.....，我不想一次又一次地重写一堆 case_when 函数。

我现在拥有的是这样的（我在其中为每个前缀写了一个 case_when）：

def my_function = function(df) { 
    df %>% mutate(
          # If a total low doesn't exist, use A (if exists) or B (if exists)
          "ans_low" := case_when(
            !is.na(.data[["low_TOT"]]) ~ .data[["low_TOT"]],
            !is.na(.data[["low_A"]]) ~ .data[["low_A"]],
            !is.na(.data[["low_B"]]) ~ .data[["low_B"]],
          ),

          # If a total high doesn't exist, use A (if exists) or B (if exists)
          "ans_high" := case_when(
            !is.na(.data[["high_TOT"]]) ~ .data[["high_TOT"]],
            !is.na(.data[["high_A"]]) ~ .data[["high_R"]],
            !is.na(.data[["high_B"]]) ~ .data[["high_B"]],
              
         # Plus a whole bunch of similar case_when functions...
}

我想要的是理想地获得一种动态生成具有不同条件的 case_when 函数的方法，这样我就不会每次都通过利用以下事实编写新的 case_when :

所有三个条件具有相同的一般形式和相同的变量名结构，但具有不同的前缀（high_、low_ 等）。
它们具有相同的公式，形式为 !is.na( .data[[ . ]]) ~ .data[[ . ]]，其中点(.) 是动态生成的列名称。

我想要的是：

def my_function = function(df) { 
    df %>% mutate(
          "ans_low" := some_func(prefix="Low"),
          "ans_high" := some_func(prefix="High")
}

我尝试创建自己的 case_when 生成器来替换标准 case_when 生成器，如下所示，但出现错误。我猜那是因为 .data 在 tidyverse 函数之外真的不起作用？

some_func = function(prefix) {
  case_when(
    !is.na(.data[[ sprintf("%s_TOT", prefix) ]]) ~ .data[[ sprintf("%s_TOT", prefix) ]],
    !is.na(.data[[ sprintf("%s_A", prefix) ]]) ~ .data[[ sprintf("%s_A", prefix) ]],
    !is.na(.data[[ sprintf("%s_B", prefix) ]]) ~ .data[[ sprintf("%s_B", prefix) ]]
  )
}

我很好奇的另一件事是制作一个更通用的 case_when 生成器。到目前为止的示例中，只有列的名称（前缀）发生了变化。如果我想怎么办

更改后缀的数量和名称（例如，high_W, high_X, high_Y, high_Z, low_W, low_X, low_Y, low_Z, .......），因此使后缀的字符向量成为 some_func
更改公式的形式。现在，它的所有条件都是 !is.na(.data[[ . ]]) ~ .data[[ . ]] 形式，但是如果我想让它成为 some_func 的参数怎么办？例如，!is.na(.data[[ . ]]) ~ sprintf("%s is missing", .)

我很乐意让它与不同的前缀一起工作，但如果我能理解如何使用任意（但常见的）后缀和任意公式实现更通用的东西，那将是非常酷的，这样我就可以做 some_func(prefix, suffixes, formula).

Answer 1

更新解决方案 我认为这个完全基于 base R 的解决方案可能会对你有所帮助。

fn <- function(data) {
  
  do.call(cbind, lapply(unique(gsub("([[:alpha:]]+)_.*", "\1", names(test_df))), function(x) {
    tmp <- test_df[paste0(x, c("_TOT", "_A", "_B"))]
    tmp[[paste(x, "ans", sep = "_")]] <- Reduce(function(a, b) {
      i <- which(is.na(a))
      a[i] <- b[i]
      a
    }, tmp)
    tmp
  }))
}

fn(test_df)

fn(test_df)

   high_TOT high_A high_B high_ans low_TOT low_A low_B low_ans
1       NA     NA     60       60      NA     5    20       5
2       40     NA     20       40      10    15    25      10
3       NA     10     NA       10      NA    NA    30      30

Answer 2

这是一个自定义 case_when 函数，您可以使用 purrr::reduce 和变量名称的字符串部分的向量（在示例 c("low", "high"):

中调用）

library(dplyr)
library(purrr)

my_case_when <- function(df, x) {
  
  mutate(df,
         "ans_{x}" := case_when(
           !is.na(!! sym(paste0(x, "_TOT"))) ~ !! sym(paste0(x, "_TOT")),
           !is.na(!! sym(paste0(x, "_A"))) ~ !! sym(paste0(x, "_A")),
           !is.na(!! sym(paste0(x, "_B"))) ~ !! sym(paste0(x, "_B"))
           )
  )
}

test_df %>% 
  reduce(c("low", "high"), my_case_when, .init = .)

#> # A tibble: 3 x 8
#>   low_A low_TOT low_B high_A high_TOT high_B ans_low ans_high
#>   <dbl>   <dbl> <dbl>  <dbl>    <dbl>  <dbl>   <dbl>    <dbl>
#> 1     5      NA    20     NA       NA     60       5       60
#> 2    15      10    25     NA       40     20      10       40
#> 3    NA      NA    30     10       NA     NA      30       10

^{由 reprex package (v0.3.0)}

于 2021-07-22 创建

我在 Github {dplyover} 上也有一个包是为这种情况制作的。对于具有两个以上变量的示例，我将使用 dplyover::over 和特殊语法来将字符串评估为变量名。我们可以进一步使用 dplyover::cut_names("_TOT") 来提取 "_TOT" 之前或之后的变量名的字符串部分（在示例中是 "low" 和 "high"）。

我们可以使用 case_when:

library(dplyr)
library(dplyover) # https://github.com/TimTeaFan/dplyover

test_df %>% 
  mutate(over(cut_names("_TOT"),
              list(ans = ~ case_when(
                  !is.na(.("{.x}_TOT")) ~ .("{.x}_TOT"),
                  !is.na(.("{.x}_A")) ~ .("{.x}_A"),
                  !is.na(.("{.x}_B")) ~ .("{.x}_B")
                  )),
              .names = "{fn}_{x}")
         )

#> # A tibble: 3 x 8
#>   low_A low_TOT low_B high_A high_TOT high_B ans_low ans_high
#>   <dbl>   <dbl> <dbl>  <dbl>    <dbl>  <dbl>   <dbl>    <dbl>
#> 1     5      NA    20     NA       NA     60       5       60
#> 2    15      10    25     NA       40     20      10       40
#> 3    NA      NA    30     10       NA     NA      30       10

或者更简单一些 coalesce:

test_df %>% 
  mutate(over(cut_names("_TOT"),
              list(ans = ~ coalesce(.("{.x}_TOT"),
                                    .("{.x}_A"),
                                    .("{.x}_B"))),
              .names = "{fn}_{x}")
  )

#> # A tibble: 3 x 8
#>   low_A low_TOT low_B high_A high_TOT high_B ans_low ans_high
#>   <dbl>   <dbl> <dbl>  <dbl>    <dbl>  <dbl>   <dbl>    <dbl>
#> 1     5      NA    20     NA       NA     60       5       60
#> 2    15      10    25     NA       40     20      10       40
#> 3    NA      NA    30     10       NA     NA      30       10

^{由 reprex package (v0.3.0)}

于 2021-07-22 创建

Answer 3

冒着不回答问题的风险，我认为解决这个问题的最简单方法是重塑并使用 coalesce()。无论哪种方式（我认为），您的数据结构都需要两个枢轴，但这不需要仔细考虑存在的前缀。

library(tidyverse)

test_df <- tibble(
  low_A = c(5, 15, NA),
  low_TOT = c(NA, 10, NA),
  low_B = c(20, 25, 30),
  high_A = c(NA, NA, 10),
  high_TOT = c(NA, 40, NA),
  high_B = c(60, 20, NA)
)

test_df %>%
  rowid_to_column() %>%
  pivot_longer(cols = -rowid, names_to = c("prefix", "suffix"), names_sep = "_") %>%
  pivot_wider(names_from = suffix, values_from = value) %>%
  mutate(ans = coalesce(TOT, A, B)) %>%
  pivot_longer(cols = c(-rowid, -prefix), names_to = "suffix") %>%
  pivot_wider(names_from = c(prefix, suffix), names_sep = "_", values_from = value)
#> # A tibble: 3 x 9
#>   rowid low_A low_TOT low_B low_ans high_A high_TOT high_B high_ans
#>   <int> <dbl>   <dbl> <dbl>   <dbl>  <dbl>    <dbl>  <dbl>    <dbl>
#> 1     1     5      NA    20       5     NA       NA     60       60
#> 2     2    15      10    25      10     NA       40     20       40
#> 3     3    NA      NA    30      30     10       NA     NA       10

另请注意，case_when 没有整洁的评估，因此不使用 mutate 会大大简化您的 some_func。您已经在 mutate 中使用 !!sym 得到了答案，所以这里是一个说明更简单方法的版本。除非必要，否则我不喜欢使用 tidyeval，因为我想使用 mutate 链，而这里并不是真正需要的。

some_func <- function(df, prefix) {
  ans <- str_c(prefix, "_ans")
  TOT <- df[[str_c(prefix, "_TOT")]]
  A <- df[[str_c(prefix, "_A")]]
  B <- df[[str_c(prefix, "_B")]]
  
  df[[ans]] <- case_when(
    !is.na(TOT) ~ TOT,
    !is.na(A) ~ A,
    !is.na(B) ~ B
  )
  df
}

reduce(c("low", "high"), some_func, .init = test_df)
#> # A tibble: 3 x 8
#>   low_A low_TOT low_B high_A high_TOT high_B low_ans high_ans
#>   <dbl>   <dbl> <dbl>  <dbl>    <dbl>  <dbl>   <dbl>    <dbl>
#> 1     5      NA    20     NA       NA     60       5       60
#> 2    15      10    25     NA       40     20      10       40
#> 3    NA      NA    30     10       NA     NA      30       10

Answer 4

感谢大家的回答！ Calum 你的回答特别让我意识到一直坚持 Tidyverse 不一定是最好的，有时基础 R 有更好、更简单、更优雅的解决方案。

多亏了 noahm 在 RStduio 社区上的大量搜索和 this excellent post，我还能够想出一个我自己的解决方案来满足我的需求：

library(tidyverse)
library(rlang)
library(glue)

make_expr = function(prefix, suffix) {
  rlang::parse_expr(glue::glue('!is.na(.data[[\"{prefix}_{suffix}\"]]) ~ .data[[\"{prefix}_{suffix}\"]]'))
}

make_conds = function(prefixes, suffixes){
  map2(prefixes, suffixes, make_expr)
}

ans_df = test_df %>%  
    mutate(
        "ans_low" := case_when(
            !!! make_conds( prefixes=c("low"), suffixes=c("TOT", "A", "B") ) 
        ),
        "ans_high" := case_when(
            !!! make_conds( prefixes=c("high"), suffixes=c("TOT", "A", "B") ) 
        )
    )

# The ans is the same as the expected solution
> all_equal(ans_df, expected_df)
[1] TRUE

我还检查了它在函数内部是否有效（这对我来说是另一个重要的考虑因素）。

此解决方案的一个好处是后缀不是硬编码的，并且至少达到了我一直在寻找的第一级通用性。

我想一些带有替换的字符串操作也可能允许公式结构的通用性。最终，通用公式需要某种字符串模板解决方案，因为使用这种结构，您可以将其保留在胶水中。

Answer 5

这不会生成任何 case_when，但您可以按如下方式创建两个新列。当然，这也可以是一个以 test_df、ans_order 和 and_groups 作为参数的函数。

ans_order <- c('TOT', 'A', 'B')
ans_groups <- c('low', 'high')

test_df[paste0('ans_', ans_groups)] <- 
  apply(outer(ans_groups, ans_order, paste, sep = '_'), 1, 
        function(x) do.call(dplyr::coalesce, test_df[x]))

test_df
#>   low_A low_TOT low_B high_A high_TOT high_B ans_low ans_high
#> 1     5      NA    20     NA       NA     60       5       60
#> 2    15      10    25     NA       40     20      10       40
#> 3    NA      NA    30     10       NA     NA      30       10

如果您不想使用任何包，另一个选择是

test_df[paste0('ans_', ans_groups)] <- 
  apply(outer(ans_groups, ans_order, paste, sep = '_'), 1, 
        function(x) Reduce(function(x, y) ifelse(is.na(x), y, x), test_df[x]))

Answer 6

虽然答案已被接受，但我觉得这可以在 dplyr 中完成（即使对于任意数量的列集），而无需提前编写自定义函数。

test_df %>%
  mutate(across(ends_with('_TOT'), ~ coalesce(., 
                                              get(gsub('_TOT', '_A', cur_column())), 
                                              get(gsub('_TOT', '_B', cur_column()))
                                              ),
                .names = "ans_{gsub('_TOT', '', .col)}"))

# A tibble: 3 x 8
  low_A low_TOT low_B high_A high_TOT high_B ans_low ans_high
  <dbl>   <dbl> <dbl>  <dbl>    <dbl>  <dbl>   <dbl>    <dbl>
1     5      NA    20     NA       NA     60       5       60
2    15      10    25     NA       40     20      10       40
3    NA      NA    30     10       NA     NA      30       10

完整的基础 R 方法

Reduce(function(.x, .y) {
  xx <- .x[paste0(.y, c('_TOT', '_A', '_B'))]
  .x[[paste0('ans_',.y)]] <- apply(xx, 1, \(.z) head(na.omit(.z), 1))
  .x
}, unique(gsub('([_]*)_.*', '\1', names(test_df))),
init = test_df)

# A tibble: 3 x 8
  low_A low_TOT low_B high_A high_TOT high_B ans_low ans_high
  <dbl>   <dbl> <dbl>  <dbl>    <dbl>  <dbl>   <dbl>    <dbl>
1     5      NA    20     NA       NA     60       5       60
2    15      10    25     NA       40     20      10       40
3    NA      NA    30     10       NA     NA      30       10

dplyr tidyr – 如何在动态条件下生成 case_when？

dplyr tidyr – How to generate case_when with dynamic conditons?

r

dplyr

tidyr

rlang