Implement basic support for S7 (#1843)

* Methods get useful default names, aliases, and usage
* New `@prop` tag for documenting non-constructor properties

Fixes #1484

Author: hadley

DESCRIPTION

@@ -37,6 +37,7 @@ Imports:
 Suggests: 
     covr,
     R.methodsS3,
+    S7,
     R.oo,
     rmarkdown (>= 2.16),
     testthat (>= 3.1.2),

NAMESPACE

@@ -45,6 +45,7 @@ S3method(format,rd_section_name)
 S3method(format,rd_section_note)
 S3method(format,rd_section_package)
 S3method(format,rd_section_param)
+S3method(format,rd_section_prop)
 S3method(format,rd_section_rawRd)
 S3method(format,rd_section_rcmethods)
 S3method(format,rd_section_reexport)
@@ -64,6 +65,7 @@ S3method(merge,rd_section_inherit_dot_params)
 S3method(merge,rd_section_inherit_section)
 S3method(merge,rd_section_minidesc)
 S3method(merge,rd_section_param)
+S3method(merge,rd_section_prop)
 S3method(merge,rd_section_reexport)
 S3method(merge,rd_section_section)
 S3method(merge,rd_section_seealso)
@@ -80,6 +82,9 @@ S3method(object_defaults,s3method)
 S3method(object_defaults,s4class)
 S3method(object_defaults,s4generic)
 S3method(object_defaults,s4method)
+S3method(object_defaults,s7class)
+S3method(object_defaults,s7generic)
+S3method(object_defaults,s7method)
 S3method(object_defaults,value)
 S3method(object_format,default)
 S3method(object_name,"function")
@@ -94,6 +99,9 @@ S3method(object_usage,default)
 S3method(object_usage,s3method)
 S3method(object_usage,s4generic)
 S3method(object_usage,s4method)
+S3method(object_usage,s7class)
+S3method(object_usage,s7generic)
+S3method(object_usage,s7method)
 S3method(object_usage,value)
 S3method(print,object)
 S3method(print,rd)
@@ -166,6 +174,7 @@ S3method(roxy_tag_parse,roxy_tag_noRd)
 S3method(roxy_tag_parse,roxy_tag_note)
 S3method(roxy_tag_parse,roxy_tag_order)
 S3method(roxy_tag_parse,roxy_tag_param)
+S3method(roxy_tag_parse,roxy_tag_prop)
 S3method(roxy_tag_parse,roxy_tag_rawNamespace)
 S3method(roxy_tag_parse,roxy_tag_rawRd)
 S3method(roxy_tag_parse,roxy_tag_rdname)
@@ -208,6 +217,7 @@ S3method(roxy_tag_rd,roxy_tag_inheritSection)
 S3method(roxy_tag_rd,roxy_tag_keywords)
 S3method(roxy_tag_rd,roxy_tag_note)
 S3method(roxy_tag_rd,roxy_tag_param)
+S3method(roxy_tag_rd,roxy_tag_prop)
 S3method(roxy_tag_rd,roxy_tag_rawRd)
 S3method(roxy_tag_rd,roxy_tag_references)
 S3method(roxy_tag_rd,roxy_tag_return)

NEWS.md

@@ -1,4 +1,8 @@
 # roxygen2 (development version)
+* Added initial support for S7 classes, generics, and methods (#1484). 
+  * S7 generics are documented like regular functions.
+  * S7 classes are documented like regular functions, but you can use `@prop` to document additional properties that are not constructor parameters. If multiple classes share one page, use `@prop ClassName@prop_name description` to group properties by class. 
+  * S7 methods registered with `method(generic, class) <- fn` are detected automatically and generate usage with `## S7 method for class <ClassName>`.
 * roxygen2 no longer depends on stringr/stringi. This means that no package in the devtools constellation depends on stringr, which in turn means you no longer need stringi, making it a bit easier to install in constrained Linux environments.
 * roxygen2 options can now be set using `Config/roxygen2/` fields in DESCRIPTION (e.g. `Config/roxygen2/markdown: TRUE`) instead of the `Roxygen` field. The old `Roxygen` field is still supported. Similarly, the roxygen2 version is now stored in `Config/roxygen2/version` instead of `RoxygenNote` (#1328).
 * Tags that expect single-line input now warn when they span multiple lines, catching common mistakes. Affected tags: `@aliases`, `@concept`, `@encoding`, `@exportClass`, `@exportMethod`, `@exportPattern`, `@exportS3Method`, `@importFrom`, `@importClassesFrom`, `@importMethodsFrom`, `@include`, `@inheritParams`, `@keywords`, `@method`, `@name`, `@order`, `@rdname`, `@S3method`, `@template`, and `@useDynLib` (#1642, #1688). This may break some existing usage, but it prevents a wide class of otherwise silent errors.

R/field.R

@@ -73,7 +73,16 @@ rd_section_description <- function(name, dt, dd) {
   if (length(dt) == 0) {
     return("")
   }
+  paste0("\\section{", name, "}{\n\n", rd_enumerate(dt, dd), "}\n")
+}
+rd_subsection_description <- function(name, dt, dd) {
+  if (length(dt) == 0) {
+    return("")
+  }
+  paste0("\\subsection{", name, "}{\n\n", rd_enumerate(dt, dd), "\n}\n")
+}
 
+rd_enumerate <- function(dt, dd) {
   items <- paste0("\\item{\\code{", dt, "}}{", dd, "}", collapse = "\n\n")
-  paste0("\\section{", name, "}{\n\n", "\\describe{\n", items, "\n}}\n")
+  paste0("\\describe{\n", items, "\n}")
 }

R/object-defaults.R

@@ -120,6 +120,20 @@ object_defaults.import <- function(x, block) {
   )
 }
 
+#' @export
+object_defaults.s7class <- object_defaults.function
+
+#' @export
+object_defaults.s7generic <- object_defaults.function
+
+#' @export
+object_defaults.s7method <- function(x, block) {
+  list(
+    roxy_generated_tag(block, "usage", object_usage(x)),
+    roxy_generated_tag(block, ".formals", names(formals(x$value$fn)))
+  )
+}
+
 #' @export
 object_defaults.s4class <- function(x, block) {
   list(

R/object-from-call.R

@@ -8,6 +8,10 @@ object_from_call <- function(call, env, block, file) {
   } else if (is_set_call(call)) {
     parser_r6_set(call, env)
   } else if (is.call(call)) {
+    if (is_s7_method_call(call)) {
+      return(parser_s7_method(call, env, block))
+    }
+
     call <- call_match(call, eval(call[[1]], env))
     name <- deparse(call[[1]])
     switch(
@@ -74,6 +78,10 @@ object_from_name <- function(name, env, block) {
     type <- "s4method"
   } else if (methods::is(value, "standardGeneric")) {
     type <- "s4generic"
+  } else if (inherits(value, "S7_class")) {
+    type <- "s7class"
+  } else if (inherits(value, "S7_generic")) {
+    type <- "s7generic"
   } else if (is.function(value)) {
     # Potential S3 methods/generics need metadata added
     method <- block_get_tag_value(block, "method")
@@ -225,6 +233,63 @@ parser_setConstructorS3 <- function(call, env, block) {
   object(get(name, env), name, "function")
 }
 
+# method(generic, class) <- fn
+# `<-`(method(generic, class), fn)
+is_s7_method_call <- function(call) {
+  is_call(call, "<-", n = 2) && is_call(call[[2]], "method", ns = c("", "S7"))
+}
+
+parser_s7_method <- function(call, env, block) {
+  generic_call <- call[[2]][[2]]
+  class_call <- call[[2]][[3]]
+  method_call <- call[[3]]
+
+  generic <- eval(generic_call, env)
+  generic_name <- generic@name
+
+  # Evaluate class spec: either a single class, a union, or list() for
+  # multi-dispatch
+  classes <- eval(class_call, env)
+  if (!is_bare_list(classes)) {
+    classes <- list(classes)
+  }
+  class_names <- lapply(classes, s7_class_name, block = block)
+
+  fn <- eval(method_call, env)
+
+  value <- list(fn = fn, generic = generic_name, classes = class_names)
+  aliases <- s7_method_aliases(generic_name, class_names)
+  object(value, aliases, "s7method")
+}
+
+s7_method_aliases <- function(generic, classes) {
+  if (!any(lengths(classes) > 1)) {
+    return(NULL)
+  }
+
+  combos <- expand.grid(classes, stringsAsFactors = FALSE)
+  apply(combos, 1, function(row) {
+    paste0(generic, ",", paste0(row, collapse = ","), "-method")
+  })
+}
+
+# https://github.com/RConsortium/S7/issues/594
+s7_class_name <- function(cls, block) {
+  name <- nameOfClass(cls)
+  if (!is.null(name)) {
+    # Regular S7 class + base wrappers
+    name
+  } else if (inherits(cls, "S7_union")) {
+    # Unions return vector of member names, recursing for nested types
+    unlist(lapply(cls$classes, s7_class_name, block = block))
+  } else if (inherits(cls, "S7_S3_class")) {
+    cls$class
+  } else {
+    warn_roxy_block(block, "Unknown S7 class type")
+    paste0(deparse(cls), collapse = " ")
+  }
+}
+
 # helpers -----------------------------------------------------------------
 
 add_s3_metadata <- function(val, name, env, block) {
@@ -332,18 +397,16 @@ print.object <- function(x, ...) {
 object_topic <- function(value, alias, type) {
   switch(
     type,
-    s4method = paste0(
-      value@generic,
-      ",",
-      paste0(value@defined, collapse = ","),
-      "-method"
-    ),
+    s4method = method_topic(value@generic, value@defined),
     s4class = paste0(value@className, "-class"),
     s4generic = value@generic,
     rcclass = paste0(value@className, "-class"),
     r6class = alias,
     r6method = alias,
     rcmethod = value@name,
+    s7class = alias,
+    s7generic = alias,
+    s7method = method_topic(value$generic, value$classes),
     s3generic = alias,
     s3method = alias,
     import = alias,
@@ -355,6 +418,11 @@ object_topic <- function(value, alias, type) {
   )
 }
 
+method_topic <- function(generic, classes) {
+  class_strings <- vapply(classes, paste0, character(1), collapse = "/")
+  paste0(generic, ",", paste0(class_strings, collapse = ","), "-method")
+}
+
 call_to_object <- function(code, env = pkg_env(), file = NULL) {
   code <- enexpr(code)
 

R/rd-s7.R

@@ -0,0 +1,60 @@
+#' @export
+roxy_tag_parse.roxy_tag_prop <- function(x) {
+  x <- tag_two_part(x, "a property name", "a description")
+
+  # Optionally specify a class
+  if (grepl("@", x$val$name, fixed = TRUE)) {
+    pieces <- strsplit(x$val$name, "@", fixed = TRUE)[[1]]
+    if (length(pieces) != 2 || pieces[[1]] == "" || pieces[[2]] == "") {
+      warn_roxy_tag(x, "must have form class@prop")
+      return()
+    }
+    x$val$class <- pieces[[1]]
+    x$val$name <- pieces[[2]]
+  }
+
+  x
+}
+
+#' @export
+roxy_tag_rd.roxy_tag_prop <- function(x, base_path, env) {
+  rd_section(
+    x$tag,
+    data.frame(
+      class = x$val$class %||% NA_character_,
+      name = x$val$name,
+      description = x$val$description
+    )
+  )
+}
+
+#' @export
+merge.rd_section_prop <- function(x, y, ...) {
+  stopifnot(identical(class(x), class(y)))
+  rd_section(x$type, rbind(x$value, y$value))
+}
+
+#' @export
+format.rd_section_prop <- function(x, ...) {
+  props <- x$value
+  classes <- unique(props$class)
+
+  if (identical(classes, NA_character_)) {
+    return(rd_section_description(
+      "Additional properties",
+      paste0("@", props$name),
+      props$description
+    ))
+  }
+
+  sections <- map_chr(classes, function(cls) {
+    rows <- props[props$class == cls, ]
+    rd_subsection_description(cls, paste0("@", rows$name), rows$description)
+  })
+
+  paste0(
+    "\\section{Additional properties}{\n\n",
+    paste0(sections, collapse = "\n"),
+    "}\n"
+  )
+}

R/rd-usage.R

@@ -75,6 +75,31 @@ object_usage.s4method <- function(x) {
   function_usage(x$value@generic, formals(x$value), s4method)
 }
 
+#' @export
+object_usage.s7class <- object_usage.function
+
+#' @export
+object_usage.s7generic <- object_usage.function
+
+#' @export
+object_usage.s7method <- function(x) {
+  generic <- x$value$generic
+  classes <- x$value$classes
+
+  formatted <- map_chr(classes, \(nms) paste0("<", nms, ">", collapse = "/"))
+  if (length(formatted) == 1) {
+    comment <- paste0("## S7 method for class ", formatted)
+  } else {
+    comment <- paste0(
+      "## S7 method for classes ",
+      paste0(formatted, collapse = ", ")
+    )
+  }
+
+  usage <- function_usage(generic, formals(x$value$fn), identity)
+  rd(paste0(comment, "\n", usage))
+}
+
 # Function usage ----------------------------------------------------------
 
 # Usage:

inst/roxygen2-tags.yml

@@ -307,6 +307,13 @@
   vignette: rd
   recommend: true
 
+- name: prop
+  description: >
+    Describe an S7 class property that is not a constructor parameter.
+  template: ' ${1:name} ${2:description}'
+  vignette: rd-oop
+  recommend: true
+
 - name: R6method
   description: >
     Document an R6 method that can't be discovered by introspection,