S7 support via new generics

doc/NEWS.Rd

@@ -20,6 +20,10 @@
 
   \subsection{NEW FEATURES}{
     \itemize{
+
+      \item The matrix multiply operator \code{"\%*\%"} is now an S3 group
+      generic, belonging to new group "matrixOps". Contributed by Tomasz Kalinowski.
+
       \item The included BLAS sources have been updated to those shipped
       with LAPACK version 3.10.1.  (This caused some platform-dependent
       changes to package check output.)  And then to the sources from
@@ -187,6 +191,15 @@
 
       \item The \code{@} operator is now an S3 generic. Based on
       contributions by Tomasz Kalinowski in \PR{18482}.
+
+      \item \code{inherits(x, what)} now accepts values other than a simple
+      character vector for argument \code{what}. A new generic, \code{nameOfClass()},
+      is called by \code{inherits()} to resolve the class name from \code{what}.
+      Based on contributions by Tomasz Kalinowski.
+
+      \item new generic \code{pickOpsMethod()} provides a mechanism for
+      objects to resolve cases where two suitable methods are found for
+      an Ops Group Generic. Based on contributions by Tomasz Kalinowski.
 
       \item Detection of BLAS/LAPACK in use (\code{sessionInfo()}) with
       FlexiBLAS now reports the current backend.

src/library/base/R/S3-class-extensions.R

@@ -0,0 +1,26 @@
+#  File src/library/base/R/S3-class-extensions.R
+#  Part of the R package, https://www.R-project.org
+#
+#  Copyright (C) 1995-2023 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
+#  the Free Software Foundation; either version 2 of the License, or
+#  (at your option) any later version.
+#
+#  This program is distributed in the hope that it will be useful,
+#  but WITHOUT ANY WARRANTY; without even the implied warranty of
+#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+#  GNU General Public License for more details.
+#
+#  A copy of the GNU General Public License is available at
+#  https://www.R-project.org/Licenses/
+
+nameOfClass <- function(x) UseMethod("nameOfClass")
+
+nameOfClass.default <- function(x) NULL
+
+
+pickOpsMethod <- function(x, y, mx, my, reverse = FALSE) UseMethod("pickOpsMethod")
+
+pickOpsMethod.default <- function(x, y, mx, my, reverse = FALSE) FALSE

src/library/base/R/namespace.R

@@ -1539,7 +1539,7 @@ registerS3method <- function(genname, class, method, envir = parent.frame()) {
 		      c(generic, class, method, NA_character_))
         setNamespaceInfo(ns, "S3methods", regs)
     }
-    groupGenerics <- c("Math", "Ops",  "Summary", "Complex")
+    groupGenerics <- c("Math", "Ops", "matrixOps", "Summary", "Complex")
     defenv <- if(genname %in% groupGenerics) .BaseNamespaceEnv
     else {
         genfun <- get(genname, envir = envir)

src/library/base/R/zzz.R

@@ -25,7 +25,7 @@ is.name <- is.symbol
 .knownS3Generics <- local({
 
     ## include the S3 group generics here
-    baseGenerics <- c("Math", "Ops", "Summary", "Complex",
+    baseGenerics <- c("Math", "Ops", "Summary", "Complex", "matrixOps",
         "as.character", "as.data.frame", "as.environment", "as.matrix", "as.vector",
         "cbind", "labels", "print", "rbind", "rep", "seq", "seq.int",
         "plot", "sequence", "solve", "summary", "t")
@@ -58,7 +58,6 @@ is.name <- is.symbol
 
 assign("::", function(pkg, name) NULL, envir = .ArgsEnv)
 assign(":::", function(pkg, name) NULL, envir = .ArgsEnv)
-assign("%*%", function(x, y) NULL, envir = .ArgsEnv)
 assign("...length", function() NULL, envir = .ArgsEnv)
 assign("...names",  function() NULL, envir = .ArgsEnv)
 assign("...elt", function(n) NULL, envir = .ArgsEnv)
@@ -228,6 +227,8 @@ assign("as.integer", function(x, ...) UseMethod("as.integer"),
        envir = .GenericArgsEnv)
 assign("as.logical", function(x, ...) UseMethod("as.logical"),
        envir = .GenericArgsEnv)
+assign("%*%", function(x, y) UseMethod("%*%"),
+       envir = .GenericArgsEnv)
 #assign("as.raw", function(x) UseMethod("as.raw"), envir = .GenericArgsEnv)
 ## Conceptually, this is the argument list of  *default* method, not the generic :
 ## assign("c", function(..., recursive = FALSE, use.names = TRUE) UseMethod("c"),

src/library/base/man/class.Rd

@@ -13,6 +13,7 @@
 \alias{unclass}
 \alias{inherits}
 \alias{isa}
+\alias{nameOfClass}
 \description{
   \R possesses a simple generic function mechanism which can be used for
   an object-oriented style of programming.  Method dispatch takes place
@@ -23,6 +24,7 @@ class(x)
 class(x) <- value
 unclass(x)
 inherits(x, what, which = FALSE)
+nameOfClass(x)
 isa(x, what)
 
 oldClass(x)
@@ -31,8 +33,9 @@ oldClass(x) <- value
 }
 \arguments{
   \item{x}{a \R object}
-  \item{what, value}{a character vector naming classes.  \code{value}
-    can also be \code{NULL}.}
+  \item{what, value}{a character vector naming classes. \code{value}
+    can also be \code{NULL}. \code{what} can also be an R object 
+    with a \code{nameOfClass()} method.}
   \item{which}{logical affecting return value: see \sQuote{Details}.}
 }
 
@@ -103,6 +106,11 @@ oldClass(x) <- value
   no match. If \code{which} is \code{FALSE} then \code{TRUE} is
   returned by \code{inherits} if any of the names in \code{what} match
   with any \code{class}.
+
+  \code{nameOfClass} is an S3 generic. It is called by \code{inherits} to 
+  get the class name for \code{what}, allowing for \code{what} to be 
+  values other than a character vector. \code{nameOfClass} methods are 
+  expected ato return a character vector of length 1.
 
   \code{isa} tests whether \code{x} is an object of class(es) as given
   in \code{what} by using \code{\link[methods]{is}} if \code{x} is an S4

src/library/base/man/groupGeneric.Rd

@@ -1,6 +1,6 @@
 % File src/library/base/man/groupGeneric.Rd
 % Part of the R package, https://www.R-project.org
-% Copyright 1995-2020 R Core Team
+% Copyright 1995-2023 R Core Team
 % Distributed under GPL 2 or later
 
 \name{groupGeneric}
@@ -32,9 +32,10 @@
 \special{Ops(e1, e2)}
 \special{Complex(z)}
 \special{Summary(\dots, na.rm = FALSE)}
+\special{matrixOps(x, y)}
 }
 \arguments{
-  \item{x, z, e1, e2}{objects.}
+  \item{x, y, z, e1, e2}{objects.}
   \item{\dots}{further arguments passed to methods.}
   \item{na.rm}{logical: should missing values be removed?}
 }
@@ -114,7 +115,10 @@
     examined to see if there is a matching specific (preferred) or
     \code{Ops} method.  If a method is found for just one argument or
     the same method is found for both, it is used.
-    If different methods are found, there is a warning about
+    If different methods are found, then the generic \code{pickOpsMethod()} 
+    is called to pick the appropriate method. (See \code{?pickOpsMethod} for details).
+    If \code{pickOpsMethod()} does not resolve the method, 
+    then there is a warning about
     \sQuote{incompatible methods}: in that case or if no method is found
     for either argument the internal method is used.
 
@@ -150,6 +154,15 @@
       % do_cmathfuns() [complex.c:267]: if(DispatchGroup("Complex",...))
     }
     Members of this group dispatch on \code{z}.
+
+    \item Group \code{"matrixOps"}:
+    \itemize{
+      \item \code{"\%*\%"}
+      % do_matprod [array.c:1251]: if (DispatchGroup("matrixOps", ...))
+    }
+    This group contains only the matrix multiply operator \code(\%*\%)
+    binary operator presently. It has the same dispatch semantics as
+    the "Ops" group.
   }
 
   Note that a method will be used for one of these groups or one of its

src/library/base/man/matmult.Rd

@@ -26,9 +26,10 @@ x \%*\% y
   Promotion of a vector to a 1-row or 1-column matrix happens when one
   of the two choices allows \code{x} and \code{y} to get conformable
   dimensions.
-
-  This operator is S4 generic but not S3 generic.  S4 methods need to be
-  written for a function of two arguments named \code{x} and \code{y}.
+
+  This operator is a group generic, belonging to the matrixOps group. It
+  dispatches to S3 and S4 methods. Methods need to be written for a
+  function that takes two arguments named \code{x} and \code{y}.
 }
 \value{
   A double or complex matrix product.  Use \code{\link{drop}} to remove

src/library/base/man/pickOpsMethod.Rd

@@ -0,0 +1,60 @@
+% File src/library/base/man/pickOpsMethod.Rd
+% Part of the R package, https://www.R-project.org
+% Copyright 1995-2023 R Core Team
+% Distributed under GPL 2 or later
+
+\name{pickOpsMethod}
+\title{Choose the Appropriate Method for Ops}
+\usage{pickOpsMethod(x, y, mx, my, reverse = TRUE)}
+\alias{pickOpsMethod}
+
+\description{
+  \code{pickOpsMethod} is a function called by the Ops Group Generic when two
+  suitable methods are found for a given call. It determines which method to
+  use for the operation based on the objects being dispatched.
+
+  The function is first called with \code{reverse = FALSE}, where \code{x}
+  corresponds to the first argument and \code{y} to the second argument of the
+  group generic call. If \code{pickOpsMethod()} returns \code{FALSE} for \code{x},
+  then \code{pickOpsMethod} is called again, with \code{x} and \code{y} swapped,
+  \code{mx} and \code{my} swapped, and \code{reverse = TRUE}.
+}
+
+\arguments{
+  \item{x,y}{The objects being dispatched on by the group generic.}
+  \item{mx,my}{The methods found for objects \code{x} and \code{y}.}
+  \item{reverse}{A logical value indicating whether \code{x} and \code{y} are
+      reversed from the way they were supplied to the generic.}
+}
+
+\seealso{
+  \code{\link[=S3groupGeneric]{Ops}}
+}
+
+\value{
+  This function must return either \code{TRUE} or \code{FALSE}. A value of
+  \code{TRUE} indicates that method \code{mx} should be used.
+}
+\keyword{methods}
+\examples{
+
+# Create two objects with custom Ops methods
+foo_obj <- structure(1, class = "foo")
+bar_obj <- structure(1, class = "bar")
+
+`+.foo` <- function(e1, e2) "foo"
+Ops.bar <- function(e1, e2) "bar"
+
+invisible(foo_obj + bar_obj) # Warning: Incompatible methods
+
+pickOpsMethod.bar <- function(x, y, mx, my, reverse) TRUE
+
+stopifnot(exprs = {
+  identical(foo_obj + bar_obj, "bar")
+  identical(bar_obj + foo_obj, "bar")
+})
+
+# cleanup
+rm(foo_obj, bar_obj, `+.foo`, Ops.bar, pickOpsMethod.bar)
+}
+

src/library/tools/R/QC.R

@@ -212,7 +212,7 @@ function(package, dir, lib.loc = NULL)
         ## and are documented in base's groupGenerics.Rd.
         code_objs <- setdiff(code_objs,
                              c("Arith", "Compare", "Complex", "Logic",
-                               "Math", "Math2", "Ops", "Summary"))
+                               "Math", "Math2", "Ops", "Summary", "matrixOps"))
     }
 
     undoc_things <-
