1# File src/library/methods/R/is.R 2# Part of the R package, https://www.R-project.org 3# 4# Copyright (C) 1995-2021 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 20is <- function(object, class2) 21{ 22 # With two arguments, tests whether `object' can be treated as from `class2'. 23 # 24 # With one argument, returns all the super-classes of this object's class. 25 class1 <- class(object) 26 S3Case <- length(class1) > 1L 27 if(S3Case) 28 class1 <- class1[[1L]] 29 if(missing(class2)) 30 return(extends(class1)) 31 class1Def <- getClassDef(class1) 32 class2Def <- NULL 33 if(!is.character(class2)) { 34 class2Def <- class2 35 class2 <- class2Def@className 36 } 37 if(is.null(class1Def)) # an unregistered S3 class 38 return(inherits(object, class2)) 39 if(is.null(class2Def)) { 40 class2Def <- getClassDef(class2, .classDefEnv(class1Def), 41 if (!is.null(package <- packageSlot(class2))) 42 package 43 else getPackageName(topenv(parent.frame()))) 44 } 45 ## S3 inheritance is applied if the object is not S4 and class2 is either 46 ## a basic class or an S3 class (registered or not) 47 S3Case <- S3Case || (is.object(object) && !isS4(object)) 48 S3Case <- S3Case && (is.null(class2Def) || class2 %in% .BasicClasses || 49 extends(class2Def, "oldClass")) 50 if(S3Case) 51 inherits(object, class2) 52 else if(.identC(class1, class2) || .identC(class2, "ANY")) 53 TRUE 54 else { ## look for class1 in the known subclasses of class2 55 if(!is.null(contained <- class1Def@contains[[class2]])) 56 contained@simple || contained@test(object) 57 else if (is.null(class2Def)) 58 FALSE 59 else if(!.identC(class(class2Def), "classRepresentation") && 60 isClassUnion(class2Def)) 61 any(c(class1, names(class1Def@contains)) %in% 62 names(class2Def@subclasses)) 63 else { 64 ext <- class2Def@subclasses[[class1]] 65 !is.null(ext) && (ext@simple || ext@test(object)) 66 } 67 } 68} 69 70extends <- 71 ## Does the first class extend the second class? 72 ## Returns `maybe' if the extension includes a non-trivial test. 73 function(class1, class2, maybe = TRUE, fullInfo = FALSE) 74{ 75 if(is.character(class1)) { 76 if(length(class1) > 1L) 77 class1 <- class1[[1L]] 78 classDef1 <- getClassDef(class1) 79 } else if(is(class1, "classRepresentation")) { 80 classDef1 <- class1 81 class1 <- classDef1@className 82 } 83 else 84 stop("'class1' must be the name of a class or a class definition") 85 if(missing(class2)) { 86 if(is.null(classDef1)) 87 return(class1) 88 ext <- classDef1@contains 89 if(!isTRUE(maybe) && length(ext) > 0) 90 { 91 noTest <- vapply(ext, function(obj)isTRUE(body(obj@test)), NA) 92 ext <- ext[noTest] 93 } 94 if(fullInfo) { 95 ext[[class1]] <- TRUE 96 return(ext) 97 } 98 else 99 return(c(class1,names(ext))) 100 } 101 value <- NULL 102 if(is.character(class2) && length(class2) == 1L) { ## fast first checks 103 ## the [[1L]] below handles old-style classes & throws away package attributes 104 if(.identC(class1[[1L]], class2) || .identC(class2, "ANY")) 105 return(TRUE) 106 if(!is.null(classDef1) && class2 %in% names(classDef1@contains)) 107 value <- classDef1@contains[[class2]] 108 else 109 classDef2 <- getClassDef(class2) 110 } 111 else if(is(class2, "classRepresentation")) { 112 classDef2 <- class2 113 class2 <- class2@className 114 } 115 else 116 stop("'class2' must be the name of a class or a class definition") 117 if(is.null(value)) 118 value <- possibleExtends(class1, class2, classDef1, classDef2) 119 if(fullInfo) 120 value 121 else if(is.logical(value)) 122 value 123 else if(value@simple || isTRUE(body(value@test))) 124 TRUE 125 else 126 maybe 127} 128 129.specialVirtual <- c("oldClass") 130 131setIs <- 132 ## Defines class1 to be an extension of class2. 133 ## The relationship can be conditional, if a function is supplied as the `test' 134 ## argument. If a function is supplied as the `coerce' argument, this function will 135 ## be applied to any `class1' object in order to turn it into a `class2' object. 136 ## 137 ## Extension may imply that a `class1' object contains a `class2' object. The default 138 ## sense of containing is that all the slots of the simpler class are found in the 139 ## more elaborate one. If the `replace' argument is supplied as an S replacement 140 ## function, this function will be used to implement `as(obj, class2) <- value'. 141 function(class1, class2, test = NULL, coerce = NULL, 142 replace = NULL, by = character(), where = topenv(parent.frame()), 143 classDef = getClass(class1, TRUE, where = where), extensionObject = NULL, doComplete = TRUE) 144{ 145 ## class2 should exist 146 where <- as.environment(where) 147 classDef2 <- getClassDef(class2, where) 148 if(is.null(classDef2)) 149 stop(gettextf("class %s has no visible definition from package or environment %s", 150 dQuote(class2), 151 sQuote(getPackageName(where))), 152 domain = NA) 153 ## check some requirements: 154 ## One of the classes must be on the target environment (so that the relation can 155 ## be retained by saving the corresponding image) 156 m1 <- classMetaName(class1) 157 local1 <- exists(m1, where, inherits = FALSE) && 158 !(classDef@sealed || bindingIsLocked(m1, where)) 159 if(!local1) { 160 m2 <- classMetaName(class2) 161 local2 <- exists(m2, where, inherits = FALSE) && 162 !(classDef2@sealed || bindingIsLocked(m2, where)) 163 if(!local2) 164 stop(gettextf( 165 "cannot create a 'setIs' relation when neither of the classes (%s and %s) is local and modifiable in this package", 166 dQuote(class1), 167 dQuote(class2)), 168 domain = NA) 169 } 170 if(classDef@sealed && !isClassUnion(classDef2)) 171 stop(gettextf("class %s is sealed; new superclasses can not be defined, except by 'setClassUnion'", 172 dQuote(class1)), 173 domain = NA) 174 prevIs <- !identical(possibleExtends(class1, class2,classDef, classDef2), 175 FALSE) # used in checking for previous coerce 176 obj <- if(is.null(extensionObject)) 177 makeExtends(class1, coerce, test, replace, by, 178 classDef1 = classDef, classDef2 = classDef2, 179 package = getPackageName(where)) 180 else 181 extensionObject 182 ## revise the superclass/subclass info in the stored class definition 183 ok <- .validExtends(class1, class2, classDef, classDef2, obj@simple) 184 if(!isTRUE(ok)) 185 stop(ok) 186 where2 <- .findOrCopyClass(class2, classDef2, where, "subclass") 187 classDef2@subclasses[[class1]] <- obj 188 if(doComplete) 189 classDef2@subclasses <- completeSubclasses(classDef2, class1, obj, where) 190 ## try to provide a valid prototype for virtual classes 191 if(classDef2@virtual && is.na(match(class2, .specialVirtual))) { 192 ## For simplicity, we prefer NULL prototype if "NULL" 193 ## is a subclass of a virtual class; otherwise the 194 ## prototype is an element of class1 or its prototype if VIRTUAL 195 if(extends(classDef, "NULL")) 196 classDef2@prototype <- NULL 197 else if(is.null(classDef2@prototype) 198 && is.na(match("NULL", names(classDef2@subclasses)))) { 199 classDef2@prototype <- 200 if(classDef@virtual) 201 classDef@prototype 202 else # new(), but without intialize(), which may require an arg. 203 .Call(C_new_object, classDef) 204 } 205 } 206 assignClassDef(class2, classDef2, where2, TRUE) 207 .removePreviousCoerce(class1, class2, where, prevIs) 208 where1 <- .findOrCopyClass(class1, classDef, where, "superClass") 209 ## insert the direct contains information in a valid spot 210 .newDirectSuperclass(classDef@contains, class2, names(classDef2@contains)) <- obj 211 ## Since class unions are implemented as a superclass of each of 212 ## its members, if a member comes from a different package, the 213 ## inheritance information will not be present upon namespace 214 ## load. Therefore, on loading a namespace, we have to restore the 215 ## inheritance hierarchy in the cache (the runtime definition); 216 ## see cacheMetaData(). This means that the class definition has 217 ## diverged between the namespace and the cache. In cases of 218 ## divergence, we need to avoid modifying them with .checkSubclasses(), 219 ## because it will overwrite the cache with the saved version. Any 220 ## use of setIs() across packages will cause divergence. However, 221 ## the divergence is only reconciled in the case of class 222 ## unions. cacheMetaData() could be improved to recache whenever a 223 ## class already _knows_ that it is extended by a class from a 224 ## different package (like a class union does). 225 onlyRecacheSubclasses <- 226 (is(classDef, "ClassUnionRepresentation") || 227 is(classDef2, "ClassUnionRepresentation")) && 228 !identical(packageSlot(classDef), packageSlot(classDef2)) 229 if(doComplete) { 230 classDef@contains <- completeExtends(classDef, class2, obj, where = where) 231 if(!onlyRecacheSubclasses) #unions are handled in assignClassDef 232 .checkSubclasses(class1, classDef, class2, classDef2, where) 233 } 234 assignClassDef(class1, classDef, where1, TRUE, 235 doSubclasses=onlyRecacheSubclasses) 236 invisible(classDef) 237 } 238 239.findOrCopyClass <- function(class, classDef, where, purpose) { 240 whereIs <- findClass(classDef, where) 241 if(length(whereIs)) 242 whereIs[[1L]] 243 else { 244 if(purpose != "subclass") 245 warning(gettextf("class %s is defined (with package slot %s) but no metadata object found to revise %s information---not imported? Making a copy in package %s", 246 .dQ(class), sQuote(classDef@package), purpose, 247 sQuote(getPackageName(where, FALSE))), 248 call. = FALSE, domain = NA) 249 where 250 } 251} 252 253 254.validExtends <- function(class1, class2, classDef1, classDef2, slotTests) { 255 .msg <- function(class1, class2) 256 gettextf("class %s cannot extend class %s", 257 dQuote(class1), 258 dQuote(class2)) 259 if((is.null(classDef1) || is.null(classDef2)) && 260 !(isVirtualClass(class1) && isVirtualClass(class2))) 261 return(c(.msg(class1, class2), ": ", 262 gettext("both classes must be defined"))) 263 if(slotTests) { 264 slots2 <- classDef2@slots 265 if(length(slots2)) { 266 n2 <- names(slots2) 267 slots1 <- classDef1@slots 268 n1 <- names(slots1) 269 if(anyNA(match(n2, n1))) 270 return(c(.msg(class1, class2), ": ", 271 sprintf(ngettext(sum(is.na(match(n2, n1))), 272 "class %s is missing slot from class %s (%s), and no coerce method was supplied", 273 "class %s is missing slots from class %s (%s), and no coerce method was supplied"), 274 dQuote(class1), 275 dQuote(class2), 276 paste(n2[is.na(match(n2, n1))], collapse = ", ")))) 277 bad <- character() 278 for(what in n2) 279 if(!extends(slots1[[what]], slots2[[what]])) 280 bad <- c(bad, what) 281 if(length(bad)) 282 return(c(.msg(class1, class2), ": ", 283 sprintf(ngettext(length(bad), 284 "slot in class %s must extend corresponding slot in class %s: fails for %s", 285 "slots in class %s must extend corresponding slots in class %s: fails for %s"), 286 dQuote(class1), 287 dQuote(class2), 288 paste(bad, collapse = ", ")))) 289 } 290 } 291 TRUE 292} 293 294".newDirectSuperclass<-" <- function(contains, class2, superclasses2, value) { 295 superclasses <- names(contains) 296 if(length(superclasses2) == 0 || length(superclasses) == 0 || 297 all(is.na(match(superclasses2, superclasses)))) 298 contains[[class2]] <- value 299 else { 300 sq <- seq_along(superclasses) 301 before <- (sq[match(superclasses, superclasses2, 0L) > 0L])[[1]] 302 contains <- c(contains[sq < before], value, contains[sq >= before]) 303 superclasses <- c(superclasses[sq < before], class2, superclasses[sq >= before]) 304 names(contains) <- superclasses 305 } 306 contains 307} 308