Get information about ggproto methods

Usage

get_method(method, inherit = FALSE)

get_method_inheritance(obj, trim_overriden = TRUE)

ggbody(method, inherit = FALSE, as.list = TRUE)

ggformals(method, inherit = FALSE)

Arguments

method

A function or a ggproto method. The ggproto method may be specified using any of the following forms:

ggproto$method
namespace::ggproto$method
namespace:::ggproto$method

inherit

Whether the method should be searched from its closest parent. Defaults to FALSE. If TRUE, returns the parent's method and the corresponding ggbody() code as a message.

obj

A ggproto object

trim_overriden

Whether get_method_inheritance should recursively hide methods defined by a parent.

as.list

Whether ggbody() should return the body of the method as a list. Defaults to TRUE.

Value

A list

Details

get_method() returns the method.
get_method_inheritance() lists available methods from self and parent ggprotos.
ggbody() returns the body of the method.
ggformals() returns the formals of the method.

Note

get_method() calls get("method", ggproto) under the hood. The get("method", ggproto) syntax is the long form of ggproto$method which retrieves the actual function body. This is a subtle but important difference for inspecting ggproto methods.

For example, this works: debugonce(get("compute_group", StatCount))
But this fails to insert a break point: debugonce(StatCount$compute_group)

get_method() was designed so that you do not have to worry about this distinction.

Gotchas

If a method is being traced via ggtrace() or ggedit(), get_method() will return the current modified state of the method. As of v0.3.5, calling get_method() on a method that has a trace on it will return a warning to emphasize this fact.
When using inherit = TRUE, make sure that all ggproto objects from class(ggproto) are available (by loading the packages where they are defined, for example). Under the hood, get_method() loops through the parents to search for the method, so it needs to be able to evaluate each element of class(ggproto) as an object.

Examples

library(ggplot2)

# Uninformative
StatCount$compute_group
#> <ggproto method>
#>   <Wrapper function>
#>     function (...) 
#> compute_group(..., self = self)
#> 
#>   <Inner function (f)>
#>     function (self, data, scales, width = NULL, flipped_aes = FALSE) 
#> {
#>     data <- flip_data(data, flipped_aes)
#>     x <- data$x
#>     weight <- data$weight %||% rep(1, length(x))
#>     count <- as.vector(rowsum(weight, x, na.rm = TRUE))
#>     bars <- data_frame0(count = count, prop = count/sum(abs(count)), 
#>         x = sort(unique0(x)), width = width, flipped_aes = flipped_aes, 
#>         .size = length(count))
#>     flip_data(bars, flipped_aes)
#> }
formals(StatCount$compute_group)
#> $...
#> 
#> 
body(StatCount$compute_group)
#> compute_group(..., self = self)

# Errors
# get(StatCount$compute_group)

# Informative
get_method(StatCount$compute_group)
#> function (self, data, scales, width = NULL, flipped_aes = FALSE) 
#> {
#>     data <- flip_data(data, flipped_aes)
#>     x <- data$x
#>     weight <- data$weight %||% rep(1, length(x))
#>     count <- as.vector(rowsum(weight, x, na.rm = TRUE))
#>     bars <- data_frame0(count = count, prop = count/sum(abs(count)), 
#>         x = sort(unique0(x)), width = width, flipped_aes = flipped_aes, 
#>         .size = length(count))
#>     flip_data(bars, flipped_aes)
#> }
#> <bytecode: 0x0000029735db93a8>
#> <environment: namespace:ggplot2>
ggformals(StatCount$compute_group) # formals(get_method(StatCount$compute_group))
#> $self
#> 
#> 
#> $data
#> 
#> 
#> $scales
#> 
#> 
#> $width
#> NULL
#> 
#> $flipped_aes
#> [1] FALSE
#> 
ggbody(StatCount$compute_group)    # body(get_method(StatCount$compute_group))
#> [[1]]
#> `{`
#> 
#> [[2]]
#> data <- flip_data(data, flipped_aes)
#> 
#> [[3]]
#> x <- data$x
#> 
#> [[4]]
#> weight <- data$weight %||% rep(1, length(x))
#> 
#> [[5]]
#> count <- as.vector(rowsum(weight, x, na.rm = TRUE))
#> 
#> [[6]]
#> bars <- data_frame0(count = count, prop = count/sum(abs(count)), 
#>     x = sort(unique0(x)), width = width, flipped_aes = flipped_aes, 
#>     .size = length(count))
#> 
#> [[7]]
#> flip_data(bars, flipped_aes)
#> 

# Works for ggproto in extension packages

