View | Details | Raw Unified | Return to bug 16490 | Differences between
and this patch

Collapse All | Expand All

(-)src/library/methods/R/SClasses.R (-17 / +15 lines)
Lines 127-133 Link Here
127
    ## since set SClass works separately with the slots and extends arguments.
127
    ## since set SClass works separately with the slots and extends arguments.
128
    anames <- allNames(value)
128
    anames <- allNames(value)
129
    for(i in seq_along(value)) {
129
    for(i in seq_along(value)) {
130
        ei <- el(value, i)
130
        ei <- value[[i]]
131
        if(!is.character(ei) || length(ei) != 1L)
131
        if(!is.character(ei) || length(ei) != 1L)
132
            stop(gettextf("element %d of the representation was not a single character string", i), domain = NA)
132
            stop(gettextf("element %d of the representation was not a single character string", i), domain = NA)
133
    }
133
    }
Lines 205-211 Link Here
205
        what <- whatClassDef@className # includes package name as attribute
205
        what <- whatClassDef@className # includes package name as attribute
206
        ## Create the SClassExtension objects (will be simple, possibly dataPart).
206
        ## Create the SClassExtension objects (will be simple, possibly dataPart).
207
        ## The slots are supplied explicitly, since `name' is currently an undefined class
207
        ## The slots are supplied explicitly, since `name' is currently an undefined class
208
        elNamed(contains, what) <- makeExtends(name, what, slots = slots,
208
        contains[[what]] <- makeExtends(name, what, slots = slots,
209
                                              classDef2 = whatClassDef, package = package)
209
                                              classDef2 = whatClassDef, package = package)
210
    }
210
    }
211
    validity <- .makeValidityMethod(name, validity)
211
    validity <- .makeValidityMethod(name, validity)
Lines 212-218 Link Here
212
    if(is.na(virtual)) {
212
    if(is.na(virtual)) {
213
        virtual <- testVirtual(slots, contains, prototype, where)
213
        virtual <- testVirtual(slots, contains, prototype, where)
214
        if(virtual && !is.na(match("VIRTUAL", superClasses)))
214
        if(virtual && !is.na(match("VIRTUAL", superClasses)))
215
            elNamed(contains, "VIRTUAL") <- NULL
215
            contains[["VIRTUAL"]] <- NULL
216
    }
216
    }
217
    # new() must return an S4 object, except perhaps for basic classes
217
    # new() must return an S4 object, except perhaps for basic classes
218
    if(!is.null(prototype) && is.na(match(name, .BasicClasses)))
218
    if(!is.null(prototype) && is.na(match(name, .BasicClasses)))
Lines 239-252 Link Here
239
	.getClassFromCache(Class, where, package=package, resolve.msg=resolve.msg)
239
	.getClassFromCache(Class, where, package=package, resolve.msg=resolve.msg)
240
    ## else NULL # want to force a search for the metadata in this case (Why?)
240
    ## else NULL # want to force a search for the metadata in this case (Why?)
