使用带别名的公式执行多列操作
Using formulas with aliases to perform multi-column operations
此问题与 有关，但试图更通用。我想使用公式对多个 "groups" 数据执行操作（即 a_data1、a_data2、b_data1、b_data2，然后使用 *_data1 列）。
根据@ak运行对该问题的回答，我创建了以下函数。它采用单向公式并将其应用于所有 "groups of data":
suppressPackageStartupMessages({
library(dplyr)
library(tidyr)
})
polymutate <- function(df, formula,
pattern = "(.)_(.*)",
staticCols = NULL) {
staticCols <- rlang::enquo(staticCols)
rhs <- rlang::f_rhs(formula)
names <- all.vars(rhs)
df %>%
mutate(
rn = row_number()
) %>%
pivot_longer(
cols = -c(rn, !!staticCols),
names_to = c(".value", "grp"),
names_pattern = pattern
) %>%
mutate(
new = eval(rhs)
) %>%
pivot_wider(
names_from = grp,
values_from = c(names, "new")
) %>%
select(
-rn
) %>%
rename_at(
vars(starts_with("new")),
gsub, pattern = "^new_", replacement = ""
)
}
df <- data.frame(a_data1 = 1:3, b_data1 = 2:4,
a_data2 = 3:5, b_data2 = 4:6,
static = 5:7)
polymutate(df, ~ a + b, staticCols = static)
#> # A tibble: 3 x 7
#> static a_data1 a_data2 b_data1 b_data2 data1 data2
#> <int> <int> <int> <int> <int> <int> <int>
#> 1 5 1 3 2 4 3 7
#> 2 6 2 4 3 5 5 9
#> 3 7 3 5 4 6 7 11
由 reprex package (v0.3.0)
于 2020 年 3 月 13 日创建
因此，此 polymutate 将数据帧转换为更长的格式，这样我们就有一列包含组名称（data1 或 data2）和每个前缀一列（a 和 b）。然后它在这个更深的数据框的上下文中评估给定的公式（显然公式中的名称必须与前缀匹配）。完成后，它会将数据框加宽回其原始形状。
这很好用，但有点慢。在具有 20,000 行和 11 "groups" 的数据帧上使用它需要 0.77 秒。
我认为这是由于需要对如此大的数据框进行两次重组：加深然后加宽。
所以我想知道我是否可以轻松地做到这一点。我找到了 wrapr 包，它允许我们为名称创建别名。因此，我应该能够执行与上述类似的操作，传递公式和我想要更改的列的名称。
然后它可以提取公式中使用的变量并使用它们重建所需的列名，创建别名映射，然后使用该映射将公式应用于数据框。我已经很接近了，但无法得到要评估的实际公式：
suppressPackageStartupMessages({
library(dplyr)
})
polymutate2 <- function(df, formula, name) {
vars <- all.vars(formula)
rhs <- rlang::f_rhs(formula)
aliases <- paste0(vars, "_", name)
mapping <- rlang::list2(!!!aliases)
names(mapping) <- vars
mapping <- do.call(wrapr::qc, mapping)
wrapr::let(
mapping,
df %>% mutate(!!name := a + b)
)
}
df <- data.frame(a_data1 = 1:3, b_data1 = 2:4,
a_data2 = 3:5, b_data2 = 4:6,
static = 5:7)
polymutate2(df, ~ a + b, "data1")
#> a_data1 b_data1 a_data2 b_data2 static data1
#> 1 1 2 3 4 5 3
#> 2 2 3 4 5 6 5
#> 3 3 4 5 6 7 7
由 reprex package (v0.3.0)
于 2020 年 3 月 13 日创建
您会注意到 mutate 调用有一个硬编码的表达式，因为我无法让它与给定的公式一起使用。像以前的版本一样用 eval(rhs) 替换该表达式会引发 object 'a' not found 错误：
suppressPackageStartupMessages({
library(dplyr)
# library(tidyr)
})
polymutate2 <- function(df, formula, name) {
vars <- all.vars(formula)
rhs <- rlang::f_rhs(formula)
aliases <- paste0(vars, "_", name)
mapping <- rlang::list2(!!!aliases)
names(mapping) <- vars
mapping <- do.call(wrapr::qc, mapping)
wrapr::let(
mapping,
df %>% mutate(!!name := eval(rhs))
)
}
polymutate2(df, ~ a + b, "data1")
#> Error in eval(rhs): object 'a' not found
如果我能让它工作（假设该解决方案不会显着损害性能），它会快得多：只需要 0.03 秒即可完成 运行 一连串的 polymutate2 （我的 20,000 行数据框中的 11 个组中的每一个）。
那么，我怎样才能让 polymutate2 使用任何公式？我愿意接受任何建议，如果存在其他解决方案，则无需使用 wrapr。 （我还担心如果公式很复杂，调用函数或诸如此类的东西，这个解决方案可能不起作用，只是还没有设法检查）。
也许更有知识的人可以用更整洁的方法来插话，但是这个问题可以通过将整个 wrapr::let 调用包装到 eval(parse(text=..)) 中来解决（诚然，不是很优雅）-它绝对更快：
suppressPackageStartupMessages({
invisible(lapply(c("dplyr", "tidyr", "rlang", "wrapr", "microbenchmark"),
require, character.only = TRUE))
})
polymutate <- function(df, formula,
pattern = "(.)_(.*)",
staticCols = NULL) {
staticCols <- rlang::enquo(staticCols)
rhs <- rlang::f_rhs(formula)
names <- all.vars(rhs)
df %>%
mutate(
rn = row_number()
) %>%
pivot_longer(
cols = -c(rn, !!staticCols),
names_to = c(".value", "grp"),
names_pattern = pattern
) %>%
mutate(
new = eval(rhs)
) %>%
pivot_wider(
names_from = grp,
values_from = c(names, "new")
) %>%
select(
-rn
) %>%
rename_at(
vars(starts_with("new")),
gsub, pattern = "^new_", replacement = ""
)
}
polymutate2 <- function(df, formula, name) {
vars <- all.vars(formula)
rhs <- deparse(rlang::f_rhs(formula))
aliases <- paste0(vars, "_", name)
mapping <- rlang::list2(!!!aliases)
names(mapping) <- vars
mapping <- do.call(wrapr::qc, mapping)
eval(parse(text=paste0("wrapr::let(mapping, df %>% mutate(!!name := ", rhs, "))" ))
)
}
set.seed(1)
df <- setNames(data.frame(matrix(sample(1:12, 7E6, replace=TRUE), ncol=7)),
c("a_data1", "b_data1", "a_data2", "b_data2", "a_data3", "b_data3", "static"))
pd <- polymutate(df, ~ a + b, staticCols = static)
#> Note: Using an external vector in selections is ambiguous.
#> ℹ Use `all_of(names)` instead of `names` to silence this message.
#> ℹ See <https://tidyselect.r-lib.org/reference/faq-external-vector.html>.
#> This message is displayed once per session.
pd2 <- polymutate2(df, ~ a + b, "data1") %>% polymutate2(., ~ a + b, "data2") %>% polymutate2(., ~ a + b, "data3") %>% dplyr::select(static, everything()) %>%
as_tibble()
all.equal(pd, pd2)
#> [1] TRUE
microbenchmark(polymutate(df, ~ a + b, staticCols = static),
polymutate2(df, ~ a + b, "data1") %>% polymutate2(., ~ a + b, "data2") %>% polymutate2(., ~ a + b, "data3") %>% dplyr::select(static, everything()) %>%
as_tibble(),
times=10L)
#> Unit: milliseconds
#> expr
#> polymutate(df, ~a + b, staticCols = static)
#> polymutate2(df, ~a + b, "data1") %>% polymutate2(., ~a + b, "data2") %>% polymutate2(., ~a + b, "data3") %>% dplyr::select(static, everything()) %>% as_tibble()
#> min lq mean median uq max neval cld
#> 1143.582663 1151.206750 1171.46502 1173.03649 1188.91108 1209.01984 10 b
#> 9.553352 9.619473 10.88463 10.59397 12.27675 12.52403 10 a
由 reprex package (v0.3.0)
于 2020-03-14 创建
此问题与 a_data1、a_data2、b_data1、b_data2，然后使用 *_data1 列）。
根据@ak运行对该问题的回答，我创建了以下函数。它采用单向公式并将其应用于所有 "groups of data":
suppressPackageStartupMessages({
library(dplyr)
library(tidyr)
})
polymutate <- function(df, formula,
pattern = "(.)_(.*)",
staticCols = NULL) {
staticCols <- rlang::enquo(staticCols)
rhs <- rlang::f_rhs(formula)
names <- all.vars(rhs)
df %>%
mutate(
rn = row_number()
) %>%
pivot_longer(
cols = -c(rn, !!staticCols),
names_to = c(".value", "grp"),
names_pattern = pattern
) %>%
mutate(
new = eval(rhs)
) %>%
pivot_wider(
names_from = grp,
values_from = c(names, "new")
) %>%
select(
-rn
) %>%
rename_at(
vars(starts_with("new")),
gsub, pattern = "^new_", replacement = ""
)
}
df <- data.frame(a_data1 = 1:3, b_data1 = 2:4,
a_data2 = 3:5, b_data2 = 4:6,
static = 5:7)
polymutate(df, ~ a + b, staticCols = static)
#> # A tibble: 3 x 7
#> static a_data1 a_data2 b_data1 b_data2 data1 data2
#> <int> <int> <int> <int> <int> <int> <int>
#> 1 5 1 3 2 4 3 7
#> 2 6 2 4 3 5 5 9
#> 3 7 3 5 4 6 7 11
由 reprex package (v0.3.0)
于 2020 年 3 月 13 日创建因此，此 polymutate 将数据帧转换为更长的格式，这样我们就有一列包含组名称（data1 或 data2）和每个前缀一列（a 和 b）。然后它在这个更深的数据框的上下文中评估给定的公式（显然公式中的名称必须与前缀匹配）。完成后，它会将数据框加宽回其原始形状。
这很好用，但有点慢。在具有 20,000 行和 11 "groups" 的数据帧上使用它需要 0.77 秒。
我认为这是由于需要对如此大的数据框进行两次重组：加深然后加宽。
所以我想知道我是否可以轻松地做到这一点。我找到了 wrapr 包，它允许我们为名称创建别名。因此，我应该能够执行与上述类似的操作，传递公式和我想要更改的列的名称。
然后它可以提取公式中使用的变量并使用它们重建所需的列名，创建别名映射，然后使用该映射将公式应用于数据框。我已经很接近了，但无法得到要评估的实际公式：
suppressPackageStartupMessages({
library(dplyr)
})
polymutate2 <- function(df, formula, name) {
vars <- all.vars(formula)
rhs <- rlang::f_rhs(formula)
aliases <- paste0(vars, "_", name)
mapping <- rlang::list2(!!!aliases)
names(mapping) <- vars
mapping <- do.call(wrapr::qc, mapping)
wrapr::let(
mapping,
df %>% mutate(!!name := a + b)
)
}
df <- data.frame(a_data1 = 1:3, b_data1 = 2:4,
a_data2 = 3:5, b_data2 = 4:6,
static = 5:7)
polymutate2(df, ~ a + b, "data1")
#> a_data1 b_data1 a_data2 b_data2 static data1
#> 1 1 2 3 4 5 3
#> 2 2 3 4 5 6 5
#> 3 3 4 5 6 7 7
由 reprex package (v0.3.0)
于 2020 年 3 月 13 日创建您会注意到 mutate 调用有一个硬编码的表达式，因为我无法让它与给定的公式一起使用。像以前的版本一样用 eval(rhs) 替换该表达式会引发 object 'a' not found 错误：
suppressPackageStartupMessages({
library(dplyr)
# library(tidyr)
})
polymutate2 <- function(df, formula, name) {
vars <- all.vars(formula)
rhs <- rlang::f_rhs(formula)
aliases <- paste0(vars, "_", name)
mapping <- rlang::list2(!!!aliases)
names(mapping) <- vars
mapping <- do.call(wrapr::qc, mapping)
wrapr::let(
mapping,
df %>% mutate(!!name := eval(rhs))
)
}
polymutate2(df, ~ a + b, "data1")
#> Error in eval(rhs): object 'a' not found
如果我能让它工作（假设该解决方案不会显着损害性能），它会快得多：只需要 0.03 秒即可完成 运行 一连串的 polymutate2 （我的 20,000 行数据框中的 11 个组中的每一个）。
那么，我怎样才能让 polymutate2 使用任何公式？我愿意接受任何建议，如果存在其他解决方案，则无需使用 wrapr。 （我还担心如果公式很复杂，调用函数或诸如此类的东西，这个解决方案可能不起作用，只是还没有设法检查）。
也许更有知识的人可以用更整洁的方法来插话，但是这个问题可以通过将整个 wrapr::let 调用包装到 eval(parse(text=..)) 中来解决（诚然，不是很优雅）-它绝对更快：
suppressPackageStartupMessages({
invisible(lapply(c("dplyr", "tidyr", "rlang", "wrapr", "microbenchmark"),
require, character.only = TRUE))
})
polymutate <- function(df, formula,
pattern = "(.)_(.*)",
staticCols = NULL) {
staticCols <- rlang::enquo(staticCols)
rhs <- rlang::f_rhs(formula)
names <- all.vars(rhs)
df %>%
mutate(
rn = row_number()
) %>%
pivot_longer(
cols = -c(rn, !!staticCols),
names_to = c(".value", "grp"),
names_pattern = pattern
) %>%
mutate(
new = eval(rhs)
) %>%
pivot_wider(
names_from = grp,
values_from = c(names, "new")
) %>%
select(
-rn
) %>%
rename_at(
vars(starts_with("new")),
gsub, pattern = "^new_", replacement = ""
)
}
polymutate2 <- function(df, formula, name) {
vars <- all.vars(formula)
rhs <- deparse(rlang::f_rhs(formula))
aliases <- paste0(vars, "_", name)
mapping <- rlang::list2(!!!aliases)
names(mapping) <- vars
mapping <- do.call(wrapr::qc, mapping)
eval(parse(text=paste0("wrapr::let(mapping, df %>% mutate(!!name := ", rhs, "))" ))
)
}
set.seed(1)
df <- setNames(data.frame(matrix(sample(1:12, 7E6, replace=TRUE), ncol=7)),
c("a_data1", "b_data1", "a_data2", "b_data2", "a_data3", "b_data3", "static"))
pd <- polymutate(df, ~ a + b, staticCols = static)
#> Note: Using an external vector in selections is ambiguous.
#> ℹ Use `all_of(names)` instead of `names` to silence this message.
#> ℹ See <https://tidyselect.r-lib.org/reference/faq-external-vector.html>.
#> This message is displayed once per session.
pd2 <- polymutate2(df, ~ a + b, "data1") %>% polymutate2(., ~ a + b, "data2") %>% polymutate2(., ~ a + b, "data3") %>% dplyr::select(static, everything()) %>%
as_tibble()
all.equal(pd, pd2)
#> [1] TRUE
microbenchmark(polymutate(df, ~ a + b, staticCols = static),
polymutate2(df, ~ a + b, "data1") %>% polymutate2(., ~ a + b, "data2") %>% polymutate2(., ~ a + b, "data3") %>% dplyr::select(static, everything()) %>%
as_tibble(),
times=10L)
#> Unit: milliseconds
#> expr
#> polymutate(df, ~a + b, staticCols = static)
#> polymutate2(df, ~a + b, "data1") %>% polymutate2(., ~a + b, "data2") %>% polymutate2(., ~a + b, "data3") %>% dplyr::select(static, everything()) %>% as_tibble()
#> min lq mean median uq max neval cld
#> 1143.582663 1151.206750 1171.46502 1173.03649 1188.91108 1209.01984 10 b
#> 9.553352 9.619473 10.88463 10.59397 12.27675 12.52403 10 a
由 reprex package (v0.3.0)
于 2020-03-14 创建