From c492773096b5195fa8db8657c5d81641302d27ba Mon Sep 17 00:00:00 2001 From: Lionel Henry Date: Thu, 10 Nov 2016 20:28:09 +0100 Subject: [PATCH 1/3] Forward expr_ functions to rlang::arg_ functions --- DESCRIPTION | 2 ++ R/expr.R | 21 ++++++--------------- tests/testthat/test-expr.R | 17 ----------------- 3 files changed, 8 insertions(+), 32 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 8f9680a..e089a71 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -12,6 +12,8 @@ License: GPL-3 LazyData: true Depends: R (>= 3.1.0) +Imports: + rlang Suggests: knitr, rmarkdown (>= 0.2.65), diff --git a/R/expr.R b/R/expr.R index 427ee7f..863f2fa 100644 --- a/R/expr.R +++ b/R/expr.R @@ -69,28 +69,19 @@ expr_text_ <- function(x, width = 60L, nlines = Inf) { paste0(str, collapse = "\n") } -#' @useDynLib lazyeval expr_find_ #' @export #' @rdname expr_label expr_find <- function(x) { - .Call(expr_find_, quote(x), environment()) + rlang::arg_expr(x) } -#' @useDynLib lazyeval expr_env_ -#' @param default_env If supplied, \code{expr_env} will return this if the -#' promise has already been forced. Otherwise it will throw an error. +#' @param default_env Deprecated and has no longer any effect. +#' \code{expr_env()} now always returns an environment. #' @export #' @rdname expr_label expr_env <- function(x, default_env) { - env <- .Call(expr_env_, quote(x), environment()) - - if (is.null(env)) { - if (missing(default_env)) { - stop("Promise has already been forced") - } else { - default_env - } - } else { - env + if (!missing(default_env)) { + warning(call. = FALSE, "`default_env` is deprecated") } + rlang::arg_env(x) } diff --git a/tests/testthat/test-expr.R b/tests/testthat/test-expr.R index 290cc41..2caa09f 100644 --- a/tests/testthat/test-expr.R +++ b/tests/testthat/test-expr.R @@ -25,23 +25,6 @@ test_that("follows multiple promises", { expect_identical(h(x + y), environment()) }) -test_that("throws error if promise forced", { - f <- function(x) { - force(x) - expr_env(x) - } - expect_error(f(10), "already been forced") -}) - - -test_that("or can return default env", { - env <- new.env(parent = emptyenv()) - f <- function(x) { - force(x) - expr_env(x, env) - } - expect_identical(f(10), env) -}) # expr_text --------------------------------------------------------------- From 0f07170ee89f8d810f6249b5bc78b2aaf6fa532b Mon Sep 17 00:00:00 2001 From: Lionel Henry Date: Fri, 11 Nov 2016 21:08:32 +0100 Subject: [PATCH 2/3] Forward lazy functions to rlang::arg_info() --- NAMESPACE | 4 -- R/f-capture.R | 6 +-- R/lazy-dots.R | 26 +++++++-- R/lazy.R | 30 ++++++++++- R/utils.R | 6 +++ man/expr_label.Rd | 4 +- man/lazy_dots.Rd | 2 +- src/expr.c | 76 -------------------------- src/lazy.c | 107 ------------------------------------- tests/testthat/test-lazy.R | 18 ------- 10 files changed, 63 insertions(+), 216 deletions(-) delete mode 100644 src/expr.c delete mode 100644 src/lazy.c diff --git a/NAMESPACE b/NAMESPACE index d1c9971..abd3e8b 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -94,11 +94,7 @@ export(uq) export(uqf) export(uqs) useDynLib(lazyeval,env) -useDynLib(lazyeval,expr_env_) -useDynLib(lazyeval,expr_find_) useDynLib(lazyeval,interp_) useDynLib(lazyeval,lhs) useDynLib(lazyeval,lhs_name) -useDynLib(lazyeval,make_lazy) -useDynLib(lazyeval,make_lazy_dots) useDynLib(lazyeval,rhs) diff --git a/R/f-capture.R b/R/f-capture.R index f278484..8cd7da2 100644 --- a/R/f-capture.R +++ b/R/f-capture.R @@ -23,13 +23,13 @@ #' h <- function(z) f_capture(z) #' f(a + b + c) f_capture <- function(x) { - lazy <- .Call(make_lazy, quote(x), environment(), TRUE) - f_new(lazy$expr, env = lazy$env) + info <- rlang::arg_info(x) + f_new(info$expr, env = info$eval_frame$env) } #' @export #' @rdname f_capture dots_capture <- function(..., .ignore_empty = TRUE) { - lazies <- .Call(make_lazy_dots, environment(), TRUE, .ignore_empty) + lazies <- lazy_dots(..., .ignore_empty = .ignore_empty) lapply(lazies, function(x) f_new(x$expr, env = x$env)) } diff --git a/R/lazy-dots.R b/R/lazy-dots.R index d18d1fd..ae64754 100644 --- a/R/lazy-dots.R +++ b/R/lazy-dots.R @@ -5,7 +5,6 @@ #' @return A named list of \code{\link{lazy}} expressions. #' @inheritParams lazy #' @export -#' @useDynLib lazyeval make_lazy_dots #' @examples #' lazy_dots(x = 1) #' lazy_dots(a, b, c * 4) @@ -29,8 +28,29 @@ #' l["z"] <- list(~g) #' #' c(lazy_dots(x = 1), lazy_dots(f)) -lazy_dots <- function(..., .follow_symbols = FALSE, .ignore_empty = FALSE) { - .Call(make_lazy_dots, environment(), .follow_symbols, .ignore_empty) +lazy_dots <- function(..., .follow_symbols = TRUE, .ignore_empty = FALSE) { + dots <- rlang::arg_dots(...) + if (!length(dots)) { + return(structure(list(), class = "lazy_dots")) + } + + if (.follow_symbols) { + stack <- rlang::call_stack() + } else { + stack <- rlang::call_stack(2) + } + + info <- rlang::dots_info_(dots, stack) + lazy_dots <- lapply2(info, seq_along(info), info_as_lazy) + + if (.ignore_empty) { + is_missing <- vapply_lgl(lazy_dots, function(lzy) { + rlang::is_missing(lzy$expr) + }) + lazy_dots <- lazy_dots[!is_missing] + } + + structure(lazy_dots, class = "lazy_dots") } is.lazy_dots <- function(x) inherits(x, "lazy_dots") diff --git a/R/lazy.R b/R/lazy.R index 229ee53..f322620 100644 --- a/R/lazy.R +++ b/R/lazy.R @@ -48,9 +48,35 @@ lazy_ <- function(expr, env) { #' @rdname lazy_ #' @export -#' @useDynLib lazyeval make_lazy lazy <- function(expr, env = parent.frame(), .follow_symbols = TRUE) { - .Call(make_lazy, quote(expr), environment(), .follow_symbols) + if (.follow_symbols) { + stack <- rlang::call_stack() + } else { + stack <- rlang::call_stack(2) + } + info <- rlang::arg_info_(quote(expr), stack) + info_as_lazy(info) +} + +info_as_lazy <- function(info, i_dot) { + lzy <- list( + expr = info$expr, + env = info$eval_frame$env + ) + lzy <- substitute_dots(lzy, info$eval_frame$env, i_dot) + structure(lzy, class = "lazy") +} +substitute_dots <- function(lazy, caller_env, i_dot) { + if (!is.symbol(lazy$expr)) { + return(lazy) + } + + nm <- as.character(lazy$expr) + if (grepl("\\.\\.[0-9]+$", nm)) { + dots <- rlang::frame_dots(caller_env) + lazy$expr <- dots[[i_dot]] + } + lazy } is.lazy <- function(x) inherits(x, "lazy") diff --git a/R/utils.R b/R/utils.R index fe346ae..226c3bd 100644 --- a/R/utils.R +++ b/R/utils.R @@ -35,3 +35,9 @@ substitute_ <- function(x, env) { missing_arg <- function() { quote(expr = ) } +vapply_lgl <- function(.x, .f, ...) { + vapply(.x, .f, logical(1), ...) +} +lapply2 <- function(.x, .y, .f, ...) { + Map(.f, .x, .y, ...) +} diff --git a/man/expr_label.Rd b/man/expr_label.Rd index 21a6c28..6f97559 100644 --- a/man/expr_label.Rd +++ b/man/expr_label.Rd @@ -22,8 +22,8 @@ expr_env(x, default_env) \item{nlines}{Maximum number of lines to extract.} -\item{default_env}{If supplied, \code{expr_env} will return this if the -promise has already been forced. Otherwise it will throw an error.} +\item{default_env}{Deprecated and has no longer any effect. +\code{expr_env()} now always returns an environment.} } \description{ \code{expr_find()} finds the full expression; \code{expr_text()} turns the diff --git a/man/lazy_dots.Rd b/man/lazy_dots.Rd index 8e68e55..997241f 100644 --- a/man/lazy_dots.Rd +++ b/man/lazy_dots.Rd @@ -4,7 +4,7 @@ \alias{lazy_dots} \title{Capture ... (dots) for later lazy evaluation.} \usage{ -lazy_dots(..., .follow_symbols = FALSE, .ignore_empty = FALSE) +lazy_dots(..., .follow_symbols = TRUE, .ignore_empty = FALSE) } \arguments{ \item{...}{Dots from another function} diff --git a/src/expr.c b/src/expr.c deleted file mode 100644 index 2c7ec1e..0000000 --- a/src/expr.c +++ /dev/null @@ -1,76 +0,0 @@ -#define R_NO_REMAP -#include -#include -#include "utils.h" - -SEXP base_promise(SEXP promise, SEXP env) { - // recurse until we find the real promise, not a promise of a promise - while(TYPEOF(promise) == PROMSXP) { - env = PRENV(promise); - promise = PREXPR(promise); - - // promise has already been forced so can't go further - if (env == R_NilValue) - break; - - // If the promise is threaded through multiple functions, we'll - // get some symbols along the way. If the symbol is bound to a promise - // keep going on up - if (TYPEOF(promise) == SYMSXP) { - SEXP obj = Rf_findVar(promise, env); - - if (TYPEOF(obj) != PROMSXP) - break; - - if (is_lazy_load(obj)) - break; - - promise = obj; - } - } - - return promise; -} - -// Return NULL if not a promise or has already been forced -SEXP base_promise_env(SEXP promise, SEXP env) { - if (TYPEOF(promise) != PROMSXP) - return R_NilValue; - - // recurse until we find the real promise, not a promise of a promise - while(TYPEOF(promise) == PROMSXP) { - env = PRENV(promise); - promise = PREXPR(promise); - - // promise has already been forced so can't go further - if (env == R_NilValue) - return R_NilValue; - - // If the promise is threaded through multiple functions, we'll - // get some symbols along the way. If the symbol is bound to a promise - // keep going on up - if (TYPEOF(promise) == SYMSXP) { - SEXP obj = Rf_findVar(promise, env); - - if (TYPEOF(obj) != PROMSXP) - break; - - if (is_lazy_load(obj)) - break; - - promise = obj; - } - } - - return env; -} - -SEXP expr_find_(SEXP name, SEXP env) { - SEXP promise = Rf_findVar(name, env); - return base_promise(promise, env); -} - -SEXP expr_env_(SEXP name, SEXP env, SEXP env_default) { - SEXP promise = Rf_findVar(name, env); - return base_promise_env(promise, env); -} diff --git a/src/lazy.c b/src/lazy.c deleted file mode 100644 index 98883f8..0000000 --- a/src/lazy.c +++ /dev/null @@ -1,107 +0,0 @@ -#include -#include -#include "utils.h" - -SEXP promise_as_lazy(SEXP promise, SEXP env, int follow_symbols) { - // recurse until we find the real promise, not a promise of a promise - while(TYPEOF(promise) == PROMSXP) { - if (PRENV(promise) == R_NilValue) { - Rf_error("Promise has already been forced"); - } - - env = PRENV(promise); - promise = PREXPR(promise); - - // If the promise is threaded through multiple functions, we'll - // get some symbols along the way. If the symbol is bound to a promise - // keep going on up - if (follow_symbols && TYPEOF(promise) == SYMSXP) { - SEXP obj = findVar(promise, env); - - if (obj == R_MissingArg || obj == R_UnboundValue) - break; - - if (TYPEOF(obj) == PROMSXP && is_lazy_load(obj)) - break; - - promise = obj; - } - } - - // Make named list for output - SEXP lazy = PROTECT(allocVector(VECSXP, 2)); - if (NAMED(promise) < 2) - SET_NAMED(promise, 2); - SET_VECTOR_ELT(lazy, 0, promise); - SET_VECTOR_ELT(lazy, 1, env); - - SEXP names = PROTECT(allocVector(STRSXP, 2)); - SET_STRING_ELT(names, 0, mkChar("expr")); - SET_STRING_ELT(names, 1, mkChar("env")); - - setAttrib(lazy, install("names"), names); - setAttrib(lazy, install("class"), PROTECT(mkString("lazy"))); - - UNPROTECT(3); - - return lazy; -} - -SEXP make_lazy(SEXP name, SEXP env, SEXP follow_symbols_) { - SEXP promise = findVar(name, env); - int follow_symbols = asLogical(follow_symbols_); - - return promise_as_lazy(promise, env, follow_symbols); -} - -int is_missing(SEXP x) { - return TYPEOF(x) == SYMSXP && x == R_MissingArg; -} - -SEXP make_lazy_dots(SEXP env, SEXP follow_symbols_, SEXP ignore_empty_) { - SEXP dots = findVar(R_DotsSymbol, env); - int follow_symbols = asLogical(follow_symbols_); - int ignore_empty = asLogical(ignore_empty_); - - if (dots == R_MissingArg) { - SEXP out = PROTECT(Rf_allocVector(VECSXP, 0)); - setAttrib(out, install("class"), PROTECT(mkString("lazy_dots"))); - UNPROTECT(2); - return out; - } - - // Figure out how many elements in dots - int n = 0; - for(SEXP nxt = dots; nxt != R_NilValue; nxt = CDR(nxt)) { - if (ignore_empty && is_missing(CAR(nxt))) - continue; - - n++; - } - - // Allocate list to store results - SEXP lazy_dots = PROTECT(allocVector(VECSXP, n)); - SEXP names = PROTECT(allocVector(STRSXP, n)); - - // Iterate through all elements of dots, converting promises into lazy exprs - int i = 0; - for(SEXP nxt = dots; nxt != R_NilValue; nxt = CDR(nxt)) { - SEXP promise = CAR(nxt); - - if (ignore_empty && is_missing(promise)) - continue; - - SEXP lazy = promise_as_lazy(promise, env, follow_symbols); - SET_VECTOR_ELT(lazy_dots, i, lazy); - if (TAG(nxt) != R_NilValue) - SET_STRING_ELT(names, i, PRINTNAME(TAG(nxt))); - - i++; - } - setAttrib(lazy_dots, install("names"), names); - setAttrib(lazy_dots, install("class"), PROTECT(mkString("lazy_dots"))); - - UNPROTECT(3); - - return lazy_dots; -} diff --git a/tests/testthat/test-lazy.R b/tests/testthat/test-lazy.R index 5d73734..1d6f621 100644 --- a/tests/testthat/test-lazy.R +++ b/tests/testthat/test-lazy.R @@ -23,24 +23,6 @@ test_that("lazy() works with nested promises", { expect_equal(outer_fun(call("name"))$expr, quote(call("name"))) }) -test_that("lazy() does not unpack lazily loaded objects", { - lazy <- lazy_caller(mean) - expect_equal(deparse(lazy$expr), "mean") - - nested_lazy <- outer_fun(mean) - expect_equal(deparse(lazy$expr), "mean") - - outer_fun2 <- function() { - list( - lazy = lazy_caller(mean), - env = environment() - ) - } - embedded_lazy <- outer_fun2() - expect_identical(embedded_lazy$lazy$expr, as.name("mean")) - expect_identical(embedded_lazy$lazy$env, embedded_lazy$env) -}) - test_that("lazy() works for double-colon operator", { expect_error(lazy <- lazy_caller(stats::runif(10)), NA) expect_error(nested_lazy <- outer_fun(stats::runif(10)), NA) From 1b2f6f1943a8b5b90598d1f8bc9893817237fc6f Mon Sep 17 00:00:00 2001 From: Lionel Henry Date: Mon, 14 Nov 2016 13:43:52 +0100 Subject: [PATCH 3/3] Add rlang to Remotes: --- DESCRIPTION | 1 + 1 file changed, 1 insertion(+) diff --git a/DESCRIPTION b/DESCRIPTION index e089a71..c4925a1 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -21,3 +21,4 @@ Suggests: covr VignetteBuilder: knitr RoxygenNote: 5.0.1 +Remotes: hadley/rlang#2