Derive S3 metadata from @exportS3Method() (#1546)

Fixes #1202

NEWS.md

@@ -1,5 +1,8 @@
 # roxygen2 (development version)
 
+* `@exportS3Method` provides the needed metadata to generate correct usage
+  for S3 methods, just like `@method` (#1202).
+
 * If you document a function from another package it is automatically 
   imported. Additionally, if you set `@rdname` or `@name` you can opt out 
   of the default `reexports` topic generation and provide your own docs 

R/namespace.R

@@ -207,7 +207,7 @@ roxy_tag_ns.roxy_tag_exportS3Method <- function(x, block, env) {
 
     method <- attr(obj$value, "s3method")
   } else if (length(x$val) == 1) {
-    if (!inherits(obj, "function")) {
+    if (!inherits(obj, "function") && !inherits(obj, "s3method")) {
       warn_roxy_tag(x, "must be used with a function")
       return()
     }

R/object-from-call.R

@@ -71,7 +71,7 @@ object_from_name <- function(name, env, block) {
   } else if (is.function(value)) {
     # Potential S3 methods/generics need metadata added
     method <- block_get_tag_value(block, "method")
-    value <- add_s3_metadata(value, name, env, method)
+    value <- add_s3_metadata(value, name, env, block)
     if (inherits(value, "s3generic")) {
       type <- "s3generic"
     } else if (inherits(value, "s3method")) {
@@ -185,8 +185,7 @@ parser_setMethodS3 <- function(call, env, block) {
   class <- as.character(call[[3]])
   name <- paste(method, class, sep = ".")
 
-  method <- block_get_tag_value(block, "method")
-  value <- add_s3_metadata(get(name, env), name, env, method)
+  value <- add_s3_metadata(get(name, env), name, env, block)
 
   object(value, name, "s3method")
 }
@@ -199,10 +198,19 @@ parser_setConstructorS3 <- function(call, env, block) {
 
 # helpers -----------------------------------------------------------------
 
-# @param override Either NULL to use default, or a character vector of length 2
-add_s3_metadata <- function(val, name, env, override = NULL) {
-  if (!is.null(override)) {
-    return(s3_method(val, override))
+add_s3_metadata <- function(val, name, env, block) {
+  if (block_has_tags(block, "method")) {
+    method <- block_get_tag_value(block, "method")
+    return(s3_method(val, method))
+  }
+
+  if (block_has_tags(block, "exportS3Method")) {
+    method <- block_get_tag_value(block, "exportS3Method")
+    if (length(method) == 1 && str_detect(method, "::")) {
+      generic <- strsplit(method, "::")[[1]][[2]]
+      class <- gsub(paste0("^", generic, "\\."), "", name)
+      return(s3_method(val, c(generic, class)))
+    }
   }
 
   if (is_s3_generic(name, env)) {

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

@@ -127,6 +127,39 @@ test_that("finds function created with delayed assignment", {
   expect_s3_class(obj, "function")
 })
 
+# S3 ----------------------------------------------------------------------
+
+test_that("can derive S3 metadata for base generics", {
+  block <- "
+    #' @export
+    mean.foo <- function(...) 1
+  "
+  out <- parse_text(block)[[1]]
+
+  expect_equal(s3_method_info(out$object$value), c("mean", "foo"))
+})
+
+test_that("@method overrides auto-detection", {
+  block <- "
+    #' @export
+    #' @method all.equal data.frame
+    all.equal.data.frame <- function(...) 1
+  "
+  out <- parse_text(block)[[1]]
+
+  expect_equal(s3_method_info(out$object$value), c("all.equal", "data.frame"))
+})
+
+test_that("exportS3Method registers S3 metadata", {
+  block <- "
+    #' @exportS3Method stats::median
+    median.foo <- function(...) 1
+  "
+  out <- parse_text(block)[[1]]
+  expect_equal(s3_method_info(out$object$value), c("median", "foo"))
+})
+
+
 # S4 ----------------------------------------------------------------------
 
 test_that("finds S4 and RC classes", {
@@ -184,6 +217,7 @@ test_that("finds arguments when S4 method wrapped inside .local()", {
   expect_named(formals(obj$value@.Data), c("x", "foo", "..."))
 })
 
+
 # R.oo / R.methodsS3 ------------------------------------------------------
 
 test_that("can define constructor with R.oo", {

tests/testthat/test-object-s3.R

@@ -50,13 +50,3 @@ test_that("user defined functions override primitives", {
   expect_false(is_s3_generic("c"))
   expect_false(is_s3_method("c"))
 })
-
-test_that("@method overrides auto-detection", {
-  out <- parse_text("
-    #' @export
-    #' @method all.equal data.frame
-    all.equal.data.frame <- function(...) 1
-  ")[[1]]
-
-  expect_equal(s3_method_info(out$object$value), c("all.equal", "data.frame"))
-})