Skip to content

Warn about discouraged aes() usage during plot build #3346

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.

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

Merged
111 changes: 111 additions & 0 deletions R/aes.r
Original file line number Diff line number Diff line change
Expand Up @@ -334,3 +334,114 @@ mapped_aesthetics <- function(x) {
is_null <- vapply(x, is.null, logical(1))
names(x)[!is_null]
}


#' Check a mapping for discouraged usage
#'
#' @param mapping A mapping created with [aes()]
#' @param data The data to be mapped from
#'
#' @noRd
check_aes <- function(mapping, data) {
check_aes_extract_usage(mapping, data)
check_aes_column_refs(mapping, data)
}

# Checks that $ and [[ are not used when the target *is* the data
check_aes_extract_usage <- function(mapping, data) {
lapply(mapping, check_aes_extract_usage_quo, data)
}

# 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)
}
}

check_aes_extract_usage_quo <- function(quosure, data) {
check_aes_extract_usage_expr(get_expr(quosure), data, get_env(quosure))
}

check_aes_extract_usage_expr <- function(x, data, env = emptyenv()) {
if (is_call(x, "[[") || is_call(x, "$")) {
if (extract_target_is_data(x, data, env)) {
good_usage <- check_aes_get_alternative_usage(x)
warning(
"Use of `", format(x), "` is discouraged. ",
"Use `", good_usage, "` instead.",
call. = FALSE
)
}
} else if (is.call(x)) {
lapply(x, check_aes_extract_usage_expr, data, env)
} else if (is.pairlist(x)) {
lapply(x, check_aes_extract_usage_expr, data, env)
}
}

check_aes_get_alternative_usage <- function(x) {
if (is_call(x, "[[")) {
good_call <- x
good_call[[2]] <- quote(.data)
format(good_call)
} else if (is_call(x, "$")) {
as.character(x[[3]])
} else {
stop("Don't know how to get alternative usage for `", format(x), "`")
}
}

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)
}
6 changes: 5 additions & 1 deletion R/layer.r
Original file line number Diff line number Diff line change
Expand Up @@ -238,10 +238,14 @@ Layer <- ggproto("Layer", NULL,

scales_add_defaults(plot$scales, data, aesthetics, plot$plot_env)

# Evaluate and check aesthetics
# Evaluate aesthetics
evaled <- lapply(aesthetics, eval_tidy, data = data)
evaled <- compact(evaled)

# Check for discouraged usage in mapping
check_aes(aesthetics, data[setdiff(names(data), "PANEL")])

# Check aesthetic values
nondata_cols <- check_nondata_cols(evaled)
if (length(nondata_cols) > 0) {
msg <- paste0(
Expand Down
79 changes: 79 additions & 0 deletions tests/testthat/test-aes.r
Original file line number Diff line number Diff line change
Expand Up @@ -111,6 +111,85 @@ test_that("aes standardises aesthetic names", {
expect_warning(aes(color = x, colour = y), "Duplicated aesthetics")
})

test_that("Improper use of $ and [[ is detected by check_aes_extract_usage()", {

returns_x <- function() "x"
df <- data_frame(x = 1:5, nested_df = data_frame(x = 6:10))

# valid extraction in aes()
expect_silent(check_aes_extract_usage(aes(x), df))
expect_silent(check_aes_extract_usage(aes(.data$x), df))
expect_silent(check_aes_extract_usage(aes(.data[["x"]]), df))
expect_silent(check_aes_extract_usage(aes(.data[[!!quo("x")]]), df))
expect_silent(check_aes_extract_usage(aes(.data[[returns_x()]]), df))
expect_silent(check_aes_extract_usage(aes(!!sym("x")), df))
expect_silent(check_aes_extract_usage(aes(x * 10), df))
expect_silent(check_aes_extract_usage(aes(nested_df$x), df))
expect_silent(check_aes_extract_usage(aes(nested_df[["x"]]), df))
expect_silent(check_aes_extract_usage(aes(.data[[c("nested_df", "x")]]), df))
expect_silent(check_aes_extract_usage(aes(.data[[c(2, 1)]]), df))
expect_silent(check_aes_extract_usage(aes(.data[[1]]), df))

# bad: use of extraction
expect_warning(
check_aes_extract_usage(aes(df$x), df),
"Use of `df\\$x` is discouraged"
)
expect_warning(
check_aes_extract_usage(aes(df[["x"]]), df),
'Use of `df\\[\\["x"\\]\\]` is discouraged'
)
})

test_that("Warnings are issued for improper use of $ and [[ in plots", {
df <- data_frame(x = 1:3, y = 3:1)
p <- ggplot(df, aes(df$x, df$y)) + geom_point()
expect_warning(ggplot_build(p), "Use of `df\\$x` is discouraged")
})

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")
})

# Visual tests ------------------------------------------------------------

Expand Down