Retrieve the body of a function or a method as a list

Usage

ggbody(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.

Value

A list

Details

ggbody() calls as.list(body(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)

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

Gotchas

If a method is being traced via ggtrace() or ggedit(), ggbody() will return the current modified state of the method. As of v0.3.5, calling ggbody() 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, ggbody() 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)

ggbody(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.numeric(tapply(weight, x, sum, na.rm = TRUE))
#> 
#> [[6]]
#> count[is.na(count)] <- 0
#> 
#> [[7]]
#> bars <- new_data_frame(list(count = count, prop = count/sum(abs(count)), 
#>     x = sort(unique(x)), width = width, flipped_aes = flipped_aes), 
#>     n = length(count))
#> 
#> [[8]]
#> 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")]))) {
#>     warning("stat_delaunay_segment: dropping duplicated points", 
#>         call. = FALSE)
#> }
#> 
#> [[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 (is.null(data)) return(data)
#> 
#> [[3]]
#> nControls <- table(data$group)
#> 
#> [[4]]
#> controlRange <- range(nControls)
#> 
#> [[5]]
#> if (min(controlRange) < 3 || max(controlRange) > 4) {
#>     stop("Only support for quadratic and cubic beziers")
#> }
#> 
#> [[6]]
#> data <- data[order(data$group), ]
#> 
#> [[7]]
#> groups <- unique(data$group)
#> 
#> [[8]]
#> paths <- getBeziers(data$x, data$y, match(data$group, groups), 
#>     n)
#> 
#> [[9]]
#> paths <- data.frame(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(unique(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:
## ggbody(StatBoxplot$compute_panel)
ggbody(StatBoxplot$compute_panel, inherit = TRUE)
#> Returning `ggbody(Stat$compute_panel)`
#> [[1]]
#> `{`
#> 
#> [[2]]
#> if (empty(data)) return(new_data_frame())
#> 
#> [[3]]
#> groups <- split(data, data$group)
#> 
#> [[4]]
#> stats <- lapply(groups, function(group) {
#>     self$compute_group(data = group, scales = scales, ...)
#> })
#> 
#> [[5]]
#> stats <- mapply(function(new, old) {
#>     if (empty(new)) 
#>         return(new_data_frame())
#>     unique <- uniquecols(old)
#>     missing <- !(names(unique) %in% names(new))
#>     cbind(new, unique[rep(1, nrow(new)), missing, drop = FALSE])
#> }, stats, groups, SIMPLIFY = FALSE)
#> 
#> [[6]]
#> rbind_dfs(stats)
#> 
ggbody(Stat$compute_panel)
#> [[1]]
#> `{`
#> 
#> [[2]]
#> if (empty(data)) return(new_data_frame())
#> 
#> [[3]]
#> groups <- split(data, data$group)
#> 
#> [[4]]
#> stats <- lapply(groups, function(group) {
#>     self$compute_group(data = group, scales = scales, ...)
#> })
#> 
#> [[5]]
#> stats <- mapply(function(new, old) {
#>     if (empty(new)) 
#>         return(new_data_frame())
#>     unique <- uniquecols(old)
#>     missing <- !(names(unique) %in% names(new))
#>     cbind(new, unique[rep(1, nrow(new)), missing, drop = FALSE])
#> }, stats, groups, SIMPLIFY = FALSE)
#> 
#> [[6]]
#> rbind_dfs(stats)
#> 

# 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
#> Returning `ggbody(GeomShape$draw_panel)`
invisible(ggbody(GeomArcBar$draw_key, inherit = TRUE))    # grandparent
#> Returning `ggbody(GeomPolygon$draw_key)`
invisible(ggbody(GeomArcBar$draw_group, inherit = TRUE))  # top-level
#> Returning `ggbody(Geom$draw_group)`

# 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.