Forward compatibility: is_*() functions (#6388)

Author: teunbrand

NAMESPACE

@@ -458,6 +458,21 @@ export(is.facet)
 export(is.ggplot)
 export(is.ggproto)
 export(is.theme)
+export(is_coord)
+export(is_element)
+export(is_facet)
+export(is_geom)
+export(is_ggplot)
+export(is_ggproto)
+export(is_guide)
+export(is_guides)
+export(is_layer)
+export(is_mapping)
+export(is_margin)
+export(is_position)
+export(is_scale)
+export(is_stat)
+export(is_theme)
 export(label_both)
 export(label_bquote)
 export(label_context)

NEWS.md

@@ -1,5 +1,9 @@
 # ggplot2 (development version)
 
+* Standardised test functions for important classes: `is_ggproto()`, 
+ `is_ggplot()`, `is_mapping()`, `is_layer()`, `is_geom()`, `is_stat()`, 
+ `is_position()`, `is_coord()`, `is_facet()`, `is_scale()`, `is_guide()`, 
+ `is_guides()`, `is_margin()`, `is_element()` and `is_theme()`.
 * New `get_labs()` function for retrieving completed plot labels 
   (@teunbrand, #6008).
 * New `get_geom_defaults()` for retrieving resolved default aesthetics.

R/aes.R

@@ -102,6 +102,10 @@ aes <- function(x, y, ...) {
   rename_aes(aes)
 }
 
+#' @export
+#' @rdname is_tests
+is_mapping <- function(x) inherits(x, "uneval")
+
 # Wrap symbolic objects in quosures but pull out constants out of
 # quosures for backward-compatibility
 new_aesthetic <- function(x, env = globalenv()) {

R/coord-.R

@@ -204,11 +204,17 @@ Coord <- ggproto("Coord",
   }
 )
 
-#' Is this object a coordinate system?
-#'
-#' @export is.Coord
-#' @keywords internal
-is.Coord <- function(x) inherits(x, "Coord")
+#' @export
+#' @rdname is_tests
+is_coord <- function(x) inheritS(x, "Coord")
+
+#' @export
+#' @rdname is_tests
+#' @usage is.Coord(x) # Deprecated
+is.Coord <- function(x) {
+  deprecate_soft0("3.5.2", "is.Coord()", "is_coord()")
+  is_coord(x)
+}
 
 # Renders an axis with the correct orientation or zeroGrob if no axis should be
 # generated

R/coord-cartesian-.R

@@ -159,7 +159,7 @@ view_scales_from_scale <- function(scale, coord_limits = NULL, expand = TRUE) {
 }
 
 panel_guides_grob <- function(guides, position, theme, labels = NULL) {
-  if (!inherits(guides, "Guides")) {
+  if (!is_guides(guides)) {
     return(zeroGrob())
   }
   pair <- guides$get_position(position)

R/facet-.R

@@ -239,13 +239,17 @@ vars <- function(...) {
   quos(...)
 }
 
+#' @export
+#' @rdname is_tests
+is_facet <- function(x) inherits(x, "Facet")
 
-#' Is this object a faceting specification?
-#'
-#' @param x object to test
-#' @keywords internal
 #' @export
-is.facet <- function(x) inherits(x, "Facet")
+#' @rdname is_tests
+#' @usage is.facet(x) # Deprecated
+is.facet <- function(x) {
+  deprecate_soft0("3.5.2", "is.facet()", "is_facet()")
+  is_facet(x)
+}
 
 # A "special" value, currently not used but could be used to determine
 # if faceting is active
@@ -324,7 +328,7 @@ as_facets_list <- function(x) {
 }
 
 validate_facets <- function(x) {
-  if (inherits(x, "uneval")) {
+  if (is_mapping(x)) {
     cli::cli_abort("Please use {.fn vars} to supply facet variables.")
   }
   # Native pipe have higher precedence than + so any type of gg object can be

R/fortify.R

@@ -82,7 +82,7 @@ fortify.default <- function(model, data, ...) {
     "or an object coercible by {{.fn fortify}}, or a valid ",
     "{{.cls data.frame}}-like object coercible by {{.fn as.data.frame}}"
   )
-  if (inherits(model, "uneval")) {
+  if (is_mapping(model)) {
     msg <- c(
       glue(msg0, ", not {obj_type_friendly(model)}."),
       "i" = "Did you accidentally pass {.fn aes} to the {.arg data} argument?"

R/geom-.R

@@ -222,6 +222,9 @@ Geom <- ggproto("Geom",
 
 )
 
+#' @export
+#' @rdname is_tests
+is_geom <- function(x) inherits(x, "Geom")
 
 #' Graphical units
 #'

R/ggproto.R

@@ -52,7 +52,7 @@
 #'     self$x
 #'   }
 #'  )
-#' is.ggproto(Adder)
+#' is_ggproto(Adder)
 #'
 #' Adder$add(10)
 #' Adder$add(10)
@@ -88,7 +88,7 @@ ggproto <- function(`_class` = NULL, `_inherit` = NULL, ...) {
 
   super <- find_super()
   if (!is.null(super)) {
-    check_object(super, is.ggproto, "a {.cls ggproto} object", arg = "_inherit")
+    check_object(super, is_ggproto, "a {.cls ggproto} object", arg = "_inherit")
     e$super <- find_super
     class(e) <- c(`_class`, class(super))
   } else {
@@ -106,10 +106,17 @@ ggproto_parent <- function(parent, self) {
   structure(list(parent = parent, self = self), class = "ggproto_parent")
 }
 
-#' @param x An object to test.
 #' @export
-#' @rdname ggproto
-is.ggproto <- function(x) inherits(x, "ggproto")
+#' @rdname is_tests
+is_ggproto <- function(x) inherits(x, "ggproto")
+
+#' @export
+#' @rdname is_tests
+#' @usage is.ggproto(x) # Deprecated
+is.ggproto <- function(x) {
+  deprecate_soft0("3.5.2", "is.ggproto()", "is_ggproto()")
+  is_ggproto(x)
+}
 
 fetch_ggproto <- function(x, name) {
   res <- NULL
@@ -305,7 +312,7 @@ object_summaries <- function(x, exclude = NULL, flat = TRUE) {
   values <- vapply(obj_names, function(name) {
     obj <- x[[name]]
     if (is.function(obj)) "function"
-    else if (is.ggproto(obj)) format(obj, flat = flat)
+    else if (is_ggproto(obj)) format(obj, flat = flat)
     else if (is.environment(obj)) "environment"
     else if (is.null(obj)) "NULL"
     else if (is.atomic(obj)) trim(paste(as.character(obj), collapse = " "))

R/guide-.R

@@ -50,7 +50,7 @@ new_guide <- function(..., available_aes = "any", super) {
 
   # Validate theme settings
   if (!is.null(params$theme)) {
-    check_object(params$theme, is.theme, what = "a {.cls theme} object")
+    check_object(params$theme, is_theme, what = "a {.cls theme} object")
     validate_theme(params$theme, call = caller_env())
     params$direction <- params$direction %||% params$theme$legend.direction
   }
@@ -66,6 +66,10 @@ new_guide <- function(..., available_aes = "any", super) {
   )
 }
 
+#' @export
+#' @rdname is_tests
+is_guide <- function(x) inherits(x, "Guide")
+
 #' @section Guides:
 #'
 #' The `guide_*()` functions, such as `guide_legend()` return an object that
@@ -377,10 +381,10 @@ Guide <- ggproto(
   # Renders tickmarks
   build_ticks = function(key, elements, params, position = params$position,
                          length = elements$ticks_length) {
-    if (!inherits(elements, "element")) {
+    if (!is_element(elements)) {
       elements <- elements$ticks
     }
-    if (!inherits(elements, "element_line")) {
+    if (!is_element(elements, "line")) {
       return(zeroGrob())
     }