fortify.default() accepts data-frame-like objects

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).
 

R/fortify.R

@@ -33,17 +33,62 @@ 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("`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()`, 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)
   }
-  cli::cli_abort(msg)
+  msg0 <- paste0(msg0, ". ")
+  try_fetch(
+    validate_as_data_frame(model),
+    error = function(cnd) cli::cli_abort(glue(msg0), parent = cnd)
+  )
 }

tests/testthat/_snaps/fortify.md

@@ -1,5 +1,5 @@
 # fortify.default proves a helpful error with class uneval
 
-    `data` must be a <data.frame>, or an object coercible by `fortify()`, not a <uneval> object.
+    `data` must be a <data.frame>, or an object coercible by `fortify()`, or a valid <data.frame>-like object coercible by `as.data.frame()`, not a <uneval> object.
     i Did you accidentally pass `aes()` to the `data` argument?
 

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), 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(<foo>)
+
+  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(<foo>)
+  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(<foo>)
+
+  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))
+})