重新编码数据框值：每列都有其单独的查找表答案

【问题标题】：Recode dataframe values: each column has its individual lookup table重新编码数据框值：每列都有其单独的查找表
【发布时间】：2021-03-01 18:32:23
【问题描述】：

我有一个包含几列的数据框，我想重新编码值。每列都有其单独的重新编码规则集，在original replacement 映射表中给出（每个表特定于每一列）。

我正在尝试提出一种程序化解决方案，让我能够执行这种重新编码过程。

示例

给我的物品

数据
存储有关每列重新编码指令信息的表

library(tibble)

# 1. data
my_mtcars <-
  mtcars %>%
  rownames_to_column("cars")

# 2. table storing information about per-column recoding instructions
recoding_table <-
  structure(
  list(
    var_name = c("cars", "am", "vs"),
    original_vs_replacement_tbl = list(
      structure(
        list(
          original = c("Mazda RX4", "Hornet 4 Drive",
                       "Ferrari Dino"),
          replacement = c("my_pretty_mazda", "my_amazing_hornet",
                          "my_speedy_ferrari")
        ),
        row.names = c(NA,-3L),
        class = c("tbl_df",
                  "tbl", "data.frame")
      ),
      structure(
        list(original = c(0, 1),
             replacement = c(333, 777)),
        row.names = c(NA,-2L),
        class = c("tbl_df",
                  "tbl", "data.frame")
      ),
      structure(
        list(original = c(0, 1),
             replacement = c(1010, 2020)),
        row.names = c(NA,-2L),
        class = c("tbl_df",
                  "tbl", "data.frame")
      )
    )
  ),
  row.names = c(NA,-3L),
  class = c("tbl_df",
            "tbl", "data.frame")
)

> recoding_table
## # A tibble: 3 x 2
##   var_name original_vs_replacement_tbl
##   <chr>    <list>                     
## 1 cars     <tibble [3 x 2]>           
## 2 am       <tibble [2 x 2]>           
## 3 vs       <tibble [2 x 2]> 

> deframe(recoding_table)
## $cars
## # A tibble: 3 x 2
##   original       replacement      
##   <chr>          <chr>            
## 1 Mazda RX4      my_pretty_mazda  
## 2 Hornet 4 Drive my_amazing_hornet
## 3 Ferrari Dino   my_speedy_ferrari

## $am
## # A tibble: 2 x 2
##   original replacement
##      <dbl>       <dbl>
## 1        0         333
## 2        1         777

## $vs
## # A tibble: 2 x 2
##   original replacement
##      <dbl>       <dbl>
## 1        0        1010
## 2        1        2020

我的问题：当我收到recoding_table 时，如何以编程方式重新编码my_mtcars 中的值？

我心中的一个方向
如果我尝试手动解决这个问题，对于my_mtcars 中的一列，我会这样做：

library(dplyr) 

# 1. get a named vector that maps original vs. replacement values
recoding_vec_am <-
  recoding_table %>%
  filter(var_name == "am") %>%
  pull(original_vs_replacement_tbl) %>%
  deframe() %>%
  pull(replacement, original)

> recoding_vec_am
##   0   1 
## 333 777 

# 2. recode
my_mtcars %>%
  mutate(across(am, recode, !!!recoding_vec_am)) %>% 
  select(am) %>%
  head()

##    am
## 1 777
## 2 777
## 3 777
## 4 333
## 5 333
## 6 333

但话又说回来，我希望有一个自动方法来迭代 my_mtcars 列并检查 recoding_table$var_name：如果来自 my_mtcars 的列出现在 recoding_table$var_name 中，则在 my_mtcars 中重新编码该列的值根据recoding_table$original_vs_replacement_tbl 中的表格。 recoding_table$var_name 中不出现的数据列应保持不变。

期望的输出

