show( selectMethod(..) ) now prints group generic if it differs

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

Author: maechler

doc/NEWS.Rd

@@ -253,6 +253,10 @@
       \item \code{model.frame()} produces more informative error messages
       in some cases when variables in the formula are not found, thanks to
       \I{Ben Bolker}'s \PR{18860}.
+
+      \item \code{selectMethod(f, ..)} now keeps the function name if the
+      function belongs to of a group generic and the method is for the
+      generic.
     }
   }
 

src/library/methods/R/Methods.R

@@ -1,7 +1,7 @@
 #  File src/library/methods/R/Methods.R
 #  Part of the R package, https://www.R-project.org
 #
-#  Copyright (C) 1995-2024 The R Core Team
+#  Copyright (C) 1995-2025 The R Core Team
 #
 #  This program is free software; you can redistribute it and/or modify
 #  it under the terms of the GNU General Public License as published by
@@ -774,14 +774,20 @@ selectMethod <-
             cat("* mlist environment with", length(mlist),"potential methods\n")
         if(length(signature) < nsig)
             signature[(length(signature)+1):nsig] <- "ANY"
+        inGroups <- length(fdef@group) > 0L # " I belong to a group "
+        maybeGrp <- function(meth) { # meth: a function, possibly primitive, or method
+            if(inGroups && isS4(meth) && meth@generic != fdef@generic)
+                attr(meth@generic, "orig") <- fdef@generic
+            meth
+        }
         if(identical(fdef@signature, "...")) {
             method <- .selectDotsMethod(signature, mlist,
                  if(useInherited) getMethodsForDispatch(fdef, inherited = TRUE))
             if(is.null(method) && !optional)
               stop(gettextf("no method for %s matches class %s",
                             sQuote("..."), dQuote(signature)),
                    domain = NA)
-            return(method)
+            return(maybeGrp(method))
         }
         method <- .findMethodInTable(signature, mlist, fdef)
 	if(is.null(method)) {
@@ -805,7 +811,7 @@ selectMethod <-
 		## else list() : just look in the direct table
 
 	    if(length(methods))
-		return(methods[[1L]])
+		return(maybeGrp(methods[[1L]]))
 	    else if(optional)
 		return(NULL)
 	    else stop(gettextf("no method found for signature %s",

src/library/methods/R/show.R

@@ -1,7 +1,7 @@
 #  File src/library/methods/R/show.R
 #  Part of the R package, https://www.R-project.org
 #
-#  Copyright (C) 1995-2024 The R Core Team
+#  Copyright (C) 1995-2025 The R Core Team
 #
 #  This program is free software; you can redistribute it and/or modify
 #  it under the terms of the GNU General Public License as published by
@@ -80,8 +80,13 @@ show <- function(object) showDefault(object)
 			  "" else paste0(" (Class ", classLabel(cl),")")
                   cat("Method Definition",nonStandard,":\n\n", sep = "")
                   show(object@.Data)
+                  cat("\n") # in both cases
+                  if(isGroup(g <- object@generic) &&
+                     !is.null(og <- c(attr(g,"orig"))) && (g <- c(g)) != og)
+                      cat(sprintf("Generic:  target: \"%s\", defined: \"%s\"\n", og, g))
+                  ## e.g., Generic: target: "-", defined: "Arith"
                   mm <- methodSignatureMatrix(object)
-                  cat("\nSignatures:\n")
+                  cat("Signatures:\n")
                   print(mm)
               },
               where = envir)

src/library/methods/man/S4groupGeneric.Rd

@@ -1,6 +1,6 @@
 % File src/library/methods/man/S4groupGeneric.Rd
 % Part of the R package, https://www.R-project.org
-% Copyright 1995-2016 R Core Team
+% Copyright 1995-2025 R Core Team
 % Distributed under GPL 2 or later
 
 \name{S4groupGeneric}
@@ -123,14 +123,11 @@ There are also
 \references{
  Chambers, John M. (2016)
  \emph{Extending R},
-  Chapman & Hall.
-(Chapters 9 and 10.)
-
+ Chapman & Hall. (Chapters 9 and 10.)
 
  Chambers, John M. (2008)
  \emph{Software for Data Analysis: Programming with R}
   Springer. (Section 10.5)
-
 }
 \seealso{ The function \code{\link{callGeneric}} is nearly always
   relevant when writing a method for a group generic.  See the
@@ -141,6 +138,7 @@ There are also
 \examples{
 setClass("testComplex", slots = c(zz = "complex"))
 ## method for whole group "Complex"
+getGroupMembers("Complex") # "Arg"  "Conj" "Im"   "Mod"  "Re"  
 setMethod("Complex", "testComplex",
           function(z) c("groupMethod", callGeneric(z@zz)))
 ## exception for Arg() :
@@ -150,6 +148,7 @@ z1 <- 1+2i
 z2 <- new("testComplex", zz = z1)
 stopifnot(identical(Mod(z2), c("groupMethod", Mod(z1))))
 stopifnot(identical(Arg(z2), c("ArgMethod", Arg(z1))))
+selectMethod("Re", signature = "testComplex") # shows Generic: .. "Re" & .."Complex"
 \dontshow{
 removeMethods("Complex")
 removeMethods("Arg")

src/library/methods/tests/testGroupGeneric.R

@@ -6,7 +6,13 @@ a <- new("A")
 setMethod("Logic", c("A", "A"), function(e1, e2) FALSE)
 res0 <- a & a                           # inherit &,A,A-method
 setMethod("Logic", c("A", "A"), function(e1, e2) TRUE)
-stopifnot(a & a)
+stopifnot(!res0, a & a)
+## feature in R >= 4.5.0: these get same method, but slightly differing result:
+(sa <- selectMethod("&",     c("A", "A"))) # printing "Generic: ..."
+(sL <- selectMethod("Logic", c("A", "A"))) # 
+stopifnot(identical(sa@generic,
+                    structure("Logic", package = "base",
+                              orig = structure("&", package = "base"))))
 
 removeMethod("Logic", c("A", "A"))
 stopifnot(logical() == a & a)