Add backport of utils::isS3stdGeneric() for R < 4.1.0

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)

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"),

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
+}

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))