##                   cars  mpg cyl  disp  hp drat    wt  qsec   vs  am gear carb
## 1      my_pretty_mazda 21.0   6 160.0 110 3.90 2.620 16.46 1010 777    4    4
## 2        Mazda RX4 Wag 21.0   6 160.0 110 3.90 2.875 17.02 1010 777    4    4
## 3           Datsun 710 22.8   4 108.0  93 3.85 2.320 18.61 2020 777    4    1
## 4    my_amazing_hornet 21.4   6 258.0 110 3.08 3.215 19.44 2020 333    3    1
## 5    Hornet Sportabout 18.7   8 360.0 175 3.15 3.440 17.02 1010 333    3    2
## 6              Valiant 18.1   6 225.0 105 2.76 3.460 20.22 2020 333    3    1
## 7           Duster 360 14.3   8 360.0 245 3.21 3.570 15.84 1010 333    3    4
## 8            Merc 240D 24.4   4 146.7  62 3.69 3.190 20.00 2020 333    4    2
## 9             Merc 230 22.8   4 140.8  95 3.92 3.150 22.90 2020 333    4    2
## 10            Merc 280 19.2   6 167.6 123 3.92 3.440 18.30 2020 333    4    4
## 11           Merc 280C 17.8   6 167.6 123 3.92 3.440 18.90 2020 333    4    4
## 12          Merc 450SE 16.4   8 275.8 180 3.07 4.070 17.40 1010 333    3    3
## 13          Merc 450SL 17.3   8 275.8 180 3.07 3.730 17.60 1010 333    3    3
## 14         Merc 450SLC 15.2   8 275.8 180 3.07 3.780 18.00 1010 333    3    3
## 15  Cadillac Fleetwood 10.4   8 472.0 205 2.93 5.250 17.98 1010 333    3    4
## 16 Lincoln Continental 10.4   8 460.0 215 3.00 5.424 17.82 1010 333    3    4
## 17   Chrysler Imperial 14.7   8 440.0 230 3.23 5.345 17.42 1010 333    3    4
## 18            Fiat 128 32.4   4  78.7  66 4.08 2.200 19.47 2020 777    4    1
## 19         Honda Civic 30.4   4  75.7  52 4.93 1.615 18.52 2020 777    4    2
## 20      Toyota Corolla 33.9   4  71.1  65 4.22 1.835 19.90 2020 777    4    1
## 21       Toyota Corona 21.5   4 120.1  97 3.70 2.465 20.01 2020 333    3    1
## 22    Dodge Challenger 15.5   8 318.0 150 2.76 3.520 16.87 1010 333    3    2
## 23         AMC Javelin 15.2   8 304.0 150 3.15 3.435 17.30 1010 333    3    2
## 24          Camaro Z28 13.3   8 350.0 245 3.73 3.840 15.41 1010 333    3    4
## 25    Pontiac Firebird 19.2   8 400.0 175 3.08 3.845 17.05 1010 333    3    2
## 26           Fiat X1-9 27.3   4  79.0  66 4.08 1.935 18.90 2020 777    4    1
## 27       Porsche 914-2 26.0   4 120.3  91 4.43 2.140 16.70 1010 777    5    2
## 28        Lotus Europa 30.4   4  95.1 113 3.77 1.513 16.90 2020 777    5    2
## 29      Ford Pantera L 15.8   8 351.0 264 4.22 3.170 14.50 1010 777    5    4
## 30   my_speedy_ferrari 19.7   6 145.0 175 3.62 2.770 15.50 1010 777    5    6
## 31       Maserati Bora 15.0   8 301.0 335 3.54 3.570 14.60 1010 777    5    8
## 32          Volvo 142E 21.4   4 121.0 109 4.11 2.780 18.60 2020 777    4    2

由于我习惯了tidyverse 函数，所以dplyr 或purrr 解决方案对我来说都是理想的理解。但我对任何可行的事情持开放态度。谢谢！

【问题讨论】：

标签： r replace dplyr purrr recode

【解决方案1】：

我认为Map 是一个不错的候选人：

my_mtcars[recoding_table$var_name] <- 
  Map(function(x, repl) {
    replacements <- match(x, repl$original)
    replace(x, !is.na(replacements), repl$replacement[replacements][!is.na(replacements)])
  }, my_mtcars[recoding_table$var_name], recoding_table$original_vs_replacement_tbl)

