tests/testthat/helper-exports.R

In robustfa: Object Oriented Solution for Robust Factor Analysis

# Multiline-aware parsing of export() and exportMethods() from NAMESPACE
.parse_namespace_exports <- function(ns_text) {
  if (!length(ns_text)) return(data.frame(name=character(), kind=character(), line=integer(), text=character(), stringsAsFactors = FALSE))
  text <- paste(ns_text, collapse = "\n")
  m <- gregexpr("(exportMethods|export)\\s*\\((.*?)\\)", text, perl = TRUE)
  starts <- as.integer(m[[1]])
  if (length(starts) == 1L && starts[1] == -1L) {
    return(data.frame(name=character(), kind=character(), line=integer(), text=character(), stringsAsFactors = FALSE))
  }
  lens <- attr(m[[1]], "match.length")
  out_name <- character(); out_kind <- character(); out_line <- integer(); out_text <- character()
  count_lines <- function(txt) length(gregexpr("\n", txt, perl = TRUE)[[1]])
  for (i in seq_along(starts)) {
    s <- starts[i]; e <- s + lens[i] - 1L
    block <- substr(text, s, e)
    kind <- sub("^(exportMethods|export).*", "\\1", block, perl = TRUE)
    inside <- sub("^(?:exportMethods|export)\\s*\\((.*)\\)\\s*$", "\\1", block, perl = TRUE)
    items <- unlist(strsplit(inside, "\\s*,\\s*", perl = TRUE), use.names = FALSE)
    items <- gsub('^[\\s\'"]+|[\\s\'"]+$', "", items, perl = TRUE)
    items <- items[nzchar(items)]
    line_num <- 1L + count_lines(substr(text, 1L, s))
    for (nm in items) {
      out_name <- c(out_name, nm)
      out_kind <- c(out_kind, kind)
      out_line <- c(out_line, line_num)
      out_text <- c(out_text, gsub("\\s+$", "", gsub("^\\s+", "", block)))
    }
  }
  data.frame(name = out_name, kind = out_kind, line = out_line, text = out_text, stringsAsFactors = FALSE)
}

# Public: declared exports with metadata
namespace_declared_exports <- function(pkg) {
  ns <- asNamespace(pkg)
  pkg_path <- getNamespaceInfo(ns, "path")
  if (is.null(pkg_path) || is.na(pkg_path) || !nzchar(pkg_path)) {
    pkg_path <- tryCatch(find.package(pkg, quiet = TRUE), error = function(e) NA_character_)
  }
  ns_file <- file.path(pkg_path %||% "", "NAMESPACE")
  lines <- if (file.exists(ns_file)) readLines(ns_file, warn = FALSE) else character()
  .parse_namespace_exports(lines)
}

# Public: dangling exports with diagnostics (aware of exportMethods)
dangling_exports_details <- function(pkg) {
  stopifnot(is.character(pkg), length(pkg) == 1)
  if (!requireNamespace(pkg, quietly = TRUE)) {
    stop("Package '", pkg, "' not available for helper")
  }
  ns <- asNamespace(pkg)
  declared <- unique(getNamespaceExports(pkg))
  if (!length(declared)) return(structure(data.frame(), class = c("data.frame")))
  map <- namespace_declared_exports(pkg)

  is_missing <- logical(length(declared))
  for (i in seq_along(declared)) {
    nm <- declared[[i]]
    exists_sym <- exists(nm, envir = ns, inherits = FALSE)
    if (exists_sym) {
      is_missing[i] <- FALSE
    } else {
      kind <- if (nrow(map)) { k <- map$kind[match(nm, map$name)]; ifelse(is.na(k), NA_character_, k) } else NA_character_
      if (!is.na(kind) && identical(kind, "exportMethods")) {
        if (requireNamespace("methods", quietly = TRUE)) {
          meth <- try(methods::findMethods(nm, where = ns), silent = TRUE)
          has_method <- !inherits(meth, "try-error") && length(meth) > 0
          is_missing[i] <- !has_method
        } else {
          is_missing[i] <- TRUE
        }
      } else {
        is_missing[i] <- TRUE
      }
    }
  }
  missing <- declared[is_missing]
  if (!length(missing)) return(structure(data.frame(), class = c("data.frame")))
  if (nrow(map)) {
    idx <- match(missing, map$name); line <- map$line[idx]; txt <- map$text[idx]
  } else {
    line <- rep(NA_integer_, length(missing)); txt <- rep(NA_character_, length(missing))
  }
  data.frame(name = missing, namespace_line = line, namespace_text = txt, stringsAsFactors = FALSE)
}

`%||%` <- function(x, y) if (is.null(x) || length(x) == 0) y else x