/usr/lib/R/site-library/Biobase/unitTests/test_UpdateObject.R is in r-bioc-biobase 2.30.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 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 | testUpdateObjectToDefaults <- function() {
x <- 1:10
checkTrue(identical(1:10, updateObjectTo(x, 10:1)))
x <- as.numeric(1:10)
checkTrue(identical(as.integer(1:10), updateObjectTo(x, integer())))
checkTrue(!identical(as.numeric(1:10), updateObjectTo(x, integer())))
}
testUpdateObjectToSetClass <- function() {
setClass("A",
representation(x="numeric"),
prototype=prototype(x=1:10),
where=.GlobalEnv)
a <- new("A")
a1 <- new("A",x=10:1)
checkTrue(identical(a, updateObjectTo(a, a1)))
setClass("B",
representation(x="numeric"),
where=.GlobalEnv)
b <- new("B")
checkException(updateObjectTo(a, b), silent=TRUE)
setAs("A", "B", function(from) {
b <- new("B")
b@x <- from@x
b
}, where=.GlobalEnv)
obj <- updateObjectTo(a,b)
checkTrue(class(obj)=="B")
checkIdentical(obj@x, a@x)
removeMethod("coerce", c("A","B"), where=.GlobalEnv)
removeClass("B", where=.GlobalEnv)
removeClass("A", where=.GlobalEnv)
}
testUpdateExpressionSet <- function() {
opts <- options()
options(warn=-1)
obj <- new("ExpressionSet")
checkTrue(all.equal(obj, updateObject(obj)))
checkTrue(!identical(new("ExpressionSet"), updateObject(obj))) # different environments
obj <- new("ExpressionSet", storage.mode="list")
checkTrue(identical(obj, updateObject(obj)))
checkTrue(identical(new("ExpressionSet", storage.mode="list"), updateObject(obj))) # same class -- list
data(sample.ExpressionSet)
classVersion(sample.ExpressionSet)["eSet"] <- "1.0.0"
checkException(validObject(sample.ExpressionSet), silent=TRUE)
suppressMessages(obj <- updateObject(sample.ExpressionSet))
checkTrue(isVersioned(obj))
checkTrue(all(isCurrent(obj)))
checkTrue(validObject(obj))
checkTrue(identical(lapply(ls(assayData(obj), all=TRUE), function(x) x),
lapply(ls(assayData(sample.ExpressionSet),all=TRUE), function(x) x)))
checkTrue(identical(annotation(obj), annotation(sample.ExpressionSet)))
suppressMessages(obj1a <- updateObjectTo(sample.ExpressionSet, new("ExpressionSet")))
## next better written as(sample.ExpressionSet, "MultiSet")
suppressMessages(obj1b <- updateObjectTo(sample.ExpressionSet, new("MultiSet")))
obj2 <- updateObject(obj) # stop after eSet
options(opts)
}
testUpdateESetMisc <- function() {
opts <- options()
options(warn=-1)
idx <- c("phenoData", "experimentData", "featureData")
fun <- function(nm)
isS4(eval(parse(text=paste(nm,"(obj)", sep=""))))
load(system.file("unitTests", "VersionedClass_data", "devel",
"sample.exprSet.rda", package="Biobase"))
suppressMessages(obj <- as(sample.exprSet, "ExpressionSet"))
checkTrue(validObject(obj, complete=TRUE))
checkTrue(all(sapply(idx, fun)))
load(system.file("unitTests", "VersionedClass_data", "devel",
"sample.eSet.rda", package="Biobase"))
obj <- as(sample.eSet, "MultiSet")
checkTrue(validObject(obj, complete=TRUE))
checkTrue(all(sapply(idx, fun)))
load(system.file("unitTests", "VersionedClass_data", "devel", "eset.rda",
package="Biobase"))
obj <- as(eset, "ExpressionSet")
checkTrue(validObject(obj, complete=TRUE))
checkTrue(all(sapply(idx, fun)))
options(opts)
}
testUpdateMiscPreviousInstances <- function() {
opts <- options("warn")
options(warn=-1)
on.exit(options(opts))
rda <- dir(system.file("unitTests", "VersionedClass_data",
package="Biobase"), full.names=TRUE,
recursive=TRUE, pattern="^([^(ExpressionSet)]).*\\.Rda")
ok <- sapply(rda, function(nm) {
env <- new.env(parent=emptyenv())
load(nm, env)
tryCatch({
eapply(env, function(elt) {
suppressMessages(obj <- updateObject(elt))
checkTrue(isS4(obj))
checkTrue(validObject(obj, complete=TRUE))
})
TRUE
}, error=function(...) FALSE)
})
checkTrue(all(ok),
msg=sprintf("failed: '%s'", paste(rda[!ok], collapse="' '")))
}
testUpdatePreviousExpressionSet <- function() {
opts <- options("warn")
options(warn=-1)
on.exit(options(opts))
rda <- dir(system.file("unitTests", "VersionedClass_data",
package="Biobase"), full.names=TRUE,
recursive=TRUE, pattern="^ExpressionSet.*\\.Rda")
ok <- sapply(rda, function(nm) {
env <- new.env(parent=emptyenv())
load(nm, env)
tryCatch({
eapply(env, function(elt) {
suppressMessages(obj <- updateObject(elt))
checkTrue(validObject(obj, complete=TRUE))
## S4
idx <- c("phenoData", "experimentData", "featureData")
ok <- sapply(idx, function(nm) {
isS4(eval(parse(text=paste(nm,"(obj)", sep=""))))
})
checkTrue(all(ok))
## content
checkIdentical(exprs(obj),
slot(elt, "assayData")[["exprs"]])
checkIdentical(pData(phenoData(obj)),
slot(slot(elt, "phenoData"), "data"))
checkIdentical(varMetadata(phenoData(obj)),
slot(slot(elt, "phenoData"), "varMetadata"))
nms <- names(getSlots("MIAME"))
nms <- nms[!nms %in% ".__classVersion__"]
lapply(nms, function(nm)
checkIdentical(slot(experimentData(obj), nm),
slot(slot(elt, "experimentData"),
nm)))
})
TRUE
}, error=function(...) FALSE)
})
checkTrue(all(ok),
msg=sprintf("failed: '%s'", paste(rda[!ok], collapse="' '")))
}
|