使用 recode 使用命名向量的命名列表跨多个列进行变异答案

【问题标题】：Use recode to mutate across multiple columns using named list of named vectors使用 recode 使用命名向量的命名列表跨多个列进行变异
【发布时间】：2022-01-16 15:10:12
【问题描述】：

我找不到与我在这里遇到的问题类似的问题。我有一个非常大的命名向量的命名列表，它们与数据框中的列名匹配。我想使用命名向量列表来替换与每个列表元素的名称匹配的数据框列中的值。也就是说，列表中向量的名称与数据框列的名称匹配，并且每个向量元素中的键值对将用于重新编码列。

下面的例子：

library(tidyverse)

# Starting tibble
test <- tibble(Names = c("Alice","Bob","Cindy"),
               A = c(3,"q",7),
               B = c(1,2,"b"),
               C = c("a","g",9))

# Named vector
A <- c("5" = "alpha", "7" = "bravo", "3" = "charlie", "q" = "delta")
B <- c("1" = "yes", "2" = "no", "b" = "bad", "c" = "missing")
C <- c("9" = "beta", "8" = "gamma", "a" = "delta", "g" = "epsilon")

# Named list of named vectors
dicts <- list("A" = A, "B" = B, "C" = C) # Same names as columns

我可以使用mutate 并手动指定列和列表项。

# Works when replacement vector is specified
test %>% 
  mutate(across(c("A"), 
                ~recode(., !!!dicts$A)))
#> # A tibble: 3 x 4
#>   Names A       B     C    
#>   <chr> <chr>   <chr> <chr>
#> 1 Alice charlie 1     a    
#> 2 Bob   delta   2     g    
#> 3 Cindy bravo   b     9

但是，以下方法不起作用：

# Does not work when replacement vector using column names
test %>% 
  mutate(across(c("A", "B", "C"), 
                ~recode(., !!!dicts$.)))

