From 02e107edc048ead233a497ccc8b44721b8055b4e Mon Sep 17 00:00:00 2001 From: Hiroaki Yutani Date: Wed, 15 Jan 2020 22:28:37 +0900 Subject: [PATCH 01/10] Use possible_columns --- R/facet-.r | 33 ++++++++++++++++++++++++++++----- R/facet-grid-.r | 2 +- R/facet-wrap.r | 2 +- 3 files changed, 30 insertions(+), 7 deletions(-) diff --git a/R/facet-.r b/R/facet-.r index 7e2b0eed66..85b4aabf43 100644 --- a/R/facet-.r +++ b/R/facet-.r @@ -155,6 +155,7 @@ Facet <- ggproto("Facet", NULL, panels }, setup_params = function(data, params) { + params$.possible_columns <- unique(unlist(lapply(data, names))) params }, setup_data = function(data, params) { @@ -417,11 +418,12 @@ is_facets <- function(x) { # when evaluating an expression, you want to see any errors. That does # mean you can't have background data when faceting by an expression, # but that seems like a reasonable tradeoff. -eval_facets <- function(facets, data, env = globalenv()) { - vars <- compact(lapply(facets, eval_facet, data, env = env)) +eval_facets <- function(facets, data, env = globalenv(), possible_columns = NULL) { + vars <- compact(lapply(facets, eval_facet, data, env = env, possible_columns = possible_columns)) new_data_frame(tibble::as_tibble(vars)) } -eval_facet <- function(facet, data, env = emptyenv()) { +eval_facet <- function(facet, data, env = emptyenv(), possible_columns = NULL) { + browser() if (quo_is_symbol(facet)) { facet <- as.character(quo_get_expr(facet)) @@ -433,7 +435,24 @@ eval_facet <- function(facet, data, env = emptyenv()) { return(out) } - eval_tidy(facet, data, env) + # clone the env in order to prevent side effects (hopefully) + env <- env_clone(env) + + # create a env with active bindings + cushioning_env <- child_env(env_parent(env)) + bindings <- lapply( + set_names(possible_columns), + function(...) function(e) abort("", class = "ggplot2_undefined_aes_error") + ) + env_bind_active(cushioning_env, !!!bindings) + + # inject the cushioning env into the original chain of environments + env_poke_parent(env, cushioning_env) + + tryCatch( + eval_tidy(facet, data, env), + ggplot2_undefined_aes_error = function(e) NULL + ) } layout_null <- function() { @@ -524,10 +543,14 @@ panel_rows <- function(table) { #' @keywords internal #' @export combine_vars <- function(data, env = emptyenv(), vars = NULL, drop = TRUE) { + possible_columns <- unique(unlist(lapply(data, names))) if (length(vars) == 0) return(new_data_frame()) # For each layer, compute the facet values - values <- compact(lapply(data, eval_facets, facets = vars, env = env)) + values <- compact(lapply(data, eval_facets, + facets = vars, + env = env, + possible_columns = possible_columns)) # Form the base data.frame which contains all combinations of faceting # variables that appear in the data diff --git a/R/facet-grid-.r b/R/facet-grid-.r index 1a6bd430bb..6f7bc9768b 100644 --- a/R/facet-grid-.r +++ b/R/facet-grid-.r @@ -252,7 +252,7 @@ FacetGrid <- ggproto("FacetGrid", Facet, intersect(names(cols), names(data))) data <- reshape_add_margins(data, margin_vars, params$margins) - facet_vals <- eval_facets(c(rows, cols), data, params$plot_env) + facet_vals <- eval_facets(c(rows, cols), data, params$plot_env, params$.possible_columns) # If any faceting variables are missing, add them in by # duplicating the data diff --git a/R/facet-wrap.r b/R/facet-wrap.r index 926322c420..25d45c00ca 100644 --- a/R/facet-wrap.r +++ b/R/facet-wrap.r @@ -187,7 +187,7 @@ FacetWrap <- ggproto("FacetWrap", Facet, return(data) } - facet_vals <- eval_facets(vars, data, params$plot_env) + facet_vals <- eval_facets(vars, data, params$plot_env, params$.possible_columns) facet_vals[] <- lapply(facet_vals[], as.factor) missing_facets <- setdiff(names(vars), names(facet_vals)) From 3a31c5924730ca7e40c83c8903506ab729f2a051 Mon Sep 17 00:00:00 2001 From: Hiroaki Yutani Date: Wed, 15 Jan 2020 23:34:59 +0900 Subject: [PATCH 02/10] Do not use env to evaluate facets --- R/facet-.r | 17 +++++++---------- R/facet-grid-.r | 2 +- R/facet-wrap.r | 2 +- 3 files changed, 9 insertions(+), 12 deletions(-) diff --git a/R/facet-.r b/R/facet-.r index 85b4aabf43..5d3f7a8409 100644 --- a/R/facet-.r +++ b/R/facet-.r @@ -418,12 +418,11 @@ is_facets <- function(x) { # when evaluating an expression, you want to see any errors. That does # mean you can't have background data when faceting by an expression, # but that seems like a reasonable tradeoff. -eval_facets <- function(facets, data, env = globalenv(), possible_columns = NULL) { - vars <- compact(lapply(facets, eval_facet, data, env = env, possible_columns = possible_columns)) +eval_facets <- function(facets, data, possible_columns = NULL) { + vars <- compact(lapply(facets, eval_facet, data, possible_columns = possible_columns)) new_data_frame(tibble::as_tibble(vars)) } -eval_facet <- function(facet, data, env = emptyenv(), possible_columns = NULL) { - browser() +eval_facet <- function(facet, data, possible_columns = NULL) { if (quo_is_symbol(facet)) { facet <- as.character(quo_get_expr(facet)) @@ -436,7 +435,7 @@ eval_facet <- function(facet, data, env = emptyenv(), possible_columns = NULL) { } # clone the env in order to prevent side effects (hopefully) - env <- env_clone(env) + env <- env_clone(quo_get_env(facet)) # create a env with active bindings cushioning_env <- child_env(env_parent(env)) @@ -448,9 +447,10 @@ eval_facet <- function(facet, data, env = emptyenv(), possible_columns = NULL) { # inject the cushioning env into the original chain of environments env_poke_parent(env, cushioning_env) + facet <- quo_set_env(facet, env) tryCatch( - eval_tidy(facet, data, env), + eval_tidy(facet, data), ggplot2_undefined_aes_error = function(e) NULL ) } @@ -547,10 +547,7 @@ combine_vars <- function(data, env = emptyenv(), vars = NULL, drop = TRUE) { if (length(vars) == 0) return(new_data_frame()) # For each layer, compute the facet values - values <- compact(lapply(data, eval_facets, - facets = vars, - env = env, - possible_columns = possible_columns)) + values <- compact(lapply(data, eval_facets, facets = vars, possible_columns = possible_columns)) # Form the base data.frame which contains all combinations of faceting # variables that appear in the data diff --git a/R/facet-grid-.r b/R/facet-grid-.r index 6f7bc9768b..fe4fe926f1 100644 --- a/R/facet-grid-.r +++ b/R/facet-grid-.r @@ -252,7 +252,7 @@ FacetGrid <- ggproto("FacetGrid", Facet, intersect(names(cols), names(data))) data <- reshape_add_margins(data, margin_vars, params$margins) - facet_vals <- eval_facets(c(rows, cols), data, params$plot_env, params$.possible_columns) + facet_vals <- eval_facets(c(rows, cols), data, params$.possible_columns) # If any faceting variables are missing, add them in by # duplicating the data diff --git a/R/facet-wrap.r b/R/facet-wrap.r index 25d45c00ca..b5c11f895e 100644 --- a/R/facet-wrap.r +++ b/R/facet-wrap.r @@ -187,7 +187,7 @@ FacetWrap <- ggproto("FacetWrap", Facet, return(data) } - facet_vals <- eval_facets(vars, data, params$plot_env, params$.possible_columns) + facet_vals <- eval_facets(vars, data, params$.possible_columns) facet_vals[] <- lapply(facet_vals[], as.factor) missing_facets <- setdiff(names(vars), names(facet_vals)) From 9d48e3d34ec3c3deddbeece318938d2236873fc3 Mon Sep 17 00:00:00 2001 From: Hiroaki Yutani Date: Wed, 15 Jan 2020 23:37:11 +0900 Subject: [PATCH 03/10] Remove a shortcut when facet is a quosure of a symbol --- R/facet-.r | 11 ----------- 1 file changed, 11 deletions(-) diff --git a/R/facet-.r b/R/facet-.r index 5d3f7a8409..579b9b5386 100644 --- a/R/facet-.r +++ b/R/facet-.r @@ -423,17 +423,6 @@ eval_facets <- function(facets, data, possible_columns = NULL) { new_data_frame(tibble::as_tibble(vars)) } eval_facet <- function(facet, data, possible_columns = NULL) { - if (quo_is_symbol(facet)) { - facet <- as.character(quo_get_expr(facet)) - - if (facet %in% names(data)) { - out <- data[[facet]] - } else { - out <- NULL - } - return(out) - } - # clone the env in order to prevent side effects (hopefully) env <- env_clone(quo_get_env(facet)) From bebfa222d4de79a55dcbf21510c54fb6d5925292 Mon Sep 17 00:00:00 2001 From: Hiroaki Yutani Date: Wed, 15 Jan 2020 23:53:40 +0900 Subject: [PATCH 04/10] Revert to keep the current warning --- R/facet-.r | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/R/facet-.r b/R/facet-.r index 579b9b5386..f0bbb16df1 100644 --- a/R/facet-.r +++ b/R/facet-.r @@ -423,6 +423,19 @@ eval_facets <- function(facets, data, possible_columns = NULL) { new_data_frame(tibble::as_tibble(vars)) } eval_facet <- function(facet, data, possible_columns = NULL) { + # Treat the case when `facet` is a quosure of a symbol specifically + # to issue a friendlier warning + if (quo_is_symbol(facet)) { + facet <- as.character(quo_get_expr(facet)) + + if (facet %in% names(data)) { + out <- data[[facet]] + } else { + out <- NULL + } + return(out) + } + # clone the env in order to prevent side effects (hopefully) env <- env_clone(quo_get_env(facet)) From e2924eef6f954ad8dd1162dbb3539118f0a2859c Mon Sep 17 00:00:00 2001 From: Hiroaki Yutani Date: Thu, 16 Jan 2020 08:39:19 +0900 Subject: [PATCH 05/10] Install active bindings on the data mask directly --- R/facet-.r | 21 +++++++++++---------- 1 file changed, 11 insertions(+), 10 deletions(-) diff --git a/R/facet-.r b/R/facet-.r index f0bbb16df1..1bee7405f3 100644 --- a/R/facet-.r +++ b/R/facet-.r @@ -436,23 +436,24 @@ eval_facet <- function(facet, data, possible_columns = NULL) { return(out) } - # clone the env in order to prevent side effects (hopefully) - env <- env_clone(quo_get_env(facet)) + # Create an environment for data mask + env <- new_environment(data) - # create a env with active bindings - cushioning_env <- child_env(env_parent(env)) + # Bind all possible column names to raise a custom error to detect the case + # when a variable is missing from the layer data but exists in other layer + missing_columns <- setdiff(possible_columns, names(data)) bindings <- lapply( - set_names(possible_columns), + set_names(missing_columns), function(...) function(e) abort("", class = "ggplot2_undefined_aes_error") ) - env_bind_active(cushioning_env, !!!bindings) + env_bind_active(env, !!!bindings) - # inject the cushioning env into the original chain of environments - env_poke_parent(env, cushioning_env) - facet <- quo_set_env(facet, env) + # Create a data mask and install a data pronoun manually (see ?new_data_mask) + mask <- new_data_mask(env) + mask$.data <- as_data_pronoun(mask) tryCatch( - eval_tidy(facet, data), + eval_tidy(facet, mask), ggplot2_undefined_aes_error = function(e) NULL ) } From 84119d7d6ca36f2e4567e0d01765bf22595bfb47 Mon Sep 17 00:00:00 2001 From: Hiroaki Yutani Date: Thu, 16 Jan 2020 09:14:00 +0900 Subject: [PATCH 06/10] Improve comments --- R/facet-.r | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/R/facet-.r b/R/facet-.r index 1bee7405f3..df97a17a78 100644 --- a/R/facet-.r +++ b/R/facet-.r @@ -439,8 +439,9 @@ eval_facet <- function(facet, data, possible_columns = NULL) { # Create an environment for data mask env <- new_environment(data) - # Bind all possible column names to raise a custom error to detect the case - # when a variable is missing from the layer data but exists in other layer + # Bind all possible column names that remains undefined to raise a custom error + # so that we can detect and ignore the case when a variable is missing from the + # layer data but exists in other layer missing_columns <- setdiff(possible_columns, names(data)) bindings <- lapply( set_names(missing_columns), @@ -452,6 +453,8 @@ eval_facet <- function(facet, data, possible_columns = NULL) { mask <- new_data_mask(env) mask$.data <- as_data_pronoun(mask) + # Do not treat the cases as errors when it refers to a column name unavailable + # in the layer data tryCatch( eval_tidy(facet, mask), ggplot2_undefined_aes_error = function(e) NULL From 750dcf226913aeb51317cc7aab860e54756edb88 Mon Sep 17 00:00:00 2001 From: Hiroaki Yutani Date: Thu, 16 Jan 2020 09:23:06 +0900 Subject: [PATCH 07/10] Use rep_along() to replicate functions --- R/facet-.r | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/R/facet-.r b/R/facet-.r index df97a17a78..1fac626660 100644 --- a/R/facet-.r +++ b/R/facet-.r @@ -443,10 +443,9 @@ eval_facet <- function(facet, data, possible_columns = NULL) { # so that we can detect and ignore the case when a variable is missing from the # layer data but exists in other layer missing_columns <- setdiff(possible_columns, names(data)) - bindings <- lapply( - set_names(missing_columns), - function(...) function(e) abort("", class = "ggplot2_undefined_aes_error") - ) + undefined_error <- function(e) abort("", class = "ggplot2_undefined_aes_error") + bindings <- rep_along(missing_columns, list(undefined_error)) + names(bindings) <- missing_columns env_bind_active(env, !!!bindings) # Create a data mask and install a data pronoun manually (see ?new_data_mask) From c07201fe05c8f1c839ca90b512ccfe4d0bbfda93 Mon Sep 17 00:00:00 2001 From: Hiroaki Yutani Date: Thu, 16 Jan 2020 09:37:49 +0900 Subject: [PATCH 08/10] Add tests --- tests/testthat/test-facet-.r | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/tests/testthat/test-facet-.r b/tests/testthat/test-facet-.r index 2de43bc151..375305ab5d 100644 --- a/tests/testthat/test-facet-.r +++ b/tests/testthat/test-facet-.r @@ -302,6 +302,27 @@ test_that("combine_vars() generates the correct combinations with multiple data ) }) +test_that("eval_facet() is tolerant for missing columns (#2963)", { + expect_null(eval_facet(quo(2 * x), data_frame(foo = 1), possible_columns = c("x"))) + expect_null(eval_facet(quo(2 * .data$x), data_frame(foo = 1), possible_columns = c("x"))) + + # Even if there's the same name of external variable, eval_facet() returns NULL before + # reaching to the variable + bar <- 2 + expect_null(eval_facet(quo(2 * bar), data_frame(foo = 1), possible_columns = c("bar"))) + # If there's no same name of columns, the external variable is used + expect_equal( + eval_facet(quo(2 * bar), data_frame(foo = 1), possible_columns = c("x")), + 4 + ) + + # If the expression contains any non-existent variable, it fails + expect_error( + eval_facet(quo(no_such_variable * x), data_frame(foo = 1), possible_columns = c("x")), + "object 'no_such_variable' not found" + ) +}) + # Visual tests ------------------------------------------------------------ test_that("facet labels respect both justification and margin arguments", { From 4cd6b0f04af3445bdcea9d886ca110f02202aee7 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Wed, 22 Jan 2020 09:10:07 -0600 Subject: [PATCH 09/10] Minor simplification with rep_named() --- R/facet-.r | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/R/facet-.r b/R/facet-.r index 1fac626660..2fcae92ea7 100644 --- a/R/facet-.r +++ b/R/facet-.r @@ -444,8 +444,7 @@ eval_facet <- function(facet, data, possible_columns = NULL) { # layer data but exists in other layer missing_columns <- setdiff(possible_columns, names(data)) undefined_error <- function(e) abort("", class = "ggplot2_undefined_aes_error") - bindings <- rep_along(missing_columns, list(undefined_error)) - names(bindings) <- missing_columns + bindings <- rep_named(missing_columns, list(undefined_error)) env_bind_active(env, !!!bindings) # Create a data mask and install a data pronoun manually (see ?new_data_mask) From 8c3184e7b8bd84cdd76acd49beff2006cceb16f6 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Wed, 22 Jan 2020 09:15:23 -0600 Subject: [PATCH 10/10] Tweak comments a little --- R/facet-.r | 13 ++++--------- 1 file changed, 4 insertions(+), 9 deletions(-) diff --git a/R/facet-.r b/R/facet-.r index 2fcae92ea7..c4c1e58859 100644 --- a/R/facet-.r +++ b/R/facet-.r @@ -436,14 +436,11 @@ eval_facet <- function(facet, data, possible_columns = NULL) { return(out) } - # Create an environment for data mask + # Key idea: use active bindings so that column names missing in this layer + # but present in others raise a custom error env <- new_environment(data) - - # Bind all possible column names that remains undefined to raise a custom error - # so that we can detect and ignore the case when a variable is missing from the - # layer data but exists in other layer missing_columns <- setdiff(possible_columns, names(data)) - undefined_error <- function(e) abort("", class = "ggplot2_undefined_aes_error") + undefined_error <- function(e) abort("", class = "ggplot2_missing_facet_var") bindings <- rep_named(missing_columns, list(undefined_error)) env_bind_active(env, !!!bindings) @@ -451,11 +448,9 @@ eval_facet <- function(facet, data, possible_columns = NULL) { mask <- new_data_mask(env) mask$.data <- as_data_pronoun(mask) - # Do not treat the cases as errors when it refers to a column name unavailable - # in the layer data tryCatch( eval_tidy(facet, mask), - ggplot2_undefined_aes_error = function(e) NULL + ggplot2_missing_facet_var = function(e) NULL ) }