重新编码数据帧值：每列都有其单独的查找 table
Recode dataframe values: each column has its individual lookup table
我有一个包含多列的数据框，我想重新编码值。每列都有其单独的一组重新编码规则，在 table of original <=> replacement 映射中给出（每个 table 特定于每一列）。
我正试图想出一个程序化的解决方案，使我能够运行这样的重新编码程序。
例子
我得到的对象
- 数据
- table 存储有关每列重新编码指令的信息
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 中，然后根据 recoding_table$original_vs_replacement_tbl 中的 table 在 my_mtcars 中重新编码该列的值。 没有出现在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 解决方案对我来说是最理想的理解。但我对任何有用的东西都持开放态度。谢谢！
我认为 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 then
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)])
}))
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::重新编码
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 另一个动词。
我有一个包含多列的数据框，我想重新编码值。每列都有其单独的一组重新编码规则，在 table of original <=> replacement 映射中给出（每个 table 特定于每一列）。
我正试图想出一个程序化的解决方案，使我能够运行这样的重新编码程序。
例子
我得到的对象
- 数据
- table 存储有关每列重新编码指令的信息
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 中，然后根据 recoding_table$original_vs_replacement_tbl 中的 table 在 my_mtcars 中重新编码该列的值。 没有出现在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 解决方案对我来说是最理想的理解。但我对任何有用的东西都持开放态度。谢谢！
我认为 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 then
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)])
}))
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::重新编码
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 另一个动词。