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