ggbody(ggforce::StatDelaunaySegment$compute_group)
#> [[1]]
#> `{`
#> 
#> [[2]]
#> if (any(duplicated(data[, c("x", "y")]))) {
#>     cli::cli_warn("{.fn {snake_class(self)}} is dropping duplicated points")
#> }
#> 
#> [[3]]
#> if (normalize) {
#>     x_range <- range(data$x, na.rm = TRUE, finite = TRUE)
#>     y_range <- range(data$y, na.rm = TRUE, finite = TRUE)
#>     data$x <- rescale(data$x, from = x_range) * asp.ratio
#>     data$y <- rescale(data$y, from = y_range)
#>     if (!is.null(bound)) {
#>         bound[1:2] <- rescale(bound[1:2], from = x_range) * asp.ratio
#>         bound[3:4] <- rescale(bound[3:4], from = x_range)
#>     }
#> }
#> 
#> [[4]]
#> vor <- deldir::deldir(data$x, data$y, rw = bound, eps = eps, 
#>     suppressMsge = TRUE)
#> 
#> [[5]]
#> segments <- vor$delsgs[, 1:5]
#> 
#> [[6]]
#> names(segments) <- c("x", "y", "xend", "yend", "group")
#> 
#> [[7]]
#> segments$group <- vor$ind.orig[segments$group]
#> 
#> [[8]]
#> data <- cbind(segments[, 1:4], data[segments$group, !names(data) %in% 
#>     c("x", "y"), drop = FALSE])
#> 
#> [[9]]
#> if (normalize) {
#>     data$x <- rescale(data$x/asp.ratio, to = x_range, from = c(0, 
#>         1))
#>     data$xend <- rescale(data$xend/asp.ratio, to = x_range, from = c(0, 
#>         1))
#>     data$y <- rescale(data$y, to = y_range, from = c(0, 1))
#>     data$yend <- rescale(data$yend, to = y_range, from = c(0, 
#>         1))
#> }
#> 
#> [[10]]
#> data
#> 

library(ggforce)
ggbody(StatBezier$compute_panel)
#> [[1]]
#> `{`
#> 
#> [[2]]
#> if (empty_data(data)) return(data)
#> 
#> [[3]]
#> nControls <- table(data$group)
#> 
#> [[4]]
#> controlRange <- range(nControls)
#> 
#> [[5]]
#> if (min(controlRange) < 3 || max(controlRange) > 4) {
#>     cli::cli_abort(c("Only support for quadratic and cubic beziers", 
#>         i = "Make sure each group consists of 3 or 4 rows"))
#> }
#> 
#> [[6]]
#> data <- data[order(data$group), ]
#> 
#> [[7]]
#> groups <- unique0(data$group)
#> 
#> [[8]]
#> paths <- getBeziers(data$x, data$y, match(data$group, groups), 
#>     n)
#> 
#> [[9]]
#> paths <- data_frame0(x = paths$paths[, 1], y = paths$paths[, 
#>     2], group = groups[paths$pathID])
#> 
#> [[10]]
#> paths$index <- rep(seq(0, 1, length.out = n), length(nControls))
#> 
#> [[11]]
#> dataIndex <- rep(match(unique0(data$group), data$group), each = n)
#> 
#> [[12]]
#> cbind(paths, data[dataIndex, !names(data) %in% c("x", "y", "group"), 
#>     drop = FALSE])
#> 

# `inherit = TRUE` will return the method from the closest parent

## ERRORS:
## get_method(StatBoxplot$compute_panel)
## ggbody(StatBoxplot$compute_panel)
## ggformals(StatBoxplot$compute_panel)
ggbody(StatBoxplot$compute_panel, inherit = TRUE)
#> Method inherited from `Stat$compute_panel`
#> [[1]]
#> `{`
#> 
#> [[2]]
#> if (empty(data)) return(data_frame0())
#> 
#> [[3]]
#> groups <- split(data, data$group)
#> 
#> [[4]]
#> stats <- lapply(groups, function(group) {
#>     self$compute_group(data = group, scales = scales, ...)
#> })
#> 
#> [[5]]
#> non_constant_columns <- character(0)
#> 
#> [[6]]
#> stats <- mapply(function(new, old) {
#>     if (empty(new)) 
#>         return(data_frame0())
#>     old <- old[, !(names(old) %in% names(new)), drop = FALSE]
#>     non_constant <- vapply(old, vec_unique_count, integer(1)) > 
#>         1L
#>     non_constant_columns <<- c(non_constant_columns, names(old)[non_constant])
#>     vec_cbind(new, old[rep(1, nrow(new)), , drop = FALSE])
#> }, stats, groups, SIMPLIFY = FALSE)
#> 
#> [[7]]
#> non_constant_columns <- unique0(non_constant_columns)
#> 
#> [[8]]
#> dropped <- non_constant_columns[!non_constant_columns %in% self$dropped_aes]
#> 
#> [[9]]
#> if (length(dropped) > 0) {
#>     cli::cli_warn(c("The following aesthetics were dropped during statistical transformation: {.field {dropped}}.", 
#>         i = "This can happen when ggplot fails to infer the correct grouping structure in the data.", 
#>         i = "Did you forget to specify a {.code group} aesthetic or to convert a numerical variable into a factor?"))
#> }
#> 
#> [[10]]
#> data_new <- vec_rbind0(!!!stats)
#> 
#> [[11]]
#> data_new[, !names(data_new) %in% non_constant_columns, drop = FALSE]
#> 
ggbody(Stat$compute_panel)
#> [[1]]
#> `{`
#> 
#> [[2]]
#> if (empty(data)) return(data_frame0())
#> 
#> [[3]]
#> groups <- split(data, data$group)
#> 
#> [[4]]
#> stats <- lapply(groups, function(group) {
#>     self$compute_group(data = group, scales = scales, ...)
#> })
#> 
#> [[5]]
#> non_constant_columns <- character(0)
#> 
#> [[6]]
#> stats <- mapply(function(new, old) {
#>     if (empty(new)) 
#>         return(data_frame0())
#>     old <- old[, !(names(old) %in% names(new)), drop = FALSE]
#>     non_constant <- vapply(old, vec_unique_count, integer(1)) > 
#>         1L
#>     non_constant_columns <<- c(non_constant_columns, names(old)[non_constant])
#>     vec_cbind(new, old[rep(1, nrow(new)), , drop = FALSE])
#> }, stats, groups, SIMPLIFY = FALSE)
#> 
#> [[7]]
#> non_constant_columns <- unique0(non_constant_columns)
#> 
#> [[8]]
#> dropped <- non_constant_columns[!non_constant_columns %in% self$dropped_aes]
#> 
#> [[9]]
#> if (length(dropped) > 0) {
#>     cli::cli_warn(c("The following aesthetics were dropped during statistical transformation: {.field {dropped}}.", 
#>         i = "This can happen when ggplot fails to infer the correct grouping structure in the data.", 
#>         i = "Did you forget to specify a {.code group} aesthetic or to convert a numerical variable into a factor?"))
#> }
#> 
#> [[10]]
#> data_new <- vec_rbind0(!!!stats)
#> 
#> [[11]]
#> data_new[, !names(data_new) %in% non_constant_columns, drop = FALSE]
#> 

