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
|
# Make sure to put derived classes before base classes,
# otherwise the subclass look-up might not find the most appropriate method.
implementers <- list(
SpatialExperiment = "alabaster.spatial",
SingleCellExperiment = "alabaster.sce",
VCF = "alabaster.vcf",
SummarizedExperiment = "alabaster.se",
BumpyDataFrameMatrix = "alabaster.bumpy",
GRanges = "alabaster.ranges",
GRangesList = "alabaster.ranges",
AtomicVectorList = "alabaster.ranges",
DataFrameList = "alabaster.ranges",
matrix = "alabaster.matrix",
array = "alabaster.matrix",
Matrix = "alabaster.matrix",
DelayedArray = "alabaster.matrix",
MultiAssayExperiment = "alabaster.mae",
DNAStringSet = "alabaster.string"
)
package.lookup <- new.env()
package.lookup$found <- character(0)
package.exists <- function(pkg) {
length(find.package(pkg, quiet=TRUE)) > 0
}
warn.package.exists <- function(pkg, cls) {
warning("consider installing ", pkg, " for a more appropriate stageObject method for '", cls, "' objects")
}
.search_methods <- function(x) {
searchForMethods(x, package.lookup, implementers)
}
#' @export
#' @import methods
searchForMethods <- function(x, lookup, implements) {
cls <- class(x)[1]
ok <- FALSE
if (!(cls %in% lookup$found)) {
found <- NULL
if (cls %in% names(implements)) {
found <- implements[[cls]]
if (!package.exists(found)) {
warn.package.exists(found, cls)
found <- NULL
}
}
if (is.null(found)) {
for (y in names(implements)) {
if (is(x, y)) {
if (package.exists(implements[[y]])) {
found <- implements[[y]]
break
} else {
warn.package.exists(implements[[y]], cls)
}
}
}
}
if (!is.null(found) && !isNamespaceLoaded(found)) {
loadNamespace(found)
ok <- TRUE
}
# Regardless of whether it was successful, we add the class,
# so as to short-circuit any attempts in the future.
lookup$found <- c(lookup$found, cls)
}
ok
}
#' @export
setMethod("stageObject", "ANY", function(x, dir, path, child=FALSE, ...) {
# The logic is that .searchMethods should have run in the generic before
# hitting this method. If that's the case, we must have failed to find a
# suitable method, so we just throw an error here. We still need to define
# an ANY method, though, because otherwise the generic won't even run.
stop("no known method for 'stageObject' function with signature '", class(x)[1], "'")
})
# Soft-deprecated back-compatibility fix.
#' @export
.searchForMethods <- function(...) searchForMethods(...)
|
