Improve link resolution

NEWS.md

@@ -1,5 +1,6 @@
 # roxygen2 (development version)
 
+* Markdown links now do a better job of resolving package names: the process is cached for better performance (#1724); it works with infix operators (e.g. `[%in%]`) (#1728); no longer changes the link text (#1662); and includes base packages when reporting ambiguous functions (#1725).
 * Package documentation now uses `logo.svg` if available, falling back to `logo.png` (#1640).
 * `@family` no longer adds a trailing space after the colon in the default family prefix (#1628). Custom `rd_family_title` values now automatically get a colon appended if they don't already end with one (#1656).
 * `@inheritDotParams` now warns and produces no output when there are no parameters to inherit, instead of generating an empty `\describe` block that caused CRAN HTML validation warnings (#1671).

R/markdown-link-resolve.R

@@ -0,0 +1,151 @@
+find_package <- function(topic, tag = NULL) {
+  cur_pkg <- roxy_meta_get("current_package")
+  cur_pkg_dir <- roxy_meta_get("current_package_dir")
+  if (is.null(cur_pkg)) {
+    # Don't try and link in basic tests
+    return(NA_character_)
+  }
+
+  pkg <- find_package_cached(topic, pkg = cur_pkg, pkg_dir = cur_pkg_dir)
+  if (length(pkg) == 0) {
+    warn_roxy_tag(
+      tag,
+      c(
+        "Could not resolve link to topic {.val {topic}} in the dependencies or base packages.",
+        "i" = paste(
+          "If you haven't documented {.val {topic}} yet, or just changed its name, this is normal.",
+          "Once {.val {topic}} is documented, this warning goes away."
+        ),
+        "i" = "Make sure that the name of the topic is spelled correctly.",
+        "i" = "Always list the linked package as a dependency.",
+        "i" = "Alternatively, you can fully qualify the link with a package name."
+      )
+    )
+    NA_character_
+  } else if (length(pkg) == 1) {
+    pkg
+  } else {
+    warn_roxy_tag(
+      tag,
+      c(
+        "Topic {.val {topic}} is available in multiple packages: {.pkg {pkg}}.",
+        i = "Qualify topic explicitly with a package name when linking to it."
+      )
+    )
+    NA_character_
+  }
+}
+
+find_package_cache <- new_environment()
+# run in roxygenize() because the documented functions might change between runs
+find_package_cache_reset <- function() {
+  env_unbind(find_package_cache, env_names(find_package_cache))
+
+  # also reset the cache used by dev_help() (used by has_topic())
+  pkg <- roxy_meta_get("current_package")
+  if (!is.null(pkg)) pkgload::dev_topic_index_reset(pkg)
+}
+find_package_cached <- function(topic, pkg, pkg_dir) {
+  key <- paste0(pkg, "::", topic)
+  env_cache(find_package_cache, key, find_package_lookup(topic, pkg, pkg_dir))
+}
+
+# NA_character  = found, doesn't need qualification
+# character(0)  = not found
+# character(1)  = one match
+# character(>1) = multiple matches
+find_package_lookup <- function(topic, pkg, pkg_dir) {
+  # if it is in the current package, then no need for package name
+  if (has_topic(topic, pkg)) {
+    return(NA_character_)
+  }
+
+  pkgs <- pkg_deps(pkg_dir)
+  pkg_has_topic <- pkgs[map_lgl(pkgs, has_topic, topic = topic)]
+  pkg_has_topic <- map_chr(pkg_has_topic, \(pkg) find_source(topic, pkg))
+  pkg_has_topic <- unique(pkg_has_topic)
+
+  base <- base_packages()
+  if (length(pkg_has_topic) == 0) {
+    # can't find it anywhere
+    character()
+  } else if (length(pkg_has_topic) == 1) {
+    if (pkg_has_topic %in% base) {
+      # never qualify links to base packages
+      NA_character_
+    } else {
+      pkg_has_topic
+    }
+  } else if (all(pkg_has_topic %in% base)) {
+    # multiple base packages, no qualification needed
+    NA_character_
+  } else {
+    pkg_has_topic
+  }
+}
+
+pkg_deps <- function(pkgdir) {
+  deps <- desc::desc_get_deps(pkgdir)
+  deps <- deps[deps$package != "R", ]
+  deps <- deps[deps$type %in% c("Depends", "Imports", "Suggests"), ]
+  c(deps$package, base_packages())
+}
+
+base_packages <- function() {
+  if (getRversion() >= "4.4.0") {
+    asNamespace("tools")$standard_package_names()[["base"]]
+  } else {
+    c(
+      "base",
+      "compiler",
+      "datasets",
+      "graphics",
+      "grDevices",
+      "grid",
+      "methods",
+      "parallel",
+      "splines",
+      "stats",
+      "stats4",
+      "tcltk",
+      "tools",
+      "utils"
+    )
+  }
+}
+
+# Adapted from downlit:::find_reexport_source
+find_source <- function(topic, package) {
+  if (package %in% base_packages()) {
+    return(package)
+  }
+
+  ns <- ns_env(package)
+  if (!env_has(ns, topic, inherit = TRUE)) {
+    return(package)
+  }
+
+  obj <- env_get(ns, topic, inherit = TRUE)
+  if (is.primitive(obj)) {
+    # primitive functions all live in base
+    "base"
+  } else if (is.function(obj)) {
+    ## For functions, we can just take their environment.
+    ns_env_name(get_env(obj))
+  } else {
+    ## For other objects, we need to check the import env of the package,
+    ## to see where 'topic' is coming from. The import env has redundant
+    ## information. It seems that we just need to find a named list
+    ## entry that contains `topic`.
+    imp <- getNamespaceImports(ns)
+    imp <- imp[names(imp) != ""]
+    wpkgs <- map_lgl(imp, `%in%`, x = topic)
+    if (!any(wpkgs)) {
+      return(package)
+    }
+
+    pkgs <- names(wpkgs)[wpkgs]
+    # Take the last match, in case imports have name clashes.
+    pkgs[[length(pkgs)]]
+  }
+}

R/markdown-link.R

@@ -131,22 +131,26 @@ parse_link <- function(destination, contents, state) {
   thispkg <- roxy_meta_get("current_package") %||% ""
   is_code <- is_code || (grepl("[(][)]$", destination) && !has_link_text)
   pkg <- str_match(destination, "^(.*)::")[1, 2]
-  pkg <- gsub("%", "\\\\%", pkg)
+  explicit_pkg <- !is.na(pkg)
   fun <- utils::tail(strsplit(destination, "::", fixed = TRUE)[[1]], 1)
-  fun <- gsub("%", "\\\\%", fun)
   is_fun <- grepl("[(][)]$", fun)
   obj <- sub("[(][)]$", "", fun)
   s4 <- str_detect(destination, "-class$")
   noclass <- str_match(fun, "^(.*)-class$")[1, 2]
 
+  # Lookup topic using unescaped names, then escape % for Rd output
   if (is.na(pkg)) {
-    pkg <- resolve_link_package(obj, thispkg, state = state)
-  }
-  if (!is.na(pkg) && pkg == thispkg) {
+    pkg <- find_package(obj, tag = state$tag)
+  } else if (!is.na(pkg) && pkg == thispkg) {
     pkg <- NA_character_
   }
   file <- find_topic_filename(pkg, obj, state$tag)
 
+  pkg <- gsub("%", "\\\\%", pkg)
+  fun <- gsub("%", "\\\\%", fun)
+  obj <- gsub("%", "\\\\%", obj)
+  noclass <- gsub("%", "\\\\%", noclass)
+
   ## To understand this, look at the RD column of the table above
   if (!has_link_text) {
     paste0(
@@ -157,7 +161,7 @@ parse_link <- function(destination, contents, state) {
       if (!is.na(pkg)) paste0(pkg, ":"),
       if (is_fun || !is.na(pkg)) paste0(if (is.na(pkg)) obj else file, "]"),
       "{",
-      if (!is.na(pkg)) paste0(pkg, "::"),
+      if (explicit_pkg && !is.na(pkg)) paste0(pkg, "::"),
       if (s4) noclass else fun,
       "}",
       if (is_code) "}" else ""
@@ -180,119 +184,6 @@ parse_link <- function(destination, contents, state) {
   }
 }
 
-resolve_link_package <- function(
-  topic,
-  me = NULL,
-  pkgdir = NULL,
-  state = NULL
-) {
-  me <- me %||% roxy_meta_get("current_package")
-  # this is  from the roxygen2 tests, should not happen on a real package
-  if (is.null(me) || is.na(me) || me == "") {
-    return(NA_character_)
-  }
-
-  # if it is in the current package, then no need for package name, right?
-  if (has_topic(topic, me)) {
-    return(NA_character_)
-  }
-
-  # try packages in depends, imports, suggests first, error on name clashes
-  pkgs <- local_pkg_deps(pkgdir)
-
-  pkg_has_topic <- pkgs[map_lgl(pkgs, has_topic, topic = topic)]
-  pkg_has_topic <- map_chr(pkg_has_topic, function(p) {
-    p0 <- find_reexport_source(topic, p)
-    if (is.na(p0)) p else p0
-  })
-  pkg_has_topic <- unique(pkg_has_topic)
-  base <- base_packages()
-  if (length(pkg_has_topic) == 0) {
-    # fall through to check base packages as well
-  } else if (length(pkg_has_topic) == 1) {
-    if (pkg_has_topic %in% base) {
-      return(NA_character_)
-    } else {
-      return(pkg_has_topic)
-    }
-  } else {
-    warn_roxy_tag(
-      state$tag,
-      c(
-        "Topic {.val {topic}} is available in multiple packages: {.pkg {pkg_has_topic}}",
-        i = "Qualify topic explicitly with a package name when linking to it."
-      )
-    )
-    return(NA_character_)
-  }
-
-  # try base packages as well, take the first hit,
-  # there should not be any name clashes, anyway
-  for (bp in base) {
-    if (has_topic(topic, bp)) return(NA_character_)
-  }
-
-  warn_roxy_tag(
-    state$tag,
-    c(
-      "Could not resolve link to topic {.val {topic}} in the dependencies or base packages",
-      "i" = paste(
-        "If you haven't documented {.val {topic}} yet, or just changed its name, this is normal.",
-        "Once {.val {topic}} is documented, this warning goes away."
-      ),
-      "i" = "Make sure that the name of the topic is spelled correctly.",
-      "i" = "Always list the linked package as a dependency.",
-      "i" = "Alternatively, you can fully qualify the link with a package name."
-    )
-  )
-
-  NA_character_
-}
-
-# this is mostly from downlit
-is_exported <- function(name, package) {
-  name %in% getNamespaceExports(ns_env(package))
-}
-
-is_reexported <- function(name, package) {
-  if (package == "base") {
-    return(FALSE)
-  }
-  is_imported <- env_has(ns_imports_env(package), name)
-  is_imported && is_exported(name, package)
-}
-
-find_reexport_source <- function(topic, package) {
-  ns <- ns_env(package)
-  if (!env_has(ns, topic, inherit = TRUE)) {
-    return(NA_character_)
-  }
-
-  obj <- env_get(ns, topic, inherit = TRUE)
-  if (is.primitive(obj)) {
-    # primitive functions all live in base
-    "base"
-  } else if (is.function(obj)) {
-    ## For functions, we can just take their environment.
-    ns_env_name(get_env(obj))
-  } else {
-    ## For other objects, we need to check the import env of the package,
-    ## to see where 'topic' is coming from. The import env has redundant
-    ## information. It seems that we just need to find a named list
-    ## entry that contains `topic`.
-    imp <- getNamespaceImports(ns)
-    imp <- imp[names(imp) != ""]
-    wpkgs <- vapply(imp, `%in%`, x = topic, FUN.VALUE = logical(1))
-
-    if (!any(wpkgs)) {
-      return(NA_character_)
-    }
-    pkgs <- names(wpkgs)[wpkgs]
-    # Take the last match, in case imports have name clashes.
-    pkgs[[length(pkgs)]]
-  }
-}
-
 #' Dummy page to test roxygen's markdown formatting
 #'
 #' Links are very tricky, so I'll put in some links here:

R/markdown.R

@@ -17,8 +17,6 @@ markdown <- function(text, tag = NULL, sections = FALSE) {
   )
 }
 
-mddata <- new.env(parent = emptyenv())
-
 #' Expand the embedded inline code
 #'
 #' @details
@@ -70,7 +68,6 @@ mddata <- new.env(parent = emptyenv())
 #' @keywords internal
 
 markdown_pass1 <- function(text) {
-  rm(list = ls(envir = mddata), envir = mddata)
   text <- paste(text, collapse = "\n")
   mdxml <- xml_ns_strip(md_to_mdxml(text, sourcepos = TRUE))
   code_nodes <- xml_find_all(mdxml, ".//code | .//code_block")

R/roxygenize.R

@@ -33,6 +33,7 @@ roxygenize <- function(
   base_path <- normalizePath(package.dir)
   is_first <- roxygen_setup(base_path)
 
+  find_package_cache_reset()
   roxy_meta_load(base_path)
   # Load required packages for method registration
   packages <- roxy_meta_get("packages")

R/utils-warn.R

@@ -1,6 +1,12 @@
 #' @export
 #' @rdname roxy_tag
 warn_roxy_tag <- function(tag, message, parent = NULL, envir = parent.frame()) {
+  if (is.null(tag)) {
+    names(message)[[1]] <- "x"
+    cli::cli_inform(message, parent = parent, .envir = envir)
+    return(invisible())
+  }
+
   tag_name <- cli::format_inline("{.strong @{tag$tag}} ")
   if (is.null(tag$raw)) {
     tag_name <- paste(tag_name, "(automatically generated) ")

R/utils.R

@@ -234,41 +234,3 @@ auto_quote <- function(x) {
 is_syntactic <- function(x) make.names(x) == x
 has_quotes <- function(x) str_detect(x, r"[^(`|'|").*\1$]")
 strip_quotes <- function(x) str_replace(x, r"[^(`|'|")(.*)\1$]", r"(\2)")
-
-base_packages <- function() {
-  if (getRversion() >= "4.4.0") {
-    asNamespace("tools")$standard_package_names()[["base"]]
-  } else {
-    c(
-      "base",
-      "compiler",
-      "datasets",
-      "graphics",
-      "grDevices",
-      "grid",
-      "methods",
-      "parallel",
-      "splines",
-      "stats",
-      "stats4",
-      "tcltk",
-      "tools",
-      "utils"
-    )
-  }
-}
-
-# Note that this caches the result regardless of
-# pkgdir! pkgdir is mainly for testing, in which case you
-# need to clear the cache manually.
-
-local_pkg_deps <- function(pkgdir = NULL) {
-  if (!is.null(mddata[["deps"]])) {
-    return(mddata[["deps"]])
-  }
-  pkgdir <- pkgdir %||% roxy_meta_get("current_package_dir")
-  deps <- desc::desc_get_deps(pkgdir)
-  deps <- deps[deps$package != "R", ]
-  deps <- deps[deps$type %in% c("Depends", "Imports", "Suggests"), ]
-  deps$package
-}