(cont.) 87062: even better " showMethods(....) " suggestion in show(<…

…S4generic>) \\\ mv|clean "S4 tests"

git-svn-id: https://svn.r-project.org/R/trunk@87079 00db46b3-68df-0310-9c12-caf00c1e9a41

src/library/methods/R/RMethodUtils.R

@@ -496,9 +496,24 @@ getGeneric <-
  pkg == ".GlobalEnv" || isBaseNamespace(ns <- asNamespace(pkg)) ||
  name %in% names(.getNamespaceInfo(ns, "exports"))
 
-.maybeUnhideName <- function(name, pkg, qName = FALSE) {
+##' is `name` "visually exported", i.e., exported from pkg in search()
+.isExportedVis <- function(name, pkg)
+ (pkg == ".GlobalEnv" || paste0("package:", pkg) %in% search()[-1L]) &&
+ (isBaseNamespace(ns <- asNamespace(pkg)) ||
+ name %in% names(.getNamespaceInfo(ns, "exports")))
+
+##' "Minimal" valid name when `name` is from `pkg` (which can be ".GlobalEnv")
+##' @param name string
+##' @param pkg string
+##' @param qName logical(-alike)
+##' @return string
+.minimalName <- function(name, pkg, qName = FALSE, chkXport = TRUE) {
  nm <- if(qName) deparse1(as.name(name), backtick = TRUE) else name
- if(.isExported(name, pkg)) nm else paste(pkg, nm, sep=":::")
+ if(chkXport && .isExported(name, pkg)) {
+ if(pkg == ".GlobalEnv" || paste0("package:", pkg) %in% search()[-1L])
+ nm
+ else paste(pkg, nm, sep="::")
+ } else paste(pkg, nm, sep=":::")
 }
 
 ## cache and retrieve generic functions. If the same generic name

src/library/methods/R/show.R

@@ -53,8 +53,10 @@ showExtraSlots <- function(object, ignore) {
  if(is(ignore, "classRepresentation"))
  ignore <- slotNames(ignore)
  else if(!is(ignore, "character"))
- stop(gettextf("invalid 'ignore' argument; should be a class definition or a character vector, got an object of class %s", dQuote(class(ignore))),
- domain = NA)
+ stop(gettextf(
+ "invalid 'ignore' argument; should be a class definition or a character vector, got an object of class %s",
+ dQuote(class(ignore))),
+ domain = NA)
  slots <- slotNames(class(object))
  for(s in slots[is.na(match(slots, ignore))]) {
  cat("Slot ",s, ":\n", sep="")
@@ -105,10 +107,42 @@ show <- function(object) showDefault(object)
  cat("\n")
  show(object@.Data)
  pkg <- object@package
+ ## Find "correct" pkg in case in case object was e.g. Matrix::`diag<-`
+ ## where pkg is "base" (!)
+ ## This is imperfect (but clearly better than nothing):
+ mayMulti <- FALSE
+ if(notGen <- !(if(pkg == ".GlobalEnv")
+ isGeneric(nam)
+ else isGeneric(nam, getNamespace(pkg)))) {
+ ## other namespaces where a generic may live:
+ nss <- Filter(function(.) methods:::.hasS4MetaData(getNamespace(.)),
+ setdiff(loadedNamespaces(), c(pkg, "base")))
+ hasGen <- vapply(nss, function(ns) isGeneric(nam, getNamespace(ns)), NA)
+ if(notGen <- !any(hasGen))
+ ## if(notGen <- !isGeneric(nam, getNamespace(pkg <- "base")))
+ pkg <- "<pkg>"
+ else {
+ mayMulti <- TRUE
+ pkgs <- nss[hasGen] # with length >= 1
+ pkg <- pkgs[[1L]] # take the first
+ }
+ }
+ ## grepl("::", so <- as.character(substitute(object)), fixed=TRUE))
+ ## pkg <- .......
  cat("Methods may be defined for arguments: ",
  paste0(object@signature, collapse=", "), "\n",
- "Use showMethods(", .maybeUnhideName(nam, pkg, qName = TRUE),
- ") for currently available ones.\n", sep="")
+ "Use showMethods(", .minimalName(nam, pkg, qName = TRUE, chkXport = !notGen),
+ ") for currently available ones", sep="")
+ if(notGen) {
+ cat(" where <pkg> does not seem to be among the loadedNamespaces()")
+ } else if(mayMulti && length(pkgs) > 1L) { ## pkg == pkgs[[1]]
+ pkgs <- pkgs[-1L] # => length(pkgs) >= 1
+ pkgs <- dQuote(pkgs, FALSE)
+ cat(sprintf(" where additionally to %s, the <pkg> could also be %s", pkg,
+ if(length(pkgs) == 1L) pkgs
+ else paste("one of", paste0(pkgs, collapse = ", "))))
+ }
+ cat(".\n")
  if(.simpleInheritanceGeneric(object))
  cat("(This generic function excludes non-simple inheritance; see ?setIs)\n")
  },

tests/classes-methods.R

@@ -19,6 +19,7 @@ if(require("Matrix", lib.loc = .Library, quietly = TRUE)) {
  identical(D5N, pmin(D5N, 5)),
  identical(as.matrix(pmin(D5N +1, 3)),
  pmin(as.matrix(D5N)+1, 3)),
+ is.function(Matrix::crossprod), # needed Matrix 1.6-1.1 for R-devel, Sep.2023
  ##
  TRUE)
 
@@ -158,3 +159,39 @@ stopifnot(exprs = {
  grepl('x = "numeric", y = "missing"', attr(err1, "condition")$message)
  identical(err1, err1Y) # (as $call is empty)
 })
+
+
+## PR#17496: sealClass()
+setClass("foo", slots = c(name = "character"), sealed = TRUE)
+stopifnot(isSealedClass("foo"))
+tools::assertError(setClass("foo"))
+stopifnot(removeClass("foo"))
+setClass("foo")
+sealClass("foo") # failed in R < 4.5.0
+stopifnot(isSealedClass("foo"))
+stopifnot(removeClass("foo"))
+
+
+## show(<non-syntactic name>) should recommend backticks for showMethods()
+stopifnot(any(grepl("showMethods(`body<-`)", capture.output(show(`body<-`)), fixed=TRUE)))
+
+## show( <genericFunction>) should use correct " Use showMethods(.....) for ...."
+pkg <- "Matrix"
+if(length(P <- grep(pkg, search(), fixed=TRUE, value=TRUE)))
+ detach(P, character.only=TRUE, force=TRUE)
+(hasME <- requireNamespace(pkg, quietly=TRUE, lib.loc = .Library))
+if(hasME) {
+ capture.output( show(Matrix::"diag<-") ) |> tail(1) -> out1
+ stopifnot(grepl("showMethods(Matrix::`diag<-`)", out1, fixed=TRUE))
+ ##
+ if(require(pkg, character.only=TRUE)) {
+ capture.output( show(Matrix::"diag<-") ) |> tail(1) -> out1
+ stopifnot(grepl("showMethods(`diag<-`)", out1, fixed=TRUE))
+ detach(paste0("package:", pkg), character.only=TRUE, unload=TRUE)
+ } else
+ unloadNamespace(pkg)
+}
+
+
+
+cat('Time elapsed: ', proc.time(),'\n')

tests/reg-S4.R

@@ -879,16 +879,11 @@ setClass("bar", contains = "foo")
 body(getClass("bar")@contains[[1]]@coerce)[[2]]
 
 
-## PR#17496: sealClass()
-setClass("foo", slots = c(name = "character"), sealed = TRUE)
-stopifnot(isSealedClass("foo"))
-tools::assertError(setClass("foo"))
-stopifnot(removeClass("foo"))
-setClass("foo")
-sealClass("foo") # failed in R < 4.5.0
-stopifnot(isSealedClass("foo"))
-stopifnot(removeClass("foo"))
 
+## ----- from here on, keep at EOF -----
+
+cat('Time elapsed: ', proc.time(),'\n')
 
-## show(<non-syntactic name>) should recommend backticks for showMethods()
-stopifnot(any(grepl("showMethods(`body<-`)", capture.output(show(`body<-`)), fixed=TRUE)))
+### NB: Only add new tests here _IF_ checking output,
+### -- otherwise use ./classes-methods.R
+### ^^^^^^^^^^^^^^^^^

tests/reg-S4.Rout.save

@@ -1,5 +1,5 @@
 
-R Under development (unstable) (2024-05-13 r86546) -- "Unsuffered Consequences"
+R Under development (unstable) (2024-08-27 r87063) -- "Unsuffered Consequences"
 Copyright (C) 2024 The R Foundation for Statistical Computing
 Platform: x86_64-pc-linux-gnu
 
@@ -1177,17 +1177,13 @@ value <- methods::new("A")
 class(from) <- "foo"
 > 
 > 
-> ## PR#17496: sealClass()
-> setClass("foo", slots = c(name = "character"), sealed = TRUE)
-> stopifnot(isSealedClass("foo"))
-> tools::assertError(setClass("foo"))
-> stopifnot(removeClass("foo"))
-> setClass("foo")
-> sealClass("foo") # failed in R < 4.5.0
-> stopifnot(isSealedClass("foo"))
-> stopifnot(removeClass("foo"))
 > 
+> ## ----- from here on, keep at EOF -----
+> 
+> cat('Time elapsed: ', proc.time(),'\n')
+Time elapsed: 0.869 0.169 1.642 0.001 0.003 
 > 
-> ## show(<non-syntactic name>) should recommend backticks for showMethods()
-> stopifnot(any(grepl("showMethods(`body<-`)", capture.output(show(`body<-`)), fixed=TRUE)))
+> ### NB: Only add new tests here _IF_ checking output,
+> ### -- otherwise use ./classes-methods.R
+> ### ^^^^^^^^^^^^^^^^^
 >