241
    if(is.null(value)) {
241
    if(is.null(value)) {
242
	cname <-
242
	cname <- methodsPackageMetaName("C", Class[[1L]])
243
	    classMetaName(if(length(Class) > 1L)
243
        ## if length(Class) > 1L then S3 class; almost certainly has no packageSlot,
244
			  ## S3 class; almost certainly has no packageSlot,
245
			  ## but we'll continue anyway
244
			  ## but we'll continue anyway
246
			  Class[[1L]] else Class)
247
	## a string with a package slot strongly implies the class definition
245
	## a string with a package slot strongly implies the class definition
248
	## should be in that package.
246
	## should be in that package.
249
	if(identical(nzchar(package), TRUE)) {
247
	if(!is.null(package) && !is.na(package) && nzchar(package)) {
250
	    whereP <- .requirePackage(package)
248
	    whereP <- .requirePackage(package)
251
	    value <- get0(cname, whereP, inherits = inherits) # NULL if not existing
249
	    value <- get0(cname, whereP, inherits = inherits) # NULL if not existing
252
	}
250
	}
Lines 305-311 Link Here
305
{
303
{
306
    cl <- class(obj)
304
    cl <- class(obj)
307
    ClassDef <- getClass(cl) # fails if cl not a defined class (!)
305
    ClassDef <- getClass(cl) # fails if cl not a defined class (!)
308
    slotClass <- elNamed(ClassDef@slots, name)
306
    slotClass <- ClassDef@slots[[name]]
309
    if(is.null(slotClass))
307
    if(is.null(slotClass))
310
        stop(gettextf("%s is not a slot in class %s",
308
        stop(gettextf("%s is not a slot in class %s",
311
                      sQuote(name), dQuote(cl)),
309
                      sQuote(name), dQuote(cl)),
Lines 331-337 Link Here
331
checkAtAssignment <- function(cl, name, valueClass)
329
checkAtAssignment <- function(cl, name, valueClass)
332
{
330
{
333
    ClassDef <- getClass(cl) # fails if cl not a defined class (!)
331
    ClassDef <- getClass(cl) # fails if cl not a defined class (!)
334
    slotClass <- elNamed(ClassDef@slots, name)
332
    slotClass <- ClassDef@slots[[name]]
335
    if(is.null(slotClass))
333
    if(is.null(slotClass))
336
        stop(gettextf("%s is not a slot in class %s",
334
        stop(gettextf("%s is not a slot in class %s",
337
                      sQuote(name), dQuote(cl)),
335
                      sQuote(name), dQuote(cl)),
Lines 445-455 Link Here
445
        evList <- .parentEnvList(where)
443
        evList <- .parentEnvList(where)
446
        clNames <- character()
444
        clNames <- character()
447
        for(ev in evList)
445
        for(ev in evList)
448
            clNames <- c(clNames, objects(ev, pattern = pat, all.names = TRUE))
446
            clNames <- c(clNames, grep(pat, names(ev), value=TRUE))
449
        clNames <- unique(clNames)
447
        clNames <- unique(clNames)
450
    }
448
    }
451
    else
449
    else
452
        clNames <- objects(where, pattern = pat, all.names = TRUE)
450
        clNames <- grep(pat, names(where), value=TRUE)
453
    ## strip off the leading pattern (this implicitly assumes the characters
451
    ## strip off the leading pattern (this implicitly assumes the characters
454
    ## in classMetaName("") are either "." or not metacharacters
452
    ## in classMetaName("") are either "." or not metacharacters
455
    substring(clNames, nchar(pat, "c"))
453
    substring(clNames, nchar(pat, "c"))
Lines 641-651 Link Here
641
        supers <- args[!which]
639
        supers <- args[!which]
642
        thisExtends <- names(ClassDef@contains)
640
        thisExtends <- names(ClassDef@contains)
643
        slotDefs <- ClassDef@slots
641
        slotDefs <- ClassDef@slots
644
        dataPart <- elNamed(slotDefs, ".Data")
642
        dataPart <- slotDefs[[".Data"]]
645
        if(is.null(dataPart)) dataPart <- "missing"
643
        if(is.null(dataPart)) dataPart <- "missing"
646
        if(length(supers)) {
644
        if(length(supers)) {
647
            for(i in rev(seq_along(supers))) {
645
            for(i in rev(seq_along(supers))) {
648
                obj <- el(supers, i)
646
                obj <- supers[[i]]
649
                Classi <- class(obj)
647
                Classi <- class(obj)
650
                if(length(Classi) > 1L)
648
                if(length(Classi) > 1L)
651
                    Classi <- Classi[[1L]] #possible S3 inheritance
649
                    Classi <- Classi[[1L]] #possible S3 inheritance
Lines 698-707 Link Here
698
                     domain = NA)
696
                     domain = NA)
699
            firstTime <- TRUE
697
            firstTime <- TRUE
700
            for(i in seq_along(snames)) {
698
            for(i in seq_along(snames)) {
701
                slotName <- el(snames, i)
699
                slotName <- snames[[i]]
702
                slotClass <- elNamed(slotDefs, slotName)
700
                slotClass <- slotDefs[[slotName]]
703
                slotClassDef <- getClassDef(slotClass, package = ClassDef@package)
701
                slotClassDef <- getClassDef(slotClass, package = ClassDef@package)
704
                slotVal <- el(elements, i)
702
                slotVal <- elements[[i]]
705
                ## perform non-strict coercion, but leave the error messages for
703
                ## perform non-strict coercion, but leave the error messages for
706
                ## values not conforming to the slot definitions to validObject(),
704
                ## values not conforming to the slot definitions to validObject(),
707
                ## hence the check = FALSE argument in the slot assignment
705
                ## hence the check = FALSE argument in the slot assignment
(-)src/library/methods/R/as.R (-1 / +1 lines)
Lines 125-131 Link Here
125
    ## be the equivalent of new("toClass", fromObject)
125
    ## be the equivalent of new("toClass", fromObject)
126
    ## But must check that replacement is defined, in the case
126
    ## But must check that replacement is defined, in the case
127
    ## of nonstandard superclass relations
127
    ## of nonstandard superclass relations
128
    replaceMethod <- elNamed(ClassDef@contains, fromClass)
128
    replaceMethod <- ClassDef@contains[[fromClass]]
129
    if(is(replaceMethod, "SClassExtension") &&
129
    if(is(replaceMethod, "SClassExtension") &&
130
       !identical(as(replaceMethod@replace, "function"), .ErrorReplace)) {
130
       !identical(as(replaceMethod@replace, "function"), .ErrorReplace)) {
131
        f <- function(from, to) NULL
131
        f <- function(from, to) NULL
(-)src/library/methods/R/is.R (-7 / +5 lines)
Lines 23-33 Link Here
23
function(object, class2)
23
function(object, class2)
24
{
24
{
25
    cl <- class(object)
25
    cl <- class(object)
26
    S3Case <- length(cl) > 1L
26
    if(missing(class2)) {
27
    if(S3Case)
27
        .Deprecated("extends", "Calling the 'is' function with one argument is simply a synonym for extends.")
28
        cl <- cl[[1L]]
29
    if(missing(class2))
30
        return(extends(cl))
28
        return(extends(cl))
29
    }
31
    class1Def <- getClassDef(cl)
30
    class1Def <- getClassDef(cl)
32
    if(is.null(class1Def)) # an unregistered S3 class
31
    if(is.null(class1Def)) # an unregistered S3 class
33
        return(inherits(object, class2))
32
        return(inherits(object, class2))
Lines 39-47 Link Here
39
    }
38
    }
40
    ## S3 inheritance is applied if the object is not S4 and class2 is either a basic
39
    ## S3 inheritance is applied if the object is not S4 and class2 is either a basic
41
    ## class or an S3 class (registered or not)
40
    ## class or an S3 class (registered or not)
42
    S3Case <- S3Case || (is.object(object) && !isS4(object)) # first requirement
41
    S3Case <- (length(cl) > 1L || (is.object(object) && !isS4(object))) && # first requirement
43
    S3Case <- S3Case && (is.null(class2Def) || class2 %in% .BasicClasses ||
42
        (is.null(class2Def) || class2 %in% .BasicClasses || extends(class2Def, "oldClass"))
44
			 extends(class2Def, "oldClass"))
45
    if(S3Case)
43
    if(S3Case)
46
        inherits(object, class2)
44
        inherits(object, class2)
47
    else if(.identC(cl, class2) || .identC(class2, "ANY"))
45
    else if(.identC(cl, class2) || .identC(class2, "ANY"))

Return to bug 16490