| # File src/library/methods/R/BasicClasses.R |
| # Part of the R package, https://www.R-project.org |
| # |
| # Copyright (C) 1995-2018 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/ |
| |
| |
| ## a few class name definitions needed elsewhere |
| .anyClassName <- structure("ANY", package = "methods") |
| .signatureClassName <- structure("signature", package = "methods") |
| |
| |
| |
| .InitBasicClasses <- function(envir) |
| { |
| ## setClass won't allow redefining basic classes, |
| ## so make the list of these empty for now. |
| assign(".BasicClasses", character(), envir) |
| ## hide some functions that would break because the basic |
| ## classes are not yet defined |
| real.reconcileP <- reconcilePropertiesAndPrototype |
| assign("reconcilePropertiesAndPrototype", |
| function(name, properties, prototype, extends, where) { |
| list(properties=properties, prototype = prototype, extends = extends) |
| }, envir) |
| clList <- c("VIRTUAL", "ANY", "vector", "missing") |
| for(.class in clList) |
| setClass(.class, where = envir) |
| ## Now some pseudo-classes in base, marked specially for new() |
| ## "numeric" is the class returned by class() for double vectors |
| vClasses <- c("logical", "numeric", "character", |
| "double", |
| "complex", "integer", "raw", |
| "expression", "list") |
| for(.class in vClasses) { |
| .setBaseClass(.class, prototype = newBasic(.class), where = envir) |
| } |
| .setBaseClass("expression", prototype = expression(), where = envir) |
| clList <- c(clList, vClasses) |
| nullF <- function()NULL; environment(nullF) <- .GlobalEnv |
| nullF <- utils::removeSource(nullF) |
| attr(nullF, "source") <- NULL |
| .setBaseClass("function", prototype = nullF, where = envir); clList <- c(clList, "function") |
| |
| setClass("language", where = envir); clList <- c(clList, "language") |
| .setBaseClass("environment", prototype = new.env(), where = envir); clList <- c(clList, "environment") |
| |
| .setBaseClass("externalptr", prototype = .newExternalptr(), where = envir); clList <- c(clList, "externalptr") |
| |
| .setBaseClass("builtin", prototype = `<-`, where = envir); clList <- c(clList, "builtin") |
| |
| .setBaseClass("special", prototype = `if`, where = envir); clList <- c(clList, "special") |
| |
| ## S4, S3 are basic classes that are used to define methods related to being S4, S3 object |
| for(cl in c("S4", "S3")) { |
| tmp <- newClassRepresentation(className=cl, prototype = defaultPrototype(), virtual=TRUE, package = "methods") |
| assignClassDef(cl, tmp, where = envir); clList <- c(clList, cl) |
| } |
| |
| ## NULL is weird in that it has NULL as a prototype, but is not virtual |
| tmp <- newClassRepresentation(className="NULL", prototype = NULL, virtual=FALSE, package = "methods") |
| assignClassDef("NULL", tmp, where = envir); clList <- c(clList, "NULL") |
| ## the pseudo-NULL used to store NULL as a slot |
| ## must match the C code in attrib.c (would be better to use that |
| ## code to create .pseudoNULL) |
| assign(".pseudoNULL", as.name("\001NULL\001"), envir = envir) |
| |
| |
| setClass("structure", where = envir); clList <- c(clList, "structure") |
| setClass("nonStructure", where = envir); #NOT a basic class |
| stClasses <- c("matrix", "array") # classes that have attributes, but no class attr. |
| for(.class in stClasses) { |
| .setBaseClass(.class, prototype = newBasic(.class), where = envir) |
| } |
| ## "ts" will be defined below as an S3 class, but it is still |
| ## included in .BasicClasses, to allow its coerce() method to use |
| ## as.ts(). This decision may be revisited. |
| clList <- c(clList, stClasses, "ts") |
| assign(".BasicClasses", clList, envir) |
| |
| ## Now we can define the SClassExtension class and use it to instantiate some |
| ## is() relations. |
| .InitExtensions(envir) |
| |
| for(.class in vClasses) |
| setIs(.class, "vector", where = envir) |
| |
| ## The one place where "double" and "numeric" currently differ: |
| setIs("integer", "double", where = envir, |
| coerce = .gblEnv(function(object) as.double(object)), |
| replace = .gblEnv(function(from, value) { class(value) <- "integer" ; value })) |
| setIs("integer", "numeric", where = envir) |
| setIs("double", "numeric", where = envir) |
| setIs("structure", "vector", coerce = .gblEnv(function(object) as.vector(object)), |
| replace = .gblEnv(function(from, to, value) { |
| attributes(value) <- attributes(from) |
| value |
| }), |
| where = envir) |
| |
| setIs("array", "structure", where = envir) |
| setIs("matrix", "array", where = envir) |
| ### Rather want a simple setAs("array", "matrix", ..) method.. |
| ## setIs("array", "matrix", test = .gblEnv(function(object) length(dim(object)) == 2), |
| ## replace = .gblEnv(function(from, to, value) { |
| ## if(is(value, "matrix")) |
| ## value |
| ## else |
| ## stop("replacement value is not a matrix") |
| ## }), |
| ## where = envir) |
| |
| ## Some class definitions extending "language", delayed to here so |
| ## setIs will work. |
| .setBaseClass("name", "language", prototype = as.name("<UNDEFINED>"), where = envir); clList <- c(clList, "name") |
| .setBaseClass("call", "language", prototype = quote("<undef>"()), where = envir); clList <- c(clList, "call") |
| .setBaseClass("{", "language", prototype = quote({}), where = envir); clList <- c(clList, "{") |
| .setBaseClass("if", "language", prototype = quote(if(NA) TRUE else FALSE), where = envir); clList <- c(clList, "if") |
| .setBaseClass("<-", "language", prototype = quote("<undef>"<-NULL), where = envir); clList <- c(clList, "<-") |
| .setBaseClass("for", "language", prototype = quote(for(NAME in logical()) NULL), where = envir); clList <- c(clList, "for") |
| .setBaseClass("while", "language", prototype = quote(while(FALSE) NULL), where = envir); clList <- c(clList, "while") |
| .setBaseClass("repeat", "language", prototype = quote(repeat{break}), where = envir); clList <- c(clList, "repeat") |
| .setBaseClass("(", "language", prototype = quote((NULL)), where = envir); clList <- c(clList, "(") |
| |
| ## a virtual class used to allow NULL as an indicator that a possible function |
| ## is not supplied (used, e.g., for the validity slot in classRepresentation |
| setClass("OptionalFunction", where = envir) |
| setIs("function", "OptionalFunction", where = envir) |
| setIs("NULL", "OptionalFunction") |
| assign(".BasicClasses", clList, envir) |
| assign(".SealedClasses", clList, envir) |
| ## restore the true definition of the hidden functions |
| assign("reconcilePropertiesAndPrototype", real.reconcileP, envir) |
| } |
| |
| .InitS3Classes <- function(envir) { |
| ## create a virtual class from which all S3 classes will inherit the .S3Class slot |
| setClass("oldClass", representation(.S3Class = "character"), |
| contains = "VIRTUAL", prototype = prototype(.S3Class = character()), |
| where = envir) |
| ## call setOldClass on some known old-style classes. Ideally this would be done |
| ## in the code that uses the classes, but that code doesn't know about the methods |
| ## package. |
| ## Two steps; first, those classes with a known prototype. These |
| ## can be non-Virtual |
| clList <- get(".SealedClasses", envir = envir) |
| for(i in seq_along(.OldClassesPrototypes)) { |
| el <- .OldClassesPrototypes[[i]] |
| if(is.list(el) && length(el) > 1) |
| setOldClass(el[[1L]], prototype = el[[2L]], where = envir) |
| else |
| warning(gettextf("OOPS: something wrong with '.OldClassesPrototypes[[%d]]'", i), |
| domain = NA) |
| } |
| setGeneric("slotsFromS3", where = envir) |
| ## the method for "oldClass" is really a constant, just hard to express that way |
| setMethod("slotsFromS3", "oldClass", function(object) getClass("oldClass")@slots, |
| where = envir) |
| |
| setClass("ts", contains = "structure", representation(tsp = "numeric"), |
| prototype = prototype(NA, tsp = rep(1,3)), where = envir) |
| |
| setOldClass("ts", S4Class = "ts", where = envir) |
| |
| setClass("mts", contains=c("matrix", "ts"), prototype = |
| prototype(matrix(NA,1,1), tsp = rep(1,3), .S3Class = c("mts", "ts"))) |
| .init_ts <- function(.Object, ...) { |
| if(nargs() < 2) # guaranteed to be called with .Object from new |
| return(.Object) |
| args <- list(...) |
| argnames <- names(args) |
| slotnames <- if(is.null(argnames)) FALSE else { |
| nzchar(argnames) & is.na(match(argnames, .tsArgNames)) } |
| if(any(slotnames)) { |
| value <- do.call(stats::ts, args[!slotnames]) |
| .mergeAttrs(value, .Object, args[slotnames]) |
| } |
| else |
| .mergeAttrs(stats::ts(...), .Object) |
| } |
| setMethod("initialize", "ts", .init_ts, where = envir) |
| setMethod("initialize", "mts", .init_ts, where = envir) #else, it's ambiguous |
| ## the following mimics settings for other basic classes ("ts" was |
| ## not defined at the time these are done). |
| setMethod("coerce", c("ANY", "ts"), function (from, to, strict = TRUE) |
| { |
| value <- as.ts(from) |
| if(strict) { |
| attrs <- attributes(value) |
| if(length(attrs) > 2) |
| attributes(value) <- attrs[c("class", "tsp")] |
| value <- .asS4(value) |
| } |
| value |
| }, |
| where = envir) |
| setClass("factor", contains = "integer", representation(levels = "character"), |
| validity = base::.valid.factor, where = envir) |
| setOldClass("factor", S4Class = "factor", where = envir) |
| setClass("ordered", contains = "factor", where = envir) |
| setOldClass("ordered", S4Class = "ordered", where = envir) |
| if(!isGeneric("show", envir)) |
| setGeneric("show", where = envir, simpleInheritanceOnly = TRUE) |
| setMethod("show", "oldClass", function(object) { |
| if(!isS4(object)) { |
| print(object) |
| return(invisible()) |
| } |
| cl <- as.character(class(object)) |
| S3Class <- object@.S3Class |
| if(length(S3Class)) S3Class <- S3Class[[1L]] |
| else S3Class <- "oldClass" # or error? |
| cat("Object of class \"", cl, "\"\n", sep = "") |
| print(S3Part(object, strictS3 = TRUE)) |
| otherSlots <- slotNames(cl) |
| S3slots <- slotNames(S3Class) |
| otherSlots <- otherSlots[is.na(match(otherSlots, S3slots))] |
| for(what in otherSlots) { |
| cat('Slot "', what, '":\n', sep = "") |
| show(slot(object, what)) |
| cat("\n") |
| } |
| NULL |
| }, where = envir) |
| .initS3 <- function(.Object, ...) { |
| if(nargs() < 2) |
| return(.Object) |
| Class <- class(.Object) |
| ClassDef <- getClass(Class) |
| S3Class <- attr(ClassDef@prototype, ".S3Class") |
| if(is.null(S3Class)) # not a class set up by setOldClass() |
| return(callNextMethod()) |
| S3ClassP <- S3Class[[1L]] |
| args <- list(...) |
| ## separate the slots, superclass objects |
| snames <- allNames(args) |
| which <- nzchar(snames) |
| elements <- args[which] |
| supers <- args[!which] |
| thisExtends <- names(ClassDef@contains) |
| slotDefs <- ClassDef@slots |
| dataPart <- slotDefs[[".Data"]] |
| if(is.null(dataPart)) |
| dataPart <- "missing" # nothing will extend this => no data part args allowed |
| for(i in rev(seq_along(supers))) { |
| obj <- supers[[i]] |
| Classi <- class(obj) |
| defi <- getClassDef(Classi) |
| if(is.null(defi)) |
| stop(gettextf( |
| "unnamed argument to initialize() for S3 class must have a class definition; %s does not", |
| dQuote(Classi)), |
| domain = NA) |
| if(is(obj, S3ClassP)) { |
| ## eligible to be the S3 part; merge other slots from prototype; |
| ## obj then becomes the object, with its original class as the S3Class |
| if(is.null(attr(obj, ".S3Class"))) # must be an S3 object; use its own class |
| attr(obj, ".S3Class") <- Classi |
| .Object <- .asS4(.mergeAttrs(obj, .Object)) |
| } |
| else if(is(obj, dataPart)) { |
| ## the S3Class stays from the prototype |
| .Object <- .mergeAttrs(obj, .Object) |
| } |
| else stop(gettextf( |
| "unnamed argument must extend either the S3 class or the class of the data part; not true of class %s", |
| dQuote(Classi)), domain = NA) |
| } |
| ## named slots are done as in the default method, which will also call validObject() |
| if(length(elements)>0) { |
| elements <- c(list(.Object), elements) |
| .Object <- do.call(`callNextMethod`, elements) |
| } |
| else |
| validObject(.Object) |
| .Object |
| } |
| setMethod("initialize", "oldClass", .initS3, where = envir) |
| ## Next, miscellaneous S3 classes. |
| for(cl in .OldClassesList) |
| setOldClass(cl, where = envir) |
| ## special mess for "maov"; see comment in .OldClassesList |
| setIs("maov", "aov") |
| setClassUnion("data.frameRowLabels", c("character", "integer"), where = envir) |
| setClass("data.frame", |
| representation(names = "character", row.names = "data.frameRowLabels"), |
| contains = "list", prototype = unclass(data.frame()), where = envir) # the S4 version |
| setOldClass("data.frame", S4Class = "data.frame", where = envir) |
| ## the S3 methods for $<-, [[<- and [<- do some stupid things to class() |
| ## This buffers the effect from S4 classes |
| setMethod("$<-", "data.frame", where = envir, |
| function(x, name, value) { |
| S3Part(x) <- `$<-.data.frame`(S3Part(x, TRUE), name, value) |
| x |
| }) |
| callBracketReplaceGeneric <- function() { |
| call <- sys.call(sys.parent()) |
| which.ij <- if (length(call) > 4L) 3:4 else 3L |
| ij <- as.list(call[which.ij]) |
| present <- logical(length(ij)) |
| for (a in seq_along(ij)) { |
| arg <- ij[[a]] |
| present[a] <- !missing(arg) |
| } |
| ij[present] <- head(c(quote(i), quote(j)), length(ij))[present] |
| call <- as.call(c(call[[1L]], quote(x3), ij, quote(...), |
| value=quote(value))) |
| eval(call, parent.frame()) |
| } |
| setMethod("[<-", "data.frame", where = envir, |
| function (x, i, j, ..., value) { |
| x3 <- S3Part(x, TRUE) |
| S3Part(x) <- callBracketReplaceGeneric() |
| x |
| }) |
| setMethod("[[<-", "data.frame", where = envir, |
| function (x, i, j, ..., value) { |
| x3 <- S3Part(x, TRUE) |
| S3Part(x) <- callBracketReplaceGeneric() |
| x |
| }) |
| ## methods to go from S4 to S3; first, using registered class; second, general S4 object |
| setMethod("coerce", c("oldClass", "S3"), function (from, to, strict = TRUE) |
| { |
| from <- .notS4(from) # not needed? ensures that class() can return >1 string |
| cl <- class(from) |
| cl1 <- .class1(from) |
| classDef <- getClassDef(cl1) |
| S3Class <- attr(classDef@prototype, ".S3Class") |
| if(length(S3Class) > length(cl)) #add S3 inheritance |
| attr(from, "class") <- S3Class |
| from |
| }, |
| where = envir) |
| setMethod("coerce", c("ANY", "S3"), function (from, to, strict = TRUE) |
| { |
| switch(typeof(from), |
| S4 = |
| stop(gettextf("class %s does not have an S3 data part, and so is of type \"S4\"; no S3 equivalent", |
| dQuote(class(from))), |
| domain = NA), |
| .notS4(from) ) |
| }, |
| where = envir) |
| setMethod("coerce", c("ANY", "S4"), function (from, to, strict = TRUE) |
| { |
| if(isS4(from)) { |
| value <- from |
| } |
| else { |
| cl <- .class1(from) |
| classDef <- getClass(cl) |
| if(isTRUE(classDef@virtual)) |
| stop(gettextf("class %s is VIRTUAL; not meaningful to create an S4 object from this class", |
| dQuote(cl)), |
| domain = NA) |
| pr <- classDef@prototype |
| value <- new(cl) |
| slots <- classDef@slots |
| if(match(".Data", names(slots), 0L) > 0L) { |
| data <- unclass(from) |
| if(!is(data, slots[[".Data"]])) |
| stop(gettextf("object must be a valid data part for class %s; not true of type %s", |
| dQuote(cl), dQuote(class(data))), |
| domain = NA) |
| value@.Data <- unclass(from) |
| } |
| ## copy attributes: Note that this copies non-slots as well |
| ## but checks the slots for validity |
| anames <- names(attributes(from)) |
| isSlot <- anames %in% names(slots) |
| for(i in seq_along(anames)) { |
| what <- anames[[i]] |
| if(isSlot[[i]]) |
| slot(value, what) <- attr(from, what) |
| else |
| attr(value, what) <- attr(from, what) |
| } |
| } |
| if(strict) |
| ## validate. If we created S4 object, slots were tested; else, not |
| ## so complete= is set accordingly. |
| validObject(value, complete = isS4(from)) |
| value |
| }) |
| assign(".SealedClasses", c(clList,unique(unlist(.OldClassesList))), envir) |
| } |
| |
| ### create a class definition for one of the pseudo-classes in base |
| ### The class name does _not_ have a package attribute, which signals |
| ### the C coded for new() to return an object w/o explicit class |
| ### attribute, to be consistent with older R code |
| .setBaseClass <- function(cl, ..., where) { |
| setClass(cl, ..., where = where) |
| def <- getClassDef(cl, where) |
| def@className <- as.character(def@className) |
| def@prototype <- .notS4(def@prototype) |
| assignClassDef(cl, def, where = where) |
| } |
| |
| |
| .tsArgNames <- names(formals(stats::ts)) |
| |
| ### The following methods are now activated |
| ### via the last line of the function .InitMethodDefinitions in ./MethodsListClass.R |
| ### |
| ### Tradeoff between intuition of users that |
| ### new("matrix", ...) should be like matrix(...) vs consistency of new(). |
| ### Relevant when new class has basic class as its data part. |
| .InitBasicClassMethods <- function(where) { |
| ## methods to initialize "informal" classes by using the |
| ## functions of the same name. |
| |
| ## These methods are designed to be inherited or extended |
| initMatrix <- function(.Object, data = NA, nrow = 1, ncol = 1, |
| byrow = FALSE, dimnames = NULL, ...) { |
| na <- nargs() |
| if(length(dots <- list(...)) && ".Data" %in% names(dots)) { |
| if(na == 2) |
| .Object <- .mergeAttrs(dots$.Data, .Object) |
| else { |
| dat <- dots$.Data |
| dots <- dots[names(dots) != ".Data"] |
| if(na == 2 + length(dots)) { |
| .Object <- .mergeAttrs(as.matrix(dat), .Object, dots) |
| } |
| else |
| stop("cannot specify matrix() arguments when specifying '.Data'") |
| } |
| } |
| else if(is.matrix(data) && na == 2 + length(dots)) |
| .Object <- .mergeAttrs(data, .Object, dots) |
| else { |
| if (missing(nrow)) |
| nrow <- ceiling(length(data)/ncol) |
| else if (missing(ncol)) |
| ncol <- ceiling(length(data)/nrow) |
| value <- matrix(data, nrow, ncol, byrow, dimnames) |
| .Object <- .mergeAttrs(value, .Object, dots) |
| } |
| validObject(.Object) |
| .Object |
| } |
| .matrixExtends <- unique(c("matrix", names(getClass("matrix")@contains))) |
| setMethod("initialize", "matrix", where = where, |
| function(.Object, ...) { |
| if(nargs() < 2) # guaranteed to be called with .Object from new |
| return(.Object) |
| else { |
| if(isMixin(getClass(class(.Object)))) # other superclasses |
| callNextMethod() |
| else |
| initMatrix(.Object, ...) |
| } |
| } |
| ) |
| initArray <- function(.Object, data = NA, dim = length(data), |
| dimnames = NULL, ...) { |
| na <- nargs() |
| if(length(dots <- list(...)) && ".Data" %in% names(dots)) { |
| if(na == 2) |
| .Object <- .mergeAttrs(dots$.Data, .Object) |
| else { |
| dat <- dots$.Data |
| dots <- dots[names(dots) != ".Data"] |
| if(na == 2 + length(dots)) { |
| .Object <- .mergeAttrs(as.array(dat), .Object, dots) |
| } |
| else |
| stop("cannot specify array() arguments when specifying '.Data'") |
| } |
| } |
| else if(is.array(data) && na == 2 + length(dots)) |
| .Object <- .mergeAttrs(data, .Object, dots) |
| else { |
| value <- array(data, dim, dimnames) |
| .Object <- .mergeAttrs(value, .Object, dots) |
| } |
| validObject(.Object) |
| .Object |
| } |
| .arrayExtends <- unique(c("array", names(getClass("array")@contains))) |
| setMethod("initialize", "array", where = where, |
| function(.Object, ...) { |
| if(nargs() < 2) # guaranteed to be called with .Object from new |
| .Object |
| else { |
| if(isMixin(getClass(class(.Object)))) # other superclasses |
| callNextMethod() |
| else |
| initArray(.Object, ...) |
| } |
| } |
| ) |
| ## following should not be needed if data_class2 returns "array",... |
| ## setMethod("[", # a method to avoid invalid objects from an S4 class |
| ## signature(x = "array"), where = where, |
| ## function (x, i, j, ..., drop = TRUE) |
| ## { |
| ## value <- callNextMethod() |
| ## if(is(value, class(x))) |
| ## value@.Data |
| ## else |
| ## value |
| ## }) |
| |
| } |
| |
| ## .OldClassesList is a purely heuristic list of known old-style classes, with emphasis |
| ## on old-style class inheritiance. Used in .InitBasicClasses to call setOldClass for |
| ## each known class pattern. |
| ## .OldClassesPrototypes is a list of S3 classes for which prototype |
| ## objects are known & reasonable. |
| ## Its classes should not reappear in .OldClassesList (as these become VIRTUAL) |
| ## and will have been initialized first in .InitBasicClasses(). |
| ## NB: the methods package will NOT set up prototypes for S3 classes |
| ## except those in package base and for "ts" and "formula" |
| ## (and would rather not do those either). |
| ## Ideally, the package that owns the S3 class should have code to call |
| ## setOldClass in its initialization. |
| .OldClassesPrototypes <- |
| list( |
| list("data.frame", data.frame(), "data.frame"), |
| list("factor", factor()), |
| list("table", table(factor())), |
| list("summary.table", summary.table(table(factor()))) |
| , list("ts", stats::ts()) |
| , list("formula", stats::formula()) |
| ) |
| .OldClassesList <- |
| list( |
| c("anova", "data.frame"), |
| c("mlm", "lm"), |
| c("aov", "lm"), |
| ## note: definition of "maov" below differs from the |
| ## current S3 attribute, which has an inconsistent combination |
| ## of "aov" and "mlm" (version 2.12 devel, rev. 51984) |
| c("maov", "mlm", "lm"), |
| c("POSIXct", "POSIXt"), |
| c("POSIXlt", "POSIXt"), |
| "Date", |
| "dump.frames", |
| c("glm.null", "glm", "lm"), |
| c("anova.glm.null", "anova.glm"), |
| "hsearch", |
| "integrate", |
| "packageInfo", |
| "libraryIQR", |
| "packageIQR", |
| "mtable", |
| c("summaryDefault","table"), |
| "recordedplot", |
| "socket", |
| "packageIQR", |
| "density", |
| "logLik", |
| "rle" |
| ) |
| |
| .InitSpecialTypesAndClasses <- function(where) { |
| if(is.null(S3table <- where$.S3MethodsClasses)) { |
| S3table <- new.env() |
| assign(".S3MethodsClasses", S3table, envir = where) |
| } |
| specialClasses <- .indirectAbnormalClasses |
| specialTypes <- .AbnormalTypes # only part matching classes used |
| for(i in seq_along(specialClasses)) { |
| cl <- specialTypes[[i]] |
| ncl <- specialClasses[[i]] |
| setClass(ncl, representation(.xData = cl), where = where) |
| setIs(ncl, cl, coerce = function(from) from@.xData, |
| replace = function(from, value){ from@.xData <- value; from}, |
| where = where) |
| ## these classes need explicit coercion for S3 methods |
| assign(cl, getClass(cl, where), envir = S3table) |
| } |
| ## a few other special classes |
| setClass("namedList", representation(names = "character"), |
| contains = "list", where = where) |
| if(!isGeneric("show", where)) |
| setGeneric("show", where = where, simpleInheritanceOnly = TRUE) |
| setMethod("show", "namedList", function(object) { |
| cat("An object of class ", dQuote(class(object)), "\n") |
| print(structure(object@.Data, names=object@names)) |
| showExtraSlots(object, getClass("namedList")) |
| }) |
| setClass("listOfMethods", representation(arguments = "character", |
| signatures = "list", generic = "genericFunction"), |
| contains = "namedList", |
| where = where) |
| specialClasses <- c(specialClasses, "namedList", "listOfMethods") |
| assign(".SealedClasses", c(get(".SealedClasses", where), specialClasses), where) |
| setMethod("initialize", ".environment", # for simple subclasses of "environment" |
| function(.Object, ...) { |
| args <- list(...) |
| objs <- names(args) |
| hasEnvArg <- length(args) && !all(nzchar(objs)) |
| if(hasEnvArg) { |
| ii <- seq_along(args)[!nzchar(objs)] |
| i <- integer() |
| for(iii in ii) { |
| if(is(args[[iii]], "environment")) |
| i <- c(i, iii) |
| } |
| if(length(i)>1) |
| stop("cannot have more than one unnamed argument as environment") |
| if(length(i) == 1) { |
| selfEnv <- args[[i]] |
| args <- args[-i] |
| objs <- objs[-i] |
| if(!is(selfEnv, "environment")) |
| stop("unnamed argument to new() must be an environment for the new object") |
| selfEnv <- as.environment(selfEnv) |
| } |
| ## else, no environment superclasses |
| else |
| selfEnv <- new.env() |
| } |
| else |
| selfEnv <- new.env() |
| if(length(objs)) { |
| ## don't assign locally named slots of subclasses |
| ClassDef <- getClass(class(.Object)) |
| slots <- slotNames(ClassDef) |
| localObjs <- is.na(match(objs, slots)) |
| if(any(localObjs)) { |
| for(what in objs[localObjs]) |
| selfEnv[[what]] <- args[[what]] |
| objs <- objs[!localObjs] |
| args <- args[!localObjs] |
| } |
| } |
| .Object@.xData <- selfEnv |
| if(length(objs)) # call next method with remaining args |
| .Object <- do.call(callNextMethod, c(.Object, args)) |
| .Object |
| }, where = where) |
| } |
