| # File src/library/methods/R/RClassUtils.R |
| # Part of the R package, https://www.R-project.org |
| # |
| # Copyright (C) 1995-2019 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/ |
| |
| 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, where) |
| { |
| 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) { |
| enDef <- getClassDef(what, package=packageSlot(extends[[what]])) |
| if(!is.null(enDef) && isFALSE(enDef@virtual)) |
| return(FALSE) |
| } |
| } |
| (length(properties) == 0L && 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, where) |
| { |
| className <- ClassDef@className |
| snames <- names(slots) |
| ## try for a single superclass that is not virtual |
| supers <- names(extends) |
| ## virtual <- NA |
| dataPartClass <- elNamed(slots, ".Data") |
| prototype <- ClassDef@prototype |
| dataPartDone <- is.null(dataPartClass) || is(prototype, dataPartClass)# don't look for data part in supreclasses |
| ## 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) == 0L && !is.null(prototype)) |
| return(prototype) |
| for(i in seq_along(extends)) { |
| what <- el(supers, i) |
| exti <- extends[[i]] |
| if(isFALSE(exti@simple)) |
| 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, where=packageSlot(exti))) { |
| cli <- getClassDef(what, package=packageSlot(exti)) |
| 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)) { |
| for(slotName in slotsi) { |
| if(identical(slotName, ".Data")) { |
| if(!dataPartDone) { |
| prototype <- setDataPart(prototype, getDataPart(pri), FALSE) |
| dataPartDone <- TRUE |
| } |
| } |
| else if(is.na(match(slotName, pnames))) { |
| ## possible that the prototype already had this slot specified |
| ## If not, add it now. |
| slot(prototype, slotName, check=FALSE) <- |
| attr(pri, slotName) |
| pnames <- c(pnames, slotName) |
| } |
| } |
| } |
| else if(!dataPartDone && extends(cli, dataPartClass)) { |
| prototype <- setDataPart(prototype, pri, FALSE) |
| dataPartDone <- TRUE |
| } |
| } |
| } |
| if(length(slots) == 0L) |
| 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 |
| pslots <- |
| if(.identC(class(prototype), className)) |
| names(attributes(unclass(prototype))) |
| else if(isClass(class(prototype))) |
| names(getSlots(getClass(class(prototype)))) |
| ## else 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))) { |
| if(isClass(class(prototype), where = where)) { |
| prototypeClass <- getClass(class(prototype), where = where) |
| OK <- extends(prototypeClass, dataPartClass) |
| } |
| else |
| OK <- FALSE |
| if(isFALSE(OK)) |
| stop(gettextf("in constructing the prototype for class %s: prototype has class %s, but the data part specifies class %s", |
| dQuote(className), |
| dQuote(.class1(prototype)), |
| dQuote(dataPartClass)), |
| domain = NA) |
| } |
| 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; else insert NULL |
| slot(prototype, name, check = FALSE) <- tryNew(el(slots, j), where) |
| } |
| } |
| extra <- pnames[is.na(match(pnames, snames)) & !is.na(match(pnames, pslots))] |
| if(length(extra) && is.na(match("oldClass", supers))) |
| warning(gettextf("in constructing the prototype for class %s, slots in prototype and not in class: %s", |
| dQuote(className), |
| paste(extra, collapse=", ")), |
| domain = NA) |
| ## now check the elements of the prototype against the class definition |
| slotDefs <- ClassDef@slots; slotNames <- names(slotDefs) |
| pnames <- names(attributes(prototype)) |
| pnames <- pnames[!is.na(match(pnames, slotNames))] |
| check <- rep.int(FALSE, length(pnames)) |
| for(what in pnames) { |
| pwhat <- slot(prototype, what) |
| slotClass <- getClassDef(slotDefs[[what]], where) |
| if(is.null(slotClass) || !extends(class(pwhat), slotClass)) { |
| if(is.null(pwhat)) { # does this still apply?? |
| } |
| else if(is(slotClass, "classRepresentation") && |
| slotClass@virtual) {} # no nonvirtual prototype;e.g. S3 class |
| else |
| check[match(what, pnames)] <- TRUE |
| } |
| } |
| if(any(check)) |
| stop(gettextf("in making the prototype for class %s elements of the prototype failed to match the corresponding slot class: %s", |
| dQuote(className), |
| paste(pnames[check], |
| "(class", |
| .dQ(slotDefs[match(pnames[check], slotNames)]), |
| ")", |
| collapse = ", ")), |
| domain = NA) |
| 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, where) |
| 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, where) |
| ## 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(gettextf("potential cycle in class inheritance: %s has duplicates in superclasses and subclasses (%s)", |
| dQuote(Class), |
| paste(bad, collapse = ", ")), |
| domain = NA) |
| } |
| ClassDef |
| } |
| |
| .completeClassSlots <- function(ClassDef, where) { |
| properties <- ClassDef@slots |
| ## simpleContains <- ClassDef@contains |
| ## Class <- ClassDef@className |
| ## package <- ClassDef@package |
| ext <- getAllSuperClasses(ClassDef, TRUE) |
| ## 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)) { |
| superProps <- vector("list", length(ext)+1L) |
| superProps[[1L]] <- 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(anyDuplicated(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[-1L]] |
| # } |
| # 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 ", |
| # paste0(c(Class, ext)[dupClasses], collapse = ", "))) |
| # } |
| } |
| } |
| ## ensure that each element of the slots is a valid class reference |
| undefClasses <- rep.int(FALSE, length(properties)) |
| for(i in seq_along(properties)) { |
| cli <- properties[[i]] |
| if(is.null(packageSlot(cli))) { |
| cliDef <- getClassDef(cli, where) |
| if(is.null(cliDef)) |
| undefClasses[[i]] <- TRUE |
| else |
| packageSlot(properties[[i]]) <- cliDef@package |
| } |
| else { |
| cliDef <- getClassDef(cli) |
| if(is.null(cliDef)) |
| undefClasses[[i]] <- TRUE |
| } |
| } |
| if(any(undefClasses)) |
| warning(sprintf(gettext("undefined slot classes in definition of %s: %s", domain = "R-methods"), |
| .dQ(ClassDef@className), |
| paste0(names(properties)[undefClasses], gettextf("(class %s)", .dQ(unlist(properties, recursive = FALSE)[undefClasses])), collapse = ", ")), |
| call. = FALSE, domain = NA) |
| 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)) { |
| indir <- vapply(prev, .isIndirectExtension, NA) |
| slot(ClassDef, slotName) <- slot(ClassDef, slotName)[!indir] |
| } |
| ClassDef |
| } |
| } |
| |
| .isIndirectExtension <- function(object) { |
| is(object, "SClassExtension") && length(object@by) > 0 |
| } |
| |
| ## .mergeSlots <- function(classDef1, classDef2) { |
| ## } |
| |
| .directSubClasses <- function(ClassDef) { |
| ## no checks for input here: |
| if(length(sc <- ClassDef@subclasses)) { |
| names(sc)[vapply(sc, function(cc) cc@distance == 1L, NA)] |
| } ## else NULL |
| } |
| |
| 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.int(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) |
| notSoFar <- is.na(match(immediate, soFar)) |
| immediate <- immediate[notSoFar] |
| super <- list(label = immediate, depth = rep.int(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]] |
| soFar <- c(soFar, what) |
| if(!is(exti, "SClassExtension")) |
| stop(gettextf("in definition of class %s, information for superclass %s is of class %s (expected \"SClassExtension\")", |
| dQuote(ClassDef@className), |
| dQuote(what), |
| dQuote(class(exti))), |
| domain = NA) |
| superClass <- getClassDef(exti@superClass, package = exti@package) |
| if(is.null(superClass)) { |
| warning(gettextf("class %s extends an undefined class, %s", |
| dQuote(ClassDef@className), |
| dQuote(what)), |
| domain = NA) |
| 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)) { |
| 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) |
| } |
| } |
| super |
| } |
| |
| selectSuperClasses <- |
| function(Class, dropVirtual = FALSE, namesOnly = TRUE, |
| directOnly = TRUE, simpleOnly = directOnly, |
| where = topenv(parent.frame())) |
| { |
| ext <- if(isClassDef(Class)) |
| Class@contains |
| else if(isClass(Class, where = where)) |
| getClass(Class, where = where)@contains |
| else stop("'Class' must be a valid class definition or class") |
| |
| .selectSuperClasses(ext, dropVirtual = dropVirtual, namesOnly = namesOnly, |
| directOnly = directOnly, simpleOnly = simpleOnly) |
| } |
| |
| .selectSuperClasses <- function(ext, dropVirtual = FALSE, namesOnly = TRUE, |
| directOnly = TRUE, simpleOnly = directOnly) |
| { |
| ## No argument checking here |
| addCond <- function(xpr, prev) |
| if(length(prev)) substitute(P && N, list(P = prev, N = xpr)) else xpr |
| C <- if(dropVirtual) { |
| isVirtualExt <- function(x) |
| getClassDef(x@superClass, package=packageSlot(x))@virtual |
| quote(!isVirtualExt(exti)) |
| } else expression() |
| if(directOnly) C <- addCond(quote(length(exti@by) == 0), C) |
| if(simpleOnly) C <- addCond(quote(exti@simple), C) |
| if(length(C)) { |
| F <- function(exti){}; body(F) <- C |
| (if(namesOnly) names(ext) else ext)[vapply(ext, F, NA, USE.NAMES=FALSE)] |
| } |
| else if(namesOnly) names(ext) else ext |
| } |
| |
| inheritedSlotNames <- function(Class, where = topenv(parent.frame())) |
| { |
| ext <- if(isClassDef(Class)) |
| Class@contains |
| else if(isClass(Class, where = where)) |
| getClass(Class, where = where)@contains |
| supcl <- .selectSuperClasses(ext, namesOnly=FALSE) ## maybe simpleOnly = FALSE or use as argument? |
| supdefs <- lapply(supcl, function(s) { |
| getClassDef(s@superClass, package=packageSlot(s)) |
| }) |
| unique(unlist(lapply(supdefs, slotNames), use.names=FALSE)) |
| ## or just the non-simplified part (*with* names): |
| ## lapply(sapply(supcl, getClassDef, simplify=FALSE), slotNames) |
| } |
| |
| |
| 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, force = FALSE) { |
| if(!is(def,"classRepresentation")) |
| stop(gettextf("trying to assign an object of class %s as the definition of class %s: must supply a \"classRepresentation\" object", |
| dQuote(class(def)), |
| dQuote(Class)), |
| domain = NA) |
| clName <- def@className; attributes(clName) <- NULL |
| if(!.identC(Class, clName)) |
| stop(gettextf("assigning as %s a class representation with internal name %s", |
| dQuote(Class), |
| dQuote(def@className)), |
| domain = NA) |
| where <- as.environment(where) |
| mname <- classMetaName(Class) |
| if(exists(mname, envir = where, inherits = FALSE) && bindingIsLocked(mname, where)) { |
| if(force) |
| .assignOverBinding(mname, def, where, FALSE) |
| ## called this way, e.g., from setIs() |
| ## This is old and bad. Given that the cached version of the class |
| ## will have all the updated info about a class, we should leave |
| ## the locked version alone. But probably too late to fix without |
| ## a lot of flack. (JMC, 2013/10) |
| else |
| stop(gettextf("class %s has a locked definition in package %s", |
| dQuote(Class), sQuote(getPackageName(where)))) |
| } |
| else |
| assign(mname, def, where) |
| if(cacheOnAssign(where)) # will be FALSE for sourceEnvironment's |
| .cacheClass(clName, def, is(def, "ClassUnionRepresentation"), 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 <- defaultPrototype() |
| pnames <- names(protoSlots) |
| for(i in seq_along(protoSlots)) |
| slot(proto, pnames[[i]], FALSE) <- protoSlots[[i]] |
| classRepClass <- .classNameFromMethods("classRepresentation") |
| class(proto) <- classRepClass |
| object <- defaultPrototype() |
| class(object) <- classRepClass |
| slot(object, "slots", FALSE) <- defSlots |
| slot(object, "className", FALSE) <- classRepClass |
| 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) |
| ## the list of needed generics, initially empty (see .InitStructureMethods) |
| assign(".NeedPrimitiveMethods", list(), where) |
| } |
| |
| .classNameFromMethods <- function(what) { |
| packageSlot(what) <- "methods" |
| what |
| } |
| |
| .initClassSupport <- function(where) { |
| setClass("classPrototypeDef", representation(object = "ANY", slots = "character", dataPart = "logical"), |
| sealed = TRUE, where = where) |
| setClass(".Other", representation(label = "character"), |
| sealed = TRUE, where = where) # nonvirtual, nobody's subclass, see testInheritedMethods |
| ## a class and a method for reporting method selection ambiguities |
| setClass("MethodSelectionReport", |
| representation(generic = "character", allSelections = "character", target = "character", selected = "character", candidates = "list", note = "character"), |
| sealed = TRUE, where = where) |
| setClass("classGeneratorFunction", |
| representation(className = "character", package = "character"), |
| contains = "function") |
| } |
| |
| |
| 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" =, |
| "double" =, |
| "integer" =, |
| "raw" =, |
| "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(!missing(...)) array(...) else structure(numeric(), .Dim =0L), |
| "matrix" = if (!missing(...)) matrix(...) else matrix(0, 0L, 0L), |
| # "ts" = ts(...), |
| # break dependence on package stats |
| "ts" = if(!missing(...)) stats::ts(...) else |
| structure(NA, .Tsp = c(1, 1, 1), class = "ts"), |
| |
| ## otherwise: |
| { |
| args <- list(...) |
| if(length(args) == 1L && is(args[[1L]], Class)) { |
| value <- as(args[[1L]], Class) |
| } |
| else if(is.na(match(Class, .BasicClasses))) |
| msg <- paste0("Calling new() on an undefined and non-basic class (\"", |
| Class, "\")") |
| else |
| msg <- |
| gettextf("initializing objects from class %s with these arguments is not supported", |
| dQuote(Class)) |
| } |
| ) |
| if(is.null(msg)) |
| value |
| else |
| stop(msg, domain = NA) |
| } |
| |
| |
| ## this non-exported function turns on or off |
| ## the use of the S4 type as class prototype |
| .useS4Prototype <- function(on = TRUE, where = .methodsNamespace) { |
| if(on) |
| pp <- .Call(C_Rf_allocS4Object) |
| else |
| pp <- list() |
| .assignOverBinding(".defaultPrototype", where=where, pp, FALSE) |
| } |
| |
| defaultPrototype <- |
| ## the starting prototype for a non-virtual class |
| ## Should someday be a non-vector sexp type |
| function() |
| .defaultPrototype |
| |
| 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. |
| ## |
| 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") |
| dataPartValue <- FALSE |
| if(!is.null(dataPartClass) && is.null(.validDataPartClass(dataPartClass, where))) |
| stop(gettextf("in defining class %s, the supplied data part class, %s is not valid (must be a basic class or a virtual class combining basic classes)", |
| dQuote(name), dQuote(dataPartClass)), |
| domain = NA) |
| prototypeClass <- getClass(class(prototype), where = where) |
| if((!is.null(dataPartClass) || length(superClasses)) |
| && is.na(match("VIRTUAL", superClasses))) { |
| ## Look for a data part in the superclasses, either an inherited |
| ## .Data slot, or a basic class. Uses the first possibility, warns of conflicts |
| for(cl in superClasses) { |
| clDef <- getClassDef(cl, where = where) |
| if(is.null(clDef)) |
| stop(gettextf("no definition was found for superclass %s in the specification of class %s", |
| dQuote(cl), dQuote(name)), |
| domain = NA) |
| thisDataPart <- .validDataPartClass(clDef, where, dataPartClass) |
| if(!is.null(thisDataPart)) { |
| dataPartClass <- thisDataPart |
| if(!is.null(clDef@prototype)) { |
| protoClass <- class(clDef@prototype)[1L] # [1]: for (matrix, array) |
| newObject <- |
| if (protoClass %in% .AbnormalTypes) { |
| indirect <- .indirectAbnormalClasses[protoClass] |
| getClassDef(indirect)@prototype |
| } else clDef@prototype |
| dataPartValue <- TRUE |
| } |
| } |
| } |
| if(length(dataPartClass)) { |
| if(is.na(match(".Data", slots))) { |
| properties <- c(list(".Data"= dataPartClass), properties) |
| slots <- names(properties) |
| } |
| else if(!extends(elNamed(properties, ".Data"), dataPartClass)) |
| stop(gettextf("conflicting definition of data part: .Data = %s, superclass implies %s", |
| dQuote(elNamed(properties, ".Data")), |
| dQuote(dataPartClass)), |
| domain = NA) |
| ## pslots <- NULL |
| if(is.null(prototype)) { |
| if(dataPartValue) |
| prototype <- newObject |
| else if(isVirtualClass(dataPartClass, where = where)) |
| ## the equivalent of new("vector") |
| prototype <- newBasic("logical") |
| else |
| prototype <- new(dataPartClass) |
| prototypeClass <- getClass(class(prototype), where = where) |
| } |
| else { |
| if(extends(prototypeClass, "classPrototypeDef")) { |
| hasDataPart <- isTRUE(prototype@dataPart) |
| if(!hasDataPart) { |
| if(!dataPartValue) # didn't get a .Data object |
| 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(!extends(getClass(class(prototype@object), where = where) |
| , dataPartClass)) |
| stop(gettextf("a prototype object was supplied with object slot of class %s, but the class definition requires an object that is class %s", |
| dQuote(class(prototype@object)), |
| dQuote(dataPartClass)), |
| domain = NA) |
| } |
| else if(!extends(prototypeClass, dataPartClass)) |
| stop(gettextf("a prototype was supplied of class %s, but the class definition requires an object that is class %s", |
| dQuote(class(prototype)), |
| dQuote(dataPartClass)), |
| domain = NA) |
| } |
| } |
| if(is.null(prototype)) { ## non-vector (may extend NULL) |
| prototype <- StandardPrototype |
| } |
| } |
| ## check for conflicts in the slots |
| allProps <- properties |
| for(cl in superClasses) { |
| 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, names(allProps))) |
| for(dup in theseSlots[dups]) |
| if(!extends(elNamed(allProps, dup), elNamed(theseProperties, dup))) |
| stop(gettextf("Definition of slot %s, in class %s, as %s conflicts with definition, inherited from class %s, as %s", |
| sQuote(dup), |
| dQuote(name), |
| dQuote(elNamed(allProps, dup)), |
| dQuote(cl), |
| dQuote(elNamed(theseProperties, dup))), |
| domain = NA) |
| theseSlots <- theseSlots[!dups] |
| if(length(theseSlots)) |
| allProps[theseSlots] <- theseProperties[theseSlots] |
| } |
| else |
| stop(gettextf("class %s extends an undefined class (%s)", |
| dQuote(name), dQuote(cl)), |
| domain = NA) |
| } |
| undefinedPrototypeSlots <- setdiff(names(prototype), names(allProps)) |
| if (length(undefinedPrototypeSlots) > 0L) { |
| stop(gettextf("The prototype for class %s has undefined slot(s): %s", |
| dQuote(name), paste0("'", undefinedPrototypeSlots, "'", |
| collapse = ", "))) |
| } |
| if(is.null(dataPartClass)) { |
| if(extends(prototypeClass, "classPrototypeDef")) |
| {} |
| else { |
| if(is.list(prototype)) |
| prototype <- do.call("prototype", prototype) |
| if(is.null(prototype)) |
| prototype <- StandardPrototype |
| } |
| } |
| else { |
| dataPartDef <- getClass(dataPartClass) |
| checkDataPart <- !isXS3Class(dataPartDef) |
| if(checkDataPart) |
| checkDataPart <- |
| ((is.na(match(dataPartClass, .BasicClasses)) && |
| !isVirtualClass(dataPartDef)) || length(dataPartDef@slots)) |
| if(checkDataPart) |
| stop(gettextf("%s is not eligible to be the data part of another class (must be a basic class or a virtual class with no slots)", |
| dQuote(dataPartClass)), |
| domain = NA) |
| if(extends(prototypeClass, "classPrototypeDef")) |
| {} |
| else if(extends(prototypeClass, dataPartClass)) { |
| if(extends(prototypeClass, "list") && length(names(prototype))) |
| 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(extends(prototypeClass, "classPrototypeDef")) { |
| pnames <- prototype@slots |
| prototype <- prototype@object |
| if(length(superClasses) == 0L && any(is.na(match(pnames, slots)))) |
| stop(sprintf(ngettext(sum(is.na(match(pnames, slots))), |
| "named elements of prototype do not correspond to slot name: %s", |
| "named elements of prototype do not correspond to slot names: %s"), |
| paste(.dQ(pnames[is.na(match(pnames, slots))]), |
| collapse =", ")), |
| domain = NA) |
| } |
| 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] |
| nm <- names(attributes(prototype)) |
| for(i in seq_along(what)) { |
| propName <- el(what, i) |
| if(!identical(propName, ".Data") && !propName %in% nm) |
| # is.null(attr(prototype, propName))) |
| slot(prototype, propName, FALSE) <- tryNew(el(props, i), where) |
| } |
| list(properties = properties, prototype = prototype) |
| } |
| |
| tryNew <- |
| ## Tries to generate a new element from this class, but if |
| ## the class is undefined just returns NULL. |
| ## |
| ## For virtual classes, returns the class prototype |
| ## so that the object is valid member of class. |
| ## Otherwise tries to generate a new() object, but in rare |
| ## cases, this might fail if the install() method required |
| ## an argument, so this case is trapped as well. |
| function(Class, where) |
| { |
| ClassDef <- getClassDef(Class, where) |
| if(is.null(ClassDef)) |
| return(NULL) |
| else if(isTRUE(ClassDef@virtual)) |
| ClassDef@prototype |
| else tryCatch(new(ClassDef), |
| error = function(e) { |
| value <- ClassDef@prototype |
| class(value) <- ClassDef@className |
| 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) |
| cat(if(isTRUE(ClassDef@virtual)) "Virtual ", |
| "Class ", .dQ(Class), |
| ## Show the package if that is non-trivial: |
| if(nzchar(pkg <- ClassDef@package)) |
| c(" [", if(pkg != ".GlobalEnv") "package" else "in", " \"", pkg,"\"]"), |
| "\n", sep="") |
| x <- ClassDef@slots |
| if(length(x)) { |
| printPropertiesList(x, propertiesAreCalled) |
| } |
| else |
| cat("\nNo ", propertiesAreCalled, ", prototype of class \"", |
| .class1(ClassDef@prototype), "\"\n", sep="") |
| ext <- ClassDef@contains |
| if(length(ext)) { |
| cat("\nExtends: ") |
| showExtends(ext) |
| } |
| ext <- ClassDef@subclasses |
| if(length(ext)) { |
| cat("\nKnown Subclasses: ") |
| showExtends(ext) |
| } |
| } |
| |
| printPropertiesList <- function(x, propertiesAreCalled) { |
| if(length(x)) { |
| n <- length(x) |
| cat("\n",propertiesAreCalled, ":\n", sep="") |
| text <- format(c(names(x), as.character(x)), justify="right") |
| text <- matrix(text, nrow = 2L, ncol = n, byrow = TRUE) |
| dimnames(text) <- list(c("Name:", "Class:"), rep.int("", n)) |
| print(text, quote = FALSE) |
| } |
| } |
| |
| 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")) { |
| how[i] <- |
| if(length(eli@by)) |
| paste("by class", paste0("\"", eli@by, "\", distance ", |
| eli@distance, collapse = ", ")) |
| else if(isTRUE(eli@dataPart)) |
| "from data part" |
| else "directly" |
| if(!eli@simple) { |
| if(is.function(eli@test) && !isTRUE(body(eli@test))) { |
| how[i] <- |
| paste0(how[i], if(is.function(eli@coerce)) |
| ", with explicit test and coerce" else |
| ", with explicit test") |
| } |
| else if(is.function(eli@coerce)) |
| how[i] <- paste0(how[i], ", with explicit coerce") |
| } |
| } |
| } |
| if(isFALSE(printTo)) |
| list(what = what, how = how) |
| else if(all(!nzchar(how)) || all(how == "directly")) { |
| what <- paste0('"', what, '"') |
| if(length(what) > 1L) |
| what <- c(paste0(what[-length(what)], ","), what[[length(what)]]) |
| cat(file = printTo, what, fill=TRUE) |
| } |
| else cat(file = printTo, "\n", |
| paste0("Class \"", what, "\", ", how, "\n"), sep = "") |
| } |
| |
| |
| |
| printClassRepresentation <- |
| function(x, ...) |
| showClass(x, propertiesAreCalled="Slots") |
| |
| ## bootstrap definition to be used before getClass() works |
| possibleExtends <- function(class1, class2, ClassDef1, ClassDef2) |
| .identC(class1, class2) || .identC(class2, "ANY") |
| |
| ## "Real" definition (assigned in ./zzz.R ) |
| .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, ClassDef1 = getClassDef(class1), |
| ClassDef2 = getClassDef(class2, where = .classEnv(ClassDef1))) |
| { |
| if(.identC(class1[[1L]], class2) || .identC(class2, "ANY")) |
| return(TRUE) |
| if(is.null(ClassDef1)) # class1 not defined |
| return(FALSE) |
| ## else |
| ext <- ClassDef1@contains |
| if(!is.null(contained <- ext[[class2]])) |
| contained |
| else if (is.null(ClassDef2)) |
| FALSE |
| else { ## look for class1 in the known subclasses of class2 |
| subs <- ClassDef2@subclasses |
| ## check for a classUnion definition, not a plain "classRepresentation" |
| if(!.identC(class(ClassDef2), "classRepresentation") && isClassUnion(ClassDef2)) |
| ## a simple TRUE iff class1 or one of its superclasses belongs to the union |
| any(c(class1, names(ext)) %in% names(subs)) |
| else { |
| ## class1 could be multiple classes here. |
| ## I think we want to know if any extend |
| i <- match(class1, names(subs)) |
| i <- i[!is.na(i)] |
| if(length(i)) subs[[ i[1L] ]] else FALSE |
| } |
| } |
| } |
| |
| ## 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, attr(ext, "conflicts")) |
| if(length(exts)) { |
| ## ## sort the extends information by depth (required for method dispatch) |
| ## superClassNames <- getAllSuperClasses(ClassDef, FALSE) |
| ## ## FIXME: getAllSuperClassses sometimes misses. Why? |
| ## if(length(superClassNames) == length(exts)) |
| ## exts <- exts[superClassNames] |
| if("oldClass" %in% names(exts) && |
| length(ClassDef@slots) > 1L) # an extension of an S3 class |
| exts <- .S3Extends(ClassDef, exts, where) |
| } |
| if(!missing(class2) && length(ClassDef@subclasses)) { |
| strictBy <- TRUE # FIXME: would like to make this conditional but a safe condition is unknown |
| subclasses <- |
| .transitiveSubclasses(ClassDef@className, class2, extensionDef, ClassDef@subclasses, strictBy) |
| ## 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) |
| } |
| } |
| ## TODO: move these checks to a tool used by check & conditional on no .S3Class slot |
| ## S3Class <- attr(ClassDef@prototype, ".S3Class") |
| ## if(!is.null(S3Class)) { |
| ## others <- c(ClassDef@className, names(exts)) |
| ## others <- others[is.na(match(others, S3Class))] |
| ## if(length(others)>0) |
| ## .checkS3forClass(ClassDef@className, where, others) |
| ## } |
| exts |
| } |
| |
| completeSubclasses <- |
| function(classDef, class2, extensionDef, where, classDef2 = getClassDef(class2, 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)) { |
| strictBy <- TRUE |
| contains <- |
| .transitiveExtends(class2, classDef@className, extensionDef, classDef@contains, strictBy) |
| ## 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]] |
| cli <- contains[[i]]@superClass |
| cliDef <- getClassDef(cli, package=packageSlot(obji)) |
| ## don't override existing relations |
| ## TODO: have a metric that picks the "closest" relationship |
| if(!extends(classDef2, cliDef)) |
| setIs(class2, cli, extensionObject = obji, |
| doComplete = FALSE, where = where) |
| } |
| } |
| subclasses |
| } |
| |
| |
| ## utility function to walk the graph of super- or sub-class relationships |
| ## in order to incorporate indirect relationships |
| .walkClassGraph <- function(ClassDef, slotName, where, conflicts = character()) |
| { |
| ext <- slot(ClassDef, slotName) |
| if(length(ext) == 0) |
| return(ext) |
| className <- ClassDef@className |
| ## the super- vs sub-class is identified by the slotName |
| superClassCase <- identical(slotName, "contains") |
| what <- names(ext) |
| for(i in seq_along(ext)) { # note that this loops only over the original ext |
| by <- what[[i]] |
| if(isClass(by, where = packageSlot(ext[[i]]))) { |
| byDef <- getClassDef(by, package=packageSlot(ext[[i]])) |
| exti <- slot(byDef, slotName) |
| coni <- attr(exti, "conflicts") # .resolveSuperclasses makes this |
| if(superClassCase && length(coni) > 0) { |
| conflicts <- unique(c(conflicts, coni)) |
| } |
| ## add in those classes not already known to be super/subclasses |
| exti <- exti[is.na(match(names(exti), what))] |
| if(length(exti)) { |
| if(superClassCase) { |
| strictBy <- TRUE # FIXME: need to find some safe test allowing non-strict |
| exti <- .transitiveExtends(className, by, ext[[i]], exti, strictBy) |
| } |
| else { |
| strictBy <- TRUE |
| exti <- .transitiveSubclasses(by, className, ext[[i]], exti, strictBy) |
| } |
| ext <- c(ext, exti) |
| } |
| } |
| else |
| stop(gettextf("the '%s' list for class %s, includes an undefined class %s", |
| if(superClassCase) "superClass" else "subClass", |
| dQuote(className), |
| dQuote(.className(by))), |
| domain = NA) |
| } |
| 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]] |
| if(!is(exti, "conditionalExtension")) { |
| if(superClassCase) { |
| whatError <- "contain itself" |
| } |
| else { |
| whatError <- "have itself as a subclass" |
| } |
| ## this is not translatable |
| stop(sprintf("class %s may not %s: it contains class %s, with a circular relation back to %s", |
| dQuote(className), whatError, |
| dQuote(exti@by), |
| dQuote(className)), |
| domain = NA) |
| } |
| } |
| ext <- ext[ok] |
| } |
| ## require superclasses to be sorted by distance |
| distOrder <- sort.list(vapply(ext, function(x) x@distance, 1)) |
| ext <- ext[distOrder] |
| if(superClassCase && (anyDuplicated(what) || length(conflicts) > 0)) |
| ext <- .resolveSuperclasses(ClassDef, ext, where, conflicts) |
| ext |
| } |
| |
| .reportSuperclassConflicts <- function(className, ext, where) { |
| what <- names(ext) |
| conflicts <- character() |
| for(i in seq_along(ext)) { |
| by <- what[[i]] |
| ## report only the direct superclass from which inconsistencies are inherited |
| wherei <- packageSlot(ext[[i]]) |
| if(identical(ext[[i]]@distance, 1) && isClass(by, where = wherei)) { |
| byDef <- getClassDef(by, package=wherei) |
| exti <- byDef@contains |
| coni <- attr(exti, "conflicts") # .resolveSuperclasses makes this |
| if( length(coni) > 0) { |
| warning(gettextf("class %s is inheriting an inconsistent superclass structure from class %s, inconsistent with %s", |
| .dQ(className), .dQ(by), |
| paste(.dQ(coni), collapse = ", ")), |
| call. = FALSE, domain = NA) |
| conflicts <- unique(c(conflicts, coni)) |
| } |
| } |
| } |
| newconflicts <- attr(ext, "conflicts") |
| if(length(newconflicts) > length(conflicts)) |
| warning(gettextf("unable to find a consistent ordering of superclasses for class %s: order chosen is inconsistent with the superclasses of %s", |
| .dQ(className), |
| paste(.dQ(setdiff(newconflicts, conflicts)), |
| collapse = ", ")), |
| call. = FALSE, domain = NA) |
| } |
| |
| |
| .resolveSuperclasses <- function(classDef, ext, where, conflicts = attr(ext, "conflicts")) { |
| ## find conditional extensions, ignored in superclass ordering |
| .condExts <- function(contains) |
| vapply(contains, function(x) is(x, "conditionalExtension" ), NA) |
| .noncondExtsClass <- function(cl) { |
| if(isClass(cl, where = where) ) { |
| contains <- getClass(cl, where = where)@contains |
| names(contains)[!.condExts(contains)] |
| } |
| else cl |
| } |
| what <- names(ext) |
| dups <- unique(what[duplicated(what)]) |
| if(length(dups) > 0) { |
| ## First, eliminate all conditional relations, which never override non-conditional |
| affected <- match(what, dups, 0) > 0 |
| conditionals <- .condExts(ext) |
| if(any(conditionals)) { |
| affected[conditionals] <- FALSE |
| what2 <- what[affected] |
| dups <- unique(what2[duplicated(what2)]) |
| if(length(dups) == 0) { |
| ## eliminating conditonal relations removed duplicates |
| if(length(conflicts) > 0) |
| attr(ext, "conflicts") <- unique(c(conflicts, attr(ext, "conflicts"))) |
| return(ext) |
| } |
| ## else, go on with conditionals eliminated |
| } |
| directSupers <- vapply(classDef@contains, function(x) identical(x@distance, 1), NA) |
| directSupers <- unique(names(classDef@contains[directSupers])) |
| ## form a list of the superclass orderings of the direct superclasses |
| ## to check consistency with each way to eliminate duplicates |
| ## Once again, conditional relations are eliminated |
| superExts <- lapply(directSupers, .noncondExtsClass) |
| names(superExts) <- directSupers |
| retain = .choosePos(classDef@className, what, superExts, affected) |
| if(is.list(retain)) { |
| these <- retain[[2]] |
| conflicts <- unique(c(conflicts, these)) # append the new conflicts |
| retain <- retain[[1]] |
| } |
| ## eliminate the affected & not retained |
| affected[retain] <- FALSE |
| ext <- ext[!affected] |
| } |
| ## even if no dups here, may have inherited some conflicts, |
| ## which will be copied to the contains list. |
| ## FUTURE NOTE (7/09): For now, we are using an attribute for conflicts, |
| ## rather than promoting the ext list to a new class, which may be desirable |
| ## if other code comes to depend on the conflicts information. |
| attr(ext, "conflicts") <- conflicts |
| ext |
| } |
| |
| classMetaName <- |
| ## a name for the object storing this class's definition |
| function(name) |
| methodsPackageMetaName("C", name) |
| |
| # regexp for matching class metanames; semi-general but assumes the |
| # meta pattern starts with "." and has no other special characters |
| .ClassMetaPattern <- function() |
| paste0("^[.]",substring(methodsPackageMetaName("C",""),2)) |
| |
| ##FIXME: C code should take multiple strings in name so paste() calls could be avoided. |
| methodsPackageMetaName <- |
| ## a name mangling device to simulate the meta-data in S4 |
| function(prefix, name, package = "") |
| ## paste(".", prefix, name, sep="__") # too slow |
| .Call(C_R_methodsPackageMetaName, prefix, name, package) |
| |
| ## a non-exported regexp that matches methods metanames |
| ## This is quite general and matches all patterns that could be generated |
| ## by calling methodsPackageMetaName() with a sequence of capital Latin letters |
| ## Used by package.skeleton in utils |
| .methodsPackageMetaNamePattern <- "^[.]__[A-Z]+__" |
| |
| 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 = "", where = topenv(parent.frame())) |
| { |
| for(f in functions) { |
| method <- getMethod(f, optional = TRUE) |
| if(!is.function(method)) |
| method <- getGeneric(f, where = where) |
| ## this is not eval()ed in this namespace |
| body(method) <- |
| substitute(stop(methods:::.missingMethod(FF, MESSAGE, |
| if(exists(".Method")) .Method), |
| domain = NA), |
| list(FF = f, MESSAGE = message)) |
| environment(method) <- .GlobalEnv |
| setMethod(f, signature, method, where = where) |
| } |
| NULL |
| } |
| |
| ## Construct an error message for an unsatisfied required method. |
| .missingMethod <- function(f, message = "", method) { |
| if(nzchar(message)) |
| message <- paste0("(", message, ")") |
| message <- paste("for function", f, message) |
| if(is(method, "MethodDefinition")) { |
| target <- paste(.dQ(method@target), collapse=", ") |
| defined <- paste(.dQ(method@defined), collapse=", ") |
| message <- paste("Required method", message, "not defined for signature", |
| target) |
| if(!identical(target, defined)) |
| message <- paste(message, ", required for signature", defined) |
| } |
| else message <- paste("Required method not defined", message) |
| message |
| } |
| |
| getSlots <- function(x) { |
| classDef <- if(isClassDef(x)) x else getClass(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) { |
| if(is.na(match("class", names))) |
| names |
| else |
| stop("\"class\" is a reserved slot name and cannot be redefined") |
| } |
| |
| ### utility function called from primitive code for "@" |
| getDataPart <- function(object, NULL.for.none = FALSE) { |
| if(typeof(object) == "S4") { |
| ## explicit .Data or .xData slot |
| ## Some day, we may merge both of these as .Data |
| value <- attr(object, ".Data") |
| if(is.null(value)) { |
| value <- attr(object, ".xData") |
| if(is.null(value) && !NULL.for.none) |
| stop("Data part is undefined for general S4 object") |
| } |
| return(if(identical(value, .pseudoNULL)) NULL else value) |
| } |
| temp <- getClass(class(object))@slots |
| if(length(temp) == 0L) |
| return(object) |
| if(is.na(match(".Data", names(temp)))) { |
| if(NULL.for.none) |
| return(NULL) |
| else |
| stop(gettextf("no '.Data' slot defined for class %s", |
| dQuote(class(object))), |
| domain = NA) |
| } |
| ## else |
| dataPart <- temp[[".Data"]] |
| switch(dataPart, |
| ## the common cases, for efficiency |
| numeric = , vector = , integer = , character = , logical = , |
| complex = , list = |
| attributes(object) <- NULL, |
| matrix = , array = { |
| value <- object |
| attributes(value) <- NULL |
| attr(value, "dim") <- attr(object, "dim") |
| attr(value, "dimnames") <- attr(object, "dimnames") |
| object <- value |
| }, |
| ts = { |
| value <- object |
| attributes(value) <- NULL |
| attr(value, "ts") <- attr(object, "ts") |
| object <- value |
| }, |
| ## default: |
| if(is.na(match(dataPart, .BasicClasses))) { |
| ## keep attributes not corresponding to slots |
| attrVals <- attributes(object) |
| attrs <- names(attrVals) |
| attrs <- attrs[is.na(match(attrs, c("class", names(temp))))] |
| attributes(object) <- attrVals[attrs] |
| } |
| else |
| ## other basic classes have no attributes |
| attributes(object) <- NULL |
| ) |
| object |
| } |
| |
| setDataPart <- function(object, value, check = TRUE) { |
| if(check || typeof(object) == "S4") { |
| classDef <- getClass(class(object)) |
| slots <- getSlots(classDef) |
| dataSlot <- .dataSlot(names(slots)) |
| if(length(dataSlot) == 1) |
| dataClass <- elNamed(slots, dataSlot) |
| else if(check) |
| stop(gettextf("class %s does not have a data part (a .Data slot) defined", |
| dQuote(class(object))), |
| domain = NA) |
| else # this case occurs in making the methods package. why? |
| return(.mergeAttrs(value, object)) |
| value <- as(value, dataClass) # note that this is strict as() |
| if(typeof(object) == "S4") { |
| if(is.null(value)) |
| value <- .pseudoNULL |
| attr(object, dataSlot) <- value |
| return(object) |
| } |
| } |
| .mergeAttrs(value, object) |
| } |
| |
| .validDataPartClass <- function(cl, where, prevDataPartClass = NULL) { |
| if(is(cl, "classRepresentation")) { |
| ClassDef <- cl |
| cl <- ClassDef@className |
| } |
| else |
| ClassDef <- getClass(cl, TRUE) |
| |
| value <- switch(cl, |
| matrix = , array = cl, |
| ## otherwise |
| 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)) { |
| } |
| else if(isTRUE(ClassDef@virtual) && |
| length(ClassDef@slots) == 0L && |
| length(ClassDef@subclasses) ) { |
| ## 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) == 0L && ext@simple && !ext@dataPart && |
| is.na(match(what[i], .BasicClasses))) { |
| value <- NULL |
| break |
| } |
| } |
| } |
| } |
| if(!(is.null(value) || is.null(prevDataPartClass) || extends(prevDataPartClass, value) || |
| isVirtualClass(value, where = where))) { |
| warning(gettextf("more than one possible class for the data part: using %s rather than %s", |
| .dQ(prevDataPartClass), .dQ(value)), domain = NA) |
| value <- NULL |
| } |
| value |
| } |
| |
| .dataSlot <- function(slotNames) { |
| dataSlot <- c(".Data", ".xData") |
| dataSlot <- dataSlot[match(dataSlot, slotNames, 0)>0] |
| if(length(dataSlot) > 1) |
| stop("class cannot have both an ordinary and hidden data type") |
| dataSlot |
| } |
| |
| |
| .mergeAttrs <- function(value, object, explicit = NULL) { |
| supplied <- attributes(object) |
| if(length(explicit)) |
| supplied[names(explicit)] <- explicit |
| valueAttrs <- attributes(value) |
| ## names are special. |
| if(length(supplied$names) && length(valueAttrs$names) == 0L) { |
| if(length(value) != length(object)) |
| length(supplied$names) <- length(value) |
| } |
| if(length(valueAttrs)) { ## don't overwrite existing attrs |
| valueAttrs$class <- NULL ## copy in class if it's supplied |
| supplied[names(valueAttrs)] <- valueAttrs |
| } ## else -- nothing to protect |
| attributes(value) <- supplied |
| if(isS4(object)) |
| .asS4(value) |
| else |
| value |
| } |
| |
| .newExternalptr <- function() |
| .Call(C_R_externalptr_prototype_object) |
| |
| ## 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, strictBy) { |
| what <- names(moreExts) |
| ### if(!strictBy) message("Extends: ",from, ": ", paste(what, collapse = ", ")) |
| for(i in seq_along(moreExts)) { |
| toExt <- moreExts[[i]] |
| to <- what[[i]] |
| toExt <- .combineExtends(byExt, toExt, by, to, strictBy) |
| moreExts[[i]] <- toExt |
| } |
| moreExts |
| ### if(!strictBy) message("Done") |
| } |
| |
| .transitiveSubclasses <- function(by, to, toExt, moreExts, strictBy) { |
| ## what <- names(moreExts) |
| ### if(!strictBy) message("Subclasses: ",by, ": ", paste(what, collapse = ", ")) |
| for(i in seq_along(moreExts)) { |
| byExt <- moreExts[[i]] |
| byExt <- .combineExtends(byExt, toExt, by, to, strictBy) |
| moreExts[[i]] <- byExt |
| } |
| moreExts |
| ### if(!strictBy) message("Done") |
| } |
| |
| .combineExtends <- function(byExt, toExt, by, to, strictBy) { |
| ## construct the composite coerce method, taking into account the strict= |
| ## argument. |
| f <- toExt@coerce |
| 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(!isTRUE(byExpr)) { |
| if(!isTRUE(toExpr)) |
| 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) |
| if(!strictBy) { |
| toDef <- getClassDef(to, package=packageSlot(toExt)) |
| byDef <- getClassDef(by, package=packageSlot(byExt)) |
| strictBy <- is.null(toDef) || is.null(byDef) || toDef@virtual || byDef@virtual |
| } |
| if (isVirtualClass(by, .requirePackage(packageSlot(byExt)))) { |
| skipDef <- getClassDef(by, package=packageSlot(byExt)) |
| skipExt <- skipDef@contains[[to]] |
| if (!is.null(skipExt)) { |
| body(f, envir = environment(f)) <- |
| call("as", body(skipExt@replace), byExt@subClass) |
| } |
| } else { |
| expr <- substitute({ |
| .value <- as(from, BY, STRICT) |
| as(.value, TO) <- value |
| value <- .value |
| BYEXPR |
| }, list(BY=by, TO = to, BYEXPR = byExpr, STRICT = strictBy)) |
| body(f, envir = environment(f)) <- expr |
| } |
| toExt@replace <- f |
| toExt@by <- toExt@subClass |
| toExt@subClass <- byExt@subClass |
| toExt@distance <- toExt@distance + byExt@distance |
| ## the combined extension is conditional if either to or by is conditional |
| if(is(byExt, "conditionalExtension") && !is(toExt, "conditionalExtension")) |
| class(toExt) <- class(byExt) |
| 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(is.null(packageSlot(toClass))) { |
| toClass <- toDef@className |
| if(is.null(packageSlot(toClass))) # is this possible? |
| packageSlot(toClass) <- toDef@package |
| } |
| chClass <- as.character(toClass) # dropping package attrib |
| if(sameSlots) |
| substitute({class(from) <- CLASS; from}, list(CLASS = toClass)) |
| else if(length(toSlots) == 0L) { |
| ## either a basic class or something with the same representation |
| if(is.na(match(chClass, .BasicClasses))) |
| substitute({ attributes(from) <- NULL; class(from) <- CLASS; from}, |
| list(CLASS = toClass)) |
| else if(isVirtualClass(toDef)) |
| quote(from) |
| else { |
| ## a basic class; a vector type, matrix, array, or ts |
| switch(chClass, |
| matrix = , array = { |
| quote({.dm <- dim(from); .dn <- dimnames(from) |
| attributes(from) <- NULL; dim(from) <- .dm |
| dimnames(from) <- .dn; from}) |
| }, |
| ts = { |
| quote({.tsp <- tsp(from); attributes(from) <- NULL |
| tsp(from) <- .tsp; class(from) <- "ts"; from}) |
| }, |
| quote({attributes(from) <- NULL; from}) |
| ) |
| } |
| } |
| else { |
| substitute({ value <- new(CLASS) |
| for(what in TOSLOTS) |
| slot(value, what) <- slot(from, what) |
| value }, |
| list(CLASS = chClass, TOSLOTS = toSlots)) |
| } |
| } |
| |
| .simpleReplaceExpr <- function(toDef) { |
| toSlots <- names(toDef@slots) |
| substitute({ |
| for(what in TOSLOTS) |
| slot(from, what) <- slot(value, what) |
| from |
| }, list(TOSLOTS = toSlots)) |
| } |
| |
| ## 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[3L:(length(expr)+1)] <- expr[2L:length(expr)] |
| expr[[2L]] <- 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) { |
| cl <- class(x) |
| if(length(cl) > 1L) |
| cl[[1L]] |
| else |
| cl |
| } |
| |
| substituteFunctionArgs <- |
| function(def, newArgs, args = formalArgs(def), silent = FALSE, |
| functionName = "a function") |
| { |
| if(!identical(args, newArgs)) { |
| if( !missing(functionName) ) # this style does not allow translation |
| functionName <- paste("for", functionName) |
| |
| n <- length(args) |
| if(n != length(newArgs)) |
| stop(sprintf("trying to change the argument list of %s with %d arguments to have arguments (%s)", |
| functionName, n, paste(newArgs, collapse = ", ")), |
| domain = NA) |
| bdy <- body(def) |
| ## check for other uses of newArgs |
| checkFor <- newArgs[is.na(match(newArgs, args))] |
| locals <- all.vars(bdy) |
| if(length(checkFor) && any(!is.na(match(checkFor, locals)))) |
| stop(sprintf("get rid of variables in definition %s (%s); they conflict with the needed change to argument names (%s)", |
| functionName, |
| paste(checkFor[!is.na(match(checkFor, locals))], collapse = ", "), |
| paste(newArgs, collapse = ", ")), domain = NA) |
| ll <- vector("list", 2L*n) |
| for(i in seq_len(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) { |
| msg <- |
| sprintf("NOTE: arguments in definition %s changed from (%s) to (%s)", |
| functionName, |
| paste(args, collapse = ", "), |
| paste(newArgs, collapse = ", ")) |
| message(msg, domain = NA) |
| } |
| } |
| def |
| } |
| |
| .makeValidityMethod <- function(Class, validity) { |
| if(!is.null(validity)) { |
| if(!is.function(validity)) |
| stop(gettextf("a validity method must be a function of one argument, got an object of class %s", |
| dQuote(class(validity))), |
| domain = NA) |
| validity <- substituteFunctionArgs(validity, "object", functionName = sprintf("validity method for class '%s'", Class)) |
| } |
| 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 simple version |
| .isPrototype <- function(p) .identC(class(p), "classPrototypeDef") |
| |
| .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, mustFind = TRUE) |
| topenv(parent.frame()) |
| |
| ## real version of .requirePackage |
| ..requirePackage <- function(package, mustFind = TRUE) { |
| value <- package |
| if(nzchar(package)) { |
| ## lookup as lightning fast as possible: |
| if (.Internal(exists(package, .Internal(getNamespaceRegistry()), |
| "any", FALSE))) |
| value <- getNamespace(package) |
| else { |
| if(identical(package, ".GlobalEnv")) |
| return(.GlobalEnv) |
| if(identical(package, "methods")) |
| return(topenv(parent.frame())) # booting methods |
| } |
| } |
| if(is.environment(value)) |
| return(value) |
| topEnv <- getOption("topLevelEnvironment") |
| if(is.null(topEnv)) |
| topEnv <- .GlobalEnv |
| if(!is.null(pkgN <- get0(".packageName", topEnv, inherits=TRUE)) && |
| .identC(package, pkgN)) |
| return(topEnv) # kludge for source'ing package code |
| if(nzchar(package) && require(package, character.only = TRUE)) {} |
| else { |
| if(mustFind) |
| stop(gettextf("unable to find required package %s", |
| sQuote(package)), |
| domain = NA) |
| else |
| return(NULL) |
| } |
| getNamespace(package) |
| } |
| |
| .classDefEnv <- function(classDef) { |
| .requirePackage(classDef@package) |
| } |
| |
| ## bootstrap version, mustn't fail |
| .classEnv <- function(Class, default = .requirePackage("methods"), mustFind = TRUE) { |
| package <- packageSlot(Class) |
| if(is.null(package)) { |
| ## unconditionally use the methods package |
| default |
| } |
| else |
| .requirePackage(package) |
| } |
| |
| |
| ## to be .classEnv() --- currently used in 'Matrix' (via wrapper) |
| ..classEnv <- function(Class, default = .requirePackage("methods"), mustFind = TRUE) { |
| package <- { if(is.character(Class)) packageSlot(Class) else |
| ## must then be a class definition |
| Class@package } |
| if(is.null(package)) { |
| ## use the default, but check that the class is there, and if not |
| ## try a couple of other heuristics |
| value <- default |
| def <- getClassDef(Class, value, NULL) |
| if(is.null(def)) { |
| value <- .GlobalEnv |
| def <- getClassDef(Class, value, NULL) |
| if(is.null(def)) { |
| value <- .requirePackage("methods") |
| if(!identical(default, value)) # user supplied default |
| def <- getClassDef(Class, value, NULL) |
| } |
| } |
| if(is.null(def) && mustFind) |
| stop(gettextf("unable to find an environment containing class %s", |
| dQuote(Class)), |
| domain = NA) |
| value |
| } |
| else |
| .requirePackage(package) |
| } |
| |
| ## find a generic function reference, using the package slot if present |
| ## FIXME: this and .classEnv should be combined and implemented in C for speed |
| ## They differ in that .classEnv uses the class metaname when it searches; i.e., |
| ## they use getClassDef and .getGeneric resp. Also, .getEnv returns baseenv() rather |
| ## than generating an error if no generic found (so getGeneric can return gen'c for prim'ves) |
| |
| .genEnv <- function(f, default = .requirePackage("methods"), package = "") |
| { |
| if(!nzchar(package)) |
| package <- packageSlot(f) |
| if(is.null(package)) { |
| ## use the default, but check that the object is there, and if not |
| ## try a couple of other heuristics |
| value <- default |
| def <- .getGeneric(f, value) |
| if(is.null(def)) { |
| value <- .GlobalEnv |
| def <- .getGeneric(f, value) |
| if(is.null(def)) { |
| value <- .requirePackage("methods") |
| if(!identical(default, value)) # user supplied default |
| def <- .getGeneric(f, value) |
| } |
| } |
| if(is.null(def)) |
| baseenv() |
| else |
| value |
| } |
| else |
| .requirePackage(package) |
| } |
| |
| ## cache and retrieve class definitions If there is a conflict with |
| ## packages a list of classes will be cached |
| ## See .cacheGeneric, etc. for analogous computations for generics |
| .classTable <- new.env(TRUE, baseenv()) |
| assign("#HAS_DUPLICATE_CLASS_NAMES", FALSE, envir = .classTable) |
| ## FIXME We've seen duplicated classes in .classTable |
| .duplicateClassesExist <- function(on) { |
| value <- get("#HAS_DUPLICATE_CLASS_NAMES", envir = .classTable) |
| if(nargs()) |
| assign("#HAS_DUPLICATE_CLASS_NAMES", on, envir = .classTable) |
| value |
| } |
| |
| .cacheClass <- function(name, def, doSubclasses = FALSE, env) { |
| if(!isFALSE(doSubclasses)) # only when is(def, "ClassUnionRepresentation") |
| .recacheSubclasses(def@className, def, env) |
| if(!is.null(prev <- .classTable[[name]])) { |
| newpkg <- def@package |
| if(is(prev, "classRepresentation")) { |
| if(identical(prev, def)) |
| return() |
| pkg <- prev@package # start a per-package list |
| if(identical(pkg, newpkg)) { # redefinition |
| ## cache for S3, to override possible previous cache |
| .cache_class(name, .extendsForS3(def)) |
| return(.classTable[[name]] <- def) |
| } |
| else if(.simpleDuplicateClass(def, prev)) |
| return() |
| prev <- list(prev) |
| names(prev) <- pkg |
| } |
| ## now prev is a named list of class definitions (>= 1), |
| ## where the names are names of packages (rather: namespaces) |
| i <- match(newpkg, names(prev)) |
| if(is.na(i)) |
| prev[[newpkg]] <- def |
| else if(identical(def, prev[[i]])) |
| return() |
| else # replace previous |
| prev[[i]] <- def |
| def <- prev |
| if(length(def) > 1L) |
| .duplicateClassesExist(TRUE) |
| } |
| .classTable[[name]] <- def # return()s invisibly |
| } |
| |
| ## test for identical def, prev class definitions |
| ## An exhaustive test would be very complicated, having to test |
| ## superclasses in detail, prototypes for the slots, etc. |
| .simpleDuplicateClass <- function(def, prev) { |
| supers <- names(def@contains) |
| prevSupers <- names(prev@contains) |
| if(length(supers) != length(prevSupers) || |
| any(is.na(match(supers, prevSupers)))) |
| return(FALSE) |
| verbose <- getOption("verbose") |
| S3 <- "oldClass" %in% supers |
| if(S3) { |
| ## it is possible one of these is inconsistent, but unlikely |
| ## and S3 class attributes have no package so duplicates are useless |
| return(TRUE) |
| } |
| ## if there are already duplicate classes, we check duplicates |
| ## for the superclasses |
| dupsExist <- .duplicateClassesExist() |
| if(dupsExist) { |
| dups <- match(supers, multipleClasses(), 0) > 0 |
| if(any(dups)) { |
| if(verbose) |
| message(gettextf("Note: some superclasses of class %s in package %s have duplicate definitions. This definition is not being treated as equivalent to that from package %s", |
| dQuote(def@className), |
| sQuote(def@package), |
| sQuote(prev@package)), |
| domain = NA) |
| return(FALSE) |
| } |
| } |
| ## now check the slots |
| slots <- names(def@slots) |
| prevSlots <- names(prev@slots) |
| if(length(slots) != length(prevSlots) || |
| any(is.na(match(slots, prevSlots)))) |
| return(FALSE) |
| for(what in slots) { |
| slotClasses <- def@slots |
| prevClasses <- prev@slots |
| clWhat <- slotClasses[[what]] |
| prevWhat <- prevClasses[[what]] |
| if(!identical(as.character(clWhat), as.character(prevWhat)) || |
| (dupsExist && !identical(as.character(packageSlot(clWhat)), |
| as.character(packageSlot(prevWhat))))) |
| return(FALSE) |
| } |
| if(verbose) |
| message(gettextf("Note: the specification for class %s in package %s seems equivalent to one from package %s: not turning on duplicate class definitions for this class.", |
| dQuote(def@className), |
| sQuote(def@package), |
| sQuote(prev@package)), |
| domain = NA) |
| TRUE |
| } |
| |
| .uncacheClass <- function(name, def) { |
| if(!is.null(prev <- .classTable[[name]])) { |
| if(is(def, "classRepresentation")) # paranoia: should only be called this way |
| newpkg <- def@package |
| else |
| newpkg <- "" |
| if(is(prev, "classRepresentation") && identical(prev@package, newpkg) ) |
| return(remove(list = name, envir = .classTable)) |
| i <- match(newpkg, names(prev)) |
| if(!is.na(i)) |
| prev[[i]] <- NULL |
| else # we might warn about unchaching more than once |
| return() |
| if(length(prev) == 0L) |
| return(remove(list = name, envir = .classTable)) |
| else if(length(prev) == 1L) |
| prev <- prev[[1L]] |
| assign(name, prev, envir = .classTable) |
| } |
| } |
| |
| ## .getClassesFromCache() and .resolveClassList() |
| ## are the workhorses of class access |
| ## The underlying C code will return name if it is not a character vector |
| ## in the assumption this is a classRepresentation or subclass of that. |
| ## In principle, this could replace the checks on class(name) in getClassDef |
| ## and new(), which don't work for subclasses of classRepresentation anyway. |
| .getClassesFromCache <- function(name) { |
| .Call(C_R_getClassFromCache, name, .classTable) |
| } |
| |
| ## When .simpleGetClassFromCache returns a list, pick the most appropriate |
| .resolveClassList <- function(value, where, package, resolve.confl = "first", |
| resolve.msg = TRUE) |
| { |
| if(is.null(package)) |
| package <- if(is.character(where)) where |
| else getPackageName(where, FALSE) # may be "" |
| pkgs <- names(value) |
| i <- match(package, pkgs, 0L) |
| if(i == 0L && package != "methods") ## try 'methods': |
| i <- match("methods", pkgs, 0L) |
| if(i > 0L) |
| value[[i]] |
| else { ## still NULL -- but we *do* want to return one of the class definitions! |
| switch(resolve.confl, |
| "none" = NULL, |
| "first" = { |
| if(resolve.msg) { |
| message(gettextf( |
| "Found more than one class \"%s\" in cache; using the first, from namespace '%s'", |
| value[[1]]@className, pkgs[1]), domain=NA) |
| message("Also defined by ", |
| paste(sQuote(pkgs[-1]), collapse = " ")) |
| } |
| value[[1]] |
| }, |
| "all" = value) # return all, a list |
| } |
| } |
| |
| .getClassFromCache <- function(name, where, package = packageSlot(name), |
| resolve.confl = "first", resolve.msg = TRUE) |
| { |
| value <- .getClassesFromCache(name) |
| if(is.list(value)) { |
| ## multiple classes with this name -- choose at most one |
| value <- .resolveClassList(value, where, package, resolve.confl, |
| resolve.msg) |
| } |
| value |
| } |
| |
| ##' Insert superclass information into all the subclasses of this class. |
| ## Used (in 1 place only) to incorporate inheritance information from classUnions |
| .recacheSubclasses <- function(class, def, env) { |
| subs <- def@subclasses |
| subNames <- names(subs) |
| for(i in seq_along(subs)) { |
| what <- subNames[[i]] |
| subDef <- getClassDef(what, package=packageSlot(subs[[i]])) |
| if(is.null(subDef)) |
| subDef <- getClassDef(what, env) # may be the case for members of a classUnion |
| if(is.null(subDef)) |
| warning(gettextf("undefined subclass %s of class %s; definition not updated", |
| .dQ(what), .dQ(def@className))) |
| else if(is.na(match(what, names(subDef@contains)))) { |
| ## insert the new superclass to maintain order by distance |
| cntns <- subDef@contains |
| cntns[[class]] <- subs[[i]] |
| cntns <- cntns[sort.list(vapply(cntns, function(x) x@distance, 1))] |
| subDef@contains <- cntns |
| .cacheClass(what, subDef, FALSE, env) |
| } |
| } |
| NULL |
| } |
| |
| ## alternative to .recacheSubclasses, only needed for non-unions |
| ## Inferior in that nonlocal subclasses will not be updated, hence the |
| ## warning when the subclass is not in where |
| .checkSubclasses <- function(class, def, class2, def2, where, where2) { |
| where <- as.environment(where) |
| where2 <- as.environment(where2) |
| subs <- def@subclasses |
| subNames <- names(subs) |
| extDefs <- def2@subclasses |
| for(i in seq_along(subs)) { |
| what <- subNames[[i]] |
| if(.identC(what, class2)) |
| next # catch recursive relations |
| cname <- classMetaName(what) |
| if(!is.null(subDef <- get0(cname, envir = where, inherits = FALSE))) { |
| cwhere <- where |
| } |
| else if(!is.null(subDef <- get0(cname, envir = where2, inherits = FALSE))) { |
| cwhere <- where2 |
| } |
| else { |
| ## happens (wrongly) in a package which imports 'class' but not 'subclass' from another package |
| ## *and* extends 'class', e.g., by defining a class union with it as member. |
| ## Fact is that at the end, the subclass is seen to be updated fine. |
| message(gettextf(paste("From .checkSubclasses(): subclass %s of class %s is not local and", |
| "is not updated for new inheritance information currently;", |
| "\n[where=%s, where2=%s]"), |
| .dQ(what), .dQ(class), format(where), format(where2)), |
| domain = NA) |
| next |
| } |
| extension <- extDefs[[what]] |
| if(is.null(extension)) # not possible if the setIs behaved? |
| warning(gettextf("no definition of inheritance from %s to %s, though the relation was implied by the setIs() from %s", |
| .dQ(what), .dQ(def2@className), .dQ(class)), |
| call. = FALSE, domain = NA) |
| else if(is.na(match(class2, names(subDef@contains)))) { |
| ## The only "real action": seems only necessary to be called |
| ## during 'methods' "initializing class and method definitions": |
| if(isTRUE(as.logical(Sys.getenv("_R_METHODS_SHOW_CHECKSUBCLASSES", "false")))) |
| message(sprintf(paste( # currently only seen from setClassUnion() -> setIs() -> |
| "Debugging .checkSubclasses(): assignClassDef(what=\"%s\", *, where=%s, force=TRUE);\n", |
| "E := environment(): %s; parent.env(E): %s"), what, format(cwhere), |
| format(E <- environment()), format(parent.env(E)))) |
| subDef@contains[[class2]] <- extension |
| assignClassDef(what, subDef, cwhere, TRUE) |
| } # else no action (incl no warning!) at all |
| } |
| NULL |
| } |
| |
| .removeSuperclassBackRefs <- function(Class, classDef, classWhere) |
| { |
| if(length(classDef@contains)) { |
| superclasses <- names(classDef@contains) |
| for(what in superclasses) { |
| cdef <- .getClassFromCache(what, classWhere, resolve.confl = "all") |
| if(is(cdef, "classRepresentation")) |
| .removeSubClass(what, Class, cdef) |
| else if(is.list(cdef)) |
| lapply(cdef, function(cl) .removeSubClass(what, Class, cl)) |
| } |
| } |
| NULL |
| } |
| |
| |
| ## remove subclass from the list of subclasses of class |
| ## in the cache and possibly in the attached package environment |
| .removeSubClass <- function(class, subclass, cdef) { |
| if(is.null(cdef)) {} |
| else { |
| newdef <- .deleteSubClass(cdef, subclass) |
| if(!is.null(newdef)) |
| .cacheClass(class, newdef, FALSE, cdef@package) |
| ## the class definition in the search list may have been altered |
| ## (e.g., when classes are created in the global environment_ |
| pname <- cdef@package |
| if(identical(pname, ".GlobalEnv")) { |
| pos <- 1 |
| } |
| else { |
| pname <- paste0("package:", pname) |
| pos <- match(pname, search(), 0) |
| } |
| if(pos) { |
| penv <- as.environment(pname) |
| cmeta <- classMetaName(class) |
| if(!is.null(cdefp <- penv[[cmeta]])) { |
| if(subclass %in% names(cdefp@subclasses)) { |
| newdef <- .deleteSubClass(cdefp, subclass) |
| if(!is.null(newdef)) { |
| ## unfortunately, assignClassDef assigns the subclass info |
| ## even in a locked binding. Would be nice to change that, |
| ## but probably too much would break. |
| if(bindingIsLocked(cmeta, penv)) |
| .assignOverBinding(cmeta, newdef, penv, FALSE) |
| else |
| penv[[cmeta]] <- newdef |
| } |
| } |
| } |
| } |
| } |
| sig <- signature(from=subclass, to=class) |
| if(existsMethod("coerce", sig)) |
| .removeCachedMethod("coerce", sig) |
| if(existsMethod("coerce<-", sig)) |
| .removeCachedMethod("coerce<-", sig) |
| } |
| |
| .deleteSubClass <- function(cdef, subclass) { |
| subclasses <- cdef@subclasses |
| ii <- match(subclass, names(subclasses), 0) |
| ## the subclass may not be there, e.g., if that class has been |
| ## unloaded. |
| if(ii > 0) { |
| cdef@subclasses <- subclasses[-ii] |
| cdef |
| } |
| else |
| NULL |
| } |
| |
| ## remove superclass from definition of class in the cache & in environments |
| ## on search list |
| .removeSuperClass <- function(class, superclass) { |
| cdef <- getClassDef(class) |
| if(is.null(cdef)) {} |
| else { |
| newdef <- .deleteSuperClass(cdef, superclass) |
| if(!is.null(newdef)) |
| .cacheClass(class, newdef, FALSE, where) |
| } |
| sig <- signature(from=class, to=superclass) |
| if(existsMethod("coerce", sig)) |
| .removeCachedMethod("coerce", sig) |
| if(existsMethod("coerce<-", sig)) |
| .removeCachedMethod("coerce<-", sig) |
| evv <- findClass(class, .GlobalEnv) # what about hidden classes? how to find them? |
| mname <- classMetaName(class) |
| for(where in evv) { |
| if(!is.null(cdef <- where[[mname]])) { |
| newdef <- .deleteSuperClass(cdef, superclass) |
| if(!is.null(newdef)) { |
| assignClassDef(class, newdef, where, TRUE) |
| ## message("deleted ",superclass, " from ",class, "in environment") |
| } |
| } |
| } |
| NULL |
| } |
| |
| .deleteSuperClass <- function(cdef, superclass) { |
| superclasses <- cdef@contains |
| ii <- match(superclass, names(superclasses), 0L) |
| if(ii) { |
| cdef@contains <- superclasses[-ii] |
| for(subclass in names(cdef@subclasses)) |
| .removeSuperClass(subclass, superclass) |
| cdef |
| } |
| else |
| NULL |
| } |
| |
| classesToAM <- function(classes, includeSubclasses = FALSE, |
| abbreviate = 2) { |
| .mergeMatrices <- function(m1, m2) { |
| if(nrow(m1) == 0) |
| return(m2) |
| dn1 <- dimnames(m1) |
| dn2 <- dimnames(m2) |
| rows <- unique(c(dn1[[1]], dn2[[1]])) |
| columns <- unique(c(dn1[[2]], dn2[[2]])) |
| value <- matrix(0, length(rows), length(columns), dimnames = list(rows, columns)) |
| value[dn1[[1]], dn1[[2]] ] <- m1 |
| value[dn2[[1]], dn2[[2]] ] <- m2 |
| value |
| } |
| if(length(includeSubclasses) == 1) |
| includeSubclasses <- rep.int(includeSubclasses, length(classes)) |
| if(!is(includeSubclasses, "logical") || length(includeSubclasses) != length(classes)) |
| stop("argument 'includeSubclasses' must be a logical, either one value or a vector of the same length as argument 'classes'") |
| value <- matrix(0,0,0) |
| for(i in seq_along(classes)) { |
| class <- classes[[i]] # to allow for package attribute |
| classDef <- getClass(class) # throws an error if undefined. Make a warning? |
| value <- .mergeMatrices(value, .oneClassToAM(classDef, includeSubclasses[[i]])) |
| } |
| abbr <- match(as.integer(abbreviate), 0:3)-1 |
| if(length(abbr) != 1 || is.na(abbr)) |
| stop("argument 'abbreviate' must be 0, 1, 2, or 3") |
| if(abbr %% 2) |
| dimnames(value)[[1]] <- abbreviate(dimnames(value)[[1]]) |
| if(abbr %/% 2) |
| dimnames(value)[[2]] <- abbreviate(dimnames(value)[[2]]) |
| value |
| } |
| |
| .oneClassToAM <- function(classDef, includeSubclasses = FALSE, short = FALSE) { |
| findEdges <- function(extensions) { |
| superclasses <- names(extensions) |
| edges <- numeric() |
| for(what in superclasses) { |
| whatDef <- getClassDef(what, package=packageSlot(extensions[[what]])) |
| ifrom <- match(what, nodes) |
| if(is.null(whatDef) || is.na(ifrom)) |
| next |
| exts <- whatDef@contains |
| whatedges <- names(exts) |
| ito <- match(whatedges, nodes, 0) |
| for(i in seq_along(exts)) |
| if(ito[[i]] >0 && exts[[i]]@distance == 1) |
| edges <- c(edges, ifrom, ito[[i]]) |
| } |
| edges |
| } |
| nodes <- c(classDef@className, names(classDef@contains)) |
| if(includeSubclasses) |
| nodes <- c(nodes, names(classDef@subclasses)) |
| nodes <- unique(nodes) |
| labels <- |
| if(isTRUE(short)) abbreviate(nodes) |
| else if(is.character(short)) { |
| if(length(short) != length(nodes)) |
| stop(gettextf("needed the supplied labels vector of length %d, got %d", |
| length(nodes), length(short)), domain = NA) |
| else short |
| } else nodes |
| size <- length(nodes) |
| value <- matrix(0, size, size, dimnames = list(labels, labels)) |
| ifrom <- match(classDef@className, nodes) # well, 1, but just for consistency |
| ## the following could use the current fact that direct superclasses come |
| ## first, but the efficiency gain is minor, so we use the findEdges logic |
| extensions <- classDef@contains |
| superclasses <- names(extensions) |
| ito <- match(superclasses, nodes) |
| edges <- numeric() |
| for(i in seq_along(extensions)) { |
| exti <- extensions[[i]] |
| if(exti@distance == 1) |
| edges <- c(edges, ifrom, ito[[i]]) |
| } |
| edges <- c(edges, findEdges(classDef@contains)) |
| if(includeSubclasses) { |
| edges <- c(edges, findEdges(classDef@subclasses)) |
| } |
| edges <- t(matrix(edges, nrow=2)) |
| value[edges] <- 1 |
| value |
| } |
| |
| .choosePos <- function (thisClass, superclasses, subNames, affected) |
| ## find if possible a set of superclass relations that gives a consistent |
| ## ordering and eliminates any duplicates in the affected relations |
| ## Note that the returned indices are against the index of superclasses |
| ## If no successful selection is possible, return (one of) the best |
| ## attempt, and the superclass(es) inconsistently embedded |
| { |
| candidates <- list() |
| allNames <- c(thisClass, superclasses) |
| dups <- unique(superclasses[affected]) |
| whichCase <- names(subNames) |
| for(what in dups) { |
| where <- seq_along(allNames)[match( allNames, what,0)>0] |
| ## make a list of all the subsets to remove duplicates |
| whatRemove <- lapply(-seq_along(where), function(x,y) y[x], y=where) |
| if(length(candidates) == 0) |
| candidates <- whatRemove |
| else # all the pairwise combinations with the previous |
| candidates <- outer(candidates, whatRemove, |
| function(x,y)mapply(c,x,y, SIMPLIFY=FALSE)) |
| } |
| ## check each way to make the list unique against each superclass extension |
| problems <- function(x,y) any(diff(match(y, x)) < 0) |
| possibles <- lapply(candidates, function(x, names)names[-x], names=allNames) |
| ## the next could be vectorized, but here we choose instead to exit early. |
| scores <- vector("list", length(possibles)) |
| for(i in seq_along(possibles)) { |
| score <- vapply(subNames, problems, NA, x=possibles[[i]]) |
| scores[[i]] <- whichCase[score] |
| if(!any(score)) |
| return(-candidates[[i]]+1) |
| } |
| # the first min. scoring possibility and its score |
| i <- which.min(lengths(scores)) |
| list(-candidates[[i]]+1, scores[[i]]) |
| } |
| |
| .checkGeneric <- function(what, where) { |
| .checkFun <- function(x) { |
| maybe <- if(!is.null(f <- get0(x, where))) is.function(f) else FALSE |
| if(maybe) |
| maybe <- is(f, "genericFunction") || |
| (length(grep("UseMethod", deparse(f))) > 0) || |
| is.primitive(f) |
| maybe |
| } |
| vapply(what, .checkFun, NA) |
| } |
| |
| |
| S3forS4Methods <- function(where, checkClasses = character()) { |
| allClasses <- getClasses(where) |
| if(length(checkClasses) > 0) |
| allClasses <- allClasses[match(allClasses, checkClasses, 0) > 0] |
| if(length(allClasses) == 0) |
| return(allClasses) |
| pattern <- paste0("([.]",allClasses, "$)", collapse="|") |
| allObjects <- names(where) |
| allObjects <- allObjects[-grep("^[.][_][_]", allObjects)] # remove meta data |
| allObjects <- grep(pattern, allObjects, value = TRUE) |
| if(length(allObjects) > 0) { |
| badMethods <- allObjects |
| funs <- sub(pattern, "", badMethods) |
| uniqueFuns <- unique(funs) |
| uniqueFuns <- uniqueFuns[nzchar(uniqueFuns)] |
| possible <- .checkGeneric(uniqueFuns, where) |
| if(!any(possible)) |
| return(character()) |
| uniqueFuns <- uniqueFuns[possible] |
| badMethods <- badMethods[match(funs, uniqueFuns, 0) > 0] |
| allObjects <- badMethods |
| attr(allObjects, "functions") <- uniqueFuns |
| } |
| allObjects |
| } |
| |
| ## ## this function warns of S3 methods for S4 classes, but only once per package |
| ## ## per session. |
| ## .checkS3forS4 <- function(method) { |
| ## envir <- environment(method) |
| ## pkg <- getPackageName(envir) |
| ## if(!nzchar(pkg)) pkg <- getPackageName(parent.env(pkg)) #? if generic function |
| ## if(!nzchar(pkg)) pkg <- format(envir) |
| ## if(!exists(".WarnedS3forS4", .GlobalEnv, inherits = FALSE)) |
| ## assign(".WarnedS3forS4", character(), envir = .GlobalEnv) |
| ## if(is.na(match(pkg, .WarnedS3forS4))) { |
| ## methods <- S3forS4Methods(envir) |
| ## .WarnedS3forS4 <<- c(.WarnedS3forS4, pkg) |
| ## if(length(methods) > 0) { |
| ## warning("S3 methods written for S4 classes will fail inheritance!\nPackage ", pkg, " apparently has ", |
| ## length(methods), " such methods for the functions ", paste(attr(methods, "functions"), collapse = ", "), "\n\n", |
| ## "Possible dangerous methods: ", paste(methods, collapse =", "), |
| ## "\n\n(Warnings generated once per package per session)") |
| ## } |
| ## } |
| ## } |
| |
| ## a warning when a class is defined that extends classes with S3 methods. |
| ## .checkS3forClass <- function(className, where, what = className) { |
| ## badMethods <- S3forS4Methods(where, what) |
| ## if(length(badMethods) > 0) { |
| ## msg <- paste0("The apparent methods are ", paste('"',badMethods, '"', collapse = ", ")) |
| ## warning("Some of the superclasses in the definition of class \"", |
| ## className, "\" have apparent S3 methods.\n\nThese will be hidden by the S3 class that this class contains. (See ?Methods)\n\n", msg) |
| ## } |
| ## } |
| |
| ## a utility to detect mixin classes: meant to be fast for use in |
| ## initialize methods (cf the "matrix" method in BasicClasses.R) |
| isMixin <- function(classDef) { |
| val <- 0 |
| cc <- classDef@contains |
| ## relies on the superclasses in contains slot being ordered by distance |
| for(cl in cc) { |
| if(cl@distance > 1 || val > 1) |
| break |
| val <- val + 1 |
| } |
| val > 1 |
| } |
| |
| .classDefIsLocked <- function(classDef) { |
| what <- classMetaName(classDef@className) |
| env <- .NamespaceOrEnvironment(classDef@package) |
| is.environment(env) && exists(what, envir = env, inherits = FALSE) && |
| bindingIsLocked(what, env) |
| } |
