Consistently use class_ prefix for base wrappers (#207)

Fixes #170

NAMESPACE

@@ -33,13 +33,26 @@ export(R7_class)
 export(R7_data)
 export(R7_dispatch)
 export(R7_object)
-export(any_class)
 export(as_class)
+export(class_any)
+export(class_atomic)
+export(class_character)
+export(class_complex)
+export(class_double)
+export(class_environment)
+export(class_expression)
+export(class_function)
+export(class_integer)
+export(class_list)
+export(class_logical)
+export(class_missing)
+export(class_numeric)
+export(class_raw)
+export(class_vector)
 export(convert)
 export(external_methods_register)
 export(method)
 export(method_explain)
-export(missing_class)
 export(new_S3_class)
 export(new_class)
 export(new_external_generic)

NEWS.md

@@ -6,13 +6,16 @@
 
 ## Mar 2022
 
+* All built-in wrappers around base types use `class_`. You can no longer
+  refer to a base type with a string or a constructor function (#170).
+
 * `convert()` allows you to convert an object into another class (#136).
 
 * `super()` replaces `next_method()` (#110).
 
 ## Feb 2022
 
-* `any_class` and `missing_any` make it possible to dispatch on absent
+* `class_any` and `class_missing` make it possible to dispatch on absent
   arguments and arguments of any class (#67).
 
 * New `method_explain()` to explain dispatch (#194).
@@ -23,7 +26,7 @@
 
 * When creating an object, unspecified properties are initialized with their 
   default value (#67). DISCUSS: to achieve this, the constructor arguments
-  default to `missing_class`.
+  default to `class_missing`.
 
 * Add `$.R7_object` and `$<-.R7_object` methods to avoid "object of type 'S4'
   is not subsettable" error (#204).

R/S4.R

@@ -16,11 +16,13 @@ S4_to_R7_class <- function(x, error_base = "") {
   } else if (methods::is(x, "classRepresentation")) {
     if (methods::extends(x, "oldClass")) {
       new_S3_class(as.character(x@className))
-    } else if (x@package == "methods" && x@className %in% names(base_classes)) {
-      # Convert S4 representation of base types to R7 representation
-      base_classes[[x@className]]
-    } else if (x@package == "methods" && x@className == "NULL") {
-      NULL
+    } else if (x@package == "methods") {
+      base_classes <- S4_base_classes()
+      if (hasName(base_classes, x@className)) {
+        base_classes[[x@className]]
+      } else {
+        x
+      }
     } else {
       x
     }
@@ -33,6 +35,24 @@ S4_to_R7_class <- function(x, error_base = "") {
   }
 }
 
+S4_base_classes <- function() {
+  list(
+    NULL = NULL,
+    logical = class_logical,
+    integer = class_integer,
+    double = class_double,
+    numeric = class_numeric,
+    character = class_character,
+    complex = class_complex,
+    raw = class_raw,
+    list = class_list,
+    expression = class_expression,
+    vector = class_vector,
+    `function` = class_function,
+    environment = class_environment
+  )
+}
+
 S4_class_dispatch <- function(x) {
   x <- methods::getClass(x)
   self <- S4_class_name(x)
@@ -61,7 +81,7 @@ S4_class_name <- function(x) {
   class <- x@className
   package <- x@package %||% attr(class, "package")
 
-  if (identical(package, "methods") && class %in% names(base_classes)) {
+  if (identical(package, "methods") && class %in% names(S4_base_classes())) {
     class
   } else if (is.null(package) || identical(package, ".GlobalEnv")) {
     paste0("S4/", class)

R/base.R

@@ -1,8 +1,8 @@
 new_base_class <- function(name) {
   force(name)
 
-  constructor <- function(.data = missing_class) {
-    if (is_missing_class(.data)) {
+  constructor <- function(.data = class_missing) {
+    if (is_class_missing(.data)) {
       .data <- base_default(name)
     }
     .data
@@ -53,17 +53,85 @@ str.R7_base_class <- function(object, ..., nest.lev = 0) {
   print(object, ..., nest.lev = nest.lev)
 }
 
-base_classes <- list(
-  logical = new_base_class("logical"),
-  integer = new_base_class("integer"),
-  double = new_base_class("double"),
-  complex = new_base_class("complex"),
-  character = new_base_class("character"),
-  raw = new_base_class("raw"),
+#' Base classes
+#'
+#' @description
+#' These classes represent base types allowing them to be used within R7.
+#' Most correspond directly to the obvious base type. There are three
+#' exceptions:
+#'
+#' * `class_numeric` is a union of `class_integer` and `class_double`.
+#' * `class_atomic` is a union of `class_logical`, `class_numeric`,
+#'   `class_complex`, and `class_raw`.
+#' * `class_vector` is a union of `class_atomic`, `class_list`, and
+#'   `class_expression`.
+#'
+#' @name base_classes
+NULL
 
-  list = new_base_class("list"),
-  expression = new_base_class("expression"),
+#' @export
+#' @rdname base_classes
+#' @format NULL
+class_logical <- new_base_class("logical")
+
+#' @export
+#' @rdname base_classes
+#' @format NULL
+class_integer <- new_base_class("integer")
+
+#' @export
+#' @rdname base_classes
+#' @format NULL
+class_double <- new_base_class("double")
+
+#' @export
+#' @rdname base_classes
+#' @format NULL
+class_complex <- new_base_class("complex")
+
+#' @export
+#' @rdname base_classes
+#' @format NULL
+class_character <- new_base_class("character")
+
+#' @export
+#' @rdname base_classes
+#' @format NULL
+class_raw <- new_base_class("raw")
+
+#' @export
+#' @rdname base_classes
+#' @format NULL
+class_list <- new_base_class("list")
 
-  `function` = new_base_class("function"),
-  environment = new_base_class("environment")
-)
+#' @export
+#' @rdname base_classes
+#' @format NULL
+class_expression <- new_base_class("expression")
+
+#' @export
+#' @rdname base_classes
+#' @format NULL
+class_function <- new_base_class("function")
+
+#' @export
+#' @rdname base_classes
+#' @format NULL
+class_environment <- new_base_class("environment")
+
+# Base unions are created .onLoad
+
+#' @export
+#' @rdname base_classes
+#' @format NULL
+class_numeric <- NULL
+
+#' @export
+#' @rdname base_classes
+#' @format NULL
+class_atomic <- NULL
+
+#' @export
+#' @rdname base_classes
+#' @format NULL
+class_vector <- NULL

R/class-spec.R

@@ -9,43 +9,25 @@
 #'   * An R7 union (created by [new_union()]).
 #'   * An S3 class (created by [new_S3_class()]).
 #'   * An S4 class (created by [methods::getClass()] or [methods::new()]).
-#'   * A base type specified either with its constructor (`logical`, `integer`,
-#'     `double` etc) or its name (`"logical"`, `"integer"`, "`double`" etc).
-#'   * A base union type specified by its name: `"numeric"`, `"atomic"`, or
-#'      `"vector"`.
-#'   * A "special", either [missing_class] or [any_class].
+#'   * A base class, like [class_logical], [class_integer], or [class_double].
+#'   * A "special", either [class_missing] or [class_any].
 #' @param arg Argument name used when generating errors.
 #' @export
 #' @return A standardised class: either `NULL`, an R7 class, an R7 union,
 #'   as [new_S3_class], or a S4 class.
 as_class <- function(x, arg = deparse(substitute(x))) {
   error_base <- sprintf("Can't convert `%s` to a valid class. ", arg)
 
-  if (is.null(x)) {
+  if (is_foundation_class(x)) {
+    x
+  } else if (is.null(x)) {
     # NULL is handled specially because you can't assign a class to it,
     # so it can't be wrapped in new_base_class
     x
-  } else if (is_foundation_class(x)) {
-    x
   } else if (isS4(x)) {
     S4_to_R7_class(x, error_base)
-  } else if (is.function(x)) {
-    candidate <- find_base_name(x, names(base_classes))
-    if (is.na(candidate)) {
-      stop(paste0(error_base, "No matching base class."), call. = FALSE)
-    }
-    base_classes[[candidate]]
-  } else if (is.character(x) && length(x) == 1) {
-    if (x %in% names(base_classes)) {
-      base_classes[[x]]
-    } else if (x %in% names(base_unions)) {
-      base_unions[[x]]
-    } else {
-      msg <- sprintf("No base classes are called '%s'", x)
-      stop(paste0(error_base, msg), call. = FALSE)
-    }
   } else {
-    msg <- sprintf("Class specification must be an R7 class object, the result of `new_S3_class()`, an S4 class object, or a base constructor function, not a %s.", obj_desc(x))
+    msg <- sprintf("Class specification must be an R7 class object, the result of `new_S3_class()`, an S4 class object, or a base class, not a %s.", obj_desc(x))
     stop(paste0(error_base, msg), call. = FALSE)
   }
 }
@@ -55,16 +37,16 @@ is_foundation_class <- function(x) {
     is_union(x) ||
     is_base_class(x) ||
     is_S3_class(x) ||
-    is_missing_class(x) ||
-    is_any_class(x)
+    is_class_missing(x) ||
+    is_class_any(x)
 }
 
 class_type <- function(x) {
   if (is.null(x)) {
     "NULL"
-  } else if (is_missing_class(x)) {
+  } else if (is_class_missing(x)) {
     "missing"
-  } else if (is_any_class(x)) {
+  } else if (is_class_any(x)) {
     "any"
   } else if (is_base_class(x)) {
     "R7_base"
@@ -175,8 +157,8 @@ class_register <- function(x) {
 class_deparse <- function(x) {
   switch(class_type(x),
     "NULL" = "NULL",
-    missing = "missing_class",
-    any = "any_class",
+    missing = "class_missing",
+    any = "class_any",
     S4 = as.character(x@className),
     R7 = R7_class_name(x),
     R7_base = encodeString(x$class, quote = '"'),

R/class.R

@@ -4,13 +4,15 @@
 #' possess. The class, and its parent, determines which method will be used
 #' when an object is passed to a generic.
 #'
-#' @param name The name of the class, as a string.
+#' @param name The name of the class, as a string. The result of calling
+#'   `new_class()` should always be assigned to a variable with this name,
+#'   i.e. `foo <- new_class("foo")`.
 #' @param parent The parent class to inherit behavior from.
-#'   There are four options:
+#'   There are three options:
 #'
-#'   * The R7 class, like [R7_object].
+#'   * An R7 class, like [R7_object].
 #'   * An S3 class wrapped by [new_S3_class()].
-#'   * A base type, like `logical`, `double`, or `character`.
+#'   * A base type, like [class_logical], [class_integer], etc.
 #' @param package Package name. It is good practice to set the package
 #'   name when exporting an R7 class from a package because it includes
 #'   the package name in the class name when it's used for dispatch. This
@@ -51,8 +53,8 @@
 #' # Create an class that represents a range using a numeric start and end
 #' range <- new_class("range",
 #'   properties = list(
-#'     start = "numeric",
-#'     end = "numeric"
+#'     start = class_numeric,
+#'     end = class_numeric
 #'   )
 #' )
 #' r <- range(start = 10, end = 20)
@@ -69,8 +71,8 @@
 #' # are length 1, and that start is < end
 #' range <- new_class("range",
 #'   properties = list(
-#'     start = "numeric",
-#'     end = "numeric"
+#'     start = class_numeric,
+#'     end = class_numeric
 #'   ),
 #'   validator = function(self) {
 #'     if (length(self@start) != 1) {
@@ -224,7 +226,7 @@ new_object <- function(.parent, ...) {
   args <- list(...)
   nms <- names(args)
 
-  missing_props <- nms[vlapply(args, is_missing_class)]
+  missing_props <- nms[vlapply(args, is_class_missing)]
   for(prop in missing_props) {
     args[[prop]] <- prop_default(class@properties[[prop]])
   }

R/constructor.R

@@ -75,7 +75,7 @@ new_function <- function(args, body, env) {
   f
 }
 missing_args <- function(names) {
-  lapply(setNames(, names), function(i) quote(missing_class))
+  lapply(setNames(, names), function(i) quote(class_missing))
 }
 new_call <- function(call, args) {
   as.call(c(list(as.name(call)), args))

R/convert.R

@@ -15,21 +15,21 @@
 #' @param ... Other arguments passed to custom `convert()` methods.
 #' @export
 #' @examples
-#' foo1 <- new_class("foo1", properties = list(x = integer))
-#' foo2 <- new_class("foo2", foo1, properties = list(y = double))
+#' foo1 <- new_class("foo1", properties = list(x = class_integer))
+#' foo2 <- new_class("foo2", foo1, properties = list(y = class_double))
 #'
-#' method(convert, list(foo1, integer)) <- function(from, to) from@x
-#' method(convert, list(foo2, double)) <- function(from, to) from@y
+#' method(convert, list(foo1, class_integer)) <- function(from, to) from@x
+#' method(convert, list(foo2, class_double)) <- function(from, to) from@y
 #'
-#' convert(foo1(x = 1L), to = integer)
-#' try(convert(foo1(x = 1L), to = double))
+#' convert(foo1(x = 1L), to = class_integer)
+#' try(convert(foo1(x = 1L), to = class_double))
 #'
-#' convert(foo2(x = 1L, y = 2), to = integer)
-#' convert(foo2(x = 1L, y = 2), to = double)
+#' convert(foo2(x = 1L, y = 2), to = class_integer)
+#' convert(foo2(x = 1L, y = 2), to = class_double)
 #' convert(foo2(x = 1L, y = 2), to = foo1)
 #'
 #' # If we define a convert method for interger + foo1:
-#' method(convert, list(integer, foo1)) <- function(from, to) foo1(x = from)
+#' method(convert, list(class_integer, foo1)) <- function(from, to) foo1(x = from)
 #' convert(1L, to = foo1)
 #' # Converting too foo2 still errors
 #' try(convert(1L, to = foo2))

R/data.R

@@ -8,7 +8,7 @@
 #' @param value Object used to replace the underlying data.
 #' @export
 #' @examples
-#' text <- new_class("text", parent = "character")
+#' text <- new_class("text", parent = class_character)
 #' y <- text(c(foo = "bar"))
 #' y
 #' R7_data(y)