Created
June 3, 2019 18:18
-
-
Save paleolimbot/832d30625d2cd46f39086228355a9dc0 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
library(testthat) | |
library(rlang) | |
withr::with_namespace("ggplot2", { | |
# Checks that mapping refers to at least one column in data | |
check_aes_column_refs <- function(mapping, data) { | |
if (empty(data) || length(mapping) == 0) return() | |
data_name <- as_label(enquo(data)) | |
cols_in_mapping <- unlist(lapply(mapping, quo_column_refs, data)) | |
if (length(cols_in_mapping) == 0) { | |
warning("Mapping contains zero mapped columns from data", call. = FALSE) | |
} | |
} | |
quo_column_refs <- function(quosure, data) { | |
expr_column_refs(get_expr(quosure), data, get_env(quosure)) | |
} | |
expr_column_refs <- function(x, data, env = emptyenv()) { | |
if (is.name(x) && (as.character(x) %in% names(data))) { | |
as.character(x) | |
} else if (is_call(x, "[[") && extract_target_is_quo_data(x, data, env)) { | |
# in extract calls from .data, the index is not overscoped with the data | |
index_value <- try(eval_tidy(x[[3]], data = NULL, env), silent = TRUE) | |
if (inherits(index_value, "try-error")) { | |
character(0) | |
} else { | |
column_ref_from_index(index_value, data) | |
} | |
} else if (is_call(x, "$") && extract_target_is_quo_data(x, data, env)) { | |
as.character(x[[3]]) | |
} else if (is_call(x, "$")) { | |
expr_column_refs(x[[2]], data, env) | |
} else if (is.call(x)) { | |
new_names <- lapply(x, expr_column_refs, data, env) | |
unlist(new_names) | |
} else if (is.pairlist(x)) { | |
new_names <- lapply(x, expr_column_refs, data, env) | |
unlist(new_names) | |
} else { | |
character(0) | |
} | |
} | |
column_ref_from_index <- function(index, data) { | |
if (is.character(index)) { | |
index[1] | |
} else if (is.numeric(index)) { | |
names(data)[index[1]] | |
} else { | |
character(0) | |
} | |
} | |
extract_target_is_data <- function(x, data, env) { | |
data_eval <- try(eval_tidy(x[[2]], data, env), silent = TRUE) | |
identical(data_eval, data) | |
} | |
extract_target_is_quo_data <- function(x, data, env) { | |
identical(x[[2]], quote(.data)) || extract_target_is_data(x, data, env) | |
} | |
test_that("Column names are correctly extracted from quosures", { | |
returns_x <- function() "x" | |
df <- data_frame(x = 1:5, y = 12, nested_df = data_frame(x = 6:10)) | |
returns_df <- function() df | |
not_df <- data_frame(x = 1:5) | |
# valid ways to map a column | |
expect_setequal(quo_column_refs(quo(x), df), "x") | |
expect_setequal(quo_column_refs(quo(x * y), df), c("x", "y")) | |
expect_setequal(quo_column_refs(quo(.data$x), df), "x") | |
expect_setequal(quo_column_refs(quo(.data[["x"]]), df), "x") | |
expect_setequal(quo_column_refs(quo(.data[[!!quo("x")]]), df), "x") | |
expect_setequal(quo_column_refs(quo(.data[[returns_x()]]), df), "x") | |
expect_setequal(quo_column_refs(quo(!!sym("x")), df), "x") | |
expect_setequal(quo_column_refs(quo(x * 10), df), "x") | |
expect_setequal(quo_column_refs(quo(nested_df$x), df), "nested_df") | |
expect_setequal(quo_column_refs(quo(nested_df[["x"]]), df), "nested_df") | |
expect_setequal(quo_column_refs(quo(.data[[c("nested_df", "x")]]), df), "nested_df") | |
expect_setequal(quo_column_refs(quo(.data[[c(3, 1)]]), df), "nested_df") | |
expect_setequal(quo_column_refs(quo(.data[[1]]), df), "x") | |
# spurious ways to map a column that don't currently fail | |
expect_setequal(quo_column_refs(quo(df$x), df), "x") | |
expect_setequal(quo_column_refs(quo(returns_df()$x), df), "x") | |
expect_setequal(quo_column_refs(quo(df[["x"]]), df), "x") | |
# no columns mapped | |
expect_identical(quo_column_refs(quo(), df), character(0)) | |
expect_identical(quo_column_refs(quo(not_a_column), df), character(0)) | |
expect_identical(quo_column_refs(quo(not_a_column * also_not_a_column), df), character(0)) | |
# evaluation errors should result in zero mapped columns | |
expect_identical(quo_column_refs(quo(not_a_column$x), df), character(0)) | |
expect_identical(quo_column_refs(quo(not_df$x), df), character(0)) | |
expect_identical(quo_column_refs(quo(not_a_function()), df), character(0)) | |
}) | |
# test_that("Warnings are issued when zero columns from data are mapped", { | |
# df <- data_frame(x = 1:3, y = 3:1) | |
# p <- ggplot(df, aes(x, y)) + geom_hline(aes(yintercept = 1.5)) | |
# expect_warning(ggplot_build(p), "zero mapped columns") | |
# }) | |
}) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment