# File src/library/methods/R/BasicClasses.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/ ## 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(""), where = envir); clList <- c(clList, "name") .setBaseClass("call", "language", prototype = quote(""()), 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(""<-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 <- stats::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 S3Class <- if(length(S3Class)) S3Class[[1L]] else "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) }