Improve S3 method handling

NAMESPACE

@@ -77,6 +77,12 @@ S3method(object_name,s3generic)
 S3method(object_name,s3method)
 S3method(object_name,s4generic)
 S3method(object_name,s4method)
+S3method(object_usage,"function")
+S3method(object_usage,data)
+S3method(object_usage,default)
+S3method(object_usage,s3method)
+S3method(object_usage,s4generic)
+S3method(object_usage,s4method)
 S3method(print,object)
 S3method(print,rd)
 S3method(print,rd_section)
@@ -162,6 +168,7 @@ S3method(roxy_tag_parse,roxy_tag_templateVar)
 S3method(roxy_tag_parse,roxy_tag_title)
 S3method(roxy_tag_parse,roxy_tag_usage)
 S3method(roxy_tag_parse,roxy_tag_useDynLib)
+S3method(roxy_tag_rd,default)
 S3method(roxy_tag_rd,roxy_tag_.formals)
 S3method(roxy_tag_rd,roxy_tag_.methods)
 S3method(roxy_tag_rd,roxy_tag_.reexport)

NEWS.md

@@ -1,5 +1,10 @@
 # roxygen2 (development version)
 
+* The NAMESPACE roclet now reports if you have S3 methods that are missing
+  an `@export` tag. All S3 methods need to be `@export`ed (which confusingly
+  really registers the method) even if the generic is not. This avoids rare,
+  but hard to debug, problems (#1175).
+
 * `@include` now gives an informative warning if you use a path that doesn't
   exist (#1497).
 

R/block.R

@@ -289,9 +289,3 @@ parse_description <- function(tags) {
 
   c(compact(list(title, description, details)), tags)
 }
-
-warn_roxy_block <- function(block, message, ...) {
-  message[[1]] <- paste0(link_to(block$file, block$line), ": ", message[[1]], ".")
-  names(message)[[1]] <- "x"
-  cli::cli_inform(message, ..., .envir = parent.frame())
-}

R/namespace.R

@@ -32,6 +32,8 @@ namespace_roclet <- function() {
 
 #' @export
 roclet_process.roclet_namespace <- function(x, blocks, env, base_path) {
+  warn_missing_s3_exports(blocks, env)
+
   blocks_to_ns(blocks, env)
 }
 
@@ -376,3 +378,20 @@ repeat_first_ignore_current <- function(name, x) {
     repeat_first(name, x)
   }
 }
+
+# missing s3 exports ------------------------------------------------------
+
+warn_missing_s3_exports <- function(blocks, env) {
+  objs <- as.list(env)
+  funs <- Filter(is.function, objs)
+  methods <- funs[map_lgl(names(funs), is_s3_method, env = env)]
+
+  s3blocks <- blocks[map_lgl(blocks, block_has_tags, c("export", "exportS3method"))]
+  s3objects <- map(blocks, function(block) block$object$value)
+
+  undocumented <- methods[!methods %in% s3objects]
+  srcrefs <- map(undocumented, attr, "srcref")
+  messages <- paste0("S3 method `", names(undocumented) , "` needs @export or @exportS3method tag")
+  map2(undocumented, messages, warn_roxy_function)
+}
+

R/parse.R

@@ -67,7 +67,7 @@ env_file <- function(file) {
   env <- new.env(parent = parent.env(globalenv()))
   methods::setPackageName("roxygen_devtest", env)
 
-  sys.source(file, envir = env)
+  sys.source(file, envir = env, keep.source = TRUE)
   env
 }
 

R/rd-usage.R

@@ -26,20 +26,24 @@ object_usage <- function(x) {
   UseMethod("object_usage")
 }
 
+#' @export
 object_usage.default <- function(x) {
   NULL
 }
 
+#' @export
 object_usage.data <- function(x) {
   rd(x$alias)
 }
 
+#' @export
 object_usage.function <- function(x) {
   function_usage(x$alias, formals(x$value), identity)
 }
 
 object_usage.s3generic <- object_usage.function
 
+#' @export
 object_usage.s3method <- function(x) {
   method <- attr(x$value, "s3method")
   s3method <- function(name) {
@@ -48,10 +52,12 @@ object_usage.s3method <- function(x) {
   function_usage(method[1], formals(x$value), s3method)
 }
 
+#' @export
 object_usage.s4generic <- function(x) {
   function_usage(x$value@generic, formals(x$value), identity)
 }
 
+#' @export
 object_usage.s4method <- function(x) {
   s4method <- function(name) {
     classes <- auto_backtick(as.character(x$value@defined))

R/rd.R

@@ -226,6 +226,7 @@ roxy_tag_rd <- function(x, base_path, env) {
   UseMethod("roxy_tag_rd")
 }
 
+#' @export
 roxy_tag_rd.default <- function(x, base_path, env) {
 }
 

R/tag.R

@@ -116,23 +116,3 @@ roxy_tag_warning <- function(x, ...) {
   warning(message, call. = FALSE, immediate. = TRUE)
   NULL
 }
-
-#' @export
-#' @rdname roxy_tag
-warn_roxy_tag <- function(tag, message, ...) {
-  message[[1]] <- paste0(
-    link_to(tag$file, tag$line), ": {.strong @", tag$tag, "} ",
-    if (is.null(tag$raw)) ("(automatically generated) "),
-    message[[1]], "."
-  )
-  names(message)[[1]] <- "x"
-  cli::cli_inform(message, ..., .envir = parent.frame())
-}
-
-link_to <- function(file, line) {
-  cli::style_hyperlink(
-    paste0(basename(file), ":", line),
-    paste0("file://", file),
-    params = c(line = line, col = 1)
-  )
-}

R/utils-warn.R

@@ -0,0 +1,34 @@
+
+#' @export
+#' @rdname roxy_tag
+warn_roxy_tag <- function(tag, message, parent = NULL, envir = parent.frame()) {
+  tag_name <- cli::format_inline("{.strong @{tag$tag}} ")
+  if (is.null(tag$raw)) tag_name <- paste(tag_name, "(automatically generated) ")
+  message[[1]] <- paste0(tag_name, message[[1]])
+
+  warn_roxy(tag$file, tag$line, message, parent = parent, envir = envir)
+}
+
+warn_roxy_block <- function(block, message, parent = NULL, envir = parent.frame()) {
+  warn_roxy(block$file, block$line, message, parent = parent, envir = envir)
+}
+
+warn_roxy_function <- function(fun, message, parent = NULL, envir = parent.frame()) {
+  srcref <- attr(fun, "srcref")
+  file <- attr(srcref, "srcfile")$filename
+  line <- as.vector(srcref)[[1]]
+
+  warn_roxy(file, line, message, parent = parent, envir = envir)
+}
+
+warn_roxy <- function(file, line, message, parent = NULL, envir = parent.frame()) {
+  link <- cli::style_hyperlink(
+    paste0(basename(file), ":", line),
+    paste0("file://", file),
+    params = c(line = line, col = 1)
+  )
+
+  message[[1]] <- paste0(link, ": ", message[[1]], ".")
+  names(message)[[1]] <- "x"
+  cli::cli_inform(message, parent = parent, .envir = envir)
+}

tests/testthat/_snaps/namespace.md

@@ -99,3 +99,14 @@
     Code
       out <- roc_proc_text(namespace_roclet(), block)
 
+# warns if S3 method not documented
+
+    Code
+      roc_proc_text(namespace_roclet(),
+      "\n      foo <- function(x) UseMethod('foo')\n      foo.numeric <- function(x) 1\n\n      mean.myclass <- function(x) 2\n    ")
+    Message
+      x <text>:5: S3 method `mean.myclass` needs @export or @exportS3method tag.
+      x <text>:3: S3 method `foo.numeric` needs @export or @exportS3method tag.
+    Output
+      character(0)
+

tests/testthat/test-namespace.R

@@ -419,3 +419,29 @@ test_that("Invalid imports throw a helpful error", {
   expect_equal(out, "importFrom(AnUnknownUnavailablePackage,Unchecked)")
 
 })
+
+
+# warn_missing_s3_exports -------------------------------------------------
+
+test_that("warns if S3 method not documented", {
+  expect_snapshot(
+    roc_proc_text(namespace_roclet(), "
+      foo <- function(x) UseMethod('foo')
+      foo.numeric <- function(x) 1
+
+      mean.myclass <- function(x) 2
+    "),
+    # Need to manually transform since the srcref is coming from the function;
+    # roc_proc_text() uses fake srcrefs for the blocks themselves
+    transform = function(x) gsub("file[a-z0-9]+", "<text>", x)
+  )
+})
+
+test_that("doesn't warn for potential false postives", {
+  roc <- namespace_roclet()
+  expect_no_warning({
+    roc_proc_text(roc, "foo.numeric <- function(x) 1")
+    roc_proc_text(roc, "is.numeric <- function(x) 1")
+    roc_proc_text(roc, "as.numeric <- function(x) 1")
+  })
+})