testVirtual <- ## Test for a Virtual Class. ## Figures out, as well as possible, whether the class with these properties, ## extension, and prototype is a virtual class. ## Can be forced to be virtual by extending "VIRTUAL". Otherwise, a class is ## virtual only if it has no slots, extends no non-virtual classes, and has a ## NULL Prototype function(properties, extends, prototype) { if(length(extends)) { en <- names(extends) if(!is.na(match("VIRTUAL", en))) return(TRUE) ## does the class extend a known non-virtual class? for(what in en) if(isClass(what) && identical(getClass(what)@virtual, FALSE)) return(FALSE) } (length(properties)==0 && is.null(prototype)) } makePrototypeFromClassDef <- ## completes the prototype implied by ## the class definition. ## ## The following three rules are applied in this order. ## ## If the class has slots, then the prototype for each ## slot is used by default, but a corresponding element in the explicitly supplied ## prototype, if there is one, is used instead (but it must be coercible to the ## class of the slot). ## ## If there are no slots but a non-null prototype was specified, this is returned. ## ## If there is a single non-virtual superclass (a class in the extends list), ## then its prototype is used. ## ## If all three of the above fail, the prototype is `NULL'. function(slots, ClassDef, extends) { className <- ClassDef@className snames <- names(slots) ## try for a single superclass that is not virtual supers <- names(extends) virtual <- NA dataPartDone <- length(slots)==0 || !is.na(match(".Data", snames)) dataPartClass <- if(dataPartDone) "ANY" else elNamed(slots, ".Data") prototype <- ClassDef@prototype ## check for a formal prototype object (TODO: sometime ensure that this happens ## at setClass() time, so prototype slot in classRepresentation can have that class if(!.identC(class(prototype), className) && .isPrototype(prototype)) { pnames <- prototype@slots prototype <- prototype@object } else pnames <- names(attributes(prototype)) if(length(slots) == 0 && !is.null(prototype)) return(prototype) for(i in seq(along=extends)) { what <- el(supers, i) exti <- extends[[i]] if(identical(exti@simple, FALSE)) next ## only simple contains rel'ns give slots if(identical(what, "VIRTUAL")) ## the class is virtual, and the prototype usually NULL virtual <- TRUE else if(isClass(what)) { cli <- getClass(what) slotsi <- names(cli@slots) pri <- cli@prototype ## once in a while if(is.null(prototype)) { prototype <- pri pnames <- names(attributes(prototype)) fromClass <- what } else if(length(slots) > 0) { for(slotName in slotsi) { if(identical(slotName, ".Data")) { if(!dataPartDone) { prototype <- setDataPart(prototype, getDataPart(pri)) dataPartDone <- TRUE } } else if(is.na(match(slotName, pnames))) { ## possible that the prototype already had this slot specified ## If not, add it now. attr(prototype, slotName) <- attr(pri, slotName) pnames <- c(pnames, slotName) } } } else if(!dataPartDone && is(pri, dataPartClass)) prototype <- setDataPart(prototype, pri) } } if(length(slots) == 0) return(prototype) if(is.null(prototype)) prototype <- defaultPrototype() pnames <- names(attributes(prototype)) ## watch out for a prototype of this class. Not supposed to happen, but will ## at least for the basic class "ts", and can lead to inf. recursion if(.identC(class(prototype), className)) pslots <- names(attributes(unclass(prototype))) else if(isClass(class(prototype))) pslots <- names(getSlots(getClass(class(prototype)))) else pslots <- NULL ## now check that all the directly specified slots have corresponding elements ## in the prototype--the inherited slots were done in the loop over extends if(!is.na(match(".Data", snames))) { dataPartClass <- elNamed(slots, ".Data") ## check the data part if(!(isVirtualClass(dataPartClass) || is(prototype, dataPartClass))) stop("In constructing the prototype for class \"", className, "\": ", "Prototype has class \"", .class1(prototype), "\", but the data part specifies class \"", dataPartClass,"\"") iData <- -match(".Data", snames) snames <- snames[iData] slots <- slots[iData] } for(j in seq(along = snames)) { name <- el(snames, j) i <- match(name, pnames) if(is.na(i)) { ## if the class of the j-th element of slots is defined and non-virtual, ## generate an object from it ## to use as the corresponding prototype element. Else, leave NULL newi <- tryNew(el(slots, j)) if(!is.null(newi)) slot(prototype, name, check = FALSE) <- newi } } extra <- pnames[is.na(match(pnames, snames)) & !is.na(match(pnames, pslots))] if(length(extra)>0) warning("In constructing the prototype for class \"", className, "\", ", "Slots in prototype and not in class:", paste(extra, collapse=", ")) ## now check the elements of the prototype against the class definition slotDefs <- getSlots(ClassDef); slotNames <- names(slotDefs) pnames <- names(attributes(prototype)) pnames <- pnames[!is.na(match(pnames, slotNames))] check <- rep(FALSE, length(pnames)) for(what in pnames) { pwhat <- slot(prototype, what) if(!is(pwhat, slotDefs[[what]])) { if(is.null(pwhat)) { # warning("In class \"", className, # "\", the prototype for slot \"", what, "\" (slot class \"", # slotDefs[[what]], # "\") is NULL; new() will fail for this class unless this slot is supplied in the call") } else check[match(what, pnames)] <- TRUE } } if(any(check)) stop("In making the prototype for class \"", className, "\" elements of the prototype failed to match the corresponding slot class: ", paste(pnames[check], "(class \"", slotDefs[match(pnames[check], slotNames)], "\")", collapse = ", ")) prototype } newEmptyObject <- ## Utility function to create an empty object into which slots can be ## set. Currently just creates an empty list with class "NULL" ## ## Later version should create a special object reference that marks an ## object currently with no slots and no data. function() { value <- list() value } completeClassDefinition <- ## Completes the definition of Class, relative to the current environment ## ## The completed definition is stored in the session's class metadata, ## to be retrieved the next time that getClass is called on this class, ## and is returned as the value of the call. function(Class, ClassDef = getClassDef(Class), where, doExtends = TRUE) { ClassDef <- .completeClassSlots(ClassDef, where) immediate <- ClassDef@contains properties <- ClassDef@slots prototype <- makePrototypeFromClassDef(properties, ClassDef, immediate) virtual <- ClassDef@virtual validity <- ClassDef@validity access <- ClassDef@access package <- ClassDef@package extends <- if(doExtends) completeExtends(ClassDef, where = where) else ClassDef@contains subclasses <- if(doExtends) completeSubclasses(ClassDef, where = where) else ClassDef@subclasses if(is.na(virtual)) ## compute it from the immediate extensions, but all the properties virtual <- testVirtual(properties, immediate, prototype) ## modify the initial class definition object, rather than creating ## a new one, to allow extensions of "classRepresentation" ## Done by a separate function to allow a bootstrap version. ClassDef <- .mergeClassDefSlots(ClassDef, slots = properties, contains = extends, prototype = prototype, virtual = virtual, subclasses = subclasses) if(any(!is.na(match(names(ClassDef@subclasses), names(ClassDef@contains)))) && getOption("warn") > 0 ## NEEDED: a better way to turn on strict testing ) { bad <- names(ClassDef@subclasses)[!is.na(match(names(ClassDef@subclasses), names(ClassDef@contains)))] warning("Potential cycle in class inheritance: \"",Class, "\" has duplicates in superclasses and subclasses (", paste(bad, collapse = ", "), ")") } ClassDef } .completeClassSlots <- function(ClassDef, where) { properties <- ClassDef@slots simpleContains <- ClassDef@contains Class <- ClassDef@className package <- ClassDef@package ext <- getAllSuperClasses(ClassDef) ## ext has the names of all the direct and indirect superClasses but NOT those that do ## an explicit coerce (we can't conclude anything about slots, etc. from them) if(length(ext) > 0) { superProps <- vector("list", length(ext)+1) superProps[[1]] <- properties for(i in seq(along=ext)) { eClass <- ext[[i]] if(isClass(eClass, where = where)) superProps[[i+1]] <- getClassDef(eClass, where = where)@slots } properties <- unlist(superProps, recursive = FALSE) ## check for conflicting slot names if(any(duplicated(allNames(properties)))) { duped <- duplicated(names(properties)) #TEMPORARY -- until classes are completed in place & we have way to match non-inherited slots properties <- properties[!duped] # dupNames <- unique(names(properties)[duped]) # if(!is.na(match(".Data", dupNames))) { # dataParts <- seq(along=properties)[names(properties) == ".Data"] # dupNames <- dupNames[dupNames != ".Data"] # ## inherited data part classes are OK but should be consistent # dataPartClasses <- unique(as.character(properties[dataParts])) # if(length(dataPartClasses)>1) # warning("Inconsistent data part classes inherited (", # paste(dataPartClasses, collapse = ", "), # "): coercion to some may fail") # ## remove all but the first .Data # properties <- properties[-dataParts[-1]] # } # if(length(dupNames)>0) { # dupClasses <- logical(length(superProps)) # for(i in seq(along = superProps)) { # dupClasses[i] <- !all(is.na(match(dupNames, names(superProps[[i]])))) # } # stop(paste("Duplicate slot names: slots ", # paste(dupNames, collapse =", "), "; see classes ", # paste(c(Class, ext)[dupClasses], collapse = ", "), sep="")) # } } } ClassDef@slots <- properties ClassDef } .uncompleteClassDefinition <- function(ClassDef, slotName) { if(missing(slotName)) { ClassDef <- Recall(ClassDef, "contains") Recall(ClassDef, "subclasses") } else { prev <- slot(ClassDef, slotName) if(length(prev)>0) { indir <- sapply(prev, .isIndirectExtension) slot(ClassDef, slotName) <- slot(ClassDef, slotName)[!indir] } ClassDef } } .isIndirectExtension <- function(object) { is(object, "SClassExtension") && length(object@by) > 0 } .mergeSlots <- function(classDef1, classDef2) { } getAllSuperClasses <- ## Get the names of all the classes that this class definition extends. ## ## A utility function used to complete a class definition. It returns all the ## superclasses reachable from this class, in depth-first order (which is the order ## used for matching methods); that is, the first direct superclass followed by all its ## superclasses, then the next, etc. (The order is relevant only in the case that ## some of the superclasses have multiple inheritance.) ## ## The list of superclasses is stored in the extends property of the session metadata. ## User code should not need to call getAllSuperClasses directly; instead, use getClass()@contains ## (which will complete the definition if necessary). function(ClassDef, simpleOnly = TRUE) { temp <- superClassDepth(ClassDef, simpleOnly = simpleOnly) unique(temp$label[sort.list(temp$depth)]) } superClassDepth <- ## all the superclasses of ClassDef, along with the depth of the relation ## Includes the extension definitions, but these are not currently used by ## getAllSuperClasses function(ClassDef, soFar = ClassDef@className, simpleOnly = TRUE ) { ext <- ClassDef@contains ## remove indirect and maybe non-simple superclasses (latter for inferring slots) ok <- rep(TRUE, length(ext)) for(i in seq(along=ext)) { exti <- ext[[i]] if(.isIndirectExtension(exti) || (simpleOnly && ! exti @simple)) ok[i] <- FALSE } ext <- ext[ok] immediate <- names(ext) immediate <- immediate[is.na(match(immediate, soFar))] soFar <- c(soFar, immediate) super <- list(label=immediate, depth = rep(1, length(immediate)), ext = ext) for(i in seq(along = immediate)) { what <- immediate[[i]] if(!is.na(match(what, soFar))) ## watch out for loops (e.g., matrix/array have mutual is relationship) next exti <- ext[[i]] if(!is(exti, "SClassExtension")) stop("In definition of class \"", ClassDef@className, "\" information for superclass \"", what, "\" is of class \"", class(exti), "\" (expected \"SClassExtension\"") superClass <- getClassDef(exti@superClass, package = exti@package) if(isClass(what)) { if(is.null(superClass)) { warning("class \"", ClassDef@className, "\" extends an undefined class,\"", what, "\"") next } more <- Recall(superClass, soFar) whatMore <- more$label if(!all(is.na(match(whatMore, soFar)))) { ## elminate classes reachable by more than one path ## (This is allowed in the model, however) ok <- is.na(match(whatMore, soFar)) more$depth <- more$depth[ok] more$label <- more$label[ok] more$ext <- more$ext[ok] whatMore <- whatMore[ok] } if(length(whatMore) > 0) { soFar <- c(soFar, whatMore) super$depth <- c(super$depth, 1+more$depth) super$label <- c(super$label, more$label) super$ext <- c(super$ext, more$ext) } } else warning("Class information incomplete: class \"", what, "\" not defined") } super } isVirtualClass <- ## Is the named class a virtual class? A class is virtual if explicitly declared to ## be, and also if the class is not formally defined. function(Class, where = topenv(parent.frame())) { if(isClassDef(Class)) Class@virtual else if(isClass(Class, where = where)) getClass(Class, where = where)@virtual else TRUE } assignClassDef <- ## assign the definition of the class to the specially named object function(Class, def, where = .GlobalEnv) { if(!is(def,"classRepresentation")) stop("Trying to assign an object of class \"", class(def), "\" as the definition of class \"", Class, "\": must supply a \"classRepresentation\" object.") clName <- def@className; attributes(clName) <- NULL if(!.identC(Class, clName)) stop("Assigning as \"", Class, "\" a class representation with internal name ", def@className, "\"") assign(classMetaName(Class), def, where) } .InitClassDefinition <- function(where) { defSlots <- list(slots = "list", contains = "list", virtual = "logical", prototype = "ANY", validity = "OptionalFunction", access = "list", ## the above are to conform to the API; now some extensions className = "character", package = "character", subclasses = "list", versionKey = "externalptr", ## or "integer"?? sealed = "logical") ## the prototype of a new class def'n: virtual class with NULL prototype protoSlots <- list(slots=list(), contains=list(), virtual=NA, prototype = NULL, validity = NULL, access = list(), className = character(), package = character(), subclasses = list(), versionKey = .newExternalptr(), sealed = FALSE) proto <- list() pnames <- names(protoSlots) for(i in seq(along=protoSlots)) slot(proto, pnames[[i]], FALSE) <- protoSlots[[i]] class(proto) <- "classRepresentation" object <- list() class(object) <- "classRepresentation" slot(object, "slots", FALSE) <- defSlots slot(object, "className", FALSE) <- "classRepresentation" slot(object, "virtual", FALSE) <- FALSE slot(object, "prototype", FALSE) <- proto for(what in c("contains", "validity", "access", "hasValidity", "subclasses", "versionKey")) slot(object, what, FALSE) <- elNamed(protoSlots, what) slot(object, "sealed", FALSE) <- TRUE slot(object, "package", FALSE) <- getPackageName(where) ## assignClassDef("classRepresentation", object, where) assign(classMetaName("classRepresentation"), object, where) } .initClassSupport <- function(where) { setClass("classPrototypeDef", representation(object = "ANY", slots = "character", dataPart = "logical"), sealed = TRUE, where = where) } newBasic <- ## the implementation of the function `new' for basic classes. ## ## See `new' for the interpretation of the arguments. function(Class, ...) { msg <- NULL value <- switch(Class, "NULL" = return(NULL), ## can't set attr's of NULL in R "logical" =, "numeric" =, "character" =, "complex" =, "integer" =, "double" =, "list" = as.vector(c(...), Class), "expression" = eval(substitute(expression(...))), "externalptr" = { if(nargs() > 1) stop("externalptr objects cannot be initialized from new()") .newExternalptr() }, "single" = as.single(c(...)), ## note on array, matrix: not possible to be compatible with ## S-Plus on array, unless R allows 0-length .Dim attribute "array" = (if(length(list(...)) > 0) array(...) else structure(numeric(), .Dim =0)), "matrix" = (if (length(list(...)) > 0) matrix(...) else matrix(0, 0, 0)), "ts" = ts(...), { args <- list(...) if(length(args) == 1 && is(args[[1]], Class)) { value <- as(args[[1]], Class) } else if(is.na(match(Class, .BasicClasses))) msg <- paste("Calling new() on an undefined and non-basic class (\"", Class, "\")", sep="") else msg <- paste("Initializing objects from class \"", Class, "\" with these arguments is not supported", sep ="") } ) if(is.null(msg)) value else stop(msg) } defaultPrototype <- ## the starting prototype for a non-virtual class ## Should someday be a non-vector sexp type function() list() reconcilePropertiesAndPrototype <- ## makes a list or a structure look like a prototype for the given class. ## ## Specifically, returns a structure with attributes corresponding to the slot ## names in properties and values taken from prototype if they exist there, from ## `new(classi)' for the class, `classi' of the slot if that succeeds, and `NULL' ## otherwise. ## ## The prototype may imply slots not in the properties list. It is not required that ## the extends classes be define at this time. Should it be? function(name, properties, prototype, superClasses, where) { ## the StandardPrototype should really be a type that doesn't behave like ## a vector. But none of the existing SEXP types work. Someday ... StandardPrototype <- defaultPrototype() slots <- validSlotNames(allNames(properties)) dataPartClass <- elNamed(properties, ".Data") if(!is.null(dataPartClass) && is.null(.validDataPartClass(dataPartClass, name))) stop("In defining class \"", name, "\", the supplied data part class, \"", dataPartClass, "\" is not valid (must be a basic class or a virtual class combining basic classes)") if((!is.null(dataPartClass) || length(superClasses) > 0) && is.na(match("VIRTUAL", superClasses))) { ## Look for a data part in the super classes, either an inherited ## .Data slot, or a basic class. Uses the first possibility, warns of conflicts for(cl in superClasses) { thisDataPart <- .validDataPartClass(cl, name) if(!is.null(thisDataPart)) { if(is.null(dataPartClass)) { if(!is.na(match(thisDataPart, c("NULL", "environment")))) warning("Class \"", thisDataPart, "\" cannot be used as the data part of another class") else dataPartClass <- thisDataPart } else if(!extends(dataPartClass, thisDataPart) && !isVirtualClass(thisDataPart, where = where)) warning("More than one possible class for the data part: using \"", dataPartClass, "\" rather than \"", thisDataPart, "\"") } } if(length(dataPartClass) > 0) { if(is.na(match(".Data", slots))) { properties <- c(list(".Data"= dataPartClass), properties) slots <- names(properties) } else if(!extends(elNamed(properties, ".Data"), dataPartClass)) stop(paste("Conflicting definition of data part: .Data = \"", elNamed(properties, ".Data"),"\", super class implies \"", dataPartClass, "\"", sep="")) pslots <- NULL if(is.null(prototype)) { if(isVirtualClass(dataPartClass, where = where)) ## the equivalent of new("vector") prototype <- newBasic("logical") else prototype <- new(dataPartClass) } else { if(is(prototype, "classPrototypeDef")) { hasDataPart <- identical(prototype@dataPart, TRUE) if(!hasDataPart) { newObject <- new(dataPartClass) pobject <- prototype@object ## small amount of head-standing to preserve ## any attributes in newObject & not in pobject anames <- names(attributes(pobject)) attributes(newObject)[anames] <- attributes(pobject) prototype@object <- newObject } else if(!is(prototype@object, dataPartClass)) stop("A prototype object was supplied with object slot of class \"", class(prototype@object), "\", but the class definition requires an object that is class \"", dataPartClass, "\"") } else if(!is(prototype, dataPartClass)) stop("A prototype was supplied of class \"", class(prototype), "\", but the class definition requires an object that is class \"", dataPartClass, "\"") } } if(is.null(prototype)) { ## non-vector (may extend NULL) prototype <- StandardPrototype } } ## check for conflicts in the slots allProps <- properties for(i in seq(along=superClasses)) { cl <- superClasses[[i]] clDef <- getClassDef(cl, where) if(is(clDef, "classRepresentation")) { theseProperties <- getSlots(clDef) theseSlots <- names(theseProperties) theseSlots <- theseSlots[theseSlots == ".Data"] # handled already dups <- !is.na(match(theseSlots, allProps)) for(dup in theseSlots[dups]) if(!extends(elNamed(allProps, dup), elNamed(theseProperties, dup))) stop(paste("Slot \"", dup, "\" in class \"", name, "\" currently defined (or inherited) as \"", elNamed(allProps, dup), "\", conflicts with an inherited definition in class \"", cl, "\"", sep="")) theseSlots <- theseSlots[!dups] if(length(theseSlots)>0) allProps[theseSlots] <- theseProperties[theseSlots] } else stop(paste("Class \"", name, "\" extends an undefined class (\"", cl, "\"", sep="")) } if(is.null(dataPartClass)) { if(is(prototype, "classPrototypeDef")) {} else { if(is.list(prototype)) prototype <- do.call("prototype", prototype) if(is.null(prototype)) prototype <- StandardPrototype } } else { dataPartDef <- getClass(dataPartClass) if((is.na(match(dataPartClass, .BasicClasses)) && !isVirtualClass(dataPartDef)) || length(dataPartDef@slots) > 0) stop(paste("\"", dataPartClass, "\" is not eligible to be the data part of another class (must be a basic class or a virtual class with no slots", sep="")) if(is(prototype, "classPrototypeDef")) {} else if(is(prototype, dataPartClass)) { if(is(prototype, "list") && length(names(prototype)) > 0) warning("prototype is a list with named elements (could be ambiguous): better to use function prototype() to avoid trouble.") } else if(is.list(prototype)) prototype <- do.call("prototype", prototype) } ## pnames will be the names explicitly defined in the prototype if(is(prototype, "classPrototypeDef")) { pnames <- prototype@slots prototype <- prototype@object } else pnames <- allNames(attributes(prototype)) ## now set the slots not yet in the prototype object. ## An important detail is that these are ## set using slot<- with check=FALSE (because the slot will not be there already) ## what <- is.na(match(slots, pnames)) what <- seq(along=properties) props <- properties[what] what <- slots[what] for(i in seq(along=what)) { propName <- el(what, i) if(!identical(propName, ".Data") && is.null(attr(prototype, propName))) slot(prototype, propName, FALSE) <- tryNew(el(props, i)) } list(properties = properties, prototype = prototype) } tryNew <- ## Tries to generate a new element from this class, but if the attempt fails ## (as, e.g., when the class is undefined or virtual) just returns NULL. ## ## This is inefficient and also not a good idea when actually generating objects, ## but is useful in the initial definition of classes. function(Class) { if(!isClass(Class) || isVirtualClass(Class)) return(NULL) value <- trySilent(new(Class)) if(is(value, "try-error")) NULL else value } empty.dump <- function() list() isClassDef <- function(object) is(object, "classRepresentation") showClass <- ## print the information about a class definition. If complete==TRUE, include the ## indirect information about extensions. function(Class, complete = TRUE, propertiesAreCalled = "Slots") { if(isClassDef(Class)) { ClassDef <- Class Class <- ClassDef@className } else if(complete) ClassDef <- getClass(Class) else ClassDef <- getClassDef(Class) if(identical(ClassDef@virtual, TRUE)) cat("Virtual Class\n") x <- ClassDef@slots if(length(x)>0) { n <- length(x) cat("\n",propertiesAreCalled, ":\n", sep="") text <- format(c(names(x), as.character(x)), justify="right") text <- matrix(text, nrow =2, ncol = n, byrow = TRUE) dimnames(text) <- list(c("Name:", "Class:"), rep("", n)) print(text, quote = FALSE) } else cat("\nNo ", propertiesAreCalled, ", prototype of class \"", .class1(ClassDef@prototype), "\"\n", sep="") ext <- ClassDef@contains if(length(ext)>0) { cat("\nExtends: ") showExtends(ext) } ext <- ClassDef@subclasses if(length(ext)>0) { cat("\nKnown Subclasses: ") showExtends(ext) } } showExtends <- ## print the elements of the list of extensions. Also used to print ## extensions recorded in the opposite direction, via a subclass list function(ext, printTo = stdout()) { what <- names(ext) how <- character(length(ext)) for(i in seq(along=ext)) { eli <- el(ext, i) if(is(eli, "SClassExtension")) { if(length(eli@by) > 0) how[i] <- paste("by class", paste("\"", eli@by, "\"", sep="", collapse = ", ")) else if(identical(eli@dataPart, TRUE)) how[i] <- "from data part" else how[i] <- "directly" if(!eli@simple) { if(is.function(eli@test) && !identical(body(eli@test), TRUE)) { if(is.function(eli@coerce)) how[i] <- paste(how[i], ", with explicit test and coerce", sep="") else how[i] <- paste(how[i], ", with explicit test", sep="") } else if(is.function(eli@coerce)) how[i] <- paste(how[i], ", with explicit coerce", sep="") } } } if(identical(printTo, FALSE)) list(what = what, how = how) else if(all(nchar(how)==0)|| all(how == "directly")) { what <- paste('"', what, '"', sep="") if(length(what)>1) what <- c(paste(what[-length(what)], ",", sep=""), what[[length(what)]]) cat(file = printTo, what, fill=TRUE) } else cat(file = printTo, "\n", paste("Class \"", what, "\", ", how, "\n", sep=""), sep="") } print.classRepresentation <- function(x, ...) showClass(x, propertiesAreCalled="Slots") ## bootstrap definition to be used before getClass() works possibleExtends <- function(class1, class2) .identC(class1, class2) || .identC(class2, "ANY") .possibleExtends <- ## Find the information that says whether class1 extends class2, ## directly or indirectly. This can be either a logical value or ## an object containing various functions to test and/or coerce the relationship. ## TODO: convert into a generic function w. methods WHEN dispatch is really fast! function(class1, class2) { if(.identC(class1, class2) || .identC(class2, "ANY")) return(TRUE) i <- NA if(isClass(class1)) { ClassDef <- getClass(class1) ext <- ClassDef@contains i <- match(class2, names(ext)) } else i <- NA if(is.na(i)) { if(isClass(class2)) { classDef2 <- getClass(class2) ext <- classDef2@subclasses if(!.identC(class(classDef2), "classRepresentation") && isClassUnion(classDef2)) return(any(duplicated(c(class1, names(ClassDef@contains), names(ext))))) i <- match(class1, names(ext)) } } if(is.na(i)) FALSE else el(ext, i) } ## complete the extends information in the class definition, by following ## transitive chains. ## ## Elements in the immediate extends list may be added and current elements may be ## replaced, either by replacing a conditional relation with an unconditional ## one, or by adding indirect relations. ## completeExtends <- function(ClassDef, class2, extensionDef, where) { ## check for indirect extensions => already completed ext <- ClassDef@contains for(i in seq(along = ext)) { if(.isIndirectExtension(ext[[i]])) { ClassDef <- .uncompleteClassDefinition(ClassDef, "contains") break } } exts <- .walkClassGraph(ClassDef, "contains", where) if(length(exts)>0) { ## sort the extends information by depth (required for method dispatch) superClassNames <- getAllSuperClasses(ClassDef) exts <- exts[superClassNames] } if(!missing(class2) && length(ClassDef@subclasses) > 0) { subclasses <- .transitiveSubclasses(ClassDef@className, class2, extensionDef, ClassDef@subclasses) ## insert the new is relationship, but without any recursive completion ## (asserted not to be needed if the subclass slot is complete) for(i in seq(along = subclasses)) { obji <- subclasses[[i]] ## don't override existing relations ## TODO: have a metric that picks the "closest" relationship if(!extends(obji@subClass, class2)) setIs(obji@subClass, class2, extensionObject = obji, doComplete = FALSE, where = where) } } exts } completeSubclasses <- function(ClassDef, class2, extensionDef, where) { ## check for indirect extensions => already completed ext <- ClassDef@subclasses for(i in seq(along = ext)) { if(.isIndirectExtension(ext[[i]])) { ClassDef <- .uncompleteClassDefinition(ClassDef, "subclasses") break } } subclasses <- .walkClassGraph(ClassDef, "subclasses", where) if(!missing(class2) && length(ClassDef@contains) > 0) { contains <- .transitiveExtends(class2, ClassDef@className, extensionDef, ClassDef@contains) ## insert the new is relationship, but without any recursive completion ## (asserted not to be needed if the subclass slot is complete) for(i in seq(along = contains)) { obji <- contains[[i]] ## don't override existing relations ## TODO: have a metric that picks the "closest" relationship if(!extends(class2, obji@superClass)) setIs(class2, obji@superClass, extensionObject = obji, doComplete = FALSE, where = where) } } subclasses } ## utility function to walk the graph of super- or sub-class relationships .walkClassGraph <- function(ClassDef, slotName, where) { ext <- slot(ClassDef, slotName) className <- ClassDef@className ## the super- vs sub-class is identified by the slotName superClassCase <- identical(slotName, "contains") fromTo <- ClassDef@className what <- names(ext) for(i in seq(along=ext)) { by <- what[[i]] if(isClass(by, where = where)) { byDef <- getClass(by, where = where) exti <- slot(byDef, slotName) ## add in those classes not already known to be super/subclasses exti <- exti[is.na(match(names(exti), what))] if(length(exti)> 0) { if(superClassCase) exti <- .transitiveExtends(fromTo, by, ext[[i]], exti) else exti <- .transitiveSubclasses(by, fromTo, ext[[i]], exti) ext <- c(ext, exti) } } else stop("The ", if(superClassCase) "superClass" else "subClass", " list for class, \"", className, "\", includes an undefined class, \"", .className(by), "\"") } what <- names(ext) ## the direct and indirect extensions if(!all(is.na(match(what, className)))) { ok <- is.na(match(what, className)) ## A class may not contain itself, directly or indirectly ## but a non-simple cyclic relation, involving setIs, is allowed for(i in seq(along = what)[!ok]) { exti <- ext[[i]] simple <- exti@simple if(simple) { fromDef <- getClassDef(exti@superClass, package = exti@package) extBack <- elNamed(slot(fromDef, slotName), className) simple <- is(extBack, "SClassExtension") && extBack@simple } if(simple) { if(superClassCase) { whatError <- "contain itself" relation <- "contains" } else { whatError <- "have itself as a subclass" relation <- "has subclass" } stop("Class \"", className, "\" may not ", whatError, ": it ", relation, " class \"", fromTo, "\", with a circular relation back to \"", className, "\"") } } ## but sub/superclasses can enter multiple ways, with all but the first ## ignored. ext <- ext[ok] } ext } classMetaName <- ## a name for the object storing this class's definition function(name) methodsPackageMetaName("C", name) ##FIXME: C code should take multiple strings in name so the paste() call in ## mlistMetaName, etc. could be avoided. methodsPackageMetaName <- ## a name mangling device to simulate the meta-data in S4 function(prefix, name) ## paste(".", prefix, name, sep="__") # too slow .Call("R_methodsPackageMetaName", prefix, name, PACKAGE = "methods") requireMethods <- ## Require a subclass to implement methods for the generic functions, for this signature. ## ## For each generic, `setMethod' will be called to define a method that throws an error, ## with the supplied message. ## ## The `requireMethods' function allows virtual classes to require actual classes that ## extend them to implement methods for certain functions, in effect creating an API ## for the virtual class. Otherwise, default methods for the corresponding function would ## be called, resulting in less helpful error messages or (worse still) silently incorrect ## results. function(functions, signature, message = paste("No method defined for signature", paste(signature, collapse=", "))) { for(f in functions) { method <- getMethod(f, optional = TRUE) if(!is.function(method)) method <- getGeneric(f) body(method) <- substitute(stop(MESSAGE), list(MESSAGE=message)) environment(method) <- .GlobalEnv setMethod(f, signature, method) } } getSlots <- function(x, complete = TRUE) { if(isClassDef(x)) classDef <- x else classDef <- (if(complete) getClass(x) else getClassDef(x)) props <- classDef@slots value <- as.character(props) names(value) <- names(props) value } ## check for reserved slot names. Currently only "class" is reserved validSlotNames <- function(names) { i <- match("class", names) if(is.na(i)) names else stop("\"class\" is a reserved slot name and cannot be redefined") } ### utility function called from primitive code for "@" getDataPart <- function(object) { classDef <- getClass(class(object)) temp <- getSlots(classDef) slots <- c("class", names(temp)) attrVals <- attributes(object) attrs <- names(attrVals) if(identical(slots, attrs)) # basic vector as .Data attributes(object) <- NULL else { attrs <- attrs[is.na(match(attrs, slots))] attributes(object) <- attrVals[attrs] ## matrix, array, or ts are currently (R 1.7) the only other possible .Data's if(!is.na(match("tsp", attrs))) # set the class (S3-style) to "ts" class(object) <- "ts" } object } setDataPart <- function(object, value) { classDef <- getClass(class(object)) dataClass <- elNamed(getSlots(classDef), ".Data") if(is.null(dataClass)) stop(paste("class \"", class(object), "\" does not have a data part (a .Data slot) defined", sep="")) value <- as(value, dataClass) .mergeAttrs(value, object) } .validDataPartClass <- function(cl, inClass) { if(is(cl, "classRepresentation")) { ClassDef <- cl cl <- ClassDef@className } else ClassDef <- getClass(cl, TRUE) value <- elNamed(ClassDef@slots, ".Data") if(is.null(value)) { if(.identC(cl, "structure")) value <- "vector" else if((extends(cl, "vector") || !is.na(match(cl, .BasicClasses)))) value <- cl else if(extends(cl, "oldClass") && isVirtualClass(cl)) { if(.identC(cl, "ts")) value <- cl else warning("Old-style (``S3'') class \"", cl, "\" supplied as a superclass of \"", .className(inClass), "\", but no automatic conversion will be peformed for S3 classes") } else if(identical(ClassDef@virtual, TRUE) && length(ClassDef@slots) == 0 && length(ClassDef@subclasses) > 0 ) { ## look for a union of basic classes subclasses <- ClassDef@subclasses what <- names(subclasses) value <- cl for(i in seq(along = what)) { ext <- subclasses[[i]] ##TODO: the following heuristic test for an "original" ## subclass should be replaced by a suitable class (extending SClassExtension) if(length(ext@by) == 0 && ext@simple && !ext@dataPart && is.na(match(what[i], .BasicClasses))) { value <- NULL break } } } } value } .mergeAttrs <- function(value, object, explicit = NULL) { supplied <- attributes(object) if(length(explicit)>0) supplied[names(explicit)] <- explicit valueAttrs <- attributes(value) if(length(valueAttrs) == 0) # nothing to protect attributes(value) <- supplied else { valueAttrs$class <- NULL # copy in class if it's supplied # otherwise, don't overwrite existing attrs for(what in names(supplied)) if(is.null(valueAttrs[[what]])) attr(value, what) <- supplied[[what]] } value } .newExternalptr <- function() .Call("R_externalptr_prototype_object", PACKAGE = "methods") ## modify the list moreExts, currently from class `by', to represent ## extensions instead from an originating class; byExt is the extension ## from that class to `by' .transitiveExtends <- function(from, by, byExt, moreExts) { what <- names(moreExts) for(i in seq(along = moreExts)) { toExt <- moreExts[[i]] to <- what[[i]] toExt <- .combineExtends(byExt, toExt, by, to) moreExts[[i]] <- toExt } moreExts } .transitiveSubclasses <- function(by, to, toExt, moreExts) { what <- names(moreExts) for(i in seq(along = moreExts)) { byExt <- moreExts[[i]] byExt <- .combineExtends(byExt, toExt, by, to) moreExts[[i]] <- byExt } moreExts } .combineExtends <- function(byExt, toExt, by, to) { ## construct the composite coerce method, taking into account the strict= ## argument. f <- toExt@coerce fR <- toExt@replace toExpr <- body(f) fBy <- byExt@coerce byExpr <- body(fBy) ## if both are simple extensions, so is the composition if(byExt@simple && toExt@simple) { expr <- (if(byExt@dataPart) substitute({if(strict) from <- from@.Data; EXPR}, list(EXPR = toExpr)) else if(toExt@dataPart) substitute({from <- EXPR; if(strict) from@.Data}, list(EXPR = byExpr)) else (if(identical(byExpr, quote(from)) && identical(toExpr, quote(from))) quote(from) else substitute({from <- E1; E2}, list(E1 = byExpr, E2 = toExpr)) ) ) body(f, envir = environment(f)) <- expr } else { toExt@simple <- FALSE if(!identical(byExpr, quote(from))) body(f, envir = environment(f)) <- substitute( {from <- as(from, BY, strict = strict); TO}, list(BY = by, TO = toExpr)) } toExt@coerce <- f f <- toExt@test toExpr <- body(f) byExpr <- body(byExt@test) ## process the test code if(!identical(byExpr, TRUE)) { if(!identical(toExpr, TRUE)) body(f, envir = environment(f)) <- substitute((BY) && (TO), list(BY = byExpr, TO = toExpr)) else body(f, envir = environment(f)) <- byExpr } toExt@test <- f f <- byExt@replace byExpr <- body(f) ## Is there a danger of infinite loop below? expr <- substitute({.value <- as(from, BY); as(.value, TO) <- value; value <- .value; BYEXPR}, list(BY=by, TO = to, BYEXPR = byExpr)) body(f, envir = environment(f)) <- expr toExt@replace <- f toExt@by <- toExt@subClass toExt@subClass <- byExt@subClass toExt } ## construct the expression that implements the computations for coercing ## an object to one of its superclasses ## The fromSlots argument is provided for calls from makeClassRepresentation ## and completeClassDefinition, ## when the fromClass is in the process of being defined, so slotNames() would fail .simpleCoerceExpr <- function(fromClass, toClass, fromSlots, toDef) { toSlots <- names(toDef@slots) sameSlots <- (length(fromSlots) == length(toSlots) && !any(is.na(match(fromSlots, toSlots)))) if(sameSlots) expr <- substitute({class(from) <- CLASS; from}, list(CLASS = toClass)) else { if(length(toSlots)==0) { ## either a basic class or something with the same representation if(is.na(match(toClass, .BasicClasses))) expr <- substitute({ attributes(from) <- NULL; class(from) <- CLASS; from}, list(CLASS=toClass)) else if(isVirtualClass(toDef)) expr <- quote(from) else { ## a basic class; a vector type, matrix, array, or ts switch(toClass, matrix = , array = { expr <- quote({.dm <- dim(from); .dn <- dimnames(from) attributes(from) <- NULL; dim(from) <- .dm dimnames(from) <- .dn; from}) }, ts = { expr <- quote({.tsp <- tsp(from); attributes(from) <- NULL tsp(from) <- .tsp; class(from) <- "ts"; from}) }, expr <- quote({attributes(from) <- NULL; from}) ) } } else { expr <- substitute({ value <- new(CLASS) for(what in TOSLOTS) slot(value, what) <- slot(from, what) value }, list(CLASS=toClass, TOSLOTS = toSlots)) } } expr } ## the boot version of newClassRepresentation (does no checking on slots to avoid ## requiring method selection on coerce). newClassRepresentation <- function(...) { value <- new("classRepresentation") slots <- list(...) slotNames <- names(slots) for(i in seq(along = slotNames)) slot(value, slotNames[[i]], FALSE) <- slots[[i]] value } ## create a temporary definition of a class, but one that is distinguishable ## (by its class) from the real thing. See comleteClassDefinition .tempClassDef <- function(...) { value <- new("classRepresentation") slots <- list(...) slotNames <- names(slots) for(i in seq(along = slotNames)) slot(value, slotNames[[i]], FALSE) <- slots[[i]] value } ## the real version of newClassRepresentation, assigned in .First.lib .newClassRepresentation <- function(...) new("classRepresentation", ...) .insertExpr <- function(expr, el) { if(!is(expr, "{")) expr <- substitute({EXPR}, list(EXPR = expr)) expr[3:(length(expr)+1)] <- expr[2:length(expr)] expr[[2]] <- el expr } ## utility guaranteed to return only the first string of the class. ## Would not be needed if we dis-allowed S3 classes with multiple strings (or ## if the methods package version of class dropped the extra strings). .class1 <- function(x) class(x)[[1]] substituteFunctionArgs <- function(def, newArgs, args = formalArgs(def), silent = FALSE) { if(!identical(args, newArgs)) { n <- length(args) if(n != length(newArgs)) stop(paste("Trying to change the argument list of a function with ", n, " arguments to have arguments (", paste(newArgs, collapse = ", "), ")", sep="")) bdy <- body(def) ## check for other uses of newArgs checkFor <- newArgs[is.na(match(newArgs, args))] locals <- all.vars(bdy) if(length(checkFor) > 0 && any(!is.na(match(checkFor, locals)))) stop(paste("Get rid of variables in definition (", paste(checkFor[!is.na(match(checkFor, locals))], collapse = ", "), "); they conflict with the needed change to argument names (", paste(newArgs, collapse = ", "), ")", sep="")) ll <- vector("list", 2*n) for(i in seq(length = n)) { ll[[i]] <- as.name(args[[i]]) ll[[n+i]] <- as.name(newArgs[[i]]) } names(ll) <- c(args, newArgs) body(def, envir = environment(def)) <- substituteDirect(bdy, ll) if(!silent) message("Arguments in definition changed from (", paste(args, collapse = ", "), ") to (", paste(newArgs, collapse = ", "), ")") } def } .makeValidityMethod <- function(Class, validity) { if(is.null(validity)) { } else { if(!is(validity, "function")) stop(paste("A validity method must be a function of one argument, got an object of class \"", class(validity), "\"", sep="")) validity <- substituteFunctionArgs(validity, "object") } validity } # the bootstrap version of setting slots in completeClassDefinition .mergeClassDefSlots <- function(ClassDef, ...) { slots <- list(...); slotNames <- names(slots) for(i in seq(along = slots)) slot(ClassDef, slotNames[[i]], FALSE) <- slots[[i]] ClassDef } ## the real version: differs only in checking the slot values ..mergeClassDefSlots <- function(ClassDef, ...) { slots <- list(...); slotNames <- names(slots) for(i in seq(along = slots)) slot(ClassDef, slotNames[[i]]) <- slots[[i]] ClassDef } ### fix the annoying habit of R giving function definitions the local environment by default .gblEnv <- function(f) { environment(f) <- .GlobalEnv f } ## a utility for makePrototypeFromClassDef that causes inf. recursion if used too early ..isPrototype <- function(p)is(p, "classPrototypeDef") ## the dummy version .isPrototype <- function(p) FALSE .className <- function(cl) if(is(cl, "classRepresentation")) cl@className else as(cl, "character") ## bootstrap version: all classes and methods must be in the version of the methods ## package being built in the toplevel environment: MUST avoid require("methods") ! .requirePackage <- function(package) topenv(parent.frame()) ## real version of .requirePackage ..requirePackage <- function(package,useNamespace = FALSE) { if(.identC(package, ".GlobalEnv")) return(.GlobalEnv) if(.identC(package, "methods")) return(topenv(parent.frame())) # must have methods available if .requirePackage is called value <- package if(is.character(package)) value <- trySilent(loadNamespace(package)) if(is.environment(value)) return(value) if(exists(".packageName", .GlobalEnv, inherits=TRUE) && .identC(package, get(".packageName", .GlobalEnv))) return(.GlobalEnv) # kludge for running package code require(package, character.only = TRUE) .asEnvironmentPackage(package) } .classDefEnv <- function(classDef) { .requirePackage(classDef@package, TRUE) } .asEnvironmentPackage <- function(package) { if(identical(package, ".GlobalEnv")) .GlobalEnv else { ##FIXME: the paste should not be needed pkg <- paste("package", package, sep=":") as.environment(pkg) } }