head(my_mtcars)
#                cars  mpg cyl disp  hp drat    wt  qsec   vs  am gear carb
# 1   my_pretty_mazda 21.0   6  160 110 3.90 2.620 16.46 1010 777    4    4
# 2     Mazda RX4 Wag 21.0   6  160 110 3.90 2.875 17.02 1010 777    4    4
# 3        Datsun 710 22.8   4  108  93 3.85 2.320 18.61 2020 777    4    1
# 4 my_amazing_hornet 21.4   6  258 110 3.08 3.215 19.44 2020 333    3    1
# 5 Hornet Sportabout 18.7   8  360 175 3.15 3.440 17.02 1010 333    3    2
# 6           Valiant 18.1   6  225 105 2.76 3.460 20.22 2020 333    3    1

如果你更喜欢purrr，那么

library(purrr)
my_mtcars[recoding_table$var_name] <- 
  map2(my_mtcars[recoding_table$var_name], recoding_table$original_vs_replacement_tbl,
       function(x, repl) {
         replacements <- match(x, repl$original)
         replace(x, !is.na(replacements), repl$replacement[replacements][!is.na(replacements)])
       })

或者如果你也喜欢~-quasi-anonfunction 那么

my_mtcars[recoding_table$var_name] <- 
  map2(my_mtcars[recoding_table$var_name], recoding_table$original_vs_replacement_tbl,
       ~ {
         replacements <- match(.x, .y$original)
         replace(.x, !is.na(replacements), .y$replacement[replacements][!is.na(replacements)])
       })

mutate 版本。我不太喜欢这个，因为它做了更多的工作（filtering 每一步，在上面的Map/map2 版本中不会发生这种情况），但它仍然有效。

my_mtcars %>%
  mutate(across(recoding_table$var_name, ~ {
    repl <- filter(recoding_table, var_name == cur_column())$original_vs_replacement_tbl[[1]]
    ind <- match(., repl$original)
    replace(., !is.na(ind), repl$replacement[ind][!is.na(ind)])
  }))

【讨论】：

这真的很棒，谢谢！既然您已经加倍努力添加purrr::map2() 方式，可以要求使用my_mtcars %>% mutate(across(any_of(recoding_table$var_name), ~map2(...))) 的另一个变体吗？这是我通常使用的实现，但无法围绕您的代码进行调整。
查看我的编辑。我不喜欢那样做，一般也不推荐，因为我发现map2/Map 方法更直接（而且可能更快）。
谢谢。好的，这很有趣。 mutate(across(...)) 是我更新数据帧的首选方法。我从没想过速度会受到影响。

【解决方案2】：

plyr::mapvalues

library(dplyr)
library(plyr)

l <- tibble::deframe(recoding_table)

my_mtcars %>% 
  dplyr::mutate(across(names(l), ~ with(l[[cur_column()]], plyr::mapvalues(.x, original, replacement))))


                  cars  mpg cyl  disp  hp drat    wt  qsec   vs  am gear carb
1      my_pretty_mazda 21.0   6 160.0 110 3.90 2.620 16.46 1010 777    4    4
2        Mazda RX4 Wag 21.0   6 160.0 110 3.90 2.875 17.02 1010 777    4    4
3           Datsun 710 22.8   4 108.0  93 3.85 2.320 18.61 2020 777    4    1
4    my_amazing_hornet 21.4   6 258.0 110 3.08 3.215 19.44 2020 333    3    1
5    Hornet Sportabout 18.7   8 360.0 175 3.15 3.440 17.02 1010 333    3    2

l 是一个列表对象，其中名称为recoding_table$var_name，元素是具有原始值和替换值的数据框。然后，我们可以将plyr::mapvalues 应用于仅在recoding_table 中命名的变量，这些变量存储在列表名称names(l) 中。

dplyr::recode

library(dplyr)
library(purrr)

l <- purrr::imap(deframe(recoding_table), ~ deframe(.))
my_recode <- function(x, y) recode(x, !!!l[[y]])

my_mtcars %>% 
  dplyr::mutate(across(names(l), ~ my_recode(.x, cur_column())))

请注意，直接使用 my_recode 不能用作 lambda 函数：~ recode(.x, !!!l[[cur_column()]])，但是当您在上述函数中使用它时会起作用。同样recode 很可能得到depreciated 另一个动词。

【讨论】：

这是非常简洁易读的代码。我们不应该担心plyr 在我们编写新代码时完全没有得到维护吗？
是的 plyr 不再维护，但如前所述，dplyr 将来可能会为 recode 提供另一个动词。这些中的任何一个都可以在当前版本中使用。请留意 change log 以了解对 recode 的更改。