错误：mutate() 输入 ..1 有问题。 x 不提供替代品。 i 输入..1 是(function (.cols = everything(), .fns = NULL, ..., .names = NULL) ...。

此外，我发现map2_dfr 仅在指定所有未重新编码的列时才有效：

# map2_dfr Sort of works, but requires dropping some columns
map2_dfr(test %>% select(names(dicts)), 
         dicts, 
         ~recode(.x, !!!.y))
#> # A tibble: 3 x 3
#>   A       B     C      
#>   <chr>   <chr> <chr>  
#> 1 charlie yes   delta  
#> 2 delta   no    epsilon
#> 3 bravo   bad   beta

我希望使用列表中的名称重新编码列，而不删除列。

【问题讨论】：

标签： r recode

【解决方案1】：

一种解决方法是使用您的map2_dfr 代码，然后将所需的列绑定到map2_dfr 输出。尽管您仍然必须删除名称列。

library(tidyverse)

map2_dfr(test %>% select(names(dicts)),
         dicts,
         ~ recode(.x,!!!.y)) %>%
  dplyr::bind_cols(., Names = test$Names) %>%
  dplyr::select(4, 1:3)

输出

# A tibble: 3 × 4
  Names A       B     C      
  <chr> <chr>   <chr> <chr>  
1 Alice charlie yes   delta  
2 Bob   delta   no    epsilon
3 Cindy bravo   bad   beta

【讨论】：

谢谢，但是我的实际数据是大量列，所以我正在寻找一种解决方案，我不必删除未重新编码的列。

【解决方案2】：

将两者合并的解决方案可以是，

library(dplyr)
library(tidyr)

test %>% 
 pivot_longer(-1) %>% 
 left_join(stack(dicts) %>% 
             rownames_to_column('value'),
           by = c('value',  'name' = 'ind')) %>% 
 pivot_wider(id_cols = -value, names_from = name, values_from = values)

# A tibble: 3 x 4
#  Names A       B     C      
#  <chr> <chr>   <chr> <chr>  
#1 Alice charlie yes   delta  
#2 Bob   delta   no    epsilon
#3 Cindy bravo   bad   beta

【讨论】：

【解决方案3】：

以下是三种方法：

首先，我们可以在使用dplyr::cur_column() 的自定义函数中使其与dplyr::across 一起使用。

library(tidyverse)

myfun <- function(x) {
  mycol <- cur_column()
  dplyr::recode(x, !!! dicts[[mycol]])
}

test %>% 
  mutate(across(c("A", "B", "C"), myfun))

#> # A tibble: 3 x 4
#>   Names A       B     C      
#>   <chr> <chr>   <chr> <chr>  
#> 1 Alice charlie yes   delta  
#> 2 Bob   delta   no    epsilon
#> 3 Cindy bravo   bad   beta

第二种选择是将dicts 转换为表达式列表，然后使用!!! 运算符将其拼接为mutate：

expr_ls <-  imap(dicts, ~ quo(recode(!!sym(.y), !!!.x)))

test %>% 
  mutate(!!! expr_ls)

#> # A tibble: 3 x 4
#>   Names A       B     C      
#>   <chr> <chr>   <chr> <chr>  
#> 1 Alice charlie yes   delta  
#> 2 Bob   delta   no    epsilon
#> 3 Cindy bravo   bad   beta

最后，在更大的 tidyverse 中，我们可以使用 purrr::lmap_at，但它使底层函数比它需要的更复杂：

myfun2 <- function(x) {
  x_nm <- names(x)
  mutate(x, !! x_nm := recode(!! sym(x_nm), !!! dicts[[x_nm]]))
}

lmap_at(test, 
        names(dicts),
        myfun2)
#> # A tibble: 3 x 4
#>   Names A       B     C      
#>   <chr> <chr>   <chr> <chr>  
#> 1 Alice charlie yes   delta  
#> 2 Bob   delta   no    epsilon
#> 3 Cindy bravo   bad   beta

原始数据

# Starting tibble
test <- tibble(Names = c("Alice","Bob","Cindy"),
               A = c(3,"q",7),
               B = c(1,2,"b"),
               C = c("a","g",9))

# Named vector
A <- c("5" = "alpha", "7" = "bravo", "3" = "charlie", "q" = "delta")
B <- c("1" = "yes", "2" = "no", "b" = "bad", "c" = "missing")
C <- c("9" = "beta", "8" = "gamma", "a" = "delta", "g" = "epsilon")

# Named list of named vectors
dicts <- list("A" = A, "B" = B, "C" = C) # Same names as columns

^{由reprex package (v2.0.1) 于 2021 年 12 月 15 日创建}

【讨论】：

dplyr::across() 和 dplyr::cur_column() 效果最好。谢谢！
我还要注意，我通过在单独的行中命名列进行了一些修改，例如matching_vars <- na.omit(names(dicts[names(test)]))，然后将其传递给across()中的第一个参数。

【解决方案4】：

你可以试试下面的基本 R 代码

idx <- match(names(dicts), names(test))
test[idx] <- Map(`[`, dicts, test[idx])

给了

> test
# A tibble: 3 x 4
  Names A       B     C
  <chr> <chr>   <chr> <chr>
1 Alice charlie yes   delta
2 Bob   delta   no    epsilon
3 Cindy bravo   bad   beta

【讨论】：

【解决方案5】：

使用基础 R 并重新编码：

for (x in names(dicts)) { test[[x]] <- do.call(recode, c(list(test[[x]]), dicts[[x]])) }

> test
# A tibble: 3 × 4
  Names A       B     C      
  <chr> <chr>   <chr> <chr>  
1 Alice charlie yes   delta  
2 Bob   delta   no    epsilon
3 Cindy bravo   bad   beta

另请注意，基于Map() 或str_replace_all() 的其他解决方案仅适用，因为测试示例仅使用简单的替换。如果使用.default 或.missing，它们很可能会失败。

【讨论】：

【解决方案6】：

Base R（应该很容易翻译成dplyr）

# Helper function
look_dict <- function(col, values) dicts[[col]][values]

# lapply
test[names(dicts)] <- lapply(names(dicts), \(col) look_dict(col, test[[col]]))

# magrittr and for loop to avoid repeating code
library(magrittr)
for (col in names(dicts)) test[[col]] %<>% look_dict(col, .)

# # A tibble: 3 x 4
#   Names A       B     C      
#   <chr> <chr>   <chr> <chr>  
# 1 Alice charlie yes   delta  
# 2 Bob   delta   no    epsilon
# 3 Cindy bravo   bad   beta

【讨论】：

【解决方案7】：

已编辑

这是一个使用qdap::mgsub 的管道友好型解决方案。恐怕stringr::str_replace_all 和stringi::stri_replace_first_fixed() 似乎都不起作用。请参阅 cmets 了解更多信息。

test %>% 
  mutate(across(
    c("A", "B", "C"),
    ~qdap::mgsub( names(dicts[[cur_column()]]), dicts[[cur_column()]], .x)
    ))

【讨论】：

这似乎主要给出了正确的输出，除了C 的第三行。它不是返回“beta”，而是返回“betdelta”
@AndrewGillreath-Brown 我错过了。我想使用 stringr::str_replace 可以工作。
我检查了 str_replace，恐怕它似乎不起作用。
您可能必须使用paste0("^", pattern, "$") 才能完全匹配。
@David 感谢您的建议。编辑答案以提供有效的解决方案。 stringi::stri_replace_first_fixed() 恐怕也不起作用。

【解决方案8】：

不是一个完整的答案，但我认为（在撰写本文时）现有解决方案的基准可能会有所帮助。与每个基准 YMMV 一样：

如我们所见，sindri_baldur 的基本 R 版本实际上是最快的

（代码如下）

bench::mark(
  karl_base_r(data, dicts),
  tim_across(data, dicts),
  tim_lmap(data, dicts),
  sotos_pivot(data, dicts),
  thomas_base_r(data, dicts),
  sindri_base_r(data, dicts),
  check = FALSE
)
#> # A tibble: 6 x 6
#>   expression                      min   median `itr/sec` mem_alloc `gc/sec`
#>   <bch:expr>                 <bch:tm> <bch:tm>     <dbl> <bch:byt>    <dbl>
#> 1 karl_base_r(data, dicts)    825.9us  968.9us     814.   428.17KB     6.25
#> 2 tim_across(data, dicts)      5.04ms   6.44ms     147.      2.4MB     4.15
#> 3 tim_lmap(data, dicts)        7.34ms   8.49ms     108.   106.06KB     4.17
#> 4 sotos_pivot(data, dicts)    12.79ms  14.58ms      60.6    1.26MB     4.18
#> 5 thomas_base_r(data, dicts)    392us  438.6us    1891.         0B     4.07
#> 6 sindir_base_r(data, dicts)  116.8us  136.7us    5793.         0B     4.11

更大的数据集

对于更大的数据集，ThomasIsCoding base R 版本比 Sindir 的解决方案要快一点。

set.seed(15)
data_large <- data %>% sample_n(1e6, replace = TRUE)

bench::mark(
  karl_base_r(data_large, dicts),
  tim_across(data_large, dicts),
  tim_lmap(data_large, dicts),
  thomas_base_r(data_large, dicts),
  sindir_base_r(data_large, dicts),
  check = FALSE
)
#> Warning: Some expressions had a GC in every iteration; so filtering is disabled.
#> # A tibble: 5 x 6
#>   expression                            min  median `itr/sec` mem_alloc `gc/sec`
#>   <bch:expr>                       <bch:tm> <bch:t>     <dbl> <bch:byt>    <dbl>
#> 1 karl_base_r(data_large, dicts)      856ms   856ms      1.17   503.9MB     9.35
#> 2 tim_across(data_large, dicts)       647ms   647ms      1.55   504.9MB    10.8 
#> 3 tim_lmap(data_large, dicts)         809ms   809ms      1.24   503.6MB    11.1 
#> 4 thomas_base_r(data_large, dicts)    131ms   148ms      6.53    80.1MB     3.27
#> 5 sindir_base_r(data_large, dicts)    150ms   180ms      5.08    80.1MB     5.08

代码

library(tidyverse)
library(magrittr)

# Starting tibble
data <- tibble(Names = c("Alice","Bob","Cindy"),
               A = c(3,"q",7),
               B = c(1,2,"b"),
               C = c("a","g",9))

# Named vector
A <- c("5" = "alpha", "7" = "bravo", "3" = "charlie", "q" = "delta")
B <- c("1" = "yes", "2" = "no", "b" = "bad", "c" = "missing")
C <- c("9" = "beta", "8" = "gamma", "a" = "delta", "g" = "epsilon")

# Named list of named vectors
dicts <- list("A" = A, "B" = B, "C" = C) # Same names as columns


# function definitions 

karl_base_r <- function(data, dicts) {
  for (x in names(dicts)) 
    {data[[x]] <- do.call(recode, c(list(data[[x]]), dicts[[x]])) }
  
  data
}

tim_across <- function(data, dicts) {
  
  myfun <- function(x) {
    mycol <- cur_column()
    dplyr::recode(x, !!! dicts[[mycol]])
  }
  
  data %>% 
    mutate(across(c("A", "B", "C"), myfun))
}

tim_lmap <- function(data, dicts) {
  myfun2 <- function(x) {
    x_nm <- names(x)
    mutate(x, !! x_nm := recode(!! sym(x_nm), !!! dicts[[x_nm]]))
  }
  
  lmap_at(data, 
          names(dicts),
          myfun2)
}

sotos_pivot <- function(data, dicts) {
  data %>% 
    pivot_longer(-1) %>% 
    left_join(stack(dicts) %>% 
                rownames_to_column('value'),
              by = c('value',  'name' = 'ind')) %>% 
    pivot_wider(id_cols = -value, names_from = name, values_from = values)
}

thomas_base_r <- function(data, dicts) {
  idx <- match(names(dicts), names(data))
  data[idx] <- Map(`[`, dicts, data[idx])
  data
}

sindri_base_r <- function(data, dicts) {
  look_dict <- function(col, values) dicts[[col]][values]
  
  data[names(dicts)] <- lapply(names(dicts), \(col) look_dict(col, data[[col]]))
  data
}

^{由reprex package (v2.0.0) 于 2021 年 12 月 15 日创建}

【讨论】：

感谢基准测试。我很惊讶lmap 比我预期的更快更接近across。
TBH，我还没用过lmap()，但它似乎对很多用例都有用。
在处理列表时绝对有用。当它被引入时，一个可能的用例是data.frame 操作（也在文档中提到），但我认为dplyr::across 这个用例变得多余，因为across 更强大。

【解决方案9】：

使用purrr 的另一种选择，无需进行复杂的整理工作。

library(purrr)
library(tibble)

test %>% 
  lmap_at(c("A", "B", "C"), 
          ~ as_tibble_col(dicts[[names(.x)]][unlist(.x)], names(.x)))

# # A tibble: 3 x 4
#   Names A       B     C      
#   <chr> <chr>   <chr> <chr>  
# 1 Alice charlie yes   delta  
# 2 Bob   delta   no    epsilon
# 3 Cindy bravo   bad   beta

如果有 modify2_at() 或 imodify_at() 函数或其他东西，这将非常容易，但这里我们使用 lmap_at() 作为解决方法。

【讨论】：