/usr/lib/R/site-library/BiocGenerics/unitTests/test_updateObject.R is in r-bioc-biocgenerics 0.20.0-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 | ###
test_updateObject_list <- function()
{
setClass("A",
representation(x="numeric"), prototype(x=1:10),
where=.GlobalEnv)
a <- new("A")
l <- list(a,a)
checkTrue(identical(l, updateObject(l)))
setMethod("updateObject", "A",
function(object, ..., verbose=FALSE) {
if (verbose) message("updateObject object = 'A'")
object@x <- -object@x
object
},
where=.GlobalEnv)
obj <- updateObject(l)
checkTrue(identical(lapply(l, function(elt) { elt@x <- -elt@x; elt }),
obj))
removeMethod("updateObject", "A", where=.GlobalEnv)
removeClass("A", where=.GlobalEnv)
}
test_updateObject_env <- function()
{
opts <- options()
options(warn=-1)
e <- new.env()
e$x=1
e$.x=1
obj <- updateObject(e)
checkTrue(identical(e,obj)) # modifies environment
lockEnvironment(e)
obj <- updateObject(e) # copies environment
checkTrue(identical(lapply(ls(e, all=TRUE), function(x) x),
lapply(ls(obj, all=TRUE), function(x) x)))
checkTrue(!identical(e, obj)) # different environments
e <- new.env()
e$x=1
e$.x=1
lockBinding("x", e)
checkException(updateObject(e), silent=TRUE)
lockEnvironment(e)
obj <- updateObject(e)
checkTrue(TRUE==bindingIsLocked("x", obj)) # R bug, 14 May, 2006, fixed
checkTrue(FALSE==bindingIsLocked(".x", obj))
options(opts)
}
test_updateObject_defaults <- function()
{
x <- 1:10
checkTrue(identical(x, updateObject(x)))
}
test_updateObject_S4 <- function()
{
setClass("A",
representation=representation(
x="numeric"),
prototype=list(x=1:5),
where=.GlobalEnv)
.__a__ <- new("A")
setClass("A",
representation=representation(
x="numeric",
y="character"),
where=.GlobalEnv)
checkException(validObject(.__a__), silent=TRUE) # now out-of-date
.__a__@x <- 1:5
a <- updateObject(.__a__)
checkTrue(validObject(a))
checkIdentical(1:5, a@x)
removeClass("A", where=.GlobalEnv)
}
test_updateObject_setClass <- function()
{
setClass("A",
representation(x="numeric"),
prototype=prototype(x=1:10),
where=.GlobalEnv)
a <- new("A")
checkTrue(identical(a,updateObject(a)))
removeClass("A", where=.GlobalEnv)
}
test_updateObject_refClass <- function()
{
cls <- ".__test_updateObject_refClassA"
.A <- setRefClass(cls, fields=list(x="numeric", y="numeric"),
where=.GlobalEnv)
a <- .A()
checkTrue(all.equal(a, updateObject(a)))
a <- .A(x=1:5, y=5:1)
checkTrue(all.equal(a, updateObject(a)))
.A <- setRefClass(cls, fields=list(x="numeric", y="numeric", z="numeric"),
where=.GlobalEnv)
checkTrue(all.equal(.A(x=1:5, y=5:1, z=numeric()), updateObject(a)))
.A <- setRefClass(cls, fields=list(x="numeric"))
warn <- FALSE
value <- withCallingHandlers(updateObject(a), warning=function(w) {
txt <- "dropping fields(s) 'y' from object = '.__test_updateObject_refClassA'"
warn <<- identical(txt, conditionMessage(w))
invokeRestart("muffleWarning")
})
checkTrue(warn)
checkTrue(all.equal(.A(x=1:5), value))
removeClass(cls, where=.GlobalEnv)
}
|