From 801ec0e87cfcaa8c1bbf3ef17584a2980e8408a9 Mon Sep 17 00:00:00 2001
From: Alex Rossell Hayes <alexander@rossellhayes.com>
Date: Fri, 31 Mar 2023 14:24:02 -0700
Subject: [PATCH] Add backport of `utils::isS3stdGeneric()` for R < 4.1.0

---
 NAMESPACE                   |  3 ++-
 R/import.R                  |  2 +-
 R/isS3stdGeneric.R          | 32 ++++++++++++++++++++++++++++++++
 man/isS3stdGeneric.Rd       | 22 ++++++++++++++++++++++
 tests/test_isS3stdGeneric.R | 19 +++++++++++++++++++
 5 files changed, 76 insertions(+), 2 deletions(-)
 create mode 100644 R/isS3stdGeneric.R
 create mode 100644 man/isS3stdGeneric.Rd
 create mode 100644 tests/test_isS3stdGeneric.R

diff --git a/NAMESPACE b/NAMESPACE
index 2572a7a..62a3dbb 100644
--- a/NAMESPACE
+++ b/NAMESPACE
@@ -40,12 +40,13 @@ if (getRversion() < "4.0.0") export(suppressWarnings)
 if (getRversion() < "4.0.1") export(paste)
 if (getRversion() < "4.0.1") export(paste0)
 if (getRversion() < "4.1.0") export(...names)
+if (getRversion() < "4.1.0") export(.libPaths)
+if (getRversion() < "4.1.0") export(isS3stdGeneric)
 if (getRversion() < "4.3.0") S3method("as.Rconcordance", "default")
 if (getRversion() < "4.3.0") S3method("as.character", "Rconcordance")
 if (getRversion() < "4.3.0") S3method("print", "Rconcordance")
 if (getRversion() < "4.3.0") export(as.Rconcordance)
 if (getRversion() < "4.3.0") export(matchConcordance)
-if (getRversion() < "4.1.0") export(.libPaths)
 importFrom(utils,getFromNamespace)
 importFrom(utils,head)
 useDynLib(backports,dotsElt)
diff --git a/R/import.R b/R/import.R
index 2cd7666..9eec812 100644
--- a/R/import.R
+++ b/R/import.R
@@ -63,7 +63,7 @@ get_backports = function(v = getRversion()) {
 
 FUNS = list(
   "4.3.0" = c("as.Rconcordance", "matchConcordance"),
-  "4.1.0" = c("...names", ".libPaths"),
+  "4.1.0" = c("...names", ".libPaths", "isS3stdGeneric"),
   "4.0.1" = c("paste", "paste0"),
   "4.0.0" = c("R_user_dir", "deparse1", "list2DF", "suppressWarnings", "suppressMessages", "stopifnot"),
   "3.6.0" = c("warningCondition", "errorCondition", "vignetteInfo", "dQuote", "sQuote", "removeSource", "asplit", "str2lang", "str2expression"),
diff --git a/R/isS3stdGeneric.R b/R/isS3stdGeneric.R
new file mode 100644
index 0000000..3feff19
--- /dev/null
+++ b/R/isS3stdGeneric.R
@@ -0,0 +1,32 @@
+#' @title Backport of isS3stdGeneric for R < 4.1.0
+#'
+#' @description
+#' See the original description in \code{utils::isS3stdGeneric}.
+#'
+#' @keywords internal
+#' @rawNamespace if (getRversion() < "4.1.0") export(isS3stdGeneric)
+#' @examples
+#' # get function from namespace instead of possibly getting
+#' # implementation shipped with recent R versions:
+#' bp_isS3stdGeneric <- getFromNamespace("isS3stdGeneric", "backports")
+#'
+#' bp_isS3stdGeneric(mean)
+#' 
+#' f <- function(x) x
+#' bp_isS3stdGeneric(f)
+isS3stdGeneric <- function(f) {
+	bdexpr <- body(if(inherits(f, "traceable")) f@original else f)
+	## protect against technically valid but bizarre
+	## function(x) { { { UseMethod("gen")}}} by
+	## repeatedly consuming the { until we get to the first non { expr
+	while(is.call(bdexpr) && bdexpr[[1L]] == "{")
+		bdexpr <- bdexpr[[2L]]
+	
+	## We only check if it is a "standard" s3 generic. i.e. the first non-{
+	## expression is a call to UseMethod. This will return FALSE if any
+	## work occurs before the UseMethod call ("non-standard" S3 generic)
+	ret <- is.call(bdexpr) && bdexpr[[1L]] == "UseMethod"
+	if(ret)
+		names(ret) <- bdexpr[[2L]] ## arg passed to UseMethod naming generic
+	ret
+}
\ No newline at end of file
diff --git a/man/isS3stdGeneric.Rd b/man/isS3stdGeneric.Rd
new file mode 100644
index 0000000..b99eae7
--- /dev/null
+++ b/man/isS3stdGeneric.Rd
@@ -0,0 +1,22 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/isS3stdGeneric.R
+\name{isS3stdGeneric}
+\alias{isS3stdGeneric}
+\title{Backport of isS3stdGeneric for R < 4.1.0}
+\usage{
+isS3stdGeneric(f)
+}
+\description{
+See the original description in \code{utils::isS3stdGeneric}.
+}
+\examples{
+# get function from namespace instead of possibly getting
+# implementation shipped with recent R versions:
+bp_isS3stdGeneric <- getFromNamespace("isS3stdGeneric", "backports")
+
+bp_isS3stdGeneric(mean)
+
+f <- function(x) x
+bp_isS3stdGeneric(f)
+}
+\keyword{internal}
diff --git a/tests/test_isS3stdGeneric.R b/tests/test_isS3stdGeneric.R
new file mode 100644
index 0000000..cbb4f47
--- /dev/null
+++ b/tests/test_isS3stdGeneric.R
@@ -0,0 +1,19 @@
+source("helper/helper.R")
+
+f_non_s3 <- function(x) x
+f_s3 <- function(x) UseMethod("f_s3")
+
+if (getRversion() >= "4.1.0") {
+	f = get("isS3stdGeneric", envir = getNamespace("utils"))
+	expect_same = makeCompareFun(f, backports:::isS3stdGeneric)
+	
+	expect_same(mean)
+	expect_same(grep)
+	expect_same(f_non_s3)
+	expect_same(f_s3)
+}
+
+expect_identical(isS3stdGeneric(mean), c(mean = TRUE))
+expect_identical(isS3stdGeneric(grep), FALSE)
+expect_identical(isS3stdGeneric(f_non_s3), FALSE)
+expect_identical(isS3stdGeneric(f_s3), c(f_s3 = TRUE))