Introduce stop2() helper

NEWS.md

@@ -1,5 +1,6 @@
 # S7 (development version)
 
+* Errors thrown by S7 now report the function where they occurred, making it easier to track down the source of a problem (#646).
 * `method<-` now accepts `NULL` to unregister an existing method, e.g. `method(foo, class_character) <- NULL` (#613).
 * `new_object()` no longer materialises ALTREP parent values (e.g. `seq_len()`), so constructing an S7 object that wraps a large compact integer sequence is now O(1) in memory instead of O(n) (@kschaubroeck, #607).
 * Internal changes to support R-devel (4.6) (#592, #593, #598, #600).

R/S3.R

@@ -90,15 +90,15 @@
 #' my_generic(Sys.Date())
 new_S3_class <- function(class, constructor = NULL, validator = NULL) {
   if (!is.character(class)) {
-    stop("`class` must be a character vector.")
+    stop2("`class` must be a character vector.")
   }
   if (!is.null(constructor)) {
     check_S3_constructor(constructor)
   } else {
     constructor <- function(.data) {
-      stop(
+      stop2(
         sprintf("S3 class <%s> doesn't have a constructor.", class[[1]]),
-        call. = FALSE
+        call = NULL
       )
     }
   }
@@ -130,13 +130,13 @@ nameOfClass.S7_S3_class <- function(x) {
   x[["class"]]
 }
 
-check_S3_constructor <- function(constructor) {
+check_S3_constructor <- function(constructor, call = sys.call(-1L)) {
   arg_names <- names(formals(constructor))
   if (arg_names[[1]] != ".data") {
-    stop("First argument to `constructor` must be .data.", call. = FALSE)
+    stop2("First argument to `constructor` must be .data.", call = call)
   }
   if ("..." %in% arg_names) {
-    stop("`constructor` can not use `...`.", call. = FALSE)
+    stop2("`constructor` can not use `...`.", call = call)
   }
 }
 

R/S4.R

@@ -29,7 +29,7 @@ S4_register <- function(class, env = parent.frame()) {
       "`class` must be an S7 class or an S3 class, not a %s.",
       obj_desc(class)
     )
-    stop(msg, call. = FALSE)
+    stop2(msg)
   }
 
   methods::setOldClass(classes, where = topenv(env))
@@ -38,15 +38,16 @@ S4_register <- function(class, env = parent.frame()) {
 
 is_S4_class <- function(x) inherits(x, "classRepresentation")
 
-S4_to_S7_class <- function(x, error_base = "") {
+S4_to_S7_class <- function(x, error_base = "", call = sys.call(-1L)) {
   # Silence R CMD check false positives
   distance <- subClass <- className <- package <- NULL
 
   # Convert generator function to class
   if (methods::is(x, "classGeneratorFunction")) {
     return(S4_to_S7_class(
       methods::getClass(as.character(x@className)),
-      error_base
+      error_base,
+      call = call
     ))
   }
 
@@ -71,7 +72,7 @@ S4_to_S7_class <- function(x, error_base = "") {
       "Unsupported S4 object: must be a class generator or a class definition, not a %s.",
       obj_desc(x)
     )
-    stop(paste0(error_base, msg), call. = FALSE)
+    stop2(paste0(error_base, msg), call = call)
   }
 }
 

R/base-environment.R

@@ -31,7 +31,7 @@
 #' counter$n
 class_environment <- NULL
 
-check_not_environment <- function(object, fn) {
+check_not_environment <- function(object, fn, call = sys.call(-1L)) {
   if (!is.environment(object)) {
     return(invisible())
   }
@@ -40,7 +40,7 @@ check_not_environment <- function(object, fn) {
     sprintf("Can't call `%s` on an environment.\n", fn),
     "See ?class_environment for details."
   )
-  stop(msg, call. = FALSE)
+  stop2(msg, call = call)
 }
 
 # Define onload to avoid dependencies between files

R/base.R

@@ -78,7 +78,7 @@ base_S7_class <- function(x) {
     call = class_call,
     `function` = class_function,
     environment = class_environment,
-    stop(sprintf("No S7 class for base type <%s>.", typeof(x)), call. = FALSE)
+    stop2(sprintf("No S7 class for base type <%s>.", typeof(x)), call = NULL)
   )
 }
 

R/class-spec.R

@@ -29,9 +29,10 @@ as_class <- function(x, arg = deparse(substitute(x))) {
     # so it can't be wrapped in new_base_class
     x
   } else if (isS4(x)) {
-    S4_to_S7_class(x, error_base)
+    S4_to_S7_class(x, error_base, call = sys.call(-1L))
   } else {
     msg <- c(
+      error_base,
       sprintf(
         "Class specification must be one of the following, not a %s:",
         obj_desc(x)
@@ -42,7 +43,7 @@ as_class <- function(x, arg = deparse(substitute(x))) {
       " * A base class"
     )
 
-    stop(paste0(c(error_base, msg), collapse = "\n"))
+    stop2(msg)
   }
 }
 
@@ -73,7 +74,7 @@ class_type <- function(x) {
   } else if (is_S4_class(x)) {
     "S4"
   } else {
-    stop("`x` is not a standard S7 class.", call. = FALSE)
+    stop2("`x` is not a standard S7 class.", call = NULL)
   }
 }
 
@@ -121,7 +122,7 @@ class_construct_expr <- function(.x, envir = NULL, package = NULL) {
           f@package,
           f@name
         )
-        stop(msg, call. = FALSE)
+        stop2(msg, call = NULL)
       }
       return(as.call(list(cl)))
     }
@@ -184,7 +185,7 @@ class_constructor <- function(.x) {
     S7_base = .x$constructor,
     S7_union = class_constructor(.x$classes[[1]]),
     S7_S3 = .x$constructor,
-    stop(sprintf("Can't construct %s.", class_friendly(.x)), call. = FALSE)
+    stop2(sprintf("Can't construct %s.", class_friendly(.x)), call = NULL)
   )
 }
 
@@ -252,7 +253,7 @@ class_dispatch <- function(x) {
     S7 = c(S7_class_name(x), class_dispatch(x@parent)),
     S7_base = c(x$class, "S7_object"),
     S7_S3 = c(x$class, "S7_object"),
-    stop("Unsupported class type.", call. = FALSE)
+    stop2("Unsupported class type.", call = NULL)
   )
 }
 
@@ -267,7 +268,7 @@ class_register <- function(x) {
     S7 = S7_class_name(x),
     S7_base = x$class,
     S7_S3 = x$class[[1]],
-    stop("Unsupported class type.", call. = FALSE)
+    stop2("Unsupported class type.", call = NULL)
   )
 }
 

R/class.R

@@ -126,7 +126,7 @@ new_class <- function(
       abstract &&
         (!is_class(parent) || !(parent@abstract || parent@name == "S7_object"))
     ) {
-      stop("Abstract classes must have abstract parents.")
+      stop2("Abstract classes must have abstract parents.")
     }
   }
 
@@ -174,14 +174,14 @@ S7_class_name <- function(x) {
   paste(c(x@package, x@name), collapse = "::")
 }
 
-check_S7_constructor <- function(constructor) {
+check_S7_constructor <- function(constructor, call = sys.call(-1L)) {
   if (!is.function(constructor)) {
-    stop("`constructor` must be a function.", call. = FALSE)
+    stop2("`constructor` must be a function.", call = call)
   }
 
   method_call <- find_call(body(constructor), quote(new_object), packageName())
   if (is.null(method_call)) {
-    stop("`constructor` must contain a call to `new_object()`.", call. = FALSE)
+    stop2("`constructor` must contain a call to `new_object()`.", call = call)
   }
 }
 
@@ -235,31 +235,34 @@ str.S7_class <- function(object, ..., nest.lev = 0) {
 
 #' @export
 c.S7_class <- function(...) {
-  msg <- "Can not combine S7 class objects."
-  stop(msg)
+  stop2("Can not combine S7 class objects.")
 }
 
 can_inherit <- function(x) is_base_class(x) || is_S3_class(x) || is_class(x)
 
-check_can_inherit <- function(x, arg = deparse(substitute(x))) {
+check_can_inherit <- function(
+  x,
+  arg = deparse(substitute(x)),
+  call = sys.call(-1L)
+) {
   if (!can_inherit(x)) {
     msg <- sprintf(
       "`%s` must be an S7 class, S3 class, or base type, not %s.",
       arg,
       class_friendly(x)
     )
-    stop(msg, call. = FALSE)
+    stop2(msg, call = call)
   }
 }
 
 is_class <- function(x) inherits(x, "S7_class")
 
-check_parent <- function(parent, class) {
+check_parent <- function(parent, class, call = sys.call(-1L)) {
   parent_class <- class@parent
   if (is.null(parent_class)) {
-    stop(
+    stop2(
       "`.parent` must not be supplied when class has no parent.",
-      call. = FALSE
+      call = call
     )
   }
 
@@ -276,7 +279,7 @@ check_parent <- function(parent, class) {
     class_desc(parent_class),
     obj_desc(parent)
   )
-  stop(msg, call. = FALSE)
+  stop2(msg, call = call)
 }
 
 # Object ------------------------------------------------------------------
@@ -288,14 +291,14 @@ check_parent <- function(parent, class) {
 new_object <- function(.parent, ...) {
   class <- sys.function(-1)
   if (!inherits(class, "S7_class")) {
-    stop("`new_object()` must be called from within a constructor.")
+    stop2("`new_object()` must be called from within a constructor.")
   }
   if (class@abstract) {
     msg <- sprintf(
       "Can't construct an object from abstract class <%s>.",
       class@name
     )
-    stop(msg)
+    stop2(msg)
   }
 
   if (!missing(.parent)) {
@@ -304,7 +307,7 @@ new_object <- function(.parent, ...) {
 
   args <- list(...)
   if ("" %in% names2(args)) {
-    stop("All arguments to `...` must be named.")
+    stop2("All arguments to `...` must be named.")
   }
 
   has_setter <- vlapply(class@properties[names(args)], prop_has_setter)
@@ -330,7 +333,12 @@ new_object <- function(.parent, ...) {
   # i.e. it's a non-abstract S7 class
   parent_validated <- inherits(class@parent, "S7_object") &&
     !class@parent@abstract
-  validate_from(.parent, parent = if (parent_validated) class@parent)
+  validate_from(
+    .parent,
+    parent = if (parent_validated) class@parent,
+    # Attribute validation failures to the constructor call, not new_object()
+    call = sys.call(-1L)
+  )
 
   .parent
 }
@@ -397,7 +405,7 @@ S7_class <- function(object) {
 }
 
 
-check_prop_names <- function(properties, error_call = sys.call(-1L)) {
+check_prop_names <- function(properties, call = sys.call(-1L)) {
   # these attributes have special C handlers in base R
   forbidden <- c(
     "names",
@@ -416,6 +424,6 @@ check_prop_names <- function(properties, error_call = sys.call(-1L)) {
       paste0(forbidden, collapse = ", "),
       "."
     )
-    stop(simpleError(msg, error_call))
+    stop2(msg, call = call)
   }
 }

R/constructor.R

@@ -44,7 +44,7 @@ new_constructor <- function(
     args[names(arg_info$self)] <- arg_info$self
   } else {
     # user facing error in S7_class()
-    stop("Unsupported `parent` type.", call. = FALSE)
+    stop2("Unsupported `parent` type.", call = NULL)
   }
 
   # ensure default value for `...` is empty

R/convert.R

@@ -93,12 +93,12 @@ convert <- function(from, to, ...) {
       c("- from: ", obj_desc(from), "\n"),
       c("- to  : ", class_desc(to))
     )
-    stop(msg)
+    stop2(msg)
   }
 }
 
-convert_up <- function(from, to) {
-  check_not_environment(from, "convert()")
+convert_up <- function(from, to, call = sys.call(-1L)) {
+  check_not_environment(from, "convert()", call = call)
 
   from_class <- S7_class(from)
   if (is_class(from_class)) {
@@ -118,7 +118,7 @@ convert_up <- function(from, to) {
     attr(from, "S7_class") <- to
     class(from) <- class_dispatch(to)
   } else {
-    stop("Unreachable.")
+    stop2("Unreachable.")
   }
   from
 }

R/generic-spec.R

@@ -5,18 +5,18 @@ is_generic <- function(x) {
     is_S4_generic(x)
 }
 
-as_generic <- function(x) {
+as_generic <- function(x, call = sys.call(-1L)) {
   if (is_generic(x)) {
     x
   } else if (is.function(x)) {
-    as_S3_generic(x)
+    as_S3_generic(x, call = call)
   } else {
     msg <- sprintf("`generic` must be a function, not a %s.", obj_desc(x))
-    stop(msg, call. = FALSE)
+    stop2(msg, call = call)
   }
 }
 
-as_S3_generic <- function(x) {
+as_S3_generic <- function(x, call = sys.call(-1L)) {
   use_method <- find_call(body(x), quote(UseMethod))
   if (!is.null(use_method)) {
     return(S3_generic(x, as.character(use_method[[2]])))
@@ -31,10 +31,12 @@ as_S3_generic <- function(x) {
     }
   }
 
-  stop(
-    "`generic` is a function, but not an S3 generic function:\n",
-    deparse_trunc(x, 100),
-    call. = FALSE
+  stop2(
+    c(
+      "`generic` is a function, but not an S3 generic function:",
+      deparse_trunc(x, 100)
+    ),
+    call = call
   )
 }
 
@@ -77,7 +79,7 @@ generic_n_dispatch <- function(x) {
   } else if (is_S4_generic(x)) {
     length(x@signature)
   } else {
-    stop(sprintf("Invalid input %s.", obj_desc(x)), call. = FALSE)
+    stop2(sprintf("Invalid input %s.", obj_desc(x)), call = NULL)
   }
 }