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
|
#' A representation of a set of globals used with futures
#'
#' @param object A named list.
#'
#' @param resolved A logical indicating whether these globals
#' have been scanned for and resolved futures or not.
#'
#' @param total_size The total size of all globals, if known.
#'
#' @param \dots Not used.
#'
#' @return An object of class \code{FutureGlobals}.
#'
#' @details
#' This class extends the \link[globals]{Globals} class by add
#' attribute \code{resolved}.
#'
#' @aliases as.FutureGlobals as.FutureGlobals.FutureGlobals
#' as.FutureGlobals.Globals as.FutureGlobals.list [.FutureGlobals
#' c.FutureGlobals unique.FutureGlobals
#'
#' @importFrom globals Globals
#' @export
#' @keywords internal
FutureGlobals <- function(object = list(), resolved = FALSE, total_size = NA_real_, ...) {
if (!is.list(object)) {
stop("Argument 'object' is not a list: ", class(object)[1])
}
if (!inherits(object, "Globals")) {
object <- Globals(object, ...)
attr(object, "resolved") <- resolved
attr(object, "total_size") <- total_size
} else if (!inherits(object, "FutureGlobals")) {
attr(object, "resolved") <- resolved
attr(object, "total_size") <- total_size
}
structure(object, class = c("FutureGlobals", class(object)))
}
#' @export
resolved.FutureGlobals <- function(x, ...) attr(x, "resolved", exact = TRUE)
#' @export
as.FutureGlobals <- function(x, ...) UseMethod("as.FutureGlobals")
#' @export
as.FutureGlobals.FutureGlobals <- function(x, ...) x
#' @export
as.FutureGlobals.Globals <- function(x, ...) {
class(x) <- c("FutureGlobals", class(x))
attr(x, "resolved") <- FALSE
attr(x, "total_size") <- NA_real_
x
}
#' @export
as.FutureGlobals.list <- function(x, ...) {
as.FutureGlobals(as.Globals(x, ...))
}
#' @export
`[.FutureGlobals` <- function(x, i) {
resolved <- attr(x, "resolved", exact = TRUE)
size <- attr(x, "total_size", exact = TRUE)
x <- NextMethod()
attr(x, "resolved") <- resolved
attr(x, "total_size") <- size
x
}
#' @export
c.FutureGlobals <- function(x, ...) {
args <- list(...)
if (length(args) == 0) return(x)
## Are all imputs resolved?
resolved <- attr(x, "resolved", exact = TRUE)
resolved_args <- lapply(args, FUN = function(x) isTRUE(attr(x, "resolved", exact = TRUE)))
resolved_args <- unlist(resolved_args, use.names = FALSE)
resolved <- resolved && all(resolved_args)
## Total size?
size <- attr(x, "total_size", exact = TRUE)
if (!is.na(size)) {
size_args <- lapply(args, FUN = function(z) {
size <- attr(z, "total_size", exact = TRUE)
if (is.null(size)) NA_real_ else size
})
size_args <- unlist(size_args, use.names = FALSE)
size <- size + sum(size_args, na.rm = FALSE)
}
x <- NextMethod()
attr(x, "resolved") <- resolved
attr(x, "total_size") <- size
x
}
#' @export
unique.FutureGlobals <- function(x, ...) {
nx <- length(x)
if (nx == 0) return(x)
resolved <- attr(x, "resolved", exact = TRUE)
size <- attr(x, "total_size", exact = TRUE)
x <- NextMethod()
attr(x, "resolved") <- resolved
## Were any elements dropped?
if (length(x) != nx) size <- NA_real_
attr(x, "total_size") <- size
x
}
#' @export
resolve.FutureGlobals <- function(x, ...) {
## Nothing to do?
if (length(x) == 0) return(x)
## Already resolved?
if (isTRUE(attr(x, "resolved", exact = TRUE))) return(x)
x <- NextMethod()
## At this point we consider these future globals resolved (regardless of 'recursive')
attr(x, "resolved") <- TRUE
## Since we don't know whether the above turned any futures into their
## values, we cannot make any assumption about the total size.
attr(x, "total_size") <- NA_real_
x
}
|