# Navigating complex inheritance
class(GeomArcBar)
#> [1] "GeomArcBar"  "GeomShape"   "GeomPolygon" "Geom"        "ggproto"    
#> [6] "gg"         
invisible(ggbody(GeomArcBar$default_aes, inherit = TRUE)) # self
#> Method 'default_aes' is defined for `GeomArcBar`, not inherited.
invisible(ggbody(GeomArcBar$draw_panel, inherit = TRUE))  # parent
#> Method inherited from `GeomShape$draw_panel`
invisible(ggbody(GeomArcBar$draw_key, inherit = TRUE))    # grandparent
#> Method inherited from `GeomPolygon$draw_key`
invisible(ggbody(GeomArcBar$draw_group, inherit = TRUE))  # top-level
#> Method inherited from `Geom$draw_group`

# Getting information about method inheritance all at once
# - default `trim_overriden = TRUE` hides redundant methods defined in parent
get_method_inheritance(GeomArcBar, trim_overriden = TRUE)
#> $Geom
#>  [1] "aesthetics"      "draw_group"      "draw_layer"      "draw_panel"     
#>  [5] "extra_params"    "non_missing_aes" "optional_aes"    "parameters"     
#>  [9] "setup_data"      "setup_params"    "use_defaults"   
#> 
#> $GeomPolygon
#> [1] "default_aes"  "draw_key"     "handle_na"    "rename_size"  "required_aes"
#> 
#> $GeomShape
#> [1] "draw_panel"   "extra_params"
#> 
#> $GeomArcBar
#> [1] "default_aes"
#> 

# Works for custom ggproto
# - Example from {ggplot2} "Extending ggplot2" vignette
StatDensityCommon <- ggproto("StatDensityCommon", Stat,
  required_aes = "x",

  setup_params = function(data, params) {
    if (!is.null(params$bandwidth))
      return(params)

    xs <- split(data$x, data$group)
    bws <- vapply(xs, bw.nrd0, numeric(1))
    bw <- mean(bws)
    message("Picking bandwidth of ", signif(bw, 3))

    params$bandwidth <- bw
    params
  },

  compute_group = function(data, scales, bandwidth = 1) {
    d <- density(data$x, bw = bandwidth)
    data.frame(x = d$x, y = d$y)
  }
)

as.list(body(get("compute_group", StatDensityCommon)))
#> [[1]]
#> `{`
#> 
#> [[2]]
#> d <- density(data$x, bw = bandwidth)
#> 
#> [[3]]
#> data.frame(x = d$x, y = d$y)
#> 

ggbody(StatDensityCommon$compute_group)
#> [[1]]
#> `{`
#> 
#> [[2]]
#> d <- density(data$x, bw = bandwidth)
#> 
#> [[3]]
#> data.frame(x = d$x, y = d$y)
#> 

# As of v.0.4.0, ggbody works for functions as well
ggbody(sample)
#> [[1]]
#> `{`
#> 
#> [[2]]
#> if (length(x) == 1L && is.numeric(x) && is.finite(x) && x >= 
#>     1) {
#>     if (missing(size)) 
#>         size <- x
#>     sample.int(x, size, replace, prob)
#> } else {
#>     if (missing(size)) 
#>         size <- length(x)
#>     x[sample.int(length(x), size, replace, prob)]
#> }
#> 
ggtrace(sample, 1)
#> `sample` now being traced.
invisible(ggbody(sample))
#> Warning: `sample` is currently being traced
is_traced(sample)
#> [1] TRUE
gguntrace(sample)
#> `sample` no longer being traced.