Skip to content

Commit de7bad6

Browse files
hpageshpages
authored
fortify.default() accepts data-frame-like objects (#5404)
* 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. * Update snapshot of ggplot(aes(x = x)) * Improve fortify.default() based on Teun's feedback * Follow style guide a little bit more closely in error messages (see https://style.tidyverse.org/error-messages.html)
1 parent eb920af commit de7bad6

File tree

4 files changed

+165
-5
lines changed

4 files changed

+165
-5
lines changed

‎NEWS.md

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,9 @@
11
# ggplot2 (development version)
22

3+
* `fortify.default()` now accepts a data-frame-like object granted the object
4+
exhibits healthy `dim()`, `colnames()`, and `as.data.frame()` behaviors
5+
(@hpages, #5390).
6+
37
* `ScaleContinuous$get_breaks()` now only calls `scales::zero_range()` on limits
48
in transformed space, rather than in data space (#5304).
59

‎R/fortify.R

Lines changed: 51 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -33,17 +33,64 @@ fortify.grouped_df <- function(model, data, ...) {
3333
model$.group <- dplyr::group_indices(model)
3434
model
3535
}
36+
37+
# We rely on object behavior rather than type to determine whether 'data' is
38+
# an acceptable data-frame-like object or not. For this, we check that dim(),
39+
# colnames(), and as.data.frame() behave in a healthy manner on 'data',
40+
# and that their behaviors are aligned (i.e. that as.data.frame() preserves
41+
# the original dimensions and colnames). Note that we don't care about what
42+
# happens to the rownames.
43+
# There are a lot of ways that dim(), colnames(), or as.data.frame() could
44+
# do non-sensical things (they are not even guaranteed to work!) hence the
45+
# paranoid mode.
46+
.prevalidate_data_frame_like_object <- function(data) {
47+
orig_dims <- dim(data)
48+
if (!vec_is(orig_dims, integer(), size=2))
49+
cli::cli_abort(paste0("{.code dim(data)} must return ",
50+
"an {.cls integer} of length 2."))
51+
if (anyNA(orig_dims) || any(orig_dims < 0)) # extra-paranoid mode
52+
cli::cli_abort(paste0("{.code dim(data)} can't have {.code NA}s ",
53+
"or negative values."))
54+
orig_colnames <- colnames(data)
55+
if (!vec_is(orig_colnames, character(), size = ncol(data)))
56+
cli::cli_abort(paste0("{.code colnames(data)} must return a ",
57+
"{.cls character} of length {.code ncol(data)}."))
58+
}
59+
.postvalidate_data_frame_like_object <- function(df, data) {
60+
msg0 <- "{.code as.data.frame(data)} must "
61+
if (!is.data.frame(df))
62+
cli::cli_abort(paste0(msg0, "return a {.cls data.frame}."))
63+
if (!identical(dim(df), dim(data)))
64+
cli::cli_abort(paste0(msg0, "preserve dimensions."))
65+
if (!identical(colnames(df), colnames(data)))
66+
cli::cli_abort(paste0(msg0, "preserve column names."))
67+
}
68+
validate_as_data_frame <- function(data) {
69+
if (is.data.frame(data))
70+
return(data)
71+
.prevalidate_data_frame_like_object(data)
72+
df <- as.data.frame(data)
73+
.postvalidate_data_frame_like_object(df, data)
74+
df
75+
}
76+
3677
#' @export
3778
fortify.default <- function(model, data, ...) {
38-
msg <- glue(
79+
msg0 <- paste0(
3980
"{{.arg data}} must be a {{.cls data.frame}}, ",
40-
"or an object coercible by `fortify()`, not {obj_type_friendly(model)}."
81+
"or an object coercible by {{.code fortify()}}, or a valid ",
82+
"{{.cls data.frame}}-like object coercible by {{.code as.data.frame()}}"
4183
)
4284
if (inherits(model, "uneval")) {
4385
msg <- c(
44-
msg,
86+
glue(msg0, ", not {obj_type_friendly(model)}."),
4587
"i" = "Did you accidentally pass {.fn aes} to the {.arg data} argument?"
4688
)
89+
cli::cli_abort(msg)
4790
}
48-
cli::cli_abort(msg)
91+
msg0 <- paste0(msg0, ". ")
92+
try_fetch(
93+
validate_as_data_frame(model),
94+
error = function(cnd) cli::cli_abort(glue(msg0), parent = cnd)
95+
)
4996
}

‎tests/testthat/_snaps/fortify.md

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,5 @@
11
# fortify.default proves a helpful error with class uneval
22

3-
`data` must be a <data.frame>, or an object coercible by `fortify()`, not a <uneval> object.
3+
`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.
44
i Did you accidentally pass `aes()` to the `data` argument?
55

‎tests/testthat/test-fortify.R

Lines changed: 109 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -45,3 +45,112 @@ test_that("spatial polygons have correct ordering", {
4545
test_that("fortify.default proves a helpful error with class uneval", {
4646
expect_snapshot_error(ggplot(aes(x = x)))
4747
})
48+
49+
test_that("fortify.default can handle healthy data-frame-like objects", {
50+
X <- 1:10
51+
Y <- runif(length(X))
52+
Z <- rpois(length(X), 0.8)
53+
54+
# Not even data-frame-like
55+
56+
expect_error(fortify(X))
57+
expect_error(fortify(array(1:60, 5:3)))
58+
59+
# Unhealthy data-frame-like (matrix with no colnames)
60+
61+
expect_error(fortify(cbind(X, Y, Z, deparse.level=0)))
62+
63+
# Healthy data-frame-like (matrix with colnames)
64+
65+
expect_identical(fortify(cbind(X, Y, Z)), as.data.frame(cbind(X, Y, Z)))
66+
67+
# Some weird data-frame-like thing that fortify.default() considers
68+
# healthy (dim(), colnames(), and as.data.frame() behaviors are aligned)
69+
70+
object <- setNames(Y, head(letters, length(Y)))
71+
class(object) <- "foo"
72+
73+
dim.foo <- function(x) c(length(x), 2L)
74+
registerS3method("dim", "foo", dim.foo)
75+
76+
dimnames.foo <- function(x) list(format(seq_along(x)), c("key", "value"))
77+
registerS3method("dimnames", "foo", dimnames.foo)
78+
79+
as.data.frame.foo <- function(x, row.names = NULL, ...) {
80+
key <- if (is.null(names(x))) rownames(x) else names(x)
81+
data.frame(key=key, value=unname(unclass(x)))
82+
}
83+
registerS3method("as.data.frame", "foo", as.data.frame.foo)
84+
85+
expect_identical(fortify(object), data.frame(key=names(object), value=Y))
86+
87+
# Rejected by fortify.default() because of unhealthy dim() behavior
88+
89+
dim.foo <- function(x) stop("oops!")
90+
registerS3method("dim", "foo", dim.foo)
91+
expect_error(fortify(object))
92+
93+
dim.foo <- function(x) c(length(x), 2)
94+
registerS3method("dim", "foo", dim.foo)
95+
expect_error(fortify(object))
96+
97+
dim.foo <- function(x) 5:2
98+
registerS3method("dim", "foo", dim.foo)
99+
expect_error(fortify(object))
100+
101+
dim.foo <- function(x) c(length(x), NA_integer_)
102+
registerS3method("dim", "foo", dim.foo)
103+
expect_error(fortify(object))
104+
105+
dim.foo <- function(x) c(length(x), -5L)
106+
registerS3method("dim", "foo", dim.foo)
107+
expect_error(fortify(object))
108+
109+
# Repair dim(<foo>)
110+
111+
dim.foo <- function(x) c(length(x), 2L)
112+
registerS3method("dim", "foo", dim.foo)
113+
114+
# Rejected by fortify.default() because of unhealthy colnames() behavior
115+
116+
dimnames.foo <- function(x) list() # this breaks colnames(<foo>)
117+
registerS3method("dimnames", "foo", dimnames.foo)
118+
expect_error(fortify(object))
119+
120+
dimnames.foo <- function(x) list(format(seq_along(x)), toupper)
121+
registerS3method("dimnames", "foo", dimnames.foo)
122+
expect_error(fortify(object))
123+
124+
# Rejected by fortify.default() because behaviors of dim() and colnames()
125+
# don't align
126+
127+
dimnames.foo <- function(x) list(NULL, c("X1", "X2", "X3"))
128+
registerS3method("dimnames", "foo", dimnames.foo)
129+
expect_error(fortify(object))
130+
131+
# Repair colnames(<foo>)
132+
133+
dimnames.foo <- function(x) list(format(seq_along(x)), c("key", "value"))
134+
registerS3method("dimnames", "foo", dimnames.foo)
135+
136+
# Rejected by fortify.default() because of unhealthy as.data.frame() behavior
137+
138+
as.data.frame.foo <- function(x, row.names = NULL, ...) stop("oops!")
139+
registerS3method("as.data.frame", "foo", as.data.frame.foo)
140+
expect_error(fortify(object))
141+
142+
as.data.frame.foo <- function(x, row.names = NULL, ...) "whatever"
143+
registerS3method("as.data.frame", "foo", as.data.frame.foo)
144+
expect_error(fortify(object))
145+
146+
as.data.frame.foo <- function(x, row.names = NULL, ...) data.frame()
147+
registerS3method("as.data.frame", "foo", as.data.frame.foo)
148+
expect_error(fortify(object))
149+
150+
as.data.frame.foo <- function(x, row.names = NULL, ...) {
151+
key <- if (is.null(names(x))) rownames(x) else names(x)
152+
data.frame(oops=key, value=unname(unclass(x)))
153+
}
154+
registerS3method("as.data.frame", "foo", as.data.frame.foo)
155+
expect_error(fortify(object))
156+
})

0 commit comments

Comments
 (0)