Lines 16-57
Link Here
|
16 |
# A copy of the GNU General Public License is available at |
16 |
# A copy of the GNU General Public License is available at |
17 |
# https://www.R-project.org/Licenses/ |
17 |
# https://www.R-project.org/Licenses/ |
18 |
|
18 |
|
|
|
19 |
# With two arguments, tests whether `object' can be treated as from `class2'. |
19 |
is <- |
20 |
is <- |
20 |
# With two arguments, tests whether `object' can be treated as from `class2'. |
|
|
21 |
# |
22 |
# With one argument, returns all the super-classes of this object's class. |
23 |
function(object, class2) |
21 |
function(object, class2) |
24 |
{ |
22 |
{ |
25 |
cl <- class(object) |
23 |
|
26 |
S3Case <- length(cl) > 1L |
24 |
# The behaviors of this block should all be deprecated |
27 |
if(S3Case) |
25 |
# We should require direct use of 'extends'. This alternate usage |
28 |
cl <- cl[[1L]] |
26 |
# does not appear to be documented. |
|
|
27 |
# base and methods never pass a classDef for class2 |
29 |
if(missing(class2)) |
28 |
if(missing(class2)) |
30 |
return(extends(cl)) |
29 |
return(extends(class(object))) |
31 |
class1Def <- getClassDef(cl) |
30 |
else if (!is.character(class2)) |
32 |
if(is.null(class1Def)) # an unregistered S3 class |
|
|
33 |
return(inherits(object, class2)) |
34 |
if(is.character(class2)) |
35 |
class2Def <- getClassDef(class2, .classDefEnv(class1Def)) |
36 |
else { |
37 |
class2Def <- class2 |
38 |
class2 <- class2Def@ className |
31 |
class2 <- class2Def@ className |
39 |
} |
32 |
|
40 |
## S3 inheritance is applied if the object is not S4 and class2 is either a basic |
33 |
if (inherits(object, class2)) { # Use for S3 and use the inherits cache for S4 |
41 |
## class or an S3 class (registered or not) |
|
|
42 |
S3Case <- S3Case || (is.object(object) && !isS4(object)) # first requirement |
43 |
S3Case <- S3Case && (is.null(class2Def) || class2 %in% .BasicClasses || |
44 |
extends(class2Def, "oldClass")) |
45 |
if(S3Case) |
46 |
inherits(object, class2) |
47 |
else if(.identC(cl, class2) || .identC(class2, "ANY")) |
48 |
TRUE |
34 |
TRUE |
49 |
else if(is.logical(ext <- possibleExtends(cl, class2, class1Def, class2Def))) |
35 |
} else # S4 and some special cases need more chances to find a TRUE, S3 will return FALSE promptly |
|
|
36 |
if(is.logical(ext <- possibleExtends(class(object), class2))) # Perhaps we should inline the relevant parts of possbibleExtends here? |
50 |
ext |
37 |
ext |
51 |
else if(ext@simple) |
|
|
52 |
TRUE |
53 |
else |
38 |
else |
54 |
ext@test(object) |
39 |
ext@simple || ext@test(object) |
55 |
} |
40 |
} |
56 |
|
41 |
|
57 |
extends <- |
42 |
extends <- |