From 0950c345ec94277f78421b1f5c62d17003db585a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Herv=C3=A9=20Pag=C3=A8s?= Date: Fri, 1 Sep 2023 02:36:08 -0700 Subject: [PATCH 1/4] fortify.default() accepts data-frame-like objects `fortify.default()` now accepts a data-frame-like object granted the object exhibits healthy `dim()`, `colnames()`, and `as.data.frame()` behaviors. Closes #5390. --- NEWS.md | 4 ++ R/fortify.R | 92 +++++++++++++++++++++++++++- tests/testthat/test-fortify.R | 109 ++++++++++++++++++++++++++++++++++ 3 files changed, 203 insertions(+), 2 deletions(-) diff --git a/NEWS.md b/NEWS.md index ea136bae78..feb7a37240 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,9 @@ # ggplot2 (development version) +* `fortify.default()` now accepts a data-frame-like object granted the object + exhibits healthy `dim()`, `colnames()`, and `as.data.frame()` behaviors + (@hpages, #5390). + * `geom_boxplot()` gains a new argument, `staplewidth` that can draw staples at the ends of whiskers (@teunbrand, #5126) diff --git a/R/fortify.R b/R/fortify.R index 507e333b20..28c24ce0f7 100644 --- a/R/fortify.R +++ b/R/fortify.R @@ -33,17 +33,105 @@ fortify.grouped_df <- function(model, data, ...) { model$.group <- dplyr::group_indices(model) model } + +# We rely on object behavior rather than type to determine whether 'model' is +# an acceptable data-frame-like object or not. For this, we check that dim(), +# colnames(), and as.data.frame() behave in a healthy manner on 'model', +# and that their behaviors are aligned (i.e. that as.data.frame() preserves +# the original dimensions and colnames). Note that we don't care about what +# happens to the rownames. +# There are a lot of ways that dim(), colnames(), or as.data.frame() could +# do non-sensical things (they are not even guaranteed to work!) hence the +# paranoid mode. +.as_data_frame_trust_no_one <- function(model) { + msg0 <- paste0( + "No `fortify()` method found for {{.arg data}} ", + "({obj_type_friendly(model)}), and the object does not look ", + "like it can be treated as a valid data-frame-like object either " + ) + orig_dims <- try(dim(model), silent = TRUE) + if (inherits(orig_dims, "try-error")) { + msg <- glue(msg0, "(calling `dim()` on the object ", + "returned an error).") + cli::cli_abort(msg) + } + if (is.null(orig_dims)) { + msg <- glue(msg0, "(it has no dimensions).") + cli::cli_abort(msg) + } + if (!is.integer(orig_dims)) { + msg <- glue(msg0, "(calling `dim()` on the object ", + "didn't return an integer vector).") + cli::cli_abort(msg) + } + if (length(orig_dims) != 2) { + msg <- glue(msg0, "(it should have 2 dimensions).") + cli::cli_abort(msg) + } + # Extra-paranoid mode. + if (anyNA(orig_dims) || any(orig_dims < 0)) { + msg <- glue(msg0, "(calling `dim()` on the object returned ", + "a vector containing NAs or negative values).") + cli::cli_abort(msg) + } + orig_colnames <- try(colnames(model), silent = TRUE) + if (inherits(orig_colnames, "try-error")) { + msg <- glue(msg0, "(calling `colnames()` on the object ", + "returned an error).") + cli::cli_abort(msg) + } + if (is.null(orig_colnames)) { + msg <- glue(msg0, "(it has no colnames).") + cli::cli_abort(msg) + } + if (!is.character(orig_colnames)) { + msg <- glue(msg0, "(calling `colnames()` on the object ", + "didn't return a character vector).") + cli::cli_abort(msg) + } + if (length(orig_colnames) != ncol(model)) { + msg <- glue(msg0, "(the colnames don't match the number of columns).") + cli::cli_abort(msg) + } + df <- try(as.data.frame(model), silent = TRUE) + if (inherits(df, "try-error")) { + return(NULL) + } + msg0 <- paste0( + "Calling `as.data.frame()` on data-frame-like object ", + "{{.arg data}} ({obj_type_friendly(model)}) did not " + ) + if (!is.data.frame(df)) { + msg <- glue(msg0, "return a {{.cls data.frame}}.") + cli::cli_abort(msg) + } + if (!identical(dim(df), orig_dims)) { + msg <- glue(msg0, "preserve its dimensions.") + cli::cli_abort(msg) + } + if (!identical(colnames(df), orig_colnames)) { + msg <- glue(msg0, "preserve its colnames.") + cli::cli_abort(msg) + } + df +} #' @export fortify.default <- function(model, data, ...) { msg <- glue( "{{.arg data}} must be a {{.cls data.frame}}, ", - "or an object coercible by `fortify()`, not {obj_type_friendly(model)}." + "or an object coercible by `fortify()` or `as.data.frame()`, ", + "not {obj_type_friendly(model)}." ) if (inherits(model, "uneval")) { msg <- c( msg, "i" = "Did you accidentally pass {.fn aes} to the {.arg data} argument?" ) + cli::cli_abort(msg) + } + df <- .as_data_frame_trust_no_one(model) + if (is.null(df)) { + cli::cli_abort(msg) } - cli::cli_abort(msg) + df } diff --git a/tests/testthat/test-fortify.R b/tests/testthat/test-fortify.R index 2b5c19243e..797bd063aa 100644 --- a/tests/testthat/test-fortify.R +++ b/tests/testthat/test-fortify.R @@ -45,3 +45,112 @@ test_that("spatial polygons have correct ordering", { test_that("fortify.default proves a helpful error with class uneval", { expect_snapshot_error(ggplot(aes(x = x))) }) + +test_that("fortify.default can handle healthy data-frame-like objects", { + X <- 1:10 + Y <- runif(length(X)) + Z <- rpois(length(X), 0.8) + + # Not even data-frame-like + + expect_error(fortify(X)) + expect_error(fortify(array(1:60, 5:3))) + + # Unhealthy data-frame-like (matrix with no colnames) + + expect_error(fortify(cbind(X, Y, Z, deparse.level=0))) + + # Healthy data-frame-like (matrix with colnames) + + expect_identical(fortify(cbind(X, Y, Z)), as.data.frame(cbind(X, Y, Z))) + + # Some weird data-frame-like thing that fortify.default() considers + # healthy (dim(), colnames(), and as.data.frame() behaviors are aligned) + + object <- setNames(Y, head(letters, length(Y))) + class(object) <- "foo" + + dim.foo <- function(x) c(length(x), 2L) + registerS3method("dim", "foo", dim.foo) + + dimnames.foo <- function(x) list(format(seq_along(x)), c("key", "value")) + registerS3method("dimnames", "foo", dimnames.foo) + + as.data.frame.foo <- function(x, row.names = NULL, ...) { + key <- if (is.null(names(x))) rownames(x) else names(x) + data.frame(key=key, value=unname(unclass(x))) + } + registerS3method("as.data.frame", "foo", as.data.frame.foo) + + expect_identical(fortify(object), data.frame(key=names(object), value=Y)) + + # Rejected by fortify.default() because of unhealthy dim() behavior + + dim.foo <- function(x) stop("what?") + registerS3method("dim", "foo", dim.foo) + expect_error(fortify(object)) + + dim.foo <- function(x) c(length(x), -5) + registerS3method("dim", "foo", dim.foo) + expect_error(fortify(object)) + + dim.foo <- function(x) 5:2 + registerS3method("dim", "foo", dim.foo) + expect_error(fortify(object)) + + dim.foo <- function(x) c(length(x), NA_integer_) + registerS3method("dim", "foo", dim.foo) + expect_error(fortify(object)) + + dim.foo <- function(x) c(length(x), -5L) + registerS3method("dim", "foo", dim.foo) + expect_error(fortify(object)) + + # Repair dim() + + dim.foo <- function(x) c(length(x), 2L) + registerS3method("dim", "foo", dim.foo) + + # Rejected by fortify.default() because of unhealthy colnames() behavior + + dimnames.foo <- function(x) list() # this breaks colnames() + registerS3method("dimnames", "foo", dimnames.foo) + expect_error(fortify(object)) + + dimnames.foo <- function(x) list(format(seq_along(x)), toupper) + registerS3method("dimnames", "foo", dimnames.foo) + expect_error(fortify(object)) + + # Rejected by fortify.default() because behaviors of dim() and colnames() + # don't align + + dimnames.foo <- function(x) list(NULL, c("X1", "X2", "X3")) + registerS3method("dimnames", "foo", dimnames.foo) + expect_error(fortify(object)) + + # Repair colnames() + + dimnames.foo <- function(x) list(format(seq_along(x)), c("key", "value")) + registerS3method("dimnames", "foo", dimnames.foo) + + # Rejected by fortify.default() because of unhealthy as.data.frame() behavior + + as.data.frame.foo <- function(x, row.names = NULL, ...) stop("what?") + registerS3method("as.data.frame", "foo", as.data.frame.foo) + expect_error(fortify(object)) + + as.data.frame.foo <- function(x, row.names = NULL, ...) "whatever" + registerS3method("as.data.frame", "foo", as.data.frame.foo) + expect_error(fortify(object)) + + as.data.frame.foo <- function(x, row.names = NULL, ...) data.frame() + registerS3method("as.data.frame", "foo", as.data.frame.foo) + expect_error(fortify(object)) + + as.data.frame.foo <- function(x, row.names = NULL, ...) { + key <- if (is.null(names(x))) rownames(x) else names(x) + data.frame(oops=key, value=unname(unclass(x))) + } + registerS3method("as.data.frame", "foo", as.data.frame.foo) + expect_error(fortify(object)) +}) From a007243db3293aa5d5c55811ff1bcfb3b322e38a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Herv=C3=A9=20Pag=C3=A8s?= Date: Fri, 1 Sep 2023 03:10:56 -0700 Subject: [PATCH 2/4] Update snapshot of ggplot(aes(x = x)) --- tests/testthat/_snaps/fortify.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/_snaps/fortify.md b/tests/testthat/_snaps/fortify.md index d51f061fce..48e2457b03 100644 --- a/tests/testthat/_snaps/fortify.md +++ b/tests/testthat/_snaps/fortify.md @@ -1,5 +1,5 @@ # fortify.default proves a helpful error with class uneval - `data` must be a , or an object coercible by `fortify()`, not a object. + `data` must be a , or an object coercible by `fortify()` or `as.data.frame()`, not a object. i Did you accidentally pass `aes()` to the `data` argument? From d0f5ddc1c436241474bb974ed6e148b3af5a2c81 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Herv=C3=A9=20Pag=C3=A8s?= Date: Tue, 19 Sep 2023 21:22:09 -0700 Subject: [PATCH 3/4] Improve fortify.default() based on Teun's feedback --- NEWS.md | 1 + R/fortify.R | 119 ++++++++++--------------------- tests/testthat/_snaps/fortify.md | 2 +- tests/testthat/test-fortify.R | 2 +- 4 files changed, 41 insertions(+), 83 deletions(-) diff --git a/NEWS.md b/NEWS.md index c2ca3fd2b0..65572857c7 100644 --- a/NEWS.md +++ b/NEWS.md @@ -3,6 +3,7 @@ * `fortify.default()` now accepts a data-frame-like object granted the object exhibits healthy `dim()`, `colnames()`, and `as.data.frame()` behaviors (@hpages, #5390). + * `ScaleContinuous$get_breaks()` now only calls `scales::zero_range()` on limits in transformed space, rather than in data space (#5304). diff --git a/R/fortify.R b/R/fortify.R index 28c24ce0f7..87d74569e0 100644 --- a/R/fortify.R +++ b/R/fortify.R @@ -34,104 +34,61 @@ fortify.grouped_df <- function(model, data, ...) { model } -# We rely on object behavior rather than type to determine whether 'model' is +# We rely on object behavior rather than type to determine whether 'data' is # an acceptable data-frame-like object or not. For this, we check that dim(), -# colnames(), and as.data.frame() behave in a healthy manner on 'model', +# colnames(), and as.data.frame() behave in a healthy manner on 'data', # and that their behaviors are aligned (i.e. that as.data.frame() preserves # the original dimensions and colnames). Note that we don't care about what # happens to the rownames. # There are a lot of ways that dim(), colnames(), or as.data.frame() could # do non-sensical things (they are not even guaranteed to work!) hence the # paranoid mode. -.as_data_frame_trust_no_one <- function(model) { - msg0 <- paste0( - "No `fortify()` method found for {{.arg data}} ", - "({obj_type_friendly(model)}), and the object does not look ", - "like it can be treated as a valid data-frame-like object either " - ) - orig_dims <- try(dim(model), silent = TRUE) - if (inherits(orig_dims, "try-error")) { - msg <- glue(msg0, "(calling `dim()` on the object ", - "returned an error).") - cli::cli_abort(msg) - } - if (is.null(orig_dims)) { - msg <- glue(msg0, "(it has no dimensions).") - cli::cli_abort(msg) - } - if (!is.integer(orig_dims)) { - msg <- glue(msg0, "(calling `dim()` on the object ", - "didn't return an integer vector).") - cli::cli_abort(msg) - } - if (length(orig_dims) != 2) { - msg <- glue(msg0, "(it should have 2 dimensions).") - cli::cli_abort(msg) - } - # Extra-paranoid mode. - if (anyNA(orig_dims) || any(orig_dims < 0)) { - msg <- glue(msg0, "(calling `dim()` on the object returned ", - "a vector containing NAs or negative values).") - cli::cli_abort(msg) - } - orig_colnames <- try(colnames(model), silent = TRUE) - if (inherits(orig_colnames, "try-error")) { - msg <- glue(msg0, "(calling `colnames()` on the object ", - "returned an error).") - cli::cli_abort(msg) - } - if (is.null(orig_colnames)) { - msg <- glue(msg0, "(it has no colnames).") - cli::cli_abort(msg) - } - if (!is.character(orig_colnames)) { - msg <- glue(msg0, "(calling `colnames()` on the object ", - "didn't return a character vector).") - cli::cli_abort(msg) - } - if (length(orig_colnames) != ncol(model)) { - msg <- glue(msg0, "(the colnames don't match the number of columns).") - cli::cli_abort(msg) - } - df <- try(as.data.frame(model), silent = TRUE) - if (inherits(df, "try-error")) { - return(NULL) - } - msg0 <- paste0( - "Calling `as.data.frame()` on data-frame-like object ", - "{{.arg data}} ({obj_type_friendly(model)}) did not " - ) - if (!is.data.frame(df)) { - msg <- glue(msg0, "return a {{.cls data.frame}}.") - cli::cli_abort(msg) - } - if (!identical(dim(df), orig_dims)) { - msg <- glue(msg0, "preserve its dimensions.") - cli::cli_abort(msg) - } - if (!identical(colnames(df), orig_colnames)) { - msg <- glue(msg0, "preserve its colnames.") - cli::cli_abort(msg) - } +.prevalidate_data_frame_like_object <- function(data) { + orig_dims <- dim(data) + if (!vec_is(orig_dims, integer(), size=2)) + cli::cli_abort("`dim(data)` didn't return an integer vector of length 2") + if (anyNA(orig_dims) || any(orig_dims < 0)) # extra-paranoid mode + cli::cli_abort("`dim(data)` returned a vector with NAs or negative values") + orig_colnames <- colnames(data) + if (!vec_is(orig_colnames, character(), size = ncol(data))) + cli::cli_abort(glue("`colnames(data)` didn't return a ", + "character vector of length 'ncol(data)'")) +} +.postvalidate_data_frame_like_object <- function(df, data) { + msg0 <- "`as.data.frame(data)` did not " + if (!is.data.frame(df)) + cli::cli_abort(glue(msg0, "return a {{.cls data.frame}}")) + if (!identical(dim(df), dim(data))) + cli::cli_abort(glue(msg0, "preserve the dimensions")) + if (!identical(colnames(df), colnames(data))) + cli::cli_abort(glue(msg0, "preserve the colnames")) +} +validate_as_data_frame <- function(data) { + if (is.data.frame(data)) + return(data) + .prevalidate_data_frame_like_object(data) + df <- as.data.frame(data) + .postvalidate_data_frame_like_object(df, data) df } + #' @export fortify.default <- function(model, data, ...) { - msg <- glue( + msg0 <- paste0( "{{.arg data}} must be a {{.cls data.frame}}, ", - "or an object coercible by `fortify()` or `as.data.frame()`, ", - "not {obj_type_friendly(model)}." + "or an object coercible by `fortify()`, ", + "or a valid {{.cls data.frame}}-like object coercible by `as.data.frame()`" ) if (inherits(model, "uneval")) { msg <- c( - msg, + glue(msg0, ", not {obj_type_friendly(model)}."), "i" = "Did you accidentally pass {.fn aes} to the {.arg data} argument?" ) cli::cli_abort(msg) } - df <- .as_data_frame_trust_no_one(model) - if (is.null(df)) { - cli::cli_abort(msg) - } - df + msg0 <- paste0(msg0, ". ") + try_fetch( + validate_as_data_frame(model), + error = function(cnd) cli::cli_abort(glue(msg0), parent = cnd) + ) } diff --git a/tests/testthat/_snaps/fortify.md b/tests/testthat/_snaps/fortify.md index 48e2457b03..81c3decea5 100644 --- a/tests/testthat/_snaps/fortify.md +++ b/tests/testthat/_snaps/fortify.md @@ -1,5 +1,5 @@ # fortify.default proves a helpful error with class uneval - `data` must be a , or an object coercible by `fortify()` or `as.data.frame()`, not a object. + `data` must be a , or an object coercible by `fortify()`, or a valid -like object coercible by `as.data.frame()`, not a object. i Did you accidentally pass `aes()` to the `data` argument? diff --git a/tests/testthat/test-fortify.R b/tests/testthat/test-fortify.R index 797bd063aa..894d917bb5 100644 --- a/tests/testthat/test-fortify.R +++ b/tests/testthat/test-fortify.R @@ -90,7 +90,7 @@ test_that("fortify.default can handle healthy data-frame-like objects", { registerS3method("dim", "foo", dim.foo) expect_error(fortify(object)) - dim.foo <- function(x) c(length(x), -5) + dim.foo <- function(x) c(length(x), 2) registerS3method("dim", "foo", dim.foo) expect_error(fortify(object)) From 00c6398421d4c9ae43620e0da9b5d1dbd926dc1c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Herv=C3=A9=20Pag=C3=A8s?= Date: Wed, 20 Sep 2023 07:51:50 -0700 Subject: [PATCH 4/4] Follow style guide a little bit more closely in error messages (see https://style.tidyverse.org/error-messages.html) --- R/fortify.R | 22 ++++++++++++---------- tests/testthat/test-fortify.R | 4 ++-- 2 files changed, 14 insertions(+), 12 deletions(-) diff --git a/R/fortify.R b/R/fortify.R index 87d74569e0..dab0982b63 100644 --- a/R/fortify.R +++ b/R/fortify.R @@ -46,22 +46,24 @@ fortify.grouped_df <- function(model, data, ...) { .prevalidate_data_frame_like_object <- function(data) { orig_dims <- dim(data) if (!vec_is(orig_dims, integer(), size=2)) - cli::cli_abort("`dim(data)` didn't return an integer vector of length 2") + cli::cli_abort(paste0("{.code dim(data)} must return ", + "an {.cls integer} of length 2.")) if (anyNA(orig_dims) || any(orig_dims < 0)) # extra-paranoid mode - cli::cli_abort("`dim(data)` returned a vector with NAs or negative values") + cli::cli_abort(paste0("{.code dim(data)} can't have {.code NA}s ", + "or negative values.")) orig_colnames <- colnames(data) if (!vec_is(orig_colnames, character(), size = ncol(data))) - cli::cli_abort(glue("`colnames(data)` didn't return a ", - "character vector of length 'ncol(data)'")) + cli::cli_abort(paste0("{.code colnames(data)} must return a ", + "{.cls character} of length {.code ncol(data)}.")) } .postvalidate_data_frame_like_object <- function(df, data) { - msg0 <- "`as.data.frame(data)` did not " + msg0 <- "{.code as.data.frame(data)} must " if (!is.data.frame(df)) - cli::cli_abort(glue(msg0, "return a {{.cls data.frame}}")) + cli::cli_abort(paste0(msg0, "return a {.cls data.frame}.")) if (!identical(dim(df), dim(data))) - cli::cli_abort(glue(msg0, "preserve the dimensions")) + cli::cli_abort(paste0(msg0, "preserve dimensions.")) if (!identical(colnames(df), colnames(data))) - cli::cli_abort(glue(msg0, "preserve the colnames")) + cli::cli_abort(paste0(msg0, "preserve column names.")) } validate_as_data_frame <- function(data) { if (is.data.frame(data)) @@ -76,8 +78,8 @@ validate_as_data_frame <- function(data) { fortify.default <- function(model, data, ...) { msg0 <- paste0( "{{.arg data}} must be a {{.cls data.frame}}, ", - "or an object coercible by `fortify()`, ", - "or a valid {{.cls data.frame}}-like object coercible by `as.data.frame()`" + "or an object coercible by {{.code fortify()}}, or a valid ", + "{{.cls data.frame}}-like object coercible by {{.code as.data.frame()}}" ) if (inherits(model, "uneval")) { msg <- c( diff --git a/tests/testthat/test-fortify.R b/tests/testthat/test-fortify.R index 894d917bb5..8741fac2d0 100644 --- a/tests/testthat/test-fortify.R +++ b/tests/testthat/test-fortify.R @@ -86,7 +86,7 @@ test_that("fortify.default can handle healthy data-frame-like objects", { # Rejected by fortify.default() because of unhealthy dim() behavior - dim.foo <- function(x) stop("what?") + dim.foo <- function(x) stop("oops!") registerS3method("dim", "foo", dim.foo) expect_error(fortify(object)) @@ -135,7 +135,7 @@ test_that("fortify.default can handle healthy data-frame-like objects", { # Rejected by fortify.default() because of unhealthy as.data.frame() behavior - as.data.frame.foo <- function(x, row.names = NULL, ...) stop("what?") + as.data.frame.foo <- function(x, row.names = NULL, ...) stop("oops!") registerS3method("as.data.frame", "foo", as.data.frame.foo) expect_error(fortify(object))