@@ -9189,7 +9189,7 @@ function(package_name)
     c("<-", "=",
       if(package_name == "base")
       c("(", "{", "function", "if", "for", "while", "repeat",
-        "Math", "Ops", "Summary", "Complex"),
+        "Math", "Ops", "Summary", "Complex", "matrixOps"),
       if(package_name == "utils") "?",
       if(package_name == "methods") "@")
 }

src/library/tools/R/utils.R

@@ -1238,7 +1238,7 @@ function(env, nms = NULL)
 
 .get_S3_group_generics <-
 function()
-    c("Ops", "Math", "Summary", "Complex")
+    c("Ops", "Math", "Summary", "Complex", "matrixOps")
 
 ### ** .get_S3_primitive_generics
 
@@ -1269,7 +1269,9 @@ function(include_group_generics = TRUE)
           ## Group 'Summary':
           "all", "any", "sum", "prod", "max", "min", "range",
           ## Group 'Complex':
-          "Arg", "Conj", "Im", "Mod", "Re")
+          "Arg", "Conj", "Im", "Mod", "Re",
+          ## Group 'matrixOps'
+          "%*%")
     else
         base::.S3PrimitiveGenerics
 }
@@ -1737,6 +1739,8 @@ function(parent = parent.frame())
            envir = env)
     assign("Ops", function(e1, e2) UseMethod("Ops"),
            envir = env)
