Merge pull request #404 from r-lib/f-400-ggplot2-num

- New `scale_x_num()` and `scale_y_num()`. If a column created with `num()` is used in a ggplot, the x and y scale will be formatted automatically according to to the specification (#400, #404).

DESCRIPTION

@@ -46,6 +46,7 @@ Suggests:
     testthat (>= 3.1.1),
     tibble,
     units (>= 0.7.2),
+    vdiffr,
     withr
 VignetteBuilder: 
     knitr

NAMESPACE

@@ -130,6 +130,8 @@ export(obj_sum)
 export(pillar)
 export(pillar_component)
 export(pillar_shaft)
+export(scale_x_num)
+export(scale_y_num)
 export(set_char_opts)
 export(set_num_opts)
 export(size_sum)

R/ggplot2.R

@@ -0,0 +1,87 @@
+#' Scale that supports formatted numbers
+#'
+#' This scale is used by default in ggplot2 with columns created with [num()].
+#'
+#' @inheritDotParams ggplot2::continuous_scale
+#' @param guide,position Passed on to [ggplot2::continuous_scale()]
+#' @param rescaler,super Must remain `NULL`.
+#'
+#' @keywords internal
+#' @export
+scale_x_num <- function(..., position = "bottom", guide = ggplot2::waiver(),
+                        rescaler = NULL, super = NULL) {
+  stopifnot(is.null(rescaler))
+  stopifnot(is.null(super))
+  stopifnot(is_installed("ggplot2"))
+  ggplot2::continuous_scale(
+    c(
+      "x", "xmin", "xmax", "xend", "xintercept", "xmin_final", "xmax_final",
+      "xlower", "xmiddle", "xupper"
+    ),
+    "position_c", identity,
+    ...,
+    guide = guide,
+    position = position,
+    rescaler = scales::rescale,
+    super = MakeScaleContinuousPositionNum()
+  )
+}
+
+#' @rdname scale_x_num
+#' @export
+scale_y_num <- function(..., guide = ggplot2::waiver(),
+                        rescaler = NULL, super = NULL) {
+  stopifnot(is.null(rescaler))
+  stopifnot(is.null(super))
+  stopifnot(is_installed("ggplot2"))
+  ggplot2::continuous_scale(
+    c(
+      "y", "ymin", "ymax", "yend", "yintercept", "ymin_final", "ymax_final",
+      "lower", "middle", "upper"
+    ),
+    "position_c", identity,
+    ...,
+    guide = guide,
+    rescaler = scales::rescale,
+    super = MakeScaleContinuousPositionNum()
+  )
+}
+
+MakeScaleContinuousPositionNum <- function() {
+  ggplot2::ggproto("ScaleContinuousPositionNum", ggplot2::ScaleContinuousPosition,
+    ptype = NULL,
+    train = function(self, x) {
+      self$ptype <- vec_ptype2(x, self$ptype)
+      ggplot2::ggproto_parent(ggplot2::ScaleContinuousPosition, self)$train(x)
+    },
+    get_breaks = function(self, limits = self$get_limits()) {
+      out <- ggplot2::ggproto_parent(ggplot2::ScaleContinuousPosition, self)$get_breaks(limits)
+      vec_cast(out, self$ptype)
+    },
+    get_labels = function(self, breaks = self$get_breaks()) {
+      out <- ggplot2::ggproto_parent(ggplot2::ScaleContinuousPosition, self)$get_labels(breaks)
+      fansi::strip_sgr(out)
+    },
+    make_title = function(self, title) {
+      out <- ggplot2::ggproto_parent(ggplot2::ScaleContinuousPosition, self)$make_title(title)
+      pillar_attr <- attr(self$ptype, "pillar", exact = TRUE)
+      label <- pillar_attr$label
+      if (!is.null(label)) {
+        out <- paste0(out, " [", label, "]")
+      }
+      out
+    }
+  )
+}
+
+# registered in .onLoad()
+scale_type.pillar_num <- function(x) c("num", "continuous")
+
+# registered in .onLoad()
+rescale.pillar_num <- function(x,
+                               to = c(0, 1),
+                               from = range(x, na.rm = TRUE, finite = TRUE),
+                               ...) {
+  out <- scales::rescale(vec_data(x), to, from, ...)
+  vec_cast(out, x)
+}

R/register-s3.R

@@ -0,0 +1,149 @@
+# This source code file is licensed under the unlicense license
+# https://unlicense.org
+#' Register a method for a suggested dependency
+#'
+#' Generally, the recommend way to register an S3 method is to use the
+#' `S3Method()` namespace directive (often generated automatically by the
+#' `@export` roxygen2 tag). However, this technique requires that the generic
+#' be in an imported package, and sometimes you want to suggest a package,
+#' and only provide a method when that package is loaded. `s3_register()`
+#' can be called from your package's `.onLoad()` to dynamically register
+#' a method only if the generic's package is loaded.
+#'
+#' For R 3.5.0 and later, `s3_register()` is also useful when demonstrating
+#' class creation in a vignette, since method lookup no longer always involves
+#' the lexical scope. For R 3.6.0 and later, you can achieve a similar effect
+#' by using "delayed method registration", i.e. placing the following in your
+#' `NAMESPACE` file:
+#'
+#' ```
+#' if (getRversion() >= "3.6.0") {
+#'   S3method(package::generic, class)
+#' }
+#' ```
+#'
+#' @section Usage in other packages:
+#' To avoid taking a dependency on vctrs, you copy the source of
+#' [`s3_register()`](https://github.com/r-lib/vctrs/blob/master/R/register-s3.R)
+#' into your own package. It is licensed under the permissive
+#' [unlicense](https://choosealicense.com/licenses/unlicense/) to make it
+#' crystal clear that we're happy for you to do this. There's no need to include
+#' the license or even credit us when using this function.
+#'
+#' @usage NULL
+#' @param generic Name of the generic in the form `pkg::generic`.
+#' @param class Name of the class
+#' @param method Optionally, the implementation of the method. By default,
+#'   this will be found by looking for a function called `generic.class`
+#'   in the package environment.
+#'
+#'   Note that providing `method` can be dangerous if you use
+#'   devtools. When the namespace of the method is reloaded by
+#'   `devtools::load_all()`, the function will keep inheriting from
+#'   the old namespace. This might cause crashes because of dangling
+#'   `.Call()` pointers.
+#' @examples
+#' # A typical use case is to dynamically register tibble/pillar methods
+#' # for your class. That way you avoid creating a hard dependency on packages
+#' # that are not essential, while still providing finer control over
+#' # printing when they are used.
+#'
+#' .onLoad <- function(...) {
+#'   s3_register("pillar::pillar_shaft", "vctrs_vctr")
+#'   s3_register("tibble::type_sum", "vctrs_vctr")
+#' }
+#' @keywords internal
+#' @noRd
+# nocov start
+s3_register <- function(generic, class, method = NULL) {
+  stopifnot(is.character(generic), length(generic) == 1)
+  stopifnot(is.character(class), length(class) == 1)
+
+  pieces <- strsplit(generic, "::")[[1]]
+  stopifnot(length(pieces) == 2)
+  package <- pieces[[1]]
+  generic <- pieces[[2]]
+
+  caller <- parent.frame()
+
+  get_method_env <- function() {
+    top <- topenv(caller)
+    if (isNamespace(top)) {
+      asNamespace(environmentName(top))
+    } else {
+      caller
+    }
+  }
+  get_method <- function(method, env) {
+    if (is.null(method)) {
+      get(paste0(generic, ".", class), envir = get_method_env())
+    } else {
+      method
+    }
+  }
+
+  register <- function(...) {
+    envir <- asNamespace(package)
+
+    # Refresh the method each time, it might have been updated by
+    # `devtools::load_all()`
+    method_fn <- get_method(method)
+    stopifnot(is.function(method_fn))
+
+
+    # Only register if generic can be accessed
+    if (exists(generic, envir)) {
+      registerS3method(generic, class, method_fn, envir = envir)
+    } else if (identical(Sys.getenv("NOT_CRAN"), "true")) {
+      warning(sprintf(
+        "Can't find generic `%s` in package %s to register S3 method.",
+        generic,
+        package
+      ))
+    }
+  }
+
+  # Always register hook in case package is later unloaded & reloaded
+  setHook(packageEvent(package, "onLoad"), register)
+
+  # Avoid registration failures during loading (pkgload or regular)
+  if (isNamespaceLoaded(package)) {
+    register()
+  }
+
+  invisible()
+}
+
+knitr_defer <- function(expr, env = caller_env()) {
+  roxy_caller <- detect(sys.frames(), env_inherits, ns_env("knitr"))
+  if (is_null(roxy_caller)) {
+    abort("Internal error: can't find knitr on the stack.")
+  }
+
+  blast(
+    withr::defer(!!substitute(expr), !!roxy_caller),
+    env
+  )
+}
+blast <- function(expr, env = caller_env()) {
+  eval_bare(enexpr(expr), env)
+}
+
+knitr_local_registration <- function(generic, class, env = caller_env()) {
+  stopifnot(is.character(generic), length(generic) == 1)
+  stopifnot(is.character(class), length(class) == 1)
+
+  pieces <- strsplit(generic, "::")[[1]]
+  stopifnot(length(pieces) == 2)
+  package <- pieces[[1]]
+  generic <- pieces[[2]]
+
+  name <- paste0(generic, ".", class)
+  method <- env_get(env, name)
+
+  old <- env_bind(global_env(), !!name := method)
+  knitr_defer(env_bind(global_env(), !!!old))
+}
+
+
+# nocov end

R/zzz.R

@@ -41,12 +41,14 @@ NULL
   # nolint end
   # Can't use vctrs::s3_register() here with vctrs 0.1.0
   # https://github.com/r-lib/vctrs/pull/314
-  register_s3_method("knitr", "knit_print", "pillar_squeezed_colonnade")
-  register_s3_method("bit64", "pillar_shaft", "integer64", gen_pkg = "pillar")
-  register_s3_method("survival", "pillar_shaft", "Surv", gen_pkg = "pillar")
-  register_s3_method("survival", "type_sum", "Surv", gen_pkg = "pillar")
-  register_s3_method("survival", "pillar_shaft", "Surv2", gen_pkg = "pillar")
-  register_s3_method("survival", "type_sum", "Surv2", gen_pkg = "pillar")
+  s3_register("scales::rescale", "pillar_num")
+  s3_register("ggplot2::scale_type", "pillar_num")
+  s3_register("knitr::knit_print", "pillar_squeezed_colonnade")
+  s3_register("bit64::pillar_shaft", "integer64")
+  s3_register("survival::pillar_shaft", "Surv")
+  s3_register("survival::type_sum", "Surv")
+  s3_register("survival::pillar_shaft", "Surv2")
+  s3_register("survival::type_sum", "Surv2")
 
   assign_crayon_styles()
 
@@ -65,37 +67,12 @@ NULL
 
   # https://github.com/r-lib/pkgdown/issues/1540
   if (Sys.getenv("IN_PKGDOWN") != "") {
-    register_s3_method("pillar", "type_sum", "accel")
+    s3_register("pillar::type_sum", "accel")
   }
 
   invisible()
 }
 
-register_s3_method <- function(pkg, generic, class, fun = NULL, gen_pkg = pkg) {
-  stopifnot(is.character(pkg), length(pkg) == 1)
-  stopifnot(is.character(generic), length(generic) == 1)
-  stopifnot(is.character(class), length(class) == 1)
-  if (is.null(fun)) {
-    fun <- get(paste0(generic, ".", class), envir = parent.frame())
-  }
-  stopifnot(is.function(fun))
-
-  if (pkg %in% loadedNamespaces()) {
-    envir <- asNamespace(gen_pkg)
-    registerS3method(generic, class, fun, envir = envir)
-  }
-
-  # Always register hook in case package is later unloaded & reloaded
-  setHook(
-    packageEvent(pkg, "onLoad"),
-    function(...) {
-      envir <- asNamespace(gen_pkg)
-      # FIXME: Need to work around base R bug, as mentioned by Carson?
-      registerS3method(generic, class, fun, envir = envir)
-    }
-  )
-}
-
 activate_debugme <- function(level = 2) {
   old_debugme <- remove_from_logging(get_debugme())
   old_debugme <- gsub("(.)$", "\\1,", old_debugme)