diff --git a/NEWS.md b/NEWS.md index 5b4d074c57..65572857c7 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). + * `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 507e333b20..dab0982b63 100644 --- a/R/fortify.R +++ b/R/fortify.R @@ -33,17 +33,64 @@ fortify.grouped_df <- function(model, data, ...) { model$.group <- dplyr::group_indices(model) model } + +# 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 '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. +.prevalidate_data_frame_like_object <- function(data) { + orig_dims <- dim(data) + if (!vec_is(orig_dims, integer(), size=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(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(paste0("{.code colnames(data)} must return a ", + "{.cls character} of length {.code ncol(data)}.")) +} +.postvalidate_data_frame_like_object <- function(df, data) { + msg0 <- "{.code as.data.frame(data)} must " + if (!is.data.frame(df)) + cli::cli_abort(paste0(msg0, "return a {.cls data.frame}.")) + if (!identical(dim(df), dim(data))) + cli::cli_abort(paste0(msg0, "preserve dimensions.")) + if (!identical(colnames(df), colnames(data))) + cli::cli_abort(paste0(msg0, "preserve column names.")) +} +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()`, not {obj_type_friendly(model)}." + "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( - msg, + glue(msg0, ", not {obj_type_friendly(model)}."), "i" = "Did you accidentally pass {.fn aes} to the {.arg data} argument?" ) + cli::cli_abort(msg) } - cli::cli_abort(msg) + 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 d51f061fce..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()`, 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 2b5c19243e..8741fac2d0 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("oops!") + registerS3method("dim", "foo", dim.foo) + expect_error(fortify(object)) + + dim.foo <- function(x) c(length(x), 2) + 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("oops!") + 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)) +})