+    assign("matrixOps", function(e1, e2) UseMethod("matrixOps"),
+           envir = env)
     assign("Summary", function(..., na.rm = FALSE) UseMethod("Summary"),
            envir = env)
     assign("Complex", function(z) UseMethod("Complex"),

src/library/utils/R/objects.R

@@ -104,7 +104,7 @@ function(generic.function, class, envir=parent.frame())
 	    generic.function <- deparse1(substitute(generic.function))
         ## else
         if(!exists(generic.function, mode = "function", envir = envir) &&
-           !any(generic.function == c("Math", "Ops", "Complex", "Summary")))
+           !any(generic.function == c("Math", "Ops", "Complex", "Summary", "matrixOps")))
             stop(gettextf("no function '%s' is visible", generic.function),
                  domain = NA)
         warn.not.generic <- FALSE

src/main/array.c

@@ -1238,13 +1238,17 @@ attribute_hidden SEXP do_matprod(SEXP call, SEXP op, SEXP args, SEXP rho)
     Rboolean sym;
 
     if (PRIMVAL(op) == 0 && /* %*% is primitive, the others are .Internal() */
-       (IS_S4_OBJECT(x) || IS_S4_OBJECT(y))
-       && R_has_methods(op)) {
+	(OBJECT(x) || OBJECT(y))) {
 	SEXP s, value;
 	/* Remove argument names to ensure positional matching */
 	for(s = args; s != R_NilValue; s = CDR(s)) SET_TAG(s, R_NilValue);
-	value = R_possible_dispatch(call, op, args, rho, FALSE);
-	if (value) return value;
+
+	if ((IS_S4_OBJECT(x) || IS_S4_OBJECT(y)) && R_has_methods(op)){
+	    value = R_possible_dispatch(call, op, args, rho, FALSE);
+	    if (value) return value;
+	}
+	else if (DispatchGroup("matrixOps", call, op, args, rho, &ans))
+	    return ans;
     }
 
     checkArity(op, args);

