|
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 <- |