add class lookup table

R/class-spec.R

@@ -30,6 +30,8 @@ as_class <- function(x, arg = deparse(substitute(x))) {
     x
   } else if (isS4(x)) {
     S4_to_S7_class(x, error_base)
+  } else if (!is.null(cls <- class_lookup_table[[x]])) {
+    cls
   } else {
     msg <- sprintf("Class specification must be an S7 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)

R/class.R

@@ -327,3 +327,43 @@ str.S7_object <- function(object, ..., nest.lev = 0) {
 S7_class <- function(object) {
   attr(object, "S7_class", exact = TRUE)
 }
+
+class_lookup_table <- NULL
+on_load_define_class_lookup_table <- function() {
+  pairs <- list(
+    list(class_list, list),
+    list(class_logical, logical),
+    list(class_integer, integer),
+    list(class_double, double),
+    list(class_numeric, numeric),
+    list(class_character, character),
+    list(class_complex, complex),
+    list(class_raw, raw),
+    list(class_vector, vector),
+    list(class_formula, stats::formula),
+    list(class_call, call),
+    list(class_data.frame, data.frame),
+    list(class_factor, factor),
+    list(class_expression, expression),
+    list(class_matrix, matrix),
+    list(class_array, array),
+
+    # the rest are a little more questionable...
+    list(class_Date, .Date),
+    list(class_POSIXct, .POSIXct),
+    list(class_POSIXlt, .POSIXlt),
+    list(class_environment, environment),
+    list(class_language, quote)
+
+    # list(class_POSIXt, )
+    # list(class_atomic, ),
+    # list(class_name, )
+    # list(class_missing, )
+    # list(class_function, )
+    # list(class_any, )
+  )
+  class_lookup_table <<- utils::hashtab("address")
+  for (pair in pairs) {
+    utils::sethash(class_lookup_table, pair[[2]], pair[[1]])
+  }
+}

R/zzz.R

@@ -139,4 +139,5 @@ methods::setOldClass(c("S7_method", "function", "S7_object"))
   on_load_define_or_methods()
   on_load_define_S7_type()
   on_load_define_union_classes()
+  on_load_define_class_lookup_table()
 }