1as.lazy <- function(x, env = baseenv()) UseMethod("as.lazy") 2as.lazy.lazy <- function(x, env = baseenv()) x 3as.lazy.formula <- function(x, env = baseenv()) lazy_(x[[2]], environment(x)) 4as.lazy.character <- function(x, env = baseenv()) lazy_(parse(text = x)[[1]], env) 5as.lazy.call <- function(x, env = baseenv()) lazy_(x, env) 6as.lazy.name <- function(x, env = baseenv()) lazy_(x, env) 7as.lazy.numeric <- function(x, env = baseenv()) { 8 if (length(x) > 1) { 9 warning("Truncating vector to length 1", call. = FALSE) 10 x <- x[1] 11 } 12 lazy_(x, env) 13} 14as.lazy.logical <- as.lazy.numeric 15as.lazy_dots <- function(x, env) UseMethod("as.lazy_dots") 16as.lazy_dots.NULL <- function(x, env = baseenv()) { 17 structure(list(), class = "lazy_dots") 18} 19as.lazy_dots.list <- function(x, env = baseenv()) { 20 structure(lapply(x, as.lazy, env = env), class = "lazy_dots") 21} 22as.lazy_dots.name <- function(x, env = baseenv()) { 23 structure(list(as.lazy(x, env)), class = "lazy_dots") 24} 25as.lazy_dots.formula <- as.lazy_dots.name 26as.lazy_dots.call <- as.lazy_dots.name 27as.lazy_dots.lazy <- function(x, env = baseenv()) { 28 structure(list(x), class = "lazy_dots") 29} 30as.lazy_dots.character <- function(x, env = baseenv()) { 31 structure(lapply(x, as.lazy, env = env), class = "lazy_dots") 32} 33as.lazy_dots.lazy_dots <- function(x, env = baseenv()) { 34 x 35} 36all_dots <- function(.dots, ..., all_named = FALSE) { 37 dots <- as.lazy_dots(list(...)) 38 if (!missing(.dots)) { 39 dots2 <- as.lazy_dots(.dots) 40 dots <- c(dots, dots2) 41 } 42 43 if (all_named) { 44 dots <- auto_name(dots) 45 } 46 47 dots 48 49} 50lazy_eval <- function(x, data = NULL) { 51 if (is.lazy_dots(x)) { 52 return(lapply(x, lazy_eval, data = data)) 53 } 54 55 x <- as.lazy(x) 56 57 if (!is.null(data)) { 58 eval(x$expr, data, x$env) 59 } else { 60 eval(x$expr, x$env, emptyenv()) 61 } 62} 63interp <- function(`_obj`, ..., .values) { 64 UseMethod("interp") 65} 66interp.call <- function(`_obj`, ..., .values) { 67 values <- all_values(.values, ...) 68 69 substitute_(`_obj`, values) 70} 71interp.name <- function(`_obj`, ..., .values) { 72 values <- all_values(.values, ...) 73 74 substitute_(`_obj`, values) 75} 76interp.formula <- function(`_obj`, ..., .values) { 77 values <- all_values(.values, ...) 78 79 `_obj`[[2]] <- substitute_(`_obj`[[2]], values) 80 `_obj` 81} 82interp.lazy <- function(`_obj`, ..., .values) { 83 values <- all_values(.values, ...) 84 85 `_obj`$expr <- substitute_(`_obj`$expr, values) 86 `_obj` 87} 88interp.character <- function(`_obj`, ..., .values) { 89 values <- all_values(.values, ...) 90 91 expr1 <- parse(text = `_obj`)[[1]] 92 expr2 <- substitute_(expr1, values) 93 deparse(expr2) 94} 95substitute_ <- function(x, env) { 96 call <- substitute(substitute(x, env), list(x = x)) 97 eval(call) 98} 99all_values <- function(.values, ...) { 100 if (missing(.values)) { 101 values <- list(...) 102 } else if (identical(.values, globalenv())) { 103 # substitute doesn't want to replace in globalenv 104 values <- as.list(globalenv()) 105 } else { 106 values <- .values 107 } 108 # Replace lazy objects with their expressions 109 is_lazy <- vapply(values, is.lazy, logical(1)) 110 values[is_lazy] <- lapply(values[is_lazy], `[[`, "expr") 111 112 values 113} 114missing_arg <- function() { 115 quote(expr = ) 116} 117lazy_dots <- function(..., .follow_symbols = FALSE) { 118 if (nargs() == 0 || (nargs() == 1 && ! missing(.follow_symbols))) { 119 return(structure(list(), class = "lazy_dots")) 120 } 121 122 .Call(C_make_lazy_dots, environment(), .follow_symbols) 123} 124is.lazy_dots <- function(x) inherits(x, "lazy_dots") 125`[.lazy_dots` <- function(x, i) { 126 structure(NextMethod(), class = "lazy_dots") 127} 128`$<-.lazy_dots` <- function(x, i, value) { 129 value <- as.lazy(value, parent.frame()) 130 x[[i]] <- value 131 x 132} 133`[<-.lazy_dots` <- function(x, i, value) { 134 value <- lapply(value, as.lazy, env = parent.frame()) 135 NextMethod() 136} 137c.lazy_dots <- function(..., recursive = FALSE) { 138 structure(NextMethod(), class = "lazy_dots") 139} 140lazy_ <- function(expr, env) { 141 stopifnot(is.call(expr) || is.name(expr) || is.atomic(expr)) 142 143 structure(list(expr = expr, env = env), class = "lazy") 144} 145lazy <- function(expr, env = parent.frame(), .follow_symbols = TRUE) { 146 .Call(C_make_lazy, quote(expr), environment(), .follow_symbols) 147} 148is.lazy <- function(x) inherits(x, "lazy") 149print.lazy <- function(x, ...) { 150 code <- deparse(x$expr) 151 if (length(code) > 1) { 152 code <- paste(code[[1]], "...") 153 } 154 155 cat("<lazy>\n") 156 cat(" expr: ", code, "\n", sep = "") 157 cat(" env: ", format(x$env), "\n", sep = "") 158} 159make_call <- function(fun, args) { 160 stopifnot(is.call(fun) || is.name(fun)) 161 args <- as.lazy_dots(args) 162 expr <- lapply(args, `[[`, "expr") 163 164 lazy_( 165 as.call(c(fun, expr)), 166 common_env(args) 167 ) 168} 169common_env <- function(dots) { 170 if (!is.list(dots)) stop("dots must be a list", call. = FALSE) 171 if (length(dots) == 0) return(baseenv()) 172 173 dots <- as.lazy_dots(dots) 174 env <- dots[[1]]$env 175 if (length(dots) == 1) return(env) 176 177 for (i in 2:length(dots)) { 178 if (!identical(env, dots[[i]]$env)) { 179 return(baseenv()) 180 } 181 } 182 env 183} 184eval_call <- function(fun, dots, env = parent.frame()) { 185 186 vars <- paste0("x", seq_along(dots)) 187 names(vars) <- names(dots) 188 189 # Create environment containing promises 190 env <- new.env(parent = env) 191 for(i in seq_along(dots)) { 192 dot <- dots[[i]] 193 194 assign_call <- substitute( 195 delayedAssign(vars[i], expr, dot$env, assign.env = env), 196 list(expr = dot$expr) 197 ) 198 eval(assign_call) 199 } 200 201 args <- lapply(vars, as.symbol) 202 call <- as.call(c(fun, args)) 203 204 eval(call, env) 205} 206auto_name <- function(x, max_width = 40) { 207 names(x) <- auto_names(x, max_width = max_width) 208 x 209} 210auto_names <- function(x, max_width = 40) { 211 x <- as.lazy_dots(x) 212 213 nms <- names(x) %||% rep("", length(x)) 214 215 missing <- nms == "" 216 expr <- lapply(x[missing], `[[`, "expr") 217 nms[missing] <- vapply(expr, deparse_trunc, width = max_width, 218 FUN.VALUE = character(1), USE.NAMES = FALSE) 219 220 nms 221} 222deparse_trunc <- function(x, width = getOption("width")) { 223 if (is.symbol(x)) { 224 return(as.character(x)) 225 } 226 227 text <- deparse(x, width.cutoff = width) 228 if (length(text) == 1 && nchar(text) < width) return(text) 229 230 paste0(substr(text[1], 1, width - 3), "...") 231} 232promise_expr <- function(prom) { 233 .Call(C_promise_expr_, prom) 234} 235 236promise_env <- function(prom) { 237 .Call(C_promise_env_, prom) 238} 239as.lazy.promise <- function(x, ...) { 240 lazy_(promise_expr(x), promise_env(x)) 241} 242"%||%" <- function(x, y) if(is.null(x)) y else x 243