1#' Create a new ggproto object
2#'
3#' Construct a new object with `ggproto()`, test with `is.ggproto()`,
4#' and access parent methods/fields with `ggproto_parent()`.
5#'
6#' ggproto implements a protype based OO system which blurs the lines between
7#' classes and instances. It is inspired by the proto package, but it has some
8#' important differences. Notably, it cleanly supports cross-package
9#' inheritance, and has faster performance.
10#'
11#' In most cases, creating a new OO system to be used by a single package is
12#' not a good idea. However, it was the least-bad solution for ggplot2 because
13#' it required the fewest changes to an already complex code base.
14#'
15#' @section Calling methods:
16#' ggproto methods can take an optional `self` argument: if it is present,
17#' it is a regular method; if it's absent, it's a "static" method (i.e. it
18#' doesn't use any fields).
19#'
20#' Imagine you have a ggproto object `Adder`, which has a
21#' method `addx = function(self, n) n + self$x`. Then, to call this
22#' function, you would use `Adder$addx(10)` -- the `self` is passed
23#' in automatically by the wrapper function. `self` be located anywhere
24#' in the function signature, although customarily it comes first.
25#'
26#' @section Calling methods in a parent:
27#' To explicitly call a methods in a parent, use
28#' `ggproto_parent(Parent, self)`.
29#'
30#' @param _class Class name to assign to the object. This is stored as the class
31#'   attribute of the object. This is optional: if `NULL` (the default),
32#'   no class name will be added to the object.
33#' @param _inherit ggproto object to inherit from. If `NULL`, don't
34#'   inherit from any object.
35#' @param ... A list of members in the ggproto object.
36#' @export
37#' @examples
38#' Adder <- ggproto("Adder",
39#'   x = 0,
40#'   add = function(self, n) {
41#'     self$x <- self$x + n
42#'     self$x
43#'   }
44#'  )
45#' is.ggproto(Adder)
46#'
47#' Adder$add(10)
48#' Adder$add(10)
49#'
50#' Doubler <- ggproto("Doubler", Adder,
51#'   add = function(self, n) {
52#'     ggproto_parent(Adder, self)$add(n * 2)
53#'   }
54#' )
55#' Doubler$x
56#' Doubler$add(10)
57ggproto <- function(`_class` = NULL, `_inherit` = NULL, ...) {
58  e <- new.env(parent = emptyenv())
59
60  members <- list(...)
61  if (length(members) != sum(nzchar(names(members)))) {
62    abort("All members of a ggproto object must be named.")
63  }
64
65  # R <3.1.2 will error when list2env() is given an empty list, so we need to
66  # check length. https://github.com/tidyverse/ggplot2/issues/1444
67  if (length(members) > 0) {
68    list2env(members, envir = e)
69  }
70
71  # Dynamically capture parent: this is necessary in order to avoid
72  # capturing the parent at package build time.
73  `_inherit` <- substitute(`_inherit`)
74  env <- parent.frame()
75  find_super <- function() {
76    eval(`_inherit`, env, NULL)
77  }
78
79  super <- find_super()
80  if (!is.null(super)) {
81    if (!is.ggproto(super)) {
82      abort("`_inherit` must be a ggproto object.")
83    }
84    e$super <- find_super
85    class(e) <- c(`_class`, class(super))
86  } else {
87    class(e) <- c(`_class`, "ggproto", "gg")
88  }
89
90  e
91}
92
93
94#' @export
95#' @rdname ggproto
96#' @param parent,self Access parent class `parent` of object `self`.
97ggproto_parent <- function(parent, self) {
98  structure(list(parent = parent, self = self), class = "ggproto_parent")
99}
100
101#' @param x An object to test.
102#' @export
103#' @rdname ggproto
104is.ggproto <- function(x) inherits(x, "ggproto")
105
106fetch_ggproto <- function(x, name) {
107  res <- NULL
108
109  val <- .subset2(x, name)
110  # The is.null check is an optimization for a common case; exists() also
111  # catches the case where the value exists but has a NULL value.
112  if (!is.null(val) || exists(name, envir = x, inherits = FALSE)) {
113    res <- val
114  } else {
115    # If not found here, recurse into super environments
116    super <- .subset2(x, "super")
117    if (is.null(super)) {
118      # no super class
119    } else if (is.function(super)) {
120      res <- fetch_ggproto(super(), name)
121    } else {
122      abort(glue("
123        {class(x)[[1]]} was built with an incompatible version of ggproto.
124        Please reinstall the package that provides this extension.
125      "))
126    }
127  }
128
129  res
130}
131
132#' @importFrom utils .DollarNames
133#' @export
134.DollarNames.ggproto <- function(x, pattern = "") {
135  methods <- ls(envir = x)
136  if ("super" %in% methods) {
137    methods <- setdiff(methods, "super")
138    methods <- union(methods, Recall(x$super()))
139  }
140
141  if (identical(pattern, "")) {
142    methods
143  } else {
144    grep(pattern, methods, value = TRUE)
145  }
146
147}
148
149#' @export
150`$.ggproto` <- function(x, name) {
151  res <- fetch_ggproto(x, name)
152  if (!is.function(res)) {
153    return(res)
154  }
155
156  make_proto_method(x, res)
157}
158
159#' @export
160`$.ggproto_parent` <- function(x, name) {
161  res <- fetch_ggproto(.subset2(x, "parent"), name)
162  if (!is.function(res)) {
163    return(res)
164  }
165
166  make_proto_method(.subset2(x, "self"), res)
167}
168
169make_proto_method <- function(self, f) {
170  args <- formals(f)
171  # is.null is a fast path for a common case; the %in% check is slower but also
172  # catches the case where there's a `self = NULL` argument.
173  has_self  <- !is.null(args[["self"]]) || "self"  %in% names(args)
174
175  if (has_self) {
176    fun <- function(...) f(..., self = self)
177  } else {
178    fun <- function(...) f(...)
179  }
180
181  class(fun) <- "ggproto_method"
182  fun
183}
184
185#' @export
186`[[.ggproto` <- `$.ggproto`
187
188#' Convert a ggproto object to a list
189#'
190#' This will not include the object's `super` member.
191#'
192#' @param x A ggproto object to convert to a list.
193#' @param inherit If `TRUE` (the default), flatten all inherited items into
194#'   the returned list. If `FALSE`, do not include any inherited items.
195#' @inheritDotParams base::as.list.environment -x
196#' @export
197#' @keywords internal
198as.list.ggproto <- function(x, inherit = TRUE, ...) {
199  res <- list()
200
201  if (inherit) {
202    if (is.function(x$super)) {
203      res <- as.list(x$super())
204    }
205  }
206
207  current <- as.list.environment(x, ...)
208  res[names(current)] <- current
209  res$super <- NULL
210  res
211}
212
213
214#' Format or print a ggproto object
215#'
216#' If a ggproto object has a `$print` method, this will call that method.
217#' Otherwise, it will print out the members of the object, and optionally, the
218#' members of the inherited objects.
219#'
220#' @param x A ggproto object to print.
221#' @param flat If `TRUE` (the default), show a flattened list of all local
222#'   and inherited members. If `FALSE`, show the inheritance hierarchy.
223#' @param ... If the ggproto object has a `print` method, further arguments
224#'   will be passed to it. Otherwise, these arguments are unused.
225#'
226#' @export
227#' @examples
228#' Dog <- ggproto(
229#'   print = function(self, n) {
230#'     cat("Woof!\n")
231#'   }
232#'  )
233#' Dog
234#' cat(format(Dog), "\n")
235print.ggproto <- function(x, ..., flat = TRUE) {
236  if (is.function(x$print)) {
237    x$print(...)
238
239  } else {
240    cat(format(x, flat = flat), "\n", sep = "")
241    invisible(x)
242  }
243}
244
245
246#' @export
247#' @rdname print.ggproto
248format.ggproto <-  function(x, ..., flat = TRUE) {
249  classes_str <- function(obj) {
250    classes <- setdiff(class(obj), "ggproto")
251    if (length(classes) == 0)
252      return("")
253    paste0(": Class ", paste(classes, collapse = ', '))
254  }
255
256  # Get a flat list if requested
257  if (flat) {
258    objs <- as.list(x, inherit = TRUE)
259  } else {
260    objs <- x
261  }
262
263  str <- paste0(
264    "<ggproto object", classes_str(x), ">\n",
265    indent(object_summaries(objs, flat = flat), 4)
266  )
267
268  if (flat && is.function(x$super)) {
269    str <- paste0(
270      str, "\n",
271      indent(
272        paste0("super: ", " <ggproto object", classes_str(x$super()), ">"),
273        4
274      )
275    )
276  }
277
278  str
279}
280
281# Return a summary string of the items of a list or environment
282# x must be a list or environment
283object_summaries <- function(x, exclude = NULL, flat = TRUE) {
284  if (length(x) == 0)
285    return(NULL)
286
287  if (is.list(x))
288    obj_names <- sort(names(x))
289  else if (is.environment(x))
290    obj_names <- ls(x, all.names = TRUE)
291
292  obj_names <- setdiff(obj_names, exclude)
293
294  values <- vapply(obj_names, function(name) {
295    obj <- x[[name]]
296    if (is.function(obj)) "function"
297    else if (is.ggproto(obj)) format(obj, flat = flat)
298    else if (is.environment(obj)) "environment"
299    else if (is.null(obj)) "NULL"
300    else if (is.atomic(obj)) trim(paste(as.character(obj), collapse = " "))
301    else paste(class(obj), collapse = ", ")
302  }, FUN.VALUE = character(1))
303
304  paste0(obj_names, ": ", values, sep = "", collapse = "\n")
305}
306
307# Given a string, indent every line by some number of spaces.
308# The exception is to not add spaces after a trailing \n.
309indent <- function(str, indent = 0) {
310  gsub("(\\n|^)(?!$)",
311    paste0("\\1", paste(rep(" ", indent), collapse = "")),
312    str,
313    perl = TRUE
314  )
315}
316
317# Trim a string to n characters; if it's longer than n, add " ..." to the end
318trim <- function(str, n = 60) {
319  if (nchar(str) > n) paste(substr(str, 1, 56), "...")
320  else str
321}
322
323#' @export
324print.ggproto_method <- function(x, ...) {
325  cat(format(x), sep = "")
326}
327
328#' @export
329format.ggproto_method <- function(x, ...) {
330
331  # Given a function, return a string from srcref if present. If not present,
332  # paste the deparsed lines of code together.
333  format_fun <- function(fn) {
334    srcref <- attr(fn, "srcref", exact = TRUE)
335    if (is.null(srcref))
336      return(paste(format(fn), collapse = "\n"))
337
338    paste(as.character(srcref), collapse = "\n")
339  }
340
341  x <- unclass(x)
342  paste0(
343    "<ggproto method>",
344    "\n  <Wrapper function>\n    ", format_fun(x),
345    "\n\n  <Inner function (f)>\n    ", format_fun(environment(x)$f)
346  )
347}
348
349# proto2 TODO: better way of getting formals for self$draw
350ggproto_formals <- function(x) formals(environment(x)$f)
351