1# File src/library/methods/R/oldClass.R 2# Part of the R package, https://www.R-project.org 3# 4# Copyright (C) 1995-2015 The R Core Team 5# 6# This program is free software; you can redistribute it and/or modify 7# it under the terms of the GNU General Public License as published by 8# the Free Software Foundation; either version 2 of the License, or 9# (at your option) any later version. 10# 11# This program is distributed in the hope that it will be useful, 12# but WITHOUT ANY WARRANTY; without even the implied warranty of 13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14# GNU General Public License for more details. 15# 16# A copy of the GNU General Public License is available at 17# https://www.R-project.org/Licenses/ 18 19## assumes oldClass has been defined as a virtual class 20 21setOldClass <- function(Classes, prototype = NULL, 22 where = topenv(parent.frame()), test = FALSE, 23 S4Class) { 24 simpleCase <- is.null(prototype) 25 mainClass <- Classes[[1L]] 26 prevDef <- getClassDef(mainClass, where, inherits = FALSE) 27 if(!missing(S4Class)) { 28 if(test) 29 stop("not allowed to have test==TRUE and an S4Class definition") 30 if(!is(S4Class, "classRepresentation")) { 31 if(is.character(S4Class)) { 32 clName <- S4Class 33 S4Class <- getClass(S4Class) 34 if(.identC(clName, Classes[[1L]])) 35 removeClass(clName, where = where) # so Recall() will work 36 } 37 else 38 stop(gettextf("argument 'S4Class' must be a class definition: got an object of class %s", 39 dQuote(class(S4Class))), 40 domain = NA) 41 } 42 if(!is.null(prototype)) { 43 S4prototype <- S4Class@prototype 44 ## use the explicit attributes from the supplied argument, else S4prototype 45 S4Class@prototype <- .mergeAttrs(prototype, S4prototype) 46 } 47 ## register simple S3 class(es), including main class, if it's not defined already 48 Recall(Classes, where = where) 49 return(.S4OldClass(Classes[[1L]], if(length(Classes) > 1) Classes[[2L]] else "oldClass", S4Class, where, prevDef)) 50 } 51 if(test) 52 return(.setOldIs(Classes, where)) 53 if(!is.null(prevDef)) { 54 on.exit(.restoreClass(prevDef, where)) 55 removeClass(mainClass, where = where) # so Recall() will work 56 } 57 prevClass <- "oldClass" 58 S3Class <- character() #will accumulate the S3 classes inherited 59 ## The table of S3 classes, used 60 ## to convert S4 objects in S3 method dispatch. 61 ## TODO: should provide an optional argument to setOldClass() 62 ## to prevednt this conversion if it's not needed 63 if(is.null(S3table <- where$.S3MethodsClasses)) { 64 S3table <- new.env() 65 assign(".S3MethodsClasses", S3table, envir = where) 66 } 67 dataPartClass <- NULL 68 for(cl in rev(Classes)) { 69 S3Class <- c(cl, S3Class) 70 if(isClass(cl, where)) { 71 def <- getClass(cl, where) 72 if(!extends(def, prevClass)) { 73 ## maybe an object type or other valid data part 74 cl1 <- .validDataPartClass(cl, where, dataPartClass) 75 if(is.null(cl1)) 76 stop(gettextf("inconsistent old-style class information for %s; the class is defined but does not extend %s and is not valid as the data part", 77 dQuote(cl), 78 dQuote(prevClass)), 79 domain = NA) 80 else dataPartClass <- cl1 81 } 82 else { 83 prevP <- def@prototype 84 if(missing(prototype)) 85 prototype <- prevP # keep track of inherited prototype for use in mainClass 86 prevS3Class <- attr(prevP, ".S3Class") 87 if(length(prevS3Class) > length(S3Class)) #implies cl is registered S3 class 88 S3Class <- prevS3Class 89 } 90 } 91 else { 92 useP <- TRUE 93 if(cl != mainClass || simpleCase) { 94 setClass(cl, contains = c(prevClass, "VIRTUAL"), where = where) 95 } 96 else if(isClass(class(prototype))) 97 setClass(cl, contains = prevClass, prototype = prototype, where = where) 98 else { #exceptionally, we allow an S3 object from the S3 class as prototype 99 if(.class1(prototype) != mainClass) 100 stop(gettextf('the S3 class of the prototype, "%s", is undefined; only allowed when this is the S3 class being registered ("%s")', .class1(prototype), mainClass), domain = NA) 101 setClass(cl, contains = prevClass, where = where) 102 useP <- FALSE 103 } 104 def <- getClassDef(cl, where) 105 if(useP) clp <- def@prototype else clp <- prototype 106 attr(clp, ".S3Class") <- S3Class 107 def@prototype <- .notS4(clp) 108 assignClassDef(cl, def, where = where) 109 ## add the class to the table of S3 classes 110 assign(cl, def, envir= S3table) 111 } 112 prevClass <- cl 113 } 114 if(!is.null(prevDef)) # cancel error action 115 on.exit() 116} 117 118.restoreClass <- function(def, where) { 119 cl <- def@className 120 message(gettextf("restoring definition of class %s", dQuote(cl)), 121 domain = NA) 122 if(isClass(cl, where = where)) 123 removeClass(cl, where = where) 124 assignClassDef(cl, def, where = where) 125} 126 127.S4OldClass <- function(Class, prevClass, def,where, prevDef) { 128 ## def is the S4 version of this class def'n, maybe by another class 129 ## name, and may or may not already extend oldClass 130 curDef <- getClassDef(Class, where) # asserted to be defined 131 ## arrange to restore previous definition if there was one. Also done in setOldClass 132 ## when no S4Class argument supplied 133 if(!is.null(prevDef)) { 134 on.exit(.restoreClass(prevDef, where)) 135 removeClass(Class, where = where) # so Recall() will work 136 } 137 if(!identical(def@className, curDef@className)) 138 def <- .renameClassDef(def, curDef@className) 139 ## check that any common slots will give a valid S3 object 140 .validS3Extends(def, curDef) 141 def@slots[names(curDef@slots)] <- curDef@slots 142 ext <- c(def@contains, curDef@contains) 143 ## correct ordering & duplicate resolution: copied from .walkClassGraph 144 distOrder <- sort.list(vapply(ext, function(x) x@distance, 1)) 145 ext <- ext[distOrder] 146 if(anyDuplicated(names(ext))) 147 ext <- .resolveSuperclasses(def, ext, where) 148 def@contains <- ext 149 oldSupers <- setdiff(names(def@contains), names(curDef@contains)) 150 addSubclass <- function(super) { 151 superDef <- getClassDef(super, where) 152 superWhere <- .findOrCopyClass(super, superDef, where, "subclass") 153 superDef@subclasses[[Class]] <- def@contains[[super]] 154 assignClassDef(super, superDef, superWhere, TRUE) 155 } 156 lapply(oldSupers, addSubclass) 157 subcls <- curDef@subclasses 158 if(length(subcls) > 0) { 159 def@subclasses[names(subcls)] <- subcls 160 } 161 proto <- def@prototype 162 if(is.null(attr(proto, ".S3Class"))) { # no S3 class slot, as will usually be true 163 attr(proto, ".S3Class") <- if(.identC(prevClass, "oldClass")) Class else S3Class(curDef@prototype) 164 def@prototype <- proto 165 } 166 assignClassDef(Class, def, where = where) 167 ## allow an existing superclass relation to remain (it may have a coerce method) 168 ## Otherwise, create a simple transformation, which relies on consistency 169 ## in the slots. 170 if(!extends(def, prevClass, maybe = FALSE)) 171 setIs(Class, prevClass, classDef = def, where = where) 172 slotsMethod <- function(object) NULL 173 body(slotsMethod) <- substitute({LIST}, list(LIST = def@slots)) 174 setMethod("slotsFromS3", Class, slotsMethod, where = where) 175 if(!is.null(prevDef)) # cancel error action 176 on.exit() 177} 178 179.validS3Extends <- function(classDef1, classDef2) { 180 slots2 <- classDef2@slots 181 if(length(slots2) > 0) { 182 n2 <- names(slots2) 183 slots1 <- classDef1@slots 184 n1 <- names(slots1) 185 bad <- character() 186 for(what in n2[match(n2, n1, 0) > 0]) 187 if(!extends(slots1[[what]], slots2[[what]])) { 188 message(gettextf("slot %s: class %s should extend class %s", 189 sQuote(what), 190 dQuote(slots1[[what]]), 191 dQuote(slots2[[what]])), 192 domain = NA) 193 bad <- c(bad, what) 194 } 195 if(length(bad)>0) 196 stop( 197 gettextf("invalid S4 class corresponding to S3 class: slots in S4 version must extend corresponding slots in S3 version: fails for %s", 198 paste0('"', bad, '"', collapse = ", ")), 199 domain = NA) 200 } 201 TRUE 202} 203 204##.initS3Classes will make this generic, with a method for "oldClass" 205slotsFromS3 <- function(object) { 206 list() 207} 208 209utils::globalVariables("CLASS") 210 211.oldTestFun <- function(object) CLASS %in% attr(object, "class") 212.oldCoerceFun <- function(from, strict = TRUE) { 213 if(strict) 214 stop(gettextf("explicit coercion of old-style class (%s) is not defined", paste(class(from), collapse = ", ")), domain = NA) 215 from 216} 217.oldReplaceFun <- function(from, to, value) 218 stop(gettextf("explicit replacement not defined for as(x, \"%s\") <- value for old-style class %s", 219 to, dQuote(class(from)[1L])), 220 domain = NA) 221 222## the inheritance of these S3 classes must be decided on a per-instance 223## basis. At one time, there were classes in base/stats that had this 224## property, (e.g., POSIXt, POSIX{cl}t) but apparently no longer. 225## The possibility is still allowed 226## for user-defined S3 classes. 227.setOldIs <- function(Classes, where) { 228 if(length(Classes) != 2) 229 stop(gettextf("argument 'Classes' must be a vector of two classes; got an argument of length %d", length(Classes)), domain = NA) 230 for(cl in Classes) { 231 if(isClass(cl, where)) { 232 if(!extends(cl, "oldClass")) 233 warning(gettextf("inconsistent old-style class information for %s (maybe mixing old and new classes?)", 234 dQuote(cl)), domain = NA) 235 } 236 else 237 setClass(cl, representation("oldClass", "VIRTUAL"), where = where) 238 } 239 Class1 <- Classes[[1L]] 240 for(cl in Classes[-1L]) { 241 tfun <- .oldTestFun 242 body(tfun, envir = environment(tfun)) <- 243 substitute(inherits(object, CLASS), list(CLASS = cl)) 244 setIs(Class1, cl, test = tfun, coerce = .oldCoerceFun, 245 replace = .oldReplaceFun, where = where) 246 } 247 NULL 248} 249 250isXS3Class <- function(classDef) { 251 ".S3Class" %in% names(classDef@slots) 252} 253 254S3Class <- function(object) { 255 value <- attr(object, ".S3Class") 256 if(is.null(value)) { 257 if(isS4(object)) { 258 if(is.na(match(".Data", names(getClass(class(object))@slots)))) 259 stop(gettextf("'S3Class' only defined for extensions of %s or classes with a data part: not true of class %s", 260 dQuote("oldClass"), 261 dQuote(class(object))), 262 domain = NA) 263 class(getDataPart(object)) 264 } 265 else 266 class(object) 267 } 268 else 269 value 270} 271 272.S3Class <- S3Class # alias for functions with S3Class as an argument 273 274.addS3Class <- function(class, prototype, contains, where) { 275 for(what in contains) { 276 whatDef <- getClassDef(what@superClass, package=packageSlot(what)) 277 if(isXS3Class(whatDef)) 278 class <- c(class, attr(whatDef@prototype, ".S3Class")) 279 } 280 attr(prototype, ".S3Class") <- unique(class) 281 prototype 282} 283 284"S3Class<-" <- function(object, value) { 285 if(isS4(object)) { 286 current <- attr(object, ".S3Class") 287 if(is.null(current)) { 288 if(is.na(match(value, .BasicClasses))) 289 stop(gettextf("'S3Class' can only assign to S4 objects that extend \"oldClass\"; not true of class %s", 290 dQuote(class(object))), 291 domain = NA) 292 mode(object) <- value ## may still fail, a further check would be good 293 } 294 else 295 slot(object, ".S3Class") <- value 296 } 297 else 298 class(object) <- value 299 object 300} 301 302## rename a class definition: needs to change if any additional occurences of class 303## name are added, other than the className slot and the super/sub class names 304## in the contains, subclasses slots respectively. 305.renameClassDef <- function(def, className) { 306## oldName <- def@className 307 validObject(def) # to catch any non-SClassExtension objects 308 def@className <- className 309 comp <- def@contains 310 for(i in seq_along(comp)) 311 comp[[i]]@subClass <- className 312 def@contains <- comp 313 comp <- def@subclasses 314 for(i in seq_along(comp)) 315 comp[[i]]@superClass <- className 316 def@subclasses <- comp 317 def 318} 319 320## extends() w/o conditional inheritance: used for S3 inheritance, method 321## selection on S4 objects 322..extendsForS3 <- function(Class) 323 extends(Class, maybe = FALSE) 324## dummy version while generating methods package 325.extendsForS3 <- function(Class) 326 extends(Class) 327