diff --git a/R/class-spec.R b/R/class-spec.R index 65579a45..6c87190c 100644 --- a/R/class-spec.R +++ b/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) diff --git a/R/class.R b/R/class.R index a71ccb0f..175e1055 100644 --- a/R/class.R +++ b/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]]) + } +} diff --git a/R/zzz.R b/R/zzz.R index b7ba1c36..ea3cda0b 100644 --- a/R/zzz.R +++ b/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() }