| # File src/library/methods/R/SClasses.R |
| # Part of the R package, https://www.R-project.org |
| # |
| # Copyright (C) 1995-2016 The R Core Team |
| # |
| # This program is free software; you can redistribute it and/or modify |
| # it under the terms of the GNU General Public License as published by |
| # the Free Software Foundation; either version 2 of the License, or |
| # (at your option) any later version. |
| # |
| # This program is distributed in the hope that it will be useful, |
| # but WITHOUT ANY WARRANTY; without even the implied warranty of |
| # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| # GNU General Public License for more details. |
| # |
| # A copy of the GNU General Public License is available at |
| # https://www.R-project.org/Licenses/ |
| |
| setClass <- |
| ## Define Class to be an S4 class. |
| function(Class, representation = list(), prototype = NULL, |
| contains = character(), validity = NULL, access = list(), |
| where = topenv(parent.frame()), version = .newExternalptr(), |
| sealed = FALSE, package = getPackageName(where), |
| S3methods = FALSE, slots) |
| { |
| oldDef <- getClassDef(Class, where) |
| if(is(oldDef, "classRepresentation") && oldDef@sealed) |
| stop(gettextf("%s has a sealed class definition and cannot be redefined", |
| dQuote(Class)), |
| domain = NA) |
| if(!missing(slots)) { |
| ## The modern version consistent with reference classes |
| ## Arguments slots= and contains= are used, representation must not be |
| if(!missing(representation)) |
| stop("Argument \"representation\" cannot be used if argument \"slots\" is supplied") |
| properties <- inferProperties(slots, "slot") |
| classDef <- makeClassRepresentation(Class, properties, contains, prototype, package, |
| validity, access, version, sealed, where = where) |
| } |
| else if(is(representation, "classRepresentation")) { |
| ## supplied a class definition object |
| classDef <- representation |
| if(!(missing(prototype) && missing(contains) && missing(validity) && missing(access) |
| && missing(version) && missing(package))) |
| stop("only arguments 'Class' and 'where' can be supplied when argument 'representation' is a 'classRepresentation' object") |
| if(length(classDef@package) == 0L) |
| classDef@package <- package # the default |
| } |
| else { |
| ## catch the special case of a single class name as the representation |
| if(is.character(representation) && length(representation) == 1L && |
| is.null(names(representation))) |
| representation <- list(representation) |
| slots <- nzchar(allNames(representation)) |
| superClasses <- c(as.character(representation[!slots]), contains) |
| properties <- representation[slots] |
| classDef <- makeClassRepresentation(Class, properties, superClasses, prototype, package, |
| validity, access, version, sealed, where = where) |
| } |
| superClasses <- names(classDef@contains) |
| classDef <- completeClassDefinition(Class, classDef, where, doExtends = FALSE) |
| ## uncache an old definition for this package, if one is cached |
| .uncacheClass(Class, classDef) |
| if(length(superClasses) > 0L) { |
| sealed <- classDef@sealed |
| classDef@sealed <- FALSE # to allow setIs to work anyway; will be reset later |
| assignClassDef(Class, classDef, where) |
| badContains <- character() |
| ### FIXME: need to iterate over contains, not superclass to get |
| ### package for getClassDef() |
| for(class2 in superClasses) { |
| if(is(try(setIs(Class, class2, classDef = classDef, where = where)), "try-error")) |
| badContains <- c(badContains, class2) |
| else { # update class definition |
| classDef <- getClassDef(Class, where = where) |
| if(is.null(classDef)) |
| stop(sprintf("internal error: definition of class %s not properly assigned", |
| dQuote(Class)), |
| domain = NA) |
| } |
| } |
| if(length(badContains)) { |
| msg <- paste(.dQ(badContains), collapse = ", ") |
| if(is(try(removeClass(Class, where)), "try-error")) |
| stop(gettextf("error in contained classes (%s) for class %s and unable to remove definition from %s", |
| msg, dQuote(Class), |
| sQuote(getPackageName(where))), |
| domain = NA) |
| if(is.null(oldDef)) |
| stop(gettextf("error in contained classes (%s) for class %s; class definition removed from %s", |
| msg, dQuote(Class), |
| sQuote(getPackageName(where))), |
| domain = NA) |
| else if(is(try(setClass(Class, oldDef, where=where)), "try-error")) |
| stop(gettextf("error in contained classes (%s) for class %s and unable to restore previous definition from %s", |
| msg, dQuote(Class), |
| sQuote(getPackageName(where))), |
| domain = NA) |
| else |
| stop(gettextf("error in contained classes (%s) for class %s; previous definition restored to %s", |
| msg, dQuote(Class), |
| sQuote(getPackageName(where))), |
| domain = NA) |
| } |
| if(length(attr(classDef@contains, "conflicts")) > 0) |
| .reportSuperclassConflicts(Class, classDef@contains, where) |
| .checkRequiredGenerics(Class, classDef, where) |
| if(sealed) { |
| classDef@sealed <- TRUE |
| } |
| } |
| if(S3methods) |
| classDef <- .setS3MethodsOn(classDef) |
| assignClassDef(Class, classDef, where) |
| invisible(classGeneratorFunction(classDef, where)) |
| } |
| |
| representation <- |
| ## Representation of a class; that is, |
| ## a list of named slots and unnamed classes to be included in a class |
| ## definition. |
| function(...) |
| { |
| value <- list(...) |
| ## unlike the S-Plus function, this does not form the class representation, |
| ## since set SClass works separately with the slots and extends arguments. |
| anames <- allNames(value) |
| for(i in seq_along(value)) { |
| ei <- value[[i]] |
| if(!is.character(ei) || length(ei) != 1L) |
| stop(gettextf("element %d of the representation was not a single character string", i), domain = NA) |
| } |
| includes <- as.character(value[!nzchar(anames)]) |
| if(anyDuplicated(includes)) |
| stop(gettextf("duplicate class names among superclasses: %s", |
| paste(.dQ(includes[duplicated(includes)]), |
| collapse = ", ")), |
| domain = NA) |
| slots <- anames[nzchar(anames)] |
| if(anyDuplicated(slots)) { |
| dslots <- slots[duplicated(slots)] |
| stop(sprintf(ngettext(length(dslots), |
| "duplicated slot name: %s", |
| "duplicated slot names: %s"), |
| paste(sQuote(dslots), collapse="")), |
| domain = NA) |
| } |
| value |
| } |
| |
| ### the version called prototype is the external interface. But functions with argument |
| ### named prototype in R cannot call the prototype function (until there is a methods namespace |
| ### to allow methods::prototype(...) |
| prototype <- function(...) |
| .prototype(...) |
| |
| .prototype <- function(...) { |
| props <- list(...) |
| names <- allNames(props) |
| data <- !nzchar(names) |
| dataPart <- any(data) |
| if(dataPart) { |
| if(sum(data) > 1) |
| stop("only one data object (unnamed argument to prototype) allowed") |
| obj <- unclass(props[[seq_along(data)[data] ]]) |
| props <- props[!data] |
| names <- names[!data] |
| } |
| else |
| obj <- defaultPrototype() |
| for(i in seq_along(names)) |
| slot(obj, names[[i]], FALSE) <- props[[i]] |
| new("classPrototypeDef", object = obj, slots = names, dataPart = dataPart) |
| } |
| |
| makeClassRepresentation <- |
| ## Set the Class Definition. |
| ## The formal definition of the class is set according to the arguments. |
| ## |
| ## Users should call setClass instead of this function. |
| function(name, slots = list(), superClasses = character(), prototype = NULL, |
| package, validity = NULL, access = list(), version = .newExternalptr(), |
| sealed = FALSE, virtual = NA, where) |
| { |
| if(any(superClasses %in% .AbnormalTypes)) |
| superClasses <- .addAbnormalDataType(superClasses) |
| if(!is.null(prototype) || length(slots) || length(superClasses)) { |
| ## collect information about slots, create prototype if needed |
| pp <- reconcilePropertiesAndPrototype(name, slots, prototype, superClasses, where) |
| slots <- pp$properties |
| prototype <- pp$prototype |
| } |
| contains <- list() |
| if(nzchar(package)) |
| packageSlot(name) <- package |
| for(what in superClasses) { |
| whatClassDef <- |
| if(is(what, "classRepresentation")) |
| what |
| else if(is.null(packageSlot(what))) |
| getClass(what, where = where) |
| else |
| getClass(what) |
| what <- whatClassDef@className # includes package name as attribute |
| ## Create the SClassExtension objects (will be simple, possibly dataPart). |
| ## The slots are supplied explicitly, since `name' is currently an undefined class |
| contains[[what]] <- makeExtends(name, what, slots = slots, |
| classDef2 = whatClassDef, package = package) |
| } |
| validity <- .makeValidityMethod(name, validity) |
| if(is.na(virtual)) { |
| virtual <- testVirtual(slots, contains, prototype, where) |
| if(virtual && !is.na(match("VIRTUAL", superClasses))) |
| contains[["VIRTUAL"]] <- NULL |
| } |
| # new() must return an S4 object, except perhaps for basic classes |
| if(!is.null(prototype) && is.na(match(name, .BasicClasses))) |
| prototype <- .asS4(prototype) |
| if(".S3Class" %in% names(slots)) |
| prototype <- .addS3Class(name, prototype, contains, where) |
| newClassRepresentation(className = name, slots = slots, |
| contains = contains, |
| prototype = prototype, |
| virtual = virtual, |
| validity = validity, |
| access = access, |
| package = package, |
| versionKey = version, |
| sealed = sealed) |
| } |
| |
| getClassDef <- |
| ## Get the definition of the class supplied as a string. |
| function(Class, where = topenv(parent.frame()), package = packageSlot(Class), |
| inherits = TRUE) |
| { |
| if(inherits) { |
| value <- .getClassesFromCache(Class) |
| if(is.list(value)) |
| value <- .resolveClassList(value, where, package) |
| } else |
| value <- NULL |
| |
| if(is.null(value)) { |
| cname <- classMetaName(if(length(Class) > 1L) |
| ## S3 class; almost certainly has no packageSlot, |
| ## but we'll continue anyway |
| Class[[1L]] else Class) |
| ## a string with a package slot strongly implies the class definition |
| ## should be in that package. |
| if(is.character(where)) { |
| package <- where |
| } |
| |
| if(isTRUE(nzchar(package))) { |
| package <- .requirePackage(package) |
| } |
| if (is.environment(package)) { |
| value <- get0(cname, package, inherits = inherits) |
| } |
| if(is.null(value)) |
| value <- get0(cname, where, inherits = inherits) # NULL if not existing |
| } |
| value |
| } |
| |
| getClass <- |
| ## Get the complete definition of the class supplied as a string, |
| ## including all slots, etc. in classes that this class extends. |
| function(Class, .Force = FALSE, |
| where = .classEnv(Class, topenv(parent.frame()), FALSE)) |
| { |
| value <- getClassDef(Class, where) |
| if(is.null(value)) { |
| if(!.Force) |
| stop(gettextf("%s is not a defined class", |
| dQuote(Class)), |
| domain = NA) |
| else |
| value <- makeClassRepresentation(Class, package = "base", |
| virtual = TRUE, where = where) |
| } |
| value |
| } |
| |
| slot <- |
| ## Get the value of the named slot. This function does exact, not partial, matching of names, |
| ## and the name must be one of the slot names specified in the class's definition. |
| ## |
| ## Because slots are stored as attributes, the validity check is not 100% guaranteed, |
| ## but should be OK if nobody has "cheated" (e.g., by setting other attributes directly). |
| function(object, name) |
| .Call(C_R_get_slot, object, name) |
| |
| "slot<-" <- |
| ## Set the value of the named slot. Must be one of the slots in the class's definition. |
| function(object, name, check = TRUE, value) { |
| if(check) |
| value <- checkSlotAssignment(object, name, value) |
| .Call(C_R_set_slot, object, name, value) |
| ## currently --> R_do_slot_assign() in ../../../main/attrib.c |
| } |
| |
| ## ". - hidden" since one should typically rather use is(), extends() etc: |
| .hasSlot <- function(object, name) |
| .Call(C_R_hasSlot, object, name) |
| |
| checkSlotAssignment <- function(obj, name, value) |
| { |
| cl <- class(obj) |
| ClassDef <- getClass(cl) # fails if cl not a defined class (!) |
| slotClass <- ClassDef@slots[[name]] |
| if(is.null(slotClass)) |
| stop(gettextf("%s is not a slot in class %s", |
| sQuote(name), dQuote(cl)), |
| domain = NA) |
| valueClass <- class(value) |
| if(.identC(slotClass, valueClass)) |
| return(value) |
| ## check the value, but be careful to use the definition of the slot's class from |
| ## the class environment of obj (change validObject too if a better way is found) |
| ok <- possibleExtends(valueClass, slotClass, |
| ClassDef2 = getClassDef(slotClass, where = .classEnv(ClassDef))) |
| if(isFALSE(ok)) |
| stop(gettextf("assignment of an object of class %s is not valid for slot %s in an object of class %s; is(value, \"%s\") is not TRUE", |
| dQuote(valueClass), sQuote(name), dQuote(cl), slotClass), |
| domain = NA) |
| else if(isTRUE(ok)) |
| value |
| else |
| as(value, slotClass, strict=FALSE, ext = ok) |
| } |
| |
| ## slightly simpler verison to be called from do_attrgets() |
| checkAtAssignment <- function(cl, name, valueClass) |
| { |
| ClassDef <- getClass(cl) # fails if cl not a defined class (!) |
| slotClass <- ClassDef@slots[[name]] |
| if(is.null(slotClass)) |
| stop(gettextf("%s is not a slot in class %s", |
| sQuote(name), dQuote(cl)), |
| domain = NA) |
| if(.identC(slotClass, valueClass)) |
| return(TRUE) |
| ## check the value, but be careful to use the definition of the slot's class from |
| ## the class environment of obj (change validObject too if a better way is found) |
| ok <- possibleExtends(valueClass, slotClass, |
| ClassDef2 = getClassDef(slotClass, where = .classEnv(ClassDef))) |
| if(isFALSE(ok)) |
| stop(gettextf("assignment of an object of class %s is not valid for @%s in an object of class %s; is(value, \"%s\") is not TRUE", |
| dQuote(valueClass), sQuote(name), dQuote(cl), slotClass), |
| domain = NA) |
| TRUE |
| } |
| |
| ## Now a primitive in base |
| ## "@<-" <- |
| ## function(object, name, value) { |
| ## arg <- substitute(name) |
| ## if(is.name(arg)) |
| ## name <- as.character(arg) |
| ## "slot<-"(object, name, TRUE, value) |
| ## } |
| |
| ## The names of the class's slots. The argument is either the name |
| ## of a class, or an object from the relevant class. |
| |
| ## NOTA BENE: .slotNames() shouldn't be needed, |
| ## rather slotNames() should be changed (to work like .slotNames())! |
| slotNames <- function(x) |
| if(is(x, "classRepresentation")) names(x@slots) else .slotNames(x) |
| |
| .slotNames <- function(x) |
| { |
| classDef <- getClassDef( |
| if(!isS4(x) && is.character(x) && length(x) == 1L) x else class(x)) |
| if(is.null(classDef)) |
| character() |
| else |
| names(classDef@slots) |
| } |
| |
| |
| removeClass <- function(Class, where = topenv(parent.frame())) { |
| if(missing(where)) { |
| classEnv <- .classEnv(Class, where, FALSE) |
| classWhere <- findClass(Class, where = classEnv) |
| if(length(classWhere) == 0L) { |
| warning(gettextf("class definition for %s not found (no action taken)", |
| dQuote(Class)), |
| domain = NA) |
| return(FALSE) |
| } |
| if(length(classWhere) > 1L) |
| warning(gettextf( |
| "class %s has multiple definitions visible; only the first removed", |
| dQuote(Class)), |
| domain = NA) |
| classWhere <- classWhere[[1L]] |
| } |
| else classWhere <- where |
| classDef <- getClassDef(Class, where=classWhere) |
| if(length(classDef@subclasses)) { |
| subclasses <- names(classDef@subclasses) |
| found <- vapply(subclasses, isClass, NA, where = where, USE.NAMES=TRUE) |
| for(what in subclasses[found]) |
| .removeSuperClass(what, Class) |
| } |
| .removeSuperclassBackRefs(Class, classDef, classWhere) |
| .uncacheClass(Class, classDef) |
| .undefineMethod("initialize", Class, classWhere) |
| what <- classMetaName(Class) |
| rm(list=what, pos=classWhere) |
| TRUE |
| } |
| |
| |
| isClass <- |
| ## Is this a formally defined class? |
| function(Class, formal=TRUE, where = topenv(parent.frame())) |
| ## argument formal is for Splus compatibility & is ignored. (All classes that |
| ## are defined must have a class definition object.) |
| !is.null(getClassDef(Class, where)) |
| |
| ### TODO s/Class/._class/ -- in order to allow 'Class' as regular slot name |
| new <- |
| ## Generate an object from the specified class. |
| ## |
| ## Note that the basic vector classes, `"numeric"', etc. are implicitly defined, |
| ## so one can use `new' for these classes. |
| ## |
| function(Class, ...) |
| { |
| ClassDef <- getClass(Class, where = topenv(parent.frame())) |
| value <- .Call(C_new_object, ClassDef) |
| initialize(value, ...) |
| } |
| |
| getClasses <- |
| ## The names of all the classes formally defined on `where'. |
| ## If called with no argument, all the classes currently known in the session |
| ## (which does not include classes that may be defined on one of the attached |
| ## libraries, but have not yet been used in the session). |
| function(where = .externalCallerEnv(), inherits = missing(where)) |
| { |
| pat <- paste0("^",classMetaName("")) |
| if(!is.environment(where)) ## e.g. for "package:stats4" |
| where <- as.environment(where) |
| if(inherits) { |
| evList <- .parentEnvList(where) |
| clNames <- character() |
| for(ev in evList) |
| clNames <- c(clNames, grep(pat, names(ev), value=TRUE)) |
| clNames <- unique(clNames) |
| } |
| else |
| clNames <- grep(pat, names(where), value=TRUE) |
| ## strip off the leading pattern (this implicitly assumes the characters |
| ## in classMetaName("") are either "." or not metacharacters |
| substring(clNames, nchar(pat, "c")) |
| } |
| |
| |
| validObject <- function(object, test = FALSE, complete = FALSE) |
| { |
| Class <- class(object) |
| classDef <- getClassDef(Class) |
| where <- .classEnv(classDef) |
| anyStrings <- function(x) if(isTRUE(x)) character() else x |
| ## perform, from bottom up, the default and any explicit validity tests |
| ## First, validate the slots. |
| errors <- character() |
| slotTypes <- classDef@slots |
| slotNames <- names(slotTypes) |
| attrNames <- c(".Data", ".S3Class", names(attributes(object))) |
| if(any(is.na(match(slotNames, attrNames)))) { |
| badSlots <- is.na(match(slotNames, attrNames)) |
| errors <- |
| c(errors, |
| paste("slots in class definition but not in object:", |
| paste0('"', slotNames[badSlots], '"', collapse = ", "))) |
| slotTypes <- slotTypes[!badSlots] |
| slotNames <- slotNames[!badSlots] |
| } |
| for(i in seq_along(slotTypes)) { |
| classi <- slotTypes[[i]] |
| classDefi <- getClassDef(classi, where = where) |
| if(is.null(classDefi)) { |
| errors <- c(errors, |
| paste0("undefined class for slot \"", slotNames[[i]], |
| "\" (\"", classi, "\")")) |
| next |
| } |
| namei <- slotNames[[i]] |
| sloti <- try(switch(namei, |
| ## .S3Class for S3 objects (e.g., "factor") |
| .S3Class = S3Class(object), |
| slot(object, namei) |
| ), silent = TRUE) |
| if(inherits(sloti, "try-error")) { |
| errors <- c(errors, sloti) |
| next |
| } |
| ## note that the use of possibleExtends is shared with checkSlotAssignment(), in case a |
| ## future revision improves on it! |
| ok <- possibleExtends(class(sloti), classi, ClassDef2 = classDefi) |
| if(isFALSE(ok)) { |
| errors <- c(errors, |
| paste0("invalid object for slot \"", slotNames[[i]], |
| "\" in class \"", Class, |
| "\": got class \"", class(sloti), |
| "\", should be or extend class \"", classi, "\"")) |
| next |
| } |
| if(!complete) |
| next |
| errori <- anyStrings(Recall(sloti, TRUE, TRUE)) |
| if(length(errori)) { |
| errori <- paste0("In slot \"", slotNames[[i]], |
| "\" of class \"", class(sloti), "\": ", errori) |
| errors <- c(errors, errori) |
| } |
| } |
| extends <- rev(classDef@contains) |
| for(i in seq_along(extends)) { |
| exti <- extends[[i]] |
| superClass <- exti@superClass |
| if(!exti@simple && !is(object, superClass)) |
| next ## skip conditional relations that don't hold for this object |
| superDef <- getClassDef(superClass, package = packageSlot(exti)) |
| if(is.null(superDef)) { |
| errors <- c(errors, |
| paste0("superclass \"", superClass, |
| "\" not defined in the environment of the object's class")) |
| break |
| } |
| validityMethod <- superDef@validity |
| if(is.function(validityMethod)) { |
| errors <- c(errors, anyStrings(validityMethod(as(object, superClass)))) |
| if(length(errors)) |
| break |
| } |
| } |
| validityMethod <- classDef@validity |
| if(length(errors) == 0L && is.function(validityMethod)) { |
| errors <- c(errors, anyStrings(validityMethod(object))) |
| } |
| if(length(errors)) { |
| if(test) |
| errors |
| else { |
| msg <- gettextf("invalid class %s object", dQuote(Class)) |
| if(length(errors) > 1L) |
| stop(paste(paste0(msg, ":"), |
| paste(seq_along(errors), errors, sep=": "), |
| collapse = "\n"), domain = NA) |
| else stop(msg, ": ", errors, domain = NA) |
| } |
| } |
| else |
| TRUE |
| } |
| |
| setValidity <- function(Class, method, where = topenv(parent.frame())) { |
| if(isClassDef(Class)) { |
| ClassDef <- Class |
| Class <- ClassDef@className |
| } |
| else { |
| ClassDef <- getClassDef(Class, where) |
| } |
| method <- .makeValidityMethod(Class, method) |
| if(is.null(method) || |
| (is.function(method) && length(formalArgs(method)) == 1L)) |
| ClassDef@validity <- method |
| else |
| stop("validity method must be NULL or a function of one argument") |
| ## TO DO: check the where argument against the package of the class def. |
| assignClassDef(Class, ClassDef, where = where) |
| resetClass(Class, ClassDef, where = where) |
| } |
| |
| getValidity <- function (ClassDef) { |
| ## "needed" according to ../man/validObject.Rd |
| ClassDef@validity |
| } |
| |
| |
| resetClass <- function(Class, classDef, where) { |
| if(is(Class, "classRepresentation")) { |
| classDef <- Class |
| Class <- Class@className |
| if(missing(where)) |
| where <- .classDefEnv(classDef) |
| } |
| else { |
| if(missing(where)) { |
| if(missing(classDef)) |
| where <- findClass(Class, unique = "resetting the definition")[[1L]] |
| else |
| where <- .classDefEnv(classDef) |
| } |
| if(missing(classDef)) { |
| classDef <- getClassDef(Class, where) |
| if(is.null(classDef)) { |
| warning(gettextf("class %s not found on %s; 'resetClass' will have no effect", |
| dQuote(Class), |
| sQuote(getPackageName(where))), |
| domain = NA) |
| return(classDef) |
| } |
| } |
| else if(!is(classDef, "classRepresentation")) |
| stop(gettextf("argument 'classDef' must be a string or a class representation; got an object of class %s", |
| dQuote(class(classDef))), |
| domain = NA) |
| # package <- getPackageName(where) |
| } |
| if(classDef@sealed) |
| warning(gettextf("class %s is sealed; 'resetClass' will have no effect", |
| dQuote(Class)), |
| domain = NA) |
| else { |
| classDef <- .uncompleteClassDefinition(classDef) |
| classDef <- completeClassDefinition(Class, classDef, where) |
| assignClassDef(Class, classDef, where) |
| } |
| classDef |
| } |
| |
| ## the (default) initialization: becomes the default method when the function |
| ## is made a generic by .InitMethodDefinitions |
| |
| initialize <- function(.Object, ...) { |
| args <- list(...) |
| if(length(args)) { |
| Class <- class(.Object) |
| ## the basic classes have fixed definitions |
| if(!is.na(match(Class, .BasicClasses))) |
| return(newBasic(Class, ...)) |
| ClassDef <- getClass(Class) |
| ## separate the slots, superclass objects |
| snames <- allNames(args) |
| which <- nzchar(snames) |
| elements <- args[which] |
| supers <- args[!which] |
| thisExtends <- names(ClassDef@contains) |
| slotDefs <- ClassDef@slots |
| dataPart <- slotDefs[[".Data"]] |
| if(is.null(dataPart)) dataPart <- "missing" |
| if(length(supers)) { |
| for(i in rev(seq_along(supers))) { |
| obj <- supers[[i]] |
| Classi <- class(obj) |
| if(length(Classi) > 1L) |
| Classi <- Classi[[1L]] #possible S3 inheritance |
| ## test some cases that let information be copied into the |
| ## object, ordered from more to less: all the slots in the |
| ## first two cases, some in the 3rd, just the data part in 4th |
| if(.identC(Classi, Class)) |
| .Object <- obj |
| else if(extends(Classi, Class)) |
| .Object <- as(obj, Class, strict=FALSE) |
| else if(extends(Class, Classi)) |
| as(.Object, Classi) <- obj |
| else if(extends(Classi, dataPart)) |
| .Object@.Data <- obj |
| else { |
| ## is there a class to which we can coerce obj |
| ## that is then among the superclasses of Class? |
| extendsi <- extends(Classi)[-1L] |
| ## look for the common extensions, choose the first |
| ## one in the extensions of Class |
| which <- match(thisExtends, extendsi) |
| which <- seq_along(which)[!is.na(which)] |
| if(length(which)) { |
| Classi <- thisExtends[which[1L]] |
| ### was: as(.Object, Classi) <- as(obj, Classi, strict = FALSE) |
| ## but as<- does an as(....) to its value argument |
| as(.Object, Classi) <- obj |
| } |
| else |
| stop(gettextf("cannot use object of class %s in new(): class %s does not extend that class", |
| dQuote(Classi), |
| dQuote(Class)), |
| domain = NA) |
| } |
| } |
| } |
| if(length(elements)) { |
| snames <- names(elements) |
| if(anyDuplicated(snames)) |
| stop(gettextf("duplicated slot names: %s", |
| paste(sQuote(snames[duplicated(snames)]), |
| collapse = ", ")), domain = NA) |
| which <- match(snames, names(slotDefs)) |
| if(anyNA(which)) |
| stop(sprintf(ngettext(sum(is.na(which)), |
| "invalid name for slot of class %s: %s", |
| "invalid names for slots of class %s: %s"), |
| dQuote(Class), |
| paste(snames[is.na(which)], collapse=", ")), |
| domain = NA) |
| firstTime <- TRUE |
| for(i in seq_along(snames)) { |
| slotName <- snames[[i]] |
| slotClass <- slotDefs[[slotName]] |
| slotClassDef <- getClassDef(slotClass, |
| package = packageSlot(slotClass)) |
| slotVal <- elements[[i]] |
| ## perform non-strict coercion, but leave the error messages for |
| ## values not conforming to the slot definitions to validObject(), |
| ## hence the check = FALSE argument in the slot assignment |
| if(!.identC(class(slotVal), slotClass) |
| && !is.null(slotClassDef) ) { |
| valClass <- class(slotVal) |
| valClassDef <- getClassDef(valClass, package = ClassDef@package) |
| if(!identical(possibleExtends(valClass, slotClass, |
| valClassDef, slotClassDef), FALSE)) |
| slotVal <- as(slotVal, slotClass, strict = FALSE) |
| } |
| if (firstTime) { |
| ## force a copy of .Object |
| slot(.Object, slotName, check = FALSE) <- slotVal |
| firstTime <- FALSE |
| } else { |
| ## XXX: do the assignment in-place |
| "slot<-"(.Object, slotName, check = FALSE, slotVal) |
| } |
| } |
| } |
| validObject(.Object) |
| } |
| .Object |
| } |
| |
| findClass <- function(Class, where = topenv(parent.frame()), unique = "") { |
| if(is(Class, "classRepresentation")) { |
| pkg <- Class@package |
| classDef <- Class |
| Class <- Class@className |
| } |
| else { |
| pkg <- packageSlot(Class) |
| if(is.null(pkg)) |
| pkg <- "" |
| classDef <- getClassDef(Class, where, pkg) |
| } |
| where <- if(missing(where) && nzchar(pkg)) .requirePackage(pkg) else as.environment(where) |
| what <- classMetaName(Class) |
| where <- .findAll(what, where) |
| if(length(where) > 1L && nzchar(pkg)) { |
| pkgs <- sapply(where, function(db)get(what, db)@package) |
| where <- where[match(pkg, pkgs, 0L)] |
| } |
| else |
| pkgs <- pkg |
| if(length(where) == 0L) { |
| if(is.null(classDef)) |
| classDef <- getClassDef(Class) # but won't likely succeed over previous |
| if(nzchar(unique)) { |
| if(is(classDef, "classRepresentation")) |
| stop(gettextf("class %s is defined, with package %s, but no corresponding metadata object was found (not exported?)", |
| dQuote(Class), |
| sQuote(classDef@package)), |
| domain = NA) |
| else |
| stop(gettextf("no definition of %s to use for %s", |
| dQuote(Class), |
| unique), |
| domain = NA) |
| } |
| } |
| else if(length(where) > 1L) { |
| pkgs <- sapply(where, getPackageName, create = FALSE) |
| ## not all environments need be packages (e.g., imports) |
| ## We only try to eliminate duplicate package namespaces |
| where <- where[!(nzchar(pkgs) & duplicated(pkgs))] |
| if(length(where) > 1L) |
| if(nzchar(unique)) { |
| pkgs <- base::unique(pkgs) |
| where <- where[1L] |
| ## problem: 'unique'x is text passed in, so do not translate |
| warning(sprintf(ngettext(length(pkgs), |
| "multiple definition of class %s visible (%s); using the definition\n in package %s for %s", |
| "multiple definitions of class %s visible (%s); using the definition\n in package %s for %s"), |
| dQuote(Class), |
| paste(sQuote(pkgs), collapse = ", "), |
| sQuote(pkgs[[1L]]), |
| unique), |
| domain = NA) |
| } |
| ## else returns a list of >1 places, for the caller to sort out (e.g., .findOrCopyClass) |
| } |
| where |
| } |
| |
| isSealedClass <- function(Class, where = topenv(parent.frame())) { |
| if(is.character(Class)) |
| Class <- getClass(Class, TRUE, where) |
| if(!is(Class, "classRepresentation")) |
| FALSE |
| else |
| Class@sealed |
| } |
| |
| sealClass <- function(Class, where = topenv(parent.frame())) { |
| if(missing(where)) |
| where <- findClass(Class, unique = "sealing the class", where = where) |
| classDef <- getClassDef(Class, where) |
| if(!classDef@sealed) { |
| classDef@sealed <- TRUE |
| assignClassDef(Class, classDef, where) |
| } |
| invisible(classDef) |
| } |
| |
| ## see $RHOME/src/main/duplicate.c for the corresponding datatypes |
| ## not copied by duplicate1 |
| .AbnormalTypes <- c("environment", "name", "externalptr", "NULL") |
| |
| |
| .indirectAbnormalClasses <- paste0(".", .AbnormalTypes) |
| names(.indirectAbnormalClasses) <- .AbnormalTypes |
| |
| ## the types not supported by indirect classes (yet) |
| .AbnormalTypes <- c(.AbnormalTypes, |
| "special","builtin", "weakref", "bytecode") |
| |
| .addAbnormalDataType <- function(classes) { |
| types <- match(classes, .AbnormalTypes, 0) > 0 |
| type = classes[types] |
| if(length(type) == 0) |
| return(classes) |
| if(length(type) > 1) |
| stop(gettextf("class definition cannot extend more than one of these data types: %s", |
| paste0('"',type, '"', collapse = ", ")), |
| domain = NA) |
| class <- .indirectAbnormalClasses[type] |
| if(is.na(class)) |
| stop(gettextf("abnormal type %s is not supported as a superclass of a class definition", |
| dQuote(type)), |
| domain = NA) |
| ## this message USED TO BE PRINTED: reminds programmers that |
| ## they will see an unexpected superclass |
| ## message(gettextf('Defining type "%s" as a superclass via class "%s"', |
| ## type, class), domain = NA) |
| c(class, classes[!types]) |
| } |
| |
| .checkRequiredGenerics <- function(Class, classDef, where) {} |
| |
| ..checkRequiredGenerics <- function(Class, classDef, where) { |
| ## If any of the superclasses are in the .NeedPrimitiveMethods |
| ## list, cache the corresponding generics now and also save their names in |
| ## .requireCachedGenerics to be used when the environment |
| ## where= is loaded. |
| supers <- names(classDef@contains) |
| allNeeded <- get(".NeedPrimitiveMethods", envir = .methodsNamespace) |
| specials <- names(allNeeded) |
| needed <- match(specials, supers, 0L) > 0L |
| if(any(needed)) { |
| generics <- unique(allNeeded[needed]) |
| packages <- vapply(generics, function(g) { |
| def <- getGeneric(g) |
| pkg <- def@package # must be "methods" ? |
| cacheGenericsMetaData(g, def, TRUE, where, pkg) |
| pkg |
| }, character(1)) |
| previous <- if(exists(".requireCachedGenerics", where, inherits = FALSE)) |
| get(".requireCachedGenerics", where) else character() |
| packages <- c(attr(previous, "package"), packages) |
| gg <- c(previous, generics) |
| attr(gg, "package") <- packages |
| assign(".requireCachedGenerics", gg, where) |
| } |
| } |
| |
| .setS3MethodsOn <- function(classDef) { |
| ext <- extends(classDef) |
| slots <- classDef@slots |
| if(is.na(match(".S3Class", names(slots)))) { |
| ## add the slot if it's not there |
| slots$.S3Class <- getClass("oldClass")@slots$.S3Class |
| classDef@slots <- slots |
| } |
| ## in any case give the prototype the full extends as .S3Class |
| proto <- classDef@prototype |
| if(is.null(proto)) # simple virtual class--unlikely but valid |
| proto <- defaultPrototype() |
| attr(proto, ".S3Class") <- ext |
| classDef@prototype <- proto |
| classDef |
| } |
| |
| multipleClasses <- function(details = FALSE) { |
| classes <- as.list(.classTable, all.names=TRUE) |
| dups <- Filter(is.list, classes) |
| if(details) dups else names(dups) |
| } |
| |
| className <- function(class, package) { |
| if(is(class, "character")) { |
| className <- as.character(class) |
| if(missing(package)) |
| package <- packageSlot(class) |
| if(is.null(package)) { |
| if(exists(className, envir = .classTable, inherits = FALSE)) |
| classDef <- get(className, envir = .classTable) |
| else { |
| classDef <- findClass(className, topenv(parent.frame())) |
| if(length(classDef) == 1) |
| classDef <- classDef[[1]] |
| } |
| ## at this point, classDef is the definition if |
| ## unique, otherwise a list of 0 or >1 definitions |
| if(is(classDef, "classRepresentation")) |
| package <- classDef@package |
| else if(length(classDef) > 1L) { |
| pkgs <- sapply(classDef, function(cl)cl@package) |
| warning(gettextf("multiple class definitions for %s from packages: %s; picking the first", |
| dQuote(className), |
| paste(sQuote(pkgs), collapse = ", ")), |
| domain = NA) |
| package <- pkgs[[1L]] |
| } |
| else |
| stop(gettextf("no package name supplied and no class definition found for %s", |
| dQuote(className)), |
| domain = NA) |
| } |
| } |
| else if(is(class, classDef)) { |
| className <- class@className |
| if(missing(package)) |
| package <- class@package |
| } |
| new("className", .Data = className, package = package) |
| } |
| |
| ## bootstrap version before the class is defined |
| classGeneratorFunction <- function(classDef, env = topenv(parent.frame())) { |
| fun <- function(...)NULL |
| ## put the class name with package attribute into new() |
| body(fun) <- substitute(new(CLASS, ...), |
| list(CLASS = classDef@className)) |
| environment(fun) <- env |
| fun |
| } |
| |
| .classGeneratorFunction <- function(classDef, env = topenv(parent.frame())) { |
| if(is(classDef, "classRepresentation")) {} |
| else if(is(classDef, "character")) { |
| if(is.null(packageSlot(classDef))) |
| classDef <- getClass(classDef, where = env) |
| else |
| classDef <- getClass(classDef) |
| } |
| else |
| stop("argument 'classDef' must be a class definition or the name of a class") |
| fun <- function(...)NULL |
| ## put the class name with package attribute into new() |
| body(fun) <- substitute(new(CLASS, ...), |
| list(CLASS = classDef@className)) |
| environment(fun) <- env |
| fun <- as(fun, "classGeneratorFunction") |
| fun@className <- classDef@className |
| fun@package <- classDef@package |
| fun |
| } |
| |
| ## grammar: 'what' is an adjective, so not plural .... |
| inferProperties <- function(props, what) { |
| .validPropNames <- function(propNames) { |
| n <- length(props) |
| if(!n) |
| return(character()) |
| else if(is.null(propNames)) |
| stop(gettextf("No %s names supplied", what), |
| domain = NA, call. = FALSE) |
| else if(!all(nzchar(propNames))) |
| stop(gettextf("All %s names must be nonempty in:\n(%s)", what, |
| paste(sQuote(propNames), collapse = ", ")), |
| domain = NA, call. = FALSE) |
| else if(any(duplicated(propNames))) # NB: not translatable because of plurals |
| stop(gettextf("All %s names must be distinct in:\n(%s)", what, |
| paste(sQuote(propNames), collapse = ", ")), |
| domain = NA, call. = FALSE) |
| propNames |
| } |
| if(is.character(props)) { |
| propNames <- names(props) |
| if(is.null(propNames)) { |
| propNames <- .validPropNames(props) # the text is the names |
| ## treat as "ANY" |
| props <- as.list(rep("ANY", length(props))) |
| names(props) <- propNames |
| } |
| else { |
| .validPropNames(propNames) |
| props <- as.list(props) |
| } |
| } |
| else if(is.list(props)) { |
| if(length(props) > 0) # just validate them |
| .validPropNames(names(props)) |
| } |
| else |
| stop(gettextf("argument %s must be a list or a character vector; got an object of class %s", |
| dQuote(what), dQuote(class(fields))), |
| domain = NA) |
| props |
| } |
| |
| |
