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
. IfTRUE
, returns the parent's method and the correspondingggbody()
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 toTRUE
.
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()
orggedit()
,get_method()
will return the current modified state of the method. As of v0.3.5, callingget_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 fromclass(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 ofclass(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: 0x00000137490325f8>
#> <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.