S7 improvements (#1853)

* Fix error when `@prop` had mismatched braces.
* Make sure `method(generic, class)` works when `generic` is S3 or S4.
* Add tests for classes with package set, and improve the output file name.

Author: hadley

R/object-from-call.R

@@ -245,7 +245,12 @@ parser_s7_method <- function(call, env, block) {
   method_call <- call[[3]]
 
   generic <- eval(generic_call, env)
-  generic_name <- generic@name
+  if (inherits(generic, "S7_generic")) {
+    generic_name <- generic@name
+  } else {
+    # S3 or S4 generic passed by name
+    generic_name <- deparse(generic_call)
+  }
 
   # Evaluate class spec: either a single class, a union, or list() for
   # multi-dispatch

R/rd-s7.R

@@ -1,6 +1,9 @@
 #' @export
 roxy_tag_parse.roxy_tag_prop <- function(x) {
   x <- tag_two_part(x, "a property name", "a description")
+  if (is.null(x)) {
+    return()
+  }
 
   # Optionally specify a class
   if (grepl("@", x$val$name, fixed = TRUE)) {

R/utils.R

@@ -14,6 +14,7 @@ subs <- c(
   "[<-" = "-subset-",
   "[" = "-sub-",
   "<-" = "-set-",
+  "::" = "-",
 
   # Infix verbs
   "!" = "-not-",

tests/testthat/_snaps/rd-s7.md

@@ -35,6 +35,13 @@
       }
        
 
+# @prop with mismatched braces warns and doesn't crash
+
+    Code
+      . <- roc_proc_text(rd_roclet(), text)
+    Message
+      x <text>:4: @prop has mismatched braces or quotes.
+
 # @prop class@name warns on invalid spec
 
     Code

tests/testthat/test-object-from-call.R

@@ -295,6 +295,38 @@ test_that("S7 non-union method has no extra aliases", {
   expect_null(obj$alias)
 })
 
+test_that("finds S7 methods for S3 generics", {
+  skip_unless_r(">= 4.3.0")
+  obj <- call_to_object({
+    Dog <- S7::new_class("Dog")
+    S7::method(print, Dog) <- function(x, ...) cat("Dog\n")
+  })
+  expect_s3_class(obj, "s7method")
+  expect_equal(obj$topic, "print,Dog-method")
+  expect_equal(obj$value$generic, "print")
+})
+
+test_that("S7 method topic includes package prefix in class name", {
+  skip_unless_r(">= 4.3.0")
+  obj <- call_to_object({
+    Dog <- S7::new_class("Dog", package = "mypkg")
+    speak <- S7::new_generic("speak", "x")
+    S7::method(speak, Dog) <- function(x) "Woof"
+  })
+  expect_equal(obj$topic, "speak,mypkg::Dog-method")
+  expect_equal(obj$value$classes, list("mypkg::Dog"))
+})
+
+test_that("S7 method on S3 generic includes package prefix in class name", {
+  skip_unless_r(">= 4.3.0")
+  obj <- call_to_object({
+    Dog <- S7::new_class("Dog", package = "mypkg")
+    S7::method(print, Dog) <- function(x, ...) cat("Dog\n")
+  })
+  expect_equal(obj$topic, "print,mypkg::Dog-method")
+  expect_equal(obj$value$generic, "print")
+})
+
 test_that("S7 method with unknown class type warns", {
   skip_unless_r(">= 4.3.0")
   block <- roxy_block(tags = list(), file = "test.R", line = 1, call = quote(x))

tests/testthat/test-rd-s7.R

@@ -30,6 +30,17 @@ test_that("@prop class@name groups by class", {
   expect_snapshot(out$get_section("prop"))
 })
 
+test_that("@prop with mismatched braces warns and doesn't crash", {
+  text <- "
+    #' A class.
+    #'
+    #' @prop a prop a
+    #' }
+    a <- function() {}
+  "
+  expect_snapshot(. <- roc_proc_text(rd_roclet(), text))
+})
+
 test_that("@prop class@name warns on invalid spec", {
   text <- "
     #' A class.

tests/testthat/test-utils.R

@@ -8,6 +8,10 @@ test_that("nice_name protects against invalid characters", {
   expect_equal(nice_name("[.a"), "sub-.a")
 })
 
+test_that("nice_name strips ::", {
+  expect_equal(nice_name("print,pkg::Class-method"), "print-pkg-Class-method")
+})
+
 test_that("is_namespaced works as expected", {
   expect_true(is_namespaced("a::b"))
   expect_false(is_namespaced("b::"))