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).
+
 * `geom_boxplot()` gains a new argument, `staplewidth` that can draw staples
   at the ends of whiskers (@teunbrand, #5126)
 

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
 }

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