lazyeval/0000755000176200001440000000000015164116535012110 5ustar liggesuserslazyeval/tests/0000755000176200001440000000000015163705077013256 5ustar liggesuserslazyeval/tests/testthat/0000755000176200001440000000000015164116535015112 5ustar liggesuserslazyeval/tests/testthat/ast-sample.txt0000644000176200001440000000033515163037425017721 0ustar liggesusers┗ 1 ┗ `x ┗ () ┗ `+ ┗ `a ┗ `b ┗ () ┗ `function ┗ [] ┗ x = 1 ┗ y =() ┗ `+ ┗ `a ┗ `b ┗ z =`MISSING ┗ () ┗ `{ ┗ () ┗ `+ ┗ `c ┗ `d ┗ lazyeval/tests/testthat/test-ast.R0000644000176200001440000000114415162736220016776 0ustar liggesuserscontext("ast") test_that("common cases are as expected", { skip_on_cran() # because of unicode comparison problems. skip_on_os("windows") x <- list( 1, quote(x), quote(a + b), quote(function(x = 1, y = a + b, z) { c + d }) ) expect_output_file(ast_(x), "ast-sample.txt", update = TRUE) }) test_that("can print trees that can't be generated from text source", { skip_on_cran() # because of unicode comparison problems. skip_on_os("windows") x <- quote(foo()) x[[2]] <- mtcars x[[3]] <- 1:10 expect_output_file(ast_(x), "ast-irregular.txt", update = TRUE) }) lazyeval/tests/testthat/test-f-capture.R0000644000176200001440000000103212726271770020100 0ustar liggesuserscontext("f_capture") test_that("explicit promise makes a formula", { f1 <- f_capture(1 + 2 + 3) f2 <- ~ 1 + 2 + 3 expect_equal(f1, f2) }) test_that("explicit promise works several levels deep", { f <- function(x) g(x) g <- function(y) h(y) h <- function(z) f_capture(z) f1 <- f(1 + 2 + 3) f2 <- ~ 1 + 2 + 3 expect_equal(f1, f2) }) test_that("explicit dots makes a list of formulas", { fs <- dots_capture(x = 1 + 2, y = 2 + 3) f1 <- ~ 1 + 2 f2 <- ~ 2 + 3 expect_equal(fs$x, f1) expect_equal(fs$y, f2) }) lazyeval/tests/testthat/test-expr.R0000644000176200001440000000325715163675314017203 0ustar liggesuserscontext("expr") # expr_find --------------------------------------------------------------- test_that("doesn't go pass lazy loaded objects", { expect_identical(expr_find(mtcars), quote(mtcars)) }) test_that("follows multiple promises", { f <- function(x) g(x) g <- function(y) h(y) h <- function(z) expr_find(z) expect_identical(f(x + y), quote(x + y)) }) # expr_env ---------------------------------------------------------------- test_that("follows multiple promises", { f <- function(x) g(x) g <- function(y) h(y) h <- function(z) expr_env(z) 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 --------------------------------------------------------------- test_that("always returns single string", { out <- expr_text({ a + b }) expect_length(out, 1) }) test_that("can truncate lines", { out <- expr_text({ a + b }, nlines = 2) expect_equal(out, "{\n...") }) # expr_label -------------------------------------------------------------- test_that("quotes strings", { expect_equal(expr_label("a"), '"a"') expect_equal(expr_label("\n"), '"\\n"') }) test_that("backquotes names", { expect_equal(expr_label(x), "`x`") }) test_that("converts atomics to strings", { expect_equal(expr_label(0.5), "0.5") }) test_that("truncates long calls", { expect_equal( expr_label({ a + b }), "`{\n ...\n}`" ) }) lazyeval/tests/testthat/test-dots.R0000644000176200001440000000072715163675314017175 0ustar liggesuserscontext("lazy_dots") test_that("lazy_dots works with no args", { l1 <- lazy_dots() l2 <- lazy_dots(.follow_symbols = TRUE) expect_equal(l1, structure(list(), class = "lazy_dots")) expect_equal(l2, structure(list(), class = "lazy_dots")) }) test_that(".ignore_empty drops empty arguments", { l1 <- lazy_dots(, 1,) l2 <- lazy_dots(, 1, , .ignore_empty = TRUE) expect_equal(length(l1), 3) expect_equal(length(l2), 1) expect_equal(l2[[1]]$expr, 1) }) lazyeval/tests/testthat/test-f-eval.R0000644000176200001440000000341013004065022017343 0ustar liggesuserscontext("f_eval") test_that("first argument must be a function", { expect_error(f_eval(10), "`f` is not a formula") }) test_that("f_eval uses formula's environment", { x <- 10 f <- local({ y <- 100 ~ x + y }) expect_equal(f_eval(f), 110) }) test_that("data needs to be a list", { expect_error(f_eval(~ x, 10), "Do not know how to find data") }) test_that("looks first in `data`", { x <- 10 data <- list(x = 100) expect_equal(f_eval(~ x, data), 100) }) test_that("pronouns resolve ambiguity looks first in `data`", { x <- 10 data <- list(x = 100) expect_equal(f_eval(~ .data$x, data), 100) expect_equal(f_eval(~ .env$x, data), 10) }) test_that("pronouns complain about missing values", { expect_error(f_eval(~ .data$x, list()), "Variable 'x' not found in data") expect_error(f_eval(~ .env$`__`, list()), "Object '__' not found in environment") }) test_that("f_eval does quasiquoting", { x <- 10 expect_equal(f_eval(~ uq(quote(x))), 10) }) test_that("unquoted formulas look in their own env", { f <- function() { n <- 100 ~ n } n <- 10 expect_equal(f_eval(~ uq(f())), 10) }) test_that("unquoted formulas can use data", { f1 <- function() { z <- 100 ~ x + z } f2 <- function() { z <- 100 ~ .data$x + .env$z } z <- 10 expect_equal(f_eval(~ uq(f1()), data = list(x = 1)), 101) expect_equal(f_eval(~ uq(f2()), data = list(x = 1)), 101) }) test_that("f_eval_lhs uses lhs", { f <- 1 ~ 2 expect_equal(f_eval_lhs(f), 1) }) # find_data --------------------------------------------------------------- test_that("find data works for NULL, lists, and data frames", { expect_equal(find_data(NULL), list()) expect_equal(find_data(list(x = 1)), list(x = 1)) expect_equal(find_data(mtcars), mtcars) }) lazyeval/tests/testthat/test-lazy.R0000644000176200001440000000244015163675314017175 0ustar liggesuserscontext("lazy") lazy_caller <- function(arg) { lazy(arg) } outer_fun <- function(arg) { lazy_caller(arg) } test_that("basic lazy() functionality works", { expect_equal(lazy_caller(0)$expr, 0) expect_equal(lazy_caller("char")$expr, "char") expect_equal(lazy_caller(sym)$expr, as.name("sym")) expect_equal(lazy_caller(call("name"))$expr, quote(call("name"))) }) test_that("lazy() works with nested promises", { expect_equal(outer_fun(0)$expr, 0) expect_equal(outer_fun("char")$expr, "char") expect_equal(outer_fun(sym)$expr, as.name("sym")) expect_equal(outer_fun(call("name"))$expr, quote(call("name"))) }) 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) }) test_that("lazy() errors on forced promises", { f <- function(x) { force(x) lazy(x) } expect_error(f(1 + 2), "forced") expect_error(f(~a), "forced") }) test_that("lazy() works with formula promises", { f <- function(x) lazy(x) result <- f(~ a + b) expect_equal(result$expr, quote(~ a + b)) }) test_that("lazy_dots() errors on forced promises", { f <- function(...) { force(..1) lazy_dots(...) } expect_error(f(1 + 2), "forced") expect_error(f(~a), "forced") }) lazyeval/tests/testthat/ast-irregular.txt0000644000176200001440000000005515163037425020433 0ustar liggesusers┗ () ┗ `foo ┗ ┗ lazyeval/tests/testthat/test-f-unwrap.R0000644000176200001440000000073212726271770017757 0ustar liggesuserscontext("f_unwrap") test_that("f_unwrap substitutes values", { n <- 100 f1 <- f_unwrap(~ x + n) f2 <- f_new(quote(x + 100), env = parent.env(environment())) expect_identical(f1, f2) }) test_that("f_unwrap substitutes even in globalenv", { .GlobalEnv$`__1` <- 1 expect_equal(f_rhs(f_unwrap(f_new(quote(`__1`), env = globalenv()))), 1) }) test_that("doesn't go past empty env", { f <- f_new(quote(x == y), env = emptyenv()) expect_equal(f_unwrap(f), f) }) lazyeval/tests/testthat/test-f-interp.R0000644000176200001440000000323312726271770017743 0ustar liggesuserscontext("f_interp") test_that("protected against bad inputs", { f <- ~ x + 1 attr(f, ".Environment") <- 10 expect_error(f_interp(f), "must be an environment") }) test_that("interp produces single string for character inputs", { x <- interp("aaaaaaaaaaaaaa + bbbbbbbbbbbbbbb + ccccccccccccccccc + dddddddddddddddd + eeeeeeeeeeeeeee") expect_is(x, "character") expect_equal(length(x), 1) }) test_that("can interpolate from environment", { env <- new.env(parent = emptyenv()) env$a <- 10 out <- interp(~ f(a), .values = env) expect_identical(out, ~f(10)) }) # uq ---------------------------------------------------------------------- test_that("evaluates contents of uq()", { expect_equal(f_interp(~ uq(1 + 2)), ~ 3) }) test_that("unquoted formulas are interpolated first", { f <- function(n) { ~ x + uq(n) } n <- 100 expect_equal(f_interp(~ uq(f(10))), ~ x + 10) }) # uqs --------------------------------------------------------------------- test_that("contents of uqs() must be a vector", { expr <- ~ 1 + uqs(environment()) expect_error(f_interp(expr), "`x` must be a vector") }) test_that("values of uqs() spliced into expression", { expr <- ~ f(a, uqs(list(quote(b), quote(c))), d) expect_identical(f_interp(expr), ~ f(a, b, c, d)) }) test_that("names within uqs() are preseved", { expr <- ~ f(uqs(list(a = quote(b)))) expect_identical(f_interp(expr), ~ f(a = b)) }) # uqf --------------------------------------------------------------------- test_that("requires formula", { expect_error(f_interp(~ uqf(10)), "must be a formula") }) test_that("interpolates formula", { expect_equal(f_interp(~ uqf(x ~ y)), ~ (x ~ y)) }) lazyeval/tests/testthat/test-names.R0000644000176200001440000000035612467622500017316 0ustar liggesuserscontext("names") test_that("auto_name does not truncate symbols (#19)", { long_name <- quote(AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA) dots <- as.lazy_dots(long_name) expect_equal(auto_names(dots), as.character(long_name)) }) lazyeval/tests/testthat/test-complain.R0000644000176200001440000000166312726271770020026 0ustar liggesuserscontext("complain") test_that("NULL return unchanged", { expect_identical(complain(NULL), NULL) }) test_that("can't access non-existent list members", { x1 <- list(y = 1) x2 <- complain(x1) expect_equal(x2$y, 1) expect_error(x2$z, "object 'z' not found") expect_error(x2[["z"]], "object 'z' not found") }) test_that("can't access non-existent environment components", { x1 <- list2env(list(y = 1)) x2 <- complain(x1) expect_equal(x2$y, 1) expect_error(x2$z, "object 'z' not found") expect_error(x2[["z"]], "object 'z' not found") }) test_that("can't use non-character vectors", { x <- complain(list(y = 1)) expect_error(x[[1]], "subset with a string") expect_error(x[[c("a", "b")]], "subset with a string") }) test_that("complain doesn't taint env class", { x1 <- list2env(list(y = 1)) x2 <- complain(x1) expect_equal(class(x1), "environment") expect_equal(class(x2), c("complain", "environment")) }) lazyeval/tests/testthat/test-function.R0000644000176200001440000000036412726271770020046 0ustar liggesuserscontext("function") test_that("function_new equivalent to regular function", { f1 <- function(x = a + b, y) { x + y } attr(f1, "srcref") <- NULL f2 <- function_new(alist(x = a + b, y =), quote({x + y})) expect_equal(f1, f2) }) lazyeval/tests/testthat/test-call.R0000644000176200001440000000245113011153647017121 0ustar liggesuserscontext("call") # Creation ---------------------------------------------------------------- test_that("character vector must be length 1", { expect_error(call_new(letters), "must be length 1") }) test_that("args can be specified individually or as list", { out <- call_new("f", a = 1, .args = list(b = 2)) expect_equal(out, quote(f(a = 1, b = 2))) }) # Standardisation --------------------------------------------------------- test_that("can standardise base function", { out <- call_standardise(quote(matrix(nro = 3, 1:9))) expect_equal(out, quote(matrix(data = 1:9, nrow = 3))) }) test_that("can standardise local function", { foo <- function(bar, baz) {} out <- call_standardise(quote(foo(baz = 1, 4))) expect_equal(out, quote(foo(bar = 4, baz = 1))) }) # Modification ------------------------------------------------------------ test_that("all args must be named", { call <- quote(matrix(1:10)) expect_error(call_modify(call, list(1)), "must be named") }) test_that("new args inserted at end", { call <- quote(matrix(1:10)) out <- call_modify(call, list(nrow = 3)) expect_equal(out, quote(matrix(data = 1:10, nrow = 3))) }) test_that("new args replace old", { call <- quote(matrix(1:10)) out <- call_modify(call, list(data = 3)) expect_equal(out, quote(matrix(data = 3))) }) lazyeval/tests/testthat/test-f-list.R0000644000176200001440000000242312726271770017415 0ustar liggesuserscontext("f_list") test_that("input must be a list", { expect_error(as_f_list(1), "must be a list") }) test_that("LHS must evaluate to a string", { expect_error(f_list(1 ~ x), "must evaluate to a string or name") expect_error(f_list(letters ~ x), "must evaluate to a single string") expect_error(f_list(x ~ x ~ z), "must be a single-sided formula") }) test_that("regular elements are left as is", { expect_equal(f_list(x = 1:10), list(x = 1:10)) expect_equal(f_list(x = ~x), list(x = ~x)) }) test_that("output is actually a formula", { out <- f_list(x = ~x)[[1]] expect_s3_class(out, "formula") expect_identical(attr(out, ".Environment"), environment()) }) test_that("output always has names", { out <- f_list(1, 2, 3) expect_equal(names(out), c("", "", "")) }) test_that("names taken from LHS of formula", { out1 <- f_list("x" ~ y) out2 <- f_list(quote(x) ~ y) var <- ~x out3 <- f_list(var ~ y); out3 expect_equal(out1, list(x = ~y)) expect_equal(out2, list(x = ~y)) expect_equal(out3, list(x = ~y)) }) test_that("null LHS leaves names unchanged", { expect_equal(f_list(x = NULL ~ y), list(x = ~y)) }) test_that("LHS evaluated in formula environment", { f <- function(x) { paste0(x, 1) ~ y } expect_equal(f_list(f("y")), list(y1 = ~ y)) }) lazyeval/tests/testthat/test-formula.R0000644000176200001440000000313313004065022017640 0ustar liggesuserscontext("formula") # Creation ---------------------------------------------------------------- test_that("env must be an environment", { expect_error(f_new(quote(a), env = list()), "must be an environment") }) test_that("equivalent to ~", { f1 <- ~abc f2 <- f_new(quote(abc)) expect_identical(f1, f2) }) test_that("is_formula works", { expect_true(is_formula(~10)) expect_false(is_formula(10)) }) # Getters ----------------------------------------------------------------- test_that("throws errors for bad inputs", { expect_error(f_rhs(1), "not a formula") expect_error(f_rhs(`~`()), "Invalid formula") expect_error(f_rhs(`~`(1, 2, 3)), "Invalid formula") expect_error(f_lhs(1), "not a formula") expect_error(f_lhs(`~`()), "Invalid formula") expect_error(f_lhs(`~`(1, 2, 3)), "Invalid formula") expect_error(f_env(1), "not a formula") }) test_that("extracts call, name, or scalar", { expect_identical(f_rhs(~ x), quote(x)) expect_identical(f_rhs(~ f()), quote(f())) expect_identical(f_rhs(~ 1L), 1L) }) # Setters ----------------------------------------------------------------- test_that("can replace RHS of one-sided formula", { f <- ~ x1 f_rhs(f) <- quote(x2) expect_equal(f, ~ x2) }) test_that("can replace both sides of two-sided formula", { f <- x1 ~ y1 f_lhs(f) <- quote(x2) f_rhs(f) <- quote(y2) expect_equal(f, x2 ~ y2) }) test_that("can remove lhs of two-sided formula", { f <- x ~ y f_lhs(f) <- NULL expect_equal(f, ~ y) }) test_that("can modify environment", { f <- x ~ y env <- new.env() f_env(f) <- env expect_equal(f_env(f), env) }) lazyeval/tests/testthat/test-language.R0000644000176200001440000000147013004065022017760 0ustar liggesuserscontext("language") test_that("NULL is a valid language object", { expect_true(is_lang(NULL)) }) # coercion ---------------------------------------------------------------- test_that("as_name produces names", { expect_equal(as_name("a"), quote(a)) expect_equal(as_name(quote(a)), quote(a)) expect_equal(as_name(quote(a())), quote(a)) expect_equal(as_name(~ a), quote(a)) expect_equal(as_name(~ a()), quote(a)) expect_error(as_name(c("a", "b")), "Can not coerce character vector of length > 1") }) test_that("as_call produces calls", { expect_equal(as_call(quote(a)), quote(a())) expect_equal(as_call(quote(a())), quote(a())) expect_equal(as_call("a()"), quote(a())) expect_equal(as_call(~ a()), quote(a())) expect_error(as_call(c("a", "b")), "Can not coerce character vector of length > 1") }) lazyeval/tests/testthat.R0000644000176200001440000000007412467622500015233 0ustar liggesuserslibrary(testthat) library(lazyeval) test_check("lazyeval") lazyeval/MD50000644000176200001440000002052415164116535012423 0ustar liggesusers0f3aac40db4e601d7347f5b9fe200d2d *DESCRIPTION 076be75efe0b6fdb85434c1d6ba4a81e *NAMESPACE e4f08d05aa86d36c1a8efdde8ca246ef *NEWS.md d9cc209f4c0c733a11ed93e673ae0d9c *R/ast.R befb1c81988ed1357c416f919528980d *R/call.R e3159cd804827c6d85885c17b284b5fb *R/complain.R b2388d07483695bad432af4278771633 *R/expr.R 57e40b0dd45196bae1bd50f405a23129 *R/f-capture.R c1e8a4f2908cc985b4faed2c04bebc7f *R/f-eval.R 359c772d90005f9558a73eed90441302 *R/f-interp.R 1d0f8e3b2eaf491d129a04ebe3084280 *R/formula.R ea161e248423ef0d17885123c1065258 *R/function.R be4330310f7efddd7fefe5052db9a8e0 *R/language.R d9a423351a93e1514bfac54255d4eb28 *R/lazy-as.R f2b5984a77262840aea4bf29785ed9b9 *R/lazy-call.R b9ffe3bc4e4a0476f20941d79767c947 *R/lazy-dots.R 66bfb57dbc11072d7581559830ba1994 *R/lazy-eval.R 41ed7c6a852958828eb44d08374bff84 *R/lazy-interp.R 3cbae872f5df31e044ddf79731550d93 *R/lazy-names.R 82c4b4197e5df808c9eca0b9b0bd9faa *R/lazy.R eaab07fb1d658479edaa8e1385a7ae05 *R/lazyeval.R 4501ecd06bc9f3d7513cc558cc195440 *R/utils.R 68e0f2dc47895a5449105cd7d7e967a3 *R/zzz.R 742ac6a0c83b8898f47fe4ed1b9aa912 *README.md 64c73627b5fa4775a92bba63431fc636 *build/vignette.rds ed41b4a52d51c4a0d811a7aaa99bbe84 *inst/doc/lazyeval-old.R fd0e6bc6fa61549d20cc69f641dd2ffd *inst/doc/lazyeval-old.Rmd 2d2bc312b1082bd4e26b1e8ae3134e5a *inst/doc/lazyeval-old.html f33853d7663f47fd4a5ba4f5d22a475c *inst/doc/lazyeval.R 52819a27a550ab9ef94ca05550e58cff *inst/doc/lazyeval.Rmd e1ad6bac9cfbaaf734683374b570c1fd *inst/doc/lazyeval.html 2c6ee8d0f2d6cf9583df82824633a7ec *man/all_dots.Rd 2f412970013bfff969553cc5cdbf7414 *man/as.lazy.Rd 4fa1680ecbd33e9f2accbed41fc3baa8 *man/as_name.Rd 4901deef27855e3ef5092ac2e4057a75 *man/ast_.Rd 1310232e76533965b20420bf90e30409 *man/auto_name.Rd 1340d8a3bedefed84920b71fedc792b2 *man/call_modify.Rd 42f82e62a13b78b7b320d47f22306e8b *man/call_new.Rd 1a8c04aa15f32ebd4f1b7134e5e47177 *man/common_env.Rd e324b6ed864946c37f1e09742db240e2 *man/expr_label.Rd 3a2dfc1787f0e86465012f83b49f37fd *man/f_capture.Rd 723f0f8420caa731cc4728018ece4da2 *man/f_eval.Rd f0855eadd09f65673bd144dfd873cdd9 *man/f_interp.Rd fb3fd925c09ff6f29b25e47b8d0669b4 *man/f_list.Rd ab43799b3040137e6469cc910bfc641a *man/f_new.Rd f0a2c22aa74c49a34b1e3dc1932fe493 *man/f_rhs.Rd e98fbfe37e6c547e36de5a24bb1fb458 *man/f_text.Rd 49fc315564f56e6c446f4473f18c0171 *man/f_unwrap.Rd 0478841ebc4f4a9dd82b4e7e2f5f69fd *man/function_new.Rd a1aebb42db9afefd71c6d00bc831e54c *man/interp.Rd eb6f14cec04ba1c8edcc1a1248197b7e *man/is_formula.Rd 4d2fea5d64ef556504c187239d3245df *man/is_lang.Rd 5197c686f549745ac6a6978c4b2fe2b1 *man/lazy_.Rd 0db962cf222cbe82f959174dd660805b *man/lazy_dots.Rd e4dd5b05f00327e486789b26be8f674a *man/lazy_eval.Rd 4557247dd1c9ce7d6a78520aa770f55b *man/make_call.Rd 4342c540bfd816fc182175e5b0608cd2 *man/missing_arg.Rd 7ce99b4f751ed37d222acf09d6835f0b *src/Makevars 674c7cfa4278427a90484c545651a671 *src/expr.c 773dd66e84e605dfb41d9c07624a3d34 *src/init.c 1bc95312a839de51b944cc86260a64bd *src/interp.c b59f6500d3912ec657a3b86fa31edd01 *src/lazy.c 5ff30a1fc26006eb8377347e329b1d13 *src/name.c f675812d8927e9b13fce5f1e8ed31f1b *src/rlang.c 0608535fc0aaf4efdf5a51912e6a6c84 *src/rlang/arg.c f33102fbb69a55bf8a314cd6cea529bd *src/rlang/arg.h 032997de0eb7a70acd881d9a53b6efb3 *src/rlang/attrib.c 3e42584f7654b259dd1b49842b3ef33c *src/rlang/attrib.h 9c9b7d12443672c8dee0a4615b56c2fc *src/rlang/c-utils.c bf583f300a656f07bb842e3f25b96107 *src/rlang/c-utils.h 22e5d851558dcb490b87b5ffebbcb6f8 *src/rlang/call.c 291751537e6eb339c08899eca084dee6 *src/rlang/call.h 7e95330c7c69a3090b2c3f6b62412b0c *src/rlang/cnd.c c323a0eff3440f67d2652c7d9f7ba22e *src/rlang/cnd.h b176a262a2ea2e884f4914289466de7b *src/rlang/cpp/rlang.cpp 29bd3e7d88cdb8a4a641f05ee089069c *src/rlang/cpp/vec.cpp e087224ebfb79ff325c2224665ab8a90 *src/rlang/debug.c ada02ec97cd21a5717e586f6be114b76 *src/rlang/debug.h c4c0b92858e604f1e651c5aa247ac5b0 *src/rlang/decl/cnd-decl.h c42446da8c4955c10b5acc67ec1ee130 *src/rlang/decl/df-decl.h 1aa66d903f3a4cb578ca16d7188511c6 *src/rlang/decl/dict-decl.h bcd3be7be1e7d4c9056adc78687c9f71 *src/rlang/decl/dyn-list-of-decl.h 9069f6115ab0b8cc64574cb3dfd5678a *src/rlang/decl/env-binding-decl.h acb47374357e2572e2c74ace4bcf5739 *src/rlang/decl/env-decl.h bf8df189e2ff68b0c0fe62d076814545 *src/rlang/decl/obj-decl.h 5cbb39aebac52f777c30ab65c94b2461 *src/rlang/decl/stack-decl.h e235b255aac77f597c1b0ea723f628e3 *src/rlang/decl/walk-decl.h db6c3d3e9e9424851c462289c9f08032 *src/rlang/df.c 59d548d90ba18659db46a8d6407913f1 *src/rlang/df.h 543a9da88f455acab0e00bed195c33ea *src/rlang/dict.c 1cf19f35f85a08af0c2c18bccb8fcb29 *src/rlang/dict.h 71410a32c3ded0854db20181ee5d5432 *src/rlang/dots-info.c 5fae98d74d830ca3d2a5afe098dd6493 *src/rlang/dots-info.h ca299d0a21f7c1b3354f1af93f663929 *src/rlang/dyn-array.c 3a77133e2b00de3f8bb61adbae4510f4 *src/rlang/dyn-array.h aadc788be09a2bd9a565c3e825eb428c *src/rlang/dyn-list-of.c 3b0bab5449ddb404e1ea6365c7eb38af *src/rlang/dyn-list-of.h decb10ed526637adb2fe3888f16f0464 *src/rlang/env-binding.c e7386f3f3b48887c5654c13e5336429a *src/rlang/env-binding.h 0e52014937a175a24690529ce6edd68d *src/rlang/env.c 3a5f4e5731304faf675e782360c935e3 *src/rlang/env.h 3d14354720fb5e921e054b499c477fff *src/rlang/eval.c 4ca79fe26c1b1cfd826dbc1bd8db3709 *src/rlang/eval.h 01f0a156858ea14578547720b4e94232 *src/rlang/export.c 9f78f01cd55ea638136022dd7bb6eeb1 *src/rlang/export.h ec36cc014954270b6b827f3844f5cf1b *src/rlang/fn.c afe3dad269ac797b1faa96bd5b374e93 *src/rlang/fn.h edbdbd626761de992dbb9f7a3b98b65d *src/rlang/formula.c b1fe913e42251fedac387df505833e8a *src/rlang/formula.h 524663b4ae77330bf56f45ab01aab16b *src/rlang/globals.c a49c88313a4858d75327828d537ecb5c *src/rlang/globals.h 883cf705478e061c810b25eec596eff6 *src/rlang/node.c 838e203b8802e4be9b09e03f2ddb3ac0 *src/rlang/node.h 6c50f61ab770398065ef1cc3992a9978 *src/rlang/obj.c a9d225f90fcbc919915f5a2364279151 *src/rlang/obj.h 4576f3bc9e1dafe198460d4c2b0e88f4 *src/rlang/parse.c fbbf64374cf70d42e7040794e1b30c7c *src/rlang/parse.h a5e865607e4e717784f5f951533d372c *src/rlang/quo.c 91e7e7c43c3edea2509fb3d1bbc3b81c *src/rlang/quo.h f24278fd4bb74e6cbe00d85c109255e3 *src/rlang/rlang-types.h b927fd7cf8ccf08ce0382805d25479cb *src/rlang/rlang.c 426d212a318562f9cb48ce9ec0714657 *src/rlang/rlang.h a24cd0a56d6993488d143ed8f5ffb7d7 *src/rlang/rlang.hpp 3115b50ab84dff920d09f95b4f73e395 *src/rlang/session.c c4f658b2f142941877450cc6a721942c *src/rlang/session.h 6225f1c2d3182e4bb957b8f1aba27937 *src/rlang/stack.c 3205bebc161f15bb38b38d88df1d6812 *src/rlang/stack.h e08266d8bec196133ce136c495e7f4ad *src/rlang/state.h 267ea357e68ff19af4f151c76b8c21c3 *src/rlang/sym.c 6a3a6aa98e58a296b6a86a177ad1b0a9 *src/rlang/sym.h 6ec4b806d0cad8eddae9250f2cbf3231 *src/rlang/vec-chr.c ae5f17aa96c3e532b67f3b9448ef5037 *src/rlang/vec-chr.h bf006c89dcffdc61228a385ee5ad342f *src/rlang/vec-lgl.c fda191ce4e58fefe29b8d9a734a6b7ef *src/rlang/vec-lgl.h 59cbf3a32be65ef4a5e95aefc9cc8afb *src/rlang/vec.c 32a20d759795163abe023042889cd8cf *src/rlang/vec.h aad9cb50156b9ab0f02ea91fb31db1b7 *src/rlang/vendor.c 1f93206ea8ca8cab1275e816347e852a *src/rlang/vendor.h e6050a519de98f82529d300b78a19117 *src/rlang/walk.c 83491b8bfe5110dda8e27b4fe2041399 *src/rlang/walk.h bc3ac89bff5634a3ff1b077d0d712586 *src/utils.c ea7cf21744a4ab4275b5680c1dc77b70 *src/utils.h b43a93ea47dc4f6a64a4625fb67b87f6 *tests/testthat.R 28ab6d5c95cce52309b007a83e869cd1 *tests/testthat/ast-irregular.txt eda899de62882fc656bfbd548171ee04 *tests/testthat/ast-sample.txt d3f4c1a9713d0fa4f987724dfc0afd11 *tests/testthat/test-ast.R 2a7ae04e75bf6ca648d1d8b7f0f0f255 *tests/testthat/test-call.R bd8c6bcb7b287fa288af9d8dd003c46c *tests/testthat/test-complain.R e8e09495ce9fe0d764c212b1f34c6bce *tests/testthat/test-dots.R 272b4af12a6a77dbac9988d687ffecc8 *tests/testthat/test-expr.R 03a6e2c3ec4675634e9d46be2794138d *tests/testthat/test-f-capture.R 943b81371b45f3ab141370765197be09 *tests/testthat/test-f-eval.R b5ea255aacfa712ab108dff7bc031543 *tests/testthat/test-f-interp.R f13ad194342bbc3166d97bae4d2c0f0a *tests/testthat/test-f-list.R 11bfa6279aa0e9589ea9d4f1b6d62a6e *tests/testthat/test-f-unwrap.R 81dc0f3c29e0df764289059a52026e02 *tests/testthat/test-formula.R cf2bc1d7126c6275bb6a66200c86cdc4 *tests/testthat/test-function.R 4e12b82cde56263135ae960627dce9cf *tests/testthat/test-language.R 32e7d77f748b7a0bd5dfc84e3b49cf86 *tests/testthat/test-lazy.R dcd46b347706159f3b53165d13ee9272 *tests/testthat/test-names.R fd0e6bc6fa61549d20cc69f641dd2ffd *vignettes/lazyeval-old.Rmd 52819a27a550ab9ef94ca05550e58cff *vignettes/lazyeval.Rmd lazyeval/R/0000755000176200001440000000000015163705077012315 5ustar liggesuserslazyeval/R/f-eval.R0000644000176200001440000000574013004065022013575 0ustar liggesusers#' @export #' @rdname f_eval f_eval_rhs <- function(f, data = NULL) { if (!is_formula(f)) { stop("`f` is not a formula", call. = FALSE) } expr <- f_rhs(f_interp(f, data = data)) eval_expr(expr, f_env(f), data) } #' @export #' @rdname f_eval f_eval_lhs <- function(f, data = NULL) { if (!is_formula(f)) { stop("`f` is not a formula", call. = FALSE) } expr <- f_lhs(f_interp(f, data = data)) eval_expr(expr, f_env(f), data) } #' Evaluate a formula #' #' \code{f_eval_rhs} evaluates the RHS of a formula and \code{f_eval_lhs} #' evaluates the LHS. \code{f_eval} is a shortcut for \code{f_eval_rhs} since #' that is what you most commonly need. #' #' If \code{data} is specified, variables will be looked for first in this #' object, and if not found in the environment of the formula. #' #' @section Pronouns: #' When used with \code{data}, \code{f_eval} provides two pronouns to make it #' possible to be explicit about where you want values to come from: #' \code{.env} and \code{.data}. These are thin wrappers around \code{.data} #' and \code{.env} that throw errors if you try to access non-existent values. #' #' @param f A formula. Any expressions wrapped in \code{ uq() } will #' will be "unquoted", i.e. they will be evaluated, and the results inserted #' back into the formula. See \code{\link{f_interp}} for more details. #' @param data A list (or data frame). \code{find_data} is a generic used to #' find the data associated with a given object. If you want to make #' \code{f_eval} work for your own objects, you can define a method for this #' generic. #' @param x An object for which you want to find associated data. #' @export #' @examples #' f_eval(~ 1 + 2 + 3) #' #' # formulas automatically capture their enclosing environment #' foo <- function(x) { #' y <- 10 #' ~ x + y #' } #' f <- foo(1) #' f #' f_eval(f) #' #' # If you supply data, f_eval will look their first: #' f_eval(~ cyl, mtcars) #' #' # To avoid ambiguity, you can use .env and .data pronouns to be #' # explicit: #' cyl <- 10 #' f_eval(~ .data$cyl, mtcars) #' f_eval(~ .env$cyl, mtcars) #' #' # Imagine you are computing the mean of a variable: #' f_eval(~ mean(cyl), mtcars) #' # How can you change the variable that's being computed? #' # The easiest way is "unquote" with uq() #' # See ?f_interp for more details #' var <- ~ cyl #' f_eval(~ mean( uq(var) ), mtcars) f_eval <- f_eval_rhs eval_expr <- function(expr, env, data) { data <- find_data(data) expr_env <- new.env(parent = env) expr_env$.env <- complain(env, "Object '%s' not found in environment") expr_env$.data <- complain(data, "Variable '%s' not found in data") eval(expr, data, expr_env) } #' @rdname f_eval #' @export find_data <- function(x) UseMethod("find_data") #' @export find_data.NULL <- function(x) list() #' @export find_data.list <- function(x) x #' @export find_data.data.frame <- function(x) x #' @export find_data.default <- function(x) { stop("Do not know how to find data associated with `x`", call. = FALSE) } lazyeval/R/formula.R0000644000176200001440000000677113171753463014117 0ustar liggesusers#' Create a formula object by "hand". #' #' @param lhs,rhs A call, name, or atomic vector. #' @param env An environment #' @return A formula object #' @export #' @examples #' f_new(quote(a)) #' f_new(quote(a), quote(b)) f_new <- function(rhs, lhs = NULL, env = parent.frame()) { if (!is.environment(env)) { stop("`env` must be an environment", call. = FALSE) } if (is.null(lhs)) { f <- call_new("~", rhs) } else { f <- call_new("~", lhs, rhs) } structure( f, class = "formula", .Environment = env ) } #' Is object a formula? #' #' @param x Object to test #' @export #' @examples #' is_formula(~ 10) #' is_formula(10) is_formula <- function(x) { typeof(x) == "language" && inherits(x, "formula") } #' Get/set formula components. #' #' \code{f_rhs} extracts the righthand side, \code{f_lhs} extracts the #' lefthand side, and \code{f_env} extracts the environment. All functions #' throw an error if \code{f} is not a formula. #' #' @param f,x A formula #' @param value The value to replace with. #' @export #' @return \code{f_rhs} and \code{f_lhs} return language objects (i.e. #' atomic vectors of length 1, a name, or a call). \code{f_env} #' returns an environment. #' @examples #' f_rhs(~ 1 + 2 + 3) #' f_rhs(~ x) #' f_rhs(~ "A") #' f_rhs(1 ~ 2) #' #' f_lhs(~ y) #' f_lhs(x ~ y) #' #' f_env(~ x) f_rhs <- function(f) { .Call(lazyeval_rhs, f) } #' @export #' @rdname f_rhs `f_rhs<-` <- function(x, value) { stopifnot(is_formula(x)) f_new(value, f_lhs(x), f_env(x)) } #' @export #' @rdname f_rhs f_lhs <- function(f) { .Call(lazyeval_lhs, f) } #' @export #' @rdname f_rhs `f_lhs<-` <- function(x, value) { stopifnot(is_formula(x)) f_new(f_rhs(x), value, f_env(x)) } #' @export #' @rdname f_rhs f_env <- function(f) { .Call(lazyeval_env, f) } #' @export #' @rdname f_rhs `f_env<-` <- function(x, value) { stopifnot(is_formula(x)) f_new(f_rhs(x), f_lhs(x), value) } #' Turn RHS of formula into a string/label. #' #' Equivalent of \code{\link{expr_text}()} and \code{\link{expr_label}()} for #' formulas. #' #' @param x A formula. #' @inheritParams expr_text #' @export #' @examples #' f <- ~ a + b + bc #' f_text(f) #' f_label(f) #' #' # Names a quoted with `` #' f_label(~ x) #' # Strings are encoded #' f_label(~ "a\nb") #' # Long expressions are collapsed #' f_label(~ foo({ #' 1 + 2 #' print(x) #' })) f_text <- function(x, width = 60L, nlines = Inf) { expr_text_(f_rhs(x), width = width, nlines = nlines) } #' @export #' @rdname f_text f_label <- function(x) { expr_label_(f_rhs(x)) } #' Unwrap a formula #' #' This interpolates values in the formula that are defined in its environment, #' replacing the environment with its parent. #' #' @export #' @param f A formula to unwrap. #' @examples #' n <- 100 #' f <- ~ x + n #' f_unwrap(f) f_unwrap <- function(f) { stopifnot(is_formula(f)) e <- environment(f) if (identical(e, emptyenv())) { f } else { f_new(substitute_(f_rhs(f), e), f_lhs(f), parent.env(e)) } } #' Build a named list from the LHS of formulas #' #' \code{f_list} makes a new list; \code{as_f_list} takes an existing list. #' Both take the LHS of any two-sided formulas and evaluate it, replacing the #' current name with the result. #' #' @param ... Named arguments. #' @param x An existing list #' @return A named list. #' @export #' @examples #' f_list("y" ~ x) #' f_list(a = "y" ~ a, ~ b, c = ~c) f_list <- function(...) { .Call(lazyeval_lhs_name, list(...)) } #' @export #' @rdname f_list as_f_list <- function(x) { .Call(lazyeval_lhs_name, x) } lazyeval/R/lazy-interp.R0000644000176200001440000000515212726271770014721 0ustar liggesusers#' Interpolate values into an expression. #' #' This is useful if you want to build an expression up from a mixture of #' constants and variables. #' #' @param _obj An object to modify: can be a call, name, formula, #' \code{\link{lazy}}, or a string. #' @param ...,.values Either individual name-value pairs, or a list #' (or environment) of values. #' @export #' @examples #' # Interp works with formulas, lazy objects, quoted calls and strings #' interp(~ x + y, x = 10) #' interp(lazy(x + y), x = 10) #' interp(quote(x + y), x = 10) #' interp("x + y", x = 10) #' #' # Use as.name if you have a character string that gives a #' # variable name #' interp(~ mean(var), var = as.name("mpg")) #' # or supply the quoted name directly #' interp(~ mean(var), var = quote(mpg)) #' #' # Or a function! #' interp(~ f(a, b), f = as.name("+")) #' # Remember every action in R is a function call: #' # http://adv-r.had.co.nz/Functions.html#all-calls #' #' # If you've built up a list of values through some other #' # mechanism, use .values #' interp(~ x + y, .values = list(x = 10)) #' #' # You can also interpolate variables defined in the current #' # environment, but this is a little risky. #' y <- 10 #' interp(~ x + y, .values = environment()) interp <- function(`_obj`, ..., .values) { UseMethod("interp") } #' @export interp.call <- function(`_obj`, ..., .values) { values <- all_values(.values, ...) substitute_(`_obj`, values) } #' @export interp.name <- function(`_obj`, ..., .values) { values <- all_values(.values, ...) substitute_(`_obj`, values) } #' @export interp.formula <- function(`_obj`, ..., .values) { if (length(`_obj`) != 2) stop("Must use one-sided formula.", call. = FALSE) values <- all_values(.values, ...) `_obj`[[2]] <- substitute_(`_obj`[[2]], values) `_obj` } #' @export interp.lazy <- function(`_obj`, ..., .values) { values <- all_values(.values, ...) `_obj`$expr <- substitute_(`_obj`$expr, values) `_obj` } #' @export interp.character <- function(`_obj`, ..., .values) { values <- all_values(.values, ...) expr1 <- parse(text = `_obj`)[[1]] expr2 <- substitute_(expr1, values) paste(deparse(expr2), collapse = "\n") } all_values <- function(.values, ...) { if (missing(.values)) { values <- list(...) } else if (identical(.values, globalenv())) { # substitute doesn't want to replace in globalenv values <- as.list(globalenv()) } else { values <- .values } if (is.list(values)) { # Replace lazy objects with their expressions is_lazy <- vapply(values, is.lazy, logical(1)) values[is_lazy] <- lapply(values[is_lazy], `[[`, "expr") } values } lazyeval/R/language.R0000644000176200001440000000446513004065022014211 0ustar liggesusers#' Is an object a language object? #' #' These helpers are consistent wrappers around their base R equivalents. #' A language object is either an atomic vector (typically a scalar), a #' name (aka a symbol), a call, or a pairlist (used for function arguments). #' #' @param x An object to test. #' @seealso \code{\link{as_name}()} and \code{\link{as_call}()} for coercion #' functions. #' @export #' @examples #' q1 <- quote(1) #' is_lang(q1) #' is_atomic(q1) #' #' q2 <- quote(x) #' is_lang(q2) #' is_name(q2) #' #' q3 <- quote(x + 1) #' is_lang(q3) #' is_call(q3) is_lang <- function(x) { is_call(x) || is_pairlist(x) || is_atomic(x) || is_name(x) || is.null(x) } #' @rdname is_lang #' @export is_name <- function(x) { typeof(x) == "symbol" } #' @rdname is_lang #' @export is_call <- function(x) { typeof(x) == "language" } #' @rdname is_lang #' @export is_pairlist <- function(x) { typeof(x) == "pairlist" } #' @rdname is_lang #' @export is_atomic <- function(x) { typeof(x) %in% c("logical", "integer", "double", "complex", "character", "raw") } #' Coerce an object to a name or call. #' #' These are a S3 generics with built-in methods for names, calls, formuals, #' and strings. The distinction between a name and a call is particularly #' important when coercing from a string. Coercing to a call will parse the #' string, coercing to a name will create a (potentially) non-syntactic name. #' #' @param x An object to coerce #' @export #' @examples #' as_name("x + y") #' as_call("x + y") #' #' as_call(~ f) #' as_name(~ f()) as_name <- function(x) UseMethod("as_name") #' @export as_name.name <- function(x) x #' @export as_name.character <- function(x) { if (length(x) > 1) { stop("Can not coerce character vector of length > 1 to name", call. = FALSE) } as.name(x) } #' @export as_name.call <- function(x) x[[1]] #' @export as_name.formula <- function(x) { as_name(f_rhs(x)) } #' @export #' @rdname as_name as_call <- function(x) { UseMethod("as_call") } #' @export as_call.name <- function(x) { call_new(x) } #' @export as_call.call <- function(x) { x } #' @export as_call.character <- function(x) { if (length(x) > 1) { stop("Can not coerce character vector of length > 1 to name", call. = FALSE) } parse(text = x)[[1]] } #' @export as_call.formula <- function(x) { as_call(f_rhs(x)) } lazyeval/R/lazy-names.R0000644000176200001440000000212612726271770014521 0ustar liggesusers#' Automatically name all components of a lazy dots. #' #' Any components missing a name will automatically get a name added by #' looking at the first \code{max_width} characters of the deparsed expression. #' #' @param x A \code{\link{lazy_dots}} #' @param max_width Maximum number of characters to use #' @keywords internal #' @export #' @examples #' x <- lazy_dots(1 + 2, mean(mpg)) #' auto_name(x) #' #' auto_name(list(~f, quote(x))) auto_name <- function(x, max_width = 40) { names(x) <- auto_names(x, max_width = max_width) x } auto_names <- function(x, max_width = 40) { x <- as.lazy_dots(x) nms <- names(x) %||% rep("", length(x)) missing <- nms == "" expr <- lapply(x[missing], `[[`, "expr") nms[missing] <- vapply(expr, deparse_trunc, width = max_width, FUN.VALUE = character(1), USE.NAMES = FALSE) nms } deparse_trunc <- function(x, width = getOption("width")) { if (is.symbol(x)) { return(as.character(x)) } text <- deparse(x, width.cutoff = width) if (length(text) == 1 && nchar(text) < width) return(text) paste0(substr(text[1], 1, width - 3), "...") } lazyeval/R/call.R0000644000176200001440000000410213011153647013336 0ustar liggesusers#' Create a call by "hand" #' #' @param f Function to call. For \code{make_call}, either a string, a symbol #' or a quoted call. For \code{do_call}, a bare function name or call. #' @param ...,.args Arguments to the call either in or out of a list #' @export #' @examples #' # f can either be a string, a symbol or a call #' call_new("f", a = 1) #' call_new(quote(f), a = 1) #' call_new(quote(f()), a = 1) #' #' #' Can supply arguments individually or in a list #' call_new(quote(f), a = 1, b = 2) #' call_new(quote(f), .args = list(a = 1, b = 2)) call_new <- function(f, ..., .args = list()) { if (is.character(f)) { if (length(f) != 1) { stop("Character `f` must be length 1", call. = FALSE) } f <- as.name(f) } args <- c(list(...), as.list(.args)) as.call(c(f, args)) } #' Modify the arguments of a call. #' #' @param call A call to modify. It is first standardised with #' \code{\link{call_standardise}}. #' @param env Environment in which to look up call value. #' @param new_args A named list of expressions (constants, names or calls) #' used to modify the call. Use \code{NULL} to remove arguments. #' @export #' @examples #' call <- quote(mean(x, na.rm = TRUE)) #' call_standardise(call) #' #' # Modify an existing argument #' call_modify(call, list(na.rm = FALSE)) #' call_modify(call, list(x = quote(y))) #' #' # Remove an argument #' call_modify(call, list(na.rm = NULL)) #' #' # Add a new argument #' call_modify(call, list(trim = 0.1)) #' #' # Add an explicit missing argument #' call_modify(call, list(na.rm = quote(expr = ))) call_modify <- function(call, new_args, env = parent.frame()) { stopifnot(is.call(call), is.list(new_args)) call <- call_standardise(call, env) if (!all(has_names(new_args))) { stop("All new arguments must be named", call. = FALSE) } for (nm in names(new_args)) { call[[nm]] <- new_args[[nm]] } call } #' @rdname call_modify #' @export call_standardise <- function(call, env = parent.frame()) { stopifnot(is_call(call)) f <- eval(call[[1]], env) if (is.primitive(f)) return(call) match.call(f, call) } lazyeval/R/f-interp.R0000644000176200001440000000340715163703150014156 0ustar liggesusers#' Interpolate a formula #' #' Interpolation replaces sub-expressions of the form \code{uq(x)} with #' the evaluated value of \code{x}, and inlines sub-expressions of #' the form \code{uqs(x)}. #' #' @section Theory: #' Formally, \code{f_interp} is a quasiquote function, \code{uq()} is the #' unquote operator, and \code{uqs()} is the unquote splice operator. #' These terms have a rich history in LISP, and live on in modern languages #' like Julia and Racket. #' #' @param f A one-sided formula. #' @param x For \code{uq} and \code{uqf}, a formula. For \code{uqs}, a #' a vector. #' @param data When called from inside \code{f_eval}, this is used to pass on #' the data so that nested formulas are evaluated in the correct environment. #' @export #' @aliases uq uqs #' @examples #' f_interp(x ~ 1 + uq(1 + 2 + 3) + 10) #' #' # Use uqs() if you want to add multiple arguments to a function #' # It must evaluate to a list #' args <- list(1:10, na.rm = TRUE) #' f_interp(~ mean( uqs(args) )) #' #' # You can combine the two #' var <- quote(xyz) #' extra_args <- list(trim = 0.9) #' f_interp(~ mean( uq(var) , uqs(extra_args) )) #' #' foo <- function(n) { #' ~ 1 + uq(n) #' } #' f <- foo(10) #' f #' f_interp(f) f_interp <- function(f, data = NULL) { f_rhs(f) <- .Call(lazyeval_interp_, f_rhs(f), f_env(f), data) f } #' @export #' @rdname f_interp uq <- function(x, data = NULL) { if (is_formula(x)) { if (is.null(data)) { f_rhs(f_interp(x)) } else { f_eval(x, data = data) } } else { x } } #' @export #' @rdname f_interp uqf <- function(x) { if (!is_formula(x)) stop("`x` must be a formula", call. = FALSE) x } #' @export #' @rdname f_interp uqs <- function(x) { if (!is_vector(x)) { stop("`x` must be a vector") } as.pairlist(x) } lazyeval/R/ast.R0000644000176200001440000000445712726271770013241 0ustar liggesusers#' Display a call (or expression) as a tree. #' #' \code{ast_} takes a quoted expression; \code{ast} does the quoting #' for you. #' #' @param x Quoted call, list of calls, or expression to display. #' @param width Display width, defaults to current width as reported by #' \code{getOption("width")}. #' @export #' @examples #' ast(f(x, 1, g(), h(i()))) #' ast(if (TRUE) 3 else 4) #' ast(function(a = 1, b = 2) {a + b + 10}) #' ast(f(x)(y)(z)) #' #' ast_(quote(f(x, 1, g(), h(i())))) #' ast_(quote(if (TRUE) 3 else 4)) #' ast_(expression(1, 2, 3)) ast_ <- function(x, width = getOption("width")) { if (is.expression(x) || is.list(x)) { trees <- vapply(x, tree, character(1), width = width) out <- paste0(trees, collapse = "\n\n") } else { out <- tree(x, width = width) } cat(out, "\n") } #' @rdname ast_ #' @export ast <- function(x) ast_(expr_find(x)) tree <- function(x, level = 1, width = getOption("width"), branch = "\u2517 ") { if (is_atomic(x) && length(x) == 1) { label <- paste0(" ", deparse(x)[1]) children <- NULL } else if (is_name(x)) { x <- as.character(x) if (x == "") { # Special case the missing argument label <- "`MISSING" } else { label <- paste0("`", as.character(x)) } children <- NULL } else if (is_call(x)) { label <- "()" children <- vapply(as.list(x), tree, character(1), level = level + 1, width = width - 3) } else if (is_pairlist(x)) { label <- "[]" branches <- paste("\u2517", format(names(x)), "=") children <- character(length(x)) for (i in seq_along(x)) { children[i] <- tree(x[[i]], level = level + 1, width = width - 3, branch = branches[i]) } } else { # Special case for srcrefs, since they're commonly seen if (inherits(x, "srcref")) { label <- "" } else { label <- paste0("<", typeof(x), ">") } children <- NULL } indent <- paste0(str_dup(" ", level - 1), branch) label <- str_trunc(label, width - 3) if (is.null(children)) { paste0(indent, label) } else { paste0(indent, label, "\n", paste0(children, collapse = "\n")) } } str_trunc <- function(x, width = getOption("width")) { ifelse(nchar(x) <= width, x, paste0(substr(x, 1, width - 3), "...")) } str_dup <- function(x, n) { paste0(rep(x, n), collapse = "") } lazyeval/R/zzz.R0000644000176200001440000000016115163675314013273 0ustar liggesusers.onLoad <- function(libname, pkgname) { loadNamespace("rlang") .Call(r_init_library, asNamespace(pkgname)) } lazyeval/R/lazy-call.R0000644000176200001440000000555512726271770014342 0ustar liggesusers#' Make a call with \code{lazy_dots} as arguments. #' #' In order to exactly replay the original call, the environment must be the #' same for all of the dots. This function circumvents that a little, #' falling back to the \code{\link{baseenv}()} if all environments aren't #' the same. #' #' @param fun Function as symbol or quoted call. #' @param args Arguments to function; must be a \code{lazy_dots} object, #' or something \code{\link{as.lazy_dots}()} can coerce.. #' @return A list: #' \item{env}{The common environment for all elements} #' \item{expr}{The expression} #' @export #' @examples #' make_call(quote(f), lazy_dots(x = 1, 2)) #' make_call(quote(f), list(x = 1, y = ~x)) #' make_call(quote(f), ~x) #' #' # If no known or no common environment, fails back to baseenv() #' make_call(quote(f), quote(x)) make_call <- function(fun, args) { stopifnot(is.call(fun) || is.name(fun)) args <- as.lazy_dots(args) expr <- lapply(args, `[[`, "expr") lazy_( as.call(c(fun, expr)), common_env(args) ) } #' Find common environment in list of lazy objects. #' #' If no common environment is found, will return \code{baseenv()}. #' #' @param dots A list of lazy objects #' @keywords internal #' @export #' @examples #' common_env(lazy_dots(a, b, c)) #' #' f <- function(x) ~x #' common_env(list(f(1))) #' common_env(list(f(1), f(2))) common_env <- function(dots) { if (!is.list(dots)) stop("dots must be a list", call. = FALSE) if (length(dots) == 0) return(baseenv()) dots <- as.lazy_dots(dots) env <- dots[[1]]$env if (length(dots) == 1) return(env) for (i in 2:length(dots)) { if (!identical(env, dots[[i]]$env)) { return(baseenv()) } } env } # ------------------------------------------------------------------------------ #' Evaluate a call with \code{lazy_dots} as argument. #' #' This simulates the original call as closely as possible by creating #' a temporary environment where each \code{lazy} object is bound to #' a promise by \code{\link{delayedAssign}}. #' #' @noRd #' @param env Environment in which to evaluate call. Defaults to #' \code{\link{parent.frame}()}. #' @examples #' make_env <- function(...) list2env(list(...), parent = emptyenv()) #' #' f1 <- as.lazy(quote(a()), make_env(a = function() {message("!"); 1})) #' f2 <- as.lazy(quote(a), make_env(a = 10)) #' args <- as.lazy_dots(list(f1, f2)) #' #' a <- 100 #' eval_call(quote(`+`), args) eval_call <- function(fun, dots, env = parent.frame()) { vars <- paste0("x", seq_along(dots)) names(vars) <- names(dots) # Create environment containing promises env <- new.env(parent = env) for(i in seq_along(dots)) { dot <- dots[[i]] assign_call <- substitute( delayedAssign(vars[i], expr, dot$env, assign.env = env), list(expr = dot$expr) ) eval(assign_call) } args <- lapply(vars, as.symbol) call <- as.call(c(fun, args)) eval(call, env) } lazyeval/R/expr.R0000644000176200001440000000453013171753463013417 0ustar liggesusers#' Find the expression associated with an argument #' #' \code{expr_find()} finds the full expression; \code{expr_text()} turns the #' expression into a single string; \code{expr_label()} formats it nicely for #' use in messages. \code{expr_env()} finds the environment associated with #' the expression. #' #' These functions never force promises, and will work even if a promise has #' previously been forced. #' #' @param x A promise (function argument) #' @export #' @examples #' # Unlike substitute(), expr_find() finds the original expression #' f <- function(x) g(x) #' g <- function(y) h(y) #' h <- function(z) list(substitute(z), expr_find(z)) #' #' f(1 + 2 + 3) #' #' expr_label(10) #' # Names a quoted with `` #' expr_label(x) #' # Strings are encoded #' expr_label("a\nb") #' # Expressions are captured #' expr_label(a + b + c) #' # Long expressions are collapsed #' expr_label(foo({ #' 1 + 2 #' print(x) #' })) expr_label <- function(x) { expr_label_(expr_find(x)) } expr_label_ <- function(x) { if (is.character(x)) { encodeString(x, quote = '"') } else if (is.atomic(x)) { format(x) } else if (is.name(x)) { paste0("`", as.character(x), "`") } else { chr <- deparse(x) if (length(chr) > 1) { dot_call <- call_new(x[[1]], quote(...)) chr <- paste(deparse(dot_call), collapse = "\n") } paste0("`", chr, "`") } } #' @export #' @rdname expr_label #' @param width Width of each line #' @param nlines Maximum number of lines to extract. expr_text <- function(x, width = 60L, nlines = Inf) { expr_text_(expr_find(x), width = width, nlines = nlines) } expr_text_ <- function(x, width = 60L, nlines = Inf) { str <- deparse(x, width.cutoff = width) if (length(str) > nlines) { str <- c(str[seq_len(nlines - 1)], "...") } paste0(str, collapse = "\n") } #' @export #' @rdname expr_label expr_find <- function(x) { .Call(lazyeval_expr_find_, quote(x), environment()) } #' @param default_env If supplied, \code{expr_env} will return this if the #' promise has already been forced. Otherwise it will throw an error. #' @export #' @rdname expr_label expr_env <- function(x, default_env) { env <- .Call(lazyeval_expr_env_, quote(x), environment()) if (is.null(env)) { if (missing(default_env)) { stop("Promise has already been forced") } else { default_env } } else { env } } lazyeval/R/lazy-as.R0000644000176200001440000000541312726271770014023 0ustar liggesusers#' Convert an object to a lazy expression or lazy dots. #' #' @param x An R object. Current methods for \code{as.lazy()} convert formulas, #' character vectors, calls and names. Methods for \code{as.lazy_dots()} #' convert lists and character vectors (by calling \code{\link{lapply}()} #' with \code{as.lazy()}.) #' @param env Environment to use for objects that don't already have #' associated environment. #' @export #' @examples #' as.lazy(~ x + 1) #' as.lazy(quote(x + 1), globalenv()) #' as.lazy("x + 1", globalenv()) #' #' as.lazy_dots(list(~x, y = ~z + 1)) #' as.lazy_dots(c("a", "b", "c"), globalenv()) #' as.lazy_dots(~x) #' as.lazy_dots(quote(x), globalenv()) #' as.lazy_dots(quote(f()), globalenv()) #' as.lazy_dots(lazy(x)) as.lazy <- function(x, env = baseenv()) UseMethod("as.lazy") #' @export as.lazy.lazy <- function(x, env = baseenv()) x #' @export as.lazy.formula <- function(x, env = baseenv()) lazy_(x[[2]], environment(x)) #' @export as.lazy.character <- function(x, env = baseenv()) lazy_(parse(text = x)[[1]], env) #' @export as.lazy.call <- function(x, env = baseenv()) lazy_(x, env) #' @export as.lazy.name <- function(x, env = baseenv()) lazy_(x, env) #' @export as.lazy.numeric <- function(x, env = baseenv()) { if (length(x) > 1) { warning("Truncating vector to length 1", call. = FALSE) x <- x[1] } lazy_(x, env) } #' @export as.lazy.logical <- as.lazy.numeric #' @export #' @rdname as.lazy as.lazy_dots <- function(x, env) UseMethod("as.lazy_dots") #' @export as.lazy_dots.NULL <- function(x, env = baseenv()) { structure(list(), class = "lazy_dots") } #' @export as.lazy_dots.list <- function(x, env = baseenv()) { structure(lapply(x, as.lazy, env = env), class = "lazy_dots") } #' @export as.lazy_dots.name <- function(x, env = baseenv()) { structure(list(as.lazy(x, env)), class = "lazy_dots") } #' @export as.lazy_dots.formula <- as.lazy_dots.name #' @export as.lazy_dots.call <- as.lazy_dots.name #' @export as.lazy_dots.lazy <- function(x, env = baseenv()) { structure(list(x), class = "lazy_dots") } #' @export as.lazy_dots.character <- function(x, env = baseenv()) { structure(lapply(x, as.lazy, env = env), class = "lazy_dots") } #' @export as.lazy_dots.lazy_dots <- function(x, env = baseenv()) { x } #' Combine explicit and implicit dots. #' #' @param ... Individual lazy objects #' @param .dots A list of lazy objects #' @param all_named If \code{TRUE}, uses \code{\link{auto_name}} to ensure #' every component has a name. #' @return A \code{\link{lazy_dots}} #' @keywords internal #' @export all_dots <- function(.dots, ..., all_named = FALSE) { dots <- as.lazy_dots(list(...)) if (!missing(.dots)) { dots2 <- as.lazy_dots(.dots) dots <- c(dots, dots2) } if (all_named) { dots <- auto_name(dots) } dots } lazyeval/R/utils.R0000644000176200001440000000130313046425567013576 0ustar liggesusers"%||%" <- function(x, y) if(is.null(x)) y else x is_atomic <- function(x) { typeof(x) %in% c("logical", "integer", "double", "complex", "character", "raw") } is_vector <- function(x) { is_atomic(x) || is.list(x) } has_names <- function(x) { nms <- names(x) if (is.null(nms)) { rep(FALSE, length(x)) } else { !(is.na(nms) | nms == "") } } substitute_ <- function(x, env) { if (identical(env, globalenv())) { env <- as.list(env) } call <- substitute(substitute(x, env), list(x = x)) eval(call) } #' Generate a missing argument. #' #' @export #' @examples #' f_interp(~f(x = uq(missing_arg()))) #' f_interp(~f(x = uq(NULL))) missing_arg <- function() { quote(expr = ) } lazyeval/R/complain.R0000644000176200001440000000170113004065015014220 0ustar liggesuserscomplain <- function(x, message = "object '%s' not found") { if (is.null(x)) { return(NULL) } if (is.environment(x)) { x <- clone_env(x) } structure(x, message = message, class = c("complain", class(x))) } clone_env <- function(x) { list2env(as.list(x, all.names = TRUE), parent = parent.env(x)) } #' @export `$.complain` <- function(x, name) { if (!has_name(x, name)) { stop(sprintf(attr(x, "message"), name), call. = FALSE) } x[[name]] } #' @export `[[.complain` <- function(x, i, ...) { if (!is.character(i) || length(i) != 1) { stop("Must subset with a string", call. = FALSE) } if (!has_name(x, i)) { stop(sprintf(attr(x, "message"), i), call. = FALSE) } NextMethod() } has_name <- function(x, name) { UseMethod("has_name") } #' @export has_name.default <- function(x, name) { name %in% names(x) } #' @export has_name.environment <- function(x, name) { exists(name, envir = x, inherits = FALSE) } lazyeval/R/lazy.R0000644000176200001440000000407113171753463013420 0ustar liggesusers#' Capture expression for later lazy evaluation. #' #' \code{lazy()} uses non-standard evaluation to turn promises into lazy #' objects; \code{lazy_()} does standard evaluation and is suitable for #' programming. #' #' Use \code{lazy()} like you'd use \code{\link{substitute}()} #' to capture an unevaluated promise. Compared to \code{substitute()} it #' also captures the environment associated with the promise, so that you #' can correctly replay it in the future. #' #' @param expr Expression to capture. For \code{lazy_} must be a name #' or a call. #' @param env Environment in which to evaluate expr. #' @param .follow_symbols If \code{TRUE}, the default, follows promises across #' function calls. See \code{vignette("chained-promises")} for details. #' @export #' @examples #' lazy_(quote(a + x), globalenv()) #' #' # Lazy is designed to be used inside a function - you should #' # give it the name of a function argument (a promise) #' f <- function(x = b - a) { #' lazy(x) #' } #' f() #' f(a + b / c) #' #' # Lazy also works when called from the global environment. This makes #' # easy to play with interactively. #' lazy(a + b / c) #' #' # By default, lazy will climb all the way back to the initial promise #' # This is handy if you have if you have nested functions: #' g <- function(y) f(y) #' h <- function(z) g(z) #' f(a + b) #' g(a + b) #' h(a + b) #' #' # To avoid this behavour, set .follow_symbols = FALSE #' # See vignette("chained-promises") for details lazy_ <- function(expr, env) { stopifnot(is.call(expr) || is.name(expr) || is.atomic(expr)) structure(list(expr = expr, env = env), class = "lazy") } #' @rdname lazy_ #' @export lazy <- function(expr, env = parent.frame(), .follow_symbols = TRUE) { .Call(lazyeval_make_lazy, quote(expr), environment(), .follow_symbols) } is.lazy <- function(x) inherits(x, "lazy") #' @export print.lazy <- function(x, ...) { code <- deparse(x$expr) if (length(code) > 1) { code <- paste(code[[1]], "...") } cat("\n") cat(" expr: ", code, "\n", sep = "") cat(" env: ", format(x$env), "\n", sep = "") } lazyeval/R/function.R0000644000176200001440000000237712726271770014276 0ustar liggesusers#' Create a function by "hand" #' #' This constructs a new function given it's three components: #' list of arguments, body code and parent environment. #' #' @param args A named list of default arguments. Note that if you want #' arguments that don't have defaults, you'll need to use the special function #' \code{\link{alist}}, e.g. \code{alist(a = , b = 1)} #' @param body A language object representing the code inside the function. #' Usually this will be most easily generated with \code{\link{quote}} #' @param env The parent environment of the function, defaults to the calling #' environment of \code{make_function} #' @export #' @examples #' f <- function(x) x + 3 #' g <- function_new(alist(x = ), quote(x + 3)) #' #' # The components of the functions are identical #' identical(formals(f), formals(g)) #' identical(body(f), body(g)) #' identical(environment(f), environment(g)) #' #' # But the functions are not identical because f has src code reference #' identical(f, g) #' #' attr(f, "srcref") <- NULL #' # Now they are: #' stopifnot(identical(f, g)) function_new <- function(args, body, env = parent.frame()) { stopifnot(all(has_names(args)), is_lang(body), is.environment(env)) args <- as.pairlist(args) eval(call("function", args, body), env) } lazyeval/R/f-capture.R0000644000176200001440000000232213171753463014324 0ustar liggesusers#' Make a promise explicit by converting into a formula. #' #' This should be used sparingly if you want to implement true non-standard #' evaluation with 100\% magic. I recommend avoiding this unless you have #' strong reasons otherwise since requiring arguments to be formulas only #' adds one extra character to the inputs, and otherwise makes life much much #' simpler. #' #' @param x,... An unevaluated promises #' @param .ignore_empty If \code{TRUE}, empty arguments will be silently #' dropped. #' @export #' @return \code{f_capture} returns a formula; \code{dots_capture} #' returns a list of formulas. #' @examples #' f_capture(a + b) #' dots_capture(a + b, c + d, e + f) #' #' # These functions will follow a chain of promises back to the #' # original definition #' f <- function(x) g(x) #' g <- function(y) h(y) #' h <- function(z) f_capture(z) #' f(a + b + c) f_capture <- function(x) { lazy <- .Call(lazyeval_make_lazy, quote(x), environment(), TRUE) f_new(lazy$expr, env = lazy$env) } #' @export #' @rdname f_capture dots_capture <- function(..., .ignore_empty = TRUE) { lazies <- .Call(lazyeval_make_lazy_dots, environment(), TRUE, .ignore_empty) lapply(lazies, function(x) f_new(x$expr, env = x$env)) } lazyeval/R/lazy-dots.R0000644000176200001440000000275213171753463014373 0ustar liggesusers#' Capture ... (dots) for later lazy evaluation. #' #' @param ... Dots from another function #' @param .ignore_empty If \code{TRUE}, empty arguments will be ignored. #' @return A named list of \code{\link{lazy}} expressions. #' @inheritParams lazy #' @export #' @examples #' lazy_dots(x = 1) #' lazy_dots(a, b, c * 4) #' #' f <- function(x = a + b, ...) { #' lazy_dots(x = x, y = a + b, ...) #' } #' f(z = a + b) #' f(z = a + b, .follow_symbols = TRUE) #' #' # .follow_symbols is off by default because it causes problems #' # with lazy loaded objects #' lazy_dots(letters) #' lazy_dots(letters, .follow_symbols = TRUE) #' #' # You can also modify a dots like a list. Anything on the RHS will #' # be coerced to a lazy. #' l <- lazy_dots(x = 1) #' l$y <- quote(f) #' l[c("y", "x")] #' l["z"] <- list(~g) #' #' c(lazy_dots(x = 1), lazy_dots(f)) lazy_dots <- function(..., .follow_symbols = FALSE, .ignore_empty = FALSE) { .Call(lazyeval_make_lazy_dots, environment(), .follow_symbols, .ignore_empty) } is.lazy_dots <- function(x) inherits(x, "lazy_dots") #' @export `[.lazy_dots` <- function(x, i) { structure(NextMethod(), class = "lazy_dots") } #' @export `$<-.lazy_dots` <- function(x, i, value) { value <- as.lazy(value, parent.frame()) x[[i]] <- value x } #' @export `[<-.lazy_dots` <- function(x, i, value) { value <- lapply(value, as.lazy, env = parent.frame()) NextMethod() } #' @export c.lazy_dots <- function(..., recursive = FALSE) { structure(NextMethod(), class = "lazy_dots") } lazyeval/R/lazyeval.R0000644000176200001440000000006213171753463014264 0ustar liggesusers#' @useDynLib lazyeval, .registration = TRUE NULL lazyeval/R/lazy-eval.R0000644000176200001440000000131512726271770014344 0ustar liggesusers#' Evaluate a lazy expression. #' #' @param x A lazy object or a formula. #' @param data Option, a data frame or list in which to preferentially look #' for variables before using the environment associated with the lazy #' object. #' @export #' @examples #' f <- function(x) { #' z <- 100 #' ~ x + z #' } #' z <- 10 #' lazy_eval(f(10)) #' lazy_eval(f(10), list(x = 100)) #' lazy_eval(f(10), list(x = 1, z = 1)) #' #' lazy_eval(lazy_dots(a = x, b = z), list(x = 10)) lazy_eval <- function(x, data = NULL) { if (is.lazy_dots(x)) { return(lapply(x, lazy_eval, data = data)) } x <- as.lazy(x) if (!is.null(data)) { eval(x$expr, data, x$env) } else { eval(x$expr, x$env, emptyenv()) } } lazyeval/vignettes/0000755000176200001440000000000015163705077014124 5ustar liggesuserslazyeval/vignettes/lazyeval-old.Rmd0000644000176200001440000001337713171350764017202 0ustar liggesusers--- title: "Lazyeval: a new approach to NSE" date: "`r Sys.Date()`" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Lazyeval: a new approach to NSE} %\VignetteEngine{knitr::rmarkdown} %\usepackage[utf8]{inputenc} --- ```{r, echo = FALSE} knitr::opts_chunk$set(collapse = TRUE, comment = "#>") rownames(mtcars) <- NULL ``` This document outlines my previous approach to non-standard evaluation (NSE). You should avoid it unless you are working with an older version of dplyr or tidyr. There are three key ideas: * Instead of using `substitute()`, use `lazyeval::lazy()` to capture both expression and environment. (Or use `lazyeval::lazy_dots(...)` to capture promises in `...`) * Every function that uses NSE should have a standard evaluation (SE) escape hatch that does the actual computation. The SE-function name should end with `_`. * The SE-function has a flexible input specification to make it easy for people to program with. ## `lazy()` The key tool that makes this approach possible is `lazy()`, an equivalent to `substitute()` that captures both expression and environment associated with a function argument: ```{r} library(lazyeval) f <- function(x = a - b) { lazy(x) } f() f(a + b) ``` As a complement to `eval()`, the lazy package provides `lazy_eval()` that uses the environment associated with the lazy object: ```{r} a <- 10 b <- 1 lazy_eval(f()) lazy_eval(f(a + b)) ``` The second argument to lazy eval is a list or data frame where names should be looked up first: ```{r} lazy_eval(f(), list(a = 1)) ``` `lazy_eval()` also works with formulas, since they contain the same information as a lazy object: an expression (only the RHS is used by convention) and an environment: ```{r} lazy_eval(~ a + b) h <- function(i) { ~ 10 + i } lazy_eval(h(1)) ``` ## Standard evaluation Whenever we need a function that does non-standard evaluation, always write the standard evaluation version first. For example, let's implement our own version of `subset()`: ```{r} subset2_ <- function(df, condition) { r <- lazy_eval(condition, df) r <- r & !is.na(r) df[r, , drop = FALSE] } subset2_(mtcars, lazy(mpg > 31)) ``` `lazy_eval()` will always coerce it's first argument into a lazy object, so a variety of specifications will work: ```{r} subset2_(mtcars, ~mpg > 31) subset2_(mtcars, quote(mpg > 31)) subset2_(mtcars, "mpg > 31") ``` Note that quoted called and strings don't have environments associated with them, so `as.lazy()` defaults to using `baseenv()`. This will work if the expression is self-contained (i.e. doesn't contain any references to variables in the local environment), and will otherwise fail quickly and robustly. ## Non-standard evaluation With the SE version in hand, writing the NSE version is easy. We just use `lazy()` to capture the unevaluated expression and corresponding environment: ```{r} subset2 <- function(df, condition) { subset2_(df, lazy(condition)) } subset2(mtcars, mpg > 31) ``` This standard evaluation escape hatch is very important because it allows us to implement different NSE approaches. For example, we could create a subsetting function that finds all rows where a variable is above a threshold: ```{r} above_threshold <- function(df, var, threshold) { cond <- interp(~ var > x, var = lazy(var), x = threshold) subset2_(df, cond) } above_threshold(mtcars, mpg, 31) ``` Here we're using `interp()` to modify a formula. We use the value of `threshold` and the expression in by `var`. ## Scoping Because `lazy()` captures the environment associated with the function argument, we automatically avoid a subtle scoping bug present in `subset()`: ```{r} x <- 31 f1 <- function(...) { x <- 30 subset(mtcars, ...) } # Uses 30 instead of 31 f1(mpg > x) f2 <- function(...) { x <- 30 subset2(mtcars, ...) } # Correctly uses 31 f2(mpg > x) ``` `lazy()` has another advantage over `substitute()` - by default, it follows promises across function invocations. This simplifies the casual use of NSE. ```{r, eval = FALSE} x <- 31 g1 <- function(comp) { x <- 30 subset(mtcars, comp) } g1(mpg > x) #> Error: object 'mpg' not found ``` ```{r} g2 <- function(comp) { x <- 30 subset2(mtcars, comp) } g2(mpg > x) ``` Note that `g2()` doesn't have a standard-evaluation escape hatch, so it's not suitable for programming with in the same way that `subset2_()` is. ## Chained promises Take the following example: ```{r} library(lazyeval) f1 <- function(x) lazy(x) g1 <- function(y) f1(y) g1(a + b) ``` `lazy()` returns `a + b` because it always tries to find the top-level promise. In this case the process looks like this: 1. Find the object that `x` is bound to. 2. It's a promise, so find the expr it's bound to (`y`, a symbol) and the environment in which it should be evaluated (the environment of `g()`). 3. Since `x` is bound to a symbol, look up its value: it's bound to a promise. 4. That promise has expression `a + b` and should be evaluated in the global environment. 5. The expression is not a symbol, so stop. Occasionally, you want to avoid this recursive behaviour, so you can use `follow_symbol = FALSE`: ```{r} f2 <- function(x) lazy(x, .follow_symbols = FALSE) g2 <- function(y) f2(y) g2(a + b) ``` Either way, if you evaluate the lazy expression you'll get the same result: ```{r} a <- 10 b <- 1 lazy_eval(g1(a + b)) lazy_eval(g2(a + b)) ``` Note that the resolution of chained promises only works with unevaluated objects. This is because R deletes the information about the environment associated with a promise when it has been forced, so that the garbage collector is allowed to remove the environment from memory in case it is no longer used. `lazy()` will fail with an error in such situations. ```{r, error = TRUE, purl = FALSE} var <- 0 f3 <- function(x) { force(x) lazy(x) } f3(var) ``` lazyeval/vignettes/lazyeval.Rmd0000644000176200001440000005075515163703150016421 0ustar liggesusers--- title: "Non-standard evaluation" author: "Hadley Wickham" date: "`r Sys.Date()`" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Non-standard evaluation} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- ```{r, include = FALSE} library(lazyeval) knitr::opts_chunk$set(collapse = TRUE, comment = "#>") ``` This document describes lazyeval, a package that provides principled tools to perform non-standard evaluation (NSE) in R. You should read this vignette if you want to program with packages like dplyr and ggplot2[^1], or you want a principled way of working with delayed expressions in your own package. As the name suggests, non-standard evaluation breaks away from the standard evaluation (SE) rules in order to do something special. There are three common uses of NSE: 1. __Labelling__ enhances plots and tables by using the expressions supplied to a function, rather than their values. For example, note the axis labels in this plot: ```{r, fig.width = 4, fig.height = 2.5} par(mar = c(4.5, 4.5, 1, 0.5)) grid <- seq(0, 2 * pi, length = 100) plot(grid, sin(grid), type = "l") ``` 1. __Non-standard scoping__ looks for objects in places other than the current environment. For example, base R has `with()`, `subset()`, and `transform()` that look for objects in a data frame (or list) before the current environment: ```{r} df <- data.frame(x = c(1, 5, 4, 2, 3), y = c(2, 1, 5, 4, 3)) with(df, mean(x)) subset(df, x == y) transform(df, z = x + y) ``` 1. __Metaprogramming__ is a catch-all term that covers all other uses of NSE (such as in `bquote()` and `library()`). Metaprogramming is so called because it involves computing on the unevaluated code in some way. This document is broadly organised according to the three types of non-standard evaluation described above. The main difference is that after [labelling], we'll take a detour to learn more about [formulas]. You're probably familiar with formulas from linear models (e.g. `lm(mpg ~ displ, data = mtcars)`) but formulas are more than just a tool for modelling: they are a general way of capturing an unevaluated expression. The approaches recommended here are quite different to my previous generation of recommendations. I am fairly confident these new approaches are correct, and will not have to change substantially again. The current tools make it easy to solve a number of practical problems that were previously challenging and are rooted in long-standing theory. [^1]: Currently neither ggplot2 nor dplyr actually use these tools since I've only just figured it out. But I'll be working hard to make sure all my packages are consistent in the near future. ## Labelling In base R, the classic way to turn an argument into a label is to use `deparse(substitute(x))`: ```{r} my_label <- function(x) deparse(substitute(x)) my_label(x + y) ``` There are two potential problems with this approach: 1. For long some expressions, `deparse()` generates a character vector with length > 1: ```{r} my_label({ a + b c + d }) ``` 1. `substitute()` only looks one level up, so you lose the original label if the function isn't called directly: ```{r} my_label2 <- function(x) my_label(x) my_label2(a + b) ``` Both of these problems are resolved by `lazyeval::expr_text()`: ```{r} my_label <- function(x) expr_text(x) my_label2 <- function(x) my_label(x) my_label({ a + b c + d }) my_label2(a + b) ``` There are two variations on the theme of `expr_text()`: * `expr_find()` find the underlying expression. It works similarly to `substitute()` but will follow a chain of promises back up to the original expression. This is often useful for [metaprogramming]. * `expr_label()` is a customised version of `expr_text()` that produces labels designed to be used in messages to the user: ```{r} expr_label(x) expr_label(a + b + c) expr_label(foo({ x + y })) ``` ### Exercises 1. `plot()` uses `deparse(substitute(x))` to generate labels for the x and y axes. Can you generate input that causes it to display bad labels? Write your own wrapper around `plot()` that uses `expr_label()` to compute `xlim` and `ylim`. 1. Create a simple implementation of `mean()` that stops with an informative error message if the argument is not numeric: ```{r, eval = FALSE} x <- c("a", "b", "c") my_mean(x) #> Error: `x` is a not a numeric vector. my_mean(x == "a") #> Error: `x == "a"` is not a numeric vector. my_mean("a") #> Error: "a" is not a numeric vector. ``` 1. Read the source code for `expr_text()`. How does it work? What additional arguments to `deparse()` does it use? ## Formulas Non-standard scoping is probably the most useful NSE tool, but before we can talk about a solid approach, we need to take a detour to talk about formulas. Formulas are a familiar tool from linear models, but their utility is not limited to models. In fact, formulas are a powerful, general purpose tool, because a formula captures two things: 1. An unevaluated expression. 1. The context (environment) in which the expression was created. `~` is a single character that allows you to say: "I want to capture the meaning of this code, without evaluating it right away". For that reason, the formula can be thought of as a "quoting" operator. ### Definition of a formula Technically, a formula is a "language" object (i.e. an unevaluated expression) with a class of "formula" and an attribute that stores the environment: ```{r} f <- ~ x + y + z typeof(f) attributes(f) ``` The structure of the underlying object is slightly different depending on whether you have a one-sided or two-sided formula: * One-sided formulas have length two: ```{r} length(f) # The 1st element is always ~ f[[1]] # The 2nd element is the RHS f[[2]] ``` * Two-sided formulas have length three: ```{r} g <- y ~ x + z length(g) # The 1st element is still ~ g[[1]] # But now the 2nd element is the LHS g[[2]] # And the 3rd element is the RHS g[[3]] ``` To abstract away these differences, lazyeval provides `f_rhs()` and `f_lhs()` to access either side of the formula, and `f_env()` to access its environment: ```{r} f_rhs(f) f_lhs(f) f_env(f) f_rhs(g) f_lhs(g) f_env(g) ``` ### Evaluating a formula A formula captures delays the evaluation of an expression so you can later evaluate it with `f_eval()`: ```{r} f <- ~ 1 + 2 + 3 f f_eval(f) ``` This allows you to use a formula as a robust way of delaying evaluation, cleanly separating the creation of the formula from its evaluation. Because formulas capture the code and context, you get the correct result even when a formula is created and evaluated in different places. In the following example, note that the value of `x` inside `add_1000()` is used: ```{r} x <- 1 add_1000 <- function(x) { ~ 1000 + x } add_1000(3) f_eval(add_1000(3)) ``` It can be hard to see what's going on when looking at a formula because important values are stored in the environment, which is largely opaque. You can use `f_unwrap()` to replace names with their corresponding values: ```{r} f_unwrap(add_1000(3)) ``` ### Non-standard scoping `f_eval()` has an optional second argument: a named list (or data frame) that overrides values found in the formula's environment. ```{r} y <- 100 f_eval(~ y) f_eval(~ y, data = list(y = 10)) # Can mix variables in environment and data argument f_eval(~ x + y, data = list(x = 10)) # Can even supply functions f_eval(~ f(y), data = list(f = function(x) x * 3)) ``` This makes it very easy to implement non-standard scoping: ```{r} f_eval(~ mean(cyl), data = mtcars) ``` One challenge with non-standard scoping is that we've introduced some ambiguity. For example, in the code below does `x` come from `mydata` or the environment? ```{r, eval = FALSE} f_eval(~ x, data = mydata) ``` You can't tell without knowing whether or not `mydata` has a variable called `x`. To overcome this problem, `f_eval()` provides two pronouns: * `.data` is bound to the data frame. * `.env` is bound to the formula environment. They both start with `.` to minimise the chances of clashing with existing variables. With these pronouns we can rewrite the previous formula to remove the ambiguity: ```{r} mydata <- data.frame(x = 100, y = 1) x <- 10 f_eval(~ .env$x, data = mydata) f_eval(~ .data$x, data = mydata) ``` If the variable or object doesn't exist, you'll get an informative error: ```{r, error = TRUE} f_eval(~ .env$z, data = mydata) f_eval(~ .data$z, data = mydata) ``` ### Unquoting `f_eval()` has one more useful trick up its sleeve: unquoting. Unquoting allows you to write functions where the user supplies part of the formula. For example, the following function allows you to compute the mean of any column (or any function of a column): ```{r} df_mean <- function(df, variable) { f_eval(~ mean(uq(variable)), data = df) } df_mean(mtcars, ~ cyl) df_mean(mtcars, ~ disp * 0.01638) df_mean(mtcars, ~ sqrt(mpg)) ``` To see how this works, we can use `f_interp()` which `f_eval()` calls internally (you shouldn't call it in your own code, but it's useful for debugging). The key is `uq()`: `uq()` evaluates its first (and only) argument and inserts the value into the formula: ```{r} variable <- ~cyl f_interp(~ mean(uq(variable))) variable <- ~ disp * 0.01638 f_interp(~ mean(uq(variable))) ``` Unquoting allows you to create code "templates", where you write most of the expression, while still allowing the user to control important components. You can even use `uq()` to change the function being called: ```{r} f <- ~ mean f_interp(~ uq(f)(uq(variable))) ``` Note that `uq()` only takes the RHS of a formula, which makes it difficult to insert literal formulas into a call: ```{r} formula <- y ~ x f_interp(~ lm(uq(formula), data = df)) ``` You can instead use `uqf()` which uses the whole formula, not just the RHS: ```{r} f_interp(~ lm(uqf(formula), data = df)) ``` Unquoting is powerful, but it only allows you to modify a single argument: it doesn't allow you to add an arbitrary number of arguments. To do that, you'll need "unquote-splice", or `uqs()`. The first (and only) argument to `uqs()` should be a list of arguments to be spliced into the call: ```{r} variable <- ~ x extra_args <- list(na.rm = TRUE, trim = 0.9) f_interp(~ mean(uq(variable), uqs(extra_args))) ``` ### Exercises 1. Create a wrapper around `lm()` that allows the user to supply the response and predictors as two separate formulas. 1. Compare and contrast `f_eval()` with `with()`. 1. Why does this code work even though `f` is defined in two places? (And one of them is not a function). ```{r} f <- function(x) x + 1 f_eval(~ f(10), list(f = "a")) ``` ## Non-standard scoping Non-standard scoping (NSS) is an important part of R because it makes it easy to write functions tailored for interactive data exploration. These functions require less typing, at the cost of some ambiguity and "magic". This is a good trade-off for interactive data exploration because you want to get ideas out of your head and into the computer as quickly as possible. If a function does make a bad guess, you'll spot it quickly because you're working interactively. There are three challenges to implementing non-standard scoping: 1. You must correctly delay the evaluation of a function argument, capturing both the computation (the expression), and the context (the environment). I recommend making this explicit by requiring the user to "quote" any NSS arguments with `~`, and then evaluating explicit with `f_eval()`. 1. When writing functions that use NSS-functions, you need some way to avoid the automatic lookup and be explicit about where objects should be found. `f_eval()` solves this problem with the `.data.` and `.env` pronouns. 1. You need some way to allow the user to supply parts of a formula. `f_eval()` solves this with unquoting. To illustrate these challenges, I will implement a `sieve()` function that works similarly to `base::subset()` or `dplyr::filter()`. The goal of `sieve()` is to make it easy to select observations that match criteria defined by a logical expression. `sieve()` has three advantages over `[`: 1. It is much more compact when the condition uses many variables, because you don't need to repeat the name of the data frame many times. 1. It drops rows where the condition evaluates to `NA`, rather than filling them with `NA`s. 1. It always returns a data frame. The implementation of `sieve()` is straightforward. First we use `f_eval()` to perform NSS. Then we then check that we have a logical vector, replace `NA`s with `FALSE`, and subset with `[`. ```{R} sieve <- function(df, condition) { rows <- f_eval(condition, df) if (!is.logical(rows)) { stop("`condition` must be logical.", call. = FALSE) } rows[is.na(rows)] <- FALSE df[rows, , drop = FALSE] } df <- data.frame(x = 1:5, y = 5:1) sieve(df, ~ x <= 2) sieve(df, ~ x == y) ``` ### Programming with `sieve()` Imagine that you've written some code that looks like this: ```{r, eval = FALSE} sieve(march, ~ x > 100) sieve(april, ~ x > 50) sieve(june, ~ x > 45) sieve(july, ~ x > 17) ``` (This is a contrived example, but it illustrates all of the important issues you'll need to consider when writing more useful functions.) Instead of continuing to copy-and-paste your code, you decide to wrap up the common behaviour in a function: ```{r} threshold_x <- function(df, threshold) { sieve(df, ~ x > threshold) } threshold_x(df, 3) ``` There are two ways that this function might fail: 1. The data frame might not have a variable called `x`. This will fail unless there's a variable called `x` hanging around in the global environment: ```{r, error = TRUE} rm(x) df2 <- data.frame(y = 5:1) # Throws an error threshold_x(df2, 3) # Silently gives the incorrect result! x <- 5 threshold_x(df2, 3) ``` 1. The data frame might have a variable called `threshold`: ```{r} df3 <- data.frame(x = 1:5, y = 5:1, threshold = 4) threshold_x(df3, 3) ``` These failures are partiuclarly pernicious because instead of throwing an error they silently produce the wrong answer. Both failures arise because `f_eval()` introduces ambiguity by looking in two places for each name: the supplied data and formula environment. To make `threshold_x()` more reliable, we need to be more explicit by using the `.data` and `.env` pronouns: ```{r, error = TRUE} threshold_x <- function(df, threshold) { sieve(df, ~ .data$x > .env$threshold) } threshold_x(df2, 3) threshold_x(df3, 3) ``` Here `.env` is bound to the environment where `~` is evaluated, namely the inside of `threshold_x()`. ### Adding arguments The `threshold_x()` function is not very useful because it's bound to a specific variable. It would be more powerful if we could vary both the threshold and the variable it applies to. We can do that by taking an additional argument to specify which variable to use. One simple approach is to use a string and `[[`: ```{r} threshold <- function(df, variable, threshold) { stopifnot(is.character(variable), length(variable) == 1) sieve(df, ~ .data[[.env$variable]] > .env$threshold) } threshold(df, "x", 4) ``` This is a simple and robust solution, but only allows us to use an existing variable, not an arbitrary expression like `sqrt(x)`. A more general solution is to allow the user to supply a formula, and use unquoting: ```{r} threshold <- function(df, variable = ~x, threshold = 0) { sieve(df, ~ uq(variable) > .env$threshold) } threshold(df, ~ x, 4) threshold(df, ~ abs(x - y), 2) ``` In this case, it's the responsibility of the user to ensure the `variable` is specified unambiguously. `f_eval()` is designed so that `.data` and `.env` work even when evaluated inside of `uq()`: ```{r} x <- 3 threshold(df, ~ .data$x - .env$x, 0) ``` ### Dot-dot-dot There is one more tool that you might find useful for functions that take `...`. For example, the code below implements a function similar to `dplyr::mutate()` or `base::transform()`. ```{r} mogrify <- function(`_df`, ...) { args <- list(...) for (nm in names(args)) { `_df`[[nm]] <- f_eval(args[[nm]], `_df`) } `_df` } ``` (NB: the first argument is a non-syntactic name (i.e. it requires quoting with `` ` ``) so it doesn't accidentally match one of the names of the new variables.) `transmogrifty()` makes it easy to add new variables to a data frame: ```{r} df <- data.frame(x = 1:5, y = sample(5)) mogrify(df, z = ~ x + y, z2 = ~ z * 2) ``` One problem with this implementation is that it's hard to specify the names of the generated variables. Imagine you want a function where the name and expression are in separate variables. This is awkward because the variable name is supplied as an argument name to `mogrify()`: ```{r} add_variable <- function(df, name, expr) { do.call("mogrify", c(list(df), setNames(list(expr), name))) } add_variable(df, "z", ~ x + y) ``` Lazyeval provides the `f_list()` function to make writing this sort of function a little easier. It takes a list of formulas and evaluates the LHS of each formula (if present) to rename the elements: ```{r} f_list("x" ~ y, z = ~z) ``` If we tweak `mogrify()` to use `f_list()` instead of `list()`: ```{r} mogrify <- function(`_df`, ...) { args <- f_list(...) for (nm in names(args)) { `_df`[[nm]] <- f_eval(args[[nm]], `_df`) } `_df` } ``` `add_new()` becomes much simpler: ```{r} add_variable <- function(df, name, expr) { mogrify(df, name ~ uq(expr)) } add_variable(df, "z", ~ x + y) ``` ### Exercises 1. Write a function that selects all rows of `df` where `variable` is greater than its mean. Make the function more general by allowing the user to specify a function to use instead of `mean()` (e.g. `median()`). 1. Create a version of `mogrify()` where the first argument is `x`? What happens if you try to create a new variable called `x`? ## Non-standard evaluation In some situations you might want to eliminate the formula altogether, and allow the user to type expressions directly. I was once much enamoured with this approach (witness ggplot2, dplyr, ...). However, I now think that it should be used sparingly because explict quoting with `~` leads to simpler code, and makes it more clear to the user that something special is going on. That said, lazyeval does allow you to eliminate the `~` if you really want to. In this case, I recommend having both a NSE and SE version of the function. The SE version, which takes formuals, should have suffix `_`: ```{r} sieve_ <- function(df, condition) { rows <- f_eval(condition, df) if (!is.logical(rows)) { stop("`condition` must be logical.", call. = FALSE) } rows[is.na(rows)] <- FALSE df[rows, , drop = FALSE] } ``` Then create the NSE version which doesn't need the explicit formula. The key is the use of `f_capture()` which takes an unevaluated argument (a promise) and captures it as a formula: ```{r} sieve <- function(df, expr) { sieve_(df, f_capture(expr)) } sieve(df, x == 1) ``` If you're familiar with `substitute()` you might expect the same drawbacks to apply. However, `f_capture()` is smart enough to follow a chain of promises back to the original value, so, for example, this code works fine: ```{r} scramble <- function(df) { df[sample(nrow(df)), , drop = FALSE] } subscramble <- function(df, expr) { scramble(sieve(df, expr)) } subscramble(df, x < 4) ``` ### Dot-dot-dot If you want a `...` function that doesn't require formulas, I recommend that the SE version take a list of arguments, and the NSE version uses `dots_capture()` to capture multiple arguments as a list of formulas. ```{r} mogrify_ <- function(`_df`, args) { args <- as_f_list(args) for (nm in names(args)) { `_df`[[nm]] <- f_eval(args[[nm]], `_df`) } `_df` } mogrify <- function(`_df`, ...) { mogrify_(`_df`, dots_capture(...)) } ``` ### Exercises 1. Recreate `subscramble()` using `base::subset()` instead of `sieve()`. Why does it fail? ## Metaprogramming The final use of non-standard evaluation is to do metaprogramming. This is a catch-all term that encompasses any function that does computation on an unevaluated expression. You can learn about metaprogrgramming in , particularly . Over time, the goal is to move all useful metaprogramming helper functions into this package, and discuss metaprogramming more here. lazyeval/src/0000755000176200001440000000000015163705077012703 5ustar liggesuserslazyeval/src/utils.c0000644000176200001440000000366115163675314014215 0ustar liggesusers#define R_NO_REMAP #include #include #include #include bool is_symbol_str(SEXP sym, const char* f) { return !strcmp(CHAR(PRINTNAME(sym)), f); } bool is_call_to(SEXP x, const char* f) { if (!Rf_isLanguage(x)) return false; SEXP fun = CAR(x); if (Rf_isSymbol(fun)) return is_symbol_str(fun, f); else return false; } bool is_lazy_load_binding(SEXP env, SEXP sym) { if (r_env_binding_type(env, sym) != R_ENV_BINDING_TYPE_delayed) return false; return is_call_to(r_env_binding_delayed_expr(env, sym), "lazyLoadDBfetch"); } bool is_forced_lazy_load_binding(SEXP env, SEXP sym) { if (r_env_binding_type(env, sym) != R_ENV_BINDING_TYPE_forced) return false; return is_call_to(r_env_binding_forced_expr(env, sym), "lazyLoadDBfetch"); } SEXP findLast(SEXP x) { SEXP cons = x; while(CDR(cons) != R_NilValue) cons = CDR(cons); return cons; } // Formulas -------------------------------------------------------------------- bool is_formula(SEXP x) { return TYPEOF(x) == LANGSXP && Rf_inherits(x, "formula"); } SEXP rhs(SEXP f) { if (!is_formula(f)) Rf_errorcall(R_NilValue, "`x` is not a formula"); switch (Rf_length(f)) { case 2: return CADR(f); case 3: return CADDR(f); default: Rf_errorcall(R_NilValue, "Invalid formula"); } } SEXP lhs(SEXP f) { if (!is_formula(f)) Rf_errorcall(R_NilValue, "`x` is not a formula"); switch (Rf_length(f)) { case 2: return R_NilValue; case 3: return CADR(f); default: Rf_errorcall(R_NilValue, "Invalid formula"); } } SEXP env(SEXP f) { if (!is_formula(f)) Rf_errorcall(R_NilValue, "`x` is not a formula"); return Rf_getAttrib(f, Rf_install(".Environment")); } SEXP make_formula1(SEXP rhs, SEXP env) { SEXP f = PROTECT(Rf_lang2(Rf_install("~"), rhs)); Rf_setAttrib(f, R_ClassSymbol, Rf_mkString("formula")); Rf_setAttrib(f, Rf_install(".Environment"), env); UNPROTECT(1); return f; } lazyeval/src/name.c0000644000176200001440000000300213171753463013761 0ustar liggesusers#define R_NO_REMAP #include #include #include "utils.h" // Returns a CHARSXP SEXP as_name(SEXP x) { switch(TYPEOF(x)) { case STRSXP: if (Rf_length(x) != 1) Rf_errorcall(R_NilValue, "LHS must evaluate to a single string"); return STRING_ELT(x, 0); case SYMSXP: return PRINTNAME(x); case LANGSXP: if (!is_formula(x) || Rf_length(x) != 2) Rf_errorcall(R_NilValue, "RHS of LHS must be a single-sided formula"); return as_name(rhs(x)); default: Rf_errorcall(R_NilValue, "LHS must evaluate to a string or name"); } } SEXP lhs_name(SEXP x) { if (TYPEOF(x) != VECSXP) Rf_errorcall(R_NilValue, "`x` must be a list (not a %s)", Rf_type2char(TYPEOF(x))); int n = Rf_length(x); SEXP x2 = PROTECT(Rf_shallow_duplicate(x)); SEXP names = Rf_getAttrib(x2, R_NamesSymbol); // Hush rchk false positives PROTECT(names); if (names == R_NilValue) { names = Rf_allocVector(STRSXP, n); Rf_setAttrib(x2, R_NamesSymbol, names); } for (int i = 0; i < n; ++i) { SEXP xi = VECTOR_ELT(x2, i); if (!is_formula(xi) || Rf_length(xi) != 3) continue; // Hush rchk false positives SEXP p_lhs = PROTECT(lhs(xi)); SEXP p_env = PROTECT(env(xi)); // set name SEXP name = PROTECT(Rf_eval(p_lhs, p_env)); if (TYPEOF(name) != NILSXP) SET_STRING_ELT(names, i, as_name(name)); // replace with RHS of formula SET_VECTOR_ELT(x2, i, make_formula1(CADDR(xi), env(xi))); UNPROTECT(3); } UNPROTECT(2); return x2; } lazyeval/src/lazy.c0000644000176200001440000001161515163675314014032 0ustar liggesusers#define R_NO_REMAP #include #include #include "utils.h" static SEXP make_lazy_obj(SEXP expr, SEXP env); static SEXP binding_as_lazy(SEXP sym, SEXP env, int follow_symbols) { while (1) { SEXP where = r_env_until(env, sym, r_envs.empty); if (where == r_envs.empty) { Rf_error("object '%s' not found", CHAR(PRINTNAME(sym))); } switch (r_env_binding_type(where, sym)) { case R_ENV_BINDING_TYPE_unbound: Rf_error("object '%s' not found", CHAR(PRINTNAME(sym))); case R_ENV_BINDING_TYPE_missing: return make_lazy_obj(R_MissingArg, R_EmptyEnv); case R_ENV_BINDING_TYPE_forced: Rf_error("Promise has already been forced"); case R_ENV_BINDING_TYPE_value: case R_ENV_BINDING_TYPE_active: { if (follow_symbols && TYPEOF(sym) == SYMSXP && is_lazy_load_binding(where, sym)) { return make_lazy_obj(sym, env); } SEXP value = PROTECT(r_env_get(where, sym)); SEXP out = make_lazy_obj(value, env); UNPROTECT(1); return out; } case R_ENV_BINDING_TYPE_delayed: { SEXP expr = r_env_binding_delayed_expr(where, sym); SEXP expr_env = r_env_binding_delayed_env(where, sym); if (follow_symbols && TYPEOF(expr) == SYMSXP) { SEXP inner_where = r_env_until(expr_env, expr, r_envs.empty); if (inner_where == r_envs.empty) return make_lazy_obj(expr, expr_env); if (r_env_binding_type(inner_where, expr) == R_ENV_BINDING_TYPE_missing) return make_lazy_obj(expr, expr_env); if (is_lazy_load_binding(inner_where, expr)) return make_lazy_obj(expr, expr_env); sym = expr; env = expr_env; continue; } return make_lazy_obj(expr, expr_env); } } } } static SEXP make_lazy_obj(SEXP expr, SEXP env) { SEXP lazy = PROTECT(Rf_allocVector(VECSXP, 2)); MARK_NOT_MUTABLE(expr); SET_VECTOR_ELT(lazy, 0, expr); SET_VECTOR_ELT(lazy, 1, env); SEXP names = PROTECT(Rf_allocVector(STRSXP, 2)); SET_STRING_ELT(names, 0, Rf_mkChar("expr")); SET_STRING_ELT(names, 1, Rf_mkChar("env")); Rf_setAttrib(lazy, Rf_install("names"), names); Rf_setAttrib(lazy, Rf_install("class"), PROTECT(Rf_mkString("lazy"))); UNPROTECT(3); return lazy; } SEXP make_lazy(SEXP name, SEXP env, SEXP follow_symbols_) { int follow_symbols = Rf_asLogical(follow_symbols_); return binding_as_lazy(name, 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_) { int follow_symbols = Rf_asLogical(follow_symbols_); int ignore_empty = Rf_asLogical(ignore_empty_); env = r_env_until_dots(env); if (env == r_envs.empty) { Rf_error("'...' used in an incorrect context"); } r_ssize n_dots = r_env_dots_length(env); int n = 0; for (r_ssize i = 0; i < n_dots; ++i) { if (ignore_empty && r_env_dot_type(env, i) == DOT_TYPE_missing) continue; ++n; } SEXP lazy_dots = PROTECT(Rf_allocVector(VECSXP, n)); SEXP dot_names = r_env_dots_names(env); SEXP names = PROTECT(Rf_allocVector(STRSXP, n)); for (int i = 0; i < n; ++i) { SET_STRING_ELT(names, i, Rf_mkChar("")); } int j = 0; for (r_ssize i = 0; i < n_dots; ++i) { r_dot_type_t type = r_env_dot_type(env, i); if (ignore_empty && type == DOT_TYPE_missing) continue; SEXP lazy; switch (type) { case DOT_TYPE_missing: lazy = make_lazy_obj(R_MissingArg, R_EmptyEnv); break; case DOT_TYPE_forced: Rf_error("Promise has already been forced"); case DOT_TYPE_value: { SEXP dot = PROTECT(r_env_dot_get(env, i)); lazy = make_lazy_obj(dot, R_EmptyEnv); UNPROTECT(1); break; } case DOT_TYPE_delayed: { SEXP expr = r_env_dot_delayed_expr(env, i); SEXP expr_env = r_env_dot_delayed_env(env, i); if (follow_symbols && TYPEOF(expr) == SYMSXP) { SEXP inner_where = r_env_until(expr_env, expr, r_envs.empty); if (inner_where == r_envs.empty) { lazy = make_lazy_obj(expr, expr_env); } else if (r_env_binding_type(inner_where, expr) == R_ENV_BINDING_TYPE_missing) { lazy = make_lazy_obj(expr, expr_env); } else if (is_lazy_load_binding(inner_where, expr)) { lazy = make_lazy_obj(expr, expr_env); } else { lazy = binding_as_lazy(expr, expr_env, follow_symbols); } } else { lazy = make_lazy_obj(expr, expr_env); } break; } } SET_VECTOR_ELT(lazy_dots, j, lazy); if (dot_names != R_NilValue) { SEXP nm = STRING_ELT(dot_names, i); if (nm != NA_STRING && CHAR(nm)[0] != '\0') SET_STRING_ELT(names, j, nm); } ++j; } if (n > 0) { Rf_setAttrib(lazy_dots, Rf_install("names"), names); } Rf_setAttrib(lazy_dots, Rf_install("class"), PROTECT(Rf_mkString("lazy_dots"))); UNPROTECT(3); return lazy_dots; } lazyeval/src/utils.h0000644000176200001440000000055315163675314014217 0ustar liggesusers#define R_NO_REMAP #include #include #include bool is_lazy_load_binding(SEXP env, SEXP sym); bool is_forced_lazy_load_binding(SEXP env, SEXP sym); bool is_call_to(SEXP x, const char* f); bool is_formula(SEXP x); SEXP rhs(SEXP f); SEXP lhs(SEXP f); SEXP env(SEXP f); SEXP findLast(SEXP x); SEXP make_formula1(SEXP rhs, SEXP env); lazyeval/src/expr.c0000644000176200001440000000655215163675314014035 0ustar liggesusers#define R_NO_REMAP #include #include #include "utils.h" static SEXP binding_expr(SEXP env, SEXP sym) { while (1) { SEXP where = r_env_until(env, sym, r_envs.empty); switch (r_env_binding_type(where, sym)) { case R_ENV_BINDING_TYPE_unbound: Rf_error("object '%s' not found", CHAR(PRINTNAME(sym))); case R_ENV_BINDING_TYPE_missing: return R_MissingArg; case R_ENV_BINDING_TYPE_value: case R_ENV_BINDING_TYPE_forced: case R_ENV_BINDING_TYPE_active: return r_env_get(where, sym); case R_ENV_BINDING_TYPE_delayed: { SEXP expr = r_env_binding_delayed_expr(where, sym); SEXP expr_env = r_env_binding_delayed_env(where, sym); if (TYPEOF(expr) != SYMSXP) return expr; SEXP inner_where = r_env_until(expr_env, expr, r_envs.empty); if (inner_where == r_envs.empty) return expr; switch (r_env_binding_type(inner_where, expr)) { case R_ENV_BINDING_TYPE_forced: if (is_forced_lazy_load_binding(inner_where, expr)) { return expr; } return r_env_binding_forced_expr(inner_where, expr); case R_ENV_BINDING_TYPE_value: case R_ENV_BINDING_TYPE_active: return expr; case R_ENV_BINDING_TYPE_delayed: if (is_lazy_load_binding(inner_where, expr)) return expr; sym = expr; env = expr_env; continue; default: return expr; } } } } } // Return NULL if not a promise or has already been forced static SEXP binding_expr_env(SEXP env, SEXP sym) { while (1) { SEXP where = r_env_until(env, sym, r_envs.empty); if (where == r_envs.empty) Rf_error("object '%s' not found", CHAR(PRINTNAME(sym))); // recurse until we find the real promise, not a promise of a promise switch (r_env_binding_type(where, sym)) { case R_ENV_BINDING_TYPE_unbound: Rf_error("object '%s' not found", CHAR(PRINTNAME(sym))); // This is a value binding, or the // promise has already been forced so can't go further case R_ENV_BINDING_TYPE_missing: case R_ENV_BINDING_TYPE_value: case R_ENV_BINDING_TYPE_forced: case R_ENV_BINDING_TYPE_active: 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 case R_ENV_BINDING_TYPE_delayed: { SEXP expr = r_env_binding_delayed_expr(where, sym); SEXP expr_env = r_env_binding_delayed_env(where, sym); if (TYPEOF(expr) != SYMSXP) return expr_env; SEXP inner_where = r_env_until(expr_env, expr, r_envs.empty); if (inner_where == r_envs.empty) return expr_env; switch (r_env_binding_type(inner_where, expr)) { case R_ENV_BINDING_TYPE_delayed: if (is_lazy_load_binding(inner_where, expr)) return expr_env; sym = expr; env = expr_env; continue; case R_ENV_BINDING_TYPE_unbound: return expr_env; case R_ENV_BINDING_TYPE_missing: case R_ENV_BINDING_TYPE_value: case R_ENV_BINDING_TYPE_forced: case R_ENV_BINDING_TYPE_active: return R_NilValue; } } } } } SEXP expr_find_(SEXP name, SEXP env) { return binding_expr(env, name); } SEXP expr_env_(SEXP name, SEXP env) { return binding_expr_env(env, name); } lazyeval/src/init.c0000644000176200001440000000220415163675314014010 0ustar liggesusers#include #include extern SEXP env(SEXP); extern SEXP expr_env_(SEXP, SEXP); extern SEXP expr_find_(SEXP, SEXP); extern SEXP interp_(SEXP, SEXP, SEXP); extern SEXP lhs(SEXP); extern SEXP lhs_name(SEXP); extern SEXP make_lazy(SEXP, SEXP, SEXP); extern SEXP make_lazy_dots(SEXP, SEXP, SEXP); extern SEXP rhs(SEXP); static const R_CallMethodDef call_entries[] = { {"lazyeval_env", (DL_FUNC) &env, 1}, {"lazyeval_expr_env_", (DL_FUNC) &expr_env_, 2}, {"lazyeval_expr_find_", (DL_FUNC) &expr_find_, 2}, {"lazyeval_interp_", (DL_FUNC) &interp_, 3}, {"lazyeval_lhs", (DL_FUNC) &lhs, 1}, {"lazyeval_lhs_name", (DL_FUNC) &lhs_name, 1}, {"lazyeval_make_lazy", (DL_FUNC) &make_lazy, 3}, {"lazyeval_make_lazy_dots", (DL_FUNC) &make_lazy_dots, 3}, {"lazyeval_rhs", (DL_FUNC) &rhs, 1}, {"r_init_library", (DL_FUNC) &r_init_library, 1}, {NULL, NULL, 0} }; void R_init_lazyeval(DllInfo* dll) { R_registerRoutines(dll, NULL, call_entries, NULL, NULL); R_useDynamicSymbols(dll, FALSE); } lazyeval/src/Makevars0000644000176200001440000000003115163675314014371 0ustar liggesusersPKG_CPPFLAGS = -I./rlang lazyeval/src/rlang/0000755000176200001440000000000015164116535014002 5ustar liggesuserslazyeval/src/rlang/obj.h0000644000176200001440000000502015163675314014726 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_OBJ_H #define RLANG_OBJ_H #include #include "rlang-types.h" #define r_missing_arg R_MissingArg static inline r_ssize r_length(r_obj* x) { return Rf_xlength(x); } static inline enum r_type r_typeof(r_obj* x) { return (enum r_type) TYPEOF(x); } void _r_preserve(r_obj* x); void _r_unpreserve(r_obj* x); static r_unused r_obj* _r_placeholder = NULL; #define r_preserve(X) \ (R_PreserveObject(_r_placeholder = X), \ (_r_preserve)(_r_placeholder), \ (void) NULL) #define r_unpreserve(X) \ (R_ReleaseObject(_r_placeholder = X), \ (_r_unpreserve)(_r_placeholder), \ (void) NULL) static inline void r_mark_shared(r_obj* x) { MARK_NOT_MUTABLE(x); } static inline bool r_is_shared(r_obj* x) { return MAYBE_REFERENCED(x); } static inline void _r_preserve_global(r_obj* x) { (_r_preserve)(x); r_mark_shared(x); } #define r_preserve_global(X) \ (R_PreserveObject(_r_placeholder = X), \ (_r_preserve_global)(_r_placeholder), \ (void) NULL) static inline bool r_is_object(r_obj* x) { return Rf_isObject(x); } static inline bool r_inherits(r_obj* x, const char* tag) { return Rf_inherits(x, tag); } static inline r_obj* r_copy(r_obj* x) { return Rf_duplicate(x); } static inline r_obj* r_clone(r_obj* x) { return Rf_shallow_duplicate(x); } // These also clone names r_obj* r_vec_clone(r_obj* x); r_obj* r_vec_clone_shared(r_obj* x); static inline r_obj* r_type_as_string(enum r_type type) { return Rf_type2str(type); } static inline r_obj* r_type_as_character(enum r_type type) { r_obj* str = KEEP(r_type_as_string(type)); r_obj* out = Rf_ScalarString(str); return FREE(1), out; } static inline const char* r_type_as_c_string(enum r_type type) { return CHAR(Rf_type2str(type)); } static inline enum r_type r_c_str_as_r_type(const char* type) { return (enum r_type) Rf_str2type(type); } enum r_type r_chr_as_r_type(r_obj* type); static inline bool r_is_symbolic(r_obj* x) { return r_typeof(x) == LANGSXP || r_typeof(x) == SYMSXP; } static inline void r_obj_print(r_obj* x) { Rf_PrintValue(x); } static inline bool r_is_identical(r_obj* x, r_obj* y) { // 16 corresponds to base::identical()'s defaults // Do we need less conservative versions? return R_compute_identical(x, y, 16); } r_obj* r_obj_address(r_obj* x); extern r_obj* (*r_obj_encode_utf8)(r_obj* x); r_obj* r_as_label(r_obj* x); #endif lazyeval/src/rlang/dyn-array.h0000644000176200001440000001267215163675314016075 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_DYN_ARRAY_H #define RLANG_DYN_ARRAY_H #include "rlang-types.h" #include "c-utils.h" #include "cnd.h" #include "vec.h" struct r_dyn_array { r_obj* shelter; r_ssize count; r_ssize capacity; int growth_factor; r_obj* data; void* v_data; const void* v_data_const; // private: enum r_type type; r_ssize elt_byte_size; void (*barrier_set)(r_obj* x, r_ssize i, r_obj* value); }; struct r_dyn_array* r_new_dyn_vector(enum r_type type, r_ssize capacity); struct r_dyn_array* r_new_dyn_array(r_ssize elt_byte_size, r_ssize capacity); void r_dyn_resize(struct r_dyn_array* p_arr, r_ssize capacity); void r_dyn_push_back(struct r_dyn_array* p_arr, const void* p_elt); r_obj* r_dyn_unwrap(struct r_dyn_array* p_arr); static inline void* r_dyn_pointer(struct r_dyn_array* p_arr, r_ssize i) { if (p_arr->barrier_set) { r_abort("Can't take mutable pointer of barrier vector."); } r_ssize offset = i * p_arr->elt_byte_size; return ((unsigned char*) p_arr->v_data) + offset; } static inline void* r_dyn_begin(struct r_dyn_array* p_arr) { return r_dyn_pointer(p_arr, 0); } static inline void* r_dyn_last(struct r_dyn_array* p_arr) { return r_dyn_pointer(p_arr, p_arr->count - 1); } static inline void* r_dyn_end(struct r_dyn_array* p_arr) { return r_dyn_pointer(p_arr, p_arr->count); } static inline const void* r_dyn_cpointer(struct r_dyn_array* p_arr, r_ssize i) { r_ssize offset = i * p_arr->elt_byte_size; return ((const unsigned char*) p_arr->v_data_const) + offset; } static inline const void* r_dyn_cbegin(struct r_dyn_array* p_arr) { return r_dyn_cpointer(p_arr, 0); } static inline const void* r_dyn_clast(struct r_dyn_array* p_arr) { return r_dyn_cpointer(p_arr, p_arr->count - 1); } static inline const void* r_dyn_cend(struct r_dyn_array* p_arr) { return r_dyn_cpointer(p_arr, p_arr->count); } #define R_DYN_GET(TYPE, X, I) (*((TYPE*) r_dyn_pointer((X), (I)))) #define R_DYN_POKE(TYPE, X, I, VAL) (*((TYPE*) r_dyn_pointer((X), (I))) = (VAL)) static inline int r_dyn_lgl_get(struct r_dyn_array* p_vec, r_ssize i) { return ((const int*) p_vec->v_data_const)[i]; } static inline int r_dyn_int_get(struct r_dyn_array* p_vec, r_ssize i) { return ((const int*) p_vec->v_data_const)[i]; } static inline double r_dyn_dbl_get(struct r_dyn_array* p_vec, r_ssize i) { return ((const double*) p_vec->v_data_const)[i]; } static inline r_complex r_dyn_cpl_get(struct r_dyn_array* p_vec, r_ssize i) { return ((const r_complex*) p_vec->v_data_const)[i]; } static inline char r_dyn_raw_get(struct r_dyn_array* p_vec, r_ssize i) { return ((const char*) p_vec->v_data_const)[i]; } static inline r_obj* r_dyn_chr_get(struct r_dyn_array* p_vec, r_ssize i) { return ((r_obj* const *) p_vec->v_data_const)[i]; } static inline r_obj* r_dyn_list_get(struct r_dyn_array* p_vec, r_ssize i) { return ((r_obj* const *) p_vec->v_data_const)[i]; } static inline void r_dyn_lgl_poke(struct r_dyn_array* p_vec, r_ssize i, int value) { ((int*) p_vec->v_data)[i] = value; } static inline void r_dyn_int_poke(struct r_dyn_array* p_vec, r_ssize i, int value) { ((int*) p_vec->v_data)[i] = value; } static inline void r_dyn_dbl_poke(struct r_dyn_array* p_vec, r_ssize i, double value) { ((double*) p_vec->v_data)[i] = value; } static inline void r_dyn_cpl_poke(struct r_dyn_array* p_vec, r_ssize i, r_complex value) { ((r_complex*) p_vec->v_data)[i] = value; } static inline void r_dyn_raw_poke(struct r_dyn_array* p_vec, r_ssize i, char value) { ((char*) p_vec->v_data)[i] = value; } static inline void r_dyn_chr_poke(struct r_dyn_array* p_vec, r_ssize i, r_obj* value) { r_chr_poke(p_vec->data, i, value); } static inline void r_dyn_list_poke(struct r_dyn_array* p_vec, r_ssize i, r_obj* value) { r_list_poke(p_vec->data, i, value); } static inline void* const * r_dyn_pop_back(struct r_dyn_array* p_arr) { void* const * out = (void* const *) r_dyn_clast(p_arr); --p_arr->count; return out; } static inline r_ssize r__dyn_increment(struct r_dyn_array* p_arr) { r_ssize loc = p_arr->count++; if (p_arr->count > p_arr->capacity) { r_ssize new_capacity = r_ssize_mult(p_arr->capacity, p_arr->growth_factor); r_dyn_resize(p_arr, new_capacity); } return loc; } static inline void r_dyn_lgl_push_back(struct r_dyn_array* p_vec, int elt) { r_ssize loc = r__dyn_increment(p_vec); r_dyn_lgl_poke(p_vec, loc, elt); } static inline void r_dyn_int_push_back(struct r_dyn_array* p_vec, int elt) { r_ssize loc = r__dyn_increment(p_vec); r_dyn_int_poke(p_vec, loc, elt); } static inline void r_dyn_dbl_push_back(struct r_dyn_array* p_vec, double elt) { r_ssize loc = r__dyn_increment(p_vec); r_dyn_dbl_poke(p_vec, loc, elt); } static inline void r_dyn_cpl_push_back(struct r_dyn_array* p_vec, r_complex elt) { r_ssize loc = r__dyn_increment(p_vec); r_dyn_cpl_poke(p_vec, loc, elt); } static inline void r_dyn_raw_push_back(struct r_dyn_array* p_vec, char elt) { r_ssize loc = r__dyn_increment(p_vec); r_dyn_raw_poke(p_vec, loc, elt); } static inline void r_dyn_chr_push_back(struct r_dyn_array* p_vec, r_obj* elt) { KEEP(elt); r_ssize loc = r__dyn_increment(p_vec); r_dyn_chr_poke(p_vec, loc, elt); FREE(1); } static inline void r_dyn_list_push_back(struct r_dyn_array* p_vec, r_obj* elt) { KEEP(elt); r_ssize loc = r__dyn_increment(p_vec); r_dyn_list_poke(p_vec, loc, elt); FREE(1); } #endif lazyeval/src/rlang/debug.c0000644000176200001440000000120415163675314015235 0ustar liggesusers#include "rlang.h" void r_sexp_inspect(r_obj* x) { r_obj* call = KEEP(r_parse(".Internal(inspect(x))")); r_eval_with_x(call, x, r_envs.base); FREE(1); } void r_browse(r_obj* x) { r_env_bind(r_envs.global, r_sym(".debug"), x); r_printf("Object saved in `.debug`:\n"); r_obj_print(x); r_obj* frame = KEEP(r_peek_frame()); r_browse_at(frame); FREE(1); } void r_browse_at(r_obj* env) { // The NULL expression is needed because of a limitation in ESS r_parse_eval("{ browser(); NULL }", env); } void r_dbg_str(r_obj* x) { r_obj* call = KEEP(r_parse("str(x)")); r_eval_with_x(call, x, r_ns_env("utils")); FREE(1); } lazyeval/src/rlang/arg.h0000644000176200001440000000045715163675314014736 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_ARG_H #define RLANG_ARG_H #include "rlang-types.h" extern int (*r_arg_match)(r_obj* arg, r_obj* values, struct r_lazy error_arg, struct r_lazy error_call); #endif lazyeval/src/rlang/vec-chr.h0000644000176200001440000000355115163675314015512 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_VECTOR_CHR_H #define RLANG_VECTOR_CHR_H #include "globals.h" #include "rlang-types.h" static inline const char* r_str_c_string(r_obj* str) { return CHAR(str); } bool r_chr_has(r_obj* chr, const char* c_string); bool r_chr_has_any(r_obj* chr, const char** c_strings); r_ssize r_chr_detect_index(r_obj* chr, const char* c_string); void r_chr_fill(r_obj* chr, r_obj* value, r_ssize n); static inline r_obj* r_str_as_character(r_obj* x) { return Rf_ScalarString(x); } /* * A symbol is always in the native encoding. This means that UTF-8 * data frame names undergo a lossy translation when they are * transformed to symbols to create a data mask. To deal with this, we * translate all serialised unicode tags back to UTF-8. This way the * UTF-8 -> native -> UTF-8 translation that occurs during the * character -> symbol -> character conversion fundamental for data * masking is transparent and lossless for the end user. * * Starting from R 4.0, `installChar()` warns when translation to * native encoding is lossy. This warning is disruptive for us since * we correctly translate strings behind the scene. To work around * this, we call `translateChar()` which doesn't warn (at least * currently). If the pointers are the same, no translation is * needed and we can call `installChar()`, which preserves the * current encoding of the string. Otherwise we intern the symbol * with `install()` without encoding. */ static inline r_obj* r_str_as_symbol(r_obj* str) { const char* str_native = Rf_translateChar(str); if (str_native == CHAR(str)) { return Rf_installChar(str); } else { return Rf_install(str_native); } } static inline bool r_str_is_name(r_obj* str) { if (str == r_globals.na_str) { return false; } if (str == r_strs.empty) { return false; } return true; } #endif lazyeval/src/rlang/arg.c0000644000176200001440000000051715163675314014726 0ustar liggesusers#include "rlang.h" int (*r_arg_match)(r_obj* arg, r_obj* values, struct r_lazy error_arg, struct r_lazy error_call); void r_init_library_arg(void) { r_arg_match = (int (*)(r_obj*, r_obj*, struct r_lazy, struct r_lazy)) r_peek_c_callable("rlang", "rlang_arg_match_2"); } lazyeval/src/rlang/rlang.h0000644000176200001440000000400315163675314015257 0ustar liggesusers#ifndef RLANG_RLANG_H #define RLANG_RLANG_H /* * `_ISOC99_SOURCE` is defined to avoid warnings on Windows UCRT builds where * usage of `PRIx64` in Microsoft's `printf()` can generate the warnings shown * below. Defining this before including `` forces usage of MinGW's * custom `printf()`, which is C99 compliant. * warning: unknown conversion type character 'l' in format [-Wformat] * warning: too many arguments for format [-Wformat-extra-args] * * The conventional define for this is `__USE_MINGW_ANSI_STDIO`, but according * to the thread below it is recommended to instead use a feature test macro * (such as `_ISOC99_SOURCE`) which will indirectly define the internal * `__USE_MINGW_ANSI_STDIO` macro for us. * https://osdn.net/projects/mingw/lists/archive/users/2019-January/000199.html */ #ifndef _ISOC99_SOURCE #define _ISOC99_SOURCE #endif #define R_NO_REMAP #include // IWYU pragma: export #include // IWYU pragma: export #include // IWYU pragma: export #include "rlang-types.h" // IWYU pragma: export r_obj* r_init_library(r_obj* ns); r_ssize r_arg_as_ssize(r_obj* n, const char* arg); static inline r_ssize r_as_ssize(r_obj* n) { return r_arg_as_ssize(n, "n"); } extern bool _r_use_local_precious_list; // IWYU pragma: begin_exports #include "obj.h" #include "globals.h" #include "arg.h" #include "attrib.h" #include "debug.h" #include "c-utils.h" #include "call.h" #include "cnd.h" #include "dict.h" #include "df.h" #include "dyn-array.h" #include "dyn-list-of.h" #include "dots-info.h" #include "env.h" #include "env-binding.h" #include "eval.h" #include "export.h" #include "fn.h" #include "formula.h" #include "node.h" #include "parse.h" #include "quo.h" #include "session.h" #include "stack.h" #include "state.h" #include "sym.h" #include "vec.h" #include "vec-chr.h" #include "vec-lgl.h" #include "vendor.h" #include "walk.h" // IWYU pragma: end_exports #define r_abort_lazy_call(LAZY, ...) \ r_abort_call(KEEP(r_lazy_eval(LAZY)), __VA_ARGS__) #endif lazyeval/src/rlang/parse.c0000644000176200001440000000132515163675314015265 0ustar liggesusers#include "rlang.h" #include static void abort_parse(r_obj* code, const char* why) { if (r_peek_option("rlang__verbose_errors") != r_null) { r_obj_print(code); } r_abort("Internal error: %s", why); } r_obj* r_parse(const char* str) { r_obj* str_ = KEEP(r_chr(str)); ParseStatus status; r_obj* out = KEEP(R_ParseVector(str_, -1, &status, r_null)); if (status != PARSE_OK) { abort_parse(str_, "Parsing failed"); } if (r_length(out) != 1) { abort_parse(str_, "Expected a single expression"); } out = r_list_get(out, 0); FREE(2); return out; } r_obj* r_parse_eval(const char* str, r_obj* env) { r_obj* out = r_eval(KEEP(r_parse(str)), env); FREE(1); return out; } lazyeval/src/rlang/dyn-list-of.c0000644000176200001440000001562615163675314016331 0ustar liggesusers#include #include "decl/dyn-list-of-decl.h" #define R_DYN_LOF_GROWTH_FACTOR 2 #define R_DYN_LOF_INIT_SIZE 32 enum shelter_dyn_list_of { SHELTER_DYN_LOF_raw, SHELTER_DYN_LOF_reserve, SHELTER_DYN_LOF_arr_locs, SHELTER_DYN_LOF_extra_array, SHELTER_DYN_LOF_extra_shelter_array, SHELTER_DYN_LOF_moved_arr, SHELTER_DYN_LOF_moved_shelter_arr, SHELTER_DYN_LOF_arrays, SHELTER_DYN_LOF_SIZE }; struct r_dyn_list_of* r_new_dyn_list_of(enum r_type type, r_ssize capacity, r_ssize width) { switch (type) { case R_TYPE_character: case R_TYPE_list: r_abort("Can't create a dynamic list of barrier vectors."); default: break; } r_obj* shelter = KEEP(r_alloc_list(SHELTER_DYN_LOF_SIZE)); r_obj* lof_raw = r_alloc_raw(sizeof(struct r_dyn_list_of)); r_list_poke(shelter, SHELTER_DYN_LOF_raw, lof_raw); struct r_dyn_array* p_moved_arr = r_new_dyn_array(sizeof(struct r_dyn_array*), R_DYN_LOF_INIT_SIZE); r_list_poke(shelter, SHELTER_DYN_LOF_moved_arr, p_moved_arr->shelter); struct r_dyn_array* p_moved_shelter_arr = r_new_dyn_vector(R_TYPE_list, R_DYN_LOF_INIT_SIZE); r_list_poke(shelter, SHELTER_DYN_LOF_moved_shelter_arr, p_moved_shelter_arr->shelter); r_obj* reserve = r_alloc_vector(type, r_ssize_mult(capacity, width)); r_list_poke(shelter, SHELTER_DYN_LOF_reserve, reserve); void* v_reserve = r_vec_begin(reserve); r_obj* arr_locs = r_alloc_raw(sizeof(r_ssize) * capacity); r_list_poke(shelter, SHELTER_DYN_LOF_arr_locs, arr_locs); r_ssize* v_arr_locs = r_raw_begin(arr_locs); R_MEM_SET(r_ssize, v_arr_locs, -1, capacity); struct r_dyn_array* p_arrays = r_new_dyn_array(sizeof(struct r_pair_ptr_ssize), capacity); r_list_poke(shelter, SHELTER_DYN_LOF_arrays, p_arrays->shelter); struct r_dyn_list_of* p_lof = r_raw_begin(lof_raw); *p_lof = (struct r_dyn_list_of) { .shelter = shelter, .count = 0, .capacity = capacity, .growth_factor = R_DYN_LOF_GROWTH_FACTOR, .v_data = r_dyn_begin(p_arrays), // private: .width = width, .type = type, .elt_byte_size = r_vec_elt_sizeof0(type), .reserve = reserve, .v_reserve = v_reserve, .p_moved_arr = p_moved_arr, .p_moved_shelter_arr = p_moved_shelter_arr, .arr_locs = arr_locs, .v_arr_locs = v_arr_locs, .p_arrays = p_arrays, }; FREE(1); return p_lof; } r_obj* r_lof_unwrap(struct r_dyn_list_of* p_lof) { r_obj* out = KEEP(r_alloc_list(p_lof->count)); enum r_type type = p_lof->type; r_ssize n = p_lof->count; struct r_pair_ptr_ssize* v_arrays = r_dyn_begin(p_lof->p_arrays); for (r_ssize i = 0; i < n; ++i) { struct r_pair_ptr_ssize array = v_arrays[i]; r_list_poke(out, i, r_vec_n(type, array.ptr, array.size)); } FREE(1); return out; } static void r_lof_resize(struct r_dyn_list_of* p_lof, r_ssize capacity) { r_ssize count = p_lof->count; // Resize reserve r_obj* reserve = r_vec_resize0(p_lof->type, p_lof->reserve, r_ssize_mult(capacity, p_lof->width)); r_list_poke(p_lof->shelter, SHELTER_DYN_LOF_reserve, reserve); p_lof->reserve = reserve; p_lof->v_reserve = r_vec_begin0(p_lof->type, reserve); p_lof->capacity = capacity; // Resize array indirections r_obj* arr_locs = r_raw_resize(p_lof->arr_locs, r_ssize_mult(sizeof(r_ssize), capacity)); r_list_poke(p_lof->shelter, SHELTER_DYN_LOF_arr_locs, arr_locs); r_ssize* v_arr_locs = r_raw_begin(arr_locs); r_ssize n_new = capacity - count; R_MEM_SET(r_ssize, v_arr_locs + count, -1, n_new); p_lof->arr_locs = arr_locs; p_lof->v_arr_locs = v_arr_locs; // Resize addresses and update them to point to the new memory r_dyn_resize(p_lof->p_arrays, capacity); struct r_pair_ptr_ssize* v_data = r_dyn_begin(p_lof->p_arrays); p_lof->v_data = v_data; unsigned char* v_reserve_u = (unsigned char*) p_lof->v_reserve; r_ssize bytes = p_lof->width * p_lof->elt_byte_size; for (r_ssize i = 0; i < count; ++i) { // Preserve addresses of moved arrays if (v_arr_locs[i] < 0) { r_ssize offset = i * bytes; v_data[i].ptr = v_reserve_u + offset; } } } void r_lof_push_back(struct r_dyn_list_of* p_lof) { r_ssize count = p_lof->count + 1; if (count > p_lof->capacity) { r_ssize new_size = r_ssize_mult(p_lof->capacity, R_DYN_LOF_GROWTH_FACTOR); r_lof_resize(p_lof, new_size); } p_lof->count = count; unsigned char* v_reserve_u = (unsigned char*) p_lof->v_reserve; r_ssize offset = (count - 1) * p_lof->width * p_lof->elt_byte_size; struct r_pair_ptr_ssize info = { .ptr = v_reserve_u + offset, .size = 0 }; r_dyn_push_back(p_lof->p_arrays, &info); } void r_lof_arr_push_back(struct r_dyn_list_of* p_lof, r_ssize i, void* p_elt) { if (i >= p_lof->count) { r_stop_internal("Location %d does not exist.", i); } if (reserve_push_back(p_lof, i, p_elt)) { return; } struct r_dyn_array* p_arr = p_lof->p_moved_arr; r_ssize arr_i = p_lof->v_arr_locs[i]; if (arr_i >= p_arr->count) { r_stop_internal("Location %d does not exist in the extra array", arr_i); } struct r_dyn_array* p_inner_arr = R_DYN_GET(struct r_dyn_array*, p_arr, arr_i); r_dyn_push_back(p_inner_arr, p_elt); // Also update pointer in case of resize R_DYN_POKE(struct r_pair_ptr_ssize, p_lof->p_arrays, i, ((struct r_pair_ptr_ssize) { .ptr = r_dyn_begin(p_inner_arr), .size = p_inner_arr->count })); } static bool reserve_push_back(struct r_dyn_list_of* p_lof, r_ssize i, void* p_elt) { if (p_lof->v_arr_locs[i] >= 0) { return false; } struct r_pair_ptr_ssize* p_arr_info = r_dyn_pointer(p_lof->p_arrays, i); if (p_arr_info->size >= p_lof->width) { // Inner array is getting too big for the reserve. Move it to a // dynamic array. reserve_move(p_lof, i, p_elt); return false; } r_ssize count = ++p_arr_info->size; r_ssize offset = (i * p_lof->width + count - 1) * p_lof->elt_byte_size; void* p = ((unsigned char*) p_lof->v_reserve) + offset; if (p_elt) { r_memcpy(p, p_elt, p_lof->elt_byte_size); } else { r_memset(p, 0, p_lof->elt_byte_size); } return true; } static void reserve_move(struct r_dyn_list_of* p_lof, r_ssize i, void* p_elt) { struct r_dyn_array* p_moved_arr = p_lof->p_moved_arr; r_ssize n = p_lof->width; struct r_dyn_array* p_new = r_new_dyn_vector(p_lof->type, p_lof->width); r_dyn_list_push_back(p_lof->p_moved_shelter_arr, p_new->shelter); r_dyn_push_back(p_moved_arr, &p_new); void* v_new = r_dyn_begin(p_new); void* v_old = R_DYN_GET(struct r_pair_ptr_ssize, p_lof->p_arrays, i).ptr; r_memcpy(v_new, v_old, r_ssize_mult(n, p_lof->elt_byte_size)); p_new->count = n; R_DYN_POKE(struct r_pair_ptr_ssize, p_lof->p_arrays, i, ((struct r_pair_ptr_ssize) { .ptr = v_new, .size = n })); p_lof->v_arr_locs[i] = p_moved_arr->count - 1; } lazyeval/src/rlang/node.h0000644000176200001440000000427415163675314015113 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_NODE_H #define RLANG_NODE_H #include "rlang-types.h" static inline r_obj* r_node_car(r_obj* x) { return CAR(x); } static inline r_obj* r_node_cdr(r_obj* x) { return CDR(x); } static inline r_obj* r_node_tag(r_obj* x) { return TAG(x); } static inline r_obj* r_node_caar(r_obj* x) { return CAAR(x); } static inline r_obj* r_node_cadr(r_obj* x) { return CADR(x); } static inline r_obj* r_node_cdar(r_obj* x) { return CDAR(x); } static inline r_obj* r_node_cddr(r_obj* x) { return CDDR(x); } static inline void r_node_poke_car(r_obj* x, r_obj* newcar) { SETCAR(x, newcar); } static inline void r_node_poke_cdr(r_obj* x, r_obj* newcdr) { SETCDR(x, newcdr); } static inline void r_node_poke_tag(r_obj* x, r_obj* tag) { SET_TAG(x, tag); } static inline void r_node_poke_caar(r_obj* x, r_obj* newcaar) { SETCAR(CAR(x), newcaar); } static inline void r_node_poke_cadr(r_obj* x, r_obj* newcar) { SETCADR(x, newcar); } static inline void r_node_poke_cdar(r_obj* x, r_obj* newcdar) { SETCDR(CAR(x), newcdar); } static inline void r_node_poke_cddr(r_obj* x, r_obj* newcdr) { SETCDR(CDR(x), newcdr); } static inline r_obj* r_new_node(r_obj* car, r_obj* cdr) { return Rf_cons(car, cdr); } static inline r_obj* r_new_node3(r_obj* car, r_obj* cdr, r_obj* tag) { r_obj* out = Rf_cons(car, cdr); SET_TAG(out, tag); return out; } r_obj* r_new_pairlist(const struct r_pair* args, int n, r_obj** tail); #define r_pairlist Rf_list1 #define r_pairlist2 Rf_list2 #define r_pairlist3 Rf_list3 #define r_pairlist4 Rf_list4 #define r_pairlist5 Rf_list5 r_obj* r_pairlist_rev(r_obj* node); // Used by `r_attrib_get()` via `r_pairlist_get()`, // so we want it to be fully inlined static inline r_obj* r_pairlist_find(r_obj* node, r_obj* tag) { while (node != r_null) { if (r_node_tag(node) == tag) { return node; } node = r_node_cdr(node); } return r_null; } static inline r_obj* r_pairlist_get(r_obj* node, r_obj* tag) { return r_node_car(r_pairlist_find(node, tag)); } static inline r_obj* r_pairlist_tail(r_obj* x) { r_obj* cdr = r_null; while ((cdr = r_node_cdr(x)) != r_null) { x = cdr; } return x; } r_obj* r_node_tree_clone(r_obj* x); #endif lazyeval/src/rlang/cpp/0000755000176200001440000000000015163675314014570 5ustar liggesuserslazyeval/src/rlang/cpp/rlang.cpp0000644000176200001440000000002315163675314016372 0ustar liggesusers#include "vec.cpp" lazyeval/src/rlang/cpp/vec.cpp0000644000176200001440000000073115163675314016052 0ustar liggesusers#include #include extern "C" { int* r_int_unique0(int* v_data, r_ssize size) { try { return std::unique(v_data, v_data + size); } catch (...) { rcc_abort("r_int_unique0"); } } bool r_list_all_of0(r_obj* const * v_first, r_ssize size, bool (*predicate)(r_obj* x)) { try { return std::all_of(v_first, v_first + size, predicate); } catch (...) { rcc_abort("r_list_all_of"); } } } lazyeval/src/rlang/call.h0000644000176200001440000000067215163675314015077 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_LANG_H #define RLANG_LANG_H #include "rlang-types.h" #define r_new_call Rf_lcons #define r_call Rf_lang1 #define r_call2 Rf_lang2 #define r_call3 Rf_lang3 #define r_call4 Rf_lang4 #define r_call5 Rf_lang5 bool r_is_call(r_obj* x, const char* name); bool r_is_call_any(r_obj* x, const char** names, int n); r_obj* r_expr_protect(r_obj* x); r_obj* r_call_clone(r_obj* x); #endif lazyeval/src/rlang/fn.c0000644000176200001440000000161415163675314014557 0ustar liggesusers#include "rlang.h" r_obj* rlang_formula_formals = NULL; r_obj* r_as_function(r_obj* x, const char* arg) { switch (r_typeof(x)) { case R_TYPE_closure: case R_TYPE_builtin: case R_TYPE_special: return x; case R_TYPE_call: if (r_node_car(x) == r_syms.tilde && r_node_cddr(x) == r_null) { r_obj* env = r_attrib_get(x, r_syms.dot_environment); if (env == r_null) { r_abort("Can't transform formula to function because it doesn't have an environment."); } return r_new_function(rlang_formula_formals, r_node_cadr(x), env); } // else fallthrough; default: r_abort("Can't convert `%s` to a function", arg); } } void r_init_library_fn(void) { const char* formals_code = "formals(function(..., .x = ..1, .y = ..2, . = ..1) NULL)"; rlang_formula_formals = r_parse_eval(formals_code, r_envs.base); r_preserve_global(rlang_formula_formals); } lazyeval/src/rlang/formula.c0000644000176200001440000000343415163675314015623 0ustar liggesusers#include "rlang.h" r_obj* r_f_rhs(r_obj* f) { if (r_typeof(f) != LANGSXP) { r_abort("`x` must be a formula"); } switch (r_length(f)) { case 2: return r_node_cadr(f); case 3: return CADDR(f); default: r_abort("Invalid formula"); } } r_obj* r_f_lhs(r_obj* f) { if (r_typeof(f) != LANGSXP) { r_abort("`x` must be a formula"); } switch (r_length(f)) { case 2: return r_null; case 3: return r_node_cadr(f); default: r_abort("Invalid formula"); } } r_obj* r_f_env(r_obj* f) { return r_attrib_get(f, r_sym(".Environment")); } bool r_f_has_env(r_obj* f) { return r_is_environment(r_f_env(f)); } bool r_is_formula(r_obj* x, int scoped, int lhs) { if (r_typeof(x) != R_TYPE_call) { return false; } if (r_node_car(x) != r_syms.tilde) { return false; } if (scoped >= 0) { bool has_env = r_typeof(r_f_env(x)) == R_TYPE_environment; bool has_class = r_inherits(x, "formula"); if (scoped != (has_env && has_class)) { return false; } } if (lhs >= 0) { int has_lhs = r_length(x) > 2; if (lhs != has_lhs) { return false; } } return true; } r_obj* new_raw_formula(r_obj* lhs, r_obj* rhs, r_obj* env) { static r_obj* tilde_sym = NULL; if (!tilde_sym) { tilde_sym = r_sym("~"); } if (!r_is_environment(env) && env != r_null) { r_abort("`env` must be an environment"); } r_obj* f; r_obj* args; if (lhs == r_null) { args = KEEP(r_pairlist(rhs)); } else { args = KEEP(r_pairlist2(lhs, rhs)); } f = KEEP(r_new_call(tilde_sym, args)); r_attrib_poke(f, r_sym(".Environment"), env); FREE(2); return f; } r_obj* r_new_formula(r_obj* lhs, r_obj* rhs, r_obj* env) { r_obj* f = KEEP(new_raw_formula(lhs, rhs, env)); r_attrib_poke_class(f, r_chr("formula")); FREE(1); return f; } lazyeval/src/rlang/globals.c0000644000176200001440000000635615163675314015607 0ustar liggesusers#include "rlang-types.h" #include "sym.h" struct r_globals r_globals; struct r_globals_chrs r_chrs; struct r_globals_classes r_classes; struct r_globals_strs r_strs; struct r_globals_syms r_syms; struct r_globals_envs r_envs; r_obj* r_true = NULL; r_obj* r_false = NULL; void r_init_library_globals(r_obj* ns) { r_preserve_global(r_classes.data_frame = r_chr("data.frame")); const char* v_tibble_class[] = { "tbl_df", "tbl", "data.frame" }; r_preserve_global(r_globals.empty_lgl = r_alloc_logical(0)); r_preserve_global(r_globals.empty_int = r_alloc_integer(0)); r_preserve_global(r_globals.empty_dbl = r_alloc_double(0)); r_preserve_global(r_globals.empty_cpl = r_alloc_complex(0)); r_preserve_global(r_globals.empty_raw = r_alloc_raw(0)); r_preserve_global(r_globals.empty_chr = r_alloc_character(0)); r_preserve_global(r_globals.empty_list = r_alloc_list(0)); r_globals.na_lgl = NA_LOGICAL; r_globals.na_int = NA_INTEGER; r_globals.na_dbl = NA_REAL; r_globals.na_cpl = (r_complex) { .r = NA_REAL, .i = NA_REAL }; r_globals.na_str = NA_STRING; r_preserve_global(r_chrs.empty_string = r_chr("")); r_preserve_global(r_chrs.full = r_chr("full")); r_classes.tibble = r_chr_n(v_tibble_class, R_ARR_SIZEOF(v_tibble_class)); r_preserve_global(r_classes.tibble); r_strs.dots = r_sym_string(r_syms.dots); r_strs.condition = r_sym_string(r_syms.condition); r_strs.empty = r_chr_get(r_chrs.empty_string, 0); r_strs.error = r_sym_string(r_syms.error); r_strs.interrupt = r_sym_string(r_syms.interrupt); r_strs.na = r_globals.na_str; r_strs.message = r_sym_string(r_syms.message); r_strs.warning = r_sym_string(r_syms.warning); r_preserve_global(r_false = r_lgl(0)); r_preserve_global(r_true = r_lgl(1)); r_envs.empty = R_EmptyEnv; r_envs.base = R_BaseEnv; r_envs.global = R_GlobalEnv; r_envs.ns = ns; } void r_init_library_globals_syms(void) { r_syms.abort = r_sym("abort"); r_syms.arg = r_sym("arg"); r_syms.brace = R_BraceSymbol; r_syms.brackets = R_BracketSymbol; r_syms.brackets2 = R_Bracket2Symbol; r_syms.call = r_sym("call"); r_syms.class_ = R_ClassSymbol; r_syms.colon2 = R_DoubleColonSymbol; r_syms.colon3 = R_TripleColonSymbol; r_syms.condition = r_sym("condition"); r_syms.dots = R_DotsSymbol; r_syms.error = r_sym("error"); r_syms.error_arg = r_sym("error_arg"); r_syms.error_call = r_sym("error_call"); r_syms.error_call_flag = r_sym(".__error_call__."); r_syms.expr = r_sym("expr"); r_syms.interrupt = r_sym("interrupt"); r_syms.missing = R_MissingArg; r_syms.message = r_sym("message"); r_syms.names = R_NamesSymbol; r_syms.options = r_sym("options"); r_syms.dim = R_DimSymbol; r_syms.dim_names = R_DimNamesSymbol; r_syms.row_names = R_RowNamesSymbol; r_syms.stack_overflow_error = r_sym("stackOverflowError"); r_syms.warning = r_sym("warning"); r_syms.dot_environment = r_sym(".Environment"); r_syms.dot_fn = r_sym(".fn"); r_syms.dot_x = r_sym(".x"); r_syms.dot_y = r_sym(".y"); r_syms.function = r_sym("function"); r_syms.srcfile = r_sym("srcfile"); r_syms.srcref = r_sym("srcref"); r_syms.tilde = r_sym("~"); r_syms.w = r_sym("w"); r_syms.wholeSrcref = r_sym("wholeSrcref"); r_syms.x = r_sym("x"); r_syms.y = r_sym("y"); r_syms.z = r_sym("z"); } lazyeval/src/rlang/env.c0000644000176200001440000001551515163675314014751 0ustar liggesusers#include "rlang.h" #include "decl/env-decl.h" r_obj* rlang_ns_env; r_obj* r_ns_env(const char* pkg) { r_obj* pkg_str = KEEP(r_chr(pkg)); r_obj* ns = R_FindNamespace(pkg_str); FREE(1); return ns; } r_obj* r_base_ns_get(const char* name) { return r_env_get(r_envs.base, r_sym(name)); } r_obj* rlang_ns_get(const char* name) { return r_env_get(rlang_ns_env, r_sym(name)); } r_obj* r_alloc_environment(r_ssize size, r_obj* parent) { #if R_VERSION < R_Version(4, 1, 0) parent = parent ? parent : r_envs.empty; r_node_poke_car(new_env__parent_node, parent); size = size ? size : 29; r_node_poke_car(new_env__size_node, r_int(size)); r_obj* env = r_eval(new_env_call, r_envs.base); // Free for gc r_node_poke_car(new_env__parent_node, r_null); return env; #else const int hash = 1; return R_NewEnv(parent, hash, size); #endif } r_obj* r_env_as_list(r_obj* env) { return eval_with_x(env2list_call, env); } r_obj* r_env_clone(r_obj* env, r_obj* parent) { if (parent == NULL) { parent = r_env_parent(env); } // This better reproduces the behaviour of `list2env()` which in // turn affects how bindings are stored in the hash table and the // default sort of the character vector generated by `names()`. size_t size = R_MAX(r_length(env), 29); r_obj* out = KEEP(r_alloc_environment(size, parent)); r_env_coalesce(out, env); FREE(1); return out; } void r_env_coalesce(r_obj* env, r_obj* from) { r_obj* syms = KEEP(r_env_syms(from)); r_obj* types = KEEP(r_env_binding_types(from, syms)); if (types == r_null) { env_coalesce_plain(env, from, syms); FREE(2); return; } r_ssize n = r_length(syms); r_obj* const * v_syms = r_list_cbegin(syms); enum r_env_binding_type* v_types = (enum r_env_binding_type*) r_int_begin(types); for (r_ssize i = 0; i < n; ++i) { r_obj* sym = v_syms[i]; if (r_env_has(env, sym)) { continue; } switch (v_types[i]) { case R_ENV_BINDING_TYPE_unbound: break; case R_ENV_BINDING_TYPE_value: r_env_bind(env, sym, KEEP(r_env_get(from, sym))); FREE(1); break; case R_ENV_BINDING_TYPE_delayed: r_env_bind_delayed( env, sym, KEEP(r_env_binding_delayed_expr(from, sym)), KEEP(r_env_binding_delayed_env(from, sym)) ); FREE(2); break; case R_ENV_BINDING_TYPE_forced: r_env_bind_forced( env, sym, KEEP(r_env_binding_forced_expr(from, sym)), KEEP(r_env_get(from, sym)) ); FREE(2); break; case R_ENV_BINDING_TYPE_missing: r_env_bind_missing(env, sym); break; case R_ENV_BINDING_TYPE_active: r_env_bind_active(env, sym, KEEP(r_env_binding_active_fn(from, sym))); FREE(1); break; } } FREE(2); return; } static void env_coalesce_plain(r_obj* env, r_obj* from, r_obj* syms) { r_ssize n = r_length(syms); r_obj* const * v_syms = r_list_cbegin(syms); for (r_ssize i = 0; i < n; ++i) { r_obj* sym = v_syms[i]; if (r_env_has(env, sym)) { continue; } r_env_bind(env, sym, KEEP(r_env_get(from, sym))); FREE(1); } return; } r_obj* r_list_as_environment(r_obj* x, r_obj* parent) { parent = parent ? parent : r_envs.empty; return eval_with_xy(list2env_call, x, parent); } #if RLANG_USE_R_EXISTS bool r__env_has(r_obj* env, r_obj* sym) { // `exists("")` errors on older R if (sym == R_MissingArg) { return Rf_findVarInFrame3(env, sym, FALSE) != R_UnboundValue; } r_obj* nm = KEEP(r_sym_as_utf8_character(sym)); r_obj* out = eval_with_xyz(exists_call, env, nm, r_false); FREE(1); return r_as_bool(out); } bool r__env_has_anywhere(r_obj* env, r_obj* sym) { // `exists("")` errors on older R if (sym == R_MissingArg) { return Rf_findVar(sym, env) != R_UnboundValue; } r_obj* nm = KEEP(r_sym_as_utf8_character(sym)); r_obj* out = eval_with_xyz(exists_call, env, nm, r_true); FREE(1); return r_as_bool(out); } #endif bool r_env_inherits(r_obj* env, r_obj* ancestor, r_obj* top) { top = top ? top : r_envs.empty; if (r_typeof(env) != R_TYPE_environment) { r_abort("`env` must be an environment"); } if (r_typeof(ancestor) != R_TYPE_environment) { r_abort("`ancestor` must be an environment"); } if (r_typeof(top) != R_TYPE_environment) { r_abort("`top` must be an environment"); } if (env == r_envs.empty) { return false; } while (env != top && env != r_envs.empty) { if (env == ancestor) { return true; } env = r_env_parent(env); } return env == ancestor; } r_obj* r_env_until(r_obj* env, r_obj* sym, r_obj* last) { r_obj* stop = r_envs.empty; if (last != r_envs.empty) { stop = r_env_parent(last); } while (true) { if (env == r_envs.empty) { return r_envs.empty; } if (r_env_has(env, sym)) { return env; } r_obj* next = r_env_parent(env); if (next == r_envs.empty || next == stop) { return r_envs.empty; } env = next; } } r_obj* r_env_get_anywhere(r_obj* env, r_obj* sym) { env = r_env_until(env, sym, r_envs.empty); return r_env_get(env, sym); } r_obj* r_env_get_until(r_obj* env, r_obj* sym, r_obj* last) { env = r_env_until(env, sym, last); return r_env_get(env, sym); } bool r_env_has_until(r_obj* env, r_obj* sym, r_obj* last) { env = r_env_until(env, sym, last); return r_env_has(env, sym); } bool r_env_has_missing(r_obj* env, r_obj* sym) { // That's a special primitive so no need to protect `sym` r_obj* call = KEEP(r_call2(missing_prim, sym)); r_obj* out = r_eval(call, env); FREE(1); return r_as_bool(out); } void r_init_rlang_ns_env(void) { rlang_ns_env = r_ns_env("rlang"); } void r_init_library_env(void) { #if R_VERSION < R_Version(4, 1, 0) new_env_call = r_parse_eval("as.call(list(new.env, TRUE, NULL, NULL))", r_envs.base); r_preserve(new_env_call); new_env__parent_node = r_node_cddr(new_env_call); new_env__size_node = r_node_cdr(new_env__parent_node); #endif missing_prim = r_parse_eval("missing", r_envs.base); env2list_call = r_parse("as.list.environment(x, all.names = TRUE)"); r_preserve(env2list_call); list2env_call = r_parse("list2env(x, envir = NULL, parent = y, hash = TRUE)"); r_preserve(list2env_call); exists_call = r_parse("exists(y, envir = x, inherits = z)"); r_preserve(exists_call); remove_call = r_parse("remove(list = y, envir = x, inherits = z)"); r_preserve(remove_call); r_methods_ns_env = r_parse_eval("asNamespace('methods')", r_envs.base); } r_obj* rlang_ns_env = NULL; r_obj* r_methods_ns_env = NULL; #if R_VERSION < R_Version(4, 1, 0) static r_obj* new_env_call = NULL; static r_obj* new_env__parent_node = NULL; static r_obj* new_env__size_node = NULL; #endif static r_obj* exists_call = NULL; static r_obj* remove_call = NULL; static r_obj* env2list_call = NULL; static r_obj* list2env_call = NULL; static r_obj* missing_prim = NULL; lazyeval/src/rlang/vec-lgl.h0000644000176200001440000000034315163675314015510 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_VECTOR_LGL_H #define RLANG_VECTOR_LGL_H #include "rlang-types.h" r_ssize r_lgl_sum(r_obj* x, bool na_true); r_obj* r_lgl_which(r_obj* x, bool na_propagate); #endif lazyeval/src/rlang/c-utils.h0000644000176200001440000001077715163675314015553 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_C_UTILS_H #define RLANG_C_UTILS_H #include "rlang-types.h" #include #include #include #include #include "cnd.h" #define R_ARR_SIZEOF(X) sizeof(X) / sizeof(X[0]) #define R_MIN(a, b) ((a) < (b) ? (a) : (b)) #define R_MAX(a, b) ((a) > (b) ? (a) : (b)) // Like `memset()` with support for multi-byte types #define R_MEM_SET(TYPE, PTR, VALUE, N) do { \ TYPE* v = (PTR); \ TYPE value = (VALUE); \ size_t n = (N); \ for (size_t i = 0; i < n; ++i) { \ v[i] = value; \ } \ } while(0) void* r_shelter_deref(r_obj* x); // Allow integers up to 2^52, same as R_XLEN_T_MAX when long vector // support is enabled #define RLANG_MAX_DOUBLE_INT 4503599627370496 #define RLANG_MIN_DOUBLE_INT -4503599627370496 static inline bool r_dbl_is_whole(double x) { if (x > RLANG_MAX_DOUBLE_INT || x < RLANG_MIN_DOUBLE_INT) { return false; } // C99 guarantees existence of the int_least_N_t types, even on // machines that don't support arithmetic on width N: if (x != (int_least64_t) x) { return false; } return true; } // Adapted from CERT C coding standards static inline intmax_t r__intmax_add(intmax_t x, intmax_t y) { if ((y > 0 && x > (INTMAX_MAX - y)) || (y < 0 && x < (INTMAX_MIN - y))) { r_stop_internal("Values too large to be added."); } return x + y; } static inline intmax_t r__intmax_subtract(intmax_t x, intmax_t y) { if ((y > 0 && x < (INTMAX_MIN + y)) || (y < 0 && x > (INTMAX_MAX + y))) { r_stop_internal("Subtraction resulted in overflow or underflow."); } return x - y; } static inline r_ssize r_ssize_add(r_ssize x, r_ssize y) { intmax_t out = r__intmax_add(x, y); if (out > R_SSIZE_MAX) { r_stop_internal("Result too large for an `r_ssize`."); } return (r_ssize) out; } static inline r_ssize r_ssize_mult(r_ssize x, r_ssize y) { if (x > 0) { if (y > 0) { if (x > (R_SSIZE_MAX / y)) { goto error; } } else { if (y < (R_SSIZE_MIN / x)) { goto error; } } } else { if (y > 0) { if (x < (R_SSIZE_MIN / y)) { goto error; } } else { if ( (x != 0) && (y < (R_SSIZE_MAX / x))) { goto error; } } } return x * y; error: r_stop_internal("Result too large for an `r_ssize`."); } static inline int r_int_min(int x, int y) { return (y < x) ? y : x; } static inline int r_int_max(int x, int y) { return (y < x) ? x : y; } static inline r_ssize r_ssize_min(r_ssize x, r_ssize y) { return (y < x) ? y : x; } static inline r_ssize r_ssize_max(r_ssize x, r_ssize y) { return (y < x) ? x : y; } static inline int r_ssize_as_integer(r_ssize x) { if (x > INT_MAX || x < INT_MIN) { r_stop_internal("Result can't be represented as `int`."); } return (int) x; } static inline double r_ssize_as_double(r_ssize x) { if (x > DBL_MAX || x < -DBL_MAX) { r_stop_internal("Result can't be represented as `double`."); } return (double) x; } static inline r_ssize r_double_as_ssize(double x) { if (x > R_SSIZE_MAX || x < R_SSIZE_MIN) { r_stop_internal("Result can't be represented as `r_ssize`."); } return (r_ssize) x; } static inline double r_double_mult(double x, double y) { double out = x * y; if (!isfinite(out)) { r_stop_internal("Can't multiply double values."); } return out; } // Slightly safer version of `memcpy()` for use with R object memory // // Prefer this over `memcpy()`, especially when providing pointers to R object // memory. As of R 4.5.0, `DATAPTR()` and friends return `(void*) 1` on 0-length // R objects, so we must be extremely careful to never use dereference those // pointers. In particular, it is not safe to call `memcpy(dest, src, 0)` on // some machines (likely with sanitizers active) when either `dest` or `src` // resolve to `(void*) 1`. // // https://github.com/r-lib/vctrs/pull/1968 // https://github.com/r-devel/r-svn/blob/9976c3d7f08c754593d01ba8380afb6be803dde2/src/main/memory.c#L4137-L4150 static inline void r_memcpy(void* dest, const void* src, size_t count) { if (count) { memcpy(dest, src, count); } } // Slightly safer version of `memset()` for use with R object memory // // See `r_memcpy()` for rationale static inline void r_memset(void* dest, int value, size_t count) { if (count) { memset(dest, value, count); } } #endif lazyeval/src/rlang/session.c0000644000176200001440000000276015163675314015642 0ustar liggesusers#include "rlang.h" r_obj* eval_with_x(r_obj* call, r_obj* x); static r_obj* is_installed_call = NULL; bool r_is_installed(const char* pkg) { r_obj* installed = eval_with_x(is_installed_call, KEEP(r_chr(pkg))); bool out = *r_lgl_begin(installed); FREE(1); return out; } static r_obj* has_colour_call = NULL; bool r_has_colour(void) { if (!r_is_installed("crayon")) { return false; } return *r_lgl_begin(r_eval(has_colour_call, r_envs.base)); } void r_init_library_session(void) { is_installed_call = r_parse("requireNamespace(x, quietly = TRUE)"); r_preserve(is_installed_call); has_colour_call = r_parse("crayon::has_color()"); r_preserve(has_colour_call); } #ifdef _WIN32 # include # include r_obj* r_getppid(void) { DWORD pid = GetCurrentProcessId(); HANDLE handle = NULL; PROCESSENTRY32W pe = { 0 }; pe.dwSize = sizeof(PROCESSENTRY32W); handle = CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0); if (handle == INVALID_HANDLE_VALUE) { r_abort("Can't query parent pid."); } if (Process32FirstW(handle, &pe)) { do { if (pe.th32ProcessID == pid) { DWORD ppid = pe.th32ParentProcessID; CloseHandle(handle); return r_int(ppid); } } while (Process32NextW(handle, &pe)); } /* Should not get here */ CloseHandle(handle); r_stop_internal("Can't find my own process."); return r_null; } #else # include r_obj* r_getppid(void) { return r_int(getppid()); } #endif lazyeval/src/rlang/sym.c0000644000176200001440000000263115163675314014764 0ustar liggesusers#include #include "rlang.h" // In old R versions `as.name()` does not translate to native which // loses the encoding. This symbol constructor always translates. r_obj* r_new_symbol(r_obj* x, int* err) { switch (r_typeof(x)) { case SYMSXP: return x; case R_TYPE_character: if (r_length(x) == 1) { const char* string = Rf_translateChar(r_chr_get(x, 0)); return r_sym(string); } // else fallthrough default: { if (err) { *err = -1; return r_null; } else { const char* type = r_type_as_c_string(r_typeof(x)); r_abort("Can't create a symbol with a %s", type); } }} } bool r_is_symbol(r_obj* x, const char* string) { if (r_typeof(x) != SYMSXP) { return false; } else { return strcmp(CHAR(PRINTNAME(x)), string) == 0; } } bool r_is_symbol_any(r_obj* x, const char** strings, int n) { if (r_typeof(x) != SYMSXP) { return false; } const char* name = CHAR(PRINTNAME(x)); for (int i = 0; i < n; ++i) { if (strcmp(name, strings[i]) == 0) { return true; } } return false; } r_obj* (*r_sym_as_utf8_character)(r_obj* x) = NULL; r_obj* (*r_sym_as_utf8_string)(r_obj* x) = NULL; void r_init_library_sym(void) { r_sym_as_utf8_character = (r_obj* (*)(r_obj*)) r_peek_c_callable("rlang", "rlang_sym_as_character"); r_sym_as_utf8_string = (r_obj* (*)(r_obj*)) r_peek_c_callable("rlang", "rlang_sym_as_string"); } lazyeval/src/rlang/vec-lgl.c0000644000176200001440000000556215163675314015513 0ustar liggesusers#include "rlang.h" #include r_ssize r_lgl_sum(r_obj* x, bool na_true) { if (r_typeof(x) != R_TYPE_logical) { r_abort("Internal error: Excepted logical vector in `r_lgl_sum()`"); } const r_ssize n = r_length(x); const int* v_x = r_lgl_cbegin(x); // This can't overflow since `sum` is necessarily smaller or equal // to the vector length expressed in `r_ssize` r_ssize sum = 0; if (na_true) { for (r_ssize i = 0; i < n; ++i) { sum += (bool) v_x[i]; } } else { for (r_ssize i = 0; i < n; ++i) { sum += (v_x[i] == 1); } } return sum; } r_obj* r_lgl_which(r_obj* x, bool na_propagate) { const enum r_type type = r_typeof(x); if (type != R_TYPE_logical) { r_stop_unexpected_type(type); } const r_ssize n = r_length(x); const int* v_x = r_lgl_cbegin(x); const r_ssize out_n = r_lgl_sum(x, na_propagate); if (out_n > INT_MAX) { r_stop_internal("Can't fit result in an integer vector."); } r_obj* out = KEEP(r_alloc_integer(out_n)); int* v_out = r_int_begin(out); r_obj* names = r_names(x); const bool has_names = (names != r_null); if (na_propagate) { if (has_names) { // Mark `NA` locations with negative location for extracting names later for (r_ssize i = 0, j = 0; i < n && j < out_n; ++i) { const int x_elt = v_x[i]; const bool missing = x_elt == r_globals.na_lgl; const int elt = missing * (-i - 1) + !missing * x_elt * (i + 1); v_out[j] = elt; j += (bool) elt; } } else { for (r_ssize i = 0, j = 0; i < n && j < out_n; ++i) { const int x_elt = v_x[i]; const bool missing = x_elt == r_globals.na_lgl; const int elt = missing * r_globals.na_int + !missing * x_elt * (i + 1); v_out[j] = elt; j += (bool) elt; } } } else { for (r_ssize i = 0, j = 0; i < n && j < out_n; ++i) { const int x_elt = v_x[i]; v_out[j] = i + 1; j += (x_elt == 1); } } if (has_names) { r_obj* const* v_names = r_chr_cbegin(names); r_obj* out_names = r_alloc_character(out_n); r_attrib_poke_names(out, out_names); if (na_propagate) { // `v_out` contains negative locations which tells you the location of the // name to extract while also serving as a signal of where `NA`s should go // in the finalized output for (r_ssize i = 0; i < out_n; ++i) { const int loc = v_out[i]; const int abs_loc = abs(loc); const bool same = (loc == abs_loc); v_out[i] = same * loc + !same * r_globals.na_int; r_chr_poke(out_names, i, v_names[abs_loc - 1]); } } else { // `v_out` doesn't contain `NA`, so we can use the locations directly for (r_ssize i = 0; i < out_n; ++i) { const int loc = v_out[i] - 1; r_chr_poke(out_names, i, v_names[loc]); } } } FREE(1); return out; } lazyeval/src/rlang/dots-info.c0000644000176200001440000001202615163675314016055 0ustar liggesusers#include #define RLANG_HAS_R_DOTS_API (R_VERSION >= R_Version(4, 6, 0)) #if !RLANG_HAS_R_DOTS_API static bool is_promise(r_obj* x) { return r_typeof(x) == R_TYPE_promise; } static r_obj* promise_expr(r_obj* x) { return PREXPR(x); } static r_obj* promise_env(r_obj* x) { return PRENV(x); } static r_obj* env_dot_find(r_obj* env, r_ssize i) { if (i < 0) { r_abort("indexing '...' with negative index %d", (int) i); } r_obj* dots = Rf_findVarInFrame(env, r_syms.dots); if (dots == R_UnboundValue) { r_abort("'...' used in an incorrect context"); } if (dots == r_syms.missing || r_typeof(dots) != R_TYPE_dots) { r_abort("the ... list contains fewer than %d elements", (int) i + 1); } for (r_ssize j = 0; j < i; ++j) { dots = r_node_cdr(dots); if (dots == r_null) { r_abort("the ... list contains fewer than %d elements", (int) i + 1); } } return r_node_car(dots); } #endif // Dots API - mirrors R-devel PR #209 --- // See https://github.com/r-devel/r-svn/pull/209 // R API: R_DotsExist bool r_env_dots_exist(r_obj* env) { #if RLANG_HAS_R_DOTS_API return R_DotsExist(env); #else r_obj* dots = Rf_findVarInFrame(env, r_syms.dots); return dots != R_UnboundValue && (dots == r_syms.missing || r_typeof(dots) == R_TYPE_dots); #endif } r_obj* r_env_until_dots(r_obj* env) { while (env != r_envs.empty) { if (r_env_dots_exist(env)) { return env; } env = r_env_parent(env); } return r_envs.empty; } // R API: R_DotsLength r_ssize r_env_dots_length(r_obj* env) { #if RLANG_HAS_R_DOTS_API return (r_ssize) R_DotsLength(env); #else r_obj* dots = Rf_findVarInFrame(env, r_syms.dots); if (dots == R_UnboundValue) { r_abort("incorrect context: the current call has no '...' to look in"); } if (dots == r_syms.missing || r_typeof(dots) != R_TYPE_dots) { return 0; } return r_length(dots); #endif } // R API: R_DotsNames // Returns NULL when all dots are unnamed. r_obj* r_env_dots_names(r_obj* env) { #if RLANG_HAS_R_DOTS_API return R_DotsNames(env); #else r_obj* dots = KEEP(Rf_findVarInFrame(env, r_syms.dots)); if (dots == R_UnboundValue) { r_abort("incorrect context: the current call has no '...' to look in"); } r_ssize n = (dots == r_syms.missing || r_typeof(dots) != R_TYPE_dots) ? 0 : r_length(dots); r_obj* out = r_null; for (r_ssize i = 0; i < n; ++i) { r_obj* tag = r_node_tag(dots); if (r_typeof(tag) == R_TYPE_symbol) { if (out == r_null) { out = KEEP(r_alloc_character(n)); } r_chr_poke(out, i, r_sym_string(tag)); } dots = r_node_cdr(dots); } if (out != r_null) { FREE(1); } FREE(1); return out; #endif } // R API: R_DotsElt r_obj* r_env_dot_get(r_obj* env, r_ssize i) { if (r_env_dot_type(env, i) == DOT_TYPE_missing) { return r_missing_arg; } #if RLANG_HAS_R_DOTS_API return R_DotsElt((int)(i + 1), env); #else r_obj* elt = env_dot_find(env, i); return r_eval(elt, env); #endif } // R API: R_GetDotType r_dot_type_t r_env_dot_type(r_obj* env, r_ssize i) { #if RLANG_HAS_R_DOTS_API return (r_dot_type_t) R_GetDotType((int)(i + 1), env); #else r_obj* elt = env_dot_find(env, i); if (elt == r_syms.missing) { return DOT_TYPE_missing; } if (!is_promise(elt)) { return DOT_TYPE_value; } bool forced; rlang_promise_unwrap(elt, &forced); if (forced) { return DOT_TYPE_forced; } return DOT_TYPE_delayed; #endif } // R API: R_DotDelayedExpression r_obj* r_env_dot_delayed_expr(r_obj* env, r_ssize i) { #if RLANG_HAS_R_DOTS_API return R_DotDelayedExpression((int)(i + 1), env); #else r_obj* elt = env_dot_find(env, i); if (!is_promise(elt)) { r_abort("not a delayed ... element"); } bool forced; r_obj* inner = rlang_promise_unwrap(elt, &forced); if (forced) { r_abort("not a delayed ... element"); } return promise_expr(inner); #endif } // R API: R_DotDelayedEnvironment r_obj* r_env_dot_delayed_env(r_obj* env, r_ssize i) { #if RLANG_HAS_R_DOTS_API return R_DotDelayedEnvironment((int)(i + 1), env); #else r_obj* elt = env_dot_find(env, i); if (!is_promise(elt)) { r_abort("not a delayed ... element"); } bool forced; r_obj* inner = rlang_promise_unwrap(elt, &forced); if (forced) { r_abort("not a delayed ... element"); } return promise_env(inner); #endif } // R API: R_DotForcedExpression r_obj* r_env_dot_forced_expr(r_obj* env, r_ssize i) { #if RLANG_HAS_R_DOTS_API return R_DotForcedExpression((int)(i + 1), env); #else r_obj* elt = env_dot_find(env, i); if (!is_promise(elt)) { r_abort("not a forced ... element"); } bool forced; r_obj* inner = rlang_promise_unwrap(elt, &forced); if (!forced) { r_abort("not a forced ... element"); } return promise_expr(inner); #endif } lazyeval/src/rlang/stack.c0000644000176200001440000000504515163675314015263 0ustar liggesusers#include "rlang.h" #include "decl/stack-decl.h" void r_on_exit(r_obj* expr, r_obj* frame) { static r_obj* on_exit_prim = NULL; if (!on_exit_prim) { on_exit_prim = r_base_ns_get("on.exit"); } r_obj* args = r_pairlist2(expr, r_lgl(1)); r_obj* lang = KEEP(r_new_call(on_exit_prim, args)); r_eval(lang, frame); FREE(1); } r_obj* r_peek_frame(void) { return r_eval(peek_frame_call, r_envs.base); } r_obj* r_caller_env(r_obj* n) { if (r_typeof(n) != R_TYPE_environment) { r_stop_internal("`n` must be an environment."); } return r_eval(caller_env_call, n); } static r_obj* sys_frame_call = NULL; static r_obj* sys_call_call = NULL; static int* sys_frame_n_addr = NULL; static int* sys_call_n_addr = NULL; r_obj* r_sys_frame(int n, r_obj* frame) { int n_kept = 0; if (!frame) { frame = r_peek_frame(); KEEP_N(frame, &n_kept); } *sys_frame_n_addr = n; SEXP value = r_eval(sys_frame_call, frame); FREE(n_kept); return value; } r_obj* r_sys_call(int n, r_obj* frame) { int n_kept = 0; if (!frame) { frame = r_peek_frame(); KEEP_N(frame, &n_kept); } *sys_call_n_addr = n; SEXP value = r_eval(sys_call_call, frame); FREE(n_kept); return value; } static r_obj* generate_sys_call(const char* name, int** n_addr) { r_obj* sys_n = KEEP(r_int(0)); *n_addr = r_int_begin(sys_n); r_obj* sys_args = KEEP(r_new_node(sys_n, r_null)); r_obj* sys_call = KEEP(r_new_call(r_base_ns_get(name), sys_args)); r_preserve(sys_call); FREE(3); return sys_call; } void r_init_library_stack(void) { // `sys.frame(sys.nframe())` doesn't work because `sys.nframe()` // returns the number of the frame in which evaluation occurs. It // doesn't return the number of frames on the stack. So we'd need // to evaluate it in the last frame on the stack which is what we // are looking for to begin with. We use instead this workaround: // Call `sys.frame()` from a closure to push a new frame on the // stack, and use negative indexing to get the previous frame. r_obj* current_frame_body = KEEP(r_parse("sys.frame(-1)")); r_obj* current_frame_fn = KEEP(r_new_function(r_null, current_frame_body, r_envs.base)); peek_frame_call = r_new_call(current_frame_fn, r_null); r_preserve(peek_frame_call); FREE(2); sys_frame_call = generate_sys_call("sys.frame", &sys_frame_n_addr); sys_call_call = generate_sys_call("sys.call", &sys_call_n_addr); caller_env_call = r_parse("parent.frame()"); r_preserve_global(caller_env_call); } static r_obj* peek_frame_call = NULL; static r_obj* caller_env_call = NULL; lazyeval/src/rlang/eval.c0000644000176200001440000001100715163675314015100 0ustar liggesusers#include "rlang.h" r_obj* r_eval_with_x(r_obj* call, r_obj* x, r_obj* parent) { r_obj* env = KEEP(r_alloc_environment(1, parent)); r_env_bind(env, r_syms.x, x); r_obj* out = r_eval(call, env); FREE(1); return out; } r_obj* r_eval_with_xy(r_obj* call, r_obj* x, r_obj* y, r_obj* parent) { r_obj* env = KEEP(r_alloc_environment(2, parent)); r_env_bind(env, r_syms.x, x); r_env_bind(env, r_syms.y, y); r_obj* out = r_eval(call, env); FREE(1); return out; } r_obj* r_eval_with_xyz(r_obj* call, r_obj* x, r_obj* y, r_obj* z, r_obj* parent) { r_obj* env = KEEP(r_alloc_environment(3, parent)); r_env_bind(env, r_syms.x, x); r_env_bind(env, r_syms.y, y); r_env_bind(env, r_syms.z, z); r_obj* out = r_eval(call, env); FREE(1); return out; } r_obj* r_eval_with_wxyz(r_obj* call, r_obj* w, r_obj* x, r_obj* y, r_obj* z, r_obj* parent) { r_obj* env = KEEP(r_alloc_environment(4, parent)); r_env_bind(env, r_syms.w, w); r_env_bind(env, r_syms.x, x); r_env_bind(env, r_syms.y, y); r_env_bind(env, r_syms.z, z); r_obj* out = r_eval(call, env); FREE(1); return out; } // Evaluate call with a preallocated environment containing a single // `x` binding and inheriting from base env. // // Since this has side effects, it should not be used when there is a // chance of recursing into the C library. It should only be used to // evaluate pure R calls or functions from other packages, such as the // base package. static r_obj* shared_x_env; static r_obj* shared_xy_env; static r_obj* shared_xyz_env; r_obj* eval_with_x(r_obj* call, r_obj* x) { r_env_bind(shared_x_env, r_syms.x, x); r_obj* out = KEEP(r_eval(call, shared_x_env)); // Release for gc r_env_bind(shared_x_env, r_syms.x, r_null); FREE(1); return out; } r_obj* eval_with_xy(r_obj* call, r_obj* x, r_obj* y) { r_env_bind(shared_xy_env, r_syms.x, x); r_env_bind(shared_xy_env, r_syms.y, y); r_obj* out = KEEP(r_eval(call, shared_xy_env)); // Release for gc r_env_bind(shared_xy_env, r_syms.x, r_null); r_env_bind(shared_xy_env, r_syms.y, r_null); FREE(1); return out; } r_obj* eval_with_xyz(r_obj* call, r_obj* x, r_obj* y, r_obj* z) { r_env_bind(shared_xyz_env, r_syms.x, x); r_env_bind(shared_xyz_env, r_syms.y, y); r_env_bind(shared_xyz_env, r_syms.z, z); r_obj* out = KEEP(r_eval(call, shared_xyz_env)); // Release for gc r_env_bind(shared_xyz_env, r_syms.x, r_null); r_env_bind(shared_xyz_env, r_syms.y, r_null); r_env_bind(shared_xyz_env, r_syms.z, r_null); FREE(1); return out; } r_obj* r_exec_mask_n(r_obj* fn_sym, r_obj* fn, const struct r_pair* args, int n, r_obj* parent) { r_obj* mask = KEEP(r_alloc_environment(n + 1, parent)); r_obj* call = KEEP(r_exec_mask_n_call_poke(fn_sym, fn, args, n, mask)); r_obj* out = r_eval(call, mask); FREE(2); return out; } r_obj* r_exec_n(r_obj* fn_sym, r_obj* fn, const struct r_pair* args, int n, r_obj* env) { r_obj* call = KEEP(r_exec_mask_n_call_poke(fn_sym, fn, args, n, env)); r_obj* out = r_eval(call, env); FREE(1); return out; } // Create a call from arguments and poke elements with a non-NULL // symbol in `env`. Symbolic arguments are protected from evaluation // with `quote()`. r_obj* r_exec_mask_n_call_poke(r_obj* fn_sym, r_obj* fn, const struct r_pair* args, int n, r_obj* env) { if (fn_sym != r_null) { r_env_bind(env, fn_sym, fn); fn = fn_sym; } r_obj* list = KEEP(r_new_pairlist(args, n, NULL)); r_obj* node = list; while (node != r_null) { r_obj* car = r_node_car(node); r_obj* tag = r_node_tag(node); if (tag == r_null) { // If symbol is not supplied, protect symbolic arguments from // evaluation. If supplied this is not needed because of the // masking. r_node_poke_car(node, r_expr_protect(car)); } else { // If symbol is supplied, assign the value in the environment and // use the symbol instead of the value in the list of arguments r_env_bind(env, tag, car); r_node_poke_car(node, tag); } node = r_node_cdr(node); } r_obj* call = r_new_call(fn, list); FREE(1); return call; } void r_init_library_eval(void) { r_lazy_missing_arg = (struct r_lazy) { .x = r_missing_arg, .env = r_null }; } struct r_lazy r_lazy_null = { 0 }; struct r_lazy r_lazy_missing_arg = { 0 }; lazyeval/src/rlang/dyn-array.c0000644000176200001440000000575315163675314016072 0ustar liggesusers#include #include "dyn-array.h" #define R_DYN_ARRAY_GROWTH_FACTOR 2 static r_obj* dyn_array_class = NULL; struct r_dyn_array* r_new_dyn_vector(enum r_type type, r_ssize capacity) { r_obj* shelter = KEEP(r_alloc_list(2)); r_attrib_poke_class(shelter, dyn_array_class); r_obj* vec_raw = r_alloc_raw(sizeof(struct r_dyn_array)); r_list_poke(shelter, 0, vec_raw); r_obj* vec_data = r_alloc_vector(type, capacity); r_list_poke(shelter, 1, vec_data); struct r_dyn_array* p_vec = r_raw_begin(vec_raw); p_vec->shelter = shelter; p_vec->count = 0; p_vec->capacity = capacity; p_vec->growth_factor = R_DYN_ARRAY_GROWTH_FACTOR; p_vec->type = type; p_vec->elt_byte_size = r_vec_elt_sizeof0(type); p_vec->data = vec_data; switch (type) { case R_TYPE_character: p_vec->v_data = NULL; p_vec->barrier_set = &r_chr_poke; break; case R_TYPE_list: p_vec->v_data = NULL; p_vec->barrier_set = &r_list_poke; break; default: p_vec->barrier_set = NULL; p_vec->v_data = r_vec_begin0(type, vec_data); break; } p_vec->v_data_const = r_vec_cbegin0(type, vec_data); FREE(1); return p_vec; } r_obj* r_dyn_unwrap(struct r_dyn_array* p_arr) { if (p_arr->type == R_TYPE_raw) { return r_raw_resize(p_arr->data, p_arr->count * p_arr->elt_byte_size); } else { return r_vec_resize0(p_arr->type, p_arr->data, p_arr->count); } } struct r_dyn_array* r_new_dyn_array(r_ssize elt_byte_size, r_ssize capacity) { r_ssize arr_byte_size = r_ssize_mult(capacity, elt_byte_size); struct r_dyn_array* p_arr = r_new_dyn_vector(R_TYPE_raw, arr_byte_size); p_arr->capacity = capacity; p_arr->elt_byte_size = elt_byte_size; return p_arr; } void r_dyn_push_back(struct r_dyn_array* p_arr, const void* p_elt) { r_ssize loc = r__dyn_increment(p_arr); if (p_arr->barrier_set) { r_obj* value = *((r_obj* const *) p_elt); p_arr->barrier_set(p_arr->data, loc, value); } else if (p_elt) { r_memcpy(r_dyn_last(p_arr), p_elt, p_arr->elt_byte_size); } else { r_memset(r_dyn_last(p_arr), 0, p_arr->elt_byte_size); } } void r_dyn_resize(struct r_dyn_array* p_arr, r_ssize capacity) { enum r_type type = p_arr->type; r_ssize capacity_multiplier = p_arr->type == R_TYPE_raw ? r_ssize_mult(p_arr->elt_byte_size, capacity) : capacity; r_obj* data = r_vec_resize0(type, r_list_get(p_arr->shelter, 1), capacity_multiplier); r_list_poke(p_arr->shelter, 1, data); p_arr->count = r_ssize_min(p_arr->count, capacity); p_arr->capacity = capacity; p_arr->data = data; switch (type) { case R_TYPE_character: case R_TYPE_list: break; default: p_arr->v_data = r_vec_begin0(type, data); break; } p_arr->v_data_const = r_vec_cbegin0(type, data); } void r_init_library_dyn_array(void) { r_preserve_global(dyn_array_class = r_chr("rlang_dyn_array")); } lazyeval/src/rlang/env-binding.h0000644000176200001440000000303715163675314016362 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_ENV_BINDING_H #define RLANG_ENV_BINDING_H #include "rlang-types.h" enum r_env_binding_type { R_ENV_BINDING_TYPE_unbound = 0, R_ENV_BINDING_TYPE_value = 1, R_ENV_BINDING_TYPE_missing = 2, R_ENV_BINDING_TYPE_delayed = 3, R_ENV_BINDING_TYPE_forced = 4, R_ENV_BINDING_TYPE_active = 5 }; enum r_env_binding_type r_env_binding_type(r_obj* env, r_obj* sym); r_obj* r_env_binding_types(r_obj* env, r_obj* syms); r_obj* r_env_syms(r_obj* env); r_obj* r_env_get(r_obj* env, r_obj* sym); // Binding constructors static inline void r_env_bind(r_obj* env, r_obj* sym, r_obj* value) { // See rchk concerns in https://github.com/r-lib/rlang/commit/28ce7b01 KEEP(value); Rf_defineVar(sym, value, env); FREE(1); } // Silently ignores bindings that are not defined in `env`. static inline void r_env_unbind(r_obj* env, r_obj* sym) { R_removeVarFromFrame(sym, env); } void r_env_bind_active(r_obj* env, r_obj* sym, r_obj* fn); void r_env_bind_delayed(r_obj* env, r_obj* sym, r_obj* expr, r_obj* eval_env); void r_env_bind_forced(r_obj* env, r_obj* sym, r_obj* expr, r_obj* value); void r_env_bind_missing(r_obj* env, r_obj* sym); // Delayed binding accessors r_obj* r_env_binding_delayed_expr(r_obj* env, r_obj* sym); r_obj* r_env_binding_delayed_env(r_obj* env, r_obj* sym); // Forced binding accessors r_obj* r_env_binding_forced_expr(r_obj* env, r_obj* sym); // Active binding accessors r_obj* r_env_binding_active_fn(r_obj* env, r_obj* sym); void r_init_library_env_binding(void); #endif lazyeval/src/rlang/rlang.hpp0000644000176200001440000000065515163675314015630 0ustar liggesusers#ifndef RLANG_RLANG_HPP #define RLANG_RLANG_HPP #include #define R_NO_REMAP #include extern "C" { #include } static inline r_no_return void rcc_abort(const char* fn) { try { throw; } catch (const std::exception& err) { r_abort(err.what()); } catch (...) { r_obj* call = KEEP(r_call(r_sym(fn))); (r_stop_internal)("", -1, call, "Caught unknown C++ exception."); } } #endif lazyeval/src/rlang/dyn-list-of.h0000644000176200001440000000325615163675314016332 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_DYN_LIST_OF_H #define RLANG_DYN_LIST_OF_H #include "rlang-types.h" #include "dyn-array.h" struct r_dyn_list_of { r_obj* shelter; r_ssize count; r_ssize capacity; int growth_factor; // Contains the addresses and sizes of each element of the // list-of. If you copy that pointer, consider it invalid after a // push because it might have moved in memory due to a resize. struct r_pair_ptr_ssize* v_data; // private: r_ssize width; enum r_type type; r_ssize elt_byte_size; r_obj* reserve; void* v_reserve; struct r_dyn_array* p_moved_arr; struct r_dyn_array* p_moved_shelter_arr; r_obj* arr_locs; r_ssize* v_arr_locs; struct r_dyn_array* p_arrays; }; struct r_dyn_list_of* r_new_dyn_list_of(enum r_type type, r_ssize capacity, r_ssize width); r_obj* r_lof_unwrap(struct r_dyn_list_of* p_lof); void r_lof_push_back(struct r_dyn_list_of* p_lof); void r_lof_arr_push_back(struct r_dyn_list_of* p_lof, r_ssize i, void* p_elt); static inline void* r_lof_arr_ptr(struct r_dyn_list_of* p_lof, r_ssize i, r_ssize j) { r_ssize offset = j * p_lof->elt_byte_size; struct r_pair_ptr_ssize* v_arrays = (struct r_pair_ptr_ssize*) r_dyn_pointer(p_lof->p_arrays, i); return ((unsigned char*) v_arrays->ptr) + offset; } static inline void* r_lof_arr_ptr_front(struct r_dyn_list_of* p_lof, r_ssize i) { return r_lof_arr_ptr(p_lof, i, 0); } static inline void* r_lof_arr_ptr_back(struct r_dyn_list_of* p_lof, r_ssize i) { return r_lof_arr_ptr(p_lof, i, p_lof->count - 1); } #endif lazyeval/src/rlang/stack.h0000644000176200001440000000057515163675314015273 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_STACK_H #define RLANG_STACK_H #include "rlang-types.h" void r_on_exit(r_obj* expr, r_obj* frame); r_obj* r_peek_frame(void); r_obj* r_caller_env(r_obj* n); r_obj* r_sys_frame(int n, r_obj* frame); r_obj* r_sys_call(int n, r_obj* frame); static inline void r_yield_interrupt(void) { R_CheckUserInterrupt(); } #endif lazyeval/src/rlang/env.h0000644000176200001440000000476015163675314014756 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_ENV_H #define RLANG_ENV_H #include "rlang-types.h" #include "cnd.h" #include "globals.h" #include "obj.h" #define RLANG_USE_R_EXISTS (R_VERSION < R_Version(4, 2, 0)) extern r_obj* r_methods_ns_env; static inline r_obj* r_env_names(r_obj* env) { return R_lsInternal3(env, TRUE, FALSE); } static inline r_ssize r_env_length(r_obj* env) { if (r_typeof(env) != R_TYPE_environment) { r_abort("Expected an environment"); } return Rf_xlength(env); } static inline r_obj* r_env_parent(r_obj* env) { if (env == r_envs.empty) { r_stop_internal("Can't take the parent of the empty environment."); } #if R_VERSION >= R_Version(4, 5, 0) return R_ParentEnv(env); #else return ENCLOS(env); #endif } static inline bool r_is_environment(r_obj* x) { return TYPEOF(x) == ENVSXP; } static inline bool r_is_namespace(r_obj* x) { return R_IsNamespaceEnv(x); } r_obj* r_env_until(r_obj* env, r_obj* sym, r_obj* last); r_obj* r_env_get_anywhere(r_obj* env, r_obj* sym); r_obj* r_env_get_until(r_obj* env, r_obj* sym, r_obj* last); bool r_env_has_until(r_obj* env, r_obj* sym, r_obj* last); static inline bool r_env_has(r_obj* env, r_obj* sym) { #if RLANG_USE_R_EXISTS bool r__env_has(r_obj*, r_obj*); return r__env_has(env, sym); #else return R_existsVarInFrame(env, sym); #endif } static inline bool r_env_has_anywhere(r_obj* env, r_obj* sym) { #if RLANG_USE_R_EXISTS bool r__env_has_anywhere(r_obj*, r_obj*); return r__env_has_anywhere(env, sym); #else while (env != r_envs.empty) { if (r_env_has(env, sym)) { return true; } env = r_env_parent(env); } return false; #endif } bool r_env_has_missing(r_obj* env, r_obj* sym); r_obj* r_ns_env(const char* pkg); r_obj* r_base_ns_get(const char* name); r_obj* r_alloc_environment(r_ssize size, r_obj* parent); static inline r_obj* r_alloc_empty_environment(r_obj* parent) { // Non-hashed environment. // Very fast and useful when you aren't getting/setting from the result. #if R_VERSION >= R_Version(4, 1, 0) const int hash = 0; const int size = 0; // Not used when `hash = 0` return R_NewEnv(parent, hash, size); #else r_obj* env = Rf_allocSExp(R_TYPE_environment); SET_ENCLOS(env, parent); return env; #endif } r_obj* r_env_as_list(r_obj* x); r_obj* r_list_as_environment(r_obj* x, r_obj* parent); r_obj* r_env_clone(r_obj* env, r_obj* parent); void r_env_coalesce(r_obj* env, r_obj* from); bool r_env_inherits(r_obj* env, r_obj* ancestor, r_obj* top); #endif lazyeval/src/rlang/cnd.c0000644000176200001440000001136115163675314014720 0ustar liggesusers#include "rlang.h" #include "decl/cnd-decl.h" #define BUFSIZE 8192 #define INTERP(BUF, FMT, DOTS) \ { \ va_list dots; \ va_start(dots, FMT); \ vsnprintf(BUF, BUFSIZE, FMT, dots); \ va_end(dots); \ \ BUF[BUFSIZE - 1] = '\0'; \ } static r_obj* msg_call = NULL; void r_inform(const char* fmt, ...) { char buf[BUFSIZE]; INTERP(buf, fmt, ...); r_eval_with_x(msg_call, KEEP(r_chr(buf)), r_envs.ns); FREE(1); } static r_obj* wng_call = NULL; void r_warn(const char* fmt, ...) { char buf[BUFSIZE]; INTERP(buf, fmt, ...); r_eval_with_x(wng_call, KEEP(r_chr(buf)), r_envs.ns); FREE(1); } static r_obj* err_call = NULL; void r_abort(const char* fmt, ...) { char buf[BUFSIZE]; INTERP(buf, fmt, ...); r_obj* message = KEEP(r_chr(buf)); // Evaluate in a mask but forward error call to the current frame r_obj* frame = KEEP(r_peek_frame()); r_obj* mask = KEEP(r_alloc_environment(2, frame)); r_env_bind(mask, r_syms.error_call_flag, frame); struct r_pair args[] = { { r_syms.message, message } }; r_exec_n(r_null, r_syms.abort, args, R_ARR_SIZEOF(args), mask); while (1); // No return } r_no_return void r_abort_n(const struct r_pair* args, int n) { r_exec_mask_n(r_null, r_syms.abort, args, n, r_peek_frame()); r_stop_unreachable(); } r_no_return void r_abort_call(r_obj* call, const char* fmt, ...) { char buf[BUFSIZE]; INTERP(buf, fmt, ...); r_obj* message = KEEP(r_chr(buf)); struct r_pair args[] = { { r_syms.message, message }, { r_syms.call, call } }; r_obj* frame = KEEP(r_peek_frame()); r_exec_mask_n(r_null, r_syms.abort, args, R_ARR_SIZEOF(args), frame); r_stop_unreachable(); } void r_cnd_signal(r_obj* cnd) { r_eval_with_x(cnd_signal_call, cnd, r_envs.base); } // For `R_interrupts_suspended` #include #include #ifdef _WIN32 #include void r_interrupt(void) { UserBreak = 1; R_CheckUserInterrupt(); } #else #include void r_interrupt(void) { Rf_onintr(); } #endif enum r_cnd_type r_cnd_type(r_obj* cnd) { r_obj* classes = r_class(cnd); if (r_typeof(cnd) != R_TYPE_list || r_typeof(classes) != R_TYPE_character) { goto error; } r_obj* const * v_classes = r_chr_cbegin(classes); r_ssize n_classes = r_length(classes); for (r_ssize i = n_classes - 2; i >= 0; --i) { r_obj* class_str = v_classes[i]; if (class_str == r_strs.error) { return R_CND_TYPE_error; } if (class_str == r_strs.warning) { return R_CND_TYPE_warning; } if (class_str == r_strs.message) { return R_CND_TYPE_message; } if (class_str == r_strs.interrupt) { return R_CND_TYPE_interrupt; } } if (r_inherits(cnd, "condition")) { return R_CND_TYPE_condition; } error: r_abort("`cnd` is not a condition object."); } void r_init_library_cnd(void) { msg_call = r_parse("message(x)"); r_preserve(msg_call); wng_call = r_parse("warning(x, call. = FALSE)"); r_preserve(wng_call); err_call = r_parse("rlang::abort(x)"); r_preserve(err_call); cnd_signal_call = r_parse("rlang::cnd_signal(x)"); r_preserve(cnd_signal_call); // Silence "'noreturn' attribute does not apply to types warning". // It seems like GCC doesn't handle attributes in casts so we need // to cast through a typedef. // https://stackoverflow.com/questions/9441262/function-pointer-to-attribute-const-function typedef r_no_return void (*r_stop_internal_t)(const char*, int, r_obj*, const char* fmt, ...); r_stop_internal = (r_stop_internal_t) R_GetCCallable("rlang", "rlang_stop_internal2"); r_format_error_arg = (const char* (*)(r_obj*)) r_peek_c_callable("rlang", "rlang_format_error_arg"); r_obj_type_friendly_full = (const char* (*)(r_obj*, bool, bool)) r_peek_c_callable("rlang", "rlang_obj_type_friendly_full"); } r_no_return void (*r_stop_internal)(const char* file, int line, r_obj* call, const char* fmt, ...) = NULL; static r_obj* cnd_signal_call = NULL; const char* (*r_format_error_arg)(r_obj* arg) = NULL; const char* (*r_obj_type_friendly_full)(r_obj* x, bool value, bool length) = NULL; const char* r_format_lazy_error_arg(struct r_lazy arg) { r_obj* ffi_arg = KEEP(r_lazy_eval(arg)); const char* out = r_format_error_arg(ffi_arg); FREE(1); return out; } lazyeval/src/rlang/env-binding.c0000644000176200001440000001622715163675314016362 0ustar liggesusers#include "rlang.h" #include "env.h" #include "decl/env-binding-decl.h" // https://bugs.r-project.org/show_bug.cgi?id=18928 #define RLANG_HAS_R_BINDING_API (R_VERSION >= R_Version(4, 6, 0)) #if !RLANG_HAS_R_BINDING_API static inline r_obj* env_find(r_obj* env, r_obj* sym) { return Rf_findVarInFrame3(env, sym, FALSE); } #endif static r_obj* new_binding_types(r_ssize n) { r_obj* types = r_alloc_integer(n); int* types_ptr = r_int_begin(types); r_memset(types_ptr, 0, n * sizeof *types_ptr); return types; } static inline r_obj* binding_as_sym(bool list, r_obj* bindings, r_ssize i) { if (list) { r_obj* out = r_list_get(bindings, i); if (r_typeof(out) != R_TYPE_symbol) { r_abort("Binding must be a symbol."); } return out; } else { return r_str_as_symbol(r_chr_get(bindings, i)); } } static r_ssize detect_special_binding(r_obj* env, r_obj* bindings, bool symbols) { r_ssize n = r_length(bindings); for (r_ssize i = 0; i < n; ++i) { r_obj* sym = binding_as_sym(symbols, bindings, i); enum r_env_binding_type type = r_env_binding_type(env, sym); if (type == R_ENV_BINDING_TYPE_active || type == R_ENV_BINDING_TYPE_delayed) { return i; } } return -1; } // Returns NULL if all values to spare an alloc r_obj* r_env_binding_types(r_obj* env, r_obj* bindings) { if (r_typeof(env) != R_TYPE_environment) { r_abort("Expected environment in promise binding predicate."); } bool symbols; switch (r_typeof(bindings)) { case R_TYPE_list: symbols = true; break; case R_TYPE_character: symbols = false; break; default: r_abort("Internal error: Unexpected `bindings` type in `r_env_binding_types()`"); } r_ssize i = detect_special_binding(env, bindings, symbols); if (i < 0) { return r_null; } r_ssize n = r_length(bindings); r_obj* types = KEEP(new_binding_types(n)); int* types_ptr = r_int_begin(types); // Fill value type for bindings before first special binding for (r_ssize j = 0; j < i; ++j) { *types_ptr = R_ENV_BINDING_TYPE_value; ++types_ptr; } while (i < n) { r_obj* sym = binding_as_sym(symbols, bindings, i); *types_ptr = r_env_binding_type(env, sym); ++i; ++types_ptr; } FREE(1); return types; } // R API: R_envSymbols r_obj* r_env_syms(r_obj* env) { #if RLANG_HAS_R_BINDING_API return R_envSymbols(env); #else // This does an extra alloc, as does the initial implementation in https://github.com/r-devel/r-svn/commit/ee6dc5080845f911d7a884398213d22f3de63fe2 r_obj* nms = KEEP(r_env_names(env)); r_ssize n = r_length(nms); r_obj* out = KEEP(r_alloc_list(n)); r_obj* const * v_nms = r_chr_cbegin(nms); for (r_ssize i = 0; i < n; ++i) { r_list_poke(out, i, r_str_as_symbol(v_nms[i])); } FREE(2); return out; #endif } // Binding type API // Implements future R API from https://bugs.r-project.org/show_bug.cgi?id=18928 enum r_env_binding_type r_env_binding_type(r_obj* env, r_obj* sym) { #if RLANG_HAS_R_BINDING_API switch (R_GetBindingType(sym, env)) { case R_BindingTypeUnbound: return R_ENV_BINDING_TYPE_unbound; case R_BindingTypeValue: return R_ENV_BINDING_TYPE_value; case R_BindingTypeMissing: return R_ENV_BINDING_TYPE_missing; case R_BindingTypeDelayed: return R_ENV_BINDING_TYPE_delayed; case R_BindingTypeForced: return R_ENV_BINDING_TYPE_forced; case R_BindingTypeActive: return R_ENV_BINDING_TYPE_active; } r_stop_unreachable(); #else // Active binding check must come first since `r_env_find()` triggers them if (R_BindingIsActive(sym, env)) { return R_ENV_BINDING_TYPE_active; } r_obj* value = env_find(env, sym); if (value == R_UnboundValue) { return R_ENV_BINDING_TYPE_unbound; } if (value == r_missing_arg) { return R_ENV_BINDING_TYPE_missing; } if (r_typeof(value) == R_TYPE_promise) { bool forced; rlang_promise_unwrap(value, &forced); if (forced) { return R_ENV_BINDING_TYPE_forced; } return R_ENV_BINDING_TYPE_delayed; } return R_ENV_BINDING_TYPE_value; #endif } r_obj* r_env_get(r_obj* env, r_obj* sym) { enum r_env_binding_type type = r_env_binding_type(env, sym); if (type == R_ENV_BINDING_TYPE_unbound) { r_abort("object '%s' not found", r_sym_c_string(sym)); } if (type == R_ENV_BINDING_TYPE_missing) { return r_missing_arg; } #if R_VERSION >= R_Version(4, 5, 0) return R_getVar(sym, env, FALSE); #else r_obj* value = env_find(env, sym); if (r_typeof(value) == R_TYPE_dots) { return value; } // Handles value, delayed, forced, and active bindings return Rf_eval(sym, env); #endif } // Binding constructors void r_env_bind_active(r_obj* env, r_obj* sym, r_obj* fn) { KEEP(fn); r_env_unbind(env, sym); R_MakeActiveBinding(sym, fn, env); FREE(1); } void r_env_bind_delayed(r_obj* env, r_obj* sym, r_obj* expr, r_obj* eval_env) { #if RLANG_HAS_R_BINDING_API R_MakeDelayedBinding(sym, expr, eval_env, env); #else r_obj* promise = KEEP(Rf_allocSExp(PROMSXP)); SET_PRCODE(promise, expr); SET_PRENV(promise, eval_env); SET_PRVALUE(promise, R_UnboundValue); Rf_defineVar(sym, promise, env); FREE(1); #endif } void r_env_bind_forced(r_obj* env, r_obj* sym, r_obj* expr, r_obj* value) { #if RLANG_HAS_R_BINDING_API R_MakeForcedBinding(sym, expr, value, env); #else r_obj* promise = KEEP(Rf_allocSExp(PROMSXP)); SET_PRCODE(promise, expr); SET_PRENV(promise, r_null); SET_PRVALUE(promise, value); Rf_defineVar(sym, promise, env); FREE(1); #endif } void r_env_bind_missing(r_obj* env, r_obj* sym) { #if RLANG_HAS_R_BINDING_API R_MakeMissingBinding(sym, env); #else Rf_defineVar(sym, r_missing_arg, env); #endif } // Delayed binding accessors r_obj* r_env_binding_delayed_expr(r_obj* env, r_obj* sym) { #if RLANG_HAS_R_BINDING_API return R_DelayedBindingExpression(sym, env); #else r_obj* value = env_find(env, sym); if (r_typeof(value) != R_TYPE_promise) { r_abort("not a delayed binding"); } bool forced; r_obj* inner = rlang_promise_unwrap(value, &forced); if (forced) { r_abort("not a delayed binding"); } return R_PromiseExpr(inner); #endif } r_obj* r_env_binding_delayed_env(r_obj* env, r_obj* sym) { #if RLANG_HAS_R_BINDING_API return R_DelayedBindingEnvironment(sym, env); #else r_obj* value = env_find(env, sym); if (r_typeof(value) != R_TYPE_promise) { r_abort("not a delayed binding"); } bool forced; r_obj* inner = rlang_promise_unwrap(value, &forced); if (forced) { r_abort("not a delayed binding"); } return PRENV(inner); #endif } // Forced binding accessors r_obj* r_env_binding_forced_expr(r_obj* env, r_obj* sym) { #if RLANG_HAS_R_BINDING_API return R_ForcedBindingExpression(sym, env); #else r_obj* value = env_find(env, sym); if (r_typeof(value) != R_TYPE_promise) { r_abort("not a forced binding"); } bool forced; r_obj* inner = rlang_promise_unwrap(value, &forced); if (!forced) { r_abort("not a forced binding"); } return R_PromiseExpr(inner); #endif } // Use `r_env_get()` to get the value of a forced binding // Active binding accessors r_obj* r_env_binding_active_fn(r_obj* env, r_obj* sym) { return R_ActiveBindingFunction(sym, env); } lazyeval/src/rlang/call.c0000644000176200001440000000223215163675314015064 0ustar liggesusers#include "rlang.h" static r_obj* quote_prim = NULL; bool r_is_call(r_obj* x, const char* name) { if (r_typeof(x) != LANGSXP) { return false; } else { return name == NULL || r_is_symbol(r_node_car(x), name); } } bool r_is_call_any(r_obj* x, const char** names, int n) { if (r_typeof(x) != LANGSXP) { return false; } else { return r_is_symbol_any(r_node_car(x), names, n); } } r_obj* r_expr_protect(r_obj* x) { switch (r_typeof(x)) { case R_TYPE_symbol: case R_TYPE_call: case R_TYPE_promise: return r_call2(quote_prim, x); default: return x; } } static inline bool is_node(r_obj* x) { switch (r_typeof(x)) { case R_TYPE_call: case R_TYPE_pairlist: return true; default: return false; } } r_obj* r_call_clone(r_obj* x) { if (!is_node(x)) { r_abort("Input must be a call."); } x = KEEP(r_clone(x)); r_obj* rest = x; while (rest != r_null) { r_obj* head = r_node_car(rest); if (is_node(head)) { r_node_poke_car(rest, r_call_clone(head)); } rest = r_node_cdr(rest); } FREE(1); return x; } void r_init_library_call(void) { quote_prim = r_base_ns_get("quote"); } lazyeval/src/rlang/df.c0000644000176200001440000000271515163675314014550 0ustar liggesusers#include "rlang.h" #include "decl/df-decl.h" r_obj* r_alloc_df_list(r_ssize n_rows, r_obj* names, const enum r_type* v_types, r_ssize types_size) { r_obj* out = KEEP(r_alloc_list(types_size)); if (r_typeof(names) != R_TYPE_character) { r_abort("`names` must be a character vector."); } if (r_length(names) != types_size) { r_abort("`names` must match the number of columns."); } r_attrib_poke_names(out, names); for (r_ssize i = 0; i < types_size; ++i) { // A nil type stands for no column allocation enum r_type type = v_types[i]; if (type != R_TYPE_null) { r_obj* col = r_alloc_vector(type, n_rows); r_list_poke(out, i, col); } } FREE(1); return out; } void r_init_data_frame(r_obj* x, r_ssize n_rows) { init_compact_rownames(x, n_rows); r_attrib_poke(x, r_syms.class_, r_classes.data_frame); } void r_init_tibble(r_obj* x, r_ssize n_rows) { r_init_data_frame(x, n_rows); r_attrib_poke(x, r_syms.class_, r_classes.tibble); } static void init_compact_rownames(r_obj* x, r_ssize n_rows) { r_obj* rn = KEEP(new_compact_rownames(n_rows)); r_attrib_poke(x, r_syms.row_names, rn); FREE(1); } static r_obj* new_compact_rownames(r_ssize n_rows) { if (n_rows <= 0) { return r_globals.empty_int; } r_obj* out = r_alloc_integer(2); int* p_out = r_int_begin(out); p_out[0] = r_globals.na_int; p_out[1] = -n_rows; return out; } lazyeval/src/rlang/c-utils.c0000644000176200001440000000103115163675314015525 0ustar liggesusers#include void* r_shelter_deref(r_obj* x) { enum r_type type = r_typeof(x); switch (type) { case R_TYPE_list: if (r_length(x) < 1) { r_abort("Shelter must have at least one element"); } x = r_list_get(x, 0); type = r_typeof(x); break; case R_TYPE_pairlist: x = r_node_car(x); type = r_typeof(x); break; case R_TYPE_raw: break; default: r_stop_unimplemented_type(type); } if (type != R_TYPE_raw) { r_stop_unexpected_type(type); } return r_raw_begin(x); } lazyeval/src/rlang/walk.h0000644000176200001440000000745715163675314015132 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_INTERNAL_WALK_H #define RLANG_INTERNAL_WALK_H #include "rlang-types.h" #include "cnd.h" /** * Direction of iteration * * Each non-leaf node of the sexp tree is visited twice: First before * visiting the children, and again after the children have been * visited. See * about * this iteration process. * * There are three directions: * - Incoming: The first time a non-leaf node is visited. * - Leaf: After reaching a leaf node, the direction changes from * incoming to outgoing. * - Outgoing: The second time a non-leaf node is visited on the way back. */ enum r_sexp_it_direction { R_SEXP_IT_DIRECTION_leaf = 0, R_SEXP_IT_DIRECTION_incoming, R_SEXP_IT_DIRECTION_outgoing }; enum r_sexp_it_relation { R_SEXP_IT_RELATION_none = -1, R_SEXP_IT_RELATION_root = 0, R_SEXP_IT_RELATION_attrib, // Nodes R_SEXP_IT_RELATION_node_car, R_SEXP_IT_RELATION_node_cdr, R_SEXP_IT_RELATION_node_tag, R_SEXP_IT_RELATION_symbol_string, R_SEXP_IT_RELATION_symbol_value, R_SEXP_IT_RELATION_symbol_internal, R_SEXP_IT_RELATION_function_fmls, R_SEXP_IT_RELATION_function_body, R_SEXP_IT_RELATION_function_env, R_SEXP_IT_RELATION_environment_frame, R_SEXP_IT_RELATION_environment_enclos, R_SEXP_IT_RELATION_environment_hashtab, R_SEXP_IT_RELATION_promise_value, R_SEXP_IT_RELATION_promise_expr, R_SEXP_IT_RELATION_promise_env, R_SEXP_IT_RELATION_pointer_prot, R_SEXP_IT_RELATION_pointer_tag, // Vectors R_SEXP_IT_RELATION_list_elt, R_SEXP_IT_RELATION_character_elt, R_SEXP_IT_RELATION_expression_elt }; enum r_sexp_it_raw_relation { R_SEXP_IT_RAW_RELATION_root = 0, R_SEXP_IT_RAW_RELATION_attrib, R_SEXP_IT_RAW_RELATION_node_tag, R_SEXP_IT_RAW_RELATION_node_car, R_SEXP_IT_RAW_RELATION_node_cdr, R_SEXP_IT_RAW_RELATION_vector_elt }; struct r_sexp_iterator { r_obj* shelter; bool skip_incoming; r_obj* x; enum r_type type; int depth; r_obj* parent; enum r_sexp_it_relation rel; r_ssize i; enum r_sexp_it_direction dir; /* private: */ struct r_dyn_array* p_stack; }; struct r_sexp_iterator* r_new_sexp_iterator(r_obj* root); bool r_sexp_next(struct r_sexp_iterator* p_it); bool r_sexp_skip(struct r_sexp_iterator* p_it); static inline enum r_sexp_it_raw_relation r_sexp_it_raw_relation(enum r_sexp_it_relation rel) { switch (rel) { case R_SEXP_IT_RELATION_root: return R_SEXP_IT_RAW_RELATION_root; case R_SEXP_IT_RELATION_attrib: return R_SEXP_IT_RAW_RELATION_attrib; case R_SEXP_IT_RELATION_node_car: case R_SEXP_IT_RELATION_symbol_string: case R_SEXP_IT_RELATION_environment_frame: case R_SEXP_IT_RELATION_function_fmls: case R_SEXP_IT_RELATION_promise_value: return R_SEXP_IT_RAW_RELATION_node_car; case R_SEXP_IT_RELATION_node_cdr: case R_SEXP_IT_RELATION_symbol_value: case R_SEXP_IT_RELATION_environment_enclos: case R_SEXP_IT_RELATION_function_body: case R_SEXP_IT_RELATION_promise_expr: case R_SEXP_IT_RELATION_pointer_prot: return R_SEXP_IT_RAW_RELATION_node_cdr; case R_SEXP_IT_RELATION_node_tag: case R_SEXP_IT_RELATION_symbol_internal: case R_SEXP_IT_RELATION_environment_hashtab: case R_SEXP_IT_RELATION_function_env: case R_SEXP_IT_RELATION_promise_env: case R_SEXP_IT_RELATION_pointer_tag: return R_SEXP_IT_RAW_RELATION_node_tag; case R_SEXP_IT_RELATION_list_elt: case R_SEXP_IT_RELATION_character_elt: case R_SEXP_IT_RELATION_expression_elt: return R_SEXP_IT_RAW_RELATION_vector_elt; default: r_abort("Unimplemented type."); } } const char* r_sexp_it_direction_as_c_string(enum r_sexp_it_direction dir); const char* r_sexp_it_relation_as_c_string(enum r_sexp_it_relation rel); const char* r_sexp_it_raw_relation_as_c_string(enum r_sexp_it_raw_relation rel); #endif lazyeval/src/rlang/globals.h0000644000176200001440000000361715163675314015611 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_GLOBALS_H #define RLANG_GLOBALS_H #include "rlang-types.h" struct r_globals { r_obj* empty_lgl; r_obj* empty_int; r_obj* empty_dbl; r_obj* empty_cpl; r_obj* empty_raw; r_obj* empty_chr; r_obj* empty_list; int na_lgl; int na_int; double na_dbl; r_complex na_cpl; r_obj* na_str; }; struct r_globals_chrs { r_obj* empty_string; r_obj* full; }; struct r_globals_classes { r_obj* data_frame; r_obj* tibble; }; struct r_globals_strs { r_obj* dots; r_obj* condition; r_obj* empty; r_obj* error; r_obj* interrupt; r_obj* message; r_obj* na; r_obj* warning; }; struct r_globals_syms { r_obj* abort; r_obj* arg; r_obj* brace; r_obj* brackets; r_obj* brackets2; r_obj* call; // `_` is required to avoid conflicts with the C++ keyword `class`. // See https://github.com/r-lib/rlang/pull/1359 for details. r_obj* class_; r_obj* condition; r_obj* dots; r_obj* dot_environment; r_obj* dot_fn; r_obj* dot_x; r_obj* dot_y; r_obj* error; r_obj* error_arg; r_obj* error_call; r_obj* error_call_flag; r_obj* expr; r_obj* function; r_obj* interrupt; r_obj* message; r_obj* missing; r_obj* names; r_obj* options; r_obj* colon2; r_obj* colon3; r_obj* srcfile; r_obj* srcref; r_obj* dim; r_obj* dim_names; r_obj* row_names; r_obj* stack_overflow_error; r_obj* tilde; r_obj* w; r_obj* warning; r_obj* wholeSrcref; r_obj* x; r_obj* y; r_obj* z; }; struct r_globals_envs { r_obj* empty; r_obj* base; r_obj* global; r_obj* ns; // The namespace of the embedding package }; extern struct r_globals r_globals; extern struct r_globals_chrs r_chrs; extern struct r_globals_classes r_classes; extern struct r_globals_strs r_strs; extern struct r_globals_syms r_syms; extern struct r_globals_envs r_envs; extern r_obj* r_true; extern r_obj* r_false; #endif lazyeval/src/rlang/walk.c0000644000176200001440000003134015163675314015111 0ustar liggesusers#include #include "walk.h" #define SEXP_STACK_INIT_SIZE 256 enum sexp_iterator_type { SEXP_ITERATOR_TYPE_node, SEXP_ITERATOR_TYPE_pointer, SEXP_ITERATOR_TYPE_vector, SEXP_ITERATOR_TYPE_atomic }; enum sexp_iterator_state { SEXP_ITERATOR_STATE_done, SEXP_ITERATOR_STATE_attrib, SEXP_ITERATOR_STATE_tag, SEXP_ITERATOR_STATE_car, SEXP_ITERATOR_STATE_cdr, SEXP_ITERATOR_STATE_elt }; struct sexp_stack_info { r_obj* x; enum r_type type; const enum sexp_iterator_state* p_state; r_obj* const * v_arr; r_obj* const * v_arr_end; int depth; r_obj* parent; enum r_sexp_it_relation rel; enum r_sexp_it_direction dir; }; #include "decl/walk-decl.h" static const enum sexp_iterator_state node_states[] = { SEXP_ITERATOR_STATE_attrib, SEXP_ITERATOR_STATE_tag, SEXP_ITERATOR_STATE_car, SEXP_ITERATOR_STATE_cdr, SEXP_ITERATOR_STATE_done }; static const enum sexp_iterator_state pointer_states[] = { SEXP_ITERATOR_STATE_attrib, SEXP_ITERATOR_STATE_tag, SEXP_ITERATOR_STATE_cdr, SEXP_ITERATOR_STATE_done }; static const enum sexp_iterator_state vector_states[] = { SEXP_ITERATOR_STATE_attrib, SEXP_ITERATOR_STATE_elt, SEXP_ITERATOR_STATE_done }; static const enum sexp_iterator_state structure_states[] = { SEXP_ITERATOR_STATE_attrib, SEXP_ITERATOR_STATE_done }; static const enum sexp_iterator_state done_state[] = { SEXP_ITERATOR_STATE_done }; struct r_sexp_iterator* r_new_sexp_iterator(r_obj* root) { r_obj* shelter = KEEP(r_alloc_list(3)); r_obj* it = r_alloc_raw(sizeof(struct r_sexp_iterator)); r_list_poke(shelter, 0, it); struct r_sexp_iterator* p_it = r_raw_begin(it); struct r_dyn_array* p_stack = r_new_dyn_array(sizeof(struct sexp_stack_info), SEXP_STACK_INIT_SIZE); r_list_poke(shelter, 1, p_stack->shelter); // Slot 2 holds a pairlist chain of collected attribute pairlists // that need protection for the lifetime of the iterator enum r_type type = r_typeof(root); enum sexp_iterator_type it_type = sexp_iterator_type(type, root); bool has_attrib = sexp_has_attrib(type, root); struct sexp_stack_info root_info = { .x = root, .type = type, .depth = -1, .parent = r_null, .rel = R_SEXP_IT_RELATION_root }; if (it_type == SEXP_ITERATOR_TYPE_atomic && !has_attrib) { root_info.p_state = NULL; root_info.dir = R_SEXP_IT_DIRECTION_leaf; } else { init_incoming_stack_info(&root_info, it_type, has_attrib); } r_dyn_push_back(p_stack, &root_info); *p_it = (struct r_sexp_iterator) { .shelter = shelter, .p_stack = p_stack, .x = r_null, .parent = r_null, }; FREE(1); return p_it; } /* * An incoming node has a state indicating which edge we're at. An * outgoing node just need to be visited again and then popped. A * leaf node is just visited once and then popped. */ bool r_sexp_next(struct r_sexp_iterator* p_it) { struct r_dyn_array* p_stack = p_it->p_stack; if (!p_stack->count) { return false; } struct sexp_stack_info* p_info = (struct sexp_stack_info*) r_dyn_last(p_stack); if (p_it->skip_incoming) { p_it->skip_incoming = false; if (p_it->dir == R_SEXP_IT_DIRECTION_incoming) { r_dyn_pop_back(p_stack); return r_sexp_next(p_it); } } // In the normal case, if we push an "incoming" node on the stack it // means that we have already visited it and we are now visiting its // children. The root node is signalled with a depth of -1 so it can // be visited first before being visited as an incoming node. bool root = (p_info->depth == -1); if (!root && p_info->dir == R_SEXP_IT_DIRECTION_incoming) { return sexp_next_incoming(p_it, p_info); } r_ssize i = -1; if (p_info->v_arr) { i = p_info->v_arr_end - p_info->v_arr; } p_it->x = p_info->x; p_it->type = p_info->type; p_it->depth = p_info->depth; p_it->parent = p_info->parent; p_it->rel = p_info->rel; p_it->i = i; p_it->dir = p_info->dir; if (root) { ++p_it->depth; ++p_info->depth; // Incoming visit for the root node if (p_it->dir == R_SEXP_IT_DIRECTION_incoming) { return true; } } r_dyn_pop_back(p_stack); return true; } static bool sexp_next_incoming(struct r_sexp_iterator* p_it, struct sexp_stack_info* p_info) { enum sexp_iterator_state state = *p_info->p_state; r_obj* x = p_info->x; enum r_type type = p_info->type; struct sexp_stack_info child = { 0 }; child.parent = x; child.depth = p_info->depth + 1; switch (state) { case SEXP_ITERATOR_STATE_attrib: { // Allocates a new pairlist to avoid direct ATTRIB() access. // Could use R_mapAttrib() instead but would require refactoring. r_obj* collected = r_attrib_collect(x); // Protect collected pairlist in the iterator's shelter chain r_obj* chain = r_new_node(collected, r_list_get(p_it->shelter, 2)); r_list_poke(p_it->shelter, 2, chain); child.x = collected; child.rel = R_SEXP_IT_RELATION_attrib; break; } case SEXP_ITERATOR_STATE_elt: child.x = *p_info->v_arr; child.rel = R_SEXP_IT_RELATION_list_elt; break; case SEXP_ITERATOR_STATE_tag: child.x = sexp_node_tag(type, x, &child.rel); break; case SEXP_ITERATOR_STATE_car: child.x = sexp_node_car(type, x, &child.rel); break; case SEXP_ITERATOR_STATE_cdr: child.x = sexp_node_cdr(type, x, &child.rel); break; case SEXP_ITERATOR_STATE_done: r_stop_unreachable(); } child.type = r_typeof(child.x); bool has_attrib = sexp_has_attrib(child.type, child.x); enum sexp_iterator_type it_type = sexp_iterator_type(child.type, child.x); if (it_type == SEXP_ITERATOR_TYPE_atomic && !has_attrib) { child.p_state = NULL; child.dir = R_SEXP_IT_DIRECTION_leaf; } else { init_incoming_stack_info(&child, it_type, has_attrib); // Push incoming node on the stack so it can be visited again, // either to descend its children or to visit it again on the // outgoing trip r_dyn_push_back(p_it->p_stack, &child); } // Bump state for next iteration if (state == SEXP_ITERATOR_STATE_elt) { ++p_info->v_arr; if (p_info->v_arr == p_info->v_arr_end) { p_info->p_state = done_state; } } else { ++p_info->p_state; } // Flip incoming to outgoing if we're done visiting children after // this iteration. We don't leave a done node on the stack because // that would break the invariant that there are remaining nodes to // visit when `n > 0` and that the stack can be popped. if (*p_info->p_state == SEXP_ITERATOR_STATE_done) { p_info->dir = R_SEXP_IT_DIRECTION_outgoing; } r_ssize i = -1; if (child.v_arr) { i = child.v_arr_end - child.v_arr; } p_it->x = child.x; p_it->type = child.type; p_it->depth = child.depth; p_it->parent = child.parent; p_it->rel = child.rel; p_it->i = i; p_it->dir = child.dir; return true; } static inline void init_incoming_stack_info(struct sexp_stack_info* p_info, enum sexp_iterator_type it_type, bool has_attrib) { p_info->dir = R_SEXP_IT_DIRECTION_incoming; switch (it_type) { case SEXP_ITERATOR_TYPE_atomic: p_info->p_state = structure_states; break; case SEXP_ITERATOR_TYPE_node: p_info->p_state = node_states + !has_attrib; break; case SEXP_ITERATOR_TYPE_pointer: p_info->p_state = pointer_states + !has_attrib; break; case SEXP_ITERATOR_TYPE_vector: p_info->v_arr = r_vec_cbegin(p_info->x); p_info->v_arr_end = p_info->v_arr + r_length(p_info->x); p_info->p_state = vector_states + !has_attrib; break; } } static inline enum sexp_iterator_type sexp_iterator_type(enum r_type type, r_obj* x) { switch (type) { case R_TYPE_closure: case R_TYPE_environment: case R_TYPE_promise: case R_TYPE_pairlist: case R_TYPE_call: case R_TYPE_dots: return SEXP_ITERATOR_TYPE_node; case R_TYPE_pointer: return SEXP_ITERATOR_TYPE_pointer; case R_TYPE_list: case R_TYPE_expression: case R_TYPE_character: if (r_length(x)) { return SEXP_ITERATOR_TYPE_vector; } else { return SEXP_ITERATOR_TYPE_atomic; } default: return SEXP_ITERATOR_TYPE_atomic; } } static inline bool sexp_has_attrib(enum r_type type, r_obj* x) { // Strings have private data stored in attributes if (type == R_TYPE_string) { return false; } else { return r_attrib_has_any(x); } } static inline r_obj* sexp_node_car(enum r_type type, r_obj* x, enum r_sexp_it_relation* p_rel) { switch (type) { case R_TYPE_closure: *p_rel = R_SEXP_IT_RELATION_function_fmls; return r_fn_formals(x); case R_TYPE_environment: *p_rel = R_SEXP_IT_RELATION_environment_frame; return FRAME(x); case R_TYPE_promise: *p_rel = R_SEXP_IT_RELATION_promise_value; return PRVALUE(x); case R_TYPE_pairlist: case R_TYPE_call: case R_TYPE_dots: *p_rel = R_SEXP_IT_RELATION_node_car; return CAR(x); case R_TYPE_pointer: default: *p_rel = -1; return r_null; } } static inline r_obj* sexp_node_cdr(enum r_type type, r_obj* x, enum r_sexp_it_relation* p_rel) { switch (type) { case R_TYPE_closure: *p_rel = R_SEXP_IT_RELATION_function_body; return r_fn_body(x); case R_TYPE_environment: *p_rel = R_SEXP_IT_RELATION_environment_enclos; return r_env_parent(x); case R_TYPE_promise: *p_rel = R_SEXP_IT_RELATION_promise_expr; return PREXPR(x); case R_TYPE_pointer: *p_rel = R_SEXP_IT_RELATION_pointer_prot; return EXTPTR_PROT(x); case R_TYPE_pairlist: case R_TYPE_call: case R_TYPE_dots: *p_rel = R_SEXP_IT_RELATION_node_cdr; return CDR(x); default: *p_rel = -1; return r_null; } } static inline r_obj* sexp_node_tag(enum r_type type, r_obj* x, enum r_sexp_it_relation* p_rel) { switch (type) { case R_TYPE_closure: *p_rel = R_SEXP_IT_RELATION_function_env; return r_fn_env(x); case R_TYPE_environment: *p_rel = R_SEXP_IT_RELATION_environment_hashtab; return HASHTAB(x); case R_TYPE_promise: *p_rel = R_SEXP_IT_RELATION_promise_env; return PRENV(x); case R_TYPE_pointer: *p_rel = R_SEXP_IT_RELATION_pointer_tag; return EXTPTR_TAG(x); case R_TYPE_pairlist: case R_TYPE_call: case R_TYPE_dots: *p_rel = R_SEXP_IT_RELATION_node_tag; return TAG(x); default: *p_rel = -1; return r_null; } } const char* r_sexp_it_direction_as_c_string(enum r_sexp_it_direction dir) { switch (dir) { case R_SEXP_IT_DIRECTION_leaf: return "leaf"; case R_SEXP_IT_DIRECTION_incoming: return "incoming"; case R_SEXP_IT_DIRECTION_outgoing: return "outgoing"; default: r_stop_unreachable(); } } const char* r_sexp_it_relation_as_c_string(enum r_sexp_it_relation rel) { switch (rel) { case R_SEXP_IT_RELATION_root: return "root"; case R_SEXP_IT_RELATION_attrib: return "attrib"; case R_SEXP_IT_RELATION_node_car: return "node_car"; case R_SEXP_IT_RELATION_node_cdr: return "node_cdr"; case R_SEXP_IT_RELATION_node_tag: return "node_tag"; case R_SEXP_IT_RELATION_symbol_string: return "symbol_string"; case R_SEXP_IT_RELATION_symbol_value: return "symbol_value"; case R_SEXP_IT_RELATION_symbol_internal: return "symbol_internal"; case R_SEXP_IT_RELATION_function_fmls: return "function_fmls"; case R_SEXP_IT_RELATION_function_body: return "function_body"; case R_SEXP_IT_RELATION_function_env: return "function_env"; case R_SEXP_IT_RELATION_environment_frame: return "environment_frame"; case R_SEXP_IT_RELATION_environment_enclos: return "environment_enclos"; case R_SEXP_IT_RELATION_environment_hashtab: return "environment_hashtab"; case R_SEXP_IT_RELATION_promise_value: return "promise_value"; case R_SEXP_IT_RELATION_promise_expr: return "promise_expr"; case R_SEXP_IT_RELATION_promise_env: return "promise_env"; case R_SEXP_IT_RELATION_pointer_prot: return "pointer_prot"; case R_SEXP_IT_RELATION_pointer_tag: return "pointer_tag"; case R_SEXP_IT_RELATION_list_elt: return "list_elt"; case R_SEXP_IT_RELATION_character_elt: return "character_elt"; case R_SEXP_IT_RELATION_expression_elt: return "expression_elt"; case R_SEXP_IT_RELATION_none: r_stop_internal("r_sexp_it_relation_as_c_string", "Found `R_SEXP_IT_RELATION_none`."); default: r_stop_unreachable(); } } const char* r_sexp_it_raw_relation_as_c_string(enum r_sexp_it_raw_relation rel) { switch (rel) { case R_SEXP_IT_RAW_RELATION_root: return "root"; case R_SEXP_IT_RAW_RELATION_attrib: return "attrib"; case R_SEXP_IT_RAW_RELATION_node_car: return "node_car"; case R_SEXP_IT_RAW_RELATION_node_cdr: return "node_cdr"; case R_SEXP_IT_RAW_RELATION_node_tag: return "node_tag"; case R_SEXP_IT_RAW_RELATION_vector_elt: return "vector_elt"; default: r_stop_unreachable(); } } lazyeval/src/rlang/quo.c0000644000176200001440000000113215163675314014753 0ustar liggesusers#include "rlang.h" r_obj* (*r_quo_get_expr)(r_obj* quo); r_obj* (*r_quo_set_expr)(r_obj* quo, r_obj* expr); r_obj* (*r_quo_get_env)(r_obj* quo); r_obj* (*r_quo_set_env)(r_obj* quo, r_obj* env); void r_init_library_quo(void) { r_quo_get_expr = (r_obj* (*)(r_obj*)) r_peek_c_callable("rlang", "rlang_quo_get_expr"); r_quo_set_expr = (r_obj* (*)(r_obj*, r_obj*)) r_peek_c_callable("rlang", "rlang_quo_set_expr"); r_quo_get_env = (r_obj* (*)(r_obj*)) r_peek_c_callable("rlang", "rlang_quo_get_env"); r_quo_set_env = (r_obj* (*)(r_obj*, r_obj*)) r_peek_c_callable("rlang", "rlang_quo_set_env"); } lazyeval/src/rlang/vec-chr.c0000644000176200001440000000356015163675314015505 0ustar liggesusers#include #include "rlang.h" r_ssize r_chr_detect_index(r_obj* chr, const char* c_string) { r_ssize n = r_length(chr); for (r_ssize i = 0; i != n; ++i) { const char* cur = CHAR(r_chr_get(chr, i)); if (strcmp(cur, c_string) == 0) { return i; } } return -1; } bool r_chr_has(r_obj* chr, const char* c_string) { r_ssize idx = r_chr_detect_index(chr, c_string); return idx >= 0; } bool r_chr_has_any(r_obj* chr, const char** c_strings) { r_ssize n = r_length(chr); for (r_ssize i = 0; i != n; ++i) { const char* cur = CHAR(r_chr_get(chr, i)); while (*c_strings) { if (strcmp(cur, *c_strings) == 0) { return true; } ++c_strings; } } return false; } void r_chr_fill(r_obj* chr, r_obj* value, r_ssize n) { for (r_ssize i = 0; i < n; ++i) { r_chr_poke(chr, i, value); } } static void validate_chr_setter(r_obj* chr, r_obj* r_string) { if (r_typeof(chr) != R_TYPE_character) { r_abort("`chr` must be a character vector"); } if (r_typeof(r_string) != R_TYPE_string) { r_abort("`r_string` must be an internal R string"); } } // From rlang/vec.c void r_vec_poke_n(r_obj* x, r_ssize offset, r_obj* y, r_ssize from, r_ssize n); r_obj* chr_prepend(r_obj* chr, r_obj* r_string) { if (chr == r_null) { return r_str_as_character(r_string); } else { validate_chr_setter(chr, r_string); } int n = r_length(chr); r_obj* out = KEEP(r_alloc_character(n + 1)); r_vec_poke_n(out, 1, chr, 0, n); r_chr_poke(out, 0, r_string); FREE(1); return out; } r_obj* chr_append(r_obj* chr, r_obj* r_str) { if (chr == r_null) { return r_str_as_character(r_str); } validate_chr_setter(chr, r_str); int n = r_length(chr); r_obj* out = KEEP(r_alloc_character(n + 1)); r_vec_poke_n(out, 0, chr, 0, n); r_chr_poke(out, n, r_str); FREE(1); return out; } lazyeval/src/rlang/formula.h0000644000176200001440000000043515163675314015626 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_FORMULA_H #define RLANG_FORMULA_H #include "rlang-types.h" bool r_is_formula(r_obj* x, int scoped, int lhs); r_obj* r_f_rhs(r_obj* f); r_obj* r_f_lhs(r_obj* f); r_obj* r_f_env(r_obj* f); bool r_f_has_env(r_obj* f); #endif lazyeval/src/rlang/state.h0000644000176200001440000000107215163675314015277 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_STATE_H #define RLANG_STATE_H #include "call.h" #include "eval.h" #include "globals.h" #include "node.h" #include "rlang-types.h" #include "sym.h" static inline r_obj* r_peek_option(const char* name) { return Rf_GetOption1(Rf_install(name)); } static inline void r_poke_option(const char* name, r_obj* value) { r_obj* args = KEEP(r_new_node(value, r_null)); r_node_poke_tag(args, r_sym(name)); r_obj* call = KEEP(r_new_call(r_syms.options, args)); r_eval(call, r_envs.base); FREE(2); } #endif lazyeval/src/rlang/vec.c0000644000176200001440000002032615163675314014732 0ustar liggesusers#include "rlang.h" #include #include r_obj* r_chr_n(const char* const * strings, r_ssize n) { r_obj* out = KEEP(r_alloc_character(n)); for (r_ssize i = 0; i < n; ++i) { r_chr_poke(out, i, r_str(strings[i])); } FREE(1); return out; } #define RESIZE(R_TYPE, C_TYPE, CONST_DEREF, DEREF) \ do { \ r_ssize old_size = r_length(x); \ if (old_size == new_size) { \ return x; \ } \ if (!ALTREP(x) && new_size < old_size) { \ return vec_shrink(x, new_size, old_size); \ } \ \ const C_TYPE* p_x = CONST_DEREF(x); \ r_obj* out = KEEP(r_alloc_vector(R_TYPE, new_size)); \ C_TYPE* p_out = DEREF(out); \ \ r_ssize cpy_size = (new_size > old_size) ? old_size : new_size; \ r_memcpy(p_out, p_x, cpy_size * sizeof(C_TYPE)); \ \ FREE(1); \ return out; \ } while (0) #define RESIZE_BARRIER(R_TYPE, CONST_DEREF, SET) \ do { \ r_ssize old_size = r_length(x); \ if (old_size == new_size) { \ return x; \ } \ if (!ALTREP(x) && new_size < old_size) { \ return vec_shrink(x, new_size, old_size); \ } \ \ r_obj* const * p_x = CONST_DEREF(x); \ r_obj* out = KEEP(r_alloc_vector(R_TYPE, new_size)); \ \ r_ssize cpy_size = (new_size > old_size) ? old_size : new_size; \ for (r_ssize i = 0; i < cpy_size; ++i) { \ SET(out, i, p_x[i]); \ } \ \ FREE(1); \ return out; \ } while (0) // Assumption on older R: `new_size` smaller than `old_size` static inline r_obj* vec_shrink(r_obj* x, r_ssize new_size, r_ssize old_size) { #if R_VERSION >= R_Version(4, 6, 0) if (R_isResizable(x)) { R_resizeVector(x, new_size); return x; } else { return Rf_xlengthgets(x, new_size); } #else SETLENGTH(x, new_size); SET_TRUELENGTH(x, old_size); SET_GROWABLE_BIT(x); return x; #endif } // Compared to `Rf_xlengthgets()` this does not initialise the new // extended locations with `NA` r_obj* r_lgl_resize(r_obj* x, r_ssize new_size) { RESIZE(R_TYPE_logical, int, r_lgl_cbegin, r_lgl_begin); } r_obj* r_int_resize(r_obj* x, r_ssize new_size) { RESIZE(R_TYPE_integer, int, r_int_cbegin, r_int_begin); } r_obj* r_dbl_resize(r_obj* x, r_ssize new_size) { RESIZE(R_TYPE_double, double, r_dbl_cbegin, r_dbl_begin); } r_obj* r_cpl_resize(r_obj* x, r_ssize new_size) { RESIZE(R_TYPE_complex, r_complex, r_cpl_cbegin, r_cpl_begin); } r_obj* r_raw_resize(r_obj* x, r_ssize new_size) { RESIZE(R_TYPE_raw, unsigned char, r_raw_cbegin, r_raw_begin); } r_obj* r_chr_resize(r_obj* x, r_ssize new_size) { RESIZE_BARRIER(R_TYPE_character, r_chr_cbegin, r_chr_poke); } r_obj* r_list_resize(r_obj* x, r_ssize new_size) { RESIZE_BARRIER(R_TYPE_list, r_list_cbegin, r_list_poke); } #undef RESIZE #undef RESIZE_BARRIER r_obj* r_list_compact(r_obj* x) { r_ssize n = r_length(x); r_obj* inc = KEEP(r_alloc_logical(n)); int* v_inc = r_int_begin(inc); r_obj* const * v_x = r_list_cbegin(x); r_ssize new_n = 0; for (r_ssize i = 0; i < n; ++i) { v_inc[i] = v_x[i] != r_null; new_n += v_inc[i]; } r_obj* out = KEEP(r_alloc_list(new_n)); for (r_ssize i = 0, count = 0; i < n; ++i) { if (v_inc[i]) { r_list_poke(out, count, v_x[i]); ++count; } } FREE(2); return out; } r_obj* r_list_of_as_ptr_ssize(r_obj* xs, enum r_type type, struct r_pair_ptr_ssize** p_v_out) { if (r_typeof(xs) != R_TYPE_list) { r_abort("`xs` must be a list."); } r_ssize n = r_length(xs); r_obj* shelter = KEEP(r_alloc_raw(sizeof(struct r_pair_ptr_ssize) * n)); struct r_pair_ptr_ssize* v_out = r_raw_begin(shelter); r_obj* const * v_xs = r_list_cbegin(xs); for (r_ssize i = 0; i < n; ++i) { r_obj* x = v_xs[i]; if (r_typeof(x) != type) { r_abort("`xs` must be a list of vectors of type `%s`.", r_type_as_c_string(type)); } v_out[i] = (struct r_pair_ptr_ssize) { .ptr = r_int_begin(x), .size = r_length(x) }; } FREE(1); *p_v_out = v_out; return shelter; } // FIXME: Does this have a place in the library? void r_vec_poke_n(r_obj* x, r_ssize offset, r_obj* y, r_ssize from, r_ssize n) { if ((r_length(x) - offset) < n) { r_abort("Can't copy data to `x` because it is too small"); } if ((r_length(y) - from) < n) { r_abort("Can't copy data from `y` because it is too small"); } switch (r_typeof(x)) { case R_TYPE_logical: { int* src_data = r_lgl_begin(y); int* dest_data = r_lgl_begin(x); for (r_ssize i = 0; i != n; ++i) dest_data[i + offset] = src_data[i + from]; break; } case R_TYPE_integer: { int* src_data = r_int_begin(y); int* dest_data = r_int_begin(x); for (r_ssize i = 0; i != n; ++i) dest_data[i + offset] = src_data[i + from]; break; } case R_TYPE_double: { double* src_data = r_dbl_begin(y); double* dest_data = r_dbl_begin(x); for (r_ssize i = 0; i != n; ++i) dest_data[i + offset] = src_data[i + from]; break; } case R_TYPE_complex: { r_complex* src_data = r_cpl_begin(y); r_complex* dest_data = r_cpl_begin(x); for (r_ssize i = 0; i != n; ++i) dest_data[i + offset] = src_data[i + from]; break; } case R_TYPE_raw: { unsigned char* src_data = RAW(y); unsigned char* dest_data = RAW(x); for (r_ssize i = 0; i != n; ++i) dest_data[i + offset] = src_data[i + from]; break; } case R_TYPE_character: { r_obj* elt; for (r_ssize i = 0; i != n; ++i) { elt = r_chr_get(y, i + from); r_chr_poke(x, i + offset, elt); } break; } case R_TYPE_list: { r_obj* elt; for (r_ssize i = 0; i != n; ++i) { elt = r_list_get(y, i + from); r_list_poke(x, i + offset, elt); } break; } default: r_abort("Copy requires vectors"); } } void r_vec_poke_range(r_obj* x, r_ssize offset, r_obj* y, r_ssize from, r_ssize to) { r_vec_poke_n(x, offset, y, from, to - from + 1); } bool _r_is_finite(r_obj* x) { r_ssize n = r_length(x); switch(r_typeof(x)) { case R_TYPE_integer: { const int* p_x = r_int_cbegin(x); for (r_ssize i = 0; i < n; ++i) { if (p_x[i] == r_globals.na_int) { return false; } } break; } case R_TYPE_double: { const double* p_x = r_dbl_cbegin(x); for (r_ssize i = 0; i < n; ++i) { if (!isfinite(p_x[i])) { return false; } } break; } case R_TYPE_complex: { const r_complex* p_x = r_cpl_cbegin(x); for (r_ssize i = 0; i < n; ++i) { if (!isfinite(p_x[i].r) || !isfinite(p_x[i].i)) { return false; } } break; } default: r_abort("Internal error: expected a numeric vector"); } return true; } lazyeval/src/rlang/session.h0000644000176200001440000000032715163675314015644 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_SESSION_H #define RLANG_SESSION_H #include "rlang-types.h" bool r_is_installed(const char* pkg); bool r_has_colour(void); r_obj* r_getppid(void); #endif lazyeval/src/rlang/export.h0000644000176200001440000000072215163675314015501 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_EXPORT_H #define RLANG_EXPORT_H #include "rlang-types.h" typedef DL_FUNC r_void_fn; static inline r_void_fn r_peek_c_callable(const char* pkg, const char* callable) { return R_GetCCallable(pkg, callable); } static inline r_obj* r_new_fn_ptr(r_void_fn p) { return R_MakeExternalPtrFn(p, r_null, r_null); } static inline r_void_fn r_fn_ptr_addr(r_obj* p) { return R_ExternalPtrAddrFn(p); } #endif lazyeval/src/rlang/export.c0000644000176200001440000000046315163675314015476 0ustar liggesusers#include "rlang.h" #include "export.h" #include r_obj* rlang_namespace(const char* ns) { r_obj* ns_string = KEEP(Rf_mkString(ns)); r_obj* call = KEEP(r_sym("getNamespace")); call = KEEP(Rf_lang2(call, ns_string)); r_obj* ns_env = r_eval(call, R_BaseEnv); FREE(3); return ns_env; } lazyeval/src/rlang/df.h0000644000176200001440000000060315163675314014547 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_DF_H #define RLANG_DF_H #include "rlang-types.h" r_obj* r_alloc_df_list(r_ssize n_rows, r_obj* names, const enum r_type* v_types, r_ssize types_size); void r_init_data_frame(r_obj* x, r_ssize n_nows); void r_init_tibble(r_obj* x, r_ssize n_rows); #endif lazyeval/src/rlang/dict.c0000644000176200001440000002024515163675314015100 0ustar liggesusers#include #include "dict.h" #define DICT_LOAD_THRESHOLD 0.75 #define DICT_GROWTH_FACTOR 2 static size_t size_round_power_2(size_t size); #include "decl/dict-decl.h" #define DICT_DEREF(D) r_list_cbegin(D) #define DICT_KEY(V) r_list_get(V, 0) #define DICT_VALUE(V) r_list_get(V, 1) #define DICT_CDR(V) r_list_get(V, 2) #define DICT_POKE_KEY(D, K) r_list_poke(D, 0, K) #define DICT_POKE_VALUE(D, V) r_list_poke(D, 1, V) #define DICT_POKE_CDR(D, N) r_list_poke(D, 2, N) #define V_DICT_KEY(V) (V)[0] #define V_DICT_VALUE(V) (V)[1] #define V_DICT_CDR(V) (V)[2] static r_obj* new_dict_node(r_obj* key, r_obj* value) { r_obj* bucket = r_alloc_list(3); DICT_POKE_KEY(bucket, key); DICT_POKE_VALUE(bucket, value); return bucket; } struct r_dict* r_new_dict(r_ssize size) { if (size <= 0) { r_abort("`size` of dictionary must be positive."); } size = size_round_power_2(size); r_obj* shelter = KEEP(r_alloc_list(2)); r_obj* dict_raw = r_alloc_raw0(sizeof(struct r_dict)); r_list_poke(shelter, 0, dict_raw); struct r_dict* p_dict = r_raw_begin(dict_raw); p_dict->shelter = shelter; p_dict->buckets = r_alloc_list(size); r_list_poke(shelter, 1, p_dict->buckets); p_dict->p_buckets = r_list_cbegin(p_dict->buckets); p_dict->n_buckets = size; r_attrib_poke(shelter, r_syms.class_, r_chr("rlang_dict")); FREE(1); return p_dict; } void r_dict_resize(struct r_dict* p_dict, r_ssize size) { if (size < 0) { size = p_dict->n_buckets * DICT_GROWTH_FACTOR; } struct r_dict* p_new_dict = r_new_dict(size); KEEP(p_new_dict->shelter); r_ssize n = r_length(p_dict->buckets); r_obj* const * p_buckets = p_dict->p_buckets; for (r_ssize i = 0; i < n; ++i) { r_obj* bucket = p_buckets[i]; while (bucket != r_null) { r_obj* const * v_bucket = DICT_DEREF(bucket); r_obj* key = V_DICT_KEY(v_bucket); r_obj* value = V_DICT_VALUE(v_bucket); r_dict_put(p_new_dict, key, value); bucket = V_DICT_CDR(v_bucket); } } // Update all data in place except the shelter and the raw sexp // which must stay validly protected by the callers r_obj* old_shelter = p_dict->shelter; r_list_poke(old_shelter, 1, r_list_get(p_new_dict->shelter, 1)); r_memcpy(p_dict, p_new_dict, sizeof(*p_dict)); p_dict->shelter = old_shelter; FREE(1); } static size_t size_round_power_2(size_t size) { size_t out = 1; while (out < size) { out <<= 1; } return out; } static r_ssize dict_hash(const struct r_dict* p_dict, r_obj* key) { uint64_t hash = r_xxh3_64bits(&key, sizeof(r_obj*)); return hash % p_dict->n_buckets; } // Returns previous value of `key` if it existed or a C `NULL` r_obj* r_dict_poke(struct r_dict* p_dict, r_obj* key, r_obj* value) { r_ssize hash; r_obj* parent; r_obj* node = dict_find_node_info(p_dict, key, &hash, &parent); if (node != r_null) { r_obj* old = DICT_VALUE(node); DICT_POKE_VALUE(node, value); return old; } else { dict_push(p_dict, hash, parent, key, value); return NULL; } } // Returns `false` if `key` already exists in the dictionary, `true` // otherwise bool r_dict_put(struct r_dict* p_dict, r_obj* key, r_obj* value) { r_ssize hash; r_obj* parent; r_obj* node = dict_find_node_info(p_dict, key, &hash, &parent); if (node != r_null) { return false; } else { dict_push(p_dict, hash, parent, key, value); return true; } } static void dict_push(struct r_dict* p_dict, r_ssize hash, r_obj* parent, r_obj* key, r_obj* value) { r_obj* node = KEEP(new_dict_node(key, value)); if (parent == r_null) { // Empty bucket r_list_poke(p_dict->buckets, hash, node); } else { DICT_POKE_CDR(parent, node); } ++p_dict->n_entries; float load = (float) p_dict->n_entries / (float) p_dict->n_buckets; if (!p_dict->prevent_resize && load > DICT_LOAD_THRESHOLD) { r_dict_resize(p_dict, -1); } FREE(1); } // Returns `true` if key existed and was deleted. Returns `false` if // the key could not be deleted because it did not exist in the dict. bool r_dict_del(struct r_dict* p_dict, r_obj* key) { r_ssize hash; r_obj* parent; r_obj* node = dict_find_node_info(p_dict, key, &hash, &parent); if (node == r_null) { return false; } r_obj* node_cdr = DICT_CDR(node); if (parent == r_null) { r_list_poke(p_dict->buckets, hash, node_cdr); } else { DICT_POKE_CDR(parent, node_cdr); } return true; } bool r_dict_has(struct r_dict* p_dict, r_obj* key) { return dict_find_node(p_dict, key) != r_null; } r_obj* r_dict_get(struct r_dict* p_dict, r_obj* key) { r_obj* out = r_dict_get0(p_dict, key); if (!out) { r_abort("Can't find key in dictionary."); } return out; } /* The 0-suffixed variant returns a C `NULL` if the object doesn't exist. The regular variant throws an error in that case. */ r_obj* r_dict_get0(struct r_dict* p_dict, r_obj* key) { r_obj* node = dict_find_node(p_dict, key); if (node == r_null) { return NULL; } else { return DICT_VALUE(node); } } static r_obj* dict_find_node(struct r_dict* p_dict, r_obj* key) { r_ssize i = dict_hash(p_dict, key); r_obj* bucket = p_dict->p_buckets[i]; while (bucket != r_null) { r_obj* const * v_bucket = DICT_DEREF(bucket); if (V_DICT_KEY(v_bucket) == key) { return bucket; } bucket = V_DICT_CDR(v_bucket); } return r_null; } // Also returns hash and parent node if any static r_obj* dict_find_node_info(struct r_dict* p_dict, r_obj* key, r_ssize* hash, r_obj** parent) { r_ssize i = dict_hash(p_dict, key); *hash = i; r_obj* bucket = p_dict->p_buckets[i]; *parent = r_null; while (bucket != r_null) { r_obj* const * v_bucket = DICT_DEREF(bucket); if (V_DICT_KEY(v_bucket) == key) { return bucket; } *parent = bucket; bucket = V_DICT_CDR(v_bucket); } return r_null; } struct r_dict_iterator* r_new_dict_iterator(struct r_dict* p_dict) { r_obj* shelter = r_alloc_raw(sizeof(struct r_dict_iterator)); struct r_dict_iterator* p_it = r_raw_begin(shelter); p_it->shelter = shelter; p_it->key = r_null; p_it->value = r_null; p_it->i = 0; p_it->n = p_dict->n_buckets; p_it->v_buckets = p_dict->p_buckets; if (p_it->n == 0) { r_stop_internal("Empty dictionary."); } p_it->node = p_it->v_buckets[0]; return p_it; } bool r_dict_next(struct r_dict_iterator* p_it) { if (p_it->v_buckets == NULL) { return false; } r_obj* node = p_it->node; while (node == r_null) { r_ssize i = ++p_it->i; if (i >= p_it->n) { p_it->v_buckets = NULL; return false; } node = p_it->v_buckets[i]; p_it->node = node; } r_obj* const * v_node = DICT_DEREF(node); p_it->key = V_DICT_KEY(v_node); p_it->value = V_DICT_VALUE(v_node); p_it->node = V_DICT_CDR(v_node); return true; } static const char* v_dict_it_df_names_c_strings[] = { "key", "value" }; static const enum r_type v_dict_it_df_types[] = { R_TYPE_list, R_TYPE_list }; enum dict_it_df_locs { DICT_IT_DF_LOCS_key, DICT_IT_DF_LOCS_value }; #define DICT_IT_DF_SIZE R_ARR_SIZEOF(v_dict_it_df_types) r_obj* r_dict_as_df_list(struct r_dict* p_dict) { r_obj* nms = KEEP(r_chr_n(v_dict_it_df_names_c_strings, DICT_IT_DF_SIZE)); r_obj* out = KEEP(r_alloc_df_list(p_dict->n_entries, nms, v_dict_it_df_types, DICT_IT_DF_SIZE)); r_obj* key = r_list_get(out, DICT_IT_DF_LOCS_key); r_obj* value = r_list_get(out, DICT_IT_DF_LOCS_value); struct r_dict_iterator* p_it = r_new_dict_iterator(p_dict); KEEP(p_it->shelter); for (r_ssize i = 0; r_dict_next(p_it); ++i) { r_list_poke(key, i, p_it->key); r_list_poke(value, i, p_it->value); } FREE(3); return out; } r_obj* r_dict_as_list(struct r_dict* p_dict) { r_obj* out = KEEP(r_alloc_list(p_dict->n_entries)); struct r_dict_iterator* p_it = r_new_dict_iterator(p_dict); KEEP(p_it->shelter); for (r_ssize i = 0; r_dict_next(p_it); ++i) { r_list_poke(out, i, p_it->value); } FREE(2); return out; } lazyeval/src/rlang/rlang.c0000644000176200001440000000611215163675314015255 0ustar liggesusers#include #include #include "arg.c" #include "attrib.c" #include "call.c" #include "cnd.c" #include "c-utils.c" #include "debug.c" #include "dict.c" #include "df.c" #include "dots-info.c" #include "dyn-array.c" #include "dyn-list-of.c" #include "env.c" #include "env-binding.c" #include "eval.c" #include "export.c" #include "fn.c" #include "formula.c" #include "globals.c" #include "node.c" #include "obj.c" #include "parse.c" #include "quo.c" #include "session.c" #include "stack.c" #include "sym.c" #include "vec.c" #include "vec-chr.c" #include "vec-lgl.c" #include "vendor.c" #ifdef RLANG_USE_PRIVATE_ACCESSORS #include "walk.c" #endif // Allows long vectors to be indexed with doubles r_ssize r_arg_as_ssize(r_obj* n, const char* arg) { switch (r_typeof(n)) { case R_TYPE_double: { if (r_length(n) != 1) { goto invalid; } double out = r_dbl_get(n, 0); if (out > R_SSIZE_MAX) { r_abort("`%s` is too large a number.", arg); } if (out != (int_least64_t) out) { r_abort("`%s` must be a whole number, not a decimal number.", arg); } return (r_ssize) floor(out); } case R_TYPE_integer: { if (r_length(n) != 1) { goto invalid; } return (r_ssize) r_int_get(n, 0); } invalid: default: r_abort("`%s` must be a scalar integer or double.", arg); } } static r_obj* shared_x_env; static r_obj* shared_xy_env; static r_obj* shared_xyz_env; // This *must* be called before making any calls to the functions // provided in the library. Register this function in your init file // and `.Call()` it from your `.onLoad()` hook. r_obj* r_init_library(r_obj* ns) { if (!R_IsNamespaceEnv(ns)) { Rf_errorcall(r_null, "Can't initialise rlang library.\n" "x `ns` must be a namespace environment."); } // Local precious lists are disabled by default because rchk // requires the base precious list and we don't want to // double-preserve. Still enable it on CI to get that part of the // code tested. _r_use_local_precious_list = getenv("RLIB_USE_LOCAL_PRECIOUS_LIST") || getenv("CI"); // Need to be first r_init_library_vendor(); // Needed for xxh used in `r_preserve()` r_init_library_globals_syms(); r_init_library_obj(ns); r_init_library_globals(ns); shared_x_env = r_parse_eval("new.env(hash = FALSE, parent = baseenv(), size = 1L)", r_envs.base); r_preserve(shared_x_env); shared_xy_env = r_parse_eval("new.env(hash = FALSE, parent = baseenv(), size = 1L)", r_envs.base); r_preserve(shared_xy_env); shared_xyz_env = r_parse_eval("new.env(hash = FALSE, parent = baseenv(), size = 1L)", r_envs.base); r_preserve(shared_xyz_env); r_init_library_sym(); r_init_library_eval(); r_init_library_env(); r_init_rlang_ns_env(); r_init_library_arg(); r_init_library_call(); r_init_library_cnd(); r_init_library_dyn_array(); r_init_library_fn(); r_init_library_quo(); r_init_library_session(); r_init_library_stack(); // Return a SEXP so the init function can be called from R return r_null; } bool _r_use_local_precious_list = false; lazyeval/src/rlang/rlang-types.h0000644000176200001440000000767315163675314016441 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_RLANG_TYPES_H #define RLANG_RLANG_TYPES_H #define R_NO_REMAP #include // IWYU pragma: export #include // IWYU pragma: export #include // IWYU pragma: export #include // IWYU pragma: export // Use `r_visible` to mark your init function. Then users can compile // with `-fvisibility=hidden -DHAVE_VISIBILITY_ATTRIBUTE` to link to // your library (as opposed to dynamically loading it) without risking // symbol clashes. #define r_visible attribute_visible extern #ifdef __GNUC__ # define r_unused __attribute__ ((unused)) #else # define r_unused #endif #define r_no_return __attribute__ ((noreturn)) typedef struct SEXPREC r_obj; typedef Rcomplex r_complex; typedef R_xlen_t r_ssize; #define R_SSIZE_MAX R_XLEN_T_MAX #define R_SSIZE_MIN (-R_XLEN_T_MAX) #ifdef LONG_VECTOR_SUPPORT # define R_PRI_SSIZE "td" #else # define R_PRI_SSIZE "d" #endif enum r_type { R_TYPE_null = 0, R_TYPE_symbol = 1, R_TYPE_pairlist = 2, R_TYPE_closure = 3, R_TYPE_environment = 4, R_TYPE_promise = 5, R_TYPE_call = 6, R_TYPE_special = 7, R_TYPE_builtin = 8, R_TYPE_string = 9, R_TYPE_logical = 10, R_TYPE_integer = 13, R_TYPE_double = 14, R_TYPE_complex = 15, R_TYPE_character = 16, R_TYPE_dots = 17, R_TYPE_any = 18, R_TYPE_list = 19, R_TYPE_expression = 20, R_TYPE_bytecode = 21, R_TYPE_pointer = 22, R_TYPE_weakref = 23, R_TYPE_raw = 24, R_TYPE_s4 = 25, R_TYPE_new = 30, R_TYPE_free = 31, R_TYPE_function = 99 }; #define r_null R_NilValue struct r_pair { r_obj* x; r_obj* y; }; struct r_triple { r_obj* x; r_obj* y; r_obj* z; }; struct r_pair_ptr_ssize { void* ptr; r_ssize size; }; struct r_pair_callback { r_obj* (*fn)(void* data); void* data; }; struct r_lazy { r_obj* x; r_obj* env; }; #define KEEP PROTECT #define FREE UNPROTECT #define KEEP2(x, y) (KEEP(x), KEEP(y)) #define KEEP_N(x, n) (++(*n), KEEP(x)) #define r_keep_loc PROTECT_INDEX #define KEEP_AT REPROTECT #define KEEP_HERE PROTECT_WITH_INDEX #define KEEP_WHILE(X, EXPR) do { \ KEEP(X); \ EXPR; \ FREE(1); \ } while (0) #define RLANG_ASSERT(condition) ((void)sizeof(char[1 - 2*!(condition)])) // Polyfills for R API #if R_VERSION < R_Version(4, 5, 0) static inline int ANY_ATTRIB(SEXP x) { return ATTRIB(x) != R_NilValue; } static inline void CLEAR_ATTRIB(SEXP x) { SET_ATTRIB(x, R_NilValue); SET_OBJECT(x, 0); UNSET_S4_OBJECT(x); } #endif #if R_VERSION < R_Version(4, 6, 0) static inline bool rlang_promise_is_forced(r_obj* x) { return PRVALUE(x) != R_UnboundValue; } // Unwrap nested promises to the innermost one. // Sets `*forced` to TRUE if the innermost promise is forced. // Uses Floyd's cycle detection to guard against promise loops. static inline r_obj* rlang_promise_unwrap(r_obj* x, bool *forced) { r_obj* slow = x; bool advance_slow = false; while (TRUE) { r_obj* expr = PREXPR(x); if (TYPEOF(expr) != PROMSXP) { *forced = rlang_promise_is_forced(x); return x; } x = expr; if (x == slow) { Rf_error("Cycle detected in promise chain"); } if (advance_slow) { slow = PREXPR(slow); } advance_slow = !advance_slow; } } #endif #if R_VERSION < R_Version(4, 6, 0) static inline SEXP R_mapAttrib(SEXP x, SEXP (*FUN)(SEXP, SEXP, void *), void *data) { PROTECT_INDEX api; SEXP a = ATTRIB(x); SEXP val = NULL; PROTECT_WITH_INDEX(a, &api); while (a != R_NilValue) { SEXP tag = PROTECT(TAG(a)); SEXP attr = PROTECT(CAR(a)); val = FUN(tag, attr, data); UNPROTECT(2); if (val != NULL) break; REPROTECT(a = CDR(a), api); } UNPROTECT(1); return val; } #endif #endif lazyeval/src/rlang/quo.h0000644000176200001440000000050315163675314014761 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_QUO_H #define RLANG_QUO_H #include "rlang-types.h" extern r_obj* (*r_quo_get_expr)(r_obj* quo); extern r_obj* (*r_quo_set_expr)(r_obj* quo, r_obj* expr); extern r_obj* (*r_quo_get_env)(r_obj* quo); extern r_obj* (*r_quo_set_env)(r_obj* quo, r_obj* env); #endif lazyeval/src/rlang/dict.h0000644000176200001440000000246315163675314015107 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_DICT_H #define RLANG_DICT_H #include "rlang-types.h" /** * This is a simple hash table of `r_obj*`. It is structured like R * environments and uses xxhash for hashing. */ struct r_dict { r_obj* shelter; /* private: */ r_obj* buckets; r_obj* const * p_buckets; r_ssize n_buckets; r_ssize n_entries; // For testing collisions bool prevent_resize; }; struct r_dict* r_new_dict(r_ssize size); r_obj* r_dict_poke(struct r_dict* p_dict, r_obj* key, r_obj* value); bool r_dict_put(struct r_dict* p_dict, r_obj* key, r_obj* value); bool r_dict_del(struct r_dict* p_dict, r_obj* key); bool r_dict_has(struct r_dict* p_dict, r_obj* key); r_obj* r_dict_get(struct r_dict* p_dict, r_obj* key); r_obj* r_dict_get0(struct r_dict* p_dict, r_obj* key); // Pass a negative size to resize by the default growth factor void r_dict_resize(struct r_dict* p_dict, r_ssize size); r_obj* r_dict_as_df_list(struct r_dict* p_dict); r_obj* r_dict_as_list(struct r_dict* p_dict); struct r_dict_iterator { r_obj* shelter; r_obj* key; r_obj* value; /* private: */ r_ssize i; r_ssize n; r_obj* const * v_buckets; r_obj* node; }; struct r_dict_iterator* r_new_dict_iterator(struct r_dict* p_dict); bool r_dict_next(struct r_dict_iterator* p_it); #endif lazyeval/src/rlang/decl/0000755000176200001440000000000015163705077014715 5ustar liggesuserslazyeval/src/rlang/decl/walk-decl.h0000644000176200001440000000162615163675314016736 0ustar liggesusersstatic inline enum sexp_iterator_type sexp_iterator_type(enum r_type type, r_obj* x); static inline bool sexp_has_attrib(enum r_type type, r_obj* x); static inline r_obj* sexp_node_car(enum r_type type, r_obj* x, enum r_sexp_it_relation* p_rel); static inline r_obj* sexp_node_cdr(enum r_type type, r_obj* x, enum r_sexp_it_relation* p_rel); static inline r_obj* sexp_node_tag(enum r_type type, r_obj* x, enum r_sexp_it_relation* p_rel); static inline void init_incoming_stack_info(struct sexp_stack_info* p_info, enum sexp_iterator_type it_type, bool has_attrib); static bool sexp_next_incoming(struct r_sexp_iterator* p_it, struct sexp_stack_info* p_info); lazyeval/src/rlang/decl/obj-decl.h0000644000176200001440000000023315163675314016543 0ustar liggesusersstatic r_obj* new_precious_stack(r_obj* x); static int push_precious(r_obj* stack); static int pop_precious(r_obj* stack); static r_obj* as_label_call; lazyeval/src/rlang/decl/df-decl.h0000644000176200001440000000016215163675314016363 0ustar liggesusersstatic void init_compact_rownames(r_obj* x, r_ssize n_rows); static r_obj* new_compact_rownames(r_ssize n_rows); lazyeval/src/rlang/decl/dyn-list-of-decl.h0000644000176200001440000000024415163675314020140 0ustar liggesusersstatic bool reserve_push_back(struct r_dyn_list_of* p_lof, r_ssize i, void* p_elt); static void reserve_move(struct r_dyn_list_of* p_lof, r_ssize i, void* p_elt); lazyeval/src/rlang/decl/dict-decl.h0000644000176200001440000000062615163675314016722 0ustar liggesusersstatic r_obj* dict_find_node_info(struct r_dict* dict, r_obj* key, r_ssize* hash, r_obj** parent); static r_obj* dict_find_node(struct r_dict* dict, r_obj* key); static void dict_push(struct r_dict* p_dict, r_ssize hash, r_obj* parent, r_obj* key, r_obj* value); lazyeval/src/rlang/decl/env-decl.h0000644000176200001440000000101015163675314016553 0ustar liggesusersr_obj* eval_with_x(r_obj* call, r_obj* x); r_obj* eval_with_xy(r_obj* call, r_obj* x, r_obj* y); r_obj* eval_with_xyz(r_obj* call, r_obj* x, r_obj* y, r_obj* z); #if R_VERSION < R_Version(4, 1, 0) static r_obj* new_env_call; static r_obj* new_env__parent_node; static r_obj* new_env__size_node; #endif static r_obj* exists_call; static r_obj* remove_call; static r_obj* env2list_call; static r_obj* list2env_call; static r_obj* missing_prim; static void env_coalesce_plain(r_obj* env, r_obj* from, r_obj* nms); lazyeval/src/rlang/decl/cnd-decl.h0000644000176200001440000000003715163675314016537 0ustar liggesusersstatic r_obj* cnd_signal_call; lazyeval/src/rlang/decl/env-binding-decl.h0000644000176200001440000000003415163675314020170 0ustar liggesusersextern r_obj* rlang_ns_env; lazyeval/src/rlang/decl/stack-decl.h0000644000176200001440000000016415163675314017101 0ustar liggesusers// From env.c r_obj* rlang_ns_get(const char* name); static r_obj* peek_frame_call; static r_obj* caller_env_call; lazyeval/src/rlang/node.c0000644000176200001440000000255515163675314015106 0ustar liggesusers#include "rlang.h" r_obj* r_new_pairlist(const struct r_pair* args, int n, r_obj** tail) { r_obj* shelter = KEEP(r_new_node(R_NilValue, R_NilValue)); r_obj* node = shelter; for (int i = 0; i < n; ++i) { struct r_pair arg = args[i]; r_obj* tag = arg.x; r_obj* car = arg.y; r_obj* cdr = r_new_node(car, r_null); r_node_poke_tag(cdr, tag); r_node_poke_cdr(node, cdr); node = cdr; } if (n && tail) { *tail = node; } FREE(1); return r_node_cdr(shelter); } // Shallow copy of a node tree. Other objects are not cloned. r_obj* r_node_tree_clone(r_obj* x) { enum r_type type = r_typeof(x); if (type != R_TYPE_pairlist && type != R_TYPE_call) { return x; } x = KEEP(r_clone(x)); r_obj* rest = x; while (rest != r_null) { r_obj* head = r_node_car(rest); enum r_type head_type = r_typeof(head); if (head_type == R_TYPE_pairlist || head_type == R_TYPE_call) { r_node_poke_car(rest, r_node_tree_clone(head)); } rest = r_node_cdr(rest); } FREE(1); return x; } r_obj* r_pairlist_rev(r_obj* node) { if (node == r_null) { return node; } r_obj* prev = r_null; r_obj* tail = node; r_obj* next; while (tail != r_null) { next = r_node_cdr(tail); r_node_poke_cdr(tail, prev); prev = tail; tail = next; } return prev; } lazyeval/src/rlang/cnd.h0000644000176200001440000000440015163675314014721 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_CND_H #define RLANG_CND_H #include "rlang-types.h" #include "obj.h" void r_inform(const char* fmt, ...); void r_warn(const char* fmt, ...); void r_interrupt(void); void r_no_return r_abort(const char* fmt, ...); void r_no_return r_abort_n(const struct r_pair* args, int n); void r_no_return r_abort_call(r_obj* call, const char* fmt, ...); // Formats input as an argument, using cli if available. Returns a // vmax-protected string. extern const char* (*r_format_error_arg)(r_obj* arg); const char* r_format_lazy_error_arg(struct r_lazy arg); // Return vmax-protected strings extern const char* (*r_obj_type_friendly_full)(r_obj* x, bool value, bool length); static inline const char* r_obj_type_friendly(r_obj* x) { return r_obj_type_friendly_full(x, true, false); } extern r_no_return void (*r_stop_internal)(const char* file, int line, r_obj* call, const char* fmt, ...); r_obj* r_peek_frame(void); #define r_stop_internal(...) \ (r_stop_internal)(__FILE__, __LINE__, r_peek_frame(), \ __VA_ARGS__) #define r_stop_unreachable() \ (r_stop_internal)(__FILE__, __LINE__, r_peek_frame(), \ "Reached the unreachable") #define r_stop_unimplemented_type(TYPE) \ (r_stop_internal)(__FILE__, __LINE__, r_peek_frame(), \ "Unimplemented type `%s`.", Rf_type2char(TYPE)) #define r_stop_unexpected_type(TYPE) \ (r_stop_internal)(__FILE__, __LINE__, r_peek_frame(), \ "Unexpected type `%s`.", Rf_type2char(TYPE)) static inline bool r_is_condition(r_obj* x) { return r_typeof(x) == R_TYPE_list && r_inherits(x, "condition"); } void r_cnd_signal(r_obj* cnd); void r_cnd_inform(r_obj* cnd, bool mufflable); void r_cnd_warn(r_obj* cnd, bool mufflable); void r_cnd_abort(r_obj* cnd, bool mufflable); enum r_cnd_type { R_CND_TYPE_condition = 0, R_CND_TYPE_message = 1, R_CND_TYPE_warning = 2, R_CND_TYPE_error = 3, R_CND_TYPE_interrupt = 4 }; enum r_cnd_type r_cnd_type(r_obj* cnd); #endif lazyeval/src/rlang/obj.c0000644000176200001440000000576015163675314014734 0ustar liggesusers#include "rlang.h" #define PRECIOUS_DICT_INIT_SIZE 256 static struct r_dict* p_precious_dict = NULL; #include "decl/obj-decl.h" r_obj* r_vec_clone(r_obj* x) { r_obj* out = KEEP(r_clone(x)); r_obj* names = r_names(x); if (names != r_null) { r_attrib_poke_names(out, r_clone(names)); } FREE(1); return out; } r_obj* r_vec_clone_shared(r_obj* x) { if (r_is_shared(x)) { return r_vec_clone(x); } r_obj* names = r_names(x); if (names != r_null && r_is_shared(names)) { r_attrib_poke_names(x, r_clone(names)); return x; } return x; } void (_r_preserve)(r_obj* x) { if (!_r_use_local_precious_list) { return; } r_obj* stack = r_dict_get0(p_precious_dict, x); if (!stack) { stack = KEEP(new_precious_stack(x)); r_dict_put(p_precious_dict, x, stack); FREE(1); } push_precious(stack); } void (_r_unpreserve)(r_obj* x) { if (!_r_use_local_precious_list) { return; } r_obj* stack = r_dict_get0(p_precious_dict, x); if (!stack) { r_abort("Can't unpreserve `x` because it was not being preserved."); } int n = pop_precious(stack); if (n < 0) { r_stop_internal("`n` unexpectedly < 0."); } if (n == 0) { r_dict_del(p_precious_dict, x); } } static r_obj* new_precious_stack(r_obj* x) { r_obj* stack = KEEP(r_alloc_list(2)); // Store (0) protection count and (1) element to protect r_list_poke(stack, 0, r_int(0)); r_list_poke(stack, 1, x); FREE(1); return stack; } static int push_precious(r_obj* stack) { r_obj* n = r_list_get(stack, 0); int* p_n = r_int_begin(n); return ++(*p_n); } static int pop_precious(r_obj* stack) { r_obj* n = r_list_get(stack, 0); int* p_n = r_int_begin(n); return --(*p_n); } // For unit tests struct r_dict* rlang__precious_dict(void) { return p_precious_dict; } enum r_type r_chr_as_r_type(r_obj* type) { if (!r_is_string(type)) { r_abort("`type` must be a character string."); } return r_c_str_as_r_type(r_chr_get_c_string(type, 0)); } const char* obj_address_formatter = "%p"; r_obj* r_obj_address(r_obj* x) { static char buf[1000]; snprintf(buf, 1000, obj_address_formatter, (void*) x); return Rf_mkChar(buf); } r_obj* (*r_obj_encode_utf8)(r_obj* x) = NULL; r_obj* r_as_label(r_obj* x) { return r_eval_with_x(as_label_call, x, r_ns_env("rlang")); } void r_init_library_obj(r_obj* ns) { p_precious_dict = r_new_dict(PRECIOUS_DICT_INIT_SIZE); KEEP(p_precious_dict->shelter); r_env_bind(ns, r_sym(".__rlang_lib_precious_dict__."), p_precious_dict->shelter); FREE(1); // The Microsoft C library doesn't implement the hexadecimal // formatter correctly const char* null_addr = r_str_c_string(r_obj_address(r_null)); if (null_addr[0] != '0' || null_addr[1] != 'x') { obj_address_formatter = "0x%p"; } r_obj_encode_utf8 = (r_obj* (*)(r_obj*)) r_peek_c_callable("rlang", "rlang_obj_encode_utf8"); as_label_call = r_parse("as_label(x)"); r_preserve_global(as_label_call); } static r_obj* as_label_call = NULL; lazyeval/src/rlang/vendor.c0000644000176200001440000000032115163675314015443 0ustar liggesusers#include "rlang.h" uint64_t (*r_xxh3_64bits)(const void*, size_t); void r_init_library_vendor(void) { r_xxh3_64bits = (uint64_t (*)(const void*, size_t)) r_peek_c_callable("rlang", "rlang_xxh3_64bits"); } lazyeval/src/rlang/attrib.c0000644000176200001440000000223715163675314015443 0ustar liggesusers#include "rlang.h" static r_obj* r_attrib_get_cb(r_obj* tag, r_obj* val, void* data) { if (tag == *(r_obj**) data) { return val; } return NULL; } r_obj* r_attrib_get(r_obj* x, r_obj* tag) { r_obj* out = r_attrib_map(x, &r_attrib_get_cb, &tag); return out ? out : r_null; } // Collect attributes into a pairlist using `R_mapAttrib` static r_obj* r_attrib_collect_cb(r_obj* tag, r_obj* val, void* data) { r_obj** p_tail = (r_obj**) data; r_obj* node = r_new_node(val, r_null); r_node_poke_tag(node, tag); r_node_poke_cdr(*p_tail, node); *p_tail = node; return NULL; } r_obj* r_attrib_collect(r_obj* x) { r_obj* sentinel = KEEP(r_new_node(r_null, r_null)); r_obj* tail = sentinel; r_attrib_map(x, &r_attrib_collect_cb, &tail); FREE(1); return r_node_cdr(sentinel); } bool r_is_named(r_obj* x) { r_obj* nms = r_names(x); if (r_typeof(nms) != R_TYPE_character) { return false; } if (r_chr_has(nms, "")) { return false; } return true; } void r_attrib_poke_classes(r_obj* x, const char** classes, r_ssize n) { r_obj* classes_chr = KEEP(r_chr_n(classes, n)); r_attrib_poke(x, r_syms.class_, classes_chr); FREE(1); } lazyeval/src/rlang/parse.h0000644000176200001440000000031715163675314015272 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_PARSE_H #define RLANG_PARSE_H #include "rlang-types.h" r_obj* r_parse(const char* str); r_obj* r_parse_eval(const char* str, r_obj* env); #endif lazyeval/src/rlang/vec.h0000644000176200001440000003046115163675314014740 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_VECTOR_H #define RLANG_VECTOR_H #include #include "rlang-types.h" #include "c-utils.h" #include "cnd.h" #include "globals.h" #include "obj.h" static inline int* r_lgl_begin(r_obj* x) { return LOGICAL(x); } static inline int* r_int_begin(r_obj* x) { return INTEGER(x); } static inline double* r_dbl_begin(r_obj* x) { return REAL(x); } static inline r_complex* r_cpl_begin(r_obj* x) { return COMPLEX(x); } static inline void* r_raw_begin(r_obj* x) { return RAW(x); } static inline const int* r_int_cbegin(r_obj* x) { return (const int*) INTEGER(x); } static inline const int* r_lgl_cbegin(r_obj* x) { return (const int*) LOGICAL(x); } static inline const double* r_dbl_cbegin(r_obj* x) { return (const double*) REAL(x); } static inline const r_complex* r_cpl_cbegin(r_obj* x) { return (const r_complex*) COMPLEX(x); } static inline const void* r_raw_cbegin(r_obj* x) { return (const void*) RAW(x); } static inline r_obj* const * r_chr_cbegin(r_obj* x) { return STRING_PTR_RO(x); } static inline r_obj* const * r_list_cbegin(r_obj* x) { #if (R_VERSION >= R_Version(4, 5, 0)) return VECTOR_PTR_RO(x); #else return ((r_obj* const *) DATAPTR_RO(x)); #endif } static inline void* r_vec_begin0(enum r_type type, r_obj* x) { switch (type) { case R_TYPE_logical: return r_lgl_begin(x); case R_TYPE_integer: return r_int_begin(x); case R_TYPE_double: return r_dbl_begin(x); case R_TYPE_complex: return r_cpl_begin(x); case R_TYPE_raw: return r_raw_begin(x); default: r_stop_unimplemented_type(type); } } static inline void* r_vec_begin(r_obj* x) { return r_vec_begin0(r_typeof(x), x); } static inline const void* r_vec_cbegin0(enum r_type type, r_obj* x) { switch (type) { case R_TYPE_logical: return r_lgl_cbegin(x); case R_TYPE_integer: return r_int_cbegin(x); case R_TYPE_double: return r_dbl_cbegin(x); case R_TYPE_complex: return r_cpl_cbegin(x); case R_TYPE_raw: return r_raw_cbegin(x); case R_TYPE_character: return r_chr_cbegin(x); case R_TYPE_list: return r_list_cbegin(x); default: r_stop_unimplemented_type(type); } } static inline const void* r_vec_cbegin(r_obj* x) { return r_vec_cbegin0(r_typeof(x), x); } static inline int r_vec_elt_sizeof0(enum r_type type) { switch (type) { case R_TYPE_logical: return sizeof(int); case R_TYPE_integer: return sizeof(int); case R_TYPE_double: return sizeof(double); case R_TYPE_complex: return sizeof(r_complex); case R_TYPE_raw: return sizeof(char); case R_TYPE_character: return sizeof(r_obj*); case R_TYPE_list: return sizeof(r_obj*); default: r_stop_unimplemented_type(type); } } static inline int r_vec_elt_sizeof(r_obj* x) { return r_vec_elt_sizeof0(r_typeof(x)); } static inline int r_lgl_get(r_obj* x, r_ssize i) { return LOGICAL(x)[i]; } static inline int r_int_get(r_obj* x, r_ssize i) { return INTEGER(x)[i]; } static inline double r_dbl_get(r_obj* x, r_ssize i) { return REAL(x)[i]; } static inline r_complex r_cpl_get(r_obj* x, r_ssize i) { return COMPLEX(x)[i]; } static inline char r_raw_get(r_obj* x, r_ssize i) { return RAW(x)[i]; } static inline r_obj* r_chr_get(r_obj* x, r_ssize i) { return STRING_ELT(x, i); } static inline const char* r_chr_get_c_string(r_obj* x, r_ssize i) { return CHAR(r_chr_get(x, i)); } static inline r_obj* r_list_get(r_obj* x, r_ssize i) { return VECTOR_ELT(x, i); } static inline void r_lgl_poke(r_obj* x, r_ssize i, int y) { LOGICAL(x)[i] = y; } static inline void r_int_poke(r_obj* x, r_ssize i, int y) { INTEGER(x)[i] = y; } static inline void r_dbl_poke(r_obj* x, r_ssize i, double y) { REAL(x)[i] = y; } static inline void r_cpl_poke(r_obj* x, r_ssize i, r_complex y) { COMPLEX(x)[i] = y; } static inline void r_raw_poke(r_obj* x, r_ssize i, char y) { RAW(x)[i] = y; } static inline void r_chr_poke(r_obj* x, r_ssize i, r_obj* y) { SET_STRING_ELT(x, i, y); } static inline void r_list_poke(r_obj* x, r_ssize i, r_obj* y) { SET_VECTOR_ELT(x, i, y); } #define r_chr_poke(X, I, Y) SET_STRING_ELT(X, I, Y) #define r_list_poke(X, I, Y) SET_VECTOR_ELT(X, I, Y) static inline r_obj* r_alloc_vector(enum r_type type, r_ssize n) { #if R_VERSION >= R_Version(4, 6, 0) return R_allocResizableVector(type, n); #else return Rf_allocVector(type, n); #endif } static inline r_obj* r_alloc_logical(r_ssize n) { #if R_VERSION >= R_Version(4, 6, 0) return R_allocResizableVector(R_TYPE_logical, n); #else return Rf_allocVector(R_TYPE_logical, n); #endif } static inline r_obj* r_alloc_integer(r_ssize n) { #if R_VERSION >= R_Version(4, 6, 0) return R_allocResizableVector(R_TYPE_integer, n); #else return Rf_allocVector(R_TYPE_integer, n); #endif } static inline r_obj* r_alloc_double(r_ssize n) { #if R_VERSION >= R_Version(4, 6, 0) return R_allocResizableVector(R_TYPE_double, n); #else return Rf_allocVector(R_TYPE_double, n); #endif } static inline r_obj* r_alloc_complex(r_ssize n) { #if R_VERSION >= R_Version(4, 6, 0) return R_allocResizableVector(R_TYPE_complex, n); #else return Rf_allocVector(R_TYPE_complex, n); #endif } static inline r_obj* r_alloc_raw(r_ssize n) { #if R_VERSION >= R_Version(4, 6, 0) return R_allocResizableVector(R_TYPE_raw, n); #else return Rf_allocVector(R_TYPE_raw, n); #endif } static inline r_obj* r_alloc_character(r_ssize n) { #if R_VERSION >= R_Version(4, 6, 0) return R_allocResizableVector(R_TYPE_character, n); #else return Rf_allocVector(R_TYPE_character, n); #endif } static inline r_obj* r_alloc_list(r_ssize n) { #if R_VERSION >= R_Version(4, 6, 0) return R_allocResizableVector(R_TYPE_list, n); #else return Rf_allocVector(R_TYPE_list, n); #endif } static inline r_obj* r_alloc_raw0(r_ssize n) { r_obj* out = r_alloc_raw(n); unsigned char* p_out = (unsigned char*) r_raw_begin(out); r_memset(p_out, 0, n); return out; } static inline r_obj* r_lgl(bool x) { return Rf_ScalarLogical(x); } static inline r_obj* r_int(int x) { return Rf_ScalarInteger(x); } static inline r_obj* r_dbl(double x) { return Rf_ScalarReal(x); } static inline r_obj* r_cpl(r_complex x) { return Rf_ScalarComplex(x); } static inline r_obj* r_raw(char x) { return Rf_ScalarRaw(x); } static inline r_obj* r_str(const char* c_string) { return Rf_mkCharCE(c_string, CE_UTF8); } static inline r_obj* r_chr(const char* c_string) { r_obj* out = KEEP(r_alloc_character(1)); r_chr_poke(out, 0, r_str(c_string)); FREE(1); return out; } static inline r_obj* r_list(r_obj* x) { r_obj* out = r_alloc_list(1); r_list_poke(out, 0, x); return out; } r_obj* r_chr_n(const char* const * strings, r_ssize n); static inline r_obj* r_len(r_ssize x) { if (x > INT_MAX) { return r_dbl(x); } else { return r_int(x); } } // FIXME: Redundant with `r_lgl()` static inline r_obj* r_shared_lgl(bool x) { if (x) { return r_true; } else { return r_false; } } static inline bool _r_has_correct_length(r_obj* x, r_ssize n) { return n < 0 || r_length(x) == n; } extern bool _r_is_finite(r_obj* x); static inline bool _r_is_double(r_obj* x, r_ssize n, int finite) { if (r_typeof(x) != R_TYPE_double || !_r_has_correct_length(x, n)) { return false; } if (finite >= 0 && (bool) finite != _r_is_finite(x)) { return false; } return true; } static inline bool _r_is_complex(r_obj* x, r_ssize n, int finite) { if (r_typeof(x) != R_TYPE_complex || !_r_has_correct_length(x, n)) { return false; } if (finite >= 0 && (bool) finite != _r_is_finite(x)) { return false; } return true; } static inline bool r_is_bool(r_obj* x) { return r_typeof(x) == R_TYPE_logical && r_length(x) == 1 && r_lgl_get(x, 0) != r_globals.na_lgl; } static inline bool r_is_int(r_obj* x) { return r_typeof(x) == R_TYPE_integer && r_length(x) == 1 && r_int_get(x, 0) != r_globals.na_int; } static inline bool r_is_true(r_obj* x) { return r_is_bool(x) && r_lgl_get(x, 0); } static inline bool r_is_false(r_obj* x) { return r_is_bool(x) && !r_lgl_get(x, 0); } static inline bool r_is_string(r_obj* x) { return r_typeof(x) == R_TYPE_character && r_length(x) == 1 && r_chr_get(x, 0) != R_NaString; } static inline bool r_arg_as_bool(r_obj* x, const char* arg) { if (!r_is_bool(x)) { r_abort("`%s` must be `TRUE` or `FALSE`.", arg); } return r_lgl_get(x, 0); } static inline bool r_as_bool(r_obj* x) { return r_arg_as_bool(x, "x"); } static inline int r_arg_as_int(r_obj* x, const char* arg) { if (!r_is_int(x)) { r_abort("`%s` must be a single integer value.", arg); } return r_int_get(x, 0); } static inline int r_as_int(r_obj* x) { return r_arg_as_int(x, "x"); } static inline double r_arg_as_double(r_obj* x, const char* arg) { // TODO: Coercion of int and lgl values if (!_r_is_double(x, 1, -1)) { r_abort("`%s` must be a single double value.", arg); } return r_dbl_get(x, 0); } static inline double r_as_double(r_obj* x) { return r_arg_as_double(x, "x"); } static inline r_complex r_arg_as_complex(r_obj* x, const char* arg) { if (!_r_is_complex(x, 1, 1)) { r_abort("`%s` must be a single complex value.", arg); } return r_cpl_get(x, 0); } static inline r_complex r_as_complex(r_obj* x) { return r_arg_as_complex(x, "x"); } static inline char r_arg_as_char(r_obj* x, const char* arg) { if (r_typeof(x) != R_TYPE_raw && r_length(x) != 1) { r_abort("`%s` must be a single raw value.", arg); } return r_raw_get(x, 0); } static inline char r_as_char(r_obj* x) { return r_arg_as_char(x, "x"); } r_obj* r_lgl_resize(r_obj* x, r_ssize new_size); r_obj* r_int_resize(r_obj* x, r_ssize new_size); r_obj* r_dbl_resize(r_obj* x, r_ssize new_size); r_obj* r_cpl_resize(r_obj* x, r_ssize new_size); r_obj* r_raw_resize(r_obj* x, r_ssize new_size); r_obj* r_chr_resize(r_obj* x, r_ssize new_size); r_obj* r_list_resize(r_obj* x, r_ssize new_size); static inline r_obj* r_vec_resize0(enum r_type type, r_obj* x, r_ssize new_size) { switch (type) { case R_TYPE_logical: return r_lgl_resize(x, new_size); case R_TYPE_integer: return r_int_resize(x, new_size); case R_TYPE_double: return r_dbl_resize(x, new_size); case R_TYPE_complex: return r_cpl_resize(x, new_size); case R_TYPE_raw: return r_raw_resize(x, new_size); case R_TYPE_character: return r_chr_resize(x, new_size); case R_TYPE_list: return r_list_resize(x, new_size); default: r_stop_unimplemented_type(type); } } static inline r_obj* r_vec_resize(r_obj* x, r_ssize new_size) { return r_vec_resize0(r_typeof(x), x, new_size); } static inline r_obj* r_vec_n(enum r_type type, void* v_src, r_ssize n) { switch (type) { case R_TYPE_logical: case R_TYPE_integer: case R_TYPE_double: case R_TYPE_complex: case R_TYPE_raw: { r_obj* out = r_alloc_vector(type, n); r_memcpy(r_vec_begin(out), v_src, n * r_vec_elt_sizeof0(type)); return out; } case R_TYPE_character: case R_TYPE_list: r_abort("TODO: barrier types in `r_vec_n()`"); default: r_stop_unimplemented_type(type); } } static inline r_obj* r_lgl_n(int* v_src, r_ssize n) { return r_vec_n(R_TYPE_logical, v_src, n); } static inline r_obj* r_int_n(int* v_src, r_ssize n) { return r_vec_n(R_TYPE_integer, v_src, n); } static inline r_obj* r_dbl_n(int* v_src, r_ssize n) { return r_vec_n(R_TYPE_double, v_src, n); } static inline r_obj* r_cpl_n(int* v_src, r_ssize n) { return r_vec_n(R_TYPE_complex, v_src, n); } static inline r_obj* r_raw_n(int* v_src, r_ssize n) { return r_vec_n(R_TYPE_raw, v_src, n); } static inline r_obj* r_copy_in_raw(const void* src, size_t size) { r_obj* out = r_alloc_raw(size); r_memcpy(r_raw_begin(out), src, size); return out; } static inline void r_int_fill_iota0(int* p_x, int start, r_ssize n) { for (r_ssize i = 0; i < n; ++i) { p_x[i] = start++; } } static inline void r_int_fill_iota(r_obj* x) { r_int_fill_iota0(r_int_begin(x), 0, r_length(x)); } r_obj* r_list_compact(r_obj* x); r_obj* r_list_of_as_ptr_ssize(r_obj* xs, enum r_type type, struct r_pair_ptr_ssize** p_v_out); // From cpp/vec.cpp int* r_int_unique0(int* v_data, r_ssize size); bool r_list_all_of0(r_obj* const * v_first, r_ssize size, bool (*predicate)(r_obj* x)); static inline int* r_int_unique(r_obj* x) { return r_int_unique0(r_int_begin(x), r_length(x)); } static inline bool r_list_all_of(r_obj* x, bool (*predicate)(r_obj* x)) { return r_list_all_of0(r_list_cbegin(x), r_length(x), predicate); } #endif lazyeval/src/rlang/fn.h0000644000176200001440000000246415163675314014570 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_FN_H #define RLANG_FN_H #include "rlang-types.h" #include "obj.h" static inline r_obj* r_fn_formals(r_obj* fn) { #if R_VERSION >= R_Version(4, 5, 0) return R_ClosureFormals(fn); #else return FORMALS(fn); #endif } // Identical to `R_BytecodeExpr(R_ClosureBody(fn))`, which we always want // since it matches the R level `body()` static inline r_obj* r_fn_body(r_obj* fn) { return R_ClosureExpr(fn); } static inline r_obj* r_fn_env(r_obj* fn) { #if R_VERSION >= R_Version(4, 5, 0) return R_ClosureEnv(fn); #else return CLOENV(fn); #endif } static inline r_obj* r_new_function(r_obj* formals, r_obj* body, r_obj* env) { #if R_VERSION >= R_Version(4, 5, 0) return R_mkClosure(formals, body, env); #else SEXP fn = Rf_allocSExp(R_TYPE_closure); SET_FORMALS(fn, formals); SET_BODY(fn, body); SET_CLOENV(fn, env); return fn; #endif } r_obj* r_as_function(r_obj* x, const char* arg); static inline bool r_is_function(r_obj* x) { switch (r_typeof(x)) { case R_TYPE_closure: case R_TYPE_builtin: case R_TYPE_special: return true; default: return false; } } static inline bool r_is_primitive(r_obj* x) { switch (r_typeof(x)) { case R_TYPE_builtin: case R_TYPE_special: return true; default: return false; } } #endif lazyeval/src/rlang/debug.h0000644000176200001440000000040515163675314015244 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_DEBUG_H #define RLANG_DEBUG_H #include "rlang-types.h" #define r_printf Rprintf void r_sexp_inspect(r_obj* x); void r_browse(r_obj* x); void r_browse_at(r_obj* env); void r_dbg_str(r_obj* x); #endif lazyeval/src/rlang/eval.h0000644000176200001440000001146715163675314015117 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_EVAL_H #define RLANG_EVAL_H #include "rlang-types.h" #include "c-utils.h" #include "call.h" static inline r_obj* r_eval(r_obj* expr, r_obj* env) { return Rf_eval(expr, env); } r_obj* r_eval_with_x(r_obj* call, r_obj* x, r_obj* parent); r_obj* r_eval_with_xy(r_obj* call, r_obj* x, r_obj* y, r_obj* parent); r_obj* r_eval_with_xyz(r_obj* call, r_obj* x, r_obj* y, r_obj* z, r_obj* parent); r_obj* r_eval_with_wxyz(r_obj* call, r_obj* w, r_obj* x, r_obj* y, r_obj* z, r_obj* parent); r_obj* r_exec_mask_n(r_obj* fn_sym, r_obj* fn, const struct r_pair* args, int n, r_obj* parent); r_obj* r_exec_n(r_obj* fn_sym, r_obj* fn, const struct r_pair* args, int n, r_obj* env); r_obj* r_exec_mask_n_call_poke(r_obj* fn_sym, r_obj* fn, const struct r_pair* args, int n, r_obj* env); static inline r_obj* r_exec_mask1(r_obj* fn_sym, r_obj* fn, r_obj* x_sym, r_obj* x, r_obj* env) { struct r_pair args[] = { { x_sym, x } }; return r_exec_mask_n(fn_sym, fn, args, R_ARR_SIZEOF(args), env); } static inline r_obj* r_exec_mask2(r_obj* fn_sym, r_obj* fn, r_obj* x1_sym, r_obj* x1, r_obj* x2_sym, r_obj* x2, r_obj* env) { struct r_pair args[] = { { x1_sym, x1 }, { x2_sym, x2 } }; return r_exec_mask_n(fn_sym, fn, args, R_ARR_SIZEOF(args), env); } static inline r_obj* r_exec_mask3(r_obj* fn_sym, r_obj* fn, r_obj* x1_sym, r_obj* x1, r_obj* x2_sym, r_obj* x2, r_obj* x3_sym, r_obj* x3, r_obj* env) { struct r_pair args[] = { { x1_sym, x1 }, { x2_sym, x2 }, { x3_sym, x3 } }; return r_exec_mask_n(fn_sym, fn, args, R_ARR_SIZEOF(args), env); } static inline r_obj* r_exec_mask4(r_obj* fn_sym, r_obj* fn, r_obj* x1_sym, r_obj* x1, r_obj* x2_sym, r_obj* x2, r_obj* x3_sym, r_obj* x3, r_obj* x4_sym, r_obj* x4, r_obj* env) { struct r_pair args[] = { { x1_sym, x1 }, { x2_sym, x2 }, { x3_sym, x3 }, { x4_sym, x4 } }; return r_exec_mask_n(fn_sym, fn, args, R_ARR_SIZEOF(args), env); } static inline r_obj* r_exec_mask5(r_obj* fn_sym, r_obj* fn, r_obj* x1_sym, r_obj* x1, r_obj* x2_sym, r_obj* x2, r_obj* x3_sym, r_obj* x3, r_obj* x4_sym, r_obj* x4, r_obj* x5_sym, r_obj* x5, r_obj* env) { struct r_pair args[] = { { x1_sym, x1 }, { x2_sym, x2 }, { x3_sym, x3 }, { x4_sym, x4 }, { x5_sym, x5 } }; return r_exec_mask_n(fn_sym, fn, args, R_ARR_SIZEOF(args), env); } static inline r_obj* r_exec_mask6(r_obj* fn_sym, r_obj* fn, r_obj* x1_sym, r_obj* x1, r_obj* x2_sym, r_obj* x2, r_obj* x3_sym, r_obj* x3, r_obj* x4_sym, r_obj* x4, r_obj* x5_sym, r_obj* x5, r_obj* x6_sym, r_obj* x6, r_obj* env) { struct r_pair args[] = { { x1_sym, x1 }, { x2_sym, x2 }, { x3_sym, x3 }, { x4_sym, x4 }, { x5_sym, x5 }, { x6_sym, x6 } }; return r_exec_mask_n(fn_sym, fn, args, R_ARR_SIZEOF(args), env); } static inline r_obj* r_exec_mask7(r_obj* fn_sym, r_obj* fn, r_obj* x1_sym, r_obj* x1, r_obj* x2_sym, r_obj* x2, r_obj* x3_sym, r_obj* x3, r_obj* x4_sym, r_obj* x4, r_obj* x5_sym, r_obj* x5, r_obj* x6_sym, r_obj* x6, r_obj* x7_sym, r_obj* x7, r_obj* env) { struct r_pair args[] = { { x1_sym, x1 }, { x2_sym, x2 }, { x3_sym, x3 }, { x4_sym, x4 }, { x5_sym, x5 }, { x6_sym, x6 }, { x7_sym, x7 } }; return r_exec_mask_n(fn_sym, fn, args, R_ARR_SIZEOF(args), env); } static inline r_obj* r_lazy_eval(struct r_lazy lazy) { if (!lazy.env) { // Unitialised lazy variable return r_null; } else if (lazy.env == r_null) { // Forced lazy variable return lazy.x; } else { return r_eval(lazy.x, lazy.env); } } extern struct r_lazy r_lazy_null; extern struct r_lazy r_lazy_missing_arg; static inline r_obj* r_lazy_eval_protect(struct r_lazy lazy) { r_obj* out = KEEP(r_lazy_eval(lazy)); out = r_expr_protect(out); FREE(1); return out; } static inline bool r_lazy_is_null(struct r_lazy call) { return !call.x && !call.env; } #endif lazyeval/src/rlang/dots-info.h0000644000176200001440000000121315163675314016056 0ustar liggesusers#ifndef RLANG_DOTS_INFO_H #define RLANG_DOTS_INFO_H #include "rlang-types.h" typedef enum { DOT_TYPE_value = 0, DOT_TYPE_missing = 1, DOT_TYPE_delayed = 2, DOT_TYPE_forced = 3 } r_dot_type_t; bool r_env_dots_exist(r_obj* env); r_ssize r_env_dots_length(r_obj* env); r_obj* r_env_dots_names(r_obj* env); r_obj* r_env_dot_get(r_obj* env, r_ssize i); r_dot_type_t r_env_dot_type(r_obj* env, r_ssize i); r_obj* r_env_dot_delayed_expr(r_obj* env, r_ssize i); r_obj* r_env_dot_delayed_env(r_obj* env, r_ssize i); r_obj* r_env_dot_forced_expr(r_obj* env, r_ssize i); r_obj* r_env_until_dots(r_obj* env); #endif /* RLANG_DOTS_INFO_H */ lazyeval/src/rlang/sym.h0000644000176200001440000000125315163675314014770 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_SYM_H #define RLANG_SYM_H #include "rlang-types.h" // The results of `r_sym_as_` functions must be protected extern r_obj* (*r_sym_as_utf8_character)(r_obj* x); extern r_obj* (*r_sym_as_utf8_string)(r_obj* x); r_obj* r_new_symbol(r_obj* x, int* err); static inline r_obj* r_sym(const char* c_string) { return Rf_install(c_string); } static inline r_obj* r_sym_string(r_obj* sym) { return PRINTNAME(sym); } static inline const char* r_sym_c_string(r_obj* sym) { return CHAR(PRINTNAME(sym)); } bool r_is_symbol(r_obj* sym, const char* string); bool r_is_symbol_any(r_obj* x, const char** strings, int n); #endif lazyeval/src/rlang/vendor.h0000644000176200001440000000023415163675314015453 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_VENDOR_H #define RLANG_VENDOR_H extern uint64_t (*r_xxh3_64bits)(const void*, size_t); #endif lazyeval/src/rlang/attrib.h0000644000176200001440000000363415163675314015452 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_ATTRIB_H #define RLANG_ATTRIB_H #include "rlang-types.h" #include "globals.h" static inline bool r_attrib_has_any(r_obj* x) { return ANY_ATTRIB(x); } // Collect attributes into a fresh pairlist r_obj* r_attrib_collect(r_obj* x); typedef r_obj* (r_attrib_map_fn)(r_obj* tag, r_obj* value, void* data); // Map a callback to each attribute of an object. Prefer this to collecting for // performance-critical applications. static inline r_obj* r_attrib_map(r_obj* x, r_attrib_map_fn* fn, void* data) { return R_mapAttrib(x, fn, data); } static inline void r_attrib_zap(r_obj* x, r_obj* tag) { Rf_setAttrib(x, tag, r_null); } static inline void r_attrib_zap_all(r_obj* x) { CLEAR_ATTRIB(x); } static inline void r_attrib_clone_from(r_obj* to, r_obj* from) { SHALLOW_DUPLICATE_ATTRIB(to, from); } // Unlike Rf_getAttrib(), this doesn't allocate, but in practice requires // protection because rchk considers the return value to be a fresh pointer. r_obj* r_attrib_get(r_obj* x, r_obj* tag); static inline r_obj* r_class(r_obj* x) { return r_attrib_get(x, r_syms.class_); } void r_attrib_poke_classes(r_obj* x, const char** classes, r_ssize n); static inline r_obj* r_dim(r_obj* x) { return r_attrib_get(x, r_syms.dim); } static inline r_obj* r_dim_names(r_obj* x) { return r_attrib_get(x, r_syms.dim_names); } static inline r_obj* r_names(r_obj* x) { return r_attrib_get(x, r_syms.names); } bool r_is_named(r_obj* x); // Defined as macros so rchk can see that `X` protects `VALUE` #define r_attrib_poke(X, SYM, VALUE) Rf_setAttrib(X, SYM, VALUE) #define r_attrib_poke_class(X, VALUE) Rf_setAttrib(X, r_syms.class_, VALUE) #define r_attrib_poke_dim(X, VALUE) Rf_setAttrib(X, r_syms.dim, VALUE) #define r_attrib_poke_dim_names(X, VALUE) Rf_setAttrib(X, r_syms.dim_names, VALUE) #define r_attrib_poke_names(X, VALUE) Rf_setAttrib(X, r_syms.names, VALUE) #endif lazyeval/src/rlang.c0000644000176200001440000000025315163675314014152 0ustar liggesusers// This is an include point for the implementations of the rlang // library. It should be included in a single and separate compilation // unit. #include "rlang/rlang.c" lazyeval/src/interp.c0000644000176200001440000000221213442722664014344 0ustar liggesusers#define R_NO_REMAP #include #include #include "utils.h" SEXP interp_walk(SEXP x, SEXP env, SEXP data) { if (!Rf_isLanguage(x)) return x; if (is_call_to(x, "uq")) { SEXP uq_call = PROTECT(Rf_lang3(Rf_install("uq"), CADR(x), data)); SEXP res = PROTECT(Rf_eval(uq_call, env)); UNPROTECT(2); return res; } if (is_call_to(x, "uqf")) { return Rf_eval(x, env); } // Recursive case for(SEXP cur = x; cur != R_NilValue; cur = CDR(cur)) { SETCAR(cur, interp_walk(CAR(cur), env, data)); SEXP nxt = CDR(cur); if (is_call_to(CAR(nxt), "uqs")) { // uqs() does error checking and returns a pair list SEXP args_pl = Rf_eval(CAR(nxt), env); // Insert args_pl into existing pairlist of args SEXP last_arg = findLast(args_pl); SETCDR(last_arg, CDR(nxt)); SETCDR(cur, args_pl); } } return x; } SEXP interp_(SEXP x, SEXP env, SEXP data) { if (!Rf_isLanguage(x)) return x; if (!Rf_isEnvironment(env)) Rf_error("`env` must be an environment"); x = PROTECT(Rf_duplicate(x)); SEXP out = interp_walk(x, env, data); UNPROTECT(1); return out; } lazyeval/NAMESPACE0000644000176200001440000000376015162737605013342 0ustar liggesusers# Generated by roxygen2: do not edit by hand S3method("$",complain) S3method("$<-",lazy_dots) S3method("[",lazy_dots) S3method("[<-",lazy_dots) S3method("[[",complain) S3method(as.lazy,call) S3method(as.lazy,character) S3method(as.lazy,formula) S3method(as.lazy,lazy) S3method(as.lazy,logical) S3method(as.lazy,name) S3method(as.lazy,numeric) S3method(as.lazy_dots,"NULL") S3method(as.lazy_dots,call) S3method(as.lazy_dots,character) S3method(as.lazy_dots,formula) S3method(as.lazy_dots,lazy) S3method(as.lazy_dots,lazy_dots) S3method(as.lazy_dots,list) S3method(as.lazy_dots,name) S3method(as_call,call) S3method(as_call,character) S3method(as_call,formula) S3method(as_call,name) S3method(as_name,call) S3method(as_name,character) S3method(as_name,formula) S3method(as_name,name) S3method(c,lazy_dots) S3method(find_data,"NULL") S3method(find_data,data.frame) S3method(find_data,default) S3method(find_data,list) S3method(has_name,default) S3method(has_name,environment) S3method(interp,call) S3method(interp,character) S3method(interp,formula) S3method(interp,lazy) S3method(interp,name) S3method(print,lazy) export("f_env<-") export("f_lhs<-") export("f_rhs<-") export(all_dots) export(as.lazy) export(as.lazy_dots) export(as_call) export(as_f_list) export(as_name) export(ast) export(ast_) export(auto_name) export(call_modify) export(call_new) export(call_standardise) export(common_env) export(dots_capture) export(expr_env) export(expr_find) export(expr_label) export(expr_text) export(f_capture) export(f_env) export(f_eval) export(f_eval_lhs) export(f_eval_rhs) export(f_interp) export(f_label) export(f_lhs) export(f_list) export(f_new) export(f_rhs) export(f_text) export(f_unwrap) export(find_data) export(function_new) export(interp) export(is_atomic) export(is_call) export(is_formula) export(is_lang) export(is_name) export(is_pairlist) export(lazy) export(lazy_) export(lazy_dots) export(lazy_eval) export(make_call) export(missing_arg) export(uq) export(uqf) export(uqs) useDynLib(lazyeval, .registration = TRUE) lazyeval/NEWS.md0000644000176200001440000000657615163703671013226 0ustar liggesusers# lazyeval 0.2.3 * Fixes for CRAN checks. The new implementation is now compliant with the public C API of R and might differ from the historical one in subtle ways. # lazyeval 0.2.2 * Fix protection issues from rchk reports. # lazyeval 0.2.1 This is a maintenance release. The lazyeval package is no longer developed as the tidyverse is switching to tidy evaluation. * Use new registration system. * Switch from `SET_NAMED()` to `MARK_NOT_MUTABLE()` in prevision of an API change in R core * No longer check the type of the sides of the formula. # lazyeval 0.2.0 ## Formula-based lazy evaluation Lazyeval has a new system for lazy-eval based on formulas, described in depth in the new `lazyeval` vignette. This system is still a little experimental - it hasn't seen much use outside of the vignette, so it certainly may change a little in the future. However, long-term goal is to use these tools across all of my packages (ggplot2, tidyr, dplyr, etc), and I am fairly confident that this is a robust system that won't need major changes. There are three key components: * `f_eval()` evaluates a formula in the environment where it was defined. If supplied, values are first looked for in an optional `data` argument. Pronouns `.data` and `.env` can be used to resolve ambiguity in this case. (#43). Longer forms `f_eval_rhs()` and `f_eval_lhs()` emphasise the side of the formula that you want to evaluate (#64). * `f_interp()` provides a full quasiquoting system using `uq()` for unquote and `uqs()` for unquote-splice (#36). * `f_capture()` and `dots_capture()` make it easy to turn promises and `...` into explicit formulas. These should be used sparingly, as generally lazy-eval is preferred to non-standard eval. * For functions that work with `...`, `f_list()` and `as_f_list()` make it possible to use the evaluated LHS of a formula to name the elements of a list (#59). The core components are accompanied by a number of helper functions: * Identify a formula with `is_formula()`. * Create a formula from a quoted call and an environment with `f_new()`. * "Unwrap" a formula removing one level from the stack of parent environments with `f_unwrap()`. * Get or set either side of a formula with `f_rhs()` or `f_lhs()`, and the environment with `f_env()`. * Convert to text/label with `f_text()` and `f_label()`. I've also added `expr_find()`, `expr_text()` and `expr_label()` explicitly to find the expression associated with a function argument, and label it for output (#58). This is one of the primary uses cases for NSE. `expr_env()` is a similar helper that returns the environment associated with a promise (#67). ## Fixes to existing functions * `lazy_dots()` gains `.ignore_empty` argument to drop extra arguments (#32). * `interp.formula()` only accepts single-sided formulas (#37). * `interp()` accepts an environment in `.values` (#35). * `interp.character()` always produes a single string, regardless of input length (#27). * Fixed an infinite loop in `lazy_dots(.follow_symbols = TRUE)` (#22, #24) * `lazy()` now fails with an informative error when it is applied on an object that has already been evaluated (#23, @lionel-). * `lazy()` no longer follows the expressions of lazily loaded objects (#18, @lionel-). # lazyeval 0.1.10 * `as.lazy_dots()` gains a method for NULL, returning a zero-length list. * `auto_names()` no longer truncates symbols (#19, #20) lazyeval/inst/0000755000176200001440000000000015163705077013071 5ustar liggesuserslazyeval/inst/doc/0000755000176200001440000000000015163705077013636 5ustar liggesuserslazyeval/inst/doc/lazyeval-old.html0000644000176200001440000007524515163705073017140 0ustar liggesusers Lazyeval: a new approach to NSE

Lazyeval: a new approach to NSE

2026-04-03

This document outlines my previous approach to non-standard evaluation (NSE). You should avoid it unless you are working with an older version of dplyr or tidyr.

There are three key ideas:

  • Instead of using substitute(), use lazyeval::lazy() to capture both expression and environment. (Or use lazyeval::lazy_dots(...) to capture promises in ...)

  • Every function that uses NSE should have a standard evaluation (SE) escape hatch that does the actual computation. The SE-function name should end with _.

  • The SE-function has a flexible input specification to make it easy for people to program with.

lazy()

The key tool that makes this approach possible is lazy(), an equivalent to substitute() that captures both expression and environment associated with a function argument:

library(lazyeval)
f <- function(x = a - b) {
  lazy(x)
}
f()
#> <lazy>
#>   expr: a - b
#>   env:  <environment: 0x8b36f4f58>
f(a + b)
#> <lazy>
#>   expr: a + b
#>   env:  <environment: R_GlobalEnv>

As a complement to eval(), the lazy package provides lazy_eval() that uses the environment associated with the lazy object:

a <- 10
b <- 1
lazy_eval(f())
#> [1] 9
lazy_eval(f(a + b))
#> [1] 11

The second argument to lazy eval is a list or data frame where names should be looked up first:

lazy_eval(f(), list(a = 1))
#> [1] 0

lazy_eval() also works with formulas, since they contain the same information as a lazy object: an expression (only the RHS is used by convention) and an environment:

lazy_eval(~ a + b)
#> [1] 11
h <- function(i) {
  ~ 10 + i
}
lazy_eval(h(1))
#> [1] 11

Standard evaluation

Whenever we need a function that does non-standard evaluation, always write the standard evaluation version first. For example, let’s implement our own version of subset():

subset2_ <- function(df, condition) {
  r <- lazy_eval(condition, df)
  r <- r & !is.na(r)
  df[r, , drop = FALSE]
} 

subset2_(mtcars, lazy(mpg > 31))
#>     mpg cyl disp hp drat    wt  qsec vs am gear carb
#> 18 32.4   4 78.7 66 4.08 2.200 19.47  1  1    4    1
#> 20 33.9   4 71.1 65 4.22 1.835 19.90  1  1    4    1

lazy_eval() will always coerce it’s first argument into a lazy object, so a variety of specifications will work:

subset2_(mtcars, ~mpg > 31)
#>     mpg cyl disp hp drat    wt  qsec vs am gear carb
#> 18 32.4   4 78.7 66 4.08 2.200 19.47  1  1    4    1
#> 20 33.9   4 71.1 65 4.22 1.835 19.90  1  1    4    1
subset2_(mtcars, quote(mpg > 31))
#>     mpg cyl disp hp drat    wt  qsec vs am gear carb
#> 18 32.4   4 78.7 66 4.08 2.200 19.47  1  1    4    1
#> 20 33.9   4 71.1 65 4.22 1.835 19.90  1  1    4    1
subset2_(mtcars, "mpg > 31")
#>     mpg cyl disp hp drat    wt  qsec vs am gear carb
#> 18 32.4   4 78.7 66 4.08 2.200 19.47  1  1    4    1
#> 20 33.9   4 71.1 65 4.22 1.835 19.90  1  1    4    1

Note that quoted called and strings don’t have environments associated with them, so as.lazy() defaults to using baseenv(). This will work if the expression is self-contained (i.e. doesn’t contain any references to variables in the local environment), and will otherwise fail quickly and robustly.

Non-standard evaluation

With the SE version in hand, writing the NSE version is easy. We just use lazy() to capture the unevaluated expression and corresponding environment:

subset2 <- function(df, condition) {
  subset2_(df, lazy(condition))
}
subset2(mtcars, mpg > 31)
#>     mpg cyl disp hp drat    wt  qsec vs am gear carb
#> 18 32.4   4 78.7 66 4.08 2.200 19.47  1  1    4    1
#> 20 33.9   4 71.1 65 4.22 1.835 19.90  1  1    4    1

This standard evaluation escape hatch is very important because it allows us to implement different NSE approaches. For example, we could create a subsetting function that finds all rows where a variable is above a threshold:

above_threshold <- function(df, var, threshold) {
  cond <- interp(~ var > x, var = lazy(var), x = threshold)
  subset2_(df, cond)
}
above_threshold(mtcars, mpg, 31)
#>     mpg cyl disp hp drat    wt  qsec vs am gear carb
#> 18 32.4   4 78.7 66 4.08 2.200 19.47  1  1    4    1
#> 20 33.9   4 71.1 65 4.22 1.835 19.90  1  1    4    1

Here we’re using interp() to modify a formula. We use the value of threshold and the expression in by var.

Scoping

Because lazy() captures the environment associated with the function argument, we automatically avoid a subtle scoping bug present in subset():

x <- 31
f1 <- function(...) {
  x <- 30
  subset(mtcars, ...)
}
# Uses 30 instead of 31
f1(mpg > x)
#>     mpg cyl disp  hp drat    wt  qsec vs am gear carb
#> 18 32.4   4 78.7  66 4.08 2.200 19.47  1  1    4    1
#> 19 30.4   4 75.7  52 4.93 1.615 18.52  1  1    4    2
#> 20 33.9   4 71.1  65 4.22 1.835 19.90  1  1    4    1
#> 28 30.4   4 95.1 113 3.77 1.513 16.90  1  1    5    2

f2 <- function(...) {
  x <- 30
  subset2(mtcars, ...)
}
# Correctly uses 31
f2(mpg > x)
#>     mpg cyl disp hp drat    wt  qsec vs am gear carb
#> 18 32.4   4 78.7 66 4.08 2.200 19.47  1  1    4    1
#> 20 33.9   4 71.1 65 4.22 1.835 19.90  1  1    4    1

lazy() has another advantage over substitute() - by default, it follows promises across function invocations. This simplifies the casual use of NSE.

x <- 31
g1 <- function(comp) {
  x <- 30
  subset(mtcars, comp)
}
g1(mpg > x)
#> Error: object 'mpg' not found
g2 <- function(comp) {
  x <- 30
  subset2(mtcars, comp)
}
g2(mpg > x)
#>     mpg cyl disp hp drat    wt  qsec vs am gear carb
#> 18 32.4   4 78.7 66 4.08 2.200 19.47  1  1    4    1
#> 20 33.9   4 71.1 65 4.22 1.835 19.90  1  1    4    1

Note that g2() doesn’t have a standard-evaluation escape hatch, so it’s not suitable for programming with in the same way that subset2_() is.

Chained promises

Take the following example:

library(lazyeval)
f1 <- function(x) lazy(x)
g1 <- function(y) f1(y)

g1(a + b)
#> <lazy>
#>   expr: a + b
#>   env:  <environment: R_GlobalEnv>

lazy() returns a + b because it always tries to find the top-level promise.

In this case the process looks like this:

  1. Find the object that x is bound to.
  2. It’s a promise, so find the expr it’s bound to (y, a symbol) and the environment in which it should be evaluated (the environment of g()).
  3. Since x is bound to a symbol, look up its value: it’s bound to a promise.
  4. That promise has expression a + b and should be evaluated in the global environment.
  5. The expression is not a symbol, so stop.

Occasionally, you want to avoid this recursive behaviour, so you can use follow_symbol = FALSE:

f2 <- function(x) lazy(x, .follow_symbols = FALSE)
g2 <- function(y) f2(y)

g2(a + b)
#> <lazy>
#>   expr: x
#>   env:  <environment: 0x8b0915d58>

Either way, if you evaluate the lazy expression you’ll get the same result:

a <- 10
b <- 1

lazy_eval(g1(a + b))
#> [1] 11
lazy_eval(g2(a + b))
#> [1] 11

Note that the resolution of chained promises only works with unevaluated objects. This is because R deletes the information about the environment associated with a promise when it has been forced, so that the garbage collector is allowed to remove the environment from memory in case it is no longer used. lazy() will fail with an error in such situations.

var <- 0

f3 <- function(x) {
  force(x)
  lazy(x)
}

f3(var)
#> Error in `lazy()`:
#> ! Promise has already been forced
lazyeval/inst/doc/lazyeval-old.R0000644000176200001440000000512015163705072016355 0ustar liggesusers## ----echo = FALSE------------------------------------------------------------- knitr::opts_chunk$set(collapse = TRUE, comment = "#>") rownames(mtcars) <- NULL ## ----------------------------------------------------------------------------- library(lazyeval) f <- function(x = a - b) { lazy(x) } f() f(a + b) ## ----------------------------------------------------------------------------- a <- 10 b <- 1 lazy_eval(f()) lazy_eval(f(a + b)) ## ----------------------------------------------------------------------------- lazy_eval(f(), list(a = 1)) ## ----------------------------------------------------------------------------- lazy_eval(~ a + b) h <- function(i) { ~ 10 + i } lazy_eval(h(1)) ## ----------------------------------------------------------------------------- subset2_ <- function(df, condition) { r <- lazy_eval(condition, df) r <- r & !is.na(r) df[r, , drop = FALSE] } subset2_(mtcars, lazy(mpg > 31)) ## ----------------------------------------------------------------------------- subset2_(mtcars, ~mpg > 31) subset2_(mtcars, quote(mpg > 31)) subset2_(mtcars, "mpg > 31") ## ----------------------------------------------------------------------------- subset2 <- function(df, condition) { subset2_(df, lazy(condition)) } subset2(mtcars, mpg > 31) ## ----------------------------------------------------------------------------- above_threshold <- function(df, var, threshold) { cond <- interp(~ var > x, var = lazy(var), x = threshold) subset2_(df, cond) } above_threshold(mtcars, mpg, 31) ## ----------------------------------------------------------------------------- x <- 31 f1 <- function(...) { x <- 30 subset(mtcars, ...) } # Uses 30 instead of 31 f1(mpg > x) f2 <- function(...) { x <- 30 subset2(mtcars, ...) } # Correctly uses 31 f2(mpg > x) ## ----eval = FALSE------------------------------------------------------------- # x <- 31 # g1 <- function(comp) { # x <- 30 # subset(mtcars, comp) # } # g1(mpg > x) # #> Error: object 'mpg' not found ## ----------------------------------------------------------------------------- g2 <- function(comp) { x <- 30 subset2(mtcars, comp) } g2(mpg > x) ## ----------------------------------------------------------------------------- library(lazyeval) f1 <- function(x) lazy(x) g1 <- function(y) f1(y) g1(a + b) ## ----------------------------------------------------------------------------- f2 <- function(x) lazy(x, .follow_symbols = FALSE) g2 <- function(y) f2(y) g2(a + b) ## ----------------------------------------------------------------------------- a <- 10 b <- 1 lazy_eval(g1(a + b)) lazy_eval(g2(a + b)) lazyeval/inst/doc/lazyeval-old.Rmd0000644000176200001440000001337713171350764016714 0ustar liggesusers--- title: "Lazyeval: a new approach to NSE" date: "`r Sys.Date()`" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Lazyeval: a new approach to NSE} %\VignetteEngine{knitr::rmarkdown} %\usepackage[utf8]{inputenc} --- ```{r, echo = FALSE} knitr::opts_chunk$set(collapse = TRUE, comment = "#>") rownames(mtcars) <- NULL ``` This document outlines my previous approach to non-standard evaluation (NSE). You should avoid it unless you are working with an older version of dplyr or tidyr. There are three key ideas: * Instead of using `substitute()`, use `lazyeval::lazy()` to capture both expression and environment. (Or use `lazyeval::lazy_dots(...)` to capture promises in `...`) * Every function that uses NSE should have a standard evaluation (SE) escape hatch that does the actual computation. The SE-function name should end with `_`. * The SE-function has a flexible input specification to make it easy for people to program with. ## `lazy()` The key tool that makes this approach possible is `lazy()`, an equivalent to `substitute()` that captures both expression and environment associated with a function argument: ```{r} library(lazyeval) f <- function(x = a - b) { lazy(x) } f() f(a + b) ``` As a complement to `eval()`, the lazy package provides `lazy_eval()` that uses the environment associated with the lazy object: ```{r} a <- 10 b <- 1 lazy_eval(f()) lazy_eval(f(a + b)) ``` The second argument to lazy eval is a list or data frame where names should be looked up first: ```{r} lazy_eval(f(), list(a = 1)) ``` `lazy_eval()` also works with formulas, since they contain the same information as a lazy object: an expression (only the RHS is used by convention) and an environment: ```{r} lazy_eval(~ a + b) h <- function(i) { ~ 10 + i } lazy_eval(h(1)) ``` ## Standard evaluation Whenever we need a function that does non-standard evaluation, always write the standard evaluation version first. For example, let's implement our own version of `subset()`: ```{r} subset2_ <- function(df, condition) { r <- lazy_eval(condition, df) r <- r & !is.na(r) df[r, , drop = FALSE] } subset2_(mtcars, lazy(mpg > 31)) ``` `lazy_eval()` will always coerce it's first argument into a lazy object, so a variety of specifications will work: ```{r} subset2_(mtcars, ~mpg > 31) subset2_(mtcars, quote(mpg > 31)) subset2_(mtcars, "mpg > 31") ``` Note that quoted called and strings don't have environments associated with them, so `as.lazy()` defaults to using `baseenv()`. This will work if the expression is self-contained (i.e. doesn't contain any references to variables in the local environment), and will otherwise fail quickly and robustly. ## Non-standard evaluation With the SE version in hand, writing the NSE version is easy. We just use `lazy()` to capture the unevaluated expression and corresponding environment: ```{r} subset2 <- function(df, condition) { subset2_(df, lazy(condition)) } subset2(mtcars, mpg > 31) ``` This standard evaluation escape hatch is very important because it allows us to implement different NSE approaches. For example, we could create a subsetting function that finds all rows where a variable is above a threshold: ```{r} above_threshold <- function(df, var, threshold) { cond <- interp(~ var > x, var = lazy(var), x = threshold) subset2_(df, cond) } above_threshold(mtcars, mpg, 31) ``` Here we're using `interp()` to modify a formula. We use the value of `threshold` and the expression in by `var`. ## Scoping Because `lazy()` captures the environment associated with the function argument, we automatically avoid a subtle scoping bug present in `subset()`: ```{r} x <- 31 f1 <- function(...) { x <- 30 subset(mtcars, ...) } # Uses 30 instead of 31 f1(mpg > x) f2 <- function(...) { x <- 30 subset2(mtcars, ...) } # Correctly uses 31 f2(mpg > x) ``` `lazy()` has another advantage over `substitute()` - by default, it follows promises across function invocations. This simplifies the casual use of NSE. ```{r, eval = FALSE} x <- 31 g1 <- function(comp) { x <- 30 subset(mtcars, comp) } g1(mpg > x) #> Error: object 'mpg' not found ``` ```{r} g2 <- function(comp) { x <- 30 subset2(mtcars, comp) } g2(mpg > x) ``` Note that `g2()` doesn't have a standard-evaluation escape hatch, so it's not suitable for programming with in the same way that `subset2_()` is. ## Chained promises Take the following example: ```{r} library(lazyeval) f1 <- function(x) lazy(x) g1 <- function(y) f1(y) g1(a + b) ``` `lazy()` returns `a + b` because it always tries to find the top-level promise. In this case the process looks like this: 1. Find the object that `x` is bound to. 2. It's a promise, so find the expr it's bound to (`y`, a symbol) and the environment in which it should be evaluated (the environment of `g()`). 3. Since `x` is bound to a symbol, look up its value: it's bound to a promise. 4. That promise has expression `a + b` and should be evaluated in the global environment. 5. The expression is not a symbol, so stop. Occasionally, you want to avoid this recursive behaviour, so you can use `follow_symbol = FALSE`: ```{r} f2 <- function(x) lazy(x, .follow_symbols = FALSE) g2 <- function(y) f2(y) g2(a + b) ``` Either way, if you evaluate the lazy expression you'll get the same result: ```{r} a <- 10 b <- 1 lazy_eval(g1(a + b)) lazy_eval(g2(a + b)) ``` Note that the resolution of chained promises only works with unevaluated objects. This is because R deletes the information about the environment associated with a promise when it has been forced, so that the garbage collector is allowed to remove the environment from memory in case it is no longer used. `lazy()` will fail with an error in such situations. ```{r, error = TRUE, purl = FALSE} var <- 0 f3 <- function(x) { force(x) lazy(x) } f3(var) ``` lazyeval/inst/doc/lazyeval.html0000644000176200001440000027242415163705077016366 0ustar liggesusers Non-standard evaluation

Non-standard evaluation

Hadley Wickham

2026-04-03

This document describes lazyeval, a package that provides principled tools to perform non-standard evaluation (NSE) in R. You should read this vignette if you want to program with packages like dplyr and ggplot21, or you want a principled way of working with delayed expressions in your own package. As the name suggests, non-standard evaluation breaks away from the standard evaluation (SE) rules in order to do something special. There are three common uses of NSE:

  1. Labelling enhances plots and tables by using the expressions supplied to a function, rather than their values. For example, note the axis labels in this plot:

    par(mar = c(4.5, 4.5, 1, 0.5))
grid <- seq(0, 2 * pi, length = 100)
plot(grid, sin(grid), type = "l")

  2. Non-standard scoping looks for objects in places other than the current environment. For example, base R has with(), subset(), and transform() that look for objects in a data frame (or list) before the current environment:

    df <- data.frame(x = c(1, 5, 4, 2, 3), y = c(2, 1, 5, 4, 3))

with(df, mean(x))
#> [1] 3
subset(df, x == y)
#>   x y
#> 5 3 3
transform(df, z = x + y)
#>   x y z
#> 1 1 2 3
#> 2 5 1 6
#> 3 4 5 9
#> 4 2 4 6
#> 5 3 3 6

  3. Metaprogramming is a catch-all term that covers all other uses of NSE (such as in bquote() and library()). Metaprogramming is so called because it involves computing on the unevaluated code in some way.

This document is broadly organised according to the three types of non-standard evaluation described above. The main difference is that after labelling, we’ll take a detour to learn more about formulas. You’re probably familiar with formulas from linear models (e.g. lm(mpg ~ displ, data = mtcars)) but formulas are more than just a tool for modelling: they are a general way of capturing an unevaluated expression.

The approaches recommended here are quite different to my previous generation of recommendations. I am fairly confident these new approaches are correct, and will not have to change substantially again. The current tools make it easy to solve a number of practical problems that were previously challenging and are rooted in long-standing theory.

Labelling

In base R, the classic way to turn an argument into a label is to use deparse(substitute(x)):

my_label <- function(x) deparse(substitute(x))
my_label(x + y)
#> [1] "x + y"

There are two potential problems with this approach:

  1. For long some expressions, deparse() generates a character vector with length > 1:

    my_label({
  a + b
  c + d
})
#> [1] "{"         "    a + b" "    c + d" "}"

  2. substitute() only looks one level up, so you lose the original label if the function isn’t called directly:

    my_label2 <- function(x) my_label(x)
my_label2(a + b)
#> [1] "x"

Both of these problems are resolved by lazyeval::expr_text():

my_label <- function(x) expr_text(x)
my_label2 <- function(x) my_label(x)
   
my_label({
  a + b
  c + d
})
#> [1] "{\n    a + b\n    c + d\n}"
my_label2(a + b)
#> [1] "a + b"

There are two variations on the theme of expr_text():

  • expr_find() find the underlying expression. It works similarly to substitute() but will follow a chain of promises back up to the original expression. This is often useful for metaprogramming.

  • expr_label() is a customised version of expr_text() that produces labels designed to be used in messages to the user:

    expr_label(x)
#> [1] "`x`"
expr_label(a + b + c)
#> [1] "`a + b + c`"
expr_label(foo({
  x + y
}))
#> [1] "`foo(...)`"

Exercises

  1. plot() uses deparse(substitute(x)) to generate labels for the x and y axes. Can you generate input that causes it to display bad labels? Write your own wrapper around plot() that uses expr_label() to compute xlim and ylim.

  2. Create a simple implementation of mean() that stops with an informative error message if the argument is not numeric:

    x <- c("a", "b", "c")
my_mean(x)
#> Error: `x` is a not a numeric vector.
my_mean(x == "a")
#> Error: `x == "a"` is not a numeric vector.
my_mean("a")
#> Error: "a" is not a numeric vector.

  3. Read the source code for expr_text(). How does it work? What additional arguments to deparse() does it use?

Formulas

Non-standard scoping is probably the most useful NSE tool, but before we can talk about a solid approach, we need to take a detour to talk about formulas. Formulas are a familiar tool from linear models, but their utility is not limited to models. In fact, formulas are a powerful, general purpose tool, because a formula captures two things:

  1. An unevaluated expression.
  2. The context (environment) in which the expression was created.

~ is a single character that allows you to say: “I want to capture the meaning of this code, without evaluating it right away”. For that reason, the formula can be thought of as a “quoting” operator.

Definition of a formula

Technically, a formula is a “language” object (i.e. an unevaluated expression) with a class of “formula” and an attribute that stores the environment:

f <- ~ x + y + z
typeof(f)
#> [1] "language"
attributes(f)
#> $class
#> [1] "formula"
#> 
#> $.Environment
#> <environment: R_GlobalEnv>

The structure of the underlying object is slightly different depending on whether you have a one-sided or two-sided formula:

  • One-sided formulas have length two:

    length(f)
#> [1] 2
# The 1st element is always ~
f[[1]]
#> `~`
# The 2nd element is the RHS
f[[2]]
#> x + y + z

  • Two-sided formulas have length three:

    g <- y ~ x + z
length(g)
#> [1] 3
# The 1st element is still ~
g[[1]]
#> `~`
# But now the 2nd element is the LHS
g[[2]]
#> y
# And the 3rd element is the RHS
g[[3]]
#> x + z

To abstract away these differences, lazyeval provides f_rhs() and f_lhs() to access either side of the formula, and f_env() to access its environment:

f_rhs(f)
#> x + y + z
f_lhs(f)
#> NULL
f_env(f)
#> <environment: R_GlobalEnv>

f_rhs(g)
#> x + z
f_lhs(g)
#> y
f_env(g)
#> <environment: R_GlobalEnv>

Evaluating a formula

A formula captures delays the evaluation of an expression so you can later evaluate it with f_eval():

f <- ~ 1 + 2 + 3
f
#> ~1 + 2 + 3
f_eval(f)
#> [1] 6

This allows you to use a formula as a robust way of delaying evaluation, cleanly separating the creation of the formula from its evaluation. Because formulas capture the code and context, you get the correct result even when a formula is created and evaluated in different places. In the following example, note that the value of x inside add_1000() is used:

x <- 1
add_1000 <- function(x) {
  ~ 1000 + x
}

add_1000(3)
#> ~1000 + x
#> <environment: 0x8b0e70a50>
f_eval(add_1000(3))
#> [1] 1003

It can be hard to see what’s going on when looking at a formula because important values are stored in the environment, which is largely opaque. You can use f_unwrap() to replace names with their corresponding values:

f_unwrap(add_1000(3))
#> ~1000 + 3

Non-standard scoping

f_eval() has an optional second argument: a named list (or data frame) that overrides values found in the formula’s environment.

y <- 100
f_eval(~ y)
#> [1] 100
f_eval(~ y, data = list(y = 10))
#> [1] 10

# Can mix variables in environment and data argument
f_eval(~ x + y, data = list(x = 10))
#> [1] 110
# Can even supply functions
f_eval(~ f(y), data = list(f = function(x) x * 3))
#> [1] 300

This makes it very easy to implement non-standard scoping:

f_eval(~ mean(cyl), data = mtcars)
#> [1] 6.1875

One challenge with non-standard scoping is that we’ve introduced some ambiguity. For example, in the code below does x come from mydata or the environment?

f_eval(~ x, data = mydata)

You can’t tell without knowing whether or not mydata has a variable called x. To overcome this problem, f_eval() provides two pronouns:

  • .data is bound to the data frame.
  • .env is bound to the formula environment.

They both start with . to minimise the chances of clashing with existing variables.

With these pronouns we can rewrite the previous formula to remove the ambiguity:

mydata <- data.frame(x = 100, y = 1)
x <- 10

f_eval(~ .env$x, data = mydata)
#> [1] 10
f_eval(~ .data$x, data = mydata)
#> [1] 100

If the variable or object doesn’t exist, you’ll get an informative error:

f_eval(~ .env$z, data = mydata)
#> Error:
#> ! Object 'z' not found in environment
f_eval(~ .data$z, data = mydata)
#> Error:
#> ! Variable 'z' not found in data

Unquoting

f_eval() has one more useful trick up its sleeve: unquoting. Unquoting allows you to write functions where the user supplies part of the formula. For example, the following function allows you to compute the mean of any column (or any function of a column):

df_mean <- function(df, variable) {
  f_eval(~ mean(uq(variable)), data = df)
}

df_mean(mtcars, ~ cyl)
#> [1] 6.1875
df_mean(mtcars, ~ disp * 0.01638)
#> [1] 3.779224
df_mean(mtcars, ~ sqrt(mpg))
#> [1] 4.43477

To see how this works, we can use f_interp() which f_eval() calls internally (you shouldn’t call it in your own code, but it’s useful for debugging). The key is uq(): uq() evaluates its first (and only) argument and inserts the value into the formula:

variable <- ~cyl
f_interp(~ mean(uq(variable)))
#> ~mean(cyl)

variable <- ~ disp * 0.01638
f_interp(~ mean(uq(variable)))
#> ~mean(disp * 0.01638)

Unquoting allows you to create code “templates”, where you write most of the expression, while still allowing the user to control important components. You can even use uq() to change the function being called:

f <- ~ mean
f_interp(~ uq(f)(uq(variable)))
#> ~mean(disp * 0.01638)

Note that uq() only takes the RHS of a formula, which makes it difficult to insert literal formulas into a call:

formula <- y ~ x
f_interp(~ lm(uq(formula), data = df))
#> ~lm(x, data = df)

You can instead use uqf() which uses the whole formula, not just the RHS:

f_interp(~ lm(uqf(formula), data = df))
#> ~lm(y ~ x, data = df)

Unquoting is powerful, but it only allows you to modify a single argument: it doesn’t allow you to add an arbitrary number of arguments. To do that, you’ll need “unquote-splice”, or uqs(). The first (and only) argument to uqs() should be a list of arguments to be spliced into the call:

variable <- ~ x
extra_args <- list(na.rm = TRUE, trim = 0.9)
f_interp(~ mean(uq(variable), uqs(extra_args)))
#> ~mean(x, na.rm = TRUE, trim = 0.9)

Exercises

  1. Create a wrapper around lm() that allows the user to supply the response and predictors as two separate formulas.

  2. Compare and contrast f_eval() with with().

  3. Why does this code work even though f is defined in two places? (And one of them is not a function).

    f <- function(x) x + 1
f_eval(~ f(10), list(f = "a"))
#> [1] 11

Non-standard scoping

Non-standard scoping (NSS) is an important part of R because it makes it easy to write functions tailored for interactive data exploration. These functions require less typing, at the cost of some ambiguity and “magic”. This is a good trade-off for interactive data exploration because you want to get ideas out of your head and into the computer as quickly as possible. If a function does make a bad guess, you’ll spot it quickly because you’re working interactively.

There are three challenges to implementing non-standard scoping:

  1. You must correctly delay the evaluation of a function argument, capturing both the computation (the expression), and the context (the environment). I recommend making this explicit by requiring the user to “quote” any NSS arguments with ~, and then evaluating explicit with f_eval().

  2. When writing functions that use NSS-functions, you need some way to avoid the automatic lookup and be explicit about where objects should be found. f_eval() solves this problem with the .data. and .env pronouns.

  3. You need some way to allow the user to supply parts of a formula. f_eval() solves this with unquoting.

To illustrate these challenges, I will implement a sieve() function that works similarly to base::subset() or dplyr::filter(). The goal of sieve() is to make it easy to select observations that match criteria defined by a logical expression. sieve() has three advantages over [:

  1. It is much more compact when the condition uses many variables, because you don’t need to repeat the name of the data frame many times.

  2. It drops rows where the condition evaluates to NA, rather than filling them with NAs.

  3. It always returns a data frame.

The implementation of sieve() is straightforward. First we use f_eval() to perform NSS. Then we then check that we have a logical vector, replace NAs with FALSE, and subset with [.

sieve <- function(df, condition) {
  rows <- f_eval(condition, df)
  if (!is.logical(rows)) {
    stop("`condition` must be logical.", call. = FALSE)
  }
  
  rows[is.na(rows)] <- FALSE
  df[rows, , drop = FALSE]
}

df <- data.frame(x = 1:5, y = 5:1)
sieve(df, ~ x <= 2)
#>   x y
#> 1 1 5
#> 2 2 4
sieve(df, ~ x == y)
#>   x y
#> 3 3 3

Programming with sieve()

Imagine that you’ve written some code that looks like this:

sieve(march, ~ x > 100)
sieve(april, ~ x > 50)
sieve(june, ~ x > 45)
sieve(july, ~ x > 17)

(This is a contrived example, but it illustrates all of the important issues you’ll need to consider when writing more useful functions.)

Instead of continuing to copy-and-paste your code, you decide to wrap up the common behaviour in a function:

threshold_x <- function(df, threshold) {
  sieve(df, ~ x > threshold)
}
threshold_x(df, 3)
#>   x y
#> 4 4 2
#> 5 5 1

There are two ways that this function might fail:

  1. The data frame might not have a variable called x. This will fail unless there’s a variable called x hanging around in the global environment:

    rm(x)
df2 <- data.frame(y = 5:1)

# Throws an error
threshold_x(df2, 3)
#> Error:
#> ! object 'x' not found

# Silently gives the incorrect result!
x <- 5
threshold_x(df2, 3)
#>   y
#> 1 5
#> 2 4
#> 3 3
#> 4 2
#> 5 1

  2. The data frame might have a variable called threshold:

    df3 <- data.frame(x = 1:5, y = 5:1, threshold = 4)
threshold_x(df3, 3)
#>   x y threshold
#> 5 5 1         4

These failures are partiuclarly pernicious because instead of throwing an error they silently produce the wrong answer. Both failures arise because f_eval() introduces ambiguity by looking in two places for each name: the supplied data and formula environment.

To make threshold_x() more reliable, we need to be more explicit by using the .data and .env pronouns:

threshold_x <- function(df, threshold) {
  sieve(df, ~ .data$x > .env$threshold)
}

threshold_x(df2, 3)
#> Error:
#> ! Variable 'x' not found in data
threshold_x(df3, 3)
#>   x y threshold
#> 4 4 2         4
#> 5 5 1         4

Here .env is bound to the environment where ~ is evaluated, namely the inside of threshold_x().

Adding arguments

The threshold_x() function is not very useful because it’s bound to a specific variable. It would be more powerful if we could vary both the threshold and the variable it applies to. We can do that by taking an additional argument to specify which variable to use.

One simple approach is to use a string and [[:

threshold <- function(df, variable, threshold) {
  stopifnot(is.character(variable), length(variable) == 1)
  
  sieve(df, ~ .data[[.env$variable]] > .env$threshold)
}
threshold(df, "x", 4)
#>   x y
#> 5 5 1

This is a simple and robust solution, but only allows us to use an existing variable, not an arbitrary expression like sqrt(x).

A more general solution is to allow the user to supply a formula, and use unquoting:

threshold <- function(df, variable = ~x, threshold = 0) {
  sieve(df, ~ uq(variable) > .env$threshold)
}

threshold(df, ~ x, 4)
#>   x y
#> 5 5 1
threshold(df, ~ abs(x - y), 2)
#>   x y
#> 1 1 5
#> 5 5 1

In this case, it’s the responsibility of the user to ensure the variable is specified unambiguously. f_eval() is designed so that .data and .env work even when evaluated inside of uq():

x <- 3
threshold(df, ~ .data$x - .env$x, 0)
#>   x y
#> 4 4 2
#> 5 5 1

Dot-dot-dot

There is one more tool that you might find useful for functions that take .... For example, the code below implements a function similar to dplyr::mutate() or base::transform().

mogrify <- function(`_df`, ...) {
  args <- list(...)
  
  for (nm in names(args)) {
    `_df`[[nm]] <- f_eval(args[[nm]], `_df`)
  }
  
  `_df`
}

(NB: the first argument is a non-syntactic name (i.e. it requires quoting with `) so it doesn’t accidentally match one of the names of the new variables.)

transmogrifty() makes it easy to add new variables to a data frame:

df <- data.frame(x = 1:5, y = sample(5))
mogrify(df, z = ~ x + y, z2 = ~ z * 2)
#>   x y z z2
#> 1 1 3 4  8
#> 2 2 5 7 14
#> 3 3 1 4  8
#> 4 4 4 8 16
#> 5 5 2 7 14

One problem with this implementation is that it’s hard to specify the names of the generated variables. Imagine you want a function where the name and expression are in separate variables. This is awkward because the variable name is supplied as an argument name to mogrify():

add_variable <- function(df, name, expr) {
  do.call("mogrify", c(list(df), setNames(list(expr), name)))
}
add_variable(df, "z", ~ x + y)
#>   x y z
#> 1 1 3 4
#> 2 2 5 7
#> 3 3 1 4
#> 4 4 4 8
#> 5 5 2 7

Lazyeval provides the f_list() function to make writing this sort of function a little easier. It takes a list of formulas and evaluates the LHS of each formula (if present) to rename the elements:

f_list("x" ~ y, z = ~z)
#> $x
#> ~y
#> 
#> $z
#> ~z

If we tweak mogrify() to use f_list() instead of list():

mogrify <- function(`_df`, ...) {
  args <- f_list(...)
  
  for (nm in names(args)) {
    `_df`[[nm]] <- f_eval(args[[nm]], `_df`)
  }
  
  `_df`
}

add_new() becomes much simpler:

add_variable <- function(df, name, expr) {
  mogrify(df, name ~ uq(expr))
}
add_variable(df, "z", ~ x + y)
#>   x y z
#> 1 1 3 4
#> 2 2 5 7
#> 3 3 1 4
#> 4 4 4 8
#> 5 5 2 7

Exercises

  1. Write a function that selects all rows of df where variable is greater than its mean. Make the function more general by allowing the user to specify a function to use instead of mean() (e.g. median()).

  2. Create a version of mogrify() where the first argument is x? What happens if you try to create a new variable called x?

Non-standard evaluation

In some situations you might want to eliminate the formula altogether, and allow the user to type expressions directly. I was once much enamoured with this approach (witness ggplot2, dplyr, …). However, I now think that it should be used sparingly because explict quoting with ~ leads to simpler code, and makes it more clear to the user that something special is going on.

That said, lazyeval does allow you to eliminate the ~ if you really want to. In this case, I recommend having both a NSE and SE version of the function. The SE version, which takes formuals, should have suffix _:

sieve_ <- function(df, condition) {
  rows <- f_eval(condition, df)
  if (!is.logical(rows)) {
    stop("`condition` must be logical.", call. = FALSE)
  }
  
  rows[is.na(rows)] <- FALSE
  df[rows, , drop = FALSE]
}

Then create the NSE version which doesn’t need the explicit formula. The key is the use of f_capture() which takes an unevaluated argument (a promise) and captures it as a formula:

sieve <- function(df, expr) {
  sieve_(df, f_capture(expr))
}
sieve(df, x == 1)
#>   x y
#> 1 1 3

If you’re familiar with substitute() you might expect the same drawbacks to apply. However, f_capture() is smart enough to follow a chain of promises back to the original value, so, for example, this code works fine:

scramble <- function(df) {
  df[sample(nrow(df)), , drop = FALSE]
}
subscramble <- function(df, expr) {
  scramble(sieve(df, expr))
}
subscramble(df, x < 4)
#>   x y
#> 2 2 5
#> 1 1 3
#> 3 3 1

Dot-dot-dot

If you want a ... function that doesn’t require formulas, I recommend that the SE version take a list of arguments, and the NSE version uses dots_capture() to capture multiple arguments as a list of formulas.

mogrify_ <- function(`_df`, args) {
  args <- as_f_list(args)
  
  for (nm in names(args)) {
    `_df`[[nm]] <- f_eval(args[[nm]], `_df`)
  }
  
  `_df`
}

mogrify <- function(`_df`, ...) {
  mogrify_(`_df`, dots_capture(...))
}

Exercises

  1. Recreate subscramble() using base::subset() instead of sieve(). Why does it fail?

Metaprogramming

The final use of non-standard evaluation is to do metaprogramming. This is a catch-all term that encompasses any function that does computation on an unevaluated expression. You can learn about metaprogrgramming in http://adv-r.had.co.nz/Expressions.html, particularly http://adv-r.had.co.nz/Expressions.html#ast-funs. Over time, the goal is to move all useful metaprogramming helper functions into this package, and discuss metaprogramming more here.

  1. Currently neither ggplot2 nor dplyr actually use these tools since I’ve only just figured it out. But I’ll be working hard to make sure all my packages are consistent in the near future.↩︎

lazyeval/inst/doc/lazyeval.R0000644000176200001440000002106315163705077015612 0ustar liggesusers## ----include = FALSE---------------------------------------------------------- library(lazyeval) knitr::opts_chunk$set(collapse = TRUE, comment = "#>") ## ----fig.width = 4, fig.height = 2.5------------------------------------------ par(mar = c(4.5, 4.5, 1, 0.5)) grid <- seq(0, 2 * pi, length = 100) plot(grid, sin(grid), type = "l") ## ----------------------------------------------------------------------------- df <- data.frame(x = c(1, 5, 4, 2, 3), y = c(2, 1, 5, 4, 3)) with(df, mean(x)) subset(df, x == y) transform(df, z = x + y) ## ----------------------------------------------------------------------------- my_label <- function(x) deparse(substitute(x)) my_label(x + y) ## ----------------------------------------------------------------------------- my_label({ a + b c + d }) ## ----------------------------------------------------------------------------- my_label2 <- function(x) my_label(x) my_label2(a + b) ## ----------------------------------------------------------------------------- my_label <- function(x) expr_text(x) my_label2 <- function(x) my_label(x) my_label({ a + b c + d }) my_label2(a + b) ## ----------------------------------------------------------------------------- expr_label(x) expr_label(a + b + c) expr_label(foo({ x + y })) ## ----eval = FALSE------------------------------------------------------------- # x <- c("a", "b", "c") # my_mean(x) # #> Error: `x` is a not a numeric vector. # my_mean(x == "a") # #> Error: `x == "a"` is not a numeric vector. # my_mean("a") # #> Error: "a" is not a numeric vector. ## ----------------------------------------------------------------------------- f <- ~ x + y + z typeof(f) attributes(f) ## ----------------------------------------------------------------------------- length(f) # The 1st element is always ~ f[[1]] # The 2nd element is the RHS f[[2]] ## ----------------------------------------------------------------------------- g <- y ~ x + z length(g) # The 1st element is still ~ g[[1]] # But now the 2nd element is the LHS g[[2]] # And the 3rd element is the RHS g[[3]] ## ----------------------------------------------------------------------------- f_rhs(f) f_lhs(f) f_env(f) f_rhs(g) f_lhs(g) f_env(g) ## ----------------------------------------------------------------------------- f <- ~ 1 + 2 + 3 f f_eval(f) ## ----------------------------------------------------------------------------- x <- 1 add_1000 <- function(x) { ~ 1000 + x } add_1000(3) f_eval(add_1000(3)) ## ----------------------------------------------------------------------------- f_unwrap(add_1000(3)) ## ----------------------------------------------------------------------------- y <- 100 f_eval(~ y) f_eval(~ y, data = list(y = 10)) # Can mix variables in environment and data argument f_eval(~ x + y, data = list(x = 10)) # Can even supply functions f_eval(~ f(y), data = list(f = function(x) x * 3)) ## ----------------------------------------------------------------------------- f_eval(~ mean(cyl), data = mtcars) ## ----eval = FALSE------------------------------------------------------------- # f_eval(~ x, data = mydata) ## ----------------------------------------------------------------------------- mydata <- data.frame(x = 100, y = 1) x <- 10 f_eval(~ .env$x, data = mydata) f_eval(~ .data$x, data = mydata) ## ----error = TRUE------------------------------------------------------------- try({ f_eval(~ .env$z, data = mydata) f_eval(~ .data$z, data = mydata) }) ## ----------------------------------------------------------------------------- df_mean <- function(df, variable) { f_eval(~ mean(uq(variable)), data = df) } df_mean(mtcars, ~ cyl) df_mean(mtcars, ~ disp * 0.01638) df_mean(mtcars, ~ sqrt(mpg)) ## ----------------------------------------------------------------------------- variable <- ~cyl f_interp(~ mean(uq(variable))) variable <- ~ disp * 0.01638 f_interp(~ mean(uq(variable))) ## ----------------------------------------------------------------------------- f <- ~ mean f_interp(~ uq(f)(uq(variable))) ## ----------------------------------------------------------------------------- formula <- y ~ x f_interp(~ lm(uq(formula), data = df)) ## ----------------------------------------------------------------------------- f_interp(~ lm(uqf(formula), data = df)) ## ----------------------------------------------------------------------------- variable <- ~ x extra_args <- list(na.rm = TRUE, trim = 0.9) f_interp(~ mean(uq(variable), uqs(extra_args))) ## ----------------------------------------------------------------------------- f <- function(x) x + 1 f_eval(~ f(10), list(f = "a")) ## ----------------------------------------------------------------------------- sieve <- function(df, condition) { rows <- f_eval(condition, df) if (!is.logical(rows)) { stop("`condition` must be logical.", call. = FALSE) } rows[is.na(rows)] <- FALSE df[rows, , drop = FALSE] } df <- data.frame(x = 1:5, y = 5:1) sieve(df, ~ x <= 2) sieve(df, ~ x == y) ## ----eval = FALSE------------------------------------------------------------- # sieve(march, ~ x > 100) # sieve(april, ~ x > 50) # sieve(june, ~ x > 45) # sieve(july, ~ x > 17) ## ----------------------------------------------------------------------------- threshold_x <- function(df, threshold) { sieve(df, ~ x > threshold) } threshold_x(df, 3) ## ----error = TRUE------------------------------------------------------------- try({ rm(x) df2 <- data.frame(y = 5:1) # Throws an error threshold_x(df2, 3) # Silently gives the incorrect result! x <- 5 threshold_x(df2, 3) }) ## ----------------------------------------------------------------------------- df3 <- data.frame(x = 1:5, y = 5:1, threshold = 4) threshold_x(df3, 3) ## ----error = TRUE------------------------------------------------------------- try({ threshold_x <- function(df, threshold) { sieve(df, ~ .data$x > .env$threshold) } threshold_x(df2, 3) threshold_x(df3, 3) }) ## ----------------------------------------------------------------------------- threshold <- function(df, variable, threshold) { stopifnot(is.character(variable), length(variable) == 1) sieve(df, ~ .data[[.env$variable]] > .env$threshold) } threshold(df, "x", 4) ## ----------------------------------------------------------------------------- threshold <- function(df, variable = ~x, threshold = 0) { sieve(df, ~ uq(variable) > .env$threshold) } threshold(df, ~ x, 4) threshold(df, ~ abs(x - y), 2) ## ----------------------------------------------------------------------------- x <- 3 threshold(df, ~ .data$x - .env$x, 0) ## ----------------------------------------------------------------------------- mogrify <- function(`_df`, ...) { args <- list(...) for (nm in names(args)) { `_df`[[nm]] <- f_eval(args[[nm]], `_df`) } `_df` } ## ----------------------------------------------------------------------------- df <- data.frame(x = 1:5, y = sample(5)) mogrify(df, z = ~ x + y, z2 = ~ z * 2) ## ----------------------------------------------------------------------------- add_variable <- function(df, name, expr) { do.call("mogrify", c(list(df), setNames(list(expr), name))) } add_variable(df, "z", ~ x + y) ## ----------------------------------------------------------------------------- f_list("x" ~ y, z = ~z) ## ----------------------------------------------------------------------------- mogrify <- function(`_df`, ...) { args <- f_list(...) for (nm in names(args)) { `_df`[[nm]] <- f_eval(args[[nm]], `_df`) } `_df` } ## ----------------------------------------------------------------------------- add_variable <- function(df, name, expr) { mogrify(df, name ~ uq(expr)) } add_variable(df, "z", ~ x + y) ## ----------------------------------------------------------------------------- sieve_ <- function(df, condition) { rows <- f_eval(condition, df) if (!is.logical(rows)) { stop("`condition` must be logical.", call. = FALSE) } rows[is.na(rows)] <- FALSE df[rows, , drop = FALSE] } ## ----------------------------------------------------------------------------- sieve <- function(df, expr) { sieve_(df, f_capture(expr)) } sieve(df, x == 1) ## ----------------------------------------------------------------------------- scramble <- function(df) { df[sample(nrow(df)), , drop = FALSE] } subscramble <- function(df, expr) { scramble(sieve(df, expr)) } subscramble(df, x < 4) ## ----------------------------------------------------------------------------- mogrify_ <- function(`_df`, args) { args <- as_f_list(args) for (nm in names(args)) { `_df`[[nm]] <- f_eval(args[[nm]], `_df`) } `_df` } mogrify <- function(`_df`, ...) { mogrify_(`_df`, dots_capture(...)) } lazyeval/inst/doc/lazyeval.Rmd0000644000176200001440000005075515163703150016133 0ustar liggesusers--- title: "Non-standard evaluation" author: "Hadley Wickham" date: "`r Sys.Date()`" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Non-standard evaluation} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- ```{r, include = FALSE} library(lazyeval) knitr::opts_chunk$set(collapse = TRUE, comment = "#>") ``` This document describes lazyeval, a package that provides principled tools to perform non-standard evaluation (NSE) in R. You should read this vignette if you want to program with packages like dplyr and ggplot2[^1], or you want a principled way of working with delayed expressions in your own package. As the name suggests, non-standard evaluation breaks away from the standard evaluation (SE) rules in order to do something special. There are three common uses of NSE: 1. __Labelling__ enhances plots and tables by using the expressions supplied to a function, rather than their values. For example, note the axis labels in this plot: ```{r, fig.width = 4, fig.height = 2.5} par(mar = c(4.5, 4.5, 1, 0.5)) grid <- seq(0, 2 * pi, length = 100) plot(grid, sin(grid), type = "l") ``` 1. __Non-standard scoping__ looks for objects in places other than the current environment. For example, base R has `with()`, `subset()`, and `transform()` that look for objects in a data frame (or list) before the current environment: ```{r} df <- data.frame(x = c(1, 5, 4, 2, 3), y = c(2, 1, 5, 4, 3)) with(df, mean(x)) subset(df, x == y) transform(df, z = x + y) ``` 1. __Metaprogramming__ is a catch-all term that covers all other uses of NSE (such as in `bquote()` and `library()`). Metaprogramming is so called because it involves computing on the unevaluated code in some way. This document is broadly organised according to the three types of non-standard evaluation described above. The main difference is that after [labelling], we'll take a detour to learn more about [formulas]. You're probably familiar with formulas from linear models (e.g. `lm(mpg ~ displ, data = mtcars)`) but formulas are more than just a tool for modelling: they are a general way of capturing an unevaluated expression. The approaches recommended here are quite different to my previous generation of recommendations. I am fairly confident these new approaches are correct, and will not have to change substantially again. The current tools make it easy to solve a number of practical problems that were previously challenging and are rooted in long-standing theory. [^1]: Currently neither ggplot2 nor dplyr actually use these tools since I've only just figured it out. But I'll be working hard to make sure all my packages are consistent in the near future. ## Labelling In base R, the classic way to turn an argument into a label is to use `deparse(substitute(x))`: ```{r} my_label <- function(x) deparse(substitute(x)) my_label(x + y) ``` There are two potential problems with this approach: 1. For long some expressions, `deparse()` generates a character vector with length > 1: ```{r} my_label({ a + b c + d }) ``` 1. `substitute()` only looks one level up, so you lose the original label if the function isn't called directly: ```{r} my_label2 <- function(x) my_label(x) my_label2(a + b) ``` Both of these problems are resolved by `lazyeval::expr_text()`: ```{r} my_label <- function(x) expr_text(x) my_label2 <- function(x) my_label(x) my_label({ a + b c + d }) my_label2(a + b) ``` There are two variations on the theme of `expr_text()`: * `expr_find()` find the underlying expression. It works similarly to `substitute()` but will follow a chain of promises back up to the original expression. This is often useful for [metaprogramming]. * `expr_label()` is a customised version of `expr_text()` that produces labels designed to be used in messages to the user: ```{r} expr_label(x) expr_label(a + b + c) expr_label(foo({ x + y })) ``` ### Exercises 1. `plot()` uses `deparse(substitute(x))` to generate labels for the x and y axes. Can you generate input that causes it to display bad labels? Write your own wrapper around `plot()` that uses `expr_label()` to compute `xlim` and `ylim`. 1. Create a simple implementation of `mean()` that stops with an informative error message if the argument is not numeric: ```{r, eval = FALSE} x <- c("a", "b", "c") my_mean(x) #> Error: `x` is a not a numeric vector. my_mean(x == "a") #> Error: `x == "a"` is not a numeric vector. my_mean("a") #> Error: "a" is not a numeric vector. ``` 1. Read the source code for `expr_text()`. How does it work? What additional arguments to `deparse()` does it use? ## Formulas Non-standard scoping is probably the most useful NSE tool, but before we can talk about a solid approach, we need to take a detour to talk about formulas. Formulas are a familiar tool from linear models, but their utility is not limited to models. In fact, formulas are a powerful, general purpose tool, because a formula captures two things: 1. An unevaluated expression. 1. The context (environment) in which the expression was created. `~` is a single character that allows you to say: "I want to capture the meaning of this code, without evaluating it right away". For that reason, the formula can be thought of as a "quoting" operator. ### Definition of a formula Technically, a formula is a "language" object (i.e. an unevaluated expression) with a class of "formula" and an attribute that stores the environment: ```{r} f <- ~ x + y + z typeof(f) attributes(f) ``` The structure of the underlying object is slightly different depending on whether you have a one-sided or two-sided formula: * One-sided formulas have length two: ```{r} length(f) # The 1st element is always ~ f[[1]] # The 2nd element is the RHS f[[2]] ``` * Two-sided formulas have length three: ```{r} g <- y ~ x + z length(g) # The 1st element is still ~ g[[1]] # But now the 2nd element is the LHS g[[2]] # And the 3rd element is the RHS g[[3]] ``` To abstract away these differences, lazyeval provides `f_rhs()` and `f_lhs()` to access either side of the formula, and `f_env()` to access its environment: ```{r} f_rhs(f) f_lhs(f) f_env(f) f_rhs(g) f_lhs(g) f_env(g) ``` ### Evaluating a formula A formula captures delays the evaluation of an expression so you can later evaluate it with `f_eval()`: ```{r} f <- ~ 1 + 2 + 3 f f_eval(f) ``` This allows you to use a formula as a robust way of delaying evaluation, cleanly separating the creation of the formula from its evaluation. Because formulas capture the code and context, you get the correct result even when a formula is created and evaluated in different places. In the following example, note that the value of `x` inside `add_1000()` is used: ```{r} x <- 1 add_1000 <- function(x) { ~ 1000 + x } add_1000(3) f_eval(add_1000(3)) ``` It can be hard to see what's going on when looking at a formula because important values are stored in the environment, which is largely opaque. You can use `f_unwrap()` to replace names with their corresponding values: ```{r} f_unwrap(add_1000(3)) ``` ### Non-standard scoping `f_eval()` has an optional second argument: a named list (or data frame) that overrides values found in the formula's environment. ```{r} y <- 100 f_eval(~ y) f_eval(~ y, data = list(y = 10)) # Can mix variables in environment and data argument f_eval(~ x + y, data = list(x = 10)) # Can even supply functions f_eval(~ f(y), data = list(f = function(x) x * 3)) ``` This makes it very easy to implement non-standard scoping: ```{r} f_eval(~ mean(cyl), data = mtcars) ``` One challenge with non-standard scoping is that we've introduced some ambiguity. For example, in the code below does `x` come from `mydata` or the environment? ```{r, eval = FALSE} f_eval(~ x, data = mydata) ``` You can't tell without knowing whether or not `mydata` has a variable called `x`. To overcome this problem, `f_eval()` provides two pronouns: * `.data` is bound to the data frame. * `.env` is bound to the formula environment. They both start with `.` to minimise the chances of clashing with existing variables. With these pronouns we can rewrite the previous formula to remove the ambiguity: ```{r} mydata <- data.frame(x = 100, y = 1) x <- 10 f_eval(~ .env$x, data = mydata) f_eval(~ .data$x, data = mydata) ``` If the variable or object doesn't exist, you'll get an informative error: ```{r, error = TRUE} f_eval(~ .env$z, data = mydata) f_eval(~ .data$z, data = mydata) ``` ### Unquoting `f_eval()` has one more useful trick up its sleeve: unquoting. Unquoting allows you to write functions where the user supplies part of the formula. For example, the following function allows you to compute the mean of any column (or any function of a column): ```{r} df_mean <- function(df, variable) { f_eval(~ mean(uq(variable)), data = df) } df_mean(mtcars, ~ cyl) df_mean(mtcars, ~ disp * 0.01638) df_mean(mtcars, ~ sqrt(mpg)) ``` To see how this works, we can use `f_interp()` which `f_eval()` calls internally (you shouldn't call it in your own code, but it's useful for debugging). The key is `uq()`: `uq()` evaluates its first (and only) argument and inserts the value into the formula: ```{r} variable <- ~cyl f_interp(~ mean(uq(variable))) variable <- ~ disp * 0.01638 f_interp(~ mean(uq(variable))) ``` Unquoting allows you to create code "templates", where you write most of the expression, while still allowing the user to control important components. You can even use `uq()` to change the function being called: ```{r} f <- ~ mean f_interp(~ uq(f)(uq(variable))) ``` Note that `uq()` only takes the RHS of a formula, which makes it difficult to insert literal formulas into a call: ```{r} formula <- y ~ x f_interp(~ lm(uq(formula), data = df)) ``` You can instead use `uqf()` which uses the whole formula, not just the RHS: ```{r} f_interp(~ lm(uqf(formula), data = df)) ``` Unquoting is powerful, but it only allows you to modify a single argument: it doesn't allow you to add an arbitrary number of arguments. To do that, you'll need "unquote-splice", or `uqs()`. The first (and only) argument to `uqs()` should be a list of arguments to be spliced into the call: ```{r} variable <- ~ x extra_args <- list(na.rm = TRUE, trim = 0.9) f_interp(~ mean(uq(variable), uqs(extra_args))) ``` ### Exercises 1. Create a wrapper around `lm()` that allows the user to supply the response and predictors as two separate formulas. 1. Compare and contrast `f_eval()` with `with()`. 1. Why does this code work even though `f` is defined in two places? (And one of them is not a function). ```{r} f <- function(x) x + 1 f_eval(~ f(10), list(f = "a")) ``` ## Non-standard scoping Non-standard scoping (NSS) is an important part of R because it makes it easy to write functions tailored for interactive data exploration. These functions require less typing, at the cost of some ambiguity and "magic". This is a good trade-off for interactive data exploration because you want to get ideas out of your head and into the computer as quickly as possible. If a function does make a bad guess, you'll spot it quickly because you're working interactively. There are three challenges to implementing non-standard scoping: 1. You must correctly delay the evaluation of a function argument, capturing both the computation (the expression), and the context (the environment). I recommend making this explicit by requiring the user to "quote" any NSS arguments with `~`, and then evaluating explicit with `f_eval()`. 1. When writing functions that use NSS-functions, you need some way to avoid the automatic lookup and be explicit about where objects should be found. `f_eval()` solves this problem with the `.data.` and `.env` pronouns. 1. You need some way to allow the user to supply parts of a formula. `f_eval()` solves this with unquoting. To illustrate these challenges, I will implement a `sieve()` function that works similarly to `base::subset()` or `dplyr::filter()`. The goal of `sieve()` is to make it easy to select observations that match criteria defined by a logical expression. `sieve()` has three advantages over `[`: 1. It is much more compact when the condition uses many variables, because you don't need to repeat the name of the data frame many times. 1. It drops rows where the condition evaluates to `NA`, rather than filling them with `NA`s. 1. It always returns a data frame. The implementation of `sieve()` is straightforward. First we use `f_eval()` to perform NSS. Then we then check that we have a logical vector, replace `NA`s with `FALSE`, and subset with `[`. ```{R} sieve <- function(df, condition) { rows <- f_eval(condition, df) if (!is.logical(rows)) { stop("`condition` must be logical.", call. = FALSE) } rows[is.na(rows)] <- FALSE df[rows, , drop = FALSE] } df <- data.frame(x = 1:5, y = 5:1) sieve(df, ~ x <= 2) sieve(df, ~ x == y) ``` ### Programming with `sieve()` Imagine that you've written some code that looks like this: ```{r, eval = FALSE} sieve(march, ~ x > 100) sieve(april, ~ x > 50) sieve(june, ~ x > 45) sieve(july, ~ x > 17) ``` (This is a contrived example, but it illustrates all of the important issues you'll need to consider when writing more useful functions.) Instead of continuing to copy-and-paste your code, you decide to wrap up the common behaviour in a function: ```{r} threshold_x <- function(df, threshold) { sieve(df, ~ x > threshold) } threshold_x(df, 3) ``` There are two ways that this function might fail: 1. The data frame might not have a variable called `x`. This will fail unless there's a variable called `x` hanging around in the global environment: ```{r, error = TRUE} rm(x) df2 <- data.frame(y = 5:1) # Throws an error threshold_x(df2, 3) # Silently gives the incorrect result! x <- 5 threshold_x(df2, 3) ``` 1. The data frame might have a variable called `threshold`: ```{r} df3 <- data.frame(x = 1:5, y = 5:1, threshold = 4) threshold_x(df3, 3) ``` These failures are partiuclarly pernicious because instead of throwing an error they silently produce the wrong answer. Both failures arise because `f_eval()` introduces ambiguity by looking in two places for each name: the supplied data and formula environment. To make `threshold_x()` more reliable, we need to be more explicit by using the `.data` and `.env` pronouns: ```{r, error = TRUE} threshold_x <- function(df, threshold) { sieve(df, ~ .data$x > .env$threshold) } threshold_x(df2, 3) threshold_x(df3, 3) ``` Here `.env` is bound to the environment where `~` is evaluated, namely the inside of `threshold_x()`. ### Adding arguments The `threshold_x()` function is not very useful because it's bound to a specific variable. It would be more powerful if we could vary both the threshold and the variable it applies to. We can do that by taking an additional argument to specify which variable to use. One simple approach is to use a string and `[[`: ```{r} threshold <- function(df, variable, threshold) { stopifnot(is.character(variable), length(variable) == 1) sieve(df, ~ .data[[.env$variable]] > .env$threshold) } threshold(df, "x", 4) ``` This is a simple and robust solution, but only allows us to use an existing variable, not an arbitrary expression like `sqrt(x)`. A more general solution is to allow the user to supply a formula, and use unquoting: ```{r} threshold <- function(df, variable = ~x, threshold = 0) { sieve(df, ~ uq(variable) > .env$threshold) } threshold(df, ~ x, 4) threshold(df, ~ abs(x - y), 2) ``` In this case, it's the responsibility of the user to ensure the `variable` is specified unambiguously. `f_eval()` is designed so that `.data` and `.env` work even when evaluated inside of `uq()`: ```{r} x <- 3 threshold(df, ~ .data$x - .env$x, 0) ``` ### Dot-dot-dot There is one more tool that you might find useful for functions that take `...`. For example, the code below implements a function similar to `dplyr::mutate()` or `base::transform()`. ```{r} mogrify <- function(`_df`, ...) { args <- list(...) for (nm in names(args)) { `_df`[[nm]] <- f_eval(args[[nm]], `_df`) } `_df` } ``` (NB: the first argument is a non-syntactic name (i.e. it requires quoting with `` ` ``) so it doesn't accidentally match one of the names of the new variables.) `transmogrifty()` makes it easy to add new variables to a data frame: ```{r} df <- data.frame(x = 1:5, y = sample(5)) mogrify(df, z = ~ x + y, z2 = ~ z * 2) ``` One problem with this implementation is that it's hard to specify the names of the generated variables. Imagine you want a function where the name and expression are in separate variables. This is awkward because the variable name is supplied as an argument name to `mogrify()`: ```{r} add_variable <- function(df, name, expr) { do.call("mogrify", c(list(df), setNames(list(expr), name))) } add_variable(df, "z", ~ x + y) ``` Lazyeval provides the `f_list()` function to make writing this sort of function a little easier. It takes a list of formulas and evaluates the LHS of each formula (if present) to rename the elements: ```{r} f_list("x" ~ y, z = ~z) ``` If we tweak `mogrify()` to use `f_list()` instead of `list()`: ```{r} mogrify <- function(`_df`, ...) { args <- f_list(...) for (nm in names(args)) { `_df`[[nm]] <- f_eval(args[[nm]], `_df`) } `_df` } ``` `add_new()` becomes much simpler: ```{r} add_variable <- function(df, name, expr) { mogrify(df, name ~ uq(expr)) } add_variable(df, "z", ~ x + y) ``` ### Exercises 1. Write a function that selects all rows of `df` where `variable` is greater than its mean. Make the function more general by allowing the user to specify a function to use instead of `mean()` (e.g. `median()`). 1. Create a version of `mogrify()` where the first argument is `x`? What happens if you try to create a new variable called `x`? ## Non-standard evaluation In some situations you might want to eliminate the formula altogether, and allow the user to type expressions directly. I was once much enamoured with this approach (witness ggplot2, dplyr, ...). However, I now think that it should be used sparingly because explict quoting with `~` leads to simpler code, and makes it more clear to the user that something special is going on. That said, lazyeval does allow you to eliminate the `~` if you really want to. In this case, I recommend having both a NSE and SE version of the function. The SE version, which takes formuals, should have suffix `_`: ```{r} sieve_ <- function(df, condition) { rows <- f_eval(condition, df) if (!is.logical(rows)) { stop("`condition` must be logical.", call. = FALSE) } rows[is.na(rows)] <- FALSE df[rows, , drop = FALSE] } ``` Then create the NSE version which doesn't need the explicit formula. The key is the use of `f_capture()` which takes an unevaluated argument (a promise) and captures it as a formula: ```{r} sieve <- function(df, expr) { sieve_(df, f_capture(expr)) } sieve(df, x == 1) ``` If you're familiar with `substitute()` you might expect the same drawbacks to apply. However, `f_capture()` is smart enough to follow a chain of promises back to the original value, so, for example, this code works fine: ```{r} scramble <- function(df) { df[sample(nrow(df)), , drop = FALSE] } subscramble <- function(df, expr) { scramble(sieve(df, expr)) } subscramble(df, x < 4) ``` ### Dot-dot-dot If you want a `...` function that doesn't require formulas, I recommend that the SE version take a list of arguments, and the NSE version uses `dots_capture()` to capture multiple arguments as a list of formulas. ```{r} mogrify_ <- function(`_df`, args) { args <- as_f_list(args) for (nm in names(args)) { `_df`[[nm]] <- f_eval(args[[nm]], `_df`) } `_df` } mogrify <- function(`_df`, ...) { mogrify_(`_df`, dots_capture(...)) } ``` ### Exercises 1. Recreate `subscramble()` using `base::subset()` instead of `sieve()`. Why does it fail? ## Metaprogramming The final use of non-standard evaluation is to do metaprogramming. This is a catch-all term that encompasses any function that does computation on an unevaluated expression. You can learn about metaprogrgramming in , particularly . Over time, the goal is to move all useful metaprogramming helper functions into this package, and discuss metaprogramming more here. lazyeval/README.md0000644000176200001440000000232515163703150013363 0ustar liggesusers# lazyeval [![Lifecycle: deprecated](https://img.shields.io/badge/lifecycle-deprecated-orange.svg)](https://lifecycle.r-lib.org/articles/stages.html) The lazyeval package provides tools that make it easier to correctly implement non-standard evaluation (NSE) in R. You use lazy evaluation by requiring the user to "quote" specially evaluated arguments with `~`, and then using the lazyeval package to compute with those formulas. It is also possible to eliminate the use of the `~` by converting promises to formulas. This does make programming with such functions a little harder, but it can be worth it in certain situations. See `vignette("lazyeval")` for more details. ## Installation Install the released version from CRAN with: ```R install.packages("lazyeval") ``` Install the development version from github with: ```R # install.packages("devtools") devtools::install_github("hadley/lazyeval", build_vignettes = TRUE) ``` ## Status [![Lifecycle: deprecated](https://img.shields.io/badge/lifecycle-deprecated-orange.svg)](https://lifecycle.r-lib.org/articles/stages.html) lazyeval is retired: this means only changes necessary to keep it on CRAN will be made. We recommend using [rlang](https://rlang.r-lib.org/) instead. lazyeval/build/0000755000176200001440000000000015163705077013213 5ustar liggesuserslazyeval/build/vignette.rds0000644000176200001440000000037415163705077015556 0ustar liggesusersun0MDb`_<@g`itzFDrq''\j>W{`qci4|l ~jjH׹ y™qZV3|SditXopw^{+* ZNBDkT2aՐ˒="S7|f*lAi{d!(I>ce,*dž_ u]mޑ<E&;lazyeval/man/0000755000176200001440000000000015163703150012655 5ustar liggesuserslazyeval/man/f_new.Rd0000644000176200001440000000066513171753463014262 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/formula.R \name{f_new} \alias{f_new} \title{Create a formula object by "hand".} \usage{ f_new(rhs, lhs = NULL, env = parent.frame()) } \arguments{ \item{lhs, rhs}{A call, name, or atomic vector.} \item{env}{An environment} } \value{ A formula object } \description{ Create a formula object by "hand". } \examples{ f_new(quote(a)) f_new(quote(a), quote(b)) } lazyeval/man/expr_label.Rd0000644000176200001440000000255315163703150015266 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/expr.R \name{expr_label} \alias{expr_label} \alias{expr_text} \alias{expr_find} \alias{expr_env} \title{Find the expression associated with an argument} \usage{ expr_label(x) expr_text(x, width = 60L, nlines = Inf) expr_find(x) expr_env(x, default_env) } \arguments{ \item{x}{A promise (function argument)} \item{width}{Width of each line} \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.} } \description{ \code{expr_find()} finds the full expression; \code{expr_text()} turns the expression into a single string; \code{expr_label()} formats it nicely for use in messages. \code{expr_env()} finds the environment associated with the expression. } \details{ These functions never force promises, and will work even if a promise has previously been forced. } \examples{ # Unlike substitute(), expr_find() finds the original expression f <- function(x) g(x) g <- function(y) h(y) h <- function(z) list(substitute(z), expr_find(z)) f(1 + 2 + 3) expr_label(10) # Names a quoted with `` expr_label(x) # Strings are encoded expr_label("a\nb") # Expressions are captured expr_label(a + b + c) # Long expressions are collapsed expr_label(foo({ 1 + 2 print(x) })) } lazyeval/man/function_new.Rd0000644000176200001440000000227513171753463015661 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/function.R \name{function_new} \alias{function_new} \title{Create a function by "hand"} \usage{ function_new(args, body, env = parent.frame()) } \arguments{ \item{args}{A named list of default arguments. Note that if you want arguments that don't have defaults, you'll need to use the special function \code{\link{alist}}, e.g. \code{alist(a = , b = 1)}} \item{body}{A language object representing the code inside the function. Usually this will be most easily generated with \code{\link{quote}}} \item{env}{The parent environment of the function, defaults to the calling environment of \code{make_function}} } \description{ This constructs a new function given it's three components: list of arguments, body code and parent environment. } \examples{ f <- function(x) x + 3 g <- function_new(alist(x = ), quote(x + 3)) # The components of the functions are identical identical(formals(f), formals(g)) identical(body(f), body(g)) identical(environment(f), environment(g)) # But the functions are not identical because f has src code reference identical(f, g) attr(f, "srcref") <- NULL # Now they are: stopifnot(identical(f, g)) } lazyeval/man/all_dots.Rd0000644000176200001440000000100013171753463014745 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/lazy-as.R \name{all_dots} \alias{all_dots} \title{Combine explicit and implicit dots.} \usage{ all_dots(.dots, ..., all_named = FALSE) } \arguments{ \item{.dots}{A list of lazy objects} \item{...}{Individual lazy objects} \item{all_named}{If \code{TRUE}, uses \code{\link{auto_name}} to ensure every component has a name.} } \value{ A \code{\link{lazy_dots}} } \description{ Combine explicit and implicit dots. } \keyword{internal} lazyeval/man/f_interp.Rd0000644000176200001440000000251615163703150014756 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/f-interp.R \name{f_interp} \alias{f_interp} \alias{uq} \alias{uqs} \alias{uqf} \title{Interpolate a formula} \usage{ f_interp(f, data = NULL) uq(x, data = NULL) uqf(x) uqs(x) } \arguments{ \item{f}{A one-sided formula.} \item{data}{When called from inside \code{f_eval}, this is used to pass on the data so that nested formulas are evaluated in the correct environment.} \item{x}{For \code{uq} and \code{uqf}, a formula. For \code{uqs}, a a vector.} } \description{ Interpolation replaces sub-expressions of the form \code{uq(x)} with the evaluated value of \code{x}, and inlines sub-expressions of the form \code{uqs(x)}. } \section{Theory}{ Formally, \code{f_interp} is a quasiquote function, \code{uq()} is the unquote operator, and \code{uqs()} is the unquote splice operator. These terms have a rich history in LISP, and live on in modern languages like Julia and Racket. } \examples{ f_interp(x ~ 1 + uq(1 + 2 + 3) + 10) # Use uqs() if you want to add multiple arguments to a function # It must evaluate to a list args <- list(1:10, na.rm = TRUE) f_interp(~ mean( uqs(args) )) # You can combine the two var <- quote(xyz) extra_args <- list(trim = 0.9) f_interp(~ mean( uq(var) , uqs(extra_args) )) foo <- function(n) { ~ 1 + uq(n) } f <- foo(10) f f_interp(f) } lazyeval/man/f_eval.Rd0000644000176200001440000000410313171753463014407 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/f-eval.R \name{f_eval_rhs} \alias{f_eval_rhs} \alias{f_eval_lhs} \alias{f_eval} \alias{find_data} \title{Evaluate a formula} \usage{ f_eval_rhs(f, data = NULL) f_eval_lhs(f, data = NULL) f_eval(f, data = NULL) find_data(x) } \arguments{ \item{f}{A formula. Any expressions wrapped in \code{ uq() } will will be "unquoted", i.e. they will be evaluated, and the results inserted back into the formula. See \code{\link{f_interp}} for more details.} \item{data}{A list (or data frame). \code{find_data} is a generic used to find the data associated with a given object. If you want to make \code{f_eval} work for your own objects, you can define a method for this generic.} \item{x}{An object for which you want to find associated data.} } \description{ \code{f_eval_rhs} evaluates the RHS of a formula and \code{f_eval_lhs} evaluates the LHS. \code{f_eval} is a shortcut for \code{f_eval_rhs} since that is what you most commonly need. } \details{ If \code{data} is specified, variables will be looked for first in this object, and if not found in the environment of the formula. } \section{Pronouns}{ When used with \code{data}, \code{f_eval} provides two pronouns to make it possible to be explicit about where you want values to come from: \code{.env} and \code{.data}. These are thin wrappers around \code{.data} and \code{.env} that throw errors if you try to access non-existent values. } \examples{ f_eval(~ 1 + 2 + 3) # formulas automatically capture their enclosing environment foo <- function(x) { y <- 10 ~ x + y } f <- foo(1) f f_eval(f) # If you supply data, f_eval will look their first: f_eval(~ cyl, mtcars) # To avoid ambiguity, you can use .env and .data pronouns to be # explicit: cyl <- 10 f_eval(~ .data$cyl, mtcars) f_eval(~ .env$cyl, mtcars) # Imagine you are computing the mean of a variable: f_eval(~ mean(cyl), mtcars) # How can you change the variable that's being computed? # The easiest way is "unquote" with uq() # See ?f_interp for more details var <- ~ cyl f_eval(~ mean( uq(var) ), mtcars) } lazyeval/man/ast_.Rd0000644000176200001440000000130213171753463014077 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ast.R \name{ast_} \alias{ast_} \alias{ast} \title{Display a call (or expression) as a tree.} \usage{ ast_(x, width = getOption("width")) ast(x) } \arguments{ \item{x}{Quoted call, list of calls, or expression to display.} \item{width}{Display width, defaults to current width as reported by \code{getOption("width")}.} } \description{ \code{ast_} takes a quoted expression; \code{ast} does the quoting for you. } \examples{ ast(f(x, 1, g(), h(i()))) ast(if (TRUE) 3 else 4) ast(function(a = 1, b = 2) {a + b + 10}) ast(f(x)(y)(z)) ast_(quote(f(x, 1, g(), h(i())))) ast_(quote(if (TRUE) 3 else 4)) ast_(expression(1, 2, 3)) } lazyeval/man/is_lang.Rd0000644000176200001440000000144613171753463014576 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/language.R \name{is_lang} \alias{is_lang} \alias{is_name} \alias{is_call} \alias{is_pairlist} \alias{is_atomic} \title{Is an object a language object?} \usage{ is_lang(x) is_name(x) is_call(x) is_pairlist(x) is_atomic(x) } \arguments{ \item{x}{An object to test.} } \description{ These helpers are consistent wrappers around their base R equivalents. A language object is either an atomic vector (typically a scalar), a name (aka a symbol), a call, or a pairlist (used for function arguments). } \examples{ q1 <- quote(1) is_lang(q1) is_atomic(q1) q2 <- quote(x) is_lang(q2) is_name(q2) q3 <- quote(x + 1) is_lang(q3) is_call(q3) } \seealso{ \code{\link{as_name}()} and \code{\link{as_call}()} for coercion functions. } lazyeval/man/lazy_dots.Rd0000644000176200001440000000222113171753463015162 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/lazy-dots.R \name{lazy_dots} \alias{lazy_dots} \title{Capture ... (dots) for later lazy evaluation.} \usage{ lazy_dots(..., .follow_symbols = FALSE, .ignore_empty = FALSE) } \arguments{ \item{...}{Dots from another function} \item{.follow_symbols}{If \code{TRUE}, the default, follows promises across function calls. See \code{vignette("chained-promises")} for details.} \item{.ignore_empty}{If \code{TRUE}, empty arguments will be ignored.} } \value{ A named list of \code{\link{lazy}} expressions. } \description{ Capture ... (dots) for later lazy evaluation. } \examples{ lazy_dots(x = 1) lazy_dots(a, b, c * 4) f <- function(x = a + b, ...) { lazy_dots(x = x, y = a + b, ...) } f(z = a + b) f(z = a + b, .follow_symbols = TRUE) # .follow_symbols is off by default because it causes problems # with lazy loaded objects lazy_dots(letters) lazy_dots(letters, .follow_symbols = TRUE) # You can also modify a dots like a list. Anything on the RHS will # be coerced to a lazy. l <- lazy_dots(x = 1) l$y <- quote(f) l[c("y", "x")] l["z"] <- list(~g) c(lazy_dots(x = 1), lazy_dots(f)) } lazyeval/man/as_name.Rd0000644000176200001440000000120213171753463014553 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/language.R \name{as_name} \alias{as_name} \alias{as_call} \title{Coerce an object to a name or call.} \usage{ as_name(x) as_call(x) } \arguments{ \item{x}{An object to coerce} } \description{ These are a S3 generics with built-in methods for names, calls, formuals, and strings. The distinction between a name and a call is particularly important when coercing from a string. Coercing to a call will parse the string, coercing to a name will create a (potentially) non-syntactic name. } \examples{ as_name("x + y") as_call("x + y") as_call(~ f) as_name(~ f()) } lazyeval/man/f_text.Rd0000644000176200001440000000123215163703150014433 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/formula.R \name{f_text} \alias{f_text} \alias{f_label} \title{Turn RHS of formula into a string/label.} \usage{ f_text(x, width = 60L, nlines = Inf) f_label(x) } \arguments{ \item{x}{A formula.} \item{width}{Width of each line} \item{nlines}{Maximum number of lines to extract.} } \description{ Equivalent of \code{\link{expr_text}()} and \code{\link{expr_label}()} for formulas. } \examples{ f <- ~ a + b + bc f_text(f) f_label(f) # Names a quoted with `` f_label(~ x) # Strings are encoded f_label(~ "a\nb") # Long expressions are collapsed f_label(~ foo({ 1 + 2 print(x) })) } lazyeval/man/make_call.Rd0000644000176200001440000000167213171753463015073 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/lazy-call.R \name{make_call} \alias{make_call} \title{Make a call with \code{lazy_dots} as arguments.} \usage{ make_call(fun, args) } \arguments{ \item{fun}{Function as symbol or quoted call.} \item{args}{Arguments to function; must be a \code{lazy_dots} object, or something \code{\link{as.lazy_dots}()} can coerce..} } \value{ A list: \item{env}{The common environment for all elements} \item{expr}{The expression} } \description{ In order to exactly replay the original call, the environment must be the same for all of the dots. This function circumvents that a little, falling back to the \code{\link{baseenv}()} if all environments aren't the same. } \examples{ make_call(quote(f), lazy_dots(x = 1, 2)) make_call(quote(f), list(x = 1, y = ~x)) make_call(quote(f), ~x) # If no known or no common environment, fails back to baseenv() make_call(quote(f), quote(x)) } lazyeval/man/as.lazy.Rd0000644000176200001440000000170713171753463014543 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/lazy-as.R \name{as.lazy} \alias{as.lazy} \alias{as.lazy_dots} \title{Convert an object to a lazy expression or lazy dots.} \usage{ as.lazy(x, env = baseenv()) as.lazy_dots(x, env) } \arguments{ \item{x}{An R object. Current methods for \code{as.lazy()} convert formulas, character vectors, calls and names. Methods for \code{as.lazy_dots()} convert lists and character vectors (by calling \code{\link{lapply}()} with \code{as.lazy()}.)} \item{env}{Environment to use for objects that don't already have associated environment.} } \description{ Convert an object to a lazy expression or lazy dots. } \examples{ as.lazy(~ x + 1) as.lazy(quote(x + 1), globalenv()) as.lazy("x + 1", globalenv()) as.lazy_dots(list(~x, y = ~z + 1)) as.lazy_dots(c("a", "b", "c"), globalenv()) as.lazy_dots(~x) as.lazy_dots(quote(x), globalenv()) as.lazy_dots(quote(f()), globalenv()) as.lazy_dots(lazy(x)) } lazyeval/man/f_rhs.Rd0000644000176200001440000000154413171753463014262 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/formula.R \name{f_rhs} \alias{f_rhs} \alias{f_rhs<-} \alias{f_lhs} \alias{f_lhs<-} \alias{f_env} \alias{f_env<-} \title{Get/set formula components.} \usage{ f_rhs(f) f_rhs(x) <- value f_lhs(f) f_lhs(x) <- value f_env(f) f_env(x) <- value } \arguments{ \item{f, x}{A formula} \item{value}{The value to replace with.} } \value{ \code{f_rhs} and \code{f_lhs} return language objects (i.e. atomic vectors of length 1, a name, or a call). \code{f_env} returns an environment. } \description{ \code{f_rhs} extracts the righthand side, \code{f_lhs} extracts the lefthand side, and \code{f_env} extracts the environment. All functions throw an error if \code{f} is not a formula. } \examples{ f_rhs(~ 1 + 2 + 3) f_rhs(~ x) f_rhs(~ "A") f_rhs(1 ~ 2) f_lhs(~ y) f_lhs(x ~ y) f_env(~ x) } lazyeval/man/is_formula.Rd0000644000176200001440000000045313171753463015317 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/formula.R \name{is_formula} \alias{is_formula} \title{Is object a formula?} \usage{ is_formula(x) } \arguments{ \item{x}{Object to test} } \description{ Is object a formula? } \examples{ is_formula(~ 10) is_formula(10) } lazyeval/man/f_unwrap.Rd0000644000176200001440000000061413171753463014777 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/formula.R \name{f_unwrap} \alias{f_unwrap} \title{Unwrap a formula} \usage{ f_unwrap(f) } \arguments{ \item{f}{A formula to unwrap.} } \description{ This interpolates values in the formula that are defined in its environment, replacing the environment with its parent. } \examples{ n <- 100 f <- ~ x + n f_unwrap(f) } lazyeval/man/auto_name.Rd0000644000176200001440000000112713171753463015126 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/lazy-names.R \name{auto_name} \alias{auto_name} \title{Automatically name all components of a lazy dots.} \usage{ auto_name(x, max_width = 40) } \arguments{ \item{x}{A \code{\link{lazy_dots}}} \item{max_width}{Maximum number of characters to use} } \description{ Any components missing a name will automatically get a name added by looking at the first \code{max_width} characters of the deparsed expression. } \examples{ x <- lazy_dots(1 + 2, mean(mpg)) auto_name(x) auto_name(list(~f, quote(x))) } \keyword{internal} lazyeval/man/lazy_eval.Rd0000644000176200001440000000120313171753463015137 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/lazy-eval.R \name{lazy_eval} \alias{lazy_eval} \title{Evaluate a lazy expression.} \usage{ lazy_eval(x, data = NULL) } \arguments{ \item{x}{A lazy object or a formula.} \item{data}{Option, a data frame or list in which to preferentially look for variables before using the environment associated with the lazy object.} } \description{ Evaluate a lazy expression. } \examples{ f <- function(x) { z <- 100 ~ x + z } z <- 10 lazy_eval(f(10)) lazy_eval(f(10), list(x = 100)) lazy_eval(f(10), list(x = 1, z = 1)) lazy_eval(lazy_dots(a = x, b = z), list(x = 10)) } lazyeval/man/call_new.Rd0000644000176200001440000000132613171753463014743 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/call.R \name{call_new} \alias{call_new} \title{Create a call by "hand"} \usage{ call_new(f, ..., .args = list()) } \arguments{ \item{f}{Function to call. For \code{make_call}, either a string, a symbol or a quoted call. For \code{do_call}, a bare function name or call.} \item{..., .args}{Arguments to the call either in or out of a list} } \description{ Create a call by "hand" } \examples{ # f can either be a string, a symbol or a call call_new("f", a = 1) call_new(quote(f), a = 1) call_new(quote(f()), a = 1) #' Can supply arguments individually or in a list call_new(quote(f), a = 1, b = 2) call_new(quote(f), .args = list(a = 1, b = 2)) } lazyeval/man/f_list.Rd0000644000176200001440000000107613171753463014441 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/formula.R \name{f_list} \alias{f_list} \alias{as_f_list} \title{Build a named list from the LHS of formulas} \usage{ f_list(...) as_f_list(x) } \arguments{ \item{...}{Named arguments.} \item{x}{An existing list} } \value{ A named list. } \description{ \code{f_list} makes a new list; \code{as_f_list} takes an existing list. Both take the LHS of any two-sided formulas and evaluate it, replacing the current name with the result. } \examples{ f_list("y" ~ x) f_list(a = "y" ~ a, ~ b, c = ~c) } lazyeval/man/interp.Rd0000644000176200001440000000246613171753463014466 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/lazy-interp.R \name{interp} \alias{interp} \title{Interpolate values into an expression.} \usage{ interp(`_obj`, ..., .values) } \arguments{ \item{_obj}{An object to modify: can be a call, name, formula, \code{\link{lazy}}, or a string.} \item{..., .values}{Either individual name-value pairs, or a list (or environment) of values.} } \description{ This is useful if you want to build an expression up from a mixture of constants and variables. } \examples{ # Interp works with formulas, lazy objects, quoted calls and strings interp(~ x + y, x = 10) interp(lazy(x + y), x = 10) interp(quote(x + y), x = 10) interp("x + y", x = 10) # Use as.name if you have a character string that gives a # variable name interp(~ mean(var), var = as.name("mpg")) # or supply the quoted name directly interp(~ mean(var), var = quote(mpg)) # Or a function! interp(~ f(a, b), f = as.name("+")) # Remember every action in R is a function call: # http://adv-r.had.co.nz/Functions.html#all-calls # If you've built up a list of values through some other # mechanism, use .values interp(~ x + y, .values = list(x = 10)) # You can also interpolate variables defined in the current # environment, but this is a little risky. y <- 10 interp(~ x + y, .values = environment()) } lazyeval/man/f_capture.Rd0000644000176200001440000000203513171753463015125 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/f-capture.R \name{f_capture} \alias{f_capture} \alias{dots_capture} \title{Make a promise explicit by converting into a formula.} \usage{ f_capture(x) dots_capture(..., .ignore_empty = TRUE) } \arguments{ \item{x, ...}{An unevaluated promises} \item{.ignore_empty}{If \code{TRUE}, empty arguments will be silently dropped.} } \value{ \code{f_capture} returns a formula; \code{dots_capture} returns a list of formulas. } \description{ This should be used sparingly if you want to implement true non-standard evaluation with 100\% magic. I recommend avoiding this unless you have strong reasons otherwise since requiring arguments to be formulas only adds one extra character to the inputs, and otherwise makes life much much simpler. } \examples{ f_capture(a + b) dots_capture(a + b, c + d, e + f) # These functions will follow a chain of promises back to the # original definition f <- function(x) g(x) g <- function(y) h(y) h <- function(z) f_capture(z) f(a + b + c) } lazyeval/man/missing_arg.Rd0000644000176200001440000000046313171753463015462 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/utils.R \name{missing_arg} \alias{missing_arg} \title{Generate a missing argument.} \usage{ missing_arg() } \description{ Generate a missing argument. } \examples{ f_interp(~f(x = uq(missing_arg()))) f_interp(~f(x = uq(NULL))) } lazyeval/man/lazy_.Rd0000644000176200001440000000312213171753463014271 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/lazy.R \name{lazy_} \alias{lazy_} \alias{lazy} \title{Capture expression for later lazy evaluation.} \usage{ lazy_(expr, env) lazy(expr, env = parent.frame(), .follow_symbols = TRUE) } \arguments{ \item{expr}{Expression to capture. For \code{lazy_} must be a name or a call.} \item{env}{Environment in which to evaluate expr.} \item{.follow_symbols}{If \code{TRUE}, the default, follows promises across function calls. See \code{vignette("chained-promises")} for details.} } \description{ \code{lazy()} uses non-standard evaluation to turn promises into lazy objects; \code{lazy_()} does standard evaluation and is suitable for programming. } \details{ Use \code{lazy()} like you'd use \code{\link{substitute}()} to capture an unevaluated promise. Compared to \code{substitute()} it also captures the environment associated with the promise, so that you can correctly replay it in the future. } \examples{ lazy_(quote(a + x), globalenv()) # Lazy is designed to be used inside a function - you should # give it the name of a function argument (a promise) f <- function(x = b - a) { lazy(x) } f() f(a + b / c) # Lazy also works when called from the global environment. This makes # easy to play with interactively. lazy(a + b / c) # By default, lazy will climb all the way back to the initial promise # This is handy if you have if you have nested functions: g <- function(y) f(y) h <- function(z) g(z) f(a + b) g(a + b) h(a + b) # To avoid this behavour, set .follow_symbols = FALSE # See vignette("chained-promises") for details } lazyeval/man/common_env.Rd0000644000176200001440000000073613171753463015323 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/lazy-call.R \name{common_env} \alias{common_env} \title{Find common environment in list of lazy objects.} \usage{ common_env(dots) } \arguments{ \item{dots}{A list of lazy objects} } \description{ If no common environment is found, will return \code{baseenv()}. } \examples{ common_env(lazy_dots(a, b, c)) f <- function(x) ~x common_env(list(f(1))) common_env(list(f(1), f(2))) } \keyword{internal} lazyeval/man/call_modify.Rd0000644000176200001440000000200213171753463015431 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/call.R \name{call_modify} \alias{call_modify} \alias{call_standardise} \title{Modify the arguments of a call.} \usage{ call_modify(call, new_args, env = parent.frame()) call_standardise(call, env = parent.frame()) } \arguments{ \item{call}{A call to modify. It is first standardised with \code{\link{call_standardise}}.} \item{new_args}{A named list of expressions (constants, names or calls) used to modify the call. Use \code{NULL} to remove arguments.} \item{env}{Environment in which to look up call value.} } \description{ Modify the arguments of a call. } \examples{ call <- quote(mean(x, na.rm = TRUE)) call_standardise(call) # Modify an existing argument call_modify(call, list(na.rm = FALSE)) call_modify(call, list(x = quote(y))) # Remove an argument call_modify(call, list(na.rm = NULL)) # Add a new argument call_modify(call, list(trim = 0.1)) # Add an explicit missing argument call_modify(call, list(na.rm = quote(expr = ))) } lazyeval/DESCRIPTION0000644000176200001440000000145515164116535013623 0ustar liggesusersPackage: lazyeval Version: 0.2.3 Title: Lazy (Non-Standard) Evaluation Description: An alternative approach to non-standard evaluation using formulas. Provides a full implementation of LISP style 'quasiquotation', making it easier to generate code with other code. Authors@R: c( person("Hadley", "Wickham", ,"hadley@rstudio.com", c("aut", "cre")), person("RStudio", role = "cph") ) License: GPL-3 Depends: R (>= 3.1.0) Imports: rlang Suggests: knitr, rmarkdown (>= 0.2.65), testthat, covr VignetteBuilder: knitr RoxygenNote: 7.3.3 Config/build/compilation-database: true NeedsCompilation: yes Packaged: 2026-04-03 09:37:04 UTC; lionel Author: Hadley Wickham [aut, cre], RStudio [cph] Maintainer: Hadley Wickham Repository: CRAN Date/Publication: 2026-04-04 05:10:53 UTC