Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

Delay dplyr_quosures() auto naming until needed #6797

Merged
merged 1 commit into from
Mar 21, 2023
Merged

Delay dplyr_quosures() auto naming until needed #6797

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
36 changes: 22 additions & 14 deletions R/across.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -545,25 +545,35 @@ new_dplyr_quosure <- function(quo, ...) {
quo
}

dplyr_quosure_name <- function(quo_data) {
if (quo_data$is_named) {
# `name` is a user-supplied or known character string
quo_data$name
} else {
# `name` is a quosure that must be auto-named
with_no_rlang_infix_labeling(as_label(quo_data$name))
}
}

dplyr_quosures <- function(...) {
# We're using quos() instead of enquos() here for speed, because we're not defusing named arguments --
# only the ellipsis is converted to quosures, there are no further arguments.
quosures <- quos(..., .ignore_empty = "all")
names_given <- names2(quosures)
names <- names2(quosures)

for (i in seq_along(quosures)) {
quosure <- quosures[[i]]
name_given <- names_given[[i]]
is_named <- (name_given != "")
if (is_named) {
name_auto <- name_given
} else {
name_auto <- with_no_rlang_infix_labeling(as_label(quosure))
name <- names[[i]]
is_named <- (name != "")

if (!is_named) {
# Will be auto-named by `dplyr_quosure_name()` only as needed
name <- quosure
Copy link
Member Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

The fact that we capture and store the original quosure is somewhat important here, as there are cases with pick() where we expand the quosure into something else, so we need a reference to the original one to be able to auto-name it correctly. I've added a test for this.

}

quosures[[i]] <- new_dplyr_quosure(quosure,
name_given = name_given,
name_auto = name_auto,
quosures[[i]] <- new_dplyr_quosure(
quo = quosure,
name = name,
is_named = is_named,
index = i
)
Expand Down Expand Up @@ -739,8 +749,7 @@ expand_across <- function(quo) {
quo <- new_quosure(sym(var), empty_env())
quo <- new_dplyr_quosure(
quo,
name_given = name,
name_auto = name,
name = name,
is_named = TRUE,
index = c(quo_data$index, k),
column = var
Expand Down Expand Up @@ -770,8 +779,7 @@ expand_across <- function(quo) {
name <- names[[k]]
expressions[[k]] <- new_dplyr_quosure(
fn_call,
name_given = name,
name_auto = name,
name = name,
is_named = TRUE,
index = c(quo_data$index, k),
column = var
Expand Down
10 changes: 6 additions & 4 deletions R/mutate.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -382,7 +382,8 @@ mutate_col <- function(dot, data, mask, new_columns) {
chunks <- withCallingHandlers(
mask$eval_all_mutate(quo),
error = function(cnd) {
msg <- glue("Can't compute column `{quo_data$name_auto}`.")
name <- dplyr_quosure_name(quo_data)
msg <- glue("Can't compute column `{name}`.")
abort(msg, call = call("across"), parent = cnd)
}
)
Expand All @@ -398,7 +399,8 @@ mutate_col <- function(dot, data, mask, new_columns) {
if (length(rows) == 1) {
result <- chunks[[1]]
} else {
chunks <- dplyr_vec_cast_common(chunks, quo_data$name_auto)
# `name` specified lazily
chunks <- dplyr_vec_cast_common(chunks, name = dplyr_quosure_name(quo_data))
result <- list_unchop(chunks, indices = rows)
}
}
Expand All @@ -414,7 +416,7 @@ mutate_col <- function(dot, data, mask, new_columns) {
quo_result <- quosures_results[[k]]
if (is.null(quo_result)) {
if (quo_data$is_named) {
name <- quo_data$name_given
name <- dplyr_quosure_name(quo_data)
new_columns[[name]] <- zap()
mask$remove(name)
}
Expand All @@ -436,7 +438,7 @@ mutate_col <- function(dot, data, mask, new_columns) {
new_columns[types_names] <- result
} else {
# treat as a single output otherwise
name <- quo_data$name_auto
name <- dplyr_quosure_name(quo_data)
mask$add_one(name = name, chunks = chunks, result = result)

new_columns[[name]] <- result
Expand Down
11 changes: 8 additions & 3 deletions R/summarise.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -302,7 +302,7 @@ summarise_cols <- function(data, dots, by, verb, error_call = caller_env()) {
results <- append(results, results_k)
out_names <- c(out_names, types_k_names)
} else {
name <- quo_data$name_auto
name <- dplyr_quosure_name(quo_data)
mask$add_one(name = name, chunks = chunks_k, result = results_k)
chunks <- append(chunks, list(chunks_k))
types <- append(types, list(types_k))
Expand Down Expand Up @@ -360,7 +360,8 @@ summarise_eval_one <- function(quo, mask) {
chunks_k <- withCallingHandlers(
mask$eval_all_summarise(quo),
error = function(cnd) {
msg <- glue("Can't compute column `{quo_data$name_auto}`.")
name <- dplyr_quosure_name(quo_data)
msg <- glue("Can't compute column `{name}`.")
abort(msg, call = call("across"), parent = cnd)
}
)
Expand All @@ -372,7 +373,11 @@ summarise_eval_one <- function(quo, mask) {
return(NULL)
}

types_k <- dplyr_vec_ptype_common(chunks_k, quo_data$name_auto)
# `name` specified lazily
types_k <- dplyr_vec_ptype_common(
chunks = chunks_k,
name = dplyr_quosure_name(quo_data)
)

chunks_k <- vec_cast_common(!!!chunks_k, .to = types_k)
result_k <- vec_c(!!!chunks_k, .ptype = types_k)
Expand Down
12 changes: 12 additions & 0 deletions tests/testthat/_snaps/pick.md
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -128,6 +128,18 @@
Error in `pick()`:
! Must only be used inside data-masking verbs like `mutate()`, `filter()`, and `group_by()`.

# when expansion occurs, error labels use the pre-expansion quosure

Code
mutate(df, if (cur_group_id() == 1L) pick(x) else "x", .by = g)
Condition
Error in `mutate()`:
i In argument: `if (cur_group_id() == 1L) pick(x) else "x"`.
Caused by error:
! `if (cur_group_id() == 1L) pick(x) else "x"` must return compatible vectors across groups.
i Result of type <tbl_df<x:double>> for group 1: `g = 1`.
i Result of type <character> for group 2: `g = 2`.

# doesn't allow renaming

Code
Expand Down
6 changes: 2 additions & 4 deletions tests/testthat/test-across.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -1020,8 +1020,7 @@ test_that("expand_across() expands lambdas", {
quo <- quo(across(c(cyl, am), ~ identity(.x)))
quo <- new_dplyr_quosure(
quo,
name_given = "",
name_auto = "across()",
name = quo,
is_named = FALSE,
index = 1
)
Expand All @@ -1042,8 +1041,7 @@ test_that("expand_if_across() expands lambdas", {
quo <- quo(if_any(c(cyl, am), ~ . > 4))
quo <- new_dplyr_quosure(
quo,
name_given = "",
name_auto = "if_any()",
name = quo,
is_named = FALSE,
index = 1
)
Expand Down
10 changes: 10 additions & 0 deletions tests/testthat/test-pick.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -326,6 +326,16 @@ test_that("selection on rowwise data frames uses full list-cols, but actual eval
expect_identical(out$y, map(df$x, ~tibble(x = .x)))
})

test_that("when expansion occurs, error labels use the pre-expansion quosure", {
df <- tibble(g = c(1, 2, 2), x = c(1, 2, 3))

# Fails in common type casting of the group chunks,
# which references the auto-named column name
expect_snapshot(error = TRUE, {
mutate(df, if (cur_group_id() == 1L) pick(x) else "x", .by = g)
})
})

test_that("doesn't allow renaming", {
expect_snapshot(error = TRUE, {
mutate(data.frame(x = 1), pick(y = x))
Expand Down