src/main/eval.c

@@ -3991,6 +3991,16 @@ static SEXP classForGroupDispatch(SEXP obj) {
 	    : getAttrib(obj, R_ClassSymbol);
 }
 
+static Rboolean R_pickOpsMethod(SEXP x, SEXP y, SEXP x_method_sxp, SEXP y_method_sxp, 
+				SEXP rho, Rboolean reverse) {
+    SEXP call, ans;
+    PROTECT(call = lang6(install("pickOpsMethod"), x, y, x_method_sxp, y_method_sxp, ScalarLogical(reverse)));
+    PROTECT(ans = eval(call, rho));
+    Rboolean pick_left = ans == R_NilValue ? FALSE : asLogical(ans);
+    UNPROTECT(2);
+    return pick_left;
+}
+
 attribute_hidden
 int DispatchGroup(const char* group, SEXP call, SEXP op, SEXP args, SEXP rho,
 		  SEXP *ans)
@@ -4006,7 +4016,7 @@ int DispatchGroup(const char* group, SEXP call, SEXP op, SEXP args, SEXP rho,
 	return 0;
 
     SEXP s;
-    Rboolean isOps = strcmp(group, "Ops") == 0;
+    Rboolean isOps = strcmp(group, "Ops") == 0 || strcmp(group, "matrixOps") == 0;
 
     /* try for formal method */
     if(length(args) == 1 && !IS_S4_OBJECT(CAR(args))) {
@@ -4086,10 +4096,19 @@ int DispatchGroup(const char* group, SEXP call, SEXP op, SEXP args, SEXP rho,
 	         srcref ignored (as per default)
 	    */
 	    else if (!R_compute_identical(lsxp, rsxp, 16 + 1 + 2 + 4)) {
-		warning(_("Incompatible methods (\"%s\", \"%s\") for \"%s\""),
-			lname, rname, generic);
-		UNPROTECT(4);
-		return 0;
+		SEXP x = CAR(args), y = CADR(args);
+		if (R_pickOpsMethod(x, y, lsxp, rsxp, rho, FALSE)) {
+		    rsxp = R_NilValue;
+		}
+		else if (R_pickOpsMethod(y, x, rsxp, lsxp, rho, TRUE)) {
+		    lsxp = R_NilValue;
+		}
+		else {
+		    warning(_("Incompatible methods (\"%s\", \"%s\") for \"%s\""),
+			    lname, rname, generic);
+		    UNPROTECT(4);
+		    return 0;
+		}
 	    }
 	}
 	/* if the right hand side is the one */