# 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("<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 <- 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)
}