diff --git a/NEWS.md b/NEWS.md index ee6a4a52..2a37250b 100644 --- a/NEWS.md +++ b/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 diff --git a/R/namespace.R b/R/namespace.R index 38f77fef..c12225fd 100644 --- a/R/namespace.R +++ b/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() } diff --git a/R/object-from-call.R b/R/object-from-call.R index 5b71ccb6..b99c6546 100644 --- a/R/object-from-call.R +++ b/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)) { diff --git a/tests/testthat/test-object-from-call.R b/tests/testthat/test-object-from-call.R index 40482a29..c5537b1e 100644 --- a/tests/testthat/test-object-from-call.R +++ b/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", { diff --git a/tests/testthat/test-object-s3.R b/tests/testthat/test-object-s3.R index c1f10476..6d1b88fe 100644 --- a/tests/testthat/test-object-s3.R +++ b/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")) -})