rlang/0000755000176200001440000000000014742464552011372 5ustar liggesusersrlang/tests/0000755000176200001440000000000014742414044012523 5ustar liggesusersrlang/tests/sink.R0000644000176200001440000000025414127057575013624 0ustar liggesusers library(rlang) # inform() prints to file local({ file <- tempfile("inform-file-custom") inform("foo", .file = file) stopifnot(identical(readLines(file), "foo")) }) rlang/tests/testthat/0000755000176200001440000000000014742464552014374 5ustar liggesusersrlang/tests/testthat/test-standalone-s3-register.R0000644000176200001440000000074714376112150021764 0ustar liggesuserstest_that("can register for generics that don't exist", { withr::with_envvar(c(NOT_CRAN = ""), { expect_silent( s3_register("testthat::foobarbaz", "class", method = function(...) NULL) ) }) # https://github.com/r-lib/testthat/pull/1401 skip_if_not_installed("testthat", "3.0.4.9000") withr::with_envvar(c(NOT_CRAN = "true"), { expect_snapshot({ (expect_warning(s3_register("testthat::foobarbaz", "class", method = function(...) NULL))) }) }) }) rlang/tests/testthat/setup-tests.R0000644000176200001440000000014414167566140017013 0ustar liggesusers # Until https://github.com/r-lib/testthat/issues/787 is fixed Sys.setenv("TESTTHAT_PKG" = "rlang") rlang/tests/testthat/test-attr.R0000644000176200001440000001135114741441060016433 0ustar liggesuserstest_that("names2() takes care of missing values", { x <- set_names(1:3, c("a", NA, "b")) expect_identical(names2(x), c("a", "", "b")) }) test_that("names2() fails for environments", { expect_error(names2(env()), "Use `env_names()` for environments.", fixed = TRUE) }) test_that("names2<- doesn't add missing values (#1301)", { x <- 1:3 names2(x)[1:2] <- "foo" expect_equal(names(x), c("foo", "foo", "")) }) test_that("inputs must be valid", { expect_snapshot({ (expect_error(set_names(environment()))) (expect_error(set_names(1:10, letters[1:4]))) }) }) test_that("can supply vector or ...", { expect_named(set_names(1:2, c("a", "b")), c("a", "b")) expect_named(set_names(1:2, "a", "b"), c("a", "b")) expect_named(set_names(1:2, 1, 2), c("1", "2")) }) test_that("can supply function/formula to rename", { x <- c(a = 1, b = 2) expect_named(set_names(x, toupper), c("A", "B")) expect_named(set_names(x, ~ toupper(.)), c("A", "B")) expect_named(set_names(x, paste, "foo"), c("a foo", "b foo")) }) test_that("set_names() zaps names", { expect_null(names(set_names(mtcars, NULL))) }) test_that("set_names() coerces to character", { expect_identical(set_names(1L, TRUE), c(`TRUE` = 1L)) expect_identical(set_names(1:2, "a", TRUE), c(a = 1L, `TRUE` = 2L)) }) test_that("set_names() checks length generically", { x <- as.POSIXlt("1970-01-01", tz = "UTC") expect <- x names(expect) <- "a" expect_identical(set_names(x, "a"), expect) expect_error(set_names(x, c("a", "b")), "must be compatible") }) test_that("has_name() works with pairlists", { expect_true(has_name(fn_fmls(`[.data.frame`), "drop")) }) test_that("set_names() first names the vector before applying a function (#688)", { exp <- set_names(letters, toupper(letters)) expect_identical(set_names(set_names(letters), toupper), exp) expect_identical(set_names(letters, toupper), exp) }) test_that("set_names2() fills in empty names", { chr <- c("a", b = "B", "c") expect_equal(set_names2(chr), c(a = "a", b = "B", c = "c")) }) test_that("zap_srcref() removes source references", { with_srcref("x <- quote({ NULL })") expect_null(attributes(zap_srcref(x))) }) test_that("zap_srcref() handles nested functions (r-lib/testthat#1228)", { with_srcref(" factory <- function() { function() { function() { 1 } } }" ) fn <- zap_srcref(factory()) expect_null(attributes(fn)) curly <- body(fn) expect_null(attributes(curly)) fn_call <- curly[[2]] expect_null(attributes(fn_call)) # Calls to `function` store srcrefs in 4th cell expect_length(fn_call, 3) # Can call `zap_srcref()` repeatedly expect_equal( zap_srcref(fn), fn ) # Check that `factory` hasn't been modified by reference expect_true("srcref" %in% names(attributes(factory))) curly <- body(factory) expect_true("srcref" %in% names(attributes(curly))) fn_call <- curly[[2]] expect_length(fn_call, 4) }) test_that("zap_srcref() works with quosures", { with_srcref("x <- expr({ !!quo({ NULL }) })") out <- zap_srcref(x) expect_null(attributes(out)) quo <- out[[2]] expect_null(attributes(quo_get_expr(quo))) }) test_that("zap_srcref() preserves attributes", { with_srcref( "fn <- structure(function() NULL, bar = TRUE)" ) out <- zap_srcref(fn) expect_equal(attributes(out), list(bar = TRUE)) expect_null(attributes(body(out))) }) test_that("can zap_srcref() on functions with `[[` methods", { local_methods( `[[.rlang:::not_subsettable` = function(...) stop("Can't subset!"), `[[<-.rlang:::not_subsettable` = function(...) stop("Can't subset!") ) fn <- structure(quote(function() NULL), class = "rlang:::not_subsettable") expect_error(zap_srcref(fn), NA) }) test_that("set_names() recycles names of size 1", { expect_named( set_names(1:3, ""), rep("", 3) ) expect_named( set_names(1:3, ~ ""), rep("", 3) ) expect_equal( set_names(list(), ""), named(list()) ) }) test_that("is_named2() always returns `TRUE` for empty vectors (#191)", { expect_false(is_named(chr())) expect_false(is_named("a")) expect_true(is_named2(chr())) expect_false(is_named2("a")) }) test_that("zap_srcref() supports expression vectors", { xs <- parse(text = "{ foo }; bar", keep.source = TRUE) zapped <- zap_srcref(xs) expect_null(attributes(zapped)) expect_null(attributes(zapped[[1]])) expect_true("srcref" %in% names(attributes(xs))) expect_true("srcref" %in% names(attributes(xs[[1]]))) }) test_that("zap_srcref() works on calls", { # E.g. srcrefs attached to the call stack with_srcref("{ f <- function() g() g <- function() sys.call() }") call <- f() expect_null(attributes(zap_srcref(call))) expect_true("srcref" %in% names(attributes(call))) }) rlang/tests/testthat/test-quo.R0000644000176200001440000002415214376147516016305 0ustar liggesuserstest_that("quo_get_expr() and quo_get_env() retrieve quosure components", { quo <- quo(foo) expect_identical(quo_get_expr(quo), quote(foo)) expect_identical(quo_get_env(quo), environment()) }) test_that("quo_set_expr() and quo_set_env() set quosure components", { orig <- quo() env <- env() quo <- quo_set_expr(orig, quote(foo)) expect_identical(quo_get_expr(quo), quote(foo)) expect_identical(quo_get_expr(orig), missing_arg()) quo <- quo_set_env(orig, env) expect_identical(quo_get_env(quo), env) expect_identical(quo_get_env(orig), empty_env()) }) test_that("quosure getters and setters check inputs", { expect_error(quo_get_expr(10L), "`quo` must be a quosure") expect_error(quo_set_expr(10L, NULL), "`quo` must be a quosure") expect_error(quo_get_env(10L), "`quo` must be a quosure") expect_error(quo_set_env(10L, env()), "`quo` must be a quosure") expect_error(quo_set_env(quo(), 10L), "`env` must be an environment") }) test_that("generic getters work on quosures", { expect_identical(get_expr(quo(foo)), quote(foo)) expect_identical(get_env(quo(foo)), environment()) }) test_that("generic setters work on quosures", { orig <- quo() env <- env() quo <- set_env(set_expr(orig, quote(foo)), env) expect_identical(quo_get_expr(quo), quote(foo)) expect_identical(quo_get_env(quo), env) }) test_that("can flatten empty quosure", { expect_identical(quo_squash(quo()), missing_arg()) }) test_that("new_quosure() checks inputs", { expect_error(new_quosure(quote(a), env = list()), "must be an environment") }) test_that("new_quosure() produces expected internal structure", { quo <- new_quosure(quote(abc)) expect_identical(structure(~abc, class = c("quosure", "formula")), quo) }) test_that("new_quosure() double wraps", { quo1 <- quo(foo) quo2 <- new_quosure(quo1) expect_identical(quo_get_expr(quo2), quo1) }) test_that("as_quosure() uses correct env", { fn <- function(expr, env = caller_env()) { f <- as_quosure(expr, env) list(env = current_env(), quo = g(f)) } g <- function(expr, env = caller_env()) { as_quosure(expr, env) } quo_env <- child_env(NULL) quo <- new_quosure(quote(expr), quo_env) out_expr_default <- fn(quote(expr)) out_quo_default <- fn(quo) expect_identical(quo_get_env(out_expr_default$quo), current_env()) expect_identical(quo_get_env(out_quo_default$quo), quo_env) user_env <- child_env(NULL) out_expr <- fn(quote(expr), user_env) out_quo <- fn(quo, user_env) expect_identical(quo_get_env(out_expr$quo), user_env) expect_identical(out_quo$quo, quo) }) test_that("explicit promise works only one level deep", { f <- function(x) list(env = current_env(), f = g(x)) g <- function(y) enquo(y) out <- f(1 + 2 + 3) expected_f <- with_env(out$env, quo(x)) expect_identical(out$f, expected_f) }) test_that("can capture optimised constants", { arg <- function() { quo("foobar") } arg_bytecode <- compiler::cmpfun(arg) expect_identical(arg(), quo("foobar")) expect_identical(arg_bytecode(), quo("foobar")) dots <- function() { quos("foo", "bar") } dots_bytecode <- compiler::cmpfun(dots) expect_identical(dots(), quos("foo", "bar")) expect_identical(dots_bytecode(), quos("foo", "bar")) }) test_that("quosures are spliced", { q <- quo(foo(!! quo(bar), !! quo(baz(!! quo(baz), 3)))) expect_identical(quo_text(q), "foo(bar, baz(baz, 3))") q <- expr_interp(~foo::bar(!! function(x) ...)) expect_identical(f_text(q), "foo::bar(function (x) \n...)") q <- quo(!! quo(!! quo(foo(!! quo(!! quo(bar(!! quo(!! quo(!! quo(baz)))))))))) expect_identical(quo_text(q), "foo(bar(baz))") }) test_that("formulas are not spliced", { expect_identical(quo_text(quo(~foo(~bar))), "~foo(~bar)") }) test_that("splicing does not affect original quosure", { f <- ~foo(~bar) quo_text(f) expect_identical(f, ~foo(~bar)) }) test_that("as_quosure() doesn't convert functions", { expect_identical(as_quosure(base::mean), set_env(quo(!! base::mean), empty_env())) }) test_that("as_quosure() coerces formulas", { expect_identical(as_quosure(~foo), quo(foo)) }) test_that("quo_squash() warns", { expect_warning(regexp = NA, quo_squash(quo(foo), warn = TRUE)) expect_warning(quo_squash(quo(list(!! quo(foo))), warn = TRUE), "inner quosure") }) test_that("quo_deparse() indicates quosures with `^`", { x <- quo(list(!! quo(NULL), !! quo(foo()))) ctxt <- new_quo_deparser(crayon = FALSE) expect_identical(quo_deparse(x, ctxt), "^list(^NULL, ^foo())") }) test_that("quosure deparser respects width", { x <- quo(foo(quo(!!quo(bar)))) expect_identical(length(quo_deparse(x, new_quo_deparser(width = 8L))), 3L) expect_identical(length(quo_deparse(x, new_quo_deparser(width = 9L))), 2L) }) test_that("quosure predicates work", { expect_true(quo_is_missing(quo())) expect_true(quo_is_symbol(quo(sym), "sym")) expect_false(quo_is_symbol(quo(sym), "foo")) expect_true(quo_is_call(quo(call()))) expect_true(quo_is_call(quo(ns::call()), "call", 0L, "ns")) expect_false(quo_is_call(quo(ns::call()), "call", 1L, "ns")) expect_true(quo_is_symbolic(quo(sym))) expect_true(quo_is_symbolic(quo(call()))) expect_true(quo_is_null(quo(NULL))) expect_false(quo_is_missing(quo(10L))) expect_false(quo_is_symbol(quo(10L))) expect_false(quo_is_call(quo(10L))) expect_false(quo_is_symbolic(quo(10L))) expect_false(quo_is_symbolic(quo(10L))) expect_false(quo_is_null(quo(10L))) }) test_that("new_quosures() checks that elements are quosures", { expect_error(new_quosures(list(1)), "list of quosures") }) test_that("new_quosures() and as_quosures() return named lists", { exp <- structure(list(), names = chr(), class = c("quosures", "list")) expect_identical(new_quosures(list()), exp) expect_identical(as_quosures(list()), exp) }) test_that("as_quosures() applies default environment", { out <- as_quosures(list(quote(foo), quote(bar)), env = base_env()) exp <- quos_list(new_quosure(quote(foo), base_env()), new_quosure(quote(bar), base_env())) expect_identical(out, exp) }) test_that("as_quosures() auto-names if requested", { x <- list(quote(foo), quote(bar)) expect_named(as_quosures(x, global_env(), named = TRUE), c("foo", "bar")) }) test_that("quosures class has subset assign methods", { local_options(lifecycle_verbosity = "warning") x <- quos(1, 2) x[1:2] <- list(quo(3), quo(4)) expect_identical(x, quos(3, 4)) expect_warning(x[2] <- list(4), "deprecated") ## expect_error(x[2] <- list(4), "Can't assign a double vector to a list of quosures") x[[2]] <- quo(10) expect_identical(x, quos(3, 10)) ## expect_error(x[[2]] <- list(4), "Can't assign a list to a list of quosures") x <- quos(foo = 1, bar = 2) x$bar <- quo(100) expect_identical(x, quos(foo = 1, bar = 100)) ## expect_error(x$foo <- list(4), "Can't assign a list to a list of quosures") }) test_that("can remove quosures by assigning NULL", { x <- quos(1, b = 2) x[[1]] <- NULL expect_identical(x, quos(b = 2)) x$b <- NULL expect_identical(x, quos()) }) test_that("can't cast a quosure to base types (#523)", { expect_deprecated( out <- as.character(quo(foo)), "on a quosure", fixed = TRUE ) expect_identical(out, c("~", "foo")) }) test_that("quosures fail with common operations (#478, tidyverse/dplyr#3476)", { q <- quo(NULL) expect_error(q + 10, "!!myquosure \\+ rhs") expect_error(q > q, "!!myquosure1 > !!myquosure2") expect_error(10 == q, "lhs == !!myquosure") expect_error(abs(q), "abs\\(!!myquosure\\)") expect_error(mean(q), "mean\\(!!myquosure\\)") expect_error(stats::median(q), "median\\(!!myquosure\\)") expect_error(stats::quantile(q), "quantile\\(!!myquosure\\)") expect_error(-q, "-!!myquosure") expect_error(-q, "+!!myquosure") }) test_that("negating quosure fails with informative message", { expect_error(!quo(), "can only be unquoted within a quasiquotation") }) test_that("can cast quosure lists to bare lists", { expect_identical(as.list(quos(a)), named_list(quo(a))) }) test_that("can concatenate quosure lists", { expect_identical(c(quos(a, b), quos(foo = c)), quos(a, b, foo = c)) }) test_that("new_quosure() checks input", { expect_error(new_quosure(NULL, NULL), "`env` must be an environment") }) test_that("as_string(quo) produces informative error message", { expect_error(as_string(quo(foo)), "a object to a string") }) test_that("`[` properly reconstructs quosure lists", { expect_identical(quos(1, 2, 3)[2:3], quos(2, 3)) expect_identical(quos(1, 2, 3)[2:3], new_quosures(list(quo(2), quo(3)))) }) test_that("quosure lists are considered vectors", { skip_if_not_installed("vctrs", "0.2.3") expect_true(vctrs::vec_is(quos())) expect_identical(vctrs::vec_slice(quos(1, 2, 3), 2:3), quos(2, 3)) }) test_that("quosure attributes are cloned (#1142)", { x <- quos() attr(x, "foo") <- TRUE y <- quos() expect_true(setequal(names(attributes(y)), c("names", "class"))) }) test_that("quo_squash() supports nested missing args", { expect_equal( quo_squash(expr(foo(!!quo()))), quote(foo(, ))[1:2] ) expect_equal( quo_squash(expr(foo(bar(!!quo(), !!quo())))), quote(foo(bar(, ))) ) expect_equal(quo_squash(missing_arg()), missing_arg()) expect_equal(quo_squash(quo()), missing_arg()) }) test_that("quo_squash() handles quosures in function positions", { expr <- call2(quo(`==`), 1, 2) expect_equal(quo_squash(expr), quote(1 == 2)) }) test_that("quosures can be concatenated with lists of quosures (#1446)", { expect_equal( c(quo(1), quos(2)), quos(1, 2) ) expect_equal( c(quos(1), quo(2)), quos(1, 2) ) }) test_that("quo_squash() handles nested quosured quosures", { q <- new_quosure(quo(1)) expect_equal(quo_squash(q), 1) expect_equal(quo_squash(quo(foo(!!q))), quote(foo(1))) }) # Lifecycle ---------------------------------------------------------- test_that("as_quosure() still provides default env", { local_lifecycle_warnings() expect_warning(quo <- as_quosure(quote(foo)), "explicit environment") expect_reference(quo_get_env(quo), current_env()) }) test_that("can still concatenate quosure lists and non-quosures", { local_lifecycle_silence() expect_identical(c(quos(foo), list(1)), named_list(quo(foo), 1)) }) rlang/tests/testthat/test-utils.R0000644000176200001440000000400114375670676016637 0ustar liggesuserstest_that("locale setters report old locale", { tryCatch( old <- suppressMessages(poke_mbcs_locale()), warning = function(e) skip("Cannot set MBCS locale") ) mbcs <- suppressMessages(poke_latin1_locale()) suppressMessages(Sys.setlocale("LC_CTYPE", old)) expect_true(tolower(mbcs) %in% tolower(c("ja_JP.SJIS", "English_United States.932"))) }) old_digits <- getOption("digits") test_that("local_options() sets options", { old <- local_options(digits = 2L) expect_identical(old$digits, old_digits) expect_identical(getOption("digits"), 2L) }) test_that("local_options() restores options", { expect_identical(getOption("digits"), old_digits) }) test_that("trailing newlines are trimmed", { expect_identical(strip_trailing_newline("foo"), "foo") expect_identical(strip_trailing_newline(""), "") expect_identical(strip_trailing_newline("foo\n"), "foo") expect_identical(strip_trailing_newline("\n"), "") }) test_that("source_refs() creates source references", { with_srcref("x <- quote({ NULL })") attrib_names <- names(attributes(x)) expect_true(all(c("srcref", "srcfile", "wholeSrcref") %in% attrib_names)) }) test_that("path_trim_prefix() trims path", { expect_equal( path_trim_prefix("foo/bar/baz.R", 2), "bar/baz.R" ) expect_equal( path_trim_prefix("foo/bar/baz.R", 3), "foo/bar/baz.R" ) expect_equal( path_trim_prefix("foo/bar/baz.R", 1), "baz.R" ) }) test_that("detect_run_starts() works", { expect_equal( detect_run_starts(chr()), lgl() ) expect_equal( detect_run_starts("a"), TRUE ) expect_equal( detect_run_starts(NA), NA ) expect_equal( detect_run_starts(c("a", "a")), c(TRUE, FALSE) ) expect_equal( detect_run_starts(c("a", "b")), c(TRUE, TRUE) ) expect_equal( detect_run_starts(c("a", "b", NA)), c(TRUE, TRUE, NA) ) expect_equal( detect_run_starts(c("a", NA, "b")), c(TRUE, NA, TRUE) ) expect_equal( detect_run_starts(c(NA, "a", "b")), c(NA, TRUE, TRUE) ) }) rlang/tests/testthat/test-types.R0000644000176200001440000001500414741441060016624 0ustar liggesuserstest_that("predicates match definitions", { expect_true(is_character(letters, 26)) expect_false(is_character(letters, 1)) expect_false(is_list(letters, 26)) expect_true(is_list(mtcars, 11)) expect_false(is_list(mtcars, 0)) expect_false(is_double(mtcars, 11)) expect_true(is_complex(cpl(1, 2), n = 2)) expect_false(is_complex(cpl(1, 2), n = 3)) expect_false(is_scalar_complex(cpl(1, 2))) expect_false(is_bare_complex(structure(cpl(1, 2), class = "foo"))) }) test_that("can bypass string serialisation", { bar <- chr(list("cafe", string(c(0x63, 0x61, 0x66, 0xE9)))) Encoding(bar) <- "latin1" bytes <- list(bytes(c(0x63, 0x61, 0x66, 0x65)), bytes(c(0x63, 0x61, 0x66, 0xE9))) expect_identical(map(bar, charToRaw), bytes) expect_identical(Encoding(bar[[2]]), "latin1") }) test_that("is_integerish() heeds type requirement", { for (n in 0:2) { expect_true(is_integerish(integer(n))) expect_true(is_integerish(double(n))) expect_false(is_integerish(double(n + 1) + .000001)) } types <- c("logical", "complex", "character", "expression", "list", "raw") for (type in types) { expect_false(is_integerish(vector(type))) } }) test_that("is_integerish() heeds length requirement", { for (n in 0:2) { expect_true(is_integerish(double(n), n = n)) expect_false(is_integerish(double(n), n = n + 1)) } }) test_that("non finite double values are integerish", { expect_true(is_integerish(dbl(1, Inf, -Inf, NaN), finite = NULL)) expect_true(is_integerish(dbl(1, NA))) expect_true(is_integerish(int(1, NA))) }) test_that("is_finite handles numeric types", { expect_true(is_finite(1L)) expect_false(is_finite(na_int)) expect_true(is_finite(1)) expect_false(is_finite(na_dbl)) expect_false(is_finite(Inf)) expect_false(is_finite(-Inf)) expect_false(is_finite(NaN)) expect_false(is_finite(c(1, 2, NaN))) # Should we upcoerce later on? expect_error(expect_false(is_finite(NA)), "expected a numeric vector") expect_true(is_finite(0i)) expect_false(is_finite(complex(real = NA))) expect_false(is_finite(complex(imaginary = Inf))) }) test_that("check finiteness", { expect_true( is_double(dbl(1, 2), finite = TRUE)) expect_true( is_complex(cpl(1, 2), finite = TRUE)) expect_true(is_integerish(dbl(1, 2), finite = TRUE)) expect_false( is_double(dbl(1, 2), finite = FALSE)) expect_false( is_complex(cpl(1, 2), finite = FALSE)) expect_false(is_integerish(dbl(1, 2), finite = FALSE)) expect_false( is_double(dbl(1, Inf), finite = TRUE)) expect_false( is_complex(cpl(1, Inf), finite = TRUE)) expect_false(is_integerish(dbl(1, Inf), finite = TRUE)) expect_true( is_double(dbl(1, Inf), finite = FALSE)) expect_true( is_complex(cpl(1, Inf), finite = FALSE)) expect_true(is_integerish(dbl(1, Inf), finite = FALSE)) expect_true( is_double(dbl(-Inf, Inf), finite = FALSE)) expect_true( is_complex(cpl(-Inf, Inf), finite = FALSE)) expect_true(is_integerish(dbl(-Inf, Inf), finite = FALSE)) }) test_that("scalar predicates heed type and length", { expect_true_false <- function(pred, pass, fail_len, fail_type) { expect_true(pred(pass)) expect_false(pred(fail_len)) expect_false(pred(fail_type)) } expect_true_false(is_scalar_list, list(1), list(1, 2), logical(1)) expect_true_false(is_scalar_atomic, logical(1), logical(2), list(1)) expect_true_false(is_scalar_vector, list(1), list(1, 2), quote(x)) expect_true_false(is_scalar_vector, logical(1), logical(2), function() {}) expect_true_false(is_scalar_integer, integer(1), integer(2), double(1)) expect_true_false(is_scalar_double, double(1), double(2), integer(1)) expect_true_false(is_scalar_character, character(1), character(2), logical(1)) expect_true_false(is_string, character(1), character(2), logical(1)) expect_true_false(is_scalar_logical, logical(1), logical(2), character(1)) expect_true_false(is_scalar_raw, raw(1), raw(2), NULL) expect_true_false(is_scalar_bytes, raw(1), raw(2), NULL) }) test_that("is_integerish() supports large numbers (#578)", { expect_true(is_integerish(1e10)) expect_true(is_integerish(2^52)) expect_true(is_integerish(-2^52)) expect_false(is_integerish(2^52 + 1)) expect_false(is_integerish(-2^52 - 1)) expect_false(is_integerish(2^50 - 0.1)) expect_false(is_integerish(2^49 - 0.05)) expect_false(is_integerish(2^40 - 0.0001)) expect_false(is_integerish(-2^50 + 0.1)) expect_false(is_integerish(-2^49 + 0.05)) expect_false(is_integerish(-2^40 + 0.0001)) }) test_that("is_string() matches on string", { expect_true(is_string("foo")) expect_true(is_string("foo", "foo")) expect_false(is_string("foo", "bar")) expect_false(is_string(NA, NA)) expect_true(is_string("foo", c("foo", "bar"))) expect_true(is_string("foo", c("bar", "foo"))) expect_false(is_string("foo", c("bar", "baz"))) }) test_that("is_string2() matches on `empty`", { # Input checking expect_snapshot({ (expect_error(is_string2("foo", empty = 1))) (expect_error(is_string2("foo", empty = NA))) (expect_error(is_string2("foo", "foo", empty = TRUE))) }) expect_true(is_string2("foo", empty = NULL)) expect_true(is_string2("foo", empty = FALSE)) expect_false(is_string2("foo", empty = TRUE)) expect_true(is_string2("", empty = NULL)) expect_true(is_string2("", empty = TRUE)) expect_false(is_string2("", empty = FALSE)) }) test_that("is_bool() checks for single `TRUE` or `FALSE`", { expect_true(is_bool(TRUE)) expect_true(is_bool(FALSE)) expect_false(is_bool(NA)) expect_false(is_bool(c(TRUE, FALSE))) }) test_that("is_character2() matches empty and missing values", { expect_true(is_character2("", empty = TRUE, missing = TRUE)) expect_true(is_character2(na_chr, empty = TRUE, missing = TRUE)) expect_false(is_character2(c("foo", ""), empty = FALSE)) expect_true(is_character2(c("foo", ""), empty = TRUE)) expect_true(is_character2(c("", ""), empty = TRUE)) expect_true(is_character2(c("foo", "foo"), empty = FALSE)) expect_false(is_character2(c("foo", NA), missing = FALSE)) expect_true(is_character2(c("foo", NA), missing = TRUE)) expect_true(is_character2(chr(NA, NA), missing = TRUE)) expect_true(is_character2(c("foo", "foo"), missing = FALSE)) expect_true(is_character2(c("foo", "foo"), empty = FALSE, missing = FALSE)) expect_true(is_character2(c("foo", "foo"), empty = FALSE, missing = TRUE)) expect_true(is_character2(chr(NA, NA), empty = FALSE, missing = TRUE)) expect_true(is_character2(c("foo", "foo"), empty = TRUE, missing = FALSE)) expect_true(is_character2(c("", ""), empty = TRUE, missing = FALSE)) }) rlang/tests/testthat/test-standalone.R0000644000176200001440000000626514376112150017620 0ustar liggesuserstest_that("names() dispatches on environment", { env <- child_env(NULL, foo = "foo", bar = "bar") expect_identical(sort(names(env)), c("bar", "foo")) }) test_that("lazy objects are converted to tidy quotes", { env <- child_env(current_env()) lazy <- structure(list(expr = quote(foo(bar)), env = env), class = "lazy") expect_identical(compat_lazy(lazy), new_quosure(quote(foo(bar)), env)) lazy_str <- "foo(bar)" expect_identical(compat_lazy(lazy_str), quo(foo(bar))) lazy_lang <- quote(foo(bar)) expect_identical(compat_lazy(lazy_lang), quo(foo(bar))) lazy_sym <- quote(foo) expect_identical(compat_lazy(lazy_sym), quo(foo)) }) test_that("lazy_dots objects are converted to tidy quotes", { env <- child_env(current_env()) lazy_dots <- structure(class = "lazy_dots", list( lazy = structure(list(expr = quote(foo(bar)), env = env), class = "lazy"), lazy_lang = quote(foo(bar)) )) expected <- list( lazy = new_quosure(quote(foo(bar)), env), lazy_lang = quo(foo(bar)), quo(foo(bar)) ) expect_identical(compat_lazy_dots(lazy_dots, current_env(), "foo(bar)"), expected) }) test_that("unnamed lazy_dots are given default names", { lazy_dots <- structure(class = "lazy_dots", list( "foo(baz)", quote(foo(bar)) )) expected <- list( `foo(baz)` = quo(foo(baz)), `foo(bar)` = quo(foo(bar)), foobarbaz = quo(foo(barbaz)) ) dots <- compat_lazy_dots(lazy_dots, current_env(), foobarbaz = "foo(barbaz)", .named = TRUE) expect_identical(dots, expected) }) test_that("compat_lazy() handles missing arguments", { expect_identical(compat_lazy(), quo()) }) test_that("compat_lazy_dots() takes lazy objects", { lazy <- structure(list(expr = quote(foo), env = empty_env()), class = "lazy") expect_identical(compat_lazy_dots(lazy), named_list(new_quosure(quote(foo), empty_env()))) }) test_that("compat_lazy_dots() takes symbolic objects", { expect_identical(compat_lazy_dots(quote(foo), empty_env()), named_list(new_quosure(quote(foo), empty_env()))) expect_identical(compat_lazy_dots(quote(foo(bar)), empty_env()), named_list(new_quosure(quote(foo(bar)), empty_env()))) }) test_that("compat_lazy() demotes character vectors to strings", { expect_identical(compat_lazy_dots(NULL, current_env(), c("foo", "bar")), named_list(as_quosure(~foo))) }) test_that("compat_lazy() handles numeric vectors", { expect_identical(compat_lazy_dots(NULL, current_env(), NA_real_), named_list(set_env(quo(NA_real_)))) expect_warning(expect_identical(compat_lazy_dots(NULL, current_env(), 1:3), named_list(set_env(quo(1L)))), "Truncating vector") }) test_that("compat_lazy() handles bare formulas", { expect_identical(compat_lazy(~foo), quo(foo)) expect_identical(compat_lazy_dots(~foo), named_list(quo(foo))) }) test_that("trimws() trims", { x <- " foo. " expect_identical(trimws(x), "foo.") expect_identical(trimws(x, "l"), "foo. ") expect_identical(trimws(x, "r"), " foo.") }) test_that("map2() sets names", { expect_identical(map2(list(foo = NULL, bar = NULL), 1:2, function(...) NULL), list(foo = NULL, bar = NULL)) }) test_that("map2() discards recycled names", { expect_identical(map2(list(foo = NULL), 1:3, function(...) NULL), new_list(3)) }) rlang/tests/testthat/test-cnd-abort.R0000644000176200001440000005433014741441060017336 0ustar liggesuserslocal_unexport_signal_abort() test_that("errors are signalled with backtrace", { fn <- function() abort("") err <- expect_error(fn()) expect_s3_class(err$trace, "rlang_trace") }) test_that("can pass classed strings as error message", { message <- structure("foo", class = c("glue", "character")) err <- expect_error(abort(message)) expect_identical(err$message, message) }) test_that("errors are saved", { # `outFile` argument skip_if(getRversion() < "3.4") file <- tempfile() on.exit(unlink(file)) local_options( `rlang::::force_unhandled_error` = TRUE, `rlang:::message_file` = tempfile() ) try(abort("foo", "bar"), outFile = file) expect_true(inherits_all(last_error(), c("bar", "rlang_error"))) try(cnd_signal(error_cnd("foobar")), outFile = file) expect_true(inherits_all(last_error(), c("foobar", "rlang_error"))) }) test_that("No backtrace is displayed with top-level active bindings", { local_options( rlang_trace_top_env = current_env() ) env_bind_active(current_env(), foo = function() abort("msg")) expect_error(foo, "^msg$") }) test_that("Invalid on_error option resets itself", { local_options( `rlang::::force_unhandled_error` = TRUE, `rlang:::message_file` = tempfile(), rlang_backtrace_on_error = NA ) expect_snapshot({ (expect_warning(tryCatch(abort("foo"), error = identity))) }) expect_null(peek_option("rlang_backtrace_on_error")) }) test_that("format_onerror_backtrace handles empty and size 1 traces", { local_options(rlang_backtrace_on_error = "branch") trace <- new_trace(list(), int()) expect_identical(format_onerror_backtrace(trace), NULL) trace <- new_trace(list(quote(foo)), int(0)) expect_identical(format_onerror_backtrace(trace), NULL) trace <- new_trace(list(quote(foo), quote(bar)), int(0, 1)) expect_match(format_onerror_backtrace(error_cnd(trace = trace)), "foo.*bar") }) test_that("error is printed with backtrace", { skip_if_stale_backtrace() run_error_script <- function(envvars = chr()) { run_script(test_path("fixtures", "error-backtrace.R"), envvars = envvars) } default_interactive <- run_error_script(envvars = "rlang_interactive=true") default_non_interactive <- run_error_script() reminder <- run_error_script(envvars = "rlang_backtrace_on_error=reminder") branch <- run_error_script(envvars = "rlang_backtrace_on_error=branch") collapse <- run_error_script(envvars = "rlang_backtrace_on_error=collapse") full <- run_error_script(envvars = "rlang_backtrace_on_error=full") rethrown_interactive <- run_script( test_path("fixtures", "error-backtrace-rethrown.R"), envvars = "rlang_interactive=true" ) rethrown_non_interactive <- run_script( test_path("fixtures", "error-backtrace-rethrown.R") ) expect_snapshot({ cat_line(default_interactive) cat_line(default_non_interactive) cat_line(reminder) cat_line(branch) cat_line(collapse) cat_line(full) cat_line(rethrown_interactive) cat_line(rethrown_non_interactive) }) }) test_that("empty backtraces are not printed", { skip_if_stale_backtrace() run_error_script <- function(envvars = chr()) { run_script(test_path("fixtures", "error-backtrace-empty.R"), envvars = envvars) } branch_depth_0 <- run_error_script(envvars = c("rlang_backtrace_on_error=branch", "trace_depth=0")) full_depth_0 <- run_error_script(envvars = c("rlang_backtrace_on_error=full", "trace_depth=0")) branch_depth_1 <- run_error_script(envvars = c("rlang_backtrace_on_error=branch", "trace_depth=1")) full_depth_1 <- run_error_script(envvars = c("rlang_backtrace_on_error=full", "trace_depth=1")) expect_snapshot({ cat_line(branch_depth_0) cat_line(full_depth_0) cat_line(branch_depth_1) cat_line(full_depth_1) }) }) test_that("parent errors are not displayed in error message and backtrace", { skip_if_stale_backtrace() run_error_script <- function(envvars = chr()) { run_script( test_path("fixtures", "error-backtrace-parent.R"), envvars = envvars ) } non_interactive <- run_error_script() interactive <- run_error_script(envvars = "rlang_interactive=true") expect_snapshot({ cat_line(interactive) cat_line(non_interactive) }) }) test_that("backtrace reminder is displayed when called from `last_error()`", { local_options( rlang_trace_format_srcrefs = FALSE, rlang_trace_top_env = current_env() ) f <- function() g() g <- function() h() h <- function() abort("foo") err <- catch_error(f()) poke_last_error(err) expect_snapshot({ "Normal case" print(err) "From `last_error()`" print(last_error()) "Saved from `last_error()`" { saved <- last_error() print(saved) } "Saved from `last_error()`, but no longer last" { poke_last_error(error_cnd("foo")) print(saved) } }) }) local({ local_options( rlang_trace_format_srcrefs = FALSE, rlang_trace_top_env = current_env() ) throw <- NULL low1 <- function() low2() low2 <- function() low3() low3 <- NULL high3_catch <- function(..., chain, stop_helper) { tryCatch( low1(), error = function(err) { parent <- if (chain) err else NA if (stop_helper) { stop1("high-level", parent = err) } else { abort("high-level", parent = err) } } ) } high3_call <- function(..., chain, stop_helper) { withCallingHandlers( low1(), error = function(err) { parent <- if (chain) err else NA if (stop_helper) { stop1("high-level", parent = err) } else { abort("high-level", parent = err) } } ) } high3_fetch <- function(..., chain, stop_helper) { try_fetch( low1(), error = function(err) { parent <- if (chain) err else NA if (stop_helper) { stop1("high-level", parent = err) } else { abort("high-level", parent = err) } } ) } high1 <- function(...) high2(...) high2 <- function(...) high3(...) high3 <- NULL stop1 <- function(..., call = caller_env()) stop2(..., call = call) stop2 <- function(..., call = caller_env()) stop3(..., call = call) stop3 <- function(..., call = caller_env()) abort(..., call = call) throwers <- list( "stop()" = function() stop("low-level"), "abort()" = function() abort("low-level"), "warn = 2" = function() { local_options(warn = 2) warning("low-level") } ) handlers <- list( "tryCatch()" = high3_catch, "withCallingHandlers()" = high3_call, "try_fetch()" = high3_fetch ) for (i in seq_along(throwers)) { for (j in seq_along(handlers)) { case_name <- paste0( "Backtrace on rethrow: ", names(throwers)[[i]], " - ", names(handlers)[[j]] ) low3 <- throwers[[i]] high3 <- handlers[[j]] # Use `print()` because `testthat_print()` (called implicitly in # snapshots) doesn't print backtraces test_that(case_name, { expect_snapshot({ print(catch_error(high1(chain = TRUE, stop_helper = TRUE))) print(catch_error(high1(chain = TRUE, stop_helper = FALSE))) print(catch_error(high1(chain = FALSE, stop_helper = TRUE))) print(catch_error(high1(chain = FALSE, stop_helper = FALSE))) }) }) } } }) test_that("abort() displays call in error prefix", { skip_if_not_installed("rlang", "0.4.11.9001") expect_snapshot( run("{ options(cli.unicode = FALSE, crayon.enabled = FALSE) rlang::abort('foo', call = quote(bar(baz))) }") ) # errorCondition() skip_if_not_installed("base", "3.6.0") expect_snapshot( run("{ options(cli.unicode = FALSE, crayon.enabled = FALSE) rlang::cnd_signal(errorCondition('foo', call = quote(bar(baz)))) }") ) }) test_that("abort() accepts environment as `call` field.", { check_required2 <- function(arg, call = caller_call()) { check_required(arg, call = call) } f <- function(x) g(x) g <- function(x) h(x) h <- function(x) check_required2(x, call = environment()) expect_snapshot((expect_error(f()))) }) test_that("format_error_arg() formats argument", { exp <- format_arg("foo") expect_equal(format_error_arg("foo"), exp) expect_equal(format_error_arg(sym("foo")), exp) expect_equal(format_error_arg(chr_get("foo", 0L)), exp) expect_equal(format_error_arg(quote(foo())), format_arg("foo()")) expect_error(format_error_arg(c("foo", "bar")), "must be a string or an expression") expect_error(format_error_arg(function() NULL), "must be a string or an expression") }) test_that("local_error_call() works", { foo <- function() { bar() } bar <- function() { local_error_call(quote(expected())) baz() } baz <- function() { local_error_call("caller") abort("tilt") } expect_snapshot((expect_error(foo()))) }) test_that("can disable error call inference for unexported functions", { foo <- function() abort("foo") expect_snapshot({ (expect_error(foo())) local({ local_options("rlang:::restrict_default_error_call" = TRUE) (expect_error(foo())) }) local({ local_options("rlang:::restrict_default_error_call" = TRUE) (expect_error(dots_list(.homonyms = "k"))) }) }) }) test_that("error call flag is stripped", { e <- env(.__error_call__. = quote(foo(bar))) expect_equal(error_call(e), quote(foo(bar))) expect_equal(format_error_call(e), "`foo()`") }) test_that("NSE doesn't interfere with error call contexts", { # Snapshots shouldn't show `eval()` as context expect_snapshot({ (expect_error(local(arg_match0("f", "foo")))) (expect_error(eval_bare(quote(arg_match0("f", "foo"))))) (expect_error(eval_bare(quote(arg_match0("f", "foo")), env()))) }) }) test_that("error_call() requires a symbol in function position", { expect_null(format_error_call(quote((function() NULL)()))) expect_null(format_error_call(call2(function() NULL))) }) test_that("error_call() preserves index calls", { expect_equal(format_error_call(quote(foo$bar(...))), "`foo$bar()`") }) test_that("error_call() preserves `if` (r-lib/testthat#1429)", { call <- quote(if (foobar) TRUE else FALSE) expect_equal( error_call(call), call ) expect_equal( format_error_call(call), "`if (foobar) ...`" ) }) test_that("error_call() and format_error_call() preserve special syntax ops", { expect_equal( error_call(quote(1 + 2)), quote(1 + 2) ) expect_snapshot(format_error_call(quote(1 + 2))) expect_equal( error_call(quote(for (x in y) NULL)), quote(for (x in y) NULL) ) expect_snapshot(format_error_call(quote(for (x in y) NULL))) expect_snapshot(format_error_call(quote(a %||% b))) expect_snapshot(format_error_call(quote(`%||%`()))) # Suboptimal }) test_that("error_call() preserves srcrefs", { eval_parse("{ f <- function() g() g <- function() h() h <- function() abort('Foo.') }") out <- error_call(catch_error(f())$call) expect_s3_class(attr(out, "srcref"), "srcref") }) test_that("withCallingHandlers() wrappers don't throw off trace capture on rethrow", { local_options( rlang_trace_top_env = current_env(), rlang_trace_format_srcrefs = FALSE ) variant <- if (getRversion() < "3.6.0") "pre-3.6.0" else "current" low1 <- function() low2() low2 <- function() low3() low3 <- function() abort("Low-level message") wch <- function(expr, ...) { withCallingHandlers(expr, ...) } handler1 <- function(err, call = caller_env()) { handler2(err, call = call) } handler2 <- function(err, call = caller_env()) { abort("High-level message", parent = err, call = call) } high1 <- function() high2() high2 <- function() high3() high3 <- function() { wch( low1(), error = function(err) handler1(err) ) } err <- expect_error(high1()) expect_snapshot(variant = variant, { "`abort()` error" print(err) summary(err) }) # Avoid `:::` vs `::` ambiguity depending on loadall fail <- errorcall low3 <- function() fail(NULL, "Low-level message") err <- expect_error(high1()) expect_snapshot(variant = variant, { "C-level error" print(err) summary(err) }) }) test_that("headers and body are stored in respective fields", { local_use_cli() # Just to be explicit cnd <- catch_cnd(abort(c("a", "b", i = "c")), "error") expect_equal(cnd$message, set_names("a", "")) expect_equal(cnd$body, c("b", i = "c")) }) test_that("`abort()` uses older bullets formatting by default", { local_use_cli(format = FALSE) expect_snapshot_error(abort(c("foo", "bar"))) }) test_that("abort() preserves `call`", { err <- catch_cnd(abort("foo", call = quote(1 + 2)), "error") expect_equal(err$call, quote(1 + 2)) }) test_that("format_error_call() preserves I() inputs", { expect_equal( format_error_call(I(quote(.data[[1]]))), "`.data[[1]]`" ) }) test_that("format_error_call() detects non-syntactic names", { expect_equal( format_error_call(quote(`[[.foo`())), "`[[.foo`" ) }) test_that("generic call is picked up in methods", { g <- function(call = caller_env()) { abort("foo", call = call) } f1 <- function(x) { UseMethod("f1") } f1.default <- function(x) { g() } f2 <- function(x) { UseMethod("f2") } f2.NULL <- function(x) { NextMethod() } f2.default <- function(x) { g() } f3 <- function(x) { UseMethod("f3") } f3.foo <- function(x) { NextMethod() } f3.bar <- function(x) { NextMethod() } f3.default <- function(x) { g() } expect_snapshot({ err(f1()) err(f2()) err(f3()) }) }) test_that("errors are fully displayed (parents, calls) in knitted files", { skip_if_not_installed("knitr") skip_if_not_installed("rmarkdown") skip_if(!rmarkdown::pandoc_available()) expect_snapshot({ writeLines(render_md("test-parent-errors.Rmd")) }) }) test_that("can supply bullets both through `message` and `body`", { local_use_cli(format = FALSE) expect_snapshot({ (expect_error(abort("foo", body = c("a", "b")))) (expect_error(abort(c("foo", "bar"), body = c("a", "b")))) }) }) test_that("can supply bullets both through `message` and `body` (cli case)", { local_use_cli(format = TRUE) expect_snapshot({ (expect_error(abort("foo", body = c("a", "b")))) (expect_error(abort(c("foo", "bar"), body = c("a", "b")))) }) }) test_that("setting `.internal` adds footer bullet", { expect_snapshot({ err(abort(c("foo", "x" = "bar"), .internal = TRUE)) err(abort("foo", body = c("x" = "bar"), .internal = TRUE)) }) }) test_that("setting `.internal` adds footer bullet (fallback)", { local_use_cli(format = FALSE) expect_snapshot({ err(abort(c("foo", "x" = "bar"), .internal = TRUE)) err(abort("foo", body = c("x" = "bar"), .internal = TRUE)) }) }) test_that("must pass character `body` when `message` is > 1", { expect_snapshot({ # This is ok because `message` is length 1 err(abort("foo", body = function(cnd, ...) c("i" = "bar"))) # This is an internal error err(abort(c("foo", "bar"), body = function() "baz")) }) }) test_that("must pass character `body` when `message` is > 1 (non-cli case)", { local_use_cli(format = FALSE) expect_snapshot({ # This is ok because `message` is length 1 err(abort("foo", body = function(cnd, ...) c("i" = "bar"))) # This is an internal error err(abort(c("foo", "bar"), body = function() "baz")) }) }) test_that("can supply `footer`", { local_error_call(call("f")) expect_snapshot({ err(abort("foo", body = c("i" = "bar"), footer = c("i" = "baz"))) err(abort("foo", body = function(cnd, ...) c("i" = "bar"), footer = function(cnd, ...) c("i" = "baz"))) }) }) test_that("can supply `footer` (non-cli case)", { local_use_cli(format = FALSE) local_error_call(call("f")) expect_snapshot({ err(abort("foo", body = c("i" = "bar"), footer = c("i" = "baz"))) err(abort("foo", body = function(cnd, ...) c("i" = "bar"), footer = function(cnd, ...) c("i" = "baz"))) }) }) test_that("can't supply both `footer` and `.internal`", { expect_snapshot({ err(abort("foo", .internal = TRUE, call = quote(f()))) err(abort("foo", footer = "bar", .internal = TRUE, call = quote(f()))) }) }) test_that("caller of withCallingHandlers() is used as default `call`", { low <- function() { # Intervening `withCallingHandlers()` is not picked up withCallingHandlers(stop("low")) } high <- function() { withCallingHandlers( low(), error = function(cnd) abort("high", parent = cnd) ) } err <- catch_error(high()) expect_equal(err$call, quote(high())) # Named case handler <- function(cnd) abort("high", parent = cnd) high <- function() { withCallingHandlers( low(), error = handler ) } err <- catch_error(high()) expect_equal(err$call, quote(high())) # Wrapped case handler1 <- function(cnd) handler2(cnd) handler2 <- function(cnd) abort("high", parent = cnd) high <- function() { try_fetch( low(), error = handler1 ) } err <- catch_error(high()) expect_equal(err$call, quote(high())) function(cnd) abort("high", parent = cnd) }) test_that("`cli.condition_unicode_bullets` is supported by fallback formatting", { local_use_cli(format = FALSE) local_options( cli.unicode = TRUE, cli.condition_unicode_bullets = FALSE ) expect_snapshot_error( rlang::abort(c("foo", "i" = "bar")) ) }) test_that("call can be a quosure or contain quosures", { err <- catch_error(abort("foo", call = quo(f(!!quo(g()))))) expect_equal(err$call, quote(f(g()))) }) test_that("`parent = NA` signals a non-chained rethrow", { variant <- if (getRversion() < "3.6.0") "pre-3.6.0" else "current" local_options( rlang_trace_top_env = current_env(), rlang_trace_format_srcrefs = FALSE ) ff <- function() gg() gg <- function() hh() foo <- function() bar() bar <- function() baz() baz <- function() stop("bar") expect_snapshot(variant = variant, { "Absent parent causes bad trace bottom" hh <- function() { withCallingHandlers(foo(), error = function(cnd) { abort(cnd_header(cnd)) }) } print(err(ff())) "Missing parent allows correct trace bottom" hh <- function() { withCallingHandlers(foo(), error = function(cnd) { abort(cnd_header(cnd), parent = NA) }) } print(err(ff())) "Wrapped handler" handler1 <- function(cnd, call = caller_env()) handler2(cnd, call) handler2 <- function(cnd, call) abort(cnd_header(cnd), parent = NA, call = call) hh <- function() { withCallingHandlers( foo(), error = function(cnd) handler1(cnd) ) } print(err(ff())) "Wrapped handler, `try_fetch()`" hh <- function() { try_fetch( foo(), error = function(cnd) handler1(cnd) ) } print(err(ff())) "Wrapped handler, incorrect `call`" hh <- function() { withCallingHandlers( foo(), error = handler1 ) } print(err(ff())) }) }) test_that("can rethrow outside handler", { local_options(rlang_trace_format_srcrefs = FALSE) parent <- error_cnd(message = "Low-level", call = call("low")) foo <- function() bar() bar <- function() baz() baz <- function() abort("High-level", parent = parent) expect_snapshot({ print(err(foo())) }) }) test_that("if `call` is older than handler caller, use that as bottom", { local_options( rlang_trace_format_srcrefs = FALSE ) f <- function() helper() helper <- function(call = caller_env()) { try_fetch( low_level(call), error = function(cnd) abort( "Problem.", parent = cnd, call = call ) ) } expect_snapshot({ low_level <- function(call) { abort("Tilt.", call = call) } print(expect_error(f())) low_level <- function(call) { abort("Tilt.", call = list(NULL, frame = call)) } print(expect_error(f())) }) }) test_that("is_calling_handler_inlined_call() doesn't fail with OOB subsetting", { expect_false(is_calling_handler_inlined_call(call2(function() NULL))) }) test_that("base causal errors include full user backtrace", { local_options( rlang_trace_format_srcrefs = FALSE, rlang_trace_top_env = current_env() ) my_verb <- function(expr) { with_chained_errors(expr) } with_chained_errors <- function(expr, call = caller_env()) { try_fetch( expr, error = function(cnd) { abort( "Problem during step.", parent = cnd, call = call ) } ) } add <- function(x, y) x + y expect_snapshot({ print(expect_error(my_verb(add(1, "")))) }) }) test_that("can chain errors at top-level (#1405)", { out <- run_code(" tryCatch( error = function(err) rlang::abort('bar', parent = err), rlang::abort('foo') ) ") expect_true(any(grepl("foo", out$output))) expect_true(any(grepl("bar", out$output))) out <- run_code(" withCallingHandlers( error = function(err) rlang::abort('bar', parent = err), rlang::abort('foo') ) ") expect_true(any(grepl("foo", out$output))) expect_true(any(grepl("bar", out$output))) }) test_that("backtrace_on_error = 'collapse' is deprecated.", { local_options("rlang_backtrace_on_error" = "collapse") expect_warning(peek_backtrace_on_error(), "deprecated") expect_equal(peek_option("rlang_backtrace_on_error"), "none") }) test_that("can supply header method via `message`", { expect_snapshot(error = TRUE, { abort(~ "foo") abort(function(cnd, ...) "foo") }) msg <- function(cnd, ...) "foo" cnd <- catch_error(abort(msg)) expect_identical(cnd$header, msg) expect_error( abort(function(cnd) "foo"), "must take" ) }) test_that("newlines are preserved by cli (#1535)", { expect_snapshot(error = TRUE, { abort("foo\nbar", use_cli_format = TRUE) abort("foo\fbar", use_cli_format = TRUE) }) }) test_that("`show.error.messages` is respected by `abort()` (#1630)", { run_error_script <- function(envvars = chr()) { run_script(test_path("fixtures", "error-show-messages.R"), envvars = envvars) } with_messages <- run_error_script(envvars = c("show_error_messages=TRUE")) without_messages <- run_error_script(envvars = c("show_error_messages=FALSE")) expect_snapshot({ cat_line(with_messages) cat_line(without_messages) }) }) rlang/tests/testthat/test-session.R0000644000176200001440000001717314741441060017154 0ustar liggesuserstest_that("is_installed() properly checks multiple packages", { expect_false(is_installed(c("base", "no.notarealpackagename"))) }) test_that("check_installed() fails if packages are not installed", { local_options(rlang_interactive = FALSE) local_error_call(call("foo")) expect_snapshot({ (expect_error(check_installed("rlangFoo"))) (expect_error(check_installed(c("rlangFoo", "rlangBar")))) (expect_error(check_installed(c("rlangFoo", "rlangBar"), "to proceed."))) }) }) test_that("is_installed() checks minimal versions", { expect_snapshot({ (expect_error( is_installed(c("rlang", "testthat"), version = "0.1"), "the same length" )) }) expect_true(is_installed(c("rlang", "testthat"), version = c("0.1", "0.1"))) expect_false(is_installed(c("rlang", "testthat"), version = c("100.1", "0.1"))) expect_false(is_installed(c("rlang", "testthat"), version = c("0.1", "100.1"))) expect_false(is_installed(c("rlang", "testthis"), version = c("0.1", "0.1"))) expect_true(is_installed(c("rlang", "testthat"), version = chr(NA, NA))) expect_false(is_installed(c("rlang", "testthat"), version = c(NA, "100"))) expect_true(is_installed(c("rlang (>= 0.1)", "testthat (>= 0.1)"))) expect_false(is_installed(c("rlang (>= 100.1)", "testthat (>= 0.1)"))) expect_false(is_installed(c("rlang (<= 0.4.0)", "testthat (>= 0.1)"))) }) test_that("check_installed() checks minimal versions", { local_options(rlang_interactive = FALSE) local_error_call(call("foo")) expect_null(check_installed(c("rlang (>= 0.1)", "testthat (>= 0.1)"))) expect_snapshot({ (expect_error(check_installed(c("rlang", "testthat"), version = "0.1"))) (expect_error(check_installed("rlangFoo", version = "1.0"))) (expect_error(check_installed(c("rlangFoo", "rlangBar"), version = c("1.0", NA)))) (expect_error(check_installed(c("rlangFoo", "rlangBar"), version = c(NA, "2.0")))) (expect_error(check_installed(c("rlangFoo", "rlangBar"), "to proceed.", version = c("1.0", "2.0")))) (expect_error(check_installed(c("rlangFoo (>= 1.0)", "rlangBar (> 2.0)"), "to proceed."))) }) }) test_that("< requirements can't be recovered with restart", { local_options(rlang_interactive = TRUE) local_error_call(call("foo")) expect_snapshot({ (expect_error(check_installed("rlang (< 0.1)"))) }) }) test_that("pnf error is validated", { # No need to revalidate unless we export it expect_true(TRUE) return() expect_pnf <- function(out, pkg, ver) { expect_s3_class(out, "rlib_error_package_not_found") expect_equal(out$pkg, pkg) expect_equal(out$version, ver) } expect_pnf(new_error_package_not_found("foo"), "foo", NULL) expect_pnf(new_error_package_not_found("foo", "1.0"), "foo", "1.0") expect_pnf(new_error_package_not_found(c("foo", "bar"), c("1.0", "1.0")), c("foo", "bar"), c("1.0", "1.0")) expect_error( new_error_package_not_found(chr()), "at least one package" ) expect_error( new_error_package_not_found(c("foo", "bar"), "1.0"), "as long as `pkg`" ) }) test_that("can handle check-installed", { local_interactive() # Override `is_installed()` results override <- NULL is_installed_hook <- function(pkg, ver, cmp) { if (is_bool(override)) { rep_along(pkg, override) } else { with_options( "rlang:::is_installed_hook" = NULL, is_installed(pkg, version = ver, compare = cmp) ) } } local_options("rlang:::is_installed_hook" = is_installed_hook) test_env <- current_env() handle <- function(value, frame, expr) { withCallingHandlers( rlib_error_package_not_found = function(cnd) { override <<- value if (!is_null(findRestart("rlib_restart_package_not_found"))) { invokeRestart("rlib_restart_package_not_found") } }, expr ) } override <- NULL expect_no_error( handle( TRUE, test_env, check_installed(c("foo", "bar"), version = c("1.0", "2.0")) ) ) override <- NULL expect_error( handle( FALSE, test_env, check_installed(c("foo", "bar"), version = c("1.0", "2.0")) ), "are required" ) }) test_that("`pkg` is type-checked", { expect_snapshot({ (expect_error(is_installed(1))) (expect_error(is_installed(na_chr))) (expect_error(check_installed(c("foo", "")))) (expect_error(check_installed(c("foo", "bar"), version = c("1", "")))) }) }) test_that("pkg_version_info() parses info", { local_error_call(call("caller")) pkg <- c("foo (>= 1.0)", "bar", "baz (> 3.0)", "pkg (== 2.1)") out <- pkg_version_info(pkg, NULL) expect_equal(out, data_frame( pkg = c("foo", "bar", "baz", "pkg"), cmp = c(">=", NA, ">", "=="), ver = c("1.0", NA, "3.0", "2.1") )) pkg <- c("foo (>= 1.0)", "bar", "baz (> 3.0)", "quux", "dplyr (== 2.1)") out <- pkg_version_info(pkg, c(NA, "2.0", NA, NA, NA)) expect_equal(out, data_frame( pkg = c("foo", "bar", "baz", "quux", "dplyr"), cmp = c(">=", ">=", ">", NA, "=="), ver = c("1.0", "2.0", "3.0", NA, "2.1") )) pkg <- c("foo (>= 1.0)", "bar", "baz (> 3.0)", "quux", "shiny (== 3.0)") out <- pkg_version_info(pkg, c(NA, "2.0", NA, "4.0", NA)) expect_equal(out, data_frame( pkg = c("foo", "bar", "baz", "quux", "shiny"), cmp = c(">=", ">=", ">", ">=", "=="), ver = c("1.0", "2.0", "3.0", "4.0", "3.0") )) expect_snapshot({ (expect_error(pkg_version_info("foo (1.0)"), "parse")) (expect_error(pkg_version_info("foo (>= 1.0)", "1.0"), "both")) (expect_error(pkg_version_info(c("foo (!= 1.0)")))) }) }) test_that("pkg_version_info() supports `cmp`", { local_error_call(call("caller")) pkg <- c("foo", "bar", "baz", "shiny") out <- pkg_version_info(pkg, c("1.0", "2.0", "3.0", "3.1"), c(NA, NA, "<", "==")) expect_equal(out, data_frame( pkg = c("foo", "bar", "baz", "shiny"), cmp = c(">=", ">=", "<", "=="), ver = c("1.0", "2.0", "3.0", "3.1") )) expect_snapshot({ err(pkg_version_info(c("foo", "bar", "baz"), NULL, c(NA, NA, ">="))) err(pkg_version_info(c("foo", "bar", "baz"), c("1", "2", NA), c(NA, NA, ">="))) err(pkg_version_info(c("foo", "bar (>= 2.0)"), c(NA, "2.0"), c(NA, ">="))) err(pkg_version_info("foo", "1.0", "!=")) err(pkg_version_info("bar (== 1.0)", "1.0", "==")) }) }) test_that("`action` is checked", { expect_snapshot({ err(check_installed("foo", action = "identity")) err(check_installed("foo", action = identity)) }) }) test_that("`check_installed()` works within `tryCatch(error = )` (#1402, tidyverse/ggplot2#4845)", { local_options("rlang:::check_installed_test_hook" = TRUE) local_interactive() expect_snapshot({ cat(tryCatch( error = function(cnd) NULL, check_installed("rlangFoo") )) }) }) test_that("is_installed('base') works (#1434)", { r_ver <- as.character(getRversion()) expect_true(is_installed("base")) expect_true(is_installed("base", version = "0.0.1")) expect_true(is_installed("base", version = r_ver)) expect_false(is_installed("base", version = "999.9.9")) skip_if_not(is_string(Sys.getenv("R_DEFAULT_PACKAGES"), "")) for (pkg in peek_option("defaultPackages")) { expect_true(is_installed(pkg)) expect_true(is_installed(pkg, version = "0.0.1")) expect_true(is_installed(pkg, version = r_ver)) expect_false(is_installed(pkg, version = "999.9.9")) } }) test_that("is_installed() allows irregular package names", { # Consistently with `loadNamespace()` expect_false(is_installed("foo 1.0")) expect_false(is_installed("::", version = "1.0")) }) test_that("check_installed() and is_installed() support character vectors", { expect_true(is_installed(chr())) expect_null(check_installed(chr())) }) rlang/tests/testthat/test-deprecated-vec-squash.R0000644000176200001440000001133714376150033021643 0ustar liggesusers# Squashing ---------------------------------------------------------- test_that("vectors and names are squashed", { local_lifecycle_silence() expect_identical( squash_dbl(list(a = 1e0, list(c(b = 2e1, c = 3e1), d = 4e1, list(5e2, list(e = 6e3, c(f = 7e3)))), 8e0)), c(a = 1e0, b = 2e1, c = 3e1, d = 4e1, 5e2, e = 6e3, f = 7e3, 8e0) ) }) test_that("bad outer names warn even at depth", { local_lifecycle_silence() expect_warning(regexp = "Outer names", expect_identical(squash_dbl(list(list(list(A = c(a = 1))))), c(a = 1)) ) }) test_that("lists are squashed", { local_lifecycle_silence() expect_identical(squash(list(a = 1e0, list(c(b = 2e1, c = 3e1), d = 4e1, list(5e2, list(e = 6e3, c(f = 7e3)))), 8e0)), list(a = 1, c(b = 20, c = 30), d = 40, 500, e = 6000, c(f = 7000), 8)) }) test_that("squash_if() handles custom predicate", { local_lifecycle_silence() is_foo <- function(x) inherits(x, "foo") || is_bare_list(x) foo <- structure(list("bar"), class = "foo") x <- list(1, list(foo, list(foo, 100))) expect_identical(squash_if(x, is_foo), list(1, "bar", "bar", 100)) }) # Flattening --------------------------------------------------------- test_that("vectors and names are flattened", { local_lifecycle_silence() expect_identical(flatten_dbl(list(a = 1, c(b = 2), 3)), c(a = 1, b = 2, 3)) expect_identical(flatten_dbl(list(list(a = 1), list(c(b = 2)), 3)), c(a = 1, b = 2, 3)) expect_error(flatten_dbl(list(1, list(list(2)), 3)), "Can't convert") }) test_that("bad outer names warn when flattening", { local_lifecycle_silence() expect_warning(expect_identical(flatten_dbl(list(a = c(A = 1))), c(A = 1)), "Outer names") expect_warning(expect_identical(flatten_dbl(list(a = 1, list(b = c(B = 2)))), c(a = 1, B = 2)), "Outer names") }) test_that("lists are flattened", { local_lifecycle_silence() x <- list(1, list(2, list(3, list(4)))) expect_identical(flatten(x), list(1, 2, list(3, list(4)))) expect_identical(flatten(flatten(x)), list(1, 2, 3, list(4))) expect_identical(flatten(flatten(flatten(x))), list(1, 2, 3, 4)) expect_identical(flatten(flatten(flatten(flatten(x)))), list(1, 2, 3, 4)) }) test_that("flatten() checks type of splice box contents and coerces to list", { local_lifecycle_silence() expect_identical(flatten(list(1L, splice(2:3))), list(1L, 2L, 3L)) }) test_that("is_spliced_bare() is TRUE for bare lists", { local_lifecycle_silence() expect_true(is_spliced_bare(list())) }) test_that("flatten_if() handles custom predicate", { local_lifecycle_silence() obj <- structure(list(1:2), class = "foo") x <- list(obj, splice(obj), unclass(obj)) expect_identical(flatten_if(x), list(obj, obj[[1]], unclass(obj))) expect_identical(flatten_if(x, is_bare_list), list(obj, splice(obj), obj[[1]])) pred <- function(x) is_bare_list(x) || is_spliced(x) expect_identical(flatten_if(x, pred), list(obj, obj[[1]], obj[[1]])) }) test_that("flatten() splices names", { local_lifecycle_silence() expect_warning(regexp = "Outer names", expect_identical( flatten(list(a = list(A = TRUE), b = list(B = FALSE))) , list(A = TRUE, B = FALSE) ) ) expect_warning(regexp = "Outer names", expect_identical( flatten(list(a = list(TRUE), b = list(FALSE))) , list(TRUE, FALSE) ) ) }) test_that("typed flatten return typed vectors", { local_lifecycle_silence() x <- list(list(TRUE), list(FALSE)) expect_identical(flatten_lgl(x), lgl(TRUE, FALSE)) expect_identical(flatten_int(x), int(TRUE, FALSE)) expect_identical(flatten_dbl(x), dbl(TRUE, FALSE)) expect_identical(flatten_cpl(x), cpl(TRUE, FALSE)) x <- list(list("foo"), list("bar")) expect_identical(flatten_chr(x), chr("foo", "bar")) x <- list(bytes(0L), bytes(1L)) expect_identical(flatten_raw(x), as.raw(0:1)) }) test_that("typed squash return typed vectors", { local_lifecycle_silence() x <- list(list(list(TRUE)), list(list(FALSE))) expect_identical(squash_lgl(x), lgl(TRUE, FALSE)) expect_identical(squash_int(x), int(TRUE, FALSE)) expect_identical(squash_dbl(x), dbl(TRUE, FALSE)) expect_identical(squash_cpl(x), cpl(TRUE, FALSE)) x <- list(list(list("foo")), list(list("bar"))) expect_identical(squash_chr(x), chr("foo", "bar")) x <- list(list(bytes(0L)), list(bytes(1L))) expect_identical(squash_raw(x), as.raw(0:1)) }) test_that("flatten_if() and squash_if() handle primitive functions", { local_lifecycle_silence() expect_identical(flatten_if(list(list(1), 2), is.list), list(1, 2)) expect_identical(squash_if(list(list(list(1)), 2), is.list), list(1, 2)) }) test_that("only lists can be flattened (#868, #885)", { local_lifecycle_silence() expect_error(flatten(1), "Only lists") expect_error(flatten_if(list(1), function(x) TRUE), "Only lists") }) rlang/tests/testthat/helper-cnd.R0000644000176200001440000000475614375670676016564 0ustar liggesuserscnd_cat <- function(x) { cat(paste0(conditionMessage(x), "\n")) } expect_no_error <- function(...) { expect_error(regexp = NA, ...) } expect_no_error_ <- function(object, ...) { expect_error(object, regexp = NA, ...) } expect_no_warning <- function(...) { expect_warning(regexp = NA, ...) } expect_no_warning_ <- function(object, ...) { expect_warning(object, regexp = NA, ...) } expect_no_message <- function(...) { expect_message(regexp = NA, ...) } expect_no_message_ <- function(object, ...) { expect_message(object, regexp = NA, ...) } catch_wngs <- function(expr) { wngs <- list() withCallingHandlers({ expr }, warning = function(wng) { wngs <<- c(wngs, list(wng)) invokeRestart("muffleWarning") }) wngs } catch_warning_msgs <- function(expr) { wngs <- catch_wngs(expr) flatten_chr(pluck(wngs, "message")) } catch_cnds <- function(expr) { wngs <- list() msgs <- list() err <- tryCatch( withCallingHandlers({ force(expr) NULL }, message = function(msg) { msgs <<- c(msgs, list(msg)) invokeRestart("muffleMessage") }, warning = function(wng) { wngs <<- c(wngs, list(wng)) invokeRestart("muffleWarning") }), error = identity ) list(messages = msgs, warnings = wngs, error = err) } catch_conditions_msgs <- function(expr) { pluck_conditions_msgs(catch_cnds(expr)) } pluck_conditions_msgs <- function(cnds) { cnds$messages <- flatten_chr(pluck(cnds$messages, "message")) cnds$warnings <- flatten_chr(pluck(cnds$warnings, "message")) cnds$error <- cnds$error$message cnds } skip_silently <- function(reason, env = caller_env()) { expect_true(TRUE) return_from(env) } expect_data_pronoun_error <- function(object, regexp = NULL, ...) { expect_error(object, regexp, ..., class = "rlang_error_data_pronoun_not_found") } expect_defunct <- function(object, ...) { expect_error(object, class = "defunctError") } catch_error <- function(expr) { catch_cnd(expr, "error") } catch_warning <- function(expr) { catch_cnd(expr, "warning") } catch_message <- function(expr) { catch_cnd(expr, "message") } # https://github.com/r-lib/testthat/issues/1371 expect_warning2 <- catch_warning err <- function(...) { (expect_error(...)) } local_unexport_signal_abort <- function(frame = caller_env()) { local_bindings( .env = ns_env("rlang")[[".__NAMESPACE__."]][["exports"]], .frame = frame, signal_abort = zap() ) } rst_exists <- function(.restart) { !is.null(findRestart(.restart)) } rlang/tests/testthat/test-raw.R0000644000176200001440000000040614127057575016265 0ustar liggesuserstest_that("multiplication works", { expect_identical(raw_deparse_str(raw()), "") expect_identical(raw_deparse_str(charToRaw("string")), "737472696e67") expect_identical(raw_deparse_str(raw(10), prefix = "'0x", suffix = "'"), "'0x00000000000000000000'") }) rlang/tests/testthat/test-weakref.R0000644000176200001440000000270314375670676017132 0ustar liggesuserstest_that("weakref with key and no value allows key to be GC'd", { # This is the case when a weakref is used like a weak pointer (with no # value). k <- env() w_finalized <- FALSE w <- new_weakref(key = k, finalizer = function(e) w_finalized <<- TRUE) expect_identical(wref_key(w), k) expect_identical(wref_value(w), NULL) expect_false(w_finalized) rm(k) gc() expect_identical(wref_key(w), NULL) expect_true(w_finalized) }) test_that("key keeps value alive", { # Key and value: key keeps value alive k <- env() k_finalized <- FALSE reg.finalizer(k, function(e) { k_finalized <<- TRUE }) v <- env() v$x <- "hello" v_finalized <- FALSE reg.finalizer(v, function(e) { v_finalized <<- TRUE }) w_finalized <- FALSE w <- new_weakref( key = k, value = v, finalizer = function(e) { w_finalized <<- TRUE } ) expect_identical(wref_key(w), k) expect_identical(wref_value(w), v) # As long as the key is reachable, the value stays alive. rm(v) gc() expect_false(v_finalized) expect_identical(wref_value(w)$x, "hello") # Even if the weakref object is unreachable, it still exists, so as long as the key is # reachable, it keeps the value alive. rm(w) gc() expect_false(v_finalized) expect_false(w_finalized) # When the key becomes unreachable, that allows the weakref and value to be # GC'd. rm(k) gc() expect_true(k_finalized) expect_true(v_finalized) expect_true(w_finalized) }) rlang/tests/testthat/helper-performance.R0000644000176200001440000000142414375670676020306 0ustar liggesusers# From r-lib/bench with_memory_prof <- function(expr) { f <- tempfile() on.exit(unlink(f)) tryCatch( utils::Rprofmem(f, threshold = 1), error = function(...) skip("Can't profile memory on this system.") ) on.exit(utils::Rprofmem(NULL), add = TRUE) res <- force(expr) utils::Rprofmem(NULL) bytes <- parse_allocations(f)$bytes bytes <- sum(bytes, na.rm = TRUE) new_bytes(bytes) } parse_allocations <- function(filename) { if (!is_installed("profmem")) { testthat::skip("profmem must be installed.") } readRprofmem <- env_get(ns_env("profmem"), "readRprofmem") tryCatch( readRprofmem(filename), error = function(cnd) { testthat::skip(sprintf( "Memory profiling failed: %s", conditionMessage(cnd) )) } ) } rlang/tests/testthat/fixtures/0000755000176200001440000000000014657520716016245 5ustar liggesusersrlang/tests/testthat/fixtures/error-backtrace.R0000644000176200001440000000062014375670676021444 0ustar liggesusersoptions( crayon.enabled = FALSE, cli.unicode = FALSE ) opt <- Sys.getenv("rlang_backtrace_on_error") if (nzchar(opt)) { options(rlang_backtrace_on_error = opt) } if (nzchar(Sys.getenv("rlang_interactive"))) { options(rlang_interactive = TRUE) } options(rlang_trace_format_srcrefs = FALSE) f <- function() tryCatch(g()) g <- function() h() h <- function() rlang::abort("Error message") f() rlang/tests/testthat/fixtures/error-backtrace-parent.R0000644000176200001440000000064214127057575022727 0ustar liggesusers options( crayon.enabled = FALSE, cli.unicode = FALSE ) if (nzchar(Sys.getenv("rlang_interactive"))) { options(rlang_interactive = TRUE) } options(rlang_trace_format_srcrefs = FALSE) f <- function() g() g <- function() h() h <- function() rlang::abort("foo") a <- function() b() b <- function() c() c <- function() { tryCatch( f(), error = function(err) rlang::abort("bar", parent = err) ) } a() rlang/tests/testthat/fixtures/error-backtrace-empty.R0000644000176200001440000000047414127057575022577 0ustar liggesusers options( crayon.enabled = FALSE, cli.unicode = FALSE ) library(rlang) opt <- Sys.getenv("rlang_backtrace_on_error") if (nzchar(opt)) { options(rlang_backtrace_on_error = opt) } depth <- as.integer(Sys.getenv("trace_depth")) if (depth == 1) { f <- function() abort("foo") f() } else { abort("foo") } rlang/tests/testthat/fixtures/Makefile0000644000176200001440000000027014742414045017674 0ustar liggesusers SRC_DIR = $(CURDIR)/../../../src ZIP_FILE = $(CURDIR)/lib.zip lib: rm -f $(ZIP_FILE) && \ cd "$(SRC_DIR)" && \ zip $(ZIP_FILE) config.h lib.c lib/** print-%: ; @echo $* = $($*) rlang/tests/testthat/fixtures/error-entrace.R0000644000176200001440000000064314175213516021133 0ustar liggesusers options( error = rlang::entrace, rlang_interactive = TRUE, crayon.enabled = FALSE, cli.unicode = FALSE, cli.dynamic = FALSE, useFancyQuotes = FALSE, OutDec = ".", width = 80L ) f <- function() g() g <- function() h() h <- function() { switch(Sys.getenv("rlang_error_kind", unset = "base"), base = stop("foo"), rlang = rlang::abort("foo") ) } f() rlang::last_error() rlang::last_trace() rlang/tests/testthat/fixtures/trace-srcref.R0000644000176200001440000000011114127057575020741 0ustar liggesusersf <- function(e) { g(e) } g <- function(e) { rlang::trace_back(e) } rlang/tests/testthat/fixtures/lib.zip0000644000176200001440000011146014127057575017542 0ustar liggesusersPK TLMæ3»¢!!config.hUT ;\À[;\À[ux ÷#define RLANG_HAS_RINTERFACE_H 1 PKƒTIMX˜ñ,ï÷lib.cUT uh¼[Z\À[ux ÷mÑAnÄ Ð}Na¥ë$çè¾pÀ ¨Ä0¢™Û—"Íf°Ä½/Ùoü8/Ð2x6¡Z‚=8b†âü•]Ä‹,Î9 ŸÓ¶Að{ÆüZỀ¸Xƒ…Þµl»‚x>µ„f,&^ɇ^ô¿Le_Öiúz?bnu·Þduó§c)YV3°a;¢¥½ž#ß*.»gÛž«„7EŸ)æ2úÁŠÅ|Õ€cÐÇ”£¥QÛ÷‰ÂGÌ”ZXé™õ¦B"m%ZðLŠ>*ŠS¼ ùUøu©¸T&1˜”Án2*.Æe=§²§xé›úPK$_6M #?|–h lib/attrs.cUT ó¦[Z\À[ux ÷½VmoÓ0þž_q ¥UY¯¨*/‚iñ¡4MÜÖ̵+ÛÙ:Pÿ;çsç¥[‹DÓ–ù.ÏÝ=¾{ìÇ\f¢Èœi‘ÊÕùú,ŠØÎ2-Á°Ýv´œ¬˜MRk5_–™Ø›vƒ—ßd«®ÙÇQéà,¿Šjÿ¬ƒ×ݦ«êõ&À¯šP0A Én©r“ÏW:Ùîœ'zù9&„‘ Rš»ÉcUÂhf¶ÀBiáe´¢ñ¾HÁ¯\-]Ä ú0 âšì†iH…PYŠ`uÅ­Ü|¸Æ^EÈ!Àíš ¾xD\Bx¾„¸¬¹.w“IˆâžÉ“éܳTÇ¡r÷èd“êëĬSÍr²S Æ/íéwc2oBî£À¨Oš(­8"ÇÄPÍqƒŠŠ&‡xoc&-—L´c» ]"”=“:~r~?^VÔ nl’ %YR °ˆëL|˜<©Àúm戬¬£2UŠôæj:Ÿl¬6 ?Óí_’àüþCá‘o¸€ßmGœ—¹³Ì§Ã®,¹6–Òµ„9ÁÏOè`°´EvÞ$»»÷¡ïNàžÊ~QËÜŒ$Vy©qô¥…`„¥VX0.W@Ðù}zSRöK–¢åÅVp§$ÎËꂤY=3‡@.·Ð©Tù=íšÊ^+©Þ•=z]Ê}©…Ž–éívOæœeÛoÌvǵƮlùöøú/Zmx¢”¯‡ jq=¶Mîi´mCviç<ý ³ÝS¾}5£ž‡Øºï œÈ4ÏÁ*?¢Za#ã7un+ìg©,° Ü1ÛÙJAª3¹QI™ú‘c¸/ ¥C“»#ŒuèºgꫦÆÃaCøÊíèB[Í–Ü’1ņ‘\iætK*˜g—ç J¸t‚Øw ¦Wìfî*€?K¥A¨Û§¥A@¦¤ÁÎ,WÒiŸZü`™5ç1¦‹Åk¼7àíaã¶ÃUJ›á½`Ám=§ž(—2%U_¸|·QÈðÌÒԚ椺ÿ“l­Û{æœÓ ¯t1ù7†öÀ}«‚ðÝýÐKûüs·9ùüëÔT¨QVãÂdS˳®Í|{ñsþgg#øøåÃØ»dyæ,øÖÈá¡»‘§ŽZåFñ¼ºµ¶ß¡ûˆ0vN¼V€0 ¾·?OgÉÅlvõöU[íÝú§W羚gný9eÜKøßÒx?u¿PK!”8Mß²ÎD lib/attrs.hUT ½©[;\À[ux ÷UMOë0¼ûWXô’¢êIœ‡"xzO¥½[n²i ŽSÙN@üwü‘¦ë´½EöÌÎìl6™°RPâìÿüõ™Ì—ËlA^ÐÄ1Á)š0‘ó¦|£>«?›„ÒT³3Á-^A»½Å’¬Aªµd«FƒJüq;Åßc º‘Û¢“vz~P@ßÖáÏ:€½Q¾Ø"]’}¥Ywqimñ¸Eµ‘hñþ—¦o‰$E³å,§¬˜– Lؘ‰§,M“»?(šRè@Óµaö‰4js»ÜQnlˆê‚FÈ ÒÚÕ¬ØË Zåy~°¡KÊÈ«e->«UÍg½ÊQ¢.ÀsN•:VÈk¡4Î7TÞ:¯ê¨¯€%u¢ã&®9!œ-Ol𠇩™õ‰˜•v\sG²á9Ô!²qÀ£è:íg34d`Òóˆ“Ù£ýlF7æ²’]—ðµ3Vâ¤;À–+Î}-뻕¤^½C®Ýçã \A‰ÐU߀uØÑà .è°‹sIí nËåºÞ×ut EuvÌ}í™C:㫺ææjC•»6”CQ3>ž3ípÌʾ!3:ó?Q°ýPKæ¶HMrÔûŠx lib/cnd.cUT 0Ä»[Z\À[ux ÷µYÝsÛ6×_±QL6<×nîá"Å×ISùšišËØI{sI†‚HPâ™9å4ùßoÁOIÉ8ÕƒbØÝß~/‡©ˆ²mÌa*3&ÖÇ›éd2yó$~z{~ùâ¿ øÇé“šÕ¯Þ,.^{¸Àùooøùßo.}|ÞOþ.ïùÀ5 ³TU•š)…ª˜¬<"Ñ ü„–B‰R¦¢JŒVQ«qi1p2¸ˆ½ÞÞ>_ó1ã]mó¿Áé8ƒ£÷'G£âˆâód‚zWiŠß–ßA®ÖaIJ é^½}ùr>¹.Òd˜Š¤¹Ím˜ü’¼ àøø؇?‘­Áj›ÔÒ?ÌqÑú—ƒæø|‚;2ä×, oÒjÞzµÔ×WLq´Óu¿.¯=FI|ßPž_,Þ)þ݇~#Æ¡ß0)þ*àµÌ{çRŽg«ò/B^ ýä7›4ã@ØáûïáU’W[)P£…GÅe‰)$¿!^-4CË©t-P%U$UóRòˆU<5æøÑZŒÂà@Úµ§ñל.YtÅÖü‰qmL†ÐÏèëGúšB²nã2}ÿ¨¿gäÛ¼¬îȉt MÀ{€‡áÓ'x`%†àâjú‚|†6¡ø+äL› –Hµ„BÂÒ’-!»ÍçOý¹©"Ð* ®H¸âëSæ@÷öÓ¸½mÅöÎÔ: #ùæö'ºñMè‚8A¶v“¡;q¦£Ç²Ç€L%Ϲè&¥*¶2âAÇÛ&\;±ÚÂeüg³]¥v&F|³´ê…žèû½}—“[ôyÌø?"âPr‰G•J aÃL’6á†)¯« ¶²ï‚Nç² í?¤)‹+>FDS¨.UrË Å¤›K¢¨øÜÉGÙaTdèÏÉ£¨Éô½xòøñ»''ù›Mª€ŒœŠ5àŸqªÊŒÝñx Ø±&yü$Ÿj¼À3Ål¿‚ÝÔeáÅ™q¡ë<û‹øÒÏSxZµ&xÍc©5ù6ˆÊéñÏMQúŸÁ­? ÀÏvcÁ`K¶"ú† f2@3ÙS‰Þ ŒF¡u` ž€¥cç/§ß*Mµ¦&ümß°u§dRqϵ+”Q¥ß)GZìhùiUšF:šà7Ì"N+ P°œ+ÏÖV1Û¨ºcÏUzJÚ”÷ç5ù5Þ°kš@³‚$åY¬õ›öB‘+]®yd1hó‰K:Ô['w^M@Çàï> &˜"µÂ:‹Ž× æó^¤G*Ã^dH—-À¼ªõY1W…ÄÕ]ÉC‚Â0’$9Sm]mŒ.”mÆ«F]´'ºU8Û¯=‡¾>J¡£¡0‡OhÔ?i ÁŸ&ðÞìçÆÜŸ·¨Žß­ÇÕveL!cxŒƒŽHò—ØfYm^¦®”šù5mµ&Æ*“µLÓÞé(°f1‘µ"gƒµÜƒ’UúC.ÔÞ;ëٿɧHÄ£ü}ñüò?¯ƒšõ—æL—;ã1$Öv7™ÕóÞ´êzwZÞ‘–@Gº&ÒhÆrÑ䚥©´‹ZTL¬,é¦×8ÐjWG•ãŠqÕ¹ü½"ÈSˆn…ÀÕzë̹ƒ»ÐÁCt;T·‰F’çD”Kv¦`å‹6º> -% ¶´í&X¡Ù m ÍtŒY^õEp®W’³«ù©m¼ÒžÊ8˜NÓ¦ïYã½¾ðÈmYÍlŠ¸ÏŸ÷Fl´l›Ui=/ö¤}þ’fB–5ññ0MP\¼|öê_á/Ï.à ݤϟ=_„¿à®}Ÿyz¡A&,âÇ›67{\»é" 4.Þäl”ïhÒ—i¾ÍhÒÇ(e¡gyl:ôCª4m <_ñ8æño—?‘-ÐP§â"|¾áÑ­¿èÚùþð0“É„‹mNþuéN^n9|GPvsÓ+×¼jjߌ§D]$¦â< ƒ:~ôóÔ§Oö6Øœ2 Û']M®Ëñº¨ £åH­m#ªkå©34Á«WOñØÉÿyÚPÎáÑ£´ÕnçzŸ*˜é*•ÄRòÄΨ}-‡xßæ@]í»“Ž7eÔQt4³6°Ãq”—Íñ:¥ÒRZdU*¶|nW:cz“~í”uœM G~G3Ü…å3†áæ[öîÁòÃÀaÐwo.|ûòÓCò]6߃ãÔÅÑ©Ö}ÆŸmƹöáêÏù.é&HE† 6(VÿÃy¦¾®˜qÞÉC¡LÖ´/¶8cøMNEZa¥XI&ï·-­7Úú–R‡§wk_dd˜3yÒm0-¶Ê½°Ú=1ä`ƒÂ» t:ƽóg//;Ö, ÃÖ¦c¨µœÍŒ}v᪠\݉dožik?Uå^TfbØ´osA„3SêÖ\ÿW‚òŒŸóm’dôl ¯®4ÞûzÐ ì…ÕMÕÇ×ï†=; ¿GoàÞŸ:Q8­·©÷áþ´s¥ßñÀÚwõlÇ+áM`^nÝ«þ¸ ì;æÇNØ#['ÓÿPKUDM,Y0•ô lib/cnd.hUT ÑÒµ[;\À[ux ÷SMOÛ@½ï¯ 9ÈŠèÇ­ mEPUå´Úxg“ö¬µ;†Tÿ½ã8qpÚ7ï{o>ÞÌxäYtpóíìê‹>¿ºÐ_ÕHO8ÀÔÈSQ6á$±…PN§J©‡à-DíÉ…XeE ÄP,L<Wq“Édüi#z4‘^‘˜Yˆü hm˜£Ÿ5ŒZg…ˆÜDo£=1ÆØÔœ ¶“Ÿ“)u ŽµÅ:baí F•æ9<¼¾kSÜ›9æpYÒÃÐվĻyö–p×P±Ç¸XéÊ® Ö:q|UJø¨Ec=û@Y‡òïº÷°òÜ}ZÃfʆ}žÊvûíŽÛ’éŸ4Ë1üQÝøáÇÝõå÷Ï™€Ó)ü¼<¿ýu ‡‡pã¤ÛFÏ)[æpÐ'9ROýv ²ë ­“ °NË®O«g󮳪q®4³‡êÕ½QÛÛKb…ÔT­zÓ¼nGع_¥hŸ[¦pœ¹ S’ËæÝÓvêi.ÌûFn8DÁ?ìàýy ÷Q=ímo2˜©üÃ(:§þPKŒ\?è`7}Ò÷ÒƸÎÎ=`‹îg;ˆªª–ÑôÀÚÓ:iãüD] <ÁªàVСµðïMs”¬'dORlß\ vhåC¹*%”ÚGkZÐê« ƒ^e’×q×¢'Mn©£{b½~6|Žãý¯IËã5š—ðÔbl73“ úÌx‰Œ,û§J´Ò7f‡Ý¾‚ïÃâ…É{3:0QO=´Ôáì Æ3 Xs1Cf8hN§Ü!¿›ÿ‘â%Š¥Ú×»¨s\jó PK…\3¯¸ 5¹DÄÑR¨Ð´†É&å—§j  Ä'ÂÔ¦æ•%Ö¤æ¥d¦qPK!”8M%½=ºclib/env-binding.cUT ½©[Z\À[ux ÷½U[oA~ß_qĤYZbëkWZ] ±bƒ¶/Æ,³»³0:Ì™YÚjøïž¹ì|1ñ˜sýÎw.¼d¢âmM¡§8³Wó^’$¥”TAŪ(™¨™˜LK%LÓTÓÇå) rþ§~ZôáwÀHUaž–T6©“¾‚ø,%÷v€BRJeÒÞHªá@•’êòÇ%­ ­ÁÛòB€‚oZ³ŠÚëglà‡"Ë0 À´N=Hb 5­¢u†`—æän'÷W7wù–E+JÙŠÚV‘%ë#‘Ê°Õÿçǧ=NO¬|R\{›‘¾ PŸ‹´o‹J´!†U´ ±6 P#r­Ù/ ƒôfNåH·+Ä&U¨±`ˆ}FÕ=2Û$|‡bi”sBQQSE›ÔÉâ]hjÒh8€ È#f— œFªsRWÇù9LœLÃøîæÆÒN8‡á-b5ô’( DX±¬_Én;}É{­ jí)pc€1ŠzFµÔr*ß#m‹ÒÌTó­öÇH>TEpôoœisÙ9wA¡T”üÌž™Vs¢°ÿTmÛ7„ëm‡š6¤åòèTÝ ÚÍÕ´6uŒÚ›¢¦?ÝZ¿8®©œŠ™™o*Ìö¦Å¶%;4^šF*ˆÇPs‘áל±nMâ~eîi÷+ÐÐY€ÕzTÈj1ÃÁêp €õ½ß(2¶ç¡ ¦Ãf"˜j®öt÷EE»80HžÉ!.`>¾/®Gãw£ñ‡Âݘ ð£÷6±MM;3çÛ43ÝN>}ÉwŠ=˜2\°Ïxõöëè>ßáÆ&´¶›˜VòÂï}”Aœ‘y~›î_!ÑQmÿzL<€gÖßØw»Vøì”ѦÒxŒ»?Ñrîf~{^ÞOò<}’íÞ"uüPK!”8M ÙÉ¢Llib/env-binding.hUT ½©[;\À[ux ÷uÁ ‚@†ïó^*†ßáBåT`úÑFQ"—"Z “·àÀŠþ2R÷Iª“)«œÕU¶}MøÄøë:ñÃs€ œ»:Äû86ðW'‘˜ýËH«êö󉵬›ªdMMz†º8DÝ—SoDºd-w£ÎíNÚ>X À!3ðPKq‚HM8ªgÊT lib/env.cUT vg»[Z\À[ux ÷•XmoÛ6þž_qõ0TN…´ öeõ²¢/n¬Í /- ƒ"Ë´­E"Šríþï»ã›(K6Úu$ñøÜÝs/<ö‡œgE³`0’EÊWëÑÙYͶÕ9°MZ$_rµN¶‘ù’¥EƒyÞŽ'}¹Ý {Ø îx8¹Å=<à^g—Lx0¾‰2ÁkÙ:•çPݯÆðõ ¬<¯á Q*Yæ|Í’›´du•flÆVy­$BˤޕíDt€| í£ Ÿ‹†/HÀÀ~LçBªhô:å,p w?Öw£X›AX{ü'™j$GS&g{´]¥*ϼyÚ´SÖ{|‹!ô‡C‡Äü¿®Gz‡ñ@ËAOŸšs)TR”yÍ@ |)Ò‡Ý{‘.Þ¼Z2•­£±&Üz-µ«˜XF¨eL|œýù᯿?:×ÿ˜N?êµ )øÈl}¯×¼aS’!£XY©™ª¹x;›N£Ÿ,1ÆÊ[™¯VLÒv–)à%ÆI)¤µKc ‡Ö0ƒÓ¨•Xúƒøw©3OkFùCÔóíÃæCdwiƵœh7¢ºxlb"7ŸÞ¿Ÿø„ukߥ4<®–³/zÓ«”HªT2®.°ÖOKÖùëʵ•gdr)x‰h6{ ´NGÚ ôcü2+ˆc^¸‡çašP̤֘Tâž¡72²;¶»M®kUWæÏ óç9\þrÌ»FÆæä™jñ\%¶ùÒC›¾ØÞJÆ0q%¬²oö¥š¢06^pñëe½êDtiù²—>\´’Ö IE®m‡ù¶øŽ¶X÷÷¶lôBZÄÞ÷jšï {Ï]Ôq*& >ìû®oY!8 [hßê#ÎÃë ÞHƒe^£N±…QÒi¢› Õm_KjQ#E-ô@nŽ:Ç*ÖK¦c#V'ÝD£4¹Ý.f*P¸• ‰CóŒUÄ5ïÊ¥Ÿ%A·æŸmŸv-³Qmµ%Í5Oã+µŽÈ o•æ'©”ÔÙZ& &ÙÒ a•Yr¼~²Bú»¯¦Û5~„¼†¬‘d~±Ãƒ¾¤;KH³Œ¡-|j5×ðLå‚뎋*ß0ƒbY¶ÍX¥PZŠfµöÕtjPE™Þ#¹‚¼¬âÎ :) B%YÍä†YX‡Xe(+>#öˆ­/Èj‘ã+GGŸMðϯÀ'ðäIã%Š=!.Œ7%ôÓF3‡Xç~ƒ • )Et–Lo>'¯®oÞ\ß¼K^¾¾½þxYØ`}ÙÕñ; –šbºŠUŽO‘w´ï–B f7ØÝ=56ÙðÕ¯ [­­½cÖ`¹®|CN3ÅÌ”m…ÞÛä:fÍ©‹Ó ¶‚eë.ÿÅ"ú #¼¾Q)ÁžH4KÏh‰'G!J†JÂÎê‘/ôy—«$è#KM÷Òà/¶æ*>êº^2<{uïŽê(ò9u™@ÅÁAÒ˜C3,M·£´¾ ïzà¢aõB»r;û45T˜ßñxt0ûRr–©¼Oð ÌrÑÔAÙœGîvDÎ y¸ †o ~ÇðôÃ) J”ºÐ!CYòw<t«k4NÜ^“[ x­Í†(nÍ] ë´^ŸÖÙQàn a¿÷ÍçÈŽ»Ví6èÍWðpDQ€jÕôsì0_üÿ¢D­ìã^vìÏþPKC‚HM“sÇ× lib/env.hUT g»[;\À[ux ÷­UÛNÛ@}÷W äÅAV©Ê#P‰¶†"¡%(jŸÌÆÇ[Ö»Öî&$-ü{g}‹s!R_¢õÌì9³g.éñT&˜Âèîjp…ƒIôÝë‘KÜ°y=.c1O.ŒM¦J‰ÙçŽq´@m¸’Îêµ:š 5e"B¹€QtS~„rÑ ˜2ƒµû 7˜vU{Cwvn—µƒËâ„‚r´™JL$‹E0tÞ¨½L~éh. éÍ]…›nî"¸½Aq¿hÿ…ô±pÃ휩®±¦ú+UQeõ[HsÁ1'x‡aK’•9ª\Ž‡š©XƒÉã#¬ˆ†gáu€ÁÞ í4§óv×Ê1¡„ÚR–¥ÄòZ¿ÂF¨üp®rªD#\ØFï`Ã,œ%‡ü4ù\),”Ì A, äÎÎA8"ª½ÌAio‰EU¢¢ 4TÅ /Y€Ñ™Å½ tèf§C|)6†™fÏG@­dsDt:€`¯ï z}°Á‚6PxÅÐÊF :ÜMÊß؉¥õœœ²á®sPØE]ÇOðnhšføªÓ³¸köA kg±€X­Qb Vž-¿ê6ú…¼”—Úñc³ýtš\ÞŒhNŽ0š+ÒXäÙé ÷ç,—GÁ1L¯&@ã•7%¶SØP_oÐIj•]Å'·âv7@t䯎±Ð±;Sºƒ{`>QdgüEö3¬TÖ&X­±O_¦ »áû0‰á aü‘ĸÈê~uŸ©‚¸2PKý^6M ^E˜ï lib/export.cUT ­¦[Z\À[ux ÷uS]kÛ0}÷¯¸$Pä"¶ö­Ý ËëÒàd¡oB±eÇ«sm$Åk)ûﻲìØ˺!éêÜsî—¦&å1U0Ñ¥Ä|¶ŸÓ“I=ו¶ÙnãFiST8Û ÈœKUV JY,¶Q¼þú° áâN7¸ugïÄ®8\sx†!òKzù.ŸTôl•FY®¬^ ûr/?–s¨9x•y¬ueCx 2µÕ@ë†n´Í2„P»›Vö¨ñ_ræ`DÛ¶T7Áï ×‹Åz—¦.¯jþ'Y“bô¸YmbA‹™p¤îCrS…i‘]Êmʃ2µLK*4’½Ô—€’G¢ÆêsRùE+gâð´nMŒ ­š‡&²,{”æåÀ&¹²Ë^dâ±cq¹@>0gäƒÖ˜•Œ òÐB5²ì ±ø,Š°i‘‹8ŠØÕ8qï嚪H»„µÊ CåuU ígysß©vm…8ôÍÉp\׆>7&(CN!ãÑEëw—ÕØ[T»ŸC½PýJl¥Ù6š¯WÞû:¬£ Íñ|ó@Ãq¿a'M0w,ç¤I)y«Y7:>ï®ôj”½³ô¾hc1wë—î*ùÀ9:5Å6MýX¿ÿ—[©»‰è‹r8 z²¡‘×íøPKæSLMQ>áÌU lib/export.hUT Ï[À[;\À[ux ÷SïkÛ0ýî¿â Pc¶ÁöÍeò£+¸iQÖÑoBµÎ‰ˆ*I. ¥ÿûÎqd{¥ceþëNï½{wçLTi$–ÀòÙúŠ/înÙOþ#šPN|›Ž&ʺ‘—ì­S•ù´û>Îr<øÏL®„lïZN q§'cÆ-Ùæúv=…‹ è#¸lÏbü5…o)|™N#¬±u×ÊÃËs¥du‹œ¯î×s(MöJ?¼ö6‹ê„dnÄ—Ö}çíÊÄ^§Ð¼Ø†cm+?Í¢a|DIÙÒ; #ÔTeÔû ,˃‰pÃø\h}ƒ~WÉÅ–‹GcL¨5Æá97àZ_›²¢;©5WtÌh¬í0Àja¶ÜâV9bñºR†ÞqQç¡Ø ›€q)Œc²ÉxÂt4Ej-r^xU€2º]|§>(½ÿ?Äëýöoêa&­<¼D@í²³Ú|´Nüsròú//Ã,]<Ì$:¥Tç£Og{KB#AüÄÂö‚Xˆ]˜Aè‚U§æ\ܺ†õ}ž§£ÊçÄÀÎNäÆáâH£RÅæøôXé3{5Ë7Ë÷&×ï€> Äý‡·Pi‹¾±†Ê_¡³ºx*þ¿PK$_6MÁ@)*ª%lib/fn.cUT ó¦[Z\À[ux ÷uŽ±Â0 D÷|EKŠ cÅÄDië–J®ƒ’¦P!þ¤¡E l>ûÞùÖ-•è+à+‹ššÝuÅsð¸m¸UwU{*ûÖHËÚØN£Ûò$ Só 4düÉøGjÛ8~à')Ï"E‘©@$",®³äl?ql4¶IÑé8÷,7D˜œOųˆÂ,†ŽÆ¿km~ou³\åË¿*ÇFý:¹O¶Bzjj:Z´ù¬”kóéœZkLh§¢>U°[tÍ;ÏŒp»´Ìúy šÊOT4J[oàr‚kÊ!M±í ÁJE|z1g<ä„oQyåÎ2ö á>ng3 %ûPK$_6M;{%Õ—r lib/formula.cUT ó¦[Z\À[ux ÷ÍTÛjÛ@}÷WLTr¡uÞ,[J )-…R”µ´²D×+³»²‚óí½Iò¥ íSäÝ™3çÌœ7ÏX“S#|qYƒÁ@ÒíêDZ¤¢”¡ýU áiPŠT=®h]„xv–ÀôföñË÷;{˜FæµPað°}€e#Ì)(j±l †1FíøOn*••ŽQ¾P%ÂYŒŒH £1ªÁ×9M3’ ‰}ÀUðþæööÞ]å´ SãŽÆ'¾&¬Ê ìz*Ùÿ¡²a섺cùÿ¤‘òõ¾Æ~AUJ”Õ¼Q4,"<’Ë0¸œðu%j¾¤\C„D=óºf®$òÈÊ\úäÐ×/öQ0Ê®dé¶T\ÌêÍí7NÇÂKET•AVslwVq]~ÊÉ’Ê£ŸÀÏAÁ8 `º=9P˽ LÒnx†SIIŽ¨í "ÄôÌÈÀ~Ík–þêàèˆW£á‹•4– × ¼õ±Z¿kµaàø†n4I`2û†Jb›Ñ¡H—ëᎋëò= Øë“õõ¹®ï<Œ¼†QWP_»jí´^©æ®”h¨ñ„³*§›T7†s‚Fn¢ûl…9cØSU1œN ϾN§í¤Ú ϯé<ÿìŸNº}+›šç纶Vl_íñRÀëÞZà@ûOéÀ^EÜ~±qoÉa€l?O&whÝ,ãIVI|eØy‹ ûýzÆ(4}íòð¯ØÍcaۧȠéàŽ1.ŽøºO‘çnÀÝëYÕ¿hªÈ"4‰Þ5:ÁĶ›IêÕd²lý÷“IxeCÍâÞÆÓLþÎDv^Ë¡}«"“á6øÀ3F¤!ôÖ¯'øîˆàoPKý^6M°ÚxÂ}Ó lib/formula.hUT ­¦[;\À[ux ÷uͱ Â@ Æñ=Oqp‹ŠoàÔEªB¡s¨^ÂÎ\¹héã[hAQÜÂïÿA¼°b×ÔÕù€ûKsjë à'¥¸æœ\A1ä\îÏԉŕÑØoܸu¢g·ÜS˜ïm½˜{AÆmYóÞžþ8éðáËsÆØÙWð¤A^PK$_6MaìÕS lib/lang.cUT ó¦[Z\À[ux ÷ÍUQkÛ0~÷¯¸¸£ÄÅ {J¬oËBiV(Œ![I ŠìI2Khóßw’œÄrâ’AK–ÇöîûôÝ}ÖU.R^e BÉ©X¼_†A0+ ’䊤”ó¾bëòÖ1¤…PÒ%•7 èŠEðäsèK¢7%+æýu½Œo'_§w. ™®¤€9åŠ ñÍÞùASF#˜<ŒÇðüìàÕf5+8VEÆŒÄú±ƒ¶u‚m›,¡bs’°c¬bÈ…ñšÌL-ú ¶+Œƒ«ŒÍsÁàžL>O“drû=™’ | ¥©ÎÓ&ó@UÍÓÄ–úÙ^õ Fðá»0†ð“¹ î:a;l TJÄ]³ì­ÚàÅU]2š!-OŠa]´ç7ˤÆàï1>’&zÔ”=0ß‘KÕäÉ}kðÖÀF–S“Õnà–ª³]Åc`]Ã×!-+Œl;ïšMx­á¼˜þ”ÊESðlê¨m«fMèpÞzþñ¤]ÑÍŒ]@`·ì<Ë· ¹ñ‡¦cLÖÝ·ïKš¾ìcuA_×3e>DgøVù®åG®µVíp*·NUçùôŸ?voþ‘h5´ó3M­qº~gx½“Cdæ sÍéûÿY]•,Í)'EéM¼ãé :±íÇ®¯ë¨_ !}ã:Øz(þI4f¡Yª}Äúˆvï~W˜y¹Ù±‘oo‡C$ò³$™QňPdÁt?´±ÁÛê~K’;Ãý±,Mð©âIúšÀ…f¿PK$_6M—)h  lib/lang.hUT ó¦[;\À[ux ÷RÏOÂ0¾÷¯xa—I¸†&%ÀAOMi;iRÚ¥í"Äø¿Ûv 8˜\¶î½ï}?ÞšˆB1^ÀìéîùÇÇJ|E(Þ.¢D(*+Æa 4ã׫BÈ:â¡dÀ[¾)‡`°â˜)Óº@‰Év=ÊÌ|"Ã]eÌ ,©V6˜Ð½A_¬ËJHyq0p‚¼þÔ•ƒ[xÌóiºŽs?R^ `ž/ðâmš¿LR?AH;ÆÞd–çé(w~=$<ëpgnÅ kå=N YØY%e¯ð£÷>91:u½$ÂHa]'{éŽ;tçñEÆiM ¢´ÔZzœ°Íenü_óWÅ]3EÖÜ£ÛPLÔöOx·™Ïç@ù¹Æ`iüußpö±ÖL—*Ëþ2¬ÉvÉ/æiÅNIèéöL –ÎE2rfKN‘X—-g´¿_þeü´ãÔ5û(኉}PK$_6M0+À³a lib/node.cUT ó¦[Z\À[ux ÷TÁnÛ0 ½û+¸ìâÞº][ä˜ÅŠbè°³£Úr-T“ Y^S ù÷‘¢d;I³ ðÁ¢(ò=ò‘ï•©õØHX9-ÌÓÇn•eÙ ÷}®2ò¥òâéI6•±Ìkku'\h/ká¦ßÆ­áwñH¯`_·Ûo9‡ã8ô€\×7èꂱêí³¤l9J´¯?s<³Ó—‡í6ÿÌþÒ΄Ø7Ù!Ë®®à{'´¶/PÛþl ‚3{'åL†’¥ªµ52gûžáª í¥ms´½Û«^(§ÕàÙЊGë|¾º5^:#4H笻†í¾—µ—ÍœZë`X@[ü`?—¥{­jáe¾/ñÝ(‰ñTB'±äØÓË—Ni‰@ÉšQëŒÝ;)Ø$ºXèàòž°$Ï5l.=nLŠT¾QÉ)¦8p‘tBÑ,PöçÝÜs+‹"ƒ>Àm »A¯ŒÔ;P–r4 (¾Ãº*‡ñ)ö5ìzáб²£Ž;®ÊîBc=Ǻ†Gë»”þ—У)–ñ(žÿ5]cÿ:<â§Õ3ƃ­“R£•5ùqôÀ€ó¤t „WWÇ¢¥®p©«“ê|®4w M<0³XÎ#[!Içfº¨G‡V)Ô ú˜ªwÖ£¢Ñþ)è1ª/(4j„žn&³|B“§0QÅ Có!Ýö,'œð¾¹ÿqwGYS¶£–žB:žÿ4Wfhi NuÃý4뜖¦Ž¹¤‹­·˜Iò*—ãA†øîtâUIyx)0ÁÔÇsŽ´Sª{~tN5îc¼\@êA¾=ðˆŠÓ”0“Šä'M‘&¶KFÓ¼_Xš4Ï—4¾¦eyÈÞ˜„V™&Tæ| ¨LMÔjà{¶)y N-£Ÿ°§×‘b¬à‚hx>3=Ì!ûPK$_6M°Ô¹Ž&v lib/node.hUT ó¦[;\À[ux ÷¥VMoã ½ûW°ÊÅYù÷åÕnwÕ*‰ïª=!H‹áÈŠ¥jÿûb°)¸Æqº·0ü÷†yàÌè‘crÉãzs7Û(†?¼™ˆPNì ç%*éPΚdAêÓwCža(÷U žƒw€œ”UÎÁí:ñëùÒû;ZŒÅÑ”b䤞Ä\äëIìØÅMëÜÙúöQf—Ÿß(#ÀW'¾­@7”ýF¬"s‘ +}®š­nxƈNÙkÆA›æä,¢Šz§rÚAí\ÄǃøØÀ4>þ>r4Ðë@y6йëy†±h¢ÿ;©áN0²ÏÊì‰gÒH”Ÿœswðë ÿÓõýeûKB'Q„˜%L Ë1M/YÆ*-à ќѢVõ¼‹·wÍÍZ­ÀãÏ}ºÚI4—Jr–J[01êN¢>Â99ÂCÆ _nQ‡Øˆ4pD¯+¸fk o(—ÍjPyI4Õî$J*ÆÆÆa"† CZ¨ðÕ:«Jñ=ÄñÎ7˜BM%M¤6y'b2w—ı¿0½&2#n{©(׆±K¶i|›úÝÔëÖÕ¦ö‰ðkÓ•„×Jë¯?«ƒiC±qǧâ`YŸõɢɴ7Zã÷͵ÂÖ+²¶wS䣒ñv±Œ}‹—öŽEí€/õG´Éu "œ°vý€Ê‚€â?6Þ#M¾@☎éÑûPK!”8M±EXëV3 lib/parse.cUT ½©[Z\À[ux ÷µZ[Sã6~ϯiaÃ6YˆÙm·Î†6³d6$Ô^†I]ã(ÄScglÈ,ìo¯.–#Érpn<–?}ç¦#ë;×w¼é‚rèÙþÝ»q¹ôúdZð)>¸´Ã¾—J¥(¶c×;ömÆÖ߬Dðiò8ÁVÑo?Š3¶Ã·àq<Û_K¸#P ­ „ÿYÁ$v¿BåYÖ oƒZ0 ƒ0*ïƒ&-êyt&@W˜Þš„®W°Œý)á;D‰J¹íÇ0ômìFå*Þ(½ ­‰va¢+¯_‡T … K 4ÁøDÚ:ã°‚ˆ!ˆúÈþi"ò§‘Î ¦1›fZøtâ€L·ª V¯‚=:§Êl#6`¯ÐqlõeËìVï ³[p0!*cn׿#Ûõà°œ:‚º×ƒþ]<® mˆë ˆŒ§ Ò¢(LèA€ a¡Ð0Zô‹†˜Ý(¶î`Œ¹«àzäÌ4ŒŠFÀ!Œ§¡áØá‚¿-ø`{²Ó«‰ã ÿÀûŸ‰#S’(¤jïïW ¾ÁD×¢KT‚O1xÝ@¡ï@rq7¦Õ»´.Z X¬èöºÆÌÐ=ðn<Âý Àa€wv¾$WSßgèjd{ÄCè¹÷.vp2^ª)ÿÙu÷äªÝëÔüþ:Ï]¯óÿ~môóùë‚þµúòú3~ëºÛ2ÿ,Á_Lÿ?ÏÛ>"¿¶¬þD¨àÿžÉ‡wãü¦qi´®[ãoŸ êKüG‡ù맫ßoîÖjþ÷ËògâKùµ­ñŸô:hq¿_·:ƒíé? òX›ÿªÝ9Í_ÿ?®¿„Ÿ%ïRüÅò·gÖä×Okëß3µ­ò·º§‚"ÿÇMðkÛäÿ­Õý\Ï]??¯_Ì´EþÏ&Ú> S½?Ô×~þ&üioš¿côû¹ñÝ?·½mœŸ£Þ ·w%ÈØ4ÿeçzÿׯ.Ú]AÀ¦ù¯ÚF>ÿÒõC†ßl¡êm‹ü½Óë'@ä?Z›¿iœ´¹ºi~R?Ôóô¿‘ýYËõÿ‡µ÷O¼þ¹ÇûÆùÉúÏ«6ÀÎÏþ×®¯N{NËÌ‹ïêQýó“õ©åéÿqíý“ðmÿ²eÝ«s£Ÿìr"ÿÏ ø•ë'óþò›Ù:ùb\õëÊçË¢ú¤`þ&üÚùù€À¯-ý|LüSzi”JПޓ6 í8Ñ¿cק¬“g³öí,ų F:LtxÄšÃÒ>LÚ@I{H”q m¬KhùÁO )YCq¼ˆhv¼.„ï/ùö=$¢Ð\˱¢8¤¬D–úè6FÿT0˜Ü¹ ¸‘Å\É4UA“5&I÷+ztcg ÁÍá€jèØ(’oßèD[ÚÞ û AUA9ÛƒeBuÈl­"½¹ñ ^ uÄð&wSq£\q£ \(ì¬g ¢ S߉IOpMÒÏZNí0WíN /I[,Ë tsº£…ÂÚgÅ¥’~á$‘ÕÆ5cé([hóQQ¤Øbk$Iõ”¼œÎŸÙºFz3å ®+<ƒßDsŒÆ0BrÔs+©¬Ú] IN Ô”@󷆑=õb]¶ŠÙNxŽtÎí‰>8 È`°·G6‹ŽÔÞä…#éXåÆ!G¦à«Î?^ÅùÉk¬Êÿ²­Í\Ë„wá­Ù×\Å>¾Í¶ž‘Û5N_Å8úŽ±BîÈiÁ5;ÅüÑU@m3¹£grGÏu>­&Wõþ¿[{—å¡…¶X‚_q}^e•ôLå‘Ãñœëüž¹½Mko¥¤îž2i//îžnϦUl"ýÖRyGÊPÒXüL[g›ÉãLïäút}·æøÖNæy×£P.cøŠ©\[[W®ƒRHY‚_QÛ· µ·· £¿d©{P˜t—dß-šŽÅâ½e7wÓÎåš‹<‡ýQ¯ MÚ™ËJåÜôOá œ/ûÒô}ajÚU[Žý×ÂìËê])ÌÌu£–\7+=,XsªÈJ½ÉßYjk;òפýªÂÎטZÐDÝÙIôÐÎ9ÏcG´©ãúw¹L’ãDIDØ5±(åÖÁü'‘[.7iÃèYmàˆØ³žÉ3¦XÜ}‘´k¡gIÃC·ÏÖìŽdùIûE—å³Þg}þKŽ>¦ô9Ž<Ù$pò¯ËÊ~ª)Z˜ƒ¤ÕŽÎ!›Ž{ÒyF]’ê]Óo*³šÇ© Gº2øÏœ¦ÆÉ@\ «è^§)q2T§ ³w¸#nGF&=ƒL Õ¸46)NŽ ní¨lù¤Àq‘žãdB#›20­§uÉhˆËE•Š?H8R©)$Ë«›ÔZ Ü[yËÀU“w Ë%•KvkÙÝ•€Iµ‘ ^4Žk{ªäªgiuÅâÑ”‹GáG.·æ~T%W& ™XSÏù•ÿ#áh’5é{9ÁDº÷«ÊEšÂE²h#D”‘\I"Ø]‘½Îj iõÞäà4§òË’¿Êiý%úšľö!;Yü¯ôpþ<ØÞr§‹@=NñÉÜ{7ŠíÿP•á‰ÌG;ôñQçÀŸONJœŒ.|€!RÍvÆô 4"#_oPq0¶ùó½–{?ñ2EÂ>G,Mìúq•|ŠÜ!œûzÇ©Éàù9ArƒóSê9gѳ~ÀÇœƒ¸ ¦þ0q?á2+-T¤Ï^ø;Nt)4EêCÑO–ëòÅK:ý4häO›åN£j ÈW2bAÎ?I¾bÕl1œ|âLmš¢ˆ}´bdû>šH#— 1K3‘*™Ün2$“K>¡5! Ê‹÷µO¶Ò‘‹r`è"·à Ç›|²uíØ}pã ;+ÊÛ`z›d]»ù ;™È´?fʧå3I ;15Šg5™³W§šÌRè$d"ÖGD#Ô:ÂÉt&¾Vç凅ä‡ëÉyùTüÿPK$_6M eðµl lib/parse.hUT ó¦[;\À[ux ÷Vmo£Fþί)ªdGŽsN¿œU-‰¹Ä*Øj«ªÂkŸQñ.Z–ħÓý÷ÎæÍvrê7žgggž™å"Þð7àÙ¦óÌMÏ·‚'エ˜c52ܧ— ƒ”É ¡à™‚pËä%dJïºë¾°¤o4‚Òù Ù××°ØÆž|…˜‡I!¡%SBf ¶L UÎ2`iŠL’ñ¦¿kÖžíÒDoÛ@'ÈUË“+L2\ã¬b¾Èó©æ…„ŽÁ\g"É ’aË2àvÈ8Ê¡A“@{˜P°!#ÔÂaê‘·¦öPmqY–‰ð®&o Á ÍÄ…§|Ð4üªÃÆ2þ²íX—sÎä×[XmX1sÈÁ:Öd%ƒÒQZF˜Ä»XaDÖ”Ãʘ7fÄÿÒð¬èD°ú¶ÒÛ®3ùÖ#,¹ú¨2{wDT¸©ñZˆ …5ªUÜ•e³W(9”õp&”ÆY‹øûPxÿÜÕUQì¡l·ÌC*Š© 9Ý9ä–Ñ•µ¼‹”d!è^å¯Uyx$RÏwN'jŠªz['¨gãs‡ŠEL1½÷§¾Üñ¡æöôô`Ñå3óJű9½‰N`ë™A<Æqó8+ë.ËÓTdýà ˛¦×P?Jç¢Ñ“FÇ;Oðª¼ËM’¥)–µPÜà©T÷[v?‚>UŠ¢N®œÈmöŽÈê}WɹJÞtEuNwRRýRyÖéëû-ÙþðcQy(B¢Ê©šOeèhã!Y9#=ßO ÒG=/ª8â²N'êH™ý/qòMqòq§ âH…|_œa\ ÍõñPKý^6MúÚÇN¹ lib/quo.cUT ­¦[Z\À[ux ÷SÎÌKÎ)MIUP*ÊIÌK×ËPââ*N­(ÐRÐÐ*Š/,ÍOO-‰ ij@ÄbšÖhjŠ1Õè(@˜`atõ`3óʉ¢n"PÔš PKý^6MÝ]Dgô lib/quo.hUT ­¦[;\À[ux ÷SÎLËKIMSòqôs õ÷àR d楢ˆqq¥V”¤å)§Vh)hhÅ–æǧ§–ÄŠ45 â@1MkìJ‹1•ê@•€…qhÛWF¬(*áæE­^PNÍKÉLãPKý^6MÇÛÅr lib/replace-na.cUT ­¦[Z\À[ux ÷½TQoÚ0~ϯ8ч%-ªØÇx@ÌChE¤ª²Lâ4Y];2ÎÈ4ñßëÄI“ЮcíHÜw÷ù»³ï»ˆ¹ÏÒ€BO2ÂﯣžemQ±[š%— iˆO1'Ø6‘¬ß†)W}ˆ¹](•3Ô ÏqMðF½¿,(88Œ@bFù½ŠìL“™p¬ÃÍ °ÝÅÊl‰ÕÏ„ŠPç˜bŸl)¸Sw¹^|,Eá%)u­{3MÆnÉ öPÓ~>„««Ø)ktU¶.ºï`4‚ù—µuÀFRò0,ÿî­úû ì­JÓl¾z]“Ðy4•µ]5yhÜT Ò £•®Q4—_Y §8›9ìt‡–ÒÞ4¬ÛÁÝYœ¤ÂëÏm+‡ÝTøÉݼâA»9Þ Ôê¨À»´ó;÷êÜFÛÊÌo*m¸WëÝŽsÛ£Ío‰Vø ¹_ qþ‰-¤´ú®ò^\Òi^Úåžþ›±~ñ²ß±Ú÷ÖPK!”8M ]í¡W% lib/rlang.cUT ½©[Z\À[ux ÷ÅVÁnÛ0 ½ç+¸ìb§YÓ]›µ@ÙP k‡¦‡aà*6m U$O’Ó¦Cÿ}”ì­vâØzèÅ0ô¨ÇGQ¤øV¨DV)Â#¹Ê‹ÓÁ`0™ÀLJ}gAj•Ã§§a‰ TŠ÷˜Âp¤ºZJ´ì†q[ÿFï˨~ ,Y'D†¹M‰:‹TìBný6¿Ìj¶ã°@dÞ^¢Ê]AöðæÞÇ k’#ÔšK‘NÃÚcøÖ +'Ä›.%ËÑEj Gñô/¯‡OáŠ-gßæìóìë1…°ÔÆEÃuÂG­Ar“#pPÕj‰f·t•Q^jˆ;†Ljm¼‡`ö¸¤Ps4/‹rÇ©ñ¼ÝHƒçfï1ý¦˜ñJºãA'Êù}Ié¥|r° §@¡Ú4‡9lèˆp­E| ÇÂ…aÊ2TëˆLÚ˜KÃ͆%*Ý=³Ë"E¥Õ^Øñäv/¸Yíƒè³¤0Ô·“Ž¯àSæL…ÓíÅŒK‹ÞÖq'¨Ñ»÷ú§ýÐæ9ì¡}]t½F«Êº‘/,:}IyXb¦ ÂŠß ª=®6Õç „¬R‰£Ã±ž¡4z-RÚ$T›Hû¢êKÕ{ZÄu˜þ©ñLëOæÛ©Þáiò¼³¾Ï¾•á]ìOzwv¡›¼Pì ïXݬšFäÎߘjªæ[qsËJƒ‰Ð•:m‹z¹Q­æ’¥h0Û‚IÂû®°p^¨,p<'íÉ _[“Š£ ®}ƒ´’‹ ©MDC’yèSVp[øqv¾˜,Pùvº¤62:†Ðí)àóx8&xÆÞXÚ.㎈Í+¨ØôÈxx OB ûYiß½5 CLÍëâú/ö¾D¼eTÔ8µåhÊ’<Ö?ŽaãÛ¯Ùý¼cø7zÛC\†ã{™jµÞÝËú_škrbŸŒ äø0wD KRƒ)ª¿ÿ€Ñ„Œ®ÎgŸØl±˜_]G‘Ï®öÕ5Ža d©$.е ¨êNhȸü&Œàžz;Dô‚€º¸¼˜ÃµZúð×z "îÌ[RÅÃRßÑ;M>ŽzÆ—3zÆâÐMãÆÍ6C˜n”vô¤H¹ßiÍ Óö€ãŸýßPK!”8MÒƒÐK lib/rlang.hUT ½©[Z\À[ux ÷mTkoÚ0ýž_áµÒú`ƒvݪn“P—­h-EmhÓ9‰VMm‡Â¦ý÷]‡nBùæßãû>ä™LYFÂÛÞàK´ù¾ñâ’5PÏ;ä2yÊÈ{.­]/˜iÏ>"ÔØ4VJ8p§ î£0¸ë ÑÅì™–T˜ÍÝŠ8h·_%Jf|Úžxž{Âyg¬ÎKFÁd×Ä°ÕâjK†ñÚ2¢#÷Y„'j¾lTyr쎎V‚ÉÈm ÿîǣQÿgÝõ&pžÜƒhìþx^yL¨Ù}çË‘-Pf2Ÿå =R#™ AÊÏòúdǘõ–'ä¯Z­º`ô£?¾‰úƒOÁÄÝæ­ê…ñ’·êv}Õ«…Ø‚pìâJ¹Ëxà/O[n#¨Ìwø«CNI÷èºõÛù†vËG±ævµV‡í ”Åù´%2­0ú{ÀiÌáaÙ0eK*Èj¡´­c™lüWzž ZmŠKh÷:² Ú4 Ç\Õ³ ø˜S3k`–&{mèÃR­K–ì§ÉLïƒb*žaú‹*¹ C÷rÉ-¬„XS½ö[Eÿ2HtæýPK\|;Mð'õûE´ lib/session.cUT €Ü¬[Z\À[ux ÷mQ=oÂ0Ýó+®éâ ¨RWPÇt)B*óÉ8±0vzNhPůMh›u~÷¾îQ[eÚ’ e#íö©J“ÄSWO€Òà—n*ìD?QÒ˜úw—Í’€ld£ÕïH{Ô6LŒ¡#^`±šÏpíœÆ¿¡\x‚ª$O Þm3øN``@ᯅފâ]0ªŠE$É‚-€³œk›°>a4[ƒ%1mÄe9šx]…x>o05-Û¸3KNã`•ô¨œq-ßuý} ½ñ0Š›*–GgÓ¬‡\$7ÒxŠNÉÕÇ?׌±1r‘áµô„d1ut}pºŒ5[Ý Ñk–|DOÞkggwnÄXKö$R¦ÏV3-äž|-‰.‡0¡Æìc¹*²´o ÷’wX3)íZ{—¾ßÛÞ.R}Óé ÍݧqœƒþPKÜSLM¦¸ž~_v lib/session.hUT ¿[À[;\À[ux ÷SÎLËKIMSòqôsv öô÷‹÷àR fæ¥bˆsq%åçç(ÅgÇgæ—$æ䤦h$ç™ É‰EZ ÙéšÖ0U‰ÅñÉù9ù¥E@A..åÔ¼”Ì4.PK!”8M#eP£Ån lib/sexp.cUT ½©[Z\À[ux ÷…M‚0…÷œb¬‰¡†xÃŒºp×Ô:H(d¦ÐxwË7ºìëûÚï-­3EsAThwÝä"ŠÎUU)ËÊé/1c[¯¡•ðˆÆƒ+Òй¡J·r…k›ALÊw5VYZ)ŽûÃi7ò„¾!™.·!y~8““Ê5÷`BÈŸÈzjBöœµ?()íßæIˆ™íÁþñ~xüøkJšNAÕ¤G‚Õj(.fy…eí;Åž¬»öÃ+{ÇPK!”8M¤zŸŒ lib/sexp.hUT ½©[;\À[ux ÷•ßOÛ0ÇßóWœÄÃZT‰Á 4Ȇ6úCm7Á“•&×âáÚ‘í””Áÿ¾Ë/š¤I·—¦òù>÷½³}wÄ—2Ä%LïÝÑ76ó&ìÎ9¢.±¾è8Æú–À¥HšÃ_Ó¯@¹²O=ƒIt Iþ8m¬%L—,)ÌIÿÒyoBPÆk"Øm„ÅG-[Aólj7þZBJš­}ýÌ"W±)›h4¨78^üÆÀV6Ʋ¹uŠ}SîlÛ(–xóäk 벆îôçløsî^ß{…²:d¡” 7­ˆ"³¡ûxí±Ù;õnÛ‹TÕ¢2µuÐÌ›³ñõwïfÞKpÚ"¤ 5ø7ãóÁdÚü‹dJD[%@>¡æÖ”þ”4*Ñ1XÕ¼@´55· s•ˆÓ”+æëU¯ŽaÃÜäêÕ¡Ô @kn \]í:I2âfÄÅ/_Äx ›0Ž|‹»Re|ºLB¨—œÊ—Ы-TKW*¤ôdÞ…Á½í{Ûö*UJ T´ízðuJ'A(‰]ˆvÝÝÇîoøÿ媾ȤߨZµìD(»ª–”uê©gÌúÚNTµç¥?»X6¹A¾~éTÃt2‹`¬nD©=ªŽ(i¥­>˳={!1«Ð< ó RJújÚ3+x7Ôáz15œ‘ÃGÄÈl× E‡ÑvOòS(g™èY¥ójö0··6ëìqHÆÁe£·‘èIºš½×ýÍ0¢$ƒ/vG‘ÿÙæ°“8=§BjT‘’¡«`AsèâbçÚÿd€&— krŸ[/1Æd'AsŽ4lH?jÃiáKµájÅ+‚HÊ–æÃyž€s„2äKç/PK!”8Mo_cŸŽ lib/squash.cUT ½©[Z\À[ux ÷íYKsÛ6¾ëWÀÊŒ‡JäÄÎѧãq•4Sã‘Ý67†¢ ª (+môß»X¼IÊÏÌôÒ¢ÝÅ>¾ý€¼`¿NŒ¿* V4êWfpp€ µãÐJÍ!Ùß'‘ÃÍb«“èÀÄ0]tŠ`Rh«†:Ø:ȱÀ¡Ž9 GÆÊ-¡P hˆ1ØkÓv¯Ê¯4ÍK*ršò$­µíYí±ôÁ|z‘6”|Y9ÇèøYv]”S°|@NNLU¤ù"Y.C[ö¢¡Z²3„4ŒµÛNPÊŽTØDh¨&9 v ¼À˜žý‚þêÄ'«]†KÞOÆãD‡ÓÀnpxu•ö<´êÀ+U¾6;Ð)B ‡AÕÿèdÑéÇBѳp& ó3ÆŠVµ[ãÉ. ÑÅh¢Ø.¢{áÁàlsÝ[¾ï­mõåÖ·‹öè‘åúž ¨×UVUO+Õ°Z×%›Yò ¨9¦Ö®™Ìqp!ÏŠ|Á뢒þ'ÌMÍ™ ¤TE+Ê[„JΚë T°/Ø@ã«ZVªP¶± õj–Iª!ƒÆËÔp•Â|ï©eï ‹SYŒßž¾ÝØmo˜ØE¢OÐ_ªë}»ó$˜¯9É0DŽAD®=[hžé'hDÇÝÂZÂ3J_4=ðߪ]P£=_[ï\q…p¨ˆîyæONº‹ÑIG1¶oíÃŽœ–¼\}óév|ÿNÂ=Š–[îÅò°­ÛSú…>½¸»Îqg>aZF è(Äž¢Ê`M`j¯ËÇwääά´,Ai÷žò»ÏdQhÛ jÏýɼ³-?ª%7h‹ÿ}R­xR>©Á¶Q»ºaPtç;ð3x}Ãbå¾w匎Ýî»*NÏJ òQ9ÑÂ%OU¹&jèè6Õ„u­·ÿl0Š÷$ûú Úº.êxº„÷TŽÓ[|YŠàÂ…Ïš×u_xÂËN[P![BUè댥'x‹1s“ðh¿˜§²w:¡AÛvÝ7*«›øÀ>G{.±Òò9´Ç>^uå]*mæAˆu®¥nÁ,ÍÑódÓqmØà•ÁLù4îþ=ik© J/§B¨awc¹ï2nÖóLVÉXpéضÍýQ–>@·-û†3ÉÊ 2*Y¡Ð¦ê–É|Ù¥'ò ²J—ô±ƒNà¡‘sn¥öšÔÐÝ µ8 z'*]É°ƒCßDCÿÀR”1þ|}y= n€’fæºkxV\Jq:›‰÷%yÞïÿž š}EÁ³:EǽG«Øh<‚œÎêB‡âMU¹{ë/dYÃn®É‹²ªd^ó\²’çÙ /~;?X´q/ÙwØ‚²ý-ÝrøhÖ5çæ|§Ny•ÞP8Ÿ¯áJÑâ»ôÚ-ÕÁÎ]Ú'ú1ænT:uŸÊxw?¬Ý%â­Múv£òuÁ/ëÂä?¥‹lÍÊZ(ȹ)ÊiVu&˜Òö:nê°)0Å9Ð.BjY«Ô´ñh/–ÕzfùhÒˆP! 9o¬0/-pµÆÛ÷ÙéÏ“$–6$›v£)]CZ6WNÒxæ1_‡ †T©:>͸64Æÿ yr 2·o´J¤–yÌ“µ)Ó㨳Vµ5@ÔóçbðóãÅuø9ŸFÓg—çŸÃï+PzùéágˆÖÆ}¸“N5ÐË%À•‰5ì#¼2·\tI!-ô ƒ\À„rRßR!8õFá®æÚÕX­ÆÝqJîò¹ék;.'0µNÕ<¤VœSJw«RÝAS–¼M´\õ ø­{WÑ¿ƒAWòúdÑ&k3÷;Ë-"«-Sœå£uµhWÛu‘Ëô¿•Çbg™5JªýÕt.˜'¯¤x«†’³_N'Ið‚¦E o¶¾×»²Jà ° £AßàÝ(úÖ¾lÒ elÈ8,×ÖÂ)¶ßÊòaWŠAS WQ »‹µÁš‰3WÔE½fÇùõ{YZþmfkÊýU§µÃ‹‚ ƒù,ÁPÓ0䛳8Qâx2&༔¸½´KIg=©Ëc$˜˜¯k=% o^Š  µx ‡×­ß•±7á”D â#°ÓÓ¶¸íÚÉî)®#ßx\Ö zÀíþ(=kuçÙÑõÔ±ßCÃSþ¾cÈáúkwñÿ…ô´K¯*ãZᓃx 47b4b:a :×Y vö(¹Ó\_˜5³z¢±+é4p©ß|55îc?ÿ^Ãsæ %§RÔ®©/ØìÊ­Ô BóUgöÍórâ&§»{Hõì;¨Œl€úú¯Ì<ÍíD^Mj_øâ³97•Ü_:bs²ñQºíš¾ó[µ§ ¦sÒw}ò^¼@⾎hàà+õPKý^6M(Ký¤  lib/stack.hUT ­¦[;\À[ux ÷mÁ Â0 †ïyŠÀ.›ø;TSÏ¥v)·n¤lˆïnuex Éÿý "£mI‹]¶_‰Ã1Ë·b QŒ¥™ pkL‰,+¨7>vÔ· …—8öšeMI 0Ž,TÇLÖ‹7ˆù7¸I4Ö£øµ)YUÿ]à¼ôF¡±Õ+ÙDX æ®õq‚w@,D~!u=9âÍ¥ðEdK£á PKý^6MW°Ò­}™ lib/state.hUT ­¦[;\À[ux ÷]1 Â0F÷û]ÒnÎN¤¢P»‡^ð0^Br‚ þwcGÇï}^ÇAV 8ŸÆód¯Ë¸ìº†XèTuÊYâï­ôÊ›‰î6eå$Æ'©ŠþæÊ€âÔã é³ÎÁN¤—ÍÜ™¶¸É.F³™ý>­Ñ‘¬à PK!”8Môá ñ<hlib/sym-unescape.cUT ½©[Z\À[ux ÷­VmO#7þž_1ÇI°Iö i¥m ¡pw*E(µÒ YŽã$‹7²½@Tñß;~ÙÍîf“z|Öž×gfžñG!Y’M9ì©„Êùáb¯õ1?:þbŽ¾(º\¦‡r.$?\œ•$´QÂjUϦ‰˜Ø³ÖÑ|“†«ef™dF¤Rç÷þ´ZO©˜K—+ÂTQ†Æ#Í_–0sƒÿW+ȼ$\ø»=hŸ™äšÑ%_ Bkòß 4Óò,¢W“4 jl¡Úðw rU‡ œÂíxôíú ^#‰¡‡V7™’ ¬h4#FQ©jøFyå6J¾6y$&ÝH¿æ^ÒGŽÎoÐ÷øúü¡õ]sl¡ºdÇeRs%h"4ÇÿK§<²Æ‚ÙD²K¹ æi¿çfQ„³ïw”F™%I %Å "Ô:uÎóÂ{,RŽ¢Ù߇Ãk€?“'ÎLª"¬Éí_7±Ót¶j…zÁ•p×»«‰^Ž†Ã¨_šÃOXã1 v´¡F°k%FÛ!ö8²ØÒKŒ(ˆOÒ4–>”—x½ˆa<¼‚/OP²65Ñ"³4“Óm¢K•2®5™¬ σœ;$¸ ÅM wlHÐàÓ†LlËE+I ~MVh²à/%¡Ø{iÅ5ù,U؈ҷpo€Nìåº]á%n‡cR"gTÄenðÉún|µíòC«i  3èñW©Z•…!ú‡ÍFÙvÃä2lNÌ»M“)ቩ²]ÈhP’³#è嶓M°ôì‡Ør—þ0wùá4·Zp€ðª¯ÀÍ ¥-%È•ƒŽC=»¢Lz[C.Ý[Úv.-¨Œ{<çÜXZ¿F…Œ'J¯¢ìÅ×óQY&°Ü‡†iµÅË)s:*ò$ÊjJæãQ|(™¯ã1\ ÉÝøòØójp™‹Ÿº) ~ÁÆ ž¯¶gªA¦ÆŽàS˜pF3Äû™(Žé´ú钔фæ®9 ›ÃâìfBaˆèѬ c¶@å*¨û|µ×·¨¦J̉oeTÀB°¡„n¬‘ð¾r]èßû»GþÈplð6€ÄP &žÍŒê¹´Ö^UdlŽ&4:a4h:ã6u “Éf3®Š McRžÛ>¾·äZõ-+¡hTf•ãs³Á7¶Íãƒíâ+.±‘„¨VtOx¼mŸž"áuŠß5^ÇË5„˜ŒÊøznyÉ­ÿêÏ(–©Ü®uVC¤çæáýú¶j^‹ªÝHSEþÃòm#3¹‹Im¬_ç!Mš)ÇMÁUèªæî½N·Áൠ$¼Ôz=*ÇH¯h ²í½Ÿ8DÃ~}»»}áCìž6‘†KtáÚ•3X§H¬7؉ßÿy“øÆɹzÝešF’¸À­ ©LVŽï<ùk"|U#Äü|à–è,¿¶c Ó'*wF:¦ÒAÃ>ëN%¼êW8£_à€›KÌ%Š¸Õ”GèYÔ¤YbcÅn œºwr×ÝCß×wWW1ôquÙðU~ÁŸ³=¿A0Ó?9À‡c°p"÷-©-váWCÊX†h$h Ñ Òþ2¿­+dßTm¤Œi ÏÌŽýÎ.,43Îö§`Q"üøÞ»·/‡ƒ“ƒv'Ö"}/r·Cä'/Òm©¼ ö§Ï•§“ë–ð"µÆÄ}{ÓÌkÉÛgïí¬Á[…k¨4?z 4ðÎÐlïö÷íœàׯk'9Ë–…Ï+—›ÂuòýPKg;MÑú õ°Ð lib/sym.cUT g·¬[Z\À[ux ÷½TMOã0¼çW¼ ÒöH)BHË„ ‡]!ÜÄi,¹ve;mʪûÛ÷9Ž¬ö´‡í¡­ç}ÍÌ‹sÀDÆ«œÂµ6Š‰ù¨¼‰¢ÆŠ‹ÅQŸÃƒÉs˜ÂŠ*ͤÐðAôHMKªAHF¡91ŒA [QX—,+m.5¦™’™ÌíHx-™½YÌ$‡ ÛUeF* |M6ºï§G‘¦õr*tºŠÄAõ)0a†@•Àï@¯™ÉJHTj6K*‹¤¸@F4…—_/?Ÿ¯ð ¨©”€zÜ_§]¶§bnJl“ \º>öÓ°…¬$jÎ@˜À´H;ÊwÂú¬T霚Y^ 㶺¬¬’Ä•·±- U”#—‚pnJ%«y‰‘œ¤âæª%`Éu‚ígˆ'dpv¹3BTœûÞMã}¬SXî,K‰N³ÔÑ \ìz§d&•Iâ;"Ž±…¢vçÄoý/ñt¨ãÓ¦±—†ßÛm´¢™Ä,•2½³É][D·ŒŽ |›´‹ô´rÑ4Mí¸@kĆÙb™Üý¸&ÏÓ‡§×§ÛÇ{«ë´›…K¾hÊ÷ÑL‰Øì¥ê¹êæQñ¯œ£(ÜŠ½`¸•]Âc›YàEIì<–5þ\ƒÃÉ |yJZѶ•—©ßØ»“Ú??-¼€ô˶ì˜ehË’fŒðT.݃ì¬ùê¡ñï&ÆQþi:_\ãf†Í¸ïptÔmÎÛÅ»•~|x 6ó .}¬Ú½sriR*VLI± ÂX±ã.XT"3øN Q­ðV!fÏ©ƒ:l¦Ôáq?Ûâ•d¹Ý€`&ål¦ˆjgí^¾Íå¶9ñè¾Ä—¡†>Ó£>«×Ôç8Ìgt û„?q»'µ¬}QâµÇ7!¾ñøgˆZ|ýPKg;M5Õ²OY lib/sym.hUT g·¬[;\À[ux ÷}‘ANÃ0E÷>…¥nÒŠtD‘h„R@be¹Î¤XrÆ•í@âîØu’uçùÿÍ÷x¼%PÒü1ÍîÙþmǶdá‰0ÑÈ VãA×X0ÛV4g/±z媆TIk%;h«ÔGò ldá¼o«ƒV#B(n{bÎÿˆB»¸õÇÎ'Ð80H-4§U¤à‡4+@Ö—LY£pRã¬i0PÎZNª¢si}Î64³j;«~uÁ¤Ρþ‘I”š*Ñ­(³ô uÜIá%ö3ŒßV‰Ðhïܬ¨`ÖÿKúM(5àjg^2é®T2økòs%3Pݾš„=åÙs–îî’à„˜iÊxš˜%®¤m¶ižL#ãh­•ï—vº_ÜL®žsÙÀ8¶›µô=ö¼_Ša¹£æÉÓ§ón»€À`!Kò PKЭBMY±^Qkç lib/vec-chr.cUT ˳[Z\À[ux ÷½VßoÚ0~Ï_q£/² ^G[išØV­ª*ÚI“¦É5‰V'rœ¶låßÙŽóRÆ4m<@bßÝwßç»3'\„I18-”äbõf}L¨^xž'IQð r% B¥¤’0±Rkÿ!ãÑhd6†ðÓp¦Î`2ópåqÍþ¨±õÛ¬zúa«m%S¥€ øZ°§|„{$ášJ*&ý0…ýŽ¸6ïèýL«T‡µµY©Ðåó|~í[´ªLú7·‹›¯×ˆáÐ0‰3 ¾CᆠþœbºH‚;n“•$Ïî™àÎÌ€úö7þ}8¬IXÌçþÔ¼WüÑÏ(à°lȈ)Ì‹p±'ßfŽË´°BÚWD:!ÐçWg;|:áK‰vï?½[hq.®>’ùå­o²à–Aó ÓÜGó •ÒB¸¨5Wn½¶;%ðzªXfYR±_ÓâÏHóèÉÐÞ“Îú;Ÿ–ìÚãÜ”-fÒ…&Tl^€oð{êð¿¨n\›í$Ów"m›î™ÔR(Y²Yµ¸­~ÇãÚ¯ÿÌbš̶®¢Š‡ [hÂ#ª˜‘²`J7qKI×åí#Ô K¢69Ëb£œÖÇ.4“ é7ºÌ¤òwhyi‰º-P¨-Áöó j¹ø tÒN¦àl[0X61M`QÍ´õjž$—,g":Ž9/ˆ(“ÄP¯“°s‚ÙLDÙ.å-0<„ʧOzÝuÑGˆ$ú öè c˜Vµ(õ¦€DØ8 ,㉞¥¦ávf䤓ҡ™Ø(Jó‚þ¥šu¥VÐæúO¥›üN:ÑÉå廤¾MS}12•yÂC¤æ$ÄÌÔ‹e–’„ª§Ñê¸n¼p]Á¤Ìä[˜?åÈ›E= Y ‚¦¬0Ã1\³ð \†<MëÚ\q«p¢.â6â!àdí™È:† ‹çg#ü×`-V ^’Å‘Á5"ÕVöbÑVZ”#þ!øåpôsÌI§uÕ¥¹ÚèÃ…çgèn¥AĪ©uýµXTø3§÷«C;˜ò¨ë£ÀÃaQ1ÔÕ—ËËYmÐ$åv<3ç±ÑW$áKIåÆ2ºûõ¸×HèU]§TÞë9ò¬,ü}w–íì)¬˜ê±Ç¦jn¿PKЭBMŒ‘{·˜ lib/vec-chr.hUT ˳[;\À[ux ÷•UÁnÛ0 ½û+Ô(ì!ºsÖEP,‚ p²]Õ¦¡²lHÊ–lí¿’åXvœ6»Y"ùH>òÉ^È ’.ïW_éχùæ{Jç‹”.¢ Þs c¦hÂe&v9ÏÚ(.Ÿ>n¿DÑ1BÑ’k×­$¥+¶v^Q{J ûúºé-SS(ks ÙV͆Qf¯ 3<#\ ›¤uÁ0ú&nÎxšZ`Íÿá ù¢Àìs½I¿a#ËMì¼x2‹^ ¿*ž{̺z†QЩO Â4øë‡ =Ÿ:»Í0H‘UR„dÊ1`ÍAAáSá¹Wô|qŸÆöò]$ÏÍh3’0c‚9ë9^\Š€Ç €'cy[æe©æñt’$Æ{rwgÝwB4ׄx@Od;drGV?–Ë™s±±WGSÒóJ Z>ϱñøú:iÜ}3ÁÂòŠ3ÐàSz‡®QW0w᯶ÉǪÞ¼e:}HtK/Æõ(“‡3A]”Æ°–£&2™¡U¸¿ '΢e~Skf*&îeër™œßÑájt<%œÝ¬ûBȵÏߎÝÓZA 2ùè—Ž7«ßuTì'Çu÷ÀŠi%xÒ n^ ÇcKxÌʺéfJp#í¾ßŽ5X˜07e¼`§wÛÜ×k P|ai¾«Ϙ<«+§PUIÓƱÔñFwRƒâLp øͳ*oŸÃKxí1ºï¯s¸V劚C Uïre_ {ìv›¼¼àùd¶ÞåSÒuÁPçÈ&¹¹i‡3ò>bU·ÉôX ÂÞ¾ëïŒÚÁ°Ìáhõ¡|¬Ä™7]YsŒB0ŠI-p,NbÖmä—4@î$﹪kíÞo¯°ý˜^ý”, NJ²†…z ›w;ø—¿Gûˆ¤lSÿÁj4A)ó"úPKЭBM8•ËŽ lib/vec-lgl.cUT ˳[Z\À[ux ÷mS]oÓ0}ϯ8-ÒH[غׅMhš&U€H¥^zÓZòìpí”Ôÿ¾ë|´…òÆõ½Ççã:¯´-M³"ŒÙ(»¾ÜŒ“äÑ9.”/â*õ´«§ØMð't…”‹ð\“«RÙåXÜ/¾|ûŒ‹ Á²ë°é ×ñ¬GÇ!ßíj*­ àKeøµ–Õx’Iç>Ø d5r¤q9ÁâÓýÇۅœ[˜BÃÓ]%û$‘–N©«ƒvV™SÉfmŽ¢åò\šmcÌAXwÚÛë–d<ý]9¦ë4î i_nè<¡Q[ë,½E1ðm¥„ïŒ9ZÚ*ÓDpôþ}þ#;Åö9>Þ}ÞcŽ›®rPÊ…÷ú7ÅѬMᛧÿesh»;Š)ÅAùÙl –°AÌŽop·+©ŽcíØÊ”£’G(‡áÆñõr,"‰´ 7¦‹÷¤CpÒ3φ+Qn1ÑÆŠ˜ª#$Ò¤N·(y½ƒÍ0›é7ò#àÁÄÕ¾n´G©ìë·%®Œû/ßa)¬KHÕRIÞ+ÖæþIC a¡Ÿ2Ã1Á!lhðÚù€„Ë‚”,´Å²µ¼l1ÑÒ,ÇTÔéÆ)¥xŸ_PK¯BM™šqe¿x lib/vec-lgl.hUT _ͳ[;\À[ux ÷uOË Â0¼ç+ziýO"¢‡¢PÅëÛM]ˆ‰$)Å7±R*êm˜摱2 )¨ÊÅvÇÕò°«°\—¸YäÙÐ/Iˆ“µJ åžúë úb.Ø„·×ÀÖH=5èVG‹ðA®Nùƒä0Šù+¶/à.…Ψîk©¥+mËä©å1.`Áu4Yð'ÞŸ¥£æ«…äo8VŽæ”<ÊH{úcR2j/WšiÏ7þ ï.Ÿ×EF¦a%žPKý^6M„âæP¿Flib/vec-list.cUT ­¦[Z\À[ux ÷}Á‚0DïýŠ ^Š!FÎÄ#^¼ iê Pȶ(Æðï¶TÑ“ÇÙé¼™®´QÍpFH¨‘¦ÚÔ cÌâد„Á»h´u<Æ Tg¬UKZƒ‘-¦ðdÑî;8”å‘Çè •ëÈ ÷èqe§iá4KÑwWä>—Á6ƒÑ;ÞÒà_ônZûIå–†ÐѶe¹ßî‹£jŠåþ8—“°Ž´©bõûÝþT–<ŸÅ¦ýhB7 .ØÄ^PK!”8MþÞ$üñÝlib/vec-list.hUT ½©[;\À[ux ÷mPMOƒ@½ï¯ÃÞ+cHmB4i‰× Âl;‘Î’Ý­¢¦ÿÝ……°Çyó¾f"RÜ ‚]ñø²‘oùSùº“Åv_Êgù1ÞÜ a]å¨âvàXì»Ù’uò€.À0¦¶–~(_`Ð Ãd˜eh”¬Åeáû©©™m;ý·}Ó)["öy)ÿû§#as_ƯÑ|òíS¨5[õ±2+àê„ž¿èô®uë¥dʹ‡¤ 6Ò}w¨UÜ'p—AGYà\Ÿ¡ªÖâÚ#—IÉð÷ ’3ç+g‚ükî8dðxœˆRâPK{eHMÊ®Si lib/vec.cUT ê4»[Z\À[ux ÷ÍY[S7~÷¯8iê%NBÉm€˜BÊÔ!‡´ÌtÒE^˶ÈZëJ2Ømøï=ZI»Úõ®!$aâš•ŽÎMß¹©ëŒGñl@aMÄ„×ëné儨ñ£ñž·"Õ€q¥×RÅ"è'I c"Ã(‚F*Œ)©qSÒùtæ-¡”ì_ <€ÿ‚ª™àÀá%lÂçϸmÌh·ï6®”©™ ‰J&,ªå&/™ŠÆMªÅ”&CdbÖ#")t»ïOßí¸Ï£ãÿ³×Ù/l¼ëžúßïOzòý?ígfC…Õ¨!v‘h@‡d«ýÄ’êÍ+´17QF$&¢diÁY¾'PÂ/AÉI¨A"~('¥Ÿt¾©Ï<“ãdÄÐo×Á̳Y£Ë|ºÃpÿþ } ↌3EK—ã$BÛGñnã:—[-0舊t?7`ªDÊ ?Ât˜2ÔÛÃD@Ó‰dH´¹‹ÿy‰°þÁ³å…܆ÐÜH¹µáx?Äkívzùþ²ƒõ晴ÿí J>Ïõ$³~LÚæ+×|п^ó{LZk‚o¢v”L¦1;½…[=·GÓoªÔÃ_ß~xÕíè|OŸm>y¶½ý|ëÅ“›O·Ÿ7–ÆdU£p½ãÛe•ÜQ@±ö~˱ó=þ®Ò+ $R3‡KÕáú”™ºÉ·÷߶·Ù¨ÏHN^Ub²6ÑX!½N©)§rºÂm/-•(d§(áŠñ™ý¾Ê¹i{•xÈ9/§;ËAv°½ £/"ÐæL*Ê# ÉÔ˜jd 3‰Táq¨@_˜l½@´&Üñ˜hŒ¨”x€(´ÿ¬2ðÁÔxBuçšp¸d5†ã‚ú…f&æùÓPÚq«Õ·&TÄqÑš·Ø«‘TŠãõÇx«t®[Ñ݇¹¿¾!\Ùeǯkr‰‚\ÞN¼¶ sü„nsKÓÅ ú[+‰Ïâ¸ÐXnî–(lS¸Ó¨îÒª› š£¼ì\ZÞ@ûËK1¾¼&•`|TP_çêÓß\FùÒž Ø  —CGTYãW~¡Ì÷¶—=‘¨Âá›=Dc‘ HY³`é¬ùÞ ½T>r3ƒ?p¦ïcB¹¶ZóÇüg¹•Á™ç‹g½‡Á9À?³žÖÀ _ä(7ÿXdÞÙ@Î:¿®OжhÄWïf>ËÒBegó3˜ÌW ¤\±,ä¡kî׳¶Ö¢Ü%½+õ^ÜRïÅ÷лvó¶ÒØÄì/.}²E°²ªšrêì2·nÊhŽ¢¹Aåò¼pnøœk>¾|Íó¼84˜ŽÅY¨ëPË“€8; #ƒ>ã!Îý6Ò5Ëv³Õ«òœa JyÌðKŽ­C¸¤¿ƒdº€‡_õk4.6°M“O˜—+F2JªZž9îWŽ6ŠdR*5¿MÿAé¡åèXçÑA¤­EtK¬ãªO#2ÃŒÄÒVW% È ‰ãb˜4=¡­ÏÍ„hÊ4 ®S•i«nü×)¢0Ò†îÛãƒýn ïl@1ŒJ«Ý{möV21x`½û©ètYÛøq·f·/L5zÛ‡Šz½ÁëížÂJïžîš"SÜíûº§w®¸{³«zøð´?xûæ]·sšP ó­p„wæu1³£¿P´d’x8‚ ÅknŸIËUäfZd ÞÔäu„ý§{¢Ë‚¸„þ¾sz$sCbSk:Èä3K•ªöÍö›¨Š¼NÞöVªê‘|‰ªÕý_Z¨ýgÆN¦—^‡W®A8eŽ*^~êëÐ j‘JÜë°Wê¹3 šXmLÝ@›í‹¾)¶TD gÓ¯)¶¶›×ÿG'U#ÒL³Pã¹zrJw*jŒëÅS†\¦=ÉÉ^á×ò6Þe÷ºvœòNdyµîˆÉ¤Þ‰,¡Õ°‰Ë;â°ö„ë@}Ålº©;£³‹E—ƒcÅã"w“þ¢#èì'y¶Ö‚Þ0uûNw娇¬¹É/ëžn\^1»,¼aÝë?n€nî’°q^qÂÀV7éŸcx¢€š†INcá½=C)½¾£äõÑé›ÎœŒ±uBÆ}}ÒM”¹%èE¼DøÇáW ’öaΖH7óK¡bj„¥C Hô{§ó®‰·¦i·š–m|Òtuà¨EH/°× ðÂÃWˆ«¿Ì´PçDË£èÊ×½N§¹eòD (n•ÎnÕ2$Þ,¹ýPK!”8Mܯ¸ìî lib/vec.hUT ½©[;\À[ux ÷–ßkÛ0ÇßýW % lì±ô¡”ⶤa”aùœˆ)’‘•6ÞÈÿ>%Ç¿dÏi˾ûÜIßÓÉ,1$d¹¸}¸¿ÏîVËðkpaž1íÇA Â,c€¨ðhÈAlôv’Á!’ÇkcéH3J˜àèÏ„ž[¾áa ’“)ù¢@ï• ‹ÇûùÝíb‚€£`þó‡Õì~¶ôb¹_s@F¼Jb9ëÉ@…TîR‡°È„¦C”»ÇoO‹ÙÏÐ:×`)*zÊåö‡—PØIlÕ€ûój97ª=­ü+r¢p– ­ªS½Ât¥qÒn@—„+RVëÑø…ýòÊìTÁªäö²¬âNð8§¼—Ußi?XAÓÖ+ƒ1õà`-Ú«d±“!•¿Áƒº*V7·Ä†ä†äÝüÅCl¨1HD=z‰N5­4$¢ ½ÄºvÛPfŒÊ ‚e¶¥>%2°^¶IV›Q]bl—k)9.v†¦ZªnáÌU ¤¾%lib/export.hUTÏ[À[ux ÷PK$_6MÁ@)*ª%¤Ð'lib/fn.cUTó¦[ux ÷PKgeHM¯zU¤¼(lib/fn.hUTÁ4»[ux ÷PK$_6M;{%Õ—r ¤*lib/formula.cUTó¦[ux ÷PKý^6M°ÚxÂ}Ó ¤ä,lib/formula.hUT­¦[ux ÷PK$_6MaìÕS ¤¨-lib/lang.cUTó¦[ux ÷PK$_6M—)h  ¤?0lib/lang.hUTó¦[ux ÷PK$_6M0+À³a ¤ë1lib/node.cUTó¦[ux ÷PK$_6M°Ô¹Ž&v ¤â4lib/node.hUTó¦[ux ÷PK!”8M±EXëV3 ¤L7lib/parse.cUT½©[ux ÷PK$_6M eðµl ¤|@lib/parse.hUTó¦[ux ÷PKý^6MúÚÇN¹ ¤vDlib/quo.cUT­¦[ux ÷PKý^6MÝ]Dgô ¤Elib/quo.hUT­¦[ux ÷PKý^6MÇÛÅr ¤±Elib/replace-na.cUT­¦[ux ÷PK!”8M ]í¡W% ¤Hlib/rlang.cUT½©[ux ÷PK!”8MÒƒÐK ¤¶Klib/rlang.hUT½©[ux ÷PK\|;Mð'õûE´ ¤ËNlib/session.cUT€Ü¬[ux ÷PKÜSLM¦¸ž~_v ¤WPlib/session.hUT¿[À[ux ÷PK!”8M#eP£Ån ¤ýPlib/sexp.cUT½©[ux ÷PK!”8M¤zŸŒ ¤Rlib/sexp.hUT½©[ux ÷PK!”8Mo_cŸŽ ¤ÖTlib/squash.cUT½©[ux ÷PKý^6M·Q ‹Ð ¤»\lib/squash.hUT­¦[ux ÷PK!”8MŽPûƒq… ¤Œ]lib/stack.cUT½©[ux ÷PKý^6M(Ký¤  ¤B`lib/stack.hUT­¦[ux ÷PKý^6MW°Ò­}™ ¤+alib/state.hUT­¦[ux ÷PK!”8Môá ñ<h¤íalib/sym-unescape.cUT½©[ux ÷PKg;MÑú õ°Ð ¤uglib/sym.cUTg·¬[ux ÷PKg;M5Õ²OY ¤hjlib/sym.hUTg·¬[ux ÷PKЭBMY±^Qkç ¤úklib/vec-chr.cUT˳[ux ÷PKЭBMŒ‘{·˜ ¤¬olib/vec-chr.hUT˳[ux ÷PKЭBM8•ËŽ ¤ªrlib/vec-lgl.cUT˳[ux ÷PK¯BM™šqe¿x ¤¼tlib/vec-lgl.hUT_ͳ[ux ÷PKý^6M„âæP¿F¤Âulib/vec-list.cUT­¦[ux ÷PK!”8MþÞ$üñݤÉvlib/vec-list.hUT½©[ux ÷PK{eHMÊ®Si ¤xlib/vec.cUTê4»[ux ÷PK!”8Mܯ¸ìî ¤˜lib/vec.hUT½©[ux ÷PK33*ð‚rlang/tests/testthat/fixtures/rlanglibtest/0000755000176200001440000000000014375670676020747 5ustar liggesusersrlang/tests/testthat/fixtures/rlanglibtest/tests/0000755000176200001440000000000014024324576022073 5ustar liggesusersrlang/tests/testthat/fixtures/rlanglibtest/tests/testthat/0000755000176200001440000000000014742464552023741 5ustar liggesusersrlang/tests/testthat/fixtures/rlanglibtest/tests/testthat/test-quo-accessors.R0000644000176200001440000000134714127057575027635 0ustar liggesuserstest_that("r_quo_get_expr() gets expression", { r_quo_get_expr <- function(quo) { .Call(rlanglibtest_r_quo_get_expr, quo) } r_quo_set_expr <- function(quo, expr) { .Call(rlanglibtest_r_quo_set_expr, quo, expr) } r_quo_get_env <- function(quo) { .Call(rlanglibtest_r_quo_get_env, quo) } r_quo_set_env <- function(quo, env) { .Call(rlanglibtest_r_quo_set_env, quo, env) } quo <- rlang::quo(foo) expect_identical(r_quo_get_expr(quo), rlang::quo_get_expr(quo)) expect_identical(r_quo_get_env(quo), rlang::quo_get_env(quo)) expect_identical(r_quo_set_expr(quo, NULL), rlang::quo_set_expr(quo, NULL)) expect_identical(r_quo_set_env(quo, rlang::empty_env()), rlang::quo_set_env(quo, rlang::empty_env())) }) rlang/tests/testthat/fixtures/rlanglibtest/tests/testthat.R0000644000176200001440000000011013351410655024042 0ustar liggesuserslibrary("testthat") library("rlanglibtest") test_check("rlanglibtest") rlang/tests/testthat/fixtures/rlanglibtest/R/0000755000176200001440000000000014127057575021140 5ustar liggesusersrlang/tests/testthat/fixtures/rlanglibtest/R/rlanglibtest.R0000644000176200001440000000053314127057575023756 0ustar liggesusers#' @useDynLib rlanglibtest, .registration = TRUE NULL .onLoad <- function(lib, pkg) { # Causes rlang package to load and register native routines rlang::dots_list() .Call(rlanglibtest_library_load) } test_trace_unexported <- function(e) { trace_back(e) } test_trace_unexported_child <- local(function(e) { test_trace_unexported(e) }) rlang/tests/testthat/fixtures/rlanglibtest/src/0000755000176200001440000000000014175213516021516 5ustar liggesusersrlang/tests/testthat/fixtures/rlanglibtest/src/init.c0000644000176200001440000000155614175213516022634 0ustar liggesusers#include "lib/rlang.h" extern r_obj* rlanglibtest_r_quo_get_expr(r_obj*); extern r_obj* rlanglibtest_r_quo_set_expr(r_obj*, r_obj*); extern r_obj* rlanglibtest_r_quo_get_env(r_obj*); extern r_obj* rlanglibtest_r_quo_set_env(r_obj*, r_obj*); r_obj* rlanglibtest_library_load() { r_init_library(); return r_null; } static const r_callable r_callables[] = { {"rlanglibtest_library_load", (r_void_fn) &rlanglibtest_library_load, 0}, {"rlanglibtest_r_quo_get_expr", (r_void_fn) &rlanglibtest_r_quo_get_expr, 1}, {"rlanglibtest_r_quo_set_expr", (r_void_fn) &rlanglibtest_r_quo_set_expr, 2}, {"rlanglibtest_r_quo_get_env", (r_void_fn) &rlanglibtest_r_quo_get_env, 1}, {"rlanglibtest_r_quo_set_env", (r_void_fn) &rlanglibtest_r_quo_set_env, 2}, {NULL, NULL, 0} }; void R_init_rlanglibtest(r_dll_info* dll) { r_register_r_callables(dll, r_callables, NULL); } rlang/tests/testthat/fixtures/rlanglibtest/src/Makevars0000644000176200001440000000003013351410655023201 0ustar liggesusersPKG_CPPFLAGS = -I./lib/ rlang/tests/testthat/fixtures/rlanglibtest/src/test-quo-accessors.c0000644000176200001440000000057514175213516025435 0ustar liggesusers#include "lib/rlang.h" r_obj* rlanglibtest_r_quo_get_expr(r_obj* quo) { return r_quo_get_expr(quo); } r_obj* rlanglibtest_r_quo_set_expr(r_obj* quo, r_obj* expr) { return r_quo_set_expr(quo, expr); } r_obj* rlanglibtest_r_quo_get_env(r_obj* quo) { return r_quo_get_env(quo); } r_obj* rlanglibtest_r_quo_set_env(r_obj* quo, r_obj* env) { return r_quo_set_env(quo, env); } rlang/tests/testthat/fixtures/rlanglibtest/NAMESPACE0000644000176200001440000000013413351410655022142 0ustar liggesusers# Generated by roxygen2: do not edit by hand useDynLib(rlanglibtest, .registration = TRUE) rlang/tests/testthat/fixtures/rlanglibtest/DESCRIPTION0000644000176200001440000000050214375670676022452 0ustar liggesusersPackage: rlanglibtest Title: What the Package Does (one line, title case) Version: 0.0.0.9000 Authors@R: 'Lionel Henry [aut, cre]' Description: What the package does (one paragraph). Depends: R (>= 3.1.0) Imports: rlang LinkingTo: rlang Encoding: UTF-8 LazyData: true RoxygenNote: 6.0.1 rlang/tests/testthat/fixtures/error-backtrace-conditionMessage.R0000644000176200001440000000053614375670676024743 0ustar liggesusers options( crayon.enabled = FALSE, cli.unicode = FALSE ) if (nzchar(Sys.getenv("rlang_interactive"))) { options(rlang_interactive = TRUE) } options(rlang_trace_format_srcrefs = FALSE) cnd_header.foobar_error <- function(c, ...) { "dispatched!" } f <- function() g() g <- function() h() h <- function() rlang::abort("", "foobar_error") f() rlang/tests/testthat/fixtures/error-backtrace-rethrown.R0000644000176200001440000000046614127057575023312 0ustar liggesusers options( crayon.enabled = FALSE, cli.unicode = FALSE ) if (nzchar(Sys.getenv("rlang_interactive"))) { options(rlang_interactive = TRUE) } f <- function() tryCatch(g()) g <- function() h() h <- function() rlang::abort("Error message") tryCatch( f(), error = function(cnd) rlang::cnd_signal(cnd) ) rlang/tests/testthat/fixtures/error-show-messages.R0000644000176200001440000000030214462656134022275 0ustar liggesusersoptions( crayon.enabled = FALSE, cli.unicode = FALSE ) opt <- Sys.getenv("show_error_messages") if (nzchar(opt)) { options(show.error.messages = as.logical(opt)) } rlang::abort("Oh no") rlang/tests/testthat/test-arg.R0000644000176200001440000002147614741441060016243 0ustar liggesuserstest_that("matches arg", { expect_equal( arg_match_wrapper("foo", c("bar", "foo")), "foo" ) expect_snapshot_error( arg_match_wrapper("foo", c("bar", "baz")) ) }) test_that("gives an error with more than one arg", { # Interpolates `values` in the error message (#1545) expect_snapshot( (expect_error(arg_match0_wrapper(c("bar", "fun"), c("bar", "baz")))) ) }) test_that("gives error with different than rearranged arg vs value", { f <- function(myarg = c("foo", "bar", "fun")) { arg_match(myarg, c("fun", "bar")) } expect_snapshot_error( f() ) expect_snapshot_error( arg_match0_wrapper(c("foo", "foo"), c("foo", "bar"), arg_nm = "x") ) }) test_that("gives no error with rearranged arg vs value", { expect_identical(arg_match0_wrapper(rev(letters), letters), "z") skip_if_not_installed("withr") withr::with_seed( 20200624L, expect_identical(arg_match0_wrapper(letters, sample(letters)), "a") ) }) test_that("uses first value when called with all values", { myarg <- c("bar", "baz") expect_identical(arg_match0_wrapper(myarg, c("bar", "baz")), "bar") }) test_that("informative error message on partial match", { expect_error( arg_match0_wrapper("f", c("bar", "foo")), "Did you mean \"foo\"?" ) }) test_that("`arg_match()` has informative error messages", { arg_match_wrapper <- function(...) { arg_match0_wrapper(...) } expect_snapshot({ (expect_error(arg_match_wrapper("continuuos", c("discrete", "continuous"), "my_arg"))) (expect_error(arg_match_wrapper("fou", c("bar", "foo"), "my_arg"))) (expect_error(arg_match_wrapper("fu", c("ba", "fo"), "my_arg"))) (expect_error(arg_match_wrapper("baq", c("foo", "baz", "bas"), "my_arg"))) (expect_error(arg_match_wrapper("", character(), "my_arg"))) (expect_error(arg_match_wrapper("fo", "foo", quote(f())))) }) }) test_that("`arg_match()` provides no suggestion when the edit distance is too large", { expect_snapshot({ (expect_error(arg_match0_wrapper("foobaz", c("fooquxs", "discrete"), "my_arg"))) (expect_error(arg_match0_wrapper("a", c("b", "c"), "my_arg"))) }) }) test_that("`arg_match()` finds a match even with small possible typos", { expect_equal( arg_match0_wrapper("bas", c("foo", "baz", "bas")), "bas" ) }) test_that("`arg_match()` makes case-insensitive match", { expect_snapshot({ (expect_error(arg_match0_wrapper("a", c("A", "B"), "my_arg"), "Did you mean \"A\"?")) # Case-insensitive match is done after case-sensitive (expect_error(arg_match0_wrapper("aa", c("AA", "aA"), "my_arg"), "Did you mean \"aA\"?")) }) }) test_that("gets choices from function", { fn <- function(myarg = c("bar", "foo")) { arg_match(myarg) } expect_error(fn("f"), "Did you mean \"foo\"?") expect_identical(fn(), "bar") expect_identical(fn("foo"), "foo") }) test_that("is_missing() works with symbols", { x <- missing_arg() expect_true(is_missing(x)) }) test_that("is_missing() works with non-symbols", { expect_true(is_missing(missing_arg())) l <- list(missing_arg()) expect_true(is_missing(l[[1]])) expect_error(missing(l[[1]]), "invalid use") }) test_that("maybe_missing() forwards missing value", { x <- missing_arg() expect_true(is_missing(maybe_missing(x))) expect_false(is_missing(maybe_missing(1L))) }) test_that("is_missing() works with default arguments", { expect_false((function(x = 1) is_missing(x))()) expect_false((function(x = 1) is_missing(x))(1)) bare <- function(x) is_missing(x) default <- function(x = 1) is_missing(x) bare_bare <- function(x) bare(x) bare_default <- function(x) default(x) default_bare <- function(x = 1) bare(x) default_default <- function(x = 1) default(x) expect_true(bare()) expect_true(bare_bare()) expect_true(bare_default()) expect_false(default()) expect_false(default_bare()) expect_false(default_default()) expect_true(bare(missing_arg())) expect_true(bare_bare(missing_arg())) expect_true(default(missing_arg())) expect_true(bare_default(missing_arg())) expect_true(default_bare(missing_arg())) expect_true(default_default(missing_arg())) }) test_that("is_missing() detects defaults that evaluate to the missing arg", { deprecated <- function() missing_arg() fn <- function(x = deprecated()) is_missing(x) expect_true(fn()) }) test_that("is_missing() works with dots", { expect_true((function(...) is_missing(..1))()) expect_false((function(...) is_missing(..1))(1)) }) test_that("is_missing() works with enclosed arguments (currently doesn't)", { clo <- (function(other = 1) function() is_missing(other))() expect_false(clo()) # FIXME: Probably none of these should be errors clo <- (function(other) function() is_missing(other))() expect_error(clo()) #> ! 'missing' can only be used for arguments is_missing2 <- function(x) is_missing(x) clo <- (function(other = 1) function() is_missing2(other))() expect_false(clo()) clo <- (function(other) function() is_missing2(other))() expect_error(clo()) #> ! argument "other" is missing, with no default }) test_that("is_missing() in child envs", { # FIXME: Should not be an error f <- function(x) local(is_missing(x)) expect_error(f()) #> ! argument "x" is missing, with no default f <- function(x = 1) local(is_missing(x)) expect_false(f()) }) test_that("is_missing() is transitive", { caller <- function(y) f(y) f <- function(x = y, y = "foo") is_missing(x) expect_false(f()) expect_true(caller()) f <- function(x = y, y) is_missing(x) expect_true(f()) expect_true(caller()) f <- function(x = y, y = deprecated()) is_missing(x) expect_true(f()) expect_true(caller()) }) test_that("is_missing() works in unframed envs", { expect_false(inject(is_missing(foo), env(foo = 2))) expect_true(inject(is_missing(foo), env(foo = missing_arg()))) # Should not be an error, see previous test expect_error((function(x) inject(is_missing(x), env()))()) #> ! 'missing' can only be used for arguments }) test_that("check_required() checks argument is supplied (#1118)", { f <- function(x) check_required(x) g <- function(y) f(y) expect_error(f(NULL), NA) expect_error(g(NULL), NA) expect_snapshot({ (expect_error(f())) (expect_error(g())) }) }) test_that("arg_match() supports symbols and scalar strings", { expect_equal( arg_match0_wrapper(chr_get("foo", 0L), c("bar", "foo"), "my_arg"), "foo" ) expect_equal( arg_match0_wrapper(sym("foo"), c("bar", "foo"), "my_arg"), "foo" ) expect_snapshot({ (expect_error(arg_match0_wrapper(chr_get("fo", 0L), c("bar", "foo"), "my_arg"))) }) }) test_that("arg_match() requires an argument symbol", { wrapper <- function() arg_match("foo") expect_snapshot((expect_error(wrapper()))) }) test_that("can match multiple arguments", { my_wrapper <- function(my_arg = c("foo", "bar", "baz")) { arg_match(my_arg, multiple = TRUE) } expect_equal(my_wrapper("foo"), "foo") expect_equal(my_wrapper(c("foo", "baz")), c("foo", "baz")) expect_equal(my_wrapper(chr()), chr()) expect_snapshot({ (expect_error(my_wrapper("ba"))) (expect_error(my_wrapper(c("foo", "ba")))) }) }) test_that("arg_match0() defuses argument", { fn <- function(arg) arg_match0(arg, c("bar", "baz")) expect_snapshot({ (expect_error(fn("foo"))) (expect_error(arg_match0("foo", c("bar", "baz")))) }) }) test_that("check_exclusive works", { f <- function(foo) check_exclusive(foo) g <- function() check_exclusive() h <- function() check_exclusive(foo()) # Internal errors expect_snapshot({ (expect_error(f())) (expect_error(g())) (expect_error(h())) }) f <- function(foo, bar = NULL, ...) check_exclusive(foo, bar, ...) g <- function(foo, bar = NULL, baz, ...) check_exclusive(foo, bar, baz, ...) # Zero arguments supplied expect_snapshot({ (expect_error(f())) }) expect_equal(f(.require = FALSE), "") # One argument supplied expect_equal(f(NULL), "foo") expect_equal(f(, NULL), "bar") # Multiple arguments supplied expect_snapshot({ "All arguments supplied" (expect_error(g(foo, bar, baz))) "Some arguments supplied" (expect_error(g(foo, bar))) }) }) test_that("arg_match() mentions correct call if wrong type is supplied (#1388)", { f <- function(my_arg) arg_match0(my_arg, "a") g <- function(my_arg) arg_match(my_arg, "a") expect_snapshot({ (expect_error(f(1))) (expect_error(g(1))) }) }) test_that("arg_match() backtrace highlights call and arg", { f <- function(x) g(x) g <- function(x) h(x) h <- function(my_arg = c("foo", "bar")) arg_match(my_arg) err <- catch_error(f("f")) expect_snapshot({ print_highlighted_trace(err) }) }) test_that("arg_match() supports `NA` (#1519)", { f <- function(x = c("a", "b")) arg_match(x) expect_snapshot({ (expect_error(f(NA))) (expect_error(f(na_chr))) (expect_error(f(chr()))) }) }) rlang/tests/testthat/test-expr.R0000644000176200001440000000644714515703253016455 0ustar liggesusers# expr_text() -------------------------------------------------------- test_that("always returns single string", { out <- expr_text(quote({ a + b })) expect_length(out, 1) }) test_that("can truncate lines", { out <- expr_text(quote({ 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(quote(x)), "`x`") }) test_that("converts atomics to strings", { expect_equal(expr_label(0.5), "0.5") }) test_that("expr_label() truncates blocks", { expect_identical(expr_label(quote({ a + b })), "`{ ... }`") expect_identical(expr_label(expr(function() { a; b })), "`function() ...`") }) test_that("expr_label() truncates long calls", { long_call <- quote(foo()) long_arg <- quote(longlonglonglonglonglonglonglonglonglonglonglong) long_call[c(2, 3, 4)] <- list(long_arg, long_arg, long_arg) expect_identical(expr_label(long_call), "`foo(...)`") }) test_that("expr_label() NULL values come out as expected", { expect_identical(expr_label(NULL), "NULL") }) # expr_name() -------------------------------------------------------- test_that("expr_name() with symbols, calls, and literals", { expect_identical(expr_name(quote(foo)), "foo") expect_identical(expr_name(quote(foo(bar))), "foo(bar)") expect_identical(expr_name(1L), "1") expect_identical(expr_name("foo"), "foo") expect_identical(expr_name(function() NULL), "function () ...") expect_identical(expr_name(expr(function() { a; b })), "function() ...") expect_identical(expr_name(NULL), "NULL") expect_error(expr_name(1:2), "must be") expect_error(expr_name(env()), "must be") }) # -------------------------------------------------------------------- test_that("get_expr() supports closures", { expect_true(TRUE) return("Disabled because causes dplyr to fail") expect_identical(get_expr(identity), quote(x)) }) test_that("set_expr() supports closures", { fn <- function(x) x expect_equal(set_expr(fn, quote(y)), function(x) y) }) test_that("expressions are deparsed and printed", { expect_output(expr_print(1:2), "") expect_identical(expr_deparse(1:2), "") }) test_that("imaginary numbers with real part are not syntactic", { expect_true(is_syntactic_literal(0i)) expect_true(is_syntactic_literal(na_cpl)) expect_false(is_syntactic_literal(1 + 1i)) }) test_that("is_expression() detects non-parsable parse trees", { expect_true(is_expression(quote(foo(bar = baz(1, NULL))))) expect_false(is_expression(expr(foo(bar = baz(!!(1:2), NULL))))) expect_false(is_expression(call2(identity))) }) test_that("is_expression() supports missing arguments", { expect_false(is_expression(missing_arg())) expect_false(is_expression(quote(foo(, )))) }) test_that("is_expression() supports quoted functions (#1499)", { expect_true(is_expression(parse_expr("function() NULL"))) }) test_that("is_expression() detects attributes (#1475)", { x <- structure(quote(foo()), attr = TRUE) expect_false(is_expression(x)) expect_false(is_expression(expr(call(!!x)))) expect_true(is_expression(quote({ NULL }))) expect_true(is_expression(quote(function() { NULL }))) }) rlang/tests/testthat/test-dots.R0000644000176200001440000002701014741441060016431 0ustar liggesuserstest_that("exprs() without arguments creates an empty named list", { expect_identical(exprs(), named_list()) }) test_that("exprs() captures arguments forwarded with `...`", { wrapper <- function(...) exprs(...) expect_identical(wrapper(a = 1, foo = bar), list(a = 1, foo = quote(bar))) }) test_that("exprs() captures empty arguments", { expect_identical(exprs(, , .ignore_empty = "none"), set_names(list(missing_arg(), missing_arg()), c("", ""))) }) test_that("dots are always named", { expect_named(dots_list("foo"), "") expect_named(exprs(foo, bar), c("", "")) local_lifecycle_silence() expect_named(dots_splice("foo", list("bar")), c("", "")) }) test_that("dots can be spliced", { local_lifecycle_silence() spliced_dots <- dots_values(!!!list(letters)) expect_identical(spliced_dots, list(splice(list(letters)))) expect_identical(list2(!!!list(letters)), list(letters)) wrapper <- function(...) list2(...) expect_identical(wrapper(!!!list(letters)), list(letters)) local_lifecycle_silence() expect_identical(flatten(dots_values(!!! list(letters))), list(letters)) }) test_that("interpolation by value does not guard formulas", { expect_identical(dots_values(~1), list(~1)) }) test_that("dots names can be unquoted", { expect_identical(dots_values(!! paste0("foo", "bar") := 10), list(foobar = 10)) }) test_that("can take forced dots with `allowForced = FALSE`", { fn <- function(...) { force(..1) captureDots() } expect_identical(fn(a = letters), pairlist(a = list(expr = letters, env = empty_env()))) }) test_that("captured dots are only named if names were supplied", { fn <- function(...) captureDots() expect_null(names(fn(1, 2))) expect_identical(names(fn(a = 1, 2)), c("a", "")) }) test_that("dots_values() handles forced dots", { fn <- function(...) { force(..1) dots_values(...) } expect_identical(fn("foo"), list("foo")) expect_identical(lapply(1:2, function(...) dots_values(...)), list(list(1L), list(2L))) expect_identical(lapply(1:2, dots_values), list(list(1L), list(2L))) }) test_that("empty arguments trigger meaningful error", { expect_snapshot({ (expect_error(list2(1, , 3), "empty")) (expect_error(dots_list(1, , 3), "empty")) }) }) test_that("cleans empty arguments", { expect_identical(dots_list(1, ), named_list(1)) expect_identical(list2(1, ), list(1)) expect_identical(exprs(1, ), named_list(1)) expect_identical(dots_list(, 1, , .ignore_empty = "all"), named_list(1)) }) test_that("doesn't clean named empty argument arguments", { expect_error(dots_list(1, a = ), "empty") expect_identical(exprs(1, a = ), alist(1, a = )) expect_identical(exprs(1, a = , b = , , .ignore_empty = "all"), alist(1, a = , b = )) }) test_that("capturing dots by value only unquote-splices at top-level", { expect_identical_(dots_list(!!! list(quote(!!! a))), named_list(quote(!!! a))) expect_identical_(dots_list(!!! exprs(!!! 1:3)), named_list(1L, 2L, 3L)) }) test_that("can't unquote when capturing dots by value", { expect_identical(dots_list(!!! list(!!! TRUE)), named_list(FALSE)) }) test_that("can splice NULL value", { expect_identical(dots_list(!!! NULL), named_list()) expect_identical(dots_list(1, !!! NULL, 3), named_list(1, 3)) }) test_that("dots_splice() flattens lists", { local_lifecycle_silence() expect_identical(dots_splice(list("a", list("b"), "c"), "d", list("e")), named_list("a", list("b"), "c", "d", "e")) expect_identical(dots_splice(list("a"), !!! list("b"), list("c"), "d"), named_list("a", "b", "c", "d")) expect_identical(dots_splice(list("a"), splice(list("b")), list("c"), "d"), named_list("a", "b", "c", "d")) }) test_that("dots_splice() doesn't squash S3 objects", { local_lifecycle_silence() s <- structure(list(v1 = 1, v2 = 2), class = "foo") expect_identical(dots_splice(s, s), named_list(s, s)) }) test_that("dots_split() splits named and unnamed dots", { dots <- dots_split(1, 2) expect_identical(dots$named, list()) expect_identical(dots$unnamed, list(1, 2)) dots <- dots_split(a = 1, 2) expect_identical(dots$named, list(a = 1)) expect_identical(dots$unnamed, list(2)) dots <- dots_split(a = 1, b = 2) expect_identical(dots$named, list(a = 1, b = 2)) expect_identical(dots$unnamed, list()) }) test_that("dots_split() handles empty dots", { dots <- dots_split() expect_identical(dots$named, list()) expect_identical(dots$unnamed, list()) }) test_that("dots_split() fails if .n_unnamed doesn't match", { expect_error(dots_split(1, 2, .n_unnamed = 1), "Expected 1 unnamed") expect_error(dots_split(1, 2, .n_unnamed = 0:1), "Expected 0 or 1 unnamed") dots <- dots_split(a = 1, 2, .n_unnamed = 1) expect_identical(dots$named, list(a = 1)) expect_identical(dots$unnamed, list(2)) }) test_that("can splice NULL and atomic vectors", { expect_identical(list2(!!!letters), as.list(letters)) expect_identical(list2(!!!NULL), list()) }) test_that("can unquote quosures in LHS", { quo <- quo(foo) expect_identical(list2(!!quo := NULL), list(foo = NULL)) expect_identical(exprs(!!quo := bar), exprs(foo = bar)) }) test_that("can preserve empty arguments", { list3 <- function(...) unname(dots_list(..., .preserve_empty = TRUE)) expect_identical(list3(, ), list(missing_arg())) expect_identical(list3(, , .ignore_empty = "none"), list(missing_arg(), missing_arg())) expect_identical(list3(, , .ignore_empty = "all"), list()) }) test_that("forced symbolic objects are not evaluated", { x <- list(quote(`_foo`)) expect_identical_(lapply(x, list2), list(x)) expect_identical_(list2(!!!x), x) x <- unname(exprs(stop("tilt"))) expect_identical_(lapply(x, list2), list(x)) }) test_that("dots collectors do not warn by default with bare `<-` arguments", { expect_no_warning(list2(a <- 1)) expect_no_warning(dots_list(a <- 1)) expect_no_warning(exprs(a <- 1)) expect_no_warning(quos(a <- 1)) myexprs <- function(...) enexprs(...) myquos <- function(...) enexprs(...) expect_no_warning(myexprs(a <- 1)) expect_no_warning(myquos(a <- 1)) }) test_that("dots collectors can elect to warn with bare `<-` arguments", { expect_warning(dots_list(a <- 1, .check_assign = TRUE), "`<-` as argument") myexprs <- function(...) enexprs(..., .check_assign = TRUE) myquos <- function(...) enexprs(..., .check_assign = TRUE) expect_warning(myexprs(TRUE, a <- 1), "`<-` as argument") expect_warning(myquos(TRUE, a <- 1), "`<-` as argument") }) test_that("dots collectors never warn for <- when option is set", { local_options(rlang_dots_disable_assign_warning = TRUE) expect_no_warning(list2(a <- 1)) myexprs <- function(...) enexprs(..., .check_assign = TRUE) myquos <- function(...) enquos(..., .check_assign = TRUE) expect_no_warning(myexprs(a <- 1)) expect_no_warning(myquos(a <- 1)) }) test_that("`.homonyms` is matched exactly", { expect_error(dots_list(.homonyms = "k"), "must be one of") }) test_that("`.homonyms = 'first'` matches first homonym", { list_first <- function(...) { dots_list(..., .homonyms = "first") } out <- list_first(1, 2) expect_identical(out, named_list(1, 2)) out <- list_first(a = 1, b = 2, 3, 4) expect_identical(out, list(a = 1, b = 2, 3, 4)) out <- list_first(a = 1, b = 2, a = 3, a = 4, 5, 6) expect_identical(out, list(a = 1, b = 2, 5, 6)) }) test_that("`.homonyms = 'last'` matches last homonym", { list_last <- function(...) { dots_list(..., .homonyms = "last") } out <- list_last(1, 2) expect_identical(out, named_list(1, 2)) out <- list_last(a = 1, b = 2, 3, 4) expect_identical(out, list(a = 1, b = 2, 3, 4)) out <- list_last(a = 1, b = 2, a = 3, a = 4, 5, 6) expect_identical(out, list(b = 2, a = 4, 5, 6)) }) test_that("`.homonyms` = 'error' fails with homonyms", { list_error <- function(...) { dots_list(..., .homonyms = "error") } expect_identical(list_error(1, 2), named_list(1, 2)) expect_identical(list_error(a = 1, b = 2), list(a = 1, b = 2)) expect_snapshot({ (expect_error(list_error(1, a = 2, a = 3))) (expect_error(list_error(1, a = 2, b = 3, 4, b = 5, b = 6, 7, a = 8))) (expect_error(list_error(1, a = 2, b = 3, 4, b = 5, b = 6, 7, a = 8))) }) }) test_that("`.homonyms` works with spliced arguments", { args <- list(a = 1, b = 2, a = 3, a = 4, 5, 6) expect_identical(dots_list(!!!args, .homonyms = "first"), list(a = 1, b = 2, 5, 6)) myexprs <- function(...) enexprs(..., .homonyms = "last") expect_identical(myexprs(!!!args), list(b = 2, a = 4, 5, 6)) myquos <- function(...) enquos(..., .homonyms = "first") expect_identical(myquos(!!!args), quos_list(a = quo(1), b = quo(2), quo(5), quo(6))) }) test_that("can mix `!!!` and splice boxes", { expect_identical(list2(1L, !!!(2:3), splice(list(4L))), as.list(1:4)) }) test_that("list2() and dots_values() support splice boxes", { expect_identical(list2(1, splice(c("foo", "bar")), 3), list(1, "foo", "bar", 3)) local_lifecycle_silence() expect_identical(dots_values(1, splice(c("foo", "bar")), 3), list(1, splice(list("foo", "bar")), 3)) }) test_that("dots_values() doesn't splice", { local_lifecycle_silence() expect_identical_(dots_values(!!!c(1:3)), list(splice(as.list(1:3)))) expect_identical_(dots_values(!!!list("foo", "bar")), list(splice(list("foo", "bar")))) }) test_that("!!! does not evaluate multiple times (#981)", { foo <- function() x <<- x + 1 x <- 0 list2(!!!list(foo())) expect_identical(x, 1) x <- 0 exprs(!!!list(foo())) expect_identical(x, 1) x <- 0 quos(!!!list(foo())) expect_identical(x, 1) }) test_that("dots_list() optionally auto-names arguments (#957)", { expect_identical( dots_list(.named = TRUE), named(list()) ) expect_identical( dots_list(1, letters, .named = TRUE), list(`1` = 1, letters = letters) ) expect_identical( dots_list(1, foo = letters, .named = TRUE), list(`1` = 1, foo = letters) ) expect_identical( dots_list(!!!list(a = 1:3, 1:3), .named = TRUE), list(a = 1:3, `` = 1:3) ) expect_identical( dots_list(!!!list(1:3, 1:3), .named = TRUE), list(`` = 1:3, `` = 1:3) ) }) test_that("`.ignore_empty` is matched", { # Tests the `r_arg_match()` library function expect_snapshot({ (expect_error(dots_list(.ignore_empty = "t"))) foo <- function() dots_list(.ignore_empty = "t") (expect_error(foo())) }) }) # Suboptimal but not worth fixing the UI test_that("`.named` can be `NULL` (default names) or `FALSE` (minimal names)", { expect_equal( dots_list(.named = FALSE), set_names(list(), "") ) expect_equal( exprs(.named = FALSE), set_names(list(), "") ) expect_equal( dots_list(.named = NULL), list() ) expect_equal( exprs(.named = NULL), list() ) }) test_that("`.homonyms` error is thrown", { f <- function() dots_list(a = 1, a = 2, .homonyms = "error") expect_snapshot((expect_error(f()))) }) test_that("`list2(!!!x)` returns `x` without duplication", { expect_snapshot({ x <- as.list(1:100) with_memory_prof(out <- list2(!!!x)) expect_equal(out, as.list(x)) x <- 1:100 + 0L with_memory_prof(out <- list2(!!!x)) expect_equal(out, as.list(x)) }) }) test_that("list2(...) doesn't copy forced promises (#1491)", { fn <- function(...) { list(...) with_memory_prof(list2(...)) } x <- seq_len(1e4) + 0 expect_snapshot({ fn(x, x, x, x, x, x) }) }) test_that("names are not mutated after splice box early exit", { xs <- list(1) dots_list(!!!xs, .named = FALSE) expect_equal(names(xs), NULL) dots_list(!!!xs, .named = TRUE) expect_equal(names(xs), NULL) dots_list(!!!xs, .named = NULL) expect_equal(names(xs), NULL) }) rlang/tests/testthat/test-trace-full.Rmd0000644000176200001440000000057414175213516020051 0ustar liggesusers```{r} library(rlang) f <- function() g() g <- function() h() h <- function() rlang::abort("foo") ``` ```{r, error = TRUE} f() ``` Currently needs to be in a different chunk: ```{r} last_error() last_trace() ``` ```{r, error = TRUE} options(rlang_backtrace_on_error_report = "reminder") f() ``` ```{r, error = TRUE} options(rlang_backtrace_on_error_report = "full") f() ``` rlang/tests/testthat/test-entrace.Rmd0000644000176200001440000000061214401331356017420 0ustar liggesusers```{r} options( rlang_backtrace_on_error_report = "full" ) f <- function(do = stop) g(do) g <- function(do) h(do) h <- function(do) do("foo") ``` ```{r, error = TRUE} f() ``` ```{r} rlang::global_entrace() ``` ```{r, error = TRUE} f() ``` ```{r} f(warning) ``` ```{r} options( rlang_backtrace_on_warning_report = "full" ) ``` ```{r} f(warning) ``` ```{r} rlang::last_warnings() ``` rlang/tests/testthat/helper-c-api.R0000644000176200001440000000170414175213516016757 0ustar liggesusers r_parse_eval <- function(x, env = caller_env()) { .Call(ffi_test_parse_eval, x, env) } nms_are_duplicated <- function(nms, from_last = FALSE) { .Call(ffi_nms_are_duplicated, nms, from_last) } r_lgl_sum <- function(x, na_true) { stopifnot(is_logical(x), is_bool(na_true)) .Call(ffi_test_lgl_sum, x, na_true) } r_lgl_which <- function(x, na_propagate) { stopifnot(is_logical(x), is_bool(na_propagate)) .Call(ffi_test_lgl_which, x, na_propagate) } r_obj_encode_utf8 <- function(x) { .Call(ffi_test_obj_encode_utf8, x) } test_encodings <- function() { string <- "\u00B0C" utf8 <- iconv(string, from = Encoding(string), to = "UTF-8") unknown <- iconv(string, from = Encoding(string), to = "", mark = FALSE) latin1 <- iconv(string, from = Encoding(string), to = "latin1") list(utf8 = utf8, unknown = unknown, latin1 = latin1) } expect_utf8_encoded <- function(object) { expect_identical(Encoding(object), rep("UTF-8", length(object))) } rlang/tests/testthat/test-friendly-type.R0000644000176200001440000001531514741441060020260 0ustar liggesuserstest_that("obj_type_friendly() supports objects", { expect_equal(friendly_types(mtcars), c( object = "a object", object_no_value = "a object", vector = "a data frame", vector_length = "a data frame" )) expect_true(all( friendly_types(quo(1), vector = FALSE) == "a object" )) }) test_that("obj_type_friendly() only displays the first class of objects", { x <- structure(1, class = c("subclass", "class")) expect_identical(obj_type_friendly(x), "a object") }) test_that("obj_type_friendly() supports matrices and arrays (#141)", { expect_true(all(friendly_types(matrix(list(1, 2))) == "a list matrix")) expect_true(all(friendly_types(array(list(1, 2, 3), dim = 1:3)) == "a list array")) expect_true(all(friendly_types(matrix(1:3)) == "an integer matrix")) expect_true(all(friendly_types(array(1:3, dim = 1:3)) == "an integer array")) expect_true(all(friendly_types(matrix(letters)) == "a character matrix")) expect_true(all(friendly_types(array(letters[1:3], dim = 1:3)) == "a character array")) }) test_that("obj_type_friendly() supports missing arguments", { expect_equal(obj_type_friendly(missing_arg()), "absent") }) test_that("obj_type_friendly() handles scalars", { expect_equal(friendly_types(NA), c( object = "`NA`", object_no_value = "`NA`", vector = "a logical vector", vector_length = "a logical vector of length 1" )) expect_equal(friendly_types(na_int), c( object = "an integer `NA`", object_no_value = "an integer `NA`", vector = "an integer vector", vector_length = "an integer vector of length 1" )) expect_equal(friendly_types(na_dbl), c( object = "a numeric `NA`", object_no_value = "a numeric `NA`", vector = "a double vector", vector_length = "a double vector of length 1" )) expect_equal(friendly_types(na_cpl), c( object = "a complex `NA`", object_no_value = "a complex `NA`", vector = "a complex vector", vector_length = "a complex vector of length 1" )) expect_equal(friendly_types(na_chr), c( object = "a character `NA`", object_no_value = "a character `NA`", vector = "a character vector", vector_length = "a character vector of length 1" )) expect_equal(friendly_types(TRUE), c( object = "`TRUE`", object_no_value = "a logical value", vector = "a logical vector", vector_length = "a logical vector of length 1" )) expect_equal(friendly_types(FALSE), c( object = "`FALSE`", object_no_value = "a logical value", vector = "a logical vector", vector_length = "a logical vector of length 1" )) expect_equal(friendly_types(1L), c( object = "the number 1", object_no_value = "an integer", vector = "an integer vector", vector_length = "an integer vector of length 1" )) expect_equal(friendly_types(1.0), c( object = "the number 1", object_no_value = "a number", vector = "a double vector", vector_length = "a double vector of length 1" )) expect_equal(friendly_types(1i), c( object = "the complex number 0+1i", object_no_value = "a complex number", vector = "a complex vector", vector_length = "a complex vector of length 1" )) expect_equal(friendly_types(as.raw(1)), c( object = "the raw value 01", object_no_value = "a raw value", vector = "a raw vector", vector_length = "a raw vector of length 1" )) expect_equal(friendly_types("foo"), c( object = "the string \"foo\"", object_no_value = "a string", vector = "a character vector", vector_length = "a character vector of length 1" )) expect_equal(friendly_types(""), c( object = "the empty string \"\"", object_no_value = "\"\"", vector = "a character vector", vector_length = "a character vector of length 1" )) expect_equal(friendly_types(list(1)), c( object = "a list", object_no_value = "a list", vector = "a list", vector_length = "a list of length 1" )) expect_true(all(friendly_types(matrix(NA)) == "a logical matrix")) expect_true(all(friendly_types(matrix(1)) == "a double matrix")) }) test_that("obj_type_friendly() handles empty vectors", { expect_equal(friendly_types(lgl()), c( object = "an empty logical vector", object_no_value = "an empty logical vector", vector = "a logical vector", vector_length = "a logical vector of length 0" )) expect_equal(friendly_types(int()), c( object = "an empty integer vector", object_no_value = "an empty integer vector", vector = "an integer vector", vector_length = "an integer vector of length 0" )) expect_equal(friendly_types(dbl()), c( object = "an empty numeric vector", object_no_value = "an empty numeric vector", vector = "a double vector", vector_length = "a double vector of length 0" )) expect_equal(friendly_types(cpl()), c( object = "an empty complex vector", object_no_value = "an empty complex vector", vector = "a complex vector", vector_length = "a complex vector of length 0" )) expect_equal(friendly_types(chr()), c( object = "an empty character vector", object_no_value = "an empty character vector", vector = "a character vector", vector_length = "a character vector of length 0" )) expect_equal(friendly_types(raw()), c( object = "an empty raw vector", object_no_value = "an empty raw vector", vector = "a raw vector", vector_length = "a raw vector of length 0" )) expect_equal(friendly_types(list()), c( object = "an empty list", object_no_value = "an empty list", vector = "a list", vector_length = "a list of length 0" )) }) test_that("obj_type_friendly() handles NULL", { expect_true(all(friendly_types(NULL, vector = FALSE) == "`NULL`")) expect_snapshot((expect_error(friendly_types(NULL)))) }) test_that("obj_type_friendly() handles NaN and infinities", { expect_equal(friendly_types(NaN), c( object = "`NaN`", object_no_value = "`NaN`", vector = "a double vector", vector_length = "a double vector of length 1" )) expect_equal(friendly_types(Inf), c( object = "`Inf`", object_no_value = "`Inf`", vector = "a double vector", vector_length = "a double vector of length 1" )) expect_equal(friendly_types(-Inf), c( object = "`-Inf`", object_no_value = "`-Inf`", vector = "a double vector", vector_length = "a double vector of length 1" )) expect_equal(friendly_types(Inf + 0i), c( object = "the complex number Inf+0i", object_no_value = "a complex number", vector = "a complex vector", vector_length = "a complex vector of length 1" )) }) test_that("long strings are truncated", { expect_equal( obj_type_friendly(strrep("abc", 12)), "the string \"abcabcabcabcabcabcabcabcabc...\"" ) }) rlang/tests/testthat/test-cnd-handlers.R0000644000176200001440000001277114741441060020032 0ustar liggesuserslocal_unexport_signal_abort() test_that("try_fetch() catches or declines values", { f <- function() g() g <- function() h() h <- function() abort("foo") expect_error(try_fetch(f(), warning = function(cnd) NULL), "foo") expect_error(try_fetch(f(), error = function(cnd) zap()), "foo") expect_null(try_fetch(f(), error = function(cnd) NULL)) fns <- list(error = function(cnd) NULL) expect_null(try_fetch(f(), !!!fns)) }) test_that("try_fetch() checks inputs", { expect_snapshot({ (expect_error(try_fetch(NULL, function(...) NULL))) }) expect_true(try_fetch(TRUE)) }) test_that("can rethrow from `try_fetch()`", { local_options( rlang_trace_top_env = current_env(), rlang_trace_format_srcrefs = FALSE ) f <- function() g() g <- function() h() h <- function() abort("foo") high1 <- function(...) high2(...) high2 <- function(...) high3(...) high3 <- function(..., chain) { if (chain) { try_fetch(f(), error = function(cnd) abort("bar", parent = cnd)) } else { try_fetch(f(), error = function(cnd) abort("bar", parent = NA)) } } expect_snapshot({ err <- catch_error( try_fetch(f(), error = function(cnd) abort("bar", parent = cnd)) ) print(err) print(err, simplify = "none") err <- catch_error(high1(chain = TRUE)) print(err) print(err, simplify = "none") err <- catch_error(high1(chain = FALSE)) print(err) print(err, simplify = "none") }) }) test_that("can catch condition of specific classes", { expect_null(catch_cnd(signal("", "bar"), "foo")) expect_s3_class(catch_cnd(signal("", "bar"), "bar"), "bar") expect_s3_class(catch_cnd(stop(""), "error"), "error") expect_s3_class(catch_cnd(stop("tilt")), "error") expect_error(catch_cnd(stop("tilt"), "foo"), "tilt") classes <- c("foo", "bar") expect_s3_class(catch_cnd(signal("", "bar"), classes), "bar") expect_s3_class(catch_cnd(signal("", "foo"), classes), "foo") }) test_that("cnd_muffle() returns FALSE if the condition is not mufflable", { value <- NULL expect_error(withCallingHandlers( stop("foo"), error = function(cnd) value <<- cnd_muffle(cnd) )) expect_false(value) }) test_that("drop_global_handlers() works and is idempotent", { skip_if_not_installed("base", "4.0.0") code <- '{ library(testthat) globalCallingHandlers(NULL) handler <- function(...) "foo" globalCallingHandlers(foo = handler) rlang:::drop_global_handlers(bar = handler) expect_equal(globalCallingHandlers(), list(foo = handler)) rlang:::drop_global_handlers(foo = handler, bar = function() "bar") expect_equal(globalCallingHandlers(), list()) rlang:::drop_global_handlers(foo = handler, bar = function() "bar") expect_equal(globalCallingHandlers(), list()) }' out <- Rscript(shQuote(c("--vanilla", "-e", code))) expect_equal(out$out, chr()) }) test_that("stackOverflowError are caught", { overflow <- function() signal("", "stackOverflowError") handled <- FALSE try_fetch( overflow(), error = function(cnd) handled <<- TRUE ) expect_true(handled) handled <- FALSE try_fetch( overflow(), warning = identity, error = function(cnd) handled <<- TRUE ) expect_true(handled) handled <- NULL try_fetch( overflow(), error = function(cnd) { handled <<- c(handled, 1) cnd_signal(cnd) }, warning = identity, error = function(cnd) handled <<- c(handled, 2) ) expect_equal(handled, c(1, 2)) }) test_that("tryFetch() looks across chained errors (#1534)", { cnd <- error_cnd("foo", message = "ok") parent <- error_cnd(message = "bad", parent = cnd) out <- try_fetch( cnd_signal(parent), foo = function(x) x$message ) expect_equal(out, "ok") }) test_that("try_fetch() doesn't match downgraded conditions", { out <- NULL try_fetch( error = function(cnd) abort("Wrongly caught error"), warning = function(cnd) out <<- cnd, try_fetch( error = function(cnd) warn("Downgraded error", parent = cnd), abort("Parent error") ) ) expect_s3_class(out, "warning") expect_equal(cnd_header(out), "Downgraded error") out <- NULL try_fetch( error = function(cnd) abort("Wrongly caught error"), warning = function(cnd) abort("Wrongly caught warning"), message = function(cnd) out <<- cnd, try_fetch( error = function(cnd) inform("Downgraded error", parent = cnd), abort("Parent error") ) ) expect_s3_class(out, "message") expect_equal(cnd_header(out), "Downgraded error") }) test_that("try_fetch() matches upgraded conditions", { out <- NULL try_fetch( message = function(cnd) out <<- cnd, try_fetch( message = function(cnd) warn("Upgraded message", parent = cnd), inform("Parent message") ) ) expect_s3_class(out, "message") expect_equal(cnd_header(out), "Parent message") out <- NULL try_fetch( warning = function(cnd) out <<- cnd, try_fetch( warning = function(cnd) abort("Upgraded warning", parent = cnd), warn("Parent warning") ) ) expect_s3_class(out, "warning") expect_equal(cnd_header(out), "Parent warning") }) test_that("`inherit` is recursively checked", { parent <- try_fetch( abort("foo", parent = error_cnd("qux"), .inherit = FALSE), error = identity ) out <- try_fetch( abort("bar", parent = parent, .inherit = TRUE), qux = function(cnd) cnd, error = function(cnd) cnd ) expect_s3_class(out, "error") expect_true(inherits(out$parent$parent, "qux")) expect_false(cnd_inherits(out, "qux")) }) rlang/tests/testthat/test-cnd-signal.R0000644000176200001440000002526114741441060017505 0ustar liggesuserstest_that("cnd_signal() creates muffle restarts", { withCallingHandlers(cnd_signal(cnd("foo")), foo = function(c) { expect_true(rst_exists("rlang_muffle")) } ) }) test_that("signallers support character vectors as `message` parameter", { expect_message(inform(c("foo", "*" = "bar")), "foo\n* bar", fixed = TRUE) expect_warning(warn(c("foo", "*" = "bar")), "foo\n* bar", fixed = TRUE) expect_error(abort(c("foo", "*" = "bar")), "foo\n* bar", fixed = TRUE) expect_condition(signal(c("foo", "*" = "bar"), "quux"), "quux", regex = "foo\n\\* bar") }) test_that("cnd_signal() and signal() returns NULL invisibly", { expect_identical(withVisible(cnd_signal(cnd("foo"))), withVisible(invisible(NULL))) expect_identical(withVisible(signal("", "foo")), withVisible(invisible(NULL))) }) test_that("signal() accepts character vectors of classes (#195)", { expect <- function(cnd) { expect_identical(class(cnd), c("foo", "bar", "condition")) } withCallingHandlers(signal("", c("foo", "bar")), foo = expect) }) test_that("can pass condition metadata", { msg <- expect_message(inform("type", foo = "bar")) expect_identical(msg$foo, "bar") wng <- expect_warning2(warn("type", foo = "bar")) expect_identical(wng$foo, "bar") err <- expect_error(abort("type", foo = "bar")) expect_identical(err$foo, "bar") }) test_that("can signal and catch interrupts", { expect_s3_class(catch_cnd(interrupt()), "interrupt") }) test_that("can signal interrupts with cnd_signal()", { intr <- catch_cnd(interrupt()) tryCatch(cnd_signal(intr), condition = function(cnd) expect_s3_class(cnd, "interrupt") ) }) test_that("conditions have correct subclasses", { expect_true(inherits_all(expect_condition(signal("", "foo")), c("foo", "condition", "condition"))) expect_true(inherits_all(expect_message(inform("", "foo")), c("foo", "message", "condition"))) expect_true(inherits_all(expect_warning2(warn("", "foo")), c("foo", "warning", "condition"))) expect_true(inherits_all(expect_error(abort("", "foo")), c("foo", "rlang_error", "error", "condition"))) }) test_that("cnd_signal() creates a backtrace if needed", { local_options( rlang_trace_top_env = current_env(), rlang_trace_format_srcrefs = FALSE ) err <- error_cnd("rlang_error_foobar", trace = NULL) f <- function() g() g <- function() h() h <- function() cnd_signal(err) err <- catch_cnd(f()) expect_snapshot(print(err)) }) test_that("`inform()` does not append newlines to message", { expect_equal( expect_message(inform("foo"))$message, "foo" ) expect_equal( conditionMessage(expect_message(inform("foo"))), "foo" ) }) test_that("condition signallers can be called without arguments", { # For pragmatic reasons we don't require a class because we now use # `inform()` in places where `cat()` would be more appropriate expect_message(inform(), "", fixed = TRUE) expect_warning(warn(class = "foo"), "", fixed = TRUE) expect_error(abort(class = "foo"), "", fixed = TRUE, class = "foo") }) test_that("`inform()` returns invisibly", { expect_message(expect_invisible(inform("foo"))) }) test_that("warn() respects frequency", { local_options(rlib_warning_verbosity = "default") expect_warning( warn("foo", .frequency = "always", .frequency_id = "warn_always"), "^foo$" ) expect_warning( warn("foo", .frequency = "always", .frequency_id = "warn_always"), "^foo$" ) expect_warning( warn("foo", .frequency = "once", .frequency_id = "warn_once"), "^foo\n.*warning is displayed once per session" ) expect_no_warning( warn("foo", .frequency = "once", .frequency_id = "warn_once") ) expect_warning( warn("foo", .frequency = "regularly", .frequency_id = "warn_regularly"), "foo\n.*warning is displayed once every 8 hours" ) expect_no_warning( warn("foo", .frequency = "regularly", .frequency_id = "warn_regularly") ) }) test_that("inform() respects frequency", { local_options(rlib_message_verbosity = "default") expect_message( inform("foo", .frequency = "always", .frequency_id = "inform_always"), "^foo$" ) expect_message( inform("foo", .frequency = "always", .frequency_id = "inform_always"), "^foo$" ) expect_message( inform("foo", .frequency = "once", .frequency_id = "inform_once"), "^foo.*message is displayed once per session" ) expect_no_message( inform("foo", .frequency = "once", .frequency_id = "inform_once") ) expect_message( inform("foo", .frequency = "regularly", .frequency_id = "inform_regularly"), "foo\n.*message is displayed once every 8 hours" ) expect_no_message( inform("foo", .frequency = "regularly", .frequency_id = "inform_regularly") ) }) test_that("warn() and inform() use different periodicity environments", { local_options( rlib_message_verbosity = "default", rlib_warning_verbosity = "default" ) expect_message( inform("foo", .frequency = "once", .frequency_id = "warn_inform_different_envs"), "foo" ) expect_warning( warn("foo", .frequency = "once", .frequency_id = "warn_inform_different_envs"), "foo" ) }) test_that("periodic messages can be forced", { local_options(rlib_warning_verbosity = "verbose") expect_warning( warn("foo", .frequency = "once", .frequency_id = "warn_forced"), "foo" ) expect_warning( warn("foo", .frequency = "once", .frequency_id = "warn_forced"), "foo" ) }) test_that("messages can be silenced", { local_options( rlib_message_verbosity = "quiet", rlib_warning_verbosity = "quiet" ) expect_message(inform("foo"), NA) expect_warning(warn("foo"), NA) }) test_that("`.frequency_id` is mandatory", { expect_error(warn("foo", .frequency = "once"), "frequency_id") }) test_that("cnd_signal() is a no-op with `NULL`", { expect_null(catch_cnd(cnd_signal(NULL))) }) test_that("`inform()` behaves consistently in interactive and non-interactive sessions (#1037)", { # Default behaviour out1 <- Rscript(shQuote(c("--vanilla", "-e", "rlang::inform('foo')"))) out2 <- Rscript(shQuote(c("--vanilla", "-e", "rlang::with_interactive(rlang::inform('foo'))"))) expect_equal(out1$out, "foo") expect_equal(out1$out, out2$out) # Sinked behaviour out1 <- Rscript(shQuote(c("--vanilla", "-e", "capture.output(rlang::inform('foo'))"))) out2 <- Rscript(shQuote(c("--vanilla", "-e", "rlang::with_interactive(capture.output(rlang::inform('foo')))"))) expect_equal(out1$out, c("foo", "character(0)")) expect_equal(out1$out, out2$out) }) test_that("`inform()` and `warn()` with recurrent footer handle newlines correctly", { expect_snapshot({ inform("foo", .frequency = "regularly", .frequency_id = as.character(runif(1))) inform("bar", .frequency = "regularly", .frequency_id = as.character(runif(1))) warn("foo", .frequency = "regularly", .frequency_id = as.character(runif(1))) warn("bar", .frequency = "regularly", .frequency_id = as.character(runif(1))) }) }) test_that("`warning.length` is increased (#1211)", { code <- 'rlang::with_interactive(rlang::abort(paste0(strrep("_", 1000), "foo")))' out <- Rscript(shQuote(c("--vanilla", "-e", code))) expect_true(any(grepl("foo", out$out))) code <- 'rlang::with_interactive(rlang::warn(paste0(strrep("_", 1000), "foo")))' out <- Rscript(shQuote(c("--vanilla", "-e", code))) expect_true(any(grepl("foo", out$out))) # Messages are not controlled by `warning.length` code <- 'rlang::inform(paste0(strrep("_", 1000), "foo"))' out <- Rscript(shQuote(c("--vanilla", "-e", code))) expect_true(any(grepl("foo", out$out))) }) test_that("interrupt() doesn't fail when interrupts are suspended (#1224)", { skip_if_not_installed("base", "3.5.0") out <- FALSE tryCatch( interrupt = identity, { suspendInterrupts({ tryCatch( interrupt = function(x) stop("interrupt!"), interrupt() ) out <- TRUE }) # Make sure suspended interrupt is processed interrupt() } ) expect_true(out) }) test_that("`frequency` has good error messages", { expect_snapshot({ (expect_error(inform("foo", .frequency = "once", .frequency_id = NULL))) (expect_error(warn("foo", .frequency = "once", .frequency_id = 1L))) }) }) test_that("can pass `use_cli_format` as condition field", { signal_lazy_bullets <- function(catcher, signaller) { catch_error(abort( c("Header.", i = "Bullet."), use_cli_format = TRUE )) } expect_lazy_bullets <- function(cnd) { expect_equal(cnd$message, set_names("Header.", "")) expect_equal(cnd$body, c(i = "Bullet.")) expect_true(cnd$use_cli_format) } expect_lazy_bullets(signal_lazy_bullets(catch_error, abort)) expect_lazy_bullets(signal_lazy_bullets(catch_warning, warn)) expect_lazy_bullets(signal_lazy_bullets(catch_message, inform)) }) test_that("signal functions check inputs", { expect_snapshot({ (expect_error(abort(error_cnd("foo")))) (expect_error(inform(error_cnd("foo")))) (expect_error(warn(class = error_cnd("foo")))) (expect_error(abort("foo", call = base::call))) }) }) test_that("cnd_signal() sets call", { f <- function() { cnd_signal(error_cnd(message = "foo", call = current_env())) } cnd <- catch_cnd(f()) expect_equal(cnd$call, quote(f())) }) test_that("can reset verbosity", { on.exit(reset_warning_verbosity("test_reset_verbosity")) expect_warning( warn("foo", .frequency = "once", .frequency_id = "test_reset_verbosity") ) expect_no_warning( warn("foo", .frequency = "once", .frequency_id = "test_reset_verbosity") ) reset_warning_verbosity("test_reset_verbosity") expect_warning( warn("foo", .frequency = "once", .frequency_id = "test_reset_verbosity") ) }) test_that("downgraded conditions are not inherited (#1573)", { cnd <- catch_cnd(warn("", parent = error_cnd())) expect_false(cnd$rlang$inherit) cnd <- catch_cnd(inform("", parent = error_cnd())) expect_false(cnd$rlang$inherit) cnd <- catch_cnd(inform("", parent = warning_cnd())) expect_false(cnd$rlang$inherit) cnd <- catch_cnd(warn("", parent = error_cnd(), .inherit = TRUE)) expect_true(cnd$rlang$inherit) cnd <- catch_cnd(inform("", parent = error_cnd(), .inherit = TRUE)) expect_true(cnd$rlang$inherit) cnd <- catch_cnd(inform("", parent = warning_cnd(), .inherit = TRUE)) expect_true(cnd$rlang$inherit) }) # Lifecycle ---------------------------------------------------------- test_that("error_cnd() still accepts `.subclass`", { # skip_if(getRversion() < "3.6.0") local_options( lifecycle_disable_warnings = FALSE, force_subclass_deprecation = TRUE ) expect_snapshot({ expect_equal( error_cnd(.subclass = "foo"), error_cnd("foo") ) expect_error(abort("foo", .subclass = "bar"), class = "bar") }) }) rlang/tests/testthat/test-state.R0000644000176200001440000000234614375670676016631 0ustar liggesuserstest_that("options are set temporarily", { local_options(foo = "foo") expect_identical(with_options(foo = "bar", peek_option("foo")), "bar") expect_identical(peek_option("foo"), "foo") }) test_that("peek_options() returns a named list", { local_options(foo = "FOO", bar = "BAR") expect_identical(peek_options("foo", "bar"), list(foo = "FOO", bar = "BAR")) }) test_that("is_interactive() is FALSE when testthat runs", { expect_false(is_interactive()) }) test_that("is_interactive() honors rlang_interactive option, above all else", { expect_true(with_options(rlang_interactive = TRUE, is_interactive())) expect_false(with_options(rlang_interactive = FALSE, is_interactive())) expect_snapshot_error(with_options(rlang_interactive = NA, is_interactive())) local_interactive(FALSE) expect_false(is_interactive()) expect_true(with_interactive(value = TRUE, is_interactive())) }) test_that("local_options() restores options in correct order (#980)", { local_options(foo = -1) local({ local_options(foo = 0) local_options(foo = 1) }) expect_identical(peek_option("foo"), -1) local({ on.exit("existing") local_options(foo = 0) local_options(foo = 1) }) expect_identical(peek_option("foo"), -1) }) rlang/tests/testthat/test-bytes.R0000644000176200001440000001114614375670676016635 0ustar liggesuserstest_that("bytes() coerces unspecified vectors but not logical ones", { expect_equal(bytes2(c(NA, NA), NA), new_bytes(dbl(NA, NA, NA))) expect_error(bytes2(TRUE), "Can't coerce") }) test_that("can create empty and unspecified bytes() vector", { expect_equal(bytes2(), new_bytes(dbl())) expect_equal(bytes2(NA), new_bytes(na_dbl)) expect_equal(bytes2(NA, NA), new_bytes(c(na_dbl, na_dbl))) }) test_that("bytes() only accepts bare vectors", { expect_error(bytes2(factor("1Mb")), "Can't coerce") }) test_that("as_bytes() accepts numeric input unchanged", { expect_equal(unclass(as_bytes(123L)), 123L) expect_equal(unclass(as_bytes(123)), 123) }) test_that("as_bytes() accepts bench_byte input unchanged", { x <- as_bytes(123) expect_equal(as_bytes(x), x) }) test_that("parse_bytes() parses character input", { expect_equal(unclass(parse_bytes("1")), 1) expect_equal(unclass(parse_bytes("1K")), 1000) expect_equal(unclass(parse_bytes("1M")), 1000 * 1000) expect_equal(unclass(parse_bytes("10M")), 10 * 1000 * 1000) expect_equal(unclass(parse_bytes("1G")), 1000 * 1000 * 1000) }) test_that("format.rlib_bytes() formats bytes under 1024 as whole numbers", { expect_equal(format(bytes2(0)), "0 B") expect_equal(format(bytes2(1)), "1 B") expect_equal(format(bytes2(1023)), "1.02 kB") }) test_that("format.rlib_bytes() formats bytes 1024 and up as abbreviated numbers", { expect_equal(format(bytes2(1024)), "1.02 kB") expect_equal(format(bytes2(1025)), "1.02 kB") expect_equal(format(bytes2(2^16)), "65.54 kB") expect_equal(format(bytes2(2^24)), "16.78 MB") expect_equal(format(bytes2(2^24 + 555555)), "17.33 MB") expect_equal(format(bytes2(2^32)), "4.29 GB") expect_equal(format(bytes2(2^48)), "281.47 TB") expect_equal(format(bytes2(2^64)), "18.45 EB") }) test_that("format.rlib_bytes() handles NA and NaN", { expect_equal(format(bytes2(NA)), "NA B") expect_equal(format(bytes2(NaN)), "NaN B") }) test_that("format.rlib_bytes() works with vectors", { expect_snapshot( print(as_bytes(c(NA, 1, 2^13, 2^20, NaN, 2^15))) ) expect_equal( format(as_bytes(numeric())), character() ) }) test_that("sum.rlib_bytes() sums its input and returns a bench_byte", { expect_equal(sum(bytes2(0)), new_bytes(0)) expect_equal(sum(bytes2(c(1, 2))), new_bytes(3)) expect_equal(sum(bytes2(c(1, NA))), new_bytes(NA_real_)) }) test_that("min.rlib_bytes() finds minimum input and returns a bench_byte", { expect_equal(min(bytes2(0)), new_bytes(0)) expect_equal(min(bytes2(c(1, 2))), new_bytes(1)) expect_equal(min(bytes2(c(1, NA))), new_bytes(NA_real_)) }) test_that("max.rlib_bytes() finds maximum input and returns a bench_byte", { expect_equal(max(bytes2(0)), new_bytes(0)) expect_equal(max(bytes2(c(1, 2))), new_bytes(2)) expect_equal(max(bytes2(c(1, NA))), new_bytes(NA_real_)) }) test_that("[.rlib_bytes() retains the bytes2 class", { x <- bytes2(c(100, 200, 300)) expect_equal(x[], x) expect_equal(x[1], new_bytes(100)) expect_equal(x[1:2], new_bytes(c(100, 200))) }) test_that("Ops.rlib_bytes() errors for unary operators", { x <- bytes2(c(100, 200, 300)) expect_error(!x, "unary `!` not defined for objects") expect_error(+x, "unary `\\+` not defined for objects") expect_error(-x, "unary `-` not defined for objects") }) test_that("Ops.rlib_bytes() works with boolean comparison operators", { x <- bytes2(c(100, 200, 300)) expect_equal(x == 100, c(TRUE, FALSE, FALSE)) expect_equal(x != 100, c(FALSE, TRUE, TRUE)) expect_equal(x > 100, c(FALSE, TRUE, TRUE)) expect_equal(x >= 100, c(TRUE, TRUE, TRUE)) expect_equal(x < 200, c(TRUE, FALSE, FALSE)) expect_equal(x <= 200, c(TRUE, TRUE, FALSE)) expect_true(bytes2("1Mb") > "1Kb") }) test_that("Ops.rlib_bytes() works with arithmetic operators", { x <- bytes2(c(100, 200, 300)) expect_equal(x + 100, bytes2(c(200, 300, 400))) expect_equal(x - 100, bytes2(c(0, 100, 200))) expect_equal(x * 100, bytes2(c(10000, 20000, 30000))) expect_equal(x / 2, bytes2(c(50, 100, 150))) expect_equal(x ^ 2, bytes2(c(10000, 40000, 90000))) expect_equal(bytes2("1Mb") + "1000Kb", bytes2("2Mb")) }) test_that("Ops.rlib_bytes() errors for other binary operators", { x <- bytes2(c(100, 200, 300)) expect_error(x %% 2, "`%%` not defined for objects") expect_error(x %/% 2, "`%/%` not defined for objects") expect_error(x & TRUE, "`&` not defined for objects") expect_error(x | TRUE, "`|` not defined for objects") }) test_that("print method disambiguates edge cases", { expect_snapshot(print(bytes2())) expect_snapshot(print(bytes2(NA, NA))) }) rlang/tests/testthat/test-env-binding.R0000644000176200001440000003233314741441060017664 0ustar liggesuserstest_that("promises are created", { env <- child_env(NULL) env_bind_lazy(env, foo = bar <- "bar") expect_false(env_has(current_env(), "bar")) force(env$foo) expect_true(env_has(current_env(), "bar")) env_bind_lazy(env, stop = stop("forced")) expect_error(env$stop, "forced") }) test_that("env_bind_active() creates active bindings", { env <- env() env_bind_active(env, a = function() "foo") expect_identical(env$a, "foo") expect_identical(env$a, "foo") }) test_that("env_poke() returns previous value", { env <- env(env(empty_env(), bar = "bar")) expect_identical(env_poke(env, "foo", "foo"), zap()) expect_identical(env_poke(env, "foo", "FOO"), "foo") expect_identical(env_poke(env, "bar", "foo", inherit = TRUE), "bar") }) test_that("env_poke() creates binding if `create` is TRUE", { env <- new_environment() env_poke(env, "foo", "foo") expect_identical(env_get(env, "foo"), "foo") expect_error(env_poke(env, "bar", "BAR", create = FALSE), "Can't find existing binding") env_poke(env, "foo", "FOO", create = FALSE) expect_identical(env_get(env, "foo"), "FOO") }) test_that("env_poke() inherits from parents if `inherit` is TRUE", { env <- child_env(new_environment(), foo = "foo") env <- child_env(env) env_has(env, "foo") env_has(env, "foo", TRUE) env_poke(env, "foo", "FOO", inherit = TRUE, create = FALSE) expect_identical(env_get(env_parent(env), "foo", inherit = FALSE), "FOO") expect_error(env_poke(env, "bar", "bar", inherit = TRUE, create = FALSE), "Can't find existing binding") expect_error(env_poke(env, "bar", "bar", inherit = TRUE), "Can't find existing binding") env_poke(env, "bar", "bar", inherit = TRUE, create = TRUE) expect_identical(env_get(env, "bar"), "bar") }) test_that("env_get() evaluates promises and active bindings", { e <- env() env_bind_lazy(e, x = 1) env_bind_active(e, y = function() 2) expect_equal(env_get(e, "x"), 1) expect_equal(env_get(e, "y"), 2) }) test_that("env_get_list() retrieves multiple bindings", { env <- env(foo = 1L, bar = 2L) expect_identical(env_get_list(env, c("foo", "bar")), list(foo = 1L, bar =2L)) baz <- 0L expect_error(env_get_list(env, "baz"), "Can't find") expect_identical(env_get_list(env, c("foo", "baz"), inherit = TRUE), list(foo = 1L, baz =0L)) }) test_that("local_bindings binds temporarily", { env <- env(foo = "foo", bar = "bar") local({ old <- local_bindings(.env = env, foo = "FOO", bar = "BAR", baz = "BAZ" ) expect_identical(old, list3(foo = "foo", bar = "bar", baz = zap())) temp_bindings <- env_get_list(env, c("foo", "bar", "baz")) expect_identical(temp_bindings, list(foo = "FOO", bar = "BAR", baz = "BAZ")) }) bindings <- env_get_list(env, c("foo", "bar")) expect_identical(bindings, list(foo = "foo", bar = "bar")) expect_false(env_has(env, "baz")) }) test_that("local_bindings() restores in correct order", { foo <- "start" local({ local_bindings(foo = "foo") expect_identical(foo, "foo") local_bindings(foo = "bar") expect_identical(foo, "bar") }) expect_identical(foo, "start") }) test_that("with_bindings() evaluates with temporary bindings", { foo <- "foo" baz <- "baz" expect_identical(with_bindings(paste(foo, baz), foo = "FOO"), "FOO baz") expect_identical(foo, "foo") }) test_that("env_unbind() with `inherits = TRUE` only removes first match", { env <- env(foo = "foo") child <- env(env, foo = "foo") env_unbind(child, "foo", inherit = TRUE) expect_false(env_has(child, "foo")) expect_true(env_has(env, "foo")) }) test_that("env_bind() requires named elements", { expect_error(env_bind(env(), 1), "some elements are not named") expect_error(env_bind(env(), !!!list(1)), "some elements are not named") }) test_that("env_bind() works with empty unnamed lists", { expect_no_error(env_bind(env())) expect_no_error(env_bind(env(), !!!list())) }) test_that("env_names() unserialises unicode", { env <- env(`` = "foo") expect_identical(env_names(env), "\u5E78\u798F") }) test_that("env_has() returns a named vector", { expect_identical(env_has(env(a = TRUE), c("a", "b", "c")), c(a = TRUE, b = FALSE, c = FALSE)) }) test_that("env_unbind() doesn't warn if binding doesn't exist (#177)", { expect_no_warning(env_unbind(env(), c("foo", "bar"))) }) test_that("env_get() and env_get_list() accept default value", { env <- env(a = 1) expect_error(env_get(env, "b"), "Can't find") expect_error(env_get_list(env, "b"), "Can't find") expect_identical(env_get(env, "b", default = "foo"), "foo") expect_identical(env_get_list(env, c("a", "b"), default = "foo"), list(a = 1, b = "foo")) }) test_that("env_get() without default fails", { expect_snapshot({ (expect_error(env_get(env(), "foobar"))) (expect_error(env_get_list(env(), "foobar"))) }) fn <- function(env, default) env_get(env, "_foobar", default = default) expect_error(fn(env()), "Can't find") }) test_that("env_get() evaluates `default` lazily", { expect_equal(env_get(env(a = 1), "a", default = stop("tilt")), 1) }) test_that("env_bind_active() uses as_function()", { env_bind_active(current_env(), foo = ~2 + 3) expect_identical(foo, 5) }) test_that("env_bind_active() and env_bind_lazy() redefine bindings", { env <- env(a = 1, b = 2) env_bind_active(env, a = ~"foo") env_bind_lazy(env, b = "bar") expect_identical(c(env$a, env$b), c("foo", "bar")) }) test_that("binding predicates detect special bindings", { env <- env() env_bind_active(env, a = ~toupper("foo")) env_bind_lazy(env, b = toupper("foo")) env_bind(env, c = toupper("foo"), d = "irrelevant") expect_identical(env_binding_are_active(env, c("a", "b", "c")), c(a = TRUE, b = FALSE, c = FALSE)) expect_identical(env_binding_are_lazy(env, c("a", "b", "c")), c(a = FALSE, b = TRUE, c = FALSE)) force(env$b) expect_identical(env_binding_are_lazy(env, c("a", "b", "c")), c(a = FALSE, b = FALSE, c = FALSE)) env <- env(a = 1, b = 2) expect_identical(env_binding_are_active(env), c(a = FALSE, b = FALSE)) expect_identical(env_binding_are_lazy(env), c(a = FALSE, b = FALSE)) }) test_that("applies predicates to all bindings by default", { env <- env() env_bind_active(env, a = ~toupper("foo")) env_bind_lazy(env, b = toupper("foo")) env_bind(env, c = toupper("foo")) expect_identical(env_binding_are_active(env), c(a = TRUE, b = FALSE, c = FALSE)) expect_identical(env_binding_are_lazy(env), c(a = FALSE, b = TRUE, c = FALSE)) }) test_that("env_binding_are_active() doesn't force promises", { env <- env() env_bind_lazy(env, foo = stop("kaboom")) expect_no_error(env_binding_are_active(env)) expect_identical(env_binding_are_lazy(env), lgl(foo = TRUE)) expect_identical(env_binding_are_lazy(env), lgl(foo = TRUE)) }) test_that("env_binding_are_active() doesn't trigger active bindings (#1376)", { env <- env() env_bind_active(env, foo = ~stop("kaboom")) expect_no_error(env_binding_are_active(env)) expect_identical(env_binding_are_active(env), lgl(foo = TRUE)) expect_identical(env_binding_are_lazy(env), lgl(foo = FALSE)) }) test_that("env_binding_type_sum() detects types", { env <- env() env_bind_active(env, a = ~"foo") env_bind_lazy(env, b = identity("foo")) env_bind(env, c = "foo", d = 1L, e = 2 ) expect_error(env_binding_type_sum(env, 1L), "must be a character vector") types <- c(a = "active", b = "lazy", c = "chr", d = "int", e = "dbl") expect_identical(env_binding_type_sum(env), types) }) test_that("can lock and unlock bindings", { env <- env(a = "A", b = "B") expect_identical(env_binding_are_locked(env), lgl(a = FALSE, b = FALSE)) expect_identical(env_binding_lock(env, "a"), lgl(a = FALSE)) locked <- env_binding_are_locked(env) expect_identical(locked, lgl(a = TRUE, b = FALSE)) expect_identical(env_binding_unlock(env), locked) expect_identical(env_binding_are_locked(env), lgl(a = FALSE, b = FALSE)) }) test_that("can pluck missing arg from environment", { env <- env(x = missing_arg()) expect_identical(env_get(env, "x"), missing_arg()) expect_identical(env_get_list(env, "x"), list(x = missing_arg())) skip("Failing") child <- env(env) env_get(child, "x", inherit = TRUE) }) test_that("can call local_bindings() and with_bindings() without arguments", { expect_no_error(local_bindings()) expect_no_error(with_bindings("foo")) }) test_that("can bind missing args", { e <- env() expect_no_error(env_bind(e, foo = )) expect_identical(e$foo, missing_arg()) args <- list(bar = expr(), baz = expr()) expect_no_error(env_bind(e, !!!args)) expect_identical(env_get_list(e, c("bar", "baz")), args) }) test_that("can remove bindings by supplying zaps", { empty <- env() expect_no_error(env_bind(empty, foo = zap())) env <- env(foo = "foo", bar = "bar") env_bind(env, foo = zap(), bar = zap()) expect_identical(env_names(env), chr()) env <- env(foo = "foo", bar = "bar") env_bind(env, !!!rep_named(c("foo", "bar"), list(zap()))) expect_identical(env_names(env), chr()) env <- env(foo = "foo", bar = "bar") env_bind_active(env, foo = zap()) expect_identical(env_names(env), "bar") env_bind_lazy(env, bar = !!zap()) expect_identical(env_names(env), chr()) env_bind(current_env(), !!!rep_named(c("foo", "bar"), list(zap()))) }) test_that("env_bind_lazy() supports quosures", { env <- env() foo <- "foo" quo <- local({ foo <- "quux" quo(paste(foo, "bar")) }) env_bind_lazy(env, x = !!quo) expect_identical(env$x, "quux bar") foo <- "FOO" expect_identical(env$x, "quux bar") }) test_that("env_bind_active() supports quosures", { env <- env() foo <- "foo" env_bind_active(env, x = quo(paste(foo, "bar"))) expect_identical(env$x, "foo bar") foo <- "FOO" expect_identical(env$x, "FOO bar") }) test_that("env_bind_lazy() supports nested quosures", { env <- env() quo <- local({ lhs <- "quux" rhs <- local({ rhs <- "hunoz"; quo(rhs) }) quo(paste(lhs, !!rhs)) }) env_bind_lazy(env, x = !!quo) expect_identical(env$x, "quux hunoz") }) test_that("env_bind_active() supports nested quosures", { env <- env() quo <- local({ lhs <- "quux" rhs <- local({ rhs <- "hunoz"; quo(rhs) }) quo(paste(lhs, !!rhs)) }) env_bind_active(env, x = quo) expect_identical(env$x, "quux hunoz") quo <- quo_set_env(quo, env(lhs = "QUUX")) env_bind_active(env, x = quo) expect_identical(env$x, "QUUX hunoz") }) test_that("env_get() survives native encoding", { with_non_utf8_locale({ e <- env(empty_env()) funs <- list(function() 42) native <- enc2native("\u4e2d") s <- as_string(native) names(funs) <- native env_bind_active(e, !!!funs) names(funs) <- s env_bind_active(e, !!!funs) expect_equal(e[[s]], 42) expect_equal(e[[native]], 42) }) }) test_that("`env_binding_are_lazy()` type-checks `env` (#923)", { expect_error(env_binding_are_lazy("a", "b"), "must be an environment") }) test_that("env_poke() zaps (#1012)", { env <- env(zapzap = 1) env_poke(env, "zapzap", zap()) expect_false(env_has(env, "zapzap")) env <- env(env(zapzap = 1)) env_poke(env, "zapzap", zap()) expect_false(env_has(env, "zapzap")) expect_true(env_has(env, "zapzap", inherit = TRUE)) env_poke(env, "zapzap", zap(), inherit = TRUE) expect_false(env_has(env, "zapzap", inherit = TRUE)) }) test_that("env_poke() doesn't warn when unrepresentable characters are serialised", { with_non_utf8_locale({ e <- env(empty_env()) nm <- get_alien_lang_string() expect_no_warning(env_poke(e, nm, NA)) skip_if_no_utf8_marker() nms <- env_names(e) expect_equal(Encoding(nms), "UTF-8") }) }) test_that("new_environment() supports non-list data", { env <- new_environment(c(a = 1)) expect_equal(typeof(env), "environment") expect_equal(env$a, 1) }) test_that("`%<~%` assigns lazily", { x %<~% 1 expect_equal(x, 1) x %<~% stop("foo") expect_error(x, "foo") # Can reassign over a throwing promise x %<~% stop("bar") expect_error(x, "bar") }) test_that("env_get() and env_get_list() handle `last` argument", { top <- env(foo = "foo") mid <- env(top) low <- env(mid) expect_equal( env_get(low, "foo", inherit = TRUE, default = "null"), "foo" ) expect_equal( env_get(low, "foo", inherit = TRUE, last = mid, default = "null"), "null" ) expect_equal( env_get(low, "foo", inherit = TRUE, last = low, default = "null"), "null" ) expect_equal( env_get_list(low, "foo", inherit = TRUE, default = "null"), list(foo = "foo") ) expect_equal( env_get_list(low, "foo", inherit = TRUE, last = mid, default = "null"), list(foo = "null") ) expect_equal( env_get_list(low, "foo", inherit = TRUE, last = low, default = "null"), list(foo = "null") ) }) test_that("env_cache() works (#1081)", { e <- env(a = "foo") # Returns existing binding expect_equal( env_cache(e, "a", "default"), "foo" ) # Creates a `b` binding and returns its default value expect_equal( env_cache(e, "b", "default"), "default" ) # Now `b` is defined expect_equal(e$b, "default") expect_equal(e$a, "foo") }) test_that("env_get(last = ) checks for empty env when last is disconnected (#1208)", { out <- env_get( emptyenv(), "_foobar", default = "_fallback", inherit = TRUE, last = globalenv() ) expect_equal(out, "_fallback") }) rlang/tests/testthat/test-standalone-cli.R0000644000176200001440000001000414376112150020347 0ustar liggesusersskip_if_not_installed("cli") cli::test_that_cli(configs = c("plain", "ansi"), "can style strings with cli", { expect_snapshot({ mark_emph("foo") mark_strong("foo") mark_code("foo") mark_q("foo") mark_pkg("foo") mark_fn("foo") mark_arg("foo") mark_kbd("foo") mark_key("foo") mark_file("foo") mark_path("foo") mark_email("foo") mark_url("foo") mark_var("foo") mark_envvar("foo") mark_field("foo") mark_cls("foo") mark_cls(c("foo", "bar")) }) }) cli::test_that_cli(configs = c("plain", "ansi"), "can format strings with cli", { expect_snapshot({ format_emph("foo") format_strong("foo") format_code("foo") format_q("foo") format_pkg("foo") format_fn("foo") format_arg("foo") format_kbd("foo") format_key("foo") format_file("foo") format_path("foo") format_email("foo") format_url("foo") format_var("foo") format_envvar("foo") format_field("foo") format_cls("foo") format_cls(c("foo", "bar")) }) }) cli::test_that_cli(configs = c("plain", "ansi"), "styled strings may contain `{` syntax", { expect_snapshot({ mark_emph("{foo {}") format_message(mark_emph("{foo {}")) }) }) cli::test_that_cli(configs = c("plain", "ansi"), "can apply ANSI styles with cli", { expect_snapshot({ col_black("foo") col_blue("foo") col_cyan("foo") col_green("foo") col_magenta("foo") col_red("foo") col_white("foo") col_yellow("foo") col_grey("foo") col_silver("foo") col_none("foo") bg_black("foo") bg_blue("foo") bg_cyan("foo") bg_green("foo") bg_magenta("foo") bg_red("foo") bg_white("foo") bg_yellow("foo") bg_none("foo") style_dim("foo") style_blurred("foo") style_bold("foo") style_hidden("foo") style_inverse("foo") style_italic("foo") style_strikethrough("foo") style_underline("foo") style_no_dim("foo") style_no_blurred("foo") style_no_bold("foo") style_no_hidden("foo") style_no_inverse("foo") style_no_italic("foo") style_no_strikethrough("foo") style_no_underline("foo") style_reset("foo") style_no_colour("foo") style_no_bg_colour("foo") }) }) cli::test_that_cli("can create symbols with cli", { expect_snapshot({ symbol_info() symbol_cross() symbol_tick() symbol_bullet() symbol_arrow() symbol_alert() }) }) cli::test_that_cli("can create ANSI symbols with cli", { expect_snapshot({ ansi_info() ansi_cross() ansi_tick() ansi_bullet() ansi_arrow() ansi_alert() }) }) cli::test_that_cli("can format messages", { expect_snapshot({ format_error(c("Header", "i" = "Bullet.")) format_warning(c("Header", "i" = "Bullet.")) format_message(c("Header", "i" = "Bullet.")) }) }) cli::test_that_cli("formatters restore strings", { expect_true(is_bare_character(format_error("foo"))) expect_true(is_bare_character(format_warning("foo"))) expect_true(is_bare_character(format_message("foo"))) }) cli::test_that_cli(configs = c("plain", "ansi"), "cli_escape() conditionally escapes `{`", { expect_snapshot({ format_error(cli_escape("{")) }) }) test_that("hyperlinks are supported", { local_options(cli.hyperlink = FALSE) expect_equal( vec_unstructure(style_hyperlink("foo", "bar")), "foo" ) local_options(cli.hyperlink = TRUE) cache <- env_get(fn_env(.rlang_cli_has_cli), "cache") rlang_cli_local_support(CLI_SUPPORT_HYPERLINK, TRUE) expect_equal( style_hyperlink("foo", "bar"), cli::style_hyperlink("foo", "bar") ) rlang_cli_local_support(CLI_SUPPORT_HYPERLINK, FALSE) expect_equal( style_hyperlink("foo", "bar"), "foo" ) rlang_cli_local_support(CLI_SUPPORT_HYPERLINK_PARAMS, TRUE) expect_equal( style_hyperlink("foo", "bar", c(param = "baz")), cli::style_hyperlink("foo", "bar", c(param = "baz")) ) rlang_cli_local_support(CLI_SUPPORT_HYPERLINK_PARAMS, FALSE) expect_equal( style_hyperlink("foo", "bar", list()), "foo" ) }) rlang/tests/testthat/helper-trace.R0000644000176200001440000000252014401331356017054 0ustar liggesusersexpect_snapshot_trace <- function(trace, dir = normalizePath(test_path("..")), srcrefs = FALSE) { expect_snapshot({ "Full" print(trace, simplify = "none", dir = dir, srcrefs = srcrefs) "Focused" print_focused_trace(trace, dir = dir, srcrefs = srcrefs) "Branch" print(trace, simplify = "branch", dir = dir, srcrefs = srcrefs) }) } print_focused_trace <- function(trace, ...) { with_options( "rlang:::trace_deemph" = function(x) sprintf("<<%s>>", x), print(trace, ..., simplify = "none", drop = TRUE) ) } print_highlighted_trace <- function(x, ...) { local_options( "rlang_trace_format_srcrefs" = FALSE, "rlang:::trace_test_highlight" = TRUE ) print(x, ..., simplify = "none", drop = TRUE) } expect_trace_length <- function(x, n) { expect_equal(trace_length(x), n) } expect_equal_trace <- function(x, y) { expect_identical(x$parents, y$parents) expect_equal(x$calls, y$calls) } render_md <- function(file, env = global_env()) { skip_if_not_installed("rmarkdown") skip_if_not_installed("knitr") out_file <- tempfile(file) on.exit(file.remove(out_file)) rmarkdown::render( test_path(file), output_format = "md_document", output_file = out_file, quiet = TRUE, envir = env ) readLines(out_file) } rlang/tests/testthat/test-stack.R0000644000176200001440000000754014375670676016617 0ustar liggesuserstest_that("can return from frame", { fn <- function() { val <- g() paste(val, "to fn()") } g <- function(env) { h(environment()) stop("g!\n") } h <- function(env) { return_from(env, "returned from h()") stop("h!\n") } expect_equal(fn(), "returned from h() to fn()") }) test_that("current_env() and current_fn() return current frame props", { fn <- function() { list( rlang = list(identity(current_env()), current_fn()), base = list(environment(), sys.function()) ) } out <- fn() expect_identical(out$rlang[[1]], out$base[[1]]) expect_identical(out$rlang[[2]], out$base[[2]]) }) test_that("sys_parents() removes infloop values", { f <- function() g() g <- function() sys_parents() parents <- do.call("f", list(), envir = env()) n <- length(parents) # No loop when called in non-frame env expect_false(any(parents == seq_len(n))) # g() is called by f() which is called by global because the calling # env is not on the stack expect_equal(parents[[n - 1]], 0) # f() expect_equal(parents[[n]], n - 1) # g() }) test_that("current_fn() and caller_fn() work", { f <- function(n) identity(g(n)) g <- function(n) identity(h(n)) h <- function(n) identity(caller_fn(n)) expect_equal(f(1), g) expect_equal(f(2), f) # Need to break the chain of callers to get `NULL` at `n = 3`. # Otherwise we get the `eval()` frame from testthat expect_null(eval_bare(quote(f(3)), env())) f <- function() current_fn() expect_equal(f(), f) }) test_that("Parents are matched to youngest duplicate frames", { skip_on_cran() out <- env() f <- function() { invisible(g(environment(), report("f"))) } g <- function(env, arg) { fn <- function() h(env, arg) eval(as.call(list(fn)), env) } h <- function(env, arg) { fn <- function() list(arg, report("h")) eval(as.call(list(fn)), env) } report <- function(what) { parents <- sys_parents(match_oldest = FALSE) env_poke(out, what, parents) } f() f_parents <- tail(out[["f"]], 10) - length(out[["f"]]) + 10 h_parents <- tail(out[["h"]], 10) - length(out[["h"]]) + 10 expect_equal(f_parents, c(0:8, 1L)) expect_equal(h_parents, 0:9) }) test_that("frame_fn() returns the function of the supplied frame", { f <- function() { identity(g(current_env())) } g <- function(frame) { identity(h(frame)) } h <- function(frame) { tryCatch(frame_fn(frame)) } expect_equal(f(), f) f <- function() { evalq(g(current_env())) } expect_equal(f(), f) f <- function() { evalq(g(current_env()), env()) } eval_prim <- eval(call2(sys.function)) expect_equal(f(), eval_prim) f <- function() { eval_bare(quote(g(current_env())), env()) } expect_null(f()) }) test_that("current_call(), caller_call() and frame_call() work", { expect_null(eval_bare(call2(current_call), global_env())) expect_null(eval_bare(call2(caller_call), global_env())) expect_null(eval_bare(call2(frame_call), global_env())) f <- function() g() g <- function() { direct <- frame_call() indirect <- evalq(frame_call()) expect_equal(direct, indirect) } f() f <- function() { this <- current_call() that <- g() expect_equal(this, quote(f())) expect_equal(this, that) } g <- function() caller_call() f() return("Don't make this guarantee to stay consistent with `caller_env()`") f <- function() g() g <- function() { direct <- caller_call() indirect <- h(current_env()) expect_equal(indirect, direct) } h <- function(env) evalq(caller_call(), env) f() }) test_that("caller_env2() respects invariant", { f <- function() h() h <- function() { indirect <- evalq(caller_env2()) direct <- caller_env2() expect_equal(indirect, direct) } f() f <- function() g() g <- function() inject(caller_env2(), env()) expect_equal(f(), global_env()) }) rlang/tests/testthat/test-c-api.R0000644000176200001440000010706514741441060016462 0ustar liggesusers# https://github.com/r-lib/rlang/issues/1556 skip_if_not(has_size_one_bool()) r_string <- function(str) { stopifnot(is_string(str)) .Call(ffi_r_string, str) } test_that("chr_prepend() prepends", { out <- .Call(ffi_test_chr_prepend, c("foo", "bar"), r_string("baz")) expect_identical(out, c("baz", "foo", "bar")) }) test_that("chr_append() appends", { out <- .Call(ffi_test_chr_append, c("foo", "bar"), r_string("baz")) expect_identical(out, c("foo", "bar", "baz")) }) test_that("r_warn() signals", { expect_warning(regexp = "foo", withCallingHandlers(warning = function(c) expect_null(c$call), .Call(ffi_test_r_warn, "foo") )) }) test_that("r_on_exit() adds deferred expr", { var <- chr() fn <- function() { .Call(ffi_test_r_on_exit, quote(var <<- c(var, "foo")), current_env()) var <<- c(var, "bar") } fn() expect_identical(var, c("bar", "foo")) }) test_that("r_base_ns_get() fail if object does not exist", { expect_error(.Call(ffi_test_base_ns_get, "foobar")) }) test_that("r_peek_frame() returns current frame", { current_frame <- function() { list(.Call(ffi_test_current_frame), environment()) } out <- current_frame() expect_identical(out[[1]], out[[2]]) }) test_that("r_sys_frame() returns current frame environment", { sys_frame <- function(..., .n = 0L) { list(.Call(ffi_test_sys_frame, .n), sys.frame(.n)) } out <- sys_frame(foo(), bar) expect_identical(out[[1]], out[[2]]) wrapper <- function(...) { sys_frame(.n = -1L) } out <- wrapper(foo(), bar) expect_identical(out[[1]], out[[2]]) }) test_that("r_sys_call() returns current frame call", { sys_call <- function(..., .n = 0L) { list(.Call(ffi_test_sys_call, .n), sys.call(.n)) } out <- sys_call(foo(), bar) expect_identical(out[[1]], out[[2]]) wrapper <- function(...) { sys_call(.n = -1L) } out <- wrapper(foo(), bar) expect_identical(out[[1]], out[[2]]) }) test_that("r_which_operator() returns correct tokens", { expect_identical(call_parse_type(quote(foo())), "") expect_identical(call_parse_type(""), "") expect_identical(call_parse_type(quote(?a)), "?unary") expect_identical(call_parse_type(quote(a ? b)), "?") expect_identical(call_parse_type(quote(while (a) b)), "while") expect_identical(call_parse_type(quote(for (a in b) b)), "for") expect_identical(call_parse_type(quote(repeat a)), "repeat") expect_identical(call_parse_type(quote(if (a) b)), "if") expect_identical(call_parse_type(quote(break)), "break") expect_identical(call_parse_type(quote(next)), "next") expect_identical(call_parse_type(quote(a <- b)), "<-") expect_identical(call_parse_type(quote(a <<- b)), "<<-") expect_identical(call_parse_type(quote(a < b)), "<") expect_identical(call_parse_type(quote(a <= b)), "<=") expect_identical(call_parse_type(quote(`<--`(a, b))), "") expect_identical(call_parse_type(quote(`<<--`(a, b))), "") expect_identical(call_parse_type(quote(`<==`(a, b))), "") expect_identical(call_parse_type(quote(a > b)), ">") expect_identical(call_parse_type(quote(a >= b)), ">=") expect_identical(call_parse_type(quote(`>-`(a, b))), "") expect_identical(call_parse_type(quote(`>==`(a, b))), "") expect_identical(call_parse_type(quote(`=`(a, b))), "=") expect_identical(call_parse_type(quote(a == b)), "==") expect_identical(call_parse_type(quote(`=-`(a, b))), "") expect_identical(call_parse_type(quote(`==-`(a, b))), "") expect_identical(call_parse_type(quote(~a)), "~unary") expect_identical(call_parse_type(quote(a ~ b)), "~") expect_identical(call_parse_type(quote(`~-`(a))), "") expect_identical(call_parse_type(quote(a:b)), ":") expect_identical(call_parse_type(quote(a::b)), "::") expect_identical(call_parse_type(quote(a:::b)), ":::") expect_identical(call_parse_type(quote(a := b)), ":=") expect_identical(call_parse_type(quote(`:-`(a, b))), "") expect_identical(call_parse_type(quote(`::-`(a, b))), "") expect_identical(call_parse_type(quote(`:::-`(a, b))), "") expect_identical(call_parse_type(quote(`:=-`(a, b))), "") expect_identical(call_parse_type(quote(a | b)), "|") expect_identical(call_parse_type(quote(a || b)), "||") expect_identical(call_parse_type(quote(`|-`(a, b))), "") expect_identical(call_parse_type(quote(`||-`(a, b))), "") expect_identical(call_parse_type(quote(a & b)), "&") expect_identical(call_parse_type(quote(a && b)), "&&") expect_identical(call_parse_type(quote(`&-`(a, b))), "") expect_identical(call_parse_type(quote(`&&-`(a, b))), "") expect_identical_(call_parse_type(quote(!b)), "!") expect_identical_(call_parse_type(quote(`!!`(b))), "!!") expect_identical_(call_parse_type(quote(`!!!`(b))), "!!!") expect_identical_(call_parse_type(quote(`!-`(a, b))), "") expect_identical_(call_parse_type(quote(`!!-`(a, b))), "") expect_identical_(call_parse_type(quote(`!!!-`(a, b))), "") expect_identical_(call_parse_type(quote(!?b)), "!") expect_identical_(call_parse_type(quote(!!?b)), "!") expect_identical(call_parse_type(quote(+a)), "+unary") expect_identical(call_parse_type(quote(a + b)), "+") expect_identical(call_parse_type(quote(`+-`(a))), "") expect_identical(call_parse_type(quote(-a)), "-unary") expect_identical(call_parse_type(quote(a - b)), "-") expect_identical(call_parse_type(quote(`--`(a))), "") expect_identical(call_parse_type(quote(a * b)), "*") expect_identical(call_parse_type(quote(a / b)), "/") expect_identical(call_parse_type(quote(a ^ b)), "^") expect_identical(call_parse_type(quote(a$b)), "$") expect_identical(call_parse_type(quote(a@b)), "@") expect_identical(call_parse_type(quote(a[b])), "[") expect_identical(call_parse_type(quote(a[[b]])), "[[") expect_identical(call_parse_type(quote(`*-`(a, b))), "") expect_identical(call_parse_type(quote(`/-`(a, b))), "") expect_identical(call_parse_type(quote(`^-`(a, b))), "") expect_identical(call_parse_type(quote(`$-`(a, b))), "") expect_identical(call_parse_type(quote(`@-`(a, b))), "") expect_identical(call_parse_type(quote(`[-`(a, b))), "") expect_identical(call_parse_type(quote(`[[-`(a, b))), "") expect_identical(call_parse_type(quote(a %% b)), "%%") expect_identical(call_parse_type(quote(a %>% b)), "special") expect_identical(call_parse_type(quote(`%%-`(a))), "") expect_identical(call_parse_type(quote((a))), "(") expect_identical(call_parse_type(quote({ a })), "{") expect_identical(call_parse_type(quote(`(-`(a))), "") expect_identical(call_parse_type(quote(`{-`(a))), "") }) test_that("client library passes tests", { expect_true(TRUE) return("Disabled") # Avoid installing into system library by default skip_if(!nzchar(Sys.getenv("RLANG_FULL_TESTS"))) skip_on_cran() skip_on_ci() # Silence package building and embedded tests output temp <- file() sink(temp) on.exit({ sink() close(temp) }) # tools::testInstalledPackage() can't find the package if we install # to a temporary library if (FALSE) { old_libpaths <- .libPaths() temp_lib <- tempfile("temp_lib") dir.create(temp_lib) .libPaths(c(temp_lib, old_libpaths)) on.exit(.libPaths(old_libpaths), add = TRUE) } else { temp_lib <- .libPaths() } zip_file <- normalizePath(file.path("fixtures", "lib.zip")) src_path <- normalizePath(file.path("fixtures", "rlanglibtest")) # Set temporary dir to install and test the embedded package so we # don't have to clean leftovers files temp_test_dir <- tempfile("temp_test_dir") dir.create(temp_test_dir) old <- setwd(temp_test_dir) on.exit(setwd(old), add = TRUE) file.copy(src_path, temp_test_dir, overwrite = TRUE, recursive = TRUE) pkg_path <- file.path(temp_test_dir, "rlanglibtest") # We store the library as a zip to avoid VCS noise. Use # fixtures/Makefile to regenerate it. utils::unzip(zip_file, exdir = file.path(pkg_path, "src")) install.packages(pkg_path, repos = NULL, type = "source", lib = temp_lib, INSTALL_opts = "--install-tests", verbose = FALSE, quiet = TRUE ) result <- tools::testInstalledPackage("rlanglibtest", lib.loc = temp_lib, types = "test") expect_identical(result, 0L) }) node_list_clone_until <- function(node, sentinel) { .Call(ffi_test_node_list_clone_until, node, sentinel) } test_that("can clone-until with NULL list", { expect_identical(node_list_clone_until(NULL, pairlist()), list(NULL, NULL)) }) test_that("can clone-until with NULL sentinel", { node <- pairlist(a = 1, b = 2, c = 3) out <- node_list_clone_until(node, NULL) sentinel_out <- out[[2]] expect_reference(node_cddr(out[[1]]), sentinel_out) node_out <- out[[1]] expect_identical(node_out, pairlist(a = 1, b = 2, c = 3)) while (!is_null(node_out)) { expect_false(is_reference(node_out, node)) node_out <- node_cdr(node_out) node <- node_cdr(node) } }) test_that("returned sentinel and value are NULL if couldn't be found", { node <- pairlist(a = NULL) out <- node_list_clone_until(node, pairlist(NULL)) expect_false(is_reference(out[[1]], node)) expect_null(out[[1]]) expect_null(out[[2]]) }) test_that("can clone until sentinel", { node1 <- pairlist(a = 1, b = 2, c = 3) node2 <- node_cdr(node1) node3 <- node_cdr(node2) out <- node_list_clone_until(node1, node2) # No modification by reference of original list expect_false(is_reference(out, node1)) expect_true(is_reference(node_cdr(node1), node2)) expect_true(is_reference(node_cdr(node2), node3)) node_out <- out[[1]] expect_identical(node_out, pairlist(a = 1, b = 2, c = 3)) expect_false(is_reference(node_out, node1)) expect_true(is_reference(node_cdr(node_out), node2)) expect_true(is_reference(node_out, out[[2]])) }) get_attributes <- function(x) { .Call(ffi_attrib, x) } c_set_attribute <- function(x, name, value) { .Call(ffi_test_attrib_set, x, sym(name), value) } test_that("r_attrib_set() sets elements", { x <- list() out1 <- c_set_attribute(x, "foo", 1L) attrs1 <- get_attributes(out1) expect_identical(attrs1, pairlist(foo = 1L)) expect_false(is_reference(x, out1)) expect_null(get_attributes(x)) out2 <- c_set_attribute(out1, "bar", 2L) attrs2 <- get_attributes(out2) expect_identical(attrs2, pairlist(bar = 2L, foo = 1L)) expect_reference(get_attributes(out1), attrs1) expect_reference(node_cdr(attrs2), attrs1) }) test_that("r_attrib_set() zaps one element", { x <- structure(list(), foo = 1) attrs <- get_attributes(x) out <- c_set_attribute(x, "foo", NULL) expect_reference(get_attributes(x), attrs) expect_null(get_attributes(out)) }) test_that("r_attrib_set() zaps several elements", { x <- structure(list(), foo = 1, bar = 2, baz = 3) attrs <- get_attributes(x) out1 <- c_set_attribute(x, "foo", NULL) attrs1 <- get_attributes(out1) expect_identical(attrs1, pairlist(bar = 2, baz = 3)) expect_true(is_reference(attrs1, node_cdr(attrs))) expect_true(is_reference(node_cdr(attrs1), node_cddr(attrs))) out2 <- c_set_attribute(x, "bar", NULL) attrs2 <- get_attributes(out2) expect_identical(attrs2, pairlist(foo = 1, baz = 3)) expect_false(is_reference(attrs2, attrs)) expect_true(is_reference(node_cdr(attrs2), node_cddr(attrs))) out3 <- c_set_attribute(x, "baz", NULL) attrs3 <- get_attributes(out3) expect_identical(attrs3, pairlist(foo = 1, bar = 2)) expect_false(is_reference(attrs3, attrs)) expect_false(is_reference(node_cdr(attrs3), node_cdr(attrs))) }) test_that("can zap non-existing attributes", { x <- list() out <- c_set_attribute(x, "foo", NULL) expect_identical(out, list()) expect_false(is_reference(x, out)) x2 <- structure(list(), foo = 1, bar = 2) out2 <- c_set_attribute(x2, "baz", NULL) attrs2 <- get_attributes(out2) expect_identical(attrs2, pairlist(foo = 1, bar = 2)) expect_reference(attrs2, get_attributes(x2)) }) test_that("r_parse()", { expect_equal(.Call(ffi_test_parse, "{ foo; bar }"), quote({ foo; bar })) expect_error(.Call(ffi_test_parse, "foo; bar"), "single expression") expect_error(.Call(ffi_test_parse, "foo\n bar"), "single expression") }) test_that("r_parse_eval()", { foo <- "quux" expect_identical(r_parse_eval("toupper(foo)"), "QUUX") expect_error(r_parse_eval("toupper(foo); foo"), "single expression") }) test_that("failed parses are printed if `rlang__verbose_errors` is non-NULL", { expect_error( expect_output( regexp = "foo; bar", with_options(rlang__verbose_errors = TRUE, .Call(ffi_test_parse, "foo; bar") ) ), "single expression" ) }) test_that("r_deprecate_warn() warns once", { expect_warning(deprecate_warn("retired", "foo"), "retired") expect_no_warning(deprecate_warn("retired", "foo")) expect_warning(deprecate_warn("retired", "bar"), "retired") }) test_that("nms_are_duplicated() detects duplicates", { out <- nms_are_duplicated(letters) expect_identical(out, rep(FALSE, length(letters))) out <- nms_are_duplicated(c("a", "b", "a", "a", "c", "c")) expect_identical(out, c(FALSE, FALSE, TRUE, TRUE, FALSE, TRUE)) }) test_that("nms_are_duplicated() handles empty and missing names", { out <- nms_are_duplicated(c("a", NA, NA, "b", "", "", "a")) expect_identical(out, c(FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, TRUE)) }) test_that("r_lgl_sum() handles NA", { expect_identical(r_lgl_sum(lgl(TRUE, FALSE), TRUE), 1L) expect_identical(r_lgl_sum(lgl(TRUE, FALSE), FALSE), 1L) expect_identical(r_lgl_sum(lgl(TRUE, NA), TRUE), 2L) expect_identical(r_lgl_sum(lgl(TRUE, NA), FALSE), 1L) }) test_that("r_lgl_which() handles NA", { expect_identical(r_lgl_which(lgl(TRUE, FALSE), TRUE), 1L) expect_identical(r_lgl_which(lgl(TRUE, FALSE), FALSE), 1L) expect_identical(r_lgl_which(lgl(TRUE, NA, FALSE, NA, TRUE, NA), TRUE), int(1L, NA, NA, 5L, NA)) expect_identical(r_lgl_which(lgl(TRUE, NA, FALSE, NA, TRUE, NA), FALSE), int(1L, 5L)) }) test_that("r_lgl_which() handles empty vectors", { expect_identical(r_lgl_which(lgl(), TRUE), int()) expect_identical(r_lgl_which(lgl(), FALSE), int()) expect_identical(r_lgl_which(named(lgl()), TRUE), named(int())) expect_identical(r_lgl_which(named(lgl()), FALSE), named(int())) }) test_that("r_lgl_which() propagates names", { x <- lgl(a = TRUE, b = FALSE, c = NA, d = FALSE, e = NA, f = TRUE) expect_named(r_lgl_which(x, na_propagate = TRUE), c("a", "c", "e", "f")) expect_named(r_lgl_which(x, na_propagate = FALSE), c("a", "f")) # Unnamed if input is unnamed expect_named(r_lgl_which(TRUE, na_propagate = TRUE), NULL) expect_named(r_lgl_which(lgl(TRUE, NA), na_propagate = TRUE), NULL) }) test_that("r_lgl_which() handles `NA` when propagation is disabled (#750)", { expect_identical(r_lgl_which(lgl(TRUE, FALSE, NA), FALSE), int(1)) expect_identical(r_lgl_which(lgl(TRUE, FALSE, NA, TRUE), FALSE), int(1, 4)) expect_identical(r_lgl_which(lgl(TRUE, NA, FALSE, NA, TRUE, FALSE, TRUE), FALSE), int(1, 5, 7)) }) test_that("r_pairlist_rev() reverses destructively", { x <- pairlist(1) y <- node_list_reverse(x) expect_true(is_reference(x, y)) x <- pairlist(1, 2) n1 <- x n2 <- node_cdr(x) y <- node_list_reverse(x) expect_identical(y, pairlist(2, 1)) expect_true(is_reference(x, n1)) expect_true(is_reference(y, n2)) expect_true(is_reference(node_cdr(y), n1)) expect_true(is_null(node_cdr(n1))) x <- pairlist(1, 2, 3) n1 <- x n2 <- node_cdr(x) n3 <- node_cddr(x) y <- node_list_reverse(x) expect_identical(y, pairlist(3, 2, 1)) expect_true(is_reference(x, n1)) expect_true(is_reference(y, n3)) expect_true(is_reference(node_cdr(y), n2)) expect_true(is_reference(node_cddr(y), n1)) expect_true(is_null(node_cdr(n1))) }) test_that("r_dict_put() hashes object", { dict <- new_dict(10L) expect_true(dict_put(dict, quote(foo), 1)) expect_true(dict_put(dict, quote(bar), 2)) expect_false(dict_put(dict, quote(foo), 2)) expect_false(dict_put(dict, quote(bar), 2)) }) test_that("key has reference semantics", { dict <- new_dict(10L) keys <- c("foo", "bar") # Fresh character vector returned by `[[` expect_true(dict_put(dict, keys[[1]], 1)) expect_true(dict_put(dict, keys[[1]], 2)) # CHARSXP are interned and unique expect_true(dict_put(dict, chr_get(keys[[1]], 0L), 3)) expect_false(dict_put(dict, chr_get(keys[[1]], 0L), 4)) }) test_that("key can be `NULL`", { dict <- new_dict(10L) expect_true(dict_put(dict, NULL, 1)) expect_false(dict_put(dict, NULL, 2)) }) test_that("collisions are handled", { dict <- new_dict(1L, prevent_resize = TRUE) expect_true(dict_put(dict, quote(foo), 1)) expect_true(dict_put(dict, quote(bar), 2)) expect_false(dict_put(dict, quote(bar), 3)) # Check that dictionary was not resized and we indeed have colliding # elements expect_equal(dict_size(dict), 1L) }) test_that("can check existing and retrieve values", { dict <- new_dict(10L) dict_put(dict, quote(foo), 1) dict_put(dict, quote(bar), 2) dict_put(dict, quote(foo), 3) expect_true(dict_has(dict, quote(foo))) expect_true(dict_has(dict, quote(bar))) expect_false(dict_has(dict, quote(baz))) expect_equal(dict_get(dict, quote(foo)), 1) expect_equal(dict_get(dict, quote(bar)), 2) expect_error(dict_get(dict, quote(baz)), "Can't find key") }) test_that("dictionary size is rounded to next power of 2", { dict <- new_dict(3L) expect_equal(dict_size(dict), 4L) }) test_that("can resize dictionary", { dict <- new_dict(3L) dict_resize(dict, 5L) expect_equal(dict_size(dict), 8L) }) test_that("dictionary grows", { dict <- new_dict(3L) dict_put(dict, quote(foo), 1) dict_put(dict, quote(bar), 2) dict_put(dict, quote(baz), 3) expect_equal(dict_size(dict), 4L) dict_put(dict, quote(quux), 4) expect_equal(dict_size(dict), 8L) }) test_that("can delete elements from dict", { dict <- new_dict(3L) dict_put(dict, quote(foo), 1) dict_put(dict, quote(bar), 2) expect_true(dict_del(dict, quote(bar))) expect_false(dict_has(dict, quote(bar))) expect_false(dict_del(dict, quote(bar))) expect_true(dict_del(dict, quote(foo))) expect_false(dict_has(dict, quote(foo))) expect_false(dict_del(dict, quote(foo))) }) test_that("can put again after del", { dict <- new_dict(3L) dict_put(dict, quote(foo), 1) dict_del(dict, quote(foo)) expect_true(dict_put(dict, quote(foo), 2)) expect_equal(dict_get(dict, quote(foo)), 2) # Used to fail because we deleted whole bucket instead of just a # node when this node appeared first in the bucket dict <- new_dict(3L) dict_put(dict, chr_get("1"), NULL) dict_put(dict, chr_get("foo"), NULL) unclass(dict)[[2]] dict_del(dict, chr_get("1")) unclass(dict)[[2]] dict_put(dict, chr_get("1"), "1") unclass(dict) expect_null(dict_get(dict, chr_get("foo"))) expect_equal(dict_get(dict, chr_get("1")), "1") }) test_that("can poke dict value", { dict <- new_dict(3L) expect_equal( dict_poke(dict, quote(foo), 1), sym(".__C_NULL__.") ) expect_equal( dict_get(dict, quote(foo)), 1 ) expect_equal( dict_poke(dict, quote(foo), 2), 1 ) expect_equal( dict_get(dict, quote(foo)), 2 ) }) test_that("can iterate over dict", { dict <- new_dict(10L) dict_put(dict, quote(foo), 1) dict_put(dict, quote(bar), 2) it <- new_dict_iterator(dict) expect_equal( dict_it_info(it), list( key = NULL, value = NULL, i = 0L, n = 16L ) ) exp_foo <- list(key = quote(foo), value = 1) exp_bar <- list(key = quote(bar), value = 2) expect_true(dict_it_next(it)) info1 <- dict_it_info(it)[1:2] expect_true(dict_it_next(it)) info2 <- dict_it_info(it)[1:2] if (as_string(info1$key) == "foo") { expect_equal(info1, exp_foo) expect_equal(info2, exp_bar) } else { expect_equal(info1, exp_bar) expect_equal(info2, exp_foo) } expect_false(dict_it_next(it)) expect_false(dict_it_next(it)) }) test_that("can iterate over dict (edge case)", { dict <- new_dict(1L, prevent_resize = TRUE) dict_put(dict, quote(foo), 1) dict_put(dict, quote(bar), 2) it <- new_dict_iterator(dict) expect_equal( dict_it_info(it), list( key = NULL, value = NULL, i = 0L, n = 1L ) ) exp_foo <- list(key = quote(foo), value = 1) exp_bar <- list(key = quote(bar), value = 2) expect_true(dict_it_next(it)) info1 <- dict_it_info(it)[1:2] expect_true(dict_it_next(it)) info2 <- dict_it_info(it)[1:2] if (as_string(info1$key) == "foo") { expect_equal(info1, exp_foo) expect_equal(info2, exp_bar) } else { expect_equal(info1, exp_bar) expect_equal(info2, exp_foo) } expect_false(dict_it_next(it)) expect_false(dict_it_next(it)) }) test_that("can transform dict to list and df-list", { dict <- new_dict(10L) dict_put(dict, quote(foo), 1) dict_put(dict, quote(bar), 2) out <- dict_as_df_list(dict) foo_first <- as_string(out$key[[1]]) == "foo" if (foo_first) { exp <- list( key = list(quote(foo), quote(bar)), value = list(1, 2) ) } else { exp <- list( key = list(quote(bar), quote(foo)), value = list(2, 1) ) } expect_equal(out, exp) out <- dict_as_list(dict) if (foo_first) { expect_equal(out, list(1, 2)) } else { expect_equal(out, list(2, 1)) } }) test_that("can preserve and unpreserve repeatedly", { old <- use_local_precious_list(TRUE) on.exit(use_local_precious_list(old)) x <- env() # Need to call rlang_precious_dict() repeatedly because it returns a # clone of the dict dict <- function() rlang_precious_dict() peek_stack <- function() dict_get(dict(), x) peek_count <- function() peek_stack()[[1]] expect_false(dict_has(dict(), x)) rlang_preserve(x) on.exit(while (dict_has(dict(), x)) { rlang_unpreserve(x) }) expect_true(dict_has(dict(), x)) stack <- peek_stack() expect_equal(stack[[1]], 1L) expect_equal(stack[[2]], x) rlang_preserve(x) expect_equal(peek_count(), 2L) rlang_unpreserve(x) expect_equal(peek_count(), 1L) rlang_unpreserve(x) expect_false(dict_has(dict(), x)) expect_error(rlang_unpreserve(x), "Can't unpreserve") }) test_that("alloc_data_frame() creates data frame", { df <- alloc_data_frame(2L, c("a", "b", "c"), c(13L, 14L, 16L)) expect_equal(nrow(df), 2) expect_equal(ncol(df), 3) expect_equal(class(df), "data.frame") expect_equal(names(df), c("a", "b", "c")) expect_equal(lapply(df, typeof), list(a = "integer", b = "double", c = "character")) expect_equal(lapply(df, length), list(a = 2, b = 2, c = 2)) df <- alloc_data_frame(0L, chr(), int()) expect_equal(nrow(df), 0) expect_equal(ncol(df), 0) expect_equal(names(df), chr()) df <- alloc_data_frame(3L, chr(), int()) expect_equal(nrow(df), 3) expect_equal(ncol(df), 0) expect_equal(names(df), chr()) }) test_that("r_list_compact() compacts lists", { expect_equal(list_compact(list()), list()) expect_equal(list_compact(list(1, 2)), list(1, 2)) expect_equal(list_compact(list(NULL)), list()) expect_equal(list_compact(list(NULL, 1)), list(1)) expect_equal(list_compact(list(1, NULL)), list(1)) expect_equal(list_compact(list(NULL, 1, NULL, 2, NULL)), list(1, 2)) }) test_that("can grow vectors", { x <- 1:3 out <- vec_resize(x, 5) expect_length(out, 5) expect_equal(x, 1:3) expect_equal(out[1:3], x) x <- as.list(1:3) out <- vec_resize(x, 5) expect_length(out, 5) expect_equal(x, as.list(1:3)) expect_equal(out[1:3], x) }) test_that("can shrink vectors", { x_atomic <- 1:3 + 0L out <- vec_resize(x_atomic, 2) expect_equal(out, 1:2) x_list <- as.list(1:3) out <- vec_resize(x_list, 2) expect_equal(out, as.list(1:2)) # Uses truelength to modify in place on recent R if (getRversion() >= "3.4.0") { expect_equal(x_atomic, 1:2) expect_equal(x_list, as.list(1:2)) } }) test_that("can grow and shrink dynamic arrays", { arr <- new_dyn_array(1, 3) expect_equal( dyn_info(arr), list( count = 0, capacity = 3, growth_factor = 2, type = "raw", elt_byte_size = 1 ) ) dyn_push_back_bool(arr, FALSE) dyn_push_back_bool(arr, TRUE) dyn_push_back_bool(arr, TRUE) expect_equal( dyn_info(arr), list( count = 3, capacity = 3, growth_factor = 2, type = "raw", elt_byte_size = 1 ) ) dyn_push_back_bool(arr, FALSE) expect_equal( dyn_info(arr)[1:2], list( count = 4, capacity = 6 ) ) dyn_push_back_bool(arr, FALSE) dyn_push_back_bool(arr, TRUE) expect_equal( dyn_info(arr)[1:2], list( count = 6, capacity = 6 ) ) exp <- bytes(0, 1, 1, 0, 0, 1) expect_equal(arr[[2]], exp) dyn_pop_back(arr) expect_equal( dyn_info(arr)[1:2], list( count = 5, capacity = 6 ) ) expect_equal(arr[[2]], exp) }) test_that("can resize dynamic arrays", { arr <- new_dyn_array(1, 4) dyn_push_back_bool(arr, TRUE) dyn_push_back_bool(arr, FALSE) dyn_push_back_bool(arr, TRUE) dyn_resize(arr, 2L) expect_equal( dyn_info(arr), list( count = 2, capacity = 2, growth_factor = 2, type = "raw", elt_byte_size = 1 ) ) expect_equal(arr[[2]], bytes(1, 0)) dyn_resize(arr, 4L) expect_equal( dyn_info(arr)[1:2], list( count = 2, capacity = 4 ) ) expect_equal(arr[[2]][1:2], bytes(1, 0)) expect_equal(dyn_unwrap(arr), bytes(1, 0)) }) test_that("dynamic arrays with multiple bytes per elements are resized correctly", { arr <- new_dyn_array(4, 4) expect_length(arr[[2]], 16) dyn_resize(arr, 8L) expect_length(arr[[2]], 32) arr <- new_dyn_vector("integer", 4) expect_length(arr[[2]], 4) dyn_resize(arr, 8L) expect_length(arr[[2]], 8) }) test_that("can shrink and grow dynamic atomic vectors", { arr <- new_dyn_vector("double", 3) expect_equal( dyn_info(arr), list( count = 0, capacity = 3, growth_factor = 2, type = "double", elt_byte_size = 8 ) ) dyn_push_back(arr, 1) dyn_push_back(arr, 2) dyn_push_back(arr, 3) expect_equal( dyn_info(arr)[1:2], list( count = 3, capacity = 3 ) ) expect_identical(arr[[2]], dbl(1:3)) dyn_push_back(arr, 4) expect_equal( dyn_info(arr), list( count = 4, capacity = 6, growth_factor = 2, type = "double", elt_byte_size = 8 ) ) expect_identical(arr[[2]][1:4], dbl(1:4)) expect_identical(dyn_unwrap(arr), dbl(1:4)) }) test_that("can shrink and grow dynamic barrier vectors", { arr <- new_dyn_vector("list", 3) expect_equal( dyn_info(arr)[1:4], list( count = 0, capacity = 3, growth_factor = 2, type = "list" ) ) dyn_push_back(arr, 1) dyn_push_back(arr, 2) dyn_push_back(arr, 3) expect_equal( dyn_info(arr)[1:2], list( count = 3, capacity = 3 ) ) expect_identical(arr[[2]], as.list(dbl(1:3))) dyn_push_back(arr, 4) expect_equal( dyn_info(arr)[1:4], list( count = 4, capacity = 6, growth_factor = 2, type = "list" ) ) expect_identical(arr[[2]][1:4], as.list(dbl(1:4))) expect_identical(dyn_unwrap(arr), as.list(dbl(1:4))) expect_equal(dyn_pop_back(arr), 4) expect_equal(dyn_pop_back(arr), 3) expect_equal(dyn_count(arr), 2) }) test_that("can get, push, and poke elements", { arr <- new_dyn_vector("logical", 3) dyn_push_back(arr, TRUE) dyn_lgl_push_back(arr, TRUE) expect_equal(dyn_lgl_get(arr, 0L), TRUE) expect_equal(dyn_lgl_get(arr, 1L), TRUE) dyn_lgl_poke(arr, 0L, FALSE) expect_equal(dyn_lgl_get(arr, 0L), FALSE) arr <- new_dyn_vector("integer", 3) dyn_push_back(arr, 1L) dyn_int_push_back(arr, 2L) expect_equal(dyn_int_get(arr, 0L), 1L) expect_equal(dyn_int_get(arr, 1L), 2L) dyn_int_poke(arr, 0L, 10L) expect_equal(dyn_int_get(arr, 0L), 10L) arr <- new_dyn_vector("double", 3) dyn_push_back(arr, 1.5) dyn_dbl_push_back(arr, 2.5) expect_equal(dyn_dbl_get(arr, 0L), 1.5) expect_equal(dyn_dbl_get(arr, 1L), 2.5) dyn_dbl_poke(arr, 0L, 3.5) expect_equal(dyn_dbl_get(arr, 0L), 3.5) arr <- new_dyn_vector("complex", 3) dyn_push_back(arr, 0i) dyn_cpl_push_back(arr, 1i) expect_equal(dyn_cpl_get(arr, 0L), 0i) expect_equal(dyn_cpl_get(arr, 1L), 1i) dyn_cpl_poke(arr, 0L, 2i) expect_equal(dyn_cpl_get(arr, 0L), 2i) arr <- new_dyn_vector("raw", 3) dyn_push_back(arr, as.raw(1)) dyn_raw_push_back(arr, as.raw(2)) expect_equal(dyn_raw_get(arr, 0L), as.raw(1)) expect_equal(dyn_raw_get(arr, 1L), as.raw(2)) dyn_raw_poke(arr, 0L, as.raw(3)) expect_equal(dyn_raw_get(arr, 0L), as.raw(3)) arr <- new_dyn_vector("character", 3) foo <- chr_get("foo", 0L) bar <- chr_get("bar", 0L) dyn_push_back(arr, foo) dyn_chr_push_back(arr, bar) expect_true(identical(dyn_chr_get(arr, 0L), foo)) expect_true(identical(dyn_chr_get(arr, 1L), bar)) baz <- chr_get("bar", 0L) dyn_chr_poke(arr, 0L, baz) expect_true(identical(dyn_chr_get(arr, 0L), baz)) arr <- new_dyn_vector("list", 3) dyn_push_back(arr, 1:2) dyn_list_push_back(arr, 3:4) expect_equal(dyn_list_get(arr, 0L), 1:2) expect_equal(dyn_list_get(arr, 1L), 3:4) dyn_list_poke(arr, 0L, 11:12) expect_equal(dyn_list_get(arr, 0L), 11:12) }) test_that("can create dynamic list-of", { lof <- new_dyn_list_of("integer", 5, 2) info <- lof_info(lof) expect_equal( info[c( "count", "growth_factor", "arrays", "width", "capacity", "type", "elt_byte_size" )], list( count = 0, growth_factor = 2, arrays = list(), width = 2, capacity = 5, type = "integer", elt_byte_size = 4 ) ) expect_length(lof[[2]], 5 * 2) }) test_that("can push to dynamic list-of", { lof <- new_dyn_list_of("integer", 2, 2) info <- lof_info(lof) expect_equal(lof_unwrap(lof), list()) lof_push_back(lof) expect_equal(lof_unwrap(lof), list(int())) lof_push_back(lof) expect_equal(lof_unwrap(lof), list(int(), int())) lof_push_back(lof) expect_equal(lof_unwrap(lof), list(int(), int(), int())) }) test_that("internal error is thrown with OOB dyn-lof access", { skip_if(!compiled_by_gcc()) lof <- new_dyn_list_of("integer", 3, 2) expect_snapshot({ err(lof_arr_push_back(lof, 0, 42L), "Location 0 does not exist") err(lof_arr_push_back(lof, 10, 42L), "Location 10 does not exist") }) }) test_that("can push to arrays in dynamic list-of", { lof <- new_dyn_list_of("integer", 3, 2) lof_push_back(lof) lof_push_back(lof) lof_push_back(lof) lof_push_back(lof) expect_error(lof_arr_push_back(lof, 0, 42), "type double") lof_arr_push_back(lof, 0, 42L) expect_equal( lof_unwrap(lof), list(42L, int(), int(), int()) ) lof_arr_push_back(lof, 3, 42L) expect_equal( lof_unwrap(lof), list(42L, int(), int(), 42L) ) # Trigger resizes of the reserve lof_arr_push_back(lof, 0, 43L) lof_arr_push_back(lof, 0, 44L) expect_equal( lof_unwrap(lof), list(42:44, int(), int(), 42L) ) lof_arr_push_back(lof, 2, 42L) lof_arr_push_back(lof, 2, 43L) lof_arr_push_back(lof, 2, 44L) expect_equal( lof_unwrap(lof), list(42:44, int(), 42:44, 42L) ) # Trigger resize in the moved array lof_arr_push_back(lof, 3, 43L) lof_arr_push_back(lof, 3, 44L) expect_equal( lof_unwrap(lof), list(42:44, int(), 42:44, 42:44) ) }) test_that("sexp iterator visits in full order", { it_dirs <- function(snapshot) { dirs <- sapply(snapshot, `[[`, "dir") dirs <- table(dirs) nms <- names(dirs) dim(dirs) <- NULL set_names(dirs, nms) } expect_symmetric_dirs <- function(s) { dirs <- it_dirs(s) expect_equal(s[["incoming"]], s[["outgoing"]]) } expect_symmetric_dirs(sexp_iterate(list(1), list)) expect_symmetric_dirs(sexp_iterate(list(1, 2), list)) expect_symmetric_dirs(sexp_iterate(list(1, list()), list)) expect_symmetric_dirs(sexp_iterate(list(1, list(2)), list)) expect_symmetric_dirs(sexp_iterate(list(emptyenv(), emptyenv()), list)) }) test_that("addresses have hexadecimal prefix `0x` (#1135)", { expect_equal( substring(obj_address(NULL), 1, 2), "0x" ) }) test_that("can re-encode a character vector of various encodings (r-lib/vctrs#553)", { x <- unlist(test_encodings(), use.names = FALSE) results <- r_obj_encode_utf8(x) expect_utf8_encoded(results) }) test_that("re-encodes all encodings to UTF-8", { for (enc in test_encodings()) { expect_utf8_encoded(r_obj_encode_utf8(enc)) } }) test_that("can re-encode a list containing character vectors with different encodings", { results <- r_obj_encode_utf8(test_encodings()) results <- unlist(results) expect_utf8_encoded(results) }) test_that("re-encoding fails purposefully with any bytes", { bytes <- rawToChar(as.raw(0xdc)) Encoding(bytes) <- "bytes" expect_snapshot( (expect_error(r_obj_encode_utf8(bytes))) ) for (enc in test_encodings()) { expect_snapshot( (expect_error(r_obj_encode_utf8(c(enc, bytes)))) ) } }) test_that("attributes are kept when re-encoding (r-lib/vctrs#599)", { encs <- test_encodings() x <- c(encs$utf8, encs$latin1) x <- structure(x, names = c("a", "b"), extra = 1) expect_identical(attributes(r_obj_encode_utf8(x)), attributes(x)) }) test_that("re-encoding is robust against scalar types contained in lists (r-lib/vctrs#633)", { x <- list(a = z ~ y, b = z ~ z) expect_identical(r_obj_encode_utf8(x), x) }) test_that("re-encoding can still occur even if a scalar type is in a list", { x <- list(a = z ~ y, b = test_encodings()$latin1) expect_utf8_encoded(r_obj_encode_utf8(x)$b) }) test_that("re-encoding occurs inside scalars contained in a list", { encs <- test_encodings() x <- list( structure(list(x = encs$latin1), class = "scalar_list") ) result <- r_obj_encode_utf8(x) expect_utf8_encoded(result[[1]]$x) }) test_that("re-encoding treats data frames elements of lists as lists (r-lib/vctrs#1233)", { encs <- test_encodings() a <- c(encs$utf8, encs$latin1) df <- data.frame(a = a, b = 1:2, stringsAsFactors = FALSE) x <- list(df) result <- r_obj_encode_utf8(x) expect_utf8_encoded(result[[1]]$a) }) test_that("attributes are re-encoded", { utf8 <- test_encodings()$utf8 latin1 <- test_encodings()$latin1 a <- structure(1, enc = utf8) b <- structure(1, enc = latin1) c <- structure(1, enc1 = utf8, enc2 = list(latin1), enc3 = latin1) x <- list(a, b, c) result <- r_obj_encode_utf8(x) a_enc <- attr(result[[1]], "enc") b_enc <- attr(result[[2]], "enc") c_enc1 <- attr(result[[3]], "enc1") c_enc2 <- attr(result[[3]], "enc2")[[1]] c_enc3 <- attr(result[[3]], "enc3") expect_utf8_encoded(a_enc) expect_utf8_encoded(b_enc) expect_utf8_encoded(c_enc1) expect_utf8_encoded(c_enc2) expect_utf8_encoded(c_enc3) }) test_that("attributes are re-encoded recursively", { utf8 <- test_encodings()$utf8 latin1 <- test_encodings()$latin1 nested <- structure(1, latin1 = latin1) x <- structure(2, nested = nested, foo = 1, latin1 = latin1) result <- r_obj_encode_utf8(x) attrib <- attributes(result) attrib_nested <- attributes(attrib$nested) expect_utf8_encoded(attrib$latin1) expect_utf8_encoded(attrib_nested$latin1) }) test_that("NAs aren't re-encoded to 'NA' (r-lib/vctrs#1291)", { utf8 <- c(NA, test_encodings()$utf8) latin1 <- c(NA, test_encodings()$latin1) result1 <- r_obj_encode_utf8(utf8) result2 <- r_obj_encode_utf8(latin1) expect_identical(result1[[1]], NA_character_) expect_identical(result2[[1]], NA_character_) expect_utf8_encoded(result1[[2]]) expect_utf8_encoded(result2[[2]]) }) local({ df <- c_tests() for (i in seq_len(nrow(df))) { desc <- df[[1]][[i]] ptr <- df[[2]][[i]] test_that(desc, { expect_true(run_c_test(ptr)) }) } }) test_that("r_stop_internal() mentions expected namespace", { fn <- function() { .Call(get("ffi_test_stop_internal", envir = asNamespace("rlang")), "Message.") } environment(fn) <- ns_env("base") expect_error(fn(), "detected in the base package") environment(fn) <- ns_env("utils") expect_error(fn(), "detected in the utils package") }) rlang/tests/testthat/test-trace.R0000644000176200001440000004464314741441060016571 0ustar liggesuserslocal_options( rlang_trace_use_winch = FALSE ) # These tests must come first because print method includes srcrefs test_that("tree printing only changes deliberately", { # Because of srcrefs skip_on_cran() skip_if_not_installed("testthat", "2.99.0") local_options( rlang_trace_format_srcrefs = TRUE ) dir <- normalizePath(test_path("..")) e <- environment() i <- function(i) j(i) j <- function(i) { k(i) } k <- function(i) { NULL l(i) } l <- function(i) trace_back(e) trace <- i() expect_snapshot({ print(trace, dir = dir) cat("\n") print(trace_slice(trace, 0L), dir = dir) }) }) test_that("can print tree with collapsed branches", { # Because of srcrefs skip_on_cran() skip_if_not_installed("testthat", "2.99.0") # Fake eval() call does not have same signature on old R skip_if(getRversion() < "3.4") local_options( rlang_trace_format_srcrefs = TRUE ) dir <- normalizePath(test_path("..")) e <- environment() f <- function() { g() } g <- function() { tryCatch(h(), foo = identity, bar = identity) } h <- function() { tryCatch(i(), baz = identity) } i <- function() { tryCatch(trace_back(e, bottom = 0)) } trace <- eval(quote(f())) expect_snapshot_trace(trace, dir = dir, srcrefs = TRUE ) # With multiple siblings f <- function() eval(quote(eval(quote(g())))) g <- function() tryCatch(eval(quote(h())), foo = identity, bar = identity) h <- function() trace_back(e) trace <- eval(quote(f())) expect_snapshot_trace(trace, dir = dir, srcrefs = TRUE ) }) test_that("trace_simplify_branch() extracts last branch", { e <- environment() j <- function(i) k(i) k <- function(i) l(i) l <- function(i) eval(quote(m()), parent.frame(i)) m <- function() trace_back(e) x1 <- j(1) expect_equal(sum(x1$visible), 6) expect_equal(sum(trace_simplify_branch(x1)$visible), 3) x2 <- j(2) expect_equal(sum(x2$visible), 6) expect_equal(sum(trace_simplify_branch(x2)$visible), 2) x3 <- j(3) expect_equal(sum(x3$visible), 1) expect_equal(sum(trace_simplify_branch(x3)$visible), 1) }) test_that("integerish indices are allowed", { trace <- trace_back() expect_identical(trace_slice(trace, 0), trace_slice(trace, 0L)) }) test_that("cli_branch() handles edge case", { e <- environment() f <- function() trace_back(e) trace <- f() tree <- trace_as_tree(trace, srcrefs = FALSE) expect_snapshot(cli_branch(tree[-1, ])) }) test_that("trace formatting picks up `rlang_trace_format_srcrefs`", { e <- environment() f <- function() trace_back(e) trace <- f() with_options( rlang_trace_format_srcrefs = FALSE, expect_false(any(grepl("testthat", format(trace)))) ) with_options( rlang_trace_format_srcrefs = TRUE, expect_true(any(!!grepl("test-trace\\.R", format(trace)))) ) }) test_that("trace picks up option `rlang_trace_top_env` for trimming trace", { e <- current_env() f1 <- function() trace_back() f2 <- function() trace_back(e) with_options(rlang_trace_top_env = current_env(), expect_identical(trace_length(f1()), trace_length(f2())) ) }) # This test used to be about `simplify = "collapse"` test_that("collapsed formatting doesn't collapse single frame siblings", { e <- current_env() f <- function() eval_bare(quote(g())) g <- function() trace_back(e) trace <- f() expect_snapshot({ print(trace, simplify = "none", drop = TRUE, srcrefs = FALSE) print(trace, simplify = "none", drop = FALSE, srcrefs = FALSE) }) }) test_that("recursive frames are rewired to the global env", { dir <- normalizePath(test_path("..")) e <- environment() f <- function() g() g <- function() trace_back(e) trace <- eval_tidy(quo(f())) expect_snapshot_trace(trace) }) test_that("long backtrace branches are truncated", { e <- current_env() f <- function(n) { if (n) { return(f(n - 1)) } trace_back(e) } trace <- f(10) expect_snapshot({ cat("Full:\n") print(trace, simplify = "branch", srcrefs = FALSE) cat("\n5 frames:\n") print(trace, simplify = "branch", max_frames = 5, srcrefs = FALSE) cat("\n2 frames:\n") print(trace, simplify = "branch", max_frames = 2, srcrefs = FALSE) cat("\n1 frame:\n") print(trace, simplify = "branch", max_frames = 1, srcrefs = FALSE) }) expect_error(print(trace, simplify = "none", max_frames = 5), "currently only supported with") }) test_that("eval() frames are collapsed", { # Fake eval() call does not have same signature on old R skip_if(getRversion() < "3.4") e <- current_env() f <- function() base::eval(quote(g())) g <- function() eval(quote(trace_back(e, bottom = 0))) trace <- f() expect_snapshot_trace(trace) f <- function() base::evalq(g()) g <- function() evalq(trace_back(e, bottom = 0)) trace <- f() expect_snapshot_trace(trace) }) test_that("children of collapsed frames are rechained to correct parent", { # Fake eval() call does not have same signature on old R skip_if(getRversion() < "3.4") e <- current_env() f <- function() eval(quote(g()), env()) g <- function() trace_back(e) trace <- f() expect_snapshot({ cat("Full + drop:\n") print(trace, simplify = "none", drop = TRUE, srcrefs = FALSE) cat("Full - drop:\n") print(trace, simplify = "none", drop = FALSE, srcrefs = FALSE) cat("\nBranch:\n") print(trace, simplify = "branch", srcrefs = FALSE) }) }) test_that("combinations of incomplete and leading pipes collapse properly", { skip_if_not_installed("magrittr", "1.5.0.9000") skip_on_cran() # Fake eval() call does not have same signature on old R skip_if(getRversion() < "3.4") `%>%` <- magrittr::`%>%` e <- current_env() F <- function(x, ...) x T <- function(x) trace_back(e) trace <- NA %>% F() %>% T() %>% F() %>% F() expect_snapshot_trace(trace) trace <- T(NA) %>% F() expect_snapshot_trace(trace) trace <- F(NA) %>% F() %>% T() %>% F() %>% F() expect_snapshot_trace(trace) trace <- NA %>% T() expect_snapshot_trace(trace) trace <- NA %>% F() %>% T() expect_snapshot_trace(trace) trace <- F(NA) %>% T() expect_snapshot_trace(trace) trace <- F(NA) %>% F() %>% T() expect_snapshot_trace(trace) }) test_that("calls before and after pipe are preserved", { skip_if_not_installed("magrittr", "1.5.0.9000") skip_on_cran() # Fake eval() call does not have same signature on old R skip_if(getRversion() < "3.4") `%>%` <- magrittr::`%>%` e <- current_env() F <- function(x, ...) x T <- function(x) trace_back(e) C <- function(x) f() f <- function() trace_back(e) trace <- F(NA %>% T()) expect_snapshot_trace(trace) trace <- NA %>% C() expect_snapshot_trace(trace) trace <- F(NA %>% C()) expect_snapshot_trace(trace) }) test_that("always keep very first frame as part of backtrace branch", { # Fake eval() call does not have same signature on old R skip_if(getRversion() < "3.4") e <- current_env() gen <- function(x) UseMethod("gen") gen.default <- function(x) trace_back(e) trace <- gen() expect_snapshot_trace(trace) }) test_that("can take the str() of a trace (#615)", { e <- current_env() f <- function(n) if (n < 10) f(n - 1) else trace_back(e) expect_output(expect_no_error(str(f(10)))) }) test_that("anonymous calls are stripped from backtraces", { e <- current_env() trace <- (function() { "foo" "bar" trace_back(e) })() expect_identical(format(trace, simplify = "branch"), chr()) expect_snapshot_trace(trace) }) test_that("collapsing of eval() frames detects when error occurs within eval()", { e <- NULL trace <- NULL fn <- function() { local_options( rlang_trace_format_srcrefs = FALSE ) e <<- current_env() eval() } catch_cnd(withCallingHandlers( fn(), error = function(err) trace <<- trace_back(e) )) expect_snapshot_trace(trace) }) test_that("can print degenerate backtraces", { trace_sym <- new_trace(list(quote(foo)), int(0)) expect_snapshot_trace(trace_sym) trace_null <- new_trace(list(NULL), int(0)) expect_snapshot_trace(trace_null) trace_scalar <- new_trace(list(1L), int(0)) expect_snapshot_trace(trace_scalar) }) test_that("check for dangling promise in call CAR (#492)", { expect_snapshot_trace(local({ e <- current_env() print.foo <- function(x) { rlang::trace_back(e) } foo <- structure(list(), class = "foo") print(foo) })) }) test_that("dangling srcrefs are not printed", { from <- test_path("fixtures", "trace-srcref.R") to <- test_path("fixtures", "trace-srcref2.R") file.copy(from, to) on.exit(unlink(to)) source(to, local = TRUE, keep.source = TRUE) unlink(to) expect_snapshot_trace( local(f(current_env())), srcrefs = TRUE ) }) test_that("summary.rlang_trace() prints the full tree", { e <- current_env() f <- function() g() g <- function() h() h <- function() trace_back(e) trace <- f() expect_snapshot(summary(trace, srcrefs = FALSE)) }) test_that("unexported functions have `:::` prefix", { expect_true(TRUE) return("no longer using the rlanglibtest") # Should be installed as part of the C API tests skip_if_not_installed("rlanglibtest") test_trace_unexported_child <- env_get(ns_env("rlanglibtest"), "test_trace_unexported_child") e <- current_env() f <- function() test_trace_unexported_child(e) trace <- f() expect_snapshot_trace(trace) }) test_that("global functions have `global::` prefix", { f <- eval_bare(expr(function(e) rlang::trace_back(e)), global_env()) g <- function(e) f(e) trace <- g(current_env()) expect_snapshot_trace(trace) }) test_that("local functions inheriting from global do not have `global::` prefix", { f <- eval_bare(expr(function(e) rlang::trace_back(e)), env(global_env())) g <- function(e) f(e) trace <- g(current_env()) expect_snapshot_trace(trace) }) test_that("can trim layers of backtraces", { e <- current_env() f <- function(n) identity(identity(g(n))) g <- function(n) identity(identity(h(n))) h <- function(n) identity(identity(trace_back(e, bottom = n))) trace0 <- f(0) trace1 <- f(1) trace2 <- f(2) trace3 <- f(3) expect_snapshot({ local_options(rlang_trace_format_srcrefs = FALSE) cat_line("No trimming:") summary(trace0) cat_line("", "", "One layer (the default):") summary(trace1) cat_line("", "", "Two layers:") summary(trace2) cat_line("", "", "Three layers:") summary(trace3) }) # Test that trimming with frame environment is equivalent e <- current_env() f <- function(n) identity(identity(g(n))) g <- function(n) identity(identity(h(n))) h <- function(n) identity(identity(trace_back(e, bottom = caller_env(n - 1L)))) trace1_env <- f(1) trace2_env <- f(2) trace3_env <- f(3) expect_equal_trace(trace1, trace1_env) expect_equal_trace(trace2, trace2_env) expect_equal_trace(trace3, trace3_env) }) test_that("fails when `bottom` is not on the stack", { expect_error(trace_back(bottom = env()), "Can't find `bottom`") }) test_that("caught error does not display backtrace in knitted files", { skip_if_not_installed("knitr") skip_if_not_installed("rmarkdown") skip_if(!rmarkdown::pandoc_available()) local_options( rlang_backtrace_on_error = NULL, rlang_backtrace_on_error_report = NULL, rlang_interactive = FALSE ) lines <- render_md("test-trace.Rmd") error_line <- lines[[length(lines)]] expect_match(error_line, "foo$") expect_snapshot({ cat_line(render_md("test-trace-full.Rmd")) }) }) test_that("empty backtraces are dealt with", { foo <- NULL local({ env <- new.env() local_options(rlang_trace_top_env = env) tryCatch( error = identity, withCallingHandlers( error = function(cnd) foo <<- cnd_entrace(cnd), eval(quote(stop("stop")), env) ) ) }) expect_identical(trace_length(foo$trace), 0L) }) test_that("can trace back with quosured symbol", { e <- current_env() f <- function(foo = g()) { # This will create a call in the call stack that isn't really a call quo <- quo(foo) # Quosure must be nested otherwise `eval_tidy()` unwraps it eval_tidy(expr(identity(!!quo))) } g <- function() trace_back(e) # FIXME: Weird trace structure trace <- f() expect_s3_class(trace, "rlang_trace") }) test_that("can slice backtrace", { trace <- new_trace(alist(a(), b(), c()), 0:2) expect_identical( trace_slice(trace, 2:3), new_trace(alist(b(), c()), 0:1) ) exp <- new_trace(alist(a(), c()), c(0L, 0L)) expect_identical( trace_slice(trace, c(1, 3)), exp ) expect_identical( trace_slice(trace, -2), exp ) }) test_that("backtraces carry `version` attribute", { expect_identical(attr(trace_back(), "version"), 2L) }) test_that("can bind backtraces", { trace1 <- new_trace(alist(a(), b(), c()), 0:2) expect_equal(trace_bind(), new_trace(list(), int())) expect_equal(trace_bind(trace1), trace1) trace2 <- new_trace(alist(foo(), bar(), baz()), c(0L, 1L, 1L)) out <- trace_bind(trace1, trace2) expect_equal( out$call, alist(a(), b(), c(), foo(), bar(), baz()) ) expect_equal( out$parent, c(0:3, c(4L, 4L)) ) }) test_that("backtraces don't contain inlined objects (#1069, r-lib/testthat#1223)", { # !! deparsing in older R skip_if_not_installed("base", "3.5.0") local_options( rlang_trace_format_srcrefs = FALSE ) e <- environment() f <- function(...) do.call("g", list(runif(1e6) + 0)) g <- function(...) h() h <- function() trace_back(e) trace <- inject(f(!!list())) expect_snapshot(summary(trace)) expect_lt(object.size(trace$call), 50000) }) test_that("runs of namespaces are embolden (#946)", { local_options( rlang_trace_format_srcrefs = FALSE, rlang_trace_top_env = current_env() ) f <- function() g() g <- function() h() h <- function() identity(1 + "") err <- catch_cnd(withCallingHandlers(f(), error = entrace), "error") testthat::local_reproducible_output(crayon = TRUE) expect_snapshot({ print(err) summary(err) }) }) test_that("`bottom` must be a positive integer", { expect_snapshot((expect_error(trace_back(bottom = -1)))) }) test_that("collapsed case in branch formatting", { trace <- new_trace(alist(f(), g(), h(), evalq(), evalq()), 0:4) expect_snapshot_output(print(trace, simplify = "branch")) }) test_that("can detect namespace and scope from call", { fn <- set_env(function() NULL, empty_env()) expect_equal( call_trace_context(quote(bar()), fn), trace_context() ) expect_equal( call_trace_context(quote(foo::bar()), fn), trace_context("foo", "::") ) expect_equal( call_trace_context(quote(foo:::bar()), fn), trace_context("foo", ":::") ) }) test_that("trailing `FALSE` visibility is handled", { trace <- new_trace( alist(f(), g(), h(), foo(), bar()), parent = 0:4, visible = c(TRUE, TRUE, TRUE, FALSE, FALSE) ) expect_snapshot_trace(trace) }) test_that("can create empty trace with trace_back()", { expect_equal( trace_back(top = environment()), new_trace(list(), int()) ) }) test_that("can format empty traces", { trace <- new_trace(list(), int()) expect_snapshot_trace(trace) }) test_that("backtrace is formatted with sources (#1396)", { file <- tempfile("my_source", fileext = ".R") with_srcref(file = file, " f <- function() g() g <- function() abort('foo') ") err <- catch_cnd(f(), "error") rlang_cli_local_hyperlinks() lines <- format(err$trace) n_links <- sum(grepl("\033]8;.*my_source.*\\.R:", lines)) expect_true(n_links > 0) }) test_that("sibling streaks in tree backtraces", { f <- function(x) identity(identity(x)) g <- function() f(f(h())) h <- function() abort("foo") err <- catch_cnd(f(g()), "error") expect_snapshot_trace(err) }) test_that("parallel '|' branches are correctly emphasised", { f <- function(n) g(n) g <- function(n) h(n) h <- function(n) if (n) parallel(f(n - 1)) else abort("foo") parallel <- function(x) p1(identity(x)) p1 <- function(x) p2(x) p2 <- function(x) p3(x) p3 <- function(x) x err <- expect_error(parallel(f(0))) expect_snapshot_trace(err) deep <- function(n) parallel(f(n)) err <- expect_error(deep(1)) expect_snapshot_trace(err) }) test_that("error calls and args are highlighted", { f <- function(x) g(x) g <- function(x) h(x) h <- function(x) check_string(x) wrapper <- function() { try_fetch(f(1), error = function(cnd) abort("Tilt.", parent = cnd)) } parent <- catch_error(f(1)) child <- catch_error(wrapper()) expect_snapshot({ print_highlighted_trace(parent) print_highlighted_trace(child) }) }) test_that("error calls and args are highlighted (no highlighted arg)", { f <- function() g() g <- function() h() h <- function() abort("foo") argless <- catch_error(f()) expect_snapshot({ print_highlighted_trace(argless) }) }) test_that("frame is detected from the left", { f <- function() g() g <- function() h() h <- function() identity(evalq(identity(abort("foo")))) err <- catch_error(f()) expect_snapshot({ "If detected from the right, `evalq()`is highlighted instead of `h()`" print_highlighted_trace(err) }) }) test_that("arg is defensively checked", { f <- function() g() g <- function() h() h <- function() abort("foo", arg = env()) err <- catch_error(f()) expect_snapshot({ print_highlighted_trace(err) }) }) test_that("namespaced calls are highlighted", { f <- function() g() g <- function() h() h <- function() rlang:::as_string(1) err <- catch_error(f()) expect_snapshot({ print_highlighted_trace(err) }) }) test_that("can highlight long lists of arguments in backtrace (#1456)", { f <- function(...) g( aaaaaaaaaaaa = aaaaaaaaaaaa, bbbbbbbbbbbb = bbbbbbbbbbbb, cccccccccccc = cccccccccccc, dddddddddddd = dddddddddddd, eeeeeeeeeeee = eeeeeeeeeeee, ... ) g <- function(aaaaaaaaaaaa, bbbbbbbbbbbb, cccccccccccc, dddddddddddd, eeeeeeeeeeee, ...) { rlang::abort("foo", ...) } err <- catch_error(f()) expect_snapshot({ print_highlighted_trace(err) }) err <- catch_error(f(arg = "bbbbbbbbbbbb")) expect_snapshot({ print_highlighted_trace(err) }) }) test_that("can highlight multi-line arguments in backtrace (#1456)", { f <- function(...) g(x = { a b }, ...) g <- function(x, ...) { rlang::abort("foo", ...) } err <- catch_error(f()) expect_snapshot({ print_highlighted_trace(err) }) err <- catch_error(f(arg = "x")) expect_snapshot({ print_highlighted_trace(err) }) }) rlang/tests/testthat/helper-rlang.R0000644000176200001440000000624514375670676017116 0ustar liggesusers# Load downstream deps ahead of time to avoid pkgload issues is_installed("tibble") is_installed("lifecycle") zap_attributes <- function(x) { attributes(x) <- NULL x } zap_srcref_attributes <- function(x) { attr(x, "srcref") <- NULL attr(x, "srcfile") <- NULL attr(x, "wholeSrcref") <- NULL x } run_script <- function(file, envvars = chr()) { skip_on_os("windows") # Suppress non-zero exit warnings suppressWarnings(system2( file.path(R.home("bin"), "Rscript"), c("--vanilla", file), stdout = TRUE, stderr = TRUE, env = envvars )) } run_code <- function(code) { file <- withr::local_tempfile() writeLines(code, file) out <- run_script(file) list( success = identical(attr(out, "status"), 0L), output = vec_unstructure(out) ) } local_methods <- function(..., .frame = caller_env()) { local_bindings(..., .env = global_env(), .frame = .frame) } with_methods <- function(.expr, ...) { local_methods(...) .expr } # Some backtrace tests use Rscript, which requires the last version of # the backtrace code to be installed locally skip_if_stale_backtrace <- local({ current_backtrace_ver <- "1.0.1" ver <- system.file("backtrace-ver", package = "rlang") has_stale_backtrace <- ver == "" || !identical(readLines(ver), current_backtrace_ver) function() { skip_if(has_stale_backtrace) } }) skip_if_big_endian <- function() { skip_if( identical(.Platform$endian, "big"), "Skipping on big-endian platform." ) } Rscript <- function(args, ...) { out <- suppressWarnings(system2( file.path(R.home("bin"), "Rscript"), args, ..., stdout = TRUE, stderr = TRUE )) list( out = vec_unstructure(out), status = attr(out, "status") ) } run <- function(code) { cat_line(run0(code)$out) } run0 <- function(code) { # To avoid "ARGUMENT '~+~~+~~+~~+~foo __ignored__" errors on R <= 3.5 code <- gsub("\n", ";", code) Rscript(shQuote(c("--vanilla", "-e", code))) } expect_reference <- function(object, expected) { expect_true(is_reference(object, expected)) } rlang_compats <- function(fn) { list( .rlang_compat(fn), .rlang_compat(fn, try_rlang = FALSE) ) } # Deterministic behaviour on old R versions data.frame <- function(..., stringsAsFactors = FALSE) { base::data.frame(..., stringsAsFactors = stringsAsFactors) } skip_if_not_windows <- function() { system <- tolower(Sys.info()[["sysname"]]) skip_if_not(is_string(system, "windows"), "Not on Windows") } arg_match_wrapper <- function(arg, ...) { arg_match(arg, ...) } arg_match0_wrapper <- function(arg, values, arg_nm = "arg", ...) { arg_match0(arg, values, arg_nm = arg_nm, ...) } err <- function(...) { (expect_error(...)) } checker <- function(foo, check, ...) { check(foo, ...) } import_or_skip <- function(ns, names, env = caller_env()) { skip_if_not_installed(ns) ns_import_from(ns, names, env = env) } friendly_types <- function(x, vector = TRUE) { out <- c( object = obj_type_friendly(x), object_no_value = obj_type_friendly(x, value = FALSE) ) if (vector) { out <- c( out, vector = vec_type_friendly(x), vector_length = vec_type_friendly(x, length = TRUE) ) } out } rlang/tests/testthat/test-sym.R0000644000176200001440000000246414375670676016322 0ustar liggesuserstest_that("ensym() fails with calls", { capture_sym <- function(arg) ensym(arg) expect_identical(capture_sym(foo), quote(foo)) expect_snapshot({ err(capture_sym(foo(bar))) }) }) test_that("ensym() supports strings and symbols", { capture_sym <- function(arg) ensym(arg) expect_identical(capture_sym("foo"), quote(foo)) expect_identical(capture_sym(!!"foo"), quote(foo)) expect_identical(capture_sym(!!sym("foo")), quote(foo)) }) test_that("empty string is treated as the missing argument", { expect_identical(sym(""), missing_arg()) }) test_that("syms() supports symbols as well", { expect_identical(syms(list(quote(a), "b")), list(quote(a), quote(b))) }) test_that("is_symbol() matches `name`", { expect_true(is_symbol(sym("foo"))) expect_true(is_symbol(sym("foo"), "foo")) expect_false(is_symbol(sym("foo"), "bar")) }) test_that("is_symbol() matches any name in a vector", { expect_false(is_symbol(quote(C), letters)) expect_true(is_symbol(quote(c), letters)) }) test_that("must supply strings to sym()", { expect_snapshot({ err(sym(letters)) err(sym(1:2)) }) }) test_that("data_sym() and data_syms() work", { expect_equal( data_sym("foo"), quote(.data$foo) ) expect_equal( data_syms(c("foo", "bar")), alist( .data$foo, .data$bar ) ) }) rlang/tests/testthat/test-vec.R0000644000176200001440000000461214376147516016255 0ustar liggesuserstest_that("can poke a range to a vector", { y <- 11:15 x <- 1:5 x_addr <- obj_address(x) expect_error(vec_poke_range(x, 2L, y, 2L, 6L), "too small") vec_poke_range(x, 2L, y, 2L, 4L) expect_identical(x, int(1L, 12:14L, 5L)) expect_identical(x_addr, obj_address(x)) }) test_that("can poke `n` elements to a vector", { y <- 11:15 x <- 1:5 x_addr <- obj_address(x) expect_error(vec_poke_n(x, 2L, y, 2L, 5L), "too small") vec_poke_n(x, 2L, y, 2L, 4L) expect_identical(x, int(1L, 12:15)) expect_identical(x_addr, obj_address(x)) }) test_that("can poke to a vector with default parameters", { y <- 11:15 x <- 1:5 x_addr <- obj_address(x) vec_poke_range(x, 1L, y) expect_identical(x, y) expect_identical(x_addr, obj_address(x)) x <- 1:5 x_addr <- obj_address(x) vec_poke_n(x, 1L, y) expect_identical(x, y) expect_identical(x_addr, obj_address(x)) }) test_that("can poke to a vector with double parameters", { y <- 11:15 x <- 1:5 x_addr <- obj_address(x) vec_poke_range(x, 2, y, 2, 5) expect_identical(x, int(1L, 12:15L)) expect_identical(x_addr, obj_address(x)) y <- 11:15 x <- 1:5 x_addr <- obj_address(x) vec_poke_n(x, 2, y, 2, 4) expect_identical(x, int(1L, 12:15)) expect_identical(x_addr, obj_address(x)) }) test_that("vector pokers fail if parameters are not integerish", { y <- 11:15 x <- 1:5 expect_error(vec_poke_n(x, 2.5, y, 2L, 5L), "integerish") expect_error(vec_poke_n(x, 2L, y, 2.5, 5L), "integerish") expect_error(vec_poke_n(x, 2L, y, 2L, 5.5), "integerish") expect_error(vec_poke_range(x, 2.5, y, 2L, 4L), "integerish") expect_error(vec_poke_range(x, 2L, y, 2.5, 4L), "integerish") expect_error(vec_poke_range(x, 2L, y, 2L, 4.5), "integerish") }) test_that("is_string() returns FALSE for `NA`", { expect_false(is_string(na_chr)) }) test_that("are_na() requires vector input but not is_na()", { expect_error(are_na(base::eval), "must be an atomic vector") expect_false(is_na(base::eval)) }) test_that("are_na() fails with lists (#558)", { expect_error(are_na(mtcars), "must be an atomic vector") }) test_that("variadic ctors still work without warnings (#1210)", { expect_no_warning({ local_options(lifecycle_verbosity = "warning") expect_identical(lgl(1), TRUE) expect_identical(int(1), 1L) expect_identical(dbl(1), 1.0) expect_identical(cpl(1), 1+0i) expect_identical(chr(""), "") }) }) rlang/tests/testthat/test-parent-errors.Rmd0000644000176200001440000000103314375676663020627 0ustar liggesusers```{r} foo <- error_cnd( "foo", message = "Parent message.", body = c("*" = "Bullet 1.", "*" = "Bullet 2."), call = call("foo"), use_cli_format = TRUE ) ``` Error. ```{r, error = TRUE} abort( c("Message.", "x" = "Bullet A", "i" = "Bullet B."), parent = foo, call = call("f") ) ``` Warning. ```{r} warn( c("Message.", "x" = "Bullet A", "i" = "Bullet B."), parent = foo, call = call("f") ) ``` Message. ```{r} inform( c("Message.", "x" = "Bullet A", "i" = "Bullet B."), parent = foo, call = call("f") ) ``` rlang/tests/testthat/test-cnd.R0000644000176200001440000002476514741441060016242 0ustar liggesuserslocal_unexport_signal_abort() test_that("error_cnd() checks its fields", { expect_no_error(error_cnd(trace = NULL)) expect_error(error_cnd(trace = env()), "`trace` must be `NULL` or an rlang backtrace") expect_no_error(error_cnd(parent = NULL)) expect_error(error_cnd(parent = env()), "`parent` must be `NULL` or a condition object") }) test_that("can use conditionMessage() method in subclasses of rlang errors", { skip_if_stale_backtrace() run_error_script <- function(envvars = chr()) { run_script( test_path("fixtures", "error-backtrace-conditionMessage.R"), envvars = envvars ) } non_interactive <- run_error_script() interactive <- run_error_script(envvars = "rlang_interactive=true") expect_snapshot({ cat_line(interactive) cat_line(non_interactive) }) }) test_that("rlang_error.print() calls cnd_message() methods", { local_bindings(.env = global_env(), cnd_header.foobar = function(cnd, ...) cnd$foobar_msg ) local_options( rlang_trace_format_srcrefs = FALSE, rlang_trace_top_env = current_env() ) f <- function() g() g <- function() h() h <- function() abort("", "foobar", foobar_msg = "Low-level message") # Handled error err <- catch_error(f()) expect_snapshot(print(err)) }) # tryCatch() instead of wCH() causes distinct overlapping traces test_that("Overlapping backtraces are printed separately", { # Test low-level error can use conditionMessage() local_bindings(.env = global_env(), cnd_header.foobar = function(c, ...) c$foobar_msg ) f <- function() g() g <- function() h() h <- function() abort("", "foobar", foobar_msg = "Low-level message") a <- function() b() b <- function() c() c <- function() { tryCatch( f(), error = function(err) { abort("High-level message", parent = err) } ) } local_options( rlang_trace_format_srcrefs = FALSE, rlang_trace_top_env = current_env(), rlang_backtrace_on_error = "none" ) err <- catch_error(a()) expect_snapshot({ print(err) }) expect_snapshot({ print(err, simplify = "none") }) expect_snapshot_trace(err) }) test_that("3-level ancestry works (#1248)", { low <- function() { abort("Low-level", "low") } mid <- function() { tryCatch( low(), error = function(err) { abort("Mid-level", "mid", parent = err) } ) } high <- function() { tryCatch( mid(), error = function(err) { abort("High-level", "high", parent = err) } ) } local_options( rlang_trace_format_srcrefs = FALSE, rlang_trace_top_env = current_env(), rlang_backtrace_on_error = "none" ) expect_snapshot(catch_error(high())) }) test_that("summary.rlang_error() prints full backtrace", { local_options( rlang_trace_top_env = current_env(), rlang_trace_format_srcrefs = FALSE ) f <- function() tryCatch(g()) g <- function() h() h <- function() abort("The low-level error message", foo = "foo") handler <- function(c) { abort("The high-level error message", parent = c) } a <- function() tryCatch(b()) b <- function() c() c <- function() withCallingHandlers(f(), error = handler) err <- catch_error(a()) expect_snapshot(summary(err)) }) test_that("can take the str() of an rlang error (#615)", { err <- catch_error(abort("foo")) expect_output(expect_no_error(str(err))) }) test_that("don't print message or backtrace fields if empty", { err <- error_cnd("foo", message = "") expect_snapshot(print(err)) }) test_that("base parent errors are printed with rlang method", { base_err <- simpleError("foo") rlang_err <- error_cnd("bar", message = "baz", parent = base_err) expect_snapshot(print(rlang_err)) }) test_that("errors are printed with call", { err <- catch_cnd(abort("msg", call = quote(foo(bar, baz))), "error") err$trace <- NULL expect_snapshot(print(err)) }) test_that("calls are consistently displayed on rethrow (#1240)", { base_problem <- function() stop("oh no!") rlang_problem <- function() abort("oh no!") with_context <- function(expr, step_name) { withCallingHandlers( expr = force(expr), error = function(cnd) { rlang::abort( message = "Problem while executing step.", call = call(step_name), parent = cnd ) } ) } expect_snapshot({ (expect_error(with_context(base_problem(), "step_dummy"))) (expect_error(with_context(rlang_problem(), "step_dummy"))) }) }) test_that("external backtraces are displayed (#1098)", { local_options( rlang_trace_top_env = current_env(), rlang_trace_format_srcrefs = FALSE ) ext_trace <- new_trace(alist(quux(), foofy()), base::c(0L, 1L)) f <- function() g() g <- function() h() h <- function() abort("Low-level message", trace = ext_trace) foo <- function() bar() bar <- function() baz() baz <- function() { withCallingHandlers( f(), error = function(err) { abort("High-level message", parent = err) } ) } err <- catch_cnd(foo(), "error") expect_snapshot({ print(err) summary(err) }) }) test_that("rethrowing from an exiting handler", { local_options( rlang_trace_top_env = current_env(), rlang_trace_format_srcrefs = FALSE ) f <- function() g() g <- function() h() h <- function() abort("foo") foo <- function() bar() bar <- function() baz() baz <- function() { tryCatch( f(), error = function(err) abort("bar", parent = err) ) } err <- catch_cnd(foo(), "error") expect_snapshot_trace(err) }) test_that("cnd() constructs all fields", { cond <- cnd("cnd_class", message = "cnd message") expect_identical(conditionMessage(cond), "cnd message") expect_s3_class(cond, "cnd_class") }) test_that("cnd() throws with unnamed fields", { expect_error(cnd("class", "msg", 10), "must have named data fields") }) test_that("cnd_type() detects condition type", { expect_error(cnd_type(list()), "not a condition object") expect_error(cnd_type(mtcars), "not a condition object") expect_error(cnd_type(env()), "not a condition object") expect_identical(cnd_type(cnd("foo")), "condition") expect_identical(cnd_type(message_cnd()), "message") expect_identical(cnd_type(warning_cnd()), "warning") expect_identical(cnd_type(error_cnd()), "error") expect_identical(cnd_type(catch_cnd(interrupt())), "interrupt") }) test_that("bare conditions must be subclassed", { expect_snapshot({ (expect_error(cnd())) (expect_error(signal(""))) }) }) test_that("predicates match condition classes", { expect_true(is_error(catch_cnd(stop("foo")))) expect_false(is_error(catch_cnd(warning("foo")))) expect_true(is_warning(catch_cnd(warning("foo")))) expect_true(is_message(catch_cnd(message("foo")))) }) test_that("warn() and inform() signal subclassed conditions", { wrn <- catch_cnd(warn(""), "warning") msg <- catch_cnd(inform(""), "message") expect_equal(class(wrn), c("rlang_warning", "warning", "condition")) expect_equal(class(msg), c("rlang_message", "message", "condition")) }) test_that("check for duplicate condition fields (#1268)", { expect_error(error_cnd("foo", foo = 1, foo = 2), "same name") expect_error(abort("", foo = 1, foo = 2), "same name") }) test_that("cnd_type_header() formats condition classes", { expect_snapshot({ cnd_type_header(error_cnd()) cnd_type_header(warning_cnd()) cnd_type_header(message_cnd()) cnd_type_header(error_cnd(class = "foobar")) }) }) test_that("can format warnings and other conditions", { trace <- new_trace(alist(foo(), bar()), 0:1) warning <- warning_cnd( message = c("Header.", i = "Bullet."), call = quote(quux()), use_cli_format = TRUE, trace = trace ) expect_snapshot_output(cnd_print(warning)) message <- message_cnd( message = c("Header.", i = "Bullet."), call = quote(quux()), use_cli_format = TRUE, trace = trace, parent = warning ) expect_snapshot_output(cnd_print(message)) condition <- cnd( "foobar", message = c("Header.", i = "Bullet."), call = quote(quux()), use_cli_format = TRUE, trace = trace ) expect_snapshot_output(cnd_print(condition)) }) test_that("warnings and messages have `summary()` methods", { warning <- warning_cnd(trace = new_trace(alist(f(), g()), 0:1)) message <- message_cnd(trace = new_trace(alist(f(), g()), 0:1)) expect_snapshot({ print(warning) print(message) summary(warning) summary(message) }) }) test_that("cnd ctors check arguments", { expect_snapshot({ (expect_error(warning_cnd(class = list()))) (expect_error(error_cnd(class = list()))) (expect_error(message_cnd(message = 1))) }) }) test_that("cnd_inherits() detects parent classes (#1293)", { expect_false(cnd_inherits(mtcars, "data.frame")) expect_true(cnd_inherits(cnd("foo"), "foo")) expect_false(cnd_inherits(cnd("foo"), "bar")) cnd <- cnd("foo", parent = cnd("bar")) expect_true(cnd_inherits(cnd, "foo")) expect_true(cnd_inherits(cnd, "bar")) expect_false(cnd_inherits(cnd, "baz")) }) test_that("picks up cli format flag", { local_use_cli() expect_snapshot(error = TRUE, { cnd_signal(error_cnd(message = c("foo", "i" = "bar"))) cnd_signal(warning_cnd(message = c("foo", "i" = "bar"))) cnd_signal(message_cnd(message = c("foo", "i" = "bar"))) }) local_use_cli(format = FALSE) expect_snapshot(error = TRUE, { cnd_signal(error_cnd(message = c("foo", "i" = "bar"))) cnd_signal(warning_cnd(message = c("foo", "i" = "bar"))) cnd_signal(message_cnd(message = c("foo", "i" = "bar"))) }) }) test_that("picks up caller frame", { get_call <- function(ctor) ctor(call = current_env())$call expect_equal( get_call(error_cnd), quote(get_call(error_cnd)) ) expect_equal( get_call(warning_cnd), quote(get_call(warning_cnd)) ) expect_equal( get_call(message_cnd), quote(get_call(message_cnd)) ) cnd2 <- function(...) cnd("foo", ...) expect_equal( get_call(cnd2), quote(get_call(cnd2)) ) }) test_that("cnd_inherits() checks `inherit` field (#1573)", { cnd <- catch_cnd(warn("", parent = error_cnd())) expect_false(cnd_inherits(cnd, "error")) expect_true(cnd_inherits(cnd, "warning")) cnd <- catch_cnd(warn("", parent = error_cnd(), .inherit = TRUE)) expect_true(cnd_inherits(cnd, "error")) parent <- error_cnd(class = "parent") cnd_default <- catch_cnd(abort("", parent = parent)) cnd_false <- catch_cnd(abort("", parent = parent, .inherit = FALSE)) expect_true(cnd_inherits(cnd_default, "parent")) expect_false(cnd_inherits(cnd_false, "parent")) }) rlang/tests/testthat/helper-print.R0000644000176200001440000000014313351410655017114 0ustar liggesusers expect_fixed_output <- function(object, output) { expect_output(object, output, fixed = TRUE) } rlang/tests/testthat/test-standalone-zeallot.R0000644000176200001440000000125014376112150021255 0ustar liggesusers test_that("LHS must be a list of symbols wrapped in `c()`", { expect_error( foo %<-% list(1), "must be a call to `c()`", fixed = TRUE ) expect_error( c(foo()) %<-% list(1), "Element 1 of the left-hand side .* must be a symbol" ) }) test_that("can assign lists and vectors", { c(foo, bar) %<-% list(a = 1, 2) expect_equal(list(foo, bar), list(1, 2)) c(foo, bar) %<-% c(a = 1, 2) expect_equal(list(foo, bar), list(1, 2)) }) test_that("RHS and LHS must have the same length", { expect_error( c(foo) %<-% list(), "must be the same length" ) expect_error( c(foo, bar) %<-% as.list(1:10), "must be the same length" ) }) rlang/tests/testthat/test-vec-new.R0000644000176200001440000001076014317250767017043 0ustar liggesuserstest_that("atomic vectors are spliced", { lgl <- lgl(TRUE, c(TRUE, FALSE), list(FALSE, FALSE)) expect_identical(lgl, c(TRUE, TRUE, FALSE, FALSE, FALSE)) int <- int(1L, c(2L, 3L), list(4L, 5L)) expect_identical(int, 1:5) dbl <- dbl(1, c(2, 3), list(4, 5)) expect_identical(dbl, dbl(1:5)) cpl <- cpl(1i, c(2i, 3i), list(4i, 5i)) expect_identical(cpl, c(1i, 2i, 3i, 4i, 5i)) chr <- chr("foo", c("foo", "bar"), list("buz", "baz")) expect_identical(chr, c("foo", "foo", "bar", "buz", "baz")) raw <- bytes(1, c(2, 3), list(4, 5)) expect_identical(raw, bytes(1:5)) }) test_that("can create empty vectors", { expect_identical(lgl(), logical(0)) expect_identical(int(), integer(0)) expect_identical(dbl(), double(0)) expect_identical(cpl(), complex(0)) expect_identical(chr(), character(0)) expect_identical(bytes(), raw(0)) expect_identical(list2(), list()) }) test_that("objects are not spliced", { expect_error(lgl(structure(list(TRUE, TRUE), class = "bam")), "Can't splice S3 objects") }) test_that("explicitly spliced lists are spliced", { expect_identical(lgl(FALSE, splice(list(TRUE, TRUE))), c(FALSE, TRUE, TRUE)) }) test_that("splicing uses inner names", { expect_identical(lgl(c(a = TRUE, b = FALSE)), c(a = TRUE, b = FALSE)) expect_identical(lgl(list(c(a = TRUE, b = FALSE))), c(a = TRUE, b = FALSE)) }) test_that("splicing uses outer names when scalar", { expect_identical(lgl(a = TRUE, b = FALSE), c(a = TRUE, b = FALSE)) expect_identical(lgl(list(a = TRUE, b = FALSE)), c(a = TRUE, b = FALSE)) }) test_that("warn when outer names unless input is unnamed scalar atomic", { expect_warning(expect_identical(dbl(a = c(1, 2)), c(1, 2)), "Outer names") expect_warning(expect_identical(dbl(list(a = c(1, 2))), c(1, 2)), "Outer names") expect_warning(expect_identical(dbl(a = c(A = 1)), c(A = 1)), "Outer names") expect_warning(expect_identical(dbl(list(a = c(A = 1))), c(A = 1)), "Outer names") }) test_that("warn when spliced lists have outer name", { expect_warning(lgl(list(c = c(cc = FALSE))), "Outer names") }) test_that("list2() doesn't splice bare lists", { expect_identical(list2(list(1, 2)), list(list(1, 2))) expect_identical(list2(!!! list(1, 2)), list(1, 2)) }) test_that("atomic inputs are implicitly coerced", { expect_identical(lgl(10L, FALSE, list(TRUE, 0L, 0)), c(TRUE, FALSE, TRUE, FALSE, FALSE)) expect_identical(dbl(10L, 10, TRUE, list(10L, 0, TRUE)), c(10, 10, 1, 10, 0, 1)) expect_error(lgl("foo"), "Can't convert a character vector to a logical vector") expect_error(chr(10), "Can't convert a double vector to a character vector") }) test_that("type errors are handled", { expect_error(lgl(env(a = 1)), "Internal error: expected a vector") expect_error(lgl(list(env())), "Internal error: expected a vector") }) test_that("empty inputs are spliced", { expect_identical(lgl(NULL, lgl(), list(NULL, lgl())), lgl()) expect_warning(regexp = NA, expect_identical(lgl(a = NULL, a = lgl(), list(a = NULL, a = lgl())), lgl())) }) test_that("list2() splices names", { expect_identical(list2(a = TRUE, b = FALSE), list(a = TRUE, b = FALSE)) expect_identical(list2(c(A = TRUE), c(B = FALSE)), list(c(A = TRUE), c(B = FALSE))) expect_identical(list2(a = c(A = TRUE), b = c(B = FALSE)), list(a = c(A = TRUE), b = c(B = FALSE))) }) test_that("ll() is an alias to list2()", { expect_identical(ll(!!! list(1, 2)), list(1, 2)) }) test_that("vector ctors take names arguments", { expect_identical(new_logical(2, letters[1:2]), c(a = NA, b = NA)) expect_identical(new_integer(2, letters[1:2]), c(a = na_int, b = na_int)) expect_identical(new_double(2, letters[1:2]), c(a = na_dbl, b = na_dbl)) expect_identical(new_complex(2, letters[1:2]), c(a = na_cpl, b = na_cpl)) expect_identical(new_character(2, letters[1:2]), c(a = na_chr, b = na_chr)) expect_identical(new_raw(2, letters[1:2]), set_names(raw(2), c("a", "b"))) expect_identical(new_list(2, letters[1:2]), list(a = NULL, b = NULL)) }) test_that("rep_named() repeats along names", { expect_error(rep_named(1, list(1)), "must be `NULL` or a character vector") expect_identical(rep_named(NULL, list(1)), named_list()) expect_identical(rep_named(chr(), list(1)), named_list()) expect_identical(rep_named(c("foo", "bar"), list(1)), list(foo = 1, bar = 1)) }) test_that("rep_along() reps along vector", { expect_identical(rep_along(1:2, list(zap())), list(zap(), zap())) }) test_that("chr() supports logical NA", { expect_identical(chr(NA), na_chr) expect_identical(chr(NA, NA), c(na_chr, na_chr)) }) rlang/tests/testthat/test-standalone-types-check.R0000644000176200001440000001557214741441060022037 0ustar liggesuserstest_that("`check_bool()` checks", { expect_null(check_bool(TRUE)) expect_null(check_bool(FALSE)) expect_null(check_bool(NA, allow_na = TRUE)) expect_null(check_bool(NULL, allow_null = TRUE)) expect_snapshot({ err(checker(, check_bool)) err(checker(NA, check_bool)) err(checker(NULL, check_bool)) err(checker(lgl(), check_bool, allow_na = TRUE)) err(checker(c(TRUE, FALSE), check_bool, allow_na = TRUE, allow_null = TRUE)) err(checker(1, check_bool)) }) }) test_that("`check_string()` checks", { expect_null(check_string("foo")) expect_null(check_string("")) expect_null(check_string(NA, allow_na = TRUE)) expect_null(check_string(na_chr, allow_na = TRUE)) expect_null(check_string(NULL, allow_null = TRUE)) expect_snapshot({ err(checker("", check_string, allow_empty = FALSE)) err(checker(, check_string)) err(checker(NA, check_string)) err(checker(NULL, check_string)) err(checker(chr(), check_string, allow_na = TRUE)) err(checker(na_chr, check_string)) err(checker(c("", ""), check_string, allow_na = TRUE, allow_null = TRUE)) err(checker(1, check_string)) }) }) test_that("`check_name()` checks", { expect_null(check_name("foo")) expect_null(check_name(NULL, allow_null = TRUE)) expect_snapshot({ err(checker("", check_name)) err(checker(, check_name)) err(checker(NA, check_name)) err(checker(na_chr, check_name)) err(checker(NULL, check_name)) err(checker(chr(), check_name, allow_null = TRUE)) err(checker(na_chr, check_name)) err(checker(c("", ""), check_name, allow_null = TRUE)) err(checker(1, check_name)) }) }) test_that("`check_number_whole()` checks", { expect_null(check_number_whole(10)) expect_null(check_number_whole(10L)) expect_null(check_number_whole(NA, allow_na = TRUE)) expect_null(check_number_whole(na_dbl, allow_na = TRUE)) expect_null(check_number_whole(na_int, allow_na = TRUE)) expect_null(check_number_whole(NULL, allow_null = TRUE)) expect_null(check_number_whole(Inf, allow_infinite = TRUE)) expect_null(check_number_whole(-Inf, allow_infinite = TRUE)) check_number_whole(0, max = 0) check_number_whole(0, min = 0) check_number_whole(1, min = 0, max = 2) expect_snapshot({ err(checker(, check_number_whole)) err(checker(NA, check_number_whole)) err(checker(NULL, check_number_whole)) err(checker(int(), check_number_whole, allow_na = TRUE)) err(checker(na_dbl, check_number_whole)) err(checker(na_int, check_number_whole)) err(checker(10:11, check_number_whole, allow_na = TRUE, allow_null = TRUE)) err(checker(10.5, check_number_whole)) err(checker(Inf, check_number_whole)) err(checker(-Inf, check_number_whole)) err(checker(1, max = 0, check_number_whole)) err(checker(-1, min = 0, check_number_whole)) err(checker(10, min = 1, max = 5, check_number_whole)) err(checker(10, min = NA, check_number_whole)) err(checker(10, min = NaN, check_number_whole)) err(checker(10, max = NaN, check_number_whole)) }) }) test_that("`check_number_decimal()` checks", { expect_null(check_number_decimal(10)) expect_null(check_number_decimal(10L)) expect_null(check_number_decimal(10.5)) expect_null(check_number_decimal(NA, allow_na = TRUE)) expect_null(check_number_decimal(na_dbl, allow_na = TRUE)) expect_null(check_number_decimal(na_int, allow_na = TRUE)) expect_null(check_number_decimal(NULL, allow_null = TRUE)) expect_null(check_number_decimal(Inf)) expect_null(check_number_decimal(-Inf)) expect_snapshot({ err(checker(, check_number_decimal)) err(checker(NA, check_number_decimal)) err(checker(NULL, check_number_decimal)) err(checker(int(), check_number_decimal, allow_na = TRUE)) err(checker(na_dbl, check_number_decimal)) err(checker(na_int, check_number_decimal)) err(checker(10:11, check_number_decimal, allow_na = TRUE, allow_null = TRUE)) err(checker(Inf, check_number_decimal, allow_infinite = FALSE)) err(checker(-Inf, check_number_decimal, allow_infinite = FALSE)) err(checker(10, min = NA, check_number_decimal)) err(checker(10, min = NaN, check_number_decimal)) err(checker(10, max = NaN, check_number_decimal)) }) }) test_that("`check_symbol()` checks", { expect_null(check_symbol(quote(foo))) expect_null(check_symbol(NULL, allow_null = TRUE)) expect_snapshot({ err(checker(, check_symbol)) err(checker(NULL, check_symbol)) err(checker(TRUE, check_symbol)) err(checker(alist(foo, bar), check_symbol, allow_null = TRUE)) err(checker("foo", check_symbol)) err(checker(quote(foo()), check_symbol)) }) }) test_that("`check_call()` checks", { expect_null(check_call(quote(foo()))) expect_null(check_call(NULL, allow_null = TRUE)) expect_snapshot({ err(checker(, check_call)) err(checker(NULL, check_call)) err(checker(TRUE, check_call)) err(checker(alist(foo(), bar()), check_call, allow_null = TRUE)) err(checker(quote(foo), check_call)) }) }) test_that("`check_environment()` checks", { expect_null(check_environment(env())) expect_null(check_environment(NULL, allow_null = TRUE)) expect_snapshot({ err(checker(, check_environment)) err(checker(NULL, check_environment)) err(checker(FALSE, check_environment)) err(checker(list(env(), env()), check_environment, allow_null = TRUE)) }) }) test_that("`check_character()` checks", { expect_null(check_character("")) expect_null(check_character(na_chr)) expect_null(check_character(chr())) expect_null(check_character("foo")) expect_null(check_character(letters)) expect_null(check_character(NULL, allow_null = TRUE)) expect_snapshot({ err(checker(, check_character)) err(checker(NULL, check_character)) err(checker(NA, check_character)) err(checker(1, check_character)) err(checker(list("foo", "bar"), check_character, allow_null = TRUE)) }) }) test_that("`check_logical()` checks", { expect_null(check_logical(TRUE)) expect_null(check_logical(FALSE)) expect_null(check_logical(na_lgl)) expect_null(check_logical(lgl())) expect_null(check_logical(c(TRUE, FALSE, NA))) expect_null(check_logical(NULL, allow_null = TRUE)) expect_snapshot({ err(checker(, check_logical)) err(checker(NULL, check_logical)) err(checker(NA_integer_, check_logical)) err(checker(1, check_logical)) err(checker(list("foo", "bar"), check_logical, allow_null = TRUE)) }) }) test_that("non-numeric types are not numbers", { expect_snapshot({ (expect_error(check_number_whole(factor("a")))) (expect_error(check_number_decimal(as.Date("2000-01-01")))) }) }) test_that("`check_data_frame()` checks", { expect_null(check_data_frame(data.frame())) expect_null(check_environment(NULL, allow_null = TRUE)) expect_snapshot({ err(checker(, check_data_frame)) err(checker(NULL, check_data_frame)) err(checker(list(data.frame(), data.frame()), check_data_frame, allow_null = TRUE)) }) }) rlang/tests/testthat/test-operators.R0000644000176200001440000000425514175213516017510 0ustar liggesuserstest_that("%|% returns default value", { lgl <- c(TRUE, TRUE, NA, FALSE) %|% FALSE expect_identical(lgl, c(TRUE, TRUE, FALSE, FALSE)) int <- c(1L, 2L, NA, 4L) %|% 3L expect_identical(int, 1:4) dbl <- c(1, 2, NA, 4) %|% 3 expect_identical(dbl, as.double(1:4)) chr <- c("1", "2", NA, "4") %|% "3" expect_identical(chr, as.character(1:4)) cpx <- c(1i, 2i, NA, 4i) %|% 3i expect_equal(cpx, c(1i, 2i, 3i, 4i)) }) test_that("%|% also works when y is of same length as x", { lgl <- c(TRUE, TRUE, NA, FALSE) %|% c(TRUE, TRUE, FALSE, TRUE) expect_identical(lgl, c(TRUE, TRUE, FALSE, FALSE)) int <- c(1L, 2L, NA, 4L) %|% c(10L, 11L, 12L, 13L) expect_identical(int, c(1L, 2L, 12L, 4L)) dbl <- c(1, 2, NA, 4) %|% c(10, 11, 12, 13) expect_identical(dbl, c(1, 2, 12, 4)) chr <- c("1", "2", NA, "4") %|% c("10", "11", "12", "13") expect_identical(chr, c("1", "2", "12", "4")) cpx <- c(1i, 2i, NA, 4i) %|% c(10i, 11i, 12i, 13i) expect_equal(cpx, c(1i, 2i, 12i, 4i)) }) test_that("%|% fails with wrong types", { expect_snapshot({ (expect_error(c(1L, NA) %|% 2)) (expect_error(c(1, NA) %|% "")) (expect_error(c(1, NA) %|% call("fn"))) (expect_error(call("fn") %|% 1)) }) }) test_that("%|% fails with wrong length", { expect_snapshot({ (expect_error(c(1L, NA) %|% 1:3)) (expect_error(1:10 %|% 1:4)) (expect_error(1L %|% 1:4)) }) }) test_that("%@% returns attribute", { expect_identical(mtcars %@% row.names, row.names(mtcars)) expect_identical(mtcars %@% "row.names", row.names(mtcars)) expect_null(mtcars %@% "row") }) test_that("%@% has replacement version", { x <- structure(list(), foo = "bar") x %@% foo <- NULL x %@% baz <- "quux" expect_identical(x, structure(list(), baz = "quux")) }) test_that("%@% works with S4 objects (#207)", { .Person <- setClass("Person", slots = c(name = "character", species = "character")) fievel <- .Person(name = "Fievel", species = "mouse") expect_identical(fievel %@% name, "Fievel") expect_identical(fievel %@% "species", "mouse") fievel %@% name <- "Bernard" fievel %@% "species" <- "MOUSE" expect_identical(fievel@name, "Bernard") expect_identical(fievel@species, "MOUSE") }) rlang/tests/testthat/test-standalone-vctrs.R0000644000176200001440000003007614610374512020757 0ustar liggesuserstest_that("data_frame() recycles", { expect_equal( data_frame(x = 1, y = 1:2), data_frame(x = c(1, 1), y = 1:2) ) out <- data_frame(x = list(1), y = 1:2) expect_equal(out$x, list(1, 1)) }) test_that("data_frame() nests", { df <- data_frame(a = 3:4) out <- data_frame(x = 1:2, y = df) expect_equal(out$y, df) out <- data_frame(x = 1:2, y = data_frame(a = 1)) expect_equal(out$y, data_frame(a = c(1, 1))) }) test_that("new_data_frame handles zero-length inputs", { # Zero-length input creates zero-length data frame d <- data_frame(x = numeric(0), y = numeric(0)) expect_equal(nrow(d), 0L) # Constants are ignored in the context of zero-length input d <- data_frame(x = numeric(0), y = numeric(0), z = 1) expect_equal(nrow(d), 0L) # Vectors of length > 1 don't mix with zero-length input expect_error( data_frame(x = numeric(0), y = numeric(0), z = 1, a = c(1, 2)), "Inputs can't be recycled" ) # Explicit recycling doesn't work with zero-length input expect_error( new_data_frame(df_list(x = numeric(0), z = 1, .size = 5)), "Inputs can't be recycled to `size`." ) # But it works without d <- new_data_frame(df_list(x = 1, y = "a", .size = 3)) expect_equal(nrow(d), 3L) expect_identical(d$x, rep(1, 3L)) expect_identical(d$y, rep("a", 3L)) # Can supply size for empty df d <- new_data_frame(.size = 3) expect_equal(dim(d), c(3, 0)) }) test_that("can slice vectors and data frames", { fct <- factor(c("a", "b", "a")) fct_exp <- factor(c("a", "a"), levels = c("a", "b")) expect_equal( vec_slice(fct, c(1, 3)), fct_exp ) expect_equal( vec_init(fct, 2), factor(c(NA, NA), c("a", "b")) ) df <- data_frame( x = fct, y = data_frame(a = list(1, 2, 3)) ) df_exp <- data_frame( x = fct_exp, y = data_frame(a = list(1, 3)) ) expect_equal( vec_slice(df, c(1, 3)), df_exp ) expect_equal( vec_init(df, 2), data_frame( x = vec_init(fct, 2), y = data_frame(a = list(NULL, NULL)) ) ) rep_exp <- data_frame( x = rep(fct, 2), y = data_frame(a = rep(list(1, 2, 3), 2)) ) expect_equal(vec_rep(df, 2), rep_exp) }) test_that("vec_slice() is generic", { skip_if_not_installed("tibble") tib <- tibble::tibble(x = 1:2, y = data_frame(a = 3:4)) expect_equal(vec_slice(tib, 1), tib[1, ]) }) test_that("vec_assign() works", { expect_identical( vec_assign(1:2, 1, FALSE), c(0L, 2L) ) expect_error( vec_assign(1:2, 1, 1.5), "Can't convert" ) df <- data_frame(x = list(1, 2), y = data_frame(a = c("a", "b"))) expect_equal( vec_assign(df, 2, data_frame(x = list(10))), data_frame(x = list(1, 10), y = data_frame(a = c("a", NA))) ) }) test_that("vec_ptype2() implements base coercions", { expect_equal(vec_ptype2(lgl(), lgl()), lgl()) expect_equal(vec_ptype2(lgl(), int()), int()) expect_equal(vec_ptype2(lgl(), dbl()), dbl()) expect_error(vec_ptype2(lgl(), chr())) expect_error(vec_ptype2(lgl(), list())) expect_error(vec_ptype2(lgl(), raw())) expect_equal(vec_ptype2(int(), lgl()), int()) expect_equal(vec_ptype2(int(), int()), int()) expect_equal(vec_ptype2(int(), dbl()), int()) expect_error(vec_ptype2(int(), chr())) expect_error(vec_ptype2(int(), list())) expect_error(vec_ptype2(int(), raw())) expect_equal(vec_ptype2(dbl(), lgl()), dbl()) expect_equal(vec_ptype2(dbl(), int()), dbl()) expect_equal(vec_ptype2(dbl(), dbl()), dbl()) expect_error(vec_ptype2(dbl(), chr())) expect_error(vec_ptype2(dbl(), list())) expect_error(vec_ptype2(dbl(), raw())) expect_equal(vec_ptype2(chr(), chr()), chr()) expect_error(vec_ptype2(chr(), lgl())) expect_error(vec_ptype2(chr(), int())) expect_error(vec_ptype2(chr(), dbl())) expect_error(vec_ptype2(chr(), list())) expect_error(vec_ptype2(chr(), raw())) expect_equal(vec_ptype2(list(), list()), list()) expect_error(vec_ptype2(list(), lgl())) expect_error(vec_ptype2(list(), int())) expect_error(vec_ptype2(list(), dbl())) expect_error(vec_ptype2(list(), chr())) expect_error(vec_ptype2(list(), raw())) expect_snapshot(vec_ptype2(lgl(), chr()), error = TRUE) expect_snapshot(vec_ptype2(factor("a"), lgl()), error = TRUE) }) test_that("vec_ptype2() deals with unspecified vectors", { expect_equal(vec_ptype2(NA, NA), .rlang_vctrs_unspecified()) expect_equal(vec_ptype2(NA, lgl()), lgl()) expect_equal(vec_ptype2(NA, int()), int()) expect_equal(vec_ptype2(NA, dbl()), dbl()) expect_equal(vec_ptype2(NA, chr()), chr()) expect_equal(vec_ptype2(NA, list()), list()) expect_equal(vec_ptype2(lgl(), NA), lgl()) expect_equal(vec_ptype2(int(), NA), int()) expect_equal(vec_ptype2(dbl(), NA), dbl()) expect_equal(vec_ptype2(chr(), NA), chr()) expect_equal(vec_ptype2(list(), NA), list()) }) test_that("vec_is_unspecified() knows about empty logicals", { expect_true(vec_is_unspecified(NA)) expect_false(vec_is_unspecified(lgl())) }) test_that("vec_ptype_common() works", { expect_equal( vec_ptype_common(list(lgl(), dbl(), NA)), dbl() ) expect_snapshot( error = TRUE, vec_ptype_common(list(lgl(), dbl(), "")) ) }) test_that("vec_ptype_common() finalises unspecified type", { expect_equal( vec_ptype_common(list(NA, NA)), logical() ) }) test_that("safe casts work", { expect_equal(vec_cast(NULL, logical()), NULL) expect_equal(vec_cast(TRUE, logical()), TRUE) expect_equal(vec_cast(1L, logical()), TRUE) expect_equal(vec_cast(1, logical()), TRUE) expect_equal(vec_cast(NULL, integer()), NULL) expect_equal(vec_cast(TRUE, integer()), 1L) expect_equal(vec_cast(1L, integer()), 1L) expect_equal(vec_cast(1, integer()), 1L) expect_equal(vec_cast(NULL, double()), NULL) expect_equal(vec_cast(TRUE, double()), 1L) expect_equal(vec_cast(1.5, double()), 1.5) expect_equal(vec_cast(1.5, double()), 1.5) expect_equal(vec_cast("", chr()), "") expect_equal(vec_cast(NULL, character()), NULL) expect_equal(vec_cast(NA, character()), NA_character_) expect_equal(vec_cast(NULL, list()), NULL) expect_equal(vec_cast(NA, list()), list(NULL)) expect_equal(vec_cast(list(1L, 2L), list()), list(1L, 2L)) }) test_that("lossy casts throw", { expect_error(vec_cast(c(2L, 1L), logical()), "convert") expect_error(vec_cast(c(2, 1), logical()), "convert") expect_error(vec_cast(c(2.5, 2), integer()), "convert") expect_snapshot(vec_cast(1.5, 2L), error = TRUE) }) test_that("invalid casts throw", { expect_error(vec_cast(c("x", "TRUE"), logical()), "convert") expect_error(vec_cast(list(c(TRUE, FALSE), TRUE), logical()), "convert") expect_error(vec_cast(factor("a"), logical()), "Unimplemented") expect_error(vec_cast(factor("a"), integer()), "Unimplemented") expect_error(vec_cast("1", integer()), "convert") expect_error(vec_cast(list(1L), integer()), "convert") expect_error(vec_cast("1.5", double()), "convert") expect_error(vec_cast(TRUE, character()), "convert") expect_error(vec_cast(list("x"), character()), "convert") expect_error(vec_cast(1:2, list()), "convert") }) test_that("vec_cast_common(): empty input returns list()", { expect_equal(vec_cast_common(list()), list()) expect_equal(vec_cast_common(list(NULL, NULL)), list(NULL, NULL)) }) test_that("data frames have a common type", { exp <- data.frame(x = dbl(), y = chr()) exp_rlib_df <- new_data_frame(exp, .class = "tbl") exp_tibble <- new_data_frame(exp, .class = c("tbl_df", "tbl")) expect_equal( vec_ptype2(data.frame(x = 1, y = ""), data.frame(y = "")), exp ) expect_equal( vec_ptype2(data_frame(x = 1, y = ""), data_frame(y = "")), exp_rlib_df ) expect_equal( vec_ptype2(data_frame(x = 1, y = ""), data.frame(y = "")), exp_rlib_df ) expect_error( vec_ptype2(data.frame(x = 1, y = ""), data.frame(y = 1)), "combine" ) skip_if_not_installed("tibble") expect_equal( vec_ptype2(data_frame(x = 1, y = ""), tibble::tibble(y = "")), exp_tibble ) expect_equal( vec_ptype2(tibble::tibble(x = 1, y = ""), data.frame(y = "")), exp_tibble ) }) test_that("data frame takes max of individual variables", { dt1 <- data.frame(x = FALSE, y = 1L) dt2 <- data.frame(x = 1.5, y = 1.5) expect_equal( vec_ptype_common(list(dt1, dt2)), vec_ptype_common(list(dt2)) ) }) test_that("data frame combines variables", { dt1 <- data.frame(x = 1) dt2 <- data.frame(y = 1) expect_equal( vec_ptype_common(list(dt1, dt2)), vec_ptype_common(list(data.frame(x = double(), y = double()))) ) }) test_that("can cast data frames", { expect_equal( vec_cast(data.frame(y = ""), data.frame(x = 1, y = "")), data.frame(x = na_dbl, y = "") ) expect_equal( vec_cast(data.frame(y = ""), data_frame(x = 1, y = "")), data_frame(x = na_dbl, y = "") ) skip_if_not_installed("tibble") expect_equal( vec_cast(data.frame(y = ""), tibble::tibble(x = 1, y = "")), tibble::tibble(x = na_dbl, y = "") ) }) test_that("can bind data frames", { expect_equal( vec_rbind( data.frame(x = 1), data_frame(y = "") ), data_frame(x = c(1, NA), y = c(NA, "")) ) expect_equal( vec_cbind( data_frame(x = data_frame(a = TRUE)), data_frame(y = list("")) ), data_frame(x = data_frame(a = TRUE), y = list("")) ) expect_equal( vec_rbind( data_frame(x = TRUE), data_frame(y = list("")) ), data_frame(x = c(TRUE, NA), y = list(NULL, "")) ) # `rbind()` has trouble binding df-cols on old R versions skip_if(getRversion() < "4.0") expect_equal( vec_rbind( data_frame(x = data_frame(a = TRUE)), data_frame(y = list("")) ), data_frame(x = data_frame(a = c(TRUE, NA)), y = list(NULL, "")) ) }) test_that("casting to df type uses same column order", { df1 <- data.frame(x = 1, y = 2) df2 <- data.frame(y = 3, x = 4) expect_equal( vec_cast_common(list(df1, df2)), list(df1, df2[2:1]) ) df1 <- data.frame(y = 2) df2 <- data.frame(y = 3, x = 4) expect_equal( vec_cast_common(list(df1, df2)), list(data.frame(y = 2, x = na_dbl), df2) ) }) test_that("vec_as_location() works", { n <- 4 names <- letters[1:4] i <- c(2, 3) expect_identical(vec_as_location(i, n, names), 2:3) i <- -c(2, 3) expect_identical(vec_as_location(i, n, names), c(1L, 4L)) i <- c(TRUE, FALSE, TRUE, FALSE) expect_identical(vec_as_location(i, n, names), c(1L, 3L)) i <- c("a", "d") expect_identical(vec_as_location(i, n, names), c(1L, 4L)) }) test_that("vec_as_location() recycles scalar logical inputs", { expect_equal(vec_as_location(TRUE, 0), int()) expect_equal(vec_as_location(FALSE, 0), int()) }) test_that("vec_slice() preserves attributes of data frames", { df <- data_frame(x = 1:2) attr(df, "foo") <- TRUE out <- vec_slice(df, 1) expect_true(attr(out, "foo")) }) test_that("vec_slice() doesn't restore attributes if there is a `[` method", { df <- new_data_frame( df_list(x = 1:2), .class = "rlang_foobar", foo = "bar" ) local_methods(`[.rlang_foobar` = function(x, ...) { out <- NextMethod() attr(out, "foo") <- "dispatched" out }) expect_equal( attr(vec_slice(df, 1), "foo"), "dispatched" ) }) test_that("vec_slice() preserves attributes of vectors", { x <- set_names(1:2, c("a", "b")) attr(x, "foo") <- TRUE out <- vec_slice(x, 1) expect_true(attr(out, "foo")) expect_equal(attr(out, "names"), "a") }) test_that("can row-bind unspecified columns", { expect_equal( vec_rbind( data_frame(x = NA), data_frame(x = "") ), data_frame(x = c(NA, "")) ) }) test_that("unspecified is detected recursively", { ptype <- vec_ptype(data_frame(x = NA)) expect_s3_class(ptype$x, "rlang_unspecified") }) test_that("ptype is finalised", { x <- data_frame(x = NA) out <- vec_cast_common(list(x, x))[[1]] expect_identical(out$x, NA) out <- vec_cast_common(list(out, x))[[1]] expect_identical(out$x, NA) }) test_that("vec_recycle_common() throws appropriate errors", { expect_error( vec_recycle_common(list(a = 1:2), size = 1), "Inputs can't be recycled to `size`." ) expect_error( vec_recycle_common(list(a = 1:2, b = 1:3)), "Inputs can't be recycled to a common size." ) }) rlang/tests/testthat/test-nse-defuse.R0000644000176200001440000004703414516466755017550 0ustar liggesuserstest_that("quos() creates quosures", { fs <- quos(x = 1 + 2, y = 2 + 3) expect_identical(fs$x, as_quosure(~ 1 + 2)) expect_identical(fs$y, as_quosure(~ 2 + 3)) }) test_that("quos() captures correct environment", { fn <- function(x = a + b, ...) { list(dots = quos(x = x, y = a + b, ...), env = environment()) } out <- fn(z = a + b) expect_identical(get_env(out$dots$x), out$env) expect_identical(get_env(out$dots$y), out$env) expect_identical(get_env(out$dots$z), current_env()) }) test_that("dots are interpolated", { fn <- function(...) { baz <- "baz" fn_var <- quo(baz) g(..., toupper(!! fn_var)) } g <- function(...) { foo <- "foo" g_var <- quo(foo) h(toupper(!! g_var), ...) } h <- function(...) { quos(...) } bar <- "bar" var <- quo(bar) dots <- fn(toupper(!!var)) expect_identical(map(dots, deparse), named_list("~toupper(~foo)", "~toupper(~bar)", "~toupper(~baz)")) expect_identical(map(dots, eval_tidy), named_list("FOO", "BAR", "BAZ")) }) test_that("dots capture is stack-consistent", { fn <- function(...) { g(quos(...)) } g <- function(dots) { h(dots, foo(bar)) } h <- function(dots, ...) { dots } expect_identical(fn(foo(baz)), quos_list(quo(foo(baz)))) }) test_that("dots can be spliced in", { fn <- function(...) { var <- "var" list( out = g(!!! quos(...), bar(baz), !!! list(a = var, b = ~foo)), env = current_env() ) } g <- function(...) { quos(...) } out <- fn(foo(bar)) expected <- quos_list( quo(foo(bar)), set_env(quo(bar(baz)), out$env), a = quo("var"), b = set_env(quo(!! with_env(out$env, ~foo)), out$env) ) expect_identical(out$out, expected) }) test_that("spliced dots are wrapped in formulas", { args <- alist(x = var, y = foo(bar)) expect_identical(quos(!!! args), quos_list(x = quo(var), y = quo(foo(bar)))) }) test_that("dot names are interpolated", { var <- "baz" expect_identical(quos(!!var := foo, !!toupper(var) := bar), quos_list(baz = quo(foo), BAZ = quo(bar))) expect_identical(quos(!!var := foo, bar), quos_list(baz = quo(foo), quo(bar))) var <- quote(baz) expect_identical(quos(!!var := foo), quos_list(baz = quo(foo))) }) test_that("corner cases are handled when interpolating dot names", { var <- na_chr expect_identical(names(quos(!!var := NULL)), "NA") var <- NULL expect_snapshot({ (expect_error(quos(!!var := NULL))) (expect_error(list2(!!c("a", "b") := NULL))) }) }) test_that("dots are forwarded to named arguments", { outer <- function(...) inner(...) inner <- function(...) fn(...) fn <- function(x) enquo(x) env <- child_env(current_env()) expect_identical(with_env(env, outer(foo(bar))), new_quosure(quote(foo(bar)), env)) }) test_that("pronouns are scoped throughout nested captures", { outer <- function(data, ...) eval_tidy(quos(...)[[1]], data = data) inner <- function(...) map(quos(...), eval_tidy) data <- list(foo = "bar", baz = "baz") baz <- "bazz" expect_identical(outer(data, inner(foo, baz)), set_names(list("bar", "baz"), c("", ""))) }) test_that("Can supply := with LHS even if .named = TRUE", { expect_warning(regexp = NA, expect_identical( quos(!!"nm" := 2, .named = TRUE), quos_list(nm = as_quosure(quote(2), empty_env())) )) }) test_that("Can't supply both `=` and `:=`", { expect_error(regexp = "both `=` and `:=`", quos(foobar = !!"nm" := 2)) expect_error(regexp = "both `=` and `:=`", quos(foobar = !!"nm" := 2, .named = TRUE)) }) test_that("RHS of tidy defs are unquoted", { expect_identical(quos(foo := !!"bar"), quos_list(foo = as_quosure(quote("bar"), empty_env()))) }) test_that("can capture empty list of dots", { fn <- function(...) quos(...) expect_identical(fn(), quos_list()) }) test_that("quosures are spliced before serialisation", { quosures <- quos(!! quo(foo(!! quo(bar))), .named = TRUE) expect_identical(names(quosures), "foo(bar)") }) test_that("missing arguments are captured", { q <- quo() expect_true(is_missing(quo_get_expr(q))) expect_identical(quo_get_env(q), empty_env()) }) test_that("empty quosures are forwarded", { inner <- function(x) enquo(x) outer <- function(x) inner(!! enquo(x)) expect_identical(outer(), quo()) }) test_that("quos() captures missing arguments", { expect_identical(quos(, , .ignore_empty = "none"), quos_list(quo(), quo()), c("", "")) }) test_that("quos() ignores missing arguments", { expect_identical(quos(, , "foo", ), quos_list(quo(), quo(), new_quosure("foo", empty_env()))) expect_identical(quos(, , "foo", , .ignore_empty = "all"), quos_list(new_quosure("foo", empty_env()))) }) test_that("quosured literals are forwarded as is", { expect_identical(quo(!! quo(NULL)), new_quosure(NULL, empty_env())) expect_identical(quos(!! quo(10L)), set_names(quos_list(new_quosure(10L, empty_env())), "")) }) test_that("expr() returns missing argument", { expect_true(is_missing(expr())) }) test_that("expr() supports forwarded arguments", { fn <- function(...) g(...) g <- function(...) expr(...) expect_identical(fn(foo), quote(foo)) }) test_that("can take forced arguments", { fn <- function(allow, x) { force(x) captureArgInfo(x) } expect_identical(fn(TRUE, letters), list(expr = letters, env = empty_env())) if (getRversion() < "3.2.0") { skip("lapply() does not force arguments in R 3.1") } expect_error(lapply(1:2, captureArgInfo), "must be an argument name") args <- list(list(expr = 1L, env = empty_env()), list(expr = 2L, env = empty_env())) expect_identical(lapply(1:2, function(x) captureArgInfo(x)), args) }) test_that("capturing an argument that doesn't exist fails", { fn <- function(x) captureArgInfo(`_foobar`) expect_error(fn(), "object '_foobar' not found") fn <- function() enquo(`_foobar`) expect_error(fn(), "not found") fn <- function() enexpr(`_foobar`) expect_error(fn(), "not found") expect_error((function() rlang::enexpr(`_foobar`))(), "not found") }) test_that("can capture arguments across ancestry", { y <- "foo" fn <- function() captureArgInfo(y) expect_identical(fn(), list(expr = "foo", env = empty_env())) }) test_that("can capture arguments that do exist", { fn <- function() { x <- 10L captureArgInfo(x) } expect_identical(fn(), list(expr = 10L, env = empty_env())) }) test_that("can capture missing argument", { expect_identical(captureArgInfo(), list(expr = missing_arg(), env = empty_env())) }) test_that("serialised unicode in `:=` LHS is unserialised", { skip_if_no_utf8_marker() nms <- with_latin1_locale({ exprs <- exprs("\u5e78" := 10) names(exprs) }) expect_identical(charToRaw(nms), charToRaw("\u5e78")) }) test_that("exprs() supports auto-naming", { expect_identical(exprs(foo(bar), b = baz(), .named = TRUE), list(`foo(bar)` = quote(foo(bar)), b = quote(baz()))) }) test_that("dots_interp() supports unquoting", { expect_identical(exprs(!!(1 + 2)), named_list(3)) expect_identical(exprs(!!(1 + 1) + 2), named_list(quote(2 + 2))) expect_identical(exprs(!!(1 + 1) + 2 + 3), named_list(quote(2 + 2 + 3))) expect_identical(exprs(!!"foo" := bar), named_list(foo = quote(bar))) }) test_that("dots_interp() has no side effect", { f <- function(x) exprs(!! x + 2) expect_identical(f(1), named_list(quote(1 + 2))) expect_identical(f(2), named_list(quote(2 + 2))) }) test_that("exprs() handles forced arguments", { if (getRversion() < "3.2.0") { skip("lapply() does not force arguments in R 3.1") } exprs <- list(named_list(1L), named_list(2L)) expect_identical(lapply(1:2, function(...) exprs(...)), exprs) expect_identical(lapply(1:2, exprs), exprs) }) test_that("quos() handles forced arguments", { if (getRversion() < "3.2.0") { skip("lapply() does not force arguments in R 3.1") } quos <- list(quos_list(quo(1L)), quos_list(quo(2L))) expect_identical(lapply(1:2, function(...) quos(...)), quos) expect_identical(lapply(1:2, quos), quos) }) test_that("enexpr() and enquo() handle forced arguments", { foo <- "foo" expect_identical(enexpr(foo), "foo") expect_identical(enquo(foo), quo("foo")) if (getRversion() < "3.2.0") { skip("lapply() does not force arguments in R 3.1") } expect_identical(lapply(1:2, function(x) enexpr(x)), list(1L, 2L)) expect_identical(lapply(1:2, function(x) enquo(x)), list(quo(1L), quo(2L))) }) test_that("default arguments are properly captured (#201)", { fn <- function(x = x) enexpr(x) expect_identical(fn(), quote(x)) # This is just for consistency. This causes an infinite recursion # when evaluated as Hong noted fn <- function(x = x) list(enquo(x), quo(x)) out <- fn() expect_identical(out[[1]], out[[2]]) }) test_that("names-unquoting can be switched off", { foo <- "foo" bar <- "bar" expect_identical(exprs(foo := bar, .unquote_names = FALSE), named_list(quote(foo := bar))) expect_identical(exprs(!! foo := !! bar, .unquote_names = FALSE), named_list(quote("foo" := "bar"))) expect_identical(quos(foo := bar, .unquote_names = FALSE), quos_list(new_quosure(quote(foo := bar)))) expect_identical(quos(!! foo := !! bar, .unquote_names = FALSE), quos_list(new_quosure(quote("foo" := "bar")))) }) test_that("endots() captures arguments", { # enquos() fn <- function(foo, ..., bar) enquos(foo, bar, ...) expect_identical(fn(arg1, arg2, bar = arg3()), quos(arg1, arg3(), arg2)) # enexprs() fn <- function(foo, ..., bar) enexprs(foo, bar, ...) expect_identical(fn(arg1, arg2, bar = arg3()), exprs(arg1, arg3(), arg2)) }) test_that("endots() requires symbols", { expect_error(enquos(foo(bar)), "must be argument names") expect_error(enquos(1), "must be argument names") expect_error(enquos("foo"), "must be argument names") expect_error(enexprs(foo(bar)), "must be argument names") expect_error(enexprs(1), "must be argument names") expect_error(enexprs("foo"), "must be argument names") }) test_that("endots() returns a named list", { # enquos() fn <- function(foo, bar) enquos(foo, bar) expect_identical(names(fn()), c("", "")) fn <- function(arg, ...) enquos(other = arg, ...) expect_identical(fn(arg = 1, b = 2), quos(other = 1, b = 2)) # enexprs() fn <- function(foo, bar) enexprs(foo, bar) expect_identical(names(fn()), c("", "")) fn <- function(arg, ...) enexprs(other = arg, ...) expect_identical(fn(arg = 1, b = 2), exprs(other = 1, b = 2)) }) test_that("endots() captures missing arguments", { # enquos() fn <- function(foo) enquos(foo)[[1]] expect_identical(fn(), quo()) fn <- function(...) enquos(...) expect_identical(fn(), quos()) # enexprs() fn <- function(foo) enexprs(foo)[[1]] expect_identical(fn(), expr()) fn <- function(...) enexprs(...) expect_identical(fn(), exprs()) }) test_that("endots() supports `.named`", { # enquos() fn <- function(arg, ...) enquos(arg, ..., .named = TRUE) expect_identical(fn(foo, bar), quos(foo = foo, bar = bar)) # enexprs() fn <- function(arg, ...) enexprs(arg, ..., .named = TRUE) expect_identical(fn(foo, bar), exprs(foo = foo, bar = bar)) }) test_that("endots() supports `.unquote_names`", { # enquos() fn <- function(...) enquos(..., .unquote_names = TRUE) expect_identical(fn(!!"foo" := bar), quos(foo = bar)) fn <- function(...) enquos(..., .unquote_names = FALSE) expect_identical(fn(!!"foo" := bar), quos(!!"foo" := bar, .unquote_names = FALSE)) # enexprs() fn <- function(...) enexprs(..., .unquote_names = TRUE) expect_identical(fn(!!"foo" := bar), exprs(foo = bar)) fn <- function(...) enexprs(..., .unquote_names = FALSE) expect_identical(fn(!!"foo" := bar), exprs(!!"foo" := bar, .unquote_names = FALSE)) }) test_that("endots() supports `.ignore_empty`", { # enquos() fn <- function(...) enquos(..., .ignore_empty = "all") expect_identical(fn(, ), quos()) fn <- function(...) enquos(..., .ignore_empty = "trailing") expect_identical(fn(foo, ), quos(foo)) # enexprs() fn <- function(...) enexprs(..., .ignore_empty = "all") expect_identical(fn(, ), exprs()) fn <- function(...) enexprs(..., .ignore_empty = "trailing") expect_identical(fn(foo, ), exprs(foo)) }) test_that("endots() supports `.ignore_null` (#1450)", { # enquos() fn <- function(...) enquos(..., .ignore_null = "all") expect_identical(fn(NULL, NULL), quos()) expect_identical(fn(foo = NULL, NULL), quos(foo = NULL)) expect_identical(fn(!!!list(foo = NULL), NULL), quos(foo = NULL)) fn <- function(foo, ...) enquos(foo, ..., .ignore_null = "all") expect_identical(fn(NULL, NULL), quos()) fn <- function(...) enquos(...) expect_identical(fn(NULL, NULL), quos(NULL, NULL)) # enexprs() fn <- function(...) enexprs(..., .ignore_null = "all") expect_identical(fn(NULL, NULL), exprs()) fn <- function(...) enexprs(...) expect_identical(fn(NULL, NULL), exprs(NULL, NULL)) }) test_that("ensyms() captures multiple symbols", { fn <- function(arg, ...) ensyms(arg, ...) expect_identical(fn(foo, bar, baz), exprs(foo, bar, baz)) expect_snapshot(err(fn(foo()))) }) test_that("enquos() works with lexically scoped dots", { capture <- function(...) { eval_bare(quote(enquos(...)), child_env(env())) } expect_identical(capture("foo"), quos_list(quo("foo"))) }) test_that("enquo() works with lexically scoped arguments", { capture <- function(arg) { eval_bare(quote(enquo(arg)), child_env(env())) } expect_identical(capture(foo), quo(foo)) }) test_that("closures are captured with their calling environment", { expect_reference(quo_get_env(quo(!!function() NULL)), environment()) }) test_that("the missing argument is captured", { expect_equal_( quos(!!missing_arg(), .ignore_empty = "none"), quos(, ), ignore_formula_env = TRUE ) fn <- function(x) { g(!!enquo(x)) } g <- function(...) { quos(...) } expect_equal_( fn(), quos(!!missing_arg()), ignore_formula_env = TRUE ) }) test_that("missing names are forwarded", { x <- set_names(1:2, c(NA, NA)) expect_identical_(names(exprs(!!!x)), chr(na_chr, na_chr)) }) test_that("auto-naming uses type_sum() (#573)", { expect_named(quos(foo, !!(1:3), .named = TRUE), c("foo", "")) x <- list(env(), 1:3, letters) expect_named(exprs_auto_name(x), c("", "", "")) }) test_that("auto-naming supports the .data pronoun", { exprs <- exprs(.data[[toupper("foo")]], .data$bar, .named = TRUE) expect_named(exprs, c("FOO", "bar")) }) test_that("enexprs() and enquos() support `.ignore_empty = 'all'` (#414)", { myexprs <- function(what, x, y) enexprs(x = x, y = y, .ignore_empty = what) expect_identical(myexprs("none"), exprs(x = , y = )) expect_identical(myexprs("trailing"), exprs(x = , y = )) expect_identical(myexprs("all"), exprs()) myquos <- function(what, x, y) enquos(x = x, y = y, .ignore_empty = what) expect_identical(myquos("none"), quos(x = , y = )) expect_identical(myquos("trailing"), quos(x = , y = )) expect_identical(myquos("all"), quos()) }) test_that("`enquos()` does not discard named missing arguments (#1229)", { fn <- function(...) enquos(..., .ignore_empty = "all") expect_equal( fn(x = ), quos(x = ) ) expect_equal( fn(, foo), quos(foo) ) }) test_that("enexprs() and enquos() support empty dots", { myexprs <- function(what, ...) enexprs(..., .ignore_empty = what) expect_identical(myexprs("none"), exprs()) expect_identical(myexprs("trailing"), exprs()) expect_identical(myexprs("all"), exprs()) myquos <- function(what, ...) enquos(..., .ignore_empty = what) expect_identical(myquos("none"), quos()) expect_identical(myquos("trailing"), quos()) expect_identical(myquos("all"), quos()) }) test_that("supplying `!!!` with a name warns", { local_options(lifecycle_verbosity = "warning") expect_no_warning_(quos(!!!1, 2, !!!NULL)) expect_defunct(quos(foo = !!!1, 2, bar = !!!NULL), "Only the operand's names are retained") }) test_that("ensym() unwraps quosures", { fn <- function(arg) ensym(arg) expect_identical(fn(!!quo(foo)), quote(foo)) expect_identical(fn(!!quo("foo")), quote(foo)) expect_snapshot(err(fn(!!quo(foo())))) }) test_that("ensyms() unwraps quosures", { fn <- function(...) ensyms(...) expect_identical(fn(!!!quos(foo, "bar")), exprs(foo, bar)) expect_snapshot(err(fn(!!!quos(foo, bar())))) }) test_that("enquo0() and enquos0() capture arguments without injection", { fn <- function(arg) enquo0(arg) expect_equal( fn(foo(!!1)), quo(foo(!!quote(!!1))) ) fn <- function(...) enquos0(...) expect_equal_( fn(x = foo(!!1), !!!1:3, z = 3), list(x = quo(foo(!!quote(!!1))), quo(!!quote(!!!1:3)), z = quo(3)) ) }) test_that("enquo0() and enquos0() don't rewrap quosures", { fn <- function(arg) enquo0(arg) quo <- local(quo(x)) expect_equal(fn(!!quo), quo) fn <- function(...) enquos0(...) quo <- local(quo(x)) expect_equal(fn(!!quo), list(quo)) }) test_that("enquo() defuses numbered dots (#1137)", { f <- function(arg) enquo(..1) expect_error( f(foo), "'...' used in an incorrect context" ) f <- function(...) enquo(..1) expect_error( f(), "fewer than 1" ) f <- function(...) enquo(..2) expect_error( f(1), "fewer than 2" ) }) test_that("enquos() defuses numbered dots (#1137)", { f <- function(...) enquos(...) g <- function(...) f(..1) expect_equal( g(foo), quos(foo) ) f <- function(...) enquos(...) g <- function(...) f(..1, ..2) h <- function(...) g(..1, ...) expect_equal( h(foo, bar), quos(foo, foo) ) g <- function(...) f(..1, ..3) expect_equal( h(foo, bar), quos(foo, bar) ) g <- function(...) f(..1, ..4) expect_error( h(foo, bar), "fewer than 4 elements" ) }) test_that("`defer()` does not crash with environments containing quosures (#1085)", { f <- function() { withr::defer(2) dots <- quos(integer(1)) quo(c(!!!dots)) } expect_no_error(f()) # No crash }) test_that("auto-named expressions can be unique-repaired", { dots_names <- function(...) { dots <- enquos(...) dots <- exprs_auto_name(dots, repair_auto = "unique") names(dots) } expect_snapshot({ expect_equal( dots_names(1, foo = 1, 1, foo = 2), c("1...1", "foo", "1...3", "foo") ) expect_equal( dots_names(bar, foo = 1, bar, foo = 2), c("bar...1", "foo", "bar...3", "foo") ) }) }) test_that("can capture forced numbered dot", { fn <- function(..., x = ..1) { force(x) enquo(x) } expect_equal(fn(1 + 1), quo(2)) }) test_that("`enexprs()` and variants support `.named = NULL` (#1223)", { fn <- function(...) enexprs(..., .named = NULL) expect_equal(fn(), list()) expect_equal(fn(1), list(1)) expect_equal(fn(x = 1), list(x = 1)) fn <- function(...) enquos(..., .named = NULL) expect_equal(fn(), unname(quos())) expect_equal(fn(1), unname(quos(1))) expect_equal(fn(x = 1), quos(x = 1)) }) test_that("`.named = NULL` yields `NULL` names (#1505)", { fn <- function() enquos(.named = NULL) expect_null(names(fn())) fn <- function(...) enquos(..., .named = NULL) expect_null(names(fn())) expect_null(names(fn(foo))) expect_null(names(quos(.named = NULL))) expect_null(names(quos(foo, .named = NULL))) }) test_that("embraced empty arg are detected consistently (#1421)", { fn_quos <- function(cond, ...) { quos_it({{cond}}, ...) } fn_enquos <- function(cond, ...) { enquos_it({{cond}}, ...) } quos_it <- function(..., .ignore_empty = "all") { quos(..., .ignore_empty = .ignore_empty) } enquos_it <- function(..., .ignore_empty = "all") { enquos(..., .ignore_empty = .ignore_empty) } expect_equal(fn_quos(), quos()) expect_equal(fn_enquos(), quos()) expect_equal(fn_quos(.ignore_empty = "trailing"), quos()) expect_equal(fn_enquos(.ignore_empty = "trailing"), quos()) }) rlang/tests/testthat/test-eval.R0000644000176200001440000000136514127057575016430 0ustar liggesusers test_that("supports tidy dots", { expect_equal(exec(list, x = 1), list(x = 1)) args <- list(x = 1) expect_equal(exec(list, !!!args), list(x = 1)) expect_equal(exec(list, !!!args, y = 2), list(x = 1, y = 2)) }) test_that("does not inline expressions", { expect_equal(exec(list, x = expr(x), y = expr(y)), exprs(x = x, y = y)) }) test_that("inject() injects", { expect_equal_( inject(quote(foo(!!(1:2), !!!1:3))), call2("foo", 1:2, !!!1:3) ) g <- function(x) substitute(x) f <- function(x) inject(g({{ x }})) expect_equal( f(foo()), quo(foo()) ) }) test_that("inject() and eval_bare() propagate visibility", { expect_invisible(eval_bare(quote(invisible(list())))) expect_invisible(inject(invisible(list()))) }) rlang/tests/testthat/test-deprecated.R0000644000176200001440000001444414516466714017604 0ustar liggesusers# Deprecated in rlang 0.4.0 ------------------------------------------ test_that("type_of() returns correct type", { local_lifecycle_silence() expect_identical(type_of("foo"), "string") expect_identical(type_of(letters), "character") expect_identical(type_of(base::`$`), "primitive") expect_identical(type_of(base::list), "primitive") expect_identical(type_of(base::eval), "closure") expect_identical(type_of(~foo), "formula") expect_identical(type_of(quo(foo)), "formula") expect_identical(type_of(quote(foo())), "language") }) test_that("Unicode escapes are converted to UTF8 characters in env_names()", { skip_if_no_utf8_marker() local_lifecycle_silence() with_non_utf8_locale({ env <- child_env(empty_env()) env_bind(env, !!get_alien_lang_string() := NULL) nms <- env_names(env) expect_identical(nms, get_alien_lang_string()) }) }) test_that("no method dispatch", { local_lifecycle_silence() as.logical.foo <- function(x) "wrong" expect_identical(as_integer(structure(TRUE, class = "foo")), 1L) as.list.foo <- function(x) "wrong" expect_identical(as_list(structure(1:10, class = "foo")), as.list(1:10)) }) test_that("input is left intact", { local_lifecycle_silence() x <- structure(TRUE, class = "foo") y <- as_integer(x) expect_identical(x, structure(TRUE, class = "foo")) }) test_that("as_list() zaps attributes", { local_lifecycle_silence() expect_identical(as_list(structure(list(), class = "foo")), list()) }) test_that("as_list() only coerces vector or dictionary types", { local_lifecycle_silence() expect_identical(as_list(1:3), list(1L, 2L, 3L)) expect_error(as_list(quote(symbol)), "a symbol to") }) test_that("as_list() bypasses environment method and leaves input intact", { local_lifecycle_silence() as.list.foo <- function(x) "wrong" x <- structure(child_env(NULL), class = "foo") y <- as_list(x) expect_s3_class(x, "foo") expect_identical(y, set_names(list(), character(0))) }) test_that("as_integer() and as_logical() require integerish input", { local_lifecycle_silence() expect_error(as_integer(1.5), "a fractional double vector to") expect_error(as_logical(1.5), "a fractional double vector to") }) test_that("names are preserved", { local_lifecycle_silence() nms <- as.character(1:3) x <- set_names(1:3, nms) expect_identical(names(as_double(x)), nms) expect_identical(names(as_list(x)), nms) }) test_that("as_character() support logical NA", { local_lifecycle_silence() expect_identical(as_character(NA), na_chr) expect_identical(as_character(lgl(NA, NA)), c(na_chr, na_chr)) }) test_that("can convert strings (#138)", { local_lifecycle_silence() expect_identical(as_character("a"), "a") expect_identical(as_list("a"), list("a")) }) # -------------------------------------------------------------------- test_that("set_attrs() fails with uncopyable types", { local_lifecycle_silence() expect_error(set_attrs(env(), foo = "bar"), "is uncopyable") }) test_that("set_attrs() called with NULL zaps attributes", { local_lifecycle_silence() obj <- set_attrs(letters, foo = "bar") expect_identical(set_attrs(obj, NULL), letters) }) test_that("set_attrs() does not zap old attributes", { local_lifecycle_silence() obj <- set_attrs(letters, foo = "bar") obj <- set_attrs(obj, baz = "bam") expect_named(attributes(obj), c("foo", "baz")) }) test_that("invoke() buries arguments", { local_lifecycle_silence() expect_identical(invoke(call_inspect, 1:2, 3L), quote(.fn(`1`, `2`, `3`))) expect_identical(invoke("call_inspect", 1:2, 3L), quote(call_inspect(`1`, `2`, `3`))) expect_identical(invoke(call_inspect, 1:2, 3L, .bury = c("foo", "bar")), quote(foo(`bar1`, `bar2`, `bar3`))) expect_identical(invoke(call_inspect, 1:2, 3L, .bury = NULL), as.call(list(call_inspect, 1L, 2L, 3L))) }) test_that("invoke() can be called without arguments", { local_lifecycle_silence() expect_identical(invoke("list"), list()) expect_identical(invoke(list), list()) }) test_that("quo_expr() still works", { local_lifecycle_silence() x <- quo(foo(!!quo(bar), !!local(quo(baz)))) expect_identical(quo_expr(x), quo_squash(x)) }) test_that("call_fn() extracts function", { local_lifecycle_silence() expect_identical(call_fn(~matrix()), matrix) }) test_that("call_fn() looks up function in `env`", { local_lifecycle_silence() env <- local({ fn <- function() "foo" current_env() }) expect_identical(call_fn(quote(fn()), env = env), env$fn) }) test_that("with_handlers() establishes inplace and exiting handlers", { local_lifecycle_silence() handlers <- list( error = function(c) "caught error", message = function(c) "caught message", warning = calling(function(c) "warning"), foobar = calling(function(c) cat("foobar")) ) expect_equal(with_handlers(identity(letters), !!!handlers), identity(letters)) expect_equal(with_handlers(stop(letters), !!!handlers), "caught error") expect_equal(with_handlers(message(letters), !!!handlers), "caught message") expect_warning(expect_equal(with_handlers({ warning("warn!"); letters }, !!!handlers), identity(letters)), "warn!") expect_output(expect_equal(with_handlers({ signal("", "foobar"); letters }, !!!handlers), identity(letters)), "foobar") }) test_that("with_handlers() propagates visibility", { local_lifecycle_silence() expect_visible(with_handlers(list(invisible(1)))) expect_invisible(with_handlers(invisible(1))) }) test_that("bare functions are treated as exiting handlers", { local_lifecycle_silence() expect_identical(with_handlers(abort("foo"), error = function(cnd) "caught"), "caught") }) test_that("with_handlers() supports formula shortcut for lambdas", { local_lifecycle_silence() err <- with_handlers(abort("foo", "bar"), error = ~.x) expect_true(inherits(err, "bar")) }) test_that("can muffle conditions", { local_lifecycle_silence() expect_no_message( expect_identical(with_handlers({ message(""); "foo" }, message = calling(cnd_muffle)), "foo") ) expect_no_warning( expect_identical(with_handlers({ warning(""); "foo" }, warning = calling(cnd_muffle)), "foo") ) cnd_expect_muffle <- calling(function(cnd) { expect_s3_class(findRestart("rlang_muffle"), "restart") cnd_muffle(cnd) }) expect_identical(with_handlers({ signal("", "cnd"); "foo" }, cnd = cnd_expect_muffle), "foo") }) rlang/tests/testthat/test-fn.R0000644000176200001440000002421614741441060016070 0ustar liggesuserstest_that("new_function equivalent to regular function", { f1 <- function(x = a + b, y) { x + y } attr(f1, "srcref") <- NULL f2 <- new_function(alist(x = a + b, y =), quote({x + y})) expect_equal(f1, f2) env <- current_env() expect_true(is_reference(fn_env(f2), env)) }) test_that("prim_name() extracts names", { expect_equal(prim_name(c), "c") expect_equal(prim_name(prim_eval), "eval") }) test_that("as_closure() returns closure", { expect_identical(typeof(as_closure(base::list)), "closure") expect_identical(typeof(as_closure("list")), "closure") }) test_that("as_closure() handles primitive functions", { expect_identical(as_closure(`c`)(1, 3, 5), c(1, 3, 5)) expect_identical(as_closure(is.null)(1), FALSE) expect_identical(as_closure(is.null)(NULL), TRUE) }) test_that("as_closure() supports base-style and purrr-style arguments to binary operators", { and <- as_closure(`&&`) expect_error(and(), "Must supply `e1` or `.x` to binary operator") expect_error(and(TRUE), "Must supply `e2` or `.y` to binary operator") expect_error(and(.x = TRUE, e1 = TRUE), "Can't supply both `e1` and `.x` to binary operator") expect_error(and(TRUE, .y = TRUE, e2 = TRUE), "Can't supply both `e2` and `.y` to binary operator") expect_identical(and(FALSE, FALSE), FALSE) expect_identical(and(TRUE, FALSE), FALSE) expect_identical(and(FALSE, TRUE), FALSE) expect_identical(and(TRUE, TRUE), TRUE) expect_identical(and(.y = FALSE, TRUE), FALSE) expect_identical(and(e2 = FALSE, TRUE), FALSE) expect_identical(and(.y = FALSE, e1 = TRUE), FALSE) expect_identical(and(e2 = FALSE, .x = TRUE), FALSE) expect_identical(and(.y = FALSE, TRUE), FALSE) expect_identical(and(e2 = FALSE, TRUE), FALSE) }) test_that("as_closure() supports base-style and purrr-style arguments to versatile operators", { minus <- as_closure(`-`) expect_error(minus(), "Must supply `e1` or `.x` to binary operator") expect_error(minus(.y = 3), "Must supply `e1` or `.x` to binary operator") expect_error(minus(.x = 3, e1 = 1), "Can't supply both `e1` and `.x` to binary operator") expect_error(minus(0, .y = 3, e2 = 1), "Can't supply both `e2` and `.y` to binary operator") expect_identical(minus(3), -3) expect_identical(minus(e1 = 3), -3) expect_identical(minus(.x = 3), -3) expect_identical(minus(1, 3), -2) expect_identical(minus(3, 1), 2) expect_identical(minus(.y = 3, 1), -2) expect_identical(minus(e2 = 3, 1), -2) expect_identical(minus(.y = 3, e1 = 1), -2) expect_identical(minus(e2 = 3, .x = 1), -2) expect_identical(minus(.y = 1, 3), 2) expect_identical(minus(e2 = 1, 3), 2) }) test_that("as_closure(`||`) shortcircuits", { or <- as_closure(`||`) expect_error(or(), "Must supply `e1` or `.x` to binary operator") expect_error(or(FALSE), "Must supply `e2` or `.y` to binary operator") expect_identical(or(TRUE), TRUE) expect_identical(or(.x = TRUE), TRUE) expect_identical(or(e1 = TRUE), TRUE) }) test_that("as_closure() handles operators", { expect_identical(as_closure(`-`)(.y = 10, .x = 5), -5) expect_identical(as_closure(`-`)(5), -5) expect_identical(as_closure(`$`)(mtcars, cyl), mtcars$cyl) expect_identical(as_closure(`~`)(foo), ~foo) expect_identical(as_closure(`~`)(foo, bar), foo ~ bar) expect_warning(expect_identical(as_closure(`{`)(warn("foo"), 2, 3), 3), "foo") x <- "foo" as_closure(`<-`)(x, "bar") expect_identical(x, "bar") x <- list(a = 1, b = 2) as_closure(`$<-`)(x, b, 20) expect_identical(x, list(a = 1, b = 20)) x <- list(1, 2) as_closure(`[[<-`)(x, 2, 20) expect_identical(x, list(1, 20)) x <- data.frame(x = 1:2, y = 3:4) expect_identical(as_closure(`[<-`)(x, 2, 2, 10L), 10L) expect_identical(x, data.frame(x = 1:2, y = c(3L, 10L))) expect_error(as_closure(`[<-`)(), "Must supply operands") methods::setClass("rlang_test", methods::representation(foo = "character")) s4 <- methods::new("rlang_test") as_closure(`@<-`)(s4, "foo", "FOO") expect_identical(s4@foo, "FOO") x <- list(1, 2) expect_identical(as_closure(`[[<-`)(x, 2, 20), 20) expect_identical(x, list(1, 20)) x <- list2(list2(a = "A"), list2(a = "B")) expect_identical(lapply(x, as_closure(`[[`), "a"), list("A", "B")) }) test_that("lambda shortcut handles positional arguments", { expect_identical(as_function(~ ..1 + ..3)(1, 2, 3), 4) }) test_that("lambda shortcut fails with two-sided formulas", { expect_error(as_function(lhs ~ ..1 + ..3), "two-sided formula") }) test_that("as_function() handles strings", { expect_identical(as_function("mean"), mean) env <- env(fn = function() NULL) expect_identical(as_function("fn", env), env$fn) }) test_that("fn_fmls_syms() unnames `...`", { expect_identical(fn_fmls_syms(lapply), list(X = quote(X), FUN = quote(FUN), quote(...))) }) test_that("fn_fmls_syms() works with functions of zero arguments", { expect_identical(fn_fmls_syms(function() NULL), list()) }) test_that("as_closure() gives informative error messages on control flow primitives (#158)", { expect_error(as_closure(`if`), "Can't coerce the primitive function `if`") }) test_that("fn_fmls<- and fn_fmls_names<- change formals", { fn <- function() NULL fn_fmls(fn) <- list(a = 1) expect_identical(fn_fmls(fn), pairlist(a = 1)) fn_fmls_names(fn) <- c("b") expect_identical(fn_fmls(fn), pairlist(b = 1)) }) test_that("fn_ functions requires closures", { msg <- "must be an R function, not a primitive function" expect_error(fn_fmls(`+`), msg) expect_error(fn_fmls_names(`+`), msg) expect_error(fn_fmls_syms(`+`), msg) expect_error(fn_fmls(`+`) <- list(a = 1, b = 2), msg) expect_error(fn_fmls_names(`+`) <- c("A", "B"), msg) }) test_that("assignment methods preserve attributes", { orig <- structure(function(foo) NULL, foo = "foo", bar = "bar") fn <- orig fn_fmls(fn) <- list(arg = 1) expect_identical(attributes(fn), attributes(orig)) fn <- orig fn_fmls_names(fn) <- "bar" expect_identical(attributes(fn), attributes(orig)) fn <- orig fn_body(fn) <- "body" orig_attrs <- attributes(orig) orig_attrs$srcref <- NULL expect_identical(attributes(fn), orig_attrs) }) test_that("fn_body() requires a closure to extract body", { expect_error(fn_body(c), "`fn` must be an R function") expect_equal(fn_body(function() { NULL }), quote({ NULL })) expect_equal(fn_body(function() NULL), quote({ NULL })) }) test_that("fn_env() requires a function to extract env", { expect_error(fn_env(1L), "`fn` must be a function") expect_identical(fn_env(function() NULL), current_env()) }) test_that("`fn_env<-`() sets environment", { fn <- function() NULL fn_env(fn) <- base_env() expect_reference(fn_env(fn), base_env()) }) test_that("primitive predicates work", { expect_true(is_primitive_eager(c)) expect_true(is_primitive_lazy(`$`)) expect_false(is_primitive_eager(`$`)) expect_false(is_primitive_lazy(`c`)) }) test_that("quosures converted to functions ignore their arguments", { fn <- as_function(quo("foo")) expect_no_error(expect_identical(fn(NULL), "foo")) }) test_that("as_function() supports nested quosures", { quo <- local({ lhs <- "quux" rhs <- local({ rhs <- "hunoz"; quo(rhs) }) quo(paste(lhs, !!rhs)) }) fn <- as_function(quo) expect_identical(fn(), "quux hunoz") }) test_that("fn_body() always returns a `{` block", { expect_equal(fn_body(function() "foo"), quote({ "foo" })) }) test_that("as_function() adds a class to lambda functions", { out <- as_function(~foo) expect_s3_class(out, c("rlang_lambda_function", "function")) expect_output(print(out), "") }) test_that("fn_env() returns base namespace for primitives", { expect_reference(fn_env(base::list), ns_env("base")) }) test_that("as_closure() wrappers dispatch properly", { local_bindings(.env = global_env(), as.character.foobar = function(...) "dispatched!" ) x <- structure(list(), class = "foobar") expect_identical(as_closure(as.character)(x), "dispatched!") }) test_that("as_closure() wrappers are not masked", { wrapper <- as_closure(as.character) as.character <- function(...) abort("tilt") expect_identical(wrapper(1), "1") wrapper <- as_closure(as.character) expect_error(wrapper(1), "tilt") }) test_that("arguments of closured primitives are matched by name before `...` (tidyverse/purrr#411)", { expect_false(as_closure(isS4)("foo")) }) test_that("arguments of closured primitives are matched by name after `...`", { fn <- as_closure(min) expect_true(is_na(fn(1, NA))) expect_identical(fn(na.rm = TRUE, 1, NA), 1) }) test_that("transforming defused formula to function causes an informative error (#953)", { expect_error(as_function(quote(~foo)), "must carry an environment") }) test_that("functions created from quosures with as_function() print properly", { fn <- as_function(quo(x)) expect_equal(body(fn), quote(x)) }) test_that("as_function() creates functions that respect visibility", { f <- as_function(quo(invisible(1))) expect_invisible(f()) f <- as_function(quo(1)) expect_visible(f()) f <- as_function(~ invisible(1)) expect_invisible(f()) f <- as_function(~ 1) expect_visible(f()) }) test_that("as_function() with a quosure can be serialised", { fn <- as_function(local({ a <- 10; quo(a) })) blob <- serialize(fn, NULL) expect_equal( eval_tidy(fn), eval_tidy(unserialize(blob)), ignore_function_env = TRUE ) }) test_that("as_function() fetches from the global env", { foo <- function() NULL local_bindings( .env = global_env(), foo = function() "foo" ) expect_equal(as_function("foo")(), "foo") }) test_that("as_function() has nice errors", { my_function <- function(my_arg) { as_function(my_arg) } expect_snapshot({ (expect_error(as_function(1))) (expect_error(as_function(1, arg = "foo"))) (expect_error(my_function(1 + 2))) (expect_error(my_function(1))) (expect_error(my_function(a ~ b))) }) }) test_that("check inputs in function accessors", { expect_snapshot({ (expect_error(fn_fmls(1))) (expect_error(fn_body(1))) (expect_error(fn_env(1))) }) }) test_that("closure wrapper of seq.int() works (#1468)", { seq_int <- as_closure(seq.int) expect_equal(seq_int(1), 1) expect_equal(seq_int(1, 2), 1:2) expect_equal(seq_int(1, 2, 2), 1) }) rlang/tests/testthat/test-names.R0000644000176200001440000000771514375670676016621 0ustar liggesuserslocal_options(rlib_message_verbosity = "quiet") test_that("unique_names() handles unnamed vectors", { expect_equal(names_as_unique(names2(1:3)), c("...1", "...2", "...3")) }) test_that("names_as_unique() is a no-op when no repairs are needed", { x <- c("x", "y") out <- names_as_unique(x) expect_true(is_reference(out, x)) expect_equal(out, c("x", "y")) }) test_that("names_as_unique() eliminates emptiness and duplication", { expect_equal( names_as_unique(c("", "x", "y", "x")), c("...1", "x...2", "y", "x...4") ) expect_equal( names_as_unique(c("1", "foo", "1")), c("1...1", "foo", "1...3") ) }) test_that("names_as_unique(): solo empty or NA gets suffix", { expect_equal(names_as_unique(""), "...1") expect_equal(names_as_unique(NA_character_), "...1") }) test_that("names_as_unique() treats ellipsis like empty string", { expect_equal(names_as_unique("..."), names_as_unique("")) }) test_that("two_three_dots() does its job and no more", { two_to_three_dots <- function(names) { sub("(^[.][.][1-9][0-9]*$)", ".\\1", names) } x <- c(".", ".1", "...1", "..1a") expect_equal(two_to_three_dots(x), x) expect_equal(two_to_three_dots(c("..1", "..22")), c("...1", "...22")) }) test_that("two dots then number treated like three dots then number", { expect_equal(names_as_unique("..2"), names_as_unique("...5")) }) test_that("names_as_unique() strips positional suffixes, re-applies as needed", { x <- c("...20", "a...1", "b", "", "a...2...34") expect_equal(names_as_unique(x), c("...1", "a...2", "b", "...4", "a...5")) expect_equal(names_as_unique("a...1"), "a") expect_equal(names_as_unique(c("a...2", "a")), c("a...1", "a...2")) expect_equal(names_as_unique(c("a...3", "a", "a")), c("a...1", "a...2", "a...3")) expect_equal(names_as_unique(c("a...2", "a", "a")), c("a...1", "a...2", "a...3")) expect_equal(names_as_unique(c("a...2", "a...2", "a...2")), c("a...1", "a...2", "a...3")) }) test_that("names_as_unique() is idempotent", { x <- c("...20", "a...1", "b", "", "a...2") expect_equal(names_as_unique(!!x), names_as_unique(names_as_unique(!!x))) }) test_that("unique-ification has an 'algebraic'-y property", { x <- c("...20", "a...1", "b", "", "a...2", "d") y <- c("", "a...3", "b", "...3", "e") ## Fix names on each, catenate, fix the whole z1 <- names_as_unique(c(names_as_unique(x), names_as_unique(y))) ## Fix names on x, catenate, fix the whole z2 <- names_as_unique(c(names_as_unique(x), y)) ## Fix names on y, catenate, fix the whole z3 <- names_as_unique(c(x, names_as_unique(y))) ## Catenate, fix the whole z4 <- names_as_unique(c(x, y)) expect_equal(z1, z2) expect_equal(z1, z3) expect_equal(z1, z4) }) test_that("names_as_unique() are verbose or silent", { local_options(rlib_message_verbosity = "default") expect_message(names_as_unique(c("", "")), "-> `...1`", fixed = TRUE) expect_message(regexp = NA, names_as_unique(c("", ""), quiet = TRUE)) }) test_that("names with only duplicates are repaired", { expect_equal(names_as_unique(c("x", "x")), c("x...1", "x...2")) }) test_that("names_as_unique() handles encodings", { x <- unname(unlist(encodings()[c("utf8", "latin1")])) out <- names_as_unique(x) expect_equal(out, paste0(rep(x[[1]], 2), "...", 1:2)) expect_equal(Encoding(out), c("UTF-8", "UTF-8")) }) test_that("names_inform_repair() signals classed messages", { local_options(rlib_message_verbosity = "default") expect_message(names_inform_repair("x", "y"), class = "rlib_message_name_repair") }) test_that("names_inform_repair() can be silenced by `rlib_name_repair_verbosity`", { local_options(rlib_message_verbosity = "default", rlib_name_repair_verbosity = "quiet") expect_message(names_inform_repair("x", "y"), NA) }) test_that("`rlib_name_repair_verbosity` is validated", { local_options(rlib_name_repair_verbosity = 1) expect_error(peek_name_repair_verbosity()) local_options(rlib_name_repair_verbosity = "qu") expect_error(peek_name_repair_verbosity()) }) rlang/tests/testthat/test-nse-inject.R0000644000176200001440000006734414741441060017535 0ustar liggesuserstest_that("interpolation does not recurse over spliced arguments", { var2 <- quote({foo; !! stop(); bar}) expr_var2 <- tryCatch(expr(list(!!! var2)), error = identity) expect_false(inherits(expr_var2, "error")) }) test_that("formulas containing unquote operators are interpolated", { var1 <- quo(foo) var2 <- local({ foo <- "baz"; quo(foo) }) f <- expr_interp(~list(!!var1, !!var2)) expect_identical(f, new_formula(NULL, call2("list", as_quosure(var1), as_quosure(var2)))) }) test_that("interpolation is carried out in the right environment", { f <- local({ foo <- "foo"; ~!!foo }) expect_identical(expr_interp(f), new_formula(NULL, "foo", env = f_env(f))) }) test_that("interpolation now revisits unquoted formulas", { f <- ~list(!!~!!stop("should not interpolate within formulas")) f <- expr_interp(f) # This used to be idempotent: expect_error(expect_false(identical(expr_interp(f), f)), "interpolate within formulas") }) test_that("formulas are not treated as quosures", { expect_identical(expr(a ~ b), quote(a ~ b)) expect_identical(expr(~b), quote(~b)) expect_identical(expr(!!~b), ~b) }) test_that("unquote operators are always in scope", { env <- child_env("base", foo = "bar") f <- with_env(env, ~(!!foo)) expect_identical(expr_interp(f), new_formula(NULL, "bar", env)) }) test_that("can interpolate in specific env", { foo <- "bar" env <- child_env(NULL, foo = "foo") expanded <- expr_interp(~!!foo) expect_identical(expanded, set_env(~"bar")) expanded <- expr_interp(~!!foo, env) expect_identical(expanded, set_env(~"foo")) }) test_that("can qualify operators with namespace", { expect_identical(quo(other::UQ(toupper("a"))), quo(other::"A")) expect_identical(quo(x$UQ(toupper("a"))), quo(x$"A")) }) test_that("unquoting is frame-consistent", { defun <- quote(!! function() NULL) env <- child_env("base") expect_identical(fn_env(expr_interp(defun, env)), env) }) test_that("unquoted quosure has S3 class", { quo <- quo(!! ~quo) expect_s3_class(quo, "quosure") }) test_that("unquoted quosures are not guarded", { quo <- eval_tidy(quo(quo(!! ~quo))) expect_true(is_quosure(quo)) }) # !! ---------------------------------------------------------------------- test_that("`!!` binds tightly", { expect_identical_(expr(!!1 + 2 + 3), quote(1 + 2 + 3)) expect_identical_(expr(1 + !!2 + 3), quote(1 + 2 + 3)) expect_identical_(expr(1 + 2 + !!3 + 4), quote(1 + 2 + 3 + 4)) expect_identical_(expr(1 + !!(2) + 3), quote(1 + 2 + 3)) expect_identical_(expr(1 + 2 + !!3), quote(1 + 2 + 3)) expect_identical_(expr(1 + !!2 * 3), quote(1 + 2 * 3)) expect_identical_(expr(1 + !!2 * 3 + 4), quote(1 + 2 * 3 + 4)) expect_identical_(expr(1 * !!2:!!3 + 4), quote(1 * 2:3 + 4)) expect_identical_(expr(1 + 2 + !!3 * 4 + 5 + 6), quote(1 + 2 + 3 * 4 + 5 + 6)) expect_identical_(expr(1 + 2 * 3 : !!4 + 5 * 6 + 7), quote(1 + 2 * 3 : 4 + 5 * 6 + 7)) expect_identical_(expr(1 + 2 * 3 : !!4 + 5 * 6 + 7 * 8 : !!9 + 10 * 11), quote(1 + 2 * 3 : 4 + 5 * 6 + 7 * 8 : 9 + 10 * 11)) expect_identical_(expr(!!1 + !!2 * !!3:!!4 + !!5 * !!6 + !!7 * !!8:!!9 + !!10 * !!11), quote(1 + 2 * 3 : 4 + 5 * 6 + 7 * 8 : 9 + 10 * 11)) expect_identical_(expr(!!1 + !!2 + !!3 + !!4), quote(1 + 2 + 3 + 4)) expect_identical_(expr(!!1 + !!2 * !!3), quote(1 + 2 * 3)) # Local roots expect_identical_(expr(!!1 + !!2 * !!3 * !!4), quote(1 + 2 * 3 * 4)) expect_identical_(expr(1 == 2 + !!3 + 4), quote(1 == 2 + 3 + 4)) expect_identical_(expr(!!1 == !!2 + !!3 + !!4 + !!5 * !!6 * !!7), quote(1 == 2 + 3 + 4 + 5 * 6 * 7)) expect_identical_(expr(1 + 2 * 3:!!4:5), quote(1 + 2 * 3:4:5)) expect_identical_(expr(!!1 == !!2), quote(1 == 2)) expect_identical_(expr(!!1 <= !!2), quote(1 <= 2)) expect_identical_(expr(!!1 >= !!2), quote(1 >= 2)) expect_identical_(expr(!!1 * 2 != 3), quote(1 * 2 != 3)) expect_identical_(expr(!!1 * !!2 / !!3 > !!4), quote(1 * 2 / 3 > 4)) expect_identical_(expr(!!1 * !!2 > !!3 + !!4), quote(1 * 2 > 3 + 4)) expect_identical_(expr(1 <= !!2), quote(1 <= 2)) expect_identical_(expr(1 >= !!2 : 3), quote(1 >= 2 : 3)) expect_identical_(expr(1 > !!2 * 3 : 4), quote(1 > 2 * 3 : 4)) expect_identical_(expr(!!1^2^3), quote(1)) expect_identical_(expr(!!1^2^3 + 4), quote(1 + 4)) expect_identical_(expr(!!1^2 + 3:4), quote(1 + 3:4)) }) test_that("lower pivot is correctly found (#1125)", { expect_equal_(expr(1 + !!2 + 3 + 4), expr(1 + 2 + 3 + 4)) expect_equal_(expr(1 + 2 + !!3 + 4 + 5 + 6), expr(1 + 2 + 3 + 4 + 5 + 6)) expect_equal_(expr(1 * 2 + !!3 * 4 * 5 + 6), expr(1 * 2 + 3 * 4 * 5 + 6)) expect_equal_(expr(1 + 2 + !!3 * 4 * 5 + 6), expr(1 + 2 + 3 * 4 * 5 + 6)) expect_equal_(expr(1 + !!2 * 3 * 4 + 5), expr(1 + 2 * 3 * 4 + 5)) }) test_that("`!!` handles binary and unary `-` and `+`", { expect_identical_(expr(!!1 + 2), quote(1 + 2)) expect_identical_(expr(!!1 - 2), quote(1 - 2)) expect_identical_(expr(!!+1 + 2), quote(1 + 2)) expect_identical_(expr(!!-1 - 2), expr(`!!`(-1) - 2)) expect_identical_(expr(1 + -!!3 + 4), quote(1 + -3 + 4)) expect_identical_(expr(1 + ---+!!3 + 4), quote(1 + ---+3 + 4)) expect_identical_(expr(+1), quote(+1)) expect_identical_(expr(+-!!1), quote(+-1)) expect_identical_(expr(+-!!(1 + 1)), quote(+-2)) expect_identical_(expr(+-!!+-1), bquote(+-.(-1))) expect_identical_(expr(+-+-!!+1), quote(+-+-1)) expect_identical_(expr(+-+-!!-1), bquote(+-+-.(-1))) expect_identical_(expr(+-+-!!1 - 2), quote(+-+-1 - 2)) expect_identical_(expr(+-+-!!+-+1 + 2), bquote(+-+-.(-1) + 2)) expect_identical(expr(+-+-!!+-!1 + 2), quote(+-+-0L)) expect_identical_(expr(+-+-!!+-identity(1)), bquote(+-+-.(-1))) expect_identical_(expr(+-+-!!+-identity(1) + 2), bquote(+-+-.(-1) + 2)) }) test_that("`!!` handles special operators", { expect_identical(expr(!! 1 %>% 2), quote(1 %>% 2)) }) test_that("LHS of nested `!!` is expanded (#405)", { expect_identical_(expr(!!1 + foo(!!2) + !!3), quote(1 + foo(2) + 3)) expect_identical_(expr(!!1 + !!2 + foo(!!3) + !!4), quote(1 + 2 + foo(3) + 4)) }) test_that("operators with zero or one argument work (#652)", { expect_identical(quo(`/`()), new_quosure(quote(`/`()))) expect_identical(expr(`/`(2)), quote(`/`(2))) }) test_that("evaluates contents of `!!`", { expect_identical(expr(!!(1 + 2)), 3) }) test_that("quosures are not rewrapped", { var <- quo(!! quo(letters)) expect_identical(quo(!!var), quo(letters)) var <- new_quosure(local(~letters), env = child_env(current_env())) expect_identical(quo(!!var), var) }) test_that("UQ() fails if called without argument", { local_lifecycle_silence() quo <- quo(UQ(NULL)) expect_equal(quo, quo(NULL)) quo <- tryCatch(quo(UQ()), error = identity) expect_s3_class(quo, "error") expect_match(quo$message, "must be called with an argument") }) # !!! --------------------------------------------------------------------- test_that("values of `!!!` spliced into expression", { f <- quo(f(a, !!! list(quote(b), quote(c)), d)) expect_identical(f, quo(f(a, b, c, d))) }) test_that("names within `!!!` are preseved", { f <- quo(f(!!! list(a = quote(b)))) expect_identical(f, quo(f(a = b))) }) test_that("`!!!` handles `{` calls", { expect_identical(quo(list(!!! quote({ foo }))), quo(list(foo))) }) test_that("splicing an empty vector works", { expect_identical(expr_interp(~list(!!! list())), ~list()) expect_identical(expr_interp(~list(!!! character(0))), ~list()) expect_identical(expr_interp(~list(!!! NULL)), ~list()) }) # This fails but doesn't seem needed if (FALSE) { test_that("serialised unicode in argument names is unserialised on splice", { skip("failing") nms <- with_latin1_locale({ exprs <- exprs("\u5e78" := 10) quos <- quos(!!! exprs) names(quos) }) expect_identical(charToRaw(nms), charToRaw("\u5e78")) expect_true(all(chr_encoding(nms) == "UTF-8")) }) } test_that("can't splice at top level", { expect_error_(expr(!!! letters), "top level") }) test_that("can splice function body even if not a `{` block", { fn <- function(x) { x } expect_identical(exprs(!!!fn_body(fn)), named_list(quote(x))) fn <- function(x) x expect_identical(exprs(!!!fn_body(fn)), named_list(quote(x))) }) test_that("splicing a pairlist has no side effect", { x <- pairlist(NULL) expr(foo(!!! x, y)) expect_identical(x, pairlist(NULL)) }) test_that("`!!!` works in prefix form", { expect_identical(exprs(`!!!`(1:2)), named_list(1L, 2L)) expect_identical(expr(list(`!!!`(1:2))), quote(list(1L, 2L))) expect_identical(quos(`!!!`(1:2)), quos_list(quo(1L), quo(2L))) expect_identical(quo(list(`!!!`(1:2))), new_quosure(quote(list(1L, 2L)))) }) test_that("can't use prefix form of `!!!` with qualifying operators", { expect_error_(expr(foo$`!!!`(bar)), "Prefix form of `!!!` can't be used with `\\$`") expect_error_(expr(foo@`!!!`(bar)), "Prefix form of `!!!` can't be used with `@`") expect_error_(expr(foo::`!!!`(bar)), "Prefix form of `!!!` can't be used with `::`") expect_error_(expr(foo:::`!!!`(bar)), "Prefix form of `!!!` can't be used with `:::`") expect_error_(expr(rlang::`!!!`(bar)), "Prefix form of `!!!` can't be used with `::`") expect_error_(expr(rlang:::`!!!`(bar)), "Prefix form of `!!!` can't be used with `:::`") }) test_that("can't supply multiple arguments to `!!!`", { expect_error_(expr(list(`!!!`(1, 2))), "Can't supply multiple arguments to `!!!`") expect_error_(exprs(`!!!`(1, 2)), "Can't supply multiple arguments to `!!!`") }) test_that("`!!!` doesn't modify spliced inputs by reference", { x <- 1:3 quos(!!! x) expect_identical(x, 1:3) x <- as.list(1:3) quos(!!! x) expect_identical(x, as.list(1:3)) x <- quote({ 1L; 2L; 3L }) quos(!!! x) expect_equal(x, quote({ 1L; 2L; 3L })) # equal because of srcrefs }) test_that("exprs() preserves spliced quosures", { out <- exprs(!!!quos(a, b)) expect_identical(out, exprs(!!quo(a), !!quo(b))) expect_identical(out, named_list(quo(a), quo(b))) }) test_that("!!! fails with non-vectors", { expect_error_(exprs(!!!env()), "not a vector") expect_error_(exprs(!!!function() NULL), "not a vector") expect_error_(exprs(!!!base::c), "not a vector") expect_error_(exprs(!!!base::`{`), "not a vector") expect_error_(exprs(!!!expression()), "not a vector") expect_error_(quos(!!!env()), "not a vector") expect_error_(quos(!!!function() NULL), "not a vector") expect_error_(quos(!!!base::c), "not a vector") expect_error_(quos(!!!base::`{`), "not a vector") expect_error_(quos(!!!expression()), "not a vector") expect_error_(expr(list(!!!env())), "not a vector") expect_error_(expr(list(!!!function() NULL)), "not a vector") expect_error_(expr(list(!!!base::c)), "not a vector") expect_error_(expr(list(!!!base::`{`)), "not a vector") expect_error_(expr(list(!!!expression())), "not a vector") expect_error_(list2(!!!env()), "not a vector") expect_error_(list2(!!!function() NULL), "not a vector") expect_error_(list2(!!!base::c), "not a vector") expect_error_(list2(!!!base::`{`), "not a vector") expect_error_(list2(!!!expression()), "not a vector") }) test_that("!!! succeeds with vectors, pairlists and language objects", { expect_identical_(exprs(!!!NULL), named_list()) expect_identical_(exprs(!!!pairlist(1)), named_list(1)) expect_identical_(exprs(!!!list(1)), named_list(1)) expect_identical_(exprs(!!!TRUE), named_list(TRUE)) expect_identical_(exprs(!!!1L), named_list(1L)) expect_identical_(exprs(!!!1), named_list(1)) expect_identical_(exprs(!!!1i), named_list(1i)) expect_identical_(exprs(!!!"foo"), named_list("foo")) expect_identical_(exprs(!!!bytes(0)), named_list(bytes(0))) expect_identical_(quos(!!!NULL), quos_list()) expect_identical_(quos(!!!pairlist(1)), quos_list(quo(1))) expect_identical_(quos(!!!list(1)), quos_list(quo(1))) expect_identical_(quos(!!!TRUE), quos_list(quo(TRUE))) expect_identical_(quos(!!!1L), quos_list(quo(1L))) expect_identical_(quos(!!!1), quos_list(quo(1))) expect_identical_(quos(!!!1i), quos_list(quo(1i))) expect_identical_(quos(!!!"foo"), quos_list(quo("foo"))) expect_identical_(quos(!!!bytes(0)), quos_list(quo(!!bytes(0)))) expect_identical_(expr(foo(!!!NULL)), quote(foo())) expect_identical_(expr(foo(!!!pairlist(1))), quote(foo(1))) expect_identical_(expr(foo(!!!list(1))), quote(foo(1))) expect_identical_(expr(foo(!!!TRUE)), quote(foo(TRUE))) expect_identical_(expr(foo(!!!1L)), quote(foo(1L))) expect_identical_(expr(foo(!!!1)), quote(foo(1))) expect_identical_(expr(foo(!!!1i)), quote(foo(1i))) expect_identical_(expr(foo(!!!"foo")), quote(foo("foo"))) expect_identical_(expr(foo(!!!bytes(0))), expr(foo(!!bytes(0)))) expect_identical_(list2(!!!NULL), list()) expect_identical_(list2(!!!pairlist(1)), list(1)) expect_identical_(list2(!!!list(1)), list(1)) expect_identical_(list2(!!!TRUE), list(TRUE)) expect_identical_(list2(!!!1L), list(1L)) expect_identical_(list2(!!!1), list(1)) expect_identical_(list2(!!!1i), list(1i)) expect_identical_(list2(!!!"foo"), list("foo")) expect_identical_(list2(!!!bytes(0)), list(bytes(0))) }) test_that("!!! calls `[[`", { as_quos_list <- function(x, env = empty_env()) { new_quosures(map(x, new_quosure, env = env)) } exp <- map(seq_along(mtcars), function(i) mtcars[[i]]) names(exp) <- names(mtcars) expect_identical_(exprs(!!!mtcars), exp) expect_identical_(quos(!!!mtcars), as_quos_list(exp)) expect_identical_(expr(foo(!!!mtcars)), do.call(call, c(list("foo"), exp))) expect_identical_(list2(!!!mtcars), as.list(mtcars)) fct <- factor(c("a", "b")) fct <- set_names(fct, c("x", "y")) exp <- set_names(list(fct[[1]], fct[[2]]), names(fct)) expect_identical_(exprs(!!!fct), exp) expect_identical_(quos(!!!fct), as_quos_list(exp)) expect_identical_(expr(foo(!!!fct)), do.call(call, c(list("foo"), exp))) expect_identical_(list2(!!!fct), exp) }) test_that("!!! errors on scalar S4 objects without a `[[` method", { .Person <- methods::setClass("Person", slots = c(name = "character", species = "character")) fievel <- .Person(name = "Fievel", species = "mouse") expect_error_(list2(!!!fievel)) }) test_that("!!! works with scalar S4 objects with a `[[` method defined", { .Person2 <- methods::setClass("Person2", slots = c(name = "character", species = "character")) fievel <- .Person2(name = "Fievel", species = "mouse") methods::setMethod("[[", methods::signature(x = "Person2"), function(x, i, ...) .Person2(name = x@name, species = x@species) ) expect_identical_(list2(!!!fievel), list(fievel)) }) test_that("!!! works with all vector S4 objects", { .Counts <- methods::setClass("Counts", contains = "numeric", slots = c(name = "character")) fievel <- .Counts(c(1, 2), name = "Fievel") expect_identical_(list2(!!!fievel), list(1, 2)) }) test_that("!!! calls `[[` with vector S4 objects", { as_quos_list <- function(x, env = empty_env()) { new_quosures(map(x, new_quosure, env = env)) } foo <- function(x, y) { list(x, y) } .Belongings <- methods::setClass("Belongings", contains = "list", slots = c(name = "character")) fievel <- .Belongings(list(1, "x"), name = "Fievel") methods::setMethod("[[", methods::signature(x = "Belongings"), function(x, i, ...) .Belongings(x@.Data[[i]], name = x@name) ) exp <- list( .Belongings(list(1), name = "Fievel"), .Belongings(list("x"), name = "Fievel") ) exp_named <- set_names(exp, c("", "")) expect_identical_(list2(!!!fievel), exp) expect_identical_(eval_bare(expr(foo(!!!fievel))), exp) expect_identical_(exprs(!!!fievel), exp_named) expect_identical_(quos(!!!fievel), as_quos_list(exp_named)) }) test_that("!!! doesn't shorten S3 lists containing `NULL`", { x <- structure(list(NULL), class = "foobar") y <- structure(list(a = NULL, b = 1), class = "foobar") expect_identical_(list2(!!!x), list(NULL)) expect_identical_(list2(!!!y), list(a = NULL, b = 1)) }) test_that("!!! goes through `[[` for record S3 types", { x <- structure(list(x = c(1, 2, 3), y = c(3, 2, 1)), class = "rcrd") local_methods( `[[.rcrd` = function(x, i, ...) { structure(lapply(unclass(x), "[[", i), class = "rcrd") }, names.rcrd = function(x) { names(x$x) }, `names<-.rcrd` = function(x, value) { names(x$x) <- value x }, length.rcrd = function(x) { length(x$x) } ) x_named <- set_names(x, c("a", "b", "c")) expect <- list( a = structure(list(x = 1, y = 3), class = "rcrd"), b = structure(list(x = 2, y = 2), class = "rcrd"), c = structure(list(x = 3, y = 1), class = "rcrd") ) expect_identical_(list2(!!!x_named), expect) }) # bang --------------------------------------------------------------- test_that("single ! is not treated as shortcut", { expect_identical(quo(!foo), as_quosure(~!foo)) }) test_that("double and triple ! are treated as syntactic shortcuts", { var <- local(quo(foo)) expect_identical(quo(!! var), as_quosure(var)) expect_identical(quo(!! quo(foo)), quo(foo)) expect_identical(quo(list(!!! letters[1:3])), quo(list("a", "b", "c"))) }) test_that("`!!` works in prefixed calls", { var <- quo(cyl) expect_identical(expr_interp(~mtcars$`!!`(quo_squash(var))), ~mtcars$cyl) expect_identical(expr_interp(~foo$`!!`(quote(bar))), ~foo$bar) expect_identical(expr_interp(~base::`!!`(quote(list))()), ~base::list()) }) test_that("one layer of parentheses around !! is removed", { foo <- "foo" expect_identical(expr((!! foo)), "foo") expect_identical(expr(((!! foo))), quote(("foo"))) expect_identical(expr((!! foo) + 1), quote("foo" + 1)) expect_identical(expr(((!! foo)) + 1), quote(("foo") + 1)) expect_identical(expr((!! sym(foo))(bar)), quote(foo(bar))) expect_identical(expr(((!! sym(foo)))(bar)), quote((foo)(bar))) expect_identical(exprs((!! foo), ((!! foo))), named_list("foo", quote(("foo")))) }) test_that("parentheses are not removed if there's a tail", { expect_identical(expr((!! "a" + b)), quote(("a" + b))) }) test_that("can use prefix form of `!!` with qualifying operators", { expect_identical(expr(foo$`!!`(quote(bar))), quote(foo$bar)) expect_identical(expr(foo@`!!`(quote(bar))), quote(foo@bar)) expect_identical(expr(foo::`!!`(quote(bar))), quote(foo::bar)) expect_identical(expr(foo:::`!!`(quote(bar))), quote(foo:::bar)) expect_identical(expr(rlang::`!!`(quote(bar))), quote(rlang::bar)) expect_identical(expr(rlang:::`!!`(quote(bar))), quote(rlang:::bar)) }) test_that("can unquote within for loop (#417)", { # Checks for an issue caused by wrong refcount of unquoted objects x <- new_list(3) for (i in 1:3) { x[[i]] <- expr(!!i) } expect_identical(x, as.list(1:3)) for (i in 1:3) { x[[i]] <- quo(!!i) } expect_identical(x, map(1:3, new_quosure, env = empty_env())) for (i in 1:3) { x[[i]] <- quo(foo(!!i)) } exp <- list(quo(foo(1L)), quo(foo(2L)), quo(foo(3L))) expect_identical(x, exp) for (i in 1:3) { x[[i]] <- quo(foo(!!!i)) } expect_identical(x, exp) }) # quosures ----------------------------------------------------------- test_that("quosures are created for all informative formulas", { foo <- local(quo(foo)) bar <- local(quo(bar)) interpolated <- local(quo(list(!!foo, !!bar))) expected <- new_quosure(call2("list", as_quosure(foo), as_quosure(bar)), env = get_env(interpolated)) expect_identical(interpolated, expected) interpolated <- quo(!!interpolated) expect_identical(interpolated, expected) }) # dots_values() ------------------------------------------------------ test_that("can unquote-splice symbols", { spliced <- list2(!!! list(quote(`_symbol`))) expect_identical(spliced, list(quote(`_symbol`))) }) test_that("can unquote symbols", { expect_error_(dots_values(!! quote(.)), "`!!` in a non-quoting function") }) # := ----------------------------------------------------------------- test_that("`:=` unquotes its LHS as name unless `.unquote_names` is FALSE", { expect_identical(exprs(a := b), list(a = quote(b))) expect_identical(exprs(a := b, .unquote_names = FALSE), named_list(quote(a := b))) expect_identical(quos(a := b), quos_list(a = quo(b))) expect_identical(quos(a := b, .unquote_names = FALSE), quos_list(new_quosure(quote(a := b)))) expect_identical(dots_list(a := NULL), list(a = NULL)) local_lifecycle_silence() expect_identical(dots_splice(a := NULL), list(a = NULL)) }) test_that("`:=` chaining is detected at dots capture", { expect_error(exprs(a := b := c), "chained") expect_error(quos(a := b := c), "chained") expect_error(dots_list(a := b := c), "chained") local_lifecycle_silence() expect_error(dots_splice(a := b := c), "chained") }) # -------------------------------------------------------------------- test_that("Unquote operators fail when called outside quasiquoted arguments", { expect_qq_error <- function(object) expect_error(object, regexp = "within a defused argument") expect_qq_error(UQ()) expect_qq_error(UQS()) expect_qq_error(`!!`()) expect_dyn_error <- function(object) expect_error(object, regexp = "within dynamic dots") expect_dyn_error(`!!!`()) expect_dyn_error(a := b) }) test_that("`.data[[` unquotes", { foo <- "bar" expect_identical_(expr(.data[[foo]]), quote(.data[["bar"]])) expect_identical_(expr(deep(.data[[foo]])), quote(deep(.data[["bar"]]))) expect_identical_(exprs(.data[[foo]]), named_list(quote(.data[["bar"]]))) }) test_that("it is still possible to unquote manually within `.data[[`", { local_lifecycle_silence() foo <- "baz" expect_identical(expr(.data[[!!toupper(foo)]]), quote(.data[["BAZ"]])) }) test_that(".data[[ argument is not masked", { cyl <- "carb" expect_identical_(eval_tidy(expr(.data[[cyl]]), mtcars), mtcars$carb) }) test_that(".data[[ on the LHS of := fails", { expect_error(exprs(.data[["foo"]] := foo), "Can't use the `.data` pronoun on the LHS") }) test_that("it is still possible to use .data[[ in list2()", { .data <- mtcars expect_identical_(list2(.data$cyl), list(mtcars$cyl)) }) test_that("can defuse-and-label and interpolate with glue", { skip_if_not_installed("glue") env_bind_lazy(current_env(), var = letters) suffix <- "foo" expect_identical(glue_first_pass("{{var}}_{suffix}"), glue::glue("letters_{{suffix}}")) expect_identical(glue_embrace("{{var}}_{suffix}"), glue::glue("letters_foo")) expect_identical(exprs("{{var}}_{suffix}" := 1), exprs(letters_foo = 1)) }) test_that("unquoted strings are not interpolated with glue", { expect_identical_( list2(!!"{foo}" := 1), list(`{foo}` = 1) ) }) test_that("englue() returns a bare string", { fn <- function(x) englue("{{ x }}") expect_null(attributes(fn(foo)), "foo") }) test_that("englue() has good error messages (#1531)", { expect_snapshot({ fn <- function(x) englue(c("a", "b")) (expect_error(fn())) fn <- function(x) englue(env()) (expect_error(fn())) fn <- function(x) glue_embrace("{{ x }}_foo") (expect_error(fn())) fn <- function(x) englue("{{ x }}_foo") (expect_error(fn())) fn <- function(x) list2("{{ x }}_foo" := NULL) (expect_error(fn())) }) }) test_that("can wrap englue() (#1565)", { my_englue <- function(text) { englue( text, env = env(caller_env(), .qux = "QUX"), error_arg = "text", error_call = current_env() ) } fn <- function(x) { foo <- "FOO" my_englue("{{ x }}_{.qux}_{foo}") } expect_equal(fn(bar), "bar_QUX_FOO") expect_equal(my_englue("{'foo'}"), "foo") expect_snapshot({ (expect_error(my_englue(c("a", "b")))) (expect_error(my_englue(env()))) (expect_error(fn())) }) }) # Lifecycle ---------------------------------------------------------- test_that("unquoting with rlang namespace is deprecated", { expect_warning_(exprs(rlang::UQS(1:2)), regexp = "deprecated as of rlang 0.3.0") expect_warning_(quo(list(rlang::UQ(1:2))), regexp = "deprecated as of rlang 0.3.0") # Old tests local_lifecycle_silence() expect_identical(quo(rlang::UQ(toupper("a"))), new_quosure("A", empty_env())) expect_identical(quo(list(rlang::UQS(list(a = 1, b = 2)))), quo(list(a = 1, b = 2))) quo <- quo(rlang::UQ(NULL)) expect_equal(quo, quo(NULL)) quo <- tryCatch(quo(rlang::UQ()), error = identity) expect_s3_class(quo, "error") expect_match(quo$message, "must be called with an argument") expect_error_(dots_values(rlang::UQ(quote(.))), "`!!` in a non-quoting function") }) test_that("splicing language objects still works", { local_lifecycle_silence() expect_identical_(exprs(!!!~foo), named_list(~foo)) expect_identical_(exprs(!!!quote(foo(bar))), named_list(quote(foo(bar)))) expect_identical_(quos(!!!~foo), quos_list(quo(!!~foo))) expect_identical_(quos(!!!quote(foo(bar))), quos_list(quo(foo(bar)))) expect_identical_(expr(foo(!!!~foo)), expr(foo(!!~foo))) expect_identical_(expr(foo(!!!quote(foo(bar)))), expr(foo(foo(bar)))) expect_identical_(list2(!!!~foo), list(~foo)) expect_identical_(list2(!!!quote(foo(bar))), list(quote(foo(bar)))) }) test_that("can unquote string in function position", { expect_identical_(expr((!!"foo")()), quote("foo"())) }) test_that("{{ is a quote-unquote operator", { fn <- function(foo) expr(list({{ foo }})) expect_identical_(fn(bar), expr(list(!!quo(bar)))) expect_identical_(expr(list({{ letters }})), expr(list(!!quo(!!letters)))) expect_error_(expr(list({{ quote(foo) }})), "must be a symbol") }) test_that("{{ only works in quoting functions", { expect_error_( list2({{ "foo" }}), "Can't use `{{` in a non-quoting function", fixed = TRUE ) }) test_that("{{ on the LHS of :=", { foo <- "bar" expect_identical_(exprs({{ foo }} := NA), exprs(bar = NA)) foo <- quote(bar) expect_identical_(exprs({{ foo }} := NA), exprs(bar = NA)) foo <- quo(bar) expect_identical_(exprs({{ foo }} := NA), exprs(bar = NA)) fn <- function(foo) exprs({{ foo }} := NA) expect_identical_(fn(bar), exprs(bar = NA)) expect_error_(exprs({{ foo() }} := NA), "must be a symbol") }) test_that("can unquote-splice in atomic capture", { expect_identical_(chr("a", !!!c("b", "c"), !!!list("d")), c("a", "b", "c", "d")) }) test_that("can unquote-splice multiple times (#771)", { expect_identical(call2("foo", !!!list(1, 2), !!!list(3, 4)), quote(foo(1, 2, 3, 4))) expect_identical(list2(!!!list(1, 2), !!!list(3, 4)), list(1, 2, 3, 4)) expect_identical(exprs(!!!list(1, 2), !!!list(3, 4)), named_list(1, 2, 3, 4)) expect_identical(expr(foo(!!!list(1, 2), !!!list(3, 4))), quote(foo(1, 2, 3, 4))) }) test_that(".data[[quote(foo)]] creates strings (#836)", { expect_identical(expr(call(.data[[quote(foo)]])), quote(call(.data[["foo"]]))) expect_identical(expr(call(.data[[!!quote(foo)]])), quote(call(.data[["foo"]]))) }) test_that(".data[[quo(foo)]] creates strings (#807)", { expect_identical(expr(call(.data[[quo(foo)]])), quote(call(.data[["foo"]]))) expect_identical(expr(call(.data[[!!quo(foo)]])), quote(call(.data[["foo"]]))) }) test_that("can splice named empty vectors (#1045)", { # Work around bug in `Rf_coerceVector()` x <- named(dbl()) expect_equal(expr(foo(!!!x)), quote(foo())) }) test_that("Unquoted LHS is not recursed into and mutated (#1103)", { x <- quote(!!1 / !!2) x_cpy <- duplicate(x) out <- expr(!!x + 5) expect_equal(out, call("+", x, 5)) expect_equal(x, x_cpy) x <- quote(!!1 / !!2) x_cpy <- duplicate(x) out <- expr(!!x) expect_equal(out, x_cpy) expect_equal(x, x_cpy) }) test_that("{{ foo; bar }} is not injected (#1087)", { expect_equal_( expr({{ 1 }; NULL}), quote({{ 1 }; NULL}) ) }) test_that("englue() works", { g <- function(var) englue("{{ var }}") expect_equal(g(cyl), as_label(quote(cyl))) expect_equal(g(1 + 1), as_label(quote(1 + 1))) g <- function(var) englue("prefix_{{ var }}_suffix") expect_equal(g(cyl), "prefix_cyl_suffix") expect_equal(englue("{'foo'}"), "foo") }) test_that("englue() checks for the size of its result (#1492)", { expect_snapshot({ fn <- function(x) englue("{{ x }} {NULL}") (expect_error(fn(foo))) fn <- function(x) list2("{{ x }} {NULL}" := NULL) (expect_error(fn(foo))) }) }) rlang/tests/testthat/test-parse.R0000644000176200001440000000367414376112150016603 0ustar liggesuserstest_that("parse_quo() etc return quosures", { expect_identical(parse_quo("foo(bar)", "base"), set_env(quo(foo(bar)), base_env())) expect_identical(parse_quos("foo(bar)\n mtcars", "base"), new_quosures(list(set_env(quo(foo(bar)), base_env()), set_env(quo(mtcars), base_env())))) }) test_that("temporary connections are closed", { path <- tempfile("file") cat("1; 2; mtcars", file = path) conn <- file(path) parse_exprs(conn) expect_error(summary(conn), "invalid connection") }) test_that("parse_expr() throws meaningful error messages", { expect_snapshot({ err(parse_expr("")) err(parse_expr("foo; bar")) }) }) test_that("parse_exprs() and parse_quos() handle character vectors", { exprs <- parse_exprs(c("foo; bar", "baz")) attributes(exprs) <- NULL # For srcrefs expect_identical(exprs, unname(exprs(foo, bar, baz))) quos <- parse_quos(c("foo; bar", "baz"), current_env()) expect_identical(quos, quos(foo, bar, baz)) }) test_that("parse_exprs() requires connections or character vectors", { expect_error(parse_exprs(env()), "must be a character vector or an R connection") }) test_that("parse_exprs() and parse_quos() support empty input", { expect_identical(zap_srcref_attributes(parse_exprs(chr())), list()) expect_identical(zap_srcref_attributes(parse_quos(chr(), env())), quos_list()) }) test_that("parse_exprs() supports empty expressions (#954)", { x <- c("1", "", "2") expect_equal(vec_unstructure(parse_exprs(x)), list(1, 2)) expect_equal(vec_unstructure(parse_exprs("")), list()) }) test_that("parse_exprs() preserves names (#808)", { x <- c(a = "1 + 2; 3", b = "", c = "4") expect_identical( vec_unstructure(parse_exprs(x)), alist(a = 1 + 2, a = 3, c = 4) ) }) test_that("parse_expr() supports vectors of lines (#1540)", { lines <- c("{", " a", " b", "}") expect_equal(parse_expr(lines), quote({ a; b })) lines <- c("a", "b") expect_error(parse_expr(lines), "exactly 1 expression") }) rlang/tests/testthat/teardown-tests.R0000644000176200001440000000013714127057575017503 0ustar liggesusers # Until https://github.com/r-lib/testthat/issues/787 is fixed Sys.setenv("TESTTHAT_PKG" = "") rlang/tests/testthat/test-encoding.R0000644000176200001440000000177514516466727017301 0ustar liggesuserstest_that("can roundtrip symbols in non-UTF8 locale", { skip_if_no_utf8_marker() with_non_utf8_locale({ expect_identical( as_string(sym(get_alien_lang_string())), get_alien_lang_string() ) }) }) test_that("Unicode escapes are always converted to UTF8 characters on roundtrip", { expect_identical( as_string(sym("")), "\u5E78\u798F" ) }) test_that("Unicode escapes are always converted to UTF8 characters with env_names()", { skip_if_no_utf8_marker() with_non_utf8_locale({ env <- child_env(empty_env()) env_bind(env, !! get_alien_lang_string() := NULL) expect_identical(env_names(env), get_alien_lang_string()) }) }) test_that("dots names are converted to and from UTF-8 (#1218)", { skip_if_not_windows() withr::local_locale(LC_CTYPE = "Chinese (Simplified)_China.936") x <- rawToChar(as.raw(c(0xb2, 0xe2, 0xca, 0xd4))) call <- list(quote(quos), 1) names(call)[[2]] <- x out <- eval(as.call(call)) expect_equal(names(out), x) }) rlang/tests/testthat/test-dots-ellipsis.R0000644000176200001440000000723614741441060020263 0ustar liggesuserstest_that("error if dots not used", { f <- function(x, y, ...) { check_dots_used() x + y } expect_error(f(1, 2), NA) expect_error(f(1, 2, 3), class = "rlib_error_dots_unused") }) test_that("error if dots not used by another function", { g <- function(a = 1, b = 1, ...) { a + b } f <- function(x = 1, ...) { check_dots_used() x * g(...) } expect_error(f(x = 10, a = 1), NA) expect_snapshot({ (expect_error(f(x = 10, c = 3), class = "rlib_error_dots_unused")) }) }) test_that("error if dots named", { f <- function(..., xyz = 1) { check_dots_unnamed() } expect_null(f(1)) expect_error(f(xyz = 1), NA) expect_error(f(1, 2, 3), NA) expect_error(f(1, 2, 3, xyz = 4), NA) expect_error(f(1, 2, 3, xy = 4), class = "rlib_error_dots_named") expect_snapshot({ (expect_error(f(1, 2, 3, xy = 4, x = 5), class = "rlib_error_dots_named")) }) }) test_that("error if if dots not empty", { f <- function(..., xyz = 1) { check_dots_empty() } f0 <- function(..., xyz = 1) { check_dots_empty0(...) } expect_error(f(xyz = 1), NA) expect_error(f0(xyz = 1), NA) expect_snapshot({ (expect_error(f(xy = 4), class = "rlib_error_dots_nonempty")) (expect_error(f0(xy = 4), class = "rlib_error_dots_nonempty")) }) }) test_that("can control the action (deprecated)", { f <- function(action, check, ..., xyz = 1) { check(action = action) } expect_error(f(abort, check_dots_used, xy = 4), class = "rlib_error_dots_unused") expect_warning(f(warn, check_dots_used, xy = 4), class = "rlib_error_dots_unused") expect_message(f(inform, check_dots_used, xy = 4), class = "rlib_error_dots_unused") expect_error(f(abort, check_dots_unnamed, xy = 4), class = "rlib_error_dots_named") expect_warning(f(warn, check_dots_unnamed, xy = 4), class = "rlib_error_dots_named") expect_message(f(inform, check_dots_unnamed, xy = 4), class = "rlib_error_dots_named") expect_error(f(abort, check_dots_empty, xy = 4), class = "rlib_error_dots_nonempty") expect_warning(f(warn, check_dots_empty, xy = 4), class = "rlib_error_dots_nonempty") expect_message(f(inform, check_dots_empty, xy = 4), class = "rlib_error_dots_nonempty") }) test_that("warn if unused dots", { safe_median <- function(x, ...) { check_dots_used() UseMethod("safe_median") } safe_median.numeric <- function(x, ..., na.rm = TRUE) { stats::median(x, na.rm = na.rm) } expect_error(safe_median(1:10), NA) expect_error(safe_median(1:10, na.rm = TRUE), NA) expect_error(safe_median(1:10, y = 1), class = "rlib_error_dots_unused") }) test_that("can supply `error` handler", { hnd <- function(cnd) warning(cnd) f <- function(...) check_dots_empty(error = hnd) expect_silent(f()) expect_error(f(foo), class = "rlib_error_dots_nonempty") f <- function(...) check_dots_used(error = hnd) expect_silent(f()) expect_error(f(foo), class = "rlib_error_dots_unused") f <- function(...) check_dots_unnamed(error = hnd) expect_silent(f(foo)) expect_error(f(foo = foo), class = "rlib_error_dots_named") }) test_that("expression contents are mentioned", { f <- function(...) check_dots_empty() expect_snapshot(error = TRUE, { f("foo") f(foo) inject(f(!!letters)) f(a = { 1; 2 }) f(a = toupper(letters)) }) }) test_that("empty dots error mentions info bullets if any unnamed element", { f <- function(...) check_dots_empty() expect_snapshot(error = TRUE, { f(1) f(a = 1) f(a = 1, 2) }) }) test_that("check_dots_empty() allows trailing missing arg (#1390)", { fn <- function(..., a = NULL) check_dots_empty() expect_null(fn(a = 1, )) expect_snapshot({ (expect_error(fn(a = 1, b = ))) }) }) rlang/tests/testthat/test-s3.R0000644000176200001440000000666014741441060016015 0ustar liggesuserstest_that("inherits from all classes", { x <- structure(list(), class = c("foo", "bar", "baz")) expect_true(inherits_all(x, c("foo"))) expect_true(inherits_all(x, c("foo", "baz"))) expect_true(inherits_all(x, c("foo", "bar", "baz"))) expect_false(inherits_all(x, c("fooz"))) expect_false(inherits_all(x, c("foo", "barz", "baz"))) expect_false(inherits_all(x, c("fooz", "bar", "baz"))) expect_error(inherits_all(x, chr()), "empty") }) test_that("inherits from any class", { x <- structure(list(), class = "bar") expect_true(inherits_any(x, c("bar", "foo"))) expect_true(inherits_any(x, c("foo", "bar"))) expect_true(inherits_any(x, c("foo", "bar", "baz"))) expect_false(inherits_any(x, c("foo", "baz"))) expect_error(inherits_any(x, chr()), "empty") }) test_that("inherits only from class", { x <- structure(list(), class = c("foo", "bar", "baz")) expect_false(inherits_only(x, c("foo", "baz"))) expect_true(inherits_only(x, c("foo", "bar", "baz"))) }) test_that("can box and unbox a value", { box <- new_box(letters, "foo") expect_true(is_box(box)) expect_true(is_box(box), "foo") expect_false(is_box(box, "bar")) expect_identical(unbox(box), letters) box <- new_box(NULL, c("foo", "bar", "baz")) expect_true(is_box(box, c("foo", "baz"))) expect_false(is_box(box, c("baz", "foo"))) }) test_that("as_box() ensures boxed value", { box <- as_box(NULL) expect_true(inherits_only(box, "rlang_box")) boxbox <- as_box(box) expect_true(inherits_only(box, "rlang_box")) expect_null(unbox(box)) some_box <- as_box(NULL, "some_box") some_boxbox <- as_box(some_box, "other_box") expect_true(inherits_only(some_boxbox, c("other_box", "rlang_box"))) expect_true(inherits_only(unbox(some_boxbox), c("some_box", "rlang_box"))) expect_null(unbox(unbox(some_boxbox))) }) test_that("as_box_if() ensures boxed value if predicate returns TRUE", { box <- as_box_if(NULL, is_null, "null_box") expect_true(inherits_only(box, c("null_box", "rlang_box"))) boxbox <- as_box_if(box, is_null, "null_box") expect_true(inherits_only(box, c("null_box", "rlang_box"))) expect_null(unbox(boxbox)) expect_null(as_box_if(NULL, is_vector, "null_box")) expect_snapshot({ (expect_error(as_box_if(NULL, ~ 10))) (expect_error(as_box_if(NULL, ~ c(TRUE, FALSE)))) }) }) test_that("unboxing a non-boxed value is an error", { expect_error(unbox(NULL), "must be a box") }) test_that("zap() creates a zap", { expect_s3_class(zap(), "rlang_zap") expect_true(is_zap(zap())) }) test_that("can pass additional attributes to boxes", { box <- new_box(NA, "foo", bar = "baz") expect_identical(box %@% bar, "baz") }) test_that("done() boxes values", { expect_true(is_done_box(done(3))) expect_identical(unbox(done(3)), 3) expect_identical(done(3) %@% empty, FALSE) }) test_that("done() can be empty", { empty <- done() expect_identical(unbox(empty), missing_arg()) expect_true(is_done_box(empty)) expect_s3_class(empty, "rlang_box_done") expect_identical(empty %@% empty, TRUE) expect_true(is_done_box(empty, empty = TRUE)) expect_false(is_done_box(empty, empty = FALSE)) nonempty <- done(missing_arg()) expect_false(is_done_box(nonempty, empty = TRUE)) expect_true(is_done_box(nonempty, empty = FALSE)) }) test_that("splice box is constructed", { box <- splice(list(NA)) expect_true(is.object(box)) expect_identical(box, structure(list(list(NA)), class = c("rlang_box_splice", "rlang_box"))) }) rlang/tests/testthat/_snaps/0000755000176200001440000000000014741441060015643 5ustar liggesusersrlang/tests/testthat/_snaps/bytes.md0000644000176200001440000000061414663614101017315 0ustar liggesusers# format.rlib_bytes() works with vectors Code print(as_bytes(c(NA, 1, 2^13, 2^20, NaN, 2^15))) Output [1] NA B 1 B 8.19 kB 1.05 MB NaN B 32.77 kB # print method disambiguates edge cases Code print(bytes2()) Output [1] (empty) --- Code print(bytes2(NA, NA)) Output [1] NA B NA B rlang/tests/testthat/_snaps/standalone-vctrs.md0000644000176200001440000000107714657520714021473 0ustar liggesusers# vec_ptype2() implements base coercions Code vec_ptype2(lgl(), chr()) Condition Error: ! Can't combine types and . --- Code vec_ptype2(factor("a"), lgl()) Condition Error: ! Unimplemented class . # vec_ptype_common() works Code vec_ptype_common(list(lgl(), dbl(), "")) Condition Error: ! Can't combine types and . # lossy casts throw Code vec_cast(1.5, 2L) Condition Error: ! Can't convert to . rlang/tests/testthat/_snaps/cnd.md0000644000176200001440000003704514741441060016742 0ustar liggesusers# can use conditionMessage() method in subclasses of rlang errors Code cat_line(interactive) Output Error in `h()`: ! dispatched! Run `rlang::last_trace()` to see where the error occurred. Execution halted Code cat_line(non_interactive) Output Error in `h()`: ! dispatched! Backtrace: x 1. \-global f() 2. \-global g() 3. \-global h() 4. \-rlang::abort("", "foobar_error") Execution halted # rlang_error.print() calls cnd_message() methods Code print(err) Output Error in `h()`: ! Low-level message --- Backtrace: x 1. +-rlang:::catch_error(f()) 2. | \-rlang::catch_cnd(expr, "error") 3. | +-rlang::eval_bare(...) 4. | +-base::tryCatch(...) 5. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 6. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 7. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 8. | \-base::force(expr) 9. \-rlang (local) f() 10. \-rlang (local) g() 11. \-rlang (local) h() # Overlapping backtraces are printed separately Code print(err) Output Error in `c()`: ! High-level message Caused by error in `h()`: ! Low-level message --- Backtrace: x 1. +-rlang:::catch_error(a()) 2. | \-rlang::catch_cnd(expr, "error") 3. | +-rlang::eval_bare(...) 4. | +-base::tryCatch(...) 5. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 6. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 7. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 8. | \-base::force(expr) 9. \-rlang (local) a() 10. \-rlang (local) b() 11. \-rlang (local) c() 12. +-base::tryCatch(...) 13. | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 14. | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 15. | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 16. \-rlang (local) f() 17. \-rlang (local) g() 18. \-rlang (local) h() --- Code print(err, simplify = "none") Output Error in `c()`: ! High-level message Caused by error in `h()`: ! Low-level message --- Backtrace: x 1. +-rlang:::catch_error(a()) 2. | \-rlang::catch_cnd(expr, "error") 3. | +-rlang::eval_bare(...) 4. | +-base::tryCatch(...) 5. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 6. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 7. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 8. | \-base::force(expr) 9. \-rlang (local) a() 10. \-rlang (local) b() 11. \-rlang (local) c() 12. +-base::tryCatch(...) 13. | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 14. | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 15. | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 16. \-rlang (local) f() 17. \-rlang (local) g() 18. \-rlang (local) h() --- Code # Full print(trace, simplify = "none", dir = dir, srcrefs = srcrefs) Output Error in `c()`: ! High-level message Caused by error in `h()`: ! Low-level message --- Backtrace: x 1. +-rlang:::catch_error(a()) 2. | \-rlang::catch_cnd(expr, "error") 3. | +-rlang::eval_bare(...) 4. | +-base::tryCatch(...) 5. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 6. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 7. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 8. | \-base::force(expr) 9. \-rlang (local) a() 10. \-rlang (local) b() 11. \-rlang (local) c() 12. +-base::tryCatch(...) 13. | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 14. | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 15. | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 16. \-rlang (local) f() 17. \-rlang (local) g() 18. \-rlang (local) h() Code # Focused print_focused_trace(trace, dir = dir, srcrefs = srcrefs) Output Error in `c()`: ! High-level message Caused by error in `h()`: ! Low-level message --- Backtrace: x 1. +-rlang:::catch_error(a()) 2. | <<\-rlang::catch_cnd(expr, "error")>> 3. | <<+-rlang::eval_bare(...)>> 4. | <<+-base::tryCatch(...)>> 5. | <<| \-base (local) tryCatchList(expr, classes, parentenv, handlers)>> 6. | <<| \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]])>> 7. | <<| \-base (local) doTryCatch(return(expr), name, parentenv, handler)>> 8. | <<\-base::force(expr)>> 9. \-rlang (local) a() 10. \-rlang (local) b() 11. \-rlang (local) c() 12. +<<-base::tryCatch(...)>> 13. | <<\-base (local) tryCatchList(expr, classes, parentenv, handlers)>> 14. | <<\-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]])>> 15. | <<\-base (local) doTryCatch(return(expr), name, parentenv, handler)>> 16. \-rlang (local) f() 17. \-rlang (local) g() 18. \-rlang (local) h() Code # Branch print(trace, simplify = "branch", dir = dir, srcrefs = srcrefs) Output Error in `c()`: ! High-level message Caused by error in `h()`: ! Low-level message --- Backtrace: 1. rlang:::catch_error(a()) 9. rlang (local) a() 10. rlang (local) b() 11. rlang (local) c() 16. rlang (local) f() 17. rlang (local) g() 18. rlang (local) h() # 3-level ancestry works (#1248) Code catch_error(high()) Output Error in `high()`: ! High-level Caused by error in `mid()`: ! Mid-level Caused by error in `low()`: ! Low-level # summary.rlang_error() prints full backtrace Code summary(err) Output Error in `c()`: ! The high-level error message Caused by error in `h()`: ! The low-level error message --- Backtrace: x 1. +-rlang:::catch_error(a()) 2. | \-rlang::catch_cnd(expr, "error") 3. | +-rlang::eval_bare(...) 4. | +-base::tryCatch(...) 5. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 6. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 7. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 8. | \-base::force(expr) 9. \-rlang (local) a() 10. +-base::tryCatch(b()) 11. | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 12. \-rlang (local) b() 13. \-rlang (local) c() 14. +-base::withCallingHandlers(f(), error = handler) 15. \-rlang (local) f() 16. +-base::tryCatch(g()) 17. | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 18. \-rlang (local) g() 19. \-rlang (local) h() # don't print message or backtrace fields if empty Code print(err) Output # base parent errors are printed with rlang method Code print(rlang_err) Output Error: ! baz Caused by error: ! foo # errors are printed with call Code print(err) Output Error in `foo()`: ! msg # calls are consistently displayed on rethrow (#1240) Code (expect_error(with_context(base_problem(), "step_dummy"))) Output Error in `step_dummy()`: ! Problem while executing step. Caused by error in `base_problem()`: ! oh no! Code (expect_error(with_context(rlang_problem(), "step_dummy"))) Output Error in `step_dummy()`: ! Problem while executing step. Caused by error in `rlang_problem()`: ! oh no! # external backtraces are displayed (#1098) Code print(err) Output Error in `baz()`: ! High-level message Caused by error in `h()`: ! Low-level message --- Backtrace: x 1. \-quux() 2. \-foofy() Code summary(err) Output Error in `baz()`: ! High-level message Caused by error in `h()`: ! Low-level message --- Backtrace: x 1. \-quux() 2. \-foofy() # rethrowing from an exiting handler Code # Full print(trace, simplify = "none", dir = dir, srcrefs = srcrefs) Output Error in `baz()`: ! bar Caused by error in `h()`: ! foo --- Backtrace: x 1. +-rlang::catch_cnd(foo(), "error") 2. | +-rlang::eval_bare(...) 3. | +-base::tryCatch(...) 4. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 5. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 6. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 7. | \-base::force(expr) 8. \-rlang (local) foo() 9. \-rlang (local) bar() 10. \-rlang (local) baz() 11. +-base::tryCatch(f(), error = function(err) abort("bar", parent = err)) 12. | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 13. | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 14. | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 15. \-rlang (local) f() 16. \-rlang (local) g() 17. \-rlang (local) h() Code # Focused print_focused_trace(trace, dir = dir, srcrefs = srcrefs) Output Error in `baz()`: ! bar Caused by error in `h()`: ! foo --- Backtrace: x 1. +-rlang::catch_cnd(foo(), "error") 2. | <<+-rlang::eval_bare(...)>> 3. | <<+-base::tryCatch(...)>> 4. | <<| \-base (local) tryCatchList(expr, classes, parentenv, handlers)>> 5. | <<| \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]])>> 6. | <<| \-base (local) doTryCatch(return(expr), name, parentenv, handler)>> 7. | <<\-base::force(expr)>> 8. \-rlang (local) foo() 9. \-rlang (local) bar() 10. \-rlang (local) baz() 11. +<<-base::tryCatch(f(), error = function(err) abort("bar", parent = err))>> 12. | <<\-base (local) tryCatchList(expr, classes, parentenv, handlers)>> 13. | <<\-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]])>> 14. | <<\-base (local) doTryCatch(return(expr), name, parentenv, handler)>> 15. \-rlang (local) f() 16. \-rlang (local) g() 17. \-rlang (local) h() Code # Branch print(trace, simplify = "branch", dir = dir, srcrefs = srcrefs) Output Error in `baz()`: ! bar Caused by error in `h()`: ! foo --- Backtrace: 1. rlang::catch_cnd(foo(), "error") 8. rlang (local) foo() 9. rlang (local) bar() 10. rlang (local) baz() 15. rlang (local) f() 16. rlang (local) g() 17. rlang (local) h() # bare conditions must be subclassed Code (expect_error(cnd())) Output Error in `cnd()`: ! `class` is absent but must be supplied. Code (expect_error(signal(""))) Output Error in `signal()`: ! `class` is absent but must be supplied. # cnd_type_header() formats condition classes Code cnd_type_header(error_cnd()) Output [1] "" Code cnd_type_header(warning_cnd()) Output [1] "" Code cnd_type_header(message_cnd()) Output [1] "" Code cnd_type_header(error_cnd(class = "foobar")) Output [1] "" # can format warnings and other conditions Warning in `quux()`: Header. i Bullet. --- Backtrace: x 1. \-foo() 2. \-bar() --- Message in `quux()`: Header. i Bullet. Caused by warning in `quux()`: ! Header. i Bullet. --- Backtrace: x 1. \-foo() 2. \-bar() --- Condition in `quux()`: Header. i Bullet. --- Backtrace: x 1. \-foo() 2. \-bar() # warnings and messages have `summary()` methods Code print(warning) Output --- Backtrace: x 1. \-f() 2. \-g() Code print(message) Output --- Backtrace: x 1. \-f() 2. \-g() Code summary(warning) Output --- Backtrace: x 1. \-f() 2. \-g() Code summary(message) Output --- Backtrace: x 1. \-f() 2. \-g() # cnd ctors check arguments Code (expect_error(warning_cnd(class = list()))) Output Error in `warning_cnd()`: ! `class` must be a character vector, not a list. Code (expect_error(error_cnd(class = list()))) Output Error in `error_cnd()`: ! `class` must be a character vector, not a list. Code (expect_error(message_cnd(message = 1))) Output Error in `message_cnd()`: ! `message` must be a character vector, not the number 1. # picks up cli format flag Code cnd_signal(error_cnd(message = c("foo", i = "bar"))) Condition Error: ! foo i bar Code cnd_signal(warning_cnd(message = c("foo", i = "bar"))) Condition Warning: foo i bar Code cnd_signal(message_cnd(message = c("foo", i = "bar"))) Message foo i bar --- Code cnd_signal(error_cnd(message = c("foo", i = "bar"))) Condition Error: ! foo bar Code cnd_signal(warning_cnd(message = c("foo", i = "bar"))) Condition Warning: foo bar Code cnd_signal(message_cnd(message = c("foo", i = "bar"))) Message foo bar rlang/tests/testthat/_snaps/standalone-downstream-deps.md0000644000176200001440000000056614657520711023445 0ustar liggesusers# can check downstream versions Code (expect_warning({ expect_false(.rlang_downstream_check(pkg = "rlang", pkg_ver = "0.5.0", deps = bad_deps, info = "Consequences.", env = env(checked = FALSE))) NULL })) Output Warning: The package `utils` (>= 100.10) is required as of rlang 0.5.0. rlang/tests/testthat/_snaps/arg.md0000644000176200001440000001667114741441060016751 0ustar liggesusers# matches arg `arg` must be one of "bar" or "baz", not "foo". # gives an error with more than one arg Code (expect_error(arg_match0_wrapper(c("bar", "fun"), c("bar", "baz")))) Output Error in `arg_match0_wrapper()`: ! `arg` must be length 1 or a permutation of `c("bar", "baz")`. # gives error with different than rearranged arg vs value `myarg` must be one of "fun" or "bar", not "foo". --- `arg` must be length 1 or a permutation of `c("foo", "bar")`. # `arg_match()` has informative error messages Code (expect_error(arg_match_wrapper("continuuos", c("discrete", "continuous"), "my_arg"))) Output Error in `arg_match0_wrapper()`: ! `my_arg` must be one of "discrete" or "continuous", not "continuuos". i Did you mean "continuous"? Code (expect_error(arg_match_wrapper("fou", c("bar", "foo"), "my_arg"))) Output Error in `arg_match0_wrapper()`: ! `my_arg` must be one of "bar" or "foo", not "fou". i Did you mean "foo"? Code (expect_error(arg_match_wrapper("fu", c("ba", "fo"), "my_arg"))) Output Error in `arg_match0_wrapper()`: ! `my_arg` must be one of "ba" or "fo", not "fu". i Did you mean "fo"? Code (expect_error(arg_match_wrapper("baq", c("foo", "baz", "bas"), "my_arg"))) Output Error in `arg_match0_wrapper()`: ! `my_arg` must be one of "foo", "baz", or "bas", not "baq". i Did you mean "baz"? Code (expect_error(arg_match_wrapper("", character(), "my_arg"))) Output Error in `arg_match0()`: ! `values` must have at least one element. Code (expect_error(arg_match_wrapper("fo", "foo", quote(f())))) Output Error in `arg_match0()`: ! `arg_nm` must be a string or symbol. # `arg_match()` provides no suggestion when the edit distance is too large Code (expect_error(arg_match0_wrapper("foobaz", c("fooquxs", "discrete"), "my_arg"))) Output Error in `arg_match0_wrapper()`: ! `my_arg` must be one of "fooquxs" or "discrete", not "foobaz". Code (expect_error(arg_match0_wrapper("a", c("b", "c"), "my_arg"))) Output Error in `arg_match0_wrapper()`: ! `my_arg` must be one of "b" or "c", not "a". # `arg_match()` makes case-insensitive match Code (expect_error(arg_match0_wrapper("a", c("A", "B"), "my_arg"), "Did you mean \"A\"?")) Output Error in `arg_match0_wrapper()`: ! `my_arg` must be one of "A" or "B", not "a". i Did you mean "A"? Code (expect_error(arg_match0_wrapper("aa", c("AA", "aA"), "my_arg"), "Did you mean \"aA\"?")) Output Error in `arg_match0_wrapper()`: ! `my_arg` must be one of "AA" or "aA", not "aa". i Did you mean "aA"? # check_required() checks argument is supplied (#1118) Code (expect_error(f())) Output Error in `f()`: ! `x` is absent but must be supplied. Code (expect_error(g())) Output Error in `f()`: ! `x` is absent but must be supplied. # arg_match() supports symbols and scalar strings Code (expect_error(arg_match0_wrapper(chr_get("fo", 0L), c("bar", "foo"), "my_arg"))) Output Error in `arg_match0_wrapper()`: ! `my_arg` must be one of "bar" or "foo", not "fo". i Did you mean "foo"? # arg_match() requires an argument symbol Code (expect_error(wrapper())) Output Error in `arg_match()`: ! `arg` must be a symbol, not the string "foo". # can match multiple arguments Code (expect_error(my_wrapper("ba"))) Output Error in `my_wrapper()`: ! `my_arg` must be one of "foo", "bar", or "baz", not "ba". i Did you mean "bar"? Code (expect_error(my_wrapper(c("foo", "ba")))) Output Error in `my_wrapper()`: ! `my_arg` must be one of "foo", "bar", or "baz", not "ba". i Did you mean "bar"? # arg_match0() defuses argument Code (expect_error(fn("foo"))) Output Error in `fn()`: ! `arg` must be one of "bar" or "baz", not "foo". Code (expect_error(arg_match0("foo", c("bar", "baz")))) Output Error: ! `"foo"` must be one of "bar" or "baz", not "foo". # check_exclusive works Code (expect_error(f())) Output Error in `check_exclusive()`: ! Must supply at least two arguments. Code (expect_error(g())) Output Error in `check_exclusive()`: ! Must supply at least two arguments. Code (expect_error(h())) Output Error in `check_exclusive()`: ! Must supply at least two arguments. --- Code (expect_error(f())) Output Error in `f()`: ! One of `foo` or `bar` must be supplied. --- Code # All arguments supplied (expect_error(g(foo, bar, baz))) Output Error in `g()`: ! Exactly one of `foo`, `bar`, or `baz` must be supplied. Code # Some arguments supplied (expect_error(g(foo, bar))) Output Error in `g()`: ! Exactly one of `foo`, `bar`, or `baz` must be supplied. x `foo` and `bar` were supplied together. # arg_match() mentions correct call if wrong type is supplied (#1388) Code (expect_error(f(1))) Output Error in `f()`: ! `my_arg` must be a string or character vector. Code (expect_error(g(1))) Output Error in `g()`: ! `my_arg` must be a character vector, not the number 1. # arg_match() backtrace highlights call and arg Code print_highlighted_trace(err) Output Error in <>: ! `my_arg` must be one of "foo" or "bar", not "f". i Did you mean "foo"? --- Backtrace: x 1. +-rlang:::catch_error(f("f")) 2. | \-rlang::catch_cnd(expr, "error") 3. | +-rlang::eval_bare(...) 4. | +-base::tryCatch(...) 5. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 6. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 7. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 8. | \-base::force(expr) 9. \-rlang (local) f("f") 10. \-rlang (local) g(x) 11. \-rlang (local) <><><> # arg_match() supports `NA` (#1519) Code (expect_error(f(NA))) Output Error in `f()`: ! `x` must be a character vector, not `NA`. Code (expect_error(f(na_chr))) Output Error in `f()`: ! `x` must be a single string, not a character `NA`. Code (expect_error(f(chr()))) Output Error in `f()`: ! `x` must be length 1, not length 0 rlang/tests/testthat/_snaps/cnd-abort.md0000644000176200001440000020455514667532743020071 0ustar liggesusers# Invalid on_error option resets itself Code (expect_warning(tryCatch(abort("foo"), error = identity))) Output Warning: Invalid `rlang_backtrace_on_error` option. i The option was just reset to `NULL`. # error is printed with backtrace Code cat_line(default_interactive) Output Error in `h()`: ! Error message Run `rlang::last_trace()` to see where the error occurred. Execution halted Code cat_line(default_non_interactive) Output Error in `h()`: ! Error message Backtrace: x 1. \-global f() 2. +-base::tryCatch(g()) 3. | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 4. \-global g() 5. \-global h() 6. \-rlang::abort("Error message") Execution halted Code cat_line(reminder) Output Error in `h()`: ! Error message Execution halted Code cat_line(branch) Output Error in `h()`: ! Error message Backtrace: 1. global f() 4. global g() 5. global h() Execution halted Code cat_line(collapse) Output Error in `h()`: ! Error message Warning message: `"collapse"` is deprecated as of rlang 1.1.0. Please use `"none"` instead. This warning is displayed once every 8 hours. Execution halted Code cat_line(full) Output Error in `h()`: ! Error message Backtrace: x 1. \-global f() 2. +-base::tryCatch(g()) 3. | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 4. \-global g() 5. \-global h() 6. \-rlang::abort("Error message") Execution halted Code cat_line(rethrown_interactive) Output Error in `h()`: ! Error message Run `rlang::last_trace()` to see where the error occurred. Execution halted Code cat_line(rethrown_non_interactive) Output Error in `h()`: ! Error message Backtrace: x 1. +-base::tryCatch(f(), error = function(cnd) rlang::cnd_signal(cnd)) 2. | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 3. | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 4. | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 5. \-global f() 6. +-base::tryCatch(g()) 7. | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 8. \-global g() 9. \-global h() 10. \-rlang::abort("Error message") Execution halted # empty backtraces are not printed Code cat_line(branch_depth_0) Output Error: ! foo Backtrace: 1. rlang::abort("foo") Execution halted Code cat_line(full_depth_0) Output Error: ! foo Backtrace: x 1. \-rlang::abort("foo") Execution halted Code cat_line(branch_depth_1) Output Error in `f()`: ! foo Backtrace: 1. global f() Execution halted Code cat_line(full_depth_1) Output Error in `f()`: ! foo Backtrace: x 1. \-global f() 2. \-rlang::abort("foo") Execution halted # parent errors are not displayed in error message and backtrace Code cat_line(interactive) Output Error in `c()`: ! bar Caused by error in `h()`: ! foo Run `rlang::last_trace()` to see where the error occurred. Execution halted Code cat_line(non_interactive) Output Error in `c()`: ! bar Caused by error in `h()`: ! foo Backtrace: x 1. \-global a() 2. \-global b() 3. \-global c() 4. +-base::tryCatch(...) 5. | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 6. | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 7. | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 8. \-global f() 9. \-global g() 10. \-global h() 11. \-rlang::abort("foo") Execution halted # backtrace reminder is displayed when called from `last_error()` Code # Normal case print(err) Output Error in `h()`: ! foo --- Backtrace: x 1. +-rlang:::catch_error(f()) 2. | \-rlang::catch_cnd(expr, "error") 3. | +-rlang::eval_bare(...) 4. | +-base::tryCatch(...) 5. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 6. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 7. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 8. | \-base::force(expr) 9. \-rlang (local) f() 10. \-rlang (local) g() 11. \-rlang (local) h() Code # From `last_error()` print(last_error()) Output Error in `h()`: ! foo --- Backtrace: x 1. +-rlang:::catch_error(f()) 2. | \-rlang::catch_cnd(expr, "error") 3. | +-rlang::eval_bare(...) 4. | +-base::tryCatch(...) 5. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 6. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 7. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 8. | \-base::force(expr) 9. \-rlang (local) f() 10. \-rlang (local) g() 11. \-rlang (local) h() Run rlang::last_trace(drop = FALSE) to see 1 hidden frame. Code # Saved from `last_error()` { saved <- last_error() print(saved) } Output Error in `h()`: ! foo --- Backtrace: x 1. +-rlang:::catch_error(f()) 2. | \-rlang::catch_cnd(expr, "error") 3. | +-rlang::eval_bare(...) 4. | +-base::tryCatch(...) 5. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 6. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 7. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 8. | \-base::force(expr) 9. \-rlang (local) f() 10. \-rlang (local) g() 11. \-rlang (local) h() Run rlang::last_trace(drop = FALSE) to see 1 hidden frame. Code # Saved from `last_error()`, but no longer last { poke_last_error(error_cnd("foo")) print(saved) } Output Error in `h()`: ! foo --- Backtrace: x 1. +-rlang:::catch_error(f()) 2. | \-rlang::catch_cnd(expr, "error") 3. | +-rlang::eval_bare(...) 4. | +-base::tryCatch(...) 5. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 6. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 7. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 8. | \-base::force(expr) 9. \-rlang (local) f() 10. \-rlang (local) g() 11. \-rlang (local) h() Run rlang::last_trace(drop = FALSE) to see 1 hidden frame. # Backtrace on rethrow: stop() - tryCatch() Code print(catch_error(high1(chain = TRUE, stop_helper = TRUE))) Output Error in `high3()`: ! high-level Caused by error in `low3()`: ! low-level --- Backtrace: x 1. +-base::print(catch_error(high1(chain = TRUE, stop_helper = TRUE))) 2. +-rlang:::catch_error(high1(chain = TRUE, stop_helper = TRUE)) 3. | \-rlang::catch_cnd(expr, "error") 4. | +-rlang::eval_bare(...) 5. | +-base::tryCatch(...) 6. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 7. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 8. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 9. | \-base::force(expr) 10. \-rlang (local) high1(chain = TRUE, stop_helper = TRUE) 11. \-rlang (local) high2(...) 12. \-rlang (local) high3(...) Code print(catch_error(high1(chain = TRUE, stop_helper = FALSE))) Output Error in `high3()`: ! high-level Caused by error in `low3()`: ! low-level --- Backtrace: x 1. +-base::print(catch_error(high1(chain = TRUE, stop_helper = FALSE))) 2. +-rlang:::catch_error(high1(chain = TRUE, stop_helper = FALSE)) 3. | \-rlang::catch_cnd(expr, "error") 4. | +-rlang::eval_bare(...) 5. | +-base::tryCatch(...) 6. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 7. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 8. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 9. | \-base::force(expr) 10. \-rlang (local) high1(chain = TRUE, stop_helper = FALSE) 11. \-rlang (local) high2(...) 12. \-rlang (local) high3(...) Code print(catch_error(high1(chain = FALSE, stop_helper = TRUE))) Output Error in `high3()`: ! high-level Caused by error in `low3()`: ! low-level --- Backtrace: x 1. +-base::print(catch_error(high1(chain = FALSE, stop_helper = TRUE))) 2. +-rlang:::catch_error(high1(chain = FALSE, stop_helper = TRUE)) 3. | \-rlang::catch_cnd(expr, "error") 4. | +-rlang::eval_bare(...) 5. | +-base::tryCatch(...) 6. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 7. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 8. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 9. | \-base::force(expr) 10. \-rlang (local) high1(chain = FALSE, stop_helper = TRUE) 11. \-rlang (local) high2(...) 12. \-rlang (local) high3(...) Code print(catch_error(high1(chain = FALSE, stop_helper = FALSE))) Output Error in `high3()`: ! high-level Caused by error in `low3()`: ! low-level --- Backtrace: x 1. +-base::print(catch_error(high1(chain = FALSE, stop_helper = FALSE))) 2. +-rlang:::catch_error(high1(chain = FALSE, stop_helper = FALSE)) 3. | \-rlang::catch_cnd(expr, "error") 4. | +-rlang::eval_bare(...) 5. | +-base::tryCatch(...) 6. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 7. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 8. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 9. | \-base::force(expr) 10. \-rlang (local) high1(chain = FALSE, stop_helper = FALSE) 11. \-rlang (local) high2(...) 12. \-rlang (local) high3(...) # Backtrace on rethrow: stop() - withCallingHandlers() Code print(catch_error(high1(chain = TRUE, stop_helper = TRUE))) Output Error in `high3()`: ! high-level Caused by error in `low3()`: ! low-level --- Backtrace: x 1. +-base::print(catch_error(high1(chain = TRUE, stop_helper = TRUE))) 2. +-rlang:::catch_error(high1(chain = TRUE, stop_helper = TRUE)) 3. | \-rlang::catch_cnd(expr, "error") 4. | +-rlang::eval_bare(...) 5. | +-base::tryCatch(...) 6. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 7. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 8. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 9. | \-base::force(expr) 10. \-rlang (local) high1(chain = TRUE, stop_helper = TRUE) 11. \-rlang (local) high2(...) 12. \-rlang (local) high3(...) 13. +-base::withCallingHandlers(...) 14. \-rlang (local) low1() 15. \-rlang (local) low2() 16. \-rlang (local) low3() 17. \-base::stop("low-level") Code print(catch_error(high1(chain = TRUE, stop_helper = FALSE))) Output Error in `high3()`: ! high-level Caused by error in `low3()`: ! low-level --- Backtrace: x 1. +-base::print(catch_error(high1(chain = TRUE, stop_helper = FALSE))) 2. +-rlang:::catch_error(high1(chain = TRUE, stop_helper = FALSE)) 3. | \-rlang::catch_cnd(expr, "error") 4. | +-rlang::eval_bare(...) 5. | +-base::tryCatch(...) 6. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 7. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 8. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 9. | \-base::force(expr) 10. \-rlang (local) high1(chain = TRUE, stop_helper = FALSE) 11. \-rlang (local) high2(...) 12. \-rlang (local) high3(...) 13. +-base::withCallingHandlers(...) 14. \-rlang (local) low1() 15. \-rlang (local) low2() 16. \-rlang (local) low3() 17. \-base::stop("low-level") Code print(catch_error(high1(chain = FALSE, stop_helper = TRUE))) Output Error in `high3()`: ! high-level Caused by error in `low3()`: ! low-level --- Backtrace: x 1. +-base::print(catch_error(high1(chain = FALSE, stop_helper = TRUE))) 2. +-rlang:::catch_error(high1(chain = FALSE, stop_helper = TRUE)) 3. | \-rlang::catch_cnd(expr, "error") 4. | +-rlang::eval_bare(...) 5. | +-base::tryCatch(...) 6. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 7. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 8. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 9. | \-base::force(expr) 10. \-rlang (local) high1(chain = FALSE, stop_helper = TRUE) 11. \-rlang (local) high2(...) 12. \-rlang (local) high3(...) 13. +-base::withCallingHandlers(...) 14. \-rlang (local) low1() 15. \-rlang (local) low2() 16. \-rlang (local) low3() 17. \-base::stop("low-level") Code print(catch_error(high1(chain = FALSE, stop_helper = FALSE))) Output Error in `high3()`: ! high-level Caused by error in `low3()`: ! low-level --- Backtrace: x 1. +-base::print(catch_error(high1(chain = FALSE, stop_helper = FALSE))) 2. +-rlang:::catch_error(high1(chain = FALSE, stop_helper = FALSE)) 3. | \-rlang::catch_cnd(expr, "error") 4. | +-rlang::eval_bare(...) 5. | +-base::tryCatch(...) 6. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 7. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 8. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 9. | \-base::force(expr) 10. \-rlang (local) high1(chain = FALSE, stop_helper = FALSE) 11. \-rlang (local) high2(...) 12. \-rlang (local) high3(...) 13. +-base::withCallingHandlers(...) 14. \-rlang (local) low1() 15. \-rlang (local) low2() 16. \-rlang (local) low3() 17. \-base::stop("low-level") # Backtrace on rethrow: stop() - try_fetch() Code print(catch_error(high1(chain = TRUE, stop_helper = TRUE))) Output Error in `high3()`: ! high-level Caused by error in `low3()`: ! low-level --- Backtrace: x 1. +-base::print(catch_error(high1(chain = TRUE, stop_helper = TRUE))) 2. +-rlang:::catch_error(high1(chain = TRUE, stop_helper = TRUE)) 3. | \-rlang::catch_cnd(expr, "error") 4. | +-rlang::eval_bare(...) 5. | +-base::tryCatch(...) 6. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 7. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 8. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 9. | \-base::force(expr) 10. \-rlang (local) high1(chain = TRUE, stop_helper = TRUE) 11. \-rlang (local) high2(...) 12. \-rlang (local) high3(...) 13. +-rlang::try_fetch(...) 14. | +-base::tryCatch(...) 15. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 16. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 17. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 18. | \-base::withCallingHandlers(...) 19. \-rlang (local) low1() 20. \-rlang (local) low2() 21. \-rlang (local) low3() 22. \-base::stop("low-level") Code print(catch_error(high1(chain = TRUE, stop_helper = FALSE))) Output Error in `high3()`: ! high-level Caused by error in `low3()`: ! low-level --- Backtrace: x 1. +-base::print(catch_error(high1(chain = TRUE, stop_helper = FALSE))) 2. +-rlang:::catch_error(high1(chain = TRUE, stop_helper = FALSE)) 3. | \-rlang::catch_cnd(expr, "error") 4. | +-rlang::eval_bare(...) 5. | +-base::tryCatch(...) 6. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 7. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 8. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 9. | \-base::force(expr) 10. \-rlang (local) high1(chain = TRUE, stop_helper = FALSE) 11. \-rlang (local) high2(...) 12. \-rlang (local) high3(...) 13. +-rlang::try_fetch(...) 14. | +-base::tryCatch(...) 15. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 16. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 17. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 18. | \-base::withCallingHandlers(...) 19. \-rlang (local) low1() 20. \-rlang (local) low2() 21. \-rlang (local) low3() 22. \-base::stop("low-level") Code print(catch_error(high1(chain = FALSE, stop_helper = TRUE))) Output Error in `high3()`: ! high-level Caused by error in `low3()`: ! low-level --- Backtrace: x 1. +-base::print(catch_error(high1(chain = FALSE, stop_helper = TRUE))) 2. +-rlang:::catch_error(high1(chain = FALSE, stop_helper = TRUE)) 3. | \-rlang::catch_cnd(expr, "error") 4. | +-rlang::eval_bare(...) 5. | +-base::tryCatch(...) 6. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 7. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 8. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 9. | \-base::force(expr) 10. \-rlang (local) high1(chain = FALSE, stop_helper = TRUE) 11. \-rlang (local) high2(...) 12. \-rlang (local) high3(...) 13. +-rlang::try_fetch(...) 14. | +-base::tryCatch(...) 15. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 16. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 17. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 18. | \-base::withCallingHandlers(...) 19. \-rlang (local) low1() 20. \-rlang (local) low2() 21. \-rlang (local) low3() 22. \-base::stop("low-level") Code print(catch_error(high1(chain = FALSE, stop_helper = FALSE))) Output Error in `high3()`: ! high-level Caused by error in `low3()`: ! low-level --- Backtrace: x 1. +-base::print(catch_error(high1(chain = FALSE, stop_helper = FALSE))) 2. +-rlang:::catch_error(high1(chain = FALSE, stop_helper = FALSE)) 3. | \-rlang::catch_cnd(expr, "error") 4. | +-rlang::eval_bare(...) 5. | +-base::tryCatch(...) 6. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 7. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 8. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 9. | \-base::force(expr) 10. \-rlang (local) high1(chain = FALSE, stop_helper = FALSE) 11. \-rlang (local) high2(...) 12. \-rlang (local) high3(...) 13. +-rlang::try_fetch(...) 14. | +-base::tryCatch(...) 15. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 16. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 17. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 18. | \-base::withCallingHandlers(...) 19. \-rlang (local) low1() 20. \-rlang (local) low2() 21. \-rlang (local) low3() 22. \-base::stop("low-level") # Backtrace on rethrow: abort() - tryCatch() Code print(catch_error(high1(chain = TRUE, stop_helper = TRUE))) Output Error in `high3()`: ! high-level Caused by error in `low3()`: ! low-level --- Backtrace: x 1. +-base::print(catch_error(high1(chain = TRUE, stop_helper = TRUE))) 2. +-rlang:::catch_error(high1(chain = TRUE, stop_helper = TRUE)) 3. | \-rlang::catch_cnd(expr, "error") 4. | +-rlang::eval_bare(...) 5. | +-base::tryCatch(...) 6. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 7. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 8. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 9. | \-base::force(expr) 10. \-rlang (local) high1(chain = TRUE, stop_helper = TRUE) 11. \-rlang (local) high2(...) 12. \-rlang (local) high3(...) 13. +-base::tryCatch(...) 14. | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 15. | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 16. | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 17. \-rlang (local) low1() 18. \-rlang (local) low2() 19. \-rlang (local) low3() Code print(catch_error(high1(chain = TRUE, stop_helper = FALSE))) Output Error in `high3()`: ! high-level Caused by error in `low3()`: ! low-level --- Backtrace: x 1. +-base::print(catch_error(high1(chain = TRUE, stop_helper = FALSE))) 2. +-rlang:::catch_error(high1(chain = TRUE, stop_helper = FALSE)) 3. | \-rlang::catch_cnd(expr, "error") 4. | +-rlang::eval_bare(...) 5. | +-base::tryCatch(...) 6. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 7. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 8. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 9. | \-base::force(expr) 10. \-rlang (local) high1(chain = TRUE, stop_helper = FALSE) 11. \-rlang (local) high2(...) 12. \-rlang (local) high3(...) 13. +-base::tryCatch(...) 14. | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 15. | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 16. | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 17. \-rlang (local) low1() 18. \-rlang (local) low2() 19. \-rlang (local) low3() Code print(catch_error(high1(chain = FALSE, stop_helper = TRUE))) Output Error in `high3()`: ! high-level Caused by error in `low3()`: ! low-level --- Backtrace: x 1. +-base::print(catch_error(high1(chain = FALSE, stop_helper = TRUE))) 2. +-rlang:::catch_error(high1(chain = FALSE, stop_helper = TRUE)) 3. | \-rlang::catch_cnd(expr, "error") 4. | +-rlang::eval_bare(...) 5. | +-base::tryCatch(...) 6. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 7. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 8. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 9. | \-base::force(expr) 10. \-rlang (local) high1(chain = FALSE, stop_helper = TRUE) 11. \-rlang (local) high2(...) 12. \-rlang (local) high3(...) 13. +-base::tryCatch(...) 14. | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 15. | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 16. | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 17. \-rlang (local) low1() 18. \-rlang (local) low2() 19. \-rlang (local) low3() Code print(catch_error(high1(chain = FALSE, stop_helper = FALSE))) Output Error in `high3()`: ! high-level Caused by error in `low3()`: ! low-level --- Backtrace: x 1. +-base::print(catch_error(high1(chain = FALSE, stop_helper = FALSE))) 2. +-rlang:::catch_error(high1(chain = FALSE, stop_helper = FALSE)) 3. | \-rlang::catch_cnd(expr, "error") 4. | +-rlang::eval_bare(...) 5. | +-base::tryCatch(...) 6. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 7. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 8. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 9. | \-base::force(expr) 10. \-rlang (local) high1(chain = FALSE, stop_helper = FALSE) 11. \-rlang (local) high2(...) 12. \-rlang (local) high3(...) 13. +-base::tryCatch(...) 14. | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 15. | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 16. | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 17. \-rlang (local) low1() 18. \-rlang (local) low2() 19. \-rlang (local) low3() # Backtrace on rethrow: abort() - withCallingHandlers() Code print(catch_error(high1(chain = TRUE, stop_helper = TRUE))) Output Error in `high3()`: ! high-level Caused by error in `low3()`: ! low-level --- Backtrace: x 1. +-base::print(catch_error(high1(chain = TRUE, stop_helper = TRUE))) 2. +-rlang:::catch_error(high1(chain = TRUE, stop_helper = TRUE)) 3. | \-rlang::catch_cnd(expr, "error") 4. | +-rlang::eval_bare(...) 5. | +-base::tryCatch(...) 6. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 7. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 8. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 9. | \-base::force(expr) 10. \-rlang (local) high1(chain = TRUE, stop_helper = TRUE) 11. \-rlang (local) high2(...) 12. \-rlang (local) high3(...) 13. +-base::withCallingHandlers(...) 14. \-rlang (local) low1() 15. \-rlang (local) low2() 16. \-rlang (local) low3() Code print(catch_error(high1(chain = TRUE, stop_helper = FALSE))) Output Error in `high3()`: ! high-level Caused by error in `low3()`: ! low-level --- Backtrace: x 1. +-base::print(catch_error(high1(chain = TRUE, stop_helper = FALSE))) 2. +-rlang:::catch_error(high1(chain = TRUE, stop_helper = FALSE)) 3. | \-rlang::catch_cnd(expr, "error") 4. | +-rlang::eval_bare(...) 5. | +-base::tryCatch(...) 6. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 7. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 8. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 9. | \-base::force(expr) 10. \-rlang (local) high1(chain = TRUE, stop_helper = FALSE) 11. \-rlang (local) high2(...) 12. \-rlang (local) high3(...) 13. +-base::withCallingHandlers(...) 14. \-rlang (local) low1() 15. \-rlang (local) low2() 16. \-rlang (local) low3() Code print(catch_error(high1(chain = FALSE, stop_helper = TRUE))) Output Error in `high3()`: ! high-level Caused by error in `low3()`: ! low-level --- Backtrace: x 1. +-base::print(catch_error(high1(chain = FALSE, stop_helper = TRUE))) 2. +-rlang:::catch_error(high1(chain = FALSE, stop_helper = TRUE)) 3. | \-rlang::catch_cnd(expr, "error") 4. | +-rlang::eval_bare(...) 5. | +-base::tryCatch(...) 6. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 7. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 8. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 9. | \-base::force(expr) 10. \-rlang (local) high1(chain = FALSE, stop_helper = TRUE) 11. \-rlang (local) high2(...) 12. \-rlang (local) high3(...) 13. +-base::withCallingHandlers(...) 14. \-rlang (local) low1() 15. \-rlang (local) low2() 16. \-rlang (local) low3() Code print(catch_error(high1(chain = FALSE, stop_helper = FALSE))) Output Error in `high3()`: ! high-level Caused by error in `low3()`: ! low-level --- Backtrace: x 1. +-base::print(catch_error(high1(chain = FALSE, stop_helper = FALSE))) 2. +-rlang:::catch_error(high1(chain = FALSE, stop_helper = FALSE)) 3. | \-rlang::catch_cnd(expr, "error") 4. | +-rlang::eval_bare(...) 5. | +-base::tryCatch(...) 6. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 7. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 8. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 9. | \-base::force(expr) 10. \-rlang (local) high1(chain = FALSE, stop_helper = FALSE) 11. \-rlang (local) high2(...) 12. \-rlang (local) high3(...) 13. +-base::withCallingHandlers(...) 14. \-rlang (local) low1() 15. \-rlang (local) low2() 16. \-rlang (local) low3() # Backtrace on rethrow: abort() - try_fetch() Code print(catch_error(high1(chain = TRUE, stop_helper = TRUE))) Output Error in `high3()`: ! high-level Caused by error in `low3()`: ! low-level --- Backtrace: x 1. +-base::print(catch_error(high1(chain = TRUE, stop_helper = TRUE))) 2. +-rlang:::catch_error(high1(chain = TRUE, stop_helper = TRUE)) 3. | \-rlang::catch_cnd(expr, "error") 4. | +-rlang::eval_bare(...) 5. | +-base::tryCatch(...) 6. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 7. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 8. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 9. | \-base::force(expr) 10. \-rlang (local) high1(chain = TRUE, stop_helper = TRUE) 11. \-rlang (local) high2(...) 12. \-rlang (local) high3(...) 13. +-rlang::try_fetch(...) 14. | +-base::tryCatch(...) 15. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 16. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 17. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 18. | \-base::withCallingHandlers(...) 19. \-rlang (local) low1() 20. \-rlang (local) low2() 21. \-rlang (local) low3() Code print(catch_error(high1(chain = TRUE, stop_helper = FALSE))) Output Error in `high3()`: ! high-level Caused by error in `low3()`: ! low-level --- Backtrace: x 1. +-base::print(catch_error(high1(chain = TRUE, stop_helper = FALSE))) 2. +-rlang:::catch_error(high1(chain = TRUE, stop_helper = FALSE)) 3. | \-rlang::catch_cnd(expr, "error") 4. | +-rlang::eval_bare(...) 5. | +-base::tryCatch(...) 6. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 7. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 8. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 9. | \-base::force(expr) 10. \-rlang (local) high1(chain = TRUE, stop_helper = FALSE) 11. \-rlang (local) high2(...) 12. \-rlang (local) high3(...) 13. +-rlang::try_fetch(...) 14. | +-base::tryCatch(...) 15. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 16. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 17. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 18. | \-base::withCallingHandlers(...) 19. \-rlang (local) low1() 20. \-rlang (local) low2() 21. \-rlang (local) low3() Code print(catch_error(high1(chain = FALSE, stop_helper = TRUE))) Output Error in `high3()`: ! high-level Caused by error in `low3()`: ! low-level --- Backtrace: x 1. +-base::print(catch_error(high1(chain = FALSE, stop_helper = TRUE))) 2. +-rlang:::catch_error(high1(chain = FALSE, stop_helper = TRUE)) 3. | \-rlang::catch_cnd(expr, "error") 4. | +-rlang::eval_bare(...) 5. | +-base::tryCatch(...) 6. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 7. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 8. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 9. | \-base::force(expr) 10. \-rlang (local) high1(chain = FALSE, stop_helper = TRUE) 11. \-rlang (local) high2(...) 12. \-rlang (local) high3(...) 13. +-rlang::try_fetch(...) 14. | +-base::tryCatch(...) 15. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 16. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 17. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 18. | \-base::withCallingHandlers(...) 19. \-rlang (local) low1() 20. \-rlang (local) low2() 21. \-rlang (local) low3() Code print(catch_error(high1(chain = FALSE, stop_helper = FALSE))) Output Error in `high3()`: ! high-level Caused by error in `low3()`: ! low-level --- Backtrace: x 1. +-base::print(catch_error(high1(chain = FALSE, stop_helper = FALSE))) 2. +-rlang:::catch_error(high1(chain = FALSE, stop_helper = FALSE)) 3. | \-rlang::catch_cnd(expr, "error") 4. | +-rlang::eval_bare(...) 5. | +-base::tryCatch(...) 6. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 7. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 8. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 9. | \-base::force(expr) 10. \-rlang (local) high1(chain = FALSE, stop_helper = FALSE) 11. \-rlang (local) high2(...) 12. \-rlang (local) high3(...) 13. +-rlang::try_fetch(...) 14. | +-base::tryCatch(...) 15. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 16. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 17. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 18. | \-base::withCallingHandlers(...) 19. \-rlang (local) low1() 20. \-rlang (local) low2() 21. \-rlang (local) low3() # Backtrace on rethrow: warn = 2 - tryCatch() Code print(catch_error(high1(chain = TRUE, stop_helper = TRUE))) Output Error in `high3()`: ! high-level Caused by error in `low3()`: ! (converted from warning) low-level --- Backtrace: x 1. +-base::print(catch_error(high1(chain = TRUE, stop_helper = TRUE))) 2. +-rlang:::catch_error(high1(chain = TRUE, stop_helper = TRUE)) 3. | \-rlang::catch_cnd(expr, "error") 4. | +-rlang::eval_bare(...) 5. | +-base::tryCatch(...) 6. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 7. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 8. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 9. | \-base::force(expr) 10. \-rlang (local) high1(chain = TRUE, stop_helper = TRUE) 11. \-rlang (local) high2(...) 12. \-rlang (local) high3(...) Code print(catch_error(high1(chain = TRUE, stop_helper = FALSE))) Output Error in `high3()`: ! high-level Caused by error in `low3()`: ! (converted from warning) low-level --- Backtrace: x 1. +-base::print(catch_error(high1(chain = TRUE, stop_helper = FALSE))) 2. +-rlang:::catch_error(high1(chain = TRUE, stop_helper = FALSE)) 3. | \-rlang::catch_cnd(expr, "error") 4. | +-rlang::eval_bare(...) 5. | +-base::tryCatch(...) 6. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 7. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 8. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 9. | \-base::force(expr) 10. \-rlang (local) high1(chain = TRUE, stop_helper = FALSE) 11. \-rlang (local) high2(...) 12. \-rlang (local) high3(...) Code print(catch_error(high1(chain = FALSE, stop_helper = TRUE))) Output Error in `high3()`: ! high-level Caused by error in `low3()`: ! (converted from warning) low-level --- Backtrace: x 1. +-base::print(catch_error(high1(chain = FALSE, stop_helper = TRUE))) 2. +-rlang:::catch_error(high1(chain = FALSE, stop_helper = TRUE)) 3. | \-rlang::catch_cnd(expr, "error") 4. | +-rlang::eval_bare(...) 5. | +-base::tryCatch(...) 6. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 7. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 8. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 9. | \-base::force(expr) 10. \-rlang (local) high1(chain = FALSE, stop_helper = TRUE) 11. \-rlang (local) high2(...) 12. \-rlang (local) high3(...) Code print(catch_error(high1(chain = FALSE, stop_helper = FALSE))) Output Error in `high3()`: ! high-level Caused by error in `low3()`: ! (converted from warning) low-level --- Backtrace: x 1. +-base::print(catch_error(high1(chain = FALSE, stop_helper = FALSE))) 2. +-rlang:::catch_error(high1(chain = FALSE, stop_helper = FALSE)) 3. | \-rlang::catch_cnd(expr, "error") 4. | +-rlang::eval_bare(...) 5. | +-base::tryCatch(...) 6. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 7. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 8. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 9. | \-base::force(expr) 10. \-rlang (local) high1(chain = FALSE, stop_helper = FALSE) 11. \-rlang (local) high2(...) 12. \-rlang (local) high3(...) # Backtrace on rethrow: warn = 2 - withCallingHandlers() Code print(catch_error(high1(chain = TRUE, stop_helper = TRUE))) Output Error in `high3()`: ! high-level Caused by error in `low3()`: ! (converted from warning) low-level --- Backtrace: x 1. +-base::print(catch_error(high1(chain = TRUE, stop_helper = TRUE))) 2. +-rlang:::catch_error(high1(chain = TRUE, stop_helper = TRUE)) 3. | \-rlang::catch_cnd(expr, "error") 4. | +-rlang::eval_bare(...) 5. | +-base::tryCatch(...) 6. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 7. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 8. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 9. | \-base::force(expr) 10. \-rlang (local) high1(chain = TRUE, stop_helper = TRUE) 11. \-rlang (local) high2(...) 12. \-rlang (local) high3(...) 13. +-base::withCallingHandlers(...) 14. \-rlang (local) low1() 15. \-rlang (local) low2() 16. \-rlang (local) low3() 17. \-base::warning("low-level") Code print(catch_error(high1(chain = TRUE, stop_helper = FALSE))) Output Error in `high3()`: ! high-level Caused by error in `low3()`: ! (converted from warning) low-level --- Backtrace: x 1. +-base::print(catch_error(high1(chain = TRUE, stop_helper = FALSE))) 2. +-rlang:::catch_error(high1(chain = TRUE, stop_helper = FALSE)) 3. | \-rlang::catch_cnd(expr, "error") 4. | +-rlang::eval_bare(...) 5. | +-base::tryCatch(...) 6. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 7. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 8. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 9. | \-base::force(expr) 10. \-rlang (local) high1(chain = TRUE, stop_helper = FALSE) 11. \-rlang (local) high2(...) 12. \-rlang (local) high3(...) 13. +-base::withCallingHandlers(...) 14. \-rlang (local) low1() 15. \-rlang (local) low2() 16. \-rlang (local) low3() 17. \-base::warning("low-level") Code print(catch_error(high1(chain = FALSE, stop_helper = TRUE))) Output Error in `high3()`: ! high-level Caused by error in `low3()`: ! (converted from warning) low-level --- Backtrace: x 1. +-base::print(catch_error(high1(chain = FALSE, stop_helper = TRUE))) 2. +-rlang:::catch_error(high1(chain = FALSE, stop_helper = TRUE)) 3. | \-rlang::catch_cnd(expr, "error") 4. | +-rlang::eval_bare(...) 5. | +-base::tryCatch(...) 6. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 7. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 8. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 9. | \-base::force(expr) 10. \-rlang (local) high1(chain = FALSE, stop_helper = TRUE) 11. \-rlang (local) high2(...) 12. \-rlang (local) high3(...) 13. +-base::withCallingHandlers(...) 14. \-rlang (local) low1() 15. \-rlang (local) low2() 16. \-rlang (local) low3() 17. \-base::warning("low-level") Code print(catch_error(high1(chain = FALSE, stop_helper = FALSE))) Output Error in `high3()`: ! high-level Caused by error in `low3()`: ! (converted from warning) low-level --- Backtrace: x 1. +-base::print(catch_error(high1(chain = FALSE, stop_helper = FALSE))) 2. +-rlang:::catch_error(high1(chain = FALSE, stop_helper = FALSE)) 3. | \-rlang::catch_cnd(expr, "error") 4. | +-rlang::eval_bare(...) 5. | +-base::tryCatch(...) 6. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 7. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 8. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 9. | \-base::force(expr) 10. \-rlang (local) high1(chain = FALSE, stop_helper = FALSE) 11. \-rlang (local) high2(...) 12. \-rlang (local) high3(...) 13. +-base::withCallingHandlers(...) 14. \-rlang (local) low1() 15. \-rlang (local) low2() 16. \-rlang (local) low3() 17. \-base::warning("low-level") # Backtrace on rethrow: warn = 2 - try_fetch() Code print(catch_error(high1(chain = TRUE, stop_helper = TRUE))) Output Error in `high3()`: ! high-level Caused by error in `low3()`: ! (converted from warning) low-level --- Backtrace: x 1. +-base::print(catch_error(high1(chain = TRUE, stop_helper = TRUE))) 2. +-rlang:::catch_error(high1(chain = TRUE, stop_helper = TRUE)) 3. | \-rlang::catch_cnd(expr, "error") 4. | +-rlang::eval_bare(...) 5. | +-base::tryCatch(...) 6. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 7. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 8. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 9. | \-base::force(expr) 10. \-rlang (local) high1(chain = TRUE, stop_helper = TRUE) 11. \-rlang (local) high2(...) 12. \-rlang (local) high3(...) 13. +-rlang::try_fetch(...) 14. | +-base::tryCatch(...) 15. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 16. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 17. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 18. | \-base::withCallingHandlers(...) 19. \-rlang (local) low1() 20. \-rlang (local) low2() 21. \-rlang (local) low3() 22. \-base::warning("low-level") Code print(catch_error(high1(chain = TRUE, stop_helper = FALSE))) Output Error in `high3()`: ! high-level Caused by error in `low3()`: ! (converted from warning) low-level --- Backtrace: x 1. +-base::print(catch_error(high1(chain = TRUE, stop_helper = FALSE))) 2. +-rlang:::catch_error(high1(chain = TRUE, stop_helper = FALSE)) 3. | \-rlang::catch_cnd(expr, "error") 4. | +-rlang::eval_bare(...) 5. | +-base::tryCatch(...) 6. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 7. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 8. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 9. | \-base::force(expr) 10. \-rlang (local) high1(chain = TRUE, stop_helper = FALSE) 11. \-rlang (local) high2(...) 12. \-rlang (local) high3(...) 13. +-rlang::try_fetch(...) 14. | +-base::tryCatch(...) 15. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 16. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 17. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 18. | \-base::withCallingHandlers(...) 19. \-rlang (local) low1() 20. \-rlang (local) low2() 21. \-rlang (local) low3() 22. \-base::warning("low-level") Code print(catch_error(high1(chain = FALSE, stop_helper = TRUE))) Output Error in `high3()`: ! high-level Caused by error in `low3()`: ! (converted from warning) low-level --- Backtrace: x 1. +-base::print(catch_error(high1(chain = FALSE, stop_helper = TRUE))) 2. +-rlang:::catch_error(high1(chain = FALSE, stop_helper = TRUE)) 3. | \-rlang::catch_cnd(expr, "error") 4. | +-rlang::eval_bare(...) 5. | +-base::tryCatch(...) 6. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 7. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 8. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 9. | \-base::force(expr) 10. \-rlang (local) high1(chain = FALSE, stop_helper = TRUE) 11. \-rlang (local) high2(...) 12. \-rlang (local) high3(...) 13. +-rlang::try_fetch(...) 14. | +-base::tryCatch(...) 15. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 16. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 17. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 18. | \-base::withCallingHandlers(...) 19. \-rlang (local) low1() 20. \-rlang (local) low2() 21. \-rlang (local) low3() 22. \-base::warning("low-level") Code print(catch_error(high1(chain = FALSE, stop_helper = FALSE))) Output Error in `high3()`: ! high-level Caused by error in `low3()`: ! (converted from warning) low-level --- Backtrace: x 1. +-base::print(catch_error(high1(chain = FALSE, stop_helper = FALSE))) 2. +-rlang:::catch_error(high1(chain = FALSE, stop_helper = FALSE)) 3. | \-rlang::catch_cnd(expr, "error") 4. | +-rlang::eval_bare(...) 5. | +-base::tryCatch(...) 6. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 7. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 8. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 9. | \-base::force(expr) 10. \-rlang (local) high1(chain = FALSE, stop_helper = FALSE) 11. \-rlang (local) high2(...) 12. \-rlang (local) high3(...) 13. +-rlang::try_fetch(...) 14. | +-base::tryCatch(...) 15. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 16. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 17. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 18. | \-base::withCallingHandlers(...) 19. \-rlang (local) low1() 20. \-rlang (local) low2() 21. \-rlang (local) low3() 22. \-base::warning("low-level") # abort() displays call in error prefix Code run( "{\n options(cli.unicode = FALSE, crayon.enabled = FALSE)\n rlang::abort('foo', call = quote(bar(baz)))\n }") Output Error in `bar()`: ! foo Backtrace: x 1. \-rlang::abort("foo", call = quote(bar(baz))) Execution halted --- Code run( "{\n options(cli.unicode = FALSE, crayon.enabled = FALSE)\n rlang::cnd_signal(errorCondition('foo', call = quote(bar(baz))))\n }") Output Error in `bar()`: ! foo Backtrace: x 1. \-rlang::cnd_signal(errorCondition("foo", call = quote(bar(baz)))) Execution halted # abort() accepts environment as `call` field. Code (expect_error(f())) Output Error in `h()`: ! `arg` is absent but must be supplied. # local_error_call() works Code (expect_error(foo())) Output Error in `expected()`: ! tilt # can disable error call inference for unexported functions Code (expect_error(foo())) Output Error in `foo()`: ! foo Code local({ local_options(`rlang:::restrict_default_error_call` = TRUE) (expect_error(foo())) }) Output Error in `foo()`: ! foo Code local({ local_options(`rlang:::restrict_default_error_call` = TRUE) (expect_error(dots_list(.homonyms = "k"))) }) Output Error in `dots_list()`: ! `.homonyms` must be one of "keep", "first", "last", or "error", not "k". i Did you mean "keep"? # NSE doesn't interfere with error call contexts Code (expect_error(local(arg_match0("f", "foo")))) Output Error: ! `"f"` must be one of "foo", not "f". i Did you mean "foo"? Code (expect_error(eval_bare(quote(arg_match0("f", "foo"))))) Output Error: ! `"f"` must be one of "foo", not "f". i Did you mean "foo"? Code (expect_error(eval_bare(quote(arg_match0("f", "foo")), env()))) Output Error: ! `"f"` must be one of "foo", not "f". i Did you mean "foo"? # error_call() and format_error_call() preserve special syntax ops Code format_error_call(quote(1 + 2)) Output [1] "`1 + 2`" --- Code format_error_call(quote(for (x in y) NULL)) Output [1] "`for (x in y) NULL`" --- Code format_error_call(quote(a %||% b)) Output [1] "`a %||% b`" --- Code format_error_call(quote(`%||%`())) Output [1] "`` `%||%`() ``" # `abort()` uses older bullets formatting by default foo * bar # generic call is picked up in methods Code err(f1()) Output Error in `f1()`: ! foo Code err(f2()) Output Error in `f2()`: ! foo Code err(f3()) Output Error in `f3()`: ! foo # errors are fully displayed (parents, calls) in knitted files Code writeLines(render_md("test-parent-errors.Rmd")) Output foo <- error_cnd( "foo", message = "Parent message.", body = c("*" = "Bullet 1.", "*" = "Bullet 2."), call = call("foo"), use_cli_format = TRUE ) Error. abort( c("Message.", "x" = "Bullet A", "i" = "Bullet B."), parent = foo, call = call("f") ) ## Error in `f()`: ## ! Message. ## x Bullet A ## i Bullet B. ## Caused by error in `foo()`: ## ! Parent message. ## * Bullet 1. ## * Bullet 2. Warning. warn( c("Message.", "x" = "Bullet A", "i" = "Bullet B."), parent = foo, call = call("f") ) ## Warning in f(): Message. ## x Bullet A ## i Bullet B. ## Caused by error in `foo()`: ## ! Parent message. ## * Bullet 1. ## * Bullet 2. Message. inform( c("Message.", "x" = "Bullet A", "i" = "Bullet B."), parent = foo, call = call("f") ) ## Message. ## x Bullet A ## i Bullet B. ## Caused by error in `foo()`: ## ! Parent message. ## * Bullet 1. ## * Bullet 2. # can supply bullets both through `message` and `body` Code (expect_error(abort("foo", body = c("a", "b")))) Output Error: ! foo a b Code (expect_error(abort(c("foo", "bar"), body = c("a", "b")))) Output Error: ! foo * bar a b # can supply bullets both through `message` and `body` (cli case) Code (expect_error(abort("foo", body = c("a", "b")))) Output Error: ! foo a b Code (expect_error(abort(c("foo", "bar"), body = c("a", "b")))) Output Error: ! foo bar a b # setting `.internal` adds footer bullet Code err(abort(c("foo", x = "bar"), .internal = TRUE)) Output Error: ! foo x bar i This is an internal error that was detected in the rlang package. Please report it at with a reprex () and the full backtrace. Code err(abort("foo", body = c(x = "bar"), .internal = TRUE)) Output Error: ! foo x bar i This is an internal error that was detected in the rlang package. Please report it at with a reprex () and the full backtrace. # setting `.internal` adds footer bullet (fallback) Code err(abort(c("foo", x = "bar"), .internal = TRUE)) Output Error: ! foo x bar i This is an internal error that was detected in the rlang package. Please report it at with a reprex () and the full backtrace. Code err(abort("foo", body = c(x = "bar"), .internal = TRUE)) Output Error: ! foo x bar i This is an internal error that was detected in the rlang package. Please report it at with a reprex () and the full backtrace. # must pass character `body` when `message` is > 1 Code err(abort("foo", body = function(cnd, ...) c(i = "bar"))) Output Error: ! foo i bar Code err(abort(c("foo", "bar"), body = function() "baz")) Output Error in `abort()`: ! Can't supply conflicting bodies in `body` and `message`. x `body` must be character or NULL when a length > 1 `message` is supplied. i `body` is currently a function. # must pass character `body` when `message` is > 1 (non-cli case) Code err(abort("foo", body = function(cnd, ...) c(i = "bar"))) Output Error: ! foo bar Code err(abort(c("foo", "bar"), body = function() "baz")) Output Error in `abort()`: ! Can't supply conflicting bodies in `body` and `message`. x `body` must be character or NULL when a length > 1 `message` is supplied. i `body` is currently a function. # can supply `footer` Code err(abort("foo", body = c(i = "bar"), footer = c(i = "baz"))) Output Error in `f()`: ! foo i bar i baz Code err(abort("foo", body = function(cnd, ...) c(i = "bar"), footer = function(cnd, ...) c(i = "baz"))) Output Error in `f()`: ! foo i bar i baz # can supply `footer` (non-cli case) Code err(abort("foo", body = c(i = "bar"), footer = c(i = "baz"))) Output Error in `f()`: ! foo i bar i baz Code err(abort("foo", body = function(cnd, ...) c(i = "bar"), footer = function(cnd, ...) c(i = "baz"))) Output Error in `f()`: ! foo bar baz # can't supply both `footer` and `.internal` Code err(abort("foo", .internal = TRUE, call = quote(f()))) Output Error in `f()`: ! foo i This is an internal error that was detected in the rlang package. Please report it at with a reprex () and the full backtrace. Code err(abort("foo", footer = "bar", .internal = TRUE, call = quote(f()))) Output Error in `abort()`: ! Exactly one of `footer` or `.internal` must be supplied. # `cli.condition_unicode_bullets` is supported by fallback formatting foo i bar # can rethrow outside handler Code print(err(foo())) Output Error in `baz()`: ! High-level Caused by error in `low()`: ! Low-level --- Backtrace: x 1. +-base::print(err(foo())) 2. +-rlang:::err(foo()) 3. | \-testthat::expect_error(...) 4. | \-testthat:::expect_condition_matching(...) 5. | \-testthat:::quasi_capture(...) 6. | +-testthat (local) .capture(...) 7. | | \-base::withCallingHandlers(...) 8. | \-rlang::eval_bare(quo_get_expr(.quo), quo_get_env(.quo)) 9. \-rlang (local) foo() 10. \-rlang (local) bar() 11. \-rlang (local) baz() # if `call` is older than handler caller, use that as bottom Code low_level <- (function(call) { abort("Tilt.", call = call) }) print(expect_error(f())) Output Error in `f()`: ! Problem. Caused by error in `f()`: ! Tilt. --- Backtrace: x 1. +-base::print(expect_error(f())) 2. +-testthat::expect_error(f()) 3. | \-testthat:::expect_condition_matching(...) 4. | \-testthat:::quasi_capture(...) 5. | +-testthat (local) .capture(...) 6. | | \-base::withCallingHandlers(...) 7. | \-rlang::eval_bare(quo_get_expr(.quo), quo_get_env(.quo)) 8. \-rlang (local) f() Code low_level <- (function(call) { abort("Tilt.", call = list(NULL, frame = call)) }) print(expect_error(f())) Output Error in `f()`: ! Problem. Caused by error: ! Tilt. --- Backtrace: x 1. +-base::print(expect_error(f())) 2. +-testthat::expect_error(f()) 3. | \-testthat:::expect_condition_matching(...) 4. | \-testthat:::quasi_capture(...) 5. | +-testthat (local) .capture(...) 6. | | \-base::withCallingHandlers(...) 7. | \-rlang::eval_bare(quo_get_expr(.quo), quo_get_env(.quo)) 8. \-rlang (local) f() # base causal errors include full user backtrace Code print(expect_error(my_verb(add(1, "")))) Output Error in `my_verb()`: ! Problem during step. Caused by error in `x + y`: ! non-numeric argument to binary operator --- Backtrace: x 1. +-base::print(expect_error(my_verb(add(1, "")))) 2. +-testthat::expect_error(my_verb(add(1, ""))) 3. | \-testthat:::expect_condition_matching(...) 4. | \-testthat:::quasi_capture(...) 5. | +-testthat (local) .capture(...) 6. | | \-base::withCallingHandlers(...) 7. | \-rlang::eval_bare(quo_get_expr(.quo), quo_get_env(.quo)) 8. +-rlang (local) my_verb(add(1, "")) 9. | \-rlang (local) with_chained_errors(expr) 10. | \-rlang::try_fetch(...) 11. | +-base::tryCatch(...) 12. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 13. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 14. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 15. | \-base::withCallingHandlers(...) 16. \-rlang (local) add(1, "") # can supply header method via `message` Code abort(~"foo") Condition Error: ! foo Code abort(function(cnd, ...) "foo") Condition Error: ! foo # newlines are preserved by cli (#1535) Code abort("foo\nbar", use_cli_format = TRUE) Condition Error: ! foo bar Code abort("foo\fbar", use_cli_format = TRUE) Condition Error: ! foo bar # `show.error.messages` is respected by `abort()` (#1630) Code cat_line(with_messages) Output Error: ! Oh no Backtrace: x 1. \-rlang::abort("Oh no") Execution halted Code cat_line(without_messages) Output Execution halted rlang/tests/testthat/_snaps/types.md0000644000176200001440000000112314741441060017326 0ustar liggesusers# is_string2() matches on `empty` Code (expect_error(is_string2("foo", empty = 1))) Output Error in `is_string2()`: ! `empty` must be `NULL` or a logical value. Code (expect_error(is_string2("foo", empty = NA))) Output Error in `is_string2()`: ! `empty` must be `NULL` or a logical value. Code (expect_error(is_string2("foo", "foo", empty = TRUE))) Output Error in `is_string2()`: ! Exactly one of `string` and `empty` must be supplied. rlang/tests/testthat/_snaps/cnd-entrace.md0000644000176200001440000001314314657520667020373 0ustar liggesusers# rlang and base errors are properly entraced Code cat_line(base) Output Error in h() : foo Calls: f -> g -> h Run `rlang::last_trace()` to see where the error occurred. Error: ! foo --- Backtrace: x 1. \-global f() 2. \-global g() 3. \-global h() Error: ! foo --- Backtrace: x 1. \-global f() 2. \-global g() 3. \-global h() Code cat_line(rlang) Output Error in `h()`: ! foo Run `rlang::last_trace()` to see where the error occurred. Error in `h()`: ! foo --- Backtrace: x 1. \-global f() 2. \-global g() 3. \-global h() Run rlang::last_trace(drop = FALSE) to see 1 hidden frame. Error in `h()`: ! foo --- Backtrace: x 1. \-global f() 2. \-global g() 3. \-global h() Run rlang::last_trace(drop = FALSE) to see 1 hidden frame. # can supply handler environment as `bottom` Code print(err) Output Error in `1 + ""`: ! non-numeric argument to binary operator --- Backtrace: x 1. +-rlang::catch_cnd(...) 2. | +-rlang::eval_bare(...) 3. | +-base::tryCatch(...) 4. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 5. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 6. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 7. | \-base::force(expr) 8. +-base::withCallingHandlers(...) 9. \-rlang (local) f() 10. \-rlang (local) g() 11. \-rlang (local) h() 12. \-base::identity(1 + "") # can set `entrace()` as a global handler Error in `1 + ""`: ! non-numeric argument to binary operator Backtrace: x 1. \-global f() 2. \-global g() 3. \-global h() Execution halted Ran 8/8 deferred expressions --- Error in `1 + ""`: ! non-numeric argument to binary operator Backtrace: x 1. \-global f() 2. \-global g() 3. \-global h() Execution halted Ran 8/8 deferred expressions --- FOO Warning in g() : bar baz > rlang::last_warnings() [[1]] Warning in `f()`: foo --- Backtrace: x 1. \-global f() [[2]] Warning in `g()`: bar --- Backtrace: x 1. \-global f() 2. \-global g() > rlang::last_warnings(2) [[1]] Warning in `f()`: foo --- Backtrace: x 1. \-global f() [[2]] Warning in `g()`: bar --- Backtrace: x 1. \-global f() 2. \-global g() > summary(rlang::last_messages()) [[1]] Message in `message()`: FOO --- Backtrace: x 1. \-global f() [[2]] Message in `message()`: baz --- Backtrace: x 1. \-global f() 2. \-global g() 3. \-global h() > summary(rlang::last_messages(1)) [[1]] Message in `message()`: baz --- Backtrace: x 1. \-global f() 2. \-global g() 3. \-global h() Warning message: In f() : foo Ran 8/8 deferred expressions # can call `global_entrace()` in knitted documents Code cat_line(entrace_lines) Output options( rlang_backtrace_on_error_report = "full" ) f <- function(do = stop) g(do) g <- function(do) h(do) h <- function(do) do("foo") f() ## Error in h(do): foo rlang::global_entrace() f() ## Error in `h()`: ## ! foo ## Backtrace: ## x ## 1. \-rlang (local) f() ## 2. \-rlang (local) g(do) ## 3. \-rlang (local) h(do) f(warning) ## Warning in h(do): foo options( rlang_backtrace_on_warning_report = "full" ) f(warning) ## Warning in h(do): foo ## Backtrace: ## x ## 1. \-rlang (local) f(warning) ## 2. \-rlang (local) g(do) ## 3. \-rlang (local) h(do) rlang::last_warnings() ## [[1]] ## ## Warning in `h()`: ## foo ## --- ## Backtrace: ## x ## 1. \-rlang (local) f(warning) ## 2. \-rlang (local) g(do) ## 3. \-rlang (local) h(do) ## ## [[2]] ## ## Warning in `h()`: ## foo ## --- ## Backtrace: ## x ## 1. \-rlang (local) f(warning) ## 2. \-rlang (local) g(do) ## 3. \-rlang (local) h(do) # can't set backtrace-on-warning to reminder Code peek_backtrace_on_warning_report() Condition Warning: `rlang_backtrace_on_warning_report` must be one of `c("none", "branch", "full")`. i The option was reset to "none". Output [1] "none" rlang/tests/testthat/_snaps/lifecycle.md0000644000176200001440000000026114657520704020134 0ustar liggesusers# can supply bullets Code deprecate_warn(c("foo", i = "bar")) Condition Warning: foo i bar This warning is displayed once every 8 hours. rlang/tests/testthat/_snaps/nse-inject.md0000644000176200001440000000374414741441060020234 0ustar liggesusers# englue() has good error messages (#1531) Code fn <- (function(x) englue(c("a", "b"))) (expect_error(fn())) Output Error in `englue()`: ! `x` must be a single string, not a character vector. Code fn <- (function(x) englue(env())) (expect_error(fn())) Output Error in `englue()`: ! `x` must be a single string, not an environment. Code fn <- (function(x) glue_embrace("{{ x }}_foo")) (expect_error(fn())) Output Error in `fn()`: ! `x` is absent but must be supplied. Code fn <- (function(x) englue("{{ x }}_foo")) (expect_error(fn())) Output Error in `fn()`: ! `x` is absent but must be supplied. Code fn <- (function(x) list2("{{ x }}_foo" := NULL)) (expect_error(fn())) Output Error in `fn()`: ! `x` is absent but must be supplied. # can wrap englue() (#1565) Code (expect_error(my_englue(c("a", "b")))) Output Error in `my_englue()`: ! `text` must be a single string, not a character vector. Code (expect_error(my_englue(env()))) Output Error in `my_englue()`: ! `text` must be a single string, not an environment. Code (expect_error(fn())) Output Error in `fn()`: ! `x` is absent but must be supplied. # englue() checks for the size of its result (#1492) Code fn <- (function(x) englue("{{ x }} {NULL}")) (expect_error(fn(foo))) Output Error in `englue()`: ! The glue string must be size 1, not 0. Code fn <- (function(x) list2("{{ x }} {NULL}" := NULL)) (expect_error(fn(foo))) Output Error in `englue()`: ! The glue string must be size 1, not 0. rlang/tests/testthat/_snaps/dots-ellipsis.md0000644000176200001440000000546414741441060020771 0ustar liggesusers# error if dots not used by another function Code (expect_error(f(x = 10, c = 3), class = "rlib_error_dots_unused")) Output Error in `f()`: ! Arguments in `...` must be used. x Problematic argument: * c = 3 i Did you misspell an argument name? # error if dots named Code (expect_error(f(1, 2, 3, xy = 4, x = 5), class = "rlib_error_dots_named")) Output Error in `f()`: ! Arguments in `...` must be passed by position, not name. x Problematic arguments: * xy = 4 * x = 5 # error if if dots not empty Code (expect_error(f(xy = 4), class = "rlib_error_dots_nonempty")) Output Error in `f()`: ! `...` must be empty. x Problematic argument: * xy = 4 Code (expect_error(f0(xy = 4), class = "rlib_error_dots_nonempty")) Output Error in `f0()`: ! `...` must be empty. x Problematic argument: * xy = 4 # expression contents are mentioned Code f("foo") Condition Error in `f()`: ! `...` must be empty. x Problematic argument: * ..1 = "foo" i Did you forget to name an argument? Code f(foo) Condition Error in `f()`: ! `...` must be empty. x Problematic argument: * ..1 = foo i Did you forget to name an argument? Code inject(f(!!letters)) Condition Error in `f()`: ! `...` must be empty. x Problematic argument: * ..1 = i Did you forget to name an argument? Code f(a = { 1 2 }) Condition Error in `f()`: ! `...` must be empty. x Problematic argument: * a = { ... } Code f(a = toupper(letters)) Condition Error in `f()`: ! `...` must be empty. x Problematic argument: * a = toupper(letters) # empty dots error mentions info bullets if any unnamed element Code f(1) Condition Error in `f()`: ! `...` must be empty. x Problematic argument: * ..1 = 1 i Did you forget to name an argument? Code f(a = 1) Condition Error in `f()`: ! `...` must be empty. x Problematic argument: * a = 1 Code f(a = 1, 2) Condition Error in `f()`: ! `...` must be empty. x Problematic arguments: * a = 1 * ..2 = 2 i Did you forget to name an argument? # check_dots_empty() allows trailing missing arg (#1390) Code (expect_error(fn(a = 1, b = ))) Output Error in `fn()`: ! `...` must be empty. x Problematic argument: * b = rlang/tests/testthat/_snaps/state.md0000644000176200001440000000020214657520715017312 0ustar liggesusers# is_interactive() honors rlang_interactive option, above all else `rlang_interactive` must be `TRUE` or `FALSE`, not `NA`. rlang/tests/testthat/_snaps/call.md0000644000176200001440000000250214663614103017102 0ustar liggesusers# call functions type-check their input (#187) Code x <- list(a = 1) err(call_modify(x, NULL)) Output Error in `call_modify()`: ! `.call` must be a defused call, not a list. Code err(call_name(x)) Output Error in `call_name()`: ! `call` must be a defused call, not a list. Code err(call_args(x)) Output Error in `call_args()`: ! `call` must be a defused call, not a list. Code err(call_args_names(x)) Output Error in `call_args_names()`: ! `call` must be a defused call, not a list. Code q <- quo(!!x) err(call_modify(q, NULL)) Output Error in `call_modify()`: ! `.call` must be a defused call, not a list. Code err(call_name(q)) Output Error in `call_name()`: ! `call` must be a defused call, not a list. Code err(call_args(q)) Output Error in `call_args()`: ! `call` must be a defused call, not a list. Code err(call_args_names(q)) Output Error in `call_args_names()`: ! `call` must be a defused call, not a list. rlang/tests/testthat/_snaps/env.md0000644000176200001440000000063714657520702016772 0ustar liggesusers# env_is_user_facing() can be overridden Code options(rlang_user_facing = NA) (expect_error(env_is_user_facing(empty_env()))) Output Error in `env_is_user_facing()`: ! `options(rlang_user_facing = )` must be `TRUE`, `FALSE`, or a package name, not `NA`. i The option was reset to `NULL`. Code expect_null(peek_option("rlang_user_facing")) rlang/tests/testthat/_snaps/standalone-rlang.md0000644000176200001440000000151114657520712021424 0ustar liggesusers# signallers work Code inform(c("Header.", i = "Bullet.")) Message Header. i Bullet. --- Code inform(c("Header.", i = "Bullet.")) Message Header. Bullet. --- Code warn(c("Header.", i = "Bullet.")) Condition Warning: Header. i Bullet. --- Code warn(c("Header.", i = "Bullet.")) Condition Warning: Header. Bullet. --- Code abort(c("Header.", i = "Bullet.")) Condition Error: ! Header. i Bullet. --- Code abort(c("Header.", i = "Bullet.")) Condition Error: ! Header. Bullet. # unknown functions throw Code .rlang_compat("foo") Condition Error in `.rlang_compat()`: ! Internal error in rlang shims: Unknown function `foo()`. rlang/tests/testthat/_snaps/session.md0000644000176200001440000001417014741441060017653 0ustar liggesusers# check_installed() fails if packages are not installed Code (expect_error(check_installed("rlangFoo"))) Output Error in `foo()`: ! The package "rlangFoo" is required. Code (expect_error(check_installed(c("rlangFoo", "rlangBar")))) Output Error in `foo()`: ! The packages "rlangFoo" and "rlangBar" are required. Code (expect_error(check_installed(c("rlangFoo", "rlangBar"), "to proceed."))) Output Error in `foo()`: ! The packages "rlangFoo" and "rlangBar" are required to proceed. # is_installed() checks minimal versions Code (expect_error(is_installed(c("rlang", "testthat"), version = "0.1"), "the same length")) Output Error in `is_installed()`: ! `version` must be `NULL` or a vector of versions the same length as `pkg`. # check_installed() checks minimal versions Code (expect_error(check_installed(c("rlang", "testthat"), version = "0.1"))) Output Error in `check_installed()`: ! `version` must be `NULL` or a vector of versions the same length as `pkg`. Code (expect_error(check_installed("rlangFoo", version = "1.0"))) Output Error in `foo()`: ! The package "rlangFoo" (>= 1.0) is required. Code (expect_error(check_installed(c("rlangFoo", "rlangBar"), version = c("1.0", NA))) ) Output Error in `foo()`: ! The packages "rlangFoo" (>= 1.0) and "rlangBar" are required. Code (expect_error(check_installed(c("rlangFoo", "rlangBar"), version = c(NA, "2.0"))) ) Output Error in `foo()`: ! The packages "rlangFoo" and "rlangBar" (>= 2.0) are required. Code (expect_error(check_installed(c("rlangFoo", "rlangBar"), "to proceed.", version = c("1.0", "2.0")))) Output Error in `foo()`: ! The packages "rlangFoo" (>= 1.0) and "rlangBar" (>= 2.0) are required to proceed. Code (expect_error(check_installed(c("rlangFoo (>= 1.0)", "rlangBar (> 2.0)"), "to proceed."))) Output Error in `foo()`: ! The packages "rlangFoo" (>= 1.0) and "rlangBar" (> 2.0) are required to proceed. # < requirements can't be recovered with restart Code (expect_error(check_installed("rlang (< 0.1)"))) Output Error in `foo()`: ! The package "rlang" (< 0.1) is required. # `pkg` is type-checked Code (expect_error(is_installed(1))) Output Error in `is_installed()`: ! `pkg` must be a package name or a vector of package names. Code (expect_error(is_installed(na_chr))) Output Error in `is_installed()`: ! `pkg` must be a package name or a vector of package names. Code (expect_error(check_installed(c("foo", "")))) Output Error in `check_installed()`: ! `pkg` must be a package name or a vector of package names. Code (expect_error(check_installed(c("foo", "bar"), version = c("1", "")))) Output Error in `check_installed()`: ! `version` must be `NULL` or a vector of versions the same length as `pkg`. # pkg_version_info() parses info Code (expect_error(pkg_version_info("foo (1.0)"), "parse")) Output Error in `caller()`: ! Can't parse version in `pkg`. x Problematic versions: * foo (1.0) i Example of expected version format: `rlang (>= 1.0.0)`. Code (expect_error(pkg_version_info("foo (>= 1.0)", "1.0"), "both")) Output Error in `caller()`: ! Can't supply version in both `pkg` and `version`. x Redundant versions: * "foo (>= 1.0)" Code (expect_error(pkg_version_info(c("foo (!= 1.0)")))) Output Error in `caller()`: ! `compare` must be one of ">", ">=", "==" ,"<", or "<=". # pkg_version_info() supports `cmp` Code err(pkg_version_info(c("foo", "bar", "baz"), NULL, c(NA, NA, ">="))) Output Error in `caller()`: ! `version` must be supplied when `compare` is supplied. Code err(pkg_version_info(c("foo", "bar", "baz"), c("1", "2", NA), c(NA, NA, ">="))) Output Error in `caller()`: ! `version` must be supplied when `compare` is supplied. Code err(pkg_version_info(c("foo", "bar (>= 2.0)"), c(NA, "2.0"), c(NA, ">="))) Output Error in `caller()`: ! Can't supply version in both `pkg` and `version`. x Redundant versions: * "bar (>= 2.0)" Code err(pkg_version_info("foo", "1.0", "!=")) Output Error in `caller()`: ! `compare` must be one of ">", ">=", "==" ,"<", or "<=". Code err(pkg_version_info("bar (== 1.0)", "1.0", "==")) Output Error in `caller()`: ! Can't supply version in both `pkg` and `version`. x Redundant versions: * "bar (== 1.0)" # `action` is checked Code err(check_installed("foo", action = "identity")) Output Error in `check_installed()`: ! `action` must be an R function or `NULL`, not the string "identity". Code err(check_installed("foo", action = identity)) Output Error in `check_installed()`: ! `action` must take a `...` argument. # `check_installed()` works within `tryCatch(error = )` (#1402, tidyverse/ggplot2#4845) Code cat(tryCatch(error = function(cnd) NULL, check_installed("rlangFoo"))) Output i The package "rlangFoo" is required. x Would you like to install it? rlang/tests/testthat/_snaps/dots.md0000644000176200001440000000473114741441060017143 0ustar liggesusers# empty arguments trigger meaningful error Code (expect_error(list2(1, , 3), "empty")) Output Error in `list2()`: ! Argument 2 can't be empty. Code (expect_error(dots_list(1, , 3), "empty")) Output Error in `dots_list()`: ! Argument 2 can't be empty. # `.homonyms` = 'error' fails with homonyms Code (expect_error(list_error(1, a = 2, a = 3))) Output Error in `list_error()`: ! Arguments in `...` must have unique names. x Multiple arguments named `a` at positions 2 and 3. Code (expect_error(list_error(1, a = 2, b = 3, 4, b = 5, b = 6, 7, a = 8))) Output Error in `list_error()`: ! Arguments in `...` must have unique names. x Multiple arguments named `a` at positions 2 and 8. x Multiple arguments named `b` at positions 3, 5, and 6. Code (expect_error(list_error(1, a = 2, b = 3, 4, b = 5, b = 6, 7, a = 8))) Output Error in `list_error()`: ! Arguments in `...` must have unique names. x Multiple arguments named `a` at positions 2 and 8. x Multiple arguments named `b` at positions 3, 5, and 6. # `.ignore_empty` is matched Code (expect_error(dots_list(.ignore_empty = "t"))) Output Error in `dots_list()`: ! `.ignore_empty` must be one of "trailing", "none", or "all", not "t". i Did you mean "trailing"? Code foo <- (function() dots_list(.ignore_empty = "t")) (expect_error(foo())) Output Error in `dots_list()`: ! `.ignore_empty` must be one of "trailing", "none", or "all", not "t". i Did you mean "trailing"? # `.homonyms` error is thrown Code (expect_error(f())) Output Error in `f()`: ! Arguments in `...` must have unique names. x Multiple arguments named `a` at positions 1 and 2. # `list2(!!!x)` returns `x` without duplication Code x <- as.list(1:100) with_memory_prof(out <- list2(!!!x)) Output [1] 0 B Code expect_equal(out, as.list(x)) x <- 1:100 + 0L with_memory_prof(out <- list2(!!!x)) Output [1] 848 B Code expect_equal(out, as.list(x)) # list2(...) doesn't copy forced promises (#1491) Code fn(x, x, x, x, x, x) Output [1] 0 B rlang/tests/testthat/_snaps/standalone-cli.md0000644000176200001440000004070614657520711021100 0ustar liggesusers# can style strings with cli [plain] Code mark_emph("foo") Output [1] "{.emph {\"foo\"}}" Code mark_strong("foo") Output [1] "{.strong {\"foo\"}}" Code mark_code("foo") Output [1] "{.code {\"foo\"}}" Code mark_q("foo") Output [1] "{.q {\"foo\"}}" Code mark_pkg("foo") Output [1] "{.pkg {\"foo\"}}" Code mark_fn("foo") Output [1] "{.fn {\"foo\"}}" Code mark_arg("foo") Output [1] "{.arg {\"foo\"}}" Code mark_kbd("foo") Output [1] "{.kbd {\"foo\"}}" Code mark_key("foo") Output [1] "{.key {\"foo\"}}" Code mark_file("foo") Output [1] "{.file {\"foo\"}}" Code mark_path("foo") Output [1] "{.path {\"foo\"}}" Code mark_email("foo") Output [1] "{.email {\"foo\"}}" Code mark_url("foo") Output [1] "{.url {\"foo\"}}" Code mark_var("foo") Output [1] "{.var {\"foo\"}}" Code mark_envvar("foo") Output [1] "{.envvar {\"foo\"}}" Code mark_field("foo") Output [1] "{.field {\"foo\"}}" Code mark_cls("foo") Output [1] "{.cls {\"foo\"}}" Code mark_cls(c("foo", "bar")) Output [1] "{.cls {\"foo\"}}" "{.cls {\"bar\"}}" # can style strings with cli [ansi] Code mark_emph("foo") Output [1] "{.emph {\"foo\"}}" Code mark_strong("foo") Output [1] "{.strong {\"foo\"}}" Code mark_code("foo") Output [1] "{.code {\"foo\"}}" Code mark_q("foo") Output [1] "{.q {\"foo\"}}" Code mark_pkg("foo") Output [1] "{.pkg {\"foo\"}}" Code mark_fn("foo") Output [1] "{.fn {\"foo\"}}" Code mark_arg("foo") Output [1] "{.arg {\"foo\"}}" Code mark_kbd("foo") Output [1] "{.kbd {\"foo\"}}" Code mark_key("foo") Output [1] "{.key {\"foo\"}}" Code mark_file("foo") Output [1] "{.file {\"foo\"}}" Code mark_path("foo") Output [1] "{.path {\"foo\"}}" Code mark_email("foo") Output [1] "{.email {\"foo\"}}" Code mark_url("foo") Output [1] "{.url {\"foo\"}}" Code mark_var("foo") Output [1] "{.var {\"foo\"}}" Code mark_envvar("foo") Output [1] "{.envvar {\"foo\"}}" Code mark_field("foo") Output [1] "{.field {\"foo\"}}" Code mark_cls("foo") Output [1] "{.cls {\"foo\"}}" Code mark_cls(c("foo", "bar")) Output [1] "{.cls {\"foo\"}}" "{.cls {\"bar\"}}" # can format strings with cli [plain] Code format_emph("foo") Output [1] "foo" Code format_strong("foo") Output [1] "foo" Code format_code("foo") Output [1] "`foo`" Code format_q("foo") Output [1] "\"foo\"" Code format_pkg("foo") Output [1] "foo" Code format_fn("foo") Output [1] "`foo()`" Code format_arg("foo") Output [1] "`foo`" Code format_kbd("foo") Output [1] "[foo]" Code format_key("foo") Output [1] "[foo]" Code format_file("foo") Output [1] "'foo'" Code format_path("foo") Output [1] "'foo'" Code format_email("foo") Output [1] "'foo'" Code format_url("foo") Output [1] "" Code format_var("foo") Output [1] "`foo`" Code format_envvar("foo") Output [1] "`foo`" Code format_field("foo") Output [1] "foo" Code format_cls("foo") Output [1] "" Code format_cls(c("foo", "bar")) Output [1] "" # can format strings with cli [ansi] Code format_emph("foo") Output [1] "\033[3mfoo\033[23m" Code format_strong("foo") Output [1] "\033[1mfoo\033[22m" Code format_code("foo") Output [1] "`foo`" Code format_q("foo") Output [1] "\"foo\"" Code format_pkg("foo") Output [1] "\033[34mfoo\033[39m" Code format_fn("foo") Output [1] "`foo()`" Code format_arg("foo") Output [1] "`foo`" Code format_kbd("foo") Output [1] "\033[34m[foo]\033[39m" Code format_key("foo") Output [1] "\033[34m[foo]\033[39m" Code format_file("foo") Output [1] "\033[34mfoo\033[39m" Code format_path("foo") Output [1] "\033[34mfoo\033[39m" Code format_email("foo") Output [1] "\033[34mfoo\033[39m" Code format_url("foo") Output [1] "\033[3m\033[34m\033[39m\033[23m" Code format_var("foo") Output [1] "`foo`" Code format_envvar("foo") Output [1] "`foo`" Code format_field("foo") Output [1] "\033[32mfoo\033[39m" Code format_cls("foo") Output [1] "\033[34m\033[39m" Code format_cls(c("foo", "bar")) Output [1] "\033[34m\033[39m" # styled strings may contain `{` syntax [plain] Code mark_emph("{foo {}") Output [1] "{.emph {\"{foo {}\"}}" Code format_message(mark_emph("{foo {}")) Output [1] "{foo {}" # styled strings may contain `{` syntax [ansi] Code mark_emph("{foo {}") Output [1] "{.emph {\"{foo {}\"}}" Code format_message(mark_emph("{foo {}")) Output [1] "\033[1m\033[22m\033[3m{foo {}\033[23m" # can apply ANSI styles with cli [plain] Code col_black("foo") Output [1] "foo" Code col_blue("foo") Output [1] "foo" Code col_cyan("foo") Output [1] "foo" Code col_green("foo") Output [1] "foo" Code col_magenta("foo") Output [1] "foo" Code col_red("foo") Output [1] "foo" Code col_white("foo") Output [1] "foo" Code col_yellow("foo") Output [1] "foo" Code col_grey("foo") Output [1] "foo" Code col_silver("foo") Output [1] "foo" Code col_none("foo") Output [1] "foo" Code bg_black("foo") Output [1] "foo" Code bg_blue("foo") Output [1] "foo" Code bg_cyan("foo") Output [1] "foo" Code bg_green("foo") Output [1] "foo" Code bg_magenta("foo") Output [1] "foo" Code bg_red("foo") Output [1] "foo" Code bg_white("foo") Output [1] "foo" Code bg_yellow("foo") Output [1] "foo" Code bg_none("foo") Output [1] "foo" Code style_dim("foo") Output [1] "foo" Code style_blurred("foo") Output [1] "foo" Code style_bold("foo") Output [1] "foo" Code style_hidden("foo") Output [1] "foo" Code style_inverse("foo") Output [1] "foo" Code style_italic("foo") Output [1] "foo" Code style_strikethrough("foo") Output [1] "foo" Code style_underline("foo") Output [1] "foo" Code style_no_dim("foo") Output [1] "foo" Code style_no_blurred("foo") Output [1] "foo" Code style_no_bold("foo") Output [1] "foo" Code style_no_hidden("foo") Output [1] "foo" Code style_no_inverse("foo") Output [1] "foo" Code style_no_italic("foo") Output [1] "foo" Code style_no_strikethrough("foo") Output [1] "foo" Code style_no_underline("foo") Output [1] "foo" Code style_reset("foo") Output [1] "foo" Code style_no_colour("foo") Output [1] "foo" Code style_no_bg_colour("foo") Output [1] "foo" # can apply ANSI styles with cli [ansi] Code col_black("foo") Output [1] "\033[30mfoo\033[39m" Code col_blue("foo") Output [1] "\033[34mfoo\033[39m" Code col_cyan("foo") Output [1] "\033[36mfoo\033[39m" Code col_green("foo") Output [1] "\033[32mfoo\033[39m" Code col_magenta("foo") Output [1] "\033[35mfoo\033[39m" Code col_red("foo") Output [1] "\033[31mfoo\033[39m" Code col_white("foo") Output [1] "\033[37mfoo\033[39m" Code col_yellow("foo") Output [1] "\033[33mfoo\033[39m" Code col_grey("foo") Output [1] "\033[90mfoo\033[39m" Code col_silver("foo") Output [1] "\033[90mfoo\033[39m" Code col_none("foo") Output [1] "\033[0m\033[22m\033[23m\033[24m\033[27m\033[28m\033[29m\033[49mfoo\033[39m" Code bg_black("foo") Output [1] "\033[40mfoo\033[49m" Code bg_blue("foo") Output [1] "\033[44mfoo\033[49m" Code bg_cyan("foo") Output [1] "\033[46mfoo\033[49m" Code bg_green("foo") Output [1] "\033[42mfoo\033[49m" Code bg_magenta("foo") Output [1] "\033[45mfoo\033[49m" Code bg_red("foo") Output [1] "\033[41mfoo\033[49m" Code bg_white("foo") Output [1] "\033[47mfoo\033[49m" Code bg_yellow("foo") Output [1] "\033[43mfoo\033[49m" Code bg_none("foo") Output [1] "\033[0m\033[22m\033[23m\033[24m\033[27m\033[28m\033[29m\033[39mfoo\033[49m" Code style_dim("foo") Output [1] "\033[2mfoo\033[22m" Code style_blurred("foo") Output [1] "\033[2mfoo\033[22m" Code style_bold("foo") Output [1] "\033[1mfoo\033[22m" Code style_hidden("foo") Output [1] "\033[8mfoo\033[28m" Code style_inverse("foo") Output [1] "\033[7mfoo\033[27m" Code style_italic("foo") Output [1] "\033[3mfoo\033[23m" Code style_strikethrough("foo") Output [1] "\033[9mfoo\033[29m" Code style_underline("foo") Output [1] "\033[4mfoo\033[24m" Code style_no_dim("foo") Output [1] "\033[0m\033[23m\033[24m\033[27m\033[28m\033[29m\033[39m\033[49mfoo\033[22m" Code style_no_blurred("foo") Output [1] "\033[0m\033[23m\033[24m\033[27m\033[28m\033[29m\033[39m\033[49mfoo\033[22m" Code style_no_bold("foo") Output [1] "\033[0m\033[23m\033[24m\033[27m\033[28m\033[29m\033[39m\033[49mfoo\033[22m" Code style_no_hidden("foo") Output [1] "\033[0m\033[22m\033[23m\033[24m\033[27m\033[29m\033[39m\033[49mfoo\033[28m" Code style_no_inverse("foo") Output [1] "\033[0m\033[22m\033[23m\033[24m\033[28m\033[29m\033[39m\033[49mfoo\033[27m" Code style_no_italic("foo") Output [1] "\033[0m\033[22m\033[24m\033[27m\033[28m\033[29m\033[39m\033[49mfoo\033[23m" Code style_no_strikethrough("foo") Output [1] "\033[0m\033[22m\033[23m\033[24m\033[27m\033[28m\033[39m\033[49mfoo\033[29m" Code style_no_underline("foo") Output [1] "\033[0m\033[22m\033[23m\033[27m\033[28m\033[29m\033[39m\033[49mfoo\033[24m" Code style_reset("foo") Output [1] "\033[0mfoo\033[0m\033[22m\033[23m\033[24m\033[27m\033[28m\033[29m\033[39m\033[49m" Code style_no_colour("foo") Output [1] "\033[0m\033[22m\033[23m\033[24m\033[27m\033[28m\033[29m\033[49mfoo\033[39m" Code style_no_bg_colour("foo") Output [1] "\033[0m\033[22m\033[23m\033[24m\033[27m\033[28m\033[29m\033[39mfoo\033[49m" # can create symbols with cli [plain] Code symbol_info() Output [1] "i" Code symbol_cross() Output [1] "x" Code symbol_tick() Output [1] "v" Code symbol_bullet() Output [1] "*" Code symbol_arrow() Output [1] ">" Code symbol_alert() Output [1] "!" # can create symbols with cli [ansi] Code symbol_info() Output [1] "i" Code symbol_cross() Output [1] "x" Code symbol_tick() Output [1] "v" Code symbol_bullet() Output [1] "*" Code symbol_arrow() Output [1] ">" Code symbol_alert() Output [1] "!" # can create symbols with cli [unicode] Code symbol_info() Output [1] "ℹ" Code symbol_cross() Output [1] "✖" Code symbol_tick() Output [1] "✔" Code symbol_bullet() Output [1] "•" Code symbol_arrow() Output [1] "→" Code symbol_alert() Output [1] "!" # can create symbols with cli [fancy] Code symbol_info() Output [1] "ℹ" Code symbol_cross() Output [1] "✖" Code symbol_tick() Output [1] "✔" Code symbol_bullet() Output [1] "•" Code symbol_arrow() Output [1] "→" Code symbol_alert() Output [1] "!" # can create ANSI symbols with cli [plain] Code ansi_info() Output [1] "i" Code ansi_cross() Output [1] "x" Code ansi_tick() Output [1] "v" Code ansi_bullet() Output [1] "*" Code ansi_arrow() Output [1] ">" Code ansi_alert() Output [1] "!" # can create ANSI symbols with cli [ansi] Code ansi_info() Output [1] "\033[34mi\033[39m" Code ansi_cross() Output [1] "\033[31mx\033[39m" Code ansi_tick() Output [1] "\033[32mv\033[39m" Code ansi_bullet() Output [1] "\033[36m*\033[39m" Code ansi_arrow() Output [1] ">" Code ansi_alert() Output [1] "\033[33m!\033[39m" # can create ANSI symbols with cli [unicode] Code ansi_info() Output [1] "ℹ" Code ansi_cross() Output [1] "✖" Code ansi_tick() Output [1] "✔" Code ansi_bullet() Output [1] "•" Code ansi_arrow() Output [1] "→" Code ansi_alert() Output [1] "!" # can create ANSI symbols with cli [fancy] Code ansi_info() Output [1] "\033[34mℹ\033[39m" Code ansi_cross() Output [1] "\033[31m✖\033[39m" Code ansi_tick() Output [1] "\033[32m✔\033[39m" Code ansi_bullet() Output [1] "\033[36m•\033[39m" Code ansi_arrow() Output [1] "→" Code ansi_alert() Output [1] "\033[33m!\033[39m" # can format messages [plain] Code format_error(c("Header", i = "Bullet.")) Output [1] "Header\ni Bullet." Code format_warning(c("Header", i = "Bullet.")) Output [1] "Header\ni Bullet." Code format_message(c("Header", i = "Bullet.")) Output [1] "Header\ni Bullet." # can format messages [ansi] Code format_error(c("Header", i = "Bullet.")) Output [1] "\033[1m\033[22mHeader\n\033[36mi\033[39m Bullet." Code format_warning(c("Header", i = "Bullet.")) Output [1] "\033[1m\033[22mHeader\n\033[36mi\033[39m Bullet." Code format_message(c("Header", i = "Bullet.")) Output [1] "\033[1m\033[22mHeader\n\033[36mi\033[39m Bullet." # can format messages [unicode] Code format_error(c("Header", i = "Bullet.")) Output [1] "Header\nℹ Bullet." Code format_warning(c("Header", i = "Bullet.")) Output [1] "Header\nℹ Bullet." Code format_message(c("Header", i = "Bullet.")) Output [1] "Header\nℹ Bullet." # can format messages [fancy] Code format_error(c("Header", i = "Bullet.")) Output [1] "\033[1m\033[22mHeader\n\033[36mℹ\033[39m Bullet." Code format_warning(c("Header", i = "Bullet.")) Output [1] "\033[1m\033[22mHeader\n\033[36mℹ\033[39m Bullet." Code format_message(c("Header", i = "Bullet.")) Output [1] "\033[1m\033[22mHeader\n\033[36mℹ\033[39m Bullet." # cli_escape() conditionally escapes `{` [plain] Code format_error(cli_escape("{")) Output [1] "{" # cli_escape() conditionally escapes `{` [ansi] Code format_error(cli_escape("{")) Output [1] "\033[1m\033[22m{" rlang/tests/testthat/_snaps/standalone-types-check.md0000644000176200001440000003502714741441060022541 0ustar liggesusers# `check_bool()` checks Code err(checker(, check_bool)) Output Error in `checker()`: ! `foo` must be `TRUE` or `FALSE`, not absent. Code err(checker(NA, check_bool)) Output Error in `checker()`: ! `foo` must be `TRUE` or `FALSE`, not `NA`. Code err(checker(NULL, check_bool)) Output Error in `checker()`: ! `foo` must be `TRUE` or `FALSE`, not `NULL`. Code err(checker(lgl(), check_bool, allow_na = TRUE)) Output Error in `checker()`: ! `foo` must be `TRUE`, `FALSE`, or `NA`, not an empty logical vector. Code err(checker(c(TRUE, FALSE), check_bool, allow_na = TRUE, allow_null = TRUE)) Output Error in `checker()`: ! `foo` must be `TRUE`, `FALSE`, `NA`, or `NULL`, not a logical vector. Code err(checker(1, check_bool)) Output Error in `checker()`: ! `foo` must be `TRUE` or `FALSE`, not the number 1. # `check_string()` checks Code err(checker("", check_string, allow_empty = FALSE)) Output Error in `checker()`: ! `foo` must be a single string, not the empty string "". Code err(checker(, check_string)) Output Error in `checker()`: ! `foo` must be a single string, not absent. Code err(checker(NA, check_string)) Output Error in `checker()`: ! `foo` must be a single string, not `NA`. Code err(checker(NULL, check_string)) Output Error in `checker()`: ! `foo` must be a single string, not `NULL`. Code err(checker(chr(), check_string, allow_na = TRUE)) Output Error in `checker()`: ! `foo` must be a single string or `NA`, not an empty character vector. Code err(checker(na_chr, check_string)) Output Error in `checker()`: ! `foo` must be a single string, not a character `NA`. Code err(checker(c("", ""), check_string, allow_na = TRUE, allow_null = TRUE)) Output Error in `checker()`: ! `foo` must be a single string, `NA`, or `NULL`, not a character vector. Code err(checker(1, check_string)) Output Error in `checker()`: ! `foo` must be a single string, not the number 1. # `check_name()` checks Code err(checker("", check_name)) Output Error in `checker()`: ! `foo` must be a valid name, not the empty string "". Code err(checker(, check_name)) Output Error in `checker()`: ! `foo` must be a valid name, not absent. Code err(checker(NA, check_name)) Output Error in `checker()`: ! `foo` must be a valid name, not `NA`. Code err(checker(na_chr, check_name)) Output Error in `checker()`: ! `foo` must be a valid name, not a character `NA`. Code err(checker(NULL, check_name)) Output Error in `checker()`: ! `foo` must be a valid name, not `NULL`. Code err(checker(chr(), check_name, allow_null = TRUE)) Output Error in `checker()`: ! `foo` must be a valid name or `NULL`, not an empty character vector. Code err(checker(na_chr, check_name)) Output Error in `checker()`: ! `foo` must be a valid name, not a character `NA`. Code err(checker(c("", ""), check_name, allow_null = TRUE)) Output Error in `checker()`: ! `foo` must be a valid name or `NULL`, not a character vector. Code err(checker(1, check_name)) Output Error in `checker()`: ! `foo` must be a valid name, not the number 1. # `check_number_whole()` checks Code err(checker(, check_number_whole)) Output Error in `checker()`: ! `foo` must be a whole number, not absent. Code err(checker(NA, check_number_whole)) Output Error in `checker()`: ! `foo` must be a whole number, not `NA`. Code err(checker(NULL, check_number_whole)) Output Error in `checker()`: ! `foo` must be a whole number, not `NULL`. Code err(checker(int(), check_number_whole, allow_na = TRUE)) Output Error in `checker()`: ! `foo` must be a whole number or `NA`, not an empty integer vector. Code err(checker(na_dbl, check_number_whole)) Output Error in `checker()`: ! `foo` must be a whole number, not a numeric `NA`. Code err(checker(na_int, check_number_whole)) Output Error in `checker()`: ! `foo` must be a whole number, not an integer `NA`. Code err(checker(10:11, check_number_whole, allow_na = TRUE, allow_null = TRUE)) Output Error in `checker()`: ! `foo` must be a whole number, `NA`, or `NULL`, not an integer vector. Code err(checker(10.5, check_number_whole)) Output Error in `checker()`: ! `foo` must be a whole number, not the number 10.5. Code err(checker(Inf, check_number_whole)) Output Error in `checker()`: ! `foo` must be a whole number, not `Inf`. Code err(checker(-Inf, check_number_whole)) Output Error in `checker()`: ! `foo` must be a whole number, not `-Inf`. Code err(checker(1, max = 0, check_number_whole)) Output Error in `checker()`: ! `foo` must be a whole number smaller than or equal to 0, not the number 1. Code err(checker(-1, min = 0, check_number_whole)) Output Error in `checker()`: ! `foo` must be a whole number larger than or equal to 0, not the number -1. Code err(checker(10, min = 1, max = 5, check_number_whole)) Output Error in `checker()`: ! `foo` must be a whole number between 1 and 5, not the number 10. Code err(checker(10, min = NA, check_number_whole)) Output Error in `check()`: ! `min` must be a single double value. Code err(checker(10, min = NaN, check_number_whole)) Output Error in `check()`: ! `min` must be a number, not missing. Code err(checker(10, max = NaN, check_number_whole)) Output Error in `check()`: ! `max` must be a number, not missing. # `check_number_decimal()` checks Code err(checker(, check_number_decimal)) Output Error in `checker()`: ! `foo` must be a number, not absent. Code err(checker(NA, check_number_decimal)) Output Error in `checker()`: ! `foo` must be a number, not `NA`. Code err(checker(NULL, check_number_decimal)) Output Error in `checker()`: ! `foo` must be a number, not `NULL`. Code err(checker(int(), check_number_decimal, allow_na = TRUE)) Output Error in `checker()`: ! `foo` must be a number or `NA`, not an empty integer vector. Code err(checker(na_dbl, check_number_decimal)) Output Error in `checker()`: ! `foo` must be a number, not a numeric `NA`. Code err(checker(na_int, check_number_decimal)) Output Error in `checker()`: ! `foo` must be a number, not an integer `NA`. Code err(checker(10:11, check_number_decimal, allow_na = TRUE, allow_null = TRUE)) Output Error in `checker()`: ! `foo` must be a number, `NA`, or `NULL`, not an integer vector. Code err(checker(Inf, check_number_decimal, allow_infinite = FALSE)) Output Error in `checker()`: ! `foo` must be a number, not `Inf`. Code err(checker(-Inf, check_number_decimal, allow_infinite = FALSE)) Output Error in `checker()`: ! `foo` must be a number, not `-Inf`. Code err(checker(10, min = NA, check_number_decimal)) Output Error in `check()`: ! `min` must be a single double value. Code err(checker(10, min = NaN, check_number_decimal)) Output Error in `check()`: ! `min` must be a number, not missing. Code err(checker(10, max = NaN, check_number_decimal)) Output Error in `check()`: ! `max` must be a number, not missing. # `check_symbol()` checks Code err(checker(, check_symbol)) Output Error in `checker()`: ! `foo` must be a symbol, not absent. Code err(checker(NULL, check_symbol)) Output Error in `checker()`: ! `foo` must be a symbol, not `NULL`. Code err(checker(TRUE, check_symbol)) Output Error in `checker()`: ! `foo` must be a symbol, not `TRUE`. Code err(checker(alist(foo, bar), check_symbol, allow_null = TRUE)) Output Error in `checker()`: ! `foo` must be a symbol or `NULL`, not a list. Code err(checker("foo", check_symbol)) Output Error in `checker()`: ! `foo` must be a symbol, not the string "foo". Code err(checker(quote(foo()), check_symbol)) Output Error in `checker()`: ! `foo` must be a symbol, not a call. # `check_call()` checks Code err(checker(, check_call)) Output Error in `checker()`: ! `foo` must be a defused call, not absent. Code err(checker(NULL, check_call)) Output Error in `checker()`: ! `foo` must be a defused call, not `NULL`. Code err(checker(TRUE, check_call)) Output Error in `checker()`: ! `foo` must be a defused call, not `TRUE`. Code err(checker(alist(foo(), bar()), check_call, allow_null = TRUE)) Output Error in `checker()`: ! `foo` must be a defused call or `NULL`, not a list. Code err(checker(quote(foo), check_call)) Output Error in `checker()`: ! `foo` must be a defused call, not a symbol. # `check_environment()` checks Code err(checker(, check_environment)) Output Error in `checker()`: ! `foo` must be an environment, not absent. Code err(checker(NULL, check_environment)) Output Error in `checker()`: ! `foo` must be an environment, not `NULL`. Code err(checker(FALSE, check_environment)) Output Error in `checker()`: ! `foo` must be an environment, not `FALSE`. Code err(checker(list(env(), env()), check_environment, allow_null = TRUE)) Output Error in `checker()`: ! `foo` must be an environment or `NULL`, not a list. # `check_character()` checks Code err(checker(, check_character)) Output Error in `checker()`: ! `foo` must be a character vector, not absent. Code err(checker(NULL, check_character)) Output Error in `checker()`: ! `foo` must be a character vector, not `NULL`. Code err(checker(NA, check_character)) Output Error in `checker()`: ! `foo` must be a character vector, not `NA`. Code err(checker(1, check_character)) Output Error in `checker()`: ! `foo` must be a character vector, not the number 1. Code err(checker(list("foo", "bar"), check_character, allow_null = TRUE)) Output Error in `checker()`: ! `foo` must be a character vector or `NULL`, not a list. # `check_logical()` checks Code err(checker(, check_logical)) Output Error in `checker()`: ! `foo` must be a logical vector, not absent. Code err(checker(NULL, check_logical)) Output Error in `checker()`: ! `foo` must be a logical vector, not `NULL`. Code err(checker(NA_integer_, check_logical)) Output Error in `checker()`: ! `foo` must be a logical vector, not an integer `NA`. Code err(checker(1, check_logical)) Output Error in `checker()`: ! `foo` must be a logical vector, not the number 1. Code err(checker(list("foo", "bar"), check_logical, allow_null = TRUE)) Output Error in `checker()`: ! `foo` must be a logical vector or `NULL`, not a list. # non-numeric types are not numbers Code (expect_error(check_number_whole(factor("a")))) Output Error: ! `factor("a")` must be a whole number, not a object. Code (expect_error(check_number_decimal(as.Date("2000-01-01")))) Output Error: ! `as.Date("2000-01-01")` must be a number, not a object. # `check_data_frame()` checks Code err(checker(, check_data_frame)) Output Error in `checker()`: ! `foo` must be a data frame, not absent. Code err(checker(NULL, check_data_frame)) Output Error in `checker()`: ! `foo` must be a data frame, not `NULL`. Code err(checker(list(data.frame(), data.frame()), check_data_frame, allow_null = TRUE)) Output Error in `checker()`: ! `foo` must be a data frame or `NULL`, not a list. rlang/tests/testthat/_snaps/friendly-type.md0000644000176200001440000000030214741441060020753 0ustar liggesusers# obj_type_friendly() handles NULL Code (expect_error(friendly_types(NULL))) Output Error in `vec_type_friendly()`: ! `x` must be a vector. rlang/tests/testthat/_snaps/operators.md0000644000176200001440000000247714657520706020230 0ustar liggesusers# %|% fails with wrong types Code (expect_error(c(1L, NA) %|% 2)) Output Error in `c(1L, NA) %|% 2`: ! Replacement values must have type integer, not type double Code (expect_error(c(1, NA) %|% "")) Output Error in `c(1, NA) %|% ""`: ! Replacement values must have type double, not type character Code (expect_error(c(1, NA) %|% call("fn"))) Output Error in `c(1, NA) %|% call("fn")`: ! Replacement values must have type double, not type language Code (expect_error(call("fn") %|% 1)) Output Error in `call("fn") %|% 1`: ! Cannot replace missing values in an object of type language # %|% fails with wrong length Code (expect_error(c(1L, NA) %|% 1:3)) Output Error in `c(1L, NA) %|% 1:3`: ! The replacement values must have size 1 or 2, not 3 Code (expect_error(1:10 %|% 1:4)) Output Error in `1:10 %|% 1:4`: ! The replacement values must have size 1 or 10, not 4 Code (expect_error(1L %|% 1:4)) Output Error in `1L %|% 1:4`: ! The replacement values must have size 1, not 4 rlang/tests/testthat/_snaps/cnd-message.md0000644000176200001440000002714314741441060020362 0ustar liggesusers# `body` must be a character vector or a function Code (expect_error(stop(error_cnd("foo", body = 1:3)), "must be")) Output Error in `cnd_body()`: ! `body` field must be a character vector or a function. # can request a line break in error bullets (#1130) Code (expect_error(abort(c("Main header.", "Header 1", x = "Bullet 1", x = "Bullet 2", "Header 2", x = "Bullet 3", x = "Bullet 4")))) Output Error: ! Main header. Header 1 x Bullet 1 x Bullet 2 Header 2 x Bullet 3 x Bullet 4 Code (expect_error(abort(c("Main header.", "Header 1", x = "Bullet 1", ` ` = "Break line", x = "Bullet 2", "", "Header 2", x = "Bullet 3", ` ` = "Break line", x = "Bullet 4"))) ) Output Error: ! Main header. Header 1 x Bullet 1 Break line x Bullet 2 Header 2 x Bullet 3 Break line x Bullet 4 # format_error_bullets() generates bullets [plain] Code format_error_bullets(c("Header.", i = "Bullet.")) Output [1] "Header.\ni Bullet." # format_error_bullets() generates bullets [ansi] Code format_error_bullets(c("Header.", i = "Bullet.")) Output [1] "Header.\n\033[34mi\033[39m Bullet." # format_error_bullets() generates bullets [unicode] Code format_error_bullets(c("Header.", i = "Bullet.")) Output [1] "Header.\nℹ Bullet." # format_error_bullets() generates bullets [fancy] Code format_error_bullets(c("Header.", i = "Bullet.")) Output [1] "Header.\n\033[34mℹ\033[39m Bullet." # can use cli syntax in `cnd_message()` methods [plain] Code cnd_message(cnd) Output [1] "Header: User { {field}.\ni Bullet: User { {field}.\nFooter: User { {field}." # can use cli syntax in `cnd_message()` methods [fancy] Code cnd_message(cnd) Output [1] "\033[1m\033[22mHeader: \033[3mUser { {field}.\033[23m\n\033[36mℹ\033[39m Bullet: \033[3mUser { {field}.\033[23m\nFooter: \033[3mUser { {field}.\033[23m" # prefix takes call into account Code err <- error_cnd(message = "msg", call = quote(foo(bar = TRUE))) writeLines(cnd_message_format_prefixed(err)) Output Error in `foo()`: ! msg Code err1 <- error_cnd(message = "msg", call = expr(foo(bar = !!(1:3)))) err2 <- error_cnd(message = "msg", call = quote(foo$bar())) err3 <- error_cnd(message = "msg", call = call2(identity)) writeLines(cnd_message_format_prefixed(err1)) Output Error in `foo()`: ! msg Code writeLines(cnd_message_format_prefixed(err2)) Output Error in `foo$bar()`: ! msg Code writeLines(cnd_message_format_prefixed(err3)) Output Error: ! msg # long prefixes cause a line break Code (expect_error(very_very_very_very_very_long_function_name())) Output Error in `very_very_very_very_very_long_function_name()`: ! My somewhat longish and verbose error message. # prefixes include srcrefs Code (expect_error(f())) Output Error in `g()` at bar/baz/myfile.R:2:10: ! Foo. # inform() and warn() use fallback bullets formatting Code local_use_cli(format = FALSE) warn(msg) Condition Warning: foo i bar Code warn(msg, .frequency = "once", .frequency_id = as.character(runif(1))) Condition Warning: foo i bar This warning is displayed once per session. --- Code local_use_cli(format = TRUE) warn(msg) Condition Warning: foo i bar Code warn(msg, .frequency = "once", .frequency_id = as.character(runif(1))) Condition Warning: foo i bar This warning is displayed once per session. --- Code local_use_cli(format = FALSE) inform(msg) Message foo i bar Code inform(msg, .frequency = "once", .frequency_id = as.character(runif(1))) Message foo i bar This message is displayed once per session. --- Code local_use_cli(format = TRUE) inform(msg) Message foo i bar Code inform(msg, .frequency = "once", .frequency_id = as.character(runif(1))) Message foo i bar This message is displayed once per session. # can supply bullet without header Code (catch_cnd(inform(c(i = "foo")), "message")) Output Message: i foo Code (catch_cnd(warn(c(i = "foo")), "warning")) Output Warning: i foo # parent errors prints with bullets in all cases Code (expect_error(f(TRUE))) Output Error in `f()`: ! Wrapper Caused by error in `f()`: ! Header i Bullet Code (expect_error(f(FALSE))) Output Error in `f()`: ! Wrapper Caused by error in `f()`: ! Header i Bullet # special syntax calls handle edge cases Code error_call_as_string(quote(`+`())) Output [1] "`+`()" Code error_call_as_string(quote(base::`+`(1, 2))) Output [1] "1 + 2" # can print message with and without prefix Code foo <- error_cnd("foo", message = "Parent message.", body = c(`*` = "Bullet 1.", `*` = "Bullet 2."), use_cli_format = TRUE) bar <- error_cnd("bar", message = "Message.", body = c(`*` = "Bullet A.", `*` = "Bullet B."), parent = foo, use_cli_format = TRUE) writeLines(cnd_message(foo, prefix = TRUE)) Output Error: ! Parent message. * Bullet 1. * Bullet 2. Code writeLines(cnd_message(bar, prefix = TRUE)) Output Error: ! Message. * Bullet A. * Bullet B. Caused by error: ! Parent message. * Bullet 1. * Bullet 2. Code writeLines(cnd_message(foo, prefix = FALSE)) Output Parent message. * Bullet 1. * Bullet 2. Code writeLines(cnd_message(bar, prefix = FALSE)) Output Message. * Bullet A. * Bullet B. Caused by error: ! Parent message. * Bullet 1. * Bullet 2. # can print message without inheritance Code foo <- error_cnd("foo", message = "Parent message.", body = c(`*` = "Bullet 1.", `*` = "Bullet 2."), use_cli_format = TRUE) bar <- error_cnd("bar", message = "Message.", body = c(`*` = "Bullet A.", `*` = "Bullet B."), parent = foo, use_cli_format = TRUE) writeLines(cnd_message(foo, inherit = FALSE, prefix = TRUE)) Output Error: ! Parent message. * Bullet 1. * Bullet 2. Code writeLines(cnd_message(bar, inherit = FALSE, prefix = TRUE)) Output Error: ! Message. * Bullet A. * Bullet B. Code writeLines(cnd_message(foo, inherit = FALSE, prefix = FALSE)) Output Parent message. * Bullet 1. * Bullet 2. Code writeLines(cnd_message(bar, inherit = FALSE, prefix = FALSE)) Output Message. * Bullet A. * Bullet B. # as.character() and conditionMessage() methods for errors, warnings, and messages Code cat(as.character(cnd_with(error_cnd))) Output Error in `bar()`: ! Message. * Bullet A. * Bullet B. Code cat(as.character(cnd_with(warning_cnd))) Output Warning in `bar()`: Message. * Bullet A. * Bullet B. Code cat(as.character(cnd_with(message_cnd))) Output Message in `bar()`: Message. * Bullet A. * Bullet B. Code cat(as.character(cnd_with(error_cnd, parent = TRUE))) Output Error in `bar()`: ! Message. * Bullet A. * Bullet B. Caused by error in `foo()`: ! Parent message. * Bullet 1. * Bullet 2. Code cat(as.character(cnd_with(warning_cnd, parent = TRUE))) Output Warning in `bar()`: Message. * Bullet A. * Bullet B. Caused by error in `foo()`: ! Parent message. * Bullet 1. * Bullet 2. Code cat(as.character(cnd_with(message_cnd, parent = TRUE))) Output Message in `bar()`: Message. * Bullet A. * Bullet B. Caused by error in `foo()`: ! Parent message. * Bullet 1. * Bullet 2. Code cat(conditionMessage(cnd_with(error_cnd))) Output Message. * Bullet A. * Bullet B. Code cat(conditionMessage(cnd_with(warning_cnd))) Output Message. * Bullet A. * Bullet B. Code cat(conditionMessage(cnd_with(message_cnd))) Output Message. * Bullet A. * Bullet B. Code cat(conditionMessage(cnd_with(error_cnd, parent = TRUE))) Output Message. * Bullet A. * Bullet B. Caused by error in `foo()`: ! Parent message. * Bullet 1. * Bullet 2. Code cat(conditionMessage(cnd_with(warning_cnd, parent = TRUE))) Output Message. * Bullet A. * Bullet B. Caused by error in `foo()`: ! Parent message. * Bullet 1. * Bullet 2. Code cat(conditionMessage(cnd_with(message_cnd, parent = TRUE))) Output Message. * Bullet A. * Bullet B. Caused by error in `foo()`: ! Parent message. * Bullet 1. * Bullet 2. # multiline operator calls are preserved Error in `1 + ("veeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeery_long" + "veeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeery_long")`: ! This is the error message. --- Error in `{ 1 2 } + { 2 3 }`: ! This is the error message. --- Error in `x[{ 1 2 }]`: ! This is the error message. # can disable srcrefs in call formatting Code err(f()) Output Error in `g()`: ! foo # fallback method supports unknown bullets (#1364) Code # With fallback (expect_error(abort(c("foo", i2 = "bar")))) Output Error: ! foo bar Code (expect_error(abort(c(i1 = "foo", i2 = "bar")))) Output Error: ! foo bar --- Code # With cli (expect_error(abort(c("foo", i2 = "bar")))) Output Error: ! foo bar Code (expect_error(abort(c(i1 = "foo", i2 = "bar")))) Output Error: foo bar # arguments are highlighted but code spans are not Code with_error_arg_highlight(print(err)) Output Error: ! <> - `code` - <> # chained errors may have empty messages Code print(child) Output Error: ! Tilt. Code cat_line(cnd_message(child, prefix = TRUE)) Output Error: ! Tilt. --- Code print(child) Output Error in `foo()`: Caused by error: ! Tilt. Code cat_line(cnd_message(child, prefix = TRUE)) Output Error in `foo()`: Caused by error: ! Tilt. --- Code print(child) Output Error: ! Tilt. Code cat_line(cnd_message(child, prefix = TRUE)) Output Error: ! Tilt. rlang/tests/testthat/_snaps/trace.md0000644000176200001440000013150514657520720017277 0ustar liggesusers# tree printing only changes deliberately Code print(trace, dir = dir) Output x 1. \-rlang (local) i() at test-trace.R:25:3 2. \-rlang (local) j(i) at test-trace.R:18:8 3. \-rlang (local) k(i) at test-trace.R:19:22 4. \-rlang (local) l(i) at test-trace.R:22:5 Code cat("\n") Output Code print(trace_slice(trace, 0L), dir = dir) Output x # can print tree with collapsed branches Code # Full print(trace, simplify = "none", dir = dir, srcrefs = srcrefs) Output x 1. \-rlang (local) f() 2. \-rlang (local) g() at test-trace.R:49:21 3. +-base::tryCatch(h(), foo = identity, bar = identity) at test-trace.R:50:21 4. | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 5. | +-base (local) tryCatchOne(...) 6. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 7. | \-base (local) tryCatchList(expr, names[-nh], parentenv, handlers[-nh]) 8. | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 9. | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 10. \-rlang (local) h() 11. +-base::tryCatch(i(), baz = identity) at test-trace.R:51:21 12. | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 13. | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 14. | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 15. \-rlang (local) i() 16. +-base::tryCatch(trace_back(e, bottom = 0)) at test-trace.R:52:21 17. | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 18. \-rlang::trace_back(e, bottom = 0) Code # Focused print_focused_trace(trace, dir = dir, srcrefs = srcrefs) Output x 1. \-rlang (local) f() 2. \-rlang (local) g() at test-trace.R:49:21 3. +<<-base::tryCatch(h(), foo = identity, bar = identity) at test-trace.R:50:21>> 4. | <<\-base (local) tryCatchList(expr, classes, parentenv, handlers)>> 5. | <<+-base (local) tryCatchOne(...)>> 6. | <<| \-base (local) doTryCatch(return(expr), name, parentenv, handler)>> 7. | <<\-base (local) tryCatchList(expr, names[-nh], parentenv, handlers[-nh])>> 8. | <<\-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]])>> 9. | <<\-base (local) doTryCatch(return(expr), name, parentenv, handler)>> 10. \-rlang (local) h() 11. +<<-base::tryCatch(i(), baz = identity) at test-trace.R:51:21>> 12. | <<\-base (local) tryCatchList(expr, classes, parentenv, handlers)>> 13. | <<\-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]])>> 14. | <<\-base (local) doTryCatch(return(expr), name, parentenv, handler)>> 15. \-rlang (local) i() Code # Branch print(trace, simplify = "branch", dir = dir, srcrefs = srcrefs) Output 1. rlang (local) f() 2. rlang (local) g() at test-trace.R:49:21 10. rlang (local) h() 15. rlang (local) i() --- Code # Full print(trace, simplify = "none", dir = dir, srcrefs = srcrefs) Output x 1. \-rlang (local) f() 2. +-base::eval(quote(eval(quote(g())))) at test-trace.R:61:8 3. | \-base::eval(quote(eval(quote(g())))) 4. +-base::eval(quote(g())) 5. | \-base::eval(quote(g())) 6. \-rlang (local) g() 7. +-base::tryCatch(eval(quote(h())), foo = identity, bar = identity) at test-trace.R:62:8 8. | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 9. | +-base (local) tryCatchOne(...) 10. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 11. | \-base (local) tryCatchList(expr, names[-nh], parentenv, handlers[-nh]) 12. | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 13. | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 14. +-base::eval(quote(h())) 15. | \-base::eval(quote(h())) 16. \-rlang (local) h() Code # Focused print_focused_trace(trace, dir = dir, srcrefs = srcrefs) Output x 1. \-rlang (local) f() 2. +<<-base::eval(quote(eval(quote(g())))) at test-trace.R:61:8>> 3. | <<\-base::eval(quote(eval(quote(g()))))>> 4. +<<-base::eval(quote(g()))>> 5. | <<\-base::eval(quote(g()))>> 6. \-rlang (local) g() 7. +<<-base::tryCatch(eval(quote(h())), foo = identity, bar = identity) at test-trace.R:62:8>> 8. | <<\-base (local) tryCatchList(expr, classes, parentenv, handlers)>> 9. | <<+-base (local) tryCatchOne(...)>> 10. | <<| \-base (local) doTryCatch(return(expr), name, parentenv, handler)>> 11. | <<\-base (local) tryCatchList(expr, names[-nh], parentenv, handlers[-nh])>> 12. | <<\-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]])>> 13. | <<\-base (local) doTryCatch(return(expr), name, parentenv, handler)>> 14. +<<-base::eval(quote(h()))>> 15. | <<\-base::eval(quote(h()))>> 16. \-rlang (local) h() Code # Branch print(trace, simplify = "branch", dir = dir, srcrefs = srcrefs) Output 1. rlang (local) f() 6. rlang (local) g() 16. rlang (local) h() # cli_branch() handles edge case Code cli_branch(tree[-1, ]) Output [1] " 1. rlang (local) f()" # collapsed formatting doesn't collapse single frame siblings Code print(trace, simplify = "none", drop = TRUE, srcrefs = FALSE) Output x 1. \-rlang (local) f() 2. +-rlang::eval_bare(quote(g())) 3. \-rlang (local) g() Code print(trace, simplify = "none", drop = FALSE, srcrefs = FALSE) Output x 1. \-rlang (local) f() 2. +-rlang::eval_bare(quote(g())) 3. \-rlang (local) g() # recursive frames are rewired to the global env Code # Full print(trace, simplify = "none", dir = dir, srcrefs = srcrefs) Output x 1. +-rlang::eval_tidy(quo(f())) 2. \-rlang (local) f() 3. \-rlang (local) g() Code # Focused print_focused_trace(trace, dir = dir, srcrefs = srcrefs) Output x 1. +-rlang::eval_tidy(quo(f())) 2. \-rlang (local) f() 3. \-rlang (local) g() Code # Branch print(trace, simplify = "branch", dir = dir, srcrefs = srcrefs) Output 1. rlang::eval_tidy(quo(f())) 2. rlang (local) f() 3. rlang (local) g() # long backtrace branches are truncated Code cat("Full:\n") Output Full: Code print(trace, simplify = "branch", srcrefs = FALSE) Output 1. rlang (local) f(10) 2. rlang (local) f(n - 1) 3. rlang (local) f(n - 1) 4. rlang (local) f(n - 1) 5. rlang (local) f(n - 1) 6. rlang (local) f(n - 1) 7. rlang (local) f(n - 1) 8. rlang (local) f(n - 1) 9. rlang (local) f(n - 1) 10. rlang (local) f(n - 1) 11. rlang (local) f(n - 1) Code cat("\n5 frames:\n") Output 5 frames: Code print(trace, simplify = "branch", max_frames = 5, srcrefs = FALSE) Output 1. rlang (local) f(10) 2. rlang (local) f(n - 1) 3. rlang (local) f(n - 1) ... 10. rlang (local) f(n - 1) 11. rlang (local) f(n - 1) Code cat("\n2 frames:\n") Output 2 frames: Code print(trace, simplify = "branch", max_frames = 2, srcrefs = FALSE) Output 1. rlang (local) f(10) ... 11. rlang (local) f(n - 1) Code cat("\n1 frame:\n") Output 1 frame: Code print(trace, simplify = "branch", max_frames = 1, srcrefs = FALSE) Output 1. rlang (local) f(10) ... # eval() frames are collapsed Code # Full print(trace, simplify = "none", dir = dir, srcrefs = srcrefs) Output x 1. \-rlang (local) f() 2. +-base::eval(quote(g())) 3. | \-base::eval(quote(g())) 4. \-rlang (local) g() 5. +-base::eval(quote(trace_back(e, bottom = 0))) 6. | \-base::eval(quote(trace_back(e, bottom = 0))) 7. \-rlang::trace_back(e, bottom = 0) Code # Focused print_focused_trace(trace, dir = dir, srcrefs = srcrefs) Output x 1. \-rlang (local) f() 2. +<<-base::eval(quote(g()))>> 3. | <<\-base::eval(quote(g()))>> 4. \-rlang (local) g() Code # Branch print(trace, simplify = "branch", dir = dir, srcrefs = srcrefs) Output 1. rlang (local) f() 4. rlang (local) g() --- Code # Full print(trace, simplify = "none", dir = dir, srcrefs = srcrefs) Output x 1. \-rlang (local) f() 2. +-base::evalq(g()) 3. | \-base::evalq(g()) 4. \-rlang (local) g() 5. +-base::evalq(trace_back(e, bottom = 0)) 6. | \-base::evalq(trace_back(e, bottom = 0)) 7. \-rlang::trace_back(e, bottom = 0) Code # Focused print_focused_trace(trace, dir = dir, srcrefs = srcrefs) Output x 1. \-rlang (local) f() 2. +<<-base::evalq(g())>> 3. | <<\-base::evalq(g())>> 4. \-rlang (local) g() Code # Branch print(trace, simplify = "branch", dir = dir, srcrefs = srcrefs) Output 1. rlang (local) f() 4. rlang (local) g() # children of collapsed frames are rechained to correct parent Code cat("Full + drop:\n") Output Full + drop: Code print(trace, simplify = "none", drop = TRUE, srcrefs = FALSE) Output x 1. \-rlang (local) f() 2. \-base::eval(quote(g()), env()) 3. \-base::eval(quote(g()), env()) 4. \-rlang (local) g() Code cat("Full - drop:\n") Output Full - drop: Code print(trace, simplify = "none", drop = FALSE, srcrefs = FALSE) Output x 1. \-rlang (local) f() 2. \-base::eval(quote(g()), env()) 3. \-base::eval(quote(g()), env()) 4. \-rlang (local) g() Code cat("\nBranch:\n") Output Branch: Code print(trace, simplify = "branch", srcrefs = FALSE) Output 1. rlang (local) f() 2. base::eval(quote(g()), env()) 3. base::eval(quote(g()), env()) 4. rlang (local) g() # combinations of incomplete and leading pipes collapse properly Code # Full print(trace, simplify = "none", dir = dir, srcrefs = srcrefs) Output x 1. +-NA %>% F() %>% T() %>% F() %>% F() 2. +-rlang (local) F(.) 3. +-rlang (local) F(.) 4. \-rlang (local) T(.) Code # Focused print_focused_trace(trace, dir = dir, srcrefs = srcrefs) Output x 1. +-NA %>% F() %>% T() %>% F() %>% F() 2. +-rlang (local) F(.) 3. +-rlang (local) F(.) 4. \-rlang (local) T(.) Code # Branch print(trace, simplify = "branch", dir = dir, srcrefs = srcrefs) Output 1. NA %>% F() %>% T() %>% F() %>% F() 4. rlang (local) T(.) --- Code # Full print(trace, simplify = "none", dir = dir, srcrefs = srcrefs) Output x 1. +-T(NA) %>% F() 2. +-rlang (local) F(.) 3. \-rlang (local) T(NA) Code # Focused print_focused_trace(trace, dir = dir, srcrefs = srcrefs) Output x 1. +-T(NA) %>% F() 2. +-rlang (local) F(.) 3. \-rlang (local) T(NA) Code # Branch print(trace, simplify = "branch", dir = dir, srcrefs = srcrefs) Output 1. T(NA) %>% F() 3. rlang (local) T(NA) --- Code # Full print(trace, simplify = "none", dir = dir, srcrefs = srcrefs) Output x 1. +-F(NA) %>% F() %>% T() %>% F() %>% F() 2. +-rlang (local) F(.) 3. +-rlang (local) F(.) 4. \-rlang (local) T(.) Code # Focused print_focused_trace(trace, dir = dir, srcrefs = srcrefs) Output x 1. +-F(NA) %>% F() %>% T() %>% F() %>% F() 2. +-rlang (local) F(.) 3. +-rlang (local) F(.) 4. \-rlang (local) T(.) Code # Branch print(trace, simplify = "branch", dir = dir, srcrefs = srcrefs) Output 1. F(NA) %>% F() %>% T() %>% F() %>% F() 4. rlang (local) T(.) --- Code # Full print(trace, simplify = "none", dir = dir, srcrefs = srcrefs) Output x 1. +-NA %>% T() 2. \-rlang (local) T(.) Code # Focused print_focused_trace(trace, dir = dir, srcrefs = srcrefs) Output x 1. +-NA %>% T() 2. \-rlang (local) T(.) Code # Branch print(trace, simplify = "branch", dir = dir, srcrefs = srcrefs) Output 1. NA %>% T() 2. rlang (local) T(.) --- Code # Full print(trace, simplify = "none", dir = dir, srcrefs = srcrefs) Output x 1. +-NA %>% F() %>% T() 2. \-rlang (local) T(.) Code # Focused print_focused_trace(trace, dir = dir, srcrefs = srcrefs) Output x 1. +-NA %>% F() %>% T() 2. \-rlang (local) T(.) Code # Branch print(trace, simplify = "branch", dir = dir, srcrefs = srcrefs) Output 1. NA %>% F() %>% T() 2. rlang (local) T(.) --- Code # Full print(trace, simplify = "none", dir = dir, srcrefs = srcrefs) Output x 1. +-F(NA) %>% T() 2. \-rlang (local) T(.) Code # Focused print_focused_trace(trace, dir = dir, srcrefs = srcrefs) Output x 1. +-F(NA) %>% T() 2. \-rlang (local) T(.) Code # Branch print(trace, simplify = "branch", dir = dir, srcrefs = srcrefs) Output 1. F(NA) %>% T() 2. rlang (local) T(.) --- Code # Full print(trace, simplify = "none", dir = dir, srcrefs = srcrefs) Output x 1. +-F(NA) %>% F() %>% T() 2. \-rlang (local) T(.) Code # Focused print_focused_trace(trace, dir = dir, srcrefs = srcrefs) Output x 1. +-F(NA) %>% F() %>% T() 2. \-rlang (local) T(.) Code # Branch print(trace, simplify = "branch", dir = dir, srcrefs = srcrefs) Output 1. F(NA) %>% F() %>% T() 2. rlang (local) T(.) # calls before and after pipe are preserved Code # Full print(trace, simplify = "none", dir = dir, srcrefs = srcrefs) Output x 1. +-rlang (local) F(NA %>% T()) 2. +-NA %>% T() 3. \-rlang (local) T(.) Code # Focused print_focused_trace(trace, dir = dir, srcrefs = srcrefs) Output x 1. +-rlang (local) F(NA %>% T()) 2. +-NA %>% T() 3. \-rlang (local) T(.) Code # Branch print(trace, simplify = "branch", dir = dir, srcrefs = srcrefs) Output 1. rlang (local) F(NA %>% T()) 3. rlang (local) T(.) --- Code # Full print(trace, simplify = "none", dir = dir, srcrefs = srcrefs) Output x 1. +-NA %>% C() 2. \-rlang (local) C(.) 3. \-rlang (local) f() Code # Focused print_focused_trace(trace, dir = dir, srcrefs = srcrefs) Output x 1. +-NA %>% C() 2. \-rlang (local) C(.) 3. \-rlang (local) f() Code # Branch print(trace, simplify = "branch", dir = dir, srcrefs = srcrefs) Output 1. NA %>% C() 2. rlang (local) C(.) 3. rlang (local) f() --- Code # Full print(trace, simplify = "none", dir = dir, srcrefs = srcrefs) Output x 1. +-rlang (local) F(NA %>% C()) 2. +-NA %>% C() 3. \-rlang (local) C(.) 4. \-rlang (local) f() Code # Focused print_focused_trace(trace, dir = dir, srcrefs = srcrefs) Output x 1. +-rlang (local) F(NA %>% C()) 2. +-NA %>% C() 3. \-rlang (local) C(.) 4. \-rlang (local) f() Code # Branch print(trace, simplify = "branch", dir = dir, srcrefs = srcrefs) Output 1. rlang (local) F(NA %>% C()) 3. rlang (local) C(.) 4. rlang (local) f() # always keep very first frame as part of backtrace branch Code # Full print(trace, simplify = "none", dir = dir, srcrefs = srcrefs) Output x 1. +-rlang (local) gen() 2. \-rlang (local) gen.default() Code # Focused print_focused_trace(trace, dir = dir, srcrefs = srcrefs) Output x 1. +-rlang (local) gen() 2. \-rlang (local) gen.default() Code # Branch print(trace, simplify = "branch", dir = dir, srcrefs = srcrefs) Output 1. rlang (local) gen() 2. rlang (local) gen.default() # anonymous calls are stripped from backtraces Code # Full print(trace, simplify = "none", dir = dir, srcrefs = srcrefs) Output x 1. \-(function() {... Code # Focused print_focused_trace(trace, dir = dir, srcrefs = srcrefs) Output x 1. \-(function() {... Code # Branch print(trace, simplify = "branch", dir = dir, srcrefs = srcrefs) Output # collapsing of eval() frames detects when error occurs within eval() Code # Full print(trace, simplify = "none", dir = dir, srcrefs = srcrefs) Output x 1. +-base::eval() 2. \-base::.handleSimpleError(...) 3. \-rlang (local) h(simpleError(msg, call)) Code # Focused print_focused_trace(trace, dir = dir, srcrefs = srcrefs) Output x 1. +-base::eval() 2. \-base::.handleSimpleError(...) 3. \-rlang (local) h(simpleError(msg, call)) Code # Branch print(trace, simplify = "branch", dir = dir, srcrefs = srcrefs) Output 1. base::eval() 2. base::.handleSimpleError(...) 3. rlang (local) h(simpleError(msg, call)) # can print degenerate backtraces Code # Full print(trace, simplify = "none", dir = dir, srcrefs = srcrefs) Output x 1. \-foo Code # Focused print_focused_trace(trace, dir = dir, srcrefs = srcrefs) Output x 1. \-foo Code # Branch print(trace, simplify = "branch", dir = dir, srcrefs = srcrefs) Output 1. foo --- Code # Full print(trace, simplify = "none", dir = dir, srcrefs = srcrefs) Output x 1. \-NULL Code # Focused print_focused_trace(trace, dir = dir, srcrefs = srcrefs) Output x 1. \-NULL Code # Branch print(trace, simplify = "branch", dir = dir, srcrefs = srcrefs) Output 1. NULL --- Code # Full print(trace, simplify = "none", dir = dir, srcrefs = srcrefs) Output x 1. \-1L Code # Focused print_focused_trace(trace, dir = dir, srcrefs = srcrefs) Output x 1. \-1L Code # Branch print(trace, simplify = "branch", dir = dir, srcrefs = srcrefs) Output 1. 1L # check for dangling promise in call CAR (#492) Code # Full print(trace, simplify = "none", dir = dir, srcrefs = srcrefs) Output x 1. +-base::print(foo) 2. \-rlang (local) print.foo(foo) Code # Focused print_focused_trace(trace, dir = dir, srcrefs = srcrefs) Output x 1. +-base::print(foo) 2. \-rlang (local) print.foo(foo) Code # Branch print(trace, simplify = "branch", dir = dir, srcrefs = srcrefs) Output 1. base::print(foo) 2. rlang (local) print.foo(foo) # dangling srcrefs are not printed Code # Full print(trace, simplify = "none", dir = dir, srcrefs = srcrefs) Output x 1. \-rlang (local) f(current_env()) 2. \-rlang (local) g(e) at fixtures/trace-srcref2.R:2:3 Code # Focused print_focused_trace(trace, dir = dir, srcrefs = srcrefs) Output x 1. \-rlang (local) f(current_env()) 2. \-rlang (local) g(e) at fixtures/trace-srcref2.R:2:3 Code # Branch print(trace, simplify = "branch", dir = dir, srcrefs = srcrefs) Output 1. rlang (local) f(current_env()) 2. rlang (local) g(e) at fixtures/trace-srcref2.R:2:3 # summary.rlang_trace() prints the full tree Code summary(trace, srcrefs = FALSE) Output x 1. \-rlang (local) f() 2. \-rlang (local) g() 3. \-rlang (local) h() # global functions have `global::` prefix Code # Full print(trace, simplify = "none", dir = dir, srcrefs = srcrefs) Output x 1. \-rlang (local) g(current_env()) 2. \-global f(e) Code # Focused print_focused_trace(trace, dir = dir, srcrefs = srcrefs) Output x 1. \-rlang (local) g(current_env()) 2. \-global f(e) Code # Branch print(trace, simplify = "branch", dir = dir, srcrefs = srcrefs) Output 1. rlang (local) g(current_env()) 2. global f(e) # local functions inheriting from global do not have `global::` prefix Code # Full print(trace, simplify = "none", dir = dir, srcrefs = srcrefs) Output x 1. \-rlang (local) g(current_env()) 2. \-f(e) Code # Focused print_focused_trace(trace, dir = dir, srcrefs = srcrefs) Output x 1. \-rlang (local) g(current_env()) 2. \-f(e) Code # Branch print(trace, simplify = "branch", dir = dir, srcrefs = srcrefs) Output 1. rlang (local) g(current_env()) 2. f(e) # can trim layers of backtraces Code local_options(rlang_trace_format_srcrefs = FALSE) cat_line("No trimming:") Output No trimming: Code summary(trace0) Output x 1. \-rlang (local) f(0) at test-trace.R:412:3 2. +-base::identity(identity(g(n))) at test-trace.R:408:8 3. +-base::identity(g(n)) 4. \-rlang (local) g(n) 5. +-base::identity(identity(h(n))) at test-trace.R:409:8 6. +-base::identity(h(n)) 7. \-rlang (local) h(n) 8. +-base::identity(identity(trace_back(e, bottom = n))) at test-trace.R:410:8 9. +-base::identity(trace_back(e, bottom = n)) 10. \-rlang::trace_back(e, bottom = n) Code cat_line("", "", "One layer (the default):") Output One layer (the default): Code summary(trace1) Output x 1. \-rlang (local) f(1) at test-trace.R:413:3 2. +-base::identity(identity(g(n))) at test-trace.R:408:8 3. +-base::identity(g(n)) 4. \-rlang (local) g(n) 5. +-base::identity(identity(h(n))) at test-trace.R:409:8 6. +-base::identity(h(n)) 7. \-rlang (local) h(n) Code cat_line("", "", "Two layers:") Output Two layers: Code summary(trace2) Output x 1. \-rlang (local) f(2) at test-trace.R:414:3 2. +-base::identity(identity(g(n))) at test-trace.R:408:8 3. +-base::identity(g(n)) 4. \-rlang (local) g(n) Code cat_line("", "", "Three layers:") Output Three layers: Code summary(trace3) Output x 1. \-rlang (local) f(3) at test-trace.R:415:3 # caught error does not display backtrace in knitted files Code cat_line(render_md("test-trace-full.Rmd")) Output library(rlang) f <- function() g() g <- function() h() h <- function() rlang::abort("foo") f() ## Error in `h()`: ## ! foo Currently needs to be in a different chunk: last_error() ## ## Error in `h()`: ## ! foo ## --- ## Backtrace: ## x ## 1. \-global f() ## 2. \-global g() ## 3. \-global h() ## Run rlang::last_trace(drop = FALSE) to see 1 hidden frame. last_trace() ## ## Error in `h()`: ## ! foo ## --- ## Backtrace: ## x ## 1. \-global f() ## 2. \-global g() ## 3. \-global h() ## Run rlang::last_trace(drop = FALSE) to see 1 hidden frame. options(rlang_backtrace_on_error_report = "reminder") f() ## Error in `h()`: ## ! foo ## Run `rlang::last_trace()` to see where the error occurred. options(rlang_backtrace_on_error_report = "full") f() ## Error in `h()`: ## ! foo ## Backtrace: ## x ## 1. \-global f() ## 2. \-global g() ## 3. \-global h() ## 4. \-rlang::abort("foo") # backtraces don't contain inlined objects (#1069, r-lib/testthat#1223) Code summary(trace) Output x 1. +-rlang::inject(f(!!list())) 2. \-rlang (local) f(``) 3. +-base::do.call("g", list(runif(1e+06) + 0)) 4. \-rlang (local) g(``) 5. \-rlang (local) h() # runs of namespaces are embolden (#946) Code print(err) Output  Error in `1 + ""`: ! non-numeric argument to binary operator --- Backtrace:  x  1. +-rlang::catch_cnd(withCallingHandlers(f(), error = entrace), "error")  2. | +-rlang::eval_bare(...)  3. | +-base::tryCatch(...)  4. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers)  5. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]])  6. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler)  7. | \-base::force(expr)  8. +-base::withCallingHandlers(f(), error = entrace)  9. \-rlang (local) f()  10.  \-rlang (local) g()  11.  \-rlang (local) h()  12.  \-base::identity(1 + "") Code summary(err) Output  Error in `1 + ""`: ! non-numeric argument to binary operator --- Backtrace:  x  1. +-rlang::catch_cnd(withCallingHandlers(f(), error = entrace), "error")  2. | +-rlang::eval_bare(...)  3. | +-base::tryCatch(...)  4. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers)  5. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]])  6. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler)  7. | \-base::force(expr)  8. +-base::withCallingHandlers(f(), error = entrace)  9. \-rlang (local) f()  10.  \-rlang (local) g()  11.  \-rlang (local) h()  12.  \-base::identity(1 + "") # `bottom` must be a positive integer Code (expect_error(trace_back(bottom = -1))) Output Error in `trace_back()`: ! `bottom` must be a positive integer. # collapsed case in branch formatting 1. f() 2. g() 3. h() 4. evalq() 5. evalq() # trailing `FALSE` visibility is handled Code # Full print(trace, simplify = "none", dir = dir, srcrefs = srcrefs) Output x 1. \-f() 2. \-g() 3. \-h() 4. \-foo() 5. \-bar() Code # Focused print_focused_trace(trace, dir = dir, srcrefs = srcrefs) Output x 1. \-f() 2. \-g() 3. \-h() Code # Branch print(trace, simplify = "branch", dir = dir, srcrefs = srcrefs) Output 1. f() 2. g() 3. h() # can format empty traces Code # Full print(trace, simplify = "none", dir = dir, srcrefs = srcrefs) Output x Code # Focused print_focused_trace(trace, dir = dir, srcrefs = srcrefs) Output x Code # Branch print(trace, simplify = "branch", dir = dir, srcrefs = srcrefs) Output # sibling streaks in tree backtraces Code # Full print(trace, simplify = "none", dir = dir, srcrefs = srcrefs) Output Error in `h()`: ! foo --- Backtrace: x 1. +-rlang::catch_cnd(f(g()), "error") 2. | +-rlang::eval_bare(...) 3. | +-base::tryCatch(...) 4. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 5. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 6. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 7. | \-base::force(expr) 8. +-rlang (local) f(g()) 9. | +-base::identity(identity(x)) 10. | \-base::identity(x) 11. \-rlang (local) g() 12. +-rlang (local) f(f(h())) 13. | +-base::identity(identity(x)) 14. | \-base::identity(x) 15. +-rlang (local) f(h()) 16. | +-base::identity(identity(x)) 17. | \-base::identity(x) 18. \-rlang (local) h() Code # Focused print_focused_trace(trace, dir = dir, srcrefs = srcrefs) Output Error in `h()`: ! foo --- Backtrace: x 1. +-rlang::catch_cnd(f(g()), "error") 2. | <<+-rlang::eval_bare(...)>> 3. | <<+-base::tryCatch(...)>> 4. | <<| \-base (local) tryCatchList(expr, classes, parentenv, handlers)>> 5. | <<| \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]])>> 6. | <<| \-base (local) doTryCatch(return(expr), name, parentenv, handler)>> 7. | <<\-base::force(expr)>> 8. +-rlang (local) f(g()) 9. | <<+-base::identity(identity(x))>> 10. | <<\-base::identity(x)>> 11. \-rlang (local) g() 12. +<<-rlang (local) f(f(h()))>> 13. | <<+-base::identity(identity(x))>> 14. | <<\-base::identity(x)>> 15. +<<-rlang (local) f(h())>> 16. | <<+-base::identity(identity(x))>> 17. | <<\-base::identity(x)>> 18. \-rlang (local) h() Code # Branch print(trace, simplify = "branch", dir = dir, srcrefs = srcrefs) Output Error in `h()`: ! foo --- Backtrace: 1. rlang::catch_cnd(f(g()), "error") 11. rlang (local) g() 18. rlang (local) h() # parallel '|' branches are correctly emphasised Code # Full print(trace, simplify = "none", dir = dir, srcrefs = srcrefs) Output Error in `h()`: ! foo --- Backtrace: x 1. +-testthat::expect_error(parallel(f(0))) 2. | \-testthat:::expect_condition_matching(...) 3. | \-testthat:::quasi_capture(...) 4. | +-testthat (local) .capture(...) 5. | | \-base::withCallingHandlers(...) 6. | \-rlang::eval_bare(quo_get_expr(.quo), quo_get_env(.quo)) 7. +-rlang (local) parallel(f(0)) 8. | +-rlang (local) p1(identity(x)) 9. | | \-rlang (local) p2(x) 10. | | \-rlang (local) p3(x) 11. | \-base::identity(x) 12. \-rlang (local) f(0) 13. \-rlang (local) g(n) 14. \-rlang (local) h(n) Code # Focused print_focused_trace(trace, dir = dir, srcrefs = srcrefs) Output Error in `h()`: ! foo --- Backtrace: x 1. +-testthat::expect_error(parallel(f(0))) 2. | <<\-testthat:::expect_condition_matching(...)>> 3. | <<\-testthat:::quasi_capture(...)>> 4. | <<+-testthat (local) .capture(...)>> 5. | <<| \-base::withCallingHandlers(...)>> 6. | <<\-rlang::eval_bare(quo_get_expr(.quo), quo_get_env(.quo))>> 7. +-rlang (local) parallel(f(0)) 8. | <<+-rlang (local) p1(identity(x))>> 9. | <<| \-rlang (local) p2(x)>> 10. | <<| \-rlang (local) p3(x)>> 11. | <<\-base::identity(x)>> 12. \-rlang (local) f(0) 13. \-rlang (local) g(n) 14. \-rlang (local) h(n) Code # Branch print(trace, simplify = "branch", dir = dir, srcrefs = srcrefs) Output Error in `h()`: ! foo --- Backtrace: 1. testthat::expect_error(parallel(f(0))) 12. rlang (local) f(0) 13. rlang (local) g(n) 14. rlang (local) h(n) --- Code # Full print(trace, simplify = "none", dir = dir, srcrefs = srcrefs) Output Error in `h()`: ! foo --- Backtrace: x 1. +-testthat::expect_error(deep(1)) 2. | \-testthat:::expect_condition_matching(...) 3. | \-testthat:::quasi_capture(...) 4. | +-testthat (local) .capture(...) 5. | | \-base::withCallingHandlers(...) 6. | \-rlang::eval_bare(quo_get_expr(.quo), quo_get_env(.quo)) 7. \-rlang (local) deep(1) 8. +-rlang (local) parallel(f(n)) 9. | +-rlang (local) p1(identity(x)) 10. | | \-rlang (local) p2(x) 11. | | \-rlang (local) p3(x) 12. | \-base::identity(x) 13. \-rlang (local) f(n) 14. \-rlang (local) g(n) 15. \-rlang (local) h(n) 16. +-rlang (local) parallel(f(n - 1)) 17. | +-rlang (local) p1(identity(x)) 18. | | \-rlang (local) p2(x) 19. | | \-rlang (local) p3(x) 20. | \-base::identity(x) 21. \-rlang (local) f(n - 1) 22. \-rlang (local) g(n) 23. \-rlang (local) h(n) Code # Focused print_focused_trace(trace, dir = dir, srcrefs = srcrefs) Output Error in `h()`: ! foo --- Backtrace: x 1. +-testthat::expect_error(deep(1)) 2. | <<\-testthat:::expect_condition_matching(...)>> 3. | <<\-testthat:::quasi_capture(...)>> 4. | <<+-testthat (local) .capture(...)>> 5. | <<| \-base::withCallingHandlers(...)>> 6. | <<\-rlang::eval_bare(quo_get_expr(.quo), quo_get_env(.quo))>> 7. \-rlang (local) deep(1) 8. +<<-rlang (local) parallel(f(n))>> 9. | <<+-rlang (local) p1(identity(x))>> 10. | <<| \-rlang (local) p2(x)>> 11. | <<| \-rlang (local) p3(x)>> 12. | <<\-base::identity(x)>> 13. \-rlang (local) f(n) 14. \-rlang (local) g(n) 15. \-rlang (local) h(n) 16. +<<-rlang (local) parallel(f(n - 1))>> 17. | <<+-rlang (local) p1(identity(x))>> 18. | <<| \-rlang (local) p2(x)>> 19. | <<| \-rlang (local) p3(x)>> 20. | <<\-base::identity(x)>> 21. \-rlang (local) f(n - 1) 22. \-rlang (local) g(n) 23. \-rlang (local) h(n) Code # Branch print(trace, simplify = "branch", dir = dir, srcrefs = srcrefs) Output Error in `h()`: ! foo --- Backtrace: 1. testthat::expect_error(deep(1)) 7. rlang (local) deep(1) 13. rlang (local) f(n) 14. rlang (local) g(n) 15. rlang (local) h(n) 21. rlang (local) f(n - 1) 22. rlang (local) g(n) 23. rlang (local) h(n) # error calls and args are highlighted Code print_highlighted_trace(parent) Output Error in <>: ! `x` must be a single string, not the number 1. --- Backtrace: x 1. +-rlang:::catch_error(f(1)) 2. | \-rlang::catch_cnd(expr, "error") 3. | +-rlang::eval_bare(...) 4. | +-base::tryCatch(...) 5. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 6. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 7. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 8. | \-base::force(expr) 9. \-rlang (local) f(1) 10. \-rlang (local) g(x) 11. \-rlang (local) <><><> Code print_highlighted_trace(child) Output Error in <>: ! Tilt. Caused by error in <>: ! `x` must be a single string, not the number 1. --- Backtrace: x 1. +-rlang:::catch_error(wrapper()) 2. | \-rlang::catch_cnd(expr, "error") 3. | +-rlang::eval_bare(...) 4. | +-base::tryCatch(...) 5. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 6. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 7. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 8. | \-base::force(expr) 9. \-rlang (local) wrapper() 10. +-rlang::try_fetch(f(1), error = function(cnd) abort("Tilt.", parent = cnd)) 11. | +-base::tryCatch(...) 12. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 13. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 14. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 15. | \-base::withCallingHandlers(...) 16. \-rlang (local) f(1) 17. \-rlang (local) g(x) 18. \-rlang (local) <><><> # error calls and args are highlighted (no highlighted arg) Code print_highlighted_trace(argless) Output Error in <>: ! foo --- Backtrace: x 1. +-rlang:::catch_error(f()) 2. | \-rlang::catch_cnd(expr, "error") 3. | +-rlang::eval_bare(...) 4. | +-base::tryCatch(...) 5. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 6. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 7. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 8. | \-base::force(expr) 9. \-rlang (local) f() 10. \-rlang (local) g() 11. \-rlang (local) <><> # frame is detected from the left Code # If detected from the right, `evalq()`is highlighted instead of `h()` print_highlighted_trace(err) Output Error in <>: ! foo --- Backtrace: x 1. +-rlang:::catch_error(f()) 2. | \-rlang::catch_cnd(expr, "error") 3. | +-rlang::eval_bare(...) 4. | +-base::tryCatch(...) 5. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 6. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 7. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 8. | \-base::force(expr) 9. \-rlang (local) f() 10. \-rlang (local) g() 11. \-rlang (local) <><> # arg is defensively checked Code print_highlighted_trace(err) Output Error in <>: ! foo --- Backtrace: x 1. +-rlang:::catch_error(f()) 2. | \-rlang::catch_cnd(expr, "error") 3. | +-rlang::eval_bare(...) 4. | +-base::tryCatch(...) 5. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 6. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 7. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 8. | \-base::force(expr) 9. \-rlang (local) f() 10. \-rlang (local) g() 11. \-rlang (local) <><> # namespaced calls are highlighted Code print_highlighted_trace(err) Output Error in <>: ! Can't convert a double vector to a string. --- Backtrace: x 1. +-rlang:::catch_error(f()) 2. | \-rlang::catch_cnd(expr, "error") 3. | +-rlang::eval_bare(...) 4. | +-base::tryCatch(...) 5. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 6. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 7. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 8. | \-base::force(expr) 9. \-rlang (local) f() 10. \-rlang (local) g() 11. \-rlang (local) h() 12. \-<>1<> # can highlight long lists of arguments in backtrace (#1456) Code print_highlighted_trace(err) Output Error in <>: ! foo --- Backtrace: x 1. +-rlang:::catch_error(f()) 2. | \-rlang::catch_cnd(expr, "error") 3. | +-rlang::eval_bare(...) 4. | +-base::tryCatch(...) 5. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 6. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 7. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 8. | \-base::force(expr) 9. \-rlang (local) f() 10. \-rlang (local) <>...<> --- Code print_highlighted_trace(err) Output Error in <>: ! foo --- Backtrace: x 1. +-rlang:::catch_error(f(arg = "bbbbbbbbbbbb")) 2. | \-rlang::catch_cnd(expr, "error") 3. | +-rlang::eval_bare(...) 4. | +-base::tryCatch(...) 5. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 6. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 7. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 8. | \-base::force(expr) 9. \-rlang (local) f(arg = "bbbbbbbbbbbb") 10. \-rlang (local) <><><> # can highlight multi-line arguments in backtrace (#1456) Code print_highlighted_trace(err) Output Error in <>: ! foo --- Backtrace: x 1. +-rlang:::catch_error(f()) 2. | \-rlang::catch_cnd(expr, "error") 3. | +-rlang::eval_bare(...) 4. | +-base::tryCatch(...) 5. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 6. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 7. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 8. | \-base::force(expr) 9. \-rlang (local) f() 10. \-rlang (local) <>...<> --- Code print_highlighted_trace(err) Output Error in <>: ! foo --- Backtrace: x 1. +-rlang:::catch_error(f(arg = "x")) 2. | \-rlang::catch_cnd(expr, "error") 3. | +-rlang::eval_bare(...) 4. | +-base::tryCatch(...) 5. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 6. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 7. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 8. | \-base::force(expr) 9. \-rlang (local) f(arg = "x") 10. \-rlang (local) <><><> rlang/tests/testthat/_snaps/eval-tidy.md0000644000176200001440000000454514741441060020073 0ustar liggesusers# fake pronoun fails informatively Code # Fake pronouns f <- (function() .data$foo) (expect_error(f(), "subset")) Output Error in `f()`: ! Can't subset `.data` outside of a data mask context. Code f <- (function() .data[["foo"]]) (expect_error(f(), "subset")) Output Error in `f()`: ! Can't subset `.data` outside of a data mask context. # `.data` pronoun fails informatively Code (expect_error(f())) Output Error in `g()`: ! Can't subset `.data` outside of a data mask context. Code (expect_error(f(mtcars))) Output Error in `.data$foo`: ! Column `foo` not found in `.data`. Code g <- (function(data) h(.data[[2]], data)) (expect_error(f(mtcars))) Output Error in `.data[[2]]`: ! Must subset the data pronoun with a string, not the number 2. Code g <- (function(data) h(.data["foo"], data = data)) (expect_error(f(mtcars))) Output Error in `.data["foo"]`: ! `[` is not supported by the `.data` pronoun, use `[[` or $ instead. Code g <- (function(data) h(.data[["foo"]] <- 1, data = data)) (expect_error(f(mtcars))) Output Error in `.data[["foo"]] <- ...`: ! Can't modify the data pronoun. Code g <- (function(data) h(.data$foo <- 1, data = data)) (expect_error(f(mtcars))) Output Error in `.data$"foo" <- ...`: ! Can't modify the data pronoun. Code g <- (function(data) h(.env["foo"], data = data)) (expect_error(f(mtcars))) Output Error in `.env["foo"]`: ! `[` is not supported by the `.env` pronoun, use `[[` or $ instead. Code g <- (function(data) h(.env$foo <- 1, data = data)) (expect_error(f(mtcars))) Output Error in `.env$"foo" <- ...`: ! Can't modify the context pronoun. Code g <- (function(data) h(.env[["foo"]] <- 1, data = data)) (expect_error(f(mtcars))) Output Error in `.env[["foo"]] <- ...`: ! Can't modify the context pronoun. rlang/tests/testthat/_snaps/sym.md0000644000176200001440000000075514657520715017017 0ustar liggesusers# ensym() fails with calls Code err(capture_sym(foo(bar))) Output Error in `ensym()`: ! Can't convert to a symbol. # must supply strings to sym() Code err(sym(letters)) Output Error in `sym()`: ! Can't convert a character vector to a symbol. Code err(sym(1:2)) Output Error in `sym()`: ! Can't convert an integer vector to a symbol. rlang/tests/testthat/_snaps/parse.md0000644000176200001440000000056414657520707017320 0ustar liggesusers# parse_expr() throws meaningful error messages Code err(parse_expr("")) Output Error in `parse_expr()`: ! `x` must contain exactly 1 expression, not 0. Code err(parse_expr("foo; bar")) Output Error in `parse_expr()`: ! `x` must contain exactly 1 expression, not 2. rlang/tests/testthat/_snaps/nse-defuse.md0000644000176200001440000000251514657520705020240 0ustar liggesusers# corner cases are handled when interpolating dot names Code (expect_error(quos(!!var := NULL))) Output Error in `quos()`: ! The LHS of `:=` must be a string, not `NULL`. Code (expect_error(list2(!!c("a", "b") := NULL))) Output Error in `list2()`: ! The LHS of `:=` must be a string, not a character vector. # ensyms() captures multiple symbols Code err(fn(foo())) Output Error in `sym()`: ! Can't convert a call to a symbol. # ensym() unwraps quosures Code err(fn(!!quo(foo()))) Output Error in `ensym()`: ! Can't convert to a symbol. # ensyms() unwraps quosures Code err(fn(!!!quos(foo, bar()))) Output Error in `sym()`: ! Can't convert a call to a symbol. # auto-named expressions can be unique-repaired Code expect_equal(dots_names(1, foo = 1, 1, foo = 2), c("1...1", "foo", "1...3", "foo")) Message New names: * `1` -> `1...1` * `1` -> `1...3` Code expect_equal(dots_names(bar, foo = 1, bar, foo = 2), c("bar...1", "foo", "bar...3", "foo")) Message New names: * `bar` -> `bar...1` * `bar` -> `bar...3` rlang/tests/testthat/_snaps/fn.md0000644000176200001440000000262114741441060016571 0ustar liggesusers# as_function() has nice errors Code (expect_error(as_function(1))) Output Error: ! Can't convert `1`, a double vector, to a function. Code (expect_error(as_function(1, arg = "foo"))) Output Error: ! Can't convert `foo`, a double vector, to a function. Code (expect_error(my_function(1 + 2))) Output Error in `my_function()`: ! Can't convert `my_arg`, a double vector, to a function. Code (expect_error(my_function(1))) Output Error in `my_function()`: ! Can't convert `my_arg`, a double vector, to a function. Code (expect_error(my_function(a ~ b))) Output Error in `my_function()`: ! Can't convert `my_arg`, a two-sided formula, to a function. # check inputs in function accessors Code (expect_error(fn_fmls(1))) Output Error in `fn_fmls()`: ! `fn` must be an R function, not the number 1. Code (expect_error(fn_body(1))) Output Error in `fn_body()`: ! `fn` must be an R function, not the number 1. Code (expect_error(fn_env(1))) Output Error in `fn_env()`: ! `fn` must be a function, not the number 1. rlang/tests/testthat/_snaps/attr.md0000644000176200001440000000057414741441060017145 0ustar liggesusers# inputs must be valid Code (expect_error(set_names(environment()))) Output Error in `set_names()`: ! `x` must be a vector Code (expect_error(set_names(1:10, letters[1:4]))) Output Error in `set_names()`: ! The size of `nm` (4) must be compatible with the size of `x` (10). rlang/tests/testthat/_snaps/cnd-signal.md0000644000176200001440000000600514741441060020205 0ustar liggesusers# cnd_signal() creates a backtrace if needed Code print(err) Output --- Backtrace: x 1. +-rlang::catch_cnd(f()) 2. | +-rlang::eval_bare(...) 3. | +-base::tryCatch(...) 4. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 5. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 6. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 7. | \-base::force(expr) 8. \-rlang (local) f() 9. \-rlang (local) g() 10. \-rlang (local) h() # `inform()` and `warn()` with recurrent footer handle newlines correctly Code inform("foo", .frequency = "regularly", .frequency_id = as.character(runif(1))) Message foo This message is displayed once every 8 hours. Code inform("bar", .frequency = "regularly", .frequency_id = as.character(runif(1))) Message bar This message is displayed once every 8 hours. Code warn("foo", .frequency = "regularly", .frequency_id = as.character(runif(1))) Condition Warning: foo This warning is displayed once every 8 hours. Code warn("bar", .frequency = "regularly", .frequency_id = as.character(runif(1))) Condition Warning: bar This warning is displayed once every 8 hours. # `frequency` has good error messages Code (expect_error(inform("foo", .frequency = "once", .frequency_id = NULL))) Output Error in `inform()`: ! `.frequency_id` must be supplied with `.frequency`. Code (expect_error(warn("foo", .frequency = "once", .frequency_id = 1L))) Output Error in `warn()`: ! `.frequency` must be a valid name, not the number 1. # signal functions check inputs Code (expect_error(abort(error_cnd("foo")))) Output Error in `abort()`: ! `message` must be a character vector, not a object. Code (expect_error(inform(error_cnd("foo")))) Output Error in `inform()`: ! `message` must be a character vector, not a object. Code (expect_error(warn(class = error_cnd("foo")))) Output Error in `warn()`: ! `class` must be a character vector, not a object. Code (expect_error(abort("foo", call = base::call))) Output Error in `abort()`: ! `call` must be a call or environment, not a primitive function. # error_cnd() still accepts `.subclass` Code expect_equal(error_cnd(.subclass = "foo"), error_cnd("foo")) Condition Warning: The `.subclass` argument of `error_cnd()` has been renamed to `class`. Code expect_error(abort("foo", .subclass = "bar"), class = "bar") Condition Warning: The `.subclass` argument of `abort()` has been renamed to `class`. rlang/tests/testthat/_snaps/s3.md0000644000176200001440000000073214741441060016514 0ustar liggesusers# as_box_if() ensures boxed value if predicate returns TRUE Code (expect_error(as_box_if(NULL, ~10))) Output Error in `.p()`: ! Predicate functions must return a single `TRUE` or `FALSE`, not the number 10 Code (expect_error(as_box_if(NULL, ~ c(TRUE, FALSE)))) Output Error in `.p()`: ! Predicate functions must return a single `TRUE` or `FALSE`, not a logical vector rlang/tests/testthat/_snaps/pre-3.6.0/0000755000176200001440000000000014376112150017072 5ustar liggesusersrlang/tests/testthat/_snaps/pre-3.6.0/cnd-abort.md0000644000176200001440000002313114376112150021265 0ustar liggesusers# withCallingHandlers() wrappers don't throw off trace capture on rethrow Code # `abort()` error print(err) Output Error in `wch()`: ! High-level message Caused by error in `low3()`: ! Low-level message --- Backtrace: x 1. +-testthat::expect_error(high1()) 2. | \-testthat:::expect_condition_matching(...) 3. | \-testthat:::quasi_capture(...) 4. | +-testthat (local) .capture(...) 5. | | \-base::withCallingHandlers(...) 6. | \-rlang::eval_bare(quo_get_expr(.quo), quo_get_env(.quo)) 7. \-rlang (local) high1() 8. \-rlang (local) high2() 9. \-rlang (local) high3() 10. +-rlang (local) wch(low1(), error = function(err) handler1(err)) 11. | \-base::withCallingHandlers(expr, ...) 12. \-rlang (local) low1() 13. \-rlang (local) low2() 14. \-rlang (local) low3() Code summary(err) Output Error in `wch()`: ! High-level message Caused by error in `low3()`: ! Low-level message --- Backtrace: x 1. +-testthat::expect_error(high1()) 2. | \-testthat:::expect_condition_matching(...) 3. | \-testthat:::quasi_capture(...) 4. | +-testthat (local) .capture(...) 5. | | \-base::withCallingHandlers(...) 6. | \-rlang::eval_bare(quo_get_expr(.quo), quo_get_env(.quo)) 7. \-rlang (local) high1() 8. \-rlang (local) high2() 9. \-rlang (local) high3() 10. +-rlang (local) wch(low1(), error = function(err) handler1(err)) 11. | \-base::withCallingHandlers(expr, ...) 12. \-rlang (local) low1() 13. \-rlang (local) low2() 14. \-rlang (local) low3() --- Code # C-level error print(err) Output Error in `wch()`: ! High-level message Caused by error: ! Low-level message --- Backtrace: x 1. +-testthat::expect_error(high1()) 2. | \-testthat:::expect_condition_matching(...) 3. | \-testthat:::quasi_capture(...) 4. | +-testthat (local) .capture(...) 5. | | \-base::withCallingHandlers(...) 6. | \-rlang::eval_bare(quo_get_expr(.quo), quo_get_env(.quo)) 7. \-rlang (local) high1() 8. \-rlang (local) high2() 9. \-rlang (local) high3() 10. +-rlang (local) wch(low1(), error = function(err) handler1(err)) 11. | \-base::withCallingHandlers(expr, ...) 12. \-rlang (local) low1() 13. \-rlang (local) low2() 14. \-rlang (local) low3() 15. \-rlang (local) fail(NULL, "Low-level message") Code summary(err) Output Error in `wch()`: ! High-level message Caused by error: ! Low-level message --- Backtrace: x 1. +-testthat::expect_error(high1()) 2. | \-testthat:::expect_condition_matching(...) 3. | \-testthat:::quasi_capture(...) 4. | +-testthat (local) .capture(...) 5. | | \-base::withCallingHandlers(...) 6. | \-rlang::eval_bare(quo_get_expr(.quo), quo_get_env(.quo)) 7. \-rlang (local) high1() 8. \-rlang (local) high2() 9. \-rlang (local) high3() 10. +-rlang (local) wch(low1(), error = function(err) handler1(err)) 11. | \-base::withCallingHandlers(expr, ...) 12. \-rlang (local) low1() 13. \-rlang (local) low2() 14. \-rlang (local) low3() 15. \-rlang (local) fail(NULL, "Low-level message") # `parent = NA` signals a non-chained rethrow Code # Absent parent causes bad trace bottom hh <- (function() { withCallingHandlers(foo(), error = function(cnd) { abort(cnd_header(cnd)) }) }) print(err(ff())) Output Error in `h()`: ! bar --- Backtrace: x 1. +-base::print(err(ff())) 2. +-rlang:::err(ff()) 3. | \-testthat::expect_error(...) 4. | \-testthat:::expect_condition_matching(...) 5. | \-testthat:::quasi_capture(...) 6. | +-testthat (local) .capture(...) 7. | | \-base::withCallingHandlers(...) 8. | \-rlang::eval_bare(quo_get_expr(.quo), quo_get_env(.quo)) 9. +-rlang (local) ff() 10. | \-rlang (local) gg() 11. | \-rlang (local) hh() 12. | +-base::withCallingHandlers(...) 13. | \-rlang (local) foo() 14. | \-rlang (local) bar() 15. | \-rlang (local) baz() 16. | \-base::stop("bar") 17. \-base::.handleSimpleError(``, "bar", quote(baz())) 18. \-rlang (local) h(simpleError(msg, call)) Code # Missing parent allows correct trace bottom hh <- (function() { withCallingHandlers(foo(), error = function(cnd) { abort(cnd_header(cnd), parent = NA) }) }) print(err(ff())) Output Error in `hh()`: ! bar --- Backtrace: x 1. +-base::print(err(ff())) 2. +-rlang:::err(ff()) 3. | \-testthat::expect_error(...) 4. | \-testthat:::expect_condition_matching(...) 5. | \-testthat:::quasi_capture(...) 6. | +-testthat (local) .capture(...) 7. | | \-base::withCallingHandlers(...) 8. | \-rlang::eval_bare(quo_get_expr(.quo), quo_get_env(.quo)) 9. \-rlang (local) ff() 10. \-rlang (local) gg() 11. \-rlang (local) hh() 12. +-base::withCallingHandlers(...) 13. \-rlang (local) foo() 14. \-rlang (local) bar() 15. \-rlang (local) baz() 16. \-base::stop("bar") Code # Wrapped handler handler1 <- (function(cnd, call = caller_env()) handler2(cnd, call)) handler2 <- (function(cnd, call) abort(cnd_header(cnd), parent = NA, call = call)) hh <- (function() { withCallingHandlers(foo(), error = function(cnd) handler1(cnd)) }) print(err(ff())) Output Error in `hh()`: ! bar --- Backtrace: x 1. +-base::print(err(ff())) 2. +-rlang:::err(ff()) 3. | \-testthat::expect_error(...) 4. | \-testthat:::expect_condition_matching(...) 5. | \-testthat:::quasi_capture(...) 6. | +-testthat (local) .capture(...) 7. | | \-base::withCallingHandlers(...) 8. | \-rlang::eval_bare(quo_get_expr(.quo), quo_get_env(.quo)) 9. \-rlang (local) ff() 10. \-rlang (local) gg() 11. \-rlang (local) hh() 12. +-base::withCallingHandlers(foo(), error = function(cnd) handler1(cnd)) 13. \-rlang (local) foo() 14. \-rlang (local) bar() 15. \-rlang (local) baz() 16. \-base::stop("bar") Code # Wrapped handler, `try_fetch()` hh <- (function() { try_fetch(foo(), error = function(cnd) handler1(cnd)) }) print(err(ff())) Output Error in `hh()`: ! bar --- Backtrace: x 1. +-base::print(err(ff())) 2. +-rlang:::err(ff()) 3. | \-testthat::expect_error(...) 4. | \-testthat:::expect_condition_matching(...) 5. | \-testthat:::quasi_capture(...) 6. | +-testthat (local) .capture(...) 7. | | \-base::withCallingHandlers(...) 8. | \-rlang::eval_bare(quo_get_expr(.quo), quo_get_env(.quo)) 9. \-rlang (local) ff() 10. \-rlang (local) gg() 11. \-rlang (local) hh() 12. +-rlang::try_fetch(foo(), error = function(cnd) handler1(cnd)) 13. | +-base::tryCatch(...) 14. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 15. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 16. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 17. | \-base::withCallingHandlers(...) 18. \-rlang (local) foo() 19. \-rlang (local) bar() 20. \-rlang (local) baz() 21. \-base::stop("bar") Code # Wrapped handler, incorrect `call` hh <- (function() { withCallingHandlers(foo(), error = handler1) }) print(err(ff())) Output Error in `.handleSimpleError()`: ! bar --- Backtrace: x 1. +-base::print(err(ff())) 2. +-rlang:::err(ff()) 3. | \-testthat::expect_error(...) 4. | \-testthat:::expect_condition_matching(...) 5. | \-testthat:::quasi_capture(...) 6. | +-testthat (local) .capture(...) 7. | | \-base::withCallingHandlers(...) 8. | \-rlang::eval_bare(quo_get_expr(.quo), quo_get_env(.quo)) 9. \-rlang (local) ff() 10. \-rlang (local) gg() 11. \-rlang (local) hh() 12. +-base::withCallingHandlers(foo(), error = handler1) 13. \-rlang (local) foo() 14. \-rlang (local) bar() 15. \-rlang (local) baz() 16. \-base::stop("bar") rlang/tests/testthat/_snaps/standalone-obj-type.md0000644000176200001440000000042314657520711022052 0ustar liggesusers# stop_input_type() handles I() in `arg` (#1607) Code err(checker(1, stop_input_type, what = "a logical", arg = I("Element 1 of `x`"))) Output Error in `checker()`: ! Element 1 of `x` must be a logical, not the number 1. rlang/tests/testthat/_snaps/c-api.md0000644000176200001440000000335214741441060017161 0ustar liggesusers# internal error is thrown with OOB dyn-lof access Code err(lof_arr_push_back(lof, 0, 42L), "Location 0 does not exist") Output Error in `lof_arr_push_back()`: ! Location 0 does not exist. i In file 'rlang/dyn-list-of.c' at line 167. i This is an internal error that was detected in the rlang package. Please report it at with a reprex () and the full backtrace. Code err(lof_arr_push_back(lof, 10, 42L), "Location 10 does not exist") Output Error in `lof_arr_push_back()`: ! Location 10 does not exist. i In file 'rlang/dyn-list-of.c' at line 167. i This is an internal error that was detected in the rlang package. Please report it at with a reprex () and the full backtrace. # re-encoding fails purposefully with any bytes Code (expect_error(r_obj_encode_utf8(bytes))) Output --- Code (expect_error(r_obj_encode_utf8(c(enc, bytes)))) Output --- Code (expect_error(r_obj_encode_utf8(c(enc, bytes)))) Output --- Code (expect_error(r_obj_encode_utf8(c(enc, bytes)))) Output rlang/tests/testthat/_snaps/env-binding.md0000644000176200001440000000057014741441060020367 0ustar liggesusers# env_get() without default fails Code (expect_error(env_get(env(), "foobar"))) Output Error in `env_get()`: ! Can't find `foobar` in environment. Code (expect_error(env_get_list(env(), "foobar"))) Output Error in `env_get_list()`: ! Can't find `foobar` in environment. rlang/tests/testthat/_snaps/current/0000755000176200001440000000000014667532743017345 5ustar liggesusersrlang/tests/testthat/_snaps/current/cnd-abort.md0000644000176200001440000002313714667532743021546 0ustar liggesusers# withCallingHandlers() wrappers don't throw off trace capture on rethrow Code # `abort()` error print(err) Output Error in `wch()`: ! High-level message Caused by error in `low3()`: ! Low-level message --- Backtrace: x 1. +-testthat::expect_error(high1()) 2. | \-testthat:::expect_condition_matching(...) 3. | \-testthat:::quasi_capture(...) 4. | +-testthat (local) .capture(...) 5. | | \-base::withCallingHandlers(...) 6. | \-rlang::eval_bare(quo_get_expr(.quo), quo_get_env(.quo)) 7. \-rlang (local) high1() 8. \-rlang (local) high2() 9. \-rlang (local) high3() 10. +-rlang (local) wch(low1(), error = function(err) handler1(err)) 11. | \-base::withCallingHandlers(expr, ...) 12. \-rlang (local) low1() 13. \-rlang (local) low2() 14. \-rlang (local) low3() Code summary(err) Output Error in `wch()`: ! High-level message Caused by error in `low3()`: ! Low-level message --- Backtrace: x 1. +-testthat::expect_error(high1()) 2. | \-testthat:::expect_condition_matching(...) 3. | \-testthat:::quasi_capture(...) 4. | +-testthat (local) .capture(...) 5. | | \-base::withCallingHandlers(...) 6. | \-rlang::eval_bare(quo_get_expr(.quo), quo_get_env(.quo)) 7. \-rlang (local) high1() 8. \-rlang (local) high2() 9. \-rlang (local) high3() 10. +-rlang (local) wch(low1(), error = function(err) handler1(err)) 11. | \-base::withCallingHandlers(expr, ...) 12. \-rlang (local) low1() 13. \-rlang (local) low2() 14. \-rlang (local) low3() --- Code # C-level error print(err) Output Error in `wch()`: ! High-level message Caused by error: ! Low-level message --- Backtrace: x 1. +-testthat::expect_error(high1()) 2. | \-testthat:::expect_condition_matching(...) 3. | \-testthat:::quasi_capture(...) 4. | +-testthat (local) .capture(...) 5. | | \-base::withCallingHandlers(...) 6. | \-rlang::eval_bare(quo_get_expr(.quo), quo_get_env(.quo)) 7. \-rlang (local) high1() 8. \-rlang (local) high2() 9. \-rlang (local) high3() 10. +-rlang (local) wch(low1(), error = function(err) handler1(err)) 11. | \-base::withCallingHandlers(expr, ...) 12. \-rlang (local) low1() 13. \-rlang (local) low2() 14. \-rlang (local) low3() 15. \-rlang (local) fail(NULL, "Low-level message") Code summary(err) Output Error in `wch()`: ! High-level message Caused by error: ! Low-level message --- Backtrace: x 1. +-testthat::expect_error(high1()) 2. | \-testthat:::expect_condition_matching(...) 3. | \-testthat:::quasi_capture(...) 4. | +-testthat (local) .capture(...) 5. | | \-base::withCallingHandlers(...) 6. | \-rlang::eval_bare(quo_get_expr(.quo), quo_get_env(.quo)) 7. \-rlang (local) high1() 8. \-rlang (local) high2() 9. \-rlang (local) high3() 10. +-rlang (local) wch(low1(), error = function(err) handler1(err)) 11. | \-base::withCallingHandlers(expr, ...) 12. \-rlang (local) low1() 13. \-rlang (local) low2() 14. \-rlang (local) low3() 15. \-rlang (local) fail(NULL, "Low-level message") # `parent = NA` signals a non-chained rethrow Code # Absent parent causes bad trace bottom hh <- (function() { withCallingHandlers(foo(), error = function(cnd) { abort(cnd_header(cnd)) }) }) print(err(ff())) Output Error in `h()`: ! bar --- Backtrace: x 1. +-base::print(err(ff())) 2. +-rlang:::err(ff()) 3. | \-testthat::expect_error(...) 4. | \-testthat:::expect_condition_matching(...) 5. | \-testthat:::quasi_capture(...) 6. | +-testthat (local) .capture(...) 7. | | \-base::withCallingHandlers(...) 8. | \-rlang::eval_bare(quo_get_expr(.quo), quo_get_env(.quo)) 9. +-rlang (local) ff() 10. | \-rlang (local) gg() 11. | \-rlang (local) hh() 12. | +-base::withCallingHandlers(...) 13. | \-rlang (local) foo() 14. | \-rlang (local) bar() 15. | \-rlang (local) baz() 16. | \-base::stop("bar") 17. \-base::.handleSimpleError(``, "bar", base::quote(baz())) 18. \-rlang (local) h(simpleError(msg, call)) Code # Missing parent allows correct trace bottom hh <- (function() { withCallingHandlers(foo(), error = function(cnd) { abort(cnd_header(cnd), parent = NA) }) }) print(err(ff())) Output Error in `hh()`: ! bar --- Backtrace: x 1. +-base::print(err(ff())) 2. +-rlang:::err(ff()) 3. | \-testthat::expect_error(...) 4. | \-testthat:::expect_condition_matching(...) 5. | \-testthat:::quasi_capture(...) 6. | +-testthat (local) .capture(...) 7. | | \-base::withCallingHandlers(...) 8. | \-rlang::eval_bare(quo_get_expr(.quo), quo_get_env(.quo)) 9. \-rlang (local) ff() 10. \-rlang (local) gg() 11. \-rlang (local) hh() 12. +-base::withCallingHandlers(...) 13. \-rlang (local) foo() 14. \-rlang (local) bar() 15. \-rlang (local) baz() 16. \-base::stop("bar") Code # Wrapped handler handler1 <- (function(cnd, call = caller_env()) handler2(cnd, call)) handler2 <- (function(cnd, call) abort(cnd_header(cnd), parent = NA, call = call)) hh <- (function() { withCallingHandlers(foo(), error = function(cnd) handler1(cnd)) }) print(err(ff())) Output Error in `hh()`: ! bar --- Backtrace: x 1. +-base::print(err(ff())) 2. +-rlang:::err(ff()) 3. | \-testthat::expect_error(...) 4. | \-testthat:::expect_condition_matching(...) 5. | \-testthat:::quasi_capture(...) 6. | +-testthat (local) .capture(...) 7. | | \-base::withCallingHandlers(...) 8. | \-rlang::eval_bare(quo_get_expr(.quo), quo_get_env(.quo)) 9. \-rlang (local) ff() 10. \-rlang (local) gg() 11. \-rlang (local) hh() 12. +-base::withCallingHandlers(foo(), error = function(cnd) handler1(cnd)) 13. \-rlang (local) foo() 14. \-rlang (local) bar() 15. \-rlang (local) baz() 16. \-base::stop("bar") Code # Wrapped handler, `try_fetch()` hh <- (function() { try_fetch(foo(), error = function(cnd) handler1(cnd)) }) print(err(ff())) Output Error in `hh()`: ! bar --- Backtrace: x 1. +-base::print(err(ff())) 2. +-rlang:::err(ff()) 3. | \-testthat::expect_error(...) 4. | \-testthat:::expect_condition_matching(...) 5. | \-testthat:::quasi_capture(...) 6. | +-testthat (local) .capture(...) 7. | | \-base::withCallingHandlers(...) 8. | \-rlang::eval_bare(quo_get_expr(.quo), quo_get_env(.quo)) 9. \-rlang (local) ff() 10. \-rlang (local) gg() 11. \-rlang (local) hh() 12. +-rlang::try_fetch(foo(), error = function(cnd) handler1(cnd)) 13. | +-base::tryCatch(...) 14. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 15. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 16. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 17. | \-base::withCallingHandlers(...) 18. \-rlang (local) foo() 19. \-rlang (local) bar() 20. \-rlang (local) baz() 21. \-base::stop("bar") Code # Wrapped handler, incorrect `call` hh <- (function() { withCallingHandlers(foo(), error = handler1) }) print(err(ff())) Output Error in `.handleSimpleError()`: ! bar --- Backtrace: x 1. +-base::print(err(ff())) 2. +-rlang:::err(ff()) 3. | \-testthat::expect_error(...) 4. | \-testthat:::expect_condition_matching(...) 5. | \-testthat:::quasi_capture(...) 6. | +-testthat (local) .capture(...) 7. | | \-base::withCallingHandlers(...) 8. | \-rlang::eval_bare(quo_get_expr(.quo), quo_get_env(.quo)) 9. \-rlang (local) ff() 10. \-rlang (local) gg() 11. \-rlang (local) hh() 12. +-base::withCallingHandlers(foo(), error = handler1) 13. \-rlang (local) foo() 14. \-rlang (local) bar() 15. \-rlang (local) baz() 16. \-base::stop("bar") rlang/tests/testthat/_snaps/standalone-s3-register.md0000644000176200001440000000065114657520712022474 0ustar liggesusers# can register for generics that don't exist Code (expect_warning(s3_register("testthat::foobarbaz", "class", method = function( ...) NULL))) Output Warning: Can't find generic `foobarbaz` in package testthat to register S3 method. i This message is only shown to developers using devtools. i Do you need to update testthat to the latest version? rlang/tests/testthat/_snaps/cnd-handlers.md0000644000176200001440000001760014741441060020533 0ustar liggesusers# try_fetch() checks inputs Code (expect_error(try_fetch(NULL, function(...) NULL))) Output Error in `try_fetch()`: ! `...` must be named with condition classes. # can rethrow from `try_fetch()` Code err <- catch_error(try_fetch(f(), error = function(cnd) abort("bar", parent = cnd))) print(err) Output Error: ! bar Caused by error in `h()`: ! foo --- Backtrace: x 1. +-rlang:::catch_error(...) 2. | \-rlang::catch_cnd(expr, "error") 3. | +-rlang::eval_bare(...) 4. | +-base::tryCatch(...) 5. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 6. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 7. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 8. | \-base::force(expr) 9. +-rlang::try_fetch(f(), error = function(cnd) abort("bar", parent = cnd)) 10. | +-base::tryCatch(...) 11. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 12. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 13. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 14. | \-base::withCallingHandlers(...) 15. \-rlang (local) f() 16. \-rlang (local) g() 17. \-rlang (local) h() Code print(err, simplify = "none") Output Error: ! bar Caused by error in `h()`: ! foo --- Backtrace: x 1. +-rlang:::catch_error(...) 2. | \-rlang::catch_cnd(expr, "error") 3. | +-rlang::eval_bare(...) 4. | +-base::tryCatch(...) 5. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 6. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 7. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 8. | \-base::force(expr) 9. +-rlang::try_fetch(f(), error = function(cnd) abort("bar", parent = cnd)) 10. | +-base::tryCatch(...) 11. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 12. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 13. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 14. | \-base::withCallingHandlers(...) 15. \-rlang (local) f() 16. \-rlang (local) g() 17. \-rlang (local) h() Code err <- catch_error(high1(chain = TRUE)) print(err) Output Error in `high3()`: ! bar Caused by error in `h()`: ! foo --- Backtrace: x 1. +-rlang:::catch_error(high1(chain = TRUE)) 2. | \-rlang::catch_cnd(expr, "error") 3. | +-rlang::eval_bare(...) 4. | +-base::tryCatch(...) 5. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 6. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 7. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 8. | \-base::force(expr) 9. \-rlang (local) high1(chain = TRUE) 10. \-rlang (local) high2(...) 11. \-rlang (local) high3(...) 12. +-rlang::try_fetch(f(), error = function(cnd) abort("bar", parent = cnd)) 13. | +-base::tryCatch(...) 14. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 15. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 16. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 17. | \-base::withCallingHandlers(...) 18. \-rlang (local) f() 19. \-rlang (local) g() 20. \-rlang (local) h() Code print(err, simplify = "none") Output Error in `high3()`: ! bar Caused by error in `h()`: ! foo --- Backtrace: x 1. +-rlang:::catch_error(high1(chain = TRUE)) 2. | \-rlang::catch_cnd(expr, "error") 3. | +-rlang::eval_bare(...) 4. | +-base::tryCatch(...) 5. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 6. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 7. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 8. | \-base::force(expr) 9. \-rlang (local) high1(chain = TRUE) 10. \-rlang (local) high2(...) 11. \-rlang (local) high3(...) 12. +-rlang::try_fetch(f(), error = function(cnd) abort("bar", parent = cnd)) 13. | +-base::tryCatch(...) 14. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 15. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 16. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 17. | \-base::withCallingHandlers(...) 18. \-rlang (local) f() 19. \-rlang (local) g() 20. \-rlang (local) h() Code err <- catch_error(high1(chain = FALSE)) print(err) Output Error in `high3()`: ! bar --- Backtrace: x 1. +-rlang:::catch_error(high1(chain = FALSE)) 2. | \-rlang::catch_cnd(expr, "error") 3. | +-rlang::eval_bare(...) 4. | +-base::tryCatch(...) 5. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 6. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 7. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 8. | \-base::force(expr) 9. \-rlang (local) high1(chain = FALSE) 10. \-rlang (local) high2(...) 11. \-rlang (local) high3(...) 12. +-rlang::try_fetch(f(), error = function(cnd) abort("bar", parent = NA)) 13. | +-base::tryCatch(...) 14. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 15. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 16. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 17. | \-base::withCallingHandlers(...) 18. \-rlang (local) f() 19. \-rlang (local) g() 20. \-rlang (local) h() Code print(err, simplify = "none") Output Error in `high3()`: ! bar --- Backtrace: x 1. +-rlang:::catch_error(high1(chain = FALSE)) 2. | \-rlang::catch_cnd(expr, "error") 3. | +-rlang::eval_bare(...) 4. | +-base::tryCatch(...) 5. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 6. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 7. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 8. | \-base::force(expr) 9. \-rlang (local) high1(chain = FALSE) 10. \-rlang (local) high2(...) 11. \-rlang (local) high3(...) 12. +-rlang::try_fetch(f(), error = function(cnd) abort("bar", parent = NA)) 13. | +-base::tryCatch(...) 14. | | \-base (local) tryCatchList(expr, classes, parentenv, handlers) 15. | | \-base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 16. | | \-base (local) doTryCatch(return(expr), name, parentenv, handler) 17. | \-base::withCallingHandlers(...) 18. \-rlang (local) f() 19. \-rlang (local) g() 20. \-rlang (local) h() rlang/tests/testthat/test-standalone-downstream-deps.R0000644000176200001440000000533714376112150022731 0ustar liggesuserstest_that("can parse versions", { out <- .rlang_downstream_parse_deps(c("foo (>= 1.0)")) expect_equal(out, list( c(pkg = "foo", min = "1.0") )) out <- .rlang_downstream_parse_deps(c("foo (>= 1.0)", "bar (>= 2.0.0)")) expect_equal(out, list( c(pkg = "foo", min = "1.0"), c(pkg = "bar", min = "2.0.0") )) expect_error( .rlang_downstream_parse_deps("foo"), "Parsing error" ) expect_error( .rlang_downstream_parse_deps("foo (1.0)"), "Parsing error" ) expect_error( .rlang_downstream_parse_deps("foo (< 1.0)"), "Can only check `>=` requirements" ) }) test_that("can check downstream versions", { local_interactive(FALSE) ok_deps <- .rlang_downstream_parse_deps(c( "base (>= 1.0)", "utils (>= 1.1)" )) expect_no_warning( expect_true( .rlang_downstream_check( pkg = "rlang", pkg_ver = "0.5.0", deps = ok_deps, info = "Consequences.", env = env(checked = FALSE) ) ) ) bad_deps <- .rlang_downstream_parse_deps(c( "base (>= 1.0)", "utils (>= 100.10)" )) expect_snapshot({ (expect_warning({ expect_false( .rlang_downstream_check( pkg = "rlang", pkg_ver = "0.5.0", deps = bad_deps, info = "Consequences.", env = env(checked = FALSE) ) ) NULL })) }) missing_deps <- .rlang_downstream_parse_deps(c( "base (>= 1.0)", "foobar (>= 100.10)" )) expect_no_warning({ expect_true( .rlang_downstream_check( pkg = "rlang", pkg_ver = "0.5.0", deps = missing_deps, info = "Consequences.", env = env(checked = FALSE) ) ) NULL }) }) test_that("setting `rlib_downstream_check` disables the check", { local_options(rlib_downstream_check = FALSE) local_interactive(FALSE) bad_deps <- .rlang_downstream_parse_deps(c( "base (>= 1.0)", "utils (>= 100.10)" )) expect_no_warning( expect_null( .rlang_downstream_check( pkg = "rlang", pkg_ver = "0.5.0", deps = bad_deps, info = "Consequences.", env = env(checked = FALSE) ) ) ) }) test_that("check_downstream() saves status in global env", { local_interactive(TRUE) local_options("rlang:::no_downstream_prompt" = TRUE) bad_deps <- .rlang_downstream_parse_deps(c( "base (>= 1.0)", "utils (>= 100.10)" )) key <- as.character(runif(1)) check <- function() { .rlang_downstream_check( pkg = "rlang", pkg_ver = "0.5.0", deps = bad_deps, info = "Consequences.", deps_key = key, env = env(checked = FALSE) ) } expect_warning(expect_false(check())) expect_no_warning(expect_null(check())) }) rlang/tests/testthat/test-standalone-obj-type.R0000644000176200001440000000135114741441060021337 0ustar liggesusersutils::globalVariables(c("setClass", "R6Class", "new_class")) test_that("obj_type_oo() works", { bare <- list() expect_equal(obj_type_oo(bare), "bare") s3 <- mtcars expect_equal(obj_type_oo(s3), "S3") import_or_skip("methods", "setClass") setClass("s4", "integer", where = environment()) s4 <- new("s4", 1L) expect_equal(obj_type_oo(s4), "S4") import_or_skip("R6", "R6Class") r6 <- R6Class("r6")$new() expect_equal(obj_type_oo(r6), "R6") import_or_skip("R7", "new_class") r7 <- new_class("r7")() expect_equal(obj_type_oo(r7), "R7") }) test_that("stop_input_type() handles I() in `arg` (#1607)", { expect_snapshot({ err(checker(1, stop_input_type, what = "a logical", arg = I("Element 1 of `x`"))) }) }) rlang/tests/testthat/test-hash.R0000644000176200001440000000246514175213516016416 0ustar liggesuserstest_that("simple hashes with no ALTREP and no attributes are reproducible", { skip_if_big_endian() expect_identical(hash(1), "a3f7d4a39b65b170005aafbbeed05106") expect_identical(hash("a"), "4d52a7da68952b85f039e85a90f9bbd2") expect_identical(hash(1:5 + 0L), "0d26bf75943b8e13c080c6bab12a7440") }) test_that("hash_file() errors if the file doesn't exist", { expect_error(hash_file("foo.ext")) }) test_that("hash_file() works for 0 length input", { expect_identical(hash_file(character()), character()) }) test_that("hash_file() has known fixed value for empty files", { skip_if_big_endian() path <- withr::local_tempfile() file.create(path) expect_identical(hash_file(path), "99aa06d3014798d86001c324468d497f") }) test_that("hash_file() results change as more data is written to the file", { path <- withr::local_tempfile() file.create(path) initial <- hash_file(path) saveRDS(1, path) expect_true(hash_file(path) != initial) }) test_that("hash_file()'s internal state is reset between files", { path1 <- withr::local_tempfile() file.create(path1) saveRDS(1, path1) path2 <- withr::local_tempfile() file.create(path2) saveRDS(2, path2) hashes <- hash_file(c(path1, path2)) expect_identical(hashes[[1]], hash_file(path1)) expect_identical(hashes[[2]], hash_file(path2)) }) rlang/tests/testthat/test-eval-tidy.R0000644000176200001440000004035414741441060017364 0ustar liggesuserstest_that("accepts expressions", { expect_identical(eval_tidy(10), 10) expect_identical(eval_tidy(quote(letters)), letters) }) test_that("eval_tidy uses quosure environment", { x <- 10 quo <- local({ y <- 100 quo(x + y) }) expect_equal(eval_tidy(quo), 110) }) test_that("data must be uniquely named", { expect_error(eval_tidy(NULL, list(x = 1, x = 2)), "has duplicate columns") data <- set_names(data.frame(x = 1, x = 2, y = 3, y = 4), c("x", "x", "y", "y")) expect_error(eval_tidy(NULL, data), "has duplicate columns") }) test_that("can supply unnamed empty data", { expect_identical(eval_tidy("foo", list()), "foo") expect_identical(eval_tidy("foo", data.frame()), "foo") }) test_that("looks first in `data`", { x <- 10 data <- list(x = 100) expect_equal(eval_tidy(quo(x), data), 100) }) test_that("pronouns resolve ambiguity looks first in `data`", { x <- 10 data <- list(x = 100) expect_equal(eval_tidy(quo(.data$x), data), 100) expect_equal(eval_tidy(quo(.env$x), data), 10) }) test_that("pronouns complain about missing values", { expect_data_pronoun_error(eval_tidy(quo(.data$x), list()), "Column `x` not found in `.data`") expect_data_pronoun_error(eval_tidy(quo(.data$x), data.frame()), "Column `x` not found in `.data`") }) test_that("nested quosures look in their own env", { n <- 10 f <- function() { n <- 100 quo(n) } quo <- quo(!!f()) expect_equal(eval_tidy(quo), 100) }) test_that("nested quosure thunks rechain properly in the non-data mask", { bar <- "foo" quo <- quo(identity(!!quo(toupper(!!quo(identity(bar)))))) expect_identical(eval_tidy(quo), "FOO") }) test_that("unquoted formulas can use data", { f1 <- function() { z <- 100 x <- 2 quo(x + z) } f2 <- function() { z <- 100 quo(.data$x + .env$z) } z <- 10 expect_identical(eval_tidy(f2(), list(x = 1)), 101) expect_identical(eval_tidy(quo(!! f1()), data = list(x = 1)), 101) expect_identical(eval_tidy(quo(!! f2()), data = list(x = 1)), 101) }) test_that("bare formulas are not evaluated", { f <- local(~x) expect_identical(eval_tidy(quo(!! f)), f) f <- a ~ b expect_identical(eval_tidy(quo(!! f)), f) }) test_that("quosures are not evaluated if not forced", { fn <- function(arg, force) { if (force) arg else "bar" } f1 <- quo(fn(!! quo(stop("forced!")), force = FALSE)) f2 <- quo(fn(!! local(quo(stop("forced!"))), force = FALSE)) expect_identical(eval_tidy(f1), "bar") expect_identical(eval_tidy(f2), "bar") f_forced1 <- quo(fn(!! quo(stop("forced!")), force = TRUE)) f_forced2 <- quo(fn(!! local(quo(stop("forced!"))), force = TRUE)) expect_error(eval_tidy(f_forced1), "forced!") expect_error(eval_tidy(f_forced2), "forced!") }) test_that("can unquote captured arguments", { var <- quo(cyl) fn <- function(arg) eval_tidy(enquo(arg), mtcars) expect_identical(fn(var), quo(cyl)) expect_identical(fn(!!var), mtcars$cyl) }) test_that("quosures are evaluated recursively", { foo <- "bar" expect_identical(eval_tidy(quo(foo)), "bar") expect_identical(eval_tidy(quo(!!quo(!! quo(foo)))), "bar") }) test_that("quosures have lazy semantics", { fn <- function(arg) "unforced" expect_identical(eval_tidy(quo(fn(~stop()))), "unforced") }) test_that("can unquote hygienically within captured arg", { fn <- function(df, arg) eval_tidy(enquo(arg), df) foo <- "bar"; var <- quo(foo) expect_identical(fn(mtcars, list(var, !!var)), list(quo(foo), "bar")) var <- quo(cyl) expect_identical(fn(mtcars, (!!var) > 4), mtcars$cyl > 4) expect_identical(fn(mtcars, list(var, !!var)), list(quo(cyl), mtcars$cyl)) expect_equal( fn(mtcars, list(~var, !!var)), list(~var, mtcars$cyl), ignore_formula_env = TRUE ) expect_equal( fn(mtcars, list(~~var, !!quo(var), !!quo(quo(var)))), list(~~var, quo(cyl), quo(var)), ignore_formula_env = TRUE ) }) test_that("can unquote for old-style NSE functions", { var <- quo(foo) fn <- function(x) substitute(x) expect_identical(quo(fn(!!quo_get_expr(var))), quo(fn(foo))) expect_identical(eval_tidy(quo(fn(!!quo_get_expr(var)))), quote(foo)) }) test_that("all quosures in the call are evaluated", { foobar <- function(x) paste0("foo", x) x <- new_quosure(call("foobar", local({ bar <- "bar"; quo(bar) }))) f <- new_quosure(call("identity", x)) expect_identical(eval_tidy(f), "foobar") }) test_that("two-sided formulas are not treated as quosures", { expect_identical(eval_tidy(new_quosure(a ~ b)), a ~ b) }) test_that("formulas are evaluated in evaluation environment", { f <- eval_tidy(quo(foo ~ bar), list(foo = "bar")) expect_false(identical(f_env(f), current_env())) }) test_that("evaluation env is cleaned up", { f <- local(quo(function() list(f = ~letters, env = environment()))) fn <- eval_tidy(f) out <- fn() expect_identical(out$f, with_env(env = out$env, ~letters)) }) test_that("inner formulas are rechained to evaluation env", { env <- child_env(NULL) f1 <- quo(env$eval_env1 <- current_env()) f2 <- quo({ !! f1 env$eval_env2 <- current_env() }) eval_tidy(f2, mtcars) expect_identical(env$eval_env1, env$eval_env2) expect_true(env_inherits(env$eval_env2, get_env(f2))) }) test_that("empty quosure self-evaluates", { quo <- quo(is_missing(!! quo())) expect_true(eval_tidy(quo)) }) test_that("cannot replace elements of pronouns", { expect_error(eval_tidy(quo(.data$foo <- "bar"), mtcars), "Can't modify the data pronoun") }) test_that("formulas are not evaluated as quosures", { expect_identical(eval_tidy(~letters), ~letters) }) test_that("tilde calls are evaluated in overscope", { quo <- quo({ foo <- "foo" ~foo }) f <- eval_tidy(quo) expect_true(env_has(f_env(f), "foo")) }) test_that(".env pronoun refers to current quosure (#174)", { inner_quo <- local({ var <- "inner" quo(.env$var) }) outer_quo <- local({ var <- "outer" quo(identity(!! inner_quo)) }) expect_identical(eval_tidy(outer_quo, list()), "inner") }) test_that("can call tilde with named arguments (#226)", { expect_equal( eval_tidy(quote(`~`(foo = x, bar = y))), `~`(foo = x, bar = y), ignore_formula_env = TRUE ) expect_equal( eval_tidy(quote(`~`(foo = x, bar = y, baz = z))), `~`(foo = x, bar = y, baz = z), ignore_formula_env = TRUE ) }) test_that("Arguments to formulas are not stripped from their attributes (#227)", { quo <- quo(x) f <- eval_tidy(quo(~!!quo)) expect_identical(f_rhs(f), quo) f <- eval_tidy(quo(!!quo(x) ~ a)) expect_identical(f_lhs(f), quo) }) test_that("evaluating an empty quosure fails", { expect_error(eval_tidy(quo()), "not found") }) test_that("can supply a data mask as data", { mask <- as_data_mask(list(x = 1L)) eval_tidy(quo(x <- 2L), mask) expect_identical(eval_tidy(quo(x), mask), 2L) }) test_that("as_data_pronoun() creates pronoun", { data <- as_data_pronoun(mtcars) expect_s3_class(data, "rlang_data_pronoun") data_env <- .subset2(data, 1) expect_reference(env_parent(data_env), empty_env()) expect_true(all(env_names(data_env) %in% names(mtcars))) expect_data_pronoun_error(data$foobar, "Column `foobar` not found in `.data`") expect_identical(data[["cyl"]], mtcars$cyl) }) test_that("can create pronoun from a mask", { top <- env(a = 1) bottom <- env(top, b = 2) mask <- new_data_mask(bottom, top) .data <- as_data_pronoun(mask) expect_s3_class(.data, "rlang_data_pronoun") expect_identical(.data$a, 1) expect_identical(.data$b, 2) }) test_that("pronoun has print() and str() method", { data <- as_data_pronoun(mtcars) expect_output(print(data), "") expect_output(str(data), "") data <- as_data_pronoun(list(a = 1)) expect_output(print(data), "") }) test_that("data mask can escape", { fn <- eval_tidy(quote(function() cyl), mtcars) expect_identical(fn(), mtcars$cyl) }) test_that("inner formulas are evaluated in the current frame", { quo <- quo(local(list(f_env = f_env(~foo), env = current_env()))) envs <- eval_tidy(quo) expect_identical(envs$f_env, envs$env) quo <- quo(as_function(~list(f_env = get_env(~foo), env = current_env()))()) envs <- eval_tidy(quo) expect_identical(envs$f_env, envs$env) }) test_that("names are translated to native when creating data mask", { with_latin1_locale({ str_utf8 <- "\u00fc" str_native <- enc2native(str_utf8) d <- set_names(list("value"), str_utf8) s <- sym(str_native) expect_identical(eval_tidy(s, data = d), "value") foreign_utf8 <- "\u5FCD" foreign_native <- enc2native(foreign_utf8) d <- setNames(list("value"), foreign_utf8) s <- sym(foreign_native) expect_identical(eval_tidy(s, data = d), "value") }) }) test_that("new_data_mask() checks `top` is a parent of `bottom`", { top <- env() bottom <- env(top) expect_no_error(new_data_mask(bottom, top)) expect_error(new_data_mask(top, bottom), "`top` is not a parent of `bottom`") }) test_that("data mask inherits from last environment", { mask <- new_data_mask(NULL, NULL) expect_reference(env_parent(mask), empty_env()) eval_tidy(NULL, mask) expect_reference(env_parent(mask), current_env()) env <- env() quo <- new_quosure(NULL, env) eval_tidy(quo, mask) expect_reference(env_parent(mask), env) }) test_that("is_data_pronoun() detects pronouns", { expect_true(!!is_data_pronoun(quote(.data$foo))) expect_true(!!is_data_pronoun(quote(.data[[foo]]))) expect_false(!!is_data_pronoun(quote(.data[foo]))) expect_false(!!is_data_pronoun(quote(data[[foo]]))) }) test_that("data_pronoun_name() extracts name", { expr <- quote(.data[[foo]]) expect_null(data_pronoun_name(expr)) expr <- quote(.data[[toupper("foo")]]) expect_null(data_pronoun_name(expr)) expr <- quote(`$`(.data, toupper("foo"))) expect_null(data_pronoun_name(expr)) expect_identical(data_pronoun_name(quote(.data[["foo"]])), "foo") expect_identical(data_pronoun_name(quote(.data$foo)), "foo") }) test_that(".data pronoun walks the ancestry of environments", { e <- 0 e1 <- env(a = 1, b = 1, c = 1) e2 <- env(a = 2, b = 2, e1) e3 <- env(a = 3, e2) data_mask <- new_data_mask(e3, e1) .data <- as_data_pronoun(data_mask) expect_equal(.data$a, 3) expect_equal(.data$b, 2) expect_equal(.data$c, 1) expect_data_pronoun_error(.data$d, "Column `d` not found in `.data`") expect_data_pronoun_error(.data$e, "Column `e` not found in `.data`") expect_data_pronoun_error(.data$.data, "Column `.data` not found in `.data`") expect_data_pronoun_error(.data$.env, "Column `.env` not found in `.data`") expect_data_pronoun_error(.data$.top_env, "Column `.top_env` not found in `.data`") expect_equal(.data[["a"]], 3) expect_equal(.data[["b"]], 2) expect_equal(.data[["c"]], 1) expect_data_pronoun_error(.data[["d"]], "Column `d` not found in `.data`") expect_data_pronoun_error(.data[["e"]], "Column `e` not found in `.data`") expect_data_pronoun_error(.data[[".data"]], "Column `.data` not found in `.data`") expect_data_pronoun_error(.data[[".env"]], "Column `.env` not found in `.data`") expect_data_pronoun_error(.data[[".top_env"]], "Column `.top_env` not found in `.data`") expect_error(.data["a"]) }) test_that("can inspect the exported pronoun", { expect_output(print(rlang::.data), "") }) test_that("data pronoun doesn't skip functions (#1061, #5608)", { top <- env(c = "c") bottom <- env(top, c = base::c) mask <- new_data_mask(bottom, top) .data <- as_data_pronoun(mask) expect_identical(.data$c, base::c) }) test_that("leaked quosure masks are not mistaken with data masks", { local_lifecycle_silence() e <- eval_tidy(quote(current_env())) expect_no_error(eval_tidy("foo", e)) }) test_that("quosures look for data masks lexically", { out <- eval_tidy(data = mtcars, expr({ fn <- as_function(~ !!quo(cyl)) list( fn(), local(!!quo(disp)) ) })) expect_identical(out, list(mtcars$cyl, mtcars$disp)) }) test_that("can evaluate quosures created in the data mask without infloop", { quo <- eval_tidy(quote(quo(a)), list(a = "foo")) expect_identical(eval_bare(quo, quo_get_env(quo)), "foo") }) test_that("`.env` pronoun is constructed", { pronoun <- eval_tidy(quote(.env), mtcars) expect_s3_class(pronoun, "rlang_ctxt_pronoun") expect_reference(env_parent(pronoun), current_env()) }) test_that("the `.env` pronoun is not an environment", { pronoun <- eval_tidy(quote(.env), mtcars) expect_length(pronoun, 0L) expect_named(pronoun, chr()) }) test_that("subsetting `.env` evaluates", { expect_error(eval_tidy(quote(.env[["cyl"]]), mtcars, env()), "not found") cyl <- "foo" expect_identical(eval_tidy(quote(.env$cyl), mtcars, env()), "foo") expect_identical(eval_tidy(quote(.env[["cyl"]]), mtcars, env()), "foo") }) test_that("mask inherits from `env` after evaluation", { flag <- env(empty_env()) mask <- new_data_mask(env()) eval_tidy(NULL, mask, flag) expect_true(env_inherits(mask, flag)) }) test_that("can't take the names() and length() of the `.data` pronoun", { pronoun <- as_data_pronoun(mtcars) expect_length(pronoun, 0L) expect_named(pronoun, chr()) }) test_that("eval_tidy() does not infloop when the quosure inherits from the mask", { # New r-devel error: cycles in parent chains are not allowed skip_if(getRversion() >= "4.4.0" && grepl("devel", R.version$status)) mask <- as_data_mask(list(foo = 1)) quo <- new_quosure(quote(foo), mask) expect_identical(eval_tidy(quo, mask), 1) top <- env(foo = 1) bottom <- env(top) mask <- new_data_mask(bottom, top) quo <- new_quosure(quote(foo), top) expect_identical(eval_tidy(quo, mask), 1) }) test_that(".data pronoun handles promises (#908)", { e <- env() env_bind_lazy(e, a = c(1)) mask <- new_data_mask(e) mask$.data <- as_data_pronoun(mask) expect_equal(eval_tidy(expr(.data$a * 2), mask), 2) }) test_that("can evaluate tilde in nested masks", { tilde <- eval_tidy(quo(eval_tidy(~1))) expect_identical( eval_bare(tilde, f_env(tilde)), tilde ) }) test_that("eval_tidy() propagates visibility", { expect_visible(eval_tidy(quo(list(invisible(list()))))) expect_invisible(eval_tidy(quo(invisible(list())))) expect_invisible(eval_tidy(quo(identity(!!local(quo(invisible(list()))))))) }) test_that("quosures that inherit from the mask are not rechained", { local_data <- "bar" mask <- new_data_mask(env(mask_data = "foo")) q1 <- eval_tidy(quote(rlang::quo(letters)), mask, base_env()) expr <- quote(paste(letters[[1]], mask_data, local_data)) q2 <- eval_tidy(quote(local(rlang::quo(!!expr))), mask) expect_equal(eval_tidy(q1, mask, base_env()), letters) # This used to hang (tidyverse/dplyr#5927) expect_equal(eval_tidy(q2, mask, base_env()), "a foo bar") }) test_that("eval_tidy() has dimnames method (#1265)", { expect_equal( eval_tidy(quote(dimnames(.data)), mtcars), list(chr(), chr()) ) }) test_that("fake pronoun fails informatively", { expect_snapshot({ "Fake pronouns" f <- function() .data$foo (expect_error(f(), "subset")) f <- function() .data[["foo"]] (expect_error(f(), "subset")) }) }) test_that("`.data` pronoun fails informatively", { f <- function(data = NULL) g(data) g <- function(data) h(.data$foo, data = data) h <- function(x, data) i({{ x }}, data) i <- function(x, data) eval_tidy(enquo(x), data) expect_snapshot({ (expect_error(f())) (expect_error(f(mtcars))) g <- function(data) h(.data[[2]], data) (expect_error(f(mtcars))) g <- function(data) h(.data["foo"], data = data) (expect_error(f(mtcars))) g <- function(data) h(.data[["foo"]] <- 1, data = data) (expect_error(f(mtcars))) g <- function(data) h(.data$foo <- 1, data = data) (expect_error(f(mtcars))) g <- function(data) h(.env["foo"], data = data) (expect_error(f(mtcars))) g <- function(data) h(.env$foo <- 1, data = data) (expect_error(f(mtcars))) g <- function(data) h(.env[["foo"]] <- 1, data = data) (expect_error(f(mtcars))) }) }) # Lifecycle ---------------------------------------------------------- test_that("supplying environment as data is deprecated", { local_options(lifecycle_verbosity = "warning") `_x` <- "foo" expect_deprecated(eval_tidy("foo", current_env()), "deprecated") local_options(lifecycle_verbosity = "quiet") expect_identical(eval_tidy(quo(`_x`), current_env()), "foo") expect_error(eval_tidy(quo(`_y`), current_env()), "not found") }) rlang/tests/testthat/test-deparse.R0000644000176200001440000006433314376112150017113 0ustar liggesuserstest_that("line_push() adds indentation", { out <- line_push("foo", "bar", width = 4, indent = 2) expect_identical(out, c("foo", " bar")) }) test_that("line_push() doesn't make a new line if current is only spaces", { expect_identical(line_push(" ", "foo", width = 2L), " foo") }) test_that("line_push() trims trailing spaces", { expect_identical(line_push("foo ", "bar", width = 1L), c("foo", "bar")) }) test_that("line_push() doesn't trim trailing spaces on sticky inputs", { expect_identical(line_push("tag", " = ", sticky = TRUE, width = 3L, indent = 2L), "tag = ") }) test_that("sticky input sticks", { expect_identical(line_push("foo ", "bar", sticky = TRUE, width = 1L), "foo bar") }) test_that("line_push() respects boundaries", { expect_identical(line_push("foo, ", "bar", boundary = 4L, width = 1L, indent = 2L), c("foo,", " bar")) expect_identical(line_push("foo, ", "bar", sticky = TRUE, boundary = 4L, width = 1L, indent = 2L), c("foo,", " bar")) expect_identical(line_push("foo, bar", "baz", boundary = 4L, width = 1L, indent = 2L), c("foo, bar", " baz")) }) test_that("line_push() handles the nchar(line) == boundary case", { expect_identical(line_push(" tag = ", "bar", sticky = TRUE, boundary = 8L, width = 3L, indent = 2L), " tag = bar") }) test_that("line_push() strips ANSI codes before computing overflow", { local_options(cli.num_colors = 8L) if (!has_ansi()) { skip("test needs cli") } expect_identical(length(line_push("foo", open_blue(), width = 3L)), 2L) expect_identical(length(line_push("foo", open_blue(), width = 3L, has_colour = TRUE)), 1L) }) test_that("can push several lines (useful for default base deparser)", { expect_identical(new_lines()$push(c("foo", "bar"))$get_lines(), "foobar") }) test_that("control flow is deparsed", { expect_identical(fn_call_deparse(expr(function(a, b) 1)), "function(a, b) 1") expect_identical(fn_call_deparse(expr(function(a = 1, b = 2) { 3; 4; 5 })), c("function(a = 1, b = 2) {", " 3", " 4", " 5", "}")) expect_identical(while_deparse(quote(while(1) 2)), "while (1) 2") expect_identical(for_deparse(quote(for(a in 2) 3)), "for (a in 2) 3") expect_identical(repeat_deparse(quote(repeat 1)), "repeat 1") expect_identical(if_deparse(quote(if (1) 2 else { 3 })), c("if (1) 2 else {", " 3", "}")) }) test_that("functions defs increase indent", { ctxt <- new_lines(width = 3L) expect_identical(sexp_deparse(quote(function() 1), ctxt), c("function()", " 1")) ctxt <- new_lines(width = 3L) expect_identical(sexp_deparse(function() 1, ctxt), c("")) }) test_that("blocks are deparsed", { expect_identical(braces_deparse(quote({1; 2; { 3; 4 }})), c("{", " 1", " 2", " {", " 3", " 4", " }", "}")) expect_identical_(sexp_deparse(quote({{ 1 }})), c("{", " {", " 1", " }", "}")) ctxt <- new_lines(width = 3L) expected_lines <- c("{", " 11111", " 22222", " {", " 33333", " 44444", " }", "}") expect_identical(braces_deparse(quote({11111; 22222; { 33333; 44444 }}), ctxt), expected_lines) }) test_that("multiple openers on the same line only trigger one indent", { ctxt <- new_lines(width = 3L) expect_identical(sexp_deparse(quote(function() { 1 }), ctxt), c("function()", " {", " 1", " }")) ctxt <- new_lines(width = 12L) expect_identical(sexp_deparse(quote(function() { 1 }), ctxt), c("function() {", " 1", "}")) }) test_that("multiple openers on the same line are correctly reset", { expect_identical(sexp_deparse(quote({ 1(2()) })), c("{", " 1(2())", "}")) }) test_that("parentheses are deparsed", { expect_identical(parens_deparse(quote((1))), "(1)") expect_identical(parens_deparse(quote(({ 1; 2 }))), c("({", " 1", " 2", "})")) expect_identical(sexp_deparse(quote(({({ 1 })}))), c("({", " ({", " 1", " })", "})")) }) test_that("spaced operators are deparsed", { expect_identical(spaced_op_deparse(quote(1 ? 2)), "1 ? 2") expect_identical(spaced_op_deparse(quote(1 <- 2)), "1 <- 2") expect_identical(spaced_op_deparse(quote(1 <<- 2)), "1 <<- 2") expect_identical(spaced_op_deparse(quote(`=`(1, 2))), "1 = 2") expect_identical(spaced_op_deparse(quote(1 := 2)), "1 := 2") expect_identical(spaced_op_deparse(quote(1 ~ 2)), "1 ~ 2") expect_identical(spaced_op_deparse(quote(1 | 2)), "1 | 2") expect_identical(spaced_op_deparse(quote(1 || 2)), "1 || 2") expect_identical(spaced_op_deparse(quote(1 & 2)), "1 & 2") expect_identical(spaced_op_deparse(quote(1 && 2)), "1 && 2") expect_identical(spaced_op_deparse(quote(1 > 2)), "1 > 2") expect_identical(spaced_op_deparse(quote(1 >= 2)), "1 >= 2") expect_identical(spaced_op_deparse(quote(1 < 2)), "1 < 2") expect_identical(spaced_op_deparse(quote(1 <= 2)), "1 <= 2") expect_identical(spaced_op_deparse(quote(1 == 2)), "1 == 2") expect_identical(spaced_op_deparse(quote(1 != 2)), "1 != 2") expect_identical(spaced_op_deparse(quote(1 + 2)), "1 + 2") expect_identical(spaced_op_deparse(quote(1 - 2)), "1 - 2") expect_identical(spaced_op_deparse(quote(1 * 2)), "1 * 2") expect_identical(spaced_op_deparse(quote(1 / 2)), "1 / 2") expect_identical(spaced_op_deparse(quote(1 %% 2)), "1 %% 2") expect_identical(spaced_op_deparse(quote(1 %>% 2)), "1 %>% 2") expect_identical(sexp_deparse(quote({ 1; 2 } + { 3; 4 })), c("{", " 1", " 2", "} + {", " 3", " 4", "}")) }) test_that("unspaced operators are deparsed", { expect_identical(unspaced_op_deparse(quote(1:2)), "1:2") expect_identical(unspaced_op_deparse(quote(1^2)), "1^2") expect_identical(unspaced_op_deparse(quote(a$b)), "a$b") expect_identical(unspaced_op_deparse(quote(a@b)), "a@b") expect_identical(unspaced_op_deparse(quote(a::b)), "a::b") expect_identical(unspaced_op_deparse(quote(a:::b)), "a:::b") }) test_that("operands are wrapped in parentheses to ensure correct predecence", { expect_identical_(sexp_deparse(expr(1 + !!quote(2 + 3))), "1 + (2 + 3)") expect_identical_(sexp_deparse(expr((!!quote(1^2))^3)), "(1^2)^3") skip_on_cran() skip_if(getRversion() < "4.0.0") expect_identical_(sexp_deparse(quote(function() 1 ? 2)), "(function() 1) ? 2") expect_identical_(sexp_deparse(expr(!!quote(function() 1) ? 2)), "(function() 1) ? 2") }) test_that("unary operators are deparsed", { expect_identical(unary_op_deparse(quote(?1)), "?1") expect_identical(unary_op_deparse(quote(~1)), "~1") expect_identical(unary_op_deparse(quote(!1)), "!1") expect_identical_(unary_op_deparse(quote(!!1)), "!!1") expect_identical_(unary_op_deparse(quote(!!!1)), "!!!1") expect_identical_(unary_op_deparse(quote(`!!`(1))), "!!1") expect_identical_(unary_op_deparse(quote(`!!!`(1))), "!!!1") expect_identical(unary_op_deparse(quote(+1)), "+1") expect_identical(unary_op_deparse(quote(-1)), "-1") }) test_that("brackets are deparsed", { expect_identical(sexp_deparse(quote(1[2])), c("1[2]")) expect_identical(sexp_deparse(quote(1[[2]])), c("1[[2]]")) ctxt <- new_lines(width = 1L) expect_identical(sexp_deparse(quote(1[2]), ctxt), c("1[", " 2]")) ctxt <- new_lines(width = 1L) expect_identical(sexp_deparse(quote(1[[2]]), ctxt), c("1[[", " 2]]")) }) test_that("calls are deparsed", { expect_identical(call_deparse(quote(foo(bar, baz))), "foo(bar, baz)") expect_identical(call_deparse(quote(foo(one = bar, two = baz))), "foo(one = bar, two = baz)") }) test_that("call_deparse() respects boundaries", { ctxt <- new_lines(width = 1L) expect_identical(call_deparse(quote(foo(bar, baz)), ctxt), c("foo(", " bar,", " baz)")) ctxt <- new_lines(width = 7L) expect_identical(call_deparse(quote(foo(bar, baz)), ctxt), c("foo(", " bar,", " baz)")) ctxt <- new_lines(width = 8L) expect_identical(call_deparse(quote(foo(bar, baz)), ctxt), c("foo(bar,", " baz)")) ctxt <- new_lines(width = 1L) expect_identical(call_deparse(quote(foo(one = bar, two = baz)), ctxt), c("foo(", " one = bar,", " two = baz)")) }) test_that("call_deparse() handles multi-line arguments", { ctxt <- new_lines(width = 1L) expect_identical(sexp_deparse(quote(foo(one = 1, two = nested(one = 1, two = 2))), ctxt), c("foo(", " one = 1,", " two = nested(", " one = 1,", " two = 2))")) ctxt <- new_lines(width = 20L) expect_identical(sexp_deparse(quote(foo(one = 1, two = nested(one = 1, two = 2))), ctxt), c("foo(one = 1, two = nested(", " one = 1, two = 2))")) }) test_that("call_deparse() delimits CAR when needed", { fn_call <- quote(function() x + 1) call <- expr((!!fn_call)()) expect_identical(call_deparse(call), "(function() x + 1)()") roundtrip <- parse_expr(expr_deparse(call)) exp <- call2(call("(", fn_call)) # Zap srcref to work around https://github.com/r-lib/waldo/issues/59 expect_equal(zap_srcref(roundtrip), zap_srcref(exp)) call <- expr((!!quote(f + g))(x)) expect_identical(call_deparse(call), "`+`(f, g)(x)") expect_identical(parse_expr(expr_deparse(call)), call) call <- expr((!!quote(+f))(x)) expect_identical(call_deparse(call), "`+`(f)(x)") expect_identical(parse_expr(expr_deparse(call)), call) call <- expr((!!quote(while (TRUE) NULL))(x)) expect_identical(call_deparse(call), "`while`(TRUE, NULL)(x)") expect_identical(parse_expr(expr_deparse(call)), call) call <- expr(foo::bar(x)) expect_identical(call_deparse(call), "foo::bar(x)") expect_identical(parse_expr(expr_deparse(call)), call) }) test_that("literal functions are deparsed", { expect_identical_(sexp_deparse(function(a) 1), "") expect_identical_(sexp_deparse(expr(foo(!!function(a) 1))), "foo()") }) test_that("literal dots are deparsed", { dots <- (function(...) env_get(, "..."))(NULL) expect_identical_(sexp_deparse(expr(foo(!!dots))), "foo(<...>)") }) test_that("environments are deparsed", { expect_identical(sexp_deparse(expr(foo(!! env()))), "foo()") }) test_that("atomic vectors are deparsed", { expect_identical(sexp_deparse(set_names(c(TRUE, FALSE, TRUE), c("", "b", ""))), "") expect_identical(sexp_deparse(set_names(1:3, c("", "b", ""))), "") expect_identical(sexp_deparse(set_names(c(1, 2, 3), c("", "b", ""))), "") expect_identical(sexp_deparse(set_names(as.complex(1:3), c("", "b", ""))), "") expect_identical(sexp_deparse(set_names(as.character(1:3), c("", "b", ""))), "") expect_identical(sexp_deparse(set_names(as.raw(1:3), c("", "b", ""))), "") }) test_that("boundaries are respected when deparsing vectors", { ctxt <- new_lines(width = 1L) vec <- set_names(1:3, c("", "b", "")) expect_identical_(sexp_deparse(expr(foo(!!vec)), ctxt), c("foo(", " )")) ctxt <- new_lines(width = 12L) expect_identical(sexp_deparse(list(c("foo", "bar", "baz")), ctxt), c(">")) }) test_that("scalar atomic vectors are simply printed", { expect_identical(sexp_deparse(TRUE), "TRUE") expect_identical(sexp_deparse(1L), "1L") expect_identical(sexp_deparse(1), "1") expect_identical(sexp_deparse(1i), "0+1i") expect_identical(sexp_deparse("1"), "\"1\"") }) test_that("scalar raw vectors are printed in long form", { expect_identical(sexp_deparse(as.raw(1)), "") }) test_that("literal lists are deparsed", { expect_identical(sexp_deparse(list(TRUE, b = 2L, 3, d = "4", as.raw(5))), ">") }) test_that("long vectors are truncated by default", { expect_identical(sexp_deparse(1:10), "") expect_identical(sexp_deparse(as.list(1:10)), "") }) test_that("long vectors are truncated when max_elements = 0L", { lines <- new_lines(max_elements = 0L) expect_identical(sexp_deparse(1:10, lines), "") lines <- new_lines(max_elements = 0L) expect_identical(sexp_deparse(as.list(1:10), lines), "") }) test_that("long vectors are not truncated when max_elements = NULL", { lines <- new_lines(max_elements = NULL) expect_identical(sexp_deparse(1:10, lines), "") lines <- new_lines(max_elements = NULL) expect_identical(sexp_deparse(as.list(1:10), lines), "") }) test_that("other objects are deparsed with base deparser", { expect_identical_(sexp_deparse(expr(foo((!!base::list)(1, 2)))), "foo(.Primitive(\"list\")(1, 2))") expect_identical_(sexp_deparse(expr(foo((!!base::`if`)(1, 2)))), "foo(.Primitive(\"if\")(1, 2))") }) test_that("S3 objects are deparsed", { skip_on_cran() expr <- expr(list(!!factor(1:3), !!structure(list(), class = c("foo", "bar", "baz")))) expect_identical(sexp_deparse(expr), "list(, )") }) test_that("successive indentations on a single line are only counted once", { ctxt <- new_lines(5L) broken_output <- c(">") expect_identical(sexp_deparse(list(c(foo = "bar", baz = "bam")), ctxt), broken_output) ctxt <- new_lines(12L) unbroken_output <- c(">") expect_identical(sexp_deparse(list(c(foo = "bar", baz = "bam")), ctxt), unbroken_output) }) test_that("successive indentations close off properly", { expect_identical(sexp_deparse(quote(1(2(), 3(4())))), "1(2(), 3(4()))") expect_identical(sexp_deparse(quote(1(2(), 3(4()))), new_lines(width = 1L)), c("1(", " 2(),", " 3(", " 4()))")) expect_identical(sexp_deparse(expr(c((1), function() { 2 }))), c("c((1), function() {", " 2", "})")) }) test_that("empty quosures are deparsed", { expect_identical(strip_style(quo_deparse(quo())), "^") }) test_that("missing values are deparsed", { expect_identical(expr_deparse(NA), "NA") expect_identical(expr_deparse(NaN), "NaN") expect_identical(expr_deparse(NA_integer_), "NA_integer_") expect_identical(expr_deparse(NA_real_), "NA_real_") expect_identical(expr_deparse(NA_complex_), "NA_complex_") expect_identical(expr_deparse(NA_character_), "NA_character_") expect_identical(expr_deparse(c(NaN, 2, NA)), "") expect_identical(expr_deparse(c(foo = NaN)), "") expect_identical(sexp_deparse(c(name = NA)), "") expect_identical(sexp_deparse(c(NA, "NA")), "") expect_identical(sexp_deparse(quote(call(NA))), "call(NA)") expect_identical(sexp_deparse(quote(call(NA_integer_))), "call(NA_integer_)") expect_identical(sexp_deparse(quote(call(NA_real_))), "call(NA_real_)") expect_identical(sexp_deparse(quote(call(NA_complex_))), "call(NA_complex_)") expect_identical(sexp_deparse(quote(call(NA_character_))), "call(NA_character_)") }) test_that("needs_backticks() detects non-syntactic symbols", { expect_true(all(map_lgl(reserved_words, needs_backticks))) expect_false(any(map_lgl(c(".", "a", "Z"), needs_backticks))) expect_true(all(map_lgl(c("1", ".1", "~", "!"), needs_backticks))) expect_true(all(map_lgl(c("_", "_foo", "1foo"), needs_backticks))) expect_true(all(map_lgl(c(".fo!o", "b&ar", "baz <- _baz", "~quux.", "h~unoz_"), needs_backticks))) expect_false(any(map_lgl(c(".foo", "._1", "bar", "baz_baz", "quux.", "hunoz_", "..."), needs_backticks))) expect_false(needs_backticks(expr())) }) test_that("expr_text() and expr_name() interpret unicode tags (#611)", { expect_identical(expr_text(quote(``)), "o") expect_identical(expr_name(quote(`~f`)), "~foo") expect_identical(as_label(quote(`~f`)), "~foo") }) test_that("expr_text() deparses non-syntactic symbols with backticks (#211)", { expect_identical(expr_text(sym("~foo")), "`~foo`") expect_identical(expr_text(sym("~f")), "`~foo`") expect_identical(expr_text(call("~foo")), "`~foo`()") }) test_that("expr_text() deparses empty arguments", { expect_identical(expr_text(expr()), "") expect_identical(quo_text(expr()), "") expect_identical(quo_text(quo()), "") }) test_that("expr_name() deparses empty arguments", { expect_identical(expr_name(expr()), "") expect_identical(quo_name(quo()), "") expect_identical(names(quos_auto_name(quos(, ))), "") expect_identical(as_label(expr()), "") }) test_that("expr_deparse() handles newlines in strings (#484)", { x <- "foo\n" expect_identical(expr_deparse(x), "\"foo\\n\"") expect_output(expr_print(x), "foo\\n", fixed = TRUE) roundtrip <- parse_expr(expr_deparse(x)) expect_identical(x, roundtrip) }) test_that("expr_deparse() handles ANSI escapes in strings", { expect_identical(expr_deparse("\\"), deparse("\\")) expect_identical(expr_deparse("\\a"), deparse("\\a")) expect_identical(expr_deparse("\\b"), deparse("\\b")) expect_identical(expr_deparse("\\f"), deparse("\\f")) expect_identical(expr_deparse("\\n"), deparse("\\n")) expect_identical(expr_deparse("\\r"), deparse("\\r")) expect_identical(expr_deparse("\\t"), deparse("\\t")) expect_identical(expr_deparse("\\v"), deparse("\\v")) expect_identical(expr_deparse("\\0"), deparse("\\0")) }) test_that("as_label() and expr_name() handles .data pronoun", { expect_identical(expr_name(quote(.data[["bar"]])), "bar") expect_identical(quo_name(quo(.data[["bar"]])), "bar") expect_identical(as_label(quote(.data[["bar"]])), "bar") expect_identical(as_label(quo(.data[["bar"]])), "bar") }) test_that("as_label() handles literals", { expect_identical(as_label(1:2), "") expect_identical(as_label(c(1, 2)), "") expect_identical(as_label(letters), "") expect_identical(as_label(base::list), "") expect_identical(as_label(base::mean), "") }) test_that("as_label() handles objects", { skip_on_cran() expect_identical(as_label(mtcars), "") expect_identical(as_label(structure(1, class = "foo")), "") }) test_that("bracket deparsing is a form of argument deparsing", { expect_identical(expr_deparse(quote(foo[bar, , baz()])), "foo[bar, , baz()]") expect_identical(expr_deparse(quote(foo[[bar, , baz()]])), "foo[[bar, , baz()]]") skip_on_cran() expect_identical(expr_deparse(call("[", iris, missing_arg(), drop = FALSE)), "[, drop = FALSE]") }) test_that("non-syntactic symbols are deparsed with backticks", { expect_identical(expr_deparse(quote(`::foo`)), "`::foo`") expect_identical(expr_deparse(quote(x(`_foo`))), "x(`_foo`)") expect_identical(expr_deparse(quote(x[`::foo`])), "x[`::foo`]") }) test_that("symbols with unicode are deparsed consistently (#691)", { skip_if(getRversion() < "3.2") expect_identical(expr_text(sym("\u00e2a")), "\u00e2a") expect_identical(expr_deparse(sym("\u00e2a")), "\u00e2a") expect_identical(expr_text(sym("a\u00e2")), "a\u00e2") expect_identical(expr_deparse(sym("a\u00e2")), "a\u00e2") }) test_that("formal parameters are backticked if needed", { expect_identical(expr_deparse(function(`^`) {}), c("")) }) test_that("empty blocks are deparsed on the same line", { expect_identical(expr_deparse(quote({ })), "{ }") }) test_that("top-level S3 objects are deparsed", { skip_on_cran() f <- structure(function() { }, class = "lambda") expect_identical(expr_deparse(f), "") }) # This test causes a parsing failure in R CMD check >= 3.6 # # test_that("binary operators with 0 or 1 arguments are properly deparsed", { # expect_identical_(expr_deparse(quote(`/`())), "`/`()") # expect_identical(expr_deparse(quote(`/`("foo"))), "`/`(\"foo\")") # expect_identical_(expr_deparse(quote(`::`())), "`::`()") # expect_identical(expr_deparse(quote(`::`("foo"))), "`::`(\"foo\")") # }) test_that("as_label() supports symbols, calls, and literals", { expect_identical(as_label(quote(foo)), "foo") expect_identical(as_label(quote(foo(bar))), "foo(bar)") expect_identical(as_label(1L), "1L") expect_identical(as_label("foo"), "\"foo\"") expect_identical(as_label(function() NULL), "") expect_identical(as_label(expr(function() { a; b })), "function() ...") expect_identical(as_label(1:2), "") expect_identical(as_label(env()), "") }) test_that("as_label() supports special objects", { expect_match(as_label(quote(foo := bar)), ":=") expect_identical(as_label(quo(foo)), "foo") expect_identical(as_label(quo(foo(!!quo(bar)))), "foo(bar)") expect_identical(as_label(~foo), "~foo") expect_identical(as_label(NULL), "NULL") }) test_that("as_name() supports quosured symbols and strings", { expect_identical(as_name(quo(foo)), "foo") expect_identical(as_name(quo("foo")), "foo") expect_error(as_name(quo(foo())), "Can't convert a call to a string") }) test_that("named empty lists are marked as named", { expect_identical(expr_deparse(set_names(list(), chr())), "") }) test_that("infix operators are sticky", { expect_identical(expr_deparse(quote(foo %>% bar), width = 3L), c("foo %>%", " bar")) expect_identical(expr_deparse(quote(foo + bar), width = 3L), c("foo +", " bar")) }) test_that("argument names are backticked if needed (#950)", { expect_identical(expr_deparse(quote(list(`a b` = 1))), "list(`a b` = 1)") }) test_that("`next` and `break` are deparsed", { expect_equal(expr_deparse(quote({ next; (break) })), c("{", " next", " (break)", "}")) expect_equal(expr_deparse(quote(a <- next <- break)), c("a <- next <- break")) }) test_that("double colon is never wrapped (#1072)", { expect_identical( expr_deparse(quote(some.very.long::construct), width = 20), "some.very.long::construct" ) expect_identical( expr_deparse(quote(id_function <- base::identity), width = 15), c( "id_function <-", " base::identity" ) ) expect_identical( expr_deparse(quote(id_fun <- base::identity), width = 20), "id_fun <- base::identity" ) }) test_that("triple colon is never wrapped (#1072)", { expect_identical( expr_deparse(quote(some.very.long:::construct), width = 20), "some.very.long:::construct" ) expect_identical( expr_deparse(quote(id_function <- base:::identity), width = 15), c( "id_function <-", " base:::identity" ) ) expect_identical( expr_deparse(quote(id_fun <- base:::identity), width = 20), "id_fun <- base:::identity" ) }) test_that("backslashes in strings are properly escaped (#1160)", { expect_equal( expr_deparse(sym("a\\b")), "`a\\\\b`" ) # Escaping ensures this roundtrip expect_equal( parse_expr(expr_deparse(sym("a\\b"))), sym("a\\b") ) # Argument names expect_equal( expr_deparse(quote(c("a\\b" = "c\\d"))), "c(`a\\\\b` = \"c\\\\d\")" ) # Vector names expect_equal( expr_deparse(c("a\\b" = "c\\d")), "" ) expect_equal( expr_deparse(list("a\\b" = "c\\d")), "" ) }) test_that("formulas are deparsed (#1169)", { # Evaluated formulas are treated as objects expect_equal( expr_deparse(~foo), "" ) # Unevaluated formulas with a symbol have no space expect_equal( expr_deparse(quote(~foo)), "~foo" ) # Unevaluated formulas with expressions have a space expect_equal( expr_deparse(quote(~+foo)), "~ +foo" ) expect_equal( expr_deparse(quote(~foo())), "~ foo()" ) }) test_that("matrices and arrays are formatted (#383)", { mat <- matrix(1:3) expect_equal(as_label(mat), "") expect_equal(expr_deparse(mat), "") mat2 <- matrix(1:4, 2) expect_equal(as_label(mat2), "") expect_equal(expr_deparse(mat2), "") arr <- array(1:3, c(1, 1, 3)) expect_equal(as_label(arr), "") expect_equal(expr_deparse(arr), "") }) test_that("infix operators are labelled (#956, r-lib/testthat#1432)", { expect_equal( as_label(quote({ 1; 2} + 3)), "... + 3" ) expect_equal( as_label(quote(`+`(1, 2, 3))), "`+`(1, 2, 3)" ) expect_equal( as_label(quote( arg + arg + arg + arg + arg + arg + arg + arg + arg + arg + arg + arg )), "... + arg" ) expect_equal( as_label(quote(X[key1 == "val1" & key2 == "val2"]$key3 & foobarbaz(foobarbaz(foobarbaz(foobarbaz(foobarbaz(foobarbaz(foobarbaz())))))))), "X[key1 == \"val1\" & key2 == \"val2\"]$key3 & ..." ) expect_equal( as_label(quote(X[key1 == "val1"]$key3 & foobarbaz(foobarbaz()))), "X[key1 == \"val1\"]$key3 & foobarbaz(foobarbaz())" ) # This fits in 60 characters so we don't need to truncate it expect_equal( as_label(quote(nchar(chr, type = "bytes", allowNA = TRUE) == 1)), "nchar(chr, type = \"bytes\", allowNA = TRUE) == 1" ) # This fits into 60 characters if we truncate either side, # so we don't need to shorten both of them expect_equal( as_label(quote(very_long_expression[with(subsetting), -1] - another_very_long_expression[with(subsetting), -1] )), "very_long_expression[with(subsetting), -1] - ..." ) lhs_perfect_fit <- sym(paste(rep("a", 56), collapse = "")) lhs_no_fit <- sym(paste(rep("a", 57), collapse = "")) expect_equal( as_label(expr(!!lhs_perfect_fit + 1)), "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + 1" ) expect_equal( as_label(expr(!!lhs_perfect_fit + 10)), "... + 10" ) expect_equal( as_label(expr(1 + !!lhs_perfect_fit)), "1 + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" ) expect_equal( as_label(expr(10 + !!lhs_perfect_fit)), "10 + ..." ) expect_equal( as_label(expr(!!lhs_no_fit + 1)), "... + 1" ) expect_equal( as_label(expr(!!lhs_no_fit + !!lhs_no_fit)), "... + ..." ) }) test_that("binary op without arguments", { expect_equal( expr_deparse(quote(`+`())), "`+`()" ) expect_equal( expr_deparse(quote(`$`())), "`$`()" ) expect_equal( expr_deparse(quote(`~`())), "`~`()" ) }) test_that("call_deparse_highlight() handles long lists of arguments (#1456)", { out <- call_deparse_highlight(quote( foo( aaaaaa = aaaaaa, bbbbbb = bbbbbb, cccccc = cccccc, dddddd = dddddd, eeeeee = eeeeee ) ), NULL) expect_equal( cli::ansi_strip(out), "foo(...)" ) }) test_that("call_deparse_highlight() handles multi-line arguments (#1456)", { out <- call_deparse_highlight(quote( fn(arg = { a b }) ), NULL) expect_equal( cli::ansi_strip(out), "fn(...)" ) }) test_that("embrace operator is deparsed (#1511)", { expect_equal_( expr_deparse(quote({{ a }})), "{{ a }}" ) expect_equal_( expr_deparse(quote(foo({{ a }}))), "foo({{ a }})" ) }) rlang/tests/testthat/test-obj.R0000644000176200001440000000213114376112150016226 0ustar liggesuserstest_that("poke_type() changes object type", { x <- new_node(quote(foo), NULL) out <- withVisible(poke_type(x, "language")) expect_false(out$visible) expect_identical(out$value, x) expect_identical(typeof(x), "language") }) test_that("can access promise properties", { fn <- function(...) { list(node_car(get("..."))) } prom <- fn(foo) expect_identical(promise_expr(prom[[1]]), quote(foo)) expect_identical(promise_env(prom[[1]]), current_env()) }) test_that("can pluck promise and its properties from env", { fn <- function(x) { list( promise_expr("x"), promise_env("x") ) } expect_identical(fn(foo), list(quote(foo), current_env())) }) test_that("can pluck promise value", { fn <- function(x) promise_value("x") expect_identical(fn(foo), sym("R_UnboundValue")) fn <- function(x) { force(x); promise_value("x") } foo <- "foo" expect_identical(fn(foo), "foo") }) test_that("can take the address of the missing arg (#1521)", { fn <- function(x) obj_address(x) expect_true(is_string(fn())) expect_true(is_string(obj_address(missing_arg()))) }) rlang/tests/testthat/helper-cli.R0000644000176200001440000000112314375670676016550 0ustar liggesuserscli_style <- with_options( cli.unicode = FALSE, cli_box_chars() ) rlang_cli_local_support <- function(version, value = TRUE, frame = caller_env()) { cache <- env_get(fn_env(.rlang_cli_has_cli), "cache") local_bindings( .env = cache, .frame = frame, "{version}" := value ) } rlang_cli_local_hyperlinks <- function(frame = caller_env()) { local_options( cli.hyperlink = TRUE, .frame = frame ) rlang_cli_local_support( CLI_SUPPORT_HYPERLINK_PARAMS, TRUE, frame = frame ) } rlang/tests/testthat/test-standalone-purrr.R0000644000176200001440000000437714376112150020772 0ustar liggesuserstest_that("map functions work", { expect_equal(map(1:2, length), list(1, 1)) expect_equal(walk(1:2, length), 1:2) expect_equal(map_lgl(0:1, as.logical), c(FALSE, TRUE)) expect_identical(map_int(1:2, as.integer), 1:2) expect_identical(map_dbl(1:2, as.integer), c(1, 2)) expect_equal(map_chr(1:2, as.character), c("1", "2")) }) test_that("map2 functions work", { expect_equal(map2(1, 1:2, `+`), list(2, 3)) expect_equal(map2_lgl(1, 1:2, `==`), c(TRUE, FALSE)) expect_identical(map2_int(1, 1:2, `+`), c(2L, 3L)) expect_identical(map2_dbl(1, 1:2, `+`), c(2, 3)) expect_equal(map2_chr(1, 1:2, paste0), c("11", "12")) }) test_that("imap works", { expect_equal(imap(c("a", "b"), list), list(list("a", 1L), list("b", 2L))) expect_equal(imap(c(x = "a", y = "b"), list), list(x = list("a", "x"), y = list("b", "y"))) expect_equal(imap(c(x = "a", "b"), list), list(x = list("a", "x"), list("b", ""))) }) test_that("pmap works", { expect_equal(pmap(list(1, 1:2), paste0), list("11", "12")) }) test_that("predicate based functions work", { x <- list(1, 2) expect_equal(keep(x, ~ sum(.x) > 1), list(2)) expect_equal(discard(x, ~ sum(.x) > 1), list(1)) expect_equal(map_if(x, ~ sum(.x) > 1, ~ 10), list(1, 10)) expect_true(every(x, ~ .x > 0)) expect_false(every(x, ~ .x < 0)) expect_true(some(x, ~ .x > 0)) expect_false(some(x, ~ .x < 0)) expect_equal(detect(x, ~ .x > 1), 2) expect_identical(detect_index(x, ~ .x > 0), 1L) }) test_that("reduce/accumulate work", { x <- 1:3 expect_equal(reduce(x, `+`), 6) expect_equal(reduce_right(x, `+`), 6) expect_equal(accumulate(x, `+`), c(1, 3, 6)) expect_equal(accumulate_right(x, `+`), c(6, 5, 3)) }) test_that("transpose() handles empty list", { expect_equal(transpose(list()), list()) }) test_that("transpose() handles incongruent names consistently with purrr (#1346)", { x <- list( needles = list(a = 1, b = 2), condition = c("<", ">") ) expect_equal(transpose(x), list( a = list(needles = 1, condition = "<"), b = list(needles = 2, condition = ">") )) x <- list( needles = list(a = 1, b = 2), condition = c(c = "<", d = ">") ) expect_equal(transpose(x), list( a = list(needles = 1, condition = NULL), b = list(needles = 2, condition = NULL) )) }) rlang/tests/testthat/test-cnd-entrace.R0000644000176200001440000002541014741441060017645 0ustar liggesuserstest_that("cnd_entrace() entraces conditions properly", { with_cnd_entrace <- function(signaller, catcher, arg, classes = "error") { f <- function() g() g <- function() h() h <- function() signaller(arg) handlers <- rep_named(classes, alist(function(cnd) { cnd <- cnd_entrace(cnd) cnd_signal(cnd) })) env_bind_lazy(current_env(), do = catcher(withCallingHandlers(f(), !!!handlers))) do } expect_cnd_trace <- function(signaller, catcher, arg, native = NULL, classes = "error", abort = FALSE) { err <- with_cnd_entrace(signaller, catcher, arg, classes = classes) trace <- err$trace n <- trace_length(err$trace) if (is_null(trace)) { abort("Expected trace, got NULL.") } if (abort) { calls <- trace$call[seq2(n - 3, n)] expect_true(all( is_call(calls[[1]], "f"), is_call(calls[[2]], "g"), is_call(calls[[3]], "h"), is_call(calls[[4]], "signaller") )) } else if (is_null(native)) { calls <- trace$call[seq2(n - 2, n)] expect_true(all( is_call(calls[[1]], "f"), is_call(calls[[2]], "g"), is_call(calls[[3]], "h") )) } else { calls <- trace$call[seq2(n - 4, n)] expect_true(all( is_call(calls[[1]], "f"), is_call(calls[[2]], "g"), is_call(calls[[3]], "h"), is_call(calls[[4]], "signaller"), is_call(calls[[5]], native) )) } } local_options( rlang_trace_top_env = current_env() ) with_cnd_entrace(base::message, catch_message, "") with_cnd_entrace(base::message, catch_error, "", classes = "message") expect_cnd_trace(base::stop, catch_error, "") expect_cnd_trace(base::stop, catch_error, cnd("error")) expect_cnd_trace(function(msg) errorcall(NULL, msg), catch_error, "", "errorcall") expect_cnd_trace(abort, catch_error, "", abort = TRUE) expect_cnd_trace(base::warning, catch_warning, "", classes = "warning") expect_cnd_trace(base::warning, catch_warning, cnd("warning"), classes = "warning") expect_cnd_trace(function(msg) warningcall(NULL, msg), catch_warning, "", "warningcall", classes = "warning") expect_cnd_trace(warn, catch_warning, "", classes = "warning") expect_cnd_trace(base::message, catch_message, "", classes = "message") expect_cnd_trace(base::message, catch_message, cnd("message"), classes = "message") expect_cnd_trace(inform, catch_message, "", classes = "message") expect_cnd_trace(base::signalCondition, catch_cnd, cnd("foo"), classes = "condition") }) test_that("signal context is detected", { get_signal_info <- function(cnd) { nframe <- sys.nframe() - 1 out <- signal_context_info(nframe) info <- list(out[[1]], sys.call(out[[2]])) invokeRestart("out", info) } signal_info <- function(class, signaller, arg) { f <- function() signaller(arg) hnd <- set_names(list(get_signal_info), class) inject( withRestarts( out = identity, withCallingHandlers(!!!hnd, f()) ) ) } expect_equal(signal_info("error", base::stop, ""), list("stop_message", quote(f()))) expect_equal(signal_info("error", base::stop, cnd("error")), list("stop_condition", quote(f()))) expect_equal(signal_info("error", function(msg) errorcall(NULL, msg), ""), list("stop_native", quote(errorcall(NULL, msg)))) # No longer works since we switched to signalCondition approach # expect_equal(signal_info(abort, "")[[1]], "stop_rlang") expect_equal(signal_info("warning", base::warning, ""), list("warning_message", quote(f()))) expect_equal(signal_info("warning", base::warning, cnd("warning")), list("warning_condition", quote(f()))) expect_equal(signal_info("warning", function(msg) warningcall(NULL, msg), ""), list("warning_native", quote(warningcall(NULL, msg)))) expect_equal(signal_info("warning", warn, "")[[1]], "warning_rlang") expect_equal(signal_info("message", base::message, ""), list("message", quote(f()))) expect_equal(signal_info("message", base::message, cnd("message")), list("message", quote(f()))) expect_equal(signal_info("message", inform, "")[[1]], "message_rlang") expect_equal(signal_info("condition", base::signalCondition, cnd("foo")), list("condition", quote(f()))) # Warnings won't be promoted if `condition` is handled. We need to # handle `error` instead. signal_info_error <- function(signaller, arg) { f <- function() signaller(arg) withRestarts( out = identity, withCallingHandlers(error = get_signal_info, f()) ) } expr <- quote(with_options(warn = 2, signal_info_error(base::warning, ""))) expect_equal(eval_top(expr), list("warning_promoted", quote(f()))) }) test_that("cnd_entrace() skips capture context", { capture <- function(expr) { env <- environment() withCallingHandlers( expr, error = function(err) { err <- cnd_entrace(err) return_from(env, err) } ) } foo <- function() bar() bar <- function() stop("foobar") local_options(rlang_trace_top_env = current_env()) err <- capture(foo()) last <- err$trace$call[[4]] expect_match(deparse(last), "bar") }) test_that("rlang and base errors are properly entraced", { skip_if_stale_backtrace() base <- run_script(test_path("fixtures", "error-entrace.R")) rlang <- run_script( test_path("fixtures", "error-entrace.R"), envvars = "rlang_error_kind=rlang" ) expect_snapshot({ cat_line(base) cat_line(rlang) }) }) test_that("entrace() preserves exit status in non-interactive sessions (#1052, rstudio/bookdown#920)", { # Probably because of skip_if(getRversion() < "3.3") # This also tests for empty backtraces out <- Rscript(shQuote(c("--vanilla", "-e", 'options(error = rlang::entrace); stop("An error")'))) expect_false(out$status == 0L) code <- '{ options(error = rlang::entrace) f <- function() g() g <- function() h() h <- function() stop("An error") f() }' out <- Rscript(shQuote(c("--vanilla", "-e", code))) expect_false(out$status == 0L) }) test_that("entrace() doesn't embed backtraces twice", { skip_if_stale_backtrace() code <- "withCallingHandlers(error = rlang::entrace, rlang::abort('foo'))" out <- Rscript(shQuote(c("--vanilla", "-e", code)))$out expect_equal(sum(grepl("^Backtrace", out)), 1) }) test_that("`options(error = entrace)` strips error prefix", { code <- ' { options(error = rlang::entrace) f <- function() g() g <- function() h() h <- function() 1 + "" f() last_error() }' out <- Rscript(shQuote(c("--vanilla", "-e", code))) expect_false(out$status == 0L) }) test_that("can supply handler environment as `bottom`", { local_options( rlang_trace_format_srcrefs = FALSE, rlang_trace_top_env = current_env() ) f <- function() g() g <- function() h() h <- function() identity(1 + "") err <- catch_cnd( withCallingHandlers( error = function(...) rlang::entrace(..., bottom = environment()), f() ), "error" ) expect_snapshot(print(err)) }) test_that("can set `entrace()` as a global handler", { skip_if_not_installed("base", "4.0.0") expect_snapshot_output(run('{ suppressMessages(testthat::local_reproducible_output()) rlang::global_entrace() f <- function() g() g <- function() h() h <- function() 1 + "" f() }')) # Indirected case for developers of rlang expect_snapshot_output(run('{ suppressMessages(testthat::local_reproducible_output()) globalCallingHandlers(error = function(...) rlang::entrace(..., bottom = environment())) f <- function() g() g <- function() h() h <- function() 1 + "" f() }')) expect_snapshot_output(run('{ suppressMessages(testthat::local_reproducible_output()) rlang::global_entrace() f <- function() { warning("foo"); message("FOO"); g() } g <- function() { warning("bar", immediate. = TRUE); h() } h <- function() message("baz") f() writeLines("> rlang::last_warnings()") print(rlang::last_warnings()) writeLines("\\n> rlang::last_warnings(2)") print(rlang::last_warnings(2)) writeLines("\\n> summary(rlang::last_messages())") summary(rlang::last_messages()) writeLines("\\n> summary(rlang::last_messages(1))") summary(rlang::last_messages(1)) }')) }) test_that("can set `entrace()` as a global handler (older R)", { skip_if(getRversion() >= "4.0", ) expect_snapshot_output(run('{ suppressMessages(testthat::local_reproducible_output()) rlang::global_entrace() f <- function() g() g <- function() h() h <- function() 1 + "" f() }')) }) test_that("errors are saved by `entrace()`", { out <- tryCatch( withCallingHandlers( abort("foo"), error = entrace ), error = identity ) # Remove internal data stored by `last_error()` err <- last_error() err$rlang <- NULL out$rlang <- NULL expect_equal(err, out) }) test_that("only the first n warnings are entraced (#1473)", { suppressWarnings({ local_options( "rlang:::cnd_frame" = current_env(), "rlang:::max_entracing" = 3L ) f <- function() g() g <- function() h() h <- function() warning("foo") try_fetch( warning = function(cnd) { entrace(cnd); zap() }, for (i in 1:5) f() ) expect_equal( map_lgl(last_warnings(), function(x) is_null(x$trace)), c(FALSE, FALSE, FALSE, TRUE, TRUE) ) }) }) test_that("warnings are resignalled", { expect_no_warning( cnd <- catch_cnd(withCallingHandlers( warning = entrace, warning("foo") )) ) expect_s3_class(cnd, "rlang_warning") expect_true(!is_null(cnd$trace)) }) test_that("can call `global_entrace()` in knitted documents", { local_options( rlang_backtrace_on_error_report = peek_option("rlang_backtrace_on_error_report"), rlang_backtrace_on_warning_report = peek_option("rlang_backtrace_on_warning_report") ) skip_if_not_installed("knitr") skip_if_not_installed("rmarkdown") skip_if(!rmarkdown::pandoc_available()) entrace_lines <- render_md("test-entrace.Rmd", env = current_env()) expect_snapshot({ cat_line(entrace_lines) }) }) test_that("can't set backtrace-on-warning to reminder", { local_options(rlang_backtrace_on_warning_report = "reminder") expect_snapshot({ peek_backtrace_on_warning_report() }) expect_equal( peek_option("rlang_backtrace_on_warning_report"), "none" ) }) test_that("warnings converted to errors are not resignalled by `global_entrace()`", { skip_if_not_installed("base", "3.6.0") local_options(warn = 2) out <- withCallingHandlers( warning = entrace, tryCatch(error = function(...) "ok", warning("foo")) ) expect_equal(out, "ok") }) rlang/tests/testthat/test-lifecycle.R0000644000176200001440000000705514376147516017443 0ustar liggesuserstest_that("deprecate_soft() warns when called from global env", { reset_warning_verbosity("rlang_test1") reset_warning_verbosity("rlang_test2") reset_warning_verbosity("rlang_test3") reset_warning_verbosity("rlang_test4") # Disable testthat handling withr::local_envvar(c("TESTTHAT_PKG" = "")) depr_soft <- function(id) deprecate_soft("foo", id) depr <- function(id) deprecate_warn("foo", id) # Indirect usage local_env <- env( ns_env("rlang"), depr_soft = depr_soft, depr = depr ) local(envir = local_env, { expect_no_warning(depr_soft("rlang_test1")) expect_warning(depr("rlang_test2"), "foo") # Does not warn again expect_no_warning(depr("rlang_test2")) }) # Direct usage local_bindings( .env = global_env(), depr_soft = depr_soft, depr = depr ) local(envir = global_env(), { expect_warning(depr_soft("rlang_test3"), "foo") expect_warning(depr("rlang_test4"), "foo") # Warns again expect_warning(depr_soft("rlang_test3"), "foo") expect_warning(depr("rlang_test4"), "foo") }) }) test_that("deprecate_soft() warns when called from package being tested", { reset_warning_verbosity("rlang_test") withr::local_envvar(c("TESTTHAT_PKG" = "rlang")) depr <- function() deprecate_soft("warns from package being tested", id = "rlang_test") expect_warning(depr(), "warns from") expect_warning(depr(), "warns from") }) test_that("deprecate_soft() indirect behaviour when warning verbosity is set", { reset_warning_verbosity("rlang_test") local_options(lifecycle_verbosity = "warning") local_env <- env( ns_env("base"), depr = inject(function(id) (!!deprecate_soft)("foo", id)) ) # FIXME: Is this a bug in lifecycle? local(envir = local_env, { expect_no_warning(depr("rlang_test")) expect_no_warning(depr("rlang_test")) }) }) test_that("can disable lifecycle warnings", { local_lifecycle_silence() expect_no_warning(deprecate_soft("foo")) expect_no_warning(deprecate_warn("foo")) }) test_that("can promote lifecycle warnings to errors", { local_lifecycle_errors() expect_defunct(deprecate_soft("foo"), "foo") expect_defunct(deprecate_warn("foo"), "foo") }) test_that("can enable warnings and errors with `with_` helpers", { expect_defunct(with_lifecycle_errors(deprecate_soft("foo")), "foo") expect_no_warning(with_lifecycle_warnings(with_lifecycle_silence(deprecate_warn("foo")))) # FIXME: Is this a bug in lifecycle? expect_no_warning(with_lifecycle_warnings(deprecate_soft("foo"))) }) test_that("soft-deprecation warnings are issued when called from child of global env as well", { fn <- function() deprecate_soft("called from child of global env") expect_warning(eval_bare(call2(fn), env(global_env())), "child of global env") }) test_that("once-per-session note is not displayed on repeated warnings", { reset_warning_verbosity("once-per-session-note") wrn <- catch_cnd( deprecate_warn("foo", "once-per-session-note"), "lifecycle_warning_deprecated" ) expect_true(grepl("once every", conditionMessage(wrn))) }) test_that("lifecycle signallers support character vectors", { local_lifecycle_errors() expect_defunct(deprecate_soft(c("foo", "bar")), "foo\nbar") expect_defunct(deprecate_warn(c("foo", "bar")), "foo\nbar") expect_defunct(deprecate_stop(c("foo", "bar")), "foo\nbar") }) test_that("the topenv of the empty env is not the global env", { expect_silent(deprecate_soft("topenv empty env", user_env = empty_env())) }) test_that("can supply bullets", { expect_snapshot({ deprecate_warn(c("foo", "i" = "bar")) }) }) rlang/tests/testthat/test-call.R0000644000176200001440000006035314401326407016402 0ustar liggesusers# Creation ---------------------------------------------------------------- test_that("character vector must be length 1", { expect_error(call2(letters), "must be a string") }) test_that("args can be specified individually or as list", { out <- call2("f", a = 1, splice(list(b = 2))) expect_equal(out, quote(f(a = 1, b = 2))) }) test_that("creates namespaced calls", { expect_identical(call2("fun", foo = quote(baz), .ns = "bar"), quote(bar::fun(foo = baz))) }) test_that("fails with non-callable objects", { expect_error(call2(1), "non-callable") expect_error(call2(current_env()), "non-callable") }) test_that("succeeds with literal functions", { expect_error(regexp = NA, call2(base::mean, 1:10)) expect_error(regexp = NA, call2(base::list, 1:10)) }) test_that("call2() preserves empty arguments", { expect_identical(call2("[", quote(x), , drop = ), quote(x[, drop = ])) }) test_that("call2() requires a symbol when namespace is supplied", { expect_identical(call2("foo", .ns = "bar"), quote(bar::foo())) expect_error(call2(function() NULL, .ns = "bar"), "must be a string or symbol") expect_error(call2(quote(foo()), .ns = "bar"), "must be a string or symbol") }) # Standardisation --------------------------------------------------------- test_that("call_standardise() supports quosures", { local_lifecycle_silence() fn <- function(foo, bar) "Not this one" quo <- local({ fn <- function(baz, quux) "This one" quo(fn(this, that)) }) exp <- new_quosure(quote(fn(baz = this, quux = that)), quo_get_env(quo)) expect_identical(call_standardise(quo), exp) }) test_that("can standardise primitive functions (#473)", { local_lifecycle_silence() expect_identical(call_standardise(foo ~ bar), foo ~ bar) expect_identical(call_standardise(quote(1 + 2)), quote(1 + 2)) }) test_that("if `call` is supplied to `call_match()`, `fn` must be supplied", { expect_error( call_match(quote(list())), "`fn` must be supplied." ) }) test_that("call_match() infers call and definition", { fn <- function(foo) call_match(defaults = TRUE) expect_equal(fn(), quote(fn(foo = ))) expect_equal(fn(TRUE), quote(fn(foo = TRUE))) # Finds dots dots <- function(...) fn(...) expect_equal(dots(), quote(fn(foo = ))) expect_equal(dots(bar), quote(fn(foo = ..1))) }) test_that("call_match() returns early with primitive functions", { expect_equal( call_match(quote(x[[1]]), `[[`), quote(x[[1]]) ) }) test_that("call_match() matches defaults", { fn <- function(a, b = TRUE, ..., c = FALSE, d) NULL expect_equal( call_match(quote(fn()), fn, defaults = TRUE), quote(fn(a = , b = TRUE, c = FALSE, d = )) ) expect_equal( call_match(quote(fn()), fn, defaults = FALSE), quote(fn()) ) expect_equal( call_match(quote(fn(NULL)), fn, defaults = TRUE), quote(fn(a = NULL, b = TRUE, c = FALSE, d = )) ) expect_equal( call_match(quote(fn(NULL)), fn, defaults = FALSE), quote(fn(a = NULL)) ) expect_equal( call_match(quote(fn(NULL, foo = TRUE)), fn, defaults = TRUE), quote(fn(a = NULL, b = TRUE, foo = TRUE, c = FALSE, d = )) ) expect_equal( call_match(quote(fn(NULL, foo = TRUE)), fn, defaults = FALSE), quote(fn(a = NULL, foo = TRUE)) ) expect_equal( call_match(quote(fn(NULL, foo = TRUE)), fn, dots_expand = FALSE, defaults = TRUE), expr(fn(a = NULL, b = TRUE, ... = !!pairlist(foo = TRUE), c = FALSE, d = )) ) expect_equal( call_match(quote(fn(NULL, foo = TRUE)), fn, dots_expand = FALSE, defaults = FALSE), quote(fn(a = NULL, ... = !!pairlist(foo = TRUE))) ) }) test_that("`call_match(dots_expand = TRUE)` handles `...` positional edge cases", { m <- function(fn) call_match(quote(fn(foo = TRUE)), fn, defaults = FALSE) expect_equal(m(function(...) NULL), quote(fn(foo = TRUE))) expect_equal(m(function(foo, ...) NULL), quote(fn(foo = TRUE))) expect_equal(m(function(..., foo) NULL), quote(fn(foo = TRUE))) expect_equal(m(function(foo, ..., bar) NULL), quote(fn(foo = TRUE))) }) # Modification ------------------------------------------------------------ test_that("can modify formulas inplace", { expect_identical(call_modify(~matrix(bar), quote(foo)), ~matrix(bar, foo)) }) test_that("new args inserted at end", { local_lifecycle_silence() call <- quote(matrix(1:10)) out <- call_modify(call_standardise(call), nrow = 3) expect_equal(out, quote(matrix(data = 1:10, nrow = 3))) }) test_that("new args replace old", { local_lifecycle_silence() call <- quote(matrix(1:10)) out <- call_modify(call_standardise(call), data = 3) expect_equal(out, quote(matrix(data = 3))) }) test_that("can modify calls for primitive functions", { expect_identical(call_modify(~list(), foo = "bar"), ~list(foo = "bar")) }) test_that("can modify calls for functions containing dots", { expect_identical(call_modify(~mean(), na.rm = TRUE), ~mean(na.rm = TRUE)) }) test_that("accepts unnamed arguments", { expect_identical( call_modify(~get(), "foo", envir = "bar", "baz"), ~get("foo", envir = "bar", "baz") ) }) test_that("allows duplicated arguments (#398)", { expect_identical(call_modify(~mean(), na.rm = TRUE, na.rm = FALSE), ~mean(na.rm = FALSE)) expect_identical(call_modify(~mean(), TRUE, FALSE), ~mean(TRUE, FALSE)) expect_identical(call_modify(~mean(), foo = zap(), foo = zap()), ~mean()) }) test_that("zaps remove arguments", { expect_identical(call_modify(quote(foo(bar = )), bar = zap()), quote(foo())) expect_identical_(call_modify(quote(foo(bar = , baz = )), !!!rep_named(c("foo", "bar", "baz"), list(zap()))), quote(foo())) }) test_that("can remove unexisting arguments (#393)", { expect_identical(call_modify(quote(foo()), ... = zap()), quote(foo())) }) test_that("can add a missing argument", { expect_identical(call_modify(quote(foo()), bar = expr()), quote(foo(bar = ))) expect_identical(call_modify(quote(foo()), bar = ), quote(foo(bar = ))) }) test_that("can refer to dots as named argument", { expect_error(call_modify(quote(foo()), ... = NULL), "must be `zap\\(\\)` or empty") expect_error(call_modify(quote(foo()), ... = "foo"), "must be `zap\\(\\)` or empty") expect_identical(call_modify(quote(foo(x, ..., y)), ... = ), quote(foo(x, ..., y))) expect_identical(call_modify(quote(foo(x)), ... = ), quote(foo(x, ...))) expect_identical(call_modify(quote(foo(x, ..., y)), ... = zap()), quote(foo(x, y))) }) test_that("can't supply unnamed zaps", { expect_error(call_modify(quote(foo(bar)), zap()), "can't be unnamed") }) test_that("positions are not changed", { expect_identical(call_modify(quote(fn(1)), x = "foo"), quote(fn(1, x = "foo"))) expect_identical(call_modify(quote(fn(x = 1)), x = "foo"), quote(fn(x = "foo"))) expect_identical(call_modify(quote(fn(1, x = 1)), x = "foo"), quote(fn(1, x = "foo"))) expect_identical(call_modify(quote(fn(x = 1, 1)), x = "foo"), quote(fn(x = "foo", 1))) expect_identical(call_modify(quote(fn(1)), ... = ), quote(fn(1, ...))) expect_identical(call_modify(quote(fn(...)), ... = ), quote(fn(...))) expect_identical(call_modify(quote(fn(1, ...)), ... = ), quote(fn(1, ...))) expect_identical(call_modify(quote(fn(..., 1)), ... = ), quote(fn(..., 1))) expect_identical(call_modify(quote(fn()), 1, x = "foo"), quote(fn(1, x = "foo"))) expect_identical(call_modify(quote(fn()), x = 1, x = "foo"), quote(fn(x = "foo"))) expect_identical(call_modify(quote(fn()), 1, x = 1, x = "foo"), quote(fn(1, x = "foo"))) expect_identical(call_modify(quote(fn()), x = 1, 1, x = "foo"), quote(fn(x = "foo", 1))) expect_identical(call_modify(quote(fn()), 1, ... = ), quote(fn(1, ...))) expect_identical(call_modify(quote(fn()), ... = , ... = ), quote(fn(...))) expect_identical(call_modify(quote(fn()), 1, ... = , ... = ), quote(fn(1, ...))) expect_identical(call_modify(quote(fn()), ... = , 1, ... = ), quote(fn(..., 1))) }) test_that("empty quosures are treated as empty args", { expect_identical(call_modify(quote(fn()), ... = quo()), quote(fn(...))) }) # Utils -------------------------------------------------------------- test_that("NULL is a valid language object", { expect_true(is_expression(NULL)) }) test_that("is_call() pattern-matches", { expect_true(is_call(quote(foo(bar)), "foo")) expect_false(is_call(quote(foo(bar)), "bar")) expect_true(is_call(quote(foo(bar)), quote(foo))) expect_true(is_call(quote(foo(bar)), "foo", n = 1)) expect_false(is_call(quote(foo(bar)), "foo", n = 2)) expect_true(is_call(quote(+3), n = 1)) expect_true(is_call(quote(3 + 3), n = 2)) expect_true(is_call(quote(foo::bar())), quote(foo::bar())) expect_false(is_call(1)) expect_false(is_call(NULL)) }) test_that("quosures are not calls", { skip("Disabled") expect_false(is_call(quo())) }) test_that("is_call() supports symbol `name`", { expect_true(is_call(quote(foo()), quote(foo))) expect_false(is_call(quote(foo()), quote(bar))) }) test_that("is_call() vectorises name", { expect_false(is_call(quote(foo::bar), c("fn", "fn2"))) expect_true(is_call(quote(foo::bar), c("fn", "::"))) expect_true(is_call(quote(foo::bar), quote(`::`))) expect_true(is_call(quote(foo::bar), list(quote(`@`), quote(`::`)))) expect_false(is_call(quote(foo::bar), list(quote(`@`), quote(`:::`)))) }) test_that("call_name() handles namespaced and anonymous calls", { expect_equal(call_name(quote(foo::bar())), "bar") expect_equal(call_name(quote(foo:::bar())), "bar") expect_null(call_name(quote(foo@bar()))) expect_null(call_name(quote(foo$bar()))) expect_null(call_name(quote(foo[[bar]]()))) expect_null(call_name(quote(foo()()))) expect_null(call_name(quote(foo::bar()()))) expect_null(call_name(quote((function() NULL)()))) }) test_that("call_name() handles formulas", { expect_identical(call_name(~foo(baz)), "foo") }) test_that("Inlined functions return NULL name", { call <- quote(fn()) call[[1]] <- function() {} expect_null(call_name(call)) }) test_that("call_args() and call_args_names() work", { expect_equal(call_args(~fn(a, b)), set_names(list(quote(a), quote(b)), c("", ""))) expect_equal(call_args_names(quote(foo(a = , b = ))), c("a", "b")) }) test_that("qualified and namespaced symbols are recognised", { expect_true(is_qualified_call(quote(foo@baz()))) expect_true(is_qualified_call(quote(foo::bar()))) expect_false(is_qualified_call(quote(foo()()))) expect_false(is_namespaced_call(quote(foo@bar()))) expect_true(is_namespaced_call(quote(foo::bar()))) }) test_that("can specify ns in namespaced predicate", { expr <- quote(foo::bar()) expect_false(is_namespaced_call(expr, quote(bar))) expect_true(is_namespaced_call(expr, quote(foo))) expect_true(is_namespaced_call(expr, "foo")) }) test_that("can specify ns in is_call()", { expr <- quote(foo::bar()) expect_true(is_call(expr, ns = NULL)) expect_false(is_call(expr, ns = "")) expect_false(is_call(expr, ns = "baz")) expect_true(is_call(expr, ns = "foo")) expect_true(is_call(expr, name = "bar", ns = "foo")) expect_false(is_call(expr, name = "baz", ns = "foo")) }) test_that("can check multiple namespaces with is_call()", { expect_true(is_call(quote(foo::quux()), ns = c("foo", "bar"))) expect_true(is_call(quote(bar::quux()), ns = c("foo", "bar"))) expect_false(is_call(quote(baz::quux()), ns = c("foo", "bar"))) expect_false(is_call(quote(quux()), ns = c("foo", "bar"))) expect_false(is_call(quote(baz::quux()), ns = c("foo", "bar", ""))) expect_true(is_call(quote(quux()), ns = c("foo", "bar", ""))) }) test_that("can unnamespace calls", { expect_identical(call_unnamespace(quote(bar(baz))), quote(bar(baz))) expect_identical(call_unnamespace(quote(foo::bar(baz))), quote(bar(baz))) expect_identical(call_unnamespace(quote(foo@bar(baz))), quote(foo@bar(baz))) }) test_that("precedence of regular calls", { expect_true(call_has_precedence(quote(1 + 2), quote(foo(1 + 2)))) expect_true(call_has_precedence(quote(foo()), quote(1 + foo()))) }) test_that("precedence of associative ops", { expect_true(call_has_precedence(quote(1 + 2), quote(1 + 2 + 3), "lhs")) expect_false(call_has_precedence(quote(2 + 3), quote(1 + 2 + 3), "rhs")) expect_false(call_has_precedence(quote(1^2), quote(1^2^3), "lhs")) expect_true(call_has_precedence(quote(2^3), quote(1^2^3), "rhs")) }) test_that("call functions type-check their input (#187)", { expect_snapshot({ x <- list(a = 1) err(call_modify(x, NULL)) err(call_name(x)) err(call_args(x)) err(call_args_names(x)) q <- quo(!!x) err(call_modify(q, NULL)) err(call_name(q)) err(call_args(q)) err(call_args_names(q)) }) }) test_that("call_print_type() returns correct enum", { expect_error(call_print_type(""), "must be a defused call") expect_identical(call_print_type(quote(foo())), "prefix") expect_identical(call_print_type(quote(~a)), "prefix") expect_identical(call_print_type(quote(?a)), "prefix") expect_identical_(call_print_type(quote(!b)), "prefix") expect_identical_(call_print_type(quote(`!!`(b))), "prefix") expect_identical_(call_print_type(quote(`!!!`(b))), "prefix") expect_identical(call_print_type(quote(+a)), "prefix") expect_identical(call_print_type(quote(-a)), "prefix") expect_identical(call_print_type(quote(while (a) b)), "special") expect_identical(call_print_type(quote(for (a in b) b)), "special") expect_identical(call_print_type(quote(repeat a)), "special") expect_identical(call_print_type(quote(if (a) b)), "special") expect_identical(call_print_type(quote((a))), "special") expect_identical(call_print_type(quote({ a })), "special") expect_identical(call_print_type(quote(a[b])), "special") expect_identical(call_print_type(quote(a[[b]])), "special") expect_identical(call_print_type(quote(a ? b)), "infix") expect_identical(call_print_type(quote(a ~ b)), "infix") expect_identical(call_print_type(quote(a <- b)), "infix") expect_identical(call_print_type(quote(a <<- b)), "infix") expect_identical(call_print_type(quote(a < b)), "infix") expect_identical(call_print_type(quote(a <= b)), "infix") expect_identical(call_print_type(quote(a > b)), "infix") expect_identical(call_print_type(quote(a >= b)), "infix") expect_identical(call_print_type(quote(`=`(a, b))), "infix") expect_identical(call_print_type(quote(a == b)), "infix") expect_identical(call_print_type(quote(a:b)), "infix") expect_identical(call_print_type(quote(a::b)), "infix") expect_identical(call_print_type(quote(a:::b)), "infix") expect_identical(call_print_type(quote(a := b)), "infix") expect_identical(call_print_type(quote(a | b)), "infix") expect_identical(call_print_type(quote(a || b)), "infix") expect_identical(call_print_type(quote(a & b)), "infix") expect_identical(call_print_type(quote(a && b)), "infix") expect_identical(call_print_type(quote(a + b)), "infix") expect_identical(call_print_type(quote(a - b)), "infix") expect_identical(call_print_type(quote(a * b)), "infix") expect_identical(call_print_type(quote(a / b)), "infix") expect_identical(call_print_type(quote(a ^ b)), "infix") expect_identical(call_print_type(quote(a$b)), "infix") expect_identical(call_print_type(quote(a@b)), "infix") expect_identical(call_print_type(quote(a %% b)), "infix") expect_identical(call_print_type(quote(a %>% b)), "infix") expect_identical(call_print_type(quote(`?`(a, b, c))), "prefix") expect_identical(call_print_type(quote(`~`(a, b, c))), "prefix") expect_identical(call_print_type(quote(`<`(a, b, c))), "prefix") expect_identical(call_print_type(quote(`<=`(a, b, c))), "prefix") expect_identical(call_print_type(quote(`>`(a, b, c))), "prefix") expect_identical(call_print_type(quote(`>=`(a, b, c))), "prefix") expect_identical(call_print_type(quote(`==`(a, b, c))), "prefix") expect_identical(call_print_type(quote(`:`(a, b, c))), "prefix") expect_identical(call_print_type(quote(`:=`(a, b, c))), "prefix") expect_identical(call_print_type(quote(`|`(a, b, c))), "prefix") expect_identical(call_print_type(quote(`||`(a, b, c))), "prefix") expect_identical(call_print_type(quote(`&`(a, b, c))), "prefix") expect_identical(call_print_type(quote(`&&`(a, b, c))), "prefix") expect_identical(call_print_type(quote(`+`(a, b, c))), "prefix") expect_identical(call_print_type(quote(`-`(a, b, c))), "prefix") expect_identical(call_print_type(quote(`*`(a, b, c))), "prefix") expect_identical(call_print_type(quote(`/`(a, b, c))), "prefix") expect_identical(call_print_type(quote(`^`(a, b, c))), "prefix") expect_identical(call_print_type(quote(`%%`(a, b, c))), "prefix") expect_identical(call_print_type(quote(`%>%`(a, b, c))), "prefix") expect_identical(call_print_type(quote(`<-`(a, b, c))), "infix") expect_identical(call_print_type(quote(`<<-`(a, b, c))), "infix") expect_identical(call_print_type(quote(`=`(a, b, c))), "infix") expect_identical(call_print_type(quote(`::`(a, b, c))), "infix") expect_identical(call_print_type(quote(`:::`(a, b, c))), "infix") expect_identical(call_print_type(quote(`$`(a, b, c))), "infix") expect_identical(call_print_type(quote(`@`(a, b, c))), "infix") }) test_that("call_print_fine_type() returns correct enum", { expect_error(call_print_fine_type(""), "must be a defused call") expect_identical(call_print_fine_type(quote(foo())), "call") expect_identical(call_print_fine_type(quote(~a)), "prefix") expect_identical(call_print_fine_type(quote(?a)), "prefix") expect_identical_(call_print_fine_type(quote(!b)), "prefix") expect_identical_(call_print_fine_type(quote(`!!`(b))), "prefix") expect_identical_(call_print_fine_type(quote(`!!!`(b))), "prefix") expect_identical(call_print_fine_type(quote(+a)), "prefix") expect_identical(call_print_fine_type(quote(-a)), "prefix") expect_identical(call_print_fine_type(quote(while (a) b)), "control") expect_identical(call_print_fine_type(quote(for (a in b) b)), "control") expect_identical(call_print_fine_type(quote(repeat a)), "control") expect_identical(call_print_fine_type(quote(if (a) b)), "control") expect_identical(call_print_fine_type(quote((a))), "delim") expect_identical(call_print_fine_type(quote({ a })), "delim") expect_identical(call_print_fine_type(quote(a[b])), "subset") expect_identical(call_print_fine_type(quote(a[[b]])), "subset") expect_identical(call_print_fine_type(quote(a ? b)), "infix") expect_identical(call_print_fine_type(quote(a ~ b)), "infix") expect_identical(call_print_fine_type(quote(a <- b)), "infix") expect_identical(call_print_fine_type(quote(a <<- b)), "infix") expect_identical(call_print_fine_type(quote(a < b)), "infix") expect_identical(call_print_fine_type(quote(a <= b)), "infix") expect_identical(call_print_fine_type(quote(a > b)), "infix") expect_identical(call_print_fine_type(quote(a >= b)), "infix") expect_identical(call_print_fine_type(quote(`=`(a, b))), "infix") expect_identical(call_print_fine_type(quote(a == b)), "infix") expect_identical(call_print_fine_type(quote(a:b)), "infix") expect_identical(call_print_fine_type(quote(a::b)), "infix") expect_identical(call_print_fine_type(quote(a:::b)), "infix") expect_identical(call_print_fine_type(quote(a := b)), "infix") expect_identical(call_print_fine_type(quote(a | b)), "infix") expect_identical(call_print_fine_type(quote(a || b)), "infix") expect_identical(call_print_fine_type(quote(a & b)), "infix") expect_identical(call_print_fine_type(quote(a && b)), "infix") expect_identical(call_print_fine_type(quote(a + b)), "infix") expect_identical(call_print_fine_type(quote(a - b)), "infix") expect_identical(call_print_fine_type(quote(a * b)), "infix") expect_identical(call_print_fine_type(quote(a / b)), "infix") expect_identical(call_print_fine_type(quote(a ^ b)), "infix") expect_identical(call_print_fine_type(quote(a$b)), "infix") expect_identical(call_print_fine_type(quote(a@b)), "infix") expect_identical(call_print_fine_type(quote(a %% b)), "infix") expect_identical(call_print_fine_type(quote(a %>% b)), "infix") expect_identical(call_print_fine_type(quote(`?`(a, b, c))), "call") expect_identical(call_print_fine_type(quote(`~`(a, b, c))), "call") expect_identical(call_print_fine_type(quote(`<`(a, b, c))), "call") expect_identical(call_print_fine_type(quote(`<=`(a, b, c))), "call") expect_identical(call_print_fine_type(quote(`>`(a, b, c))), "call") expect_identical(call_print_fine_type(quote(`>=`(a, b, c))), "call") expect_identical(call_print_fine_type(quote(`==`(a, b, c))), "call") expect_identical(call_print_fine_type(quote(`:`(a, b, c))), "call") expect_identical(call_print_fine_type(quote(`:=`(a, b, c))), "call") expect_identical(call_print_fine_type(quote(`|`(a, b, c))), "call") expect_identical(call_print_fine_type(quote(`||`(a, b, c))), "call") expect_identical(call_print_fine_type(quote(`&`(a, b, c))), "call") expect_identical(call_print_fine_type(quote(`&&`(a, b, c))), "call") expect_identical(call_print_fine_type(quote(`+`(a, b, c))), "call") expect_identical(call_print_fine_type(quote(`-`(a, b, c))), "call") expect_identical(call_print_fine_type(quote(`*`(a, b, c))), "call") expect_identical(call_print_fine_type(quote(`/`(a, b, c))), "call") expect_identical(call_print_fine_type(quote(`^`(a, b, c))), "call") expect_identical(call_print_fine_type(quote(`%%`(a, b, c))), "call") expect_identical(call_print_fine_type(quote(`%>%`(a, b, c))), "call") expect_identical(call_print_fine_type(quote(`<-`(a, b, c))), "infix") expect_identical(call_print_fine_type(quote(`<<-`(a, b, c))), "infix") expect_identical(call_print_fine_type(quote(`=`(a, b, c))), "infix") expect_identical(call_print_fine_type(quote(`::`(a, b, c))), "infix") expect_identical(call_print_fine_type(quote(`:::`(a, b, c))), "infix") expect_identical(call_print_fine_type(quote(`$`(a, b, c))), "infix") expect_identical(call_print_fine_type(quote(`@`(a, b, c))), "infix") }) test_that("call_name() fails with namespaced objects (#670)", { expect_true(TRUE) return("Disabled for the 0.3.1 release") expect_error(call_name(~foo::bar), "`call` must be a quoted call") expect_error(call_name(~foo:::bar), "`call` must be a quoted call") }) test_that("call_ns() retrieves namespaces", { expect_error(call_ns(quote(foo)), "must be a defused call") expect_null(call_ns(quote(foo()))) expect_identical(call_ns(quote(foo::bar())), "foo") expect_identical(call_ns(quote(foo:::bar())), "foo") }) test_that("is_call_infix() detects infix operators", { expect_true(is_call_infix(quote(a %>_>% b))) expect_true(is_call_infix(quote(a + b))) expect_false(is_call_infix(quote(+b))) }) test_that("call_zap_inline() works", { expect_equal( call_zap_inline(quote(foo(1:2))), quote(foo(1:2)) ) expect_equal( call_zap_inline(expr(foo(!!(1:2)))), quote(foo(``)) ) expect_equal( call_zap_inline(quote(function() 1)), quote(function() 1) ) call <- expr(function(x = NULL) foo(!!(1:2))) call[[2]]$x <- 1:2 expect_equal( call_zap_inline(call), quote(function(x = ``) foo(``)) ) call2 <- expr(function(x = NULL) foo(!!(1:2))) call2[[2]]$x <- 1:2 # No mutation expect_equal(call, call2) }) test_that("is_call_simple() works", { expect_false(is_call_simple(quote(foo))) expect_false(is_call_simple(quote(foo()()))) expect_false(is_call_simple(quote(foo::bar))) expect_true(is_call_simple(quote(foo()))) expect_true(is_call_simple(quote(bar::foo()))) expect_true(is_call_simple(quote(foo()), ns = FALSE)) expect_false(is_call_simple(quote(foo()), ns = TRUE)) expect_true(is_call_simple(quote(bar::foo()), ns = TRUE)) expect_false(is_call_simple(quote(bar::foo()), ns = FALSE)) expect_true(is_call_simple(~ bar::foo(), ns = TRUE)) expect_false(is_call_simple(quo())) }) test_that("call_name() and call_ns() detect `::` calls (#670)", { expect_null(call_name(quote(foo::bar))) expect_null(call_name(quote(foo:::bar))) expect_null(call_ns(quote(foo::bar))) expect_null(call_ns(quote(foo:::bar))) }) test_that("is_call_index() works", { expect_true(is_call_index(quote(a$b(...)))) expect_true(is_call_index(quote(a@b$c[[d]](...)))) expect_true(is_call_index(quote(a@b$c[[d]](...)))) expect_true(is_call_index(quote(foo::a$b(...)))) expect_false(is_call_index(quote(a@b$c[[d]]))) expect_false(is_call_index(quote(1 + a@b$c[[d]]))) expect_false(is_call_index(quote((a@b$c[[d]])()))) }) test_that("call_match() supports `...` in arg list when `dots_expand = FALSE`", { f <- function(x, ...) NULL expect_equal( call_match(quote(f(...)), f, dots_expand = FALSE), quote(f()) ) }) rlang/tests/testthat/test-cnd-message.R0000644000176200001440000003573514741441060017663 0ustar liggesuserstest_that("format_error_bullets() formats bullets depending on names", { expect_equal(format_error_bullets(c("foo", "bar")), "* foo\n* bar") expect_equal(format_error_bullets(c(i = "foo", "*" = "baz", x = "bar", v = "bam")), "i foo\n* baz\nx bar\nv bam") expect_equal(format_error_bullets(c(i = "foo", u = "bar")), "i foo\nbar") expect_equal(format_error_bullets(chr()), chr()) }) test_that("default conditionMessage() method for rlang errors calls cnd_message()", { # Fallback out <- conditionMessage(error_cnd("rlang_foobar", message = "embedded")) expect_identical(out, "embedded") # Only `cnd_header()` method out <- with_methods( cnd_header.rlang_foobar = function(cnd, ...) "dispatched!", conditionMessage(error_cnd("rlang_foobar", message = "embedded")) ) expect_identical(out, "dispatched!") # Both `cnd_header()` and `cnd_body()` methods out <- with_methods( cnd_header.rlang_foobar = function(cnd, ...) "dispatched!", cnd_body.rlang_foobar = function(cnd, ...) c("one", "two", "three"), conditionMessage(error_cnd("rlang_foobar", message = "embedded")) ) exp <- paste0("dispatched!\n", paste_line(c("one", "two", "three"))) expect_identical(out, exp) # All three methods defined out <- with_methods( cnd_header.rlang_foobar = function(cnd, ...) "dispatched!", cnd_body.rlang_foobar = function(cnd, ...) c("one", "two", "three"), cnd_footer.rlang_foobar = function(cnd, ...) c("foo", "bar"), conditionMessage(error_cnd("rlang_foobar", message = "embedded")) ) exp <- paste0(exp, "\nfoo\nbar") expect_identical(out, exp) }) test_that("can override header, body, and footer methods with fields", { local_methods(cnd_body.rlang_foobar = function(...) "wrong") expect_error( stop(error_cnd( "rlang_foobar", message = "header", body = "body" )), "header\nbody", class = "rlang_foobar" ) expect_error( stop(error_cnd( "rlang_foobar", header = "header", body = "body", footer = "footer" )), "header\nbody\nfooter", class = "rlang_foobar" ) # Also messages and warnings expect_message( message(message_cnd( "rlang_foobar", header = ~ "header", body = ~ "body", footer = ~ "footer" )), "header\nbody\nfooter", class = "rlang_foobar" ) expect_warning( warning(warning_cnd( "rlang_foobar", header = function(...) "header", body = function(...) "body", footer = function(...) "footer" )), "header\nbody\nfooter", class = "rlang_foobar" ) expect_error( stop(error_cnd("rlang_foobar", message = "header", body = ~ format_error_bullets("body"))), "header\n* body", fixed = TRUE, class = "rlang_foobar" ) }) test_that("`body` must be a character vector or a function", { expect_snapshot({ (expect_error( stop(error_cnd("foo", body = 1:3)), "must be" )) }) }) test_that("can request a line break in error bullets (#1130)", { expect_snapshot({ (expect_error(abort(c( "Main header.", "Header 1", x = "Bullet 1", x = "Bullet 2", "Header 2", x = "Bullet 3", x = "Bullet 4" )))) (expect_error(abort(c( "Main header.", "Header 1", "x" = "Bullet 1", " " = "Break line", "x" = "Bullet 2", "", "Header 2", "x" = "Bullet 3", " " = "Break line", "x" = "Bullet 4" )))) }) }) test_that("fully unnamed bullet vectors are treated as bullets", { expect_equal( format_error_bullets("foo"), "* foo" ) expect_equal( format_error_bullets(c("foo", "bar")), "* foo\n* bar" ) non_bullets <- set_names(c("foo", "bar"), c("", "")) expect_equal( format_error_bullets(non_bullets), "foo\nbar" ) }) test_that("empty names in partially named bullet vectors are treated as line breaks", { expect_equal( format_error_bullets(c("foo", i = "bar", "baz")), "foo\ni bar\nbaz" ) expect_equal( format_error_bullets(c(i = "bar", "baz")), "i bar\nbaz" ) }) test_that("! and > symbols create warning and alert bullets", { expect_equal( format_error_bullets(c("Header", "!" = "Attention", ">" = "Alert")), "Header\n! Attention\n> Alert" ) }) test_that("cli is not used when message is escaped with `I()`", { local_use_cli(inline = TRUE) x <- "foo" expect_equal( conditionMessage(expect_error(abort("{x}"))), "foo" ) return("no longer the case") expect_equal( conditionMessage(expect_error(abort(I("{x}")))), "{x}" ) }) test_that(".rlang_cli_str_restore() deals with attributes", { msg <- structure("foo", attr = TRUE) expect_equal( .rlang_cli_str_restore("bar", msg), structure("bar", attr = TRUE) ) msg_oo <- structure("foo", attr = TRUE, class = "foo") expect_equal( .rlang_cli_str_restore("bar", msg_oo), "bar" ) }) skip_if_not_installed("cli", "2.5.0") skip_if_not_installed("glue") cli::test_that_cli("format_error_bullets() generates bullets", { expect_snapshot({ format_error_bullets(c("Header.", i = "Bullet.")) }) }) cli::test_that_cli(configs = c("plain", "fancy"), "can use cli syntax in `cnd_message()` methods", { local_methods( cnd_header.rlang_foobar = function(cnd, ...) { cli::format_inline("Header: {.emph {cnd$field}}") }, cnd_body.rlang_foobar = function(cnd, ...) { c("i" = cli::format_inline("Bullet: {.emph {cnd$field}}")) }, cnd_footer.rlang_foobar = function(cnd, ...) { c("_" = cli::format_inline("i" = "Footer: {.emph {cnd$field}}")) } ) cnd <- error_cnd( "rlang_foobar", field = "User { {field}.", use_cli_format = TRUE ) expect_snapshot(cnd_message(cnd)) }) test_that("prefix takes call into account", { expect_snapshot({ err <- error_cnd(message = "msg", call = quote(foo(bar = TRUE))) writeLines(cnd_message_format_prefixed(err)) # Inlined objects disable context deparsing err1 <- error_cnd(message = "msg", call = expr(foo(bar = !!(1:3)))) err2 <- error_cnd(message = "msg", call = quote(foo$bar())) err3 <- error_cnd(message = "msg", call = call2(identity)) writeLines(cnd_message_format_prefixed(err1)) writeLines(cnd_message_format_prefixed(err2)) writeLines(cnd_message_format_prefixed(err3)) }) }) test_that("long prefixes cause a line break", { very_very_very_very_very_long_function_name <- function() { abort("My somewhat longish and verbose error message.") } expect_snapshot((expect_error(very_very_very_very_very_long_function_name()))) }) test_that("prefixes include srcrefs", { withr::local_envvar("TESTTHAT" = "") eval_parse("{ f <- function() g() g <- function() abort('Foo.') }") src_file <- g %@% srcref %@% srcfile src_file$filename <- "/foo/bar/baz/myfile.R" expect_snapshot((expect_error(f()))) }) test_that("inform() and warn() use fallback bullets formatting", { msg <- c("foo", i = "bar") expect_snapshot({ local_use_cli(format = FALSE) warn(msg) warn(msg, .frequency = "once", .frequency_id = as.character(runif(1))) }) expect_snapshot({ local_use_cli(format = TRUE) warn(msg) warn(msg, .frequency = "once", .frequency_id = as.character(runif(1))) }) expect_snapshot({ local_use_cli(format = FALSE) inform(msg) inform(msg, .frequency = "once", .frequency_id = as.character(runif(1))) }) expect_snapshot({ local_use_cli(format = TRUE) inform(msg) inform(msg, .frequency = "once", .frequency_id = as.character(runif(1))) }) }) test_that("cnd_message() uses `body` and `footer` fields by default", { expect_equal( cnd_message(cnd("foo", message = "foo", footer = "baz")), "foo\nbaz" ) expect_equal( cnd_message(cnd("foo", message = "foo", body = "bar", footer = "baz")), "foo\nbar\nbaz" ) }) test_that("can supply bullet without header", { expect_snapshot({ (catch_cnd(inform(c(i = "foo")), "message")) (catch_cnd(warn(c(i = "foo")), "warning")) }) }) test_that("parent errors prints with bullets in all cases", { f <- function(use_cli = TRUE) { local_use_cli(format = use_cli) try_fetch( abort(c( "Header", i = "Bullet" )), error = function(cnd) { abort("Wrapper", parent = cnd) } ) } expect_snapshot({ (expect_error(f(TRUE))) (expect_error(f(FALSE))) }) }) test_that("qualified calls are included in error prefix (#1315)", { expect_equal( error_call_as_string(quote(foo::bar())), "foo::bar()" ) }) test_that("special syntax calls handle edge cases", { expect_snapshot({ error_call_as_string(quote(`+`())) error_call_as_string(quote(base::`+`(1, 2))) }) }) test_that("can print message with and without prefix", { expect_snapshot(cran = TRUE, { foo <- error_cnd( "foo", message = "Parent message.", body = c("*" = "Bullet 1.", "*" = "Bullet 2."), use_cli_format = TRUE ) bar <- error_cnd( "bar", message = "Message.", body = c("*" = "Bullet A.", "*" = "Bullet B."), parent = foo, use_cli_format = TRUE ) writeLines(cnd_message(foo, prefix = TRUE)) writeLines(cnd_message(bar, prefix = TRUE)) writeLines(cnd_message(foo, prefix = FALSE)) writeLines(cnd_message(bar, prefix = FALSE)) }) }) test_that("can print message without inheritance", { expect_snapshot(cran = TRUE, { foo <- error_cnd( "foo", message = "Parent message.", body = c("*" = "Bullet 1.", "*" = "Bullet 2."), use_cli_format = TRUE ) bar <- error_cnd( "bar", message = "Message.", body = c("*" = "Bullet A.", "*" = "Bullet B."), parent = foo, use_cli_format = TRUE ) writeLines(cnd_message(foo, inherit = FALSE, prefix = TRUE)) writeLines(cnd_message(bar, inherit = FALSE, prefix = TRUE)) writeLines(cnd_message(foo, inherit = FALSE, prefix = FALSE)) writeLines(cnd_message(bar, inherit = FALSE, prefix = FALSE)) }) }) test_that("ANSI escapes are supported in `conditionMessage()`", { skip_if_not_installed("cli") foo <- error_cnd( "foo", message = "Parent message.", use_cli_format = TRUE ) bar <- error_cnd( "bar", message = "Message.", parent = foo, use_cli_format = TRUE ) testthat::local_reproducible_output( unicode = FALSE, crayon = FALSE ) out_bare <- conditionMessage(bar) testthat::local_reproducible_output( unicode = TRUE, crayon = TRUE ) out_ansi <- conditionMessage(bar) expect_equal(out_bare, cli::ansi_strip(out_ansi)) }) test_that("as.character() and conditionMessage() methods for errors, warnings, and messages", { parent_cnd <- error_cnd( "foo", message = "Parent message.", body = c("*" = "Bullet 1.", "*" = "Bullet 2."), call = call("foo"), use_cli_format = TRUE ) cnd_with <- function(ctor, parent = FALSE) { ctor( "bar", message = "Message.", body = c("*" = "Bullet A.", "*" = "Bullet B."), call = call("bar"), parent = if (parent) parent_cnd, use_cli_format = TRUE ) } expect_snapshot(cran = TRUE, { cat(as.character(cnd_with(error_cnd))) cat(as.character(cnd_with(warning_cnd))) cat(as.character(cnd_with(message_cnd))) cat(as.character(cnd_with(error_cnd, parent = TRUE))) cat(as.character(cnd_with(warning_cnd, parent = TRUE))) cat(as.character(cnd_with(message_cnd, parent = TRUE))) cat(conditionMessage(cnd_with(error_cnd))) cat(conditionMessage(cnd_with(warning_cnd))) cat(conditionMessage(cnd_with(message_cnd))) cat(conditionMessage(cnd_with(error_cnd, parent = TRUE))) cat(conditionMessage(cnd_with(warning_cnd, parent = TRUE))) cat(conditionMessage(cnd_with(message_cnd, parent = TRUE))) }) }) test_that("multiline operator calls are preserved", { err <- function(expr) error_cnd(message = "This is the error message.", call = enexpr(expr)) expect_snapshot_output(err(1 + ("veeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeery_long" + "veeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeery_long"))) expect_snapshot_output(err({ 1; 2 } + { 2; 3 })) expect_snapshot_output(err(x[{ 1; 2 }])) }) test_that("eval_tidy() is not mentioned in calls", { expect_null(format_error_call(quote(eval_tidy(expr)))) }) test_that("header, body, and footer don't partial-match", { expect_equal( cnd_header(error_cnd("foo", headers = 1)), "" ) expect_equal( cnd_body(error_cnd("foo", bodyy = 1)), chr() ) expect_equal( cnd_footer(error_cnd("foo", footers = 1)), chr() ) }) test_that("can disable srcrefs in call formatting", { withr::local_envvar(c("TESTTHAT" = "false")) local_options(rlang_call_format_srcrefs = FALSE) with_srcref("{ f <- function() { g() } g <- function() abort('foo') }") expect_snapshot(err(f())) }) test_that("fallback method supports unknown bullets (#1364)", { local_use_cli(format = FALSE) expect_snapshot({ "With fallback" (expect_error(abort(c("foo", i2 = "bar")))) (expect_error(abort(c(i1 = "foo", i2 = "bar")))) }) local_use_cli(format = TRUE) expect_snapshot({ "With cli" (expect_error(abort(c("foo", i2 = "bar")))) (expect_error(abort(c(i1 = "foo", i2 = "bar")))) }) }) test_that("`cnd_message(prefix = TRUE)` propagates warning style across parent errors (#1387)", { local_options(cli.num_colors = 8) hnd_message <- function(cnd) cnd_message(cnd, prefix = TRUE) msg_warning <- try_fetch( error = function(cnd) warn("foo", parent = cnd), condition = hnd_message, abort("bar") ) msg_error <- try_fetch( error = function(cnd) abort("foo", parent = cnd), condition = hnd_message, abort("bar") ) expect_false(grepl("\033\\[1mCaused by error", msg_warning)) expect_true(grepl("\033\\[1mCaused by error", msg_error)) }) test_that("arguments are highlighted but code spans are not", { local_options("rlang:::trace_test_highlight" = TRUE) err <- error_cnd(header = function(cnd) sprintf( "%s - %s - %s", format_arg("arg1"), format_code("code"), format_arg("arg2") )) expect_snapshot({ with_error_arg_highlight( print(err) ) }) }) test_that("chained errors may have empty messages", { parent <- error_cnd(message = "Tilt.") child <- error_cnd(parent = parent) expect_snapshot({ print(child) cat_line(cnd_message(child, prefix = TRUE)) }) # This is the intended usage child <- error_cnd(call = call("foo"), parent = parent) expect_snapshot({ print(child) cat_line(cnd_message(child, prefix = TRUE)) }) # Irrelevant calls are considered as NULL child <- error_cnd(call = call("eval"), parent = parent) expect_snapshot({ print(child) cat_line(cnd_message(child, prefix = TRUE)) }) }) test_that("`cnd_message()` returns a single string", { local_interactive(TRUE) f <- function(do) g(do) g <- function(do) h(do) h <- function(do) do("foo") cnd <- catch_cnd(f(abort)) cnd <- cnd_set_backtrace_on_error(cnd, "reminder") expect_length(cnd_message(cnd), 1) class(cnd) <- c("rlang_warning", "warning", "condition") expect_length(cnd_message(cnd), 1) }) rlang/tests/testthat/test-trace.Rmd0000644000176200001440000000024314175213516017102 0ustar liggesusers```{r} options(rlang_trace_top_env = environment()) f <- function() g() g <- function() h() h <- function() rlang::abort("foo") ``` ```{r, error = TRUE} f() ``` rlang/tests/testthat/helper-locale.R0000644000176200001440000000632214516466472017240 0ustar liggesusersget_lang_strings <- function() { lang_strings <- c( de = "Gl\u00fcck", cn = "\u5e78\u798f", ru = "\u0441\u0447\u0430\u0441\u0442\u044c\u0435", ko = "\ud589\ubcf5" ) native_lang_strings <- enc2native(lang_strings) same <- (lang_strings == native_lang_strings) list( same = lang_strings[same], different = lang_strings[!same] ) } get_native_lang_string <- function() { lang_strings <- get_lang_strings() if (length(lang_strings$same) == 0) testthat::skip("No native language string available") lang_strings$same[[1L]] } get_alien_lang_string <- function() { lang_strings <- get_lang_strings() if (length(lang_strings$different) == 0) testthat::skip("No alien language string available") lang_strings$different[[1L]] } local_utf8_test <- function(frame = caller_env()) { reporter <- get_reporter() old <- reporter$unicode defer(reporter$unicode <- old, envir = frame) reporter$unicode <- FALSE } with_non_utf8_locale <- function(code) { local_utf8_test() old_locale <- poke_locale_non_utf8() on.exit(poke_ctype_locale(old_locale), add = TRUE) code } poke_locale_non_utf8 <- function() { if (.Platform$OS.type == "windows") { return(NULL) } tryCatch( poke_ctype_locale("en_US.ISO8859-1"), warning = function(...) { testthat::skip("Cannot set latin-1 locale") } ) } with_latin1_locale <- function(expr) { local_utf8_test() old_locale <- suppressMessages(poke_latin1_locale()) on.exit(poke_ctype_locale(old_locale)) expr } poke_utf8_locale <- function() { if (.Platform$OS.type == "windows") { warn("UTF-8 is not supported on Windows") } else { inform("Locale codeset is now UTF-8") poke_ctype_locale("en_US.UTF-8") } } poke_latin1_locale <- function() { if (.Platform$OS.type == "windows") { locale <- "English_United States.1252" } else { locale <- "en_US.ISO8859-1" } inform("Locale codeset is now latin1") poke_ctype_locale(locale) } poke_mbcs_locale <- function() { if (.Platform$OS.type == "windows") { locale <- "English_United States.932" } else { locale <- "ja_JP.SJIS" } inform("Locale codeset is now of non-UTF-8 MBCS type") poke_ctype_locale(locale) } poke_ctype_locale <- function(x) { if (is_null(x)) { return(x) } # Workaround bug in Sys.setlocale() old <- Sys.getlocale("LC_CTYPE") Sys.setlocale("LC_CTYPE", locale = x) invisible(old) } encodings <- function(bytes = FALSE) { string <- "\u00B0C" utf8 <- iconv(string, from = Encoding(string), to = "UTF-8") unknown <- iconv(string, from = Encoding(string), to = "", mark = FALSE) latin1 <- iconv(string, from = Encoding(string), to = "latin1") out <- list(utf8 = utf8, unknown = unknown, latin1 = latin1) if (bytes) { out <- list2(!!! out, bytes = encoding_bytes()) } out } # On some plaftorms iconv doesn't create unicode markers when encoding # fails. Instead it transliterates to "?" characters. skip_if_no_utf8_marker <- function() { skip <- tryCatch( expr = { out <- iconv("幸ç¦", from = "UTF-8", to = "ISO8859-1") !is_string(out) || !grepl("<", out) }, error = function(...) { TRUE } ) if (skip) { skip("No UTF-8 marker with this version of libiconv.") } } rlang/tests/testthat/test-vec-utils.R0000644000176200001440000000067214127057575017414 0ustar liggesuserstest_that("seq2() creates increasing sequences", { expect_identical(seq2(2, 3), 2:3) expect_identical(seq2(3, 2), int()) }) test_that("seq2_along() creates increasing sequences", { expect_identical(seq2_along(3, 1:2), int()) expect_identical(seq2_along(-1, 1:2), -1:2) }) test_that("seq2() fails with non-scalar inputs", { expect_error(seq2(int(), 1), "must be length one") expect_error(seq2(1, int()), "must be length one") }) rlang/tests/testthat/test-formula.R0000644000176200001440000000577214375670676017164 0ustar liggesusers# Creation ---------------------------------------------------------------- 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), "must be a formula") expect_error(f_rhs(`~`()), "Invalid formula") expect_error(f_rhs(`~`(1, 2, 3)), "Invalid formula") expect_error(f_lhs(1), "must be a formula") expect_error(f_lhs(`~`()), "Invalid formula") expect_error(f_lhs(`~`(1, 2, 3)), "Invalid formula") expect_error(f_env(1), "must be 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) }) test_that("setting RHS preserves attributes", { attrs <- list(foo = "bar", class = "formula") f <- inject(structure(~foo, !!!attrs)) f_rhs(f) <- quote(bar) expect_identical(f, inject(structure(~bar, !!!attrs))) }) test_that("setting LHS preserves attributes", { attrs <- list(foo = "bar", class = "formula") f <- inject(structure(~foo, !!!attrs)) f_lhs(f) <- quote(bar) expect_identical(f, inject(structure(bar ~ foo, !!!attrs))) f_lhs(f) <- quote(baz) expect_identical(f, inject(structure(baz ~ foo, !!!attrs))) }) test_that("setting environment preserves attributes", { attrs <- list(foo = "bar", class = "formula") env <- env() f <- inject(structure(~foo, !!!attrs)) f_env(f) <- env expect_identical(f, inject(structure(~foo, !!!attrs, .Environment = env))) }) test_that("unevaluated tilde calls are formulas", { f <- quote(~foo) expect_true(is_formula(f)) expect_false(is_formula(f, scoped = TRUE)) expect_true(is_formula(f, scoped = FALSE)) expect_true(is_formula(f, scoped = NULL)) expect_false(is_bare_formula(f)) expect_false(is_bare_formula(f, scoped = TRUE)) expect_true(is_bare_formula(f, scoped = FALSE)) expect_true(is_bare_formula(f, scoped = NULL)) }) # Utils -------------------------------------------------------------- test_that("quosures are not recognised as bare formulas", { expect_false(is_bare_formula(quo(foo))) }) test_that("lhs is inspected", { expect_true(is_formula(~foo)) expect_false(is_formula(~foo, lhs = TRUE)) expect_true(is_formula(~foo, lhs = FALSE)) expect_true(is_formula(foo ~ bar, lhs = TRUE)) expect_false(is_formula(foo ~ bar, lhs = FALSE)) }) rlang/tests/testthat/test-node.R0000644000176200001440000000620314175213516016412 0ustar liggesuserstest_that("node() creates a pairlist node", { x <- new_node("foo", "bar") expect_type(x, "pairlist") expect_identical(node_car(x), "foo") expect_identical(node_cdr(x), "bar") }) test_that("node getters and pokers work", { A <- as.pairlist(c(a = "a", b = "b")) B <- as.pairlist(c(A = "A", B = "B")) x <- pairlist(foo = A, bar = B, baz = "baz") expect_identical(node_car(x), A) expect_identical(node_cdr(x), pairlist(bar = B, baz = "baz")) expect_identical(node_caar(x), "a") expect_identical(node_cadr(x), B) expect_identical(node_cdar(x), pairlist(b = "b")) expect_identical(node_cddr(x), pairlist(baz = "baz")) expect_identical(node_tag(x), sym("foo")) node_poke_car(x, B) expect_identical(node_car(x), B) node_poke_cdr(x, pairlist(foo = A)) expect_identical(node_cdr(x), pairlist(foo = A)) node_poke_cdar(x, "cdar") expect_identical(node_cdar(x), "cdar") node_poke_caar(x, "caar") expect_identical(node_caar(x), "caar") node_poke_cadr(x, "cadr") expect_identical(node_cadr(x), "cadr") node_poke_cddr(x, "cddr") expect_identical(node_cddr(x), "cddr") node_poke_tag(x, sym("tag")) expect_identical(node_tag(x), sym("tag")) }) test_that("node_tree_clone() clones all nodes", { x <- pairlist(1, pairlist(2)) clone <- node_tree_clone(x) # Outer vector expect_false(obj_address(x) == obj_address(clone)) # Outer node list expect_true(obj_address(node_car(x)) == obj_address(node_car(clone))) cdr <- node_cdr(x) clone_cdr <- node_cdr(clone) expect_false(obj_address(cdr) == obj_address(clone_cdr)) # Inner node list cadr <- node_car(cdr) clone_cadr <- node_car(clone_cdr) expect_false(obj_address(cadr) == obj_address(clone_cadr)) # Inner vector caadr <- node_car(cadr) clone_caadr <- node_car(clone_cadr) expect_true(obj_address(caadr) == obj_address(clone_caadr)) }) test_that("pairlist predicates detect pairlists", { node <- new_node(NULL) call <- quote(foo(bar)) expect_true(is_pairlist(node)) expect_true(is_node(node)) expect_true(is_node(call)) expect_true(is_node_list(node)) expect_true(is_node_list(NULL)) }) test_that("pairlist2() converts to pairlist", { expect_identical_(pairlist2(1, !!!c(2, 3), 4), pairlist(1, 2, 3, 4)) expect_identical_(pairlist2(1, !!!mtcars[1:2], 4), pairlist(1, mpg = mtcars$mpg, cyl = mtcars$cyl, 4)) local_bindings(.env = global_env(), `[[.rlang_foobar` = function(x, i) "foo" ) foobar <- structure(NA, class = "rlang_foobar") expect_identical_(pairlist2(1, !!!foobar, 4), pairlist(1, "foo", 4)) }) test_that("pairlist2() duplicates spliced pairlists", { x <- pairlist("foo", "bar") pairlist2(1, !!!x, 4) expect_identical(x, pairlist("foo", "bar")) }) test_that("pairlist2() preserves empty arguments", { expect_identical(pairlist2(1, x = , , 4), pairlist(1, x = missing_arg(), missing_arg(), 4)) }) test_that("pairlist2() supports splice boxes", { expect_identical(pairlist2(1, splice(list("foo", "bar")), 4), pairlist(1, "foo", "bar", 4)) }) test_that("pairlist2() supports empty spliced vectors", { expect_null_(pairlist2(!!!NULL)) expect_null_(pairlist2(!!!lgl())) expect_null_(pairlist2(!!!list())) }) rlang/tests/testthat/test-standalone-rlang.R0000644000176200001440000000163014376112150020710 0ustar liggesuserstest_that("is_installed() works", { for (is_installed in rlang_compats("is_installed")) { expect_true(is_installed("base")) expect_false(is_installed("_foo")) } }) test_that("is_interactive() works", { for (is_interactive in rlang_compats("is_interactive")) { with_options( rlang_interactive = TRUE, expect_true(is_interactive()) ) with_options( rlang_interactive = FALSE, expect_false(is_interactive()) ) } }) test_that("signallers work", { for (inform in rlang_compats("inform")) { expect_snapshot(inform(c("Header.", i = "Bullet."))) } for (warn in rlang_compats("warn")) { expect_snapshot(warn(c("Header.", i = "Bullet."))) } for (abort in rlang_compats("abort")) { expect_snapshot(abort(c("Header.", i = "Bullet.")), error = TRUE) } }) test_that("unknown functions throw", { expect_snapshot(.rlang_compat("foo"), error = TRUE) }) rlang/tests/testthat/test-env-special.R0000644000176200001440000000517614175213516017703 0ustar liggesuserstest_that("search_envs() includes the global and base env", { envs <- search_envs() expect_identical(envs[[1]], global_env()) expect_identical(envs[[length(envs)]], base_env()) }) test_that("search_envs() returns named environments", { expect_identical(names(search_envs()), c("global", search()[-1])) }) test_that("search_envs() returns an rlang_envs object", { expect_s3_class(search_envs(), "rlang_envs") }) test_that("is_namespace() recognises namespaces", { expect_false(is_namespace(env())) expect_true(is_namespace(get_env(is_namespace))) }) test_that("env_name() returns proper environment name", { expect_identical(env_name(global_env()), "global") expect_identical(env_name(empty_env()), "empty") expect_identical(env_name(base_env()), "package:base") expect_identical(env_name(pkg_env("rlang")), "package:rlang") expect_identical(env_name(ns_imports_env("rlang")), "imports:rlang") expect_identical(env_name(ns_env("rlang")), "namespace:rlang") env <- structure(env(), name = "foobar") expect_identical(env_label(env), "foobar") }) test_that("env_label() returns memory address for anonymous envs", { env <- env() expect_identical(env_label(env), obj_address(env)) }) test_that("is_attached() detects environments on the search path", { expect_false(is_attached("utils")) expect_true(is_attached("package:utils")) expect_true(is_attached(base_env())) expect_true(is_attached(global_env())) expect_false(is_attached(ns_env("base"))) }) test_that("ns_env() and ns_env_name() support primitive functions", { expect_true(is_reference(ns_env(base::list), ns_env("base"))) expect_true(is_reference(ns_env(base::`{`), ns_env("base"))) expect_identical(ns_env_name(base::list), "base") expect_identical(ns_env_name(base::`{`), "base") }) test_that("ns_env() and ns_env_name() support closures", { fn <- function() NULL environment(fn) <- env(ns_env("rlang")) expect_true(is_reference(ns_env(fn), ns_env("rlang"))) expect_identical(ns_env_name(fn), "rlang") }) test_that("ns_env_name() accepts environments", { expect_identical(ns_env_name(ns_env("base")), "base") }) test_that("ns_env() and ns_env_name() take the topenv()", { ns <- ns_env("rlang") local <- env(ns) expect_true(is_reference(ns_env(local), ns)) expect_identical(ns_env_name(local), "rlang") }) test_that("ns_env() and variants have default argument", { fn <- function() list(ns_env(), ns_imports_env(), ns_env_name()) environment(fn) <- ns_env("rlang") out <- fn() expect_true(is_reference(out[[1]], ns_env("rlang"))) expect_true(is_reference(out[[2]], ns_imports_env("rlang"))) expect_identical(out[[3]], "rlang") }) rlang/tests/testthat/test-env.R0000644000176200001440000004152614741441060016260 0ustar liggesuserstest_that("env_parent() returns enclosure frame by default", { enclos_env <- child_env(pkg_env("rlang")) fn <- with_env(enclos_env, function() env_parent()) expect_identical(fn(), enclos_env) }) test_that("child_env() has correct parent", { env <- child_env(empty_env()) expect_false(env_has(env, "list", inherit = TRUE)) fn <- function() list(new = child_env(current_env()), env = environment()) out <- fn() expect_identical(env_parent(out$new), out$env) expect_identical(env_parent(child_env(NULL)), empty_env()) expect_identical(env_parent(child_env("base")), base_env()) }) test_that("env_parent() reports correct parent", { env <- child_env(child_env(NULL, obj = "b"), obj = "a") expect_identical(env_parent(env, 1)$obj, "b") expect_identical(env_parent(env, 2), empty_env()) expect_error(env_parent(env, 3), "empty environment has no parent") }) test_that("env_tail() climbs env chain", { expect_identical(env_tail(global_env()), base_env()) }) test_that("env_tail() stops at the global env", { tail <- env(global_env()) env <- env(tail) expect_identical(env_tail(env), tail) }) test_that("with_env() evaluates within correct environment", { fn <- function() { g(current_env()) "normal return" } g <- function(env) { with_env(env, return("early return")) } expect_equal(fn(), "early return") }) test_that("locally() evaluates within correct environment", { env <- child_env("rlang") local_env <- with_env(env, locally(current_env())) expect_identical(env_parent(local_env), env) }) test_that("as_environment() dispatches correctly", { expect_identical(as_environment("base"), base_env()) expect_false(env_has(as_environment(set_names(letters)), "map")) expect_identical(as_environment(NULL), empty_env()) expect_true(all(env_has(as_environment(mtcars), names(mtcars)))) expect_identical(env_parent(as_environment(mtcars)), empty_env()) expect_identical(env_parent(as_environment(mtcars, base_env())), base_env()) }) test_that("env_inherits() finds ancestor", { env <- env(env(current_env())) expect_true(env_inherits(env, current_env())) expect_false(env_inherits(env, ns_env("utils"))) }) test_that("env_inherits() detects empty environment", { expect_false(env_inherits(empty_env(), empty_env())) expect_true(env_inherits(env(empty_env()), empty_env())) }) test_that("env() creates child of current environment", { env <- env(a = 1, b = "foo") expect_identical(env_parent(env), current_env()) expect_identical(env$b, "foo") }) test_that("set_env() sets current env by default", { quo <- set_env(locally(~foo)) expect_identical(f_env(quo), current_env()) }) test_that("finds correct env type", { expect_identical(env_type(global_env()), "global") expect_identical(env_type(empty_env()), "empty") expect_identical(env_type(base_env()), "base") }) test_that("current_env() fails if no default", { expect_error(get_env(list()), "Can't extract an environment from") }) test_that("current_env() picks up default", { dft <- env() expect_identical(get_env(list(), dft), dft) expect_identical(get_env("a", dft), dft) }) test_that("with_env() handles data", { expect_identical(with_env(mtcars, cyl), mtcars$cyl) foo <- "foo" expect_identical(with_env(mtcars, foo), "foo") }) test_that("with_env() evaluates in env", { env <- env() expect_identical(with_env(env, current_env()), env) }) test_that("env_depth() counts parents", { expect_identical(env_depth(child_env(child_env(NULL))), 2L) expect_identical(env_depth(empty_env()), 0L) }) test_that("env_parents() returns all parents", { expect_identical(env_parents(empty_env()), new_environments(list())) env1 <- env(empty_env()) env2 <- env(env1) expect_identical(env_parents(env2), new_environments(list(env1, empty_env()))) }) test_that("env() doesn't partial match on env_bind()'s .env", { expect_true(all(env_has(env(.data = 1, . = 2), c(".data", ".")))) }) test_that("new_environment() creates a child of the empty env", { env <- new_environment(list(a = 1, b = 2)) expect_true(all(env_has(env, c("a", "b")))) expect_identical(env_parent(env), empty_env()) }) test_that("new_environment() accepts empty vectors", { expect_identical(length(new_environment()), 0L) expect_identical(length(new_environment(dbl())), 0L) }) test_that("env_tail() detects sentinel", { sentinel <- current_env() env <- env() descendant <- child_env(child_env(child_env(env))) expect_identical(env_tail(descendant, sentinel), env) }) test_that("as_environment() treats named strings as vectors", { env <- as_environment(c(foo = "bar")) expect_true(is_environment(env)) expect_true(env_has(env, "foo")) }) test_that("as_environment() converts character vectors", { env <- as_environment(set_names(letters)) expect_true(is_environment(env)) expect_true(all(env_has(env, letters))) }) test_that("child_env() requires named elements", { expect_error(child_env(env(), 1), "some elements are not named") }) test_that("env() requires named elements", { expect_error(env(env(), 1), "Expected 0 or 1 unnamed arguments") }) test_that("env() doesn't require uniquely named elements", { env <- env(a = 1, a = 2) expect_identical(env$a, 2) }) test_that("env_clone() clones an environment", { data <- list(a = 1L, b = 2L) env <- env(!!! data) clone <- env_clone(env) expect_false(is_reference(env, clone)) expect_reference(env_parent(env), env_parent(clone)) expect_identical(env_get_list(clone, c("a", "b")), data) }) test_that("friendly_env_type() returns a friendly env name", { expect_identical(friendly_env_type("global"), "the global environment") expect_identical(friendly_env_type("empty"), "the empty environment") expect_identical(friendly_env_type("base"), "the base environment") expect_identical(friendly_env_type("frame"), "a frame environment") expect_identical(friendly_env_type("local"), "a local environment") }) test_that("new_environment() accepts optional parent", { env <- new_environment(parent = base_env()) expect_reference(env_parent(env), base_env()) }) test_that("env() accepts one unnamed argument to specify parent", { env <- env(base_env()) expect_reference(env_parent(env), base_env()) env <- env(global_env(), a = 1) expect_reference(env_parent(env), global_env()) expect_identical(env_names(env), "a") }) test_that("env_parents() stops at the global env by default", { env <- env(env(global_env())) expect_identical(env_parents(env), new_environments(list(env_parent(env), global_env()))) rlang_parents <- env_parents(ns_env("rlang")) expected <- list(`namespace:base` = ns_env("base"), global = global_env()) expect_identical(unclass(rlang_parents[2:3]), expected) }) test_that("env_parents() always stops at the empty env", { expect_identical(env_parents(empty_env()), new_environments(list())) expect_identical(env_parents(pkg_env("base")), new_environments(list(empty_env()))) }) test_that("env_parents() stops at the sentinel if supplied", { expect_reference(last(env_parents(pkg_env("utils"))), empty_env()) expect_reference(last(env_parents(pkg_env("utils"), base_env())), base_env()) }) test_that("env_parents() returns a named list", { env <- env(structure(env(base_env()), name = "foobar")) expect_identical(names(env_parents(env)), c("foobar", "package:base", "empty")) }) test_that("can lock environments", { env <- env() expect_false(env_is_locked(env)) expect_false(env_lock(env)) expect_true(env_is_locked(env)) expect_true(env_lock(env)) }) test_that("can unlock environments", { env <- env() env_lock(env) expect_true(env_unlock(env)) expect_false(env_is_locked(env)) expect_no_error(env_bind(env, a = 1)) }) test_that("env_print() has flexible input", { # because it's primarily used interactively f <- function() 1 expect_output(env_print(f), "environment: ") }) test_that("active and promise bindings are pretty-printed", { env <- env() env_bind_lazy(env, a = "foo") env_bind_active(env, b = ~"foo") expect_output(env_print(env), "a: .*b: ") }) test_that("locked environments are pretty-printed", { env <- env() expect_output(env_print(env), sprintf("\n", obj_address(env))) env_lock(env) expect_output(env_print(env), sprintf(" \\[L\\]\n", obj_address(env))) }) test_that("locked bindings are pretty-printed", { env <- env(a = 1, b = 2) env_binding_lock(env, "a") expect_output(env_print(env), "a: \\[L\\].*b: ") }) test_that("large environments are truncated", { n_truncated <- length(env_names(base_env())) - 20L expected <- sprintf("\\.\\.\\. with %s more bindings", n_truncated) expect_output(env_print(base_env()), expected) }) test_that("special names are backticked", { env <- env(`<-` = 1, `:` = 2) expect_output(env_print(env), "`:`:") expect_output(env_print(env), "`<-`:") }) test_that("empty environment is pretty printed", { expect_output(env_print(empty_env()), "\nParent: NULL$") }) test_that("envs printer: padding is added to right-align indices", { x <- c(rep(list(empty_env()), 9L), global_env()) x <- new_environments(x) expect_output(print(x), "^ \\[\\[1\\]\\]") expect_output(print(x), "\n\\[\\[10\\]\\]") }) test_that("envs printer: name tag is added to named elements", { x <- list(empty_env(), env(), empty_env()) x <- new_environments(x) expect_output(print(x), "[[1]] $ <", fixed = TRUE) expect_output(print(x), "\n[[2]] <", fixed = TRUE) expect_output(print(x), "\n[[3]] $ <", fixed = TRUE) }) test_that("envs printer: no name tag if no named elements", { x <- list(env(), env()) x <- new_environments(x) expect_output(print(x), "[[1]] <", fixed = TRUE) expect_output(print(x), "\n[[2]] <", fixed = TRUE) names(x) <- c("", NA) expect_output(print(x), "[[1]] <", fixed = TRUE) expect_output(print(x), "\n[[2]] <", fixed = TRUE) }) test_that("envs printer: long lists are truncated", { x <- rep(list(empty_env()), 20L) x <- new_environments(x) expect_output(print(x), "empty>$") x <- rep(list(empty_env()), 25L) x <- new_environments(x) expect_output(print(x), "empty>\n... and 5 more environments$") }) test_that("can print environment containing missing argument", { env <- env(x = missing_arg(), y = quote(foo)) expect_output(env_print(env), "x: ") expect_output(env_print(env), "y: ") }) test_that("parent environment is printed with full header", { env <- env(global_env()) expect_output(env_print(env), "Parent: ") }) test_that("environment is printed with class if any", { env <- env() out <- capture.output(env_print(env)) expect_false(any(grepl("class", out))) env <- structure(env(), class = "foo") expect_output(env_print(env), "Class: foo") env <- structure(env(), class = c("foo", "bar")) expect_output(env_print(env), "Class: foo, bar") }) test_that("env_clone() handles active bindings", { # FIXME: Seems cloning evaluates the binding value <- NULL e <- env() env_bind_active(e, foo = function() value) out <- env_clone(e) value <- "foo" expect_equal(out$foo, "foo") value <- "bar" expect_equal(out$foo, "bar") }) test_that("env_clone() doesn't force promises", { skip_if_not_installed("base", "4.0.0") e <- env() env_bind_lazy(e, foo = value) value <- "foo" out <- env_clone(e) value <- "bar" expect_equal(out$foo, "bar") }) test_that("env_poke_parent() pokes parent", { e <- env() env_poke_parent(e, empty_env()) expect_reference(env_parent(e), empty_env()) }) test_that("env_poke_parent() fails with namespaces, package envs, and locked envs", { expect_error(env_poke_parent(ns_env("rlang"), env()), "namespace environment") expect_error(env_poke_parent(pkg_env("rlang"), env()), "package environment") expect_error(env_poke_parent(global_env(), env()), "global") expect_error(env_poke_parent(empty_env(), env()), "empty") expect_error(env_poke_parent(base_env(), env())) env <- env() env_lock(env) expect_error(env_poke_parent(env, env()), "locked environment") }) test_that("env_length() gives env length", { expect_error(env_length(1), "must be an environment") expect_identical(env_length(env()), 0L) expect_identical(env_length(env(a = "a")), 1L) }) test_that("env_clone() duplicates frame", { skip_silently("Would fail on non-GNU R") e <- new.env(hash = FALSE) e$x <- 1 c <- env_clone(e) expect_false(is_reference(env_frame(e), env_frame(c))) }) test_that("env_clone() duplicates hash table", { skip_silently("Would fail on non-GNU R") e <- env(x = 1) c <- env_clone(e) e_hash <- env_hash_table(e) c_hash <- env_hash_table(c) expect_false(is_reference(e_hash, c_hash)) i <- detect_index(e_hash, is_null, .p = is_false) expect_false(is_reference(e_hash[[i]], c_hash[[i]])) }) test_that("env_clone() increases refcounts (#621)", { e <- env(x = 1:2) env_bind_lazy(e, foo = 1) env_bind_active(e, bar = function() 1) c <- env_clone(e) c$x[1] <- NA expect_identical(e$x, c(1L, 2L)) expect_identical(c$x, c(NA, 2L)) }) test_that("env_coalesce() merges environments", { x <- env(x = 1, y = 2) y <- env(x = "a", z = "c") env_coalesce(x, y) expect_equal(x, env(x = 1, y = 2, z = "c")) expect_equal(y, env(x = "a", z = "c")) }) test_that("env_coalesce() handles fancy bindings", { old_r <- getRversion() < "4.0.0" x <- env(x = 1, y = 2) y <- env(x = "a", z = "c") env_bind_lazy(y, lazy = { signal("", "lazy"); "lazy-value" }) env_bind_active(y, active = function() { signal("", "active"); "active-value" }) env_coalesce(x, y) if (!old_r) { expect_condition( expect_equal(x$lazy, "lazy-value"), class = "lazy" ) } expect_condition( expect_equal(x$active, "active-value"), class = "active" ) expect_equal(x$x, 1) expect_equal(x$y, 2) expect_equal(x$z, "c") expect_equal(x$active, "active-value") expect_equal(x$lazy, "lazy-value") # `y$lazy` was forced at the same time as `x$lazy` expect_false(env_binding_are_lazy(y, "lazy")) expect_condition( expect_equal(y$active, "active-value"), class = "active" ) expect_equal(y$x, "a") expect_equal(y$z, "c") expect_equal(y$active, "active-value") expect_equal(y$lazy, "lazy-value") }) test_that("can subset `rlang_envs` list", { envs <- new_environments(list(env(), env(), env())) out <- envs[1:2] expect_length(out, 2) expect_s3_class(out, "rlang_envs") out <- envs[3] expect_length(out, 1) expect_s3_class(out, "rlang_envs") }) test_that("can concatenate `rlang_envs` lists", { envs1 <- new_environments(list(env())) envs2 <- new_environments(list(env(), env())) out <- c(envs1, envs2) expect_length(out, 3) expect_s3_class(out, "rlang_envs") }) test_that("env_name() requires an environment", { expect_error(env_name("base"), "must be an environment") }) test_that("env_unbind() removes objects", { env <- env(a = 1L) env_unbind(env, "a") expect_false(env_has(env, "a")) env <- env(a = 1L) child <- child_env(env) env_unbind(child, "a") expect_true(env_has(child, "a", inherit = TRUE)) env_unbind(child, "a", inherit = TRUE) expect_false(env_has(env, "a")) }) test_that("get_env() returns the base namespace for primitive functions (r-lib/downlit#32)", { expect_identical(get_env(is.null), ns_env("base")) }) test_that("can browse environments", { env <- env() expect_false(env_is_browsed(env)) old <- env_browse(env) expect_false(old) expect_true(env_is_browsed(env)) old <- env_browse(env, FALSE) expect_true(old) expect_false(env_is_browsed(env)) }) test_that("env_has() doesn't force active bindings (#1292)", { e <- env() env_bind_active(e, active = function() abort("forced")) expect_true(env_has(e, "active")) e2 <- env(e) expect_true(env_has(e2, "active", inherit = TRUE)) }) test_that("env_is_user_facing() detects direct usage from the global env", { expect_true(env_is_user_facing(global_env())) expect_true(env_is_user_facing(env(global_env()))) expect_false(env_is_user_facing(ns_env("base"))) expect_false(env_is_user_facing(ns_env("testthat"))) }) test_that("env_is_user_facing() detects direct usage in tests", { # Simulate `devtools::test()` and `devtools::check()` envs to allow # direct interactive evaluation env <- env(ns_env("rlang")) expect_true(from_testthat(env)) expect_true(env_is_user_facing(env)) withr::with_envvar( c(TESTTHAT_PKG = "foo"), { expect_false(from_testthat(env)) expect_false(env_is_user_facing(env)) } ) }) test_that("env_is_user_facing() can be overridden", { with_options( rlang_user_facing = TRUE, expect_true(env_is_user_facing(empty_env())) ) with_options( rlang_user_facing = FALSE, expect_false(env_is_user_facing(empty_env())) ) with_options( rlang_user_facing = "utils", expect_true(env_is_user_facing(ns_env("utils"))) ) expect_snapshot({ options(rlang_user_facing = NA) (expect_error(env_is_user_facing(empty_env()))) expect_null(peek_option("rlang_user_facing")) }) }) rlang/tests/testthat/helper-capture.R0000644000176200001440000000165114376112150017425 0ustar liggesusersnamed <- function(x) { set_names(x, names2(x)) } named_list <- function(...) { named(list(...)) } quos_list <- function(...) { structure(named_list(...), class = c("quosures", "list")) } expect_error_ <- function(object, ...) { expect_error(object, ...) } expect_warning_ <- function(object, ...) { expect_warning(object, ...) } expect_identical_ <- function(object, expected, ...) { expect_identical(object, expected, ...) } expect_equal_ <- function(object, expected, ...) { expect_equal(object, expected, ...) } expect_no_warning <- function(object, ...) { expect_warning(!!enquo(object), NA, ...) } expect_no_warning_ <- function(object, ...) { expect_warning(object, NA, ...) } expect_no_error <- function(object, ...) { expect_error(!!enquo(object), NA, ...) } expect_no_error_ <- function(object, ...) { expect_error(object, NA, ...) } expect_null_ <- function(object, ...) { expect_null(object, ...) } rlang/tests/testthat.R0000644000176200001440000000020714127057575014516 0ustar liggesusers# Workaround for loadNamespace() failure on R 3.2 requireNamespace("rlang") library("testthat") library("rlang") test_check("rlang") rlang/MD50000644000176200001440000010321614742464552011705 0ustar liggesusers4b6875114895631d6de6ea86740f7237 *DESCRIPTION e6f43178fbfc71c5d0c6586954b66df1 *LICENSE 571f9fded5d43695ad11e04790c0af64 *LICENSE.note 8074975cae52b5fac2c1dca49d125429 *NAMESPACE 6dd50e275656440706128a1ab1b52298 *NEWS.md 735441b7f469df891cd9debe004dd218 *R/aaa-topics.R d2c19c56b94b60b6b5b011f6fac22494 *R/aaa.R 0384758d34ddd8cd5cd163da3000138a *R/arg.R 26dbad767c6e4dad4e4318d980ff5f0a *R/attr.R f9cf767baafb05074ad175ced2b474a7 *R/bytes.R e3ddea862d8a816feced02d6bf1b3514 *R/c-lib.R d78e12cf2194ff9818efdb4c5e484459 *R/call.R 0431f79dec6783e63e331d2196153da1 *R/cnd-abort.R 920aaae045e0624f05ddfcbb7ec9aaa4 *R/cnd-entrace.R 89d5ec3f7a8b56c881e5d0b0db941d95 *R/cnd-handlers.R dfd00241a44bb209f0d8c466bbc4abe1 *R/cnd-last.R 590c30f101929710f2a7bfb4d3decbe3 *R/cnd-message.R 8807e57df3bb9b0d09a861da2fad1762 *R/cnd-signal.R 9775b4b65d621a4b5d7635667fffe660 *R/cnd.R 43bfc8c447eb835dc18564d4d40c0055 *R/deparse.R 72e0aad40bceda1b9a0a6a82f1f4b052 *R/doc-data-masking.R 984d7f2d685f9d2a34a38b0966612c14 *R/dots-ellipsis.R cae17eee540ff87f5121c61175a1a4e2 *R/dots.R 4c5d673c585e4a80c1deb310c21186c4 *R/env-binding.R cb4791680a491dc2ecc14e5ac49c9d94 *R/env-special.R 6437780959d6592f654a00474ce7c929 *R/env.R 7aa8fa8652f133489e379c9b063e759d *R/eval-tidy.R e6f8e9f58091c292666bd45955658da6 *R/eval.R 024eadcce813480c3ad8bf8a97a17bea *R/expr.R e668771a8785ba80c053d2e11f29c4a8 *R/faq.R 9cdbf19d5480096577396a32c512e705 *R/fn.R 2403f2751077d29419a64515735e634f *R/formula.R cbd5adbf2bf5c6c0c1ddc37ca91989bd *R/hash.R bcea89fc81bf6088505d8a36d6ed97fa *R/import-standalone-defer.R e5da8077a918b141472dc0258b744a47 *R/lifecycle-deprecated.R 1620a8f4946bb732089c61f5724a150b *R/lifecycle-superseded.R 343dd3cfad5c3587a57cd8e73005d49b *R/names.R 8b5fab9d099b28b18415e2fc85ff2ebb *R/node.R e8e834d8ba802b18ddd2d237279cac4a *R/nse-defuse.R c0a6ce233b9f7d827b5a896baa94ea79 *R/nse-inject.R 9038dd465c374a761c9e89f0af28733e *R/obj.R c8570ee9e01fce5cc41119ddd6c2edd6 *R/operators.R fecaff6975a3389233125ea5322c47a7 *R/parse.R 27ba0cec8276fba36575dc63157f055b *R/quo.R 8a5fc056502149af6e6d3a2fdc36080d *R/raw.R e1b34265467d74d53757e60dc4e009f5 *R/rlang-package.R c41f2e460a75695f99370d8aead2dd8b *R/s3.R f9f393a5045dd46be32b6aa599e03d02 *R/session.R 24078aec1ce8feea192c166ff7f2be8b *R/stack.R 003b70363704460758d49e3c0d91a051 *R/standalone-cli.R 9e6596154b4f9ab5f66d027904ed0ba0 *R/standalone-downstream-deps.R 2cd11253698248cd89fc9d6616de3d6d *R/standalone-lazyeval.R 140e25cf99883626a76840c948f55c3c *R/standalone-lifecycle.R 95db0fd247b0ac2f1dc0b9cbf0f70f61 *R/standalone-linked-version.R 5eaad1d7c35c51c943e116e51d91818f *R/standalone-obj-type.R 98d4ba5a3b47cee97c92cc434da15f32 *R/standalone-purrr.R 6d2c89ebecb4fa2f677dbf1e13b93830 *R/standalone-rlang.R 6af0229880b7a5d7f2b9e99be58c138c *R/standalone-s3-register.R f2c659c3503dfb635e64208633032e63 *R/standalone-sizes.R 1bc563195fcce9a5a634bb9d0c3e5e13 *R/standalone-types-check.R d5abc7bdcf27c5f15565a20673af0a2f *R/standalone-vctrs.R 7375986702fb2a07d2cce1de78e1cba7 *R/standalone-zeallot.R 01810a6010dbf3d794ba36e89ee846d0 *R/state.R cefd68df4edd60820de55e2804486a26 *R/sym.R 00d965df339dfaf911c29c0446b27061 *R/topic-errors.R b80d2a54dcab5b15ed948475483d6d00 *R/topic-nse.R f1466cf4083d7648ac2fc491b119dbaa *R/trace.R 703ff038b64af4f44e0f234245512fe9 *R/types.R 2aa2fe12593295abd1fc8a9f10a80fd7 *R/utils-cli-tree.R 4781b54aaf80606079332a6cb70a0a23 *R/utils-encoding.R 12c078aa16d722808ee758fc56d22ea0 *R/utils.R b4e5506d7ae38a7ddf5a338587b7a286 *R/vec-na.R 5bea9108163c7df7f71dcbd550b92b8d *R/vec-new.R bfa75cd74d99a222ebdca231145b8cd4 *R/vec.R e47e03438deb3ee65a93fe1fb0af5863 *R/weakref.R e2f4fd333502b673efdacb9905e2ac76 *R/zzz.R e352c19bb253fd761d10ae8ee67b4357 *README.md ee7ab3e7e15d1e00ec001ca33b4571f1 *inst/backtrace-ver 3a8dcbc96c06ecb013f0213f8fc38cdd *man/UQ.Rd ab210c448d110707db1b7852b1a9318a *man/abort.Rd 917e5ccdc0e75fe4dba8434a1fb0bd9b *man/are_na.Rd c18c32f0454b834575faee9c0ab9c262 *man/arg_match.Rd 58466481e6d311a0f2daac6b0aa816c7 *man/args_data_masking.Rd b894b50e18c68792f42b36124f8e1d7d *man/args_dots_empty.Rd e4d098ea2ba5f0cd07c0f86254aca7e1 *man/args_dots_used.Rd 5479a09f93dd5525ec61df178cf83e11 *man/args_error_context.Rd 57f09f994c5299b9bbae947252dd0354 *man/as_box.Rd dce02f677aa8916e339670039706cdb1 *man/as_closure.Rd 2fae1eeb4b0ad63a5bfa395962ae720d *man/as_data_mask.Rd fc5e95e3381a28f5cff74afb443ff7d6 *man/as_environment.Rd a366b3095bb90dcd5e987ed06725e879 *man/as_function.Rd dc0f03cb218c75eea979eedf8757aa24 *man/as_label.Rd cab60a0c7a43ac8da42f532d95fa41e9 *man/as_name.Rd 61b8cc1fbd77eb921a090a597c8bfb65 *man/as_string.Rd 8ee18f3c9e9172c61da21a049ecaf4ba *man/as_utf8_character.Rd 3b47728c0e77980c2e5378a8132b2d4d *man/bare-type-predicates.Rd 482fbf2c0adcf23247b5d73ca09600ba *man/box.Rd b2c9cf7a18ac0a0014516dd707a93d99 *man/bytes-class.Rd f7e012cc050bb87d7e2a390f77160158 *man/call2.Rd 4f7e9f727876541998b29b3c62f97e20 *man/call_args.Rd c23e226eac057e5aceab951da04de3ff *man/call_fn.Rd ac98c2d9ef15ce2be8546b69e7fbd23b *man/call_inspect.Rd 93a1d29c10237fc9407c8b46443923a5 *man/call_match.Rd d638109d0f21d968320b9a19150660b4 *man/call_modify.Rd 80127b239018a2c10ae0114c0b4a82a6 *man/call_name.Rd a6faffae5804a05ac8b708951fc1d7d9 *man/call_standardise.Rd a13aae1ccd7c2e9a5cc65b24c60b978d *man/caller_arg.Rd fbb49d5cbc765200fef6ff0dfb754a5e *man/catch_cnd.Rd ac2694861efe8978603165fcb2232c36 *man/check_dots_empty.Rd 42a1e7af05ceb5d2c73403d54e59de3c *man/check_dots_empty0.Rd 0114f14224ae36e255c686a37051e939 *man/check_dots_unnamed.Rd d76374d972d11bc0cefc72e196c6acc7 *man/check_dots_used.Rd 4213e49b012fe660526430a548d6a3ae *man/check_exclusive.Rd 2e8093f220fb37bebc7dbd2b9a8ac31b *man/check_required.Rd 6be46bfb8cac5e71ff7799096c175c80 *man/child_env.Rd 8db51aeb7752da89d533755ab21272b3 *man/chr_unserialise_unicode.Rd cd9de89cb7298ab8dbe8c5c8c8bc98e3 *man/cnd.Rd 21c30afe488b0da61e4d1630c27dee07 *man/cnd_inherits.Rd b451db677052e8d1271079beed096264 *man/cnd_message.Rd 69900ac92ce74840441df33d7ab9e943 *man/cnd_muffle.Rd 30237256aa3adf124b90b84b91b0a1c1 *man/cnd_signal.Rd ff04cda4427d58d29adffe62584a893c *man/cnd_type.Rd c1e671813cde844e26751dd4e6e5e30f *man/defusing-advanced.Rd 5b9326c06da5d1f63faac239d1bba6ba *man/dev-notes-dots.Rd 8654e8dc8b768c62606b06b23d468697 *man/done.Rd 35e80e2d719b2a23d85c9c9734d971e0 *man/dot-data.Rd eeb1597b3c596c220fc4d98aff8c387b *man/dots_n.Rd e4c7bacb1ff620259456a98a814d49bd *man/dots_splice.Rd 93b15ab27d235ce0d0af77481eafb3e2 *man/dots_values.Rd 445644e1bae7d8ba97a2decff617d35f *man/duplicate.Rd adffdd8202d5b3fb4cc85460bb3ff7e8 *man/dyn-dots.Rd 2b10184dc8df6705a426a6f9856a7276 *man/embrace-operator.Rd 16d5c0a4d87193d62a935037549cb822 *man/empty_env.Rd c0eb1426eb53d963cae957b242ccd8ba *man/englue.Rd 5a4d7e5e7d4b30c235bfab086da08ad2 *man/enquo.Rd 829b19b5db2b933577d1f4239dd7ff1d *man/entrace.Rd 3a7f3e4a8fea83f8d60750304ebd1e24 *man/env.Rd 9ba115cdd038e2bfa241abb669e33a5a *man/env_bind.Rd b47e067311258519120f14a6b49eb7b4 *man/env_binding_are_active.Rd e53335c123c6311672efd82acf61fff6 *man/env_binding_lock.Rd 307c267709302c23b56c7a7bc230d8fa *man/env_browse.Rd 3bfc6d6cc29007569f18d38322ef70cd *man/env_bury.Rd 60ee286ee915de7cf58a0d00719dc839 *man/env_cache.Rd 4ef396c2ab2bec17bb0792905948d3ae *man/env_clone.Rd f330df1e53699e936dabc4617079c438 *man/env_depth.Rd 518d65776c2bd043c90391797b395712 *man/env_get.Rd b9520b5a9c45754cb75a7dfd41c467a3 *man/env_has.Rd 2e4b15ff1b9f7d608dbaff7e1efc6399 *man/env_inherits.Rd 8adcdb44441fd12ea1b4121416a30ece *man/env_is_user_facing.Rd 6603c9256e666f619ba42d35eb64fcab *man/env_lock.Rd 5bee84cd96d0aa2d27af6ac6346ce9f0 *man/env_name.Rd 874a7a42f2f3714957ba6e2d743420a7 *man/env_names.Rd 3cc0675314ceabdf5622ec981363172d *man/env_parent.Rd 0d5477d9ccc16c41fd38411f80322c23 *man/env_poke.Rd 69608a9d734c63d716efeded8d33d1f9 *man/env_print.Rd 0cf194f1ec3a0a96ef943d1297ad01e1 *man/env_unbind.Rd 51cae32ed1f181fee83f694d37a8baf6 *man/env_unlock.Rd cfc05893ed21dd3534de3bb491d9b435 *man/eval_bare.Rd b0b1f9b601df93fc42a68e10b37c8489 *man/eval_tidy.Rd bdb8be19415d59bd69ea88bf4097495d *man/exec.Rd 85f5f66e0db17c52e3c99cdac162592a *man/expr.Rd 738aeb5fbd1b0a07c3ece324567aa1a5 *man/expr_interp.Rd 18d969b1151f92483196bad07a35b4f2 *man/expr_label.Rd 2cda0fe88bcb4210faddca56c40aa492 *man/expr_print.Rd 0e3deee9e2b022b93d8b6adfc8577470 *man/exprs_auto_name.Rd f9fe2913a3200a2db8c3695e21b73dff *man/f_rhs.Rd 04ddff4dc1e88d33f18c8c4592ba4707 *man/f_text.Rd fced977363baf33fe0244e2006687268 *man/faq-options.Rd 05f4ef3230ba59ea4d3754fc58991f40 *man/ffi_standalone_types_check.Rd cb1e46f469cfbbbde29c8b5113e1d789 *man/figures/lifecycle-archived.svg c0d2e5a54f1fa4ff02bf9533079dd1f7 *man/figures/lifecycle-defunct.svg a1b8c987c676c16af790f563f96cbb1f *man/figures/lifecycle-deprecated.svg c3978703d8f40f2679795335715e98f4 *man/figures/lifecycle-experimental.svg 952b59dc07b171b97d5d982924244f61 *man/figures/lifecycle-maturing.svg 27b879bf3677ea76e3991d56ab324081 *man/figures/lifecycle-questioning.svg 46de21252239c5a23d400eae83ec6b2d *man/figures/lifecycle-retired.svg 6902bbfaf963fbc4ed98b86bda80caa2 *man/figures/lifecycle-soft-deprecated.svg 53b3f893324260b737b3c46ed2a0e643 *man/figures/lifecycle-stable.svg 1c1fe7a759b86dc6dbcbe7797ab8246c *man/figures/lifecycle-superseded.svg 42e90e0813fee26f77866a2f8025b3ba *man/figures/logo.png 1b450eebc3e296aaf9e039f352e5836f *man/flatten.Rd 4fe851baf51454d7457f6c488d300741 *man/fn_body.Rd 211721d74f26ffda3874dcf3e699d078 *man/fn_env.Rd 9ab97e8f285362bf7067279191951d3f *man/fn_fmls.Rd 8a839cd9d2cf33fe13ef0634955d7c4d *man/format_error_bullets.Rd 35fd5fcfb7cc2c898291673dfc5bc43b *man/format_error_call.Rd fd9f444eefb5c68b6c0fbee1e0fa3d95 *man/friendly_type.Rd e7cd2f813270106cb90c96d7aff48a71 *man/get_env.Rd 57ac86e03092d79dfdc3b7b0a5da5ff2 *man/global_entrace.Rd f97940d1b652b22e9c721a0e6a43ff21 *man/global_handle.Rd 104c9feefbbfb4939d2aedae2dad41a9 *man/global_prompt_install.Rd a8339e81f22e440779746acef8fbc43c *man/glue-operators.Rd 36a034671a550aae53290d36e926ddc7 *man/has_length.Rd 9314263b645e88284694fffcb74117c8 *man/has_name.Rd e6ad7e4ddbf47d0600c519f4b1d22889 *man/hash.Rd 2f013cc6446d059609819be4fb2a3777 *man/inherits_any.Rd 93735a66fc8473ceda90f64c363e29ba *man/inject.Rd 6a22700a5b63b6289c9817a26b5ff067 *man/injection-operator.Rd b6554ecabdd63a643c1b460932b3e313 *man/interrupt.Rd 00e24d6030dfa9a1d180c4fef5858ff9 *man/invoke.Rd b3dbc0bf4c9ee7d3450e6d1386fedfa3 *man/is_call.Rd 7a153c5c18079918623d0b5a9ed89284 *man/is_callable.Rd 0ff7b6e515f525463434bdaf726947ed *man/is_condition.Rd 66808a49eb27f386625c38a66f1dae84 *man/is_copyable.Rd a209aaea08fe324eabe775425abb0caf *man/is_dictionaryish.Rd ab65d6e0c9ab4b2914627ef58f4995ee *man/is_empty.Rd 2731bdb87a563f5a2e5903b34d9ca50b *man/is_environment.Rd aadec817d9bbe52602e1191bd5096774 *man/is_expression.Rd 7c69a28e8dce318aba557f9f03571218 *man/is_formula.Rd 25711a6beaeef66fbcb0e2b70741e970 *man/is_function.Rd 8c54bb7ecb71cf3180dc5a76783a693d *man/is_installed.Rd e1e67bbed234e93c04bac1fb45b17019 *man/is_integerish.Rd 64428493e2062ee4394c9a644fa04ee7 *man/is_interactive.Rd 00658e1359ae33639294135cb883fca5 *man/is_lang.Rd 658ec61d7a7a0e0dccf7fd293f6ed715 *man/is_named.Rd 468eb2b598b28efdbd4d5d9f8c12a226 *man/is_namespace.Rd a811ebb034918a018971346506163c43 *man/is_pairlist.Rd b4a02a7600060f95965d6838ec04e1ca *man/is_reference.Rd 41556c0aaeeab103f071615edaa12d43 *man/is_symbol.Rd c524dae3c587048154fff2fbded9f7b9 *man/is_true.Rd c69137d6645b654033e89868911e03b4 *man/is_weakref.Rd 4c973ecf731ec4e8fe7b15583a4d646d *man/lang.Rd f2bb76af415e0f73533725cd4de44cbd *man/last_error.Rd ecf0a33d9eff610f438410f28d5267dc *man/last_warnings.Rd 92ce97a3df06300f6d9d26372c421474 *man/list2.Rd 59742d6634d0813c130e892db08a4dc5 *man/local_bindings.Rd 5259975a4b71c5ef434986d96a550bcf *man/local_error_call.Rd fbe16d7c265aa1a09bfc3341469b5490 *man/local_options.Rd 129e18e08bf3d387c186bf5c0ae69894 *man/local_use_cli.Rd f47bbfac4f973e9b5628ac9dfded293d *man/missing.Rd 09c196ea0ab1a92780ffbc230e56c4bb *man/missing_arg.Rd 0094d2c6334b4826597dc96dfe6ef7be *man/names2.Rd d2045a55875da5e7f49648f2e282217a *man/names_inform_repair.Rd ba7630e711cfd3cca7c8d0b88b51a19d *man/new-vector.Rd 96fa4dd88da49efa4b4f1c4aca74d879 *man/new_call.Rd 2ad8783d26be37103f821e5ae535c56b *man/new_formula.Rd 8a0d62729751756e783c3416040c2075 *man/new_function.Rd a972c4fb293a9817ba9e94f45eddaec1 *man/new_node.Rd 215899ed8ff316307f130f45b7c4aecd *man/new_quosure.Rd 73f43de162110988a7b3839b2f2bcffc *man/new_quosures.Rd 124c3a599323e8c3eeb8eedaa5c49594 *man/new_weakref.Rd b2dafb87fefbd18eeb883676d054acd6 *man/notes/handling-introspection.R 14471dd5bece543db739b79eb8847430 *man/ns_env.Rd 4d325a54145a8b47480c32ff1bae0818 *man/ns_registry_env.Rd 6ad713457fa1756df97d267bf5321cae *man/obj_address.Rd a739e2f8ea62dedf8486c5f87aa67760 *man/on_load.Rd 84259297bc000baf9e9d182954fd6653 *man/op-get-attr.Rd f7db9c3f41a662777dc9ae8ecaa4045b *man/op-na-default.Rd 104a6a1976e8c95b00c7f5f3457ba6d7 *man/op-null-default.Rd ed4dcc3823679adb0b250a2594ae3c6f *man/pairlist2.Rd 6a42fefcb01e3f37f10d6a5811d28a06 *man/parse_expr.Rd afc9cc159795e4415c38a5987075910d *man/prim_name.Rd 546ba404ed245116362209f93d99c1f9 *man/qq_show.Rd b71040a0147644f62a7e97580659c9fa *man/quo_expr.Rd e78640299fdc11d850a9dcc311adb60c *man/quo_label.Rd 38559c57b2b7e4f563732d3450433d5a *man/quo_squash.Rd c8d96459b1e506660275ffe0ec438104 *man/quosure-tools.Rd ee222ba5b1575536df9c0166f030b90b *man/raw_deparse_str.Rd 9951ed59df6c313b031098c947e06413 *man/rep_along.Rd 66e18f453b6deddbbd1d9bbd4d4a6964 *man/return_from.Rd a4f23f20540a2c8f3901d4b205e37af0 *man/rlang-package.Rd f679bebf0d611e153fab4d49a3b47a07 *man/rlang_backtrace_on_error.Rd 5e2bee79f2da314eac8c4811f4dfc10d *man/rlang_error.Rd 62022180afd07b3a46263c817e4e6eb5 *man/rlib_trace_spec.Rd 47fcca843474e62ad16ccd3703a44a93 *man/rmd/glue-operators.Rmd e6005d32672c76030e9bfff7d40e5dbd *man/rmd/setup.Rmd f9cbbb7a16efcd6c18d1cf4740675ee1 *man/rmd/topic-condition-customisation.Rmd fc4683e873fe37a0ea2bf1d909ff4ac8 *man/rmd/topic-condition-formatting.Rmd 19b81a6a3700cd90481e72251e04f51b *man/rmd/topic-data-mask-ambiguity.Rmd 1a7bb677574cdf4c11ceb8f73d4e204a *man/rmd/topic-data-mask-programming.Rmd 47f166df6d33cd1758cd6af1a896cb11 *man/rmd/topic-data-mask.Rmd b4644e33ae8565a38c7eb96e897f6403 *man/rmd/topic-defuse.Rmd 12a3e80c80cadaf04b888248cadb64a9 *man/rmd/topic-double-evaluation.Rmd 12fe358bb4f1a5dfa3fa46432c116f08 *man/rmd/topic-embrace-constants.Rmd a7e810b3ea7acc34f70ec51315df8993 *man/rmd/topic-embrace-non-args.Rmd 51599556a0f0580f3b13853160064c86 *man/rmd/topic-error-call.Rmd 92e6f2ae41db7971c724fa7219390ec0 *man/rmd/topic-error-chaining.Rmd 6791dac79a431488bfbb101f16f0d780 *man/rmd/topic-inject-out-of-context.Rmd c0c01c8787b46cfdd5bdcce3ab440b4c *man/rmd/topic-inject.Rmd 681296137b1d679f9184a6cf61d32daa *man/rmd/topic-metaprogramming.Rmd 3171546bf85ca3bac2a41c26e7d1420e *man/rmd/topic-multiple-columns.Rmd 9cc8d8250ea3635589f0e3f5bc3ddc40 *man/rmd/topic-quosure.Rmd 942d10b1d0ce068c640d9d42497450bf *man/scalar-type-predicates.Rd 843fe15cab1816b37376ec964f979440 *man/scoped_env.Rd 049b6d9b5d77ab07e69b2f975258f608 *man/scoped_interactive.Rd 7d1173fbd423e97d0d15512dcbdf29df *man/search_envs.Rd 231f1a6e76b2d308aa1eb9c6430e3bcb *man/seq2.Rd 270a29b52e01a4538186b8d719b67e68 *man/set_attrs.Rd a3bfd928fe1b8afdae87ed2f07f6db0b *man/set_expr.Rd cf0beb7db0ee823dbbc67290bdfbe591 *man/set_names.Rd 4d444a148e993e9b5c0d72f45628defc *man/splice-operator.Rd 01ec22464fe579ddd23e6d73356f5eb0 *man/splice.Rd c41221590c7f7c2a5ff987ec2f10c35c *man/stack-deprecated.Rd ef1436704e9225e5ef75178c17845c57 *man/stack.Rd 19b4df59b9377d88db539ab5ca2824b1 *man/string.Rd d3dc0a4f4528b9baf031d16defc56f39 *man/switch_type.Rd 2e0a61c6e54f14f8e5aac8bcdd7c5122 *man/sym.Rd 654ea7e43f626acbb7c7886a549c51c7 *man/topic-condition-customisation.Rd fc1d4a893ed7f03838b4625d56a4dfab *man/topic-condition-formatting.Rd e845825b2ab842ee73bdbe9a69348758 *man/topic-data-mask-ambiguity.Rd d65aa0f9d86c17eb10689ffb4bfbe811 *man/topic-data-mask-programming.Rd be4afc9cc71d10c85499e7bc061f1a65 *man/topic-data-mask.Rd b5a8ebaa33d76b5d2d75f3d7a0499bcd *man/topic-defuse.Rd bbc05f783495fbf54fd5edef9243b028 *man/topic-double-evaluation.Rd 2fa83201ff93feb7d16a9ac4ed802c67 *man/topic-embrace-constants.Rd 6269df0bd2139689e46fd960881ce5ae *man/topic-embrace-non-args.Rd 15b24db4555e3463648319ae3b1d095e *man/topic-error-call.Rd 1b847a41bea28bb6074c9ea4ab0a895f *man/topic-error-chaining.Rd 9aabb764812da07fc21e8475ef13f77d *man/topic-inject-out-of-context.Rd 4e3c562b10960d05ac0e23625f130253 *man/topic-inject.Rd 2bea08336b82cdf7abb022dde9bce1f5 *man/topic-metaprogramming.Rd 8ac68805eaf5086a2bd7ff4d7e8a5fcd *man/topic-multiple-columns.Rd c254b3ad2117423c0456035fde13fd4e *man/topic-quosure.Rd e5ce6b3f74e050b8a1336ea241a8a09b *man/trace_back.Rd 8cc731f4cb55d2cf9d421abc0b933bfc *man/try_fetch.Rd 4103e95e1c8c3c0f164bec81b6b79ce9 *man/type-predicates.Rd c53e5713e7c43eae04263dba97a7b539 *man/type_of.Rd 4d2c1f93770ebb724817585bc9b16976 *man/vec_poke_n.Rd 998e55518065c2d5820a809596314e91 *man/vector-coercion.Rd c54a898791cd2c4dc063515a3729f825 *man/vector-construction.Rd 6871ecd04942f405d9efc3351af44ac1 *man/with_env.Rd 69895be933df521b6d76edb6675acc99 *man/with_handlers.Rd 6dadd42c4837cfdd7bd7c647a875f065 *man/wref_key.Rd b1488158ec99011b492963e9bcae0a8b *man/zap.Rd 5f844153c5118bd3171727127790d78c *man/zap_srcref.Rd 65654360190f336824142bfc697c77dc *src/Makevars 464a805d8f1d8fc1a09574dbff0c1d92 *src/capture.c 4ef367588c5e607b1a99842eba7d6a5f *src/config.h d466c34ffa77fcf2b3ae36c5ae82efaa *src/internal.c cc87c24a8298cf8fccc64b7a58fddf4d *src/internal/arg.c 939329bd1aaeb0d795ddecd9510db50a *src/internal/ast-rotate.c 35c6a3c9fb1879a55817cc7b13ad532b *src/internal/ast-rotate.h 0419c0f13b7ab752f825c96cf9f6aca9 *src/internal/attr.c 070ecb91187a672ab33fb4c8f91213ef *src/internal/call.c cba8a9786b294c0f52a142c6604916fb *src/internal/call.h 0bb37ec869f828354d3c5842c3ab5fad *src/internal/cnd-handlers.c 543c1a4c60f1140e6c97a83b956eb8e4 *src/internal/cnd.c c3bf2f37fad9954f4f4af4e76decd52c *src/internal/decl/arg-decl.h c6ad5b956927273f033f07d1fa9eaff2 *src/internal/decl/ast-rotate-decl.h 8432556745c79bd3ad59367212c276d2 *src/internal/decl/attr-decl.h e2fa92d9d5165c82c7e8a19d3003c87d *src/internal/decl/call-decl.h 47fc2f5df2c57dfe8b7debe5908b535e *src/internal/decl/cnd-decl.h 587c0bb1706a51948bfba3b7fc0de790 *src/internal/decl/cnd-handlers-decl.h 14f117f0a22ad8543299142baf4c5e73 *src/internal/decl/dots-decl.h 11a4b60bebc9795e9c38b129afbf19b0 *src/internal/decl/encoding-decl.h ab8ba9d44711965151ee298799eb93c4 *src/internal/decl/env-decl.h 1e1dc0c23e59707eb2ae38dc8470ba8e *src/internal/decl/hash-decl.h 3aa3dc9619fbfd4394ba6daff333ddd6 *src/internal/decl/names-decl.h 030dd04d4a71c6b3679665d6351aeccc *src/internal/decl/standalone-types-check-decl.h 4f2aa941222e14fc3abd2173d5643da8 *src/internal/decl/sym-unescape-decl.h 69d4333c022312deed09703c28e257ee *src/internal/decl/tests-decl.h d8f62d08155e52256bfa294f1d79b484 *src/internal/decl/vec-decl.h 0b24ac9853cd6b1b492ec52f93f72404 *src/internal/dots-ellipsis.c 7171dfbcd875a5615972bb4cb29be754 *src/internal/dots.c d643f0fdfb78450ba3590fb78cbe0efe *src/internal/dots.h 8be427875b2af1b35509050ae46be105 *src/internal/encoding.c 599ee0872d65b1c2a12c4a2bdc2fcb09 *src/internal/env-binding.c e05c03d1dd4a7a6e4178c295564134fb *src/internal/env.c 57b0b92c7b3d900ef8238ce41941f179 *src/internal/env.h 26f9da89660a2517c8a8db8c0d19bb92 *src/internal/eval-tidy.c e648def2f16d88ca2ff2c657e31baa19 *src/internal/eval.c 17e78882c4a1b461a954125483087a80 *src/internal/exported.c 6c29aeafe8f2d3644b65276cf5479159 *src/internal/file.c b3cdc6bf27a721e46bb00f99068569fd *src/internal/file.h 304011bb58a1a5e8bf0bc20134edf302 *src/internal/fn.c 708b16754b62d7f9d5b1575f0672467b *src/internal/globals.c e6f25862035f1cb51aa132dc48755fdb *src/internal/globals.h 05cd0ab97fe83cfe9ef91e4271368bd6 *src/internal/hash.c d4b830c866c853867cbdf50d19b4f693 *src/internal/init.c 55fec425a4934042f80aed7814693701 *src/internal/internal.c 31c75eddcbe886259fdc3e730f70697b *src/internal/internal.h d1fdd8506ad72bbd92e3214f809d45a2 *src/internal/names.c 0726c2a3d69c770b3c25442b975f9337 *src/internal/nse-defuse.c 91a1e3ecab762f206f92631b9f544546 *src/internal/nse-inject.c 6023609a056bf0117c17781f40eb73ec *src/internal/nse-inject.h 44cb4ded1c76022dc79ede6dce4a7780 *src/internal/parse.c e71b9bfb8c96b4d7d7ac691e19556705 *src/internal/parse.h 7cbc89611525403aa13a7dbd275734b0 *src/internal/quo.c 1c5ffd5cac0a3f7e1e247ac2650835c7 *src/internal/quo.h d9b6dd30c8b51a75e33e810c8d68778f *src/internal/replace-na.c a96c265470781047009d6ebd5a687d0c *src/internal/squash.c dc705d94f021d9f14d41fdf31bebdc61 *src/internal/squash.h c43d33f9b893732916aefba9f46599ed *src/internal/standalone-types-check.c 369bc80078833126df1245811fb6b2ba *src/internal/sym-unescape.c ed23eef7aca7a61c08c5cc9c0bc0ec65 *src/internal/tests.c 34d09c6a751316d36cf4a69aa9b3fecc *src/internal/utils.c 182f71362591001fa51b0653e919b15f *src/internal/utils.h 491b8e0ab16b8fe87db1ad83207f58e2 *src/internal/vec-raw.c bc8259faf9e33be6e0cc1ff3373f4144 *src/internal/vec.c 8ca3608c53996d68a7247391ac828840 *src/internal/vec.h 3dafc481c79d41f5e8ed3c1b4db0d5e2 *src/internal/weakref.c 3066518b768e229d4b44248362581f9c *src/internal/xxhash/xxhash.h f675812d8927e9b13fce5f1e8ed31f1b *src/rlang.c 2ac29d4e778ca5cd4ede63936aceec6a *src/rlang/altrep.h 0608535fc0aaf4efdf5a51912e6a6c84 *src/rlang/arg.c 516c28cc1b7d182ce35425ddd1aeec92 *src/rlang/arg.h 51c833ea77aaa0b98613ea09327a4285 *src/rlang/attrib.c 91b9e07c242164935f070acd1906dc85 *src/rlang/attrib.h 9c9b7d12443672c8dee0a4615b56c2fc *src/rlang/c-utils.c 958e57eea0ecc2a59584284d13e74ac6 *src/rlang/c-utils.h 22e5d851558dcb490b87b5ffebbcb6f8 *src/rlang/call.c 8b7f8d124612d68d51fd8c1d1131674e *src/rlang/call.h 334cf2bf146b2092fd5ae90f0063bb46 *src/rlang/cnd.c beb3cae7fa9aaabc41ce9a4baa9919c9 *src/rlang/cnd.h b176a262a2ea2e884f4914289466de7b *src/rlang/cpp/rlang.cpp 29bd3e7d88cdb8a4a641f05ee089069c *src/rlang/cpp/vec.cpp 6641e807daa143b432f19ec466be377d *src/rlang/debug.c 6cfc4c254c05bb83ded1ccfcfdd73135 *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 4faf5ad969081c60feecc51bd0dc81b2 *src/rlang/decl/env-decl.h bf8df189e2ff68b0c0fe62d076814545 *src/rlang/decl/obj-decl.h 5cbb39aebac52f777c30ab65c94b2461 *src/rlang/decl/stack-decl.h 5be592253e1434fb98c28029abc7b5f2 *src/rlang/decl/walk-decl.h 1da9bd6ded0503adf71366ca9157ca33 *src/rlang/df.c b60f69df26d28f1549b7af6a743220d1 *src/rlang/df.h 71cb9741795db383b500a5df30ccac58 *src/rlang/dict.c 65f78ebe4befef95942b4ec7d809f37e *src/rlang/dict.h 6e469204c177ce2654c64ab1a4657518 *src/rlang/dyn-array.c 91bdbc1c57d928a5b5f0b75cfb4d4444 *src/rlang/dyn-array.h 1a0756c1c50f978b84035395ccce3cb1 *src/rlang/dyn-list-of.c a0f33ea79f34c196989f738968e0e1d9 *src/rlang/dyn-list-of.h f33d928d13ae05dbc3ecb6e46ec5cf10 *src/rlang/env-binding.c 21089db32f310a24b72b0128faf10065 *src/rlang/env-binding.h d8dbbca7e94e0554eec92c097b5e5d7e *src/rlang/env.c e5e77cabfb2cf22230e7e11fd9660b2f *src/rlang/env.h ca30eb74e8fdf150423d871ae72818cc *src/rlang/eval.c 88c2128a2e83789a7908b28a140c469d *src/rlang/eval.h 47ced9fa82505197086534c254580b43 *src/rlang/export.c fa2eb194b1c5969ab31898499b10ae4b *src/rlang/export.h ec36cc014954270b6b827f3844f5cf1b *src/rlang/fn.c 1eae432b32bb6ac5533515d570ee50fe *src/rlang/fn.h 676b90d434ca8455b5306a86a73ec080 *src/rlang/formula.c db5097eb19dae675d9523431fe7a7b85 *src/rlang/formula.h 97d8e16a62839f989c53127d4339efb6 *src/rlang/globals.c ba2c20c5c3596a89f9c9b40c8eb242d7 *src/rlang/globals.h 240370964fa57c63867b60d3a66bb0ad *src/rlang/node.c 04013de2090e7a49f594111532d8dbe8 *src/rlang/node.h 4688cfc8593a2b4e293f4de1d29c0684 *src/rlang/obj.c 3c9d4c44e50870bb284b9fb618bf24fc *src/rlang/obj.h 4576f3bc9e1dafe198460d4c2b0e88f4 *src/rlang/parse.c 7816d9d5ca0a5c7173a7e94de9b3d369 *src/rlang/parse.h a5e865607e4e717784f5f951533d372c *src/rlang/quo.c 0e9752fcf2462f0639f6fff5ba35526c *src/rlang/quo.h 9a59495aec0fd237423215b6aacf66ed *src/rlang/rlang-types.h 6f7ae5669e60bbf2e910f5a81501e69e *src/rlang/rlang.c 7e0cfe3ef93b50bb6aebc281594ad12e *src/rlang/rlang.h a24cd0a56d6993488d143ed8f5ffb7d7 *src/rlang/rlang.hpp 3115b50ab84dff920d09f95b4f73e395 *src/rlang/session.c b66e2877a29b59aca668b26defc1004f *src/rlang/session.h 6225f1c2d3182e4bb957b8f1aba27937 *src/rlang/stack.c 569bf6966ce2f97b72d79717c070ab41 *src/rlang/stack.h 10e3dea942472e0b20dfd804dd3bdf71 *src/rlang/state.h 267ea357e68ff19af4f151c76b8c21c3 *src/rlang/sym.c 595f09b9b51c33a8e2a864b9d4a92d75 *src/rlang/sym.h 6ec4b806d0cad8eddae9250f2cbf3231 *src/rlang/vec-chr.c e267a560c64a208fcc7a4bab77b93bc9 *src/rlang/vec-chr.h bf006c89dcffdc61228a385ee5ad342f *src/rlang/vec-lgl.c e509790fe4a79d6943c93d96dbbe83c3 *src/rlang/vec-lgl.h bf1c072d4e6af784afd362c8f77aef00 *src/rlang/vec.c 13953fa3199b0cc7aaa63e7fb5a55df0 *src/rlang/vec.h aad9cb50156b9ab0f02ea91fb31db1b7 *src/rlang/vendor.c 139544f5576475c395dc8601655c7948 *src/rlang/vendor.h 4b8fd26a08a137a90c8d1323faa286ec *src/rlang/walk.c 05a1bc12017a29dd10726ce3a2320dcb *src/rlang/walk.h 6cf30f8d9b1b25b490b91e75babaeca9 *src/version.c b535466226f2ed8212a97ea8790639c4 *tests/sink.R 689f0fa1b25df0719206586844edb2d0 *tests/testthat.R 551d389cbed2dcebdb066ff491b0f2ce *tests/testthat/_snaps/arg.md e723554814936b8aee1596969249e9dc *tests/testthat/_snaps/attr.md bf3693d1b29260502e4447eed001dffd *tests/testthat/_snaps/bytes.md e3a7bf66c4bd315d88d998016fffe07a *tests/testthat/_snaps/c-api.md 09232ea522dbff9416988eed76936e21 *tests/testthat/_snaps/call.md 9a2c103b8a76a50aa8ba1df47db7ee10 *tests/testthat/_snaps/cnd-abort.md 5e4cdff9eca7f6c8cfa093077f1e6680 *tests/testthat/_snaps/cnd-entrace.md cd05d91f045729b769e83aacbd9a983b *tests/testthat/_snaps/cnd-handlers.md 6cfc77aa904520642975c9daf8124928 *tests/testthat/_snaps/cnd-message.md 9569a9d090a95266af46963da4e0e621 *tests/testthat/_snaps/cnd-signal.md 05b369b87e520f30eab6552981e96db1 *tests/testthat/_snaps/cnd.md 02b7f7fe39070c5ff24f6c0fd0d4a5df *tests/testthat/_snaps/current/cnd-abort.md 7041da4f0c4f530913fc779ca0fe230c *tests/testthat/_snaps/dots-ellipsis.md 613092981a2299f481d141b9d50191c4 *tests/testthat/_snaps/dots.md d1138e29c1ad847e1610b9640d5e9331 *tests/testthat/_snaps/env-binding.md 8110ec13c19a8342bb141b110e558fe1 *tests/testthat/_snaps/env.md 74538b90967a2b5f2eb72e40835de2d1 *tests/testthat/_snaps/eval-tidy.md ee7c3ae60a3c22d0030176c52f40863a *tests/testthat/_snaps/fn.md c314b68ccbad562aaa1d13e02e2e46eb *tests/testthat/_snaps/friendly-type.md 734dba10d1233a821d13b95024c8d60b *tests/testthat/_snaps/lifecycle.md 1f073e350c00b044884be4dcb4c747cf *tests/testthat/_snaps/nse-defuse.md ad54bc1d35a53acc94658bfa38163280 *tests/testthat/_snaps/nse-inject.md 30e39e163d67da011eab19ae8e8a62e6 *tests/testthat/_snaps/operators.md d9977898c017591a75b1e000134935fd *tests/testthat/_snaps/parse.md 11a021d7f695acb39f3bdd47a32ed331 *tests/testthat/_snaps/pre-3.6.0/cnd-abort.md 87d8837ab232aa8570d182865ec90972 *tests/testthat/_snaps/s3.md 2e542a6e49bca2ba6e29e8e3f82f046f *tests/testthat/_snaps/session.md 27181555eae14983a14582ceb3ca58ae *tests/testthat/_snaps/standalone-cli.md 91ed2571b4fed85009551cf4c891a169 *tests/testthat/_snaps/standalone-downstream-deps.md 0bfc8bf78945a3c1f92fd9cedf54a118 *tests/testthat/_snaps/standalone-obj-type.md 21b638f8631a2bf130f83b2380db47fe *tests/testthat/_snaps/standalone-rlang.md bf2192fe3fe5338469b7d880b687846f *tests/testthat/_snaps/standalone-s3-register.md 849dd09395c83c5a12bc34bac3f21810 *tests/testthat/_snaps/standalone-types-check.md 1edd77bd799cd22b2c3afb16de478907 *tests/testthat/_snaps/standalone-vctrs.md 37a08870995b87f2e7bdc31f71380ecb *tests/testthat/_snaps/state.md 0f2bcb63150664cd2ee10f897de52cdc *tests/testthat/_snaps/sym.md 97affdee5e6ef98d8c6563232eb7e748 *tests/testthat/_snaps/trace.md 30b32d0a6389e9ff2f1f7c9d7ccb8693 *tests/testthat/_snaps/types.md ba141ebe66e9cbf68456c4894d8f811d *tests/testthat/fixtures/Makefile 991013de81c7cc5791d2bbe181f61f63 *tests/testthat/fixtures/error-backtrace-conditionMessage.R ac9346885a36276a5ecc31dd63ea2dfe *tests/testthat/fixtures/error-backtrace-empty.R 7530c4b7eb71435b132a22841c60b75b *tests/testthat/fixtures/error-backtrace-parent.R 3ab920cb77c0ea75ce7d624a53fb0188 *tests/testthat/fixtures/error-backtrace-rethrown.R fb42369494252c86eb9d0fe1a44fd48b *tests/testthat/fixtures/error-backtrace.R 9a18b7ababafccca6767075103f5e030 *tests/testthat/fixtures/error-entrace.R 691bd605cdb97c2442e8bca925300425 *tests/testthat/fixtures/error-show-messages.R 8c22bc013d19c89ee1d781719df9ec69 *tests/testthat/fixtures/lib.zip 6ea94f365a014ea7962ad856a464900d *tests/testthat/fixtures/rlanglibtest/DESCRIPTION 7aab50abe7351ed88ab8802f5f80ce0e *tests/testthat/fixtures/rlanglibtest/NAMESPACE d6b263e1ae07adbe16fb5f2f275898c9 *tests/testthat/fixtures/rlanglibtest/R/rlanglibtest.R de5d6e28846d582858e06161de676531 *tests/testthat/fixtures/rlanglibtest/src/Makevars 439eaaf9326273c700a01517c1624fbb *tests/testthat/fixtures/rlanglibtest/src/init.c d5454aea580d1b09b6acd30ce8064552 *tests/testthat/fixtures/rlanglibtest/src/test-quo-accessors.c d18d1bdcf3564ccaa3a32da5977d5787 *tests/testthat/fixtures/rlanglibtest/tests/testthat.R 0265f256d07760e01cf9754ccba69504 *tests/testthat/fixtures/rlanglibtest/tests/testthat/test-quo-accessors.R 14b5a0404c1240c2cab8fe47085c7edb *tests/testthat/fixtures/trace-srcref.R 5413b03ff31365f8c9b40c935dc0e749 *tests/testthat/helper-c-api.R a3d7f6dfc5ab44af81dd760bd5b08235 *tests/testthat/helper-capture.R eb5ffac2e72dfbfb677fefd3563f822b *tests/testthat/helper-cli.R 733f1e58e2aeb114b0580d1053b5bfb6 *tests/testthat/helper-cnd.R 303e573460e7056f52644a6cc1cc12f2 *tests/testthat/helper-locale.R d5d51398feaf1a5473e1a8f71afca634 *tests/testthat/helper-performance.R 71d70b5fc2aa426a2918ec167f657855 *tests/testthat/helper-print.R 5b176ff9aa1940976ea3be451dc7e820 *tests/testthat/helper-rlang.R 1805fa5867a87b893a700b47217c6cb5 *tests/testthat/helper-trace.R 174be906c15a7e0857eeb05b32a1bcb0 *tests/testthat/setup-tests.R 512dd39b4a02489cc9cbc68c76480b3d *tests/testthat/teardown-tests.R 649f8d9912b364aab8111d588342bd24 *tests/testthat/test-arg.R b6d558b3b9d139cd7bde1dcade5d6fd3 *tests/testthat/test-attr.R 458ef7d472ed388f44cd809cd9919ad5 *tests/testthat/test-bytes.R 706b18675b95cc68ac51d62c7fe91bd6 *tests/testthat/test-c-api.R c6a8f89c1b26d5b57dfa9c1bb14547c5 *tests/testthat/test-call.R 6724b9c4e98b917e417558ffd87732ca *tests/testthat/test-cnd-abort.R 7d374d929642468322d63008177b798a *tests/testthat/test-cnd-entrace.R 292549a9bf42f3ae2c9df5af04aad027 *tests/testthat/test-cnd-handlers.R 79c033aa62f54418a856c0d41aa9d518 *tests/testthat/test-cnd-message.R 304d7b32026f4a4f51a3c3367adedfab *tests/testthat/test-cnd-signal.R 29c41dd72ae57b4d82c901b698b3c20b *tests/testthat/test-cnd.R 790abbfa0ddd511287fa3fca981b28ce *tests/testthat/test-deparse.R 4a05bbf91de69ec12d52ed09c0038dbf *tests/testthat/test-deprecated-vec-squash.R a2c14b0458ba2ceb93b427a63fbb9f28 *tests/testthat/test-deprecated.R dc1e9e1e02bd49ef2a02fccc2f10964d *tests/testthat/test-dots-ellipsis.R 2e89ef91d86022e87d91fa389ef487cf *tests/testthat/test-dots.R 8ad00c0854ecb79ea1449559be1d69c1 *tests/testthat/test-encoding.R 50267dfc30521c19a40807a9584f494b *tests/testthat/test-entrace.Rmd 91300e080ca225b04b3d3fb8810d02be *tests/testthat/test-env-binding.R 70b091c6db7d4257124f524141ec46f0 *tests/testthat/test-env-special.R 5248b54094a24a8f911a78f4b71ce92c *tests/testthat/test-env.R 5ce1887dc076c6c3147d6d0e25715ec4 *tests/testthat/test-eval-tidy.R 377cd0001f2ba46fc77a93b4b06733ef *tests/testthat/test-eval.R 591d5a69c244a091c8dd17f5a956de1c *tests/testthat/test-expr.R e16b1e0a362ba85233c7fa6c8f3f50a8 *tests/testthat/test-fn.R ace5a10bc42c509b44c2227ac2dc4b04 *tests/testthat/test-formula.R e12e46d0466ceca8bd52cb0265b97820 *tests/testthat/test-friendly-type.R 3e079814372a88c93d2f90cc0a2d6c28 *tests/testthat/test-hash.R 262da063e9074d4ae8ceeaf5355b17b0 *tests/testthat/test-lifecycle.R 18fc02939481b71f2585729de604d3a7 *tests/testthat/test-names.R 3e8b4e677880f90dc1df3aa739f10947 *tests/testthat/test-node.R 2c67a6d164e84345676604d8e083e265 *tests/testthat/test-nse-defuse.R 394073bb1656b7fb3a86f48fcc26a779 *tests/testthat/test-nse-inject.R 18cceb00e279a71a3b6658c7be5b433e *tests/testthat/test-obj.R 6e8559b1ff84952b4611d235f5f19a37 *tests/testthat/test-operators.R 763c3b3df1681bddd39fe347a3dca8b9 *tests/testthat/test-parent-errors.Rmd 30a440dbdefe42d7e01399ca974d753c *tests/testthat/test-parse.R a0907b64d582856e08b2683e4120fd67 *tests/testthat/test-quo.R 9b5fcad3895f42f389b18c755e9d4dd1 *tests/testthat/test-raw.R 47115f98191dc51108c2acbb74da4f1d *tests/testthat/test-s3.R 83e582cfa4c21a46d473b9e94425bad3 *tests/testthat/test-session.R 507cdddc0c4b741a528c2b5930971ca2 *tests/testthat/test-stack.R a3863a6a1f98b35d1b9bf06a26a4ae7b *tests/testthat/test-standalone-cli.R f1b3b8e1ba47b794f0e4157d979ac825 *tests/testthat/test-standalone-downstream-deps.R cb407c903b426e5b6e53fbc934822f9a *tests/testthat/test-standalone-obj-type.R 088a84317df507d0867e7a1f13009c4b *tests/testthat/test-standalone-purrr.R e7dcfa9e8275abaee417a1937d768917 *tests/testthat/test-standalone-rlang.R b3cd0d7565345fff425d5d7c35c0ce30 *tests/testthat/test-standalone-s3-register.R 1919fe322ad918d1e82d0accdff2ea72 *tests/testthat/test-standalone-types-check.R 03759e1ffb4c97d4faed056a78a1e555 *tests/testthat/test-standalone-vctrs.R 118fdca850c936ea6594cb4d5dcb3ba3 *tests/testthat/test-standalone-zeallot.R 0a55d24ab0a36e048f4ae92751d27294 *tests/testthat/test-standalone.R 338286a6cca19f833d8c7b7d2b8dbcb2 *tests/testthat/test-state.R a1f2e44398700558882d15c4503588a8 *tests/testthat/test-sym.R 9f2a88c97bd5e662127f5255c59eb104 *tests/testthat/test-trace-full.Rmd 127025b46395d9c34334417e78b9a59d *tests/testthat/test-trace.R b37cbdb161077277d03ece18960cf5a7 *tests/testthat/test-trace.Rmd 234248e3e74b43f3e5b6041f1ba01469 *tests/testthat/test-types.R 9a85ae43ce30a46b69fcc86c8792e3c1 *tests/testthat/test-utils.R fcbf18c3edc78c2b4a83015ea0335955 *tests/testthat/test-vec-new.R c53fedcc096fc0e78885803eb08203e2 *tests/testthat/test-vec-utils.R 4560ac6208a606a5cc7e7051f08e04bc *tests/testthat/test-vec.R f168bd3cece49da38f0b38fb4534aa9a *tests/testthat/test-weakref.R rlang/R/0000755000176200001440000000000014742414044011562 5ustar liggesusersrlang/R/dots-ellipsis.R0000644000176200001440000001676514626342040014514 0ustar liggesusers#' Check that all dots have been used #' #' When `...` arguments are passed to methods, it is assumed there #' method will match and use these arguments. If this isn't the case, #' this often indicates a programming error. Call `check_dots_used()` #' to fail with an error when unused arguments are detected. #' #' @param error An optional error handler passed to [try_fetch()]. Use #' this e.g. to demote an error into a warning. #' @param action `r lifecycle::badge("deprecated")` #' @param env Environment in which to look for `...` and to set up handler. #' @inheritParams args_error_context #' #' @family dots checking functions #' @details #' In packages, document `...` with this standard tag: #' #' ``` #' @@inheritParams rlang::args_dots_used #' ``` #' #' `check_dots_used()` implicitly calls [on.exit()] to check that all #' elements of `...` have been used when the function exits. If you #' use [on.exit()] elsewhere in your function, make sure to use `add = #' TRUE` so that you don't override the handler set up by #' `check_dots_used()`. #' #' @examples #' f <- function(...) { #' check_dots_used() #' g(...) #' } #' #' g <- function(x, y, ...) { #' x + y #' } #' f(x = 1, y = 2) #' #' try(f(x = 1, y = 2, z = 3)) #' #' try(f(x = 1, y = 2, 3, 4, 5)) #' #' # Use an `error` handler to handle the error differently. #' # For instance to demote the error to a warning: #' fn <- function(...) { #' check_dots_empty( #' error = function(cnd) { #' warning(cnd) #' } #' ) #' "out" #' } #' fn() #' #' @export check_dots_used <- function(env = caller_env(), call = caller_env(), error = NULL, action = deprecated()) { # Capture frame environment before `caller_env()` exits (#1448) force(call) handler <- function() check_dots(env, error, action, call) inject(base::on.exit(!!call2(handler), add = TRUE), env) invisible() } check_dots <- function(env = caller_env(), error, action, call) { if (.Call(ffi_ellipsis_dots_used, env)) { return(invisible()) } proms <- ellipsis_dots(env) unused <- !map_lgl(proms, promise_forced) action_dots( error = error, action = action, message = "Arguments in `...` must be used.", note = c("i" = "Did you misspell an argument name?"), dots_i = unused, class = "rlib_error_dots_unused", call = call, env = env ) } #' Check that all dots are unnamed #' #' In functions like `paste()`, named arguments in `...` are often a #' sign of misspelled argument names. Call `check_dots_unnamed()` to #' fail with an error when named arguments are detected. #' #' @inheritParams check_dots_used #' @family dots checking functions #' @param env Environment in which to look for `...`. #' @export #' @examples #' f <- function(..., foofy = 8) { #' check_dots_unnamed() #' c(...) #' } #' #' f(1, 2, 3, foofy = 4) #' #' try(f(1, 2, 3, foof = 4)) check_dots_unnamed <- function(env = caller_env(), error = NULL, call = caller_env(), action = abort) { if (.Call(ffi_has_dots_unnamed, env)) { return() } proms <- ellipsis_dots(env) unnamed <- names2(proms) == "" if (all(unnamed)) { return(invisible()) } named <- !unnamed action_dots( error = error, action = action, message = "Arguments in `...` must be passed by position, not name.", dots_i = named, class = "rlib_error_dots_named", call = call, env = env ) } #' Check that dots are empty #' #' `...` can be inserted in a function signature to force users to #' fully name the details arguments. In this case, supplying data in #' `...` is almost always a programming error. This function checks #' that `...` is empty and fails otherwise. #' #' @inheritParams check_dots_used #' @param env Environment in which to look for `...`. #' #' @family dots checking functions #' @details #' In packages, document `...` with this standard tag: #' #' ``` #' @@inheritParams rlang::args_dots_empty #' ``` #' #' @examples #' f <- function(x, ..., foofy = 8) { #' check_dots_empty() #' x + foofy #' } #' #' # This fails because `foofy` can't be matched positionally #' try(f(1, 4)) #' #' # This fails because `foofy` can't be matched partially by name #' try(f(1, foof = 4)) #' #' # Thanks to `...`, it must be matched exactly #' f(1, foofy = 4) #' #' @export check_dots_empty <- function(env = caller_env(), error = NULL, call = caller_env(), action = abort) { dots <- ellipsis_dots(env) n <- length(dots) if (n == 0) { return() } if (n == 1) { nms <- names(dots) no_name <- is_null(nms) || identical(nms[[n]], "") if (no_name && identical(dots[[n]], missing_arg())) { return() } } if (!is_named(dots)) { note <- c("i" = "Did you forget to name an argument?") } else { note <- NULL } action_dots( error = error, action = action, message = "`...` must be empty.", note = note, dots_i = TRUE, class = "rlib_error_dots_nonempty", call = call, env = env ) } #' Check that dots are empty (low level variant) #' #' `check_dots_empty0()` is a more efficient version of #' [check_dots_empty()] with a slightly different interface. Instead #' of inspecting the current environment for dots, it directly takes #' `...`. It is only meant for very low level functions where a #' couple microseconds make a difference. #' #' @param ... Dots which should be empty. #' @keywords internal #' @export check_dots_empty0 <- function(..., call = caller_env()) { if (nargs()) { check_dots_empty(call = call) } } action_dots <- function(error, action, message, dots_i, env, class = NULL, note = NULL, ...) { if (is_missing(action)) { action <- abort } else { # Silently deprecated for now paste_line( "The `action` argument of ellipsis functions is deprecated as of rlang 1.0.0.", "Please use the `error` argument instead." ) } dots <- substitute(...(), env = env)[dots_i] names(dots) <- ifelse( have_name(dots), names2(dots), paste0("..", seq_along(dots)) ) bullet_header <- ngettext( length(dots), "Problematic argument:", "Problematic arguments:", ) bullets <- map2_chr(names(dots), dots, function(name, expr) { sprintf("%s = %s", name, as_label(expr)) }) if (is_null(error)) { try_dots <- identity } else { try_dots <- function(expr) try_fetch(expr, error = error) } try_dots(action( c(message, "x" = bullet_header, set_names(bullets, "*"), note), class = c(class, "rlib_error_dots"), ... )) } promise_forced <- function(x) { .Call(ffi_ellipsis_promise_forced, x) } ellipsis_dots <- function(env = caller_env()) { .Call(ffi_ellipsis_dots, env) } #' Helper for consistent documentation of empty dots #' #' Use `@inheritParams rlang::args_dots_empty` in your package #' to consistently document `...` that must be empty. #' #' @param ... These dots are for future extensions and must be empty. #' @name args_dots_empty #' @keywords internal NULL #' Helper for consistent documentation of used dots #' #' Use `@inheritParams rlang::args_dots_used` in your package #' to consistently document `...` that must be used. #' #' @param ... Arguments passed to methods. #' @name args_dots_used #' @keywords internal NULL rlang/R/cnd-signal.R0000644000176200001440000002675514401326407013740 0ustar liggesusers #' Signal a condition object #' #' @description #' #' `cnd_signal()` takes a condition as argument and emits the #' corresponding signal. The type of signal depends on the class of #' the condition: #' #' * A message is signalled if the condition inherits from #' `"message"`. This is equivalent to signalling with [inform()] or #' [base::message()]. #' #' * A warning is signalled if the condition inherits from #' `"warning"`. This is equivalent to signalling with [warn()] or #' [base::warning()]. #' #' * An error is signalled if the condition inherits from #' `"error"`. This is equivalent to signalling with [abort()] or #' [base::stop()]. #' #' * An interrupt is signalled if the condition inherits from #' `"interrupt"`. This is equivalent to signalling with #' [interrupt()]. #' #' @param cnd A condition object (see [cnd()]). If `NULL`, #' `cnd_signal()` returns without signalling a condition. #' @inheritParams args_dots_empty #' @seealso #' * [cnd_type()] to determine the type of a condition. #' #' * [abort()], [warn()] and [inform()] for creating and signalling #' structured R conditions in one go. #' #' * [try_fetch()] for establishing condition handlers for #' particular condition classes. #' @export #' @examples #' # The type of signal depends on the class. If the condition #' # inherits from "warning", a warning is issued: #' cnd <- warning_cnd("my_warning_class", message = "This is a warning") #' cnd_signal(cnd) #' #' # If it inherits from "error", an error is raised: #' cnd <- error_cnd("my_error_class", message = "This is an error") #' try(cnd_signal(cnd)) cnd_signal <- function(cnd, ...) { check_dots_empty0(...) .__signal_frame__. <- TRUE if (is_null(cnd)) { return(invisible(NULL)) } switch( cnd_type(cnd), error = { if (is_environment(cnd$call)) { frame <- cnd$call cnd$call <- error_call(cnd$call) } else { frame <- caller_env() } if (is_null(cnd$trace)) { info <- abort_context(frame, rethrowing = !is_null(cnd$parent)) with_options( "rlang:::visible_bottom" = info$bottom_frame, { cnd$trace <- trace_back() } ) } signal_abort(cnd) }, warning = warning(cnd), message = message(cnd), interrupt = interrupt(), condition = invisible(withRestarts( rlang_muffle = function() NULL, signalCondition(cnd) )) ) } #' @rdname abort #' @param .frequency How frequently should the warning or message be #' displayed? By default (`"always"`) it is displayed at each #' time. If `"regularly"`, it is displayed once every 8 hours. If #' `"once"`, it is displayed once per session. #' @param .frequency_id A unique identifier for the warning or #' message. This is used when `.frequency` is supplied to recognise #' recurring conditions. This argument must be supplied if #' `.frequency` is not set to `"always"`. #' @export warn <- function(message = NULL, class = NULL, ..., body = NULL, footer = NULL, parent = NULL, use_cli_format = NULL, .inherit = NULL, .frequency = c("always", "regularly", "once"), .frequency_id = NULL, .subclass = deprecated()) { message <- validate_signal_args(message, class, NULL, .subclass, "warn") message_info <- cnd_message_info( message, body, footer, caller_env(), use_cli_format = use_cli_format ) message <- message_info$message extra_fields <- message_info$extra_fields use_cli_format <- message_info$use_cli_format .frequency <- arg_match0(.frequency, c("always", "regularly", "once")) if (!needs_signal(.frequency, .frequency_id, warning_freq_env, "rlib_warning_verbosity")) { return(invisible(NULL)) } if (!is_null(parent)) { # Don't inherit from `parent` by default if chained to a # downgraded error if (is_null(.inherit)) { .inherit <- !inherits(parent, "error") } extra_fields$rlang <- c( extra_fields$rlang, list(inherit = .inherit) ) } cnd <- warning_cnd( class, message = message, !!!extra_fields, use_cli_format = use_cli_format, parent = parent, ... ) cnd$footer <- c(cnd$footer, message_freq(message, .frequency, "warning")) local_long_messages() warning(cnd) } #' @rdname abort #' @export inform <- function(message = NULL, class = NULL, ..., body = NULL, footer = NULL, parent = NULL, use_cli_format = NULL, .inherit = NULL, .file = NULL, .frequency = c("always", "regularly", "once"), .frequency_id = NULL, .subclass = deprecated()) { message <- message %||% "" validate_signal_args(message, class, NULL, .subclass, "inform") message_info <- cnd_message_info( message, body, footer, caller_env(), use_cli_format = use_cli_format ) message <- message_info$message extra_fields <- message_info$extra_fields use_cli_format <- message_info$use_cli_format .frequency <- arg_match0(.frequency, c("always", "regularly", "once")) if (!needs_signal(.frequency, .frequency_id, message_freq_env, "rlib_message_verbosity")) { return(invisible(NULL)) } if (!is_null(parent)) { # Don't inherit from `parent` by default if chained to a # downgraded warning or error if (is_null(.inherit)) { .inherit <- !inherits(parent, c("warning", "error")) } extra_fields$rlang <- c( extra_fields$rlang, list(inherit = .inherit) ) } cnd <- message_cnd( class, message = message, !!!extra_fields, parent = parent, use_cli_format = use_cli_format, ... ) cnd$footer <- c(cnd$footer, message_freq(message, .frequency, "message")) withRestarts(muffleMessage = function() NULL, { signalCondition(cnd) msg <- paste0(conditionMessage(cnd), "\n") cat(msg, file = .file %||% default_message_file()) }) invisible() } #' @rdname abort #' @export signal <- function(message = "", class, ..., .subclass = deprecated()) { validate_signal_args(message, class, NULL, .subclass, "signal") message <- .rlang_cli_format_fallback(message) cnd <- cnd(class, ..., message = message) cnd_signal(cnd) } # Increase message length temporarily if it set to the default # value. The limit can quickly be hit if the message includes a lot of # ANSI escapes. local_long_messages <- function(..., frame = caller_env()) { if (peek_option("warning.length") == 1000) { local_options(warning.length = 8170, .frame = frame) } } default_message_file <- function() { opt <- peek_option("rlang:::message_file") if (!is_null(opt)) { return(opt) } if ((is_interactive() || is_rstudio()) && sink.number("output") == 0 && sink.number("message") == 2) { stdout() } else { stderr() } } is_rstudio <- function() { Sys.getenv("RSTUDIO_SESSION_PID") %in% c(Sys.getpid(), getppid()) } deprecate_subclass <- function(subclass, fn, env = caller_env()) { msg <- sprintf( "The %s argument of %s has been renamed to %s.", format_arg(".subclass"), format_fn(fn), format_arg("class") ) # 2022-01: Too many packages still use `.subclass` # - https://github.com/ropensci/jstor/issues/88 # - https://github.com/jacob-long/jtools/issues/118 # - https://github.com/tidyverse/tibble/issues/1015 # - https://github.com/r-lib/pkgload/issues/188 # - https://github.com/poissonconsulting/chk/issues/102 # - https://github.com/burchill/catchr/issues/8 # - https://github.com/cynkra/dm/issues/743 # - https://github.com/factset/analyticsapi-engines-r-sdk/issues/13 # - https://github.com/tidymodels/textrecipes/issues/152 # - https://github.com/NikKrieger/sociome/issues/14 # - https://github.com/r-lib/testthat/commit/f09df60dd881530332b252474e9f35c97f8640be if (is_true(peek_option("force_subclass_deprecation"))) { deprecate_soft(msg) } env_bind(env, class = subclass) } #' Simulate interrupt condition #' #' `interrupt()` simulates a user interrupt of the kind that is #' signalled with `Ctrl-C`. It is currently not possible to create #' custom interrupt condition objects. #' #' @keywords internal #' @export interrupt <- function() { .Call(ffi_interrupt) } validate_signal_args <- function(message, class, call, subclass, fn, env = caller_env()) { local_error_call("caller") if (!is_missing(subclass)) { deprecate_subclass(subclass, fn, env) } check_required(class, call = env) if (!is_missing(call)) { if (!is_null(call) && !is_environment(call) && !is_call(call)) { stop_input_type(call, "a call or environment", arg = "call", call = env) } } if (is_null(message) && is_null(class)) { abort("Either `message` or `class` must be supplied.", call = env) } message <- message %||% "" if (is_function(message)) { if (!"..." %in% names(formals(message))) { abort("`cnd_header()` methods must take `...`.", call = env) } } else { check_character(message, call = env) } if (!is_null(class)) { check_character(class, call = env) } message } warning_freq_env <- new.env(parent = emptyenv()) message_freq_env <- new.env(parent = emptyenv()) needs_signal <- function(frequency, id, env, opt) { local_error_call("caller") switch( peek_verbosity(opt), verbose = return(TRUE), quiet = return(FALSE), default = NULL ) if (is_string(frequency, "always")) { return(TRUE) } # Safe to remove in 2022 if (is_true(peek_option("rlang:::message_always"))) { return(TRUE) } if (is_null(id)) { abort(sprintf( "%s must be supplied with %s.", format_arg(".frequency_id"), format_arg(".frequency") )) } check_name(id, arg = ".frequency") sentinel <- env[[id]] if (is_null(sentinel)) { env_poke(env, id, Sys.time()) return(TRUE) } if (is_string(frequency, "once")) { return(FALSE) } if (!inherits(sentinel, "POSIXct")) { abort("Expected `POSIXct` value.", .internal = TRUE) } # Signal every 8 hours (Sys.time() - sentinel) > (8 * 60 * 60) } peek_verbosity <- function(opt, call = caller_env()) { arg_match0( peek_option(opt) %||% "default", c("default", "verbose", "quiet"), opt, error_call = call ) } #' @rdname abort #' @param id The identifying string of the condition that was supplied #' as `.frequency_id` to `warn()` or `inform()`. #' @export reset_warning_verbosity <- function(id) { reset_verbosity(id, "warning") } #' @rdname abort #' @export reset_message_verbosity <- function(id) { reset_verbosity(id, "message") } reset_verbosity <- function(id, type = c("message", "warning")) { check_name(id) type <- arg_match(type) env <- switch( type, message = message_freq_env, warning = warning_freq_env ) env[[id]] <- NULL invisible(NULL) } message_freq <- function(message, frequency, type) { if (is_string(frequency, "always")) { return(chr()) } if (is_string(frequency, "regularly")) { info <- col_silver("This %s is displayed once every 8 hours.") } else { info <- col_silver("This %s is displayed once per session.") } sprintf(info, type) } rlang/R/stack.R0000644000176200001440000001305214375670676013034 0ustar liggesusers#' Get properties of the current or caller frame #' #' @description #' These accessors retrieve properties of frames on the call stack. #' The prefix indicates for which frame a property should be accessed: #' #' * From the current frame with `current_` accessors. #' * From a calling frame with `caller_` accessors. #' * From a matching frame with `frame_` accessors. #' #' The suffix indicates which property to retrieve: #' #' * `_fn` accessors return the function running in the frame. #' * `_call` accessors return the defused call with which the function #' running in the frame was invoked. #' * `_env` accessors return the execution environment of the function #' running in the frame. #' #' @param n The number of callers to go back. #' @param frame A frame environment of a currently running function, #' as returned by [caller_env()]. `NULL` is returned if the #' environment does not exist on the stack. #' #' @seealso [caller_env()] and [current_env()] #' @name stack NULL #' @rdname stack #' @export current_call <- function() { caller_call() } #' @rdname stack #' @export current_fn <- function() { caller_fn() } #' @rdname stack #' @export current_env <- function() { parent.frame() } #' @rdname stack #' @export caller_call <- function(n = 1) { check_number_whole(n) frame_call(caller_env(n + 1)) } #' @rdname stack #' @export caller_fn <- function(n = 1) { check_number_whole(n) frame_fn(caller_env(n + 1)) } #' @rdname stack #' @export caller_env <- function(n = 1) { parent.frame(n + 1) } #' @rdname stack #' @export frame_call <- function(frame = caller_env()) { check_environment(frame) frame_get(frame, sys.call) } #' @rdname stack #' @export frame_fn <- function(frame = caller_env()) { check_environment(frame) frame_get(frame, sys.function) } frame_get <- function(frame, accessor) { if (identical(frame, global_env())) { return(NULL) } # Match the oldest frame to find an actual execution environment if # it exists. Using the `eval_bare(call2(accessor), frame)` trick # would match from the bottom and might encounter `eval()` frames. frames <- eval_bare(call2(sys.frames), frame) for (i in seq_along(frames)) { if (identical(frames[[i]], frame)) { return(accessor(i)) } } NULL } # Respects the invariant: caller_env2() === evalq(caller_env2()) caller_env2 <- function(n = 1, error_call = caller_env()) { # Start from `current_env()` with `n + 1` because `caller_env()` # might not be on the stack parent <- sys_parent( n + 1, patch_eval = TRUE, frame = current_env(), error_call = error_call ) sys.frame(parent) } sys_parent <- function(n, patch_eval = FALSE, frame = caller_env(), error_call = caller_env()) { parents <- sys_parents(frame = frame) if (n > length(parents)) { msg <- sprintf( "%s can't be larger than the number of calling frames.", format_arg("n") ) abort(msg, call = error_call) } if (!length(parents)) { return(0L) } out <- length(parents) while (n && out) { if (patch_eval && identical(sys.function(out), prim_eval)) { out <- parents[[out - 1]] } out <- parents[[out]] n <- n - 1L } out } sys_parents <- function(frame = caller_env(), match_oldest = TRUE) { parents <- eval_bare(call2(sys.parents), frame) # Fix infloop parents caused by evaluation in non-frame environments parents[parents == seq_along(parents)] <- 0L if (match_oldest) { return(parents) } # Patch callers of frames that have the same environment which can # happens with frames created by `eval()`. When duplicates # environments are on the stack, `sys.parents()` returns the number # of the oldest frame instead of the youngest. We fix this here when # requested to be consistent with `parent.frame()`. frames <- as.list(sys.frames()) remaining_dups <- which(duplicated(frames) | duplicated(frames, fromLast = TRUE)) while (length(remaining_dups)) { dups <- which(map_lgl(frames, identical, frames[[remaining_dups[[1]]]])) remaining_dups <- setdiff(remaining_dups, dups) # We're going to patch the callers of duplicate frames so discard # any duplicate that doesn't have a caller dups <- dups[dups < length(parents)] parents[dups + 1L] <- dups } parents } #' Jump to or from a frame #' #' @description #' `r lifecycle::badge("questioning")` #' #' While [base::return()] can only return from the current local #' frame, `return_from()` will return from any frame on the #' current evaluation stack, between the global and the currently #' active context. #' #' @param frame An execution environment of a currently running #' function. #' @param value The return value. #' #' @keywords internal #' @export #' @examples #' fn <- function() { #' g(current_env()) #' "ignored" #' } #' g <- function(env) { #' h(env) #' "ignored" #' } #' h <- function(env) { #' return_from(env, "early return") #' "ignored" #' } #' #' fn() return_from <- function(frame, value = NULL) { eval_bare(expr(return(!!value)), frame) } #' Inspect a call #' #' This function is a wrapper around [base::match.call()]. It returns #' its own function call. #' #' @param ... Arguments to display in the returned call. #' @export #' @examples #' # When you call it directly, it simply returns what you typed #' call_inspect(foo(bar), "" %>% identity()) #' #' # Pass `call_inspect` to functionals like `lapply()` or `map()` to #' # inspect the calls they create around the supplied function #' lapply(1:3, call_inspect) call_inspect <- function(...) match.call() rlang/R/parse.R0000644000176200001440000001203614422712073013017 0ustar liggesusers#' Parse R code #' #' @description #' These functions parse and transform text into R expressions. This #' is the first step to interpret or evaluate a piece of R code #' written by a programmer. #' #' * `parse_expr()` returns one expression. If the text contains more #' than one expression (separated by semicolons or new lines), an #' error is issued. On the other hand `parse_exprs()` can handle #' multiple expressions. It always returns a list of expressions #' (compare to [base::parse()] which returns a base::expression #' vector). All functions also support R connections. #' #' * `parse_expr()` concatenates `x` with `\\n` separators prior to #' parsing in order to support the roundtrip #' `parse_expr(expr_deparse(x))` (deparsed expressions might be #' multiline). On the other hand, `parse_exprs()` doesn't do any #' concatenation because it's designed to support named inputs. The #' names are matched to the expressions in the output, which is #' useful when a single named string creates multiple expressions. #' #' In other words, `parse_expr()` supports vector of lines whereas #' `parse_exprs()` expects vectors of complete deparsed expressions. #' #' * `parse_quo()` and `parse_quos()` are variants that create a #' [quosure][quo]. Supply `env = current_env()` if you're parsing #' code to be evaluated in your current context. Supply `env = #' global_env()` when you're parsing external user input to be #' evaluated in user context. #' #' Unlike quosures created with [enquo()], [enquos()], or `{{`, a #' parsed quosure never contains injected quosures. It is thus safe #' to evaluate them with `eval()` instead of [eval_tidy()], though #' the latter is more convenient as you don't need to extract `expr` #' and `env`. #' #' @details #' Unlike [base::parse()], these functions never retain source reference #' information, as doing so is slow and rarely necessary. #' #' @param x Text containing expressions to parse_expr for #' `parse_expr()` and `parse_exprs()`. Can also be an R connection, #' for instance to a file. If the supplied connection is not open, #' it will be automatically closed and destroyed. #' @return `parse_expr()` returns an [expression][is_expression], #' `parse_exprs()` returns a list of expressions. Note that for the #' plural variants the length of the output may be greater than the #' length of the input. This would happen is one of the strings #' contain several expressions (such as `"foo; bar"`). The names of #' `x` are preserved (and recycled in case of multiple expressions). #' The `_quo` suffixed variants return quosures. #' @seealso [base::parse()] #' @export #' @examples #' # parse_expr() can parse any R expression: #' parse_expr("mtcars %>% dplyr::mutate(cyl_prime = cyl / sd(cyl))") #' #' # A string can contain several expressions separated by ; or \n #' parse_exprs("NULL; list()\n foo(bar)") #' #' # Use names to figure out which input produced an expression: #' parse_exprs(c(foo = "1; 2", bar = "3")) #' #' # You can also parse source files by passing a R connection. Let's #' # create a file containing R code: #' path <- tempfile("my-file.R") #' cat("1; 2; mtcars", file = path) #' #' # We can now parse it by supplying a connection: #' parse_exprs(file(path)) parse_expr <- function(x) { if (is_character(x)) { exprs <- chr_parse(paste_line(x)) } else { exprs <- parse_exprs(x) } n <- length(exprs) if (n != 1) { abort(sprintf( "%s must contain exactly 1 expression, not %d.", format_arg("x"), n )) } exprs[[1]] } #' @rdname parse_expr #' @export parse_exprs <- function(x) { if (inherits(x, "connection")) { if (!isOpen(x)) { open(x) on.exit(close(x)) } exprs <- parse(file = x, keep.source = FALSE) } else if (is.character(x)) { exprs <- chr_parse_exprs(x) } else { stop_input_type(x, "a character vector or an R connection") } as.list(exprs) } chr_parse_exprs <- function(x) { parsed <- map(x, function(elt) as.list(chr_parse(elt))) nms <- names(parsed) parsed <- unname(parsed) if (!is_null(nms)) { nms <- list_c(map2(parsed, nms, rep_along)) } if (length(parsed)) { parsed <- list_c(parsed) } set_names(parsed, nms) } chr_parse <- function(x) { # Never keep sources, because they get dropped anyways when combining # multiple expressions together, and keeping them here is very slow parse(text = x, keep.source = FALSE) } #' @rdname parse_expr #' @param env The environment for the quosures. The [global #' environment][global_env] (the default) may be the right choice #' when you are parsing external user inputs. You might also want to #' evaluate the R code in an isolated context (perhaps a child of #' the global environment or of the [base environment][base_env]). #' @export parse_quo <- function(x, env) { check_required(env) new_quosure(parse_expr(x), as_environment(env)) } #' @rdname parse_expr #' @export parse_quos <- function(x, env) { check_required(env) out <- map(parse_exprs(x), new_quosure, env = as_environment(env)) new_quosures(out) } rlang/R/nse-inject.R0000644000176200001440000003644414422714366013764 0ustar liggesusers#' Injection operator `!!` #' #' @description #' #' The [injection][topic-inject] operator `!!` injects a value or #' expression inside another expression. In other words, it modifies a #' piece of code before R evaluates it. #' #' There are two main cases for injection. You can inject constant #' values to work around issues of [scoping #' ambiguity][topic-data-mask-ambiguity], and you can inject [defused #' expressions][topic-defuse] like [symbolised][sym] column names. #' #' #' @section Where does `!!` work?: #' #' `!!` does not work everywhere, you can only use it within certain #' special functions: #' #' - Functions taking [defused][topic-defuse] and #' [data-masked][topic-data-mask] arguments. #' #' Technically, this means function arguments defused with #' `r link("{{")` or `en`-prefixed operators like #' [enquo()], [enexpr()], etc. #' #' - Inside [inject()]. #' #' All data-masking verbs in the tidyverse support injection operators #' out of the box. With base functions, you need to use [inject()] to #' enable `!!`. Using `!!` out of context may lead to incorrect #' results, see `r link("topic_inject_out_of_context")`. #' #' The examples below are built around the base function [with()]. #' Since it's not a tidyverse function we will use [inject()] to enable #' `!!` usage. #' #' #' @section Injecting values: #' #' Data-masking functions like [with()] are handy because you can #' refer to column names in your computations. This comes at the price #' of data mask ambiguity: if you have defined an env-variable of the #' same name as a data-variable, you get a name collisions. This #' collision is always resolved by giving precedence to the #' data-variable (it masks the env-variable): #' #' ```{r, comment = "#>", collapse = TRUE} #' cyl <- c(100, 110) #' with(mtcars, mean(cyl)) #' ``` #' #' The injection operator offers one way of solving this. Use it to #' inject the env-variable inside the data-masked expression: #' #' ```{r, comment = "#>", collapse = TRUE} #' inject( #' with(mtcars, mean(!!cyl)) #' ) #' ``` #' #' Note that the [`.env`] pronoun is a simpler way of solving the #' ambiguity. See `r link("topic_data_mask_ambiguity")` for more about #' this. #' #' #' @section Injecting expressions: #' #' Injection is also useful for modifying parts of a [defused #' expression][topic-defuse]. In the following example we use the #' [symbolise-and-inject pattern][topic-metaprogramming] to #' inject a column name inside a data-masked expression. #' #' ```{r, comment = "#>", collapse = TRUE} #' var <- sym("cyl") #' inject( #' with(mtcars, mean(!!var)) #' ) #' ``` #' #' Since [with()] is a base function, you can't inject #' [quosures][topic-quosure], only naked symbols and calls. This #' isn't a problem here because we're injecting the name of a data #' frame column. If the environment is important, try injecting a #' pre-computed value instead. #' #' #' @section When do I need `!!`?: #' #' With tidyverse APIs, injecting expressions with `!!` is no longer a #' common pattern. First, the [`.env`][.env] pronoun solves the #' ambiguity problem in a more intuitive way: #' #' ```r #' cyl <- 100 #' mtcars %>% dplyr::mutate(cyl = cyl * .env$cyl) #' ``` #' #' Second, the embrace operator `r link("{{")` makes the #' [defuse-and-inject pattern][topic-metaprogramming] easier to #' learn and use. #' #' ```r #' my_mean <- function(data, var) { #' data %>% dplyr::summarise(mean({{ var }})) #' } #' #' # Equivalent to #' my_mean <- function(data, var) { #' data %>% dplyr::summarise(mean(!!enquo(var))) #' } #' ``` #' #' `!!` is a good tool to learn for advanced applications but our #' hope is that it isn't needed for common data analysis cases. #' #' #' @seealso #' - `r link("topic_inject")` #' - `r link("topic_metaprogramming")` #' #' @name injection-operator #' @aliases bang-bang NULL #' @rdname injection-operator #' @usage NULL #' @export `!!` <- function(x) { abort("`!!` can only be used within a defused argument.", call = caller_env()) } #' Splice operator `!!!` #' #' @description #' #' The splice operator `!!!` implemented in [dynamic dots][dyn-dots] #' injects a list of arguments into a function call. It belongs to the #' family of [injection][topic-inject] operators and provides the same #' functionality as [do.call()]. #' #' The two main cases for splice injection are: #' #' - Turning a list of inputs into distinct arguments. This is #' especially useful with functions that take data in `...`, such as #' [base::rbind()]. #' #' ```r #' dfs <- list(mtcars, mtcars) #' inject(rbind(!!!dfs)) #' ``` #' #' - Injecting [defused expressions][topic-defuse] like #' [symbolised][sym] column names. #' #' For tidyverse APIs, this second case is no longer as useful #' since dplyr 1.0 and the `across()` operator. #' #' #' @section Where does `!!!` work?: #' #' `!!!` does not work everywhere, you can only use it within certain #' special functions: #' #' - Functions taking [dynamic dots][dyn-dots] like [list2()]. #' - Functions taking [defused][topic-defuse] and #' [data-masked][topic-data-mask] arguments, which are dynamic by #' default. #' - Inside [inject()]. #' #' Most tidyverse functions support `!!!` out of the box. With base #' functions you need to use [inject()] to enable `!!!`. #' #' Using the operator out of context may lead to incorrect results, #' see `r link("topic_inject_out_of_context")`. #' #' #' @section Splicing a list of arguments: #' #' Take a function like [base::rbind()] that takes data in `...`. This #' sort of functions takes a variable number of arguments. #' #' ```{r, comment = "#>", collapse = TRUE} #' df1 <- data.frame(x = 1) #' df2 <- data.frame(x = 2) #' #' rbind(df1, df2) #' ``` #' #' Passing individual arguments is only possible for a fixed amount of #' arguments. When the arguments are in a list whose length is #' variable (and potentially very large), we need a programmatic #' approach like the splicing syntax `!!!`: #' #' ```{r, comment = "#>", collapse = TRUE} #' dfs <- list(df1, df2) #' #' inject(rbind(!!!dfs)) #' ``` #' #' Because `rbind()` is a base function we used [inject()] to #' explicitly enable `!!!`. However, many functions implement [dynamic #' dots][list2] with `!!!` implicitly enabled out of the box. #' #' ```{r, include = FALSE} #' # Work around pkgload collision messages #' is_installed("tidyr") #' ```` #' #' ```{r, comment = "#>", collapse = TRUE} #' tidyr::expand_grid(x = 1:2, y = c("a", "b")) #' #' xs <- list(x = 1:2, y = c("a", "b")) #' tidyr::expand_grid(!!!xs) #' ``` #' #' Note how the expanded grid has the right column names. That's #' because we spliced a _named_ list. Splicing causes each name of the #' list to become an argument name. #' #' ```{r, comment = "#>", collapse = TRUE} #' tidyr::expand_grid(!!!set_names(xs, toupper)) #' ``` #' #' #' @section Splicing a list of expressions: #' #' Another usage for `!!!` is to inject [defused #' expressions][topic-defuse] into [data-masked][topic-data-mask] #' dots. However this usage is no longer a common pattern for #' programming with tidyverse functions and we recommend using other #' patterns if possible. #' #' First, instead of using the [defuse-and-inject #' pattern][topic-data-mask-programming] with `...`, you can simply pass #' them on as you normally would. These two expressions are completely #' equivalent: #' #' ```r #' my_group_by <- function(.data, ...) { #' .data %>% dplyr::group_by(!!!enquos(...)) #' } #' #' # This equivalent syntax is preferred #' my_group_by <- function(.data, ...) { #' .data %>% dplyr::group_by(...) #' } #' ``` #' #' Second, more complex applications such as [transformation #' patterns][topic-metaprogramming] can be solved with the `across()` #' operation introduced in dplyr 1.0. Say you want to take the #' `mean()` of all expressions in `...`. Before `across()`, you had to #' defuse the `...` expressions, wrap them in a call to `mean()`, and #' inject them in `summarise()`. #' #' ```r #' my_mean <- function(.data, ...) { #' # Defuse dots and auto-name them #' exprs <- enquos(..., .named = TRUE) #' #' # Wrap the expressions in a call to `mean()` #' exprs <- purrr::map(exprs, ~ call("mean", .x, na.rm = TRUE)) #' #' # Inject them #' .data %>% dplyr::summarise(!!!exprs) #' } #' ``` #' #' It is much easier to use `across()` instead: #' #' ```r #' my_mean <- function(.data, ...) { #' .data %>% dplyr::summarise(across(c(...), ~ mean(.x, na.rm = TRUE))) #' } #' ``` #' #' #' @section Performance of injected dots and dynamic dots: #' #' Take this [dynamic dots][dyn-dots] function: #' #' ```{r, comment = "#>", collapse = TRUE} #' n_args <- function(...) { #' length(list2(...)) #' } #' ``` #' #' Because it takes dynamic dots you can splice with `!!!` out of the #' box. #' #' ```{r, comment = "#>", collapse = TRUE} #' n_args(1, 2) #' #' n_args(!!!mtcars) #' ``` #' #' Equivalently you could enable `!!!` explicitly with [inject()]. #' #' ```{r, comment = "#>", collapse = TRUE} #' inject(n_args(!!!mtcars)) #' ``` #' #' While the result is the same, what is going on under the hood is #' completely different. [list2()] is a dots collector that #' special-cases `!!!` arguments. On the other hand, [inject()] #' operates on the language and creates a function call containing as #' many arguments as there are elements in the spliced list. If you #' supply a list of size 1e6, `inject()` is creating one million #' arguments before evaluation. This can be much slower. #' #' ```r #' xs <- rep(list(1), 1e6) #' #' system.time( #' n_args(!!!xs) #' ) #' #> user system elapsed #' #> 0.009 0.000 0.009 #' #' system.time( #' inject(n_args(!!!xs)) #' ) #' #> user system elapsed #' #> 0.445 0.012 0.457 #' ``` #' #' The same issue occurs when functions taking dynamic dots are called #' inside a data-masking function like `dplyr::mutate()`. The #' mechanism that enables `!!!` injection in these arguments is the #' same as in `inject()`. #' #' @seealso #' - `r link("topic_inject")` #' - [inject()] #' - [exec()] #' #' @name splice-operator NULL #' @rdname splice-operator #' @usage NULL #' @export `!!!` <- function(x) { abort("`!!!` can only be used within dynamic dots.", call = caller_env()) } #' Name injection with `"{"` and `"{{"` #' #' ```{r, child = "man/rmd/glue-operators.Rmd"} #' ``` #' #' @name glue-operators NULL #' Defuse function arguments with glue #' #' @description #' `englue()` creates a string with the [glue #' operators][glue-operators] `{` and `{{`. These operators are #' normally used to inject names within [dynamic dots][dyn-dots]. #' `englue()` makes them available anywhere within a function. #' #' `englue()` must be used inside a function. `englue("{{ var }}")` #' [defuses][topic-defuse] the argument `var` and transforms it to a #' string using the default name operation. #' #' @param x A string to interpolate with glue operators. #' @param env User environment where the interpolation data lives in #' case you're wrapping `englue()` in another function. #' @inheritParams args_error_context #' #' @details #' `englue("{{ var }}")` is equivalent to `as_label(enquo(var))`. It #' [defuses][topic-defuse] `arg` and transforms the expression to a #' string with [as_label()]. #' #' In dynamic dots, using only `{` is allowed. In `englue()` you must #' use `{{` at least once. Use `glue::glue()` for simple #' interpolation. #' #' Before using `englue()` in a package, first ensure that glue is #' installed by adding it to your `Imports:` section. #' #' ```r #' usethis::use_package("glue", "Imports") #' ``` #' #' @section Wrapping `englue()`: #' #' You can provide englue semantics to a user provided string by supplying `env`. #' In this example we create a variant of `englue()` that supports a #' special `.qux` pronoun by: #' #' - Creating an environment `masked_env` that inherits from the user #' env, the one where their data lives. #' #' - Overriding the `error_arg` and `error_call` arguments to point to #' our own argument name and call environment. This pattern is #' slightly different from usual error context passing because #' `englue()` is a backend function that uses its own error context #' by default (and not a checking function that uses _your_ error #' context by default). #' #' ```{r} #' my_englue <- function(text) { #' masked_env <- env(caller_env(), .qux = "QUX") #' #' englue( #' text, #' env = masked_env, #' error_arg = "text", #' error_call = current_env() #' ) #' } #' #' # Users can then use your wrapper as they would use `englue()`: #' fn <- function(x) { #' foo <- "FOO" #' my_englue("{{ x }}_{.qux}_{foo}") #' } #' #' fn(bar) #' ``` #' #' If you are creating a low level package on top of englue(), you #' should also consider exposing `env`, `error_arg` and `error_call` #' in your `englue()` wrapper so users can wrap your wrapper. #' #' @seealso #' - `r link("topic_inject")` #' #' @examples #' g <- function(var) englue("{{ var }}") #' g(cyl) #' g(1 + 1) #' g(!!letters) #' #' # These are equivalent to #' as_label(quote(cyl)) #' as_label(quote(1 + 1)) #' as_label(letters) #' #' @export englue <- function(x, env = caller_env(), error_call = current_env(), error_arg = "x") { check_string(x, arg = error_arg, call = error_call) glue_embrace(x, env = env) } glue_embrace <- function(text, env = caller_env()) { out <- glue_first_pass(text, env = env) out <- unstructure(glue::glue(out, .envir = env)) if (length(out) != 1) { msg <- sprintf( "The glue string must be size 1, not %s.", length(out) ) abort(msg, call = quote(englue())) } out } glue_first_pass <- function(text, env = caller_env()) { glue::glue( text, .open = "{{", .close = "}}", .transformer = function(...) glue_first_pass_eval(...), .envir = env ) } glue_first_pass_eval <- function(text, env) { text_expr <- parse_expr(text) defused_expr <- eval_bare(call2(enexpr, text_expr), env) if (is_symbol(text_expr) && is_missing(defused_expr)) { error_arg <- as_string(text_expr) error_call <- NULL # Find the relevant error frame. There are edge cases where this # will not be correct but passing the user error call makes things # too complex in the wrapping case. while (!identical(env, empty_env())) { if (env_has(env, error_arg)) { error_call <- env break } env <- env_parent(env) } check_required( defused_expr, arg = error_arg, call = error_call ) } as_label(defused_expr) } #' Show injected expression #' #' `qq_show()` helps examining [injected expressions][topic-inject] #' inside a function. This is useful for learning about injection and #' for debugging injection code. #' #' @usage NULL #' @param expr An expression involving [injection #' operators][topic-inject]. #' #' @section Examples: #' #' ```{r, child = "man/rmd/setup.Rmd", include = FALSE} #' ``` #' #' `qq_show()` shows the intermediary expression before it is #' evaluated by R: #' #' ```{r, comment = "#>", collapse = TRUE} #' list2(!!!1:3) #' #' qq_show(list2(!!!1:3)) #' ``` #' #' It is especially useful inside functions to reveal what an injected #' expression looks like: #' #' ```{r, comment = "#>", collapse = TRUE} #' my_mean <- function(data, var) { #' qq_show(data %>% dplyr::summarise(mean({{ var }}))) #' } #' #' mtcars %>% my_mean(cyl) #' ``` #' #' @seealso #' - `r link("topic_inject")` #' #' @export qq_show <- function(expr) { expr_print(enexpr(expr)) } rlang/R/attr.R0000644000176200001440000001713614741441060012664 0ustar liggesusers#' Is object named? #' #' @description #' #' * `is_named()` is a scalar predicate that checks that `x` has a #' `names` attribute and that none of the names are missing or empty #' (`NA` or `""`). #' #' * `is_named2()` is like `is_named()` but always returns `TRUE` for #' empty vectors, even those that don't have a `names` attribute. #' In other words, it tests for the property that each element of a #' vector is named. `is_named2()` composes well with [names2()] #' whereas `is_named()` composes with `names()`. #' #' * `have_name()` is a vectorised variant. #' #' @param x A vector to test. #' @return `is_named()` and `is_named2()` are scalar predicates that #' return `TRUE` or `FALSE`. `have_name()` is vectorised and returns #' a logical vector as long as the input. #' #' @details #' `is_named()` always returns `TRUE` for empty vectors because #' #' @examples #' # is_named() is a scalar predicate about the whole vector of names: #' is_named(c(a = 1, b = 2)) #' is_named(c(a = 1, 2)) #' #' # Unlike is_named2(), is_named() returns `FALSE` for empty vectors #' # that don't have a `names` attribute. #' is_named(list()) #' is_named2(list()) #' #' # have_name() is a vectorised predicate #' have_name(c(a = 1, b = 2)) #' have_name(c(a = 1, 2)) #' #' # Empty and missing names are treated as invalid: #' invalid <- set_names(letters[1:5]) #' names(invalid)[1] <- "" #' names(invalid)[3] <- NA #' #' is_named(invalid) #' have_name(invalid) #' #' # A data frame normally has valid, unique names #' is_named(mtcars) #' have_name(mtcars) #' #' # A matrix usually doesn't because the names are stored in a #' # different attribute #' mat <- matrix(1:4, 2) #' colnames(mat) <- c("a", "b") #' is_named(mat) #' names(mat) #' @export is_named <- function(x) { nms <- names(x) if (is_null(nms)) { return(FALSE) } if (any(detect_void_name(nms))) { return(FALSE) } TRUE } #' @rdname is_named #' @export is_named2 <- function(x) { nms <- names(x) if (is_null(nms)) { # Empty vectors are always named return(!length(x)) } if (any(detect_void_name(nms))) { return(FALSE) } TRUE } #' @rdname is_named #' @export have_name <- function(x) { nms <- names(x) if (is.null(nms)) { rep(FALSE, length(x)) } else { !detect_void_name(nms) } } detect_named <- have_name detect_void_name <- function(x) { x == "" | is.na(x) } #' Is a vector uniquely named? #' #' Like [is_named()] but also checks that names are unique. #' @param x A vector. #' @keywords internal #' @export is_dictionaryish <- function(x) { # 2022-01: Used in many packages. Don't deprecate without a # replacement. if (!length(x)) { return(!is.null(x)) } is_named(x) && !any(duplicated(names(x))) } #' Does an object have an element with this name? #' #' This function returns a logical value that indicates if a data #' frame or another named object contains an element with a specific #' name. Note that `has_name()` only works with vectors. For instance, #' environments need the specialised function [env_has()]. #' #' Unnamed objects are treated as if all names are empty strings. `NA` #' input gives `FALSE` as output. #' #' @param x A data frame or another named object #' @param name Element name(s) to check #' @return A logical vector of the same length as `name` #' @examples #' has_name(iris, "Species") #' has_name(mtcars, "gears") #' @export has_name <- function(x, name) { name %in% names2(x) } #' Set names of a vector #' #' @description #' #' This is equivalent to [stats::setNames()], with more features and #' stricter argument checking. #' #' #' @section Life cycle: #' #' `set_names()` is stable and exported in purrr. #' #' @param x Vector to name. #' @param nm,... Vector of names, the same length as `x`. If length 1, #' `nm` is recycled to the length of `x` following the recycling #' rules of the tidyverse.. #' #' You can specify names in the following ways: #' #' * If not supplied, `x` will be named to `as.character(x)`. #' #' * If `x` already has names, you can provide a function or formula #' to transform the existing names. In that case, `...` is passed #' to the function. #' #' * Otherwise if `...` is supplied, `x` is named to `c(nm, ...)`. #' #' * If `nm` is `NULL`, the names are removed (if present). #' @export #' @examples #' set_names(1:4, c("a", "b", "c", "d")) #' set_names(1:4, letters[1:4]) #' set_names(1:4, "a", "b", "c", "d") #' #' # If the second argument is ommitted a vector is named with itself #' set_names(letters[1:5]) #' #' # Alternatively you can supply a function #' set_names(1:10, ~ letters[seq_along(.)]) #' set_names(head(mtcars), toupper) #' #' # If the input vector is unnamed, it is first named after itself #' # before the function is applied: #' set_names(letters, toupper) #' #' # `...` is passed to the function: #' set_names(head(mtcars), paste0, "_foo") #' #' # If length 1, the second argument is recycled to the length of the first: #' set_names(1:3, "foo") #' set_names(list(), "") set_names <- function(x, nm = x, ...) { mold <- x .Call(ffi_set_names, x, mold, nm, environment()) } #' Get names of a vector #' #' @description #' `names2()` always returns a character vector, even when an #' object does not have a `names` attribute. In this case, it returns #' a vector of empty names `""`. It also standardises missing names to #' `""`. #' #' The replacement variant `names2<-` never adds `NA` names and #' instead fills unnamed vectors with `""`. #' #' @param x A vector. #' #' @examples #' names2(letters) #' #' # It also takes care of standardising missing names: #' x <- set_names(1:3, c("a", NA, "b")) #' names2(x) #' #' # Replacing names with the base `names<-` function may introduce #' # `NA` values when the vector is unnamed: #' x <- 1:3 #' names(x)[1:2] <- "foo" #' names(x) #' #' # Use the `names2<-` variant to avoid this #' x <- 1:3 #' names2(x)[1:2] <- "foo" #' names(x) #' #' @export names2 <- function(x) { .Call(ffi_names2, x, environment()) } #' @rdname names2 #' @param value New names. #' @export `names2<-` <- function(x, value) { if (is_null(names(x))) { names(x) <- names2(x) } names(x) <- value x } length_ <- function(x) { .Call(ffi_length, x) } #' How long is an object? #' #' This is a function for the common task of testing the length of an #' object. It checks the length of an object in a non-generic way: #' [base::length()] methods are ignored. #' #' @param x A R object. #' @param n A specific length to test `x` with. If `NULL`, #' `has_length()` returns `TRUE` if `x` has length greater than #' zero, and `FALSE` otherwise. #' @export #' @keywords internal #' @examples #' has_length(list()) #' has_length(list(), 0) #' #' has_length(letters) #' has_length(letters, 20) #' has_length(letters, 26) has_length <- function(x, n = NULL) { len <- .Call(ffi_length, x) if (is_null(n)) { as.logical(len) } else { len == n } } poke_attributes <- function(x, attrs) { .Call(ffi_poke_attrib, x, attrs) } #' Zap source references #' #' @description #' #' There are a number of situations where R creates source references: #' #' - Reading R code from a file with `source()` and `parse()` might save #' source references inside calls to `function` and `{`. #' - [sys.call()] includes a source reference if possible. #' - Creating a closure stores the source reference from the call to #' `function`, if any. #' #' These source references take up space and might cause a number of #' issues. `zap_srcref()` recursively walks through expressions and #' functions to remove all source references. #' #' @param x An R object. Functions and calls are walked recursively. #' #' @export zap_srcref <- function(x) { .Call(ffi_zap_srcref, x) } rlang/R/doc-data-masking.R0000644000176200001440000000663214741441060015014 0ustar liggesusers# Include a link to the following data-masking doc by prefixing an # argument anchor with: <[`data-masking`][rlang::args_data_masking]> #' Argument type: data-masking #' #' @description #' This page describes the `` argument modifier which #' indicates that the argument uses tidy evaluation with **data masking**. #' If you've never heard of tidy evaluation before, start with #' `vignette("programming", package = "dplyr")`. #' #' #' # Key terms #' #' The primary motivation for tidy evaluation in tidyverse packages is that it #' provides **data masking**, which blurs the distinction between two types of #' variables: #' #' * __env-variables__ are "programming" variables and live in an environment. #' They are usually created with `<-`. Env-variables can be any type of R #' object. #' #' * __data-variables__ are "statistical" variables and live in a data frame. #' They usually come from data files (e.g. `.csv`, `.xls`), or are created by #' manipulating existing variables. Data-variables live inside data frames, #' so must be vectors. #' #' #' # General usage #' #' Data masking allows you to refer to variables in the "current" data frame #' (usually supplied in the `.data` argument), without any other prefix. #' It's what allows you to type (e.g.) `filter(diamonds, x == 0 & y == 0 & z == 0)` #' instead of `diamonds[diamonds$x == 0 & diamonds$y == 0 & diamonds$z == 0, ]`. #' #' #' # Indirection #' #' The main challenge of data masking arises when you introduce some #' indirection, i.e. instead of directly typing the name of a variable you #' want to supply it in a function argument or character vector. #' #' There are two main cases: #' #' * If you want the user to supply the variable (or function of variables) #' in a function argument, embrace the argument, e.g. `filter(df, {{ var }})`. #' #' ``` #' dist_summary <- function(df, var) { #' df %>% #' summarise(n = n(), min = min({{ var }}), max = max({{ var }})) #' } #' mtcars %>% dist_summary(mpg) #' mtcars %>% group_by(cyl) %>% dist_summary(mpg) #' ``` #' #' * If you have the column name as a character vector, use the `.data` #' pronoun, e.g. `summarise(df, mean = mean(.data[[var]]))`. #' #' ``` #' for (var in names(mtcars)) { #' mtcars %>% count(.data[[var]]) %>% print() #' } #' #' lapply(names(mtcars), function(var) mtcars %>% count(.data[[var]])) #' ``` #' #' (Note that the contents of `[[`, e.g. `var` above, is never evaluated #' in the data environment so you don't need to worry about a data-variable #' called `var` causing problems.) #' #' #' # Dot-dot-dot (...) #' #' When this modifier is applied to `...`, there is one other useful technique #' which solves the problem of creating a new variable with a name supplied by #' the user. Use the interpolation syntax from the glue package: `"{var}" := #' expression`. (Note the use of `:=` instead of `=` to enable this syntax). #' #' ``` #' var_name <- "l100km" #' mtcars %>% mutate("{var_name}" := 235 / mpg) #' ``` #' #' Note that `...` automatically provides indirection, so you can use it as is #' (i.e. without embracing) inside a function: #' #' ``` #' grouped_mean <- function(df, var, ...) { #' df %>% #' group_by(...) %>% #' summarise(mean = mean({{ var }})) #' } #' ``` #' #' @seealso #' - `r link("topic_data_mask")`. #' - `r link("topic_data_mask_programming")`. #' #' @keywords internal #' @name args_data_masking NULL rlang/R/formula.R0000644000176200001440000001376014375670676013402 0ustar liggesusers#' Create a formula #' #' @param lhs,rhs A call, name, or atomic vector. #' @param env An environment. #' @return A formula object. #' @seealso [new_quosure()] #' @export #' @examples #' new_formula(quote(a), quote(b)) #' new_formula(NULL, quote(b)) new_formula <- function(lhs, rhs, env = caller_env()) { .Call(ffi_new_formula, lhs, rhs, env) } #' Is object a formula? #' #' @description #' `is_formula()` tests whether `x` is a call to `~`. `is_bare_formula()` #' tests in addition that `x` does not inherit from anything else than #' `"formula"`. #' #' __Note__: When we first implemented `is_formula()`, we thought it #' best to treat unevaluated formulas as formulas by default (see #' section below). Now we think this default introduces too many edge #' cases in normal code. We recommend always supplying `scoped = #' TRUE`. Unevaluated formulas can be handled via a `is_call(x, "~")` #' branch. #' #' @param x An object to test. #' @param scoped A boolean indicating whether the quosure is scoped, #' that is, has a valid environment attribute and inherits from #' `"formula"`. If `NULL`, the scope is not inspected. #' @param lhs A boolean indicating whether the formula has a left-hand #' side. If `NULL`, the LHS is not inspected and `is_formula()` #' returns `TRUE` for both one- and two-sided formulas. #' #' @section Dealing with unevaluated formulas: #' At parse time, a formula is a simple call to `~` and it does not #' have a class or an environment. Once evaluated, the `~` call #' becomes a properly structured formula. Unevaluated formulas arise #' by quotation, e.g. `~~foo`, `quote(~foo)`, or `substitute(arg)` #' with `arg` being supplied a formula. Use the `scoped` argument to #' check whether the formula carries an environment. #' #' @examples #' is_formula(~10) #' is_formula(10) #' #' # If you don't supply `lhs`, both one-sided and two-sided formulas #' # will return `TRUE` #' is_formula(disp ~ am) #' is_formula(~am) #' #' # You can also specify whether you expect a LHS: #' is_formula(disp ~ am, lhs = TRUE) #' is_formula(disp ~ am, lhs = FALSE) #' is_formula(~am, lhs = TRUE) #' is_formula(~am, lhs = FALSE) #' #' # Handling of unevaluated formulas is a bit tricky. These formulas #' # are special because they don't inherit from `"formula"` and they #' # don't carry an environment (they are not scoped): #' f <- quote(~foo) #' f_env(f) #' #' # By default unevaluated formulas are treated as formulas #' is_formula(f) #' #' # Supply `scoped = TRUE` to ensure you have an evaluated formula #' is_formula(f, scoped = TRUE) #' #' # By default unevaluated formulas not treated as bare formulas #' is_bare_formula(f) #' #' # If you supply `scoped = TRUE`, they will be considered bare #' # formulas even though they don't inherit from `"formula"` #' is_bare_formula(f, scoped = TRUE) #' @export is_formula <- function(x, scoped = NULL, lhs = NULL) { .Call(ffi_is_formula, x, scoped, lhs) } #' @rdname is_formula #' @export is_bare_formula <- function(x, scoped = TRUE, lhs = NULL) { if (!is_formula(x, scoped = scoped, lhs = lhs)) { return(FALSE) } if (is_null(scoped)) { exp_class <- c("call", "formula") } else if (is_true(scoped)) { exp_class <- "formula" } else if (is_false(scoped)) { exp_class <- "call" } else { stop_input_type(scoped, "`NULL` or a logical value.") } is_string(class(x), exp_class) } #' Get or set formula components #' #' `f_rhs` extracts the righthand side, `f_lhs` extracts the lefthand #' side, and `f_env` extracts the environment. All functions throw an #' error if `f` is not a formula. #' #' @param f,x A formula #' @param value The value to replace with. #' @export #' @return `f_rhs` and `f_lhs` return language objects (i.e. atomic #' vectors of length 1, a name, or a call). `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) { if (is_quosure(f)) { signal_formula_access() return(quo_get_expr(f)) } .Call(ffi_f_rhs, f) } #' @export #' @rdname f_rhs `f_rhs<-` <- function(x, value) { if (is_quosure(x)) { signal_formula_access() return(quo_set_expr(x, value)) } check_formula(x, arg = "LHS") x[[length(x)]] <- value x } #' @export #' @rdname f_rhs f_lhs <- function(f) { if (is_quosure(f)) { signal_formula_access() abort("Can't retrieve the LHS of a quosure.") } .Call(ffi_f_lhs, f) } #' @export #' @rdname f_rhs `f_lhs<-` <- function(x, value) { if (is_quosure(x)) { signal_formula_access() abort("Can't set the LHS of a quosure.") } check_formula(x, arg = "LHS") if (length(x) < 3) { x <- duplicate(x) node_poke_cdr(x, pairlist(value, x[[2]])) } else { x[[2]] <- value } x } #' @export #' @rdname f_rhs f_env <- function(f) { if (is_quosure(f)) { signal_formula_access() return(quo_get_env(f)) } check_formula(f) attr(f, ".Environment") } #' @export #' @rdname f_rhs `f_env<-` <- function(x, value) { if (is_quosure(x)) { signal_formula_access() return(quo_set_env(x, value)) } if (!is_formula(x)) { abort("`f` must be a formula") } structure(x, .Environment = value) } #' Turn RHS of formula into a string or label #' #' Equivalent of [expr_text()] and [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) } #' @rdname f_text #' @export f_name <- function(x) { expr_name(f_rhs(x)) } #' @rdname f_text #' @export f_label <- function(x) { expr_label(f_rhs(x)) } signal_formula_access <- function() { if (is_true(peek_option("rlang:::warn_quosure_access"))) { warn( "Using formula accessors with quosures is soft-deprecated" ) } } rlang/R/session.R0000644000176200001440000002637214401326407013377 0ustar liggesusers#' Are packages installed in any of the libraries? #' #' @description #' These functions check that packages are installed with minimal side #' effects. If installed, the packages will be loaded but not #' attached. #' #' - `is_installed()` doesn't interact with the user. It simply #' returns `TRUE` or `FALSE` depending on whether the packages are #' installed. #' #' - In interactive sessions, `check_installed()` asks the user #' whether to install missing packages. If the user accepts, the #' packages are installed with `pak::pkg_install()` if available, or #' [utils::install.packages()] otherwise. If the session is non #' interactive or if the user chooses not to install the packages, #' the current evaluation is aborted. #' #' You can disable the prompt by setting the #' `rlib_restart_package_not_found` global option to `FALSE`. In that #' case, missing packages always cause an error. #' #' @param pkg The package names. Can include version requirements, #' e.g. `"pkg (>= 1.0.0)"`. #' @param reason Optional string indicating why is `pkg` needed. #' Appears in error messages (if non-interactive) and user prompts #' (if interactive). #' @param ... These dots must be empty. #' @param version Minimum versions for `pkg`. If supplied, must be the #' same length as `pkg`. `NA` elements stand for any versions. #' @param compare A character vector of comparison operators to use #' for `version`. If supplied, must be the same length as #' `version`. If `NULL`, `>=` is used as default for all #' elements. `NA` elements in `compare` are also set to `>=` by #' default. #' @return `is_installed()` returns `TRUE` if _all_ package names #' provided in `pkg` are installed, `FALSE` #' otherwise. `check_installed()` either doesn't return or returns #' `NULL`. #' #' @section Handling package not found errors: #' `check_installed()` signals error conditions of class #' `rlib_error_package_not_found`. The error includes `pkg` and #' `version` fields. They are vectorised and may include several #' packages. #' #' The error is signalled with a `rlib_restart_package_not_found` #' restart on the stack to allow handlers to install the required #' packages. To do so, add a [calling handler][withCallingHandlers] #' for `rlib_error_package_not_found`, install the required packages, #' and invoke the restart without arguments. This restarts the check #' from scratch. #' #' The condition is not signalled in non-interactive sessions, in the #' restarting case, or if the `rlib_restart_package_not_found` user #' option is set to `FALSE`. #' #' @export #' @examples #' is_installed("utils") #' is_installed(c("base", "ggplot5")) #' is_installed(c("base", "ggplot5"), version = c(NA, "5.1.0")) is_installed <- function(pkg, ..., version = NULL, compare = NULL) { check_dots_empty0(...) info <- pkg_version_info(pkg, version = version, compare = compare) all(detect_installed(info)) } detect_installed <- function(info) { # Internal mechanism for unit tests hook <- peek_option("rlang:::is_installed_hook") if (is_function(hook)) { return(all(hook(info$pkg, info$ver, info$cmp))) } out <- list_c(pmap(info, function(pkg, cmp, ver) { if (is_string(pkg, "base")) { # Special-case the base package because it is not locked on # older R versions is_fully_loaded <- TRUE } else { # Check that package is on disk in case it's been removed (#1561) is_fully_loaded <- is_on_disk(pkg) # Check for sealed namespaces to protect against `is_installed()` # being called from user hooks of `pkg` (#1378) is_fully_loaded <- is_fully_loaded && requireNamespace(pkg, quietly = TRUE) && env_is_locked(ns_env(pkg)) } if (is_fully_loaded) { is_na(ver) || exec(cmp, utils::packageVersion(pkg), ver) } else { FALSE } })) out %||% TRUE } is_on_disk <- function(pkg) { # A warning is emitted if the package was removed from disk suppressWarnings( nzchar(system.file(package = pkg)) ) } pkg_version_info <- function(pkg, version = NULL, compare = NULL, call = caller_env()) { check_pkg_version(pkg, version, compare, call = call) matches <- grepl(version_regex, pkg) pkg_info <- as_version_info(pkg[matches], call = call) info <- data_frame(pkg = pkg, cmp = na_chr, ver = na_chr) info <- vec_assign(info, matches, pkg_info) if (!is_null(version)) { has_version <- !detect_na(version) is_redundant <- has_version & matches if (any(is_redundant)) { elts <- encodeString(pkg[is_redundant], quote = '"') msg <- c( sprintf( "Can't supply version in both %s and %s.", format_arg("pkg"), format_arg("version") ), "x" = "Redundant versions:", set_names(elts, "*") ) abort(msg, call = call) } compare <- compare %||% ">=" compare <- compare %|% ">=" info$ver[has_version] <- version[has_version] info$cmp[has_version] <- compare } if (!all(detect_na(info$cmp) | info$cmp %in% c(">", ">=", "<", "<=", "=="))) { msg <- sprintf( '%s must be one of ">", ">=", "==" ,"<", or "<=".', format_arg("compare") ) abort(msg, call = call) } info } version_regex <- "(.*) \\((.*)\\)$" as_version_info <- function(pkg, call = caller_env()) { if (!length(pkg)) { return(data_frame(pkg = chr(), cmp = chr(), ver = chr())) } ver <- sub(version_regex, "\\2", pkg) ver <- strsplit(ver, " ") ok <- map_lgl(ver, is_character2, n = 2, missing = FALSE, empty = FALSE) if (!all(ok)) { abort( c( sprintf("Can't parse version in %s.", format_arg("pkg")), "x" = "Problematic versions:", set_names(pkg[!ok], "*"), "i" = "Example of expected version format: `rlang (>= 1.0.0)`." ), call = call ) } info <- set_names(transpose(ver), c("cmp", "ver")) info <- map(info, list_c) pkg <- sub(version_regex, "\\1", pkg) info <- c(list(pkg = pkg), info) new_data_frame(info, .class = "tbl") } #' @rdname is_installed #' @param action An optional function taking `pkg` and `...` #' arguments. It is called by `check_installed()` when the user #' chooses to update outdated packages. The function is passed the #' missing and outdated packages as a character vector of names. #' @inheritParams args_error_context #' @export check_installed <- function(pkg, reason = NULL, ..., version = NULL, compare = NULL, action = NULL, call = caller_env()) { check_dots_empty0(...) check_action(action) info <- pkg_version_info(pkg, version = version, compare = compare) needs_install <- !detect_installed(info) pkg <- info$pkg version <- info$ver compare <- info$cmp missing_pkgs <- pkg[needs_install] missing_vers <- version[needs_install] missing_cmps <- compare[needs_install] if (!length(missing_pkgs)) { return(invisible(NULL)) } cnd <- new_error_package_not_found( missing_pkgs, missing_vers, missing_cmps, reason = reason, call = call ) restart <- peek_option("rlib_restart_package_not_found") %||% TRUE if (!is_bool(restart)) { abort("`rlib_restart_package_not_found` must be a logical value.") } if (!is_interactive() || !restart || any(missing_cmps %in% c("<", "<="))) { stop(cnd) } if (signal_package_not_found(cnd)) { # A calling handler asked for a restart. Disable restarts and try # again. return(with_options( "rlib_restart_package_not_found" = FALSE, check_installed(pkg, reason, version = version, call = call) )) } header <- cnd_header(cnd) n <- length(missing_pkgs) question <- pluralise( n, "Would you like to install it?", "Would you like to install them?" ) question <- paste_line( paste0(ansi_info(), " ", header), paste0(ansi_cross(), " ", question), .trailing = TRUE ) if (is_true(peek_option("rlang:::check_installed_test_hook"))) { return(question) } cat(question) if (utils::menu(c("Yes", "No")) != 1) { # Pass condition in case caller sets up an `abort` restart invokeRestart("abort", cnd) } if (!is_null(action)) { action(missing_pkgs) } else if (is_installed("pak")) { pkg_install <- env_get(ns_env("pak"), "pkg_install") pkg_install(missing_pkgs, ask = FALSE) } else { utils::install.packages(missing_pkgs) } } check_pkg_version <- function(pkg, version, compare, call = caller_env()) { if (!is_character2(pkg, missing = FALSE, empty = FALSE)) { abort( sprintf( "%s must be a package name or a vector of package names.", format_arg("pkg") ), call = call ) } if (!is_null(version) && !is_character2(version, n = length(pkg), empty = FALSE)) { abort( sprintf( "%s must be `NULL` or a vector of versions the same length as %s.", format_arg("version"), format_arg("pkg") ), call = call ) } if (!is_null(compare)) { if (is_null(version) || any((!detect_na(compare)) & detect_na(version))) { msg <- sprintf( "%s must be supplied when %s is supplied.", format_arg("version"), format_arg("compare") ) abort(msg, call = call) } } } check_action <- function(action, call = caller_env()) { # Take `pkg`, `version`, and `compare`? if (!is_null(action)) { check_closure(action, call = call, allow_null = TRUE) if (!"..." %in% names(formals(action))) { msg <- sprintf( "%s must take a %s argument.", format_arg("action"), format_arg("...") ) abort(msg, call = call) } } } new_error_package_not_found <- function(pkg, version = NULL, compare = NULL, ..., reason = NULL, class = NULL) { error_cnd( class = c(class, "rlib_error_package_not_found"), pkg = pkg, version = version, compare = compare, reason = reason, ... ) } #' @export cnd_header.rlib_error_package_not_found <- function(cnd, ...) { pkg <- cnd$pkg version <- cnd$version compare <- cnd$compare reason <- cnd$reason n <- length(pkg) # Quote with `"` to make it easier to copy/paste (#1447) pkg_enum <- chr_quoted(cnd$pkg, type = "\"") if (!is_null(version)) { pkg_enum <- list_c(pmap(list(pkg_enum, compare, version), function(p, o, v) { if (is_na(v)) { p } else { sprintf("%s (%s %s)", p, o, v) } })) } pkg_enum <- oxford_comma(pkg_enum, final = "and") info <- pluralise( n, paste0("The package ", pkg_enum, " is required"), paste0("The packages ", pkg_enum, " are required") ) if (is_null(reason)) { paste0(info, ".") } else { paste(info, reason) } } signal_package_not_found <- function(cnd) { class(cnd) <- vec_remove(class(cnd), "error") withRestarts({ signalCondition(cnd) FALSE }, rlib_restart_package_not_found = function() { TRUE }) } rlang/R/obj.R0000644000176200001440000000524014741441060012455 0ustar liggesusers#' Duplicate an R object #' #' `duplicate()` is an interface to the C-level `duplicate()` and #' `shallow_duplicate()` functions. It is mostly meant for users of #' the C API of R, e.g. for debugging, experimenting, or prototyping C #' code in R. #' #' @param x An R object. Uncopyable objects like symbols and #' environments are returned as is (just like with `<-`). #' @param shallow Recursive data structures like lists, calls and #' pairlists are duplicated in full by default. A shallow copy only #' duplicates the top-level data structure. #' @seealso pairlist #' @keywords internal #' @export duplicate <- function(x, shallow = FALSE) { .Call(ffi_duplicate, x, shallow) } #' Address of an R object #' @param x Any R object. #' @return Its address in memory in a string. #' @keywords internal #' @export obj_address <- function(x) { .Call(ffi_obj_address, maybe_missing(x)) } # Imported from lifecycle sexp_address <- obj_address # nocov start - These functions are mostly for interactive experimentation poke_type <- function(x, type) { invisible(.Call(ffi_poke_type, x, type)) } sexp_named <- function(x) { # Don't use `substitute()` because dots might be forwarded arg <- match.call(expand.dots = FALSE)$x .Call(ffi_named, arg, parent.frame()) } mark_object <- function(x) { invisible(.Call(ffi_mark_object, x)) } unmark_object <- function(x) { invisible(.Call(ffi_unmark_object, x)) } true_length <- function(x) { .Call(ffi_true_length, x) } env_frame <- function(x) { .Call(ffi_env_frame, x) } env_hash_table <- function(x) { .Call(ffi_env_hash_table, x) } promise_expr <- function(name, env = caller_env()) { .Call(ffi_promise_expr, name, env) } promise_env <- function(name, env = caller_env()) { .Call(ffi_promise_env, name, env) } promise_value <- function(name, env = caller_env()) { .Call(ffi_promise_value, name, env) } c_warning <- function(msg) { .Call(ffi_test_Rf_warning, msg) } c_error <- function(msg) { .Call(ffi_test_Rf_error, msg) } warningcall <- function(call, msg) { .Call(ffi_test_Rf_warningcall, call, msg) } errorcall <- function(call, msg) { .Call(ffi_test_Rf_errorcall, call, msg) } obj_attrib <- function(x) { .Call(ffi_attrib, x) } vec_alloc <- function(type, n) { stopifnot( is_string(type), is_integer(n, 1) && is.finite(n) ) .Call(ffi_vec_alloc, type, n) } # Note that the C-level function has inverted arguments find_var <- function(env, sym) { .Call(ffi_find_var, env, sym); } find_var_in_frame <- function(env, sym) { .Call(ffi_find_var, env, sym); } chr_get <- function(x, i = 0L) { .Call(ffi_chr_get, x, i) } list_poke <- function(x, i, value) { .Call(ffi_list_poke, x, i, value) } # nocov end rlang/R/env-special.R0000644000176200001440000002142614515704003014113 0ustar liggesusers#' Search path environments #' #' @description #' #' The search path is a chain of environments containing exported #' functions of attached packages. #' #' The API includes: #' #' - [base::search()] to get the names of environments attached to the #' search path. #' #' - `search_envs()` returns the environments on the search path as a #' list. #' #' - `pkg_env_name()` takes a bare package name and prefixes it with #' `"package:"`. Attached package environments have search names of #' the form `package:name`. #' #' - `pkg_env()` takes a bare package name and returns the scoped #' environment of packages if they are attached to the search path, #' and throws an error otherwise. It is a shortcut for #' `search_env(pkg_env_name("pkgname"))`. #' #' - `global_env()` and `base_env()` (simple aliases for [globalenv()] #' and [baseenv()]). These are respectively the first and last #' environments of the search path. #' #' - `is_attached()` returns `TRUE` when its argument (a search name #' or a package environment) is attached to the search path. #' #' #' @section The search path: #' #' This chain of environments determines what objects are visible from #' the global workspace. It contains the following elements: #' #' - The chain always starts with `global_env()` and finishes with #' `base_env()` which inherits from the terminal environment #' `empty_env()`. #' #' - Each [base::library()] call attaches a new package environment to #' the search path. Attached packages are associated with a [search #' name][env_name]. #' #' - In addition, any list, data frame, or environment can be attached #' to the search path with [base::attach()]. #' #' #' @param name The name of an environment attached to the search #' path. Call [base::search()] to get the names of environments #' currently attached to the search path. Note that the search name #' of a package environment is prefixed with `"package:"`. #' #' @keywords internal #' @export #' @examples #' # List the search names of environments attached to the search path: #' search() #' #' # Get the corresponding environments: #' search_envs() #' #' # The global environment and the base package are always first and #' # last in the chain, respectively: #' envs <- search_envs() #' envs[[1]] #' envs[[length(envs)]] #' #' # These two environments have their own shortcuts: #' global_env() #' base_env() #' #' # Packages appear in the search path with a special name. Use #' # pkg_env_name() to create that name: #' pkg_env_name("rlang") #' search_env(pkg_env_name("rlang")) #' #' # Alternatively, get the scoped environment of a package with #' # pkg_env(): #' pkg_env("utils") search_envs <- function() { env_parents(env(.GlobalEnv), last = base_env()) } #' @rdname search_envs #' @export search_env <- function(name) { check_name(name) if (!is_attached(name)) { abort(paste_line( sprintf("`%s` is not attached.", name), "Do you need to prefix it with \"package:\"?" )) } as.environment(name) } #' @rdname search_envs #' @param pkg The name of a package. #' @export pkg_env <- function(pkg) { search_env(pkg_env_name(pkg)) } #' @rdname search_envs #' @export pkg_env_name <- function(pkg) { paste0("package:", pkg) } #' @rdname search_envs #' @param x An environment or a search name. #' @export is_attached <- function(x) { if (is_string(x)) { return(x %in% search()) } check_environment(x, what = "an environment or a name") env <- global_env() while (!is_reference(env, empty_env())) { if (is_reference(x, env)) { return(TRUE) } env <- env_parent(env) } FALSE } #' @rdname search_envs #' @export base_env <- baseenv #' @rdname search_envs #' @export global_env <- globalenv #' Get the empty environment #' #' The empty environment is the only one that does not have a parent. #' It is always used as the tail of an environment chain such as the #' search path (see [search_envs()]). #' #' @export #' @examples #' # Create environments with nothing in scope: #' child_env(empty_env()) empty_env <- emptyenv #' Get the namespace of a package #' #' Namespaces are the environment where all the functions of a package #' live. The parent environments of namespaces are the `imports` #' environments, which contain all the functions imported from other #' packages. #' #' @param x #' * For `ns_env()`, the name of a package or an environment as a #' string. #' * An environment (the current environment by default). #' * A function. #' #' In the latter two cases, the environment ancestry is searched for #' a namespace with [base::topenv()]. If the environment doesn't #' inherit from a namespace, this is an error. #' #' @seealso [pkg_env()] #' @keywords internal #' @export ns_env <- function(x = caller_env()) { env <- switch(typeof(x), builtin = , special = ns_env("base"), closure = topenv(fn_env(x)), environment = topenv(x), character = if (is_string(x)) asNamespace(x) ) if (!is_namespace(env)) { stop_input_type(x, "a package name or a function inheriting from a namespace") } env } #' @rdname ns_env #' @export ns_imports_env <- function(x = caller_env()) { env_parent(ns_env(x)) } #' @rdname ns_env #' @export ns_env_name <- function(x = caller_env()) { env <- switch(typeof(x), environment = , builtin = , special = , closure = ns_env(x), stop_input_type(x, "an environment or a function inheriting from a namespace") ) unname(getNamespaceName(env)) } ns_exports <- function(ns) getNamespaceExports(ns) ns_imports <- function(ns) getNamespaceImports(ns) ns_exports_has <- function(ns, name) { if (is_string(ns)) { if (!is_installed(ns)) { return(FALSE) } ns <- ns_env(ns) } if (is_reference(ns, ns_env("base"))) { exports <- base_pkg_env } else { exports <- ns$.__NAMESPACE__.$exports } !is_null(exports) && exists(name, envir = exports, inherits = FALSE) } ns_import_from <- function(ns, names, env = caller_env()) { objs <- env_get_list(ns_env(ns), names) env_bind(env, !!!objs) } #' Is an object a namespace environment? #' #' @param x An object to test. #' @export is_namespace <- function(x) { isNamespace(x) } env_type <- function(env) { if (is_reference(env, global_env())) { "global" } else if (is_reference(env, empty_env())) { "empty" } else if (is_reference(env, base_env())) { "base" } else { "local" } } friendly_env_type <- function(type) { switch(type, global = "the global environment", empty = "the empty environment", base = "the base environment", frame = "a frame environment", local = "a local environment", abort("Unknown environment type.", .internal = TRUE) ) } env_format <- function(env) { type <- env_type(env) if (type %in% c("frame", "local")) { addr <- obj_address(get_env(env)) type <- paste(type, addr) } type } #' Label of an environment #' #' @description #' #' Special environments like the global environment have their own #' names. `env_name()` returns: #' #' * "global" for the global environment. #' #' * "empty" for the empty environment. #' #' * "base" for the base package environment (the last environment on #' the search path). #' #' * "namespace:pkg" if `env` is the namespace of the package "pkg". #' #' * The `name` attribute of `env` if it exists. This is how the #' [package environments][search_envs] and the [imports #' environments][ns_imports_env] store their names. The name of package #' environments is typically "package:pkg". #' #' * The empty string `""` otherwise. #' #' `env_label()` is exactly like `env_name()` but returns the memory #' address of anonymous environments as fallback. #' #' @param env An environment. #' #' @export #' @examples #' # Some environments have specific names: #' env_name(global_env()) #' env_name(ns_env("rlang")) #' #' # Anonymous environments don't have names but are labelled by their #' # address in memory: #' env_name(env()) #' env_label(env()) env_name <- function(env) { check_environment(env) if (is_reference(env, global_env())) { return("global") } if (is_reference(env, base_env())) { return("package:base") } if (is_reference(env, empty_env())) { return("empty") } nm <- environmentName(env) if (is_namespace(env)) { return(paste0("namespace:", nm)) } nm } #' @rdname env_name #' @export env_label <- function(env) { nm <- env_name(env) if (nzchar(nm)) { nm } else { obj_address(env) } } #' Return the namespace registry env #' #' Note that the namespace registry does not behave like a normal #' environment because the parent is `NULL` instead of the empty #' environment. This is exported for expert usage in development tools #' only. #' #' @keywords internal #' @export ns_registry_env <- function() { .Call(ffi_ns_registry_env) } on_load({ base_ns_env <- ns_env("base") base_pkg_env <- baseenv() }) rlang/R/aaa.R0000644000176200001440000001205614603762135012436 0ustar liggesusersthe <- new.env(parent = emptyenv()) # `on_load()`, `run_on_load()`, and `on_package_load()` are # implemented in base-only compat style. # # Changelog: # # - 2021-09-24: # - Now base-only compat. # - `on_package_load()` checks that namespace is sealed. # # - 2021-05-07: Added `on_package_load()`. # # - 2021-04-29: `expr` is now evaluated in caller environment rather # than the top environment. #' Run expressions on load #' #' @description #' - `on_load()` registers expressions to be run on the user's machine #' each time the package is loaded in memory. This is by contrast to #' normal R package code which is run once at build time on the #' packager's machine (e.g. CRAN). #' #' `on_load()` expressions require `run_on_load()` to be called #' inside [.onLoad()]. #' #' - `on_package_load()` registers expressions to be run each time #' another package is loaded. #' #' `on_load()` is for your own package and runs expressions when the #' namespace is not _sealed_ yet. This means you can modify existing #' binding or create new ones. This is not the case with #' `on_package_load()` which runs expressions after a foreign package #' has finished loading, at which point its namespace is sealed. #' #' @param expr An expression to run on load. #' @param env The environment in which to evaluate `expr`. Defaults to #' the current environment, which is your package namespace if you #' run `on_load()` at top level. #' @param ns The namespace in which to hook `expr`. #' #' @section When should I run expressions on load?: #' There are two main use cases for running expressions on load: #' #' 1. When a side effect, such as registering a method with #' `s3_register()`, must occur in the user session rather than the #' package builder session. #' #' 2. To avoid hard-coding objects from other packages in your #' namespace. If you assign `foo::bar` or the result of #' `foo::baz()` in your package, they become constants. Any #' upstream changes in the `foo` package will not be reflected in #' the objects you've assigned in your namespace. This often breaks #' assumptions made by the authors of `foo` and causes all sorts of #' issues. #' #' Recreating the foreign objects each time your package is loaded #' makes sure that any such changes will be taken into account. In #' technical terms, running an expression on load introduces #' _indirection_. #' #' @section Comparison with `.onLoad()`: #' `on_load()` has the advantage that hooked expressions can appear in #' any file, in context. This is unlike `.onLoad()` which gathers #' disparate expressions in a single block. #' #' `on_load()` is implemented via `.onLoad()` and requires #' `run_on_load()` to be called from that hook. #' #' The expressions inside `on_load()` do not undergo static analysis #' by `R CMD check`. Therefore, it is advisable to only use #' simple function calls inside `on_load()`. #' #' @examples #' quote({ # Not run #' #' # First add `run_on_load()` to your `.onLoad()` hook, #' # then use `on_load()` anywhere in your package #' .onLoad <- function(lib, pkg) { #' run_on_load() #' } #' #' # Register a method on load #' on_load({ #' s3_register("foo::bar", "my_class") #' }) #' #' # Assign an object on load #' var <- NULL #' on_load({ #' var <- foo() #' }) #' #' # To use `on_package_load()` at top level, wrap it in `on_load()` #' on_load({ #' on_package_load("foo", message("foo is loaded")) #' }) #' #' # In functions it can be called directly #' f <- function() on_package_load("foo", message("foo is loaded")) #' #' }) #' @export on_load <- function(expr, env = parent.frame(), ns = topenv(env)) { expr <- substitute(expr) force(env) callback <- function() { # Evaluate with promise semantics rather than `base::eval()` do <- NULL do.call(delayedAssign, list("do", expr, env)) do } ns$.__rlang_hook__. <- c(ns$.__rlang_hook__., list(callback)) } #' @rdname on_load #' @export run_on_load <- function(ns = topenv(parent.frame())) { hook <- ns$.__rlang_hook__. rm(envir = ns, list = ".__rlang_hook__.") # FIXME: Transform to `while` loop to allow hooking into on-load # from an on-load hook? for (callback in hook) { callback() } } #' @rdname on_load #' @param pkg Package to hook expression into. #' @export on_package_load <- function(pkg, expr, env = parent.frame()) { expr <- substitute(expr) force(env) run <- function(...) { # Evaluate with promise semantics rather than `base::eval()` do <- NULL do.call(delayedAssign, list("do", expr, env)) do } # Always register hook in case package is later unloaded & reloaded setHook(packageEvent(pkg, "onLoad"), run) # For compatibility with R < 4.0 where base isn't locked is_sealed <- function(pkg) { identical(pkg, "base") || environmentIsLocked(asNamespace(pkg)) } # Run right away if package is already loaded but only if its # namespace is locked. The registering package might be a dependency # of `package`. In that case, `package` might not be fully populated # yet (#1225). if (isNamespaceLoaded(pkg) && is_sealed(pkg)) { run() } } rlang/R/node.R0000644000176200001440000001143014375670676012652 0ustar liggesusers#' Helpers for pairlist and language nodes #' #' @description #' #' **Important**: These functions are for expert R programmers only. #' You should only use them if you feel comfortable manipulating low #' level R data structures at the C level. We export them at the R level #' in order to make it easy to prototype C code. They don't perform #' any type checking and can crash R very easily (try to take the CAR #' of an integer vector --- save any important objects beforehand!). #' #' @param x A language or pairlist node. Note that these functions are #' barebones and do not perform any type checking. #' @param car,newcar,cdr,newcdr The new CAR or CDR for the node. These #' can be any R objects. #' @param newtag The new tag for the node. This should be a symbol. #' @return Setters like `node_poke_car()` invisibly return `x` modified #' in place. Getters return the requested node component. #' @seealso [duplicate()] for creating copy-safe objects and #' [base::pairlist()] for an easier way of creating a linked list of #' nodes. #' @keywords internal #' @export new_node <- function(car, cdr = NULL) { .Call(ffi_new_node, car, cdr) } #' @rdname new_node #' @export node_car <- function(x) { .Call(ffi_node_car, x) } #' @rdname new_node #' @export node_cdr <- function(x) { .Call(ffi_node_cdr, x) } #' @rdname new_node #' @export node_caar <- function(x) { .Call(ffi_node_caar, x) } #' @rdname new_node #' @export node_cadr <- function(x) { .Call(ffi_node_cadr, x) } #' @rdname new_node #' @export node_cdar <- function(x) { .Call(ffi_node_cdar, x) } #' @rdname new_node #' @export node_cddr <- function(x) { .Call(ffi_node_cddr, x) } #' @rdname new_node #' @export node_poke_car <- function(x, newcar) { invisible(.Call(ffi_node_poke_car, x, newcar)) } #' @rdname new_node #' @export node_poke_cdr <- function(x, newcdr) { invisible(.Call(ffi_node_poke_cdr, x, newcdr)) } #' @rdname new_node #' @export node_poke_caar <- function(x, newcar) { invisible(.Call(ffi_node_poke_caar, x, newcar)) } #' @rdname new_node #' @export node_poke_cadr <- function(x, newcar) { invisible(.Call(ffi_node_poke_cadr, x, newcar)) } #' @rdname new_node #' @export node_poke_cdar <- function(x, newcdr) { invisible(.Call(ffi_node_poke_cdar, x, newcdr)) } #' @rdname new_node #' @export node_poke_cddr <- function(x, newcdr) { invisible(.Call(ffi_node_poke_cddr, x, newcdr)) } node_get <- function(node, i) { if (i < 1L) { abort("`i` must be an integer greater than 0.") } while (i > 1L) { node <- node_cdr(node) i <- i - 1L } node } node_get_car <- function(node, i) { node_car(node_get(node, i)) } #' @rdname new_node #' @export node_tag <- function(x) { .Call(ffi_node_tag, x) } #' @rdname new_node #' @export node_poke_tag <- function(x, newtag) { invisible(.Call(ffi_node_poke_tag, x, newtag)) } #' Is object a node or pairlist? #' #' @description #' #' * `is_pairlist()` checks that `x` has type `pairlist`. #' #' * `is_node()` checks that `x` has type `pairlist` or `language`. #' It tests whether `x` is a node that has a CAR and a CDR, #' including callable nodes (language objects). #' #' * `is_node_list()` checks that `x` has type `pairlist` or `NULL`. #' `NULL` is the empty node list. #' #' #' @section Life cycle: #' #' These functions are experimental. We are still figuring out a good #' naming convention to refer to the different lisp-like lists in R. #' #' @param x Object to test. #' @seealso [is_call()] tests for language nodes. #' @keywords internal #' @export is_pairlist <- function(x) { typeof(x) == "pairlist" } #' @rdname is_pairlist #' @export is_node <- function(x) { typeof(x) %in% c("pairlist", "language") } #' @rdname is_pairlist #' @export is_node_list <- function(x) { typeof(x) %in% c("pairlist", "NULL") } # Shallow copy of node trees node_tree_clone <- function(x) { .Call(ffi_node_tree_clone, x); } node_walk <- function(.x, .f, ...) { cur <- .x while (!is.null(cur)) { .f(cur, ...) cur <- node_cdr(cur) } NULL } node_walk_nonnull <- function(.x, .f, ...) { cur <- .x out <- NULL while (!is.null(cur) && is.null(out)) { out <- .f(cur, ...) cur <- node_cdr(cur) } out } node_walk_last <- function(.x, .f, ...) { cur <- .x while (!is.null(node_cdr(cur))) { cur <- node_cdr(cur) } .f(cur, ...) } node_append <- function(.x, .y) { node_walk_last(.x, function(l) node_poke_cdr(l, .y)) .x } node_list_reverse <- function(x) { .Call(ffi_pairlist_rev, x) } #' Create a new call from components #' #' @param car The head of the call. It should be a #' [callable][is_callable] object: a symbol, call, or literal #' function. #' @param cdr The tail of the call, i.e. a [pairlist][new_node] of #' arguments. #' #' @keywords internal #' @export new_call <- function(car, cdr = NULL) { .Call(ffi_new_call, car, cdr) } rlang/R/utils-encoding.R0000644000176200001440000001202314375670676014650 0ustar liggesusers#' Coerce to a character vector and attempt encoding conversion #' #' @description #' #' `r lifecycle::badge("experimental")` #' #' Unlike specifying the `encoding` argument in `as_string()` and #' `as_character()`, which is only declarative, these functions #' actually attempt to convert the encoding of their input. There are #' two possible cases: #' #' * The string is tagged as UTF-8 or latin1, the only two encodings #' for which R has specific support. In this case, converting to the #' same encoding is a no-op, and converting to native always works #' as expected, as long as the native encoding, the one specified by #' the `LC_CTYPE` locale has support for all characters occurring in #' the strings. Unrepresentable characters are serialised as unicode #' points: "". #' #' * The string is not tagged. R assumes that it is encoded in the #' native encoding. Conversion to native is a no-op, and conversion #' to UTF-8 should work as long as the string is actually encoded in #' the locale codeset. #' #' When translating to UTF-8, the strings are parsed for serialised #' unicode points (e.g. strings looking like "U+xxxx") with #' [chr_unserialise_unicode()]. This helps to alleviate the effects of #' character-to-symbol-to-character roundtrips on systems with #' non-UTF-8 native encoding. #' #' @param x An object to coerce. #' @export #' @keywords internal #' @examples #' # Let's create a string marked as UTF-8 (which is guaranteed by the #' # Unicode escaping in the string): #' utf8 <- "caf\uE9" #' Encoding(utf8) #' charToRaw(utf8) as_utf8_character <- function(x) { .Call(ffi_unescape_character, as.character(x)) } # `as_utf8_character()` is currently used in dplyr and tidyr as an # interface for `chr_unserialise_unicode()` #' Translate unicode points to UTF-8 #' #' @description #' #' `r lifecycle::badge("experimental")` #' #' For historical reasons, R translates strings to the native encoding #' when they are converted to symbols. This string-to-symbol #' conversion is not a rare occurrence and happens for instance to the #' names of a list of arguments converted to a call by `do.call()`. #' #' If the string contains unicode characters that cannot be #' represented in the native encoding, R serialises those as an ASCII #' sequence representing the unicode point. This is why Windows users #' with western locales often see strings looking like ``. To #' alleviate some of the pain, rlang parses strings and looks for #' serialised unicode points to translate them back to the proper #' UTF-8 representation. This transformation occurs automatically in #' functions like [env_names()] and can be manually triggered with #' `as_utf8_character()` and `chr_unserialise_unicode()`. #' #' #' @section Life cycle: #' #' This function is experimental. #' #' @param chr A character vector. #' @export #' @keywords internal #' @examples #' ascii <- "" #' chr_unserialise_unicode(ascii) #' #' identical(chr_unserialise_unicode(ascii), "\u5e78") chr_unserialise_unicode <- function(chr) { stopifnot(is_character(chr)) .Call(ffi_unescape_character, chr) } #' Create a string #' #' @description #' #' `r lifecycle::badge("experimental")` #' #' These base-type constructors allow more control over the creation #' of strings in R. They take character vectors or string-like objects #' (integerish or raw vectors), and optionally set the encoding. The #' string version checks that the input contains a scalar string. #' #' @param x A character vector or a vector or list of string-like #' objects. #' @param encoding If non-null, set an encoding mark. This is only #' declarative, no encoding conversion is performed. #' @keywords internal #' @export #' @examples #' # As everywhere in R, you can specify a string with Unicode #' # escapes. The characters corresponding to Unicode codepoints will #' # be encoded in UTF-8, and the string will be marked as UTF-8 #' # automatically: #' cafe <- string("caf\uE9") #' Encoding(cafe) #' charToRaw(cafe) #' #' # In addition, string() provides useful conversions to let #' # programmers control how the string is represented in memory. For #' # encodings other than UTF-8, you'll need to supply the bytes in #' # hexadecimal form. If it is a latin1 encoding, you can mark the #' # string explicitly: #' cafe_latin1 <- string(c(0x63, 0x61, 0x66, 0xE9), "latin1") #' Encoding(cafe_latin1) #' charToRaw(cafe_latin1) string <- function(x, encoding = NULL) { if (is_integerish(x)) { x <- rawToChar(as.raw(x)) } else if (is_raw(x)) { x <- rawToChar(x) } else if (!is_string(x)) { stop_input_type(x, "a string or a raw vector") } if (!is_null(encoding)) { Encoding(x) <- encoding } x } cast_raw <- function(x, call = caller_env()) { if (is_integerish(x)) { as.raw(x) } else if (is_raw(x)) { x } else { abort("`...` must be numbers.", call = call) } } # Used in internal/vec.c legacy_as_raw <- function(x) { switch(typeof(x), raw = return(x), character = if (is_string(x)) return(charToRaw(x)) ) stop_input_type(x, "a string or a raw vector", call = NULL) } rlang/R/standalone-cli.R0000644000176200001440000004404214515703253014607 0ustar liggesusers# --- # repo: r-lib/rlang # file: standalone-cli.R # last-updated: 2023-10-06 # license: https://unlicense.org # --- # # Provides a minimal shim API to format message elements consistently # with cli in packages that can't depend on it. If available, cli is # used to format the elements. Otherwise a fallback format is used. # # ## Changelog # # 2023-10-06: # # * Speedup in `.rlang_cli_compat()`. # # 2022-09-23: # # * `format_` functions now use `cli::format_inline()` instead of # `cli::format_message()`, resulting in simpler ANSI codes. # # * Added `format_run()` and `format_href()`. # # # 2022-08-16: # # * Added `has_ansi()`. This checks that cli is installed and that # `cli::num_ansi_colors()` is greater than 1. # # * `col_` and `style_` functions now consistently return bare strings. # # # 2022-05-23: # # * Added compat for `style_hyperlink()`. # # # 2022-02-23: # # * Bullet formatting now ignores unknown bullet names, consistently # with cli. This increases resiliency against hard-to-detect errors # and improves forward compatibility. # # # 2022-02-22: # # * `format_error()` and variants now call cli even when ANSI colours # are disabled. # # * The fallback formatting for `.emph` and `.strong` no longer # surrounds in `_` or `*` characters. This is consistent with cli # formatting. # # # 2021-07-06: # # * Added missing `col_`, `bg_`, and `style_` functions. # # # 2021-05-18: # # * Added `symbol_` and corresponding `ansi_` functions to create # unicode symbols if possible. The `ansi_` variants apply default # colours to these symbols if possible. # # * Added `style_` functions to apply ANSI styling (colours, slant, weight). # # * Added `format_error()` and variants to format messages with # cli (including bullets). # # * Added `cli_escape()` to escape glue and cli syntax. # # * `mark_` functions now produce `{.cli input}` tags to be formatted # with one of the message formatter (such as `format_error()`). They # all have a `format_` variant that formats eagerly. Eager # formatting is easier to work with but might produce incorrect # styling in very specific cases involving sophisticated cli themes. # # # 2021-05-11: # # * Initial version. # # nocov start #' Create unicode symbols #' #' The `symbol_` functions generate Unicode symbols if cli is #' installed and Unicode is enabled. The corresponding `ansi_` #' functions apply default ANSI colours to these symbols if possible. #' #' @noRd symbol_info <- function() if (.rlang_cli_has_cli()) cli::symbol$info else "i" symbol_cross <- function() if (.rlang_cli_has_cli()) cli::symbol$cross else "x" symbol_tick <- function() if (.rlang_cli_has_cli()) cli::symbol$tick else "v" symbol_bullet <- function() if (.rlang_cli_has_cli()) cli::symbol$bullet else "*" symbol_arrow <- function() if (.rlang_cli_has_cli()) cli::symbol$arrow_right else ">" symbol_alert <- function() "!" ansi_info <- function() col_blue(symbol_info()) ansi_cross <- function() col_red(symbol_cross()) ansi_tick <- function() col_green(symbol_tick()) ansi_bullet <- function() col_cyan(symbol_bullet()) ansi_arrow <- function() symbol_arrow() ansi_alert <- function() col_yellow(symbol_alert()) #' Apply ANSI styling #' #' The `col_`, `bg_`, and `style_` functions style their inputs using #' the relevant ANSI escapes if cli is installed and ANSI colours are #' enabled. #' #' @param x A string. #' #' @noRd col_black <- function(x) if (.rlang_cli_has_cli()) .rlang_cli_unstructure(cli::col_black(x)) else x col_blue <- function(x) if (.rlang_cli_has_cli()) .rlang_cli_unstructure(cli::col_blue(x)) else x col_cyan <- function(x) if (.rlang_cli_has_cli()) .rlang_cli_unstructure(cli::col_cyan(x)) else x col_green <- function(x) if (.rlang_cli_has_cli()) .rlang_cli_unstructure(cli::col_green(x)) else x col_magenta <- function(x) if (.rlang_cli_has_cli()) .rlang_cli_unstructure(cli::col_magenta(x)) else x col_red <- function(x) if (.rlang_cli_has_cli()) .rlang_cli_unstructure(cli::col_red(x)) else x col_white <- function(x) if (.rlang_cli_has_cli()) .rlang_cli_unstructure(cli::col_white(x)) else x col_yellow <- function(x) if (.rlang_cli_has_cli()) .rlang_cli_unstructure(cli::col_yellow(x)) else x col_grey <- function(x) if (.rlang_cli_has_cli()) .rlang_cli_unstructure(cli::col_grey(x)) else x col_silver <- function(x) if (.rlang_cli_has_cli()) .rlang_cli_unstructure(cli::col_silver(x)) else x col_none <- function(x) if (.rlang_cli_has_cli()) .rlang_cli_unstructure(cli::col_none(x)) else x bg_black <- function(x) if (.rlang_cli_has_cli()) .rlang_cli_unstructure(cli::bg_black(x)) else x bg_blue <- function(x) if (.rlang_cli_has_cli()) .rlang_cli_unstructure(cli::bg_blue(x)) else x bg_cyan <- function(x) if (.rlang_cli_has_cli()) .rlang_cli_unstructure(cli::bg_cyan(x)) else x bg_green <- function(x) if (.rlang_cli_has_cli()) .rlang_cli_unstructure(cli::bg_green(x)) else x bg_magenta <- function(x) if (.rlang_cli_has_cli()) .rlang_cli_unstructure(cli::bg_magenta(x)) else x bg_red <- function(x) if (.rlang_cli_has_cli()) .rlang_cli_unstructure(cli::bg_red(x)) else x bg_white <- function(x) if (.rlang_cli_has_cli()) .rlang_cli_unstructure(cli::bg_white(x)) else x bg_yellow <- function(x) if (.rlang_cli_has_cli()) .rlang_cli_unstructure(cli::bg_yellow(x)) else x bg_none <- function(x) if (.rlang_cli_has_cli()) .rlang_cli_unstructure(cli::bg_none(x)) else x style_dim <- function(x) if (.rlang_cli_has_cli()) .rlang_cli_unstructure(cli::style_dim(x)) else x style_blurred <- function(x) if (.rlang_cli_has_cli()) .rlang_cli_unstructure(cli::style_blurred(x)) else x style_bold <- function(x) if (.rlang_cli_has_cli()) .rlang_cli_unstructure(cli::style_bold(x)) else x style_hidden <- function(x) if (.rlang_cli_has_cli()) .rlang_cli_unstructure(cli::style_hidden(x)) else x style_inverse <- function(x) if (.rlang_cli_has_cli()) .rlang_cli_unstructure(cli::style_inverse(x)) else x style_italic <- function(x) if (.rlang_cli_has_cli()) .rlang_cli_unstructure(cli::style_italic(x)) else x style_strikethrough <- function(x) if (.rlang_cli_has_cli()) .rlang_cli_unstructure(cli::style_strikethrough(x)) else x style_underline <- function(x) if (.rlang_cli_has_cli()) .rlang_cli_unstructure(cli::style_underline(x)) else x style_no_dim <- function(x) if (.rlang_cli_has_cli()) .rlang_cli_unstructure(cli::style_no_dim(x)) else x style_no_blurred <- function(x) if (.rlang_cli_has_cli()) .rlang_cli_unstructure(cli::style_no_blurred(x)) else x style_no_bold <- function(x) if (.rlang_cli_has_cli()) .rlang_cli_unstructure(cli::style_no_bold(x)) else x style_no_hidden <- function(x) if (.rlang_cli_has_cli()) .rlang_cli_unstructure(cli::style_no_hidden(x)) else x style_no_inverse <- function(x) if (.rlang_cli_has_cli()) .rlang_cli_unstructure(cli::style_no_inverse(x)) else x style_no_italic <- function(x) if (.rlang_cli_has_cli()) .rlang_cli_unstructure(cli::style_no_italic(x)) else x style_no_strikethrough <- function(x) if (.rlang_cli_has_cli()) .rlang_cli_unstructure(cli::style_no_strikethrough(x)) else x style_no_underline <- function(x) if (.rlang_cli_has_cli()) .rlang_cli_unstructure(cli::style_no_underline(x)) else x style_reset <- function(x) if (.rlang_cli_has_cli()) .rlang_cli_unstructure(cli::style_reset(x)) else x style_no_colour <- function(x) if (.rlang_cli_has_cli()) .rlang_cli_unstructure(cli::style_no_color(x)) else x style_no_bg_colour <- function(x) if (.rlang_cli_has_cli()) .rlang_cli_unstructure(cli::style_no_bg_color(x)) else x CLI_SUPPORT_HYPERLINK <- "2.2.0" CLI_SUPPORT_HYPERLINK_PARAMS <- "3.1.1" style_hyperlink <- function(text, url, params = NULL) { if (is.null(params)) { if (.rlang_cli_has_cli(CLI_SUPPORT_HYPERLINK)) { cli::style_hyperlink(text, url) } else { text } } else { if (.rlang_cli_has_cli(CLI_SUPPORT_HYPERLINK_PARAMS)) { cli::style_hyperlink(text, url, params = params) } else { text } } } #' Apply inline styling #' #' @description #' This set of `mark_` and `format_` functions create consistent #' inline styling, using cli if available or an ASCII fallback style #' otherwise. #' #' * The `mark_` functions wrap the input with mark up tags when cli #' is available. For instance, `"foo"` is transformed to `{.span #' {\"foo\"}}`. These marked up strings must eventually be formatted #' using a formatter such as `format_error()` to be styled #' appropriately. #' #' * The `format_` functions are easier to work with because they #' format the style eagerly. However they produce slightly incorrect #' style in corner cases because the formatting doesn't take into #' account the message type. In principle, cli themes can create #' different stylings depending on the message type. #' #' @param x A string. #' #' @noRd mark_emph <- function(x) .rlang_cli_style_inline(x, "emph", "_%s_") mark_strong <- function(x) .rlang_cli_style_inline(x, "strong", "*%s*") mark_code <- function(x) .rlang_cli_style_inline(x, "code", "`%s`") mark_q <- function(x) .rlang_cli_style_inline(x, "q", NULL) mark_pkg <- function(x) .rlang_cli_style_inline(x, "pkg", NULL) mark_fn <- function(x) .rlang_cli_style_inline(x, "fn", "`%s()`") mark_arg <- function(x) .rlang_cli_style_inline(x, "arg", "`%s`") mark_kbd <- function(x) .rlang_cli_style_inline(x, "kbd", "[%s]") mark_key <- function(x) .rlang_cli_style_inline(x, "key", "[%s]") mark_file <- function(x) .rlang_cli_style_inline(x, "file", NULL) mark_path <- function(x) .rlang_cli_style_inline(x, "path", NULL) mark_email <- function(x) .rlang_cli_style_inline(x, "email", NULL) mark_url <- function(x) .rlang_cli_style_inline(x, "url", "<%s>") mark_var <- function(x) .rlang_cli_style_inline(x, "var", "`%s`") mark_envvar <- function(x) .rlang_cli_style_inline(x, "envvar", "`%s`") mark_field <- function(x) .rlang_cli_style_inline(x, "field", NULL) mark_cls <- function(x) { fallback <- function(x) sprintf("<%s>", paste0(x, collapse = "/")) .rlang_cli_style_inline(x, "cls", fallback) } format_emph <- function(x) .rlang_cli_format_inline(x, "emph", "%s") format_strong <- function(x) .rlang_cli_format_inline(x, "strong", "%s") format_code <- function(x) .rlang_cli_format_inline(x, "code", "`%s`") format_q <- function(x) .rlang_cli_format_inline(x, "q", NULL) format_pkg <- function(x) .rlang_cli_format_inline(x, "pkg", NULL) format_fn <- function(x) .rlang_cli_format_inline(x, "fn", "`%s()`") format_arg <- function(x) .rlang_cli_format_inline(x, "arg", "`%s`") format_kbd <- function(x) .rlang_cli_format_inline(x, "kbd", "[%s]") format_key <- function(x) .rlang_cli_format_inline(x, "key", "[%s]") format_file <- function(x) .rlang_cli_format_inline(x, "file", NULL) format_path <- function(x) .rlang_cli_format_inline(x, "path", NULL) format_email <- function(x) .rlang_cli_format_inline(x, "email", NULL) format_url <- function(x) .rlang_cli_format_inline(x, "url", "<%s>") format_var <- function(x) .rlang_cli_format_inline(x, "var", "`%s`") format_envvar <- function(x) .rlang_cli_format_inline(x, "envvar", "`%s`") format_field <- function(x) .rlang_cli_format_inline(x, "field", NULL) format_href <- function(x, target = NULL) .rlang_cli_format_inline_link(x, target, "href", "<%s>") format_run <- function(x, target = NULL) .rlang_cli_format_inline_link(x, target, "run", "`%s`") format_error_arg_highlight <- function(x, quote = TRUE) { if (is_true(peek_option("rlang:::trace_test_highlight"))) { return(paste0("<>")) } out <- if (quote) format_arg(x) else x style_bold(cli::col_br_magenta(out)) } format_error_call_highlight <- function(x, quote = TRUE) { if (is_true(peek_option("rlang:::trace_test_highlight"))) { return(paste0("<>")) } out <- if (quote) format_code(x) else x style_bold(cli::col_br_blue(out)) } format_cls <- function(x) { fallback <- function(x) sprintf("<%s>", paste0(x, collapse = "/")) .rlang_cli_format_inline(x, "cls", fallback) } .rlang_cli_style_inline <- function(x, span, fallback = "`%s`") { if (.rlang_cli_has_cli()) { paste0("{.", span, " {\"", encodeString(x), "\"}}") } else if (is.null(fallback)) { x } else if (is.function(fallback)) { fallback(x) } else { sprintf(fallback, x) } } .rlang_cli_format_inline <- function(x, span, fallback = "`%s`") { if (.rlang_cli_has_cli()) { cli::format_inline(paste0("{.", span, " {x}}")) } else { .rlang_cli_style_inline(x, span, fallback = fallback) } } .rlang_cli_format_inline_link <- function(x, target, span, fallback = "`%s`") { if (.rlang_cli_has_cli()) { if (is_null(target)) { cli::format_inline(paste0("{.", span, " {x}}")) } else { cli::format_inline(paste0("{.", span, " [{x}]({target})}")) } } else { .rlang_cli_style_inline(x, span, fallback = fallback) } } #' Format messages #' #' @description #' #' These format functions use cli if available to format condition #' messages. This includes structural formatting: #' #' - Styling as a function of the message type (error, warning, #' message). #' - Bullets formatting (info, alert, ...). #' - Indented width wrapping. #' #' This also applies inline formatting in combination with the #' `style_` prefixed functions. #' #' The input should not contain any `"{foo}"` glue syntax. If you are #' assembling a message from multiple pieces, use `cli_escape()` on #' user or external inputs that might contain curly braces. #' #' @param x A character vector of lines. Names define bullet types. #' #' @noRd format_error <- function(x) { .rlang_cli_format(x, cli::format_error) } #' @rdname format_error #' @noRd format_warning <- function(x) { .rlang_cli_format(x, cli::format_warning) } #' @rdname format_error #' @noRd format_message <- function(x) { .rlang_cli_format(x, cli::format_message) } .rlang_cli_format <- function(x, cli_format) { if (.rlang_cli_has_cli()) { out <- cli_format(x, .envir = emptyenv()) .rlang_cli_str_restore(out, unname(x)) } else { .rlang_cli_format_fallback(x) } } .rlang_cli_format_fallback <- function(x) { if (!length(x)) { return(unname(x)) } nms <- names(x) if (is_null(nms)) { nms <- rep_len("", length(x)) } abort <- .rlang_cli_compat("abort") bullets <- local({ unicode_opt <- getOption("cli.condition_unicode_bullets") if (identical(unicode_opt, FALSE)) { old <- options(cli.unicode = FALSE) on.exit(options(old)) } # For consistency with `cli::format_error()` and for resiliency # against hard-to-detect errors (see #1364), unknown names are # silently ignored. This also makes it easier to add new bullet # names in the future with forward-compatibility. ifelse(nms == "i", ansi_info(), ifelse(nms == "x", ansi_cross(), ifelse(nms == "v", ansi_tick(), ifelse(nms == "*", ansi_bullet(), ifelse(nms == "!", ansi_alert(), ifelse(nms == ">", ansi_arrow(), ifelse(nms == "", "", ifelse(nms == " ", " ", "")))))))) }) bullets <- ifelse(bullets == "", "", paste0(bullets, " ")) out <- paste0(bullets, x, collapse = "\n") .rlang_cli_str_restore(out, unname(x)) } .rlang_cli_str_restore <- function(x, to) { out <- to out <- out[1] out[[1]] <- x # Restore attributes only if unclassed. It is assumed the `[` and # `[[` methods deal with attributes in case of classed objects. # Preserving attributes matters for the assertthat package for # instance. if (!is.object(to)) { attrib <- attributes(to) attrib$names <- NULL attrib$dim <- NULL attrib$dimnames <- NULL attrib <- c(attributes(out), attrib) attributes(out) <- attrib } out } has_ansi <- function() { .rlang_cli_has_cli() && cli::num_ansi_colors() > 1 } .rlang_cli_has_cli <- local({ cache <- new.env() function(version = "3.0.0") { out <- cache[[version]] if (is.null(out)) { out <- cache[[version]] <<- requireNamespace("cli", quietly = TRUE) && utils::packageVersion("cli") >= version } out } }) #' Escape cli and glue syntax #' #' This doubles all `{` and `}` characters to prevent them from being #' interpreted as syntax for glue interpolation or cli styling. #' #' @param x A character vector. #' #' @noRd cli_escape <- function(x) { if (.rlang_cli_has_cli()) { gsub("\\}", "}}", gsub("\\{", "{{", x)) } else { x } } .rlang_cli_compat <- function(fn, try_rlang = TRUE) { # Compats that behave the same independently of rlang's presence out <- switch( fn, is_installed = return(function(pkg) requireNamespace(pkg, quietly = TRUE)) ) # Only use rlang if it is fully loaded (#1482) if (try_rlang && requireNamespace("rlang", quietly = TRUE) && environmentIsLocked(asNamespace("rlang"))) { switch( fn, is_interactive = return(rlang::is_interactive) ) ns <- asNamespace("rlang") # Make sure rlang knows about "x" and "i" bullets. # Pull from namespace rather than via `utils::packageVersion()` # to avoid slowdown (#1657) if (ns[[".__NAMESPACE__."]][["spec"]][["version"]] >= "0.4.2") { switch( fn, abort = return(rlang::abort), warn = return((rlang::warn)), inform = return(rlang::inform) ) } } # Fall back to base compats is_interactive_compat <- function() { opt <- getOption("rlang_interactive") if (!is.null(opt)) { opt } else { interactive() } } format_msg <- function(x) paste(x, collapse = "\n") switch( fn, is_interactive = return(is_interactive_compat), abort = return(function(msg) stop(format_msg(msg), call. = FALSE)), warn = return(function(msg) warning(format_msg(msg), call. = FALSE)), inform = return(function(msg) message(format_msg(msg))) ) stop(sprintf("Internal error in rlang shims: Unknown function `%s()`.", fn)) } .rlang_cli_unstructure <- function(x) { attributes(x) <- NULL x } # nocov end rlang/R/env.R0000644000176200001440000005673014741441060012505 0ustar liggesusers#' Create a new environment #' #' @description #' #' These functions create new environments. #' #' * `env()` creates a child of the current environment by default #' and takes a variable number of named objects to populate it. #' #' * `new_environment()` creates a child of the empty environment by #' default and takes a named list of objects to populate it. #' #' #' @section Environments as objects: #' #' Environments are containers of uniquely named objects. Their most #' common use is to provide a scope for the evaluation of R #' expressions. Not all languages have first class environments, #' i.e. can manipulate scope as regular objects. Reification of scope #' is one of the most powerful features of R as it allows you to change #' what objects a function or expression sees when it is evaluated. #' #' Environments also constitute a data structure in their own #' right. They are a collection of uniquely named objects, subsettable #' by name and modifiable by reference. This latter property (see #' section on reference semantics) is especially useful for creating #' mutable OO systems (cf the [R6 package](https://github.com/r-lib/R6) #' and the [ggproto #' system](https://ggplot2.tidyverse.org/articles/extending-ggplot2.html) #' for extending ggplot2). #' #' #' @section Inheritance: #' #' All R environments (except the [empty environment][empty_env]) are #' defined with a parent environment. An environment and its #' grandparents thus form a linear hierarchy that is the basis for #' [lexical #' scoping](https://en.wikipedia.org/wiki/Scope_(computer_science)) in #' R. When R evaluates an expression, it looks up symbols in a given #' environment. If it cannot find these symbols there, it keeps #' looking them up in parent environments. This way, objects defined #' in child environments have precedence over objects defined in #' parent environments. #' #' The ability of overriding specific definitions is used in the #' tidyeval framework to create powerful domain-specific grammars. A #' common use of masking is to put data frame columns in scope. See #' for example [as_data_mask()]. #' #' #' @section Reference semantics: #' #' Unlike regular objects such as vectors, environments are an #' [uncopyable][is_copyable()] object type. This means that if you #' have multiple references to a given environment (by assigning the #' environment to another symbol with `<-` or passing the environment #' as argument to a function), modifying the bindings of one of those #' references changes all other references as well. #' #' @param ...,data <[dynamic][dyn-dots]> Named values. You can #' supply one unnamed to specify a custom parent, otherwise it #' defaults to the current environment. #' @param parent A parent environment. #' @seealso [env_has()], [env_bind()]. #' @export #' @examples #' # env() creates a new environment that inherits from the current #' # environment by default #' env <- env(a = 1, b = "foo") #' env$b #' identical(env_parent(env), current_env()) #' #' # Supply one unnamed argument to inherit from another environment: #' env <- env(base_env(), a = 1, b = "foo") #' identical(env_parent(env), base_env()) #' #' #' # Both env() and child_env() support tidy dots features: #' objs <- list(b = "foo", c = "bar") #' env <- env(a = 1, !!! objs) #' env$c #' #' # You can also unquote names with the definition operator `:=` #' var <- "a" #' env <- env(!!var := "A") #' env$a #' #' #' # Use new_environment() to create containers with the empty #' # environment as parent: #' env <- new_environment() #' env_parent(env) #' #' # Like other new_ constructors, it takes an object rather than dots: #' new_environment(list(a = "foo", b = "bar")) env <- function(...) { dots <- dots_split(..., .n_unnamed = 0:1) if (length(dots$unnamed)) { parent <- dots$unnamed[[1]] } else { parent = caller_env() } env <- new.env(parent = parent) env_bind0(env, dots$named) env } #' @rdname env #' @export new_environment <- function(data = list(), parent = empty_env()) { env <- new.env(parent = parent) if (!is_list(data)) { data <- rlang_as_list(data) } env_bind0(env, data) env } #' Coerce to an environment #' #' `as_environment()` coerces named vectors (including lists) to an #' environment. The names must be unique. If supplied an unnamed #' string, it returns the corresponding package environment (see #' [pkg_env()]). #' #' If `x` is an environment and `parent` is not `NULL`, the #' environment is duplicated before being set a new parent. The return #' value is therefore a different environment than `x`. #' #' @param x An object to coerce. #' @param parent A parent environment, [empty_env()] by default. This #' argument is only used when `x` is data actually coerced to an #' environment (as opposed to data representing an environment, like #' `NULL` representing the empty environment). #' @export #' @examples #' # Coerce a named vector to an environment: #' env <- as_environment(mtcars) #' #' # By default it gets the empty environment as parent: #' identical(env_parent(env), empty_env()) #' #' #' # With strings it is a handy shortcut for pkg_env(): #' as_environment("base") #' as_environment("rlang") #' #' # With NULL it returns the empty environment: #' as_environment(NULL) as_environment <- function(x, parent = NULL) { if (is_string(x) && !is_named(x)) { return(pkg_env(x)) } switch(typeof(x), NULL = empty_env(), environment = x, logical = , integer = , double = , character = , complex = , raw = , list = vec_as_environment(x, parent), abort_coercion(x, "an environment") ) } vec_as_environment <- function(x, parent = NULL) { stopifnot(is_dictionaryish(x)) if (is_atomic(x)) { x <- vec_coerce(x, "list") } list2env(x, parent = parent %||% empty_env()) } #' Get parent environments #' #' @description #' #' - `env_parent()` returns the parent environment of `env` if called #' with `n = 1`, the grandparent with `n = 2`, etc. #' #' - `env_tail()` searches through the parents and returns the one #' which has [empty_env()] as parent. #' #' - `env_parents()` returns the list of all parents, including the #' empty environment. This list is named using [env_name()]. #' #' See the section on _inheritance_ in [env()]'s documentation. #' #' @inheritParams get_env #' @param n The number of generations to go up. #' @param last The environment at which to stop. Defaults to the #' global environment. The empty environment is always a stopping #' condition so it is safe to leave the default even when taking the #' tail or the parents of an environment on the search path. #' #' `env_tail()` returns the environment which has `last` as parent #' and `env_parents()` returns the list of environments up to `last`. #' @return An environment for `env_parent()` and `env_tail()`, a list #' of environments for `env_parents()`. #' @export #' @examples #' # Get the parent environment with env_parent(): #' env_parent(global_env()) #' #' # Or the tail environment with env_tail(): #' env_tail(global_env()) #' #' # By default, env_parent() returns the parent environment of the #' # current evaluation frame. If called at top-level (the global #' # frame), the following two expressions are equivalent: #' env_parent() #' env_parent(base_env()) #' #' # This default is more handy when called within a function. In this #' # case, the enclosure environment of the function is returned #' # (since it is the parent of the evaluation frame): #' enclos_env <- env() #' fn <- set_env(function() env_parent(), enclos_env) #' identical(enclos_env, fn()) env_parent <- function(env = caller_env(), n = 1) { check_environment(env) while (n > 0) { if (is_empty_env(env)) { abort("The empty environment has no parent.") } n <- n - 1 env <- parent.env(env) } env } #' @rdname env_parent #' @export env_tail <- function(env = caller_env(), last = global_env()) { check_environment(env) parent <- env_parent(env) while (!identical(parent, last) && !is_empty_env(parent)) { env <- parent parent <- env_parent(parent) } env } #' @rdname env_parent #' @export env_parents <- function(env = caller_env(), last = global_env()) { if (is_empty_env(env)) { return(new_environments(list())) } n <- env_depth(env) out <- new_list(n) if (!is_null(last)) { check_environment(last, what = "`NULL` or an environment") } i <- 1L parent <- env_parent(env) while (TRUE) { out[[i]] <- parent if (is_reference(parent, last) || is_empty_env(parent)) { break } i <- i + 1L env <- parent parent <- env_parent(env) } if (i < n) { out <- out[seq_len(i)] } new_environments(out) } #' Depth of an environment chain #' #' This function returns the number of environments between `env` and #' the [empty environment][empty_env()], including `env`. The depth of #' `env` is also the number of parents of `env` (since the empty #' environment counts as a parent). #' #' @inheritParams get_env #' @return An integer. #' @seealso The section on inheritance in [env()] documentation. #' @export #' @examples #' env_depth(empty_env()) #' env_depth(pkg_env("rlang")) env_depth <- function(env) { check_environment(env) n <- 0L while (!is_empty_env(env)) { env <- env_parent(env) n <- n + 1L } n } `_empty_env` <- emptyenv() is_empty_env <- function(env) { is_reference(env, `_empty_env`) } #' Get or set the environment of an object #' #' These functions dispatch internally with methods for functions, #' formulas and frames. If called with a missing argument, the #' environment of the current evaluation frame is returned. If you #' call `get_env()` with an environment, it acts as the identity #' function and the environment is simply returned (this helps #' simplifying code when writing generic functions for environments). #' #' While `set_env()` returns a modified copy and does not have side #' effects, `env_poke_parent()` operates changes the environment by #' side effect. This is because environments are #' [uncopyable][is_copyable]. Be careful not to change environments #' that you don't own, e.g. a parent environment of a function from a #' package. #' #' @param env An environment. #' @param default The default environment in case `env` does not wrap #' an environment. If `NULL` and no environment could be extracted, #' an error is issued. #' #' @seealso [quo_get_env()] and [quo_set_env()] for versions of #' [get_env()] and [set_env()] that only work on quosures. #' @export #' @examples #' # Environment of closure functions: #' fn <- function() "foo" #' get_env(fn) #' #' # Or of quosures or formulas: #' get_env(~foo) #' get_env(quo(foo)) #' #' #' # Provide a default in case the object doesn't bundle an environment. #' # Let's create an unevaluated formula: #' f <- quote(~foo) #' #' # The following line would fail if run because unevaluated formulas #' # don't bundle an environment (they didn't have the chance to #' # record one yet): #' # get_env(f) #' #' # It is often useful to provide a default when you're writing #' # functions accepting formulas as input: #' default <- env() #' identical(get_env(f, default), default) get_env <- function(env, default = NULL) { out <- switch(typeof(env), environment = env, definition = , language = if (is_formula(env)) attr(env, ".Environment"), builtin = , special = , primitive = ns_env("base"), closure = environment(env) ) out <- out %||% default if (is_null(out)) { type <- obj_type_friendly(env) abort(paste0("Can't extract an environment from ", type, ".")) } else { out } } #' @rdname get_env #' @param new_env An environment to replace `env` with. #' @export #' @examples #' #' # set_env() can be used to set the enclosure of functions and #' # formulas. Let's create a function with a particular environment: #' env <- child_env("base") #' fn <- set_env(function() NULL, env) #' #' # That function now has `env` as enclosure: #' identical(get_env(fn), env) #' identical(get_env(fn), current_env()) #' #' # set_env() does not work by side effect. Setting a new environment #' # for fn has no effect on the original function: #' other_env <- child_env(NULL) #' set_env(fn, other_env) #' identical(get_env(fn), other_env) #' #' # Since set_env() returns a new function with a different #' # environment, you'll need to reassign the result: #' fn <- set_env(fn, other_env) #' identical(get_env(fn), other_env) set_env <- function(env, new_env = caller_env()) { if (is_formula(env) || is_closure(env)) { environment(env) <- new_env return(env) } check_environment(env) new_env } #' @rdname get_env #' @export env_poke_parent <- function(env, new_env) { check_environment(env) check_environment(new_env) .Call(ffi_env_poke_parent, env, new_env) } `env_parent<-` <- function(x, value) { check_environment(env) check_environment(value) .Call(ffi_env_poke_parent, env, value) } #' Clone or coalesce an environment #' #' @description #' - `env_clone()` creates a new environment containing exactly the #' same bindings as the input, optionally with a new parent. #' #' - `env_coalesce()` copies binding from the RHS environment into the #' LHS. If the RHS already contains bindings with the same name as #' in the LHS, those are kept as is. #' #' Both these functions preserve active bindings and promises (the #' latter are only preserved on R >= 4.0.0). #' #' @inheritParams get_env #' @param parent The parent of the cloned environment. #' @export #' @examples #' # A clone initially contains the same bindings as the original #' # environment #' env <- env(a = 1, b = 2) #' clone <- env_clone(env) #' #' env_print(clone) #' env_print(env) #' #' # But it can acquire new bindings or change existing ones without #' # impacting the original environment #' env_bind(clone, a = "foo", c = 3) #' #' env_print(clone) #' env_print(env) #' #' #' # `env_coalesce()` copies bindings from one environment to another #' lhs <- env(a = 1) #' rhs <- env(a = "a", b = "b", c = "c") #' env_coalesce(lhs, rhs) #' env_print(lhs) #' #' # To copy all the bindings from `rhs` into `lhs`, first delete the #' # conflicting bindings from `rhs` #' env_unbind(lhs, env_names(rhs)) #' env_coalesce(lhs, rhs) #' env_print(lhs) env_clone <- function(env, parent = env_parent(env)) { check_environment(env) check_environment(parent) .Call(ffi_env_clone, env, parent) } #' @rdname env_clone #' @param from Environment to copy bindings from. #' @export env_coalesce <- function(env, from) { check_environment(env) check_environment(from) invisible(.Call(ffi_env_coalesce, env, from)) } #' Does environment inherit from another environment? #' #' This returns `TRUE` if `x` has `ancestor` among its parents. #' #' @inheritParams get_env #' @param ancestor Another environment from which `x` might inherit. #' @export env_inherits <- function(env, ancestor) { check_environment(env) check_environment(ancestor) .Call(ffi_env_inherits, env, ancestor) } #' Lock an environment #' #' @description #' #' `r lifecycle::badge("experimental")` #' #' Locked environments cannot be modified. An important example is #' namespace environments which are locked by R when loaded in a #' session. Once an environment is locked it normally cannot be #' unlocked. #' #' Note that only the environment as a container is locked, not the #' individual bindings. You can't remove or add a binding but you can #' still modify the values of existing bindings. See #' [env_binding_lock()] for locking individual bindings. #' #' @param env An environment. #' @return The old value of `env_is_locked()` invisibly. #' #' @seealso [env_binding_lock()] #' @keywords internal #' @export #' @examples #' # New environments are unlocked by default: #' env <- env(a = 1) #' env_is_locked(env) #' #' # Use env_lock() to lock them: #' env_lock(env) #' env_is_locked(env) #' #' # Now that `env` is locked, it is no longer possible to remove or #' # add bindings. If run, the following would fail: #' # env_unbind(env, "a") #' # env_bind(env, b = 2) #' #' # Note that even though the environment as a container is locked, #' # the individual bindings are still unlocked and can be modified: #' env$a <- 10 env_lock <- function(env) { old <- env_is_locked(env) lockEnvironment(env) invisible(old) } #' @rdname env_lock #' @export env_is_locked <- function(env) { environmentIsLocked(env) } #' Unlock an environment #' #' This function should only be used in development tools or #' interactively. #' #' @inheritParams env_lock #' @return Whether the environment has been unlocked. #' #' @keywords internal #' @export env_unlock <- function(env) { invisible(.Call(ffi_env_unlock, env)) } #' Pretty-print an environment #' #' @description #' #' This prints: #' #' * The [label][env_label] and the parent label. #' #' * Whether the environment is [locked][env_lock]. #' #' * The bindings in the environment (up to 20 bindings). They are #' printed succintly using `pillar::type_sum()` (if available, #' otherwise uses an internal version of that generic). In addition #' [fancy bindings][env_bind_lazy] (actives and promises) are #' indicated as such. #' #' * Locked bindings get a `[L]` tag #' #' Note that printing a package namespace (see [ns_env()]) with #' `env_print()` will typically tag function bindings as `` #' until they are evaluated the first time. This is because package #' functions are lazily-loaded from disk to improve performance when #' loading a package. #' #' @param env An environment, or object that can be converted to an #' environment by [get_env()]. #' #' @export env_print <- function(env = caller_env()) { env <- get_env(env) if (is_empty_env(env)) { parent <- "NULL" } else { parent <- sprintf("", env_label(env_parent(env))) } if (env_is_locked(env)) { locked <- " [L]" } else { locked <- "" } header <- format_cls(sprintf("environment: %s", env_label(env))) cat_line( style_bold(paste0(header, locked)), sprintf("Parent: %s", parent) ) class <- attr(env, "class") if (is_character(class)) { class <- paste(class, collapse = ", ") cat_line(sprintf("Class: %s", class)) } nms <- env_names(env) n <- length(nms) if (n) { cat_line("Bindings:") if (n > 20) { other <- nms[seq(21L, n)] nms <- nms[1:20] } else { other <- chr() } escaped_nms <- map_chr(syms(nms), deparse, backtick = TRUE) types <- env_binding_type_sum(env, nms) types <- paste0(escaped_nms, ": <", types, ">") locked <- env_binding_are_locked(env, nms) locked <- ifelse(locked, " [L]", "") types <- paste0(types, locked) types <- set_names(types, "*") n_other <- length(other) if (n_other) { types <- c(types, sprintf("... with %s more bindings", n_other)) } writeLines(format_error_bullets(types)) } invisible(env) } new_environments <- function(envs, names) { stopifnot(is_list(envs)) structure( envs, names = map_chr(unname(envs), env_name), class = "rlang_envs" ) } #' @export print.rlang_envs <- function(x, ...) { n <- length(x) if (!n) { print(list()) return(invisible(x)) } if (n > 20L) { footer <- sprintf("... and %s more environments", n - 20L) x <- x[seq_len(20L)] } else { footer <- chr() } digits <- n_digits(seq_along(x)) pads <- digits[[length(x)]] - digits pads <- map_chr(pads, spaces) labels <- map_chr(x, env_label) nms_tags <- names_tags(names(x)) cat_line( paste0(pads, "[[", seq_along(x), "]]", nms_tags, " "), footer ) invisible(x) } n_digits <- function(x) { floor(log10(x) + 1) } names_tags <- function(nms) { if (is_null(nms)) { return("") } invalid <- detect_void_name(nms) if (all(invalid)) { return("") } ifelse(invalid, " ", " $") } #' @export c.rlang_envs <- function(...) { new_environments(NextMethod()) } #' @export `[.rlang_envs` <- function(x, i) { new_environments(NextMethod()) } #' @export str.rlang_envs <- function(object, ...) { i <- 0 for (env in object) { i <- inc(i) cat(sprintf("[[%s]]\n", i)) env_print(env) cat("\n") } invisible(object) } #' Browse environments #' #' @description #' #' * `env_browse(env)` is equivalent to evaluating `browser()` in #' `env`. It persistently sets the environment for step-debugging. #' Supply `value = FALSE` to disable browsing. #' #' * `env_is_browsed()` is a predicate that inspects whether an #' environment is being browsed. #' #' @param env An environment. #' @param value Whether to browse `env`. #' @return `env_browse()` returns the previous value of #' `env_is_browsed()` (a logical), invisibly. #' @export env_browse <- function(env, value = TRUE) { invisible(.Call(ffi_env_browse, env, value)) } #' @rdname env_browse #' @export env_is_browsed <- function(env) { .Call(ffi_env_is_browsed, env) } #' Is frame environment user facing? #' #' @description #' Detects if `env` is user-facing, that is, whether it's an environment #' that inherits from: #' #' - The global environment, as would happen when called interactively #' - A package that is currently being tested #' #' If either is true, we consider `env` to belong to an evaluation #' frame that was called _directly_ by the end user. This is by #' contrast to _indirect_ calls by third party functions which are not #' user facing. #' #' For instance the [lifecycle](https://lifecycle.r-lib.org/) package #' uses `env_is_user_facing()` to figure out whether a deprecated function #' was called directly or indirectly, and select an appropriate #' verbosity level as a function of that. #' #' @param env An environment. #' #' @section Escape hatch: #' #' You can override the return value of `env_is_user_facing()` by #' setting the global option `"rlang_user_facing"` to: #' #' - `TRUE` or `FALSE`. #' - A package name as a string. Then `env_is_user_facing(x)` returns #' `TRUE` if `x` inherits from the namespace corresponding to that #' package name. #' #' @examples #' fn <- function() { #' env_is_user_facing(caller_env()) #' } #' #' # Direct call of `fn()` from the global env #' with(global_env(), fn()) #' #' # Indirect call of `fn()` from a package #' with(ns_env("utils"), fn()) #' @export env_is_user_facing <- function(env) { check_environment(env) if (env_inherits_global(env)) { return(TRUE) } opt <- peek_option("rlang_user_facing") if (!is_null(opt)) { if (is_bool(opt)) { return(opt) } if (is_string(opt)) { top <- topenv(env) if (!is_namespace(top)) { return(FALSE) } return(identical(ns_env_name(top), opt)) } options(rlang_user_facing = NULL) msg <- c( sprintf( "`options(rlang_user_facing = )` must be `TRUE`, `FALSE`, or a package name, not %s.", obj_type_friendly(opt) ), "i" = "The option was reset to `NULL`." ) abort(msg) } if (from_testthat(env)) { return(TRUE) } FALSE } env_inherits_global <- function(env) { # `topenv(emptyenv())` returns the global env. Return `FALSE` in # that case to allow passing the empty env when the # soft-deprecation should not be promoted to deprecation based on # the caller environment. if (is_reference(env, empty_env())) { return(FALSE) } is_reference(topenv(env), global_env()) } # TRUE if we are in unit tests and the package being tested is the # same as the package that called from_testthat <- function(env) { tested_package <- Sys.getenv("TESTTHAT_PKG") if (!nzchar(tested_package)) { return(FALSE) } top <- topenv(env) if (!is_namespace(top)) { return(FALSE) } # Test for environment names rather than reference/contents because # testthat clones the namespace identical(ns_env_name(top), tested_package) } rlang/R/call.R0000644000176200001440000006621614741441060012630 0ustar liggesusers#' Create a call #' #' @description #' #' Quoted function calls are one of the two types of #' [symbolic][is_symbolic] objects in R. They represent the action of #' calling a function, possibly with arguments. There are two ways of #' creating a quoted call: #' #' * By [quoting][nse-defuse] it. Quoting prevents functions from being #' called. Instead, you get the description of the function call as #' an R object. That is, a quoted function call. #' #' * By constructing it with [base::call()], [base::as.call()], or #' `call2()`. In this case, you pass the call elements (the function #' to call and the arguments to call it with) separately. #' #' See section below for the difference between `call2()` and the base #' constructors. #' #' #' @param .fn Function to call. Must be a callable object: a string, #' symbol, call, or a function. #' @param ... <[dynamic][dyn-dots]> Arguments for the function #' call. Empty arguments are preserved. #' @param .ns Namespace with which to prefix `.fn`. Must be a string #' or symbol. #' #' #' @section Difference with base constructors: #' #' `call2()` is more flexible than `base::call()`: #' #' * The function to call can be a string or a [callable][is_callable] #' object: a symbol, another call (e.g. a `$` or `[[` call), or a #' function to inline. `base::call()` only supports strings and you #' need to use `base::as.call()` to construct a call with a callable #' object. #' #' ``` #' call2(list, 1, 2) #' #' as.call(list(list, 1, 2)) #' ``` #' #' * The `.ns` argument is convenient for creating namespaced calls. #' #' ``` #' call2("list", 1, 2, .ns = "base") #' #' # Equivalent to #' ns_call <- call("::", as.symbol("list"), as.symbol("base")) #' as.call(list(ns_call, 1, 2)) #' ``` #' #' * `call2()` has [dynamic dots][list2] support. You can splice lists #' of arguments with `!!!` or unquote an argument name with glue #' syntax. #' #' ``` #' args <- list(na.rm = TRUE, trim = 0) #' #' call2("mean", 1:10, !!!args) #' #' # Equivalent to #' as.call(c(list(as.symbol("mean"), 1:10), args)) #' ``` #' #' #' @section Caveats of inlining objects in calls: #' #' `call2()` makes it possible to inline objects in calls, both in #' function and argument positions. Inlining an object or a function #' has the advantage that the correct object is used in all #' environments. If all components of the code are inlined, you can #' even evaluate in the [empty environment][empty_env]. #' #' However inlining also has drawbacks. It can cause issues with NSE #' functions that expect symbolic arguments. The objects may also leak #' in representations of the call stack, such as [traceback()]. #' #' @seealso [call_modify()] #' @examples #' # fn can either be a string, a symbol or a call #' call2("f", a = 1) #' call2(quote(f), a = 1) #' call2(quote(f()), a = 1) #' #' #' Can supply arguments individually or in a list #' call2(quote(f), a = 1, b = 2) #' call2(quote(f), !!!list(a = 1, b = 2)) #' #' # Creating namespaced calls is easy: #' call2("fun", arg = quote(baz), .ns = "mypkg") #' #' # Empty arguments are preserved: #' call2("[", quote(x), , drop = ) #' @export call2 <- function(.fn, ..., .ns = NULL) { .External2(ffi_call2, .fn, .ns) } #' Collect dynamic dots in a pairlist #' #' This pairlist constructor uses [dynamic dots][dyn-dots]. Use #' it to manually create argument lists for calls or parameter lists #' for functions. #' #' @param ... <[dynamic][dyn-dots]> Arguments stored in the #' pairlist. Empty arguments are preserved. #' #' @export #' @examples #' # Unlike `exprs()`, `pairlist2()` evaluates its arguments. #' new_function(pairlist2(x = 1, y = 3 * 6), quote(x * y)) #' new_function(exprs(x = 1, y = 3 * 6), quote(x * y)) #' #' # It preserves missing arguments, which is useful for creating #' # parameters without defaults: #' new_function(pairlist2(x = , y = 3 * 6), quote(x * y)) pairlist2 <- function(...) { .Call(ffi_dots_pairlist, frame_env = environment(), named = FALSE, ignore_empty = "trailing", preserve_empty = TRUE, unquote_names = TRUE, homonyms = "keep", check_assign = FALSE ) } #' Is an object callable? #' #' A callable object is an object that can appear in the function #' position of a call (as opposed to argument position). This includes #' [symbolic objects][is_symbolic] that evaluate to a function or #' literal functions embedded in the call. #' #' Note that strings may look like callable objects because #' expressions of the form `"list"()` are valid R code. However, #' that's only because the R parser transforms strings to symbols. It #' is not legal to manually set language heads to strings. #' #' @param x An object to test. #' @keywords internal #' @export #' @examples #' # Symbolic objects and functions are callable: #' is_callable(quote(foo)) #' is_callable(base::identity) #' #' # node_poke_car() lets you modify calls without any checking: #' lang <- quote(foo(10)) #' node_poke_car(lang, current_env()) #' #' # Use is_callable() to check an input object is safe to put as CAR: #' obj <- base::identity #' #' if (is_callable(obj)) { #' lang <- node_poke_car(lang, obj) #' } else { #' abort("`obj` must be callable") #' } #' #' eval_bare(lang) is_callable <- function(x) { is_symbolic(x) || is_function(x) } #' Is object a call? #' #' This function tests if `x` is a [call][call2]. This is a #' pattern-matching predicate that returns `FALSE` if `name` and `n` #' are supplied and the call does not match these properties. #' #' @param x An object to test. Formulas and quosures are treated #' literally. #' @param name An optional name that the call should match. It is #' passed to [sym()] before matching. This argument is vectorised #' and you can supply a vector of names to match. In this case, #' `is_call()` returns `TRUE` if at least one name matches. #' @param n An optional number of arguments that the call should #' match. #' @param ns The namespace of the call. If `NULL`, the namespace #' doesn't participate in the pattern-matching. If an empty string #' `""` and `x` is a namespaced call, `is_call()` returns #' `FALSE`. If any other string, `is_call()` checks that `x` is #' namespaced within `ns`. #' #' Can be a character vector of namespaces, in which case the call #' has to match at least one of them, otherwise `is_call()` returns #' `FALSE`. #' @seealso [is_expression()] #' @export #' @examples #' is_call(quote(foo(bar))) #' #' # You can pattern-match the call with additional arguments: #' is_call(quote(foo(bar)), "foo") #' is_call(quote(foo(bar)), "bar") #' is_call(quote(foo(bar)), quote(foo)) #' #' # Match the number of arguments with is_call(): #' is_call(quote(foo(bar)), "foo", 1) #' is_call(quote(foo(bar)), "foo", 2) #' #' #' # By default, namespaced calls are tested unqualified: #' ns_expr <- quote(base::list()) #' is_call(ns_expr, "list") #' #' # You can also specify whether the call shouldn't be namespaced by #' # supplying an empty string: #' is_call(ns_expr, "list", ns = "") #' #' # Or if it should have a namespace: #' is_call(ns_expr, "list", ns = "utils") #' is_call(ns_expr, "list", ns = "base") #' #' # You can supply multiple namespaces: #' is_call(ns_expr, "list", ns = c("utils", "base")) #' is_call(ns_expr, "list", ns = c("utils", "stats")) #' #' # If one of them is "", unnamespaced calls will match as well: #' is_call(quote(list()), "list", ns = "base") #' is_call(quote(list()), "list", ns = c("base", "")) #' is_call(quote(base::list()), "list", ns = c("base", "")) #' #' #' # The name argument is vectorised so you can supply a list of names #' # to match with: #' is_call(quote(foo(bar)), c("bar", "baz")) #' is_call(quote(foo(bar)), c("bar", "foo")) #' is_call(quote(base::list), c("::", ":::", "$", "@")) is_call <- function(x, name = NULL, n = NULL, ns = NULL) { .Call(ffi_is_call, x, name, n, ns) } # Until `is_call()` is fixed is_call2 <- function(x, ...) { if (is_quosure(x)) { FALSE } else { rlang::is_call(x, ...) } } #' How does a call print at the console? #' #' @description #' #' `call_print_type()` returns the way a call is deparsed and printed #' at the console. This is useful when generating documents based on R #' code. The types of calls are: #' #' * `"prefix"` for calls like `foo()`, unary operators, `-1`, and #' operators with more than 2 arguments like \code{`+`(1, 2, 3)} #' (the latter can be obtained by building calls manually). #' #' * `"infix"` for operators like `1 + 2` or `foo$bar`. #' #' * `"special"` for function definitions, control-flow calls like #' `if` or `for`, and subscripting calls like `foo[]` and `foo[[]]`. #' #' @param call A quoted function call. An error is raised if not a call. #' #' @section Finer print types: #' #' `call_print_fine_type()` is a lower level version with the following #' differences: #' #' * The `"special"` calls are categorised as `"control"` (`if`, #' `for`, `while`, `repeat`, `function`), `"delim"` (`(` and `{`), #' and `"subset"` (`[` and `[[`). #' #' * The `"prefixed"` calls are categorised as `"prefix"` (`+`, `-`, #' ...) and `"calls"`. #' #' #' @examples #' call_print_type(quote(foo(bar))) #' call_print_type(quote(foo[[bar]])) #' call_print_type(quote(+foo)) #' call_print_type(quote(function() foo)) #' #' # When an operator call has an artificial number of arguments, R #' # often prints it in prefix form: #' call <- call("+", 1, 2, 3) #' call #' call_print_type(call) #' #' # But not always: #' call <- call("$", 1, 2, 3) #' call #' call_print_type(call) #' @noRd call_print_type <- function(call) { check_call(call) type <- call_print_fine_type(call) switch( type, call = "prefix", control = , delim = , subset = "special", type ) } call_print_fine_type <- function(call) { check_call(call) op <- call_parse_type(call) if (op == "") { return("call") } switch( op, `+unary` = , `-unary` = , `~unary` = , `?unary` = , `!` = , `!!` = , `!!!` = "prefix", `function` = , `while` = , `for` = , `repeat` = , `if` = "control", `(` = , `{` = "delim", `[` = , `[[` = "subset", # These operators always print in infix form even if they have # more arguments `<-` = , `<<-` = , `=` = , `::` = , `:::` = , `$` = , `@` = "infix", `+` = , `-` = , `?` = , `~` = , `:=` = , `|` = , `||` = , `&` = , `&&` = , `>` = , `>=` = , `<` = , `<=` = , `==` = , `!=` = , `*` = , `/` = , `%%` = , `special` = , `:` = , `^` = if (length(node_cdr(call)) == 2) { "infix" } else { "call" } ) } #' Is object a call to infix operator? #' @param x An object. #' @return `FALSE` if not a call or not a call to an infix #' operator. `TRUE` otherwise. #' @noRd #' @examples #' is_call_infix(quote(-1)) #' is_call_infix(quote(1 - 2)) #' is_call_infix(quote(1 %-% 2)) #' is_call_infix(quote(a@b)) is_call_infix <- function(x) { switch( call_parse_type(x), `<-` = , `<<-` = , `=` = , `::` = , `:::` = , `$` = , `@` = , `+` = , `-` = , `?` = , `~` = , `:=` = , `|` = , `||` = , `&` = , `&&` = , `>` = , `>=` = , `<` = , `<=` = , `==` = , `!=` = , `*` = , `/` = , `%%` = , `special` = , `:` = , `^` = TRUE, FALSE ) } #' What is the parser type of a call? #' @return A string, one of: #' - `""` #' - `"break"` #' - `"next"` #' - `"while"` #' - `"for"` #' - `"repeat"` #' - `"if"` #' - `"function"` #' - `"?"` #' - `"?unary"` #' - `"<-"` #' - `"<<-"` #' - `"="` #' - `":="` #' - `"~"` #' - `"~unary"` #' - `"|"` #' - `"||"` #' - `"&"` #' - `"&&"` #' - `"!"` #' - `"!!!"` #' - `">"` #' - `">="` #' - `"<"` #' - `"<="` #' - `"=="` #' - `"!="` #' - `"+"` #' - `"-"` #' - `"*"` #' - `"/"` #' - `"%%"` #' - `"special"` #' - `":"` #' - `"!!"` #' - `"+unary"` #' - `"-unary"` #' - `"^"` #' - `"$"` #' - `"@"` #' - `"::"` #' - `":::"` #' - `"("` #' - `"["` #' - `"[["` #' - `"{"` #' @keywords internal #' @noRd call_parse_type <- function(call) { .Call(ffi_which_operator, call) } call_has_precedence <- function(call, parent_call, side = NULL) { side <- switch( side %||% "none", lhs = -1L, none = 0L, rhs = 1L, abort("Unexpected `side` value in `call_has_precendence()`.") ) .Call(ffi_call_has_precedence, call, parent_call, side) } #' Modify the arguments of a call #' #' If you are working with a user-supplied call, make sure the #' arguments are standardised with [call_match()] before #' modifying the call. #' #' @inheritParams dots_list #' @param .call Can be a call, a formula quoting a call in the #' right-hand side, or a frame object from which to extract the call #' expression. #' @param ... <[dynamic][dyn-dots]> Named or unnamed expressions #' (constants, names or calls) used to modify the call. Use [zap()] #' to remove arguments. Empty arguments are preserved. #' @param .standardise,.env Deprecated as of rlang 0.3.0. Please #' call [call_match()] manually. #' #' @return A quosure if `.call` is a quosure, a call otherwise. #' @export #' @examples #' call <- quote(mean(x, na.rm = TRUE)) #' #' # Modify an existing argument #' call_modify(call, na.rm = FALSE) #' call_modify(call, x = quote(y)) #' #' # Remove an argument #' call_modify(call, na.rm = zap()) #' #' # Add a new argument #' call_modify(call, trim = 0.1) #' #' # Add an explicit missing argument: #' call_modify(call, na.rm = ) #' #' # Supply a list of new arguments with `!!!` #' newargs <- list(na.rm = NULL, trim = 0.1) #' call <- call_modify(call, !!!newargs) #' call #' #' # Remove multiple arguments by splicing zaps: #' newargs <- rep_named(c("na.rm", "trim"), list(zap())) #' call <- call_modify(call, !!!newargs) #' call #' #' #' # Modify the `...` arguments as if it were a named argument: #' call <- call_modify(call, ... = ) #' call #' #' call <- call_modify(call, ... = zap()) #' call #' #' #' # When you're working with a user-supplied call, standardise it #' # beforehand in case it includes unmatched arguments: #' user_call <- quote(matrix(x, nc = 3)) #' call_modify(user_call, ncol = 1) #' #' # `call_match()` applies R's argument matching rules. Matching #' # ensures you're modifying the intended argument. #' user_call <- call_match(user_call, matrix) #' user_call #' call_modify(user_call, ncol = 1) #' #' #' # By default, arguments with the same name are kept. This has #' # subtle implications, for instance you can move an argument to #' # last position by removing it and remapping it: #' call <- quote(foo(bar = , baz)) #' call_modify(call, bar = NULL, bar = missing_arg()) #' #' # You can also choose to keep only the first or last homonym #' # arguments: #' args <- list(bar = NULL, bar = missing_arg()) #' call_modify(call, !!!args, .homonyms = "first") #' call_modify(call, !!!args, .homonyms = "last") call_modify <- function(.call, ..., .homonyms = c("keep", "first", "last", "error"), .standardise = NULL, .env = caller_env()) { args <- dots_list(..., .preserve_empty = TRUE, .homonyms = .homonyms) expr <- get_expr(.call) check_call(expr, arg = ".call") expr <- duplicate(expr, shallow = TRUE) # Discard "" names nms <- names2(args) named <- have_name(args) named_args <- args[named] for (i in seq_along(args)) { tag <- sym(nms[[i]]) arg <- args[[i]] if (is_missing(tag)) { if (is_zap(arg)) { abort("Zap sentinels can't be unnamed") } node_append(expr, new_node(arg)) next } if (identical(tag, dots_sym)) { # Unwrap empty quosures. Useful for passing captured arguments # to `call_modify()`. if (identical(maybe_missing(arg), quo())) { arg <- missing_arg() } if (!is_missing(arg) && !is_zap(arg)) { abort("`...` arguments must be `zap()` or empty") } node_accessor <- node_car } else { node_accessor <- node_tag } prev <- expr node <- node_cdr(expr) while (!is_null(node)) { if (identical(node_accessor(node), tag)) { # Remove argument from the list if a zap sentinel if (is_zap(maybe_missing(arg))) { node <- node_cdr(node) node_poke_cdr(prev, node) next } # If `...` it can only be missing at this point, which means # we keep it in the argument list as is if (!identical(tag, dots_sym)) { node_poke_car(node, maybe_missing(arg)) } break } prev <- node node <- node_cdr(node) } if (is_null(node) && !is_zap(maybe_missing(arg))) { if (identical(tag, dots_sym)) { node <- new_node(dots_sym, NULL) node_poke_cdr(prev, node) } else { node <- new_node(maybe_missing(arg), NULL) node_poke_tag(node, tag) node_poke_cdr(prev, node) } } } set_expr(.call, expr) } abort_call_input_type <- function(arg, call = caller_env()) { abort( sprintf("%s must be a quoted call.", format_arg(arg)), call = call ) } abort_simple_call_input_type <- function(arg, fn, call = caller_env()) { msg <- c( sprintf("%s must be a simple call.", format_arg(arg)), i = "Calls to `::` or `:::` are not simple calls.", i = sprintf("See %s.", format_code("?is_call_simple")) ) abort(msg, call = call) } #' Match supplied arguments to function definition #' #' @description #' `call_match()` is like [match.call()] with these differences: #' #' - It supports matching missing argument to their defaults in the #' function definition. #' #' - It requires you to be a little more specific in some cases. #' Either all arguments are inferred from the call stack or none of #' them are (see the Inference section). #' #' @param call A call. The arguments will be matched to `fn`. #' @param fn A function definition to match arguments to. #' @param ... These dots must be empty. #' @param defaults Whether to match missing arguments to their #' defaults. #' @param dots_env An execution environment where to find dots. If #' supplied and dots exist in this environment, and if `call` #' includes `...`, the forwarded dots are matched to numbered dots #' (e.g. `..1`, `..2`, etc). By default this is set to the empty #' environment which means that `...` expands to nothing. #' @param dots_expand If `FALSE`, arguments passed through `...` will #' not be spliced into `call`. Instead, they are gathered in a #' pairlist and assigned to an argument named `...`. Gathering dots #' arguments is useful if you need to separate them from the other #' named arguments. #' #' Note that the resulting call is not meant to be evaluated since R #' does not support passing dots through a named argument, even if #' named `"..."`. #' #' @section Inference from the call stack: #' When `call` is not supplied, it is inferred from the call stack #' along with `fn` and `dots_env`. #' #' - `call` and `fn` are inferred from the calling environment: #' `sys.call(sys.parent())` and `sys.function(sys.parent())`. #' #' - `dots_env` is inferred from the caller of the calling #' environment: `caller_env(2)`. #' #' If `call` is supplied, then you must supply `fn` as well. Also #' consider supplying `dots_env` as it is set to the empty environment #' when not inferred. #' #' @examples #' # `call_match()` supports matching missing arguments to their #' # defaults #' fn <- function(x = "default") fn #' call_match(quote(fn()), fn) #' call_match(quote(fn()), fn, defaults = TRUE) #' @export call_match <- function(call = NULL, fn = NULL, ..., defaults = FALSE, dots_env = NULL, dots_expand = TRUE) { check_dots_empty0(...) if (is_null(call)) { call <- sys.call(sys.parent()) fn <- fn %||% sys.function(sys.parent()) dots_env <- dots_env %||% caller_env(2) } else { dots_env <- dots_env %||% env(empty_env(), ... = NULL) } if (is_null(fn)) { abort("`fn` must be supplied.") } if (!is_environment(dots_env)) { abort("`dots_env` must be an environment.") } if (is_primitive(fn)) { return(call) } # Don't expand dots before matching defaults to make it easier to # sort the arguments by formals call <- match.call(fn, call, expand.dots = FALSE, envir = dots_env) if (defaults) { fmls <- fn_fmls(fn) names <- names(fmls) missing <- !names %in% names(call) args <- c(as.list(call[-1]), fmls[missing]) args <- args[names] call <- call2(call[[1]], !!!args) } if (is_missing(call$...)) { call$... <- NULL return(call) } if (!dots_expand) { return(call) } i <- match("...", names(call)) if (is_na(i)) { return(call) } call <- as.list(call) as.call(c( call[seq2(1, i - 1)], call$..., call[seq2(i + 1, length(call))] )) } #' Extract function name or namespace of a call #' #' @description #' `call_name()` and `call_ns()` extract the function name or #' namespace of _simple_ calls as a string. They return `NULL` for #' complex calls. #' #' * Simple calls: `foo()`, `bar::foo()`. #' * Complex calls: `foo()()`, `bar::foo`, `foo$bar()`, `(function() NULL)()`. #' #' The `is_call_simple()` predicate helps you determine whether a call #' is simple. There are two invariants you can count on: #' #' 1. If `is_call_simple(x)` returns `TRUE`, `call_name(x)` returns a #' string. Otherwise it returns `NULL`. #' #' 2. If `is_call_simple(x, ns = TRUE)` returns `TRUE`, `call_ns()` #' returns a string. Otherwise it returns `NULL`. #' #' @param call A defused call. #' @return The function name or namespace as a string, or `NULL` if #' the call is not named or namespaced. #' #' @examples #' # Is the function named? #' is_call_simple(quote(foo())) #' is_call_simple(quote(foo[[1]]())) #' #' # Is the function namespaced? #' is_call_simple(quote(list()), ns = TRUE) #' is_call_simple(quote(base::list()), ns = TRUE) #' #' # Extract the function name from quoted calls: #' call_name(quote(foo(bar))) #' call_name(quo(foo(bar))) #' #' # Namespaced calls are correctly handled: #' call_name(quote(base::matrix(baz))) #' #' # Anonymous and subsetted functions return NULL: #' call_name(quote(foo$bar())) #' call_name(quote(foo[[bar]]())) #' call_name(quote(foo()())) #' #' # Extract namespace of a call with call_ns(): #' call_ns(quote(base::bar())) #' #' # If not namespaced, call_ns() returns NULL: #' call_ns(quote(bar())) #' @export call_name <- function(call) { check_required(call) if (is_quosure(call) || is_formula(call)) { call <- get_expr(call) } check_call(call) if (is_call(call, c("::", ":::"))) { return(NULL) } switch(call_type(call), named = as_string(node_car(call)), namespaced = as_string(node_cadr(node_cdar(call))), NULL ) } #' @rdname call_name #' @export call_ns <- function(call) { check_required(call) if (is_quosure(call) || is_formula(call)) { call <- get_expr(call) } check_call(call) if (!is_call(call)) { abort_call_input_type("call") } head <- call[[1]] if (is_call(head, c("::", ":::"))) { as_string(head[[2]]) } else { NULL } } #' @rdname call_name #' @param x An object to test. #' @param ns Whether call is namespaced. If `NULL`, `is_call_simple()` #' is insensitive to namespaces. If `TRUE`, `is_call_simple()` #' detects namespaced calls. If `FALSE`, it detects unnamespaced #' calls. #' @export is_call_simple <- function(x, ns = NULL) { check_required(x) # For compatibility with `call_name()` and `call_ns()` if (is_quosure(x) || is_formula(x)) { x <- get_expr(x) } if (!is_call(maybe_missing(x))) { return(FALSE) } if (is_call(x, c("::", ":::"))) { return(FALSE) } head <- x[[1]] namespaced <- is_call(head, c("::", ":::")) if (!is_null(ns) && !identical(namespaced, ns)) { return(FALSE) } namespaced || is_symbol(head) } is_call_index <- function(x, ns = NULL) { check_required(x) if (!is_call(x)) { return(FALSE) } out <- FALSE while (is_call(fn <- x[[1]])) { if (!is_call(fn, c("$", "@", "[", "[["))) { return(FALSE) } if (!every(fn[-1], is_arg_index, ns)) { return(FALSE) } out <- TRUE x <- fn } out } is_arg_index <- function(arg, ns) { if (!is_call(arg)) { return(TRUE) } namespaced <- is_call(arg, c("::", ":::")) if (namespaced) { if (!is_null(ns) && !identical(namespaced, ns)) { return(FALSE) } else { return(TRUE) } } is_call_simple(arg) } #' Extract arguments from a call #' #' @inheritParams call_name #' @return A named list of arguments. #' @seealso [fn_fmls()] and [fn_fmls_names()] #' @examples #' call <- quote(f(a, b)) #' #' # Subsetting a call returns the arguments converted to a language #' # object: #' call[-1] #' #' # On the other hand, call_args() returns a regular list that is #' # often easier to work with: #' str(call_args(call)) #' #' # When the arguments are unnamed, a vector of empty strings is #' # supplied (rather than NULL): #' call_args_names(call) #' @export call_args <- function(call) { check_required(call) if (is_quosure(call) || is_formula(call)) { call <- get_expr(call) } check_call(call) args <- as.list(call[-1]) set_names((args), names2(args)) } #' @rdname call_args #' @export call_args_names <- function(call) { check_required(call) if (is_quosure(call) || is_formula(call)) { call <- get_expr(call) } check_call(call) names2(call[-1]) } is_qualified_call <- function(x) { if (typeof(x) != "language") return(FALSE) is_qualified_symbol(node_car(x)) } is_namespaced_call <- function(x, ns = NULL, private = NULL) { if (typeof(x) != "language") return(FALSE) if (!is_namespaced_symbol(node_car(x), ns, private)) return(FALSE) TRUE } # Returns a new call whose CAR has been unqualified call_unnamespace <- function(x) { if (is_namespaced_call(x)) { call <- call2(node_cadr(node_cdar(x))) node_poke_cdr(call, node_cdr(x)) } else { x } } # Qualified and namespaced symbols are actually calls is_qualified_symbol <- function(x) { if (typeof(x) != "language") return(FALSE) head <- node_cadr(node_cdr(x)) if (typeof(head) != "symbol") return(FALSE) qualifier <- node_car(x) identical(qualifier, namespace_sym) || identical(qualifier, namespace2_sym) || identical(qualifier, dollar_sym) || identical(qualifier, at_sym) } is_namespaced_symbol <- function(x, ns = NULL, private = NULL) { if (typeof(x) != "language") return(FALSE) if (!is_null(ns) && !identical(node_cadr(x), sym(ns))) return(FALSE) head <- node_car(x) if (is_null(private)) { identical(head, namespace_sym) || identical(head, namespace2_sym) } else if (private) { identical(head, namespace2_sym) } else { identical(head, namespace_sym) } } call_type <- function(x) { x <- get_expr(x) stopifnot(typeof(x) == "language") type <- typeof(node_car(x)) if (type == "symbol") { "named" } else if (is_namespaced_symbol(node_car(x))) { "namespaced" } else if (type == "language") { "recursive" } else if (type %in% c("closure", "builtin", "special")) { "inlined" } else { abort("corrupt language object") } } call_zap_inline <- function(x) { .Call(ffi_call_zap_inline, x) } # Called from C call_type_sum <- function(x) { sym(sprintf("<%s>", rlang_type_sum(x))) } rlang/R/standalone-s3-register.R0000644000176200001440000001360714626326545016222 0ustar liggesusers# --- # repo: r-lib/rlang # file: standalone-s3-register.R # last-updated: 2024-05-14 # license: https://unlicense.org # --- # # ## Changelog # # 2024-05-14: # # * Mentioned `usethis::use_standalone()`. # # nocov start #' Register a method for a suggested dependency #' #' Generally, the recommended way to register an S3 method is to use the #' `S3Method()` namespace directive (often generated automatically by the #' `@export` roxygen2 tag). However, this technique requires that the generic #' be in an imported package, and sometimes you want to suggest a package, #' and only provide a method when that package is loaded. `s3_register()` #' can be called from your package's `.onLoad()` to dynamically register #' a method only if the generic's package is loaded. #' #' For R 3.5.0 and later, `s3_register()` is also useful when demonstrating #' class creation in a vignette, since method lookup no longer always involves #' the lexical scope. For R 3.6.0 and later, you can achieve a similar effect #' by using "delayed method registration", i.e. placing the following in your #' `NAMESPACE` file: #' #' ``` #' if (getRversion() >= "3.6.0") { #' S3method(package::generic, class) #' } #' ``` #' #' @section Usage in other packages: #' To avoid taking a dependency on rlang, you copy the source of #' [`s3_register()`](https://github.com/r-lib/rlang/blob/main/R/standalone-s3-register.R) #' into your own package or with #' `usethis::use_standalone("r-lib/rlang", "s3-register")`. It is licensed under #' the permissive [unlicense](https://choosealicense.com/licenses/unlicense/) to #' make it crystal clear that we're happy for you to do this. There's no need to #' include the license or even credit us when using this function. #' #' @param generic Name of the generic in the form `"pkg::generic"`. #' @param class Name of the class #' @param method Optionally, the implementation of the method. By default, #' this will be found by looking for a function called `generic.class` #' in the package environment. #' @examples #' # A typical use case is to dynamically register tibble/pillar methods #' # for your class. That way you avoid creating a hard dependency on packages #' # that are not essential, while still providing finer control over #' # printing when they are used. #' #' .onLoad <- function(...) { #' s3_register("pillar::pillar_shaft", "vctrs_vctr") #' s3_register("tibble::type_sum", "vctrs_vctr") #' } #' @keywords internal #' @noRd s3_register <- function(generic, class, method = NULL) { stopifnot(is.character(generic), length(generic) == 1) stopifnot(is.character(class), length(class) == 1) pieces <- strsplit(generic, "::")[[1]] stopifnot(length(pieces) == 2) package <- pieces[[1]] generic <- pieces[[2]] caller <- parent.frame() get_method_env <- function() { top <- topenv(caller) if (isNamespace(top)) { asNamespace(environmentName(top)) } else { caller } } get_method <- function(method) { if (is.null(method)) { get(paste0(generic, ".", class), envir = get_method_env()) } else { method } } register <- function(...) { envir <- asNamespace(package) # Refresh the method each time, it might have been updated by # `devtools::load_all()` method_fn <- get_method(method) stopifnot(is.function(method_fn)) # Only register if generic can be accessed if (exists(generic, envir)) { registerS3method(generic, class, method_fn, envir = envir) } else if (identical(Sys.getenv("NOT_CRAN"), "true")) { warn <- .rlang_s3_register_compat("warn") warn(c( sprintf( "Can't find generic `%s` in package %s to register S3 method.", generic, package ), "i" = "This message is only shown to developers using devtools.", "i" = sprintf("Do you need to update %s to the latest version?", package) )) } } # Always register hook in case package is later unloaded & reloaded setHook(packageEvent(package, "onLoad"), function(...) { register() }) # For compatibility with R < 4.1.0 where base isn't locked is_sealed <- function(pkg) { identical(pkg, "base") || environmentIsLocked(asNamespace(pkg)) } # Avoid registration failures during loading (pkgload or regular). # Check that environment is locked because the registering package # might be a dependency of the package that exports the generic. In # that case, the exports (and the generic) might not be populated # yet (#1225). if (isNamespaceLoaded(package) && is_sealed(package)) { register() } invisible() } .rlang_s3_register_compat <- function(fn, try_rlang = TRUE) { # Compats that behave the same independently of rlang's presence out <- switch( fn, is_installed = return(function(pkg) requireNamespace(pkg, quietly = TRUE)) ) # Only use rlang if it is fully loaded (#1482) if (try_rlang && requireNamespace("rlang", quietly = TRUE) && environmentIsLocked(asNamespace("rlang"))) { switch( fn, is_interactive = return(rlang::is_interactive) ) # Make sure rlang knows about "x" and "i" bullets if (utils::packageVersion("rlang") >= "0.4.2") { switch( fn, abort = return(rlang::abort), warn = return((rlang::warn)), inform = return(rlang::inform) ) } } # Fall back to base compats is_interactive_compat <- function() { opt <- getOption("rlang_interactive") if (!is.null(opt)) { opt } else { interactive() } } format_msg <- function(x) paste(x, collapse = "\n") switch( fn, is_interactive = return(is_interactive_compat), abort = return(function(msg) stop(format_msg(msg), call. = FALSE)), warn = return(function(msg) warning(format_msg(msg), call. = FALSE)), inform = return(function(msg) message(format_msg(msg))) ) stop(sprintf("Internal error in rlang shims: Unknown function `%s()`.", fn)) } # nocov end rlang/R/dots.R0000644000176200001440000003461614376150033012666 0ustar liggesusers#' Dynamic dots features #' #' @description #' #' The base `...` syntax supports: #' #' - __Forwarding__ arguments from function to function, matching them #' along the way to arguments. #' #' - __Collecting__ arguments inside data structures, e.g. with [c()] or #' [list()]. #' #' Dynamic dots offer a few additional features, #' [injection][topic-inject] in particular: #' #' 1. You can __splice__ arguments saved in a list with the splice #' operator [`!!!`][splice-operator]. #' #' 2. You can __inject__ names with [glue syntax][glue-operators] on #' the left-hand side of `:=`. #' #' 3. Trailing commas are ignored, making it easier to copy and paste #' lines of arguments. #' #' #' @section Add dynamic dots support in your functions: #' #' If your function takes dots, adding support for dynamic features is #' as easy as collecting the dots with [list2()] instead of [list()]. #' See also [dots_list()], which offers more control over the collection. #' #' In general, passing `...` to a function that supports dynamic dots #' causes your function to inherit the dynamic behaviour. #' #' In packages, document dynamic dots with this standard tag: #' #' ``` #' @@param ... <[`dynamic-dots`][rlang::dyn-dots]> What these dots do. #' ``` #' #' @name dyn-dots #' @aliases tidy-dots doc_dots_dynamic #' #' @examples #' f <- function(...) { #' out <- list2(...) #' rev(out) #' } #' #' # Trailing commas are ignored #' f(this = "that", ) #' #' # Splice lists of arguments with `!!!` #' x <- list(alpha = "first", omega = "last") #' f(!!!x) #' #' # Inject a name using glue syntax #' if (is_installed("glue")) { #' nm <- "key" #' f("{nm}" := "value") #' f("prefix_{nm}" := "value") #' } NULL #' @rdname dyn-dots #' @usage NULL #' @export `:=` <- function(x, y) { abort("`:=` can only be used within dynamic dots.", call = caller_env()) } #' Collect dynamic dots in a list #' #' `list2(...)` is equivalent to `list(...)` with a few additional #' features, collectively called [dynamic dots][dyn-dots]. While #' `list2()` hard-code these features, `dots_list()` is a lower-level #' version that offers more control. #' #' @param ... Arguments to collect in a list. These dots are #' [dynamic][dyn-dots]. #' @return A list containing the `...` inputs. #' #' @details #' For historical reasons, `dots_list()` creates a named list by #' default. By comparison `list2()` implements the preferred behaviour #' of only creating a names vector when a name is supplied. #' #' @export list2 <- function(...) { .Call( ffi_dots_list, frame_env = environment(), named = NULL, ignore_empty = "trailing", preserve_empty = FALSE, unquote_names = TRUE, homonyms = "keep", check_assign = FALSE ) } #' @rdname list2 #' @usage NULL #' @export ll <- list2 # Preserves empty arguments list3 <- function(...) { .Call( ffi_dots_list, frame_env = environment(), named = NULL, ignore_empty = "trailing", preserve_empty = TRUE, unquote_names = TRUE, homonyms = "keep", check_assign = FALSE ) } #' @rdname list2 #' @param .named If `TRUE`, unnamed inputs are automatically named #' with [as_label()]. This is equivalent to applying #' [exprs_auto_name()] on the result. If `FALSE`, unnamed elements #' are left as is and, if fully unnamed, the list is given minimal #' names (a vector of `""`). If `NULL`, fully unnamed results are #' left with `NULL` names. #' @param .ignore_empty Whether to ignore empty arguments. Can be one #' of `"trailing"`, `"none"`, `"all"`. If `"trailing"`, only the #' last argument is ignored if it is empty. #' @param .preserve_empty Whether to preserve the empty arguments that #' were not ignored. If `TRUE`, empty arguments are stored with #' [missing_arg()] values. If `FALSE` (the default) an error is #' thrown when an empty argument is detected. #' @param .homonyms How to treat arguments with the same name. The #' default, `"keep"`, preserves these arguments. Set `.homonyms` to #' `"first"` to only keep the first occurrences, to `"last"` to keep #' the last occurrences, and to `"error"` to raise an informative #' error and indicate what arguments have duplicated names. #' @param .check_assign Whether to check for `<-` calls. When `TRUE` a #' warning recommends users to use `=` if they meant to match a #' function parameter or wrap the `<-` call in curly braces otherwise. #' This ensures assignments are explicit. #' @export #' @examples #' # Let's create a function that takes a variable number of arguments: #' numeric <- function(...) { #' dots <- list2(...) #' num <- as.numeric(dots) #' set_names(num, names(dots)) #' } #' numeric(1, 2, 3) #' #' # The main difference with list(...) is that list2(...) enables #' # the `!!!` syntax to splice lists: #' x <- list(2, 3) #' numeric(1, !!! x, 4) #' #' # As well as unquoting of names: #' nm <- "yup!" #' numeric(!!nm := 1) #' #' #' # One useful application of splicing is to work around exact and #' # partial matching of arguments. Let's create a function taking #' # named arguments and dots: #' fn <- function(data, ...) { #' list2(...) #' } #' #' # You normally cannot pass an argument named `data` through the dots #' # as it will match `fn`'s `data` argument. The splicing syntax #' # provides a workaround: #' fn("wrong!", data = letters) # exact matching of `data` #' fn("wrong!", dat = letters) # partial matching of `data` #' fn(some_data, !!!list(data = letters)) # no matching #' #' # Empty trailing arguments are allowed: #' list2(1, ) #' #' # But non-trailing empty arguments cause an error: #' try(list2(1, , )) #' #' # Use the more configurable `dots_list()` function to preserve all #' # empty arguments: #' list3 <- function(...) dots_list(..., .preserve_empty = TRUE) #' #' # Note how the last empty argument is still ignored because #' # `.ignore_empty` defaults to "trailing": #' list3(1, , ) #' #' # The list with preserved empty arguments is equivalent to: #' list(1, missing_arg()) #' #' #' # Arguments with duplicated names are kept by default: #' list2(a = 1, a = 2, b = 3, b = 4, 5, 6) #' #' # Use the `.homonyms` argument to keep only the first of these: #' dots_list(a = 1, a = 2, b = 3, b = 4, 5, 6, .homonyms = "first") #' #' # Or the last: #' dots_list(a = 1, a = 2, b = 3, b = 4, 5, 6, .homonyms = "last") #' #' # Or raise an informative error: #' try(dots_list(a = 1, a = 2, b = 3, b = 4, 5, 6, .homonyms = "error")) #' #' #' # dots_list() can be configured to warn when a `<-` call is #' # detected: #' my_list <- function(...) dots_list(..., .check_assign = TRUE) #' my_list(a <- 1) #' #' # There is no warning if the assignment is wrapped in braces. #' # This requires users to be explicit about their intent: #' my_list({ a <- 1 }) dots_list <- function(..., .named = FALSE, .ignore_empty = c("trailing", "none", "all"), .preserve_empty = FALSE, .homonyms = c("keep", "first", "last", "error"), .check_assign = FALSE) { .Call( ffi_dots_list, frame_env = environment(), named = .named, ignore_empty = .ignore_empty, preserve_empty = .preserve_empty, unquote_names = TRUE, homonyms = .homonyms, check_assign = .check_assign ) } dots_split <- function(..., .n_unnamed = NULL, .ignore_empty = c("trailing", "none", "all"), .preserve_empty = FALSE, .homonyms = c("keep", "first", "last", "error"), .check_assign = FALSE) { dots <- .Call( ffi_dots_list, frame_env = environment(), named = NULL, ignore_empty = .ignore_empty, preserve_empty = .preserve_empty, unquote_names = TRUE, homonyms = .homonyms, check_assign = .check_assign ) if (is_null(names(dots))) { if (length(dots)) { unnamed_idx <- TRUE } else { unnamed_idx <- lgl() } n <- length(dots) } else { unnamed_idx <- names(dots) == "" n <- sum(unnamed_idx) } if (!is_null(.n_unnamed) && all(n != .n_unnamed)) { ns <- oxford_comma(.n_unnamed) abort(sprintf("Expected %s unnamed arguments in `...`", ns)) } unnamed <- dots[unnamed_idx] named <- dots[!unnamed_idx] # Remove empty names vector names(unnamed) <- NULL list(named = named, unnamed = unnamed) } #' Splice values at dots collection time #' #' @description #' The splicing operator `!!!` operates both in values contexts like #' [list2()] and [dots_list()], and in metaprogramming contexts like #' [expr()], [enquos()], or [inject()]. While the end result looks the #' same, the implementation is different and much more efficient in #' the value cases. This difference in implementation may cause #' performance issues for instance when going from: #' #' ```r #' xs <- list(2, 3) #' list2(1, !!!xs, 4) #' ``` #' #' to: #' #' ```r #' inject(list2(1, !!!xs, 4)) #' ``` #' #' In the former case, the performant value-splicing is used. In the #' latter case, the slow metaprogramming splicing is used. #' #' A common practical case where this may occur is when code is #' wrapped inside a tidyeval context like `dplyr::mutate()`. In this #' case, the metaprogramming operator `!!!` will take over the #' value-splicing operator, causing an unexpected slowdown. #' #' To avoid this in performance-critical code, use `splice()` instead #' of `!!!`: #' #' ```r #' # These both use the fast splicing: #' list2(1, splice(xs), 4) #' inject(list2(1, splice(xs), 4)) #' ``` #' #' @param x A list or vector to splice non-eagerly. #' @export splice <- function(x) { .Call(ffi_new_splice_box, x) } #' @rdname splice #' @export is_spliced <- function(x) { .Call(ffi_is_splice_box, x) } #' @rdname splice #' @export is_spliced_bare <- function(x) { is_bare_list(x) || is_spliced(x) } #' @export print.rlang_box_splice <- function(x, ...) { cat_line("") print(unbox(x)) } #' Evaluate dots with preliminary splicing #' #' This is a tool for advanced users. It captures dots, processes #' unquoting and splicing operators, and evaluates them. Unlike #' [dots_list()], it does not flatten spliced objects, instead they #' are attributed a `spliced` class (see [splice()]). You can process #' spliced objects manually, perhaps with a custom predicate (see #' [flatten_if()]). #' #' @inheritParams dots_list #' @param ... Arguments to evaluate and process splicing operators. #' #' @keywords internal #' @export #' @examples #' dots <- dots_values(!!! list(1, 2), 3) #' dots #' #' # Flatten the objects marked as spliced: #' flatten_if(dots, is_spliced) dots_values <- function(..., .ignore_empty = c("trailing", "none", "all"), .preserve_empty = FALSE, .homonyms = c("keep", "first", "last", "error"), .check_assign = FALSE) { .External( ffi_dots_values, env = environment(), named = NULL, ignore_empty = .ignore_empty, preserve_empty = .preserve_empty, unquote_names = TRUE, homonyms = .homonyms, check_assign = .check_assign ) } # Micro optimisation: Inline character vectors in formals list formals(dots_values) <- pairlist( ... = quote(expr = ), .ignore_empty = c("trailing", "none", "all"), .preserve_empty = FALSE, .homonyms = c("keep", "first", "last", "error"), .check_assign = FALSE ) #' How many arguments are currently forwarded in dots? #' #' This returns the number of arguments currently forwarded in `...` #' as an integer. #' #' @param ... Forwarded arguments. #' @keywords internal #' @export #' @examples #' fn <- function(...) dots_n(..., baz) #' fn(foo, bar) dots_n <- function(...) { nargs() } abort_dots_homonyms <- function(dots, dups) { .__error_call__. <- "caller" nms <- names(dots) # This includes the first occurrence as well dups_all <- nms %in% nms[dups] dups_nms <- unique(nms[dups_all]) dups_n <- length(dups_nms) if (!dups_n) { abort("Internal error: Expected dots duplicates") } enums <- map(dups_nms, homonym_enum, dups_all, nms) line <- "Multiple arguments named `%s` at positions %s." enums_lines <- map2_chr(dups_nms, enums, sprintf, fmt = line) abort(c( "Arguments in `...` must have unique names.", set_names(enums_lines, "x") )) } homonym_enum <- function(nm, dups, nms) { dups[nms != nm] <- FALSE oxford_comma(as.character(which(dups)), final = "and") } # This helper is used when splicing S3 or S4 objects found # in `!!!`. It is similar to `as.list()`, but the names of # `x` always end up on the names of the output list, # unlike `as.list.factor()`. rlang_as_list <- function(x) { if ("list" %in% class(x)) { # `x` explicitly inherits from `"list"`, which we take it to mean # that it has list storage (i.e. it's not a class like POSIXlt, # it's not proxied, and it's not a scalar object like `"lm"`) out <- vec_unstructure(x) } else if (is.list(x)) { out <- rlang_as_list_from_list_impl(x) } else { out <- rlang_as_list_impl(x) } names(out) <- names(x) out } rlang_as_list_impl <- function(x) { n <- length(x) out <- vector("list", n) for (i in seq_len(n)) { out[[i]] <- x[[i]] } out } # Special handling if `x` is already a list. # This avoids the potential for `out[[i]] <- NULL`, # which shortens the list. rlang_as_list_from_list_impl <- function(x) { n <- length(x) out <- vector("list", n) for (i in seq_len(n)) { elt <- x[[i]] if (is.null(elt)) { next } out[[i]] <- elt } out } #' Development notes - `dots.R` #' #' @section `.__error_call__.` flag in dots collectors: #' #' Dots collectors like [dots_list()] are a little tricky because they #' may error out in different situations. Do we want to forward the #' context, i.e. set the call flag to the calling environment? #' Collectors throw errors in these cases: #' #' 1. While checking their own parameters, in which case the relevant #' context is the collector itself and we don't forward. #' #' 2. While collecting the dots, during evaluation of the supplied #' arguments. In this case forwarding or not is irrelevant because #' expressions in `...` are evaluated in their own environment #' which is not connected to the collector's context. #' #' 3. While collecting the dots, during argument constraints checks #' such as determined by the `.homonyms` argument. In this case we #' want to forward the context because the caller of the dots #' collector is the one who determines the constraints for its #' users. #' #' @keywords internal #' @name dev-notes-dots NULL rlang/R/standalone-downstream-deps.R0000644000176200001440000002221614375670676017173 0ustar liggesusers# --- # repo: r-lib/rlang # file: standalone-downstream-deps.R # last-updated: 2022-01-19 # license: https://unlicense.org # --- # # No dependencies but uses rlang and pak if available. In interactive # sessions the user is prompted to update outdated packages. If they # choose no, they are informed about the global option # `rlib_downstream_check` to turn off these prompts. In non # interactive sessions a warning is issued. This happens when the # outdated dep is being loaded. # # ## Changelog # # 2022-01-19: # # * Prompt results are no longer cached in the `org:r-lib` search path # environment in non-interactive sessions. This is to avoid side # effects causing R CMD check failures. # # # 2021-06-08: # # * User response is cached in the global env to avoid asking again # when session is reloaded. # # # 2021-05-20: # # * Fixed issue when downstream package is not installed. # # # 2021-05-17: # # * Added an `info` argument intended to inform users about the # consequences of not updating right away. # # # 2021-05-12: # # * All packages are now updated at once. The user is not prompted # again after accepting or declining to update the packages, even # when one of the packages is loaded later on. # # # 2021-05-07: # # * In interactive sessions, user is now prompted to update outdated # packages. # # * Added global option `rlib_downstream_check` to turn off prompts or # warnings. # # * Renamed to `check_downstream()`. # # * The requirement format is now "pkg (>= 0.0.0)", consistently with # DESCRIPTION fields. # # nocov start check_downstream <- function(ver, ..., info = NULL) { env <- topenv(parent.frame()) if (!isNamespace(env)) { stop("`check_downstream()` must be called from a namespace.", call. = FALSE) } pkg <- unname(getNamespaceName(env)) deps <- c(...) if (!is.character(deps)) { stop("`...` must be strings.", call. = FALSE) } deps_key <- paste0(deps, collapse = " ") deps <- .rlang_downstream_parse_deps(deps) on_package_load <- function(pkg, expr) { if (isNamespaceLoaded(pkg)) { expr } else { thunk <- function(...) expr setHook(packageEvent(pkg, "onLoad"), thunk) } } is_interactive <- .rlang_downstream_compat("is_interactive") if (is_interactive()) { cache <- .rlang_downstream_get_cache() cache[[pkg]][[deps_key]] <- FALSE } checked <- FALSE for (dep in deps) { on_package_load( dep[["pkg"]], .rlang_downstream_check( pkg, ver, deps, info = info, deps_key = deps_key ) ) } } .rlang_downstream_parse_deps <- function(deps) { str_trim <- function(x) { sub("^\\s+", "", sub("\\s+$", "", x)) } deps <- lapply(strsplit(deps, "\\("), str_trim) deps <- lapply(deps, sub, pattern = "\\)$", replacement = "") deps <- lapply(deps, .rlang_downstream_parse_min_requirement) deps } .rlang_downstream_parse_min_requirement <- function(dep) { if (length(dep) != 2) { stop("Parsing error during downstream check.", call. = FALSE) } is_string <- function(x) { is.character(x) && length(x) == 1 && !is.na(x) } parts <- strsplit(dep[[2]], " +")[[1]] if (length(parts) != 2) { stop("Parsing error during downstream check.", call. = FALSE) } op <- parts[[1]] ver <- parts[[2]] stopifnot(is_string(op), is_string(ver)) if (op != ">=") { stop("Can only check `>=` requirements.", call. = FALSE) } c(pkg = dep[[1]], min = ver) } .rlang_downstream_check <- function(pkg, pkg_ver, deps, info, deps_key = as.character(stats::runif(1)), env = parent.frame()) { isFALSE <- function(x) { is.logical(x) && length(x) == 1L && !is.na(x) && !x } if (isFALSE(getOption("rlib_downstream_check"))) { return(NULL) } # Check cache in the global environment. This cache gets saved along # with the session. This avoids getting repeated checks when session # is reloaded, e.g. when revisiting RStudio servers. is_interactive <- .rlang_downstream_compat("is_interactive") if (is_interactive()) { cache <- .rlang_downstream_get_cache() if (isTRUE(cache[[pkg]][[deps_key]])) { return(NULL) } } # Still check closure env in case the cache in the global # environment has been deleted if (isTRUE(env$checked)) { return(NULL) } # Don't ask again. Flip now instead of on exit to defensively # prevent recursion. if (is_interactive()) { cache[[pkg]][deps_key] <- list(TRUE) } env$checked <- TRUE pkgs <- vapply(deps, `[[`, "", "pkg") mins <- vapply(deps, `[[`, "", "min") # Don't use `requireNamespace()` to avoid loading packages is_on_disk <- function(pkg) nzchar(system.file(package = pkg)) on_disk <- vapply(pkgs, is_on_disk, NA) pkgs <- pkgs[on_disk] mins <- mins[on_disk] vers <- lapply(pkgs, utils::packageVersion) ok <- as.logical(Map(`>=`, vers, mins)) if (all(ok)) { return(TRUE) } pkgs <- pkgs[!ok] mins <- mins[!ok] pkgs_quoted <- paste0("`", pkgs, "` (>= ", mins, ")") pkgs_enum <- .rlang_downstream_collapse(pkgs_quoted, final = "and") n <- length(pkgs) if (n == 1) { header <- paste0("The package ", pkgs_enum, " is required") } else { header <- paste0("The packages ", pkgs_enum, " are required") } header <- sprintf("%s as of %s %s.", header, pkg, pkg_ver) warn <- .rlang_downstream_compat("warn") inform <- .rlang_downstream_compat("inform") is_interactive <- .rlang_downstream_compat("is_interactive") if (!is_interactive() || !is.null(getOption("rlang:::no_downstream_prompt"))) { warn(header) return(FALSE) } if (n == 1) { question <- "Would you like to update it now?" } else { question <- "Would you like to update them now?" } # Use "i" bullets by default if (!is.null(info) && is.null(names(info))) { names(info) <- rep("i", length(info)) } prompt <- c( "!" = question, " " = "You will likely need to restart R if you update now.", info ) inform(c(header, prompt)) if (utils::menu(c("Yes", "No")) != 1) { inform("Set `options(rlib_downstream_check = FALSE)` to disable this prompt.") return(FALSE) } if (is_installed("pak")) { pkg_install <- get(envir = asNamespace("pak"), "pkg_install") pkg_install(pkgs, ask = FALSE) } else { utils::install.packages(pkgs) } TRUE } # Keep in sync with standalone-linked-version.R .rlang_downstream_howto_reinstall_msg <- function(pkg) { os <- tolower(Sys.info()[["sysname"]]) if (os == "windows") { url <- "https://github.com/jennybc/what-they-forgot/issues/62" c( i = sprintf("Please update %s to the latest version.", pkg), i = sprintf("Updating packages on Windows requires precautions:\n <%s>", url) ) } else { c( i = sprintf("Please update %s with `install.packages(\"%s\")` and restart R.", pkg, pkg) ) } } .rlang_downstream_collapse <- function(x, sep = ", ", final = "or") { n <- length(x) if (n < 2) { return(x) } n <- length(x) head <- x[seq_len(n - 1)] last <- x[length(x)] head <- paste(head, collapse = sep) # Write a or b. But a, b, or c. if (n > 2) { paste0(head, sep, final, " ", last) } else { paste0(head, " ", final, " ", last) } } .rlang_downstream_compat <- function(fn, try_rlang = TRUE) { # Compats that behave the same independently of rlang's presence out <- switch( fn, is_installed = return(function(pkg) requireNamespace(pkg, quietly = TRUE)) ) # Only use rlang if it is fully loaded (#1482) if (try_rlang && requireNamespace("rlang", quietly = TRUE) && environmentIsLocked(asNamespace("rlang"))) { switch( fn, is_interactive = return(rlang::is_interactive) ) # Make sure rlang knows about "x" and "i" bullets if (utils::packageVersion("rlang") >= "0.4.2") { switch( fn, abort = return(rlang::abort), warn = return((rlang::warn)), inform = return(rlang::inform) ) } } # Fall back to base compats is_interactive_compat <- function() { opt <- getOption("rlang_interactive") if (!is.null(opt)) { opt } else { interactive() } } format_msg <- function(x) paste(x, collapse = "\n") switch( fn, is_interactive = return(is_interactive_compat), abort = return(function(msg) stop(format_msg(msg), call. = FALSE)), warn = return(function(msg) warning(format_msg(msg), call. = FALSE)), inform = return(function(msg) message(format_msg(msg))) ) stop(sprintf("Internal error in rlang shims: Unknown function `%s()`.", fn)) } .rlang_downstream_get_cache <- function() { if (!"org:r-lib" %in% search()) { do.call( attach, list( list(), pos = length(search()), name = "org:r-lib" ) ) } cache_env <- as.environment("org:r-lib") check_cache_name <- "rlang_downstream_check" cache <- cache_env[[check_cache_name]] if (is.null(cache)) { cache <- new.env(parent = emptyenv()) cache_env[[check_cache_name]] <- cache } cache } #nocov end rlang/R/topic-errors.R0000644000176200001440000000150014375670676014352 0ustar liggesusers# Guides --------------------------------------------------------------- #' `r title("topic_error_call")` #' #' ```{r, child = "man/rmd/topic-error-call.Rmd"} #' ``` #' #' @keywords internal #' @name topic-error-call NULL #' `r title("topic_error_chaining")` #' #' ```{r, child = "man/rmd/topic-error-chaining.Rmd"} #' ``` #' #' @keywords internal #' @name topic-error-chaining NULL # Notes ------------------------------------------------------------------- #' `r title("topic_condition_formatting")` #' #' ```{r, child = "man/rmd/topic-condition-formatting.Rmd"} #' ``` #' #' @keywords internal #' @name topic-condition-formatting NULL #' `r title("topic_condition_customisation")` #' #' ```{r, child = "man/rmd/topic-condition-customisation.Rmd"} #' ``` #' #' @keywords internal #' @name topic-condition-customisation NULL rlang/R/import-standalone-defer.R0000644000176200001440000001303114416532241016424 0ustar liggesusers# Compatibility file: do not edit by hand # Source: # # --- # repo: r-lib/withr # source: standalone-defer.R # last-updated: 2022-03-03 # license: https://unlicense.org # --- # # This drop-in file implements withr::defer(). Please find the most # recent version in withr's repository. # # ## Changelog: # # 2022-03-03 # * Support for `source()` and `knitr::knit()` # * Handlers are now stored in environments instead of lists to avoid # infinite recursion issues. # * The handler list is now soft-namespaced. # nocov start defer <- function(expr, envir = parent.frame(), priority = c("first", "last")) { } local({ defer <<- defer <- function(expr, envir = parent.frame(), priority = c("first", "last")) { priority <- match.arg(priority) invisible( add_handler( envir, handler = new_handler(substitute(expr), parent.frame()), front = priority == "first" ) ) } new_handler <- function(expr, envir) { hnd <- new.env(FALSE, size = 2) hnd[["expr"]] <- expr hnd[["envir"]] <- envir hnd } add_handler <- function(envir, handler, front, frames = as.list(sys.frames()), calls = as.list(sys.calls())) { envir <- exit_frame(envir, frames, calls) if (front) { handlers <- c(list(handler), get_handlers(envir)) } else { handlers <- c(get_handlers(envir), list(handler)) } set_handlers(envir, handlers, frames = frames, calls = calls) handler } set_handlers <- function(envir, handlers, frames, calls) { if (is.null(get_handlers(envir))) { # Ensure that list of handlers called when environment "ends" setup_handlers(envir) } attr(envir, "withr_handlers") <- handlers } # Evaluate `frames` lazily setup_handlers <- function(envir, frames = as.list(sys.frames()), calls = as.list(sys.calls())) { if (is_top_level_global_env(envir, frames)) { # For session scopes we use reg.finalizer() if (is_interactive()) { message( sprintf("Setting global deferred event(s).\n"), "i These will be run:\n", " * Automatically, when the R session ends.\n", " * On demand, if you call `withr::deferred_run()`.\n", "i Use `withr::deferred_clear()` to clear them without executing." ) } reg.finalizer(envir, function(env) deferred_run(env), onexit = TRUE) } else { # for everything else we use on.exit() call <- make_call(execute_handlers, envir) # We have to use do.call here instead of eval because of the way on.exit # determines its evaluation context # (https://stat.ethz.ch/pipermail/r-devel/2013-November/067867.html) do.call(base::on.exit, list(call, TRUE), envir = envir) } } exit_frame <- function(envir, frames = as.list(sys.frames()), calls = as.list(sys.calls())) { frame_loc <- frame_loc(envir, frames) if (!frame_loc) { return(envir) } if (in_knitr(envir)) { out <- knitr_frame(envir, frames, calls, frame_loc) if (!is.null(out)) { return(out) } } out <- source_frame(envir, frames, calls, frame_loc) if (!is.null(out)) { return(out) } envir } knitr_frame <- function(envir, frames, calls, frame_loc) { knitr_ns <- asNamespace("knitr") # This doesn't handle correctly the recursive case (knitr called # within a chunk). Handling this would be a little fiddly for an # uncommon edge case. for (i in seq(1, frame_loc)) { if (identical(topenv(frames[[i]]), knitr_ns)) { return(frames[[i]]) } } NULL } source_frame <- function(envir, frames, calls, frame_loc) { i <- frame_loc if (i < 4) { return(NULL) } is_call <- function(x, fn) { is.call(x) && identical(x[[1]], fn) } calls <- as.list(calls) if (!is_call(calls[[i - 3]], quote(source))) { return(NULL) } if (!is_call(calls[[i - 2]], quote(withVisible))) { return(NULL) } if (!is_call(calls[[i - 1]], quote(eval))) { return(NULL) } if (!is_call(calls[[i - 0]], quote(eval))) { return(NULL) } frames[[i - 3]] } frame_loc <- function(envir, frames) { n <- length(frames) if (!n) { return(0) } for (i in seq_along(frames)) { if (identical(frames[[n - i + 1]], envir)) { return(n - i + 1) } } 0 } in_knitr <- function(envir) { knitr_in_progress() && identical(knitr::knit_global(), envir) } is_top_level_global_env <- function(envir, frames) { if (!identical(envir, globalenv())) { return(FALSE) } # Check if another global environment is on the stack !any(vapply(frames, identical, NA, globalenv())) } get_handlers <- function(envir) { attr(envir, "withr_handlers") } execute_handlers <- function(envir) { handlers <- get_handlers(envir) errors <- list() for (handler in handlers) { tryCatch(eval(handler$expr, handler$envir), error = function(e) { errors[[length(errors) + 1]] <<- e } ) } attr(envir, "withr_handlers") <- NULL for (error in errors) { stop(error) } } make_call <- function(...) { as.call(list(...)) } # base implementation of rlang::is_interactive() is_interactive <- function() { opt <- getOption("rlang_interactive") if (!is.null(opt)) { return(opt) } if (knitr_in_progress()) { return(FALSE) } if (identical(Sys.getenv("TESTTHAT"), "true")) { return(FALSE) } interactive() } knitr_in_progress <- function() { isTRUE(getOption("knitr.in.progress")) } }) # defer() namespace # nocov end rlang/R/vec.R0000644000176200001440000000474714375670676012517 0ustar liggesusers#' Increasing sequence of integers in an interval #' #' These helpers take two endpoints and return the sequence of all #' integers within that interval. For `seq2_along()`, the upper #' endpoint is taken from the length of a vector. Unlike #' `base::seq()`, they return an empty vector if the starting point is #' a larger integer than the end point. #' #' @param from The starting point of the sequence. #' @param to The end point. #' @param x A vector whose length is the end point. #' @return An integer vector containing a strictly increasing #' sequence. #' @export #' @examples #' seq2(2, 10) #' seq2(10, 2) #' seq(10, 2) #' #' seq2_along(10, letters) seq2 <- function(from, to) { if (length(from) != 1) { abort(sprintf("%s must be length one.", format_arg("from"))) } if (length(to) != 1) { abort(sprintf("%s must be length one.", format_arg("to"))) } if (from > to) { int() } else { seq.int(from, to) } } #' @rdname seq2 #' @export seq2_along <- function(from, x) { seq2(from, length(x)) } first <- function(x) { .subset2(x, 1L) } last <- function(x) { .subset2(x, length_(x)) } validate_index <- function(i, n) { seq_len(n)[i] } #' Poke values into a vector #' #' @description #' #' `r lifecycle::badge("experimental")` #' #' These tools are for R experts only. They copy elements from `y` #' into `x` by mutation. You should only do this if you own `x`, #' i.e. if you have created it or if you are certain that it doesn't #' exist in any other context. Otherwise you might create unintended #' side effects that have undefined consequences. #' #' @param x The destination vector. #' @param start The index indicating where to start modifying `x`. #' @param y The source vector. #' @param from The index indicating where to start copying from `y`. #' @param n How many elements should be copied from `y` to `x`. #' @param to The index indicating the end of the range to copy from `y`. #' #' @keywords internal #' @export vec_poke_n <- function(x, start, y, from = 1L, n = length(y)) { stopifnot( is_integerish(start), is_integerish(from), is_integerish(n) ) .Call(ffi_vec_poke_n, x, start, y, from, n) } #' @rdname vec_poke_n #' @export vec_poke_range <- function(x, start, y, from = 1L, to = length(y) - from + 1L) { stopifnot( is_integerish(start), is_integerish(from), is_integerish(to) ) .Call(ffi_vec_poke_range, x, start, y, from, to) } rlang/R/nse-defuse.R0000644000176200001440000004065014376150033013746 0ustar liggesusers#' Embrace operator `{{` #' #' @description #' #' The embrace operator `{{` is used to create functions that call #' other [data-masking][topic-data-mask] functions. It transports a #' data-masked argument (an argument that can refer to columns of a #' data frame) from one function to another. #' #' ```r #' my_mean <- function(data, var) { #' dplyr::summarise(data, mean = mean({{ var }})) #' } #' ``` #' #' @section Under the hood: #' #' `{{` combines [enquo()] and [`!!`][injection-operator] in one #' step. The snippet above is equivalent to: #' #' ```r #' my_mean <- function(data, var) { #' var <- enquo(var) #' dplyr::summarise(data, mean = mean(!!var)) #' } #' ``` #' #' @name embrace-operator #' @aliases curly-curly #' #' @seealso #' - `r link("topic_data_mask")` #' - `r link("topic_data_mask_programming")` #' NULL #' Defuse an R expression #' #' @description #' #' `expr()` [defuses][topic-defuse] an R expression with #' [injection][injection-operator] support. #' #' It is equivalent to [base::bquote()]. #' #' @usage NULL #' @param expr An expression to defuse. #' #' @seealso #' - `r link("topic_defuse")` for an overview. #' #' - [enquo()] to defuse non-local expressions from function #' arguments. #' #' - [Advanced defusal operators][defusing-advanced]. #' #' - [sym()] and [call2()] for building expressions (symbols and calls #' respectively) programmatically. #' #' - [base::eval()] and [rlang::eval_bare()] for resuming evaluation #' of a defused expression. #' #' @examples #' # R normally returns the result of an expression #' 1 + 1 #' #' # `expr()` defuses the expression that you have supplied and #' # returns it instead of its value #' expr(1 + 1) #' #' expr(toupper(letters)) #' #' # It supports _injection_ with `!!` and `!!!`. This is a convenient #' # way of modifying part of an expression by injecting other #' # objects. #' var <- "cyl" #' expr(with(mtcars, mean(!!sym(var)))) #' #' vars <- c("cyl", "am") #' expr(with(mtcars, c(!!!syms(vars)))) #' #' # Compare to the normal way of building expressions #' call("with", call("mean", sym(var))) #' #' call("with", call2("c", !!!syms(vars))) #' #' @export expr <- function(expr) { enexpr(expr) } #' Defuse function arguments #' #' @description #' #' `enquo()` and `enquos()` [defuse][topic-defuse] function arguments. #' A defused expression can be examined, modified, and injected into #' other expressions. #' #' Defusing function arguments is useful for: #' #' - Creating data-masking functions. #' - Interfacing with another [data-masking][topic-data-mask] function #' using the [defuse-and-inject][topic-metaprogramming] pattern. #' #' These are advanced tools. Make sure to first learn about the embrace #' operator `r link("{{")` in `r link("topic_data_mask_programming")`. #' `{{` is easier to work with less theory, and it is sufficient #' in most applications. #' #' @inheritParams dots_list #' @param arg An unquoted argument name. The expression #' supplied to that argument is defused and returned. #' @param ... Names of arguments to defuse. #' @param .ignore_empty Whether to ignore empty arguments. Can be one #' of `"trailing"`, `"none"`, `"all"`. If `"trailing"`, only the #' last argument is ignored if it is empty. Named arguments are not #' considered empty. #' @param .ignore_null Whether to ignore unnamed null arguments. Can be #' `"none"` or `"all"`. #' @param .unquote_names Whether to treat `:=` as `=`. Unlike `=`, the #' `:=` syntax supports [names injection][glue-operators]. #' @return `enquo()` returns a [quosure][topic-quosure] and `enquos()` #' returns a list of quosures. #' #' @section Implicit injection: #' #' Arguments defused with `enquo()` and `enquos()` automatically gain #' [injection][topic-inject] support. #' #' ```r #' my_mean <- function(data, var) { #' var <- enquo(var) #' dplyr::summarise(data, mean(!!var)) #' } #' #' # Can now use `!!` and `{{` #' my_mean(mtcars, !!sym("cyl")) #' ``` #' #' See [enquo0()] and [enquos0()] for variants that don't enable #' injection. #' #' @seealso #' - `r link("topic_defuse")` for an overview. #' #' - [expr()] to defuse your own local expressions. #' #' - [Advanced defusal operators][defusing-advanced]. #' #' - [base::eval()] and [rlang::eval_bare()] for resuming evaluation #' of a defused expression. #' #' @examples #' # `enquo()` defuses the expression supplied by your user #' f <- function(arg) { #' enquo(arg) #' } #' #' f(1 + 1) #' #' # `enquos()` works with arguments and dots. It returns a list of #' # expressions #' f <- function(...) { #' enquos(...) #' } #' #' f(1 + 1, 2 * 10) #' #' #' # `enquo()` and `enquos()` enable _injection_ and _embracing_ for #' # your users #' g <- function(arg) { #' f({{ arg }} * 2) #' } #' g(100) #' #' column <- sym("cyl") #' g(!!column) #' #' @export enquo <- function(arg) { .Call(ffi_enquo, substitute(arg), parent.frame()) } #' @rdname enquo #' @export enquos <- function(..., .named = FALSE, .ignore_empty = c("trailing", "none", "all"), .ignore_null = c("none", "all"), .unquote_names = TRUE, .homonyms = c("keep", "first", "last", "error"), .check_assign = FALSE) { quos <- endots( call = sys.call(), frame_env = parent.frame(), capture_arg = ffi_enquo, capture_dots = ffi_quos_interp, named = .named, ignore_empty = .ignore_empty, ignore_null = .ignore_null, unquote_names = .unquote_names, homonyms = .homonyms, check_assign = .check_assign ) structure(quos, class = c("quosures", "list")) } #' Advanced defusal operators #' #' @description #' #' These advanced operators [defuse][topic-defuse] R expressions. #' [expr()], [enquo()], and [enquos()] are sufficient for most #' purposes but rlang provides these other operations, either for #' completeness or because they are useful to experts. #' #' * `exprs()` is the plural variant of `expr()`. It returns a list of #' expressions. It is like [base::alist()] but with #' [injection][nse-inject] support. #' #' * `quo()` and `quos()` are like `expr()` and `exprs()` but return #' quosures instead of naked expressions. When you are defusing #' your own local expressions (by opposition to function arguments #' where non-local expressions are supplied by your users), there #' is generally no need to attach the current environment in a #' quosure. See `r link("topic_quosure")`. #' #' * `enexpr()` and `enexprs()` are like [enquo()] and [enquos()] but #' return naked expressions instead of quosures. These operators #' should very rarely be used because they lose track of the #' environment of defused arguments. #' #' * `ensym()` and `ensyms()` are like `enexpr()` and `enexprs()` but #' they throw an error when the defused expressions are not simple #' symbols. They also support strings which are interpreted as #' symbols. These functions are modelled on the behaviour of the #' left-hand side of `=` and `<-` where you can supply symbols and #' strings interchangeably. #' #' ``` #' "foo" <- NULL #' list("foo" = NULL) #' ``` #' #' * `enquo0` and `enquos0()` are like `enquo()` and `enquos()` but #' without injection support. The injection operators `!!`, `!!!`, #' and `{{` are not processed, instead they are preserved in the #' defused expression. This makes it possible to defuse #' expressions that potentially contain injection operators meant #' for later use. The trade off is that it makes it harder for #' users to inject expressions in your function. They have to #' enable injection explicitly with [inject()]. #' #' None of the features of [dynamic dots][dyn-dots] are available #' when defusing with `enquos0()`. For instance, trailing empty #' arguments are not automatically trimmed. #' #' @inheritParams expr #' @inheritParams enquo #' @param ... For `enexprs()`, `ensyms()` and `enquos()`, names of #' arguments to defuse. For `exprs()` and `quos()`, expressions #' to defuse. #' #' @examples #' # `exprs()` is the plural variant of `expr()` #' exprs(foo, bar, bar) #' #' # `quo()` and `quos()` are the quosure variants of `expr()` and `exprs()` #' quo(foo) #' quos(foo, bar) #' #' # `enexpr()` and `enexprs()` are the naked variants of `enquo()` and `enquos()` #' my_function1 <- function(arg) enexpr(arg) #' my_function2 <- function(arg, ...) enexprs(arg, ...) #' my_function1(1 + 1) #' my_function2(1 + 1, 10 * 2) #' #' #' # `ensym()` and `ensyms()` are symbol variants of `enexpr()` and `enexprs()` #' my_function3 <- function(arg) ensym(arg) #' my_function4 <- function(arg, ...) ensyms(arg, ...) #' #' # The user must supply symbols #' my_function3(foo) #' my_function4(foo, bar) #' #' # Complex expressions are an error #' try(my_function3(1 + 1)) #' try(my_function4(1 + 1, 10 * 2)) #' #' #' # `enquo0()` and `enquos0()` disable injection operators #' automatic_injection <- function(x) enquo(x) #' no_injection <- function(x) enquo0(x) #' #' automatic_injection(foo(!!!1:3)) #' no_injection(foo(!!!1:3)) #' #' # Injection can still be done explicitly #' inject(no_injection(foo(!!!1:3))) #' #' @name defusing-advanced #' @keywords internal NULL #' @rdname defusing-advanced #' @export enexpr <- function(arg) { .Call(ffi_enexpr, substitute(arg), parent.frame()) } #' @rdname defusing-advanced #' @export exprs <- function(..., .named = FALSE, .ignore_empty = c("trailing", "none", "all"), .unquote_names = TRUE) { .Call(ffi_exprs_interp, frame_env = environment(), named = .named, ignore_empty = .ignore_empty, unquote_names = .unquote_names, homonyms = "keep", check_assign = FALSE ) } #' @rdname defusing-advanced #' @export enexprs <- function(..., .named = FALSE, .ignore_empty = c("trailing", "none", "all"), .ignore_null = c("none", "all"), .unquote_names = TRUE, .homonyms = c("keep", "first", "last", "error"), .check_assign = FALSE) { endots( call = sys.call(), frame_env = parent.frame(), capture_arg = ffi_enexpr, capture_dots = ffi_exprs_interp, named = .named, ignore_empty = .ignore_empty, ignore_null = .ignore_null, unquote_names = .unquote_names, homonyms = .homonyms, check_assign = .check_assign ) } #' @rdname defusing-advanced #' @export ensym <- function(arg) { .Call(ffi_ensym, substitute(arg), parent.frame()) } #' @rdname defusing-advanced #' @export ensyms <- function(..., .named = FALSE, .ignore_empty = c("trailing", "none", "all"), .ignore_null = c("none", "all"), .unquote_names = TRUE, .homonyms = c("keep", "first", "last", "error"), .check_assign = FALSE) { exprs <- endots( call = sys.call(), frame_env = parent.frame(), capture_arg = ffi_enexpr, capture_dots = ffi_exprs_interp, named = .named, ignore_empty = .ignore_empty, ignore_null = .ignore_null, unquote_names = .unquote_names, homonyms = .homonyms, check_assign = .check_assign ) map(exprs, function(expr) { if (is_quosure(expr)) { expr <- quo_get_expr(expr) } sym(expr) }) } #' @rdname defusing-advanced #' @export quo <- function(expr) { enquo(expr) } #' @rdname defusing-advanced #' @export quos <- function(..., .named = FALSE, .ignore_empty = c("trailing", "none", "all"), .unquote_names = TRUE) { .Call(ffi_quos_interp, frame_env = environment(), named = .named, ignore_empty = .ignore_empty, unquote_names = .unquote_names, homonyms = "keep", check_assign = FALSE ) } #' @rdname defusing-advanced #' @export enquo0 <- function(arg) { info <- .External(ffi_capturearginfo, environment(), parent.frame()) as_quosure(info$expr, info$env) } #' @rdname defusing-advanced #' @export enquos0 <- function(...) { dots <- .External(ffi_capturedots, environment()) lapply(dots, function(dot) as_quosure(dot$expr, dot$env)) } capture_args <- c( ".named", ".ignore_empty", ".ignore_null", ".unquote_names", ".homonyms", ".check_assign" ) endots <- function(call, frame_env, capture_arg, capture_dots, named, ignore_empty, ignore_null, unquote_names, homonyms, check_assign, error_call = caller_env()) { ignore_empty <- arg_match0( ignore_empty, c("trailing", "none", "all"), error_call = error_call ) ignore_null <- arg_match0( ignore_null, c("none", "all"), error_call = error_call ) syms <- as.list(node_cdr(call)) if (!is_null(names(syms))) { is_arg <- names(syms) %in% capture_args syms <- syms[!is_arg] if (all(names(syms) == "")) { names(syms) <- NULL } } # Avoid note about registration problems dot_call <- .Call dots <- map(syms, function(sym) { if (!is_symbol(sym)) { abort( "Inputs to defuse must be argument names.", call = error_call ) } if (identical(sym, dots_sym)) { unclass(dot_call( capture_dots, frame_env = frame_env, named = named, ignore_empty = ignore_empty, unquote_names = unquote_names, homonyms = homonyms, check_assign = check_assign )) } else { list(dot_call(capture_arg, sym, frame_env)) } }) dots <- list_c(dots) %||% dots if (ignore_empty == "all") { if (identical(capture_arg, ffi_enquo)) { dot_is_missing <- quo_is_missing } else { dot_is_missing <- is_missing } is_missing <- map_lgl(dots, dot_is_missing) # Keep named arguments unless these names come from the `enquos()` # call, e.g. `enquos(foo)` is_named <- detect_named(dots) is_dev_supplied <- is_named & names2(dots) %in% names(syms) is_empty <- is_missing & (is_dev_supplied | !is_named) dots <- discard(dots, is_empty) } if (ignore_null == "all") { if (identical(capture_arg, ffi_enquo)) { dot_is_null <- quo_is_null } else { dot_is_null <- is_null } is_null <- map_lgl(dots, dot_is_null) # Keep named arguments unless these names come from the `enquos()` # call, e.g. `enquos(foo)` is_named <- detect_named(dots) is_dev_supplied <- is_named & names2(dots) %in% names(syms) is_null <- is_null & (is_dev_supplied | !is_named) dots <- discard(dots, is_null) } if (is_true(named)) { dots <- quos_auto_name(dots) } else if (is_false(named)) { names(dots) <- names2(dots) } else if (!is_null(named)) { check_bool(named, arg = ".named", call = error_call) } dots } #' Ensure that all elements of a list of expressions are named #' #' This gives default names to unnamed elements of a list of #' expressions (or expression wrappers such as formulas or #' quosures), deparsed with [as_label()]. #' #' @param exprs A list of expressions. #' @inheritParams args_dots_empty #' @param repair_auto Whether to repair the automatic names. By #' default, minimal names are returned. See `?vctrs::vec_as_names` #' for information about name repairing. #' @param repair_quiet Whether to inform user about repaired names. #' @export exprs_auto_name <- function(exprs, ..., repair_auto = c("minimal", "unique"), repair_quiet = FALSE) { check_dots_empty0(...) repair_auto <- arg_match0(repair_auto, c("minimal", "unique")) named <- detect_named(exprs) if (all(named)) { return(exprs) } names <- names(exprs) auto_names <- map_chr(exprs[!named], as_label) names[!named] <- auto_names if (repair_auto == "unique" && anyDuplicated(auto_names)) { orig <- names unique_names <- names_as_unique(names, quiet = TRUE) names[!named] <- unique_names[!named] if (!repair_quiet) { names_inform_repair(orig, names) } } names(exprs) <- names exprs } #' @rdname exprs_auto_name #' @param quos A list of quosures. #' @export quos_auto_name <- function(quos) { exprs_auto_name(quos) } captureArgInfo <- function(arg) { .External(ffi_capturearginfo, environment(), parent.frame()) } captureDots <- function() { .External(ffi_capturedots, parent.frame()) } # Enable glue syntax in name-unquoting when glue is loaded on_load( on_package_load("glue", .Call(ffi_glue_is_here)) ) rlang/R/zzz.R0000644000176200001440000000040714522160273012541 0ustar liggesusers.onLoad <- function(lib, pkg) { check_linked_version(pkg, with_rlang = FALSE) rlang_ns <- topenv(environment()) .Call(ffi_init_r_library, rlang_ns) .Call(ffi_init_rlang, rlang_ns) run_on_load() } .onUnload <- function(lib) { .Call(ffi_fini_rlang) } rlang/R/s3.R0000644000176200001440000001426514375670676012263 0ustar liggesusers#' Does an object inherit from a set of classes? #' #' @description #' #' * `inherits_any()` is like [base::inherits()] but is more explicit #' about its behaviour with multiple classes. If `classes` contains #' several elements and the object inherits from at least one of #' them, `inherits_any()` returns `TRUE`. #' #' * `inherits_all()` tests that an object inherits from all of the #' classes in the supplied order. This is usually the best way to #' test for inheritance of multiple classes. #' #' * `inherits_only()` tests that the class vectors are identical. It #' is a shortcut for `identical(class(x), class)`. #' #' @param x An object to test for inheritance. #' @param class A character vector of classes. #' #' @export #' @examples #' obj <- structure(list(), class = c("foo", "bar", "baz")) #' #' # With the _any variant only one class must match: #' inherits_any(obj, c("foobar", "bazbaz")) #' inherits_any(obj, c("foo", "bazbaz")) #' #' # With the _all variant all classes must match: #' inherits_all(obj, c("foo", "bazbaz")) #' inherits_all(obj, c("foo", "baz")) #' #' # The order of classes must match as well: #' inherits_all(obj, c("baz", "foo")) #' #' # inherits_only() checks that the class vectors are identical: #' inherits_only(obj, c("foo", "baz")) #' inherits_only(obj, c("foo", "bar", "baz")) inherits_any <- function(x, class) { if (is_empty(class)) { abort("`class` can't be empty.") } inherits(x, class) } #' @rdname inherits_any #' @export inherits_all <- function(x, class) { if (is_empty(class)) { abort("`class` can't be empty.") } idx <- inherits(x, class, which = TRUE) cummax <- cummax(idx) cummax[[1]] != 0L && all(idx == cummax) } #' @rdname inherits_any #' @export inherits_only <- function(x, class) { identical(class(x), class) } #' Box a value #' #' `new_box()` is similar to [base::I()] but it protects a value by #' wrapping it in a scalar list rather than by adding an attribute. #' `unbox()` retrieves the boxed value. `is_box()` tests whether an #' object is boxed with optional class. `as_box()` ensures that a #' value is wrapped in a box. `as_box_if()` does the same but only if #' the value matches a predicate. #' #' @name box #' @param x,.x An R object. #' @param class For `new_box()`, an additional class for the #' boxed value (in addition to `rlang_box`). For `is_box()`, a class #' or vector of classes passed to [inherits_all()]. #' @param ... Additional attributes passed to [base::structure()]. #' @export #' @examples #' boxed <- new_box(letters, "mybox") #' is_box(boxed) #' is_box(boxed, "mybox") #' is_box(boxed, "otherbox") #' #' unbox(boxed) #' #' # as_box() avoids double-boxing: #' boxed2 <- as_box(boxed, "mybox") #' boxed2 #' unbox(boxed2) #' #' # Compare to: #' boxed_boxed <- new_box(boxed, "mybox") #' boxed_boxed #' unbox(unbox(boxed_boxed)) #' #' # Use `as_box_if()` with a predicate if you need to ensure a box #' # only for a subset of values: #' as_box_if(NULL, is_null, "null_box") #' as_box_if("foo", is_null, "null_box") new_box <- function(.x, class = NULL, ...) { structure( list(.x), class = c(class, "rlang_box"), ... ) } #' @rdname box #' @export is_box <- function(x, class = NULL) { inherits_all(x, c(class, "rlang_box")) } #' @rdname box #' @param box A boxed value to unbox. #' @export unbox <- function(box) { if (!inherits(box, "rlang_box")) { abort("`box` must be a box") } box[[1]] } print.box <- function(x, ...) { cat_line("") print(unbox(x)) } #' Convert object to a box #' #' @description #' #' * `as_box()` boxes its input only if it is not already a box. The #' class is also checked if supplied. #' #' * `as_box_if()` boxes its input only if it not already a box, or if #' the predicate `.p` returns `TRUE`. #' #' @inheritParams box #' @param class,.class A box class. If the input is already a box of #' that class, it is returned as is. If the input needs to be boxed, #' `class` is passed to [new_box()]. #' #' @export as_box <- function(x, class = NULL) { if (is_box(x, class)) { x } else { new_box(x, class) } } #' @rdname as_box #' @param .p A predicate function. #' @param ... Arguments passed to `.p`. #' @export as_box_if <- function(.x, .p, .class = NULL, ...) { .p <- as_predicate(.p) if (is_box(.x, .class) || !.p(.x, ...)) { .x } else { new_box(.x, .class) } } #' Box a final value for early termination #' #' @description #' #' A value boxed with `done()` signals to its caller that it #' should stop iterating. Use it to shortcircuit a loop. #' #' @param x For `done()`, a value to box. For `is_done_box()`, a #' value to test. #' @return A [boxed][new_box] value. #' #' @examples #' done(3) #' #' x <- done(3) #' is_done_box(x) #' @export done <- function(x) { new_box( maybe_missing(x), class = "rlang_box_done", empty = missing(x) ) } #' @rdname done #' @param empty Whether the box is empty. If `NULL`, `is_done_box()` #' returns `TRUE` for all done boxes. If `TRUE`, it returns `TRUE` #' only for empty boxes. Otherwise it returns `TRUE` only for #' non-empty boxes. #' @export is_done_box <- function(x, empty = NULL) { if (!inherits(x, "rlang_box_done")) { return(FALSE) } if (is_null(empty)) { return(TRUE) } attr(x, "empty") == empty } #' @export print.rlang_box_done <- function(x, ...) { cat_line("") print(unbox(x)) } #' Create zap objects #' #' @description #' #' `zap()` creates a sentinel object that indicates that an object #' should be removed. For instance, named zaps instruct [env_bind()] #' and [call_modify()] to remove those objects from the environment or #' the call. #' #' The advantage of zap objects is that they unambiguously signal the #' intent of removing an object. Sentinels like `NULL` or #' [missing_arg()] are ambiguous because they represent valid R #' objects. #' #' @param x An object to test. #' #' @export #' @examples #' # Create one zap object: #' zap() #' #' # Create a list of zaps: #' rep(list(zap()), 3) #' rep_named(c("foo", "bar"), list(zap())) zap <- function() { `zap!` } #' @rdname zap #' @export is_zap <- function(x) { inherits(x, "rlang_zap") } `zap!` <- structure(list(), class = "rlang_zap") #' @export print.rlang_zap <- function(x, ...) { cat_line("") } rlang/R/standalone-linked-version.R0000644000176200001440000000401414403561346016765 0ustar liggesusers# --- # repo: r-lib/rlang # file: standalone-linked-version.R # last-updated: 2022-05-26 # license: https://unlicense.org # imports: rlang (>= 1.0.0) # --- # # nocov start check_linked_version <- local({ # Keep in sync with standalone-downstream-deps.R howto_reinstall_msg <- function(pkg) { os <- tolower(Sys.info()[["sysname"]]) if (os == "windows") { url <- "https://github.com/jennybc/what-they-forgot/issues/62" c( i = sprintf("Please update %s to the latest version.", pkg), i = sprintf("Updating packages on Windows requires precautions:\n <%s>", url) ) } else { c( i = sprintf("Please update %s with `install.packages(\"%s\")` and restart R.", pkg, pkg) ) } } function(pkg, with_rlang = requireNamespace("rlang", quietly = TRUE)) { ver <- utils::packageVersion(pkg) ns <- asNamespace(pkg) linked_ver_ptr <- ns[[paste0(pkg, "_linked_version")]] if (is.null(linked_ver_ptr)) { linked_ver <- "" } else { # Construct call to avoid NOTE when argument to `.Call()` is not # statically analysable linked_ver <- do.call(".Call", list(linked_ver_ptr)) } if (nzchar(linked_ver) && ver == linked_ver) { return(invisible(NULL)) } header <- sprintf("The %s package is not properly installed.", pkg) if (nzchar(linked_ver)) { msg <- c(x = sprintf( "The DLL version (%s) does not correspond to the package version (%s).", linked_ver, ver )) } else { # Package does not have a version pointer. This happens when DLL # updating fails for the first version that includes the pointer. msg <- c(x = "The DLL version does not correspond to the package version.") } msg <- c(msg, howto_reinstall_msg(pkg)) if (with_rlang) { msg <- paste(header, rlang::format_error_bullets(msg), sep = "\n") rlang::abort(msg) } else { msg <- paste(c(header, msg), collapse = "\n") stop(msg, call. = FALSE) } } }) # nocov end rlang/R/standalone-obj-type.R0000644000176200001440000002043014741441060015560 0ustar liggesusers# --- # repo: r-lib/rlang # file: standalone-obj-type.R # last-updated: 2023-05-01 # license: https://unlicense.org # imports: rlang (>= 1.1.0) # --- # # ## Changelog # # 2023-05-01: # - `obj_type_friendly()` now only displays the first class of S3 objects. # # 2023-03-30: # - `stop_input_type()` now handles `I()` input literally in `arg`. # # 2022-10-04: # - `obj_type_friendly(value = TRUE)` now shows numeric scalars # literally. # - `stop_friendly_type()` now takes `show_value`, passed to # `obj_type_friendly()` as the `value` argument. # # 2022-10-03: # - Added `allow_na` and `allow_null` arguments. # - `NULL` is now backticked. # - Better friendly type for infinities and `NaN`. # # 2022-09-16: # - Unprefixed usage of rlang functions with `rlang::` to # avoid onLoad issues when called from rlang (#1482). # # 2022-08-11: # - Prefixed usage of rlang functions with `rlang::`. # # 2022-06-22: # - `friendly_type_of()` is now `obj_type_friendly()`. # - Added `obj_type_oo()`. # # 2021-12-20: # - Added support for scalar values and empty vectors. # - Added `stop_input_type()` # # 2021-06-30: # - Added support for missing arguments. # # 2021-04-19: # - Added support for matrices and arrays (#141). # - Added documentation. # - Added changelog. # # nocov start #' Return English-friendly type #' @param x Any R object. #' @param value Whether to describe the value of `x`. Special values #' like `NA` or `""` are always described. #' @param length Whether to mention the length of vectors and lists. #' @return A string describing the type. Starts with an indefinite #' article, e.g. "an integer vector". #' @noRd obj_type_friendly <- function(x, value = TRUE) { if (is_missing(x)) { return("absent") } if (is.object(x)) { if (inherits(x, "quosure")) { type <- "quosure" } else { type <- class(x)[[1L]] } return(sprintf("a <%s> object", type)) } if (!is_vector(x)) { return(.rlang_as_friendly_type(typeof(x))) } n_dim <- length(dim(x)) if (!n_dim) { if (!is_list(x) && length(x) == 1) { if (is_na(x)) { return(switch( typeof(x), logical = "`NA`", integer = "an integer `NA`", double = if (is.nan(x)) { "`NaN`" } else { "a numeric `NA`" }, complex = "a complex `NA`", character = "a character `NA`", .rlang_stop_unexpected_typeof(x) )) } show_infinites <- function(x) { if (x > 0) { "`Inf`" } else { "`-Inf`" } } str_encode <- function(x, width = 30, ...) { if (nchar(x) > width) { x <- substr(x, 1, width - 3) x <- paste0(x, "...") } encodeString(x, ...) } if (value) { if (is.numeric(x) && is.infinite(x)) { return(show_infinites(x)) } if (is.numeric(x) || is.complex(x)) { number <- as.character(round(x, 2)) what <- if (is.complex(x)) "the complex number" else "the number" return(paste(what, number)) } return(switch( typeof(x), logical = if (x) "`TRUE`" else "`FALSE`", character = { what <- if (nzchar(x)) "the string" else "the empty string" paste(what, str_encode(x, quote = "\"")) }, raw = paste("the raw value", as.character(x)), .rlang_stop_unexpected_typeof(x) )) } return(switch( typeof(x), logical = "a logical value", integer = "an integer", double = if (is.infinite(x)) show_infinites(x) else "a number", complex = "a complex number", character = if (nzchar(x)) "a string" else "\"\"", raw = "a raw value", .rlang_stop_unexpected_typeof(x) )) } if (length(x) == 0) { return(switch( typeof(x), logical = "an empty logical vector", integer = "an empty integer vector", double = "an empty numeric vector", complex = "an empty complex vector", character = "an empty character vector", raw = "an empty raw vector", list = "an empty list", .rlang_stop_unexpected_typeof(x) )) } } vec_type_friendly(x) } vec_type_friendly <- function(x, length = FALSE) { if (!is_vector(x)) { abort("`x` must be a vector.") } type <- typeof(x) n_dim <- length(dim(x)) add_length <- function(type) { if (length && !n_dim) { paste0(type, sprintf(" of length %s", length(x))) } else { type } } if (type == "list") { if (n_dim < 2) { return(add_length("a list")) } else if (is.data.frame(x)) { return("a data frame") } else if (n_dim == 2) { return("a list matrix") } else { return("a list array") } } type <- switch( type, logical = "a logical %s", integer = "an integer %s", numeric = , double = "a double %s", complex = "a complex %s", character = "a character %s", raw = "a raw %s", type = paste0("a ", type, " %s") ) if (n_dim < 2) { kind <- "vector" } else if (n_dim == 2) { kind <- "matrix" } else { kind <- "array" } out <- sprintf(type, kind) if (n_dim >= 2) { out } else { add_length(out) } } .rlang_as_friendly_type <- function(type) { switch( type, list = "a list", NULL = "`NULL`", environment = "an environment", externalptr = "a pointer", weakref = "a weak reference", S4 = "an S4 object", name = , symbol = "a symbol", language = "a call", pairlist = "a pairlist node", expression = "an expression vector", char = "an internal string", promise = "an internal promise", ... = "an internal dots object", any = "an internal `any` object", bytecode = "an internal bytecode object", primitive = , builtin = , special = "a primitive function", closure = "a function", type ) } .rlang_stop_unexpected_typeof <- function(x, call = caller_env()) { abort( sprintf("Unexpected type <%s>.", typeof(x)), call = call ) } #' Return OO type #' @param x Any R object. #' @return One of `"bare"` (for non-OO objects), `"S3"`, `"S4"`, #' `"R6"`, or `"R7"`. #' @noRd obj_type_oo <- function(x) { if (!is.object(x)) { return("bare") } class <- inherits(x, c("R6", "R7_object"), which = TRUE) if (class[[1]]) { "R6" } else if (class[[2]]) { "R7" } else if (isS4(x)) { "S4" } else { "S3" } } #' @param x The object type which does not conform to `what`. Its #' `obj_type_friendly()` is taken and mentioned in the error message. #' @param what The friendly expected type as a string. Can be a #' character vector of expected types, in which case the error #' message mentions all of them in an "or" enumeration. #' @param show_value Passed to `value` argument of `obj_type_friendly()`. #' @param ... Arguments passed to [abort()]. #' @inheritParams args_error_context #' @noRd stop_input_type <- function(x, what, ..., allow_na = FALSE, allow_null = FALSE, show_value = TRUE, arg = caller_arg(x), call = caller_env()) { # From standalone-cli.R cli <- env_get_list( nms = c("format_arg", "format_code"), last = topenv(), default = function(x) sprintf("`%s`", x), inherit = TRUE ) if (allow_na) { what <- c(what, cli$format_code("NA")) } if (allow_null) { what <- c(what, cli$format_code("NULL")) } if (length(what)) { what <- oxford_comma(what) } if (inherits(arg, "AsIs")) { format_arg <- identity } else { format_arg <- cli$format_arg } message <- sprintf( "%s must be %s, not %s.", format_arg(arg), what, obj_type_friendly(x, value = show_value) ) abort(message, ..., call = call, arg = arg) } oxford_comma <- function(chr, sep = ", ", final = "or") { n <- length(chr) if (n < 2) { return(chr) } head <- chr[seq_len(n - 1)] last <- chr[n] head <- paste(head, collapse = sep) # Write a or b. But a, b, or c. if (n > 2) { paste0(head, sep, final, " ", last) } else { paste0(head, " ", final, " ", last) } } # nocov end rlang/R/deparse.R0000644000176200001440000005563214376112150013337 0ustar liggesusersline_push <- function(line, text, sticky = FALSE, boundary = NULL, width = NULL, indent = 0L, has_colour = FALSE) { if (!length(line)) { return(text) } check_string(line) check_string(text) width <- width %||% peek_option("width") if (!has_overflown(line, text, width, has_colour)) { return(paste0(line, text)) } if (is_scalar_integer(boundary) && nchar(line) != boundary) { first <- substr(line, 0L, boundary) second <- substr(line, boundary + 1L, nchar(line)) # Trim trailing spaces after boundary second <- trim_leading_spaces(second) second <- paste0(spaces(indent), second) if (sticky || !has_overflown(second, text, width, has_colour)) { line <- trim_trailing_spaces(first) text <- paste0(second, text) } else { text <- paste0(spaces(indent), text) } } else if (sticky) { line <- paste0(line, text) text <- chr() } else { line <- trim_trailing_spaces(line) text <- paste0(spaces(indent), text) } c(line, text) } spaces <- function(ns) { map_chr(ns, function(n) paste(rep(" ", n), collapse = "")) } is_spaces <- function(str) { identical(str, spaces(nchar(str))) } has_overflown <- function(line, text, width, has_colour) { if (has_colour) { line <- strip_style(line) text <- strip_style(text) } text <- trim_trailing_spaces(text) nchar(line) + nchar(text) > width && !is_spaces(line) } trim_trailing_spaces <- function(line) { sub(" *$", "", line) } trim_leading_spaces <- function(line) { sub("^ *", "", line) } new_lines <- function(width = peek_option("width"), max_elements = 5L, deparser = sexp_deparse) { width <- width %||% 60L stopifnot( is_integerish(width, n = 1), is_null(max_elements) || is_scalar_integerish(max_elements) ) r6lite( deparse = function(self, x) { deparser(x, lines = self) }, width = width, max_elements = max_elements, boundary = NULL, next_sticky = FALSE, indent = 0L, indent_status = pairlist(), next_indent_sticky = FALSE, has_colour = FALSE, lines = chr(), last_line = chr(), get_lines = function(self) { c(self$lines, self$last_line) }, get_indent = function(self) { if (self$indent < 0) { warn("Internal error: Negative indent while deparsing") 0L } else { self$indent } }, push = function(self, lines) { stopifnot(is_character(lines)) for (line in lines) { self$push_one(line) } self }, push_one = function(self, line) { line <- line_push(self$last_line, line, sticky = self$next_sticky, boundary = self$boundary, width = self$width, indent = self$get_indent(), has_colour = self$has_colour ) n <- length(line) if (n > 1) { self$lines <- c(self$lines, line[-n]) self$last_line <- line[[n]] self$boundary <- NULL self$next_indent_sticky <- FALSE } else if (n) { self$last_line <- line if (self$next_sticky) { self$boundary <- nchar(line) } } self$next_sticky <- FALSE self }, push_newline = function(self) { self$lines <- c(self$lines, self$last_line) self$last_line <- spaces(self$get_indent()) self$next_sticky <- FALSE self$next_indent_sticky <- FALSE self }, push_sticky = function(self, line) { stopifnot(is_string(line)) self$next_sticky <- TRUE self$push(line) self$set_boundary() self }, make_next_sticky = function(self) { self$next_sticky <- TRUE self }, set_boundary = function(self) { self$boundary <- nchar(self$last_line) self }, increase_indent = function(self) { status <- node_car(self$indent_status) if (self$next_indent_sticky) { node_poke_cadr(status, inc(node_cadr(status))) } else { self$indent <- self$indent + 2L self$indent_status <- new_node(new_node(FALSE, new_node(0L, NULL)), self$indent_status) self$next_indent_sticky <- TRUE } self }, decrease_indent = function(self) { status <- node_car(self$indent_status) if (is_null(status)) { warn("Internal error: Detected NULL `status` while deparsing") return(self) } reset <- node_car(status) n_sticky <- node_cadr(status) # Decrease indent level only once for all the openers that were # on a single line if (!reset) { self$indent <- self$indent - 2L node_poke_car(status, TRUE) self$next_indent_sticky <- FALSE } if (n_sticky >= 1L) { node_poke_cadr(status, dec(n_sticky)) } else { self$indent_status <- node_cdr(self$indent_status) self$next_indent_sticky <- FALSE } self } ) } fmls_deparse <- function(x, lines = new_lines()) { lines$push_sticky("(") lines$increase_indent() while (!is_null(x)) { sym_deparse(node_tag(x), lines) car <- node_car(x) if (!is_missing(car)) { lines$push_sticky(" = ") lines$make_next_sticky() lines$deparse(node_car(x)) } x <- node_cdr(x) if (!is_null(x)) { lines$push_sticky(", ") } } lines$push_sticky(")") lines$decrease_indent() lines$get_lines() } fn_call_deparse <- function(x, lines = new_lines()) { lines$push("function") x <- node_cdr(x) fmls_deparse(node_car(x), lines) lines$push_sticky(" ") lines$increase_indent() x <- node_cdr(x) lines$deparse(node_car(x)) lines$decrease_indent() lines$get_lines() } fn_deparse <- function(x, lines) { lines$push("") lines$decrease_indent() lines$get_lines() } while_deparse <- function(x, lines = new_lines()) { x <- node_cdr(x) lines$push("while (") lines$deparse(node_car(x)) x <- node_cdr(x) lines$push(") ") lines$deparse(node_car(x)) lines$get_lines() } for_deparse <- function(x, lines = new_lines()) { x <- node_cdr(x) lines$push("for (") lines$deparse(node_car(x)) x <- node_cdr(x) lines$push(" in ") lines$deparse(node_car(x)) x <- node_cdr(x) lines$push(") ") lines$deparse(node_car(x)) lines$get_lines() } repeat_deparse <- function(x, lines = new_lines()) { lines$push("repeat ") lines$deparse(node_cadr(x)) lines$get_lines() } next_deparse <- function(x, lines = new_lines()) { lines$push("next") lines$get_lines() } break_deparse <- function(x, lines = new_lines()) { lines$push("break") lines$get_lines() } if_deparse <- function(x, lines = new_lines()) { x <- node_cdr(x) lines$push("if (") lines$deparse(node_car(x)) x <- node_cdr(x) lines$push(") ") lines$deparse(node_car(x)) x <- node_cdr(x) if (!is_null(x)) { lines$push(" else ") lines$deparse(node_car(x)) } lines$get_lines() } # Wrap if the call lower in the AST is not supposed to have # precedence. This sort of AST cannot arise in parsed code but can # occur in constructed calls. operand_deparse <- function(x, parent, side, lines) { wrap <- !call_has_precedence(x, parent, side) if (wrap) { lines$push("(") lines$make_next_sticky() } lines$deparse(x) if (wrap) { lines$push_sticky(")") } } binary_op_deparse <- function(x, lines = new_lines(), space = " ", sticky_rhs = FALSE) { # Constructed call without second argument if (is_null(node_cddr(x))) { return(call_deparse(x, lines)) } outer <- x; op <- as_string(node_car(x)) x <- node_cdr(x) operand_deparse(node_car(x), outer, "lhs", lines) lines$push_sticky(paste0(space, op, space)) if (sticky_rhs) { lines$make_next_sticky() } x <- node_cdr(x) lines$increase_indent() operand_deparse(node_car(x), outer, "rhs", lines) lines$decrease_indent() lines$get_lines() } spaced_op_deparse <- function(x, lines = new_lines()) { binary_op_deparse(x, lines, space = " ") } unspaced_op_deparse <- function(x, lines = new_lines()) { binary_op_deparse(x, lines, space = "") } tight_op_deparse <- function(x, lines = new_lines()) { binary_op_deparse(x, lines, space = "", sticky_rhs = TRUE) } unary_op_deparse <- function(x, lines = new_lines()) { # Constructed call without argument if (is_null(node_cdr(x))) { return(call_deparse(x, lines)) } op <- as_string(node_car(x)) lines$push(op) lines$deparse(node_cadr(x)) lines$get_lines() } unary_f_deparse <- function(x, lines = new_lines()) { # Constructed call without argument if (is_null(node_cdr(x))) { return(call_deparse(x, lines)) } lines$push("~") rhs <- node_cadr(x) if (!is_symbol(rhs) && !is_syntactic_literal(rhs)) { lines$push(" ") } lines$deparse(rhs) lines$get_lines() } brackets_deparse <- function(x, lines = new_lines()) { x <- node_cdr(x) lines$deparse(node_car(x)) args_deparse(node_cdr(x), lines, delims = c("[", "]")) lines$get_lines() } brackets2_deparse <- function(x, lines = new_lines()) { x <- node_cdr(x) lines$deparse(node_car(x)) args_deparse(node_cdr(x), lines, delims = c("[[", "]]")) lines$get_lines() } parens_deparse <- function(x, lines = new_lines()) { lines$push("(") lines$deparse(node_cadr(x)) lines$push(")") lines$get_lines() } braces_deparse <- function(x, lines = new_lines()) { lines$push("{") lines$increase_indent() x <- node_cdr(x) # No need for a newline if the block is empty if (is_null(x)) { lines$push(" }") return(lines$get_lines()) } while (!is_null(x)) { lines$push_newline() lines$deparse(node_car(x)) x <- node_cdr(x) } lines$decrease_indent() lines$push_newline() lines$push("}") lines$get_lines() } embrace_deparse <- function(x, lines = new_lines()) { lines$push("{{ ") lines$increase_indent() sym <- node_cadr(node_cadr(x)) lines$deparse(sym) lines$push(" }}") lines$decrease_indent() lines$get_lines() } sym_deparse <- function(x, lines = new_lines()) { str <- encodeString(as_string(x)) if (needs_backticks(str)) { str <- sprintf("`%s`", str) } lines$push(str)$get_lines() } args_deparse <- function(x, lines = new_lines(), delims = c("(", ")")) { stopifnot(is_character(delims, n = 2)) lines$push_sticky(delims[[1]]) lines$increase_indent() while (!is_null(x)) { tag <- node_tag(x) if (!is_null(tag)) { sym_deparse(tag, lines = lines) lines$push_sticky(" = ") lines$make_next_sticky() } lines$deparse(node_car(x)) x <- node_cdr(x) if (!is_null(x)) { lines$push_sticky(", ") } } lines$push_sticky(delims[[2]]) lines$decrease_indent() lines$get_lines() } call_deparse <- function(x, lines = new_lines()) { car <- node_car(x) type <- call_delimited_type(car) switch(type, parens = { car <- call("(", car) lines$deparse(car) }, backticks = { lines$deparse(node_car(car)) args_deparse(node_cdr(car), lines) }, lines$deparse(car) ) args_deparse(node_cdr(x), lines) } call_delimited_type <- function(call) { if (!is_call(call)) { return("none") } op <- call_parse_type(call) if (op == "") { return("none") } switch (op, `function` = "parens", `while` = , `for` = , `repeat` = , `if` = , `?` = , `<-` = , `<<-` = , `=` = , `:=` = , `~` = , `|` = , `||` = , `&` = , `&&` = , `>` = , `>=` = , `<` = , `<=` = , `==` = , `!=` = , `+` = , `-` = , `*` = , `/` = , `%%` = , `special` = , `:` = , `^` = , `?unary` = , `~unary` = , `!` = , `!!!` = , `!!` = , `+unary` = , `-unary` = "backticks", `$` = , `@` = , `::` = , `:::` = , `[` = , `[[` = , `(` = , `{` = , `{{` = "none", abort("Internal error: Unexpected operator while deparsing") ) } op_deparse <- function(op, x, lines) { deparser <- switch (op, `function` = fn_call_deparse, `while` = while_deparse, `for` = for_deparse, `repeat` = repeat_deparse, `if` = if_deparse, `next` = next_deparse, `break` = break_deparse, `?` = , `<-` = , `<<-` = , `=` = , `:=` = , `~` = , `|` = , `||` = , `&` = , `&&` = , `>` = , `>=` = , `<` = , `<=` = , `==` = , `!=` = , `+` = , `-` = , `*` = , `/` = , `%%` = , `special` = spaced_op_deparse, `:` = , `^` = , `$` = , `@` = unspaced_op_deparse, `::` = , `:::` = tight_op_deparse, `~unary` = unary_f_deparse, `?unary` = , `!` = , `!!!` = , `!!` = , `+unary` = , `-unary` = unary_op_deparse, `[` = brackets_deparse, `[[` = brackets2_deparse, `(` = parens_deparse, `{` = braces_deparse, `{{` = embrace_deparse, abort("Internal error: Unexpected operator while deparsing") ) deparser(x, lines) lines$get_lines() } call_deparser <- function(x) { op <- call_parse_type(x) if (op != "") { function(x, lines) op_deparse(op, x, lines) } else { call_deparse } } atom_elements <- function(x) { elts <- as.character(x) na_pos <- are_na(x) & !is.nan(x) elts[na_pos] <- "NA" elts[!na_pos] <- switch (typeof(x), integer = paste0(elts[!na_pos], "L"), character = map_chr(elts[!na_pos], deparse), elts[!na_pos] ) elts } is_scalar_deparsable <- function(x) { typeof(x) != "raw" && length(x) == 1 && !is_named(x) } atom_deparse <- function(x, lines = new_lines()) { if (is_scalar_deparsable(x)) { lines$push(deparse(x)) return(NULL) } max_elements <- lines$max_elements truncated <- !is.null(max_elements) && length(x) > max_elements if (truncated) { x <- .subset(x, seq_len(max_elements)) } lines$push(paste0("<", rlang_type_sum(x), ": ")) lines$increase_indent() elts <- atom_elements(x) nms <- deparsed_names(x) n <- length(elts) for (i in seq_len(n)) { nm <- nms[[i]] if (nzchar(nm)) { lines$push(paste0(nm, " = ")) lines$make_next_sticky() } lines$push(elts[[i]]) if (i < n || truncated) { lines$push_sticky(", ") } } if (truncated) { lines$push("...") } lines$push_sticky(">") lines$decrease_indent() lines$get_lines() } list_deparse <- function(x, lines = new_lines()) { if (!length(x) && !is_null(names(x))) { lines$push("") return(lines$get_lines()) } max_elements <- lines$max_elements lines$push(paste0(" max_elements if (truncated) { x <- .subset(x, seq_len(max_elements)) } nms <- deparsed_names(x) n <- length(x) for (i in seq_len(n)) { nm <- nms[[i]] if (nzchar(nm)) { lines$push(paste0(nm, " = ")) lines$make_next_sticky() } lines$deparse(x[[i]]) if (i < n || truncated) { lines$push_sticky(", ") } } if (truncated) { lines$push("...") } lines$push_sticky(">") lines$decrease_indent() lines$get_lines() } s3_deparse <- function(x, lines = new_lines()) { lines$push(paste0("<", rlang_type_sum(x), ">")) lines$get_lines() } literal_deparser <- function(type) { function(x, lines = new_lines()) { lines$push(paste0("<", type, ">")) } } default_deparse <- function(x, lines = new_lines()) { lines$push(deparse(x, control = "keepInteger")) lines$get_lines() } sexp_deparse <- function(x, lines = new_lines()) { if (is.object(x)) { return(s3_deparse(x, lines)) } deparser <- switch (typeof(x), symbol = sym_deparse, language = call_deparser(x), closure = fn_deparse, `...` = literal_deparser("..."), any = literal_deparser("any"), environment = literal_deparser("environment"), externalptr = literal_deparser("pointer"), promise = literal_deparser("promise"), weakref = literal_deparser("weakref"), logical = , integer = , double = , complex = , character = , raw = atom_deparse, list = list_deparse, default_deparse ) deparser(x, lines) lines$get_lines() } needs_backticks <- function(str) { if (!is_string(str)) { str <- as_string(str) } n <- nchar(str) if (!n) { return(FALSE) } if (str %in% reserved_words) { return(TRUE) } start <- substr(str, 1, 1) if (!grepl("[[:alpha:].]", start)) { return(TRUE) } if (n == 1) { return(FALSE) } remaining <- substr(str, 2, n) # .0 double literals if (start == "." && grepl("^[[:digit:]]", remaining)) { return(TRUE) } grepl("[^[:alnum:]_.]", remaining) } # From gram.y reserved_words <- c( "NULL", "NA", "TRUE", "FALSE", "Inf", "NaN", "NA_integer_", "NA_real_", "NA_character_", "NA_complex_", "function", "while", "repeat", "for", "if", "in", "else", "next", "break" ) deparsed_names <- function(x) { encodeString(names2(x)) } #' Create a default name for an R object #' #' @description #' #' `as_label()` transforms R objects into a short, human-readable #' description. You can use labels to: #' #' * Display an object in a concise way, for example to labellise axes #' in a graphical plot. #' #' * Give default names to columns in a data frame. In this case, #' labelling is the first step before name repair. #' #' See also [as_name()] for transforming symbols back to a #' string. Unlike `as_label()`, `as_name()` is a well defined #' operation that guarantees the roundtrip symbol -> string -> #' symbol. #' #' In general, if you don't know for sure what kind of object you're #' dealing with (a call, a symbol, an unquoted constant), use #' `as_label()` and make no assumption about the resulting string. If #' you know you have a symbol and need the name of the object it #' refers to, use [as_name()]. For instance, use `as_label()` with #' objects captured with `enquo()` and `as_name()` with symbols #' captured with `ensym()`. #' #' @param x An object. #' #' @section Transformation to string: #' #' * Quosures are [squashed][quo_squash] before being labelled. #' * Symbols are transformed to string with `as_string()`. #' * Calls are abbreviated. #' * Numbers are represented as such. #' * Other constants are represented by their type, such as `` #' or ``. #' #' @seealso [as_name()] for transforming symbols back to a string #' deterministically. #' #' @examples #' # as_label() is useful with quoted expressions: #' as_label(expr(foo(bar))) #' #' as_label(expr(foobar)) #' #' # It works with any R object. This is also useful for quoted #' # arguments because the user might unquote constant objects: #' as_label(1:3) #' #' as_label(base::list) #' @export as_label <- function(x) { x <- quo_squash(x) if (is_missing(x)) { return("") } switch( typeof(x), NULL = "NULL", symbol = as_string(x), language = { if (is_data_pronoun(x)) { return(data_pronoun_name(x) %||% "") } if (use_as_label_infix() && infix_overflows(x)) { return(as_label_infix(x)) } name <- deparse_one(x) name <- gsub("\n.*$", "...", name) name }, if (is_bare_atomic(x, n = 1)) { name <- expr_text(x) name <- gsub("\n.*$", "...", name) name } else { paste0("<", rlang_type_sum(x), ">") } ) } # Work around a slowdown caused by `infix_overflows()` # https://github.com/tidyverse/dplyr/issues/6674 # https://github.com/tidyverse/dplyr/issues/6681 use_as_label_infix <- function() { !is_false(peek_option("rlang:::use_as_label_infix")) } infix_overflows <- function(x) { call_print_type(x) %in% c("infix", "subset") && length(expr_deparse(x, width = 60)) > 1 } as_label_infix <- function(x) { # Shorten the expression if we're too long. Preserve the left side # if possible. infix_n <- nchar_infix(x) dots_n <- 3 left_width <- 60 - infix_n - dots_n left <- expr_deparse(x[[2]], width = left_width) if (length(left) > 1 || nchar(left) > left_width) { x[[2]] <- quote(...) left_n <- dots_n } else { left_n <- nchar(left) } right_width <- 60 - left_n - infix_n right <- expr_deparse(x[[3]], width = right_width) if (length(right) > 1 || nchar(right) > right_width) { x[[3]] <- quote(...) } out <- expr_deparse(x, width = 60) # In case something went wrong if (length(out) > 1) { if (testing()) { abort("Deparsed `out` can't be multiline.", .internal = TRUE) } paste(out[[1]], "...") } else { out } } nchar_infix <- function(x) { x[c(2, 3)] <- 1 nchar(expr_deparse(x)) - 2 } #' Extract names from symbols #' #' @description #' #' `as_name()` converts [symbols][sym] to character strings. The #' conversion is deterministic. That is, the roundtrip `symbol -> name #' -> symbol` always gives the same result. #' #' - Use `as_name()` when you need to transform a symbol to a string #' to _refer_ to an object by its name. #' #' - Use [as_label()] when you need to transform any kind of object to #' a string to _represent_ that object with a short description. #' #' @param x A string or symbol, possibly wrapped in a [quosure][quosure]. #' If a string, the attributes are removed, if any. #' @return A character vector of length 1. #' #' @details #' `rlang::as_name()` is the _opposite_ of [base::as.name()]. If #' you're writing base R code, we recommend using [base::as.symbol()] #' which is an alias of `as.name()` that follows a more modern #' terminology (R types instead of S modes). #' #' @seealso [as_label()] for converting any object to a single string #' suitable as a label. [as_string()] for a lower-level version that #' doesn't unwrap quosures. #' #' @examples #' # Let's create some symbols: #' foo <- quote(foo) #' bar <- sym("bar") #' #' # as_name() converts symbols to strings: #' foo #' as_name(foo) #' #' typeof(bar) #' typeof(as_name(bar)) #' #' # as_name() unwraps quosured symbols automatically: #' as_name(quo(foo)) #' @export as_name <- function(x) { if (is_quosure(x)) { x <- quo_get_expr(x) } as_string(x) } call_deparse_highlight <- function(call, arg) { stopifnot(is_call(call)) if (!is_string(arg)) { arg <- NULL } local_error_highlight() if (!is_call_simple(call) || call_print_fine_type(call) != "call") { return(format_code_unquoted(as_label(call))) } names <- names(call) if (!is_null(arg) && arg %in% names) { # Simply remove other arguments for now call <- call[c(1, match(arg, names))] args_list <- sprintf("%s = %s", arg, as_label(call[[arg]])) args_list <- format_arg_unquoted(args_list) } else { args_list <- call args_list[[1]] <- quote(F) args_list <- as_label(args_list) args_list <- substring(args_list, 3, nchar(args_list) - 1) } head <- call[[1]] if (is_symbol(head)) { fn <- sym_text(head) } else { fn <- as_label(head) } open <- format_code_unquoted(sprintf("%s(", fn)) close <- format_code_unquoted(")") paste0(open, args_list, close) } rlang/R/expr.R0000644000176200001440000002623514515703253012674 0ustar liggesusers#' Is an object an expression? #' #' @description #' In rlang, an _expression_ is the return type of [parse_expr()], the #' set of objects that can be obtained from parsing R code. Under this #' definition expressions include numbers, strings, `NULL`, symbols, #' and function calls. These objects can be classified as: #' #' * Symbolic objects, i.e. symbols and function calls (for which #' `is_symbolic()` returns `TRUE`) #' * Syntactic literals, i.e. scalar atomic objects and `NULL` #' (testable with `is_syntactic_literal()`) #' #' `is_expression()` returns `TRUE` if the input is either a symbolic #' object or a syntactic literal. If a call, the elements of the call #' must all be expressions as well. Unparsable calls are not #' considered expressions in this narrow definition. #' #' Note that in base R, there exists [expression()] vectors, a data #' type similar to a list that supports special attributes created by #' the parser called source references. This data type is not #' supported in rlang. #' #' @details #' `is_symbolic()` returns `TRUE` for symbols and calls (objects with #' type `language`). Symbolic objects are replaced by their value #' during evaluation. Literals are the complement of symbolic #' objects. They are their own value and return themselves during #' evaluation. #' #' `is_syntactic_literal()` is a predicate that returns `TRUE` for the #' subset of literals that are created by R when parsing text (see #' [parse_expr()]): numbers, strings and `NULL`. Along with symbols, #' these literals are the terminating nodes in an AST. #' #' Note that in the most general sense, a literal is any R object that #' evaluates to itself and that can be evaluated in the empty #' environment. For instance, `quote(c(1, 2))` is not a literal, it is #' a call. However, the result of evaluating it in [base_env()] is a #' literal(in this case an atomic vector). #' #' As the data structure for function arguments, pairlists are also a #' kind of language objects. However, since they are mostly an #' internal data structure and can't be returned as is by the parser, #' `is_expression()` returns `FALSE` for pairlists. #' #' @param x An object to test. #' @seealso [is_call()] for a call predicate. #' @export #' @examples #' q1 <- quote(1) #' is_expression(q1) #' is_syntactic_literal(q1) #' #' q2 <- quote(x) #' is_expression(q2) #' is_symbol(q2) #' #' q3 <- quote(x + 1) #' is_expression(q3) #' is_call(q3) #' #' #' # Atomic expressions are the terminating nodes of a call tree: #' # NULL or a scalar atomic vector: #' is_syntactic_literal("string") #' is_syntactic_literal(NULL) #' #' is_syntactic_literal(letters) #' is_syntactic_literal(quote(call())) #' #' # Parsable literals have the property of being self-quoting: #' identical("foo", quote("foo")) #' identical(1L, quote(1L)) #' identical(NULL, quote(NULL)) #' #' # Like any literals, they can be evaluated within the empty #' # environment: #' eval_bare(quote(1L), empty_env()) #' #' # Whereas it would fail for symbolic expressions: #' # eval_bare(quote(c(1L, 2L)), empty_env()) #' #' #' # Pairlists are also language objects representing argument lists. #' # You will usually encounter them with extracted formals: #' fmls <- formals(is_expression) #' typeof(fmls) #' #' # Since they are mostly an internal data structure, is_expression() #' # returns FALSE for pairlists, so you will have to check explicitly #' # for them: #' is_expression(fmls) #' is_pairlist(fmls) is_expression <- function(x) { stack <- new_stack() stack$push(zap_srcref(x)) while (!is_exhausted(elt <- stack$pop())) { if (is_missing(elt)) { return(FALSE) } if (!is_null(attributes(elt))) { return(FALSE) } switch( typeof(elt), language = stack$push(!!!as.list(elt)), if (!is_symbol(elt) && !is_syntactic_literal(elt)) { return(FALSE) } ) } TRUE } #' @export #' @rdname is_expression is_syntactic_literal <- function(x) { switch(typeof(x), NULL = { TRUE }, logical = , integer = , double = , character = { length(x) == 1 }, complex = { if (length(x) != 1) { return(FALSE) } is_na(x) || Re(x) == 0 }, FALSE ) } #' @export #' @rdname is_expression is_symbolic <- function(x) { typeof(x) %in% c("language", "symbol") } #' Turn an expression to a label #' #' @keywords internal #' @description #' #' `r lifecycle::badge("questioning")` #' #' `expr_text()` turns the expression into a single string, which #' might be multi-line. `expr_name()` is suitable for formatting #' names. It works best with symbols and scalar types, but also #' accepts calls. `expr_label()` formats the expression nicely for use #' in messages. #' #' @param expr An expression to labellise. #' #' @examples #' # To labellise a function argument, first capture it with #' # substitute(): #' fn <- function(x) expr_label(substitute(x)) #' fn(x:y) #' #' # Strings are encoded #' expr_label("a\nb") #' #' # Names and expressions are quoted with `` #' expr_label(quote(x)) #' expr_label(quote(a + b + c)) #' #' # Long expressions are collapsed #' expr_label(quote(foo({ #' 1 + 2 #' print(x) #' }))) #' @export expr_label <- function(expr) { if (is.character(expr)) { encodeString(expr, quote = '"') } else if (is.null(expr) || is.atomic(expr)) { format(expr) } else if (is.name(expr)) { paste0("`", as.character(expr), "`") } else { chr <- deparse_one(expr) paste0("`", chr, "`") } } #' @rdname expr_label #' @export expr_name <- function(expr) { if (is_null(expr)) { return("NULL") } if (is_symbol(expr)) { return(as_string(expr)) } if (is_call(expr)) { if (is_data_pronoun(expr)) { name <- data_pronoun_name(expr) %||% "" } else { name <- deparse_one(expr) name <- gsub("\n.*$", "...", name) } return(name) } # So 1L is translated to "1" and not "1L" if (is_scalar_atomic(expr)) { return(as.character(expr)) } if (length(expr) == 1) { name <- expr_text(expr) name <- gsub("\n.*$", "...", name) return(name) } abort(sprintf( "%s must be a symbol, scalar, or call.", format_arg("expr") )) } #' @rdname expr_label #' @export #' @param width Width of each line. #' @param nlines Maximum number of lines to extract. expr_text <- function(expr, width = 60L, nlines = Inf) { if (is_symbol(expr)) { return(sym_text(expr)) } str <- deparse(expr, width.cutoff = width, backtick = TRUE) if (length(str) > nlines) { str <- c(str[seq_len(nlines - 1)], "...") } paste0(str, collapse = "\n") } sym_text <- function(sym) { # Use as_string() to translate unicode tags text <- as_string(sym) if (needs_backticks(text)) { text <- sprintf("`%s`", text) } text } deparse_one <- function(expr) { str <- deparse(expr, 60L) if (length(str) > 1) { if (is_call(expr, function_sym)) { expr[[3]] <- quote(...) str <- deparse(expr, 60L) } else if (is_call(expr, brace_sym)) { str <- "{ ... }" } else if (is_call(expr)) { str <- deparse(call2(expr[[1]], quote(...)), 60L) } str <- paste(str, collapse = "\n") } str } #' Set and get an expression #' #' @keywords internal #' @description #' #' These helpers are useful to make your function work generically #' with quosures and raw expressions. First call `get_expr()` to #' extract an expression. Once you're done processing the expression, #' call `set_expr()` on the original object to update the expression. #' You can return the result of `set_expr()`, either a formula or an #' expression depending on the input type. Note that `set_expr()` does #' not change its input, it creates a new object. #' #' @param x An expression, closure, or one-sided formula. In addition, #' `set_expr()` accept frames. #' @param value An updated expression. #' @param default A default expression to return when `x` is not an #' expression wrapper. Defaults to `x` itself. #' @return The updated original input for `set_expr()`. A raw #' expression for `get_expr()`. #' @seealso [quo_get_expr()] and [quo_set_expr()] for versions of #' [get_expr()] and [set_expr()] that only work on quosures. #' @export #' @examples #' f <- ~foo(bar) #' e <- quote(foo(bar)) #' frame <- identity(identity(ctxt_frame())) #' #' get_expr(f) #' get_expr(e) #' get_expr(frame) #' #' set_expr(f, quote(baz)) #' set_expr(e, quote(baz)) set_expr <- function(x, value) { if (is_quosure(x)) { x <- quo_set_expr(x, value) } else if (is_formula(x)) { f_rhs(x) <- value } else if (is_closure(x)) { body(x) <- value } else { x <- value } x } #' @rdname set_expr #' @export get_expr <- function(x, default = x) { .Call(ffi_get_expression, x, default) } expr_type_of <- function(x) { if (is_missing(x)) { return("missing") } type <- typeof(x) if (type %in% c("symbol", "language", "pairlist", "NULL")) { type } else { "literal" } } switch_expr <- function(.x, ...) { switch(expr_type_of(.x), ...) } #' Print an expression #' #' @description #' #' `expr_print()`, powered by `expr_deparse()`, is an alternative #' printer for R expressions with a few improvements over the base R #' printer. #' #' * It colourises [quosures][nse-defuse] according to their environment. #' Quosures from the global environment are printed normally while #' quosures from local environments are printed in unique colour (or #' in italic when all colours are taken). #' #' * It wraps inlined objects in angular brackets. For instance, an #' integer vector unquoted in a function call (e.g. #' `expr(foo(!!(1:3)))`) is printed like this: `foo()` while by default R prints the code to create that vector: #' `foo(1:3)` which is ambiguous. #' #' * It respects the width boundary (from the global option `width`) #' in more cases. #' #' @param x An object or expression to print. #' @param width The width of the deparsed or printed expression. #' Defaults to the global option `width`. #' @param ... Arguments passed to `expr_deparse()`. #' #' @return `expr_deparse()` returns a character vector of lines. #' `expr_print()` returns its input invisibly. #' #' @export #' @examples #' # It supports any object. Non-symbolic objects are always printed #' # within angular brackets: #' expr_print(1:3) #' expr_print(function() NULL) #' #' # Contrast this to how the code to create these objects is printed: #' expr_print(quote(1:3)) #' expr_print(quote(function() NULL)) #' #' # The main cause of non-symbolic objects in expressions is #' # quasiquotation: #' expr_print(expr(foo(!!(1:3)))) #' #' #' # Quosures from the global environment are printed normally: #' expr_print(quo(foo)) #' expr_print(quo(foo(!!quo(bar)))) #' #' # Quosures from local environments are colourised according to #' # their environments (if you have crayon installed): #' local_quo <- local(quo(foo)) #' expr_print(local_quo) #' #' wrapper_quo <- local(quo(bar(!!local_quo, baz))) #' expr_print(wrapper_quo) expr_print <- function(x, ...) { cat_line(expr_deparse(x, ...)) invisible(x) } #' @rdname expr_print #' @export expr_deparse <- function(x, ..., width = peek_option("width")) { check_dots_empty0(...) deparser <- new_quo_deparser(width = width) quo_deparse(x, deparser) } rlang/R/lifecycle-superseded.R0000644000176200001440000000243114375670676016026 0ustar liggesusers#' Mask bindings by defining symbols deeper in a scope #' #' @description #' `r lifecycle::badge("superseded")` #' #' This function is superseded. Please use [env()] (and possibly #' [set_env()] if you're masking the bindings for another object like #' a closure or a formula) instead. #' #' `env_bury()` is like [env_bind()] but it creates the bindings in a #' new child environment. This makes sure the new bindings have #' precedence over old ones, without altering existing environments. #' Unlike `env_bind()`, this function does not have side effects and #' returns a new environment (or object wrapping that environment). #' #' @inheritParams env_bind #' @return A copy of `.env` enclosing the new environment containing #' bindings to `...` arguments. #' @seealso [env_bind()], [env_unbind()] #' #' @keywords internal #' @export #' @examples #' orig_env <- env(a = 10) #' fn <- set_env(function() a, orig_env) #' #' # fn() currently sees `a` as the value `10`: #' fn() #' #' # env_bury() will bury the current scope of fn() behind a new #' # environment: #' fn <- env_bury(fn, a = 1000) #' fn() #' #' # Even though the symbol `a` is still defined deeper in the scope: #' orig_env$a env_bury <- function(.env, ...) { env_ <- get_env(.env) env_ <- child_env(env_, ...) set_env(.env, env_) } rlang/R/topic-nse.R0000644000176200001440000000432714375670676013635 0ustar liggesusers# Overviews --------------------------------------------------------------- #' `r title("topic_data_mask")` #' #' ```{r, child = "man/rmd/topic-data-mask.Rmd"} #' ``` #' #' @keywords internal #' @name topic-data-mask NULL #' `r title("topic_data_mask_programming")` #' #' ```{r, child = "man/rmd/topic-data-mask-programming.Rmd"} #' ``` #' #' @keywords internal #' @name topic-data-mask-programming NULL #' `r title("topic_metaprogramming")` #' #' ```{r, child = "man/rmd/topic-metaprogramming.Rmd"} #' ``` #' #' @keywords internal #' @name topic-metaprogramming NULL #' `r title("topic_defuse")` #' #' ```{r, child = "man/rmd/topic-defuse.Rmd"} #' ``` #' #' @keywords internal #' @aliases quotation nse-defuse #' @name topic-defuse NULL #' `r title("topic_inject")` #' #' ```{r, child = "man/rmd/topic-inject.Rmd"} #' ``` #' #' @keywords internal #' @aliases quasiquotation nse-force nse-inject #' @name topic-inject NULL #' `r title("topic_quosure")` #' #' ```{r, child = "man/rmd/topic-quosure.Rmd"} #' ``` #' #' @keywords internal #' @name topic-quosure NULL # Guides ------------------------------------------------------------------ #' `r title("topic_data_mask_ambiguity")` #' #' ```{r, child = "man/rmd/topic-data-mask-ambiguity.Rmd"} #' ``` #' #' @keywords internal #' @name topic-data-mask-ambiguity NULL #' `r title("topic_double_evaluation")` #' #' ```{r, child = "man/rmd/topic-double-evaluation.Rmd"} #' ``` #' #' @keywords internal #' @name topic-double-evaluation NULL #' `r title("topic_multiple_columns")` #' #' ```{r, child = "man/rmd/topic-multiple-columns.Rmd"} #' ``` #' #' @keywords internal #' @name topic-multiple-columns NULL # Notes ------------------------------------------------------------------- #' `r title("topic_embrace_non_args")` #' #' ```{r, child = "man/rmd/topic-embrace-non-args.Rmd"} #' ``` #' #' @keywords internal #' @name topic-embrace-non-args NULL #' `r title("topic_embrace_constants")` #' #' ```{r, child = "man/rmd/topic-embrace-constants.Rmd"} #' ``` #' #' @keywords internal #' @name topic-embrace-constants NULL #' `r title("topic_inject_out_of_context")` #' #' ```{r, child = "man/rmd/topic-inject-out-of-context.Rmd"} #' ``` #' #' @keywords internal #' @name topic-inject-out-of-context NULL rlang/R/trace.R0000644000176200001440000006677714710121314013020 0ustar liggesusers#' Capture a backtrace #' #' @description #' A backtrace captures the sequence of calls that lead to the current #' function (sometimes called the call stack). Because of lazy #' evaluation, the call stack in R is actually a tree, which the #' `print()` method for this object will reveal. #' #' Users rarely need to call `trace_back()` manually. Instead, #' signalling an error with [abort()] or setting up [global_entrace()] #' is the most common way to create backtraces when an error is #' thrown. Inspect the backtrace created for the most recent error #' with [last_error()]. #' #' `trace_length()` returns the number of frames in a backtrace. #' #' @param top The first frame environment to be included in the #' backtrace. This becomes the top of the backtrace tree and #' represents the oldest call in the backtrace. #' #' This is needed in particular when you call `trace_back()` #' indirectly or from a larger context, for example in tests or #' inside an RMarkdown document where you don't want all of the #' knitr evaluation mechanisms to appear in the backtrace. #' #' If not supplied, the `rlang_trace_top_env` global option is #' consulted. This makes it possible to trim the embedding context #' for all backtraces created while the option is set. If knitr is #' in progress, the default value for this option is #' `knitr::knit_global()` so that the knitr context is trimmed out #' of backtraces. #' @param bottom The last frame environment to be included in the #' backtrace. This becomes the rightmost leaf of the backtrace tree #' and represents the youngest call in the backtrace. #' #' Set this when you would like to capture a backtrace without the #' capture context. #' #' Can also be an integer that will be passed to [caller_env()]. #' @examples #' # Trim backtraces automatically (this improves the generated #' # documentation for the rlang website and the same trick can be #' # useful within knitr documents): #' options(rlang_trace_top_env = current_env()) #' #' f <- function() g() #' g <- function() h() #' h <- function() trace_back() #' #' # When no lazy evaluation is involved the backtrace is linear #' # (i.e. every call has only one child) #' f() #' #' # Lazy evaluation introduces a tree like structure #' identity(identity(f())) #' identity(try(f())) #' try(identity(f())) #' #' # When printing, you can request to simplify this tree to only show #' # the direct sequence of calls that lead to `trace_back()` #' x <- try(identity(f())) #' x #' print(x, simplify = "branch") #' #' # With a little cunning you can also use it to capture the #' # tree from within a base NSE function #' x <- NULL #' with(mtcars, {x <<- f(); 10}) #' x #' #' #' # Restore default top env for next example #' options(rlang_trace_top_env = NULL) #' #' # When code is executed indirectly, i.e. via source or within an #' # RMarkdown document, you'll tend to get a lot of guff at the beginning #' # related to the execution environment: #' conn <- textConnection("summary(f())") #' source(conn, echo = TRUE, local = TRUE) #' close(conn) #' #' # To automatically strip this off, specify which frame should be #' # the top of the backtrace. This will automatically trim off calls #' # prior to that frame: #' top <- current_env() #' h <- function() trace_back(top) #' #' conn <- textConnection("summary(f())") #' source(conn, echo = TRUE, local = TRUE) #' close(conn) #' @export trace_back <- function(top = NULL, bottom = NULL) { # FIXME: Include this in the `trace_back()` UI? visible_bottom <- peek_option("rlang:::visible_bottom") frames <- sys.frames() idx <- trace_find_bottom(bottom, frames) visible_idx <- trace_find_bottom(visible_bottom, frames) visible_idx <- intersect(visible_idx, idx) is_visible <- seq_along(idx) %in% visible_idx frames <- frames[idx] parents <- sys.parents()[idx] calls <- as.list(sys.calls()[idx]) calls <- map(calls, call_fix_car) calls <- map(calls, call_zap_inline) context <- empty_trace_context() if (length(calls)) { context_data <- map2(calls, seq_along(calls), call_trace_context) context$namespace <- do.call(base::c, map(context_data, `[[`, "namespace")) context$scope <- do.call(base::c, map(context_data, `[[`, "scope")) } context <- new_data_frame(context) parents <- normalise_parents(parents) trace <- new_trace( calls, parents, namespace = context$namespace, scope = context$scope, visible = is_visible ) error_frame <- peek_option("rlang:::error_frame") if (!is_null(error_frame)) { trace[["error_frame"]] <- FALSE i <- detect_index(frames, identical, error_frame) if (i) { trace[["error_frame"]][[i]] <- TRUE error_arg <- peek_option("rlang:::error_arg") if (!is_null(error_arg)) { if (is_null(trace[["error_arg"]])) { trace[["error_arg"]] <- list(NULL) } trace[["error_arg"]][[i]] <- error_arg # Match arguments so we can fully highlight the faulty input in # the backtrace. Preserve srcrefs from original frame call. matched <- call_match(trace$call[[i]], frame_fn(error_frame), defaults = TRUE) attributes(matched) <- attributes(trace$call[[i]]) trace$call[[i]] <- matched } } } trace <- add_winch_trace(trace) trace <- trace_trim_env(trace, frames, top) trace } trace_find_bottom <- function(bottom, frames, arg = caller_arg(bottom), call = caller_env()) { if (is_null(bottom)) { return(seq_len(sys.parent(2L))) } if (is_environment(bottom)) { top <- detect_index(frames, is_reference, bottom) if (!top) { if (is_reference(bottom, global_env())) { return(int()) } msg <- sprintf( "Can't find %s on the call tree.", format_arg(arg) ) abort(msg, call = call) } return(seq_len(top)) } if (is_integerish(bottom, n = 1)) { if (bottom < 0) { msg <- sprintf( "%s must be a positive integer.", format_arg(arg) ) abort(msg, call = call) } if (inherits(bottom, "AsIs")) { return(seq_len(bottom)) } else { return(seq_len(sys.parent(bottom + 1L))) } } msg <- sprintf( "%s must be `NULL`, a frame environment, or an integer.", format_arg(arg) ) abort(msg, call = call) } # Work around R bug causing promises to leak in frame calls call_fix_car <- function(call) { if (typeof(node_car(call)) == "promise") { node_poke_car(call, eval_bare(node_car(call))) } call } call_trace_context <- function(call, fn) { if (is_quosure(call)) { call <- quo_get_expr(call) if (!is_call(call)) { return(trace_context()) } } if (call_print_fine_type(call) != "call") { return(trace_context()) } namespace <- call_ns(call) name <- call_name(call) if (is_null(name)) { return(trace_context()) } if (!is_null(namespace)) { return(trace_context( namespace = namespace, scope = as_string(call[[1]][[1]]) )) } if (is_environment(fn)) { fn <- get(name, envir = fn, mode = "function") } else if (is_function(fn)) { fn <- fn } else { fn <- sys.function(fn) } env <- fn_env(fn) top <- topenv(env) if (is_reference(env, global_env())) { namespace <- NA scope <- "global" } else if (is_namespace(top)) { namespace <- ns_env_name(top) if (ns_exports_has(top, name)) { scope <- "::" } else if (env_has(top, name)) { scope <- ":::" } else { scope <- "local" } } else { namespace <- NA scope <- NA } trace_context( namespace = namespace, scope = scope ) } trace_context <- function(namespace = NA, scope = NA) { list( namespace = namespace, scope = scope ) } empty_trace_context <- function() { trace_context(chr(), chr()) } # Remove recursive frames which occur with quosures normalise_parents <- function(parents) { recursive <- parents == seq_along(parents) parents[recursive] <- 0L parents } # Can't use new_environment() here winch_available_env <- new.env(parent = emptyenv()) add_winch_trace <- function(trace) { # FIXME: Until r-prof/winch#56 is fixed return(trace) avail <- winch_available_env$installed if (is_null(avail)) { avail <- rlang::is_installed("winch") winch_available_env$installed <- avail } if (!avail) { return(trace) } use_winch <- peek_option("rlang_trace_use_winch") %||% FALSE if (!is_true(as.logical(use_winch))) { return(trace) } winch::winch_add_trace_back(trace) } # Construction ------------------------------------------------------------ new_trace <- function(call, parent, ..., visible = TRUE, namespace = na_chr, scope = na_chr, class = NULL) { new_trace0( call, parent, ..., visible = visible, namespace = namespace, scope = scope, class = c(class, "rlang_trace", "rlib_trace") ) } new_trace0 <- function(call, parent, ..., visible = TRUE, namespace = NA, scope = NA, class = NULL) { if (is_pairlist(call)) { call <- as.list(call) } stopifnot( is_bare_list(call), is_bare_integer(parent) ) df <- df_list( call = call, parent = parent, visible = visible, namespace = namespace, scope = scope, ... ) new_data_frame( df, .class = c(class, "tbl"), version = 2L ) } # Operations -------------------------------------------------------------- #' @rdname trace_back #' @param trace A backtrace created by `trace_back()`. #' @export trace_length <- function(trace) { nrow(trace) } trace_slice <- function(trace, i) { i <- vec_as_location(i, trace_length(trace)) parent <- match(trace$parent, i, nomatch = 0) out <- vec_slice(trace, i) out$parent <- parent[i] out } trace_bind <- function(...) { traces <- compact(list2(...)) n <- length(traces) if (!every(traces, inherits, "rlang_trace")) { abort("`...` must contain backtraces.") } if (n == 0L) { return(new_trace(list(), int())) } if (n == 1L) { return(traces[[1]]) } out <- reduce(traces, function(x, y) { if (identical(x$call, y$call)) { return(x) } y$parent <- y$parent + nrow(x) vec_rbind(as.data.frame(x), as.data.frame(y)) }) new_data_frame(out, .class = c("rlang_trace", "rlib_trace", "tbl")) } # Methods ----------------------------------------------------------------- # For internal use only c.rlang_trace <- function(...) { traces <- list(...) calls <- flatten(map(traces, `[[`, "call")) parents <- flatten_int(map(traces, `[[`, "parent")) new_trace(calls, parents) } #' @export format.rlang_trace <- function(x, ..., simplify = c("none", "branch"), max_frames = NULL, dir = getwd(), srcrefs = NULL, drop = FALSE) { switch( arg_match_simplify(simplify), none = trace_format(x, max_frames, dir, srcrefs, drop = drop, ...), branch = trace_format_branch(x, max_frames, dir, srcrefs) ) } arg_match_simplify <- function(simplify, call = caller_env()) { if (is_null(simplify)) { return("none") } if (is_string(simplify, "collapse")) { deprecate_collapse() simplify <- "none" } arg_match0(simplify, c("none", "branch"), error_call = call) } arg_match_drop <- function(drop) { drop %||% TRUE } deprecate_collapse <- function() { deprecate_warn("`\"collapse\"` is deprecated as of rlang 1.1.0.\nPlease use `\"none\"` instead.") } trace_format <- function(trace, max_frames, dir, srcrefs, drop = FALSE, ...) { if (is_false(drop) && length(trace$visible)) { trace$visible <- TRUE } if (!is_null(max_frames)) { msg <- "`max_frames` is currently only supported with `simplify = \"branch\"`" stop(msg, call. = FALSE) } if (!trace_length(trace)) { return(trace_root()) } tree <- trace_as_tree( trace, dir = dir, srcrefs = srcrefs, drop = drop ) cli_tree(tree) } trace_format_branch <- function(trace, max_frames, dir, srcrefs) { trace <- trace_simplify_branch(trace) tree <- trace_as_tree(trace, dir = dir, srcrefs = srcrefs) # Remove root in the branch view tree <- vec_slice(tree, -1) cli_branch(tree, max = max_frames) } cli_branch <- function(tree, max = NULL, style = NULL) { lines <- tree$call_text if (!length(lines)) { return(chr()) } indices <- tree$id indices <- pad_spaces(as.character(indices)) indices <- paste0(" ", indices, ". ") padding <- spaces(nchar(indices[[1]])) lines <- paste0(col_silver(indices), lines) src_locs <- tree$src_loc src_locs <- map_if(src_locs, nzchar, ~ paste0(padding, " at ", .x)) src_locs <- style_locs(src_locs) lines <- zip_chr(lines, src_locs) if (is_null(max)) { return(lines) } stopifnot( is_scalar_integerish(max, finite = TRUE), max > 0L ) n <- length(lines) if (n <= max) { return(lines) } style <- style %||% cli_box_chars() n_collapsed <- n - max collapsed_line <- paste0(padding, "...") if (max == 1L) { lines <- chr( lines[1L], collapsed_line ) return(lines) } half <- max / 2L n_top <- ceiling(half) n_bottom <- floor(half) chr( lines[seq(1L, n_top)], collapsed_line, lines[seq(n - n_bottom + 1L, n)] ) } style_locs <- function(locs) { chr(map_if(locs, nzchar, col_grey)) } zip_chr <- function(xs, ys) { list_c(map2(xs, ys, function(x, y) { if (nzchar(y)) { c(x, y) } else { x } })) } #' @export print.rlang_trace <- function(x, ..., simplify = c("none", "branch"), max_frames = NULL, dir = getwd(), srcrefs = NULL) { simplify <- arg_match_simplify(simplify) cat_line(format(x, ..., simplify = simplify, max_frames = max_frames, dir = dir, srcrefs = srcrefs )) invisible(x) } #' @export summary.rlang_trace <- function(object, ..., max_frames = NULL, dir = getwd(), srcrefs = NULL) { cat_line(format(object, ..., simplify = "none", max_frames = max_frames, dir = dir, srcrefs = srcrefs )) invisible(object) } # Trimming ---------------------------------------------------------------- trace_trim_env <- function(x, frames, to) { idx <- trace_trim_env_idx(trace_length(x), frames, to) trace_slice(x, idx) } trace_trim_env_idx <- function(n, frames, to) { to <- to %||% peek_option("rlang_trace_top_env") # Trim knitr context if available if (is_null(to) && is_true(peek_option('knitr.in.progress'))) { to <- knitr::knit_global() } if (is.null(to)) { return(TRUE) } is_top <- map_lgl(frames, is_reference, to) if (!any(is_top)) { return(TRUE) } start <- last(which(is_top)) + 1L seq2(start, n) } trace_simplify_branch <- function(trace) { if (!trace_length(trace)) { return(trace) } parents <- trace$parent old_visible <- trace$visible visible <- rep_along(old_visible, FALSE) old_visible_loc <- which(old_visible) if (length(old_visible_loc)) { id <- last(old_visible_loc) } else { id <- 0L } while (id != 0L) { # Set `old_visible` to avoid uninformative calls in position 1 to # be included (see below) if (is_uninformative_call(trace$call[[id]])) { old_visible[[id]] <- FALSE } else if (old_visible[[id]]) { visible[[id]] <- TRUE } id <- parents[id] } # Always include first visible call first <- detect_index(old_visible, is_true) if (first) { visible[[first]] <- TRUE } trace$visible <- visible trace$parent <- parents trace } # Bypass calls with inlined functions is_uninformative_call <- function(call) { if (!is_call2(call)) { return(FALSE) } fn <- call[[1]] if (is_winch_frame(fn)) { return(TRUE) } # Inlined functions occur with active bindings if (is_function(fn)) { return(TRUE) } # If a call, might be wrapped in parentheses while (is_call2(fn, "(")) { fn <- fn[[2]] if (is_call2(fn, "function")) { return(TRUE) } } FALSE } # To be replaced with a more structured way of disabling frames in # various displays is_winch_frame <- function(call) { if (!is_call(call, "::")) { return(FALSE) } lhs <- call[[2]] if (!is_symbol(lhs)) { return(FALSE) } name <- as_string(lhs) grepl("^[/\\\\].+[.]", name) } # Printing ---------------------------------------------------------------- trace_as_tree <- function(trace, dir = getwd(), srcrefs = NULL, drop = FALSE) { root_id <- 0 root_children <- list(find_children(root_id, trace$parent)) trace$id <- seq_len(nrow(trace)) trace$children <- map(trace$id, find_children, trace$parent) # Subset out hidden frames trace <- trace_slice(trace, trace$visible) trace$children <- map(trace$children, intersect, trace$id) root_children[[1]] <- intersect(root_children[[1]], trace$id) params <- intersect( c("call", "namespace", "scope", "error_frame", "error_arg"), names(trace) ) trace$call_text <- chr(!!!pmap(trace[params], trace_call_text)) srcrefs <- srcrefs %||% peek_option("rlang_trace_format_srcrefs") %||% TRUE stopifnot(is_scalar_logical(srcrefs)) if (srcrefs) { refs <- map(trace$call, attr, "srcref") src_locs <- map_chr(refs, src_loc) trace$src_loc <- src_locs } else { trace$src_loc <- vec_recycle("", trace_length(trace)) } root <- data_frame( call = list(NULL), parent = 0L, visible = TRUE, namespace = NA, scope = NA, src_loc = "", id = root_id, children = root_children, call_text = trace_root() ) trace <- vec_rbind(root, trace) if (drop) { trace$node_type <- node_type(lengths(trace$children), trace$children) } else { trace$node_type <- rep_len("main", nrow(trace)) } if (has_ansi()) { # Detect runs of namespaces/global ns <- trace$namespace ns <- ifelse(is.na(ns) & trace$scope == "global", "global", ns) ns[[1]] <- "_root" starts <- detect_run_starts(ns) # Embolden first occurrences in runs of namespaces/global trace$call_text <- map2_chr(trace$call_text, starts, function(text, start) { if (is_true(start)) { text <- sub( "^([a-zA-Z]+)(::|:::| )", sprintf("%s\\1%s\\2", open_bold(), close_bold()), text ) } text }) } trace } find_children <- function(id, parent) { seq_along(parent)[parent == id] } node_type <- function(ns, children) { type <- rep_along(ns, "main") for (i in seq_along(ns)) { n <- ns[[i]] if (is_string(type[[i]], "main")) { if (n >= 2) { val <- if (i == 1) "main_sibling" else "sibling" idx <- as.numeric(children[[i]][-n]) + 1 type[idx] <- val } } else { if (n >= 1) { idx <- as.numeric(children[[i]][-1]) + 1 type[idx] <- "sibling" } } } type } # FIXME: Add something like call_deparse_line() trace_call_text <- function(call, namespace, scope, error_frame = FALSE, error_arg = NULL) { if (is_call(call) && is_symbol(call[[1]])) { if (scope %in% c("::", ":::") && !is_na(namespace)) { call[[1]] <- call(scope, sym(namespace), call[[1]]) } } if (error_frame) { text <- call_deparse_highlight(call, error_arg) } else { text <- as_label(call) } if (is_string(scope, "global")) { text <- paste0("global ", text) } else if (is_string(scope, "local") && !is_na(namespace)) { text <- paste0(namespace, " (local) ", text) } text } src_loc <- function(srcref) { if (is.null(srcref)) { return("") } srcfile <- attr(srcref, "srcfile") if (is.null(srcfile)) { return("") } file <- srcfile$filename if (identical(file, "") || identical(file, "")) { return("") } if (is_null(peek_option("rlang:::disable_trim_srcref"))) { file_trim <- path_trim_prefix(file, 3) } else { file_trim <- file } line <- srcref[[1]] column <- srcref[[5]] style_hyperlink( paste0(file_trim, ":", line, ":", column), paste0("file://", normalizePath(file, mustWork = FALSE)), params = c(line = line, col = column) ) } trace_root <- function() { if (cli_is_utf8_output()) { "\u2586" } else { "x" } } #' Trace functions from a set of packages #' #' @param pkgs One or more package names whose functions should be traced. #' @param max_level Maximum nesting level of call stack. #' @param regexp Regular expression passed to [base::grepl()] to #' select which functions should be traced. Can be a single string #' or a vector as long as `pkgs`. #' @param ... These dots are for future extensions and should be empty. #' #' @author Iñaki Ucar (ORCID: 0000-0001-6403-5550) #' @noRd trace_pkgs <- function(pkgs, max_level = Inf, ..., regexp = NULL) { check_dots_empty() if (length(regexp) == 1) { regexp <- rep_along(pkgs, regexp) } fns <- lapply(seq_along(pkgs), function(i) { fns <- as.list(ns_env(pkgs[[i]])) fns <- keep(fns, is_closure) fns <- names(fns) if (!is_null(regexp)) { fns <- fns[grepl(regexp[[i]], fns)] } fns }) names(fns) <- pkgs trace_fns(fns) } trace_fns <- function(fns, max_level = Inf) { stopifnot( is_list(fns), every(fns, is_character) ) c(tracer, exit) %<-% new_tracers(max_level) pkgs <- names(fns) for (i in seq_along(pkgs)) { nms <- fns[[i]] pkg <- pkgs[[i]] ns <- ns_env(pkg) suppressMessages(trace( nms, tracer = tracer, exit = exit, print = FALSE, where = ns )) message(sprintf( "Tracing %d functions in %s.", length(nms), pkg )) } } utils::globalVariables(c("tracer", "exit")) new_tracers <- function(max_level) { trace_level <- 0 # Create a thunk because `trace()` sloppily transforms functions into calls tracer <- call2(function() { trace_level <<- trace_level + 1 if (trace_level > max_level) { return() } # Work around sys.foo() weirdness get_fn <- call2(function(fn = sys.function(sys.parent())) fn) fn <- eval(get_fn, envir = parent.frame()) try(silent = TRUE, { call <- evalq(base::match.call(), envir = parent.frame()) call <- call_add_namespace(call, fn) indent <- paste0(rep(" ", (trace_level - 1) * 2), collapse = "") line <- paste0(indent, as_label(call)) cat(line, "\n") }) }) exit <- call2(function() { trace_level <<- trace_level - 1 }) list(tracer = tracer, exit = exit) } call_add_namespace <- function(call, fn) { if (!is.call(call) || !is.symbol(call[[1]])) { return(call) } sym <- call[[1]] nm <- as_string(sym) if (nm %in% c("::", ":::")) { return(call) } env <- environment(fn) top <- topenv(env) if (is_reference(env, globalenv())) { prefix <- "global" op <- "::" } else if (is_namespace(top)) { prefix <- ns_env_name(top) if (ns_exports_has(top, nm)) { op <- "::" } else { op <- ":::" } } else { return(call) } namespaced_sym <- call(op, sym(prefix), sym) call[[1]] <- namespaced_sym call } is_trace <- function(x) { inherits_any(x, c("rlang_trace", "rlib_trace")) } #' Backtrace specification #' #' @description #' #' `r lifecycle::badge("experimental")` #' #' #' @section Structure: #' #' An r-lib backtrace is a data frame that contains the following #' columns: #' #' - `call`: List of calls. These may carry `srcref` objects. #' #' - `visible`: Logical vector. If `FALSE`, the corresponding call #' will be hidden from simplified backtraces. #' #' - `parent`: Integer vector of parent references (see #' [sys.parents()]) as row numbers. 0 is global. #' #' - `namespace`: Character vector of namespaces. `NA` for global or #' no namespace #' #' - `scope`: Character vector of strings taking values `"::"`, #' `":::"`, `"global"`, or `"local"`. #' #' A backtrace data frame may contain extra columns. If you add #' additional columns, make sure to prefix their names with the name #' of your package or organisation to avoid potential conflicts with #' future extensions of this spec, e.g. `"mypkg_column"`. #' #' #' @section Operations: #' #' - **Length**. The length of the backtrace is the number of rows of #' the underlying data. #' #' - **Concatenation**. Performed by row-binding two backtraces. The #' `parent` column of the RHS is shifted by `nrow(LHS)` so that the #' last call of the LHS takes place of the global frame of the RHS. #' #' - **Subsetting**. Performed by slicing the backtrace. After the #' data frame is sliced, the `parent` column is adjusted to the new #' row indices. Any `parent` value that no longer exists in the #' sliced backtrace is set to 0 (the global frame). #' #' #' @name rlib_trace_spec #' @keywords internal NULL local_error_highlight <- function(frame = caller_env(), code = TRUE) { if (!has_cli_start_app) { return() } if (is_true(peek_option("rlang:::trace_test_highlight"))) { if (code) { theme <- theme_error_highlight_test } else { theme <- theme_error_arg_highlight_test } } else { if (code) { theme <- theme_error_highlight } else { theme <- theme_error_arg_highlight } } cli::start_app(theme, .envir = frame) } with_error_highlight <- function(expr) { local_error_highlight() expr } # Used for highlighting `.arg` spans in error messages without # affecting `.code` spans with_error_arg_highlight <- function(expr) { local_options("rlang:::error_highlight" = TRUE) local_error_highlight(code = FALSE) expr } on_load({ theme_error_highlight <- local({ if (ns_exports_has("cli", "builtin_theme")) { cli_theme <- cli::builtin_theme() } else { cli_theme <- list() } arg_theme <- list( "color" = "br_magenta", "font-weight" = "bold" ) code_theme <- list( "color" = "br_blue", "font-weight" = "bold" ) list( "span.arg" = utils::modifyList( cli_theme[["span.arg"]] %||% list(), arg_theme ), "span.code" = utils::modifyList( cli_theme[["span.code"]] %||% list(), code_theme ), "span.arg-unquoted" = arg_theme, "span.code-unquoted" = code_theme ) }) theme_error_arg_highlight <- theme_error_highlight theme_error_arg_highlight[c("span.code", "span.code-unquoted")] <- NULL }) theme_error_highlight_test <- list( "span.arg" = list(before = "<", x) } else { x } } if (n[i] < mx[i]) { if (i == length(n)) { if (deemphasise) { mark_deemph(paste0(style$j, style$h)) } else if (!main_sibling && !full_emphasis) { paste0(style$j, mark_deemph(style$h)) } else { paste0(style$j, style$h) } } else { # Detect first "|" branch displayed by taking into account # the empty " " spaces past <- seq_len(i) n_spaces <- sum(n[past] >= mx[past] & past != length(n)) if (!deemphasise || i == 1 + n_spaces) { paste0(style$v, " ") } else { mark_deemph(paste0(style$v, " ")) } } } else if (n[i] == mx[i] && i == length(n)) { if (deemphasise) { mark_deemph(paste0(style$l, style$h)) } else { paste0(style$l, style$h) } } else { " " } }) line <- paste0(paste(prefix, collapse = ""), labels[[num_root]]) if (marked_deemph) { parts <- strsplit(line, "")[[1]] line <- paste0(parts[[1]], trace_deemph(parts[[2]])) } res <<- c(res, line) children <- data$children[[num_root]] deemphasise <- deemphasise || !is_string(data$node_type[[num_root]], "main") for (d in seq_along(children)) { pt(children[[d]], c(n, d), c(mx, length(children)), deemphasise = deemphasise) } } if (nrow(data)) { pt(root) } indices <- data$id[-1] if (length(indices)) { indices <- pad_spaces(indices) indices <- paste0(" ", indices, ". ") # The root isn't numbered root_padding <- spaces(nchar(indices[[1]])) indices <- c(root_padding, indices) res <- paste0(col_silver(indices), res) } res } trace_deemph <- function(x) { deemph <- peek_option("rlang:::trace_deemph") %||% style_dim_soft deemph(x) } cli_box_chars <- function() { if (cli_is_utf8_output()) { list( "h" = "\u2500", # horizontal "v" = "\u2502", # vertical "l" = "\u2514", # leaf "j" = "\u251C" # junction ) } else { list( "h" = "-", # horizontal "v" = "|", # vertical "l" = "\\", # leaf "j" = "+" # junction ) } } cli_is_utf8_output <- function() { opt <- getOption("cli.unicode", NULL) if (!is.null(opt)) { isTRUE(opt) } else { l10n_info()$`UTF-8` && !cli_is_latex_output() } } cli_is_latex_output <- function() { if (!("knitr" %in% loadedNamespaces())) return(FALSE) get("is_latex_output", asNamespace("knitr"))() } rlang/R/standalone-sizes.R0000644000176200001440000000602214375670676015211 0ustar liggesusers# --- # repo: r-lib/rlang # file: standalone-sizes.R # last-updated: 2022-06-23 # license: https://unlicense.org # --- # # nocov start format_bytes <- local({ pretty_bytes <- function(bytes, style = c("default", "nopad", "6")) { style <- switch( match.arg(style), "default" = pretty_bytes_default, "nopad" = pretty_bytes_nopad, "6" = pretty_bytes_6 ) style(bytes) } compute_bytes <- function(bytes, smallest_unit = "B") { units0 <- c("B", "kB", "MB", "GB", "TB", "PB", "EB", "ZB", "YB") stopifnot( is.numeric(bytes), is.character(smallest_unit), length(smallest_unit) == 1, !is.na(smallest_unit), smallest_unit %in% units0 ) limits <- c(1000, 999950 * 1000 ^ (seq_len(length(units0) - 2) - 1)) low <- match(smallest_unit, units0) units <- units0[low:length(units0)] limits <- limits[low:length(limits)] neg <- bytes < 0 & !is.na(bytes) bytes <- abs(bytes) mat <- matrix( rep(bytes, each = length(limits)), nrow = length(limits), ncol = length(bytes) ) mat2 <- matrix(mat < limits, nrow = length(limits), ncol = length(bytes)) exponent <- length(limits) - colSums(mat2) + low - 1L res <- bytes / 1000 ^ exponent unit <- units[exponent - low + 2L] ## Zero bytes res[bytes == 0] <- 0 unit[bytes == 0] <- units[1] ## NA and NaN bytes res[is.na(bytes)] <- NA_real_ res[is.nan(bytes)] <- NaN unit[is.na(bytes)] <- units0[low] # Includes NaN as well data.frame( stringsAsFactors = FALSE, amount = res, unit = unit, negative = neg ) } pretty_bytes_default <- function(bytes) { szs <- compute_bytes(bytes) amt <- szs$amount ## String. For fractions we always show two fraction digits res <- character(length(amt)) int <- is.na(amt) | amt == as.integer(amt) res[int] <- format( ifelse(szs$negative[int], -1, 1) * amt[int], scientific = FALSE ) res[!int] <- sprintf("%.2f", ifelse(szs$negative[!int], -1, 1) * amt[!int]) format(paste(res, szs$unit), justify = "right") } pretty_bytes_nopad <- function(bytes) { sub("^\\s+", "", pretty_bytes_default(bytes)) } pretty_bytes_6 <- function(bytes) { szs <- compute_bytes(bytes, smallest_unit = "kB") amt <- szs$amount na <- is.na(amt) nan <- is.nan(amt) neg <- !na & !nan & szs$negative l10 <- !na & !nan & !neg & amt < 10 l100 <- !na & !nan & !neg & amt >= 10 & amt < 100 b100 <- !na & !nan & !neg & amt >= 100 szs$unit[neg] <- "kB" famt <- character(length(amt)) famt[na] <- " NA" famt[nan] <- "NaN" famt[neg] <- "< 0" famt[l10] <- sprintf("%.1f", amt[l10]) famt[l100] <- sprintf(" %.0f", amt[l100]) famt[b100] <- sprintf("%.0f", amt[b100]) paste0(famt, " ", szs$unit) } structure( list( .internal = environment(), pretty_bytes = pretty_bytes, compute_bytes = compute_bytes ), class = c("standalone_bytes", "standalone") ) }) # nocov end rlang/R/operators.R0000644000176200001440000000475214547214127013736 0ustar liggesusers#' Default value for `NULL` #' #' This infix function makes it easy to replace `NULL`s with a default #' value. It's inspired by the way that Ruby's or operation (`||`) #' works. #' #' @param x,y If `x` is NULL, will return `y`; otherwise returns `x`. #' @export #' @name op-null-default #' @examples #' 1 %||% 2 #' NULL %||% 2 `%||%` <- function(x, y) { if (is_null(x)) y else x } # Reexport from base on newer versions of R to avoid conflict messages if (exists("%||%", envir = baseenv())) { `%||%` <- get("%||%", envir = baseenv()) } `%|0|%` <- function(x, y) { if (!length(x)) y else x } #' Replace missing values #' #' @description #' __Note__: This operator is now out of scope for rlang. It will be #' replaced by a vctrs-powered operator (probably in the [funs #' package](https://github.com/tidyverse/funs)) at which point the #' rlang version of `%|%` will be deprecated. #' #' This infix function is similar to \code{\%||\%} but is vectorised #' and provides a default value for missing elements. It is faster #' than using [base::ifelse()] and does not perform type conversions. #' #' @param x The original values. #' @param y The replacement values. Must be of length 1 or the same length as `x`. #' @keywords internal #' @export #' @name op-na-default #' @seealso [op-null-default] #' @examples #' c("a", "b", NA, "c") %|% "default" #' c(1L, NA, 3L, NA, NA) %|% (6L:10L) `%|%` <- function(x, y) { .Call(ffi_replace_na, x, y) } #' Infix attribute accessor and setter #' #' This operator extracts or sets attributes for regular objects and #' S4 fields for S4 objects. #' #' @param x Object #' @param name Attribute name #' @export #' @name op-get-attr #' @examples #' # Unlike `@`, this operator extracts attributes for any kind of #' # objects: #' factor(1:3) %@% "levels" #' mtcars %@% class #' #' mtcars %@% class <- NULL #' mtcars #' #' # It also works on S4 objects: #' .Person <- setClass("Person", slots = c(name = "character", species = "character")) #' fievel <- .Person(name = "Fievel", species = "mouse") #' fievel %@% name `%@%` <- function(x, name) { name <- as_string(ensym(name)) if (isS4(x)) { eval_bare(expr(`@`(x, !!name))) } else { attr(x, name, exact = TRUE) } } #' @rdname op-get-attr #' @param value New value for attribute `name`. #' @usage x \%@\% name <- value #' @export `%@%<-` <- function(x, name, value) { name <- as_string(ensym(name)) if (isS4(x)) { eval_bare(expr(`@`(x, !!name) <- value)) } else { eval_bare(expr(attr(x, !!name) <- value)) } x } rlang/R/quo.R0000644000176200001440000004676014457435161012534 0ustar liggesusers#' Quosure getters, setters and predicates #' #' @description #' These tools inspect and modify [quosures][topic-quosure], a type of #' [defused expression][topic-defuse] that includes a reference to the #' context where it was created. A quosure is guaranteed to evaluate #' in its original environment and can refer to local objects safely. #' #' - You can access the quosure components with `quo_get_expr()` and #' `quo_get_env()`. #' #' - The `quo_` prefixed predicates test the expression of a quosure, #' `quo_is_missing()`, `quo_is_symbol()`, etc. #' #' All `quo_` prefixed functions expect a quosure and will fail if #' supplied another type of object. Make sure the input is a quosure #' with [is_quosure()]. #' #' @section Empty quosures and missing arguments: #' When missing arguments are captured as quosures, either through #' [enquo()] or [quos()], they are returned as an empty quosure. These #' quosures contain the [missing argument][missing_arg] and typically #' have the [empty environment][empty_env] as enclosure. #' #' Use `quo_is_missing()` to test for a missing argument defused with #' [enquo()]. #' #' @seealso #' * [quo()] for creating quosures by [argument defusal][topic-defuse]. #' * [new_quosure()] and [as_quosure()] for assembling quosures from #' components. #' * `r link("topic_quosure")` for an overview. #' #' @name quosure-tools #' @aliases quosure #' #' @examples #' quo <- quo(my_quosure) #' quo #' #' #' # Access and set the components of a quosure: #' quo_get_expr(quo) #' quo_get_env(quo) #' #' quo <- quo_set_expr(quo, quote(baz)) #' quo <- quo_set_env(quo, empty_env()) #' quo #' #' # Test wether an object is a quosure: #' is_quosure(quo) #' #' # If it is a quosure, you can use the specialised type predicates #' # to check what is inside it: #' quo_is_symbol(quo) #' quo_is_call(quo) #' quo_is_null(quo) #' #' # quo_is_missing() checks for a special kind of quosure, the one #' # that contains the missing argument: #' quo() #' quo_is_missing(quo()) #' #' fn <- function(arg) enquo(arg) #' fn() #' quo_is_missing(fn()) NULL #' @rdname quosure-tools #' @param quo A quosure to test. #' @export quo_is_missing <- function(quo) { .Call(ffi_quo_is_missing, quo) } #' @rdname quosure-tools #' @param name The name of the symbol or function call. If `NULL` the #' name is not tested. #' @export quo_is_symbol <- function(quo, name = NULL) { is_symbol(quo_get_expr(quo), name = name) } #' @rdname quosure-tools #' @inheritParams is_call #' @export quo_is_call <- function(quo, name = NULL, n = NULL, ns = NULL) { is_call(quo_get_expr(quo), name = name, n = n, ns = ns) } #' @rdname quosure-tools #' @export quo_is_symbolic <- function(quo) { .Call(ffi_quo_is_symbolic, quo) } #' @rdname quosure-tools #' @export quo_is_null <- function(quo) { .Call(ffi_quo_is_null, quo) } #' @rdname quosure-tools #' @export quo_get_expr <- function(quo) { .Call(ffi_quo_get_expr, quo) } #' @rdname quosure-tools #' @export quo_get_env <- function(quo) { .Call(ffi_quo_get_env, quo) } #' @rdname quosure-tools #' @param expr A new expression for the quosure. #' @export quo_set_expr <- function(quo, expr) { .Call(ffi_quo_set_expr, quo, expr) } #' @rdname quosure-tools #' @param env A new environment for the quosure. #' @export quo_set_env <- function(quo, env) { .Call(ffi_quo_set_env, quo, env) } #' Create a quosure from components #' #' @description #' * `new_quosure()` wraps any R object (including expressions, #' formulas, or other quosures) into a [quosure][topic-quosure]. #' #' * `as_quosure()` is similar but it does not rewrap formulas and #' quosures. #' #' @param x For `is_quosure()`, an object to test. For `as_quosure()`, #' an object to convert. #' @param expr An expression to wrap in a quosure. #' @param env The environment in which the expression should be #' evaluated. Only used for symbols and calls. This should normally #' be the environment in which the expression was created. #' #' @seealso #' * [enquo()] and [quo()] for creating a quosure by [argument #' defusal][topic-defuse]. #' #' * `r link("topic_quosure")` #' @examples #' # `new_quosure()` creates a quosure from its components. These are #' # equivalent: #' new_quosure(quote(foo), current_env()) #' #' quo(foo) #' #' # `new_quosure()` always rewraps its input into a new quosure, even #' # if the input is itself a quosure: #' new_quosure(quo(foo)) #' #' # This is unlike `as_quosure()` which preserves its input if it's #' # already a quosure: #' as_quosure(quo(foo)) #' #' #' # `as_quosure()` uses the supplied environment with naked expressions: #' env <- env(var = "thing") #' as_quosure(quote(var), env) #' #' # If the expression already carries an environment, this #' # environment is preserved. This is the case for formulas and #' # quosures: #' as_quosure(~foo, env) #' #' as_quosure(~foo) #' #' # An environment must be supplied when the input is a naked #' # expression: #' try( #' as_quosure(quote(var)) #' ) #' @export new_quosure <- function(expr, env = caller_env()) { .Call(ffi_new_quosure, expr, env) } #' @rdname new_quosure #' @export as_quosure <- function(x, env = NULL) { if (is_quosure(x)) { return(x) } if (is_bare_formula(x)) { env <- f_env(x) if (is_null(env)) { abort(paste_line( "The formula does not have an environment.", "This is a quoted formula that was never evaluated." )) } return(new_quosure(f_rhs(x), env)) } if (is_symbolic(x)) { if (is_null(env)) { deprecate_warn(paste_line( "`as_quosure()` requires an explicit environment as of rlang 0.3.0.", "Please supply `env`." )) env <- caller_env() } return(new_quosure(x, env)) } new_quosure(x, empty_env()) } #' @rdname new_quosure #' @param x An object to test. #' @export is_quosure <- function(x) { inherits(x, "quosure") } #' Create a list of quosures #' #' @description #' #' This small S3 class provides methods for `[` and `c()` and ensures #' the following invariants: #' #' * The list only contains quosures. #' * It is always named, possibly with a vector of empty strings. #' #' `new_quosures()` takes a list of quosures and adds the `quosures` #' class and a vector of empty names if needed. `as_quosures()` calls #' [as_quosure()] on all elements before creating the `quosures` #' object. #' #' @param x A list of quosures or objects to coerce to quosures. #' @param env The default environment for the new quosures. #' @param named Whether to name the list with [quos_auto_name()]. #' @export new_quosures <- function(x) { if (!is_list(x) || !every(x, is_quosure)) { abort("Expected a list of quosures") } structure(x, class = c("quosures", "list"), names = names2(x) ) } #' @rdname new_quosures #' @export as_quosures <- function(x, env, named = FALSE) { x <- map(x, as_quosure, env = env) if (named) { x <- quos_auto_name(x) } new_quosures(x) } #' @rdname new_quosures #' @export is_quosures <- function(x) { inherits(x, "quosures") } #' @export `[.quosures` <- function(x, i) { structure(NextMethod(), class = c("quosures", "list")) } #' @export c.quosures <- function(..., recursive = FALSE) { out <- NextMethod() if (every(out, is_quosure)) { new_quosures(out) } else { deprecate_warn(paste_line( "Quosure lists can't be concatenated with objects other than quosures as of rlang 0.3.0.", "Please call `as.list()` on the quosure list first." )) out } } #' @export print.quosures <- function(x, ...) { cat_line(">\n") print(unclass(x), ...) } #' @export as.list.quosures <- function(x, ...) { unclass(x) } #' @export `[<-.quosures` <- function(x, i, value) { if (idx <- detect_index(value, negate(is_quosure))) { signal_quosure_assign(value[[idx]]) } NextMethod() } #' @export `[[<-.quosures` <- function(x, i, value) { if (!is_quosure(value) && !is_null(value)) { signal_quosure_assign(value) } NextMethod() } #' @export `$<-.quosures` <- function(x, name, value) { x[[name]] <- value x } signal_quosure_assign <- function(x) { deprecate_warn(paste_line( "Assigning non-quosure objects to quosure lists is deprecated as of rlang 0.3.0.", "Please coerce to a bare list beforehand with `as.list()`" )) } pillar_shaft.quosures <- function(x, ...) { labels <- map_chr(unname(x), as_label) structure(labels, width = 10L) } type_sum.quosures <- function(x, ...) { "quos" } on_load({ s3_register("pillar::pillar_shaft", "quosures", pillar_shaft.quosures) s3_register("pillar::type_sum", "quosures", type_sum.quosures) }) #' Squash a quosure #' #' @description #' #' `quo_squash()` flattens all nested quosures within an expression. #' For example it transforms `^foo(^bar(), ^baz)` to the bare #' expression `foo(bar(), baz)`. #' #' This operation is safe if the squashed quosure is used for #' labelling or printing (see [as_label()], but note that `as_label()` #' squashes quosures automatically). However if the squashed quosure #' is evaluated, all expressions of the flattened quosures are #' resolved in a single environment. This is a source of bugs so it is #' good practice to set `warn` to `TRUE` to let the user know about #' the lossy squashing. #' #' @param quo A quosure or expression. #' @param warn Whether to warn if the quosure contains other quosures #' (those will be collapsed). This is useful when you use #' `quo_squash()` in order to make a non-tidyeval API compatible #' with quosures. In that case, getting rid of the nested quosures #' is likely to cause subtle bugs and it is good practice to warn #' the user about it. #' #' @export #' @examples #' # Quosures can contain nested quosures: #' quo <- quo(wrapper(!!quo(wrappee))) #' quo #' #' # quo_squash() flattens all the quosures and returns a simple expression: #' quo_squash(quo) quo_squash <- function(quo, warn = FALSE) { # Never warn when unwrapping outer quosure if (is_quosure(quo)) { quo <- quo_get_expr(quo) } if (is_missing(quo)) { missing_arg() } else { quo_squash_impl(duplicate(quo), warn = warn) } } #' Format quosures for printing or labelling #' #' @keywords internal #' @description #' `r lifecycle::badge("superseded")` #' #' **Note:** You should now use [as_label()] or [as_name()] instead #' of `quo_name()`. See life cycle section below. #' #' These functions take an arbitrary R object, typically an #' [expression][is_expression], and represent it as a string. #' #' * `quo_name()` returns an abbreviated representation of the object #' as a single line string. It is suitable for default names. #' #' * `quo_text()` returns a multiline string. For instance block #' expressions like `{ foo; bar }` are represented on 4 lines (one #' for each symbol, and the curly braces on their own lines). #' #' These deparsers are only suitable for creating default names or #' printing output at the console. The behaviour of your functions #' should not depend on deparsed objects. If you are looking for a way #' of transforming symbols to strings, use [as_string()] instead of #' `quo_name()`. Unlike deparsing, the transformation between symbols #' and strings is non-lossy and well defined. #' #' @inheritParams quo_squash #' @inheritParams expr_label #' #' @section Life cycle: #' #' These functions are superseded. #' #' * [as_label()] and [as_name()] should be used instead of #' `quo_name()`. `as_label()` transforms any R object to a string #' but should only be used to create a default name. Labelisation is #' not a well defined operation and no assumption should be made #' about the label. On the other hand, `as_name()` only works with #' (possibly quosured) symbols, but is a well defined and #' deterministic operation. #' #' * We don't have a good replacement for `quo_text()` yet. See #' to follow discussions #' about a new deparsing API. #' #' @seealso [expr_label()], [f_label()] #' @examples #' # Quosures can contain nested quosures: #' quo <- quo(foo(!! quo(bar))) #' quo #' #' # quo_squash() unwraps all quosures and returns a raw expression: #' quo_squash(quo) #' #' # This is used by quo_text() and quo_label(): #' quo_text(quo) #' #' # Compare to the unwrapped expression: #' expr_text(quo) #' #' # quo_name() is helpful when you need really short labels: #' quo_name(quo(sym)) #' quo_name(quo(!! sym)) #' @export quo_label <- function(quo) { expr_label(quo_squash(quo)) } #' @rdname quo_label #' @export quo_text <- function(quo, width = 60L, nlines = Inf) { expr_text(quo_squash(quo), width = width, nlines = nlines) } #' @rdname quo_label #' @export quo_name <- function(quo) { expr_name(quo_squash(quo)) } quo_squash_impl <- function(x, parent = NULL, warn = FALSE) { quo_squash_do <- function(x) { if (!is_false(warn)) { if (is_string(warn)) { msg <- warn } else { msg <- "Collapsing inner quosure" } warn(msg) warn <- FALSE } while (is_quosure(maybe_missing(x))) { x <- quo_get_expr(x) } if (!is_null(parent)) { node_poke_car(parent, maybe_missing(x)) } quo_squash_impl(x, parent, warn = warn) } node_squash <- function(x) { while (!is_null(x)) { quo_squash_impl(node_car(x), parent = x, warn = warn) x <- node_cdr(x) } } switch_expr( x, language = { if (is_quosure(x)) { x <- quo_squash_do(x) } else { node_squash(x) } }, pairlist = node_squash(x) ) maybe_missing(x) } #' @export print.quosure <- function(x, ...) { cat_line(.trailing = FALSE, style_bold(""), "expr: " ) quo_print(x) cat_line(.trailing = FALSE, "env: " ) env <- quo_get_env(x) quo_env_print(env) invisible(x) } #' @export str.quosure <- function(object, ...) { str(unclass(object), ...) } #' @export as.character.quosure <- function(x, ...) { deprecate_warn(paste_line( "Using `as.character()` on a quosure is deprecated as of rlang 0.3.0.", "Please use `as_label()` or `as_name()` instead." )) NextMethod() } #' @export `[.quosure` <- function(x, i, ...) { deprecate_soft(c( "Subsetting quosures with `[` is deprecated as of rlang 0.4.0", "Please use `quo_get_expr()` instead." )) NextMethod() } #' @export `[[.quosure` <- function(x, i, ...) { deprecate_soft(c( "Subsetting quosures with `[[` is deprecated as of rlang 0.4.0", "Please use `quo_get_expr()` instead." )) NextMethod() } # Create a circular list of colours. This infloops if printed in the REPL! new_quo_palette <- function() { last_node <- new_node(open_cyan, NULL) palette <- new_node(open_blue, new_node(open_green, new_node(open_magenta, last_node))) node_poke_cdr(last_node, palette) # First node has no colour new_node(close_colour, palette) } # Reproduces output of printed calls base_deparse <- function(x) { deparse(x, control = "keepInteger") } quo_deparse <- function(x, lines = new_quo_deparser()) { if (!is_quosure(x)) { return(sexp_deparse(x, lines = lines)) } env <- quo_get_env(x) lines$quo_open_colour(env) lines$push("^") lines$make_next_sticky() sexp_deparse(quo_get_expr(x), lines = lines) lines$quo_reset_colour() lines$get_lines() } new_quo_deparser <- function(width = peek_option("width"), max_elements = 5L, crayon = has_ansi()) { lines <- new_lines( width = width, max_elements = max_elements, deparser = quo_deparse ) child_r6lite(lines, has_colour = crayon, quo_envs = list(), quo_history = pairlist(), quo_colours = list( open_blue, open_green, open_magenta, open_cyan, open_yellow ), quo_was_too_many = FALSE, quo_push_opener = function(self, opener) { self$quo_history <- new_node(opener, self$quo_history) self$push_sticky(opener()) self }, quo_open_colour = function(self, env) { if (self$has_colour) { if (is_reference(env, global_env()) || is_reference(env, empty_env())) { self$quo_push_opener(close_colour) return(NULL) } n_known_envs <- length(self$quo_envs) idx <- detect_index(self$quo_envs, identical, env) if (idx) { opener <- self$quo_colours[[idx]] } else if (n_known_envs < length(self$quo_colours)) { self$quo_envs <- c(self$quo_envs, list(env)) idx <- n_known_envs + 1L opener <- self$quo_colours[[idx]] } else { opener <- function() paste0(close_colour(), open_blurred_italic()) self$quo_was_too_many <- TRUE } self$quo_push_opener(opener) } }, quo_reset_colour = function(self) { if (self$has_colour) { if (self$quo_was_too_many) { self$push_sticky(close_blurred_italic()) } self$quo_history <- node_cdr(self$quo_history) reset <- node_car(self$quo_history) %||% close_colour self$push_sticky(reset()) } } ) } quo_print <- function(quo) { # Take into account the first 8-character wide columns width <- peek_option("width") - 10L deparser <- new_quo_deparser(width = width) lines <- quo_deparse(quo, deparser) n <- length(lines) lines[seq2(2, n)] <- paste0(" ", lines[seq2(2, n)]) cat(paste0(lines, "\n")) } quo_env_print <- function(env) { nm <- env_label(env) if (!is_reference(env, global_env()) && !is_reference(env, empty_env())) { nm <- col_blue(nm) } cat_line(nm) } #' @export Ops.quosure <- function(e1, e2) { if (identical(.Generic, "!")) { abort(paste_line( "Quosures can only be unquoted within a quasiquotation context.", "", " # Bad:", " list(!!myquosure)", "", " # Good:", " dplyr::mutate(data, !!myquosure)" )) } if (missing(e2)) { bad <- sprintf(" %s%s", .Generic, "myquosure") good <- sprintf(" %s!!%s", .Generic, "myquosure") } else if (is_quosure(e1) && is_quosure(e2)) { bad <- sprintf(" myquosure1 %s myquosure2", .Generic) good <- sprintf(" !!myquosure1 %s !!myquosure2", .Generic) } else if (is_quosure(e1)) { bad <- sprintf(" myquosure %s rhs", .Generic) good <- sprintf(" !!myquosure %s rhs", .Generic) } else { bad <- sprintf(" lhs %s myquosure", .Generic) good <- sprintf(" lhs %s !!myquosure", .Generic) } abort(paste_line( "Base operators are not defined for quosures.", "Do you need to unquote the quosure?", "", " # Bad:", bad, "", " # Good:", good, )) } abort_quosure_op <- function(group, op) { abort(paste_line( sprintf("%s operations are not defined for quosures.", group), "Do you need to unquote the quosure?", "", " # Bad:", sprintf(" %s(myquosure)", op), "", " # Good:", sprintf(" %s(!!myquosure)", op), )) } #' @export Math.quosure <- function(x, ...) { abort_quosure_op("Math", .Generic) } #' @export Summary.quosure <- function(x, ...) { abort_quosure_op("Summary", .Generic) } #' @export mean.quosure <- function(x, na.rm = TRUE, ...) { abort_quosure_op("Summary", "mean") } #' @importFrom stats median #' @export median.quosure <- function(x, na.rm = TRUE, ...) { abort_quosure_op("Summary", "median") } #' @importFrom stats quantile #' @export quantile.quosure <- function(x, na.rm = TRUE, ...) { abort_quosure_op("Summary", "quantile") } #' @export c.quosure <- function(..., recursive = FALSE) { inputs <- list(...) if (some(inputs, function(x) !is_quosure(x) && !is.list(x))) { abort("Can't concatenate quosures with incompatible objects.") } out <- NextMethod() if (!every(out, is_quosure)) { abort("Can't concatenate quosures with incompatible objects.") } new_quosures(out) } rlang/R/bytes.R0000644000176200001440000001333214375670676013056 0ustar liggesusers#' Human readable memory sizes #' #' @description #' Construct, manipulate and display vectors of byte sizes. These are numeric #' vectors, so you can compare them numerically, but they can also be compared #' to human readable values such as '10MB'. #' #' - `parse_bytes()` takes a character vector of human-readable bytes #' and returns a structured bytes vector. #' #' - `as_bytes()` is a generic conversion function for objects #' representing bytes. #' #' Note: A `bytes()` constructor will be exported soon. #' #' @details #' These memory sizes are always assumed to be base 1000, rather than 1024. #' #' @param x A numeric or character vector. Character representations can use #' shorthand sizes (see examples). #' @examples #' parse_bytes("1") #' parse_bytes("1K") #' parse_bytes("1Kb") #' parse_bytes("1KiB") #' parse_bytes("1MB") #' #' parse_bytes("1KB") < "1MB" #' #' sum(parse_bytes(c("1MB", "5MB", "500KB"))) #' @name bytes-class NULL # To be renamed to `bytes()` once next version of vctrs is on CRAN # https://github.com/r-lib/vctrs/commit/04f1857e bytes2 <- function(...) { dots <- map(list(...), ~ unclass(bytes_cast(.x))) new_bytes(inject(c(!!!dots))) } # Constructors and core methods ------------------------------------------- new_bytes <- function(x) { x <- x %||% dbl() stopifnot(is.numeric(x)) structure(x, class = c("rlib_bytes", "numeric")) } bytes_cast <- function(x) { if (!is.object(x)) { switch( typeof(x), logical = if (is_unspecified(x)) return(new_bytes(as.double(x))), integer = , double = return(new_bytes(x)), character = return(parse_bytes(x)) ) } abort(sprintf( "Can't coerce %s to .", obj_type_friendly(x) )) } #' @export `[.rlib_bytes` <- function(x, i) { new_bytes(NextMethod("[")) } #' @export `[[.rlib_bytes` <- function(x, i) { new_bytes(NextMethod("[[")) } # Generic conversion ------------------------------------------------------ #' @rdname bytes-class #' @export as_bytes <- function(x) { UseMethod("as_bytes") } #' @export as_bytes.rlib_bytes <- function(x) { x } #' @export as_bytes.character <- function(x) { parse_bytes(x) } #' @export as_bytes.numeric <- function(x) { new_bytes(x) } on_package_load("methods", { methods::setOldClass(c("as_bytes", "numeric"), numeric()) }) # Parsing ----------------------------------------------------------------- #' @rdname bytes-class #' @export parse_bytes <- function(x) { stopifnot(is_character(x)) pos <- regexpr( "^(?[[:digit:].]+)\\s*(?[kKMGTPEZY]?)i?[Bb]?$", x, perl = TRUE ) m <- captures(x, pos) m$unit[m$unit == ""] <- "B" new_bytes(unname(as.numeric(m$size) * byte_units[m$unit])) } # TODO: Add support for decimal prefixes byte_units <- c( 'B' = 1, 'k' = 1000, 'K' = 1000, 'M' = 1000 ^ 2, 'G' = 1000 ^ 3, 'T' = 1000 ^ 4, 'P' = 1000 ^ 5, 'E' = 1000 ^ 6, 'Z' = 1000 ^ 7, 'Y' = 1000 ^ 8 ) captures <- function(x, m) { if (!is_character(x)) { abort("`x` must be a character.") } if (!is_reg_match(m)) { abort("`m` must be a match object from `regexpr()`.") } starts <- attr(m, "capture.start") strings <- substring( x, starts, starts + attr(m, "capture.length") - 1L ) out <- data.frame( matrix(strings, ncol = NCOL(starts)), stringsAsFactors = FALSE ) colnames(out) <- auto_name_seq(attr(m, "capture.names")) out[is.na(m) | m == -1, ] <- NA_character_ out } is_reg_match <- function(x) { if (!inherits(x, "integer")) { return(FALSE) } nms <- c( "match.length", "capture.start", "capture.length", "capture.names" ) all(nms %in% names(attributes(x))) } auto_name_seq <- function(names) { void <- detect_void_name(names) if (!any(void)) { return(names) } names[void] <- seq_along(names)[void] names } # Printing ---------------------------------------------------------------- # Adapted from https://github.com/gaborcsardi/prettyunits #' @export format.rlib_bytes <- function(x, ...) { check_dots_used() format_bytes$pretty_bytes(unclass(x)) } #' @export as.character.rlib_bytes <- format.rlib_bytes #' @export print.rlib_bytes <- function(x, ...) { check_dots_used() # Disambiguate edge cases if (!length(x) || all(is.na(x))) { writeLines("") } if (length(x)) { print(format(x, ...), quote = FALSE) } else { writeLines("[1] (empty)") } } # Arithmetic -------------------------------------------------------------- #' @export sum.rlib_bytes <- function(x, ...) { new_bytes(NextMethod()) } #' @export min.rlib_bytes <- function(x, ...) { new_bytes(NextMethod()) } #' @export max.rlib_bytes <- function(x, ...) { new_bytes(NextMethod()) } #' @export # Adapted from Ops.numeric_version Ops.rlib_bytes <- function (e1, e2) { if (nargs() == 1L) { abort(sprintf("unary `%s` not defined for objects", .Generic)) } boolean <- switch( .Generic, `+` = TRUE, `-` = TRUE, `*` = TRUE, `/` = TRUE, `^` = TRUE, `<` = TRUE, `>` = TRUE, `==` = TRUE, `!=` = TRUE, `<=` = TRUE, `>=` = TRUE, FALSE ) if (!boolean) { abort(sprintf("`%s` not defined for objects", .Generic)) } e1 <- as_bytes(e1) e2 <- as_bytes(e2) NextMethod(.Generic) } # Integration ------------------------------------------------------------- # Lazily exported pillar_shaft.rlib_bytes <- function(x, ...) { pillar::new_pillar_shaft_simple(format.rlib_bytes(x), align = "right", ...) } type_sum.rlib_bytes <- function(x, ...) { "byt" } scale_type.rlib_bytes <- function(x) { "rlib_bytes" } on_load({ s3_register("pillar::pillar_shaft", "rlib_bytes") s3_register("pillar::type_sum", "rlib_bytes") s3_register("ggplot2::scale_type", "rlib_bytes") }) rlang/R/rlang-package.R0000644000176200001440000000073614654414131014406 0ustar liggesusers#' @useDynLib rlang, .registration = TRUE #' @keywords internal "_PACKAGE" on_load({ local_use_cli() }) compiled_by_gcc <- function() { .Call(ffi_compiled_by_gcc) } #' Internal API for standalone-types-check #' @name ffi_standalone_types_check #' @aliases ffi_standalone_is_bool_1.0.7 #' @aliases ffi_standalone_check_number_1.0.7 #' @keywords internal #' @rawNamespace export(ffi_standalone_is_bool_1.0.7) #' @rawNamespace export(ffi_standalone_check_number_1.0.7) NULL rlang/R/faq.R0000644000176200001440000000172514140235137012455 0ustar liggesusers#' Global options for rlang #' #' @description #' rlang has several options which may be set globally to control #' behavior. A brief description of each is given here. If any functions #' are referenced, refer to their documentation for additional details. #' #' * `rlang_interactive`: A logical value used by [is_interactive()]. This #' can be set to `TRUE` to test interactive behavior in unit tests, #' for example. #' #' * `rlang_backtrace_on_error`: A character string which controls whether #' backtraces are displayed with error messages, and the level of #' detail they print. See [rlang_backtrace_on_error] for the possible option values. #' #' * `rlang_trace_format_srcrefs`: A logical value used to control whether #' srcrefs are printed as part of the backtrace. #' #' * `rlang_trace_top_env`: An environment which will be treated as the #' top-level environment when printing traces. See [trace_back()] #' for examples. #' @name faq-options NULL rlang/R/cnd-message.R0000644000176200001440000003002114741440425014070 0ustar liggesusers#' Build an error message from parts #' #' @description #' #' `cnd_message()` assembles an error message from three generics: #' #' - `cnd_header()` #' - `cnd_body()` #' - `cnd_footer()` #' #' Methods for these generics must return a character vector. The #' elements are combined into a single string with a newline #' separator. Bullets syntax is supported, either through rlang (see #' [format_error_bullets()]), or through cli if the condition has #' `use_cli_format` set to `TRUE`. #' #' The default method for the error header returns the `message` field #' of the condition object. The default methods for the body and #' footer return the the `body` and `footer` fields if any, or empty #' character vectors otherwise. #' #' `cnd_message()` is automatically called by the `conditionMessage()` #' for rlang errors, warnings, and messages. Error classes created #' with [abort()] only need to implement header, body or footer #' methods. This provides a lot of flexibility for hierarchies of #' error classes, for instance you could inherit the body of an error #' message from a parent class while overriding the header and footer. #' #' #' @section Overriding header, body, and footer methods: #' #' Sometimes the contents of an error message depends on the state of #' your checking routine. In that case, it can be tricky to lazily #' generate error messages with `cnd_header()`, `cnd_body()`, and #' `cnd_footer()`: you have the choice between overspecifying your #' error class hierarchies with one class per state, or replicating #' the type-checking control flow within the `cnd_body()` method. None #' of these options are ideal. #' #' A better option is to define `header`, `body`, or `footer` fields #' in your condition object. These can be a static string, a #' [lambda-formula][as_function], or a function with the same #' signature as `cnd_header()`, `cnd_body()`, or `cnd_footer()`. These #' fields override the message generics and make it easy to generate #' an error message tailored to the state in which the error was #' constructed. #' #' @param cnd A condition object. #' @param ... Arguments passed to methods. #' @param inherit Wether to include parent messages. Parent messages #' are printed with a "Caused by error:" prefix, even if `prefix` is #' `FALSE`. #' @param prefix Whether to print the full message, including the #' condition prefix (`Error:`, `Warning:`, `Message:`, or #' `Condition:`). The prefix mentions the `call` field if present, #' and the `srcref` info if present. If `cnd` has a `parent` field #' (i.e. the condition is chained), the parent messages are included #' in the message with a `Caused by` prefix. #' #' @export cnd_message <- function(cnd, ..., inherit = TRUE, prefix = FALSE) { orig <- cnd # Easier to zap the parent than thread `inherit` across functions if (!inherit) { cnd$parent <- NULL } if (prefix) { # Skip child errors that have empty messages and calls while (!length(msg <- cnd_message_format_prefixed(cnd, ..., parent = FALSE))) { parent <- cnd[["parent"]] if (is_condition(parent)) { cnd <- parent } else { break } } } else { msg <- cnd_message_format(cnd, ...) } warning <- inherits(cnd, "warning") # Parent messages are always prefixed while (is_condition(cnd <- cnd$parent)) { parent_msg <- cnd_message_format_prefixed(cnd, parent = TRUE, warning = warning) msg <- paste_line(msg, parent_msg) } backtrace_on_error <- cnd_backtrace_on_error(orig) %||% "none" trace_footer <- format_onerror_backtrace(orig, opt = backtrace_on_error) paste_line(msg, trace_footer) } cnd_message_lines <- function(cnd, ...) { c( cnd_header(cnd, ...), cnd_body(cnd, ...), cnd_footer(cnd, ...) ) } # Set an internal field that is processed by `cnd_message()`. # `cnd_message()` is called by `conditionMessage()` and # `as.character()` methods. The latter is called from `knitr::sew()`. cnd_set_backtrace_on_error <- function(cnd, opt) { cnd$rlang$internal$backtrace_on_error <- opt cnd } cnd_backtrace_on_error <- function(cnd) { cnd[["rlang"]]$internal$backtrace_on_error } cnd_message_format <- function(cnd, ..., alert = FALSE) { lines <- cnd_message_lines(cnd, ...) if (is_string(lines, "")) { return("") } needs_alert <- alert && length(lines) && is_string(names2(lines)[[1]], "") if (!is_true(cnd$use_cli_format)) { out <- paste_line(lines) if (needs_alert) { out <- paste(ansi_alert(), out) } return(out) } if (needs_alert) { names2(lines)[[1]] <- "!" } cli_format <- switch( cnd_type(cnd), error = format_error, warning = format_warning, format_message ) cli_format(glue_escape(lines)) } local_cli_indent <- function(frame = caller_env()) { cli::cli_div( class = "indented", theme = list(div.indented = list("margin-left" = 2)), .envir = frame ) } #' @rdname cnd_message #' @export cnd_header <- function(cnd, ...) { if (is_null(cnd[["header"]])) { UseMethod("cnd_header") } else { exec_cnd_method("header", cnd, ...) } } #' @export cnd_header.default <- function(cnd, ...) { cnd$message } #' @rdname cnd_message #' @export cnd_body <- function(cnd, ...) { if (is_null(cnd[["body"]])) { UseMethod("cnd_body") } else { exec_cnd_method("body", cnd, ...) } } #' @export cnd_body.default <- function(cnd, ...) { chr() } #' @rdname cnd_message #' @export cnd_footer <- function(cnd, ...) { if (is_null(cnd[["footer"]])) { UseMethod("cnd_footer") } else { exec_cnd_method("footer", cnd, ...) } } #' @export cnd_footer.default <- function(cnd, ...) { chr() } exec_cnd_method <- function(name, cnd, ...) { method <- cnd[[name]] if (is_function(method)) { method(cnd, ...) } else if (is_bare_formula(method)) { method <- as_function(method) method(cnd, ...) } else if (is_character(method)) { method } else { msg <- sprintf( "%s field must be a character vector or a function.", format_code(name) ) abort(msg, call = caller_env()) } } cnd_message_format_prefixed <- function(cnd, ..., parent = FALSE, alert = NULL, warning = FALSE) { type <- cnd_type(cnd) if (is_null(alert)) { alert <- is_error(cnd) || parent } if (parent) { prefix <- sprintf("Caused by %s", type) # FIXME: Enable this by default later on if (use_red_error_prefix()) { prefix <- col_prefix(prefix, type) } } else { prefix <- capitalise(type) prefix <- col_prefix(prefix, type) } evalq({ if (is_true(peek_option("rlang:::error_highlight"))) { local_error_highlight() } call <- format_error_call(cnd[["call"]]) }) message <- cnd_message_format(cnd, ..., alert = alert) message <- strip_trailing_newline(message) if (!nzchar(message) && is_null(call)) { return(character()) } has_loc <- FALSE if (is_null(call)) { prefix <- sprintf("%s:", prefix) } else { src_loc <- src_loc(attr(cnd[["call"]], "srcref")) if (nzchar(src_loc) && peek_call_format_srcref()) { prefix <- sprintf("%s in %s at %s:", prefix, call, src_loc) has_loc <- TRUE } else { prefix <- sprintf("%s in %s:", prefix, call) } } if (!warning) { prefix <- style_bold(prefix) } if (nzchar(message)) { paste0(prefix, "\n", message) } else { prefix } } col_prefix <- function(prefix, type) { if (type == "error" && use_red_error_prefix()) { col_red(prefix) } else { col_yellow(prefix) } } use_red_error_prefix <- function() { peek_option("rlang:::use_red_error_prefix") %||% FALSE } peek_call_format_srcref <- function() { opt <- peek_option("rlang_call_format_srcrefs") if (is_null(opt)) { !is_testing() } else { check_bool(opt, arg = "rlang_call_format_srcrefs") opt } } #' @export conditionMessage.rlang_message <- function(c) { cnd_message(c) } #' @export conditionMessage.rlang_warning <- function(c) { cnd_message(c) } #' @export conditionMessage.rlang_error <- function(c) { cnd_message(c) } #' @export as.character.rlang_message <- function(x, ...) { paste0(cnd_message(x, prefix = TRUE), "\n") } #' @export as.character.rlang_warning <- function(x, ...) { paste0(cnd_message(x, prefix = TRUE), "\n") } #' @export as.character.rlang_error <- function(x, ...) { paste0(cnd_message(x, prefix = TRUE), "\n") } on_load({ s3_register("knitr::sew", "rlang_error", function(x, options, ...) { # Simulate interactive session to prevent full backtrace from # being included in error message local_interactive() # Save the unhandled error for `rlang::last_error()`. poke_last_error(x) # Include backtrace footer option in the condition. Processed by # `cnd_message()`. x <- cnd_set_backtrace_on_error(x, peek_backtrace_on_error_report()) # The `sew.error()` method calls `as.character()`, which dispatches # to `cnd_message()` NextMethod() }) }) on_load({ s3_register("knitr::sew", "rlang_warning", function(x, options, ...) { # Simulate interactive session to prevent full backtrace from # being included in error message local_interactive() # Include backtrace footer option in the condition. Processed by # `cnd_message()`. x <- cnd_set_backtrace_on_error(x, peek_backtrace_on_warning_report()) # The `sew.error()` method calls `as.character()`, which dispatches # to `cnd_message()` NextMethod() }) }) #' Format bullets for error messages #' #' @description #' `format_error_bullets()` takes a character vector and returns a single #' string (or an empty vector if the input is empty). The elements of #' the input vector are assembled as a list of bullets, depending on #' their names: #' #' - Unnamed elements are unindented. They act as titles or subtitles. #' - Elements named `"*"` are bulleted with a cyan "bullet" symbol. #' - Elements named `"i"` are bulleted with a blue "info" symbol. #' - Elements named `"x"` are bulleted with a red "cross" symbol. #' - Elements named `"v"` are bulleted with a green "tick" symbol. #' - Elements named `"!"` are bulleted with a yellow "warning" symbol. #' - Elements named `">"` are bulleted with an "arrow" symbol. #' - Elements named `" "` start with an indented line break. #' #' For convenience, if the vector is fully unnamed, the elements are #' formatted as "*" bullets. #' #' The bullet formatting for errors follows the idea that sentences in #' error messages are best kept short and simple. The best way to #' present the information is in the [cnd_body()] method of an error #' conditon as a bullet list of simple sentences containing a single #' clause. The info and cross symbols of the bullets provide hints on #' how to interpret the bullet relative to the general error issue, #' which should be supplied as [cnd_header()]. #' #' @param x A named character vector of messages. Named elements are #' prefixed with the corresponding bullet. Elements named with a #' single space `" "` trigger a line break from the previous bullet. #' @examples #' # All bullets #' writeLines(format_error_bullets(c("foo", "bar"))) #' #' # This is equivalent to #' writeLines(format_error_bullets(set_names(c("foo", "bar"), "*"))) #' #' # Supply named elements to format info, cross, and tick bullets #' writeLines(format_error_bullets(c(i = "foo", x = "bar", v = "baz", "*" = "quux"))) #' #' # An unnamed element breaks the line #' writeLines(format_error_bullets(c(i = "foo\nbar"))) #' #' # A " " element breaks the line within a bullet (with indentation) #' writeLines(format_error_bullets(c(i = "foo", " " = "bar"))) #' @export format_error_bullets <- function(x) { # Treat unnamed vectors as all bullets if (is_null(names(x))) { x <- set_names(x, "*") } # Always use fallback for now .rlang_cli_format_fallback(x) } # No-op for the empty string, e.g. for `abort("", class = "foo")` and # a `conditionMessage.foo()` method. Don't format inputs escaped with `I()`. can_format <- function(x) { !is_string(x, "") && !inherits(x, "AsIs") } rlang/R/utils.R0000644000176200001440000002035314560467514013060 0ustar liggesusersdeprecated <- function() missing_arg() abort_coercion <- function(x, to_type, x_type = NULL, arg = NULL, call = caller_env()) { if (is_null(x_type)) { if (is_vector(x)) { x_type <- vec_type_friendly(x) } else { x_type <- obj_type_friendly(x) } } if (is_null(arg)) { msg <- sprintf("Can't convert %s to %s.", x_type, to_type) } else { arg <- format_arg(arg) msg <- sprintf("Can't convert %s, %s, to %s.", arg, x_type, to_type) } abort(msg, call = call) } set_names2 <- function(x, nms = names2(x)) { empty <- nms == "" nms[empty] <- x[empty] names(x) <- nms x } cat_line <- function(..., .trailing = TRUE, file = "") { cat(paste_line(..., .trailing = .trailing), file = file) } paste_line <- function(..., .trailing = FALSE) { text <- chr(...) if (.trailing) { paste0(text, "\n", collapse = "") } else { paste(text, collapse = "\n") } } open_red <- function() if (has_ansi()) open_style("red") open_blue <- function() if (has_ansi()) open_style("blue") open_green <- function() if (has_ansi()) open_style("green") open_yellow <- function() if (has_ansi()) open_style("yellow") open_magenta <- function() if (has_ansi()) open_style("magenta") open_cyan <- function() if (has_ansi()) open_style("cyan") open_bold <- function() if (has_ansi()) open_style("bold") close_colour <- function() if (has_ansi()) "\u001b[39m" close_italic <- function() if (has_ansi()) "\u001b[23m" close_bold <- function() if (has_ansi()) close_style("bold") open_yellow_italic <- function() if (has_ansi()) "\u001b[33m\u001b[3m" open_blurred_italic <- function() if (has_ansi()) "\u001b[2m\u001b[3m" close_blurred_italic <- function() if (has_ansi()) "\u001b[23m\u001b[22m" open_style <- function(style) { paste0("\u001b[", codes[[style]][[1]], "m") } close_style <- function(style) { paste0("\u001b[", codes[[style]][[2]], "m") } ansi_regex <- paste0( "(?:(?:\\x{001b}\\[)|\\x{009b})", "(?:(?:[0-9]{1,3})?(?:(?:;[0-9]{0,3})*)?[A-M|f-m])", "|\\x{001b}[A-M]" ) strip_style <- function(x) { gsub(ansi_regex, "", x, perl = TRUE) } codes <- list( reset = c(0L, 0L), bold = c(1L, 22L), blurred = c(2L, 22L), italic = c(3L, 23L), underline = c(4L, 24L), inverse = c(7L, 27L), hidden = c(8L, 28L), strikethrough = c(9L, 29L), black = c(30L, 39L), red = c(31L, 39L), green = c(32L, 39L), yellow = c(33L, 39L), blue = c(34L, 39L), magenta = c(35L, 39L), cyan = c(36L, 39L), white = c(37L, 39L), silver = c(90L, 39L), bgBlack = c(40L, 49L), bgRed = c(41L, 49L), bgGreen = c(42L, 49L), bgYellow = c(43L, 49L), bgBlue = c(44L, 49L), bgMagenta = c(45L, 49L), bgCyan = c(46L, 49L), bgWhite = c(47L, 49L) ) `$.r6lite` <- function(self, arg) { field <- env_get(self, as_string(substitute(arg)), inherit = TRUE) if (is_function(field)) { expr_interp(function(...) { # Unquote the method so it is printable method <- !!field method(self, ...) }) } else { field } } r6lite <- function(...) { structure(new_environment(list2(...)), class = "r6lite") } child_r6lite <- function(.parent, ...) { structure(child_env(.parent, ...), class = "r6lite") } inc <- function(x) { x + 1L } dec <- function(x) { x - 1L } pluralise <- function(n, singular, plural) { if (n == 1) { singular } else { plural } } pad_spaces <- function(x, left = TRUE) { widths <- nchar(x) pads <- max(widths) - widths if (left) { paste0(spaces(pads), x) } else { paste0(x, spaces(pads)) } } # Import symbols from cli if available on_load({ has_cli <- is_installed("cli") has_cli_format <- is_installed("cli", version = "3.0.0") has_cli_start_app <- is_installed("cli", version = "2.0.0") }) style_dim_soft <- function(x) { if (cli::num_ansi_colors() >= 256) { crayon::make_style(grDevices::grey(0.6), colors = 256)(x) } else { col_silver(x) } } strip_trailing_newline <- function(x) { n <- nchar(x) if (substr(x, n, n) == "\n") { substr(x, 0, n - 1L) } else { x } } unstructure <- function(x) { attributes(x) <- NULL x } vec_unstructure <- function(x) { out <- x attributes(out) <- NULL dim(out) <- dim(x) names(out) <- names(x) out } stop_internal <- function(message, ..., call = caller_env(2)) { abort(message, ..., call = call, .internal = TRUE) } stop_internal_c_lib <- function(file, line, call, message, frame) { if (nzchar(file)) { message <- c( message, "i" = sprintf( "In file %s at line %d.", format_file(file), line )) } if (!is_installed("winch") && is_interactive()) { message <- c( message, "i" = sprintf( "Install the %s package to get additional debugging info the next time you get this error.", format_pkg("winch") ) ) } abort(message, call = call, .internal = TRUE, .frame = frame) } with_srcref <- function(src, env = caller_env(), file = NULL) { file <- file %||% tempfile("sourced", fileext = ".R") on.exit(unlink(file)) writeLines(src, file) source(file, local = env, keep.source = TRUE) } chr_has_curly <- function(x) { .Call(ffi_chr_has_curly, x) } new_stack <- function() { stack <- new_dyn_vector("list", 100) push <- function(...) { for (obj in list2(...)) { dyn_push_back(stack, maybe_missing(obj)) } } # Can be used as a coro generator pop <- function() { if (dyn_count(stack)) { dyn_pop_back(stack) } else { exhausted() } } new_environment(list( push = push, pop = pop )) } exhausted <- function() as.symbol(".__exhausted__.") is_exhausted <- function(x) identical(x, exhausted()) path_trim_prefix <- function(path, n) { split <- strsplit(path, "/")[[1]] n_split <- length(split) if (n_split <= n) { path } else { paste(split[seq2(n_split - n + 1, n_split)], collapse = "/") } } browser <- function(..., skipCalls = 0, frame = parent.frame()) { if (!identical(stdout(), getConnection(1))) { sink(getConnection(1)) withr::defer(sink(), envir = frame) } # Calling `browser()` on exit avoids RStudio displaying the # `browser2()` location. We still need one `n` to get to the # expected place. Ideally `skipCalls` would not skip but exit the # contexts. on.exit(base::browser(..., skipCalls = skipCalls + 1)) } df_print <- function(x, ...) { class(x) <- c("tbl", "data.frame") print(x, ...) invisible(x) } is_testing <- function() { identical(Sys.getenv("TESTTHAT"), "true") } glue_escape <- function(x) { gsub("\\}", "}}", gsub("\\{", "{{", x)) } detect_run_starts <- function(x) { if (!length(x)) { return(lgl()) } lagged <- c(NA, x[-length(x)]) x != lagged | (is.na(lagged) & !is.na(x)) } # No ANSI support capitalise <- function(x) { stopifnot(length(x) == 1) n <- nchar(x) if (n == 0) { x } else if (n == 1) { toupper(x) } else { paste0(toupper(substring(x, 1, 1)), substring(x, 2)) } } testing <- function() { nzchar(Sys.getenv("TESTTHAT")) } cli_with_whiteline_escapes <- function(x, fn) { x <- gsub("\n", "__NEW_LINE__", x, fixed = TRUE) x <- gsub(" ", "__SPACE__", x, fixed = TRUE) x <- fn(x) x <- gsub("__SPACE__", " ", x, fixed = TRUE) x <- gsub("__NEW_LINE__", "\n", x, fixed = TRUE) x } style_rlang_run <- function(code) { style_hyperlink( paste0("rlang::", code), paste0("x-r-run:rlang::", code) ) } vec_remove <- function(x, values) { loc <- match(values, x, nomatch = 0) if (sum(loc) == 0) { x } else { x[-loc] } } str_nzchar <- function(x) { is_string(x) && nzchar(x) } pkg_url_bug <- function(pkg) { # First check that package is installed, e.g. in case of # runtime-only namespace created by pkgload if (nzchar(system.file(package = pkg))) { url <- utils::packageDescription(pkg)$BugReports # `url` can be NULL if not part of the description if (is_string(url) && grepl("^https://", url)) { return(url) } } NULL } rlang/R/c-lib.R0000644000176200001440000002177514640750733012714 0ustar liggesusers#' Import or update the rlang C library #' #' @description #' #' The rlang library is downloaded from the development version on #' github by default. Set the `RLANG_PATH` environment variable to a #' local path to copy rlang from a local source. #' #' Set the `RLANG_LIB_NO_PROMPT` environment variable to `"true"` to #' disable the prompts about overwriting an existing library. #' #' @noRd use_rlang_c_library <- function() { check_installed(c("fs", "usethis"), "to install the rlang C library.") rlang_path <- Sys.getenv("RLANG_PATH") if (!nzchar(rlang_path)) { rlang_path <- download_rlang() on.exit(fs::dir_delete(rlang_path)) } check_rlang(rlang_path) rlang_lib_path <- fs::path(rlang_path, "src", "rlang") rlang_lib_include_path <- fs::path(rlang_path, "src", "rlang.c") proj_path <- usethis::proj_get() if (is_rlang_dir(proj_path)) { abort(c( "Can't update rlang from itself.", i = "Did you forget to change project?" )) } src_path <- fs::path(proj_path, "src") lib_path <- fs::path(src_path, "rlang") lib_include_path <- fs::path(src_path, "rlang.c") has_library <- any(fs::file_exists(c(lib_path, lib_include_path))) if (has_library) { no_prompt <- tolower(Sys.getenv("RLANG_LIB_NO_PROMPT")) if (!is_string(no_prompt, "true")) { prompt <- paste("Remove existing library in", src_path) if (!usethis::ui_yeah(prompt)) { invokeRestart("abort") } } if (fs::file_exists(lib_path)) { fs::file_delete(lib_path) } if (any(fs::file_exists(lib_include_path))) { fs::file_delete(lib_include_path) } } fs::dir_copy(rlang_lib_path, lib_path) fs::file_copy(rlang_lib_include_path, lib_include_path) if (has_library) { usethis::ui_done("Updated rlang library.") } else { usethis::ui_done("Installed rlang library to `src/rlang`.") } if (!has_include_directive(src_path)) { usethis::ui_todo("Add to `src/Makevars`:") usethis::ui_code_block("PKG_CPPFLAGS = -I./rlang") } if (!detect_rlang_lib_usage(src_path)) { usethis::ui_todo("Include the library with `#include `.") usethis::ui_todo("Call `r_init_library()` from your `.onLoad()` hook.") } } download_rlang <- function() { dest_zip <- fs::file_temp("rlang-src") url <- "https://github.com/r-lib/rlang/archive/main.zip" utils::download.file(url, dest_zip) dest_dir <- fs::file_temp("rlang-src") utils::unzip(dest_zip, exdir = dest_dir) fs::path(dest_dir, "rlang-main") } check_rlang <- function(path) { if (!is_rlang_dir(path)) { abort("Can't find rlang in path.") } } is_rlang_dir <- function(path) { lib_path <- fs::path(path, "src", "rlang") desc_path <- fs::path(path, "DESCRIPTION") if (!fs::dir_exists(lib_path)) { return(FALSE) } if (!fs::file_exists(desc_path)) { return(FALSE) } desc <- readLines(desc_path, n = 1) if (!is_string(desc, "Package: rlang")) { return(FALSE) } TRUE } has_include_directive <- function(src_path) { makevars_path <- fs::path(src_path, "Makevars") if (!fs::file_exists(makevars_path)) { return(FALSE) } makevars_lines <- readLines(makevars_path) any(grepl("PKG_CPPFLAGS.*-I.*rlang", makevars_lines)) } detect_rlang_lib_usage <- function(src_path) { src_files <- fs::dir_ls(src_path, glob = "*.c", recurse = TRUE) src_files <- src_files[!grepl("/src/rlang/", src_files)] has_include <- FALSE has_init <- FALSE for (file in src_files) { lines <- readLines(file) if (any(grepl("#include ", lines))) { has_include <- TRUE } if (any(grepl("r_init_library", lines))) { has_init <- TRUE } if (has_include && has_init) { return(TRUE) } } FALSE } # cnd.c format_error_arg <- function(arg) { .Call(ffi_format_error_arg, arg) } # df.c alloc_data_frame <- function(n_rows, names, types) { .Call(ffi_alloc_data_frame, n_rows, names, types) } # dict.c new_dict <- function(size, prevent_resize = FALSE) { .Call(ffi_new_dict, size, prevent_resize) } dict_size <- function(dict) { length(dict[[2]]) } dict_resize <- function(dict, size) { .Call(ffi_dict_resize, dict, size) } dict_poke <- function(dict, key, value) { .Call(ffi_dict_poke, dict, key, value) } dict_put <- function(dict, key, value) { .Call(ffi_dict_put, dict, key, value) } dict_del <- function(dict, key) { .Call(ffi_dict_del, dict, key) } dict_has <- function(dict, key) { .Call(ffi_dict_has, dict, key) } dict_get <- function(dict, key) { .Call(ffi_dict_get, dict, key) } dict_as_df_list <- function(dict) { .Call(ffi_dict_as_df_list, dict) } dict_as_list <- function(dict) { .Call(ffi_dict_as_list, dict) } #' @export print.rlang_dict <- function(x, ...) { writeLines(sprintf("", obj_address(x))) writeLines(paste0("size: ", dict_size(x))) } new_dict_iterator <- function(dict) { .Call(ffi_new_dict_iterator, dict) } dict_it_info <- function(it) { .Call(ffi_dict_it_info, it) } dict_it_next <- function(it) { .Call(ffi_dict_next, it) } # dyn-array.c new_dyn_vector <- function(type, capacity) { .Call(ffi_new_dyn_vector, type, capacity) } new_dyn_array <- function(elt_size, capacity) { .Call(ffi_new_dyn_array, elt_size, capacity) } dyn_unwrap <- function(x) { .Call(ffi_dyn_unwrap, x) } dyn_info <- function(x) { .Call(ffi_dyn_info, x) } dyn_count <- function(x) { dyn_info(x)$count } dyn_push_back <- function(x, value) { .Call(ffi_dyn_push_back, x, value) } dyn_push_back_bool <- function(x, value) { .Call(ffi_dyn_push_back_bool, x, value) } dyn_pop_back <- function(x) { .Call(ffi_dyn_pop_back, x) } dyn_resize <- function(x, capacity) { .Call(ffi_dyn_resize, x, capacity) } dyn_lgl_get <- function(x, i) { .Call(ffi_dyn_lgl_get, x, i) } dyn_int_get <- function(x, i) { .Call(ffi_dyn_int_get, x, i) } dyn_dbl_get <- function(x, i) { .Call(ffi_dyn_dbl_get, x, i) } dyn_cpl_get <- function(x, i) { .Call(ffi_dyn_cpl_get, x, i) } dyn_raw_get <- function(x, i) { .Call(ffi_dyn_raw_get, x, i) } dyn_chr_get <- function(x, i) { .Call(ffi_dyn_chr_get, x, i) } dyn_list_get <- function(x, i) { .Call(ffi_dyn_list_get, x, i) } dyn_lgl_poke <- function(x, i, value) { invisible(.Call(ffi_dyn_lgl_poke, x, i, value)) } dyn_int_poke <- function(x, i, value) { invisible(.Call(ffi_dyn_int_poke, x, i, value)) } dyn_dbl_poke <- function(x, i, value) { invisible(.Call(ffi_dyn_dbl_poke, x, i, value)) } dyn_cpl_poke <- function(x, i, value) { invisible(.Call(ffi_dyn_cpl_poke, x, i, value)) } dyn_raw_poke <- function(x, i, value) { invisible(.Call(ffi_dyn_raw_poke, x, i, value)) } dyn_chr_poke <- function(x, i, value) { invisible(.Call(ffi_dyn_chr_poke, x, i, value)) } dyn_list_poke <- function(x, i, value) { invisible(.Call(ffi_dyn_list_poke, x, i, value)) } dyn_lgl_push_back <- function(x, value) { invisible(.Call(ffi_dyn_lgl_push_back, x, value)) } dyn_int_push_back <- function(x, value) { invisible(.Call(ffi_dyn_int_push_back, x, value)) } dyn_dbl_push_back <- function(x, value) { invisible(.Call(ffi_dyn_dbl_push_back, x, value)) } dyn_cpl_push_back <- function(x, value) { invisible(.Call(ffi_dyn_cpl_push_back, x, value)) } dyn_raw_push_back <- function(x, value) { invisible(.Call(ffi_dyn_raw_push_back, x, value)) } dyn_chr_push_back <- function(x, value) { invisible(.Call(ffi_dyn_chr_push_back, x, value)) } dyn_list_push_back <- function(x, value) { invisible(.Call(ffi_dyn_list_push_back, x, value)) } # https://github.com/r-lib/rlang/issues/1556 has_size_one_bool <- function() { .Call(ffi_has_size_one_bool) } #' @export print.rlang_dyn_array <- function(x, ...) { writeLines(sprintf("", obj_address(x))) info <- dyn_info(x) writeLines(paste0("count: ", info$count)) writeLines(paste0("capacity: ", info$capacity)) writeLines(paste0("growth_factor: ", info$growth_factor)) writeLines(paste0("type: ", info$type)) writeLines(paste0("elt_byte_size: ", info$elt_byte_size)) } # dyn-list-of.c new_dyn_list_of <- function(type, capacity, width) { .Call(ffi_new_dyn_list_of, type, capacity, width) } lof_info <- function(lof) { .Call(ffi_lof_info, lof) } lof_unwrap <- function(lof) { .Call(ffi_lof_unwrap, lof) } lof_push_back <- function(lof) { .Call(ffi_lof_push_back, lof) } lof_arr_push_back <- function(lof, i, value) { .Call(ffi_lof_arr_push_back, lof, i, value) } # obj.c has_local_precious_list <- function() { .Call(ffi_has_local_precious_list) } use_local_precious_list <- function(x) { .Call(ffi_use_local_precious_list, x) } # sexp.c rlang_precious_dict <- function() { .Call(ffi_precious_dict) } rlang_preserve <- function(x) { .Call(ffi_preserve, x) } rlang_unpreserve <- function(x) { .Call(ffi_unpreserve, x) } # session.c getppid <- function() { .Call(ffi_getppid) } # tests.c c_tests <- function() { .Call(ffi_c_tests) } run_c_test <- function(ptr) { .Call(ffi_run_c_test, ptr) } # vec.c list_compact <- function(x) { .Call(ffi_list_compact, x) } vec_resize <- function(x, n) { .Call(ffi_vec_resize, x, n) } # walk.c sexp_iterate <- function(x, fn) { .Call(ffi_sexp_iterate, x, fn) } rlang/R/standalone-lazyeval.R0000644000176200001440000000431114403561346015663 0ustar liggesusers# --- # repo: r-lib/rlang # file: standalone-lazyeval.R # last-updated: 2018-09-18 # license: https://unlicense.org # imports: rlang # --- # # This file serves as a reference for compatibility functions for lazyeval. # # nocov start warn_underscored <- function() { return(NULL) warn(paste( "The underscored versions are deprecated in favour of", "tidy evaluation idioms. Please see the documentation", "for `quo()` in rlang" )) } warn_text_se <- function() { return(NULL) warn("Text parsing is deprecated, please supply an expression or formula") } compat_lazy <- function(lazy, env = caller_env(), warn = TRUE) { if (warn) warn_underscored() if (missing(lazy)) { return(quo()) } if (is_quosure(lazy)) { return(lazy) } if (is_formula(lazy)) { return(as_quosure(lazy, env)) } out <- switch(typeof(lazy), symbol = , language = new_quosure(lazy, env), character = { if (warn) warn_text_se() parse_quo(lazy[[1]], env) }, logical = , integer = , double = { if (length(lazy) > 1) { warn("Truncating vector to length 1") lazy <- lazy[[1]] } new_quosure(lazy, env) }, list = if (inherits(lazy, "lazy")) { lazy = new_quosure(lazy$expr, lazy$env) } ) if (is_null(out)) { abort(sprintf("Can't convert a %s to a quosure", typeof(lazy))) } else { out } } compat_lazy_dots <- function(dots, env, ..., .named = FALSE) { if (missing(dots)) { dots <- list() } if (inherits(dots, c("lazy", "formula"))) { dots <- list(dots) } else { dots <- unclass(dots) } dots <- c(dots, list(...)) warn <- TRUE for (i in seq_along(dots)) { dots[[i]] <- compat_lazy(dots[[i]], env, warn) warn <- FALSE } named <- have_name(dots) if (.named && any(!named)) { nms <- vapply(dots[!named], function(x) expr_text(get_expr(x)), character(1)) names(dots)[!named] <- nms } names(dots) <- names2(dots) dots } compat_as_lazy <- function(quo) { structure(class = "lazy", list( expr = get_expr(quo), env = get_env(quo) )) } compat_as_lazy_dots <- function(...) { structure(class = "lazy_dots", lapply(quos(...), compat_as_lazy)) } # nocov end rlang/R/standalone-vctrs.R0000644000176200001440000003376714610374512015213 0ustar liggesusers# --- # repo: r-lib/rlang # file: standalone-vctrs.R # last-updated: 2021-08-27 # license: https://unlicense.org # --- # This file provides a minimal shim to provide a vctrs-like API on top of # base R functions. They are not drop-in replacements but allow a similar style # of programming. # # The main goal of these functions is robust-by-default manipulation # of data frames without having to depend on tibble or vctrs. The # embedded type system is minimal and not extensible. # 2024-04-17: # * `vec_recycle_common()` throws intended error when `size = 1` but input # is larger. # 2021-08-27: # * `vec_slice()` now preserves attributes of data frames and vectors. # * `vec_ptype2()` detects unspecified columns of data frames. # 2021-08-26: # * Added compat for `vec_as_location()`. # # 2021-05-28: # * Initial revision. # # nocov start # Construction ------------------------------------------------------------ # Constructs data frames inheriting from `"tbl"`. This allows the # pillar package to take over printing as soon as it is loaded. # The data frame otherwise behaves like a base data frame. data_frame <- function(...) { new_data_frame(df_list(...), .class = "tbl") } new_data_frame <- function(.x = list(), ..., .size = NULL, .class = NULL) { n_cols <- length(.x) if (n_cols != 0 && is.null(names(.x))) { stop("Columns must be named.", call. = FALSE) } if (is.null(.size)) { if (n_cols == 0) { .size <- 0 } else { .size <- vec_size(.x[[1]]) } } structure( .x, class = c(.class, "data.frame"), row.names = .set_row_names(.size), ... ) } df_list <- function(..., .size = NULL) { vec_recycle_common(list(...), size = .size) } # Binding ----------------------------------------------------------------- vec_rbind <- function(...) { xs <- vec_cast_common(list(...)) do.call(base::rbind, xs) } vec_cbind <- function(...) { xs <- list(...) ptype <- vec_ptype_common(lapply(xs, `[`, 0)) class <- setdiff(class(ptype), "data.frame") xs <- vec_recycle_common(xs) out <- do.call(base::cbind, xs) new_data_frame(out, .class = class) } # Slicing ----------------------------------------------------------------- vec_size <- function(x) { if (is.data.frame(x)) { nrow(x) } else { length(x) } } vec_rep <- function(x, times) { i <- rep.int(seq_len(vec_size(x)), times) vec_slice(x, i) } vec_recycle_common <- function(xs, size = NULL) { sizes <- vapply(xs, vec_size, integer(1)) n <- unique(sizes) if (length(n) == 1 && is.null(size)) { return(xs) } n <- setdiff(n, 1L) ns <- length(n) if (ns == 0) { if (is.null(size)) { return(xs) } } else if (ns == 1) { if (is.null(size)) { size <- n } else if (n != size) { stop("Inputs can't be recycled to `size`.", call. = FALSE) } } else { stop("Inputs can't be recycled to a common size.", call. = FALSE) } to_recycle <- sizes == 1L xs[to_recycle] <- lapply(xs[to_recycle], vec_rep, size) xs } vec_slice <- function(x, i) { if (is.logical(i)) { i <- which(i) } stopifnot(is.numeric(i) || is.character(i)) if (is.null(x)) { return(NULL) } if (is.data.frame(x)) { # We need to be a bit careful to be generic. First empty all # columns and expand the df to final size. out <- x[i, 0, drop = FALSE] # Then fill in with sliced columns out[seq_along(x)] <- lapply(x, vec_slice, i) # Reset automatic row names to work around `[` weirdness if (is.numeric(attr(x, "row.names"))) { row_names <- .set_row_names(nrow(out)) } else { row_names <- attr(out, "row.names") } # Restore attributes mtd <- .rlang_vctrs_s3_method("[", class(x)) if (is_null(mtd) || identical(environment(mtd), asNamespace("base"))) { attrib <- attributes(x) attrib$row.names <- row_names attributes(out) <- attrib } return(out) } d <- vec_dims(x) if (d == 1) { if (is.object(x)) { out <- x[i] } else { out <- x[i, drop = FALSE] } } else if (d == 2) { out <- x[i, , drop = FALSE] } else { j <- rep(list(quote(expr = )), d - 1) out <- eval(as.call(list(quote(`[`), quote(x), quote(i), j, drop = FALSE))) } mtd <- .rlang_vctrs_s3_method("[", class(x)) if (is_null(mtd) || identical(environment(mtd), asNamespace("base"))) { attrib <- attributes(x) attrib$names <- attr(out, "names") attrib$dim <- attr(out, "dim") attrib$dim.names <- attr(out, "dim.names") attributes(out) <- attrib } out } vec_dims <- function(x) { d <- dim(x) if (is.null(d)) { 1L } else { length(d) } } vec_as_location <- function(i, n, names = NULL) { out <- seq_len(n) names(out) <- names # Special-case recycling to size 0 if (is_logical(i, n = 1) && !length(out)) { return(out) } unname(out[i]) } vec_init <- function(x, n = 1L) { vec_slice(x, rep_len(NA_integer_, n)) } vec_assign <- function(x, i, value) { if (is.null(x)) { return(NULL) } if (is.logical(i)) { i <- which(i) } stopifnot( is.numeric(i) || is.character(i) ) value <- vec_recycle(value, vec_size(i)) value <- vec_cast(value, to = x) d <- vec_dims(x) if (d == 1) { x[i] <- value } else if (d == 2) { x[i, ] <- value } else { stop("Can't slice-assign arrays.", call. = FALSE) } x } vec_recycle <- function(x, size) { if (is.null(x) || is.null(size)) { return(NULL) } n_x <- vec_size(x) if (n_x == size) { x } else if (size == 0L) { vec_slice(x, 0L) } else if (n_x == 1L) { vec_slice(x, rep(1L, size)) } else { stop("Incompatible lengths: ", n_x, ", ", size, call. = FALSE) } } # Coercion ---------------------------------------------------------------- vec_cast_common <- function(xs, to = NULL) { ptype <- vec_ptype_common(xs, ptype = to) lapply(xs, vec_cast, to = ptype) } vec_cast <- function(x, to) { if (is.null(x)) { return(NULL) } if (is.null(to)) { return(x) } if (vec_is_unspecified(x)) { return(vec_init(to, vec_size(x))) } stop_incompatible_cast <- function(x, to) { stop( sprintf("Can't convert <%s> to <%s>.", .rlang_vctrs_typeof(x), .rlang_vctrs_typeof(to) ), call. = FALSE ) } lgl_cast <- function(x, to) { lgl_cast_from_num <- function(x) { if (any(!x %in% c(0L, 1L))) { stop_incompatible_cast(x, to) } as.logical(x) } switch( .rlang_vctrs_typeof(x), logical = x, integer = , double = lgl_cast_from_num(x), stop_incompatible_cast(x, to) ) } int_cast <- function(x, to) { int_cast_from_dbl <- function(x) { out <- suppressWarnings(as.integer(x)) if (any((out != x) | xor(is.na(x), is.na(out)))) { stop_incompatible_cast(x, to) } else { out } } switch( .rlang_vctrs_typeof(x), logical = as.integer(x), integer = x, double = int_cast_from_dbl(x), stop_incompatible_cast(x, to) ) } dbl_cast <- function(x, to) { switch( .rlang_vctrs_typeof(x), logical = , integer = as.double(x), double = x, stop_incompatible_cast(x, to) ) } chr_cast <- function(x, to) { switch( .rlang_vctrs_typeof(x), character = x, stop_incompatible_cast(x, to) ) } list_cast <- function(x, to) { switch( .rlang_vctrs_typeof(x), list = x, stop_incompatible_cast(x, to) ) } df_cast <- function(x, to) { # Check for extra columns if (length(setdiff(names(x), names(to))) > 0 ) { stop("Can't convert data frame because of missing columns.", call. = FALSE) } # Avoid expensive [.data.frame method out <- as.list(x) # Coerce common columns common <- intersect(names(x), names(to)) out[common] <- Map(vec_cast, out[common], to[common]) # Add new columns from_type <- setdiff(names(to), names(x)) out[from_type] <- lapply(to[from_type], vec_init, n = vec_size(x)) # Ensure columns are ordered according to `to` out <- out[names(to)] new_data_frame(out) } rlib_df_cast <- function(x, to) { new_data_frame(df_cast(x, to), .class = "tbl") } tib_cast <- function(x, to) { new_data_frame(df_cast(x, to), .class = c("tbl_df", "tbl")) } switch( .rlang_vctrs_typeof(to), logical = lgl_cast(x, to), integer = int_cast(x, to), double = dbl_cast(x, to), character = chr_cast(x, to), list = list_cast(x, to), base_data_frame = df_cast(x, to), rlib_data_frame = rlib_df_cast(x, to), tibble = tib_cast(x, to), stop_incompatible_cast(x, to) ) } vec_ptype_common <- function(xs, ptype = NULL) { if (!is.null(ptype)) { return(vec_ptype(ptype)) } xs <- Filter(function(x) !is.null(x), xs) if (length(xs) == 0) { return(NULL) } if (length(xs) == 1) { out <- vec_ptype(xs[[1]]) } else { xs <- map(xs, vec_ptype) out <- Reduce(vec_ptype2, xs) } vec_ptype_finalise(out) } vec_ptype_finalise <- function(x) { if (is.data.frame(x)) { x[] <- lapply(x, vec_ptype_finalise) return(x) } if (inherits(x, "rlang_unspecified")) { logical() } else { x } } vec_ptype <- function(x) { if (vec_is_unspecified(x)) { return(.rlang_vctrs_unspecified()) } if (is.data.frame(x)) { out <- new_data_frame(lapply(x, vec_ptype)) attrib <- attributes(x) attrib$row.names <- attr(out, "row.names") attributes(out) <- attrib return(out) } vec_slice(x, 0) } vec_ptype2 <- function(x, y) { stop_incompatible_type <- function(x, y) { stop( sprintf("Can't combine types <%s> and <%s>.", .rlang_vctrs_typeof(x), .rlang_vctrs_typeof(y)), call. = FALSE ) } x_type <- .rlang_vctrs_typeof(x) y_type <- .rlang_vctrs_typeof(y) if (x_type == "unspecified" && y_type == "unspecified") { return(.rlang_vctrs_unspecified()) } if (x_type == "unspecified") { return(y) } if (y_type == "unspecified") { return(x) } df_ptype2 <- function(x, y) { set_partition <- function(x, y) { list( both = intersect(x, y), only_x = setdiff(x, y), only_y = setdiff(y, x) ) } # Avoid expensive [.data.frame x <- as.list(vec_slice(x, 0)) y <- as.list(vec_slice(y, 0)) # Find column types names <- set_partition(names(x), names(y)) if (length(names$both) > 0) { common_types <- Map(vec_ptype2, x[names$both], y[names$both]) } else { common_types <- list() } only_x_types <- x[names$only_x] only_y_types <- y[names$only_y] # Combine and construct out <- c(common_types, only_x_types, only_y_types) out <- out[c(names(x), names$only_y)] new_data_frame(out) } rlib_df_ptype2 <- function(x, y) { new_data_frame(df_ptype2(x, y), .class = "tbl") } tib_ptype2 <- function(x, y) { new_data_frame(df_ptype2(x, y), .class = c("tbl_df", "tbl")) } ptype <- switch( x_type, logical = switch( y_type, logical = x, integer = y, double = y, stop_incompatible_type(x, y) ), integer = switch( .rlang_vctrs_typeof(y), logical = x, integer = x, double = y, stop_incompatible_type(x, y) ), double = switch( .rlang_vctrs_typeof(y), logical = x, integer = x, double = x, stop_incompatible_type(x, y) ), character = switch( .rlang_vctrs_typeof(y), character = x, stop_incompatible_type(x, y) ), list = switch( .rlang_vctrs_typeof(y), list = x, stop_incompatible_type(x, y) ), base_data_frame = switch( .rlang_vctrs_typeof(y), base_data_frame = , s3_data_frame = df_ptype2(x, y), rlib_data_frame = rlib_df_ptype2(x, y), tibble = tib_ptype2(x, y), stop_incompatible_type(x, y) ), rlib_data_frame = switch( .rlang_vctrs_typeof(y), base_data_frame = , rlib_data_frame = , s3_data_frame = rlib_df_ptype2(x, y), tibble = tib_ptype2(x, y), stop_incompatible_type(x, y) ), tibble = switch( .rlang_vctrs_typeof(y), base_data_frame = , rlib_data_frame = , tibble = , s3_data_frame = tib_ptype2(x, y), stop_incompatible_type(x, y) ), stop_incompatible_type(x, y) ) vec_slice(ptype, 0) } .rlang_vctrs_typeof <- function(x) { if (is.object(x)) { class <- class(x) if (identical(class, "rlang_unspecified")) { return("unspecified") } if (identical(class, "data.frame")) { return("base_data_frame") } if (identical(class, c("tbl", "data.frame"))) { return("rlib_data_frame") } if (identical(class, c("tbl_df", "tbl", "data.frame"))) { return("tibble") } if (inherits(x, "data.frame")) { return("s3_data_frame") } class <- paste0(class, collapse = "/") stop(sprintf("Unimplemented class <%s>.", class), call. = FALSE) } type <- typeof(x) switch( type, NULL = return("null"), logical = if (vec_is_unspecified(x)) { return("unspecified") } else { return(type) }, integer = , double = , character = , raw = , list = return(type) ) stop(sprintf("Unimplemented type <%s>.", type), call. = FALSE) } vec_is_unspecified <- function(x) { !is.object(x) && typeof(x) == "logical" && length(x) && all(vapply(x, identical, logical(1), NA)) } .rlang_vctrs_unspecified <- function(x = NULL) { structure( rep(NA, length(x)), class = "rlang_unspecified" ) } .rlang_vctrs_s3_method <- function(generic, class, env = parent.frame()) { fn <- get(generic, envir = env) ns <- asNamespace(topenv(fn)) tbl <- ns$.__S3MethodsTable__. for (c in class) { name <- paste0(generic, ".", c) if (exists(name, envir = tbl, inherits = FALSE)) { return(get(name, envir = tbl)) } if (exists(name, envir = globalenv(), inherits = FALSE)) { return(get(name, envir = globalenv())) } } NULL } # nocov end rlang/R/aaa-topics.R0000644000176200001440000000531014375670676013746 0ustar liggesuserstitles <- list( # NSE ## Overviews topic_data_mask = "What is data-masking and why do I need `{{`?", topic_data_mask_programming = "Data mask programming patterns", topic_metaprogramming = "Metaprogramming patterns", topic_defuse = "Defusing R expressions", topic_inject = "Injecting with `!!`, `!!!`, and glue syntax", topic_quosure = "What are quosures and when are they needed?", ## Guides topic_data_mask_ambiguity = "The data mask ambiguity", topic_double_evaluation = "The double evaluation problem", topic_multiple_columns = "Taking multiple columns without `...`", ## Notes topic_embrace_non_args = "Does `{{` work on regular objects?", topic_embrace_constants = "Why are strings and other constants enquosed in the empty environment?", topic_inject_out_of_context = "What happens if I use injection operators out of context?", # Errors ## Guides topic_error_call = "Including function calls in error messages", topic_error_chaining = "Including contextual information with error chains", topic_condition_formatting = "Formatting messages with cli", ## Notes topic_condition_customisation = "Customising condition messages" ) sprintf_topic_link <- function(id, topic = NULL) { if (is.null(topic)) { topic <- gsub("_", "-", id) } title <- titles[[id]] # Link texts can't include code html_title <- gsub("`", "", title) html_title <- gsub("{", "\\{", html_title, fixed = TRUE) html <- sprintf("\\link[=%s]{%s}", topic, html_title) # Link texts can't include curly symbols because the escpaing # routine of the Rd-to-TeX translators is broken text_title <- gsub("`", "", title) text_title <- gsub("{{", "curly-curly", text_title, fixed = TRUE) text_title <- gsub("{", "curly", text_title, fixed = TRUE) text <- sprintf("\\link[=%s]{%s}", topic, text_title) sprintf("\\ifelse{html}{%s}{%s}", html, text) } links <- lapply(names(titles), sprintf_topic_link) names(links) <- names(titles) links[["{{"]] <- "\\ifelse{html}{\\code{\\link[=embrace-operator]{\\{\\{}}}{\\verb{\\{\\{}}" links[["'{{'"]] <- "\\ifelse{html}{\\code{\\link[=glue-operators]{\"\\{\\{\"}}}{\\verb{\"\\{\\{\"}}" links[["'{'"]] <- "\\ifelse{html}{\\code{\\link[=glue-operators]{\"\\{\"}}}{\\verb{\"\\{\"}}" title <- function(id) { out <- titles[[id]] if (is.null(out)) { stop(sprintf("`id` '%s' doesn't exist.", id)) } out } link <- function(id) { out <- links[[id]] if (is.null(out)) { stop(sprintf("`id` '%s' doesn't exist.", id)) } out } text <- function(id) { switch( id, "'{'" = "\\verb{\"\\{\"}", "'{{'" = "\\verb{\"\\{\\{\"}", stop(sprintf("`id` '%s' doesn't exist.", id)) ) } rlang/R/env-binding.R0000644000176200001440000005036214375670676014134 0ustar liggesusers#' Bind symbols to objects in an environment #' #' @description #' #' These functions create bindings in an environment. The bindings are #' supplied through `...` as pairs of names and values or expressions. #' `env_bind()` is equivalent to evaluating a `<-` expression within #' the given environment. This function should take care of the #' majority of use cases but the other variants can be useful for #' specific problems. #' #' - `env_bind()` takes named _values_ which are bound in `.env`. #' `env_bind()` is equivalent to [base::assign()]. #' #' - `env_bind_active()` takes named _functions_ and creates active #' bindings in `.env`. This is equivalent to #' [base::makeActiveBinding()]. An active binding executes a #' function each time it is evaluated. The arguments are passed to #' [as_function()] so you can supply formulas instead of functions. #' #' Remember that functions are scoped in their own environment. #' These functions can thus refer to symbols from this enclosure #' that are not actually in scope in the dynamic environment where #' the active bindings are invoked. This allows creative solutions #' to difficult problems (see the implementations of `dplyr::do()` #' methods for an example). #' #' - `env_bind_lazy()` takes named _expressions_. This is equivalent #' to [base::delayedAssign()]. The arguments are captured with #' [exprs()] (and thus support call-splicing and unquoting) and #' assigned to symbols in `.env`. These expressions are not #' evaluated immediately but lazily. Once a symbol is evaluated, the #' corresponding expression is evaluated in turn and its value is #' bound to the symbol (the expressions are thus evaluated only #' once, if at all). #' #' - `%<~%` is a shortcut for `env_bind_lazy()`. It works like `<-` #' but the RHS is evaluated lazily. #' #' #' @section Side effects: #' #' Since environments have reference semantics (see relevant section #' in [env()] documentation), modifying the bindings of an environment #' produces effects in all other references to that environment. In #' other words, `env_bind()` and its variants have side effects. #' #' Like other side-effecty functions like `par()` and `options()`, #' `env_bind()` and variants return the old values invisibly. #' #' @param .env An environment. #' @param ... <[dynamic][dyn-dots]> Named objects (`env_bind()`), #' expressions `env_bind_lazy()`, or functions (`env_bind_active()`). #' Use [zap()] to remove bindings. #' @return The input object `.env`, with its associated environment #' modified in place, invisibly. #' @seealso [env_poke()] for binding a single element. #' @export #' @examples #' # env_bind() is a programmatic way of assigning values to symbols #' # with `<-`. We can add bindings in the current environment: #' env_bind(current_env(), foo = "bar") #' foo #' #' # Or modify those bindings: #' bar <- "bar" #' env_bind(current_env(), bar = "BAR") #' bar #' #' # You can remove bindings by supplying zap sentinels: #' env_bind(current_env(), foo = zap()) #' try(foo) #' #' # Unquote-splice a named list of zaps #' zaps <- rep_named(c("foo", "bar"), list(zap())) #' env_bind(current_env(), !!!zaps) #' try(bar) #' #' # It is most useful to change other environments: #' my_env <- env() #' env_bind(my_env, foo = "foo") #' my_env$foo #' #' # A useful feature is to splice lists of named values: #' vals <- list(a = 10, b = 20) #' env_bind(my_env, !!!vals, c = 30) #' my_env$b #' my_env$c #' #' # You can also unquote a variable referring to a symbol or a string #' # as binding name: #' var <- "baz" #' env_bind(my_env, !!var := "BAZ") #' my_env$baz #' #' #' # The old values of the bindings are returned invisibly: #' old <- env_bind(my_env, a = 1, b = 2, baz = "baz") #' old #' #' # You can restore the original environment state by supplying the #' # old values back: #' env_bind(my_env, !!!old) env_bind <- function(.env, ...) { check_environment(.env) invisible(.Call( ffi_env_bind, env = .env, values = list3(...), needs_old = TRUE, bind_type = "value", eval_env = NULL )) } # Doesn't return list of old bindings for efficiency env_bind0 <- function(.env, values) { invisible(.Call( ffi_env_bind, env = .env, values = values, needs_old = FALSE, bind_type = "value", eval_env = NULL )) } #' @rdname env_bind #' @param .eval_env The environment where the expressions will be #' evaluated when the symbols are forced. #' @export #' @examples #' #' # env_bind_lazy() assigns expressions lazily: #' env <- env() #' env_bind_lazy(env, name = { cat("forced!\n"); "value" }) #' #' # Referring to the binding will cause evaluation: #' env$name #' #' # But only once, subsequent references yield the final value: #' env$name #' #' # You can unquote expressions: #' expr <- quote(message("forced!")) #' env_bind_lazy(env, name = !!expr) #' env$name #' #' #' # By default the expressions are evaluated in the current #' # environment. For instance we can create a local binding and refer #' # to it, even though the variable is bound in a different #' # environment: #' who <- "mickey" #' env_bind_lazy(env, name = paste(who, "mouse")) #' env$name #' #' # You can specify another evaluation environment with `.eval_env`: #' eval_env <- env(who = "minnie") #' env_bind_lazy(env, name = paste(who, "mouse"), .eval_env = eval_env) #' env$name #' #' # Or by unquoting a quosure: #' quo <- local({ #' who <- "fievel" #' quo(paste(who, "mouse")) #' }) #' env_bind_lazy(env, name = !!quo) #' env$name env_bind_lazy <- function(.env, ..., .eval_env = caller_env()) { check_environment(.env) invisible(.Call( ffi_env_bind, env = .env, values = exprs(...), needs_old = TRUE, bind_type = "lazy", eval_env = .eval_env )) } #' @rdname env_bind #' @export #' @examples #' #' # You can create active bindings with env_bind_active(). Active #' # bindings execute a function each time they are evaluated: #' fn <- function() { #' cat("I have been called\n") #' rnorm(1) #' } #' #' env <- env() #' env_bind_active(env, symbol = fn) #' #' # `fn` is executed each time `symbol` is evaluated or retrieved: #' env$symbol #' env$symbol #' eval_bare(quote(symbol), env) #' eval_bare(quote(symbol), env) #' #' # All arguments are passed to as_function() so you can use the #' # formula shortcut: #' env_bind_active(env, foo = ~ runif(1)) #' env$foo #' env$foo env_bind_active <- function(.env, ...) { check_environment(.env) invisible(.Call( ffi_env_bind, env = .env, values = list3(...), needs_old = TRUE, bind_type = "active", eval_env = caller_env() )) } #' @rdname env_bind #' @param lhs The variable name to which `rhs` will be lazily assigned. #' @param rhs An expression lazily evaluated and assigned to `lhs`. #' @export `%<~%` <- function(lhs, rhs) { env <- caller_env() inject( base::delayedAssign( as_string(substitute(lhs)), !!substitute(rhs), eval.env = env, assign.env = env ) ) } #' Temporarily change bindings of an environment #' #' @description #' #' * `local_bindings()` temporarily changes bindings in `.env` (which #' is by default the caller environment). The bindings are reset to #' their original values when the current frame (or an arbitrary one #' if you specify `.frame`) goes out of scope. #' #' * `with_bindings()` evaluates `expr` with temporary bindings. When #' `with_bindings()` returns, bindings are reset to their original #' values. It is a simple wrapper around `local_bindings()`. #' #' @inheritParams env_bind #' @param ... Pairs of names and values. These dots support splicing #' (with value semantics) and name unquoting. #' @param .frame The frame environment that determines the scope of #' the temporary bindings. When that frame is popped from the call #' stack, bindings are switched back to their original values. #' @return `local_bindings()` returns the values of old bindings #' invisibly; `with_bindings()` returns the value of `expr`. #' @export #' @examples #' foo <- "foo" #' bar <- "bar" #' #' # `foo` will be temporarily rebinded while executing `expr` #' with_bindings(paste(foo, bar), foo = "rebinded") #' paste(foo, bar) local_bindings <- function(..., .env = .frame, .frame = caller_env()) { check_environment(.env) check_environment(.frame) old <- env_bind(.env, ...) defer(env_bind0(.env, old), envir = .frame) invisible(old) } #' @rdname local_bindings #' @param .expr An expression to evaluate with temporary bindings. #' @export with_bindings <- function(.expr, ..., .env = caller_env()) { check_environment(.env) local_bindings(..., .env = .env) .expr } #' Remove bindings from an environment #' #' `env_unbind()` is the complement of [env_bind()]. Like `env_has()`, #' it ignores the parent environments of `env` by default. Set #' `inherit` to `TRUE` to track down bindings in parent environments. #' #' @inheritParams get_env #' @param nms A character vector of binding names to remove. #' @param inherit Whether to look for bindings in the parent #' environments. #' @return The input object `env` with its associated environment #' modified in place, invisibly. #' @export #' @examples #' env <- env(foo = 1, bar = 2) #' env_has(env, c("foo", "bar")) #' #' # Remove bindings with `env_unbind()` #' env_unbind(env, c("foo", "bar")) #' env_has(env, c("foo", "bar")) #' #' # With inherit = TRUE, it removes bindings in parent environments #' # as well: #' parent <- env(empty_env(), foo = 1, bar = 2) #' env <- env(parent, foo = "b") #' #' env_unbind(env, "foo", inherit = TRUE) #' env_has(env, c("foo", "bar")) #' env_has(env, c("foo", "bar"), inherit = TRUE) env_unbind <- function(env = caller_env(), nms, inherit = FALSE) { .Call(ffi_env_unbind, env, nms, inherit) invisible(env) } #' Does an environment have or see bindings? #' #' `env_has()` is a vectorised predicate that queries whether an #' environment owns bindings personally (with `inherit` set to #' `FALSE`, the default), or sees them in its own environment or in #' any of its parents (with `inherit = TRUE`). #' #' @inheritParams env_unbind #' @param nms A character vector of binding names for which to check #' existence. #' @return A named logical vector as long as `nms`. #' @export #' @examples #' parent <- child_env(NULL, foo = "foo") #' env <- child_env(parent, bar = "bar") #' #' # env does not own `foo` but sees it in its parent environment: #' env_has(env, "foo") #' env_has(env, "foo", inherit = TRUE) env_has <- function(env = caller_env(), nms, inherit = FALSE) { check_environment(env) .Call(ffi_env_has, env, nms, inherit) } #' Get an object in an environment #' #' `env_get()` extracts an object from an enviroment `env`. By #' default, it does not look in the parent environments. #' `env_get_list()` extracts multiple objects from an environment into #' a named list. #' #' @inheritParams get_env #' @inheritParams env_has #' @param nm Name of binding, a string. #' @param nms Names of bindings, a character vector. #' @param default A default value in case there is no binding for `nm` #' in `env`. #' @param last Last environment inspected when `inherit` is `TRUE`. #' Can be useful in conjunction with [base::topenv()]. #' @return An object if it exists. Otherwise, throws an error. #' #' @seealso [env_cache()] for a variant of `env_get()` designed to #' cache a value in an environment. #' @export #' @examples #' parent <- child_env(NULL, foo = "foo") #' env <- child_env(parent, bar = "bar") #' #' # This throws an error because `foo` is not directly defined in env: #' # env_get(env, "foo") #' #' # However `foo` can be fetched in the parent environment: #' env_get(env, "foo", inherit = TRUE) #' #' # You can also avoid an error by supplying a default value: #' env_get(env, "foo", default = "FOO") env_get <- function(env = caller_env(), nm, default, inherit = FALSE, last = empty_env()) { check_environment(env) check_environment(last) if (missing(default)) { default %<~% stop_env_get_missing(nm) } .Call( ffi_env_get, env = env, nm = nm, inherit = inherit, last = last, closure_env = environment() ) } #' @rdname env_get #' @export env_get_list <- function(env = caller_env(), nms, default, inherit = FALSE, last = empty_env()) { check_environment(env) check_environment(last) .Call( ffi_env_get_list, env = env, nms = nms, inherit = inherit, last = last, closure_env = environment() ) } stop_env_get_missing <- function(nm) { msg <- sprintf("Can't find %s in environment.", format_arg(nm)) abort(msg, call = caller_env()) } #' Poke an object in an environment #' #' `env_poke()` will assign or reassign a binding in `env` if `create` #' is `TRUE`. If `create` is `FALSE` and a binding does not already #' exists, an error is issued. #' #' #' @details #' #' If `inherit` is `TRUE`, the parents environments are checked for #' an existing binding to reassign. If not found and `create` is #' `TRUE`, a new binding is created in `env`. The default value for #' `create` is a function of `inherit`: `FALSE` when inheriting, #' `TRUE` otherwise. #' #' This default makes sense because the inheriting case is mostly #' for overriding an existing binding. If not found, something #' probably went wrong and it is safer to issue an error. Note that #' this is different to the base R operator `<<-` which will create #' a binding in the global environment instead of the current #' environment when no existing binding is found in the parents. #' #' #' @inheritParams env_get #' @param value The value for a new binding. #' @param create Whether to create a binding if it does not already #' exist in the environment. #' @return The old value of `nm` or a [zap sentinel][zap] if the #' binding did not exist yet. #' #' @seealso [env_bind()] for binding multiple elements. [env_cache()] #' for a variant of `env_poke()` designed to cache values. #' @export env_poke <- function(env = caller_env(), nm, value, inherit = FALSE, create = !inherit) { check_environment(env) invisible(.Call( ffi_env_poke, env = env, nm = nm, values = value, inherit = inherit, create = create )) } #' Cache a value in an environment #' #' @description #' `env_cache()` is a wrapper around [env_get()] and [env_poke()] #' designed to retrieve a cached value from `env`. #' #' - If the `nm` binding exists, it returns its value. #' - Otherwise, it stores the default value in `env` and returns that. #' #' @inheritParams env_get #' @param default The default value to store in `env` if `nm` does not #' exist yet. #' @return Either the value of `nm` or `default` if it did not exist #' yet. #' #' @examples #' e <- env(a = "foo") #' #' # Returns existing binding #' env_cache(e, "a", "default") #' #' # Creates a `b` binding and returns its default value #' env_cache(e, "b", "default") #' #' # Now `b` is defined #' e$b #' @export env_cache <- function(env, nm, default) { check_required(default) check_name(nm) if (env_has(env, nm)) { env_get(env, nm) } else { env_poke(env, nm, default) default } } #' Names and numbers of symbols bound in an environment #' #' `env_names()` returns object names from an enviroment `env` as a #' character vector. All names are returned, even those starting with #' a dot. `env_length()` returns the number of bindings. #' #' @section Names of symbols and objects: #' #' Technically, objects are bound to symbols rather than strings, #' since the R interpreter evaluates symbols (see [is_expression()] for a #' discussion of symbolic objects versus literal objects). However it #' is often more convenient to work with strings. In rlang #' terminology, the string corresponding to a symbol is called the #' _name_ of the symbol (or by extension the name of an object bound #' to a symbol). #' #' @section Encoding: #' #' There are deep encoding issues when you convert a string to symbol #' and vice versa. Symbols are _always_ in the native encoding. If #' that encoding (let's say latin1) cannot support some characters, #' these characters are serialised to ASCII. That's why you sometimes #' see strings looking like ``, especially if you're running #' Windows (as R doesn't support UTF-8 as native encoding on that #' platform). #' #' To alleviate some of the encoding pain, `env_names()` always #' returns a UTF-8 character vector (which is fine even on Windows) #' with ASCII unicode points translated back to UTF-8. #' #' @inheritParams get_env #' @return A character vector of object names. #' @export #' @examples #' env <- env(a = 1, b = 2) #' env_names(env) env_names <- function(env) { check_environment(env) nms <- names(env) .Call(ffi_unescape_character, nms) } #' @rdname env_names #' @export env_length <- function(env) { check_environment(env) length(env) } #' Lock or unlock environment bindings #' #' @description #' #' `r lifecycle::badge("experimental")` #' #' Locked environment bindings trigger an error when an attempt is #' made to redefine the binding. #' #' @param env An environment. #' @param nms Names of bindings. Defaults to all bindings in `env`. #' #' @return `env_binding_are_unlocked()` returns a logical vector as #' long as `nms` and named after it. `env_binding_lock()` and #' `env_binding_unlock()` return the old value of #' `env_binding_are_unlocked()` invisibly. #' #' @seealso [env_lock()] for locking an environment. #' #' @keywords internal #' @export #' @examples #' # Bindings are unlocked by default: #' env <- env(a = "A", b = "B") #' env_binding_are_locked(env) #' #' # But can optionally be locked: #' env_binding_lock(env, "a") #' env_binding_are_locked(env) #' #' # If run, the following would now return an error because `a` is locked: #' # env_bind(env, a = "foo") #' # with_env(env, a <- "bar") #' #' # Let's unlock it. Note that the return value indicate which #' # bindings were locked: #' were_locked <- env_binding_unlock(env) #' were_locked #' #' # Now that it is unlocked we can modify it again: #' env_bind(env, a = "foo") #' with_env(env, a <- "bar") #' env$a env_binding_lock <- function(env, nms = NULL) { nms <- env_binding_validate_names(env, nms) old <- env_binding_are_locked(env, nms) map(nms, lockBinding, env = env) invisible(old) } #' @rdname env_binding_lock #' @export env_binding_unlock <- function(env, nms = NULL) { nms <- env_binding_validate_names(env, nms) old <- env_binding_are_locked(env, nms) map(nms, unlockBinding, env = env) invisible(old) } #' @rdname env_binding_lock #' @export env_binding_are_locked <- function(env, nms = NULL) { nms <- env_binding_validate_names(env, nms) set_names(map_lgl(nms, bindingIsLocked, env = env), nms) } #' What kind of environment binding? #' #' `r lifecycle::badge("experimental")` #' #' @inheritParams env_binding_lock #' #' @keywords internal #' @return A logical vector as long as `nms` and named after it. #' @export env_binding_are_active <- function(env, nms = NULL) { env_binding_are_type(env, nms, 2L) } #' @rdname env_binding_are_active #' @export env_binding_are_lazy <- function(env, nms = NULL) { env_binding_are_type(env, nms, 1L) } env_binding_are_type <- function(env, nms, type, error_call = caller_env()) { check_environment(env, call = error_call) nms <- env_binding_validate_names(env, nms, call = error_call) promise <- env_binding_types(env, nms) if (is_null(promise)) { promise <- rep(FALSE, length(nms)) } else { promise <- promise == type } set_names(promise, nms) } env_binding_validate_names <- function(env, nms, call = caller_env()) { if (is_null(nms)) { nms <- env_names(env) } else { check_character( nms, what = "a character vector of names", call = call ) } nms } env_binding_types <- function(env, nms = env_names(env)) { .Call(ffi_env_binding_types, env, nms) } env_binding_type_sum <- function(env, nms = NULL) { nms <- env_binding_validate_names(env, nms) active <- env_binding_are_active(env, nms) promise <- env_binding_are_lazy(env, nms) other <- !active & !promise types <- new_character(length(nms), nms) types[active] <- "active" types[promise] <- "lazy" types[other] <- map_chr(env_get_list(env, nms[other]), rlang_type_sum) types } rlang/R/cnd.R0000644000176200001440000004025214612631170012451 0ustar liggesusers#' Errors of class `rlang_error` #' #' @description #' [abort()] and [error_cnd()] create errors of class `"rlang_error"`. #' The differences with base errors are: #' #' - Implementing `conditionMessage()` methods for subclasses of #' `"rlang_error"` is undefined behaviour. Instead, implement the #' [cnd_header()] method (and possibly [cnd_body()] and #' [cnd_footer()]). These methods return character vectors which are #' assembled by rlang when needed: when #' [`conditionMessage.rlang_error()`][conditionMessage] is called #' (e.g. via [try()]), when the error is displayed through [print()] #' or [format()], and of course when the error is displayed to the #' user by [abort()]. #' #' - [cnd_header()], [cnd_body()], and [cnd_footer()] methods can be #' overridden by storing closures in the `header`, `body`, and #' `footer` fields of the condition. This is useful to lazily #' generate messages based on state captured in the closure #' environment. #' #' - `r lifecycle::badge("experimental")` The `use_cli_format` #' condition field instructs whether to use cli (or rlang's fallback #' method if cli is not installed) to format the error message at #' print time. #' #' In this case, the `message` field may be a character vector of #' header and bullets. These are formatted at the last moment to #' take the context into account (starting position on the screen #' and indentation). #' #' See [local_use_cli()] for automatically setting this field in #' errors thrown with [abort()] within your package. #' #' @name rlang_error NULL #' Create a condition object #' #' @description #' These constructors create subclassed conditions, the objects that #' power the error, warning, and message system in R. #' #' * `cnd()` creates bare conditions that only inherit from #' `condition`. #' #' * Conditions created with `error_cnd()`, `warning_cnd()`, and #' `message_cnd()` inherit from `"error"`, `"warning"`, or `"message"`. #' #' * `error_cnd()` creates subclassed errors. See #' [`"rlang_error"`][rlang_error]. #' #' Use [cnd_signal()] to emit the relevant signal for a particular #' condition class. #' #' @param class The condition subclass. #' @param ... <[dynamic][dyn-dots]> Named data fields stored inside #' the condition object. #' @param message A default message to inform the user about the #' condition when it is signalled. #' @param call A function call to be included in the error message. #' If an execution environment of a running function, the #' corresponding function call is retrieved. #' @param trace A `trace` object created by [trace_back()]. #' @param parent A parent condition object. #' @param use_cli_format Whether to use the cli package to format #' `message`. See [local_use_cli()]. #' @seealso [cnd_signal()], [try_fetch()]. #' #' @keywords internal #' @export #' @examples #' # Create a condition inheriting only from the S3 class "foo": #' cnd <- cnd("foo") #' #' # Signal the condition to potential handlers. Since this is a bare #' # condition the signal has no effect if no handlers are set up: #' cnd_signal(cnd) #' #' # When a relevant handler is set up, the signal transfers control #' # to the handler #' with_handlers(cnd_signal(cnd), foo = function(c) "caught!") #' tryCatch(cnd_signal(cnd), foo = function(c) "caught!") cnd <- function(class, ..., message = "", call = NULL, use_cli_format = NULL) { check_required(class) if (is_environment(call)) { call <- error_call(call) } fields <- cnd_fields( ..., call = call, `_use_cli_format` = use_cli_format, `_fn` = "cnd", `_frame` = caller_env() ) .Call(ffi_new_condition, class, message, fields) } #' @rdname cnd #' @export error_cnd <- function(class = NULL, ..., message = "", call = NULL, trace = NULL, parent = NULL, use_cli_format = NULL) { if (!is_null(trace) && !inherits(trace, "rlang_trace")) { stop_input_type(trace, "`NULL` or an rlang backtrace") } if (!is_null(parent) && !inherits(parent, "condition")) { stop_input_type(parent, "`NULL` or a condition object") } if (is_environment(call)) { call <- error_call(call) } fields <- error_cnd_fields( trace = trace, parent = parent, ..., use_cli_format = use_cli_format, call = call ) .Call( ffi_new_condition, c(class, "rlang_error", "error"), message, fields ) } error_cnd_fields <- function(trace, parent, ..., use_cli_format = NULL, .subclass = NULL, `_env` = caller_env(), `_frame` = caller_env(2)) { if (!is_null(.subclass)) { deprecate_subclass(.subclass, "error_cnd", `_env`) } use_cli_format <- use_cli_format %||% use_cli(`_frame`)[["format"]] if (is_true(use_cli_format)) { list2(trace = trace, parent = parent, ..., use_cli_format = TRUE) } else { list2(trace = trace, parent = parent, ...) } } #' @rdname cnd #' @export warning_cnd <- function(class = NULL, ..., message = "", call = NULL, use_cli_format = NULL) { if (is_environment(call)) { call <- error_call(call) } fields <- cnd_fields( ..., call = call, `_use_cli_format` = use_cli_format, `_fn` = "warning_cnd", `_frame` = caller_env() ) .Call( ffi_new_condition, c(class, "rlang_warning", "warning"), message, fields ) } #' @rdname cnd #' @export message_cnd <- function(class = NULL, ..., message = "", call = NULL, use_cli_format = NULL) { if (is_environment(call)) { call <- error_call(call) } fields <- cnd_fields( ..., call = call, `_use_cli_format` = use_cli_format, `_fn` = "message_cnd", `_frame` = caller_env() ) .Call( ffi_new_condition, c(class, "rlang_message", "message"), message, fields ) } cnd_fields <- function(..., .subclass = NULL, `_use_cli_format` = NULL, `_fn` = "cnd", `_env` = caller_env(), `_frame` = caller_env(2)) { if (!is_null(.subclass)) { deprecate_subclass(.subclass, `_fn`, `_env`) } use_cli_format <- `_use_cli_format` %||% use_cli(`_frame`)[["format"]] if (is_true(use_cli_format)) { dots_list(..., use_cli_format = use_cli_format) } else { dots_list(...) } } #' Is object a condition? #' @param x An object to test. #' @keywords internal #' @export is_condition <- function(x) { inherits(x, "condition") } #' @rdname is_condition #' @export is_error <- function(x) { inherits(x, "error") } #' @rdname is_condition #' @export is_warning <- function(x) { inherits(x, "warning") } #' @rdname is_condition #' @export is_message <- function(x) { inherits(x, "message") } #' What type is a condition? #' #' Use `cnd_type()` to check what type a condition is. #' #' @param cnd A condition object. #' @return A string, either `"condition"`, `"message"`, `"warning"`, #' `"error"` or `"interrupt"`. #' #' @keywords internal #' @export #' @examples #' cnd_type(catch_cnd(abort("Abort!"))) #' cnd_type(catch_cnd(interrupt())) cnd_type <- function(cnd) { .Call(ffi_cnd_type, cnd) } #' Does a condition or its ancestors inherit from a class? #' #' @description #' Like any R objects, errors captured with catchers like [tryCatch()] #' have a [class()] which you can test with [inherits()]. However, #' with chained errors, the class of a captured error might be #' different than the error that was originally signalled. Use #' `cnd_inherits()` to detect whether an error or any of its _parent_ #' inherits from a class. #' #' Whereas `inherits()` tells you whether an object is a particular #' kind of error, `cnd_inherits()` answers the question whether an #' object is a particular kind of error or has been caused by such an #' error. #' #' Some chained conditions carry parents that are not inherited. See #' the `.inherit` argument of [abort()], [warn()], and [inform()]. #' #' #' # Capture an error with `cnd_inherits()` #' #' Error catchers like [tryCatch()] and [try_fetch()] can only match #' the class of a condition, not the class of its parents. To match a #' class across the ancestry of an error, you'll need a bit of #' craftiness. #' #' Ancestry matching can't be done with `tryCatch()` at all so you'll #' need to switch to [withCallingHandlers()]. Alternatively, you can #' use the experimental rlang function [try_fetch()] which is able to #' perform the roles of both `tryCatch()` and `withCallingHandlers()`. #' #' #' ## `withCallingHandlers()` #' #' Unlike `tryCatch()`, `withCallingHandlers()` does not capture an #' error. If you don't explicitly jump with an _error_ or a _value_ #' throw, nothing happens. #' #' Since we don't want to throw an error, we'll throw a value using #' [callCC()]: #' #' ```{r, comment = "#>", collapse = TRUE} #' f <- function() { #' parent <- error_cnd("bar", message = "Bar") #' abort("Foo", parent = parent) #' } #' #' cnd <- callCC(function(throw) { #' withCallingHandlers( #' f(), #' error = function(x) if (cnd_inherits(x, "bar")) throw(x) #' ) #' }) #' #' class(cnd) #' class(cnd$parent) #' ``` #' #' #' ## `try_fetch()` #' #' This pattern is easier with [try_fetch()]. Like #' `withCallingHandlers()`, it doesn't capture a matching error right #' away. Instead, it captures it only if the handler doesn't return a #' [zap()] value. #' #' ```{r, comment = "#>", collapse = TRUE} #' cnd <- try_fetch( #' f(), #' error = function(x) if (cnd_inherits(x, "bar")) x else zap() #' ) #' #' class(cnd) #' class(cnd$parent) #' ``` #' #' Note that `try_fetch()` uses `cnd_inherits()` internally. This #' makes it very easy to match a parent condition: #' #' ```{r, comment = "#>", collapse = TRUE} #' cnd <- try_fetch( #' f(), #' bar = function(x) x #' ) #' #' # This is the parent #' class(cnd) #' ``` #' #' @param cnd A condition to test. #' @param class A class passed to [inherits()]. #' #' @export cnd_inherits <- function(cnd, class) { cnd_some(cnd, inherits, class) } cnd_some <- function(cnd, fn, ...) { while (is_condition(cnd)) { if (fn(cnd, ...)) { return(TRUE) } inherit <- .subset2(.subset2(cnd, "rlang"), "inherit") if (is_false(inherit)) { return(FALSE) } cnd <- cnd[["parent"]] } FALSE } # Methods ----------------------------------------------------------------- #' @export print.rlang_error <- function(x, ...) { writeLines(format(x, ...)) invisible(x) } is_rlang_error <- function(x) { inherits(x, "rlang_error") } #' @export format.rlang_error <- function(x, ..., backtrace = TRUE, simplify = NULL, drop = NULL) { simplify <- arg_match_simplify(simplify) drop <- arg_match_drop(drop) # Allow overwriting default display via condition field simplify <- x$rlang$internal$trace_simplify %||% simplify drop <- x$rlang$internal$trace_drop %||% drop simplify <- arg_match_simplify(simplify) with_error_arg_highlight( out <- cnd_format( x, ..., backtrace = backtrace, simplify = simplify, drop = drop ) ) # Recommend printing the full backtrace if called from `last_error()` from_last_error <- is_true(x$rlang$internal$from_last_error) if (from_last_error && !is_null(x$trace)) { if (drop && !all(x$trace$visible)) { n_hidden <- sum(!x$trace$visible) hidden <- ngettext( n_hidden, "%d hidden frame", "%d hidden frames" ) hidden <- sprintf(hidden, n_hidden) last_trace <- style_rlang_run("last_trace(drop = FALSE)") reminder <- col_silver(sprintf("Run %s to see %s.", last_trace, hidden)) out <- paste_line(out, reminder) } else if (simplify == "branch") { last_trace <- style_rlang_run("last_trace()") reminder <- col_silver(paste0("Run `", last_trace, "` to see the full context.")) out <- paste_line(out, reminder) } } out } #' @export summary.rlang_error <- function(object, ...) { print(object, simplify = "none") } #' @export print.rlang_warning <- function(x, ...) { writeLines(format(x, ...)) invisible(x) } #' @export summary.rlang_warning <- function(object, ...) { print(object, ..., simplify = "none") } #' @export format.rlang_warning <- function(x, ..., backtrace = TRUE, simplify = "none") { cnd_format(x, ..., backtrace = backtrace, simplify = simplify) } #' @export print.rlang_message <- print.rlang_warning #' @export summary.rlang_message <- summary.rlang_warning #' @export format.rlang_message <- format.rlang_warning cnd_print <- function(x, ...) { writeLines(cnd_format(x, ...)) invisible(x) } cnd_format <- function(x, ..., backtrace = TRUE, simplify = NULL, prefix = TRUE, alert = NULL, drop = NULL) { simplify <- arg_match_simplify(simplify) drop <- arg_match_drop(drop) alert <- alert %||% is_error(x) orig <- x parent <- x[["parent"]] style <- cli_box_chars() header <- cnd_type_header(x) if (prefix) { # Skip child errors that have empty messages and calls while (!length(message <- cnd_message_format_prefixed(x, alert = alert))) { if (is_condition(parent)) { x <- parent parent <- x[["parent"]] } else { break } } } else { message <- cnd_message_format(x, alert = alert) } out <- paste_line( header, message ) trace <- x[["trace"]] last_trace <- NULL pending_trace <- NULL # This flushes backtraces lazily so that chained error messages # accumulate before displaying a backtrace push_trace <- function(cnd, trace) { if (!can_paste_trace(backtrace, trace)) { return() } if (is_same_trace()) { return() } flush_trace() pending_trace <<- list(cnd = cnd, trace = trace) } flush_trace <- function() { if (is_null(pending_trace)) { return() } out <<- paste_line(out, "---") out <<- paste_trace( out, pending_trace[["trace"]], simplify = simplify, ..., drop = drop ) if (!is_null(parent)) { out <<- paste_line(out, "---") } last_trace <<- pending_trace[["trace"]] pending_trace <<- NULL } is_same_trace <- function() { compare <- if (is_null(pending_trace)) last_trace else pending_trace[["trace"]] if (!is_trace(trace) || !is_trace(compare)) { return(FALSE) } # NOTE: Should we detect trace subsets as well? identical( format(trace, simplify = simplify, drop = drop), format(compare, simplify = simplify, drop = drop) ) } push_trace(x, trace) while (!is_null(parent)) { x <- parent parent <- parent[["parent"]] trace <- x[["trace"]] if (!is_null(trace) && !is_same_trace()) { flush_trace() } message <- cnd_message_format_prefixed(x, parent = TRUE) out <- paste_line(out, message) push_trace(x, trace) } flush_trace() out } can_paste_trace <- function(backtrace, trace) { backtrace && is_trace(trace) && trace_length(trace) } paste_trace <- function(x, trace, simplify, ...) { trace_lines <- format( trace, ..., simplify = simplify ) paste_line(x, style_bold("Backtrace:"), trace_lines) } cnd_type_header <- function(cnd) { type <- cnd_type(cnd) class <- class(cnd)[[1]] if (class != type) { class <- c(type, class) } style_bold(format_cls(class)) } testthat_print_cnd <- function(x, ...) { print(x, backtrace = FALSE) } on_load({ s3_register("testthat::testthat_print", "rlang_error", testthat_print_cnd) s3_register("testthat::testthat_print", "rlang_warning", testthat_print_cnd) s3_register("testthat::testthat_print", "rlang_message", testthat_print_cnd) }) rlang/R/standalone-types-check.R0000644000176200001440000002731414741441060016256 0ustar liggesusers# --- # repo: r-lib/rlang # file: standalone-types-check.R # last-updated: 2023-03-13 # license: https://unlicense.org # dependencies: standalone-obj-type.R # imports: rlang (>= 1.1.0) # --- # # ## Changelog # # 2023-03-13: # - Improved error messages of number checkers (@teunbrand) # - Added `allow_infinite` argument to `check_number_whole()` (@mgirlich). # - Added `check_data_frame()` (@mgirlich). # # 2023-03-07: # - Added dependency on rlang (>= 1.1.0). # # 2023-02-15: # - Added `check_logical()`. # # - `check_bool()`, `check_number_whole()`, and # `check_number_decimal()` are now implemented in C. # # - For efficiency, `check_number_whole()` and # `check_number_decimal()` now take a `NULL` default for `min` and # `max`. This makes it possible to bypass unnecessary type-checking # and comparisons in the default case of no bounds checks. # # 2022-10-07: # - `check_number_whole()` and `_decimal()` no longer treat # non-numeric types such as factors or dates as numbers. Numeric # types are detected with `is.numeric()`. # # 2022-10-04: # - Added `check_name()` that forbids the empty string. # `check_string()` allows the empty string by default. # # 2022-09-28: # - Removed `what` arguments. # - Added `allow_na` and `allow_null` arguments. # - Added `allow_decimal` and `allow_infinite` arguments. # - Improved errors with absent arguments. # # # 2022-09-16: # - Unprefixed usage of rlang functions with `rlang::` to # avoid onLoad issues when called from rlang (#1482). # # 2022-08-11: # - Added changelog. # # nocov start # Scalars ----------------------------------------------------------------- .standalone_types_check_dot_call <- .Call check_bool <- function(x, ..., allow_na = FALSE, allow_null = FALSE, arg = caller_arg(x), call = caller_env()) { if (!missing(x) && .standalone_types_check_dot_call(ffi_standalone_is_bool_1.0.7, x, allow_na, allow_null)) { return(invisible(NULL)) } stop_input_type( x, c("`TRUE`", "`FALSE`"), ..., allow_na = allow_na, allow_null = allow_null, arg = arg, call = call ) } check_string <- function(x, ..., allow_empty = TRUE, allow_na = FALSE, allow_null = FALSE, arg = caller_arg(x), call = caller_env()) { if (!missing(x)) { is_string <- .rlang_check_is_string( x, allow_empty = allow_empty, allow_na = allow_na, allow_null = allow_null ) if (is_string) { return(invisible(NULL)) } } stop_input_type( x, "a single string", ..., allow_na = allow_na, allow_null = allow_null, arg = arg, call = call ) } .rlang_check_is_string <- function(x, allow_empty, allow_na, allow_null) { if (is_string(x)) { if (allow_empty || !is_string(x, "")) { return(TRUE) } } if (allow_null && is_null(x)) { return(TRUE) } if (allow_na && (identical(x, NA) || identical(x, na_chr))) { return(TRUE) } FALSE } check_name <- function(x, ..., allow_null = FALSE, arg = caller_arg(x), call = caller_env()) { if (!missing(x)) { is_string <- .rlang_check_is_string( x, allow_empty = FALSE, allow_na = FALSE, allow_null = allow_null ) if (is_string) { return(invisible(NULL)) } } stop_input_type( x, "a valid name", ..., allow_na = FALSE, allow_null = allow_null, arg = arg, call = call ) } IS_NUMBER_true <- 0 IS_NUMBER_false <- 1 IS_NUMBER_oob <- 2 check_number_decimal <- function(x, ..., min = NULL, max = NULL, allow_infinite = TRUE, allow_na = FALSE, allow_null = FALSE, arg = caller_arg(x), call = caller_env()) { if (missing(x)) { exit_code <- IS_NUMBER_false } else if (0 == (exit_code <- .standalone_types_check_dot_call( ffi_standalone_check_number_1.0.7, x, allow_decimal = TRUE, min, max, allow_infinite, allow_na, allow_null ))) { return(invisible(NULL)) } .stop_not_number( x, ..., exit_code = exit_code, allow_decimal = TRUE, min = min, max = max, allow_na = allow_na, allow_null = allow_null, arg = arg, call = call ) } check_number_whole <- function(x, ..., min = NULL, max = NULL, allow_infinite = FALSE, allow_na = FALSE, allow_null = FALSE, arg = caller_arg(x), call = caller_env()) { if (missing(x)) { exit_code <- IS_NUMBER_false } else if (0 == (exit_code <- .standalone_types_check_dot_call( ffi_standalone_check_number_1.0.7, x, allow_decimal = FALSE, min, max, allow_infinite, allow_na, allow_null ))) { return(invisible(NULL)) } .stop_not_number( x, ..., exit_code = exit_code, allow_decimal = FALSE, min = min, max = max, allow_na = allow_na, allow_null = allow_null, arg = arg, call = call ) } .stop_not_number <- function(x, ..., exit_code, allow_decimal, min, max, allow_na, allow_null, arg, call) { if (allow_decimal) { what <- "a number" } else { what <- "a whole number" } if (exit_code == IS_NUMBER_oob) { min <- min %||% -Inf max <- max %||% Inf if (min > -Inf && max < Inf) { what <- sprintf("%s between %s and %s", what, min, max) } else if (x < min) { what <- sprintf("%s larger than or equal to %s", what, min) } else if (x > max) { what <- sprintf("%s smaller than or equal to %s", what, max) } else { abort("Unexpected state in OOB check", .internal = TRUE) } } stop_input_type( x, what, ..., allow_na = allow_na, allow_null = allow_null, arg = arg, call = call ) } check_symbol <- function(x, ..., allow_null = FALSE, arg = caller_arg(x), call = caller_env()) { if (!missing(x)) { if (is_symbol(x)) { return(invisible(NULL)) } if (allow_null && is_null(x)) { return(invisible(NULL)) } } stop_input_type( x, "a symbol", ..., allow_na = FALSE, allow_null = allow_null, arg = arg, call = call ) } check_arg <- function(x, ..., allow_null = FALSE, arg = caller_arg(x), call = caller_env()) { if (!missing(x)) { if (is_symbol(x)) { return(invisible(NULL)) } if (allow_null && is_null(x)) { return(invisible(NULL)) } } stop_input_type( x, "an argument name", ..., allow_na = FALSE, allow_null = allow_null, arg = arg, call = call ) } check_call <- function(x, ..., allow_null = FALSE, arg = caller_arg(x), call = caller_env()) { if (!missing(x)) { if (is_call(x)) { return(invisible(NULL)) } if (allow_null && is_null(x)) { return(invisible(NULL)) } } stop_input_type( x, "a defused call", ..., allow_na = FALSE, allow_null = allow_null, arg = arg, call = call ) } check_environment <- function(x, ..., allow_null = FALSE, arg = caller_arg(x), call = caller_env()) { if (!missing(x)) { if (is_environment(x)) { return(invisible(NULL)) } if (allow_null && is_null(x)) { return(invisible(NULL)) } } stop_input_type( x, "an environment", ..., allow_na = FALSE, allow_null = allow_null, arg = arg, call = call ) } check_function <- function(x, ..., allow_null = FALSE, arg = caller_arg(x), call = caller_env()) { if (!missing(x)) { if (is_function(x)) { return(invisible(NULL)) } if (allow_null && is_null(x)) { return(invisible(NULL)) } } stop_input_type( x, "a function", ..., allow_na = FALSE, allow_null = allow_null, arg = arg, call = call ) } check_closure <- function(x, ..., allow_null = FALSE, arg = caller_arg(x), call = caller_env()) { if (!missing(x)) { if (is_closure(x)) { return(invisible(NULL)) } if (allow_null && is_null(x)) { return(invisible(NULL)) } } stop_input_type( x, "an R function", ..., allow_na = FALSE, allow_null = allow_null, arg = arg, call = call ) } check_formula <- function(x, ..., allow_null = FALSE, arg = caller_arg(x), call = caller_env()) { if (!missing(x)) { if (is_formula(x)) { return(invisible(NULL)) } if (allow_null && is_null(x)) { return(invisible(NULL)) } } stop_input_type( x, "a formula", ..., allow_na = FALSE, allow_null = allow_null, arg = arg, call = call ) } # Vectors ----------------------------------------------------------------- check_character <- function(x, ..., allow_null = FALSE, arg = caller_arg(x), call = caller_env()) { if (!missing(x)) { if (is_character(x)) { return(invisible(NULL)) } if (allow_null && is_null(x)) { return(invisible(NULL)) } } stop_input_type( x, "a character vector", ..., allow_na = FALSE, allow_null = allow_null, arg = arg, call = call ) } check_logical <- function(x, ..., allow_null = FALSE, arg = caller_arg(x), call = caller_env()) { if (!missing(x)) { if (is_logical(x)) { return(invisible(NULL)) } if (allow_null && is_null(x)) { return(invisible(NULL)) } } stop_input_type( x, "a logical vector", ..., allow_na = FALSE, allow_null = allow_null, arg = arg, call = call ) } check_data_frame <- function(x, ..., allow_null = FALSE, arg = caller_arg(x), call = caller_env()) { if (!missing(x)) { if (is.data.frame(x)) { return(invisible(NULL)) } if (allow_null && is_null(x)) { return(invisible(NULL)) } } stop_input_type( x, "a data frame", ..., allow_null = allow_null, arg = arg, call = call ) } # nocov end rlang/R/cnd-handlers.R0000644000176200001440000003054614462656134014266 0ustar liggesusers#' Register default global handlers #' #' @description #' `global_handle()` sets up a default configuration for error, #' warning, and message handling. It calls: #' #' * [global_entrace()] to enable rlang errors and warnings globally. #' #' * [global_prompt_install()] to recover from `packageNotFoundError`s #' with a user prompt to install the missing package. Note that at #' the time of writing (R 4.1), there are only very limited #' situations where this handler works. #' #' @param entrace Passed as `enable` argument to [global_entrace()]. #' @param prompt_install Passed as `enable` argument to #' [global_prompt_install()]. #' #' @export global_handle <- function(entrace = TRUE, prompt_install = TRUE) { check_bool(entrace) check_bool(prompt_install) global_entrace(entrace) global_prompt_install(prompt_install) invisible(NULL) } #' Prompt user to install missing packages #' #' @description #' When enabled, `packageNotFoundError` thrown by [loadNamespace()] #' cause a user prompt to install the missing package and continue #' without interrupting the current program. #' #' This is similar to how [check_installed()] prompts users to install #' required packages. It uses the same install strategy, using pak if #' available and [install.packages()] otherwise. #' #' @inheritParams global_entrace #' @export global_prompt_install <- function(enable = TRUE) { check_bool(enable) if (getRversion() <= "4.0") { return(invisible(NULL)) } poke_global_handlers( enable, packageNotFoundError = hnd_prompt_install ) } # To help with `load_all()`, hard-code to base env with `rlang::` # indirection hnd_prompt_install <- function(cnd) { if (!rlang::is_interactive()) { return(rlang::zap()) } # Be defensive to avoid weird errors if (!rlang::is_string(cnd$package) || is.null(findRestart("retry_loadNamespace"))) { return(rlang::zap()) } rlang::check_installed(cnd$package) invokeRestart("retry_loadNamespace") } environment(hnd_prompt_install) <- baseenv() #' Try an expression with condition handlers #' #' @description #' `r lifecycle::badge("experimental")` #' #' `try_fetch()` establishes handlers for conditions of a given class #' (`"error"`, `"warning"`, `"message"`, ...). Handlers are functions #' that take a condition object as argument and are called when the #' corresponding condition class has been signalled. #' #' A condition handler can: #' #' - **Recover from conditions** with a value. In this case the computation of #' `expr` is aborted and the recovery value is returned from #' `try_fetch()`. Error recovery is useful when you don't want #' errors to abruptly interrupt your program but resume at the #' catching site instead. #' #' ``` #' # Recover with the value 0 #' try_fetch(1 + "", error = function(cnd) 0) #' ``` #' #' - **Rethrow conditions**, e.g. using `abort(msg, parent = cnd)`. #' See the `parent` argument of [abort()]. This is typically done to #' add information to low-level errors about the high-level context #' in which they occurred. #' #' ``` #' try_fetch(1 + "", error = function(cnd) abort("Failed.", parent = cnd)) #' ``` #' #' - **Inspect conditions**, for instance to log data about warnings #' or errors. In this case, the handler must return the [zap()] #' sentinel to instruct `try_fetch()` to ignore (or zap) that #' particular handler. The next matching handler is called if any, #' and errors bubble up to the user if no handler remains. #' #' ``` #' log <- NULL #' try_fetch(1 + "", error = function(cnd) { #' log <<- cnd #' zap() #' }) #' ``` #' #' Whereas `tryCatch()` catches conditions (discarding any running #' code along the way) and then calls the handler, `try_fetch()` first #' calls the handler with the condition on top of the currently #' running code (fetches it where it stands) and then catches the #' return value. This is a subtle difference that has implications #' for the debuggability of your functions. See the comparison with #' `tryCatch()` section below. #' #' Another difference between `try_fetch()` and the base equivalent is #' that errors are matched across chains, see the `parent` argument of #' [abort()]. This is a useful property that makes `try_fetch()` #' insensitive to changes of implementation or context of evaluation #' that cause a classed error to suddenly get chained to a contextual #' error. Note that some chained conditions are not inherited, see the #' `.inherit` argument of [abort()] or [warn()]. In particular, #' downgraded conditions (e.g. from error to warning or from warning #' to message) are not matched across parents. #' #' @param expr An R expression. #' @param ... <[`dynamic-dots`][rlang::dyn-dots]> Named condition #' handlers. The names specify the condition class for which a #' handler will be called. #' #' @section Stack overflows: #' #' A stack overflow occurs when a program keeps adding to itself until #' the stack memory (whose size is very limited unlike heap memory) is #' exhausted. #' #' ``` #' # A function that calls itself indefinitely causes stack overflows #' f <- function() f() #' f() #' #> Error: C stack usage 9525680 is too close to the limit #' ``` #' #' Because memory is very limited when these errors happen, it is not #' possible to call the handlers on the existing program stack. #' Instead, error conditions are first caught by `try_fetch()` and only #' then error handlers are called. Catching the error interrupts the #' program up to the `try_fetch()` context, which allows R to reclaim #' stack memory. #' #' The practical implication is that error handlers should never #' assume that the whole call stack is preserved. For instance a #' [trace_back()] capture might miss frames. #' #' Note that error handlers are only run for stack overflows on R >= #' 4.2. On older versions of R the handlers are simply not run. This #' is because these errors do not inherit from the class #' `stackOverflowError` before R 4.2. Consider using [tryCatch()] #' instead with critical error handlers that need to capture all #' errors on old versions of R. #' #' @section Comparison with `tryCatch()`: #' #' `try_fetch()` generalises `tryCatch()` and `withCallingHandlers()` #' in a single function. It reproduces the behaviour of both calling #' and exiting handlers depending on the return value of the handler. #' If the handler returns the [zap()] sentinel, it is taken as a #' calling handler that declines to recover from a condition. #' Otherwise, it is taken as an exiting handler which returns a value #' from the catching site. #' #' The important difference between `tryCatch()` and `try_fetch()` is #' that the program in `expr` is still fully running when an error #' handler is called. Because the call stack is preserved, this makes #' it possible to capture a full backtrace from within the handler, #' e.g. when rethrowing the error with `abort(parent = cnd)`. #' Technically, `try_fetch()` is more similar to (and implemented on #' top of) [base::withCallingHandlers()] than `tryCatch().` #' #' @export try_fetch <- function(expr, ...) { frame <- environment() catch <- value <- NULL throw <- function(x) { value <<- x delayedAssign("catch", return(value), frame, frame) catch } .External(ffi_try_fetch, frame) } handler_call <- quote(function(cnd) { { .__handler_frame__. <- TRUE .__setup_frame__. <- frame if (inherits(cnd, "message")) { except <- c("warning", "error") } else if (inherits(cnd, "warning")) { except <- "error" } else { except <- "" } } while (!is_null(cnd)) { if (inherits(cnd, CLASS)) { out <- handlers[[I]](cnd) if (!inherits(out, "rlang_zap")) throw(out) } inherit <- .subset2(.subset2(cnd, "rlang"), "inherit") if (is_false(inherit)) { return() } cnd <- .subset2(cnd, "parent") } }) #' Catch a condition #' #' This is a small wrapper around `tryCatch()` that captures any #' condition signalled while evaluating its argument. It is useful for #' situations where you expect a specific condition to be signalled, #' for debugging, and for unit testing. #' #' @param expr Expression to be evaluated with a catching condition #' handler. #' @param classes A character vector of condition classes to catch. By #' default, catches all conditions. #' @return A condition if any was signalled, `NULL` otherwise. #' @examples #' catch_cnd(10) #' catch_cnd(abort("an error")) #' catch_cnd(signal("my_condition", message = "a condition")) #' @export catch_cnd <- function(expr, classes = "condition") { stopifnot(is_character(classes)) handlers <- rep_named(classes, list(identity)) eval_bare(rlang::expr( tryCatch(!!!handlers, { force(expr) return(NULL) }) )) } #' Muffle a condition #' #' Unlike [exiting()] handlers, [calling()] handlers must be explicit #' that they have handled a condition to stop it from propagating to #' other handlers. Use `cnd_muffle()` within a calling handler (or as #' a calling handler, see examples) to prevent any other handlers from #' being called for that condition. #' #' #' @section Mufflable conditions: #' #' Most conditions signalled by base R are muffable, although the name #' of the restart varies. cnd_muffle() will automatically call the #' correct restart for you. It is compatible with the following #' conditions: #' #' * `warning` and `message` conditions. In this case `cnd_muffle()` #' is equivalent to [base::suppressMessages()] and #' [base::suppressWarnings()]. #' #' * Bare conditions signalled with `signal()` or [cnd_signal()]. Note #' that conditions signalled with [base::signalCondition()] are not #' mufflable. #' #' * Interrupts are sometimes signalled with a `resume` restart on #' recent R versions. When this is the case, you can muffle the #' interrupt with `cnd_muffle()`. Check if a restart is available #' with `base::findRestart("resume")`. #' #' If you call `cnd_muffle()` with a condition that is not mufflable #' you will cause a new error to be signalled. #' #' * Errors are not mufflable since they are signalled in critical #' situations where execution cannot continue safely. #' #' * Conditions captured with [base::tryCatch()], [with_handlers()] or #' [catch_cnd()] are no longer mufflable. Muffling restarts _must_ #' be called from a [calling] handler. #' #' @param cnd A condition to muffle. #' @return If `cnd` is mufflable, `cnd_muffle()` jumps to the muffle #' restart and doesn't return. Otherwise, it returns `FALSE`. #' #' @examples #' fn <- function() { #' inform("Beware!", "my_particular_msg") #' inform("On your guard!") #' "foobar" #' } #' #' # Let's install a muffling handler for the condition thrown by `fn()`. #' # This will suppress all `my_particular_wng` warnings but let other #' # types of warnings go through: #' with_handlers(fn(), #' my_particular_msg = calling(function(cnd) { #' inform("Dealt with this particular message") #' cnd_muffle(cnd) #' }) #' ) #' #' # Note how execution of `fn()` continued normally after dealing #' # with that particular message. #' #' # cnd_muffle() can also be passed to with_handlers() as a calling #' # handler: #' with_handlers(fn(), #' my_particular_msg = calling(cnd_muffle) #' ) #' @keywords internal #' @export cnd_muffle <- function(cnd) { restart <- switch(cnd_type(cnd), message = "muffleMessage", warning = "muffleWarning", interrupt = "resume", "rlang_muffle" ) if (!is_null(findRestart(restart))) { invokeRestart(restart) } FALSE } if (getRversion() < "4.0") { utils::globalVariables("globalCallingHandlers") } poke_global_handlers <- function(enable, ...) { check_bool(enable) handlers <- list2(...) in_knitr <- knitr_in_progress() if (in_knitr) { if (enable) { knitr::opts_chunk$set(calling.handlers = handlers) } else { abort("Can't remove calling handlers in knitted documents") } } else { if (enable) { inject(globalCallingHandlers(!!!handlers)) } else { inject(drop_global_handlers(!!!handlers)) } } } drop_global_handlers <- function(...) { to_pop <- list(...) handlers <- globalCallingHandlers() for (i in seq_along(to_pop)) { if (loc <- detect_index(handlers, identical, to_pop[[i]])) { if (is_string(names(to_pop)[[i]], names(handlers)[[loc]])) { handlers[[loc]] <- NULL } } } globalCallingHandlers(NULL) globalCallingHandlers(handlers) } rlang/R/types.R0000644000176200001440000003247414626342040013060 0ustar liggesusers#' Type predicates #' #' These type predicates aim to make type testing in R more #' consistent. They are wrappers around [base::typeof()], so operate #' at a level beneath S3/S4 etc. #' #' Compared to base R functions: #' #' * The predicates for vectors include the `n` argument for #' pattern-matching on the vector length. #' #' * Unlike `is.atomic()` in R < 4.4.0, `is_atomic()` does not return `TRUE` for #' `NULL`. Starting in R 4.4.0 `is.atomic(NULL)` returns FALSE. #' #' * Unlike `is.vector()`, `is_vector()` tests if an object is an #' atomic vector or a list. `is.vector` checks for the presence of #' attributes (other than name). #' #' @param x Object to be tested. #' @param n Expected length of a vector. #' @param finite Whether all values of the vector are finite. The #' non-finite values are `NA`, `Inf`, `-Inf` and `NaN`. Setting this #' to something other than `NULL` can be expensive because the whole #' vector needs to be traversed and checked. #' @seealso [bare-type-predicates] [scalar-type-predicates] #' @name type-predicates NULL #' @export #' @rdname type-predicates is_list <- function(x, n = NULL) { .Call(ffi_is_list, x, n) } parsable_atomic_types <- c("logical", "integer", "double", "complex", "character") atomic_types <- c(parsable_atomic_types, "raw") #' @export #' @rdname type-predicates is_atomic <- function(x, n = NULL) { .Call(ffi_is_atomic, x, n) } #' @export #' @rdname type-predicates is_vector <- function(x, n = NULL) { .Call(ffi_is_vector, x, n) } # Mostly for unit testing is_finite <- function(x) { .Call(ffi_is_finite, x) } #' @export #' @rdname type-predicates is_integer <- function(x, n = NULL) { .Call(ffi_is_integer, x, n) } #' @export #' @rdname type-predicates is_double <- function(x, n = NULL, finite = NULL) { .Call(ffi_is_double, x, n, finite) } #' @export #' @rdname type-predicates is_complex <- function(x, n = NULL, finite = NULL) { .Call(ffi_is_complex, x, n, finite) } #' @export #' @rdname type-predicates is_character <- function(x, n = NULL) { .Call(ffi_is_character, x, n, NULL, NULL) } is_character2 <- function(x, n = NULL, ..., missing = TRUE, empty = TRUE) { check_dots_empty0(...) # FIXME: Change API at C-level so that `TRUE` means no restriction if (is_true(missing)) { missing <- NULL } if (is_true(empty)) { empty <- NULL } .Call(ffi_is_character, x, n, missing, empty) } #' @export #' @rdname type-predicates is_logical <- function(x, n = NULL) { .Call(ffi_is_logical, x, n) } #' @export #' @rdname type-predicates is_raw <- function(x, n = NULL) { .Call(ffi_is_raw, x, n) } #' @export #' @rdname type-predicates is_bytes <- is_raw #' @export #' @usage is_null(x) #' @rdname type-predicates is_null <- is.null #' Scalar type predicates #' #' @description #' #' These predicates check for a given type and whether the vector is #' "scalar", that is, of length 1. #' #' In addition to the length check, `is_string()` and `is_bool()` #' return `FALSE` if their input is missing. This is useful for #' type-checking arguments, when your function expects a single string #' or a single `TRUE` or `FALSE`. #' #' @param x object to be tested. #' @seealso [type-predicates], [bare-type-predicates] #' @name scalar-type-predicates NULL #' @export #' @rdname scalar-type-predicates is_scalar_list <- function(x) { .Call(ffi_is_list, x, 1L) } #' @export #' @rdname scalar-type-predicates is_scalar_atomic <- function(x) { .Call(ffi_is_atomic, x, 1L) } #' @export #' @rdname scalar-type-predicates is_scalar_vector <- function(x) { .Call(ffi_is_vector, x, 1L) } #' @export #' @rdname scalar-type-predicates is_scalar_integer <- function(x) { .Call(ffi_is_integer, x, 1L) } #' @export #' @rdname scalar-type-predicates is_scalar_double <- function(x) { .Call(ffi_is_double, x, 1L, NULL) } #' @export #' @rdname scalar-type-predicates is_scalar_complex <- function(x) { .Call(ffi_is_complex, x, 1L, NULL) } #' @export #' @rdname scalar-type-predicates is_scalar_character <- function(x) { is_character(x, n = 1L) } #' @export #' @rdname scalar-type-predicates is_scalar_logical <- function(x) { .Call(ffi_is_logical, x, 1L) } #' @export #' @rdname scalar-type-predicates is_scalar_raw <- function(x) { .Call(ffi_is_raw, x, 1L) } #' @export #' @param string A string to compare to `x`. If a character vector, #' returns `TRUE` if at least one element is equal to `x`. #' @rdname scalar-type-predicates is_string <- function(x, string = NULL) { .Call(ffi_is_string, x, string, NULL) } is_string2 <- function(x, string = NULL, ..., empty = NULL) { check_dots_empty0(...) .Call(ffi_is_string, x, string, empty) } #' @export #' @rdname scalar-type-predicates is_scalar_bytes <- is_scalar_raw #' @export #' @rdname scalar-type-predicates is_bool <- function(x) { is_logical(x, n = 1) && !is.na(x) } #' Bare type predicates #' #' These predicates check for a given type but only return `TRUE` for #' bare R objects. Bare objects have no class attributes. For example, #' a data frame is a list, but not a bare list. #' #' * The predicates for vectors include the `n` argument for #' pattern-matching on the vector length. #' #' * Like [is_atomic()] and unlike base R `is.atomic()` for R < 4.4.0, #' `is_bare_atomic()` does not return `TRUE` for `NULL`. Starting in #' R 4.4.0, `is.atomic(NULL)` returns FALSE. #' #' * Unlike base R `is.numeric()`, `is_bare_double()` only returns #' `TRUE` for floating point numbers. #' @inheritParams type-predicates #' @seealso [type-predicates], [scalar-type-predicates] #' @name bare-type-predicates NULL #' @export #' @rdname bare-type-predicates is_bare_list <- function(x, n = NULL) { !is.object(x) && is_list(x, n) } #' @export #' @rdname bare-type-predicates is_bare_atomic <- function(x, n = NULL) { !is.object(x) && is_atomic(x, n) } #' @export #' @rdname bare-type-predicates is_bare_vector <- function(x, n = NULL) { is_bare_atomic(x) || is_bare_list(x, n) } #' @export #' @rdname bare-type-predicates is_bare_double <- function(x, n = NULL) { !is.object(x) && is_double(x, n) } #' @export #' @rdname bare-type-predicates is_bare_complex <- function(x, n = NULL) { !is.object(x) && is_complex(x, n) } #' @export #' @rdname bare-type-predicates is_bare_integer <- function(x, n = NULL) { !is.object(x) && is_integer(x, n) } #' @export #' @rdname bare-type-predicates is_bare_numeric <- function(x, n = NULL) { if (!is_null(n) && length(x) != n) return(FALSE) !is.object(x) && typeof(x) %in% c("double", "integer") } #' @export #' @rdname bare-type-predicates is_bare_character <- function(x, n = NULL) { !is.object(x) && is_character(x, n) } #' @export #' @rdname bare-type-predicates is_bare_logical <- function(x, n = NULL) { !is.object(x) && is_logical(x, n) } #' @export #' @rdname bare-type-predicates is_bare_raw <- function(x, n = NULL) { !is.object(x) && is_raw(x, n) } #' @export #' @rdname bare-type-predicates is_bare_string <- function(x, n = NULL) { !is.object(x) && is_string(x, n) } #' @export #' @rdname bare-type-predicates is_bare_bytes <- is_bare_raw #' Is object an empty vector or NULL? #' #' @param x object to test #' @export #' @examples #' is_empty(NULL) #' is_empty(list()) #' is_empty(list(NULL)) is_empty <- function(x) length(x) == 0 #' Is object an environment? #' #' `is_bare_environment()` tests whether `x` is an environment without a s3 or #' s4 class. #' #' @inheritParams is_empty #' @export is_environment <- function(x) { typeof(x) == "environment" } #' @rdname is_environment #' @export is_bare_environment <- function(x) { !is.object(x) && typeof(x) == "environment" } #' Is object identical to TRUE or FALSE? #' #' These functions bypass R's automatic conversion rules and check #' that `x` is literally `TRUE` or `FALSE`. #' @inheritParams is_empty #' @export #' @examples #' is_true(TRUE) #' is_true(1) #' #' is_false(FALSE) #' is_false(0) is_true <- function(x) { identical(x, TRUE) } #' @rdname is_true #' @export is_false <- function(x) { identical(x, FALSE) } #' Is a vector integer-like? #' #' @description #' #' These predicates check whether R considers a number vector to be #' integer-like, according to its own tolerance check (which is in #' fact delegated to the C library). This function is not adapted to #' data analysis, see the help for [base::is.integer()] for examples #' of how to check for whole numbers. #' #' Things to consider when checking for integer-like doubles: #' #' * This check can be expensive because the whole double vector has #' to be traversed and checked. #' #' * Large double values may be integerish but may still not be #' coercible to integer. This is because integers in R only support #' values up to `2^31 - 1` while numbers stored as double can be #' much larger. #' #' @seealso [is_bare_numeric()] for testing whether an object is a #' base numeric type (a bare double or integer vector). #' @inheritParams type-predicates #' @export #' @examples #' is_integerish(10L) #' is_integerish(10.0) #' is_integerish(10.0, n = 2) #' is_integerish(10.000001) #' is_integerish(TRUE) is_integerish <- function(x, n = NULL, finite = NULL) { .Call(ffi_is_integerish, x, n, finite) } #' @rdname is_integerish #' @export is_bare_integerish <- function(x, n = NULL, finite = NULL) { !is.object(x) && is_integerish(x, n, finite) } #' @rdname is_integerish #' @export is_scalar_integerish <- function(x, finite = NULL) { .Call(ffi_is_integerish, x, 1L, finite) } type_of_ <- function(x) { type <- typeof(x) if (is_formula(x)) { if (identical(node_car(x), colon_equals_sym)) { "definition" } else { "formula" } } else if (type == "character") { if (length(x) == 1) "string" else "character" } else if (type %in% c("builtin", "special")) { "primitive" } else { type } } #' Is an object copyable? #' #' When an object is modified, R generally copies it (sometimes #' lazily) to enforce [value #' semantics](https://en.wikipedia.org/wiki/Value_semantics). #' However, some internal types are uncopyable. If you try to copy #' them, either with `<-` or by argument passing, you actually create #' references to the original object rather than actual #' copies. Modifying these references can thus have far reaching side #' effects. #' #' @param x An object to test. #' @keywords internal #' @export #' @examples #' # Let's add attributes with structure() to uncopyable types. Since #' # they are not copied, the attributes are changed in place: #' env <- env() #' structure(env, foo = "bar") #' env #' #' # These objects that can only be changed with side effect are not #' # copyable: #' is_copyable(env) #' #' structure(base::list, foo = "bar") #' str(base::list) is_copyable <- function(x) { switch(typeof(x), NULL = , char = , symbol = , special = , builtin = , environment = , externalptr = FALSE, TRUE ) } is_equal <- function(x, y) { identical(x, y) } #' Is an object referencing another? #' #' @description #' #' There are typically two situations where two symbols may refer to #' the same object. #' #' * R objects usually have copy-on-write semantics. This is an #' optimisation that ensures that objects are only copied if #' needed. When you copy a vector, no memory is actually copied #' until you modify either the original object or the copy is #' modified. #' #' Note that the copy-on-write optimisation is an implementation #' detail that is not guaranteed by the specification of the R #' language. #' #' * Assigning an [uncopyable][is_copyable] object (like an #' environment) creates a reference. These objects are never copied #' even if you modify one of the references. #' #' @param x,y R objects. #' @keywords internal #' @export #' @examples #' # Reassigning an uncopyable object such as an environment creates a #' # reference: #' env <- env() #' ref <- env #' is_reference(ref, env) #' #' # Due to copy-on-write optimisation, a copied vector can #' # temporarily reference the original vector: #' vec <- 1:10 #' copy <- vec #' is_reference(copy, vec) #' #' # Once you modify on of them, the copy is triggered in the #' # background and the objects cease to reference each other: #' vec[[1]] <- 100 #' is_reference(copy, vec) is_reference <- function(x, y) { .Call(ffi_is_reference, x, y) } # Use different generic name to avoid import warnings when loading # packages that import all of rlang after it has been load_all'd rlang_type_sum <- function(x) { if (is_installed("pillar")) { pillar::type_sum(x) } else { UseMethod("rlang_type_sum") } } #' @export rlang_type_sum.ordered <- function(x) "ord" #' @export rlang_type_sum.factor <- function(x) "fct" #' @export rlang_type_sum.POSIXct <- function(x) "dttm" #' @export rlang_type_sum.difftime <- function(x) "time" #' @export rlang_type_sum.Date <- function(x) "date" #' @export rlang_type_sum.data.frame <- function(x) class(x)[[1]] #' @export rlang_type_sum.default <- function(x) { if (!is.object(x)) { switch(typeof(x), logical = "lgl", integer = "int", double = "dbl", character = "chr", complex = "cpl", builtin = , special = , closure = "fn", environment = "env", symbol = if (is_missing(x)) { "missing" } else { "sym" }, typeof(x) ) } else if (!isS4(x)) { paste0("S3: ", class(x)[[1]]) } else { paste0("S4: ", methods::is(x)[[1]]) } } rlang/R/hash.R0000644000176200001440000000354614175213516012641 0ustar liggesusers#' Hashing #' #' @description #' - `hash()` hashes an arbitrary R object. #' #' - `hash_file()` hashes the data contained in a file. #' #' The generated hash is guaranteed to be reproducible across platforms that #' have the same endianness and are using the same R version. #' #' @details #' These hashers use the XXH128 hash algorithm of the xxHash library, which #' generates a 128-bit hash. Both are implemented as streaming hashes, which #' generate the hash with minimal extra memory usage. #' #' For `hash()`, objects are converted to binary using R's native serialization #' tools. On R >= 3.5.0, serialization version 3 is used, otherwise version 2 is #' used. See [serialize()] for more information about the serialization version. #' #' @param x An object. #' #' @param path A character vector of paths to the files to be hashed. #' #' @return #' - For `hash()`, a single character string containing the hash. #' #' - For `hash_file()`, a character vector containing one hash per file. #' #' @export #' @examples #' hash(c(1, 2, 3)) #' hash(mtcars) #' #' authors <- file.path(R.home("doc"), "AUTHORS") #' copying <- file.path(R.home("doc"), "COPYING") #' hashes <- hash_file(c(authors, copying)) #' hashes #' #' # If you need a single hash for multiple files, #' # hash the result of `hash_file()` #' hash(hashes) hash <- function(x) { .Call(ffi_hash, x) } # Keep this alias for a while # https://github.com/r-lib/rlang/issues/1177 on_load( rlang_hash <- ffi_hash ) #' @rdname hash #' @export hash_file <- function(path) { path <- normalizePath(path, mustWork = TRUE) .Call(ffi_hash_file, path) } # ------------------------------------------------------------------------------ hasher_init <- function() { .Call(ffi_hasher_init) } hasher_update <- function(x, data) { .Call(ffi_hasher_update, x, data) } hasher_value <- function(x) { .Call(ffi_hasher_value, x) } rlang/R/cnd-abort.R0000644000176200001440000013632314741440555013573 0ustar liggesusers#' Signal an error, warning, or message #' #' @description #' These functions are equivalent to base functions [base::stop()], #' [base::warning()], and [base::message()]. They signal a condition #' (an error, warning, or message respectively) and make it easy to #' supply condition metadata: #' #' * Supply `class` to create a classed condition that can be caught #' or handled selectively, allowing for finer-grained error #' handling. #' #' * Supply metadata with named `...` arguments. This data is stored #' in the condition object and can be examined by handlers. #' #' * Supply `call` to inform users about which function the error #' occurred in. #' #' * Supply another condition as `parent` to create a [chained #' condition][topic-error-chaining]. #' #' Certain components of condition messages are formatted with unicode #' symbols and terminal colours by default. These aspects can be #' customised, see `r link("topic_condition_customisation")`. #' #' @inheritParams cnd #' @param message The message to display, formatted as a __bulleted #' list__. The first element is displayed as an _alert_ bullet #' prefixed with `!` by default. Elements named `"*"`, `"i"`, `"v"`, #' `"x"`, and `"!"` are formatted as regular, info, success, #' failure, and error bullets respectively. See `r link("topic_condition_formatting")` #' for more about bulleted messaging. #' #' If a message is not supplied, it is expected that the message is #' generated __lazily__ through [cnd_header()] and [cnd_body()] #' methods. In that case, `class` must be supplied. Only `inform()` #' allows empty messages as it is occasionally useful to build user #' output incrementally. #' #' If a function, it is stored in the `header` field of the error #' condition. This acts as a [cnd_header()] method that is invoked #' lazily when the error message is displayed. #' @param class Subclass of the condition. #' @param ... Additional data to be stored in the condition object. #' If you supply condition fields, you should usually provide a #' `class` argument. You may consider prefixing condition fields #' with the name of your package or organisation to prevent name #' collisions. #' @param body,footer Additional bullets. #' @param call The execution environment of a currently running #' function, e.g. `call = caller_env()`. The corresponding function #' call is retrieved and mentioned in error messages as the source #' of the error. #' #' You only need to supply `call` when throwing a condition from a #' helper function which wouldn't be relevant to mention in the #' message. #' #' Can also be `NULL` or a [defused function call][topic-defuse] to #' respectively not display any call or hard-code a code to display. #' #' For more information about error calls, see `r link("topic_error_call")`. #' @param parent Supply `parent` when you rethrow an error from a #' condition handler (e.g. with [try_fetch()]). #' #' - If `parent` is a condition object, a _chained error_ is #' created, which is useful when you want to enhance an error with #' more details, while still retaining the original information. #' #' - If `parent` is `NA`, it indicates an unchained rethrow, which #' is useful when you want to take ownership over an error and #' rethrow it with a custom message that better fits the #' surrounding context. #' #' Technically, supplying `NA` lets `abort()` know it is called #' from a condition handler. This helps it create simpler #' backtraces where the condition handling context is hidden by #' default. #' #' For more information about error calls, see `r link("topic_error_chaining")`. #' @param use_cli_format Whether to format `message` lazily using #' [cli](https://cli.r-lib.org/) if available. This results in #' prettier and more accurate formatting of messages. See #' [local_use_cli()] to set this condition field by default in your #' package namespace. #' #' If set to `TRUE`, `message` should be a character vector of #' individual and unformatted lines. Any newline character `"\\n"` #' already present in `message` is reformatted by cli's paragraph #' formatter. See `r link("topic_condition_formatting")`. #' @param .inherit Whether the condition inherits from `parent` #' according to [cnd_inherits()] and [try_fetch()]. By default, #' parent conditions of higher severity are not inherited. For #' instance an error chained to a warning is not inherited to avoid #' unexpectedly catching an error downgraded to a warning. #' @param .internal If `TRUE`, a footer bullet is added to `message` #' to let the user know that the error is internal and that they #' should report it to the package authors. This argument is #' incompatible with `footer`. #' @param .file A connection or a string specifying where to print the #' message. The default depends on the context, see the `stdout` vs #' `stderr` section. #' @param .frame The throwing context. Used as default for #' `.trace_bottom`, and to determine the internal package to mention #' in internal errors when `.internal` is `TRUE`. #' @param .trace_bottom Used in the display of simplified backtraces #' as the last relevant call frame to show. This way, the irrelevant #' parts of backtraces corresponding to condition handling #' ([tryCatch()], [try_fetch()], `abort()`, etc.) are hidden by #' default. Defaults to `call` if it is an environment, or `.frame` #' otherwise. Without effect if `trace` is supplied. #' @param .subclass `r lifecycle::badge("deprecated")` This argument #' was renamed to `class` in rlang 0.4.2 for consistency with our #' conventions for class constructors documented in #' . #' #' @section Error prefix: #' As with [base::stop()], errors thrown with `abort()` are prefixed #' with `"Error: "`. Calls and source references are included in the #' prefix, e.g. `"Error in `my_function()` at myfile.R:1:2:"`. There #' are a few cosmetic differences: #' #' - The call is stripped from its arguments to keep it simple. It is #' then formatted using the [cli package](https://cli.r-lib.org/) if #' available. #' #' - A line break between the prefix and the message when the former #' is too long. When a source location is included, a line break is #' always inserted. #' #' If your throwing code is highly structured, you may have to #' explicitly inform `abort()` about the relevant user-facing call to #' include in the prefix. Internal helpers are rarely relevant to end #' users. See the `call` argument of `abort()`. #' #' @section Backtrace: #' `abort()` saves a backtrace in the `trace` component of the error #' condition. You can print a simplified backtrace of the last error #' by calling [last_error()] and a full backtrace with #' `summary(last_error())`. Learn how to control what is displayed #' when an error is thrown with [`rlang_backtrace_on_error`]. #' #' @section Muffling and silencing conditions: #' Signalling a condition with `inform()` or `warn()` displays a #' message in the console. These messages can be muffled as usual with #' [base::suppressMessages()] or [base::suppressWarnings()]. #' #' `inform()` and `warn()` messages can also be silenced with the #' global options `rlib_message_verbosity` and #' `rlib_warning_verbosity`. These options take the values: #' #' - `"default"`: Verbose unless the `.frequency` argument is supplied. #' - `"verbose"`: Always verbose. #' - `"quiet"`: Always quiet. #' #' When set to quiet, the message is not displayed and the condition #' is not signalled. #' #' @section `stdout` and `stderr`: #' By default, `abort()` and `inform()` print to standard output in #' interactive sessions. This allows rlang to be in control of the #' appearance of messages in IDEs like RStudio. #' #' There are two situations where messages are streamed to `stderr`: #' #' - In non-interactive sessions, messages are streamed to standard #' error so that R scripts can easily filter them out from normal #' output by redirecting `stderr`. #' #' - If a sink is active (either on output or on messages) messages #' are always streamd to `stderr`. #' #' These exceptions ensure consistency of behaviour in interactive and #' non-interactive sessions, and when sinks are active. #' #' @details #' - `abort()` throws subclassed errors, see #' [`"rlang_error"`][rlang_error]. #' #' - `warn()` temporarily set the `warning.length` global option to #' the maximum value (8170), unless that option has been changed #' from the default value. The default limit (1000 characters) is #' especially easy to hit when the message contains a lot of ANSI #' escapes, as created by the crayon or cli packages #' #' @seealso #' - `r link("topic_error_call")` #' - `r link("topic_error_chaining")` #' #' @examples #' # These examples are guarded to avoid throwing errors #' if (FALSE) { #' #' # Signal an error with a message just like stop(): #' abort("The error message.") #' #' #' # Unhandled errors are saved automatically by `abort()` and can be #' # retrieved with `last_error()`. The error prints with a simplified #' # backtrace: #' f <- function() try(g()) #' g <- function() evalq(h()) #' h <- function() abort("Tilt.") #' last_error() #' #' # Use `summary()` to print the full backtrace and the condition fields: #' summary(last_error()) #' #' #' # Give a class to the error: #' abort("The error message", "mypkg_bad_error") #' #' # This allows callers to handle the error selectively #' tryCatch( #' mypkg_function(), #' mypkg_bad_error = function(err) { #' warn(conditionMessage(err)) # Demote the error to a warning #' NA # Return an alternative value #' } #' ) #' #' # You can also specify metadata that will be stored in the condition: #' abort("The error message.", "mypkg_bad_error", data = 1:10) #' #' # This data can then be consulted by user handlers: #' tryCatch( #' mypkg_function(), #' mypkg_bad_error = function(err) { #' # Compute an alternative return value with the data: #' recover_error(err$data) #' } #' ) #' #' #' # If you call low-level APIs it may be a good idea to create a #' # chained error with the low-level error wrapped in a more #' # user-friendly error. Use `try_fetch()` to fetch errors of a given #' # class and rethrow them with the `parent` argument of `abort()`: #' file <- "http://foo.bar/baz" #' try( #' try_fetch( #' download(file), #' error = function(err) { #' msg <- sprintf("Can't download `%s`", file) #' abort(msg, parent = err) #' }) #' ) #' #' # You can also hard-code the call when it's not easy to #' # forward it from the caller #' f <- function() { #' abort("my message", call = call("my_function")) #' } #' g <- function() { #' f() #' } #' # Shows that the error occured in `my_function()` #' try(g()) #' #' } #' @export abort <- function(message = NULL, class = NULL, ..., call, body = NULL, footer = NULL, trace = NULL, parent = NULL, use_cli_format = NULL, .inherit = TRUE, .internal = FALSE, .file = NULL, .frame = caller_env(), .trace_bottom = NULL, .subclass = deprecated()) { check_environment(.frame) .__signal_frame__. <- TRUE rethrowing <- !is_null(parent) if (is_na(parent)) { parent <- NULL } if (is_list(maybe_missing(call))) { if (!identical(names(call), c("call", "frame")) && !identical(names(call), c("", "frame"))) { abort("When a list, `call` must have \"call\" and \"frame\" names.") } .frame <- call[["frame"]] %||% .frame call <- call[["call"]] } # `.frame` is used to soft-truncate the backtrace if (is_null(.trace_bottom)) { if (rethrowing) { .trace_bottom <- .frame } else { # Truncate backtrace up to `call` if it is a frame if (is_environment(maybe_missing(call))) { .trace_bottom <- call } else { .trace_bottom <- .frame } } } else { check_environment(.trace_bottom) } info <- abort_context(.trace_bottom, rethrowing, maybe_missing(call)) if (is_missing(call)) { if (is_null(info$from_handler)) { call <- .frame } else { call <- info$setup_caller } } else if (rethrowing && identical(call, info$handler_frame)) { call <- info$setup_caller } if (is_formula(message, scoped = TRUE, lhs = FALSE)) { message <- as_function(message) } message <- validate_signal_args(message, class, call, .subclass, "abort") error_call <- error_call(call) message_info <- cnd_message_info( message, body, footer, .frame, use_cli_format = use_cli_format, internal = .internal ) message <- message_info$message extra_fields <- message_info$extra_fields use_cli_format <- message_info$use_cli_format extra_fields$rlang <- c( extra_fields$rlang, list(inherit = .inherit) ) parent_trace <- if (rethrowing) parent[["trace"]] if (!is_null(parent_trace) && is_environment(call)) { calls <- sys.calls() frames <- sys.frames() loc_frame <- detect_index(frames, identical, call, .right = TRUE) if (loc_frame && loc_frame <= nrow(parent_trace)) { parent_call <- parent_trace[["call"]][[loc_frame]] this_call <- frame_call(call) if (identical(parent_call, this_call)) { if (is_null(parent_trace[["error_frame"]])) { parent_trace[["error_frame"]] <- FALSE } parent_trace[["error_frame"]][[loc_frame]] <- TRUE parent$trace <- parent_trace } } } cnd <- error_cnd( class, ..., message = message, !!!extra_fields, use_cli_format = use_cli_format, call = error_call, parent = parent ) if (is_null(trace) && is_null(parent_trace) && is_null(peek_option("rlang:::disable_trace_capture"))) { with_options( # Prevents infloops when rlang throws during trace capture "rlang:::disable_trace_capture" = TRUE, "rlang:::visible_bottom" = info$bottom_frame, "rlang:::error_frame" = if (is_environment(call)) call else NULL, "rlang:::error_arg" = cnd[["arg"]], { trace <- trace_back() } ) } cnd$trace <- trace signal_abort(cnd, .file) } abort_context <- function(frame, rethrowing, abort_call, call = caller_env()) { calls <- sys.calls() frames <- sys.frames() parents <- sys.parents() frame_loc <- detect_index(frames, identical, frame) bottom_loc <- frame_loc setup_loc <- 0L setup_caller <- NULL from_handler <- NULL handler_frame <- NULL # If rethrowing we need to find: # - The caller of the condition setup frame. This replaces `call` # when it points to the handler frame. # - The caller of the handler frame, used to soft-truncate the # backtrace. This way we hide the condition signalling and # handling context (which can be quite complex) in simplified # backtraces. if (rethrowing) { # This iteration through callers may be incorrect in case of # intervening frames. Ideally, we'd iterate only over parent frames. # This shouldn't be likely to cause issues though. while (is_null(from_handler) && frame_loc > 1L) { prev_frame <- frames[[frame_loc - 1L]] if (env_has(prev_frame, ".__handler_frame__.")) { from_handler <- "calling" handler_frame <- frames[[frame_loc]] frame_loc <- frame_loc - 1L setup_frame <- env_get(prev_frame, ".__setup_frame__.", default = NULL) if (!is_null(setup_frame)) { setup_caller <- eval_bare(call2(parent.frame), setup_frame) } } if ((frame_loc - 1) > 0) { call1 <- calls[[frame_loc]] call2 <- calls[[frame_loc - 1]] if (is_exiting_handler_call(call1, call2)) { from_handler <- "exiting" handler_frame <- handler_frame %||% frames[[frame_loc]] setup_loc <- calls_try_catch_loc(calls, frame_loc) bottom_loc <- parents[[setup_loc]] } else { if (is_calling_handler_inlined_call(call1)) { from_handler <- "calling" handler_frame <- handler_frame %||% frames[[frame_loc]] bottom_loc <- calls_signal_loc(calls, frame_loc - 1L) } else if (is_calling_handler_simple_error_call(call1, call2)) { from_handler <- "calling" handler_frame <- handler_frame %||% frames[[frame_loc]] bottom_loc <- calls_signal_loc(calls, frame_loc - 2L) } setup_loc <- calls_setup_loc(calls, frames, frame_loc) } } if (is_null(from_handler)) { frame_loc <- frame_loc - 1L } } } if (bottom_loc) { # Skip frames marked with the sentinel `.__signal_frame__.` bottom_loc <- skip_signal_frames(bottom_loc, frames) bottom_frame <- frames[[bottom_loc]] if (!rethrowing && !is_missing(abort_call) && is_environment(abort_call)) { abort_call_loc <- detect_index(frames, identical, abort_call) if (abort_call_loc && abort_call_loc < bottom_loc) { bottom_frame <- frames[[abort_call_loc]] } } } else { bottom_frame <- NULL } if (is_null(setup_caller) && setup_loc && parents[[setup_loc]]) { setup_caller <- frames[[parents[[setup_loc]]]] } list( from_handler = from_handler, handler_frame = handler_frame, bottom_frame = bottom_frame, setup_caller = setup_caller ) } calls_try_catch_loc <- function(calls, loc) { loc <- loc - 1L node <- as.pairlist(rev(calls[seq_len(loc)])) while (is_call(node_car(node), c("tryCatchList", "tryCatchOne"))) { node <- node_cdr(node) loc <- loc - 1L } loc } calls_signal_loc <- function(calls, loc) { # Visible bindings for R CMD check tmp_node <- tmp_loc <- found_restart <- NULL node <- as.pairlist(rev(calls[seq_len(loc)])) call <- node_car(node) advance <- function(node, i) { list(node_cdr(node), i - 1L) } advance_restart <- function(node, i) { found <- FALSE restart_fns <- c( "doWithOneRestart", "withOneRestart", "withRestarts" ) while (is_call(node_car(node), restart_fns)) { node <- node_cdr(node) i <- i - 1L found <- TRUE } list(node, i, found) } if (is_call(call, "stop")) { return(loc) } if (is_call(call, "signalCondition")) { c(tmp_node, tmp_loc, found_restart) %<-% advance_restart(node, loc) if (found_restart && is_call(node_car(tmp_node), "message")) { return(tmp_loc) } else { return(loc) } } c(tmp_node, tmp_loc, found_restart) %<-% advance_restart(node, loc) if (found_restart) { if (is_call(node_car(tmp_node), ".signalSimpleWarning")) { c(tmp_node, tmp_loc) %<-% advance(tmp_node, tmp_loc) } if (is_call(node_car(tmp_node), "warning")) { return(tmp_loc) } } loc } calls_setup_loc <- function(calls, frames, handler_loc) { handler <- sys.function(handler_loc) top <- handler_loc while (TRUE) { calls <- calls[seq_len(top)] setup_loc <- detect_index(calls, is_call, "withCallingHandlers", .right = TRUE) if (!setup_loc) { return(0L) } signal_handlers <- frames[[setup_loc]][["handlers"]] if (some(signal_handlers, identical, handler)) { return(setup_loc) } top <- setup_loc - 1L } } skip_signal_frames <- function(loc, frames) { found <- FALSE while (loc > 1 && env_has(frames[[loc - 1L]], ".__signal_frame__.")) { found <- TRUE loc <- loc - 1L } if (found) { loc - 1L } else { loc } } is_calling_handler_inlined_call <- function(call) { is_call(call) && length(call) >= 2 && is_function(call[[1]]) && is_condition(call[[2]]) } is_calling_handler_simple_error_call <- function(call1, call2) { identical(call1, quote(h(simpleError(msg, call)))) && is_call(call2, ".handleSimpleError") } is_exiting_handler_call <- function(call1, call2) { identical(call1, quote(value[[3L]](cond))) && is_call(call2, "tryCatchOne") } cnd_message_info <- function(message, body, footer, env, cli_opts = NULL, use_cli_format = NULL, internal = FALSE, error_call = caller_env()) { if (internal) { check_exclusive(footer, .internal, .require = FALSE, .frame = error_call) } if (is_function(message)) { header <- message message <- "" } else { header <- NULL } if (length(message) > 1 && !is_character(body) && !is_null(body)) { stop_multiple_body(body, call = error_call) } cli_opts <- cli_opts %||% use_cli(env, error_call = error_call) if (!is_null(use_cli_format)) { cli_opts[["format"]] <- use_cli_format } fields <- list() if (cli_opts[["inline"]]) { message[] <- map_chr(message, cli::format_inline, .envir = env) } use_cli_format <- cli_opts[["format"]] # Formatting with cli is delayed until print time so we can properly # indent and width-wrap depending on the context if (use_cli_format) { if (length(message) > 1) { fields$body <- c(message[-1], body) message <- message[1] } else { fields$body <- body } if (!is_null(header)) { fields$header <- header } if (!is_null(footer)) { fields$footer <- footer } if (internal) { fields$footer <- footer_internal(env) } } else { # Compatibility with older bullets formatting if (length(message) > 1 && is_null(names(message))) { names(message) <- c("", rep_len("*", length(message) - 1)) } if (is_character(body)) { message <- c(message, body) } else { fields$body <- body } if (is_character(footer)) { message <- c(message, footer) } else { fields$footer <- footer } if (internal) { message <- c(message, footer_internal(env)) } message <- .rlang_cli_format_fallback(message) if (is_function(header)) { fields$header <- header } } list( message = message, use_cli_format = use_cli_format, extra_fields = fields ) } utils::globalVariables(".internal") footer_internal <- function(env) { top <- topenv(env) url_line <- NULL if (is_namespace(top)) { pkg <- ns_env_name(top) pkg_line <- sprintf( "This is an internal error that was detected in the %s package.", format_pkg(pkg) ) url <- pkg_url_bug(pkg) if (!is_null(url)) { url_line <- sprintf( "Please report it at %s with a %s and the full backtrace.", format_url(url), format_href("reprex", "https://tidyverse.org/help/") ) } } else { pkg_line <- "This is an internal error, please report it to the package authors." } c("i" = pkg_line, " " = url_line) } stop_multiple_body <- function(body, call) { msg <- c( sprintf( "Can't supply conflicting bodies in %s and %s.", format_arg("body"), format_arg("message") ), "x" = sprintf( "%s must be character or NULL when a length > 1 %s is supplied.", format_arg("body"), format_arg("message") ), "i" = sprintf( "%s is currently %s.", format_arg("body"), obj_type_friendly(body) ) ) abort(msg, call = call) } #' Use cli to format error messages #' #' @description #' `r lifecycle::badge("experimental")` #' #' `local_use_cli()` marks a package namespace or the environment of a #' running function with a special flag that instructs [abort()] to #' use cli to format error messages. This formatting happens lazily, #' at print-time, in various places: #' #' - When an unexpected error is displayed to the user. #' - When a captured error is printed in the console, for instance via #' [last_error()]. #' - When [conditionMessage()] is called. #' #' cli formats messages and bullets with indentation and #' width-wrapping to produce a polished display of messages. #' #' @inheritParams args_dots_empty #' @param format Whether to use cli at print-time to format messages #' and bullets. #' @param inline `r lifecycle::badge("experimental")` Whether to use #' cli at throw-time to format the inline parts of a message. This #' makes it possible to use cli interpolation and formatting with #' `abort()`. #' @param frame A package namespace or an environment of a running #' function. #' #' @section Usage: #' #' To use cli formatting automatically in your package: #' #' 1. Make sure [run_on_load()] is called from your `.onLoad()` hook. #' #' 2. Call `on_load(local_use_cli())` at the top level of your namespace. #' #' It is also possible to call `local_use_cli()` inside a running #' function, in which case the flag only applies within that function. #' #' @keywords internal #' @export local_use_cli <- function(..., format = TRUE, inline = FALSE, frame = caller_env()) { check_dots_empty0(...) use_cli <- c(format = format, inline = inline) if (is_namespace(frame)) { frame$.__rlang_use_cli__. <- use_cli } else { local_bindings(.__rlang_use_cli__. = use_cli, .frame = frame) } invisible(NULL) } use_cli <- function(env, error_call) { # Internal option to disable cli in case of recursive errors if (is_true(peek_option("rlang:::disable_cli"))) { return(FALSE) } # Formatting with cli is opt-in default <- c(format = FALSE, inline = FALSE) last <- topenv(env) # Search across load-all'd environments if (identical(last, global_env()) && "devtools_shims" %in% search()) { last <- empty_env() } flag <- env_get( env, ".__rlang_use_cli__.", default = default, inherit = TRUE, last = last ) check_use_cli_flag(flag, error_call = error_call) flag } # Makes sure `inline` can't be set without `format`. Formatting with # cli is optional. If cli is not installed or too old, the rlang # fallback formatting is used. On the other hand, formatting inline # parts with cli requires a recent version of cli to be installed. check_use_cli_flag <- function(flag, error_call) { if (!is_logical(flag) || !identical(names(flag), c("format", "inline")) || anyNA(flag)) { abort("`.__rlang_use_cli__.` has unknown format.", call = error_call) } if (flag[["inline"]]) { if (!has_cli_format) { msg <- c( "`.__rlang_use_cli__.[[\"inline\"]]` is set to `TRUE` but cli is not installed or is too old.", "i" = "The package author should add a recent version of `cli` to their `Imports`." ) with_options( "rlang:::disable_cli" = TRUE, abort(call = error_call) ) } if (!flag[["format"]]) { msg <- "Can't use cli inline formatting without cli bullets formatting." abort(msg, call = error_call) } } } signal_abort <- function(cnd, file = NULL) { # Hide this frame in backtraces .__signal_frame__. <- TRUE if (is_true(peek_option("rlang::::force_unhandled_error"))) { # Fall back with the full rlang error fallback <- cnd } else { # Let exiting and calling handlers handle the fully typed # condition. The error message hasn't been altered yet and won't # affect handling functions like `try()`. signalCondition(cnd) # If we're still here, the error is unhandled. Fall back with a # bare condition to avoid calling handlers logging the same error # twice fallback <- cnd class(fallback) <- c("rlang_error", "condition") fallback$message <- "" fallback$rlang$internal$entraced <- TRUE } # Save the unhandled error for `rlang::last_error()`. poke_last_error(cnd) if (peek_show_error_messages()) { # Include backtrace footer option in the condition cnd <- cnd_set_backtrace_on_error(cnd, peek_backtrace_on_error()) # Print the error manually. This allows us to use our own style, # include parent errors, and work around limitations on the length # of error messages (#856). msg <- cnd_message(cnd, inherit = TRUE, prefix = TRUE) cat_line(msg, file = file %||% default_message_file()) } # Use `stop()` to run the `getOption("error")` handler (used by # RStudio to record a backtrace) and cause a long jump. Running the # handler manually wouldn't work because it might (and in RStudio's # case, it does) call `geterrmessage()`. Turn off the regular error # printing to avoid printing the error twice. local_options(show.error.messages = FALSE) stop(fallback) } peek_show_error_messages <- function() { # `abort()` respects the base R option `show.error.messages` (#1630). # The only time we don't display error messages is an explicit `FALSE`. # All other values still show error messages. !is_false(peek_option("show.error.messages")) } #' Set local error call in an execution environment #' #' `local_error_call()` is an alternative to explicitly passing a #' `call` argument to [abort()]. It sets the call (or a value that #' indicates where to find the call, see below) in a local binding #' that is automatically picked up by [abort()]. #' #' @param call This can be: #' #' - A call to be used as context for an error thrown in that #' execution environment. #' #' - The `NULL` value to show no context. #' #' - An execution environment, e.g. as returned by [caller_env()]. #' The [sys.call()] for that environment is taken as context. #' @param frame The execution environment in which to set the local #' error call. #' #' @section Motivation for setting local error calls: #' #' By default [abort()] uses the function call of its caller as #' context in error messages: #' #' ``` #' foo <- function() abort("Uh oh.") #' foo() #' #> Error in `foo()`: Uh oh. #' ``` #' #' This is not always appropriate. For example a function that checks #' an input on the behalf of another function should reference the #' latter, not the former: #' #' ``` #' arg_check <- function(arg, #' error_arg = as_string(substitute(arg))) { #' abort(cli::format_error("{.arg {error_arg}} is failing.")) #' } #' #' foo <- function(x) arg_check(x) #' foo() #' #> Error in `arg_check()`: `x` is failing. #' ``` #' #' The mismatch is clear in the example above. `arg_check()` does not #' have any `x` argument and so it is confusing to present #' `arg_check()` as being the relevant context for the failure of the #' `x` argument. #' #' One way around this is to take a `call` or `error_call` argument #' and pass it to `abort()`. Here we name this argument `error_call` #' for consistency with `error_arg` which is prefixed because there is #' an existing `arg` argument. In other situations, taking `arg` and #' `call` arguments might be appropriate. #' #' ``` #' arg_check <- function(arg, #' error_arg = as_string(substitute(arg)), #' error_call = caller_env()) { #' abort( #' cli::format_error("{.arg {error_arg}} is failing."), #' call = error_call #' ) #' } #' #' foo <- function(x) arg_check(x) #' foo() #' #> Error in `foo()`: `x` is failing. #' ``` #' #' This is the generally recommended pattern for argument checking #' functions. If you mention an argument in an error message, provide #' your callers a way to supply a different argument name and a #' different error call. `abort()` stores the error call in the `call` #' condition field which is then used to generate the "in" part of #' error messages. #' #' In more complex cases it's often burdensome to pass the relevant #' call around, for instance if your checking and throwing code is #' structured into many different functions. In this case, use #' `local_error_call()` to set the call locally or instruct `abort()` #' to climb the call stack one level to find the relevant call. In the #' following example, the complexity is not so important that sparing #' the argument passing makes a big difference. However this #' illustrates the pattern: #' #' ``` #' arg_check <- function(arg, #' error_arg = caller_arg(arg), #' error_call = caller_env()) { #' # Set the local error call #' local_error_call(error_call) #' #' my_classed_stop( #' cli::format_error("{.arg {error_arg}} is failing.") #' ) #' } #' #' my_classed_stop <- function(message) { #' # Forward the local error call to the caller's #' local_error_call(caller_env()) #' #' abort(message, class = "my_class") #' } #' #' foo <- function(x) arg_check(x) #' foo() #' #> Error in `foo()`: `x` is failing. #' ``` #' #' @section Error call flags in performance-critical functions: #' #' The `call` argument can also be the string `"caller"`. This is #' equivalent to `caller_env()` or `parent.frame()` but has a lower #' overhead because call stack introspection is only performed when an #' error is triggered. Note that eagerly calling `caller_env()` is #' fast enough in almost all cases. #' #' If your function needs to be really fast, assign the error call #' flag directly instead of calling `local_error_call()`: #' #' ``` #' .__error_call__. <- "caller" #' ``` #' #' @examples #' # Set a context for error messages #' function() { #' local_error_call(quote(foo())) #' local_error_call(sys.call()) #' } #' #' # Disable the context #' function() { #' local_error_call(NULL) #' } #' #' # Use the caller's context #' function() { #' local_error_call(caller_env()) #' } #' @export local_error_call <- function(call, frame = caller_env()) { # This doesn't implement the semantics of a `local_` function # perfectly in order to be as fast as possible frame$.__error_call__. <- call invisible(NULL) } #' Documentation anchor for error arguments #' #' @description #' #' Use `@inheritParams rlang::args_error_context` in your package to #' document `arg` and `call` arguments (or equivalently their prefixed #' versions `error_arg` and `error_call`). #' #' - `arg` parameters should be formatted as argument (e.g. using #' cli's `.arg` specifier) and included in error messages. See also #' [caller_arg()]. #' #' - `call` parameters should be included in error conditions in a #' field named `call`. An easy way to do this is by passing a `call` #' argument to [abort()]. See also [local_error_call()]. #' #' @param arg An argument name as a string. This argument #' will be mentioned in error messages as the input that is at the #' origin of a problem. #' @param error_arg An argument name as a string. This argument #' will be mentioned in error messages as the input that is at the #' origin of a problem. #' @param call The execution environment of a currently #' running function, e.g. `caller_env()`. The function will be #' mentioned in error messages as the source of the error. See the #' `call` argument of [rlang::abort()] for more information. #' @param error_call The execution environment of a currently #' running function, e.g. `caller_env()`. The function will be #' mentioned in error messages as the source of the error. See the #' `call` argument of [rlang::abort()] for more information. #' #' @name args_error_context NULL #' Find the caller argument for error messages #' #' @description #' #' `caller_arg()` is a variant of `substitute()` or [ensym()] for #' arguments that reference other arguments. Unlike `substitute()` #' which returns an expression, `caller_arg()` formats the expression #' as a single line string which can be included in error messages. #' #' - When included in an error message, the resulting label should #' generally be formatted as argument, for instance using the `.arg` #' in the cli package. #' #' - Use `@inheritParams rlang::args_error_context` to document an #' `arg` or `error_arg` argument that takes `error_arg()` as default. #' #' @param arg An argument name in the current function. #' @usage NULL #' #' @examples #' arg_checker <- function(x, arg = caller_arg(x), call = caller_env()) { #' cli::cli_abort("{.arg {arg}} must be a thingy.", arg = arg, call = call) #' } #' #' my_function <- function(my_arg) { #' arg_checker(my_arg) #' } #' #' try(my_function(NULL)) #' @export caller_arg <- function(arg) { arg <- substitute(arg) check_arg(arg) expr <- do.call(substitute, list(arg), envir = caller_env()) as_label(expr) } #' Validate and format a function call for use in error messages #' #' @description #' #' - `error_call()` takes either a frame environment or a call. If the #' input is an environment, `error_call()` acts like [frame_call()] #' with some additional logic, e.g. for S3 methods and for frames #' with a [local_error_call()]. #' #' - `format_error_call()` simplifies its input to a simple call (see #' section below) and formats the result as code (using cli if #' available). Use this function to generate the "in" part of an #' error message from a stack frame call. #' #' `format_error_call()` first passes its input to `error_call()` to #' fetch calls from frame environments. #' #' @section Details of formatting: #' #' - The arguments of function calls are stripped. #' #' - Complex function calls containing inlined objects return #' `NULL`. #' #' - Calls to `if` preserve the condition since it might be #' informative. Branches are dropped. #' #' - Calls to operators and other special syntax are formatted using #' their names rather than the potentially confusing function form. #' #' @inheritParams args_error_context #' @return Either a string formatted as code or `NULL` if a simple #' call could not be generated. #' #' @keywords internal #' #' @examples #' # Arguments are stripped #' writeLines(format_error_call(quote(foo(bar, baz)))) #' #' # Returns `NULL` with complex calls such as those that contain #' # inlined functions #' format_error_call(call2(list)) #' #' # Operators are formatted using their names rather than in #' # function call form #' writeLines(format_error_call(quote(1 + 2))) #' @export format_error_call <- function(call) { call <- error_call(call) if (is_null(call)) { return(NULL) } label <- error_call_as_string(call) if (is_null(label)) { return(NULL) } if (grepl("\n", label)) { return(cli_with_whiteline_escapes(label, format_code)) } format_code(label) } error_call_as_string <- function(call) { if (!is_call(call)) { return(NULL) } if (inherits(call, "AsIs")) { call <- expr_deparse(unclass(call)) if (length(call) == 1) { return(call) } else { return(NULL) } } # Functions that forward their error context to their caller # shouldn't generally be called via NSE but there are exceptions, # such as testthat snapshots. # # - `do.call()` or `eval_bare()` shouldn't generally cause issues. If # the environment exists on the stack, we find its `sys.call()`. If # it doesn't exist, taking its `sys.call()` returns `NULL` which # disables the error context. # # - On the other hand, `eval()` always creates a specific frame for # all environments and the `sys.call()` for that frame is `eval()`. # It wouldn't be useful to display this as the context so calls to # `eval()` and `evalq()` are replaced by `NULL`. if (is_call(call, c("eval", "evalq", "eval_tidy"))) { return(NULL) } if (!is_call_simple(call)) { if (is_expression(call) && is_call_index(call)) { return(as_label(call[1])) } else { return(NULL) } } # Remove namespace for now to simplify conversion old <- call[[1]] call[[1]] <- sym(call_name(call)) # Deal with `if` bombs. Keep the condition as it is informative but # drop the uninformative branches to avoid multiline calls. See # https://github.com/r-lib/testthat/issues/1429 if (is_call(call, "if")) { call[[3]] <- quote(...) return(as_label(call[1:3])) } # Preserve operator calls, even if multiline if (!is_string(call_parse_type(call), "")) { return(paste(error_call_deparse(call), collapse = "\n")) } # FIXME! Deparse with arguments? if (is_symbol(call[[1]]) && needs_backticks(call[[1]])) { return(as_string(call[[1]])) } # Remove distracting arguments from the call and restore namespace call[[1]] <- old as_label(call[1]) } # Add indent to ulterior lines error_call_deparse <- function(call) { out <- expr_deparse(call) if (length(out) > 1) { out[-1] <- paste0(" ", out[-1]) } out } #' @rdname format_error_call #' @export error_call <- function(call) { while (is_environment(call)) { flag <- env_get(call, ".__error_call__.", default = TRUE) if (is_null(flag) || is_call(flag)) { call <- flag break } if (is_environment(flag)) { call <- flag next } if (is_string(flag, "caller")) { call <- eval_bare(call2(caller_env), call) next } # Replace `f.foo(...)` calls by `f(...)` if (is_string(gen <- call$.Generic)) { # Climb methods frames to find the generic call. This call # carries the relevant srcref. frames <- sys.frames() i <- detect_index(frames, identical, call, .right = TRUE) while (i > 1) { i <- i - 1 prev <- frames[[i]] if (is_call(frame_call(prev), "NextMethod")) { next } if (identical(prev$.Generic, gen)) { next } # Recurse in case there is an error flag in a dispatch helper return(error_call(prev)) } } call <- frame_call(call) break } if (!is_call(call)) { return(NULL) } quo_squash(call) } call_restore <- function(x, to) { attr(x, "srcref") <- attr(to, "srcref") x } #' Display backtrace on error #' #' @description #' rlang errors carry a backtrace that can be inspected by calling #' [last_error()]. You can also control the default display of the #' backtrace by setting the option `rlang_backtrace_on_error` to one #' of the following values: #' #' * `"none"` show nothing. #' * `"reminder"`, the default in interactive sessions, displays a reminder that #' you can see the backtrace with [rlang::last_error()]. #' * `"branch"` displays a simplified backtrace. #' * `"full"`, the default in non-interactive sessions, displays the full tree. #' #' rlang errors are normally thrown with [abort()]. If you promote #' base errors to rlang errors with [global_entrace()], #' `rlang_backtrace_on_error` applies to all errors. #' #' @section Promote base errors to rlang errors: #' #' You can use `options(error = rlang::entrace)` to promote base errors to #' rlang errors. This does two things: #' #' * It saves the base error as an rlang object so you can call [last_error()] #' to print the backtrace or inspect its data. #' #' * It prints the backtrace for the current error according to the #' `rlang_backtrace_on_error` option. #' #' @section Warnings and errors in RMarkdown: #' #' The display of errors depends on whether they're expected (i.e. #' chunk option `error = TRUE`) or unexpected: #' #' * Expected errors are controlled by the global option #' `"rlang_backtrace_on_error_report"` (note the `_report` suffix). #' The default is `"none"` so that your expected errors don't #' include a reminder to run `rlang::last_error()`. Customise this #' option if you want to demonstrate what the error backtrace will #' look like. #' #' You can also use [last_error()] to display the trace like you #' would in your session, but it currently only works in the next #' chunk. #' #' * Unexpected errors are controlled by the global option #' `"rlang_backtrace_on_error"`. The default is `"branch"` so you'll #' see a simplified backtrace in the knitr output to help you figure #' out what went wrong. #' #' When knitr is running (as determined by the `knitr.in.progress` #' global option), the default top environment for backtraces is set #' to the chunk environment `knitr::knit_global()`. This ensures that #' the part of the call stack belonging to knitr does not end up in #' backtraces. If needed, you can override this by setting the #' `rlang_trace_top_env` global option. #' #' Similarly to `rlang_backtrace_on_error_report`, you can set #' `rlang_backtrace_on_warning_report` inside RMarkdown documents to #' tweak the display of warnings. This is useful in conjunction with #' [global_entrace()]. Because of technical limitations, there is #' currently no corresponding `rlang_backtrace_on_warning` option for #' normal R sessions. #' #' To get full entracing in an Rmd document, include this in a setup #' chunk before the first error or warning is signalled. #' #' ```` #' ```{r setup} #' rlang::global_entrace() #' options(rlang_backtrace_on_warning_report = "full") #' options(rlang_backtrace_on_error_report = "full") #' ``` #' ```` #' #' #' @name rlang_backtrace_on_error #' @seealso rlang_backtrace_on_warning #' @aliases add_backtrace rlang_backtrace_on_error_report #' rlang_backtrace_on_warning_report #' #' @examples #' # Display a simplified backtrace on error for both base and rlang #' # errors: #' #' # options( #' # rlang_backtrace_on_error = "branch", #' # error = rlang::entrace #' # ) #' # stop("foo") NULL backtrace_on_error_opts <- c("none", "reminder", "branch", "full") # Whenever the backtrace-on-error format is changed, the version in # `inst/backtrace-ver` and in `tests/testthat/helper-rlang.R` must be # bumped. This way `devtools::test()` will skip the tests that require # the dev version to be installed locally. format_onerror_backtrace <- function(cnd, opt = peek_backtrace_on_error()) { opt <- arg_match0(opt, backtrace_on_error_opts, "backtrace_on_error") if (opt == "none") { return(NULL) } trace <- cnd$trace # Show backtrace of oldest parent while (is_condition(cnd$parent)) { cnd <- cnd$parent if (!is_null(cnd$trace)) { trace <- cnd$trace } } if (is_null(trace) || !trace_length(trace)) { return(NULL) } # Should come after trace length check so that we don't display a # reminder when there is no trace to display if (opt == "reminder") { if (is_interactive()) { last_error <- style_rlang_run("last_trace()") reminder <- col_silver(paste0("Run `", last_error, "` to see where the error occurred.")) } else { reminder <- NULL } return(reminder) } if (opt == "branch") { max_frames <- 10L } else { max_frames <- NULL } simplify <- switch( opt, full = "none", reminder = "branch", # Check size of backtrace branch opt ) paste_line( "Backtrace:", format(trace, simplify = simplify, max_frames = max_frames) ) } peek_backtrace_on_error <- function() { opt <- peek_backtrace_on_error_opt("rlang_backtrace_on_error") if (!is_null(opt)) { return(opt) } if (is_interactive()) { "reminder" } else { "full" } } # By default, we display no reminder or backtrace for errors captured # by knitr peek_backtrace_on_error_report <- function() { peek_backtrace_on_error_opt("rlang_backtrace_on_error_report") %||% "none" } peek_backtrace_on_warning_report <- function() { opt <- peek_backtrace_on_error_opt("rlang_backtrace_on_warning_report") %||% "none" if (is_string(opt, "reminder")) { options(rlang_backtrace_on_warning_report = "none") warn(c( "`rlang_backtrace_on_warning_report` must be one of `c(\"none\", \"branch\", \"full\")`.", i = "The option was reset to \"none\"." )) opt <- "none" } opt } peek_backtrace_on_error_opt <- function(name) { opt <- peek_option(name) if (!is_null(opt)) { if (is_string(opt, "collapse")) { options(list2("{name}" := "none")) deprecate_collapse() return("none") } if (!is_string(opt, backtrace_on_error_opts)) { options(list2("{name}" := NULL)) warn(c( sprintf("Invalid %s option.", format_arg(name)), i = "The option was just reset to `NULL`." )) return(NULL) } } opt } rlang/R/arg.R0000644000176200001440000003257414376112150012465 0ustar liggesusers#' Match an argument to a character vector #' #' @description #' #' This is equivalent to [base::match.arg()] with a few differences: #' #' * Partial matches trigger an error. #' #' * Error messages are a bit more informative and obey the tidyverse #' standards. #' #' `arg_match()` derives the possible values from the #' [caller function][caller_fn]. #' #' @param arg A symbol referring to an argument accepting strings. #' @param values A character vector of possible values that `arg` can take. #' @param ... These dots are for future extensions and must be empty. #' @param multiple Whether `arg` may contain zero or several values. #' @inheritParams args_error_context #' @return The string supplied to `arg`. #' @importFrom utils adist #' @seealso [check_required()] #' @export #' @examples #' fn <- function(x = c("foo", "bar")) arg_match(x) #' fn("bar") #' #' # Throws an informative error for mismatches: #' try(fn("b")) #' try(fn("baz")) arg_match <- function(arg, values = NULL, ..., multiple = FALSE, error_arg = caller_arg(arg), error_call = caller_env()) { check_dots_empty0(...) arg_expr <- enexpr(arg) error_arg <- as_string(error_arg) check_symbol(arg_expr, arg = "arg") check_character(arg, arg = error_arg, call = error_call) if (is_null(values)) { fn <- caller_fn() values <- formals(fn)[[error_arg]] values <- eval_bare(values, get_env(fn)) } if (multiple) { return(arg_match_multi(arg, values, error_arg, error_call)) } if (!length(arg)) { msg <- sprintf( "%s must be length 1, not length 0", format_arg(error_arg) ) abort(msg, call = error_call, arg = error_arg) } if (length(arg) > 1 && !setequal(arg, values)) { msg <- arg_match_invalid_msg(arg, values, error_arg) abort(msg, call = error_call, arg = error_arg) } arg <- arg[[1]] arg_match0( arg, values, error_arg, error_call = error_call ) } arg_match_multi <- function(arg, values, error_arg, error_call) { map_chr(arg, ~ arg_match0(.x, values, error_arg, error_call = error_call)) } #' @description #' `arg_match0()` is a bare-bones version if performance is at a premium. #' It requires a string as `arg` and explicit character `values`. #' For convenience, `arg` may also be a character vector containing #' every element of `values`, possibly permuted. #' In this case, the first element of `arg` is used. #' #' @rdname arg_match #' @param arg_nm Same as `error_arg`. #' @export #' @examples #' #' # Use the bare-bones version with explicit values for speed: #' arg_match0("bar", c("foo", "bar", "baz")) #' #' # For convenience: #' fn1 <- function(x = c("bar", "baz", "foo")) fn3(x) #' fn2 <- function(x = c("baz", "bar", "foo")) fn3(x) #' fn3 <- function(x) arg_match0(x, c("foo", "bar", "baz")) #' fn1() #' fn2("bar") #' try(fn3("zoo")) arg_match0 <- function(arg, values, arg_nm = caller_arg(arg), error_call = caller_env()) { .External(ffi_arg_match0, arg, values, environment()) } chr_interpolate <- function(x) { paste0(deparse(x), collapse = "") } stop_arg_match <- function(arg, values, error_arg, error_call) { if (length(arg) > 1) { sorted_arg <- sort(unique(arg)) sorted_values <- sort(unique(values)) if (!identical(sorted_arg, sorted_values)) { msg <- sprintf( "%s must be length 1 or a permutation of %s.", format_arg("arg"), format_code(chr_interpolate(values)) ) abort(msg, call = error_call, arg = "arg") } } if (is_na(arg)) { check_string(arg, arg = error_arg, call = error_call) } msg <- arg_match_invalid_msg(arg, values, error_arg) # Try suggest the most probable and helpful candidate value candidate <- NULL i_partial <- pmatch(arg, values) if (!is_na(i_partial)) { candidate <- values[[i_partial]] } i_close <- adist(arg, values) / nchar(values) if (any(i_close <= 0.5)) { candidate <- values[[which.min(i_close)]] } if (is_null(candidate)) { # Make case-insensitive match only after failed case-sensitive one to be # more helpful in certain edge cases. For example, # `arg_match0("aa", c("AA", "aA"))`: here "aA" is the closest candidate. i_close_nocase <- adist(arg, values, ignore.case = TRUE) / nchar(values) if (any(i_close_nocase <= 0.5)) { candidate <- values[[which.min(i_close_nocase)]] } } if (!is_null(candidate)) { candidate <- chr_quoted(candidate, "\"") msg <- c(msg, i = paste0("Did you mean ", candidate, "?")) } abort(msg, call = error_call, arg = error_arg) } arg_match_invalid_msg <- function(val, values, error_arg) { msg <- paste0(format_arg(error_arg), " must be one of ") msg <- paste0(msg, oxford_comma(chr_quoted(values, "\""))) if (is_null(val)) { msg <- paste0(msg, ".") } else { msg <- paste0(msg, sprintf(', not "%s\".', val[[1]])) } msg } #' Check that argument is supplied #' #' Throws an error if `x` is missing. #' #' @param x A function argument. Must be a symbol. #' @inheritParams args_error_context #' #' @seealso [arg_match()] #' @examples #' f <- function(x) { #' check_required(x) #' } #' #' # Fails because `x` is not supplied #' try(f()) #' #' # Succeeds #' f(NULL) #' @export check_required <- function(x, arg = caller_arg(x), call = caller_env()) { if (!missing(x)) { return(invisible(TRUE)) } arg_expr <- substitute(x) if (!is_symbol(arg_expr)) { abort(sprintf("%s must be an argument name.", format_arg("x"))) } msg <- sprintf("%s is absent but must be supplied.", format_arg(arg)) abort(msg, call = call) } chr_quoted <- function(chr, type = "`") { paste0(type, chr, type) } #' Check that arguments are mutually exclusive #' #' `check_exclusive()` checks that only one argument is supplied out of #' a set of mutually exclusive arguments. An informative error is #' thrown if multiple arguments are supplied. #' #' @param ... Function arguments. #' @param .require Whether at least one argument must be supplied. #' @param .frame Environment where the arguments in `...` are defined. #' @inheritParams args_error_context #' @return The supplied argument name as a string. If `.require` is #' `FALSE` and no argument is supplied, the empty string `""` is #' returned. #' #' @examples #' f <- function(x, y) { #' switch( #' check_exclusive(x, y), #' x = message("`x` was supplied."), #' y = message("`y` was supplied.") #' ) #' } #' #' # Supplying zero or multiple arguments is forbidden #' try(f()) #' try(f(NULL, NULL)) #' #' # The user must supply one of the mutually exclusive arguments #' f(NULL) #' f(y = NULL) #' #' #' # With `.require` you can allow zero arguments #' f <- function(x, y) { #' switch( #' check_exclusive(x, y, .require = FALSE), #' x = message("`x` was supplied."), #' y = message("`y` was supplied."), #' message("No arguments were supplied") #' ) #' } #' f() #' @export check_exclusive <- function(..., .require = TRUE, .frame = caller_env(), .call = .frame) { args <- enexprs(..., .named = TRUE) if (length(args) < 2) { abort("Must supply at least two arguments.") } if (!every(args, is_symbol)) { abort("`...` must be function arguments.") } present <- map_lgl(args, ~ inject(!base::missing(!!.x), .frame)) n_present <- sum(present) if (n_present == 0) { if (.require) { args <- map(names(args), format_arg) enum <- oxford_comma(args) msg <- sprintf("One of %s must be supplied.", enum) abort(msg, call = .call) } else { return("") } } if (n_present == 1) { return(as_string(args[[which(present)]])) } args <- map_chr(names(args), format_arg) enum <- oxford_comma(args) msg <- sprintf("Exactly one of %s must be supplied.", enum) if (n_present != length(args)) { enum <- oxford_comma(args[present], final = "and") msg <- c(msg, x = sprintf("%s were supplied together.", enum)) } abort(msg, call = .call) } #' Generate or handle a missing argument #' #' @description #' #' These functions help using the missing argument as a regular R #' object. #' #' * `missing_arg()` generates a missing argument. #' #' * `is_missing()` is like [base::missing()] but also supports #' testing for missing arguments contained in other objects like #' lists. It is also more consistent with default arguments which #' are never treated as missing (see section below). #' #' * `maybe_missing()` is useful to pass down an input that might be #' missing to another function, potentially substituting by a #' default value. It avoids triggering an "argument is missing" error. #' #' #' @section Other ways to reify the missing argument: #' #' * `base::quote(expr = )` is the canonical way to create a missing #' argument object. #' #' * `expr()` called without argument creates a missing argument. #' #' * `quo()` called without argument creates an empty quosure, i.e. a #' quosure containing the missing argument object. #' #' #' @section `is_missing()` and default arguments: #' #' The base function [missing()] makes a distinction between default #' values supplied explicitly and default values generated through a #' missing argument: #' #' ```{r} #' fn <- function(x = 1) base::missing(x) #' #' fn() #' fn(1) #' ``` #' #' This only happens within a function. If the default value has been #' generated in a calling function, it is never treated as missing: #' #' ```{r} #' caller <- function(x = 1) fn(x) #' caller() #' ``` #' #' `rlang::is_missing()` simplifies these rules by never treating #' default arguments as missing, even in internal contexts: #' #' ```{r} #' fn <- function(x = 1) rlang::is_missing(x) #' #' fn() #' fn(1) #' ``` #' #' This is a little less flexible because you can't specialise #' behaviour based on implicitly supplied default values. However, #' this makes the behaviour of `is_missing()` and functions using it #' simpler to understand. #' #' #' @section Fragility of the missing argument object: #' #' The missing argument is an object that triggers an error if and #' only if it is the result of evaluating a symbol. No error is #' produced when a function call evaluates to the missing argument #' object. For instance, it is possible to bind the missing argument #' to a variable with an expression like `x[[1]] <- missing_arg()`. #' Likewise, `x[[1]]` is safe to use as argument, e.g. `list(x[[1]])` #' even when the result is the missing object. #' #' However, as soon as the missing argument is passed down between #' functions through a bare variable, it is likely to cause a missing #' argument error: #' #' ```r #' x <- missing_arg() #' list(x) #' #> Error: #' #> ! argument "x" is missing, with no default #' ``` #' #' To work around this, `is_missing()` and `maybe_missing(x)` use a #' bit of magic to determine if the input is the missing argument #' without triggering a missing error. #' #' ```r #' x <- missing_arg() #' list(maybe_missing(x)) #' #> [[1]] #' #> #' ``` #' #' `maybe_missing()` is particularly useful for prototyping #' meta-programming algorithms in R. The missing argument is a likely #' input when computing on the language because it is a standard #' object in formals lists. While C functions are always allowed to #' return the missing argument and pass it to other C functions, this #' is not the case on the R side. If you're implementing your #' meta-programming algorithm in R, use `maybe_missing()` when an #' input might be the missing argument object. #' #' @param x An object that might be the missing argument. #' @export #' @examples #' # The missing argument usually arises inside a function when the #' # user omits an argument that does not have a default: #' fn <- function(x) is_missing(x) #' fn() #' #' # Creating a missing argument can also be useful to generate calls #' args <- list(1, missing_arg(), 3, missing_arg()) #' quo(fn(!!! args)) #' #' # Other ways to create that object include: #' quote(expr = ) #' expr() #' #' # It is perfectly valid to generate and assign the missing #' # argument in a list. #' x <- missing_arg() #' l <- list(missing_arg()) #' #' # Just don't evaluate a symbol that contains the empty argument. #' # Evaluating the object `x` that we created above would trigger an #' # error. #' # x # Not run #' #' # On the other hand accessing a missing argument contained in a #' # list does not trigger an error because subsetting is a function #' # call: #' l[[1]] #' is.null(l[[1]]) #' #' # In case you really need to access a symbol that might contain the #' # empty argument object, use maybe_missing(): #' maybe_missing(x) #' is.null(maybe_missing(x)) #' is_missing(maybe_missing(x)) #' #' #' # Note that base::missing() only works on symbols and does not #' # support complex expressions. For this reason the following lines #' # would throw an error: #' #' #> missing(missing_arg()) #' #> missing(l[[1]]) #' #' # while is_missing() will work as expected: #' is_missing(missing_arg()) #' is_missing(l[[1]]) missing_arg <- function() { .Call(ffi_missing_arg) } #' @rdname missing_arg #' @export is_missing <- function(x) { missing(x) || identical(x, quote(expr = )) } #' @rdname missing_arg #' @param default The object to return if the input is missing, #' defaults to `missing_arg()`. #' @export maybe_missing <- function(x, default = missing_arg()) { if (is_missing(x)) { default } else { x } } rlang/R/vec-new.R0000644000176200001440000001232414375670676013274 0ustar liggesusers#' Create vectors #' #' @description #' #' `r lifecycle::badge("questioning")` #' #' The atomic vector constructors are equivalent to [c()] but: #' #' * They allow you to be more explicit about the output #' type. Implicit coercions (e.g. from integer to logical) follow #' the rules described in [vector-coercion]. #' #' * They use [dynamic dots][dyn-dots]. #' #' #' @section Life cycle: #' #' * All the abbreviated constructors such as `lgl()` will probably be #' moved to the vctrs package at some point. This is why they are #' marked as questioning. #' #' * Automatic splicing is soft-deprecated and will trigger a warning #' in a future version. Please splice explicitly with `!!!`. #' #' @param ... Components of the new vector. Bare lists and explicitly #' spliced lists are spliced. #' @name vector-construction #' @examples #' # These constructors are like a typed version of c(): #' c(TRUE, FALSE) #' lgl(TRUE, FALSE) #' #' # They follow a restricted set of coercion rules: #' int(TRUE, FALSE, 20) #' #' # Lists can be spliced: #' dbl(10, !!! list(1, 2L), TRUE) #' #' #' # They splice names a bit differently than c(). The latter #' # automatically composes inner and outer names: #' c(a = c(A = 10), b = c(B = 20, C = 30)) #' #' # On the other hand, rlang's constructors use the inner names and issue a #' # warning to inform the user that the outer names are ignored: #' dbl(a = c(A = 10), b = c(B = 20, C = 30)) #' dbl(a = c(1, 2)) #' #' # As an exception, it is allowed to provide an outer name when the #' # inner vector is an unnamed scalar atomic: #' dbl(a = 1) #' #' # Spliced lists behave the same way: #' dbl(!!! list(a = 1)) #' dbl(!!! list(a = c(A = 1))) NULL #' @rdname vector-construction #' @export lgl <- function(...) { .Call(ffi_squash, dots_values(...), "logical", is_spliced_bare, 1L) } #' @rdname vector-construction #' @export int <- function(...) { .Call(ffi_squash, dots_values(...), "integer", is_spliced_bare, 1L) } #' @rdname vector-construction #' @export dbl <- function(...) { .Call(ffi_squash, dots_values(...), "double", is_spliced_bare, 1L) } #' @rdname vector-construction #' @export cpl <- function(...) { .Call(ffi_squash, dots_values(...), "complex", is_spliced_bare, 1L) } #' @rdname vector-construction #' @export #' @export chr <- function(...) { .Call(ffi_squash, dots_values(...), "character", is_spliced_bare, 1L) } #' @rdname vector-construction #' @export #' @examples #' #' # bytes() accepts integerish inputs #' bytes(1:10) #' bytes(0x01, 0xff, c(0x03, 0x05), list(10, 20, 30L)) bytes <- function(...) { dots <- map(dots_values(...), function(dot) { if (is_bare_list(dot) || is_spliced(dot)) { map(dot, cast_raw) } else { cast_raw(dot) } }) .Call(ffi_squash, dots, "raw", is_spliced_bare, 1L) } #' Create vectors matching a given length #' #' @description #' #' `r lifecycle::badge("questioning")` #' #' These functions construct vectors of a given length, with attributes #' specified via dots. Except for `new_list()` and `new_raw()`, the #' empty vectors are filled with typed [missing] values. This is in #' contrast to the base function [base::vector()] which creates #' zero-filled vectors. #' #' @param n The vector length. #' @param names Names for the new vector. #' #' @section Lifecycle: #' #' These functions are likely to be replaced by a vctrs equivalent in #' the future. They are in the questioning lifecycle stage. #' #' @keywords internal #' @examples #' new_list(10) #' new_logical(10) #' @name new-vector #' @seealso rep_along NULL #' @rdname new-vector #' @export new_logical <- function(n, names = NULL) { set_names(rep_len(na_lgl, n), names) } #' @rdname new-vector #' @export new_integer <- function(n, names = NULL) { set_names(rep_len(na_int, n), names) } #' @rdname new-vector #' @export new_double <- function(n, names = NULL) { set_names(rep_len(na_dbl, n), names) } #' @rdname new-vector #' @export new_character <- function(n, names = NULL) { set_names(rep_len(na_chr, n), names) } #' @rdname new-vector #' @export new_complex <- function(n, names = NULL) { set_names(rep_len(na_cpl, n), names) } #' @rdname new-vector #' @export new_raw <- function(n, names = NULL) { set_names(vector("raw", n), names) } #' @rdname new-vector #' @export new_list <- function(n, names = NULL) { set_names(vector("list", n), names) } #' Create vectors matching the length of a given vector #' #' These functions take the idea of [seq_along()] and apply it to #' repeating values. #' #' @param x Values to repeat. #' @param along Vector whose length determine how many times `x` #' is repeated. #' @param names Names for the new vector. The length of `names` #' determines how many times `x` is repeated. #' #' @seealso new-vector #' @export #' @examples #' x <- 0:5 #' rep_along(x, 1:2) #' rep_along(x, 1) #' #' # Create fresh vectors by repeating missing values: #' rep_along(x, na_int) #' rep_along(x, na_chr) #' #' # rep_named() repeats a value along a names vectors #' rep_named(c("foo", "bar"), list(letters)) rep_along <- function(along, x) { rep_len(x, length(along)) } #' @export #' @rdname rep_along rep_named <- function(names, x) { names <- names %||% chr() check_character(names, what = "`NULL` or a character vector") set_names(rep_len(x, length(names)), names) } rlang/R/lifecycle-deprecated.R0000644000176200001440000010324014741441060015737 0ustar liggesusers# rlang 0.2.0: 2018-02 # rlang 0.3.0: 2018-10 # rlang 0.4.0: 2019-06 # rlang 0.4.2: 2019-11 # rlang 1.0.0: 2022-01 # rlang 1.1.0: 2023-02 # Deprecated in rlang 1.1.0 # rlang 1.1.0: silent deprecation. #' Create a child environment #' #' @description #' `r lifecycle::badge("deprecated")` #' #' [env()] now supports creating child environments, please use it #' instead. #' #' @keywords internal #' @export child_env <- function(.parent, ...) { env <- new.env(parent = as_environment(.parent)) env_bind0(env, list2(...)) env } # rlang 1.1.0: soft-deprecation #' Flatten or squash a list of lists into a simpler vector #' #' @description #' `r lifecycle::badge("deprecated")` #' #' These functions are deprecated in favour of `purrr::list_c()` and #' `purrr::list_flatten()`. #' #' `flatten()` removes one level hierarchy from a list, while #' `squash()` removes all levels. These functions are similar to #' [unlist()] but they are type-stable so you always know what the #' type of the output is. #' #' @param x A list to flatten or squash. The contents of the list can #' be anything for unsuffixed functions `flatten()` and `squash()` #' (as a list is returned), but the contents must match the type for #' the other functions. #' @return `flatten()` returns a list, `flatten_lgl()` a logical #' vector, `flatten_int()` an integer vector, `flatten_dbl()` a #' double vector, and `flatten_chr()` a character vector. Similarly #' for `squash()` and the typed variants (`squash_lgl()` etc). #' @export #' @keywords internal #' @examples #' x <- replicate(2, sample(4), simplify = FALSE) #' x #' #' flatten(x) #' flatten_int(x) #' #' # With flatten(), only one level gets removed at a time: #' deep <- list(1, list(2, list(3))) #' flatten(deep) #' flatten(flatten(deep)) #' #' # But squash() removes all levels: #' squash(deep) #' squash_dbl(deep) #' #' # The typed flatten functions remove one level and coerce to an atomic #' # vector at the same time: #' flatten_dbl(list(1, list(2))) #' #' # Only bare lists are flattened, but you can splice S3 lists #' # explicitly: #' foo <- set_attrs(list("bar"), class = "foo") #' str(flatten(list(1, foo, list(100)))) #' str(flatten(list(1, splice(foo), list(100)))) #' #' # Instead of splicing manually, flatten_if() and squash_if() let #' # you specify a predicate function: #' is_foo <- function(x) inherits(x, "foo") || is_bare_list(x) #' str(flatten_if(list(1, foo, list(100)), is_foo)) #' #' # squash_if() does the same with deep lists: #' deep_foo <- list(1, list(foo, list(foo, 100))) #' str(deep_foo) #' #' str(squash(deep_foo)) #' str(squash_if(deep_foo, is_foo)) flatten <- function(x) { deprecate_soft(c( "`flatten()` is deprecated as of rlang 1.1.0.", "i" = "Please use `purrr::list_flatten()` or `purrr::list_c()`." )) .Call(ffi_squash, x, "list", is_spliced_bare, 1L) } # rlang 1.1.0: Soft deprecation. #' @rdname flatten #' @export flatten_lgl <- function(x) { deprecate_soft(c( "`flatten_lgl()` is deprecated as of rlang 1.1.0.", "i" = "Please use `purrr::list_flatten()` and/or `purrr::list_c()`." )) .Call(ffi_squash, x, "logical", is_spliced_bare, 1L) } #' @rdname flatten #' @export flatten_int <- function(x) { deprecate_soft(c( "`flatten_int()` is deprecated as of rlang 1.1.0.", "i" = "Please use `purrr::list_flatten()` and/or `purrr::list_c()`." )) .Call(ffi_squash, x, "integer", is_spliced_bare, 1L) } #' @rdname flatten #' @export flatten_dbl <- function(x) { deprecate_soft(c( "`flatten_dbl()` is deprecated as of rlang 1.1.0.", "i" = "Please use `purrr::list_flatten()` and/or `purrr::list_c()`." )) .Call(ffi_squash, x, "double", is_spliced_bare, 1L) } #' @rdname flatten #' @export flatten_cpl <- function(x) { deprecate_soft(c( "`flatten_cpl()` is deprecated as of rlang 1.1.0.", "i" = "Please use `purrr::list_flatten()` and/or `purrr::list_c()`." )) .Call(ffi_squash, x, "complex", is_spliced_bare, 1L) } #' @rdname flatten #' @export flatten_chr <- function(x) { deprecate_soft(c( "`flatten_chr()` is deprecated as of rlang 1.1.0.", "i" = "Please use `purrr::list_flatten()` and/or `purrr::list_c()`." )) .Call(ffi_squash, x, "character", is_spliced_bare, 1L) } #' @rdname flatten #' @export flatten_raw <- function(x) { deprecate_soft(c( "`flatten_raw()` is deprecated as of rlang 1.1.0.", "i" = "Please use `purrr::list_flatten()` and/or `purrr::list_c()`." )) .Call(ffi_squash, x, "raw", is_spliced_bare, 1L) } #' @rdname flatten #' @export squash <- function(x) { deprecate_soft("`squash()` is deprecated as of rlang 1.1.0.") .Call(ffi_squash, x, "list", is_spliced_bare, -1L) } #' @rdname flatten #' @export squash_lgl <- function(x) { deprecate_soft("`squash_lgl()` is deprecated as of rlang 1.1.0.") .Call(ffi_squash, x, "logical", is_spliced_bare, -1L) } #' @rdname flatten #' @export squash_int <- function(x) { deprecate_soft("`squash_int()` is deprecated as of rlang 1.1.0.") .Call(ffi_squash, x, "integer", is_spliced_bare, -1L) } #' @rdname flatten #' @export squash_dbl <- function(x) { deprecate_soft("`squash_dbl()` is deprecated as of rlang 1.1.0.") .Call(ffi_squash, x, "double", is_spliced_bare, -1L) } #' @rdname flatten #' @export squash_cpl <- function(x) { deprecate_soft("`squash_cpl()` is deprecated as of rlang 1.1.0.") .Call(ffi_squash, x, "complex", is_spliced_bare, -1L) } #' @rdname flatten #' @export squash_chr <- function(x) { deprecate_soft("`squash_chr()` is deprecated as of rlang 1.1.0.") .Call(ffi_squash, x, "character", is_spliced_bare, -1L) } #' @rdname flatten #' @export squash_raw <- function(x) { deprecate_soft("`squash_raw()` is deprecated as of rlang 1.1.0.") .Call(ffi_squash, x, "raw", is_spliced_bare, -1L) } #' @rdname flatten #' @param predicate A function of one argument returning whether it #' should be spliced. #' @export flatten_if <- function(x, predicate = is_spliced) { deprecate_soft("`flatten_if()` is deprecated as of rlang 1.1.0.") .Call(ffi_squash, x, "list", predicate, 1L) } #' @rdname flatten #' @export squash_if <- function(x, predicate = is_spliced) { deprecate_soft("`squash_if()` is deprecated as of rlang 1.1.0.") .Call(ffi_squash, x, "list", predicate, -1L) } #' Splice lists #' #' @description #' `r lifecycle::badge("deprecated")` #' #' `dots_splice()` is like [dots_list()] but automatically splices #' list inputs. #' #' @inheritParams dots_list #' @keywords internal #' @export dots_splice <- function(..., .ignore_empty = c("trailing", "none", "all"), .preserve_empty = FALSE, .homonyms = c("keep", "first", "last", "error"), .check_assign = FALSE) { deprecate_soft("`dots_splice()` is deprecated as of rlang 1.1.0.") dots <- .Call( ffi_dots_flat_list, frame_env = environment(), named = NULL, ignore_empty = .ignore_empty, preserve_empty = .preserve_empty, unquote_names = TRUE, homonyms = .homonyms, check_assign = .check_assign ) names(dots) <- names2(dots) dots } # Deprecated in rlang 1.0.0 # Silently deprecated for now # - `with_env()` is used in dplyr (unit test) and purrr. # - `locally()` is used in carrier #' Evaluate an expression within a given environment #' #' @description #' `r lifecycle::badge("deprecated")` #' #' These functions evaluate `expr` within a given environment (`env` #' for `with_env()`, or the child of the current environment for #' `locally`). They rely on [eval_bare()] which features a lighter #' evaluation mechanism than base R [base::eval()], and which also has #' some subtle implications when evaluting stack sensitive functions #' (see help for [eval_bare()]). #' #' `locally()` is equivalent to the base function #' [base::local()] but it produces a much cleaner #' evaluation stack, and has stack-consistent semantics. It is thus #' more suited for experimenting with the R language. #' #' @inheritParams eval_bare #' @param env An environment within which to evaluate `expr`. Can be #' an object with a [get_env()] method. #' @keywords internal #' @export #' @examples #' # with_env() is handy to create formulas with a given environment: #' env <- child_env("rlang") #' f <- with_env(env, ~new_formula()) #' identical(f_env(f), env) #' #' # Or functions with a given enclosure: #' fn <- with_env(env, function() NULL) #' identical(get_env(fn), env) #' #' #' # Unlike eval() it doesn't create duplicates on the evaluation #' # stack. You can thus use it e.g. to create non-local returns: #' fn <- function() { #' g(current_env()) #' "normal return" #' } #' g <- function(env) { #' with_env(env, return("early return")) #' } #' fn() #' #' #' # Since env is passed to as_environment(), it can be any object with an #' # as_environment() method. For strings, the pkg_env() is returned: #' with_env("base", ~mtcars) #' #' # This can be handy to put dictionaries in scope: #' with_env(mtcars, cyl) with_env <- function(env, expr) { .External2(ffi_eval, substitute(expr), as_environment(env, caller_env())) } #' @rdname with_env #' @export locally <- function(expr) { .External2(ffi_eval, substitute(expr), child_env(caller_env())) } # Soft-deprecated in rlang 0.4.0 ## Types #' Base type of an object #' #' @description #' #' `r lifecycle::badge("soft-deprecated")` #' `r lifecycle::badge("experimental")` #' #' This is equivalent to [base::typeof()] with a few differences that #' make dispatching easier: #' * The type of one-sided formulas is "quote". #' * The type of character vectors of length 1 is "string". #' * The type of special and builtin functions is "primitive". #' #' @param x An R object. #' @export #' @keywords internal #' @examples #' type_of(10L) #' #' # Quosures are treated as a new base type but not formulas: #' type_of(quo(10L)) #' type_of(~10L) #' #' # Compare to base::typeof(): #' typeof(quo(10L)) #' #' # Strings are treated as a new base type: #' type_of(letters) #' type_of(letters[[1]]) #' #' # This is a bit inconsistent with the core language tenet that data #' # types are vectors. However, treating strings as a different #' # scalar type is quite helpful for switching on function inputs #' # since so many arguments expect strings: #' switch_type("foo", character = abort("vector!"), string = "result") #' #' # Special and builtin primitives are both treated as primitives. #' # That's because it is often irrelevant which type of primitive an #' # input is: #' typeof(list) #' typeof(`$`) #' type_of(list) #' type_of(`$`) type_of <- function(x) { deprecate_warn(c( "`type_of()` is deprecated as of rlang 0.4.0.", "Please use `typeof()` or your own version instead." )) type_of_(x) } #' Dispatch on base types #' #' @description #' #' `r lifecycle::badge("soft-deprecated")` #' `r lifecycle::badge("experimental")` #' #' `switch_type()` is equivalent to #' \code{\link[base]{switch}(\link{type_of}(x, ...))}, while #' `switch_class()` switchpatches based on `class(x)`. The `coerce_` #' versions are intended for type conversion and provide a standard #' error message when conversion fails. #' #' #' @param .x An object from which to dispatch. #' @param ... Named clauses. The names should be types as returned by #' [type_of()]. #' @param .to This is useful when you switchpatch within a coercing #' function. If supplied, this should be a string indicating the #' target type. A catch-all clause is then added to signal an error #' stating the conversion failure. This type is prettified unless #' `.to` inherits from the S3 class `"AsIs"` (see [base::I()]). #' @export #' @keywords internal #' @examples #' switch_type(3L, #' double = "foo", #' integer = "bar", #' "default" #' ) #' #' # Use the coerce_ version to get standardised error handling when no #' # type matches: #' to_chr <- function(x) { #' coerce_type(x, "a chr", #' integer = as.character(x), #' double = as.character(x) #' ) #' } #' to_chr(3L) #' #' # Strings have their own type: #' switch_type("str", #' character = "foo", #' string = "bar", #' "default" #' ) #' #' # Use a fallthrough clause if you need to dispatch on all character #' # vectors, including strings: #' switch_type("str", #' string = , #' character = "foo", #' "default" #' ) #' #' # special and builtin functions are treated as primitive, since #' # there is usually no reason to treat them differently: #' switch_type(base::list, #' primitive = "foo", #' "default" #' ) #' switch_type(base::`$`, #' primitive = "foo", #' "default" #' ) #' #' # closures are not primitives: #' switch_type(rlang::switch_type, #' primitive = "foo", #' "default" #' ) switch_type <- function(.x, ...) { deprecate_warn(c( "`switch_type()` is soft-deprecated as of rlang 0.4.0.", "Please use `switch(typeof())` or `switch(my_typeof())` instead." )) switch(type_of_(.x), ...) } #' @rdname switch_type #' @export coerce_type <- function(.x, .to, ...) { deprecate_warn("`coerce_type()` is soft-deprecated as of rlang 0.4.0.") switch(type_of_(.x), ..., abort_coercion(.x, .to)) } #' @rdname switch_type #' @export switch_class <- function(.x, ...) { deprecate_warn("`switch_class()` is soft-deprecated as of rlang 0.4.0.") switch(class(.x), ...) } #' @rdname switch_type #' @export coerce_class <- function(.x, .to, ...) { deprecate_warn("`coerce_class()` is soft-deprecated as of rlang 0.4.0.") switch(class(.x), ..., abort_coercion(.x, .to)) } #' Format a type for error messages #' #' @description #' `r lifecycle::badge("deprecated")` #' #' `friendly_type()` is deprecated. Please use the #' `standalone-friendly-type.R` file instead. #' #' @param type A type as returned by [typeof()]. #' @return A string of the prettified type, qualified with an #' indefinite article. #' @export #' @keywords internal friendly_type <- function(type) { deprecate_warn("`friendly_type()` is deprecated as of rlang 0.4.11.") type } # rlang 0.4.0: Soft-deprecation # rlang 1.1.0: Deprecation ## Eval #' Invoke a function with a list of arguments #' #' @description #' `r lifecycle::badge("deprecated")` #' Deprecated in rlang 0.4.0 in favour of [exec()]. #' #' @param .fn,args,...,.env,.bury `r lifecycle::badge("deprecated")` #' @export #' @keywords internal invoke <- function(.fn, .args = list(), ..., .env = caller_env(), .bury = c(".fn", "")) { # rlang 0.4.0: Soft-deprecation # rlang 1.0.0: Deprecation deprecate_warn(c( "`invoke()` is deprecated as of rlang 0.4.0.", "Please use `exec()` or `inject()` instead." )) args <- c(.args, list(...)) if (is_null(.bury) || !length(args)) { if (is_scalar_character(.fn)) { .fn <- env_get(.env, .fn, inherit = TRUE) } call <- call2(.fn, !!! args) return(.External2(ffi_eval, call, .env)) } if (!is_character(.bury, 2L)) { abort("`.bury` must be a character vector of length 2") } arg_prefix <- .bury[[2]] fn_nm <- .bury[[1]] buried_nms <- paste0(arg_prefix, seq_along(args)) buried_args <- set_names(args, buried_nms) .env <- env_bury(.env, !!! buried_args) args <- set_names(buried_nms, names(args)) args <- syms(args) if (is_function(.fn)) { env_bind(.env, !! fn_nm := .fn) .fn <- fn_nm } call <- call2(.fn, !!! args) .External2(ffi_eval, call, .env) } ## Casting #' Coerce an object to a base type #' #' @description #' #' `r lifecycle::badge("deprecated")` #' #' These are equivalent to the base functions (e.g. [as.logical()], #' [as.list()], etc), but perform coercion rather than conversion. #' This means they are not generic and will not call S3 conversion #' methods. They only attempt to coerce the base type of their #' input. In addition, they have stricter implicit coercion rules and #' will never attempt any kind of parsing. E.g. they will not try to #' figure out if a character vector represents integers or booleans. #' Finally, they treat attributes consistently, unlike the base R #' functions: all attributes except names are removed. #' #' #' @section Lifecycle: #' #' These functions are deprecated in favour of `vctrs::vec_cast()`. #' #' #' @section Coercion to logical and numeric atomic vectors: #' #' * To logical vectors: Integer and integerish double vectors. See #' [is_integerish()]. #' * To integer vectors: Logical and integerish double vectors. #' * To double vectors: Logical and integer vectors. #' * To complex vectors: Logical, integer and double vectors. #' #' #' @section Coercion to character vectors: #' #' `as_character()` and `as_string()` have an optional `encoding` #' argument to specify the encoding. R uses this information for #' internal handling of strings and character vectors. Note that this #' is only declarative, no encoding conversion is attempted. #' #' Note that only `as_string()` can coerce symbols to a scalar #' character vector. This makes the code more explicit and adds an #' extra type check. #' #' #' @section Coercion to lists: #' #' `as_list()` only coerces vector and dictionary types (environments #' are an example of dictionary type). Unlike [base::as.list()], #' `as_list()` removes all attributes except names. #' #' #' @section Effects of removing attributes: #' #' A technical side-effect of removing the attributes of the input is #' that the underlying objects has to be copied. This has no #' performance implications in the case of lists because this is a #' shallow copy: only the list structure is copied, not the contents #' (see [duplicate()]). However, be aware that atomic vectors #' containing large amounts of data will have to be copied. #' #' In general, any attribute modification creates a copy, which is why #' it is better to avoid using attributes with heavy atomic vectors. #' Uncopyable objects like environments and symbols are an exception #' to this rule: in this case, attributes modification happens in #' place and has side-effects. #' #' @inheritParams string #' @param x An object to coerce to a base type. #' #' @keywords internal #' @examples #' # Coercing atomic vectors removes attributes with both base R and rlang: #' x <- structure(TRUE, class = "foo", bar = "baz") #' as.logical(x) #' #' # But coercing lists preserves attributes in base R but not rlang: #' l <- structure(list(TRUE), class = "foo", bar = "baz") #' as.list(l) #' as_list(l) #' #' # Implicit conversions are performed in base R but not rlang: #' as.logical(l) #' \dontrun{ #' as_logical(l) #' } #' #' # Conversion methods are bypassed, making the result of the #' # coercion more predictable: #' as.list.foo <- function(x) "wrong" #' as.list(l) #' as_list(l) #' #' # The input is never parsed. E.g. character vectors of numbers are #' # not converted to numeric types: #' as.integer("33") #' \dontrun{ #' as_integer("33") #' } #' #' #' # With base R tools there is no way to convert an environment to a #' # list without either triggering method dispatch, or changing the #' # original environment. as_list() makes it easy: #' x <- structure(as_environment(mtcars[1:2]), class = "foobar") #' as.list.foobar <- function(x) abort("dont call me") #' as_list(x) #' @name vector-coercion NULL signal_deprecated_cast <- function(fn, user_env = caller_env(2)) { deprecate_warn(user_env = user_env, c( sprintf("`%s()` is deprecated as of rlang 0.4.0", fn), "Please use `vctrs::vec_cast()` instead." )) } #' @rdname vector-coercion #' @export as_logical <- function(x) { signal_deprecated_cast("as_logical") legacy_as_logical(x) } #' @rdname vector-coercion #' @export as_integer <- function(x) { signal_deprecated_cast("as_integer") legacy_as_integer(x) } #' @rdname vector-coercion #' @export as_double <- function(x) { signal_deprecated_cast("as_double") legacy_as_double(x) } #' @rdname vector-coercion #' @export as_complex <- function(x) { signal_deprecated_cast("as_complex") legacy_as_complex(x) } #' @rdname vector-coercion #' @export as_character <- function(x, encoding = NULL) { signal_deprecated_cast("as_character") legacy_as_character(x, encoding = encoding) } #' @rdname vector-coercion #' @export as_list <- function(x) { signal_deprecated_cast("as_list") switch_type(x, environment = env_as_list(x), vec_as_list(x) ) } env_as_list <- function(x) { names_x <- names(x) x <- as_base_type(x, as.list) set_names(x, .Call(ffi_unescape_character, names_x)) } vec_as_list <- function(x) { coerce_type_vec(x, vec_type_friendly(list()), logical = , integer = , double = , string = , character = , complex = , raw = as_base_type(x, as.list), list = { attributes(x) <- NULL; x } ) } legacy_as_logical <- function(x) { coerce_type_vec(x, vec_type_friendly(lgl()), logical = { attributes(x) <- NULL; x }, integer = as_base_type(x, as.logical), double = as_integerish_type(x, as.logical, lgl()) ) } legacy_as_integer <- function(x) { coerce_type_vec(x, vec_type_friendly(int()), logical = as_base_type(x, as.integer), integer = { attributes(x) <- NULL; x }, double = as_integerish_type(x, as.integer, int(), value = FALSE) ) } legacy_as_double <- function(x) { coerce_type_vec(x, vec_type_friendly(dbl()), logical = , integer = as_base_type(x, as.double), double = { attributes(x) <- NULL; x } ) } legacy_as_complex <- function(x) { coerce_type_vec(x, vec_type_friendly(cpl()), logical = , integer = , double = as_base_type(x, as.complex), complex = { attributes(x) <- NULL; x } ) } legacy_as_character <- function(x, encoding = NULL) { if (is_unspecified(x)) { return(rep_along(x, na_chr)) } coerce_type_vec( x, vec_type_friendly(chr()), string = , character = { attributes(x) <- NULL if (!is_null(encoding)) { Encoding(x) <- encoding } x } ) } is_unspecified <- function(x) { is_logical(x) && all(map_lgl(x, identical, NA)) } as_base_type <- function(x, as_type) { # Zap attributes temporarily instead of unclassing. We want to avoid # method dispatch, but we also want to avoid an extra copy of atomic # vectors: the first when unclassing, the second when coercing. This # is also useful for uncopyable types like environments. attrs <- .Call(ffi_attrib, x) .Call(ffi_poke_attrib, x, NULL) # This function assumes that the target type is different than the # input type, otherwise no duplication is done and the output will # be modified by side effect when we restore the input attributes. on.exit(.Call(ffi_poke_attrib, x, attrs)) as_type(x) } as_integerish_type <- function(x, as_type, to, value = FALSE) { if (is_integerish(x)) { as_base_type(x, as_type) } else { abort(paste0( "Can't convert a fractional double vector to ", obj_type_friendly(to, value = value), "" )) } } coerce_type_vec <- function(.x, .to, ...) { # Cannot reuse coerce_type() because switch() has a bug with # fallthrough and multiple levels of dots forwarding. out <- switch(type_of_(.x), ..., abort_coercion(.x, .to, call = NULL)) if (!is_null(names(.x))) { # Avoid a copy of `out` when we restore the names, since it could be # a heavy atomic vector. We own `out`, so it is ok to change its # attributes inplace. .Call(ffi_poke_attrib, out, pairlist(names = names(.x))) } out } vec_coerce <- function(x, type) { .Call(ffi_vec_coerce, x, type) } # Stack and frames ------------------------------------------------- # 2022-01: https://github.com/tidyverse/purrr/issues/851 #' Call stack information #' #' @description #' `r lifecycle::badge("deprecated")` #' Deprecated as of rlang 0.3.0. #' @param n The number of frames to go back in the stack. #' @name stack-deprecated #' @keywords internal NULL #' @rdname stack-deprecated #' @export ctxt_frame <- function(n = 1) { deprecate_warn("`ctxt_frame()` is deprecated as of rlang 0.3.0.") stopifnot(n > 0) pos <- sys.nframe() - n if (pos < 0L) { stop("not that many frames on the stack", call. = FALSE) } else if (pos == 0L) { global_frame() } else { new_frame(list( pos = pos, caller_pos = sys.parent(n + 1), expr = sys.call(-n), env = sys.frame(-n), fn = sys.function(-n), fn_name = call_name(sys.call(-n)) )) } } # 2022-01: Used in `ctxt_frame()` #' @rdname stack-deprecated #' @export global_frame <- function() { deprecate_warn("`global_frame()` is deprecated as of rlang 0.3.0.") new_frame(list( pos = 0L, caller_pos = NA_integer_, expr = NULL, env = globalenv(), fn = NULL, fn_name = NULL )) } new_frame <- function(x) { structure(x, class = "frame") } # Tidy eval -------------------------------------------------------- #' Squash a quosure #' #' @description #' `r lifecycle::badge("deprecated")` #' This function is deprecated, please use [quo_squash()] instead. #' #' @inheritParams quo_squash #' @keywords internal #' @export quo_expr <- function(quo, warn = FALSE) { # 2022-01: Still used by many packages on CRAN deprecate_warn(paste_line( "`quo_expr()` is deprecated as of rlang 0.2.0.", "Please use `quo_squash()` instead." )) quo_squash(quo, warn = warn) } #' Process unquote operators in a captured expression #' #' @description #' `r lifecycle::badge("deprecated")` #' `expr_interp()` is deprecated, please use [inject()] instead. #' #' @param x,env `r lifecycle::badge("deprecated")` #' @keywords internal #' @export expr_interp <- function(x, env = NULL) { if (is_formula(x)) { f_rhs(x) <- .Call(ffi_interp, f_rhs(x), env %||% f_env(x)) } else if (is_closure(x)) { body(x) <- .Call(ffi_interp, body(x), env %||% fn_env(x)) } else { x <- .Call(ffi_interp, x, env %||% parent.frame()) } x } #' Deprecated `UQ()` and `UQS()` operators #' #' @description #' `r lifecycle::badge("deprecated")` #' These operators are deprecated in favour of #' [`!!`][injection-operator] and [`!!!`][splice-operator]. #' #' @keywords internal #' @export UQ <- function(x) { abort("`UQ()` can only be used within a defused argument") } #' @rdname UQ #' @export UQS <- function(x) { abort("`UQS()` can only be used within a defused argument") } # Expressions ------------------------------------------------------ #' Create a call #' #' @description #' `r lifecycle::badge("deprecated")` #' These functions are deprecated, please use [call2()] and #' [new_call()] instead. #' #' @inheritParams call2 #' @keywords internal #' @export lang <- function(.fn, ..., .ns = NULL) { # 2022-01: Still used in attempt # https://github.com/ColinFay/attempt/issues/16 deprecate_warn(paste_line( "`lang()` is deprecated as of rlang 0.2.0.", "Please use `call2()` instead." )) call2(.fn, ..., .ns = .ns) } #' Is object a call? #' #' @description #' `r lifecycle::badge("deprecated")` #' These functions are deprecated, please use [is_call()] and its `n` #' argument instead. #' @inheritParams is_call #' @keywords internal #' @export is_lang <- function(x, name = NULL, n = NULL, ns = NULL) { # 2022-01: Still used in foolbox # https://github.com/mailund/foolbox/issues/50 deprecate_warn(paste_line( "`is_lang()` is deprecated as of rlang 0.2.0.", "Please use `is_call()` instead." )) is_call(x, name, n, ns) } #' Standardise a call #' #' @description #' #' `r lifecycle::badge("deprecated")` #' #' Deprecated in rlang 0.4.11 in favour of [call_match()]. #' `call_standardise()` was designed for call wrappers that include an #' environment like formulas or quosures. The function definition was #' plucked from that environment. However in practice it is rare to #' use it with wrapped calls, and then it's easy to forget to supply #' the environment. For these reasons, we have designed [call_match()] #' as a simpler wrapper around [match.call()]. #' #' This is essentially equivalent to [base::match.call()], but with #' experimental handling of primitive functions. #' #' @inheritParams call_fn #' @inheritParams call_match #' #' @return A quosure if `call` is a quosure, a raw call otherwise. #' @keywords internal #' @export call_standardise <- function(call, env = caller_env()) { deprecate_soft("`call_standardise()` is deprecated as of rlang 0.4.11") expr <- get_expr(call) if (!is_call(expr)) { abort_call_input_type("call") } # The call name might be a literal, not necessarily a symbol env <- get_env(call, env) fn <- eval_bare(node_car(expr), env) if (is_primitive(fn)) { call } else { matched <- match.call(fn, expr) set_expr(call, matched) } } #' Extract function from a call #' #' @description #' `r lifecycle::badge("deprecated")` #' Deprecated in rlang 0.4.11. #' #' @param call,env `r lifecycle::badge("deprecated")` #' @keywords internal #' @export call_fn <- function(call, env = caller_env()) { deprecate_soft("`call_fn()` is deprecated as of rlang 0.4.11") expr <- get_expr(call) env <- get_env(call, env) if (!is_call(expr)) { abort_call_input_type("call") } switch(call_type(expr), recursive = abort("`call` does not call a named or inlined function"), inlined = node_car(expr), named = , namespaced = , eval_bare(node_car(expr), env) ) } # rlang 0.4.11: silent deprecation # rlang 1.1.0: soft-deprecation # Environments ----------------------------------------------------- # 2022-01: https://github.com/r-lib/conflicted/issues/65 #' Deprecated `scoped` functions #' #' @description #' `r lifecycle::badge("deprecated")` #' #' These functions are deprecated as of rlang 0.3.0. Please use #' [is_attached()] instead. #' #' @param nm The name of an environment attached to the search #' path. Call [base::search()] to see what is currently on the path. #' @keywords internal #' @export scoped_env <- function(nm) { deprecate_warn(paste_line( "`scoped_env()` is deprecated as of rlang 0.3.0.", "Please use `search_env()` instead." )) local_options(lifecycle_disable_warnings = TRUE) if (identical(nm, "NULL")) { return(empty_env()) } if (!is_scoped(nm)) { stop(paste0(nm, " is not in scope"), call. = FALSE) } as.environment(nm) } # 2022-01: https://github.com/tidyverse/purrr/issues/851 #' @rdname scoped_env #' @export is_scoped <- function(nm) { deprecate_warn(paste_line( "`is_scoped()` is deprecated as of rlang 0.3.0.", "Please use `is_attached()` instead." )) local_options(lifecycle_disable_warnings = TRUE) if (!is_scalar_character(nm)) { stop("`nm` must be a string", call. = FALSE) } nm %in% c(search(), "NULL") } # Attributes ------------------------------------------------------- #' Add attributes to an object #' #' `r lifecycle::badge("deprecated")` #' @param .x,... `r lifecycle::badge("deprecated")` #' #' @keywords internal #' @export set_attrs <- function(.x, ...) { # 2018-10: Soft-deprecated # 2019-06: Deprecated # 2022-01: Used in `survivalAnalysis` deprecate_warn("`set_attrs()` is deprecated as of rlang 0.3.0") if (!is_copyable(.x)) { abort("`.x` is uncopyable.") } set_attrs_impl(.x, ...) } set_attrs_impl <- function(.x, ...) { attrs <- dots_list(...) # If passed a single unnamed NULL, zap attributes if (identical(attrs, set_attrs_null)) { attributes(.x) <- NULL } else { attributes(.x) <- c(attributes(.x), attrs) } .x } set_attrs_null <- list(NULL) names(set_attrs_null) <- "" # Conditions -------------------------------------------------------- # 1.0.0: Silently deprecated. Used in recipes (in a deprecated function). # 1.1.0: soft-deprecated #' Establish handlers on the stack #' #' @description #' `r lifecycle::badge("deprecated")` #' #' As of rlang 1.0.0, `with_handlers()` is deprecated. Use the base #' functions or the experimental [try_fetch()] function instead. #' #' @param .expr,...,handler `r lifecycle::badge("deprecated")` #' @keywords internal #' @export with_handlers <- function(.expr, ...) { deprecate_soft(c( "`with_handlers()` is deprecated as of rlang 1.0.0.", "i" = "Please use `tryCatch()`, `withCallingHandlers()`, or `try_fetch()`." )) handlers <- list2(...) is_calling <- map_lgl(handlers, inherits, "rlang_box_calling_handler") handlers <- map_if(handlers, is_calling, unbox) handlers <- map(handlers, as_function) calling <- handlers[is_calling] exiting <- handlers[!is_calling] expr <- quote(.expr) if (length(calling)) { expr <- expr(withCallingHandlers(!!expr, !!!calling)) } if (length(exiting)) { expr <- expr(tryCatch(!!expr, !!!exiting)) } .External2(ffi_eval, expr, environment()) } #' @rdname with_handlers #' @export calling <- function(handler) { deprecate_soft("`calling()` is deprecated as of rlang 1.0.0.") handler <- as_function(handler) new_box(handler, "rlang_box_calling_handler") } #' @rdname with_handlers #' @export exiting <- function(handler) { deprecate_soft(c( "`exiting()` is deprecated as of rlang 0.4.0.", "Handlers are now treated as exiting by default." )) handler <- as_function(handler) structure(handler, class = c("rlang_handler_exiting", "rlang_handler", "function")) } # Scoped_ # rlang 0.4.2: Silent deprecation. # rlang 1.0.0: Soft deprecation. #' Deprecated `scoped_` functions #' #' @description #' `r lifecycle::badge("deprecated")` #' #' Deprecated as of rlang 0.4.2. Use [local_interactive()], #' [local_options()], or [local_bindings()] instead. #' #' @inheritParams local_interactive #' @inheritParams local_options #' @inheritParams local_bindings #' #' @keywords internal #' @export scoped_interactive <- function(value = TRUE, frame = caller_env()) { deprecate_soft(c( "`scoped_interactive()` is deprecated as of rlang 0.4.2.", "Please use `local_interactive()` instead." )) local_interactive(value = value, frame = frame) } #' @rdname scoped_interactive #' @export scoped_options <- function(..., .frame = caller_env()) { deprecate_soft(c( "`scoped_options()` is deprecated as of rlang 0.4.2.", "Please use `local_options()` instead." )) local_options(..., .frame = .frame) } #' @rdname scoped_interactive #' @export scoped_bindings <- function(..., .env = .frame, .frame = caller_env()) { deprecate_soft(c( "`scoped_bindings()` is deprecated as of rlang 0.4.2.", "Please use `local_bindings()` instead." )) local_bindings(..., .env = .env, .frame = .frame) } rlang/R/standalone-rlang.R0000644000176200001440000000341614403555414015143 0ustar liggesusers# --- # repo: r-lib/rlang # file: standalone-rlang.R # last-updated: 2022-09-16 # license: https://unlicense.org # --- # # Changelog: # # 2022-09-16: # * No longer uses rlang if not fully loaded (#1482) # # 2020-05-26: # * Initial version. # # nocov start # These versions of `abort()`, `warn()` and `inform()` are only # guaranteed to support "i" and "x" bullets. Other kinds of bullets # might fail if rlang is not recent enough. .rlang_compat <- function(fn, try_rlang = TRUE) { # Compats that behave the same independently of rlang's presence out <- switch( fn, is_installed = return(function(pkg) requireNamespace(pkg, quietly = TRUE)) ) # Only use rlang if it is fully loaded (#1482) if (try_rlang && requireNamespace("rlang", quietly = TRUE) && environmentIsLocked(asNamespace("rlang"))) { switch( fn, is_interactive = return(rlang::is_interactive) ) # Make sure rlang knows about "x" and "i" bullets if (utils::packageVersion("rlang") >= "0.4.2") { switch( fn, abort = return(rlang::abort), warn = return((rlang::warn)), inform = return(rlang::inform) ) } } # Fall back to base compats is_interactive_compat <- function() { opt <- getOption("rlang_interactive") if (!is.null(opt)) { opt } else { interactive() } } format_msg <- function(x) paste(x, collapse = "\n") switch( fn, is_interactive = return(is_interactive_compat), abort = return(function(msg) stop(format_msg(msg), call. = FALSE)), warn = return(function(msg) warning(format_msg(msg), call. = FALSE)), inform = return(function(msg) message(format_msg(msg))) ) stop(sprintf("Internal error in rlang shims: Unknown function `%s()`.", fn)) } #nocov end rlang/R/cnd-last.R0000644000176200001440000001537214401370442013415 0ustar liggesusers#' Last `abort()` error #' #' @description #' * `last_error()` returns the last error entraced by [abort()] or #' [global_entrace()]. The error is printed with a backtrace in #' simplified form. #' #' * `last_trace()` is a shortcut to return the backtrace stored in #' the last error. This backtrace is printed in full form. #' #' @seealso #' * [`rlang_backtrace_on_error`] to control what is displayed when an #' error is thrown. #' #' * [global_entrace()] to enable `last_error()` logging for all errors. #' #' * [last_warnings()] and [last_messages()]. #' #' @export last_error <- function() { err <- peek_last_error() if (is_null(err)) { local_options(rlang_backtrace_on_error = "none") stop("Can't show last error because no error was recorded yet", call. = FALSE) } err$rlang$internal$from_last_error <- TRUE err } #' @rdname last_error #' @param drop Whether to drop technical calls. These are hidden from #' users by default, set `drop` to `FALSE` to see the full backtrace. #' @export last_trace <- function(drop = NULL) { err <- last_error() # Drop by default with new tree display, don't drop with legacy # behaviour drop <- drop %||% TRUE err$rlang$internal$trace_simplify <- "none" err$rlang$internal$trace_drop <- drop err } peek_last_error <- function(cnd) { the$last_error } poke_last_error <- function(cnd) { the$last_error <- cnd } on_load( the$last_error <- NULL ) #' Display last messages and warnings #' #' @description #' #' `last_warnings()` and `last_messages()` return a list of all #' warnings and messages that occurred during the last R command. #' #' [global_entrace()] must be active in order to log the messages and #' warnings. #' #' By default the warnings and messages are printed with a simplified #' backtrace, like [last_error()]. Use `summary()` to print the #' conditions with a full backtrace. #' #' @param n How many warnings or messages to display. Defaults to all. #' #' @seealso [last_error()] #' #' @section Examples: #' #' Enable backtrace capture with `global_entrace()`: #' #' ```r #' global_entrace() #' ``` #' #' Signal some warnings in nested functions. The warnings inform about #' which function emitted a warning but they don't provide information #' about the call stack: #' #' ```r #' f <- function() { warning("foo"); g() } #' g <- function() { warning("bar", immediate. = TRUE); h() } #' h <- function() warning("baz") #' #' f() #' #> Warning in g() : bar #' #> Warning messages: #' #> 1: In f() : foo #' #> 2: In h() : baz #' ``` #' #' Call `last_warnings()` to see backtraces for each of these warnings: #' #' ```r #' last_warnings() #' #> [[1]] #' #> #' #> Warning in `f()`: #' #> foo #' #> Backtrace: #' #> x #' #> 1. \-global f() #' #> #' #> [[2]] #' #> #' #> Warning in `g()`: #' #> bar #' #> Backtrace: #' #> x #' #> 1. \-global f() #' #> 2. \-global g() #' #> #' #> [[3]] #' #> #' #> Warning in `h()`: #' #> baz #' #> Backtrace: #' #> x #' #> 1. \-global f() #' #> 2. \-global g() #' #> 3. \-global h() #' ``` #' #' This works similarly with messages: #' #' ```r #' f <- function() { inform("Hey!"); g() } #' g <- function() { inform("Hi!"); h() } #' h <- function() inform("Hello!") #' #' f() #' #> Hey! #' #> Hi! #' #> Hello! #' #' rlang::last_messages() #' #> [[1]] #' #> #' #> Message: #' #> Hey! #' #> --- #' #> Backtrace: #' #> x #' #> 1. \-global f() #' #> #' #> [[2]] #' #> #' #> Message: #' #> Hi! #' #> --- #' #> Backtrace: #' #> x #' #> 1. \-global f() #' #> 2. \-global g() #' #> #' #> [[3]] #' #> #' #> Message: #' #> Hello! #' #> --- #' #> Backtrace: #' #> x #' #> 1. \-global f() #' #> 2. \-global g() #' #> 3. \-global h() #' ``` #' #' @export last_warnings <- function(n = NULL) { out <- new_list_of_conditions(the$last_warnings) utils::tail(out, n = n %||% length(out)) } #' @rdname last_warnings #' @export last_messages <- function(n = NULL) { out <- new_list_of_conditions(the$last_messages) utils::tail(out, n = n %||% length(out)) } on_load({ the$n_conditions <- 0L the$last_top_frame <- NULL the$last_warnings <- list() the$last_messages <- list() }) # We collect warnings/messages in a list as long as the first frame on # the call stack has the same address. If there is a new address, it # must be that a new top-level R command is running and we start a new # list. This heuristic is technically not 100% correct. We might be # very unlucky: If (a) a GC occur between two commands (b) the first # frame on the stack reuses the same address as the last first frame # on the stack, then we'll wrongly keep collecting warnings instead of # starting anew. push_warning <- function(cnd) { push_condition(cnd, "last_warnings") } push_message <- function(cnd) { push_condition(cnd, "last_messages") } push_condition <- function(cnd, last) { top <- obj_address(cmd_frame()) if (has_new_cmd_frame(top)) { the$last_top_frame <- top the[[last]] <- list(cnd) the$n_conditions <- 1L } else { the[[last]] <- c(the[[last]], list(cnd)) # Count the number of pushed conditions to avoid entracing too many # times (#1473) the$n_conditions <- the$n_conditions + 1L } } cmd_frame <- function() { if (knitr_in_progress()) { ns <- detect(sys.frames(), function(f) env_top_name(f) == "knitr") ns %||% sys.frame(1) } else { getOption("rlang:::cnd_frame", sys.frame(1)) } } env_top_name <- function(x) { x <- topenv(x) if (is_namespace(x)) { ns_env_name(x) } else { "" } } has_new_cmd_frame <- function(top = obj_address(cmd_frame())) { !identical(the$last_top_frame, top) } # Transform foreign warnings to rlang warnings or messages. Preserve # existing backtraces. as_rlang_warning <- function(cnd, trace = NULL) { cnd$trace <- cnd$trace %||% trace if (!inherits(cnd, "rlang_warning")) { cnd <- warning_cnd( message = conditionMessage(cnd), call = conditionCall(cnd), trace = cnd$trace ) } cnd } as_rlang_message <- function(cnd, trace = NULL) { cnd$trace <- cnd$trace %||% trace if (!inherits(cnd, "rlang_message")) { cnd <- message_cnd( message = conditionMessage(cnd), call = conditionCall(cnd), trace = cnd$trace ) } cnd } new_list_of_conditions <- function(x) { stopifnot(every(x, is_condition)) structure(x, class = c("rlang:::list_of_conditions", "list")) } #' @export `[.rlang:::list_of_conditions` <- function(x, i) { new_list_of_conditions(NextMethod()) } #' @export `print.rlang:::list_of_conditions` <- function(x, ...) { print(unclass(x), ...) invisible(x) } #' @export `summary.rlang:::list_of_conditions` <- function(object, ...) { print(unclass(object), simplify = "none", ...) } rlang/R/fn.R0000644000176200001440000004601414417042612012312 0ustar liggesusers#' Create a function #' #' @description #' #' This constructs a new function given its three components: #' list of arguments, body code and parent environment. #' #' @param args A named list or pairlist of default arguments. Note #' that if you want arguments that don't have defaults, you'll need #' to use the special function [pairlist2()]. If you need quoted #' defaults, use [exprs()]. #' @param body A language object representing the code inside the #' function. Usually this will be most easily generated with #' [base::quote()] #' @param env The parent environment of the function, defaults to the #' calling environment of `new_function()` #' @export #' @examples #' f <- function() letters #' g <- new_function(NULL, quote(letters)) #' identical(f, g) #' #' # Pass a list or pairlist of named arguments to create a function #' # with parameters. The name becomes the parameter name and the #' # argument the default value for this parameter: #' new_function(list(x = 10), quote(x)) #' new_function(pairlist2(x = 10), quote(x)) #' #' # Use `exprs()` to create quoted defaults. Compare: #' new_function(pairlist2(x = 5 + 5), quote(x)) #' new_function(exprs(x = 5 + 5), quote(x)) #' #' # Pass empty arguments to omit defaults. `list()` doesn't allow #' # empty arguments but `pairlist2()` does: #' new_function(pairlist2(x = , y = 5 + 5), quote(x + y)) #' new_function(exprs(x = , y = 5 + 5), quote(x + y)) new_function <- function(args, body, env = caller_env()) { .Call(ffi_new_function, args, body, env) } prim_eval <- eval(quote(sys.function(0))) is_prim_eval <- function(x) identical(x, prim_eval) #' Name of a primitive function #' @param prim A primitive function such as [base::c()]. #' @keywords internal #' @export prim_name <- function(prim) { stopifnot(is_primitive(prim)) # Workaround because R_FunTab is not public name <- format(prim) # TERR formats primitives as `.Native("name")` (#958) name <- sub("^\\.(Primitive|Native)\\(\"", "", name) name <- sub("\"\\)$", "", name) name } #' Extract arguments from a function #' #' `fn_fmls()` returns a named list of formal arguments. #' `fn_fmls_names()` returns the names of the arguments. #' `fn_fmls_syms()` returns formals as a named list of symbols. This #' is especially useful for forwarding arguments in [constructed #' calls][lang]. #' #' Unlike `formals()`, these helpers throw an error with primitive #' functions instead of returning `NULL`. #' #' @param fn A function. It is looked up in the calling frame if not #' supplied. #' @seealso [call_args()] and [call_args_names()] #' @export #' @examples #' # Extract from current call: #' fn <- function(a = 1, b = 2) fn_fmls() #' fn() #' #' # fn_fmls_syms() makes it easy to forward arguments: #' call2("apply", !!! fn_fmls_syms(lapply)) #' #' # You can also change the formals: #' fn_fmls(fn) <- list(A = 10, B = 20) #' fn() #' #' fn_fmls_names(fn) <- c("foo", "bar") #' fn() fn_fmls <- function(fn = caller_fn()) { check_closure(fn) formals(fn) } #' @rdname fn_fmls #' @export fn_fmls_names <- function(fn = caller_fn()) { args <- fn_fmls(fn) names(args) } #' @rdname fn_fmls #' @export fn_fmls_syms <- function(fn = caller_fn()) { fmls_nms <- fn_fmls_names(fn) if (is_null(fmls_nms)) { return(list()) } nms <- set_names(fmls_nms) names(nms)[match("...", nms)] <- "" syms(nms) } #' @rdname fn_fmls #' @param value New formals or formals names for `fn`. #' @export `fn_fmls<-` <- function(fn, value) { check_closure(fn) attrs <- attributes(fn) formals(fn) <- value # Work around bug in base R attributes(fn) <- attrs fn } #' @rdname fn_fmls #' @export `fn_fmls_names<-` <- function(fn, value) { check_closure(fn) attrs <- attributes(fn) fmls <- formals(fn) names(fmls) <- value formals(fn) <- fmls # Work around bug in base R attributes(fn) <- attrs fn } #' Get or set function body #' #' `fn_body()` is a simple wrapper around [base::body()]. It always #' returns a `\{` expression and throws an error when the input is a #' primitive function (whereas `body()` returns `NULL`). The setter #' version preserves attributes, unlike `body<-`. #' #' @inheritParams fn_fmls #' #' @export #' @examples #' # fn_body() is like body() but always returns a block: #' fn <- function() do() #' body(fn) #' fn_body(fn) #' #' # It also throws an error when used on a primitive function: #' try(fn_body(base::list)) fn_body <- function(fn = caller_fn()) { check_closure(fn) body <- body(fn) if (is_call(body, "{")) { body } else { call("{", body) } } #' @rdname fn_body #' @export `fn_body<-` <- function(fn, value) { attrs <- attributes(fn) body(fn) <- value # Work around bug in base R. First remove source references since # the body has changed attrs$srcref <- NULL attributes(fn) <- attrs fn } fn_body_node <- function(fn) { body <- body(fn) if (is_call(body, "{")) { node_cdr(fn) } else { pairlist(body) } } #' Is object a function? #' #' The R language defines two different types of functions: primitive #' functions, which are low-level, and closures, which are the regular #' kind of functions. #' #' Closures are functions written in R, named after the way their #' arguments are scoped within nested environments (see #' ). The #' root environment of the closure is called the closure #' environment. When closures are evaluated, a new environment called #' the evaluation frame is created with the closure environment as #' parent. This is where the body of the closure is evaluated. These #' closure frames appear on the evaluation stack, as opposed to #' primitive functions which do not necessarily have their own #' evaluation frame and never appear on the stack. #' #' Primitive functions are more efficient than closures for two #' reasons. First, they are written entirely in fast low-level #' code. Second, the mechanism by which they are passed arguments is #' more efficient because they often do not need the full procedure of #' argument matching (dealing with positional versus named arguments, #' partial matching, etc). One practical consequence of the special #' way in which primitives are passed arguments is that they #' technically do not have formal arguments, and [formals()] will #' return `NULL` if called on a primitive function. Finally, primitive #' functions can either take arguments lazily, like R closures do, #' or evaluate them eagerly before being passed on to the C code. #' The former kind of primitives are called "special" in R terminology, #' while the latter is referred to as "builtin". `is_primitive_eager()` #' and `is_primitive_lazy()` allow you to check whether a primitive #' function evaluates arguments eagerly or lazily. #' #' You will also encounter the distinction between primitive and #' internal functions in technical documentation. Like primitive #' functions, internal functions are defined at a low level and #' written in C. However, internal functions have no representation in #' the R language. Instead, they are called via a call to #' [base::.Internal()] within a regular closure. This ensures that #' they appear as normal R function objects: they obey all the usual #' rules of argument passing, and they appear on the evaluation stack #' as any other closures. As a result, [fn_fmls()] does not need to #' look in the `.ArgsEnv` environment to obtain a representation of #' their arguments, and there is no way of querying from R whether #' they are lazy ('special' in R terminology) or eager ('builtin'). #' #' You can call primitive functions with [.Primitive()] and internal #' functions with [.Internal()]. However, calling internal functions #' in a package is forbidden by CRAN's policy because they are #' considered part of the private API. They often assume that they #' have been called with correctly formed arguments, and may cause R #' to crash if you call them with unexpected objects. #' #' @inheritParams type-predicates #' @export #' @examples #' # Primitive functions are not closures: #' is_closure(base::c) #' is_primitive(base::c) #' #' # On the other hand, internal functions are wrapped in a closure #' # and appear as such from the R side: #' is_closure(base::eval) #' #' # Both closures and primitives are functions: #' is_function(base::c) #' is_function(base::eval) is_function <- function(x) { .Call(ffi_is_function, x) } #' @export #' @rdname is_function is_closure <- function(x) { .Call(ffi_is_closure, x) } #' @export #' @rdname is_function is_primitive <- function(x) { .Call(ffi_is_primitive, x) } #' @export #' @rdname is_function #' @examples #' #' # Many primitive functions evaluate arguments eagerly: #' is_primitive_eager(base::c) #' is_primitive_eager(base::list) #' is_primitive_eager(base::`+`) is_primitive_eager <- function(x) { .Call(ffi_is_primitive_eager, x) } #' @export #' @rdname is_function #' @examples #' #' # However, primitives that operate on expressions, like quote() or #' # substitute(), are lazy: #' is_primitive_lazy(base::quote) #' is_primitive_lazy(base::substitute) is_primitive_lazy <- function(x) { .Call(ffi_is_primitive_lazy, x) } #' Return the closure environment of a function #' #' Closure environments define the scope of functions (see [env()]). #' When a function call is evaluated, R creates an evaluation frame #' that inherits from the closure environment. This makes all objects #' defined in the closure environment and all its parents available to #' code executed within the function. #' #' `fn_env()` returns the closure environment of `fn`. There is also #' an assignment method to set a new closure environment. #' #' @param fn,x A function. #' @param value A new closure environment for the function. #' @export #' @examples #' env <- child_env("base") #' fn <- with_env(env, function() NULL) #' identical(fn_env(fn), env) #' #' other_env <- child_env("base") #' fn_env(fn) <- other_env #' identical(fn_env(fn), other_env) fn_env <- function(fn) { if (is_primitive(fn)) { return(ns_env("base")) } if(is_closure(fn)) { return(environment(fn)) } check_function(fn) } #' @export #' @rdname fn_env `fn_env<-` <- function(x, value) { check_function(x) environment(x) <- value x } #' Convert to function #' #' @description #' `as_function()` transforms a one-sided formula into a function. #' This powers the lambda syntax in packages like purrr. #' #' @param x A function or formula. #' #' If a **function**, it is used as is. #' #' If a **formula**, e.g. `~ .x + 2`, it is converted to a function #' with up to two arguments: `.x` (single argument) or `.x` and `.y` #' (two arguments). The `.` placeholder can be used instead of `.x`. #' This allows you to create very compact anonymous functions (lambdas) with up #' to two inputs. Functions created from formulas have a special #' class. Use `is_lambda()` to test for it. #' #' If a **string**, the function is looked up in `env`. Note that #' this interface is strictly for user convenience because of the #' scoping issues involved. Package developers should avoid #' supplying functions by name and instead supply them by value. #' #' @param env Environment in which to fetch the function in case `x` #' is a string. #' @inheritParams args_dots_empty #' @inheritParams args_error_context #' @export #' @examples #' f <- as_function(~ .x + 1) #' f(10) #' #' g <- as_function(~ -1 * .) #' g(4) #' #' h <- as_function(~ .x - .y) #' h(6, 3) #' #' # Functions created from a formula have a special class: #' is_lambda(f) #' is_lambda(as_function(function() "foo")) as_function <- function(x, env = global_env(), ..., arg = caller_arg(x), call = caller_env()) { check_dots_empty0(...) if (is_function(x)) { return(x) } if (is_quosure(x)) { mask <- eval_tidy(call2(environment), env = quo_get_env(x)) fn <- new_function(pairlist2(... = ), quo_get_expr(x), mask) return(fn) } if (is_formula(x)) { if (length(x) > 2) { abort_coercion( x, x_type = "a two-sided formula", to_type = "a function", arg = arg, call = call ) } env <- f_env(x) if (!is_environment(env)) { abort("Formula must carry an environment.", arg = arg, call = call) } args <- list(... = missing_arg(), .x = quote(..1), .y = quote(..2), . = quote(..1)) fn <- new_function(args, f_rhs(x), env) fn <- structure(fn, class = c("rlang_lambda_function", "function")) return(fn) } if (is_string(x)) { return(get(x, envir = env, mode = "function")) } abort_coercion(x, "a function", arg = arg, call = call) } #' @export print.rlang_lambda_function <- function(x, ...) { cat_line("") NextMethod() } #' @rdname as_function #' @export is_lambda <- function(x) { inherits(x, "rlang_lambda_function") } #' Transform to a closure #' #' `as_closure()` is like [as_function()] but also wraps primitive #' functions inside closures. Some special control flow primitives #' like `if`, `for`, or `break` can't be wrapped and will cause an #' error. #' #' @inheritParams as_function #' #' @examples #' # Primitive functions are regularised as closures #' as_closure(list) #' as_closure("list") #' #' # Operators have `.x` and `.y` as arguments, just like lambda #' # functions created with the formula syntax: #' as_closure(`+`) #' as_closure(`~`) #' #' @keywords internal #' @export as_closure <- function(x, env = caller_env()) { x <- as_function(x, env = env) if (is_closure(x)) { return(x) } if (!is_primitive(x)) { abort_coercion(x, "a closure") } fn_name <- prim_name(x) fn <- op_as_closure(fn_name) if (!is_null(fn)) { return(fn) } fmls <- formals(args(fn_name)) prim_call <- call2(x, !!!prim_args(fmls)) # The closure wrapper should inherit from the global environment # to ensure proper lexical dispatch with methods defined there new_function(fmls, prim_call, global_env()) } prim_args <- function(fmls) { args <- names(fmls) # Set argument names but only after `...`. Arguments before dots # should be positionally matched. dots_i <- match("...", args) if (!is_na(dots_i)) { idx <- seq2(dots_i + 1L, length(args)) names2(args)[idx] <- args[idx] } syms(args) } utils::globalVariables(c("!<-", "(<-", "enexpr<-")) op_as_closure <- function(prim_nm) { switch(prim_nm, `<-` = , `<<-` = , `=` = function(.x, .y) { op <- sym(prim_nm) expr <- expr((!!op)(!!enexpr(.x), !!enexpr(.y))) eval_bare(expr, caller_env()) }, `@` = , `$` = function(.x, .i) { op <- sym(prim_nm) expr <- expr((!!op)(.x, !!quo_squash(enexpr(.i), warn = TRUE))) eval_bare(expr) }, `[[<-` = function(.x, .i, .value) { expr <- expr((!!enexpr(.x))[[!!enexpr(.i)]] <- !!enexpr(.value)) eval_bare(expr, caller_env()) }, `[<-` = function(.x, ...) { args <- exprs(...) n <- length(args) if (n < 2L) { abort("Must supply operands to `[<-`.") } expr <- expr((!!enexpr(.x))[!!!args[-n]] <- !!args[[n]]) eval_bare(expr, caller_env()) }, `@<-` = function(.x, .i, .value) { expr <- expr(`@`(!!enexpr(.x), !!enexpr(.i)) <- !!enexpr(.value)) eval_bare(expr, caller_env()) }, `$<-` = function(.x, .i, .value) { expr <- expr(`$`(!!enexpr(.x), !!enexpr(.i)) <- !!enexpr(.value)) eval_bare(expr, caller_env()) }, `(` = function(.x) .x, `[` = function(.x, ...) .x[...], `[[` = function(.x, ...) .x[[...]], `{` = function(...) { values <- list(...) values[[length(values)]] }, `&` = new_binary_closure(function(.x, .y) .x & .y), `|` = new_binary_closure(function(.x, .y) .x | .y), `&&` = new_binary_closure(function(.x, .y) .x && .y), `||` = new_binary_closure(function(.x, .y) .x || .y, shortcircuiting = TRUE), `!` = function(.x) !.x, `+` = new_binary_closure(function(.x, .y) if (missing(.y)) .x else .x + .y, versatile = TRUE), `-` = new_binary_closure(function(.x, .y) if (missing(.y)) -.x else .x - .y, versatile = TRUE), `*` = new_binary_closure(function(.x, .y) .x * .y), `/` = new_binary_closure(function(.x, .y) .x / .y), `^` = new_binary_closure(function(.x, .y) .x ^ .y), `%%` = new_binary_closure(function(.x, .y) .x %% .y), `<` = new_binary_closure(function(.x, .y) .x < .y), `<=` = new_binary_closure(function(.x, .y) .x <= .y), `>` = new_binary_closure(function(.x, .y) .x > .y), `>=` = new_binary_closure(function(.x, .y) .x >= .y), `==` = new_binary_closure(function(.x, .y) .x == .y), `!=` = new_binary_closure(function(.x, .y) .x != .y), `:` = new_binary_closure(function(.x, .y) .x : .y), `~` = function(.x, .y) { if (is_missing(substitute(.y))) { new_formula(NULL, substitute(.x), caller_env()) } else { new_formula(substitute(.x), substitute(.y), caller_env()) } }, `c` = function(...) c(...), seq.int = function(from = 1L, to = from, ...) seq.int(from, to, ...), # Unsupported primitives `break` = , `for` = , `function` = , `if` = , `next` = , `repeat` = , `return` = , `while` = { nm <- chr_quoted(prim_nm) abort(paste0("Can't coerce the primitive function ", nm, " to a closure.")) } ) } new_binary_closure <- function(fn, versatile = FALSE, shortcircuiting = FALSE) { if (versatile) { nodes <- versatile_check_nodes } else if (shortcircuiting) { nodes <- shortcircuiting_check_nodes } else { nodes <- binary_check_nodes } nodes <- duplicate(nodes, shallow = TRUE) nodes <- node_append(nodes, fn_body_node(fn)) body <- new_call(brace_sym, nodes) formals(fn) <- binary_fmls body(fn) <- body fn } binary_fmls <- as.pairlist(alist( e1 = , e2 = , .x = e1, .y = e2 )) binary_check_nodes <- pairlist( quote( if (missing(.x)) { if (missing(e1)) { abort("Must supply `e1` or `.x` to binary operator.") } .x <- e1 } else if (!missing(e1)) { abort("Can't supply both `e1` and `.x` to binary operator.") } ), quote( if (missing(.y)) { if (missing(e2)) { abort("Must supply `e2` or `.y` to binary operator.") } .y <- e2 } else if (!missing(e2)) { abort("Can't supply both `e2` and `.y` to binary operator.") } ) ) versatile_check_nodes <- as.pairlist(c( binary_check_nodes[[1]], quote( if (missing(.y) && !missing(e2)) { .y <- e2 } else if (!missing(e2)) { abort("Can't supply both `e2` and `.y` to binary operator.") } ) )) shortcircuiting_check_nodes <- as.pairlist(c( binary_check_nodes[[1]], quote(if (.x) return(TRUE)), binary_check_nodes[[2]] )) as_predicate <- function(.fn, ...) { .fn <- as_function(.fn) function(...) { out <- .fn(...) if (!is_bool(out)) { abort(sprintf( "Predicate functions must return a single `TRUE` or `FALSE`, not %s", as_predicate_friendly_type_of(out) )) } out } } as_predicate_friendly_type_of <- function(x) { if (is_na(x)) { "a missing value" } else { obj_type_friendly(x) } } rlang/R/eval-tidy.R0000644000176200001440000004614514723531655013624 0ustar liggesusers#' Evaluate an expression with quosures and pronoun support #' #' @description #' `eval_tidy()` is a variant of [base::eval()] that powers the tidy #' evaluation framework. Like `eval()` it accepts user data as #' argument. Whereas `eval()` simply transforms the data to an #' environment, `eval_tidy()` transforms it to a [data #' mask][topic-data-mask] with [as_data_mask()]. Evaluating in a data #' mask enables the following features: #' #' - [Quosures][topic-quosure]. Quosures are expressions bundled with #' an environment. If `data` is supplied, objects in the data mask #' always have precedence over the quosure environment, i.e. the #' data masks the environment. #' #' - [Pronouns][.data]. If `data` is supplied, the `.env` and `.data` #' pronouns are installed in the data mask. `.env` is a reference to #' the calling environment and `.data` refers to the `data` #' argument. These pronouns are an escape hatch for the [data mask #' ambiguity][topic-data-mask-ambiguity] problem. #' #' @param expr An [expression][topic-defuse] or #' [quosure][topic-quosure] to evaluate. #' @param data A data frame, or named list or vector. Alternatively, a #' data mask created with [as_data_mask()] or #' [new_data_mask()]. Objects in `data` have priority over those in #' `env`. See the section about data masking. #' @param env The environment in which to evaluate `expr`. This #' environment is not applicable for quosures because they have #' their own environments. #' #' @section When should eval_tidy() be used instead of eval()?: #' #' `base::eval()` is sufficient for simple evaluation. Use #' `eval_tidy()` when you'd like to support expressions referring to #' the `.data` pronoun, or when you need to support quosures. #' #' If you're evaluating an expression captured with #' [injection][topic-inject] support, it is recommended to use #' `eval_tidy()` because users may inject quosures. #' #' Note that unwrapping a quosure with [quo_get_expr()] does not #' guarantee that there is no quosures inside the expression. Quosures #' might be unquoted anywhere in the expression tree. For instance, #' the following does not work reliably in the presence of nested #' quosures: #' #' ``` #' my_quoting_fn <- function(x) { #' x <- enquo(x) #' expr <- quo_get_expr(x) #' env <- quo_get_env(x) #' eval(expr, env) #' } #' #' # Works: #' my_quoting_fn(toupper(letters)) #' #' # Fails because of a nested quosure: #' my_quoting_fn(toupper(!!quo(letters))) #' ``` #' #' #' @section Stack semantics of `eval_tidy()`: #' #' `eval_tidy()` always evaluates in a data mask, even when `data` is #' `NULL`. Because of this, it has different stack semantics than #' [base::eval()]: #' #' - Lexical side effects, such as assignment with `<-`, occur in the #' mask rather than `env`. #' #' - Functions that require the evaluation environment to correspond #' to a frame on the call stack do not work. This is why `return()` #' called from a quosure does not work. #' #' - The mask environment creates a new branch in the tree #' representation of backtraces (which you can visualise in a #' [browser()] session with `lobstr::cst()`). #' #' See also [eval_bare()] for more information about these differences. #' #' #' @seealso #' - `r link("topic_data_mask")`. #' - `r link("topic_quosure")`. #' - `r link("topic_defuse")`. #' - [new_data_mask()] and [as_data_mask()] for manually creating data masks. #' #' @examples #' #' # With simple defused expressions eval_tidy() works the same way as #' # eval(): #' fruit <- "apple" #' vegetable <- "potato" #' expr <- quote(paste(fruit, vegetable, sep = " or ")) #' expr #' #' eval(expr) #' eval_tidy(expr) #' #' # Both accept a data mask as argument: #' data <- list(fruit = "banana", vegetable = "carrot") #' eval(expr, data) #' eval_tidy(expr, data) #' #' # The main difference is that eval_tidy() supports quosures: #' with_data <- function(data, expr) { #' quo <- enquo(expr) #' eval_tidy(quo, data) #' } #' with_data(NULL, fruit) #' with_data(data, fruit) #' #' # eval_tidy() installs the `.data` and `.env` pronouns to allow #' # users to be explicit about variable references: #' with_data(data, .data$fruit) #' with_data(data, .env$fruit) #' @export eval_tidy <- function(expr, data = NULL, env = caller_env()) { .External2(ffi_eval_tidy, expr, data, env) } tilde_eval <- function(...) { .External2( ffi_tilde_eval, sys.call(), # Quosure env environment(), # Unwind-protect env parent.frame() # Lexical env ) } # Helps work around roxygen loading issues #' @export length.rlang_fake_data_pronoun <- function(...) 0L #' @export names.rlang_fake_data_pronoun <- function(...) NULL #' @export `$.rlang_fake_data_pronoun` <- function(...) NULL #' @export `[[.rlang_fake_data_pronoun` <- function(...) NULL #' @export print.rlang_fake_data_pronoun <- function(...) cat_line("") #' `.data` and `.env` pronouns #' #' @description #' #' The `.data` and `.env` pronouns make it explicit where to find #' objects when programming with [data-masked][topic-data-mask] #' functions. #' #' ``` #' m <- 10 #' mtcars %>% mutate(disp = .data$disp * .env$m) #' ``` #' #' * `.data` retrieves data-variables from the data frame. #' * `.env` retrieves env-variables from the environment. #' #' Because the lookup is explicit, there is no ambiguity between both #' kinds of variables. Compare: #' #' ``` #' disp <- 10 #' mtcars %>% mutate(disp = .data$disp * .env$disp) #' mtcars %>% mutate(disp = disp * disp) #' ``` #' #' Note that `.data` is only a pronoun, it is not a real data #' frame. This means that you can't take its names or map a function #' over the contents of `.data`. Similarly, `.env` is not an actual R #' environment. For instance, it doesn't have a parent and the #' subsetting operators behave differently. #' #' #' @section `.data` versus the magrittr pronoun `.`: #' #' In a [magrittr pipeline](https://magrittr.tidyverse.org/), `.data` #' is not necessarily interchangeable with the magrittr pronoun `.`. #' With grouped data frames in particular, `.data` represents the #' current group slice whereas the pronoun `.` represents the whole #' data frame. Always prefer using `.data` in data-masked context. #' #' #' @section Where does `.data` live?: #' #' The `.data` pronoun is automatically created for you by #' data-masking functions using the [tidy eval framework][eval_tidy]. #' You don't need to import `rlang::.data` or use `library(rlang)` to #' work with this pronoun. #' #' However, the `.data` object exported from rlang is useful to import #' in your package namespace to avoid a `R CMD check` note when #' referring to objects from the data mask. R does not have any way of #' knowing about the presence or absence of `.data` in a particular #' scope so you need to import it explicitly or equivalently declare #' it with `utils::globalVariables(".data")`. #' #' Note that `rlang::.data` is a "fake" pronoun. Do not refer to #' `rlang::.data` with the `rlang::` qualifier in data masking #' code. Use the unqualified `.data` symbol that is automatically put #' in scope by data-masking functions. #' #' @name dot-data #' @aliases tidyeval-data #' @format NULL #' @usage NULL #' @export .data <- structure(list(), class = "rlang_fake_data_pronoun") #' @rdname dot-data #' @format NULL #' @usage NULL #' @export .env <- .data #' Create a data mask #' #' @description #' #' A [data mask][topic-data-mask] is an environment (or possibly #' multiple environments forming an ancestry) containing user-supplied #' objects. Objects in the mask have precedence over objects in the #' environment (i.e. they mask those objects). Many R functions #' evaluate quoted expressions in a data mask so these expressions can #' refer to objects within the user data. #' #' These functions let you construct a tidy eval data mask manually. #' They are meant for developers of tidy eval interfaces rather than #' for end users. #' #' #' @section Why build a data mask?: #' #' Most of the time you can just call [eval_tidy()] with a list or a #' data frame and the data mask will be constructed automatically. #' There are three main use cases for manual creation of data masks: #' #' * When [eval_tidy()] is called with the same data in a tight loop. #' Because there is some overhead to creating tidy eval data masks, #' constructing the mask once and reusing it for subsequent #' evaluations may improve performance. #' #' * When several expressions should be evaluated in the exact same #' environment because a quoted expression might create new objects #' that can be referred in other quoted expressions evaluated at a #' later time. One example of this is `tibble::lst()` where new #' columns can refer to previous ones. #' #' * When your data mask requires special features. For instance the #' data frame columns in dplyr data masks are implemented with #' [active bindings][base::delayedAssign]. #' #' #' @section Building your own data mask: #' #' Unlike [base::eval()] which takes any kind of environments as data #' mask, [eval_tidy()] has specific requirements in order to support #' [quosures][nse-defuse]. For this reason you can't supply bare #' environments. #' #' There are two ways of constructing an rlang data mask manually: #' #' * `as_data_mask()` transforms a list or data frame to a data mask. #' It automatically installs the data pronoun [`.data`][.data]. #' #' * `new_data_mask()` is a bare bones data mask constructor for #' environments. You can supply a bottom and a top environment in #' case your data mask comprises multiple environments (see section #' below). #' #' Unlike `as_data_mask()` it does not install the `.data` pronoun #' so you need to provide one yourself. You can provide a pronoun #' constructed with `as_data_pronoun()` or your own pronoun class. #' #' `as_data_pronoun()` will create a pronoun from a list, an #' environment, or an rlang data mask. In the latter case, the whole #' ancestry is looked up from the bottom to the top of the mask. #' Functions stored in the mask are bypassed by the pronoun. #' #' Once you have built a data mask, simply pass it to [eval_tidy()] as #' the `data` argument. You can repeat this as many times as #' needed. Note that any objects created there (perhaps because of a #' call to `<-`) will persist in subsequent evaluations. #' #' #' @section Top and bottom of data mask: #' #' In some cases you'll need several levels in your data mask. One #' good reason is when you include functions in the mask. It's a good #' idea to keep data objects one level lower than function objects, so #' that the former cannot override the definitions of the latter (see #' examples). #' #' In that case, set up all your environments and keep track of the #' bottom child and the top parent. You'll need to pass both to #' `new_data_mask()`. #' #' Note that the parent of the top environment is completely #' undetermined, you shouldn't expect it to remain the same at all #' times. This parent is replaced during evaluation by [eval_tidy()] #' to one of the following environments: #' #' * The default environment passed as the `env` argument of `eval_tidy()`. #' * The environment of the current quosure being evaluated, if applicable. #' #' Consequently, all masking data should be contained between the #' bottom and top environment of the data mask. #' #' @param data A data frame or named vector of masking data. #' @return A data mask that you can supply to [eval_tidy()]. #' #' @export #' @examples #' # Evaluating in a tidy evaluation environment enables all tidy #' # features: #' mask <- as_data_mask(mtcars) #' eval_tidy(quo(letters), mask) #' #' # You can install new pronouns in the mask: #' mask$.pronoun <- as_data_pronoun(list(foo = "bar", baz = "bam")) #' eval_tidy(quo(.pronoun$foo), mask) #' #' # In some cases the data mask can leak to the user, for example if #' # a function or formula is created in the data mask environment: #' cyl <- "user variable from the context" #' fn <- eval_tidy(quote(function() cyl), mask) #' fn() #' #' # If new objects are created in the mask, they persist in the #' # subsequent calls: #' eval_tidy(quote(new <- cyl + am), mask) #' eval_tidy(quote(new * 2), mask) #' #' #' # In some cases your data mask is a whole chain of environments #' # rather than a single environment. You'll have to use #' # `new_data_mask()` and let it know about the bottom of the mask #' # (the last child of the environment chain) and the topmost parent. #' #' # A common situation where you'll want a multiple-environment mask #' # is when you include functions in your mask. In that case you'll #' # put functions in the top environment and data in the bottom. This #' # will prevent the data from overwriting the functions. #' top <- new_environment(list(`+` = base::paste, c = base::paste)) #' #' # Let's add a middle environment just for sport: #' middle <- env(top) #' #' # And finally the bottom environment containing data: #' bottom <- env(middle, a = "a", b = "b", c = "c") #' #' # We can now create a mask by supplying the top and bottom #' # environments: #' mask <- new_data_mask(bottom, top = top) #' #' # This data mask can be passed to eval_tidy() instead of a list or #' # data frame: #' eval_tidy(quote(a + b + c), data = mask) #' #' # Note how the function `c()` and the object `c` are looked up #' # properly because of the multi-level structure: #' eval_tidy(quote(c(a, b, c)), data = mask) #' #' # new_data_mask() does not create data pronouns, but #' # data pronouns can be added manually: #' mask$.fns <- as_data_pronoun(top) #' #' # The `.data` pronoun should generally be created from the #' # mask. This will ensure data is looked up throughout the whole #' # ancestry. Only non-function objects are looked up from this #' # pronoun: #' mask$.data <- as_data_pronoun(mask) #' mask$.data$c #' #' # Now we can reference values with the pronouns: #' eval_tidy(quote(c(.data$a, .data$b, .data$c)), data = mask) as_data_mask <- function(data) { .Call(ffi_as_data_mask, data) } #' @rdname as_data_mask #' @export as_data_pronoun <- function(data) { .Call(ffi_as_data_pronoun, data) } #' @rdname as_data_mask #' @param bottom The environment containing masking objects if the #' data mask is one environment deep. The bottom environment if the #' data mask comprises multiple environment. #' #' If you haven't supplied `top`, this __must__ be an environment #' that you own, i.e. that you have created yourself. #' @param top The last environment of the data mask. If the data mask #' is only one environment deep, `top` should be the same as #' `bottom`. #' #' This __must__ be an environment that you own, i.e. that you have #' created yourself. The parent of `top` will be changed by the tidy #' eval engine and should be considered undetermined. Never make #' assumption about the parent of `top`. #' @export new_data_mask <- function(bottom, top = bottom) { .Call(ffi_new_data_mask, bottom, top) } #' @export `$.rlang_data_pronoun` <- function(x, nm) { data_pronoun_get(x, nm, call = I(call("$", quote(.data), sym(nm)))) } #' @export `[[.rlang_data_pronoun` <- function(x, i, ...) { data_pronoun_get(x, i, call = I(call("[[", quote(.data), substitute(i)))) } data_pronoun_get <- function(x, nm, call) { if (!is_string(nm)) { abort( sprintf("Must subset the data pronoun with a string, not %s.", obj_type_friendly(nm)), call = call ) } mask <- .subset2(x, 1) .Call(ffi_data_pronoun_get, mask, sym(nm), call) } abort_data_pronoun <- function(nm, call) { msg <- sprintf("Column `%s` not found in `.data`.", as_string(nm)) abort(msg, "rlang_error_data_pronoun_not_found", call = call) } #' @export `$.rlang_ctxt_pronoun` <- function(x, nm) { ctxt_pronoun_get(x, nm) } #' @export `[[.rlang_ctxt_pronoun` <- function(x, i, ...) { ctxt_pronoun_get(x, i) } ctxt_pronoun_get <- function(x, nm, call) { if (!is_string(nm)) { abort( sprintf("Must subset the context pronoun with a string, not %s.", obj_type_friendly(nm)), call = call ) } eval_bare(sym(nm), x) } #' @export `$<-.rlang_data_pronoun` <- function(x, i, value) { abort( "Can't modify the data pronoun.", call = I(call("<-", call("$", quote(.data), substitute(i)), sym("..."))) ) } #' @export `[[<-.rlang_data_pronoun` <- function(x, i, value) { abort( "Can't modify the data pronoun.", call = I(call("<-", call("[[", quote(.data), substitute(i)), sym("..."))) ) } #' @export `$<-.rlang_ctxt_pronoun` <- function(x, i, value) { abort( "Can't modify the context pronoun.", call = I(call("<-", call("$", quote(.env), substitute(i)), sym("..."))) ) } #' @export `[[<-.rlang_ctxt_pronoun` <- function(x, i, value) { abort( "Can't modify the context pronoun.", call = I(call("<-", call("[[", quote(.env), substitute(i)), sym("..."))) ) } #' @export `[.rlang_data_pronoun` <- function(x, i, ...) { abort( "`[` is not supported by the `.data` pronoun, use `[[` or $ instead.", call = I(call2("[", quote(.data), !!!enexprs(i, ...))) ) } #' @export `[.rlang_ctxt_pronoun` <- function(x, i, ...) { abort( "`[` is not supported by the `.env` pronoun, use `[[` or $ instead.", call = I(call2("[", quote(.env), !!!enexprs(i, ...))) ) } #' @export names.rlang_data_pronoun <- function(x) { chr() } #' @export dimnames.rlang_data_pronoun <- function(x) { list(chr(), chr()) } #' @export length.rlang_data_pronoun <- function(x) { 0L } #' @export names.rlang_ctxt_pronoun <- function(x) { chr() } #' @export length.rlang_ctxt_pronoun <- function(x) { 0L } #' @export print.rlang_data_pronoun <- function(x, ...) { cat_line("") invisible(x) } #' @importFrom utils str #' @export str.rlang_data_pronoun <- function(object, ...) { cat_line("") } # Used for deparsing is_data_pronoun <- function(x) { is_call(x, c("[[", "$"), n = 2L) && identical(node_cadr(x), dot_data_sym) } data_pronoun_name <- function(x) { if (is_call(x, "$")) { arg <- node_cadr(node_cdr(x)) if (is_symbol(arg)) { return(as_string(arg)) } else { return(NULL) } } if (is_call(x, "[[")) { arg <- node_cadr(node_cdr(x)) if (is_string(arg)) { return(arg) } else { return(NULL) } } } #' @export `$.rlang_fake_data_pronoun` <- function(x, nm, call = caller_env()) { stop_fake_data_subset(call) } #' @export `[[.rlang_fake_data_pronoun` <- function(x, i, ..., call = caller_env()) { stop_fake_data_subset(call) } stop_fake_data_subset <- function(call) { abort( sprintf("Can't subset %s outside of a data mask context.", format_arg(".data")), call = mask_top(call, inherit = TRUE) ) } is_data_mask <- function(x) { is_environment(x) && env_has(x, ".__rlang_data_mask__.") } mask_top <- function(env, inherit = FALSE) { top <- quo_mask_top(env, inherit = inherit) if (!identical(top, env)) { top } else { data_mask_top(env, inherit = inherit) } } data_mask_top <- function(env, recursive = FALSE, inherit = FALSE) { while (env_has(env, ".__tidyeval_data_mask__.", inherit = inherit)) { env <- env_parent(env_get(env, ".top_env", inherit = inherit)) if (!recursive) { return(env) } } env } quo_mask_top <- function(env, recursive = FALSE, inherit = FALSE) { while (env_has(env, ".__tidyeval_quosure_mask__.", inherit = inherit)) { env <- env_parent(env) if (!recursive) { return(env) } } env } rlang/R/standalone-purrr.R0000644000176200001440000001252414403561346015213 0ustar liggesusers# --- # repo: r-lib/rlang # file: standalone-purrr.R # last-updated: 2023-02-23 # license: https://unlicense.org # imports: rlang # --- # # This file provides a minimal shim to provide a purrr-like API on top of # base R functions. They are not drop-in replacements but allow a similar style # of programming. # # ## Changelog # # 2023-02-23: # * Added `list_c()` # # 2022-06-07: # * `transpose()` is now more consistent with purrr when inner names # are not congruent (#1346). # # 2021-12-15: # * `transpose()` now supports empty lists. # # 2021-05-21: # * Fixed "object `x` not found" error in `imap()` (@mgirlich) # # 2020-04-14: # * Removed `pluck*()` functions # * Removed `*_cpl()` functions # * Used `as_function()` to allow use of `~` # * Used `.` prefix for helpers # # nocov start map <- function(.x, .f, ...) { .f <- as_function(.f, env = global_env()) lapply(.x, .f, ...) } walk <- function(.x, .f, ...) { map(.x, .f, ...) invisible(.x) } map_lgl <- function(.x, .f, ...) { .rlang_purrr_map_mold(.x, .f, logical(1), ...) } map_int <- function(.x, .f, ...) { .rlang_purrr_map_mold(.x, .f, integer(1), ...) } map_dbl <- function(.x, .f, ...) { .rlang_purrr_map_mold(.x, .f, double(1), ...) } map_chr <- function(.x, .f, ...) { .rlang_purrr_map_mold(.x, .f, character(1), ...) } .rlang_purrr_map_mold <- function(.x, .f, .mold, ...) { .f <- as_function(.f, env = global_env()) out <- vapply(.x, .f, .mold, ..., USE.NAMES = FALSE) names(out) <- names(.x) out } map2 <- function(.x, .y, .f, ...) { .f <- as_function(.f, env = global_env()) out <- mapply(.f, .x, .y, MoreArgs = list(...), SIMPLIFY = FALSE) if (length(out) == length(.x)) { set_names(out, names(.x)) } else { set_names(out, NULL) } } map2_lgl <- function(.x, .y, .f, ...) { as.vector(map2(.x, .y, .f, ...), "logical") } map2_int <- function(.x, .y, .f, ...) { as.vector(map2(.x, .y, .f, ...), "integer") } map2_dbl <- function(.x, .y, .f, ...) { as.vector(map2(.x, .y, .f, ...), "double") } map2_chr <- function(.x, .y, .f, ...) { as.vector(map2(.x, .y, .f, ...), "character") } imap <- function(.x, .f, ...) { map2(.x, names(.x) %||% seq_along(.x), .f, ...) } pmap <- function(.l, .f, ...) { .f <- as.function(.f) args <- .rlang_purrr_args_recycle(.l) do.call("mapply", c( FUN = list(quote(.f)), args, MoreArgs = quote(list(...)), SIMPLIFY = FALSE, USE.NAMES = FALSE )) } .rlang_purrr_args_recycle <- function(args) { lengths <- map_int(args, length) n <- max(lengths) stopifnot(all(lengths == 1L | lengths == n)) to_recycle <- lengths == 1L args[to_recycle] <- map(args[to_recycle], function(x) rep.int(x, n)) args } keep <- function(.x, .f, ...) { .x[.rlang_purrr_probe(.x, .f, ...)] } discard <- function(.x, .p, ...) { sel <- .rlang_purrr_probe(.x, .p, ...) .x[is.na(sel) | !sel] } map_if <- function(.x, .p, .f, ...) { matches <- .rlang_purrr_probe(.x, .p) .x[matches] <- map(.x[matches], .f, ...) .x } .rlang_purrr_probe <- function(.x, .p, ...) { if (is_logical(.p)) { stopifnot(length(.p) == length(.x)) .p } else { .p <- as_function(.p, env = global_env()) map_lgl(.x, .p, ...) } } compact <- function(.x) { Filter(length, .x) } transpose <- function(.l) { if (!length(.l)) { return(.l) } inner_names <- names(.l[[1]]) if (is.null(inner_names)) { fields <- seq_along(.l[[1]]) } else { fields <- set_names(inner_names) .l <- map(.l, function(x) { if (is.null(names(x))) { set_names(x, inner_names) } else { x } }) } # This way missing fields are subsetted as `NULL` instead of causing # an error .l <- map(.l, as.list) map(fields, function(i) { map(.l, .subset2, i) }) } every <- function(.x, .p, ...) { .p <- as_function(.p, env = global_env()) for (i in seq_along(.x)) { if (!rlang::is_true(.p(.x[[i]], ...))) return(FALSE) } TRUE } some <- function(.x, .p, ...) { .p <- as_function(.p, env = global_env()) for (i in seq_along(.x)) { if (rlang::is_true(.p(.x[[i]], ...))) return(TRUE) } FALSE } negate <- function(.p) { .p <- as_function(.p, env = global_env()) function(...) !.p(...) } reduce <- function(.x, .f, ..., .init) { f <- function(x, y) .f(x, y, ...) Reduce(f, .x, init = .init) } reduce_right <- function(.x, .f, ..., .init) { f <- function(x, y) .f(y, x, ...) Reduce(f, .x, init = .init, right = TRUE) } accumulate <- function(.x, .f, ..., .init) { f <- function(x, y) .f(x, y, ...) Reduce(f, .x, init = .init, accumulate = TRUE) } accumulate_right <- function(.x, .f, ..., .init) { f <- function(x, y) .f(y, x, ...) Reduce(f, .x, init = .init, right = TRUE, accumulate = TRUE) } detect <- function(.x, .f, ..., .right = FALSE, .p = is_true) { .p <- as_function(.p, env = global_env()) .f <- as_function(.f, env = global_env()) for (i in .rlang_purrr_index(.x, .right)) { if (.p(.f(.x[[i]], ...))) { return(.x[[i]]) } } NULL } detect_index <- function(.x, .f, ..., .right = FALSE, .p = is_true) { .p <- as_function(.p, env = global_env()) .f <- as_function(.f, env = global_env()) for (i in .rlang_purrr_index(.x, .right)) { if (.p(.f(.x[[i]], ...))) { return(i) } } 0L } .rlang_purrr_index <- function(x, right = FALSE) { idx <- seq_along(x) if (right) { idx <- rev(idx) } idx } list_c <- function(x) { inject(c(!!!x)) } # nocov end rlang/R/weakref.R0000644000176200001440000000572514175213516013343 0ustar liggesusers#' Create a weak reference #' #' @description #' #' A weak reference is a special R object which makes it possible to keep a #' reference to an object without preventing garbage collection of that object. #' It can also be used to keep data about an object without preventing GC of the #' object, similar to WeakMaps in JavaScript. #' #' Objects in R are considered _reachable_ if they can be accessed by following #' a chain of references, starting from a _root node_; root nodes are #' specially-designated R objects, and include the global environment and base #' environment. As long as the key is reachable, the value will not be garbage #' collected. This is true even if the weak reference object becomes #' unreachable. The key effectively prevents the weak reference and its value #' from being collected, according to the following chain of ownership: #' `weakref <- key -> value`. #' #' When the key becomes unreachable, the key and value in the weak reference #' object are replaced by `NULL`, and the finalizer is scheduled to execute. #' #' @param key The key for the weak reference. Must be a reference object -- that #' is, an environment or external pointer. #' @param value The value for the weak reference. This can be `NULL`, if you #' want to use the weak reference like a weak pointer. #' @param finalizer A function that is run after the key becomes unreachable. #' @param on_quit Should the finalizer be run when R exits? #' #' @keywords experimental #' @seealso [is_weakref()], [wref_key()] and [wref_value()]. #' @export #' @examples #' e <- env() #' #' # Create a weak reference to e #' w <- new_weakref(e, finalizer = function(e) message("finalized")) #' #' # Get the key object from the weak reference #' identical(wref_key(w), e) #' #' # When the regular reference (the `e` binding) is removed and a GC occurs, #' # the weak reference will not keep the object alive. #' rm(e) #' gc() #' identical(wref_key(w), NULL) #' #' #' # A weak reference with a key and value. The value contains data about the #' # key. #' k <- env() #' v <- list(1, 2, 3) #' w <- new_weakref(k, v) #' #' identical(wref_key(w), k) #' identical(wref_value(w), v) #' #' # When v is removed, the weak ref keeps it alive because k is still reachable. #' rm(v) #' gc() #' identical(wref_value(w), list(1, 2, 3)) #' #' # When k is removed, the weak ref does not keep k or v alive. #' rm(k) #' gc() #' identical(wref_key(w), NULL) #' identical(wref_value(w), NULL) new_weakref <- function(key, value = NULL, finalizer = NULL, on_quit = FALSE) { .Call(ffi_new_weakref, key, value, finalizer, on_quit) } #' Get key/value from a weak reference object #' #' @param x A weak reference object. #' #' @seealso [is_weakref()] and [new_weakref()]. #' #' @export wref_key <- function(x) { .Call(ffi_wref_key, x) } #' @rdname wref_key #' @export wref_value <- function(x) { .Call(ffi_wref_value, x) } #' Is object a weak reference? #' @param x An object to test. #' @export is_weakref <- function(x) { .Call(ffi_is_weakref, x) } rlang/R/names.R0000644000176200001440000000327214375670676013035 0ustar liggesusersnames_as_unique <- function(names, ..., quiet = FALSE) { check_dots_empty0(...) .Call(ffi_names_as_unique, names, quiet) } #' Inform about name repair #' #' @section Muffling and silencing messages: #' #' Name repair messages are signaled with [inform()] and are given the class #' `"rlib_message_name_repair"`. These messages can be muffled with #' [base::suppressMessages()]. #' #' Name repair messages can also be silenced with the global option #' `rlib_name_repair_verbosity`. This option takes the values: #' #' - `"verbose"`: Always verbose. #' - `"quiet"`: Always quiet. #' #' When set to quiet, the message is not displayed and the condition is not #' signaled. This is particularly useful for silencing messages during testing #' when combined with [local_options()]. #' #' @param old Original names vector. #' @param new Repaired names vector. #' @keywords internal #' @export names_inform_repair <- function(old, new) { if (is_null(old)) { old <- rep_along(new, "") } stopifnot( is_character(old), is_character(new), length(old) == length(new) ) if (peek_name_repair_verbosity() == "quiet") { return(invisible()) } old <- old %|% "" new_names <- new != old if (!any(new_names)) { return(invisible()) } bullets <- paste0( map_chr(old[new_names], format_var), " -> ", map_chr(new[new_names], format_var), .problem = "" ) message <- c( "New names:", set_names(bullets, "*") ) inform(message = message, class = "rlib_message_name_repair") } peek_name_repair_verbosity <- function() { opt <- "rlib_name_repair_verbosity" out <- peek_option(opt) %||% "verbose" out <- arg_match0(out, c("verbose", "quiet"), opt) out } rlang/R/cnd-entrace.R0000644000176200001440000002731314401331356014072 0ustar liggesusers#' Entrace unexpected errors #' #' @description #' `global_entrace()` enriches base errors, warnings, and messages #' with rlang features. #' #' - They are assigned a backtrace. You can configure whether to #' display a backtrace on error with the [rlang_backtrace_on_error] #' global option. #' #' - They are recorded in [last_error()], [last_warnings()], or #' [last_messages()]. You can inspect backtraces at any time by #' calling these functions. #' #' Set global entracing in your RProfile with: #' #' ``` #' rlang::global_entrace() #' ``` #' #' @param enable Whether to enable or disable global handling. #' @param class A character vector of one or several classes of #' conditions to be entraced. #' #' @section Inside RMarkdown documents: #' #' Call `global_entrace()` inside an RMarkdown document to cause #' errors and warnings to be promoted to rlang conditions that include #' a backtrace. This needs to be done in a separate setup chunk before #' the first error or warning. #' #' This is useful in conjunction with #' [`rlang_backtrace_on_error_report`] and #' [`rlang_backtrace_on_warning_report`]. To get full entracing in an #' Rmd document, include this in a setup chunk before the first error #' or warning is signalled. #' #' ```` #' ```{r setup} #' rlang::global_entrace() #' options(rlang_backtrace_on_warning_report = "full") #' options(rlang_backtrace_on_error_report = "full") #' ``` #' ```` #' #' @section Under the hood: #' On R 4.0 and newer, `global_entrace()` installs a global handler #' with `globalCallingHandlers()`. On older R versions, `entrace()` is #' set as an `option(error = )` handler. The latter method has the #' disadvantage that only one handler can be set at a time. This means #' that you need to manually switch between `entrace()` and other #' handlers like [recover()]. Also this causes a conflict with IDE #' handlers (e.g. in RStudio). #' @export global_entrace <- function(enable = TRUE, class = c("error", "warning", "message")) { check_bool(enable) class <- arg_match(class, multiple = TRUE) if (getRversion() < "4.0" && !knitr_in_progress()) { return(global_entrace_fallback(enable, class)) } handlers <- rep_named(class, list(hnd_entrace)) poke_global_handlers(enable, !!!handlers) invisible(NULL) } global_entrace_fallback <- function(enable, class) { if (!"error" %in% class) { return(invisible(NULL)) } if (enable) { options(error = entrace) } else { opt <- peek_option("error") if (identical(opt, entrace)) { options(error = NULL) } } invisible(NULL) } # Keep `rlang::` indirection in case rlang is reloaded. This way the # global handlers can be set once in RProfile and they will always # call into the most recently loaded version. hnd_entrace <- function(cnd) rlang::entrace(cnd) # Set to `base_env()` to avoid duplicate handlers in case of # reload. This makes `global_entrace()` idempotent. Requires # https://bugs.r-project.org/show_bug.cgi?id=18197 environment(hnd_entrace) <- baseenv() #' Add backtrace from error handler #' #' @keywords internal #' @description #' `entrace()` is a low level function. See [global_entrace()] for a #' user-friendly way of enriching errors and other conditions from #' your RProfile. #' #' * `entrace()` is meant to be used as a global handler. It enriches #' conditions with a backtrace. Errors are saved to [last_error()] #' and rethrown immediately. Messages and warnings are recorded into #' [last_messages()] and [last_warnings()] and let through. #' #' * `cnd_entrace()` adds a backtrace to a condition object, without #' any other effect. It should be called from a condition handler. #' #' `entrace()` also works as an `option(error = )` handler for #' compatibility with versions of R older than 4.0. #' #' When used as calling handler, rlang trims the handler invokation #' context from the backtrace. #' #' @inheritParams trace_back #' @param cnd When `entrace()` is used as a calling handler, `cnd` is #' the condition to handle. #' @param ... Unused. These dots are for future extensions. #' #' @seealso [global_entrace()] for configuring errors with #' `entrace()`. [cnd_entrace()] to manually add a backtrace to a #' condition. #' @examples #' quote({ # Not run #' #' # Set `entrace()` globally in your RProfile #' globalCallingHandlers(error = rlang::entrace) #' #' # On older R versions which don't feature `globalCallingHandlers`, #' # set the error handler like this: #' options(error = rlang::entrace) #' #' }) #' @keywords internal #' @export entrace <- function(cnd, ..., top = NULL, bottom = NULL) { check_dots_empty0(...) if (!missing(cnd) && inherits(cnd, "rlang_error")) { poke_last_error(cnd) return() } if (is_null(bottom)) { if (missing(cnd)) { bottom <- current_env() } else { bottom <- caller_env() } } # Remove handler invokation context from the trace if (is_environment(bottom)) { nframe <- eval_bare(quote(base::sys.nframe()), bottom) - 1 info <- signal_context_info(nframe) bottom <- sys.frame(info[[2]]) } if (!has_new_cmd_frame() && the$n_conditions >= max_entracing()) { trace <- NULL } else { trace <- trace_back(top = top, bottom = bottom) } # `options(error = )` case if (missing(cnd)) { return(entrace_handle_top(trace)) } # Log warnings if (is_warning(cnd)) { wrn <- as_rlang_warning(cnd, trace) push_warning(wrn) # Resignal enriched warning if (!is_null(findRestart("muffleWarning"))) { if (identical(peek_option("warn"), 2L)) { return() } else { warning(wrn) invokeRestart("muffleWarning") } } else { return() } } # Log messages if (is_message(cnd)) { push_message(as_rlang_message(cnd, trace)) return() } # Rethrow errors if (is_error(cnd)) { if (has_recover()) { return() } entraced <- error_cnd( message = conditionMessage(cnd) %||% "", call = conditionCall(cnd), error = cnd, trace = trace, use_cli_format = FALSE ) poke_last_error(entraced) cnd_signal(entraced) } # Ignore other condition types NULL } max_entracing <- function() { peek_option("rlang:::max_entracing") %||% 20 } has_recover <- function() { handler_call <- peek_option("error") if (!is_call(handler_call)) { return(FALSE) } if (is_call(handler_call, "recover", ns = c("", "base"))) { return(TRUE) } identical(handler_call[[1]], utils::recover) } #' @rdname entrace #' @export cnd_entrace <- function(cnd, ..., top = NULL, bottom = NULL) { check_dots_empty0(...) if (cnd_some(cnd, function(x) !is_null(x[["trace"]]))) { return(cnd) } if (is_null(bottom)) { nframe <- sys.parent() - 1 info <- signal_context_info(nframe) bottom <- sys.frame(info[[2]]) } cnd$trace <- trace_back(top = top, bottom = bottom) cnd } #' Return information about signalling context #' #' @param nframe The depth of the frame to inspect. In a condition #' handler, this would typically be `sys.nframe() - 1L`. #' #' @return A named list of two elements `type` and `depth`. The depth #' is the call frame number of the signalling context. The type is #' one of: #' #' * `"unknown"` #' * `"stop_message"` for errors thrown with `base::stop("message")" #' * `"stop_condition"` for errors thrown with `base::stop(cnd_object)` #' * `"stop_native"` for errors thrown from C #' * `"stop_rlang"` for errors thrown with `rlang::abort()` #' * `"warning_message"` for warnings signalled with `base::warning("message")" #' * `"warning_condition"` for warnings signalled with `base::warning(cnd_object)` #' * `"warning_native"` for warnings signalled from C #' * `"warning_promoted"` for warnings promoted to errors with `getOption("warn")` #' * `"warning_rlang"` for warnings signalled with `rlang::warn()` #' * `"message"` for messages signalled with `base::message()` #' * `"message_rlang"` for messages signalled with `rlang::inform()` #' * `"condition"` for conditions signalled with `base::signalCondition()` #' #' @keywords internal #' @noRd signal_context_info <- function(nframe) { first <- sys_body(nframe) if (identical(first, body(.handleSimpleError))) { if (identical(sys_body(nframe - 1), body(stop))) { return(list(type = "stop_message", depth = nframe - 2)) } else if (identical(sys_body(nframe - 4), body(.signalSimpleWarning))) { return(list(type = "warning_promoted", depth = nframe - 6)) } else { return(list(type = "stop_native", depth = nframe - 1)) } } if (identical(first, body(stop))) { if (identical(sys_body(nframe - 1), body(abort))) { return(list(type = "stop_rlang", depth = nframe - 2)) } else { return(list(type = "stop_condition", depth = nframe - 1)) } } if (identical(first, body(signalCondition))) { from_restarts <- from_withrestarts(nframe - 1) signal_body <- sys_body(nframe - 4) if (from_restarts && identical(signal_body, body(message))) { return(list(type = "message", depth = nframe - 5)) } else if (from_restarts && identical(signal_body, body(inform))) { return(list(type = "message_rlang", depth = nframe - 5)) } else { return(list(type = "condition", depth = nframe - 1)) } } if (from_withrestarts(nframe)) { withrestarts_caller <- sys_body(nframe - 3) if (identical(withrestarts_caller, body(.signalSimpleWarning))) { if (identical(sys_body(nframe - 4), body(warning))) { return(list(type = "warning_message", depth = nframe - 5)) } else { return(list(type = "warning_native", depth = nframe - 4)) } } else if (identical(withrestarts_caller, body(warning))) { if (identical(sys_body(nframe - 4), body(warn))) { return(list(type = "warning_rlang", depth = nframe - 5)) } else { return(list(type = "warning_condition", depth = nframe - 4)) } } } list(type = "unknown", depth = nframe) } from_withrestarts <- function(nframe) { is_call(sys.call(nframe), "doWithOneRestart") && identical(sys_body(nframe - 2), body(withRestarts)) } sys_body <- function(n) { body(sys.function(n)) } entrace_handle_top <- function(trace) { # Happens with ctrl-c at top-level if (!trace_length(trace)) { return(entrace_exit()) } stop_call <- sys.call(-2) stop_frame <- sys.frame(-2) cnd <- stop_frame$cond # False for errors thrown from the C side from_stop <- is_call(stop_call, "stop", ns = c("", "base")) # No need to do anything for rlang errors if (from_stop && (is_trace(cnd$trace) || is_true(cnd$rlang$internal$entraced))) { return(entrace_exit()) } if (from_stop) { if (is_null(cnd)) { msg_call <- quote(.makeMessage(..., domain = domain)) msg <- eval_bare(msg_call, stop_frame) } else { msg <- cnd$message } } else { # `geterrmessage()` returns the full error message including # prefix and newline, which we strip here msg <- geterrmessage() msg <- sub("^.*: ?", "", msg) msg <- sub("\n$", "", msg) } # Save a fake rlang error containing the backtrace err <- error_cnd(message = msg, error = cnd, trace = trace, parent = cnd) poke_last_error(err) # Print backtrace for current error backtrace_lines <- format_onerror_backtrace(err) if (length(backtrace_lines)) { cat_line(backtrace_lines) } entrace_exit() } entrace_exit <- function() { # Disable error handler in non-interactive sessions to force # non-zero exit (#1052, rstudio/bookdown#920) if (!is_interactive()) { options(error = NULL) } NULL } add_backtrace <- function() { # Warnings don't go through when error is being handled msg <- "Warning: `add_backtrace()` is now exported as `entrace()` as of rlang 0.3.1" cat_line(msg, file = stderr()) entrace(bottom = sys.frame(-1)) } rlang/R/state.R0000644000176200001440000001077114401331356013027 0ustar liggesusers#' Change global options #' #' @description #' #' * `local_options()` changes options for the duration of a stack #' frame (by default the current one). Options are set back to their #' old values when the frame returns. #' #' * `with_options()` changes options while an expression is #' evaluated. Options are restored when the expression returns. #' #' * `push_options()` adds or changes options permanently. #' #' * `peek_option()` and `peek_options()` return option values. The #' former returns the option directly while the latter returns a #' list. #' #' #' @section Life cycle: #' #' These functions are experimental. #' #' @param ... For `local_options()` and `push_options()`, named #' values defining new option values. For `peek_options()`, strings #' or character vectors of option names. #' @param .frame The environment of a stack frame which defines the #' scope of the temporary options. When the frame returns, the #' options are set back to their original values. #' @return For `local_options()` and `push_options()`, the old option #' values. `peek_option()` returns the current value of an option #' while the plural `peek_options()` returns a list of current #' option values. #' #' @keywords experimental #' @export #' @examples #' # Store and retrieve a global option: #' push_options(my_option = 10) #' peek_option("my_option") #' #' # Change the option temporarily: #' with_options(my_option = 100, peek_option("my_option")) #' peek_option("my_option") #' #' # The scoped variant is useful within functions: #' fn <- function() { #' local_options(my_option = 100) #' peek_option("my_option") #' } #' fn() #' peek_option("my_option") #' #' # The plural peek returns a named list: #' peek_options("my_option") #' peek_options("my_option", "digits") local_options <- function(..., .frame = caller_env()) { options <- list2(...) stopifnot(is_named(options)) old <- options(options) defer(options(old), envir = .frame) invisible(old) } #' @rdname local_options #' @param .expr An expression to evaluate with temporary options. #' @export with_options <- function(.expr, ...) { local_options(...) .expr } #' @rdname local_options #' @export push_options <- function(...) { options(list2(...)) } #' @rdname local_options #' @export peek_options <- function(...) { names <- set_names(chr(...)) map(names, getOption) } #' @rdname local_options #' @param name An option name as string. #' @export peek_option <- function(name) { getOption(name) } #' Is R running interactively? #' #' @description #' #' Like [base::interactive()], `is_interactive()` returns `TRUE` when #' the function runs interactively and `FALSE` when it runs in batch #' mode. It also checks, in this order: #' #' * The `rlang_interactive` global option. If set to a single `TRUE` #' or `FALSE`, `is_interactive()` returns that value immediately. This #' escape hatch is useful in unit tests or to manually turn on #' interactive features in RMarkdown outputs. #' #' * Whether knitr or testthat is in progress, in which case #' `is_interactive()` returns `FALSE`. #' #' `with_interactive()` and `local_interactive()` set the global #' option conveniently. #' #' @export is_interactive <- function() { opt <- peek_option("rlang_interactive") if (!is_null(opt)) { if (!is_bool(opt)) { options(rlang_interactive = NULL) check_bool(opt, arg = "rlang_interactive") } return(opt) } if (is_true(peek_option("knitr.in.progress"))) { return(FALSE) } if (identical(Sys.getenv("TESTTHAT"), "true")) { return(FALSE) } interactive() } #' @rdname is_interactive #' @param frame The environment of a running function which defines #' the scope of the temporary options. When the function returns, #' the options are reset to their original values. #' @param value A single `TRUE` or `FALSE`. This overrides the return #' value of `is_interactive()`. #' @export local_interactive <- function(value = TRUE, frame = caller_env()) { local_options(rlang_interactive = value, .frame = frame) } #' @rdname is_interactive #' @param expr An expression to evaluate with interactivity set to #' `value`. #' @export with_interactive <- function(expr, value = TRUE) { local_interactive(value) expr } report_in_progress <- function() { if (knitr_in_progress()) { return(TRUE) } if (is_true(peek_option("rstudio.notebook.executing"))) { return(TRUE) } FALSE } knitr_in_progress <- function() { is_true(peek_option("knitr.in.progress")) } peek_srcref <- function() { .Call(ffi_peek_srcref) } rlang/R/sym.R0000644000176200001440000001104414375670676012536 0ustar liggesusers#' Create a symbol or list of symbols #' #' @description #' #' Symbols are a kind of [defused expression][topic-defuse] that #' represent objects in environments. #' #' * `sym()` and `syms()` take strings as input and turn them into #' symbols. #' #' * `data_sym()` and `data_syms()` create calls of the form #' `.data$foo` instead of symbols. Subsetting the [`.data`] pronoun #' is more robust when you expect a data-variable. See #' `r link("topic_data_mask_ambiguity")`. #' #' Only tidy eval APIs support the [`.data`] pronoun. With base R #' functions, use simple symbols created with `sym()` or `syms()`. #' #' @param x For `sym()` and `data_sym()`, a string. For `syms()` and #' `data_syms()`, a list of strings. #' @return For `sym()` and `syms()`, a symbol or list of symbols. For #' `data_sym()` and `data_syms()`, calls of the form `.data$foo`. #' #' @seealso #' - `r link("topic_defuse")` #' - `r link("topic_metaprogramming")` #' #' @examples #' # Create a symbol #' sym("cyl") #' #' # Create a list of symbols #' syms(c("cyl", "am")) #' #' # Symbolised names refer to variables #' eval(sym("cyl"), mtcars) #' #' # Beware of scoping issues #' Cyl <- "wrong" #' eval(sym("Cyl"), mtcars) #' #' # Data symbols are explicitly scoped in the data mask #' try(eval_tidy(data_sym("Cyl"), mtcars)) #' #' # These can only be used with tidy eval functions #' try(eval(data_sym("Cyl"), mtcars)) #' #' # The empty string returns the missing argument: #' sym("") #' #' # This way sym() and as_string() are inverse of each other: #' as_string(missing_arg()) #' sym(as_string(missing_arg())) #' #' @export sym <- function(x) { if (is_symbol(x)) { return(x) } if (identical(x, "")) { return(missing_arg()) } if (!is_string(x)) { abort_coercion(x, "a symbol") } .Call(ffi_symbol, x) } #' @rdname sym #' @export syms <- function(x) { map(x, sym) } #' @rdname sym #' @export data_sym <- function(x) { call("$", quote(.data), sym(x)) } #' @rdname sym #' @export data_syms <- function(x) { map(x, data_sym) } #' Is object a symbol? #' @param x An object to test. #' @param name An optional name or vector of names that the symbol #' should match. #' @export is_symbol <- function(x, name = NULL) { if (typeof(x) != "symbol") { return(FALSE) } if (is_null(name)) { return(TRUE) } as_string(x) %in% name } #' Cast symbol to string #' #' `as_string()` converts [symbols][sym] to character strings. #' #' @param x A string or symbol. If a string, the attributes are #' removed, if any. #' @return A character vector of length 1. #' #' @section Unicode tags: #' #' Unlike [base::as.symbol()] and [base::as.name()], `as_string()` #' automatically transforms unicode tags such as `""` to the #' proper UTF-8 character. This is important on Windows because: #' #' * R on Windows has no UTF-8 support, and uses native encoding instead. #' #' * The native encodings do not cover all Unicode characters. For #' example, Western encodings do not support CKJ characters. #' #' * When a lossy UTF-8 -> native transformation occurs, uncovered #' characters are transformed to an ASCII unicode tag like `""`. #' #' * Symbols are always encoded in native. This means that #' transforming the column names of a data frame to symbols might be #' a lossy operation. #' #' * This operation is very common in the tidyverse because of data #' masking APIs like dplyr where data frames are transformed to #' environments. While the names of a data frame are stored as a #' character vector, the bindings of environments are stored as #' symbols. #' #' Because it reencodes the ASCII unicode tags to their UTF-8 #' representation, the string -> symbol -> string roundtrip is #' more stable with `as_string()`. #' #' @seealso [as_name()] for a higher-level variant of `as_string()` #' that automatically unwraps quosures. #' @examples #' # Let's create some symbols: #' foo <- quote(foo) #' bar <- sym("bar") #' #' # as_string() converts symbols to strings: #' foo #' as_string(foo) #' #' typeof(bar) #' typeof(as_string(bar)) #' @export as_string <- function(x) { if (is_string(x)) { attributes(x) <- NULL return(x) } if (is_symbol(x)) { return(.Call(ffi_sym_as_character, x)) } abort_coercion(x, "a string") } namespace_sym <- quote(`::`) namespace2_sym <- quote(`:::`) dollar_sym <- quote(`$`) dot_data_sym <- quote(.data) dots_sym <- quote(...) at_sym <- quote(`@`) tilde_sym <- quote(`~`) colon_equals_sym <- quote(`:=`) brace_sym <- quote(`{`) dots_sym <- quote(...) function_sym <- quote(`function`) dot_sym <- quote(.) pipe_sym <- quote(`%>%`) rlang/R/vec-na.R0000644000176200001440000000751614375670676013110 0ustar liggesusers#' Missing values #' #' @description #' #' `r lifecycle::badge("questioning")` #' #' Missing values are represented in R with the general symbol #' `NA`. They can be inserted in almost all data containers: all #' atomic vectors except raw vectors can contain missing values. To #' achieve this, R automatically converts the general `NA` symbol to a #' typed missing value appropriate for the target vector. The objects #' provided here are aliases for those typed `NA` objects. #' #' #' @details #' #' Typed missing values are necessary because R needs sentinel values #' of the same type (i.e. the same machine representation of the data) #' as the containers into which they are inserted. The official typed #' missing values are `NA_integer_`, `NA_real_`, `NA_character_` and #' `NA_complex_`. The missing value for logical vectors is simply the #' default `NA`. The aliases provided in rlang are consistently named #' and thus simpler to remember. Also, `na_lgl` is provided as an #' alias to `NA` that makes intent clearer. #' #' Since `na_lgl` is the default `NA`, expressions such as `c(NA, NA)` #' yield logical vectors as no data is available to give a clue of the #' target type. In the same way, since lists and environments can #' contain any types, expressions like `list(NA)` store a logical #' `NA`. #' #' #' @section Life cycle: #' #' These shortcuts might be moved to the vctrs package at some #' point. This is why they are marked as questioning. #' #' @keywords internal #' @examples #' typeof(NA) #' typeof(na_lgl) #' typeof(na_int) #' #' # Note that while the base R missing symbols cannot be overwritten, #' # that's not the case for rlang's aliases: #' na_dbl <- NA #' typeof(na_dbl) #' @name missing NULL #' @rdname missing #' @export na_lgl <- NA #' @rdname missing #' @export na_int <- NA_integer_ #' @rdname missing #' @export na_dbl <- NA_real_ #' @rdname missing #' @export na_chr <- NA_character_ #' @rdname missing #' @export na_cpl <- NA_complex_ #' Test for missing values #' #' @description #' #' `r lifecycle::badge("questioning")` #' #' `are_na()` checks for missing values in a vector and is equivalent #' to [base::is.na()]. It is a vectorised predicate, meaning that its #' output is always the same length as its input. On the other hand, #' `is_na()` is a scalar predicate and always returns a scalar #' boolean, `TRUE` or `FALSE`. If its input is not scalar, it returns #' `FALSE`. Finally, there are typed versions that check for #' particular [missing types][missing]. #' #' #' @details #' #' The scalar predicates accept non-vector inputs. They are equivalent #' to [is_null()] in that respect. In contrast the vectorised #' predicate `are_na()` requires a vector input since it is defined #' over vector values. #' #' @param x An object to test #' #' @section Life cycle: #' #' These functions might be moved to the vctrs package at some #' point. This is why they are marked as questioning. #' #' @keywords internal #' @examples #' # are_na() is vectorised and works regardless of the type #' are_na(c(1, 2, NA)) #' are_na(c(1L, NA, 3L)) #' #' # is_na() checks for scalar input and works for all types #' is_na(NA) #' is_na(na_dbl) #' is_na(character(0)) #' #' # There are typed versions as well: #' is_lgl_na(NA) #' is_lgl_na(na_dbl) #' @export are_na <- function(x) { if (!is_atomic(x)) { stop_input_type(x, "an atomic vector") } is.na(x) } #' @rdname are_na #' @export is_na <- function(x) { is_scalar_vector(x) && is.na(x) } detect_na <- are_na #' @rdname are_na #' @export is_lgl_na <- function(x) { identical(x, na_lgl) } #' @rdname are_na #' @export is_int_na <- function(x) { identical(x, na_int) } #' @rdname are_na #' @export is_dbl_na <- function(x) { identical(x, na_dbl) } #' @rdname are_na #' @export is_chr_na <- function(x) { identical(x, na_chr) } #' @rdname are_na #' @export is_cpl_na <- function(x) { identical(x, na_cpl) } rlang/R/eval.R0000644000176200001440000001631314657222001012633 0ustar liggesusers#' Evaluate an expression in an environment #' #' @description #' `eval_bare()` is a lower-level version of function [base::eval()]. #' Technically, it is a simple wrapper around the C function #' `Rf_eval()`. You generally don't need to use `eval_bare()` instead #' of `eval()`. Its main advantage is that it handles stack-sensitive #' calls (such as `return()`, `on.exit()` or `parent.frame()`) more #' consistently when you pass an enviroment of a frame on the call #' stack. #' #' @details #' #' These semantics are possible because `eval_bare()` creates only one #' frame on the call stack whereas `eval()` creates two frames, the #' second of which has the user-supplied environment as frame #' environment. When you supply an existing frame environment to #' `base::eval()` there will be two frames on the stack with the same #' frame environment. Stack-sensitive functions only detect the #' topmost of these frames. We call these evaluation semantics #' "stack inconsistent". #' #' Evaluating expressions in the actual frame environment has useful #' practical implications for `eval_bare()`: #' #' * `return()` calls are evaluated in frame environments that might #' be burried deep in the call stack. This causes a long return that #' unwinds multiple frames (triggering the `on.exit()` event for #' each frame). By contrast `eval()` only returns from the `eval()` #' call, one level up. #' #' * `on.exit()`, `parent.frame()`, `sys.call()`, and generally all #' the stack inspection functions `sys.xxx()` are evaluated in the #' correct frame environment. This is similar to how this type of #' calls can be evaluated deep in the call stack because of lazy #' evaluation, when you force an argument that has been passed #' around several times. #' #' The flip side of the semantics of `eval_bare()` is that it can't #' evaluate `break` or `next` expressions even if called within a #' loop. #' #' #' @param expr An expression to evaluate. #' @param env The environment in which to evaluate the expression. #' #' @seealso [eval_tidy()] for evaluation with data mask and quosure #' support. #' @export #' @examples #' # eval_bare() works just like base::eval() but you have to create #' # the evaluation environment yourself: #' eval_bare(quote(foo), env(foo = "bar")) #' #' # eval() has different evaluation semantics than eval_bare(). It #' # can return from the supplied environment even if its an #' # environment that is not on the call stack (i.e. because you've #' # created it yourself). The following would trigger an error with #' # eval_bare(): #' ret <- quote(return("foo")) #' eval(ret, env()) #' # eval_bare(ret, env()) # "no function to return from" error #' #' # Another feature of eval() is that you can control surround loops: #' bail <- quote(break) #' while (TRUE) { #' eval(bail) #' # eval_bare(bail) # "no loop for break/next" error #' } #' #' # To explore the consequences of stack inconsistent semantics, let's #' # create a function that evaluates `parent.frame()` deep in the call #' # stack, in an environment corresponding to a frame in the middle of #' # the stack. For consistency with R's lazy evaluation semantics, we'd #' # expect to get the caller of that frame as result: #' fn <- function(eval_fn) { #' list( #' returned_env = middle(eval_fn), #' actual_env = current_env() #' ) #' } #' middle <- function(eval_fn) { #' deep(eval_fn, current_env()) #' } #' deep <- function(eval_fn, eval_env) { #' expr <- quote(parent.frame()) #' eval_fn(expr, eval_env) #' } #' #' # With eval_bare(), we do get the expected environment: #' fn(rlang::eval_bare) #' #' # But that's not the case with base::eval(): #' fn(base::eval) eval_bare <- function(expr, env = parent.frame()) { .External2(ffi_eval, expr, env) } eval_top <- function(expr, env = caller_env()) { .Call(ffi_eval_top, expr, env) } #' Execute a function #' #' @description #' #' This function constructs and evaluates a call to `.fn`. #' It has two primary uses: #' #' * To call a function with arguments stored in a list (if the #' function doesn't support [dynamic dots][dyn-dots]). Splice the #' list of arguments with `!!!`. #' #' * To call every function stored in a list (in conjunction with `map()`/ #' [lapply()]) #' #' @param .fn A function, or function name as a string. #' @param ... <[dynamic][dyn-dots]> Arguments for `.fn`. #' @param .env Environment in which to evaluate the call. This will be #' most useful if `.fn` is a string, or the function has side-effects. #' @export #' @examples #' args <- list(x = c(1:10, 100, NA), na.rm = TRUE) #' exec("mean", !!!args) #' exec("mean", !!!args, trim = 0.2) #' #' fs <- list(a = function() "a", b = function() "b") #' lapply(fs, exec) #' #' # Compare to do.call it will not automatically inline expressions #' # into the evaluated call. #' x <- 10 #' args <- exprs(x1 = x + 1, x2 = x * 2) #' exec(list, !!!args) #' do.call(list, args) #' #' # exec() is not designed to generate pretty function calls. This is #' # most easily seen if you call a function that captures the call: #' f <- disp ~ cyl #' exec("lm", f, data = mtcars) #' #' # If you need finer control over the generated call, you'll need to #' # construct it yourself. This may require creating a new environment #' # with carefully constructed bindings #' data_env <- env(data = mtcars) #' eval(expr(lm(!!f, data)), data_env) exec <- function(.fn, ..., .env = caller_env()) { .External2(ffi_exec, .fn, .env) } #' Inject objects in an R expression #' #' @description #' #' `inject()` evaluates an expression with [injection][quasiquotation] #' support. There are three main usages: #' #' - [Splicing][!!!] lists of arguments in a function call. #' #' - Inline objects or other expressions in an expression with `!!` #' and `!!!`. For instance to create functions or formulas #' programmatically. #' #' - Pass arguments to NSE functions that [defuse][nse-defuse] their #' arguments without injection support (see for instance #' [enquo0()]). You can use `{{ arg }}` with functions documented #' to support quosures. Otherwise, use `!!enexpr(arg)`. #' #' @param expr An argument to evaluate. This argument is immediately #' evaluated in `env` (the current environment by default) with #' injected objects and expressions. #' @param env The environment in which to evaluate `expr`. Defaults to #' the current environment. For expert use only. #' #' @export #' @examples #' # inject() simply evaluates its argument with injection #' # support. These expressions are equivalent: #' 2 * 3 #' inject(2 * 3) #' inject(!!2 * !!3) #' #' # Injection with `!!` can be useful to insert objects or #' # expressions within other expressions, like formulas: #' lhs <- sym("foo") #' rhs <- sym("bar") #' inject(!!lhs ~ !!rhs + 10) #' #' # Injection with `!!!` splices lists of arguments in function #' # calls: #' args <- list(na.rm = TRUE, finite = 0.2) #' inject(mean(1:10, !!!args)) inject <- function(expr, env = caller_env()) { .External2(ffi_eval, enexpr(expr), env) } eval_parse <- function(code, env = caller_env()) { file <- tempfile("rlang_eval_parsed_", fileext = ".R") on.exit(if (file.exists(file)) file.remove(file)) writeLines(code, file) exprs <- parse(file, keep.source = TRUE) out <- NULL for (expr in exprs) { out <- eval_bare(expr, env) } out } rlang/R/standalone-lifecycle.R0000644000176200001440000001464114741441060015775 0ustar liggesusers# --- # repo: r-lib/rlang # file: standalone-lifecycle.R # last-updated: 2023-02-23 # license: https://unlicense.org # imports: rlang (>= 1.0.0) # --- # # This file serves as a reference for currently unexported rlang # lifecycle functions. These functions require rlang in your `Imports` # DESCRIPTION field but you don't need to import rlang in your # namespace. # # ## Changelog # # 2023-02-23 # # - Updated the API and internals to match modern lifecycle tools. # # # 2021-04-19 # # - Removed `lifecycle()` function. You can now use the following in # your roxygen documentation to inline a badge: # # ``` # `r lifecycle::badge()` # ``` # # This is a build-time dependency on lifecycle so there is no need # to add lifecycle to Imports just to use badges. See also # `?usethis::use_lifecycle()` for importing or updating the badge # images in your package. # # - Soft-namespaced private objects. # # nocov start #' Signal deprecation #' #' @description #' These functions provide two levels of verbosity for deprecation #' warnings. #' #' * `deprecate_soft()` warns only if called directly: from the global #' environment (so the user can change their script) or from the #' package currently being tested (so the package developer can fix #' the package). #' #' * `deprecate_warn()` warns unconditionally. #' #' * `deprecate_stop()` fails unconditionally. #' #' Both functions warn only once per session by default to avoid #' overwhelming the user with repeated warnings. #' #' @param msg The deprecation message. #' @param id The id of the deprecation. A warning is issued only once #' for each `id`. Defaults to `msg`, but you should give a unique ID #' when the message is built programmatically and depends on inputs. #' @param user_env The environment in which the deprecated function #' was called. The verbosity depends on whether the deprecated #' feature was called directly, see [rlang::env_is_user_facing()] and the #' documentation in the lifecycle package. #' #' @section Controlling verbosity: #' #' The verbosity of retirement warnings can be controlled with global #' options. You'll generally want to set these options locally with #' one of these helpers: #' #' * `with_lifecycle_silence()` disables all soft-deprecation and #' deprecation warnings. #' #' * `with_lifecycle_warnings()` enforces warnings for both #' soft-deprecated and deprecated functions. The warnings are #' repeated rather than signalled once per session. #' #' * `with_lifecycle_errors()` enforces errors for both #' soft-deprecated and deprecated functions. #' #' All the `with_` helpers have `scoped_` variants that are #' particularly useful in testthat blocks. #' #' @noRd NULL deprecate_soft <- function(msg, id = msg, user_env = rlang::caller_env(2)) { .rlang_lifecycle_signal_stage(msg, "deprecated") id <- paste(id, collapse = "\n") verbosity <- .rlang_lifecycle_verbosity() invisible(switch( verbosity, quiet = NULL, warning = , default = if (rlang::env_is_user_facing(user_env)) { always <- verbosity == "warning" trace <- rlang::trace_back(bottom = caller_env()) .rlang_lifecycle_deprecate_warn0( msg, id = id, trace = trace, always = always ) }, error = deprecate_stop(msg) )) } deprecate_warn <- function(msg, id = msg, always = FALSE, user_env = rlang::caller_env(2)) { .rlang_lifecycle_signal_stage(msg, "deprecated") id <- paste(id, collapse = "\n") verbosity <- .rlang_lifecycle_verbosity() invisible(switch( verbosity, quiet = NULL, warning = , default = { direct <- rlang::env_is_user_facing(user_env) always <- direct && (always || verbosity == "warning") trace <- tryCatch( rlang::trace_back(bottom = rlang::caller_env()), error = function(...) NULL ) .rlang_lifecycle_deprecate_warn0( msg, id = id, trace = trace, always = always ) }, error = deprecate_stop(msg), )) } .rlang_lifecycle_deprecate_warn0 <- function(msg, id = msg, trace = NULL, always = FALSE, call = rlang::caller_env()) { if (always) { freq <- "always" } else { freq <- "regularly" } rlang::warn( msg, class = "lifecycle_warning_deprecated", .frequency = freq, .frequency_id = id ) } deprecate_stop <- function(msg) { msg <- cli::format_error(msg) .rlang_lifecycle_signal_stage(msg, "deprecated") stop(rlang::cnd( c("defunctError", "error", "condition"), old = NULL, new = NULL, package = NULL, message = msg )) } .rlang_lifecycle_signal_stage <- function(msg, stage) { rlang::signal(msg, "lifecycle_stage", stage = stage) } expect_deprecated <- function(expr, regexp = NULL, ...) { rlang::local_options(lifecycle_verbosity = "warning") if (!is.null(regexp) && rlang::is_na(regexp)) { rlang::abort("`regexp` can't be `NA`.") } testthat::expect_warning( {{ expr }}, regexp = regexp, class = "lifecycle_warning_deprecated", ... ) } local_lifecycle_silence <- function(frame = rlang::caller_env()) { rlang::local_options( .frame = frame, lifecycle_verbosity = "quiet" ) } with_lifecycle_silence <- function(expr) { local_lifecycle_silence() expr } local_lifecycle_warnings <- function(frame = rlang::caller_env()) { rlang::local_options( .frame = frame, lifecycle_verbosity = "warning" ) } with_lifecycle_warnings <- function(expr) { local_lifecycle_warnings() expr } local_lifecycle_errors <- function(frame = rlang::caller_env()) { rlang::local_options( .frame = frame, lifecycle_verbosity = "error" ) } with_lifecycle_errors <- function(expr) { local_lifecycle_errors() expr } .rlang_lifecycle_verbosity <- function() { opt <- getOption("lifecycle_verbosity", "default") if (!rlang::is_string(opt, c("quiet", "default", "warning", "error"))) { options(lifecycle_verbosity = "default") rlang::warn(glue::glue( " The `lifecycle_verbosity` option must be set to one of: \"quiet\", \"default\", \"warning\", or \"error\". Resetting to \"default\". " )) } opt } # nocov end rlang/R/standalone-zeallot.R0000644000176200001440000000145414403561346015513 0ustar liggesusers# --- # repo: r-lib/rlang # file: standalone-zeallot.R # last-updated: 2020-11-24 # license: https://unlicense.org # imports: rlang # --- # # This drop-in file implements a simple version of zeallot::`%<-%`. # # nocov start `%<-%` <- function(lhs, value) { lhs <- substitute(lhs) env <- caller_env() if (!is_call(lhs, "c")) { abort("The left-hand side of `%<-%` must be a call to `c()`.") } vars <- as.list(lhs[-1]) if (length(value) != length(vars)) { abort("The left- and right-hand sides of `%<-%` must be the same length.") } for (i in seq_along(vars)) { var <- vars[[i]] if (!is_symbol(var)) { abort(paste0("Element ", i, " of the left-hand side of `%<-%` must be a symbol.")) } env[[as_string(var)]] <- value[[i]] } invisible(value) } # nocov end rlang/R/raw.R0000644000176200001440000000151314375670676012517 0ustar liggesusers#' Serialize a raw vector to a string #' #' @keywords internal #' @description #' `r lifecycle::badge("experimental")` #' #' This function converts a raw vector to a hexadecimal string, #' optionally adding a prefix and a suffix. #' It is roughly equivalent to #' `paste0(prefix, paste(format(x), collapse = ""), suffix)` #' and much faster. #' #' @param x A raw vector. #' @param prefix,suffix Prefix and suffix strings, or `NULL. #' #' @return A string. #' @export #' @examples #' raw_deparse_str(raw()) #' raw_deparse_str(charToRaw("string")) #' raw_deparse_str(raw(10), prefix = "'0x", suffix = "'") raw_deparse_str <- function(x, prefix = NULL, suffix = NULL) { if (!is.null(prefix)) { prefix <- enc2utf8(prefix) } if (!is.null(suffix)) { suffix <- enc2utf8(suffix) } .Call("ffi_raw_deparse_str", x, prefix, suffix) } rlang/LICENSE.note0000644000176200001440000000331514127057575013345 0ustar liggesusersThe implementation of `hash()` uses the xxHash library from Yann Collet, which is released under the BSD 2-Clause license. This library has been embedded into rlang, without modification, in `src/internal/xxhash/`. A copy of the BSD 2-Clause license is provided below. BSD 2-Clause License ----------------------------------------------------------- xxHash Library Copyright (c) 2012-2020 Yann Collet All rights reserved. BSD 2-Clause License (https://www.opensource.org/licenses/bsd-license.php) Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. rlang/src/0000755000176200001440000000000014742414044012150 5ustar liggesusersrlang/src/capture.c0000644000176200001440000001045314175213516013763 0ustar liggesusers#include #include #include #define attribute_hidden #define _(string) (string) static Rboolean dotDotVal(SEXP); static SEXP capturedot(SEXP, int); SEXP attribute_hidden new_captured_arg(SEXP x, SEXP env) { static SEXP nms = NULL; if (!nms) { nms = allocVector(STRSXP, 2); R_PreserveObject(nms); MARK_NOT_MUTABLE(nms); SET_STRING_ELT(nms, 0, mkChar("expr")); SET_STRING_ELT(nms, 1, mkChar("env")); } SEXP info = PROTECT(allocVector(VECSXP, 2)); SET_VECTOR_ELT(info, 0, x); SET_VECTOR_ELT(info, 1, env); setAttrib(info, R_NamesSymbol, nms); UNPROTECT(1); return info; } SEXP attribute_hidden new_captured_literal(SEXP x) { return new_captured_arg(x, R_EmptyEnv); } SEXP attribute_hidden new_captured_promise(SEXP x, SEXP env) { SEXP expr_env = R_NilValue; SEXP expr = x; while (TYPEOF(expr) == PROMSXP) { expr_env = PRENV(expr); expr = PREXPR(expr); if (expr_env == R_NilValue) break; if (TYPEOF(expr) == SYMSXP) { int dd = dotDotVal(expr); if (dd) expr = capturedot(expr_env, dd); } } // Evaluated arguments are returned as literals if (expr_env == R_NilValue) { SEXP value = PROTECT(eval(x, env)); expr = new_captured_literal(value); UNPROTECT(1); } else { MARK_NOT_MUTABLE(expr); expr = new_captured_arg(expr, expr_env); } return expr; } SEXP attribute_hidden rlang_capturearginfo(SEXP call, SEXP op, SEXP args, SEXP rho) { int nProt = 0; // Unwrap first layer of promise SEXP sym = findVarInFrame3(rho, install("arg"), TRUE); PROTECT(sym); ++nProt; // May be a literal if compiler did not wrap in a promise if (TYPEOF(sym) != PROMSXP) { SEXP value = new_captured_literal(sym); UNPROTECT(nProt); return value; } sym = PREXPR(sym); if (TYPEOF(sym) != SYMSXP) { UNPROTECT(nProt); error(_("\"x\" must be an argument name")); } SEXP frame = CAR(args); SEXP arg; int dd = dotDotVal(sym); if (dd) { arg = capturedot(frame, dd); } else { arg = findVar(sym, frame); if (arg == R_UnboundValue) error(_("object '%s' not found"), CHAR(PRINTNAME(sym))); } PROTECT(arg); ++nProt; SEXP value; if (arg == R_MissingArg) value = new_captured_literal(arg); else if (TYPEOF(arg) == PROMSXP) value = new_captured_promise(arg, frame); else value = new_captured_literal(arg); UNPROTECT(nProt); return value; } SEXP capturedots(SEXP frame) { SEXP dots = PROTECT(findVar(R_DotsSymbol, frame)); if (dots == R_UnboundValue) error(_("'...' used in an incorrect context")); if (dots == R_MissingArg) { UNPROTECT(1); return R_NilValue; } SEXP out = PROTECT(cons(R_NilValue, R_NilValue)); SEXP node = out; while (dots != R_NilValue) { SEXP head = CAR(dots); SEXP dot; if (TYPEOF(head) == PROMSXP) dot = new_captured_promise(head, frame); else dot = new_captured_literal(head); SETCDR(node, cons(dot, R_NilValue)); SET_TAG(CDR(node), TAG(dots)); node = CDR(node); dots = CDR(dots); } UNPROTECT(2); return CDR(out); } SEXP attribute_hidden rlang_capturedots(SEXP call, SEXP op, SEXP args, SEXP rho) { SEXP caller_env = CAR(args); return capturedots(caller_env); } static Rboolean dotDotVal(SEXP sym) { const char* str = CHAR(PRINTNAME(sym)); if (strlen(str) < 3) return 0; if (*str++ != '.') return 0; if (*str++ != '.') return 0; char* p_end; int val = (int) strtol(str, &p_end, 10); if (*p_end == '\0') return val; else return 0; } static SEXP capturedot(SEXP frame, int i) { if (i < 1) error("'i' must be a positive non-zero integer"); SEXP dots = PROTECT(findVar(R_DotsSymbol, frame)); if (dots == R_UnboundValue) error(_("'...' used in an incorrect context")); if (dots == R_MissingArg) goto fewer; for (int j = 1; j != i; ++j) dots = CDR(dots); if (dots == R_NilValue) goto fewer; UNPROTECT(1); return CAR(dots); fewer: error(_("the ... list contains fewer than %d elements"), i); } // Local Variables: // tab-width: 8 // c-basic-offset: 4 // indent-tabs-mode: t // End: rlang/src/internal/0000755000176200001440000000000014742464552013775 5ustar liggesusersrlang/src/internal/tests.c0000644000176200001440000000766514547212037015311 0ustar liggesusers#include #include "decl/tests-decl.h" struct r_test { const char* desc; bool (*fn_ptr)(void); }; bool test_that_true_is_true(void) { if (true) return r_true; else return r_false; } bool test_that_false_is_false(void) { if (false) return r_false; else return r_true; } enum tests_df { TESTS_DF_desc = 0, TESTS_DF_fn_ptr, TESTS_DF_SIZE }; static const char* tests_df_names_c_strings[TESTS_DF_SIZE] = { [TESTS_DF_desc] = "desc", [TESTS_DF_fn_ptr] = "fn_ptr" }; static const enum r_type tests_df_types[TESTS_DF_SIZE] = { [TESTS_DF_desc] = R_TYPE_character, [TESTS_DF_fn_ptr] = R_TYPE_list }; extern const struct r_test tests[]; r_obj* ffi_c_tests(void) { int n_rows = 0; while (tests[n_rows].desc) { ++n_rows; } r_obj* df = KEEP(r_alloc_df_list(n_rows, tests_df_names, tests_df_types, TESTS_DF_SIZE)); r_init_tibble(df, n_rows); r_obj* desc_col = r_list_get(df, TESTS_DF_desc); r_obj* fn_ptr_col = r_list_get(df, TESTS_DF_fn_ptr); for (int i = 0; i < n_rows; ++i) { struct r_test test = tests[i]; r_chr_poke(desc_col, i, r_str(test.desc)); r_list_poke(fn_ptr_col, i, r_new_fn_ptr((r_void_fn) test.fn_ptr)); } FREE(1); return df; } r_obj* ffi_run_c_test(r_obj* fn_ptr) { if (r_typeof(fn_ptr) != R_TYPE_pointer) { r_stop_unexpected_type(r_typeof(fn_ptr)); } bool (*p)(void) = (bool (*)(void)) r_fn_ptr_addr(fn_ptr); return r_lgl(p()); } // ------------------------------------------------------------------------ r_obj* ffi_r_string(r_obj* str) { return r_chr_get(str, 0); } // attrib.c r_obj* r_pairlist_clone_until(r_obj* node, r_obj* sentinel, r_obj** parent_out); r_obj* ffi_test_node_list_clone_until(r_obj* node, r_obj* sentinel) { r_obj* sentinel_out; node = KEEP(r_pairlist_clone_until(node, sentinel, &sentinel_out)); r_obj* out = r_alloc_list(2); r_list_poke(out, 0, node); r_list_poke(out, 1, sentinel_out); FREE(1); return out; } // cnd.c r_obj* ffi_test_r_warn(r_obj* x) { r_warn(r_chr_get_c_string(x, 0)); return r_null; } r_obj* ffi_test_Rf_warning(r_obj* msg) { Rf_warning("%s", r_chr_get_c_string(msg, 0)); return r_null; } r_obj* ffi_test_Rf_error(r_obj* msg) { Rf_error("%s", r_chr_get_c_string(msg, 0)); return r_null; } r_obj* ffi_test_Rf_warningcall(r_obj* call, r_obj* msg) { Rf_warningcall(call, "%s", r_chr_get_c_string(msg, 0)); return r_null; } r_obj* ffi_test_Rf_errorcall(r_obj* call, r_obj* msg) { Rf_errorcall(call, "%s", r_chr_get_c_string(msg, 0)); return r_null; } // env.c r_obj* ffi_test_base_ns_get(r_obj* name) { return r_base_ns_get(r_chr_get_c_string(name, 0)); } // formula.c extern r_obj* r_new_formula(r_obj*, r_obj*, r_obj*); // parse.c r_obj* ffi_test_parse(r_obj* str) { return r_parse(r_chr_get_c_string(str, 0)); } r_obj* ffi_test_parse_eval(r_obj* str, r_obj* env) { return r_parse_eval(r_chr_get_c_string(str, 0), env); } // squash.c bool rlang_is_clevel_spliceable(r_obj* x) { return Rf_inherits(x, "foo"); } // stack.c r_obj* ffi_test_sys_call(r_obj* n) { return r_sys_call(r_int_get(n, 0), NULL); } r_obj* ffi_test_sys_frame(r_obj* n) { return r_sys_frame(r_int_get(n, 0), NULL); } // vec-lgl.c r_obj* ffi_test_lgl_sum(r_obj* x, r_obj* na_true) { return r_int(r_lgl_sum(x, r_lgl_get(na_true, 0))); } r_obj* ffi_test_lgl_which(r_obj* x, r_obj* na_true) { return r_lgl_which(x, r_lgl_get(na_true, 0)); } // vec-chr.c extern r_obj* chr_prepend(r_obj*, r_obj*); extern r_obj* chr_append(r_obj*, r_obj*); // internals/utils.c r_obj* nms_are_duplicated(r_obj* nms, bool from_last); r_obj* ffi_test_nms_are_duplicated(r_obj* nms, r_obj* from_last) { return nms_are_duplicated(nms, r_lgl_get(from_last, 0)); } void rlang_init_tests(void) { tests_df_names = r_chr_n(tests_df_names_c_strings, TESTS_DF_SIZE); r_preserve_global(tests_df_names); } static r_obj* tests_df_names = NULL; rlang/src/internal/utils.c0000644000176200001440000001461114741441060015270 0ustar liggesusers#include r_obj* new_preserved_empty_list(void) { r_obj* empty_list = r_alloc_list(0); r_preserve(empty_list); r_mark_shared(empty_list); r_obj* nms = KEEP(r_alloc_character(0)); r_attrib_poke_names(empty_list, nms); FREE(1); return empty_list; } /* For debugging with gdb or lldb. Exported as a C callable. * Usage with lldb: * * ``` * // Full backtrace: * expr R_GetCCallable("rlang", "rlang_print_backtrace")(true) * * // Linear backtrace: * expr R_GetCCallable("rlang", "rlang_print_backtrace")(false) * ``` */ void rlang_print_backtrace(bool full) { r_obj* env = KEEP(r_peek_frame()); r_obj* trace = KEEP(r_parse_eval("rlang::trace_back()", env)); const char* source = full ? "print(x, simplify = 'none')" : "print(x, simplify = 'branch')"; r_obj* call = KEEP(r_parse(source)); r_eval_with_x(call, trace, r_envs.base); FREE(3); return; } /* Print an environment in a debugging session. * * ``` * expr R_GetCCallable("rlang", "rlang_env_print")(obj) * ``` */ void rlang_env_print(r_obj* x) { r_obj* call = KEEP(r_parse("base::print(rlang::env_print(x))")); r_eval_with_x(call, x, r_envs.base); FREE(1); return; } static r_obj* deprecate_soft_call = NULL; void deprecate_soft(const char* msg, const char* id, r_obj* env) { id = id ? id : msg; env = env ? env : r_envs.empty; if (!msg) { r_abort("Internal error: NULL `msg` in r_deprecate_soft()"); } r_obj* msg_ = KEEP(r_chr(msg)); r_obj* id_ = KEEP(r_chr(id)); r_eval_with_xyz(deprecate_soft_call, msg_, id_, env, r_envs.base); FREE(2); } #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 void signal_retirement(const char* source, const char* buf); static r_obj* deprecate_warn_call = NULL; void deprecate_warn(const char* id, const char* fmt, ...) { char buf[BUFSIZE]; INTERP(buf, fmt, ...); r_obj* msg_ = KEEP(r_chr(buf)); id = id ? id : buf; r_obj* id_ = KEEP(r_chr(id)); r_eval_with_xy(deprecate_warn_call, msg_, id_, r_envs.base); FREE(2); } void deprecate_stop(const char* fmt, ...) { char buf[BUFSIZE]; INTERP(buf, fmt, ...); signal_retirement("deprecate_stop(msg = x)", buf); r_abort("Internal error: Unexpected return after `.Defunct()`"); } static void signal_retirement(const char* source, const char* buf) { r_obj* call = KEEP(r_parse(source)); r_obj* msg = KEEP(r_chr(buf)); r_eval_with_x(call, msg, rlang_ns_env); FREE(2); } #define R_SUBSET_NAMES_N 4 static const char* r_subset_names[R_SUBSET_NAMES_N] = { "$", "@", "::", ":::" }; bool r_is_prefixed_call(r_obj* x, const char* name) { if (r_typeof(x) != LANGSXP) { return false; } r_obj* head = r_node_car(x); if (!r_is_call_any(head, r_subset_names, R_SUBSET_NAMES_N)) { return false; } if (name) { r_obj* rhs = r_node_cadr(r_node_cdr(head)); if (!r_is_symbol(rhs, name)) { return false; } } return true; } bool r_is_namespaced_call(r_obj* x, const char* ns, const char* name) { if (r_typeof(x) != LANGSXP) { return false; } r_obj* head = r_node_car(x); if (!r_is_call(head, "::")) { return false; } if (ns) { r_obj* lhs = r_node_cadr(head); if (!r_is_symbol(lhs, ns)) { return false; } } if (name) { r_obj* rhs = r_node_cadr(r_node_cdar(x)); if (!r_is_symbol(rhs, name)) { return false; } } return true; } bool r_is_namespaced_call_any(r_obj* x, const char* ns, const char** names, int n) { if (!r_is_namespaced_call(x, ns, NULL)) { return false; } r_obj* args = r_node_cdar(x); r_obj* sym = r_node_cadr(args); return r_is_symbol_any(sym, names, n); } r_obj* nms_are_duplicated(r_obj* nms, bool from_last) { if (r_typeof(nms) != R_TYPE_character) { r_abort("Internal error: Expected a character vector of names for checking duplication"); } r_obj* dups = KEEP(Rf_duplicated(nms, from_last)); r_ssize n = r_length(dups); int* p_dups = r_lgl_begin(dups); r_obj* const * p_nms = r_chr_cbegin(nms); for (r_ssize i = 0; i < n; ++i) { if (p_nms[i] == r_strs.empty || p_nms[i] == r_globals.na_str) { p_dups[i] = false; } } FREE(1); return dups; } bool vec_find_first_duplicate(r_obj* x, r_obj* except, r_ssize* index) { r_ssize idx; if (except) { idx = Rf_any_duplicated3(x, except, false); } else { idx = Rf_any_duplicated(x, false); } if (idx) { if (index) { *index = idx - 1; } return true; } else { return false; } } // Can use simple pointer hashing thanks to the string pool r_obj* chr_detect_dups(r_obj* x) { if (r_typeof(x) != R_TYPE_character) { r_stop_internal("`x` must be a character vector."); } x = KEEP(r_obj_encode_utf8(x)); // Sentinel for duplicates r_obj* dup_flag = r_strs.empty; r_ssize n = r_length(x); r_obj* const * v_data = r_chr_cbegin(x); struct r_dict* p_dict = r_new_dict(n); KEEP(p_dict->shelter); for (r_ssize i = 0; i < n; ++i) { r_obj* key = v_data[i]; r_obj* val = r_dict_get0(p_dict, key); if (val == NULL) { r_dict_put(p_dict, key, r_null); } else if (val == r_null) { r_dict_poke(p_dict, key, dup_flag); } } r_obj* out = KEEP(r_alloc_logical(n)); int* v_out = r_lgl_begin(out); for (r_ssize i = 0; i < n; ++i) { v_out[i] = r_dict_get(p_dict, v_data[i]) == dup_flag; } FREE(3); return out; } r_obj* ffi_peek_srcref(void) { if (R_Srcref) { return R_Srcref; } else { return rlang_syms.c_null; } } r_obj* ffi_has_local_precious_list(void) { return r_lgl(_r_use_local_precious_list); } r_obj* ffi_use_local_precious_list(r_obj* x) { bool old = _r_use_local_precious_list; _r_use_local_precious_list = r_as_bool(x); return r_lgl(old); } r_obj* ffi_getppid(void) { return r_getppid(); } void rlang_init_utils(void) { deprecate_warn_call = r_parse("rlang:::deprecate_warn(x, id = y)"); r_preserve(deprecate_warn_call); deprecate_soft_call = r_parse("rlang:::deprecate_soft(x, id = y, user_env = z)"); r_preserve(deprecate_soft_call); } rlang/src/internal/arg.c0000644000176200001440000001656414741441060014712 0ustar liggesusers#include #include "internal.h" #include "nse-inject.h" #include "utils.h" #include "decl/arg-decl.h" // Capture ---------------------------------------------------------------- static r_obj* capture(r_obj* sym, r_obj* frame, r_obj** arg_env) { static r_obj* capture_call = NULL; if (!capture_call) { r_obj* args = KEEP(r_new_node(r_null, r_null)); capture_call = r_new_call(rlang_ns_get("captureArgInfo"), args); r_preserve(capture_call); r_mark_shared(capture_call); FREE(1); } if (r_typeof(sym) != SYMSXP) { r_abort("`arg` must be a symbol"); } r_node_poke_cadr(capture_call, sym); r_obj* arg_info = KEEP(r_eval(capture_call, frame)); r_obj* expr = r_list_get(arg_info, 0); r_obj* env = r_list_get(arg_info, 1); // Unquoting rearranges the expression // FIXME: Only duplicate the call tree, not the leaves expr = KEEP(r_copy(expr)); expr = call_interp(expr, env); if (arg_env) { *arg_env = env; } FREE(2); return expr; } r_obj* ffi_enexpr(r_obj* sym, r_obj* frame) { return capture(sym, frame, NULL); } r_obj* ffi_ensym(r_obj* sym, r_obj* frame) { r_obj* expr = capture(sym, frame, NULL); if (is_quosure(expr)) { expr = quo_get_expr(expr); } switch (r_typeof(expr)) { case R_TYPE_symbol: break; case R_TYPE_character: if (r_length(expr) == 1) { KEEP(expr); expr = r_sym(r_chr_get_c_string(expr, 0)); FREE(1); break; } // else fallthrough default: // FIXME: Should call `abort_coercion()` r_abort("Can't convert to a symbol."); } return expr; } r_obj* ffi_enquo(r_obj* sym, r_obj* frame) { r_obj* env; r_obj* expr = KEEP(capture(sym, frame, &env)); r_obj* quo = forward_quosure(expr, env); FREE(1); return quo; } // Match ------------------------------------------------------------------ static int arg_match(r_obj* arg, r_obj* values, struct r_lazy error_arg, struct r_lazy error_call, struct r_lazy call) { if (r_typeof(values) != R_TYPE_character) { r_abort_lazy_call(call, "`values` must be a character vector."); } int values_len = r_length(values); if (values_len == 0) { r_abort_lazy_call(call, "`values` must have at least one element."); } switch (r_typeof(arg)) { case R_TYPE_character: break; case R_TYPE_string: return arg_match1(arg, values, error_arg, error_call); case R_TYPE_symbol: return arg_match1(r_sym_string(arg), values, error_arg, error_call); default: r_abort_lazy_call(error_call, "%s must be a string or character vector.", r_format_lazy_error_arg(error_arg)); } int arg_len = r_length(arg); if (arg_len == 1) { return arg_match1(r_chr_get(arg, 0), values, error_arg, error_call); } if (arg_len != values_len) { r_abort_lazy_call(call, "`arg` must be a string or have the same length as `values`."); } r_obj* const* v_values = r_chr_cbegin(values); r_obj* const* v_arg = r_chr_cbegin(arg); // Same-length vector: must be identical, we allow changed order. int i = 0; for (; i < arg_len; ++i) { if (v_arg[i] != v_values[i]) { break; } } // Elements are identical, return first if (i == arg_len) { return 0; } r_obj* my_values = KEEP(r_clone(values)); r_obj* const * v_my_values = r_chr_cbegin(my_values); // Invariant: my_values[i:(len-1)] contains the values we haven't matched yet for (; i < arg_len; ++i) { r_obj* current_arg = v_arg[i]; if (current_arg == v_my_values[i]) { continue; } bool matched = false; for (int j = i + 1; j < arg_len; ++j) { if (current_arg == v_my_values[j]) { matched = true; // Replace matched value by the element that failed to match at this iteration r_chr_poke(my_values, j, v_my_values[i]); break; } } if (!matched) { r_eval_with_wxyz(stop_arg_match_call, arg, values, KEEP(lazy_wrap_chr(error_arg)), KEEP(r_lazy_eval(error_call)), rlang_ns_env); r_stop_unreachable(); } } r_obj* first_elt = r_chr_get(arg, 0); for (i = 0; i < values_len; ++i) { if (first_elt == v_values[i]) { FREE(1); return i; } } r_stop_unreachable(); } int arg_match_legacy(r_obj* arg, r_obj* values, r_obj* error_arg, r_obj* error_call) { struct r_lazy lazy_error_arg = { error_arg, r_null }; struct r_lazy lazy_error_call = { error_call, r_null }; return arg_match(arg, values, lazy_error_arg, lazy_error_call, r_lazy_null); } static int arg_match1(r_obj* arg, r_obj* values, struct r_lazy error_arg, struct r_lazy error_call) { // Simple case: one argument, we check if it's one of the values r_obj* const* v_values = r_chr_cbegin(values); int n_values = r_length(values); for (int i = 0; i < n_values; ++i) { if (arg == v_values[i]) { return i; } } r_obj* ffi_error_call = r_lazy_eval(error_call); if (ffi_error_call == r_missing_arg) { // Replace `error_call` by environment on the stack because // `r_eval_with_` evaluates in an out-of-stack mask ffi_error_call = r_peek_frame(); } KEEP(ffi_error_call); r_eval_with_wxyz(stop_arg_match_call, KEEP(wrap_chr(arg)), values, KEEP(lazy_wrap_chr(error_arg)), ffi_error_call, rlang_ns_env); r_stop_unreachable(); } static r_obj* wrap_chr(r_obj* arg) { switch (arg_match_arg_nm_type(arg)) { case R_TYPE_string: return r_str_as_character(arg); case R_TYPE_symbol: return r_sym_as_utf8_character(arg); case R_TYPE_character: return arg; default: r_stop_unreachable(); } } static r_obj* lazy_wrap_chr(struct r_lazy arg) { r_obj* ffi_arg = KEEP(r_lazy_eval(arg)); r_obj* out = wrap_chr(ffi_arg); FREE(1); return out; } static enum r_type arg_match_arg_nm_type(r_obj* arg_nm) { switch (r_typeof(arg_nm)) { case R_TYPE_string: return R_TYPE_string; case R_TYPE_symbol: return R_TYPE_symbol; case R_TYPE_character: if (r_is_string(arg_nm)) { return R_TYPE_character; } // else fallthrough; default: r_abort("`arg_nm` must be a string or symbol."); } } int cci_arg_match(r_obj* arg, r_obj* values, struct r_lazy error_arg, struct r_lazy error_call) { return arg_match(arg, values, error_arg, error_call, r_lazy_null); } r_obj* ffi_arg_match0(r_obj* args) { args = r_node_cdr(args); r_obj* arg = r_node_car(args); args = r_node_cdr(args); r_obj* values = r_node_car(args); args = r_node_cdr(args); r_obj* frame = r_node_car(args); struct r_lazy error_arg = { .x = syms.arg_nm, .env = frame }; struct r_lazy error_call = { .x = r_syms.error_call, .env = frame }; struct r_lazy call = { .x = frame, .env = r_null }; int i = arg_match(arg, values, error_arg, error_call, call); return r_str_as_character(r_chr_get(values, i)); } void rlang_init_arg(r_obj* ns) { stop_arg_match_call = r_parse("stop_arg_match(w, values = x, error_arg = y, error_call = z)"); r_preserve(stop_arg_match_call); } static r_obj* stop_arg_match_call = NULL; rlang/src/internal/hash.c0000644000176200001440000002371314375670676015102 0ustar liggesusers#include #include "file.h" /* * Using the standard xxhash defines, as seen in: * https://github.com/Cyan4973/xxHash/blob/4c881f796d6af27ef7d9c48f87817da0d3d75dc1/xxhash.c#L40-L41 */ #define XXH_STATIC_LINKING_ONLY #define XXH_IMPLEMENTATION #include "xxhash/xxhash.h" #include // sprintf() #include // PRIx64 #include "decl/hash-decl.h" /* * Construct a define specifying whether version 2 or 3 of * `R_Serialize()` should be used. Version 3 is used with R >= 3.5.0, and * has support for ALTREP. */ #ifdef R_VERSION # if (R_VERSION >= R_Version(3, 5, 0)) # define USE_VERSION_3 1 # else # define USE_VERSION_3 0 # endif #else # define USE_VERSION_3 0 #endif /* * Before any R object data is serialized, `R_Serialize()` will first write out: * * Serialization info: * - 2 bytes for `"X\n"` to declare "binary" serialization (i.e. not "ascii") * - An `int` representing the serialization version * - An `int` representing `R_VERSION` * - An `int` representing the minimum R version where this serialization * version was supported. This is `R_Version(2,3,0)` for version 2, and * `R_Version(3,5,0)` for version 3. * * With version 3, it additionally writes out: * - An `int` representing the `strlen()` of a `const char*` containing the * native encoding. * - A `const char*` for that native encoding. The length of this comes from * the previous `int` that was written out. * * Since this changes between R versions, we skip these first bytes before * streaming any data into the hashing algorithm. * * Reference to show where R appends this information: * https://github.com/wch/r-source/blob/d48ecd61012fa6ae645d087d9a6e97e200c32fbc/src/main/serialize.c#L1382-L1389 */ #define N_BYTES_SERIALIZATION_INFO (2 + 3 * sizeof(int)) #if USE_VERSION_3 # define N_BYTES_N_NATIVE_ENC (sizeof(int)) #endif // ----------------------------------------------------------------------------- struct exec_data { r_obj* x; XXH3_state_t* p_xx_state; }; static r_obj* hash_impl(void* p_data); static void hash_cleanup(void* p_data); r_obj* ffi_hash(r_obj* x) { XXH3_state_t* p_xx_state = XXH3_createState(); struct exec_data data = { .x = x, .p_xx_state = p_xx_state }; return R_ExecWithCleanup(hash_impl, &data, hash_cleanup, &data); } struct hash_state_t { bool skip; int n_skipped; #if USE_VERSION_3 int n_native_enc; #endif XXH3_state_t* p_xx_state; }; static inline struct hash_state_t new_hash_state(XXH3_state_t* p_xx_state); static inline int hash_version(void); static inline r_obj* hash_value(XXH3_state_t* p_xx_state); static inline void hash_bytes(R_outpstream_t stream, void* p_input, int n); static inline void hash_char(R_outpstream_t stream, int input); static r_obj* hash_impl(void* p_data) { struct exec_data* p_exec_data = (struct exec_data*) p_data; r_obj* x = p_exec_data->x; XXH3_state_t* p_xx_state = p_exec_data->p_xx_state; XXH_errorcode err = XXH3_128bits_reset(p_xx_state); if (err == XXH_ERROR) { r_abort("Couldn't initialize hash state."); } struct hash_state_t state = new_hash_state(p_xx_state); int version = hash_version(); // Unused r_obj* (*hook)(r_obj*, r_obj*) = NULL; r_obj* hook_data = r_null; // We use the unstructured binary format, rather than XDR, as that is faster. // In theory it may result in different hashes on different platforms, but // in practice only integers can have variable width and here they are 32 bit. R_pstream_format_t format = R_pstream_binary_format; struct R_outpstream_st stream; R_InitOutPStream( &stream, (R_pstream_data_t) &state, format, version, hash_char, hash_bytes, hook, hook_data ); R_Serialize(x, &stream); r_obj* value = KEEP(hash_value(p_xx_state)); r_obj* out = r_str_as_character(value); FREE(1); return out; } static void hash_cleanup(void* p_data) { struct exec_data* p_exec_data = (struct exec_data*) p_data; XXH3_state_t* p_xx_state = p_exec_data->p_xx_state; XXH3_freeState(p_xx_state); } static inline struct hash_state_t new_hash_state(XXH3_state_t* p_xx_state) { return (struct hash_state_t) { .skip = true, .n_skipped = 0, #if USE_VERSION_3 .n_native_enc = 0, #endif .p_xx_state = p_xx_state }; } static inline int hash_version(void) { #if USE_VERSION_3 return 3; #else return 2; #endif } static inline r_obj* hash_value(XXH3_state_t* p_xx_state) { XXH128_hash_t hash = XXH3_128bits_digest(p_xx_state); // R assumes C99, so these are always defined as `uint64_t` in xxhash.h XXH64_hash_t high = hash.high64; XXH64_hash_t low = hash.low64; // 32 for hash, 1 for terminating null added by `snprintf()` char out[32 + 1]; snprintf(out, sizeof(out), "%016" PRIx64 "%016" PRIx64, high, low); return r_str(out); } static inline void hash_skip(struct hash_state_t* p_state, void* p_input, int n); static inline void hash_bytes(R_outpstream_t stream, void* p_input, int n) { struct hash_state_t* p_state = (struct hash_state_t*) stream->data; if (p_state->skip) { hash_skip(p_state, p_input, n); return; } XXH3_state_t* p_xx_state = p_state->p_xx_state; XXH_errorcode err = XXH3_128bits_update(p_xx_state, p_input, n); if (err == XXH_ERROR) { r_abort("Couldn't update hash state."); } } static inline void hash_char(R_outpstream_t stream, int input) { // `R_Serialize()` only ever calls `stream->OutChar()` for ASCII and // ASCIIHEX formats, neither of which we are using. // https://github.com/wch/r-source/blob/161e21346c024b79db2654d3331298f96cdf6968/src/main/serialize.c#L376 r_stop_internal("Should never be called with binary format."); } #if USE_VERSION_3 static inline void hash_skip(struct hash_state_t* p_state, void* p_input, int n) { if (p_state->n_skipped < N_BYTES_SERIALIZATION_INFO) { // Skip serialization info bytes p_state->n_skipped += n; return; } if (p_state->n_skipped == N_BYTES_SERIALIZATION_INFO) { // We've skipped all serialization info bytes. // Incoming bytes tell the size of the native encoding string. memcpy(&p_state->n_native_enc, p_input, sizeof(int)); p_state->n_skipped += n; return; } p_state->n_skipped += n; int n_bytes_header = N_BYTES_SERIALIZATION_INFO + N_BYTES_N_NATIVE_ENC + p_state->n_native_enc; if (p_state->n_skipped == n_bytes_header) { // We've skipped all serialization header bytes at this point p_state->skip = false; } } #else // !USE_VERSION_3 static inline void hash_skip(struct hash_state_t* p_state, void* p_input, int n) { // Skip serialization header bytes p_state->n_skipped += n; if (p_state->n_skipped == N_BYTES_SERIALIZATION_INFO) { // We've skipped all serialization header bytes at this point p_state->skip = false; } } #endif // USE_VERSION_3 #undef USE_VERSION_3 // ----------------------------------------------------------------------------- r_obj* ffi_hash_file(r_obj* path) { XXH3_state_t* p_xx_state = XXH3_createState(); struct exec_data data = { .x = path, .p_xx_state = p_xx_state }; return R_ExecWithCleanup(hash_file_impl, &data, hash_cleanup, &data); } #define CHUNK_SIZE 512 * 1024 static r_obj* hash_file_impl(void* p_data) { struct exec_data* p_exec_data = (struct exec_data*) p_data; r_obj* path = p_exec_data->x; XXH3_state_t* p_xx_state = p_exec_data->p_xx_state; if (r_typeof(path) != R_TYPE_character) { r_abort("`path` must be a character vector."); } r_ssize n_path = r_length(path); r_obj* const* v_path = r_chr_cbegin(path); r_obj* out = KEEP(r_alloc_character(n_path)); // Allocate before opening file to avoid handle leak on allocation failure void* buf = (void*)R_alloc(CHUNK_SIZE, sizeof(char)); for (r_ssize i = 0; i < n_path; ++i) { XXH_errorcode err = XXH3_128bits_reset(p_xx_state); if (err == XXH_ERROR) { r_abort("Can't initialize hash state."); } r_obj* elt = v_path[i]; FILE* fp = r_fopen(elt, "rb"); if (fp == NULL) { r_abort("Can't open file: %s.", Rf_translateChar(elt)); } size_t n_read; while ((n_read = fread(buf, 1, CHUNK_SIZE, fp)) > 0) { XXH_errorcode err = XXH3_128bits_update(p_xx_state, buf, n_read); if (err == XXH_ERROR) { fclose(fp); r_abort("Can't update hash state."); } } fclose(fp); r_chr_poke(out, i, hash_value(p_xx_state)); } FREE(1); return out; } #undef CHUNK_SIZE // ----------------------------------------------------------------------------- static inline void hasher_finalizer(r_obj* x) { void* p_x = R_ExternalPtrAddr(x); if (!p_x) { // Defensively exit if the external pointer resolves to `NULL` return; } XXH3_state_t* p_xx_state = (XXH3_state_t*) p_x; XXH3_freeState(p_xx_state); R_ClearExternalPtr(x); } r_obj* ffi_hasher_init(void) { XXH3_state_t* p_xx_state = XXH3_createState(); XXH_errorcode err = XXH3_128bits_reset(p_xx_state); if (err == XXH_ERROR) { r_abort("Can't initialize hash state."); } SEXP out = KEEP(R_MakeExternalPtr(p_xx_state, r_null, r_null)); R_RegisterCFinalizerEx(out, hasher_finalizer, TRUE); FREE(1); return(out); } r_obj* ffi_hasher_update(r_obj* x, r_obj* data) { if (r_typeof(x) != R_TYPE_pointer) { r_abort("`x` must be a hasher."); } if (r_typeof(data) != R_TYPE_raw) { r_abort("`data` must be a raw vector."); } void* p_x = R_ExternalPtrAddr(x); if (!p_x) { r_abort("`x` must be a hasher."); } XXH3_state_t* p_xx_state = (XXH3_state_t*) p_x; void* v_data = (void*) r_raw_begin(data); int size = r_ssize_as_integer(r_length(data)); XXH_errorcode err = XXH3_128bits_update(p_xx_state, v_data, size); if (err == XXH_ERROR) { r_abort("Can't update hash state."); } return r_true; } r_obj* ffi_hasher_value(r_obj* x) { if (r_typeof(x) != R_TYPE_pointer) { r_abort("`x` must be a hasher."); } void* p_x = R_ExternalPtrAddr(x); if (!p_x) { r_abort("`x` must be a hasher."); } XXH3_state_t* p_xx_state = (XXH3_state_t*) p_x; return hash_value(p_xx_state); } rlang/src/internal/parse.c0000644000176200001440000003253414376112150015245 0ustar liggesusers#include #include "parse.h" const struct r_op_precedence r_ops_precedence[R_OP_MAX] = { [R_OP_NONE] = { .power = 0, .assoc = 0, .unary = false, .delimited = false }, [R_OP_BREAK] = { .power = 1, .assoc = 0, .unary = false, .delimited = true }, [R_OP_NEXT] = { .power = 1, .assoc = 0, .unary = false, .delimited = true }, [R_OP_FUNCTION] = { .power = 5, .assoc = 1, .unary = true, .delimited = false }, [R_OP_QUESTION] = { .power = 10, .assoc = -1, .unary = false, .delimited = false }, [R_OP_QUESTION_UNARY] = { .power = 10, .assoc = -1, .unary = true, .delimited = false }, [R_OP_WHILE] = { .power = 20, .assoc = -1, .unary = false, .delimited = true }, [R_OP_FOR] = { .power = 20, .assoc = -1, .unary = false, .delimited = true }, [R_OP_REPEAT] = { .power = 20, .assoc = -1, .unary = false, .delimited = true }, [R_OP_IF] = { .power = 30, .assoc = 1, .unary = false, .delimited = true }, [R_OP_ASSIGN1] = { .power = 40, .assoc = 1, .unary = false, .delimited = false }, [R_OP_ASSIGN2] = { .power = 40, .assoc = 1, .unary = false, .delimited = false }, [R_OP_COLON_EQUAL] = { .power = 40, .assoc = 1, .unary = false, .delimited = false }, [R_OP_ASSIGN_EQUAL] = { .power = 50, .assoc = 1, .unary = false, .delimited = false }, [R_OP_TILDE] = { .power = 60, .assoc = -1, .unary = false, .delimited = false }, [R_OP_TILDE_UNARY] = { .power = 60, .assoc = -1, .unary = true, .delimited = false }, [R_OP_OR1] = { .power = 70, .assoc = -1, .unary = false, .delimited = false }, [R_OP_OR2] = { .power = 70, .assoc = -1, .unary = false, .delimited = false }, [R_OP_AND1] = { .power = 80, .assoc = -1, .unary = false, .delimited = false }, [R_OP_AND2] = { .power = 80, .assoc = -1, .unary = false, .delimited = false }, [R_OP_BANG1] = { .power = 90, .assoc = -1, .unary = true, .delimited = false }, [R_OP_BANG3] = { .power = 90, .assoc = -1, .unary = true, .delimited = false }, [R_OP_GREATER] = { .power = 100, .assoc = 0, .unary = false, .delimited = false }, [R_OP_GREATER_EQUAL] = { .power = 100, .assoc = 0, .unary = false, .delimited = false }, [R_OP_LESS] = { .power = 100, .assoc = 0, .unary = false, .delimited = false }, [R_OP_LESS_EQUAL] = { .power = 100, .assoc = 0, .unary = false, .delimited = false }, [R_OP_EQUAL] = { .power = 100, .assoc = 0, .unary = false, .delimited = false }, [R_OP_NOT_EQUAL] = { .power = 100, .assoc = 0, .unary = false, .delimited = false }, [R_OP_PLUS] = { .power = 110, .assoc = -1, .unary = false, .delimited = false }, [R_OP_MINUS] = { .power = 110, .assoc = -1, .unary = false, .delimited = false }, [R_OP_TIMES] = { .power = 120, .assoc = -1, .unary = false, .delimited = false }, [R_OP_RATIO] = { .power = 120, .assoc = -1, .unary = false, .delimited = false }, [R_OP_MODULO] = { .power = 130, .assoc = -1, .unary = false, .delimited = false }, [R_OP_SPECIAL] = { .power = 130, .assoc = -1, .unary = false, .delimited = false }, [R_OP_COLON1] = { .power = 140, .assoc = -1, .unary = false, .delimited = false }, [R_OP_BANG2] = { .power = 150, .assoc = -1, .unary = true, .delimited = false }, [R_OP_PLUS_UNARY] = { .power = 150, .assoc = -1, .unary = true, .delimited = false }, [R_OP_MINUS_UNARY] = { .power = 150, .assoc = -1, .unary = true, .delimited = false }, [R_OP_HAT] = { .power = 160, .assoc = 1, .unary = false, .delimited = false }, [R_OP_DOLLAR] = { .power = 170, .assoc = -1, .unary = false, .delimited = false }, [R_OP_AT] = { .power = 170, .assoc = -1, .unary = false, .delimited = false }, [R_OP_COLON2] = { .power = 180, .assoc = 0, .unary = false, .delimited = false }, [R_OP_COLON3] = { .power = 180, .assoc = 0, .unary = false, .delimited = false }, [R_OP_PARENTHESES] = { .power = 190, .assoc = 0, .unary = true, .delimited = true }, [R_OP_BRACKETS1] = { .power = 190, .assoc = -1, .unary = false, .delimited = false }, [R_OP_BRACKETS2] = { .power = 190, .assoc = -1, .unary = false, .delimited = false }, [R_OP_BRACES] = { .power = 200, .assoc = 0, .unary = false, .delimited = true }, [R_OP_EMBRACE] = { .power = 200, .assoc = 0, .unary = false, .delimited = true } }; enum r_operator r_which_operator(r_obj* call) { if (r_typeof(call) != R_TYPE_call) { return R_OP_NONE; } r_obj* head = r_node_car(call); if (r_typeof(head) != R_TYPE_symbol) { return R_OP_NONE; } const char* name = r_sym_c_string(head); int len = strlen(name); bool is_unary = r_node_cddr(call) == r_null; switch (name[0]) { case 'b': if (strcmp(name, "break") == 0) { return R_OP_BREAK; } else { goto none; } case 'f': if (strcmp(name, "for") == 0) { return R_OP_FOR; } else if (strcmp(name, "function") == 0) { return R_OP_FUNCTION; } else { goto none; } case 'i': if (strcmp(name, "if") == 0) { return R_OP_IF; } else { goto none; } case 'n': if (strcmp(name, "next") == 0) { return R_OP_NEXT; } else { goto none; } case 'r': if (strcmp(name, "repeat") == 0) { return R_OP_REPEAT; } else { goto none; } case 'w': if (strcmp(name, "while") == 0) { return R_OP_WHILE; } else { goto none; } case '?': if (len == 1) { if (is_unary) { return R_OP_QUESTION_UNARY; } else { return R_OP_QUESTION; } } else { goto none; } case '<': switch (len) { case 1: return R_OP_LESS; case 2: switch (name[1]) { case '-': return R_OP_ASSIGN1; case '=': return R_OP_LESS_EQUAL; default: goto none; } case 3: if (name[1] == '<' && name[2] == '-') { return R_OP_ASSIGN2; } else { goto none; } default: goto none; } case '>': switch (len) { case 1: return R_OP_GREATER; case 2: if (name[1] == '=') { return R_OP_GREATER_EQUAL; } else { goto none; } default: goto none; } case '=': switch (len) { case 1: return R_OP_ASSIGN_EQUAL; case 2: if (name[1] == '=') { return R_OP_EQUAL; } else { goto none; } default: goto none; } case ':': switch (len) { case 1: return R_OP_COLON1; case 2: switch (name[1]) { case '=': return R_OP_COLON_EQUAL; case ':': return R_OP_COLON2; default: goto none; } case 3: if (name[1] == ':' && name[2] == ':') { return R_OP_COLON3; } else { goto none; } default: goto none; } case '~': if (len == 1) { if (is_unary) { return R_OP_TILDE_UNARY; } else { return R_OP_TILDE; } } else { goto none; } case '|': switch (len) { case 1: return R_OP_OR1; case 2: if (name[1] == '|') { return R_OP_OR2; } else { goto none; } default: goto none; } case '&': switch (len) { case 1: return R_OP_AND1; case 2: if (name[1] == '&') { return R_OP_AND2; } else { goto none; } default: goto none; } case '!': switch (len) { case 1: return R_OP_BANG1; case 2: switch (name[1]) { case '!': return R_OP_BANG2; case '=': return R_OP_NOT_EQUAL; default: goto none; } case 3: if (name[1] == '!' && name[2] == '!') { return R_OP_BANG3; } else { goto none; } default: goto none; } case '+': if (len == 1) { if (is_unary) { return R_OP_PLUS_UNARY; } else { return R_OP_PLUS; } } else { goto none; } case '-': if (len == 1) { if (is_unary) { return R_OP_MINUS_UNARY; } else { return R_OP_MINUS; } } else { goto none; } case '*': if (len == 1) { return R_OP_TIMES; } else { goto none; } case '/': if (len == 1) { return R_OP_RATIO; } else { goto none; } case '%': switch (len) { case 1: goto none; case 2: if (name[1] == '%') { return R_OP_MODULO; } else { goto none; } default: if (name[len - 1] == '%') { return R_OP_SPECIAL; } else { goto none; } } case '^': if (len == 1) { return R_OP_HAT; } else { goto none; } case '$': if (len == 1) { return R_OP_DOLLAR; } else { goto none; } case '@': if (len == 1) { return R_OP_AT; } else { goto none; } case '(': if (len == 1) { return R_OP_PARENTHESES; } else { goto none; } case '[': switch (len) { case 1: return R_OP_BRACKETS1; case 2: if (name[1] == '[') { return R_OP_BRACKETS2; } else { goto none; } default: goto none; } case '{': if (len == 1) { r_obj* cadr = r_node_cadr(call); if (r_length(call) == 2 && r_is_call(cadr, "{") && r_length(cadr) == 2 && r_typeof(r_node_cadr(cadr)) == R_TYPE_symbol) { return R_OP_EMBRACE; } else { return R_OP_BRACES; } } else { goto none; } none: default: return R_OP_NONE; } } const char* r_op_as_c_string(enum r_operator op) { switch (op) { case R_OP_NONE: return ""; case R_OP_BREAK: return "break"; case R_OP_NEXT: return "next"; case R_OP_WHILE: return "while"; case R_OP_FOR: return "for"; case R_OP_REPEAT: return "repeat"; case R_OP_IF: return "if"; case R_OP_FUNCTION: return "function"; case R_OP_QUESTION: return "?"; case R_OP_QUESTION_UNARY: return "?unary"; case R_OP_ASSIGN1: return "<-"; case R_OP_ASSIGN2: return "<<-"; case R_OP_ASSIGN_EQUAL: return "="; case R_OP_COLON_EQUAL: return ":="; case R_OP_TILDE: return "~"; case R_OP_TILDE_UNARY: return "~unary"; case R_OP_OR1: return "|"; case R_OP_OR2: return "||"; case R_OP_AND1: return "&"; case R_OP_AND2: return "&&"; case R_OP_BANG1: return "!"; case R_OP_BANG3: return "!!!"; case R_OP_GREATER: return ">"; case R_OP_GREATER_EQUAL: return ">="; case R_OP_LESS: return "<"; case R_OP_LESS_EQUAL: return "<="; case R_OP_EQUAL: return "=="; case R_OP_NOT_EQUAL: return "!="; case R_OP_PLUS: return "+"; case R_OP_MINUS: return "-"; case R_OP_TIMES: return "*"; case R_OP_RATIO: return "/"; case R_OP_MODULO: return "%%"; case R_OP_SPECIAL: return "special"; case R_OP_COLON1: return ":"; case R_OP_BANG2: return "!!"; case R_OP_PLUS_UNARY: return "+unary"; case R_OP_MINUS_UNARY: return "-unary"; case R_OP_HAT: return "^"; case R_OP_DOLLAR: return "$"; case R_OP_AT: return "@"; case R_OP_COLON2: return "::"; case R_OP_COLON3: return ":::"; case R_OP_PARENTHESES: return "("; case R_OP_BRACKETS1: return "["; case R_OP_BRACKETS2: return "[["; case R_OP_BRACES: return "{"; case R_OP_EMBRACE: return "{{"; case R_OP_MAX: r_abort("Unexpected `enum r_operator` value"); } // Silence mistaken noreturn warning on GCC r_abort("Never reached"); } bool op_has_precedence_impl(enum r_operator x, enum r_operator parent, int side) { if (x > R_OP_MAX || parent > R_OP_MAX) { r_abort("Internal error: `enum r_operator` out of bounds"); } if (x == R_OP_NONE) { return true; } if (parent == R_OP_NONE) { return true; } struct r_op_precedence x_info = r_ops_precedence[x]; struct r_op_precedence y_info = r_ops_precedence[parent]; if (x_info.delimited) { return true; } if (y_info.delimited) { return false; } uint8_t x_power = x_info.power; uint8_t y_power = y_info.power; if (x_power == y_power) { if (side == 0) { r_abort("Internal error: Unspecified direction of associativity"); } return r_ops_precedence[x].assoc == side; } else { return x_power > y_power; } } bool r_op_has_precedence(enum r_operator x, enum r_operator parent) { return op_has_precedence_impl(x, parent, 0); } bool r_lhs_op_has_precedence(enum r_operator lhs, enum r_operator parent) { return op_has_precedence_impl(lhs, parent, -1); } bool r_rhs_op_has_precedence(enum r_operator rhs, enum r_operator parent) { return op_has_precedence_impl(rhs, parent, 1); } void init_parse(r_obj* ns) { RLANG_ASSERT((sizeof(r_ops_precedence) / sizeof(struct r_op_precedence)) == R_OP_MAX); for (int i = R_OP_NONE + 1; i < R_OP_MAX; ++i) { if (r_ops_precedence[i].power == 0) { Rf_error("Internal error: `r_ops_precedence` is not fully initialised"); } } } rlang/src/internal/replace-na.c0000644000176200001440000001115414375670676016162 0ustar liggesusers#include #include "vec.h" static r_obj* replace_na_(r_obj* x, r_obj* replacement, int start); static r_obj* replace_na_vec_(r_obj* x, r_obj* replacement, int start); r_obj* ffi_replace_na(r_obj* x, r_obj* replacement) { const enum r_type x_type = r_typeof(x); const enum r_type replacement_type = r_typeof(replacement); int n = r_length(x); int n_replacement = r_length(replacement); if (!r_is_atomic(x, -1)) { r_abort("Cannot replace missing values in an object of type %s", Rf_type2char(x_type)); } if (x_type != replacement_type) { r_abort("Replacement values must have type %s, not type %s", Rf_type2char(x_type), Rf_type2char(replacement_type)); } if (n_replacement != 1 && n_replacement != n) { if (n == 1) { r_abort("The replacement values must have size 1, not %i", n_replacement); } else { r_abort("The replacement values must have size 1 or %i, not %i", n, n_replacement); } } int i = 0; switch(x_type) { case R_TYPE_logical: { int* arr = r_lgl_begin(x); for (; i < n; ++i) { if (arr[i] == r_globals.na_lgl) { break; } } break; } case R_TYPE_integer: { int* arr = r_int_begin(x); for (; i < n; ++i) { if (arr[i] == r_globals.na_int) { break; } } break; } case R_TYPE_double: { double* arr = r_dbl_begin(x); for (; i < n; ++i) { if (ISNA(arr[i])) { break; } } break; } case R_TYPE_character: { for (; i < n; ++i) { if (r_chr_get(x, i) == r_globals.na_str) { break; } } break; } case R_TYPE_complex: { r_complex* arr = r_cpl_begin(x); for (; i < n; ++i) { if (ISNA(arr[i].r)) { break; } } break; } default: { r_abort("Internal error: Don't know how to handle object of type %s", Rf_type2char(x_type)); } } if (i == n) { return x; } else if (n_replacement == 1) { return replace_na_(x, replacement, i); } else { return replace_na_vec_(x, replacement, i); } } static r_obj* replace_na_(r_obj* x, r_obj* replacement, int i) { KEEP(x = r_copy(x)); int n = r_length(x); switch(r_typeof(x)) { case R_TYPE_logical: { int* arr = r_lgl_begin(x); int new_value = r_lgl_begin(replacement)[0]; for (; i < n; ++i) { if (arr[i] == r_globals.na_lgl) { arr[i] = new_value; } } break; } case R_TYPE_integer: { int* arr = r_int_begin(x); int new_value = r_int_begin(replacement)[0]; for (; i < n; ++i) { if (arr[i] == r_globals.na_int) { arr[i] = new_value; } } break; } case R_TYPE_double: { double* arr = r_dbl_begin(x); double new_value = r_dbl_begin(replacement)[0]; for (; i < n; ++i) { if (ISNA(arr[i])) { arr[i] = new_value; } } break; } case R_TYPE_character: { r_obj* new_value = r_chr_get(replacement, 0); for (; i < n; ++i) { if (r_chr_get(x, i) == r_globals.na_str) { r_chr_poke(x, i, new_value); } } break; } case R_TYPE_complex: { r_complex* arr = r_cpl_begin(x); r_complex new_value = r_cpl_get(replacement, 0); for (; i < n; ++i) { if (ISNA(arr[i].r)) { arr[i] = new_value; } } break; } default: { r_abort("Internal error: Don't know how to handle object of type %s", Rf_type2char(r_typeof(x))); } } FREE(1); return x; } static r_obj* replace_na_vec_(r_obj* x, r_obj* replacement, int i) { KEEP(x = r_copy(x)); int n = r_length(x); switch(r_typeof(x)) { case R_TYPE_logical: { int* arr = r_lgl_begin(x); for (; i < n; ++i) { if (arr[i] == r_globals.na_lgl) { arr[i] = r_lgl_get(replacement, i); } } break; } case R_TYPE_integer: { int* arr = r_int_begin(x); for (; i < n; ++i) { if (arr[i] == r_globals.na_int) { arr[i] = r_int_get(replacement, i); } } break; } case R_TYPE_double: { double* arr = r_dbl_begin(x); for (; i < n; ++i) { if (ISNA(arr[i])) { arr[i] = r_dbl_get(replacement, i); } } break; } case R_TYPE_character: { for (; i < n; ++i) { if (r_chr_get(x, i) == r_globals.na_str) { r_chr_poke(x, i, r_chr_get(replacement, i)); } } break; } case R_TYPE_complex: { r_complex* arr = r_cpl_begin(x); for (; i < n; ++i) { if (ISNA(arr[i].r)) { arr[i] = r_cpl_get(replacement, i); } } break; } default: { r_abort("Internal error: Don't know how to handle object of type %s", Rf_type2char(r_typeof(x))); } } FREE(1); return x; } rlang/src/internal/call.h0000644000176200001440000000022114376112150015037 0ustar liggesusers#ifndef RLANG_INTERNAL_CALL_H #define RLANG_INTERNAL_CALL_H #include r_obj* rlang_call2(r_obj* fn, r_obj* args, r_obj* ns); #endif rlang/src/internal/fn.c0000644000176200001440000000160514741441060014532 0ustar liggesusers#include #include "internal.h" r_obj* ffi_new_function(r_obj* args, r_obj* body, r_obj* env) { if (r_typeof(env) != R_TYPE_environment) { r_abort("`env` must be an environment"); } args = KEEP(r_vec_coerce(args, R_TYPE_pairlist)); r_obj* node = args; while (node != r_null) { if (r_node_tag(node) == r_null) { r_abort("All formal parameters in `args` must be named"); } node = r_node_cdr(node); } r_obj* call = KEEP(r_call3(fns_function, args, body)); r_obj* out = r_eval(call, env); FREE(2); return out; } static r_obj* as_function_call = NULL; // TODO: Replace with C implementation of `as_function()` r_obj* rlang_as_function(r_obj* x, r_obj* env) { return r_eval_with_xy(as_function_call, x, env, rlang_ns_env); } void rlang_init_fn(void) { as_function_call = r_parse("as_function(x, env = y)"); r_preserve(as_function_call); } rlang/src/internal/squash.h0000644000176200001440000000027414376112150015440 0ustar liggesusers#ifndef RLANG_INTERNAL_SQUASH_H #define RLANG_INTERNAL_SQUASH_H #include r_obj* r_squash_if(r_obj* dots, enum r_type kind, bool (*is_spliceable)(r_obj*), int depth); #endif rlang/src/internal/squash.c0000644000176200001440000002140714741441060015435 0ustar liggesusers#include #include "export.h" #include "squash.h" static r_ssize r_vec_length(r_obj* x); // From rlang/vec.c void r_vec_poke_n(r_obj* x, r_ssize offset, r_obj* y, r_ssize from, r_ssize n); // The vector to splice might be boxed in a sentinel wrapper static r_obj* maybe_unbox(r_obj* x, bool (*is_spliceable)(r_obj*)) { if (is_spliceable(x) && is_splice_box(x)) { return r_vec_coerce(rlang_unbox(x), R_TYPE_list); } else { return x; } } bool has_name_at(r_obj* x, r_ssize i) { r_obj* nms = r_names(x); return r_typeof(nms) == R_TYPE_character && r_chr_get(nms, i) != r_strs.empty; } typedef struct { r_ssize size; bool named; bool warned; bool recursive; } squash_info_t; static squash_info_t squash_info_init(bool recursive) { squash_info_t info; info.size = 0; info.named = false; info.warned = false; info.recursive = recursive; return info; } // Atomic squashing --------------------------------------------------- static r_ssize atom_squash(enum r_type kind, squash_info_t info, r_obj* outer, r_obj* out, r_ssize count, bool (*is_spliceable)(r_obj*), int depth) { if (r_typeof(outer) != VECSXP) { r_abort("Only lists can be spliced"); } r_obj* inner; r_obj* out_names = KEEP(r_names(out)); r_ssize n_outer = r_length(outer); r_ssize n_inner; for (r_ssize i = 0; i != n_outer; ++i) { inner = r_list_get(outer, i); n_inner = r_vec_length(maybe_unbox(inner, is_spliceable)); if (depth != 0 && is_spliceable(inner)) { inner = PROTECT(maybe_unbox(inner, is_spliceable)); count = atom_squash(kind, info, inner, out, count, is_spliceable, depth - 1); UNPROTECT(1); } else if (n_inner) { r_vec_poke_coerce_n(out, count, inner, 0, n_inner); if (info.named) { r_obj* nms = r_names(inner); if (r_typeof(nms) == R_TYPE_character) { r_vec_poke_n(out_names, count, nms, 0, n_inner); } else if (n_inner == 1 && has_name_at(outer, i)) { r_chr_poke(out_names, count, r_chr_get(r_names(outer), i)); } } count += n_inner; } } FREE(1); return count; } // List squashing ----------------------------------------------------- static r_ssize list_squash(squash_info_t info, r_obj* outer, r_obj* out, r_ssize count, bool (*is_spliceable)(r_obj*), int depth) { if (r_typeof(outer) != VECSXP) { r_abort("Only lists can be spliced"); } r_obj* inner; r_obj* out_names = KEEP(r_names(out)); r_ssize n_outer = r_length(outer); for (r_ssize i = 0; i != n_outer; ++i) { inner = r_list_get(outer, i); if (depth != 0 && is_spliceable(inner)) { inner = PROTECT(maybe_unbox(inner, is_spliceable)); count = list_squash(info, inner, out, count, is_spliceable, depth - 1); UNPROTECT(1); } else { r_list_poke(out, count, inner); if (info.named && r_typeof(r_names(outer)) == R_TYPE_character) { r_obj* name = r_chr_get(r_names(outer), i); r_chr_poke(out_names, count, name); } count += 1; } } FREE(1); return count; } // First pass -------------------------------------------------------- static void squash_warn_names(void) { Rf_warningcall(r_null, "Outer names are only allowed for unnamed scalar atomic inputs"); } static void update_info_outer(squash_info_t* info, r_obj* outer, r_ssize i) { if (!info->warned && info->recursive && has_name_at(outer, i)) { squash_warn_names(); info->warned = true; } } static void update_info_inner(squash_info_t* info, r_obj* outer, r_ssize i, r_obj* inner) { r_ssize n_inner = info->recursive ? 1 : r_vec_length(inner); info->size += n_inner; // Return early if possible if (info->named && info->warned) { return; } bool named = r_typeof(r_names(inner)) == R_TYPE_character; bool recursive = info->recursive; bool copy_outer = recursive || n_inner == 1; bool copy_inner = !recursive; if (named && copy_inner) { info->named = true; } if (has_name_at(outer, i)) { if (!recursive && (n_inner != 1 || named) && !info->warned) { squash_warn_names(); info->warned = true; } if (copy_outer) { info->named = true; } } } static void squash_info(squash_info_t* info, r_obj* outer, bool (*is_spliceable)(r_obj*), int depth) { if (r_typeof(outer) != R_TYPE_list) { r_abort("Only lists can be spliced"); } r_obj* inner; r_ssize n_outer = r_length(outer); for (r_ssize i = 0; i != n_outer; ++i) { inner = r_list_get(outer, i); if (depth != 0 && is_spliceable(inner)) { update_info_outer(info, outer, i); inner = PROTECT(maybe_unbox(inner, is_spliceable)); squash_info(info, inner, is_spliceable, depth - 1); UNPROTECT(1); } else if (info->recursive || r_vec_length(inner)) { update_info_inner(info, outer, i, inner); } } } static r_obj* squash(enum r_type kind, r_obj* dots, bool (*is_spliceable)(r_obj*), int depth) { bool recursive = kind == VECSXP; squash_info_t info = squash_info_init(recursive); squash_info(&info, dots, is_spliceable, depth); r_obj* out = KEEP(r_alloc_vector(kind, info.size)); if (info.named) { r_obj* nms = KEEP(r_alloc_character(info.size)); r_attrib_poke_names(out, nms); FREE(1); } if (recursive) { list_squash(info, dots, out, 0, is_spliceable, depth); } else { atom_squash(kind, info, dots, out, 0, is_spliceable, depth); } FREE(1); return out; } // Predicates -------------------------------------------------------- typedef bool (*is_spliceable_t)(r_obj*); static bool is_spliced_bare(r_obj* x) { if (!r_is_object(x)) { return r_typeof(x) == R_TYPE_list; } else { return is_splice_box(x); } } static is_spliceable_t predicate_pointer(r_obj* x) { switch (r_typeof(x)) { case VECSXP: if (Rf_inherits(x, "fn_pointer") && r_length(x) == 1) { r_obj* ptr = r_list_get(x, 0); if (r_typeof(ptr) == EXTPTRSXP) { return (is_spliceable_t) R_ExternalPtrAddrFn(ptr); } } break; case EXTPTRSXP: return (is_spliceable_t) R_ExternalPtrAddrFn(x); default: break; } r_abort("`predicate` must be a closure or function pointer"); return NULL; } static is_spliceable_t predicate_internal(r_obj* x) { static r_obj* is_spliced_clo = NULL; if (!is_spliced_clo) { is_spliced_clo = rlang_ns_get("is_spliced"); } static r_obj* is_spliceable_clo = NULL; if (!is_spliceable_clo) { is_spliceable_clo = rlang_ns_get("is_spliced_bare"); } if (x == is_spliced_clo) { return is_splice_box; } if (x == is_spliceable_clo) { return &is_spliced_bare; } return NULL; } // Emulate closure behaviour with global variable. static r_obj* clo_spliceable = NULL; static bool is_spliceable_closure(r_obj* x) { if (!clo_spliceable) { r_abort("Internal error while splicing"); } SETCADR(clo_spliceable, x); r_obj* out = r_eval(clo_spliceable, R_GlobalEnv); return r_lgl_get(out, 0); } // Export ------------------------------------------------------------ r_obj* r_squash_if(r_obj* dots, enum r_type kind, bool (*is_spliceable)(r_obj*), int depth) { switch (kind) { case R_TYPE_logical: case R_TYPE_integer: case R_TYPE_double: case R_TYPE_complex: case R_TYPE_character: case RAWSXP: case VECSXP: return squash(kind, dots, is_spliceable, depth); default: r_abort("Splicing is not implemented for this type"); return r_null; } } r_obj* ffi_squash_closure(r_obj* dots, enum r_type kind, r_obj* pred, int depth) { r_obj* prev_pred = clo_spliceable; clo_spliceable = KEEP(Rf_lang2(pred, Rf_list2(r_null, r_null))); r_obj* out = r_squash_if(dots, kind, &is_spliceable_closure, depth); clo_spliceable = prev_pred; FREE(1); return out; } r_obj* ffi_squash(r_obj* dots, r_obj* type, r_obj* pred, r_obj* depth_) { enum r_type kind = Rf_str2type(CHAR(r_chr_get(type, 0))); int depth = Rf_asInteger(depth_); is_spliceable_t is_spliceable; switch (r_typeof(pred)) { case R_TYPE_closure: is_spliceable = predicate_internal(pred); if (is_spliceable) { return r_squash_if(dots, kind, is_spliceable, depth); } // else fallthrough case R_TYPE_builtin: case R_TYPE_special: return ffi_squash_closure(dots, kind, pred, depth); default: is_spliceable = predicate_pointer(pred); return r_squash_if(dots, kind, is_spliceable, depth); } } static r_ssize r_vec_length(r_obj* x) { switch(r_typeof(x)) { case R_TYPE_null: return 0; case R_TYPE_logical: case R_TYPE_integer: case R_TYPE_double: case R_TYPE_complex: case R_TYPE_character: case R_TYPE_raw: case R_TYPE_list: case R_TYPE_string: return XLENGTH(x); default: r_abort("Internal error: expected a vector"); } } rlang/src/internal/globals.c0000644000176200001440000000020414375670676015570 0ustar liggesusers#include #include "globals.h" struct syms syms; void rlang_init_globals(r_obj* ns) { syms.arg_nm = r_sym("arg_nm"); } rlang/src/internal/ast-rotate.c0000644000176200001440000004457514375670676016253 0ustar liggesusers#include #include "parse.h" #include "nse-inject.h" #include "ast-rotate.h" /** * struct ast_rotation_info - Rotation data gathered while recursing over AST * * @upper_pivot_op: The operation type of the upper pivot. * @upper_pivot: The expression that becomes the new root after rotation. * @lower_pivot: The expression whose LHS is attached to @upper_root. * @upper_root: The expression that becomes the LHS of @lower_pivot. * @lower_root: The expression whose RHS is attached to the LHS of @lower_pivot. * @root_parent: Node whose CAR should be reattached to @upper_pivot * after rotation. */ struct ast_rotation_info { enum r_operator upper_pivot_op; enum r_operator lower_pivot_op; r_obj* upper_pivot; r_obj* lower_pivot; r_obj* upper_root; r_obj* lower_root; r_obj* root_parent; }; #include "decl/ast-rotate-decl.h" /** * DOC: Interpolation in operator calls whose precedence might need fixup * * We want `!!` to have the precedence of unary `-` and `+` instead of * the very low precedence of `!`. To that end we need to patch the * AST to reflect the new precedence. * * Let's take `1 + 2 + 3` as a motivating example. `+` is a * left-associative operator so the expression `1 + 2` on the left is * evaluated first and it is pulled downwards in the AST: * * > 1 + 2 + 3 * * █─`+` * ├─█─`+` * │ ├─1 * │ └─2 * └─3 * * After introducing an unary operator with low precedence in the * expression we get this AST: * * > 1 + !2 + 3 * * █─`+` * ├─1 * └─█─`!` * └─█─`+` * ├─2 * └─3 * * Every binary operation on the RHS of `!` that has a higher * precedence will be evaluated before `!`. As a result the second `+` * never gets the chance of being matched to the first one, it is cut * out of the LHS of `!`. The effect of `!` on the AST is equivalent * to wrapping the problematic expression in parentheses. * * > 1 + (2 + 3) * * █─`+` * ├─1 * └─█─`(` * └─█─`+` * ├─2 * └─3 * * This is only problematic when the precedence of the `!!` operand is * lower than the precedence of its parent operation. If it is higher, * the implicit grouping is the same as the one produced by `!`: * * > ast(1 + 2 * 3) // Implicit grouping * * █─`+` * ├─1 * └─█─`* * ├─2 * └─3 * * > ast(1 + !2 * 3) // `!` grouping * * █─`+` * ├─1 * └─█─`!` * └─█─`* * ├─2 * └─3 * * If the precedence of `!`'s operand is lower the R parser will * unduly pull it downward in the AST. We can fix that by swapping the * operand with the parent node of `!`. In addition the LHS of the * operand (e.g. `2`) must become the RHS of the expression it was cut * off from. It turns out that these two operations amount to a [tree * rotation](https://en.wikipedia.org/wiki/Tree_rotation). The parent * node of `!` is the root (or rotator) and the `!` operand is the * pivot. We also need to take care of the actual expression that * needs to be unquoted, which we will call "target": * * > 1 + !!2 + 3 * * █─`+` // root * ├─1 * └─█─`!` * └─█─`!` * └─█─`+` // pivot * ├─2 // target * └─3 * * Notice from the diagrams above that the leaves of the AST have the * same ordering no matter the operation precedence. When we patch up * the AST we only change the structure of the tree not the ordering * of the leaves. Tree rotation adequately preserves the ordering of * the leaves (which is why it useful for balancing ordered binary * trees). * * The rotation algorithm roughly goes as follows: * * - The `!!` target is unquoted and replaced with the unquoted value. * - The RHS of the root is attached to the LHS of the pivot. * - The LHS of the pivot is attached to the root. * - The root's parent is reattached to the pivot. * * The full story is a bit more complicated when complex expressions * are involved. There are three main complications. First the target * might not be a child of the pivot. Let's take this expression: * * > 1 + 2 * 3 + 4 * * █─`+` * ├─█─`+` * │ ├─1 * │ └─█─`*` * │ ├─2 * │ └─3 * └─4 * * and assume we want to unquote `2`: * * > 1 + !!2 * 3 + 4 * * █─`+` // root * ├─1 * └─█─`!` * └─█─`!` * └─█─`+` // pivot * ├─█─`*` * │ ├─2 // target * │ └─3 * └─4 * * The `*` call is not a pivot because it has higher precedence than * the root `+`. Instead the pivot is the second `+` call. However * `!!` has higher precedence than `*` so the target to unquote is * deeper than the LHS of the pivot. In this case it is the LHS of the * LHS (it might be deeper but always across LHS's). * * Another source of complication is that we might need to rotate * entire subsets of the AST. First the pivot might comprise several * expressions. In this case we distinguish the lower pivot as the * node whose LHS is attached to the root and the upper pivot which * becomes the new root after rotation. This complication arises when * the `!!` operand is a succession of operations with decreasing * precedence (which is the case for left-associative operators with * the same precedence). * * > 1 + 2 + 3 + 4 + 5 * * █─`+` * ├─█─`+` * │ ├─█─`+` * │ │ ├─█─`+` * │ │ │ ├─1 * │ │ │ └─2 * │ │ └─3 * │ └─4 * └─5 * * > 1 + !!2 + 3 + 4 + 5 * * █─`+` // root * ├─1 * └─█─`!` * └─█─`!` * └─█─`+` // upper pivot * ├─█─`+` * │ ├─█─`+` // lower pivot * │ │ ├─2 // target * │ │ └─3 * │ └─4 * └─5 * * Finally the root might also comprise several expressions. In the * following example we see an upper root (which becomes the pivot's * or lower pivot's LHS) and a lower root (whose RHS is attached to * the pivot's or lower pivot's LHS). This complication happens when * the operations before `!!` have increasing levels of precedence: * * > 1 + 2 * 3 + 4 * * █─`+` * ├─█─`+` * │ ├─1 * │ └─█─`*` * │ ├─2 * │ └─3 * └─4 * * > 1 + 2 * !!3 + 4 * * █─`+` // upper root * ├─1 * └─█─`*` // lower root * ├─2 * └─█─`!` * └─█─`!` * └─█─`+` // pivot * ├─3 // target * └─4 * * These three complications (deep target, root, and pivot) may arise * in conjunction. * * In addition we also need to deal with multiple `!!` calls in a * series of binary operations. This is handled by recursing from the * upper pivot (the new root) after rotation. Finally the possibility * of intervening unary `+` or `-` operations also needs special * handling. * * All operators whose precedence lies between prec(`!`) and * prec(`!!`) might be involved in such a fixup of the AST. We call * these the "problematic" operators. Since the root can be multiple * expressions deep, we can't tell in advance whether the current * operation in the AST is involved in a rotation. Hence we apply * node_list_interp_fixup() instead of node_list_interp() whenever we * reach a problematic operator. */ static bool op_is_unary(enum r_operator op) { if (op == R_OP_NONE || op > R_OP_MAX) { r_abort("Internal error: `enum r_operator` out of bounds"); } return r_ops_precedence[op].unary; } static bool is_unary(r_obj* x) { return op_is_unary(r_which_operator(x)); } static bool op_is_unary_plusminus(enum r_operator op) { switch (op) { case R_OP_PLUS_UNARY: case R_OP_MINUS_UNARY: return true; default: return false; } } static bool is_unary_plusminus(r_obj* x) { return op_is_unary_plusminus(r_which_operator(x)); } static void initialise_rotation_info(struct ast_rotation_info* info) { info->upper_pivot_op = R_OP_NONE; info->upper_pivot = NULL; info->lower_pivot = NULL; info->upper_root = NULL; info->lower_root = NULL; info->root_parent = NULL; } /** * maybe_rotate() - Rotate if we found a pivot * * @op: Problematic operator. * @env: The unquoting environment. * @info: See &struct ast_rotation_info. * * If @op has precedence over the upper pivot, this is the upper * root. Otherwise use &ast_rotation_info->upper_root. If the latter * is not defined, this means no rotation is needed because the effect * of `!` on the AST corresponds to the implicit grouping (e.g. with * `1 + !!2 * 3`). */ static r_obj* maybe_rotate(r_obj* op, r_obj* env, struct ast_rotation_info* info) { if (info->upper_pivot_op == R_OP_NONE) { return op; } // Rotate if `op` is the upper root if (r_lhs_op_has_precedence(r_which_operator(op), info->upper_pivot_op)) { // Swap the lower root's RHS with the lower pivot's LHS r_node_poke_car(info->lower_root, r_node_cadr(info->lower_pivot)); r_node_poke_cadr(info->lower_pivot, op); // After rotation the upper pivot is the new root op = info->upper_pivot; } else if (info->upper_root) { r_node_poke_car(info->lower_root, r_node_cadr(info->lower_pivot)); r_node_poke_cadr(info->lower_pivot, info->upper_root); r_node_poke_car(r_node_cddr(info->root_parent), info->upper_pivot); } // else there is no rotation needed // Reinitialise the `ast_rotation_info` on the stack in order to // reuse it in the recursion initialise_rotation_info(info); // Recurse on the RHS of the upper pivot (which is now the new root) node_list_interp_fixup(op, NULL, env, info, false); return maybe_rotate(op, env, info); } /** * fixup_interp() - Expand a problematic operation * * @x: A problematic operation, i.e. a call to an operator whose * precedence is between that of `!` and that of `!!`. * @env: The unquoting environment. * * The expression to expand is an operator that might need changes in * the AST if we find a `!!` call down the line. From this point on * there is a &struct ast_rotation_info on the stack. */ r_obj* fixup_interp(r_obj* x, r_obj* env) { // Happens with constructed calls without arguments such as `/`() if (r_node_cdr(x) == r_null) { return x; } struct ast_rotation_info rotation_info; initialise_rotation_info(&rotation_info); // Look for problematic !! calls and expand arguments on the way. // If a pivot is found rotate it around `x`. node_list_interp_fixup(x, NULL, env, &rotation_info, true); return maybe_rotate(x, env, &rotation_info); } /** * fixup_interp_first() - Expand a problematic operation starting with `!!` * * @x: A problematic operation whose LHS is a `!!` call, e.g. `!!1 + 2 + 3`. * @env: The unquoting environment. * * If `!!` is the root expression there is no rotation needed. Just * unquote the leftmost child across problematic binary operators. * However the resulting root might be involved in a rotation for a * subsequent `!!` call. */ r_obj* fixup_interp_first(r_obj* x, r_obj* env) { r_obj* parent = NULL; // `parent` will always be initialised in the loop r_obj* target = x; while (is_problematic_op((parent = target, target = r_node_cadr(target))) && !is_unary(target)) { r_obj* rhs = r_node_cddr(target); r_node_poke_car(rhs, call_interp(r_node_car(rhs), env)); }; // Unquote target r_node_poke_cadr(parent, r_eval(target, env)); // Expand the new root but no need to expand LHS as we just unquoted it struct ast_rotation_info rotation_info; initialise_rotation_info(&rotation_info); node_list_interp_fixup(x, NULL, env, &rotation_info, false); return maybe_rotate(x, env, &rotation_info); } /** * find_upper_pivot() - Find upper pivot * * @x: An expression. * @info: See &struct ast_rotation_info. * * Detect `!!` call structures. The operand is the upper pivot. Fill * in &ast_rotation_info->upper_pivot_op and * &ast_rotation_info->upper_pivot within @info. */ static void find_upper_pivot(r_obj* x, struct ast_rotation_info* info) { if (!r_is_call(x, "!")) { return; } x = r_node_cadr(x); if (!r_is_call(x, "!")) { return; } x = r_node_cadr(x); if (r_is_call(x, "!")) { return; } enum r_operator op = r_which_operator(x); if (!op_needs_fixup(op)) { return; } info->upper_pivot_op = op; info->upper_pivot = x; } /** * find_lower_pivot() - Find lower pivot and unquote target * * @x: This is the upper pivot in the first call and the LHS of the * previous node when recursing. * @parent_node: Used to handle unary `+` and `-`, e.g. `1 + !!-2 + 3`. * @env: Unquoting environment. * @info: See &struct ast_rotation_info. * * Climb through LHS's until we find an operator that has greater * precendence than the upper pivot. This node is the lower pivot * whose LHS will be attached to the upper root. Continue climbing the * LHS's until we find the target and unquote it in place. Expand all * RHS's on the way there. * * Fill in &ast_rotation_info->lower_pivot within @info. */ static void find_lower_pivot(r_obj* x, r_obj* parent_node, r_obj* env, struct ast_rotation_info* info) { r_obj* lhs_node = r_node_cdr(x); r_obj* rhs_node = r_node_cdr(lhs_node); // We found an unary `+` or `-` on the way if (rhs_node == r_null) { r_obj* target = r_eval(x, env); if (parent_node) { r_node_poke_car(parent_node, target); } else { r_node_poke_car(info->lower_root, target); // If there is no parent x there is no operator precedence to // fix so abort recursion initialise_rotation_info(info); } return; } // Only expand RHS if not the upper pivot because there might be // consecutive rotations needed. The upper pivot's RHS will be // expanded after the current rotation is complete. if (x != info->upper_pivot) { r_node_poke_car(rhs_node, call_interp(r_node_car(rhs_node), env)); } r_obj* lhs = r_node_car(lhs_node); enum r_operator lhs_op = r_which_operator(lhs); if (!op_needs_fixup(lhs_op)) { r_obj* target = r_eval(lhs, env); r_node_poke_cadr(x, target); // Stop recursion once we found target return; } if (r_lhs_op_has_precedence(info->lower_pivot_op, lhs_op)) { info->lower_pivot = lhs; info->lower_pivot_op = lhs_op; } // Recurse find_lower_pivot(lhs, lhs_node, env, info); } /** * node_list_interp_fixup() - Expansion for binary operators that might need fixup * * @x A call to a binary operator whith problematic precedence * (between prec(`!`) and prec(`!!`)). * @env The environment where to unquote the `!!` target. * @parent Needed to handle a mix of unary and binary operators * supplied to the unquote operator, e.g. `!!-1 + 2`. This is the * outer call of which `x` is an argument, or the C `NULL` if there * is none. * @info Information about the pivot, the root and the unquoted target. * @expand_lhs Whether to expand the LHS. In some cases (e.g. after a * rotation) it is not necessary to expand the LHS as it was already * visited. */ static r_obj* node_list_interp_fixup(r_obj* x, r_obj* parent, r_obj* env, struct ast_rotation_info* info, bool expand_lhs) { r_obj* lhs_node = r_node_cdr(x); r_obj* lhs = r_node_car(lhs_node); // If there's a unary `+` or `-` on the way recurse on its RHS if (is_unary_plusminus(x)) { node_list_interp_fixup_rhs(lhs, lhs_node, parent, env, info); return x; } r_obj* rhs_node = r_node_cddr(x); r_obj* rhs = r_node_car(rhs_node); if (expand_lhs) { // Expand the LHS normally, it never needs changes in the AST r_node_poke_car(lhs_node, call_interp(r_node_car(lhs_node), env)); } node_list_interp_fixup_rhs(rhs, rhs_node, x, env, info); return x; } /** * node_list_interp_fixup_rhs() - Expansion for binary operators that might need fixup * * @rhs: The right-hand side argument of an operator with problematic * precedence. * @rhs_node: Parent node of RHS. If `rhs` is a `!!` call, we reattach * the `!!` operand to its parent node `rhs_node`. * @parent: See node_list_interp_fixup(). * @env: The unquoting environment. * @info: See &struct ast_rotation_info. */ static void node_list_interp_fixup_rhs(r_obj* rhs, r_obj* rhs_node, r_obj* parent, r_obj* env, struct ast_rotation_info* info) { // Happens with constructed calls like `/`(1) if (rhs_node == r_null) { return; } // An upper pivot is an operand of a !! call that is a binary // operation whose precedence is problematic (between prec(`!`) and // prec(`!!`)) find_upper_pivot(rhs, info); if (info->upper_pivot) { info->lower_root = rhs_node; // There might be a lower pivot, so we need to find it. Also find // the target of unquoting (leftmost leaf whose predecence is // greater than prec(`!!`)) and unquote it. info->lower_pivot = info->upper_pivot; info->lower_pivot_op = info->upper_pivot_op; find_lower_pivot(info->upper_pivot, NULL, env, info); if (info->upper_pivot) { // Reattach the RHS to the upper pivot stripped of its !! call // in case there is no rotation around the lower root r_node_poke_car(rhs_node, info->upper_pivot); } return; } // If `rhs` is an operator that might be involved in a rotation // recurse with the fixup version if (is_problematic_op(rhs)) { node_list_interp_fixup(rhs, parent, env, info, true); // This might the upper root around which to rotate if (info->upper_pivot_op && r_lhs_op_has_precedence(r_which_operator(rhs), info->upper_pivot_op)) { info->upper_root = rhs; info->root_parent = parent; } return; } // RHS is not a binary operation that might need changes in the AST // so expand it as usual r_node_poke_car(rhs_node, call_interp(rhs, env)); } rlang/src/internal/env.c0000644000176200001440000000365014741441060014721 0ustar liggesusers#include #define FRAME_LOCK_MASK (1 << 14) #define FRAME_IS_LOCKED(e) (ENVFLAGS(e) & FRAME_LOCK_MASK) #define UNLOCK_FRAME(e) SET_ENVFLAGS(e, ENVFLAGS(e) & (~FRAME_LOCK_MASK)) // Should only be used in development tools r_obj* ffi_env_unlock(r_obj* env) { UNLOCK_FRAME(env); return FRAME_IS_LOCKED(env) == 0 ? r_true : r_false; } void r_env_unbind_anywhere(r_obj* env, r_obj* sym) { while (env != r_envs.empty) { if (r_env_has(env, sym)) { r_env_unbind(env, sym); return; } env = r_env_parent(env); } } static void env_unbind_names(r_obj* env, r_obj* names, bool inherit) { r_obj* const * p_names = r_chr_cbegin(names); r_ssize n = r_length(names); if (inherit) { for (r_ssize i = 0; i < n; ++i) { r_obj* sym = r_str_as_symbol(p_names[i]); r_env_unbind_anywhere(env, sym); } } else { for (r_ssize i = 0; i < n; ++i) { r_obj* sym = r_str_as_symbol(p_names[i]); r_env_unbind(env, sym); } } } void r_env_unbind_names(r_obj* env, r_obj* names) { env_unbind_names(env, names, false); } void r_env_unbind_anywhere_names(r_obj* env, r_obj* names) { env_unbind_names(env, names, true); } void r_env_unbind_c_strings(r_obj* env, const char** names, r_ssize n) { r_obj* nms = KEEP(r_chr_n(names, n)); r_env_unbind_names(env, nms); FREE(1); } void r_env_unbind_anywhere_c_strings(r_obj* env, const char** names, r_ssize n) { r_obj* nms = KEEP(r_chr_n(names, n)); r_env_unbind_anywhere_names(env, nms); FREE(1); } void r_env_unbind_c_string(r_obj* env, const char* name) { static const char* names[1] = { "" }; names[0] = name; r_env_unbind_c_strings(env, names, 1); } void r_env_unbind_anywhere_c_string(r_obj* env, const char* name) { static const char* names[1] = { "" }; names[0] = name; r_env_unbind_anywhere_c_strings(env, names, 1); } r_obj* ffi_env_coalesce(r_obj* env, r_obj* from) { r_env_coalesce(env, from); return r_null; } rlang/src/internal/xxhash/0000755000176200001440000000000014127057575015300 5ustar liggesusersrlang/src/internal/xxhash/xxhash.h0000644000176200001440000055075114127057575016771 0ustar liggesusers/* * xxHash - Extremely Fast Hash algorithm * Header File * Copyright (C) 2012-2020 Yann Collet * * BSD 2-Clause License (https://www.opensource.org/licenses/bsd-license.php) * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are * met: * * * Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * Redistributions in binary form must reproduce the above * copyright notice, this list of conditions and the following disclaimer * in the documentation and/or other materials provided with the * distribution. * * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. * * You can contact the author at: * - xxHash homepage: https://www.xxhash.com * - xxHash source repository: https://github.com/Cyan4973/xxHash */ /* TODO: update */ /* Notice extracted from xxHash homepage: xxHash is an extremely fast hash algorithm, running at RAM speed limits. It also successfully passes all tests from the SMHasher suite. Comparison (single thread, Windows Seven 32 bits, using SMHasher on a Core 2 Duo @3GHz) Name Speed Q.Score Author xxHash 5.4 GB/s 10 CrapWow 3.2 GB/s 2 Andrew MumurHash 3a 2.7 GB/s 10 Austin Appleby SpookyHash 2.0 GB/s 10 Bob Jenkins SBox 1.4 GB/s 9 Bret Mulvey Lookup3 1.2 GB/s 9 Bob Jenkins SuperFastHash 1.2 GB/s 1 Paul Hsieh CityHash64 1.05 GB/s 10 Pike & Alakuijala FNV 0.55 GB/s 5 Fowler, Noll, Vo CRC32 0.43 GB/s 9 MD5-32 0.33 GB/s 10 Ronald L. Rivest SHA1-32 0.28 GB/s 10 Q.Score is a measure of quality of the hash function. It depends on successfully passing SMHasher test set. 10 is a perfect score. Note: SMHasher's CRC32 implementation is not the fastest one. Other speed-oriented implementations can be faster, especially in combination with PCLMUL instruction: https://fastcompression.blogspot.com/2019/03/presenting-xxh3.html?showComment=1552696407071#c3490092340461170735 A 64-bit version, named XXH64, is available since r35. It offers much better speed, but for 64-bit applications only. Name Speed on 64 bits Speed on 32 bits XXH64 13.8 GB/s 1.9 GB/s XXH32 6.8 GB/s 6.0 GB/s */ #if defined (__cplusplus) extern "C" { #endif /* **************************** * INLINE mode ******************************/ /*! * XXH_INLINE_ALL (and XXH_PRIVATE_API) * Use these build macros to inline xxhash into the target unit. * Inlining improves performance on small inputs, especially when the length is * expressed as a compile-time constant: * * https://fastcompression.blogspot.com/2018/03/xxhash-for-small-keys-impressive-power.html * * It also keeps xxHash symbols private to the unit, so they are not exported. * * Usage: * #define XXH_INLINE_ALL * #include "xxhash.h" * * Do not compile and link xxhash.o as a separate object, as it is not useful. */ #if (defined(XXH_INLINE_ALL) || defined(XXH_PRIVATE_API)) \ && !defined(XXH_INLINE_ALL_31684351384) /* this section should be traversed only once */ # define XXH_INLINE_ALL_31684351384 /* give access to the advanced API, required to compile implementations */ # undef XXH_STATIC_LINKING_ONLY /* avoid macro redef */ # define XXH_STATIC_LINKING_ONLY /* make all functions private */ # undef XXH_PUBLIC_API # if defined(__GNUC__) # define XXH_PUBLIC_API static __inline __attribute__((unused)) # elif defined (__cplusplus) || (defined (__STDC_VERSION__) && (__STDC_VERSION__ >= 199901L) /* C99 */) # define XXH_PUBLIC_API static inline # elif defined(_MSC_VER) # define XXH_PUBLIC_API static __inline # else /* note: this version may generate warnings for unused static functions */ # define XXH_PUBLIC_API static # endif /* * This part deals with the special case where a unit wants to inline xxHash, * but "xxhash.h" has previously been included without XXH_INLINE_ALL, such * as part of some previously included *.h header file. * Without further action, the new include would just be ignored, * and functions would effectively _not_ be inlined (silent failure). * The following macros solve this situation by prefixing all inlined names, * avoiding naming collision with previous inclusions. */ # ifdef XXH_NAMESPACE # error "XXH_INLINE_ALL with XXH_NAMESPACE is not supported" /* * Note: Alternative: #undef all symbols (it's a pretty large list). * Without #error: it compiles, but functions are actually not inlined. */ # endif # define XXH_NAMESPACE XXH_INLINE_ /* * Some identifiers (enums, type names) are not symbols, but they must * still be renamed to avoid redeclaration. * Alternative solution: do not redeclare them. * However, this requires some #ifdefs, and is a more dispersed action. * Meanwhile, renaming can be achieved in a single block */ # define XXH_IPREF(Id) XXH_INLINE_ ## Id # define XXH_OK XXH_IPREF(XXH_OK) # define XXH_ERROR XXH_IPREF(XXH_ERROR) # define XXH_errorcode XXH_IPREF(XXH_errorcode) # define XXH32_canonical_t XXH_IPREF(XXH32_canonical_t) # define XXH64_canonical_t XXH_IPREF(XXH64_canonical_t) # define XXH128_canonical_t XXH_IPREF(XXH128_canonical_t) # define XXH32_state_s XXH_IPREF(XXH32_state_s) # define XXH32_state_t XXH_IPREF(XXH32_state_t) # define XXH64_state_s XXH_IPREF(XXH64_state_s) # define XXH64_state_t XXH_IPREF(XXH64_state_t) # define XXH3_state_s XXH_IPREF(XXH3_state_s) # define XXH3_state_t XXH_IPREF(XXH3_state_t) # define XXH128_hash_t XXH_IPREF(XXH128_hash_t) /* Ensure the header is parsed again, even if it was previously included */ # undef XXHASH_H_5627135585666179 # undef XXHASH_H_STATIC_13879238742 #endif /* XXH_INLINE_ALL || XXH_PRIVATE_API */ /* **************************************************************** * Stable API *****************************************************************/ #ifndef XXHASH_H_5627135585666179 #define XXHASH_H_5627135585666179 1 /* specific declaration modes for Windows */ #if !defined(XXH_INLINE_ALL) && !defined(XXH_PRIVATE_API) # if defined(WIN32) && defined(_MSC_VER) && (defined(XXH_IMPORT) || defined(XXH_EXPORT)) # ifdef XXH_EXPORT # define XXH_PUBLIC_API __declspec(dllexport) # elif XXH_IMPORT # define XXH_PUBLIC_API __declspec(dllimport) # endif # else # define XXH_PUBLIC_API /* do nothing */ # endif #endif /*! * XXH_NAMESPACE, aka Namespace Emulation: * * If you want to include _and expose_ xxHash functions from within your own * library, but also want to avoid symbol collisions with other libraries which * may also include xxHash, you can use XXH_NAMESPACE to automatically prefix * any public symbol from xxhash library with the value of XXH_NAMESPACE * (therefore, avoid empty or numeric values). * * Note that no change is required within the calling program as long as it * includes `xxhash.h`: Regular symbol names will be automatically translated * by this header. */ #ifdef XXH_NAMESPACE # define XXH_CAT(A,B) A##B # define XXH_NAME2(A,B) XXH_CAT(A,B) # define XXH_versionNumber XXH_NAME2(XXH_NAMESPACE, XXH_versionNumber) /* XXH32 */ # define XXH32 XXH_NAME2(XXH_NAMESPACE, XXH32) # define XXH32_createState XXH_NAME2(XXH_NAMESPACE, XXH32_createState) # define XXH32_freeState XXH_NAME2(XXH_NAMESPACE, XXH32_freeState) # define XXH32_reset XXH_NAME2(XXH_NAMESPACE, XXH32_reset) # define XXH32_update XXH_NAME2(XXH_NAMESPACE, XXH32_update) # define XXH32_digest XXH_NAME2(XXH_NAMESPACE, XXH32_digest) # define XXH32_copyState XXH_NAME2(XXH_NAMESPACE, XXH32_copyState) # define XXH32_canonicalFromHash XXH_NAME2(XXH_NAMESPACE, XXH32_canonicalFromHash) # define XXH32_hashFromCanonical XXH_NAME2(XXH_NAMESPACE, XXH32_hashFromCanonical) /* XXH64 */ # define XXH64 XXH_NAME2(XXH_NAMESPACE, XXH64) # define XXH64_createState XXH_NAME2(XXH_NAMESPACE, XXH64_createState) # define XXH64_freeState XXH_NAME2(XXH_NAMESPACE, XXH64_freeState) # define XXH64_reset XXH_NAME2(XXH_NAMESPACE, XXH64_reset) # define XXH64_update XXH_NAME2(XXH_NAMESPACE, XXH64_update) # define XXH64_digest XXH_NAME2(XXH_NAMESPACE, XXH64_digest) # define XXH64_copyState XXH_NAME2(XXH_NAMESPACE, XXH64_copyState) # define XXH64_canonicalFromHash XXH_NAME2(XXH_NAMESPACE, XXH64_canonicalFromHash) # define XXH64_hashFromCanonical XXH_NAME2(XXH_NAMESPACE, XXH64_hashFromCanonical) /* XXH3_64bits */ # define XXH3_64bits XXH_NAME2(XXH_NAMESPACE, XXH3_64bits) # define XXH3_64bits_withSecret XXH_NAME2(XXH_NAMESPACE, XXH3_64bits_withSecret) # define XXH3_64bits_withSeed XXH_NAME2(XXH_NAMESPACE, XXH3_64bits_withSeed) # define XXH3_createState XXH_NAME2(XXH_NAMESPACE, XXH3_createState) # define XXH3_freeState XXH_NAME2(XXH_NAMESPACE, XXH3_freeState) # define XXH3_copyState XXH_NAME2(XXH_NAMESPACE, XXH3_copyState) # define XXH3_64bits_reset XXH_NAME2(XXH_NAMESPACE, XXH3_64bits_reset) # define XXH3_64bits_reset_withSeed XXH_NAME2(XXH_NAMESPACE, XXH3_64bits_reset_withSeed) # define XXH3_64bits_reset_withSecret XXH_NAME2(XXH_NAMESPACE, XXH3_64bits_reset_withSecret) # define XXH3_64bits_update XXH_NAME2(XXH_NAMESPACE, XXH3_64bits_update) # define XXH3_64bits_digest XXH_NAME2(XXH_NAMESPACE, XXH3_64bits_digest) # define XXH3_generateSecret XXH_NAME2(XXH_NAMESPACE, XXH3_generateSecret) /* XXH3_128bits */ # define XXH128 XXH_NAME2(XXH_NAMESPACE, XXH128) # define XXH3_128bits XXH_NAME2(XXH_NAMESPACE, XXH3_128bits) # define XXH3_128bits_withSeed XXH_NAME2(XXH_NAMESPACE, XXH3_128bits_withSeed) # define XXH3_128bits_withSecret XXH_NAME2(XXH_NAMESPACE, XXH3_128bits_withSecret) # define XXH3_128bits_reset XXH_NAME2(XXH_NAMESPACE, XXH3_128bits_reset) # define XXH3_128bits_reset_withSeed XXH_NAME2(XXH_NAMESPACE, XXH3_128bits_reset_withSeed) # define XXH3_128bits_reset_withSecret XXH_NAME2(XXH_NAMESPACE, XXH3_128bits_reset_withSecret) # define XXH3_128bits_update XXH_NAME2(XXH_NAMESPACE, XXH3_128bits_update) # define XXH3_128bits_digest XXH_NAME2(XXH_NAMESPACE, XXH3_128bits_digest) # define XXH128_isEqual XXH_NAME2(XXH_NAMESPACE, XXH128_isEqual) # define XXH128_cmp XXH_NAME2(XXH_NAMESPACE, XXH128_cmp) # define XXH128_canonicalFromHash XXH_NAME2(XXH_NAMESPACE, XXH128_canonicalFromHash) # define XXH128_hashFromCanonical XXH_NAME2(XXH_NAMESPACE, XXH128_hashFromCanonical) #endif /* ************************************* * Version ***************************************/ #define XXH_VERSION_MAJOR 0 #define XXH_VERSION_MINOR 8 #define XXH_VERSION_RELEASE 0 #define XXH_VERSION_NUMBER (XXH_VERSION_MAJOR *100*100 + XXH_VERSION_MINOR *100 + XXH_VERSION_RELEASE) XXH_PUBLIC_API unsigned XXH_versionNumber (void); /* **************************** * Definitions ******************************/ #include /* size_t */ typedef enum { XXH_OK=0, XXH_ERROR } XXH_errorcode; /*-********************************************************************** * 32-bit hash ************************************************************************/ #if !defined (__VMS) \ && (defined (__cplusplus) \ || (defined (__STDC_VERSION__) && (__STDC_VERSION__ >= 199901L) /* C99 */) ) # include typedef uint32_t XXH32_hash_t; #else # include # if UINT_MAX == 0xFFFFFFFFUL typedef unsigned int XXH32_hash_t; # else # if ULONG_MAX == 0xFFFFFFFFUL typedef unsigned long XXH32_hash_t; # else # error "unsupported platform: need a 32-bit type" # endif # endif #endif /*! * XXH32(): * Calculate the 32-bit hash of sequence "length" bytes stored at memory address "input". * The memory between input & input+length must be valid (allocated and read-accessible). * "seed" can be used to alter the result predictably. * Speed on Core 2 Duo @ 3 GHz (single thread, SMHasher benchmark): 5.4 GB/s * * Note: XXH3 provides competitive speed for both 32-bit and 64-bit systems, * and offers true 64/128 bit hash results. It provides a superior level of * dispersion, and greatly reduces the risks of collisions. */ XXH_PUBLIC_API XXH32_hash_t XXH32 (const void* input, size_t length, XXH32_hash_t seed); /******* Streaming *******/ /* * Streaming functions generate the xxHash value from an incrememtal input. * This method is slower than single-call functions, due to state management. * For small inputs, prefer `XXH32()` and `XXH64()`, which are better optimized. * * An XXH state must first be allocated using `XXH*_createState()`. * * Start a new hash by initializing the state with a seed using `XXH*_reset()`. * * Then, feed the hash state by calling `XXH*_update()` as many times as necessary. * * The function returns an error code, with 0 meaning OK, and any other value * meaning there is an error. * * Finally, a hash value can be produced anytime, by using `XXH*_digest()`. * This function returns the nn-bits hash as an int or long long. * * It's still possible to continue inserting input into the hash state after a * digest, and generate new hash values later on by invoking `XXH*_digest()`. * * When done, release the state using `XXH*_freeState()`. */ typedef struct XXH32_state_s XXH32_state_t; /* incomplete type */ XXH_PUBLIC_API XXH32_state_t* XXH32_createState(void); XXH_PUBLIC_API XXH_errorcode XXH32_freeState(XXH32_state_t* statePtr); XXH_PUBLIC_API void XXH32_copyState(XXH32_state_t* dst_state, const XXH32_state_t* src_state); XXH_PUBLIC_API XXH_errorcode XXH32_reset (XXH32_state_t* statePtr, XXH32_hash_t seed); XXH_PUBLIC_API XXH_errorcode XXH32_update (XXH32_state_t* statePtr, const void* input, size_t length); XXH_PUBLIC_API XXH32_hash_t XXH32_digest (const XXH32_state_t* statePtr); /******* Canonical representation *******/ /* * The default return values from XXH functions are unsigned 32 and 64 bit * integers. * This the simplest and fastest format for further post-processing. * * However, this leaves open the question of what is the order on the byte level, * since little and big endian conventions will store the same number differently. * * The canonical representation settles this issue by mandating big-endian * convention, the same convention as human-readable numbers (large digits first). * * When writing hash values to storage, sending them over a network, or printing * them, it's highly recommended to use the canonical representation to ensure * portability across a wider range of systems, present and future. * * The following functions allow transformation of hash values to and from * canonical format. */ typedef struct { unsigned char digest[4]; } XXH32_canonical_t; XXH_PUBLIC_API void XXH32_canonicalFromHash(XXH32_canonical_t* dst, XXH32_hash_t hash); XXH_PUBLIC_API XXH32_hash_t XXH32_hashFromCanonical(const XXH32_canonical_t* src); #ifndef XXH_NO_LONG_LONG /*-********************************************************************** * 64-bit hash ************************************************************************/ #if !defined (__VMS) \ && (defined (__cplusplus) \ || (defined (__STDC_VERSION__) && (__STDC_VERSION__ >= 199901L) /* C99 */) ) # include typedef uint64_t XXH64_hash_t; #else /* the following type must have a width of 64-bit */ typedef unsigned long long XXH64_hash_t; #endif /*! * XXH64(): * Returns the 64-bit hash of sequence of length @length stored at memory * address @input. * @seed can be used to alter the result predictably. * * This function usually runs faster on 64-bit systems, but slower on 32-bit * systems (see benchmark). * * Note: XXH3 provides competitive speed for both 32-bit and 64-bit systems, * and offers true 64/128 bit hash results. It provides a superior level of * dispersion, and greatly reduces the risks of collisions. */ XXH_PUBLIC_API XXH64_hash_t XXH64 (const void* input, size_t length, XXH64_hash_t seed); /******* Streaming *******/ typedef struct XXH64_state_s XXH64_state_t; /* incomplete type */ XXH_PUBLIC_API XXH64_state_t* XXH64_createState(void); XXH_PUBLIC_API XXH_errorcode XXH64_freeState(XXH64_state_t* statePtr); XXH_PUBLIC_API void XXH64_copyState(XXH64_state_t* dst_state, const XXH64_state_t* src_state); XXH_PUBLIC_API XXH_errorcode XXH64_reset (XXH64_state_t* statePtr, XXH64_hash_t seed); XXH_PUBLIC_API XXH_errorcode XXH64_update (XXH64_state_t* statePtr, const void* input, size_t length); XXH_PUBLIC_API XXH64_hash_t XXH64_digest (const XXH64_state_t* statePtr); /******* Canonical representation *******/ typedef struct { unsigned char digest[sizeof(XXH64_hash_t)]; } XXH64_canonical_t; XXH_PUBLIC_API void XXH64_canonicalFromHash(XXH64_canonical_t* dst, XXH64_hash_t hash); XXH_PUBLIC_API XXH64_hash_t XXH64_hashFromCanonical(const XXH64_canonical_t* src); /*-********************************************************************** * XXH3 64-bit variant ************************************************************************/ /* ************************************************************************ * XXH3 is a new hash algorithm featuring: * - Improved speed for both small and large inputs * - True 64-bit and 128-bit outputs * - SIMD acceleration * - Improved 32-bit viability * * Speed analysis methodology is explained here: * * https://fastcompression.blogspot.com/2019/03/presenting-xxh3.html * * In general, expect XXH3 to run about ~2x faster on large inputs and >3x * faster on small ones compared to XXH64, though exact differences depend on * the platform. * * The algorithm is portable: Like XXH32 and XXH64, it generates the same hash * on all platforms. * * It benefits greatly from SIMD and 64-bit arithmetic, but does not require it. * * Almost all 32-bit and 64-bit targets that can run XXH32 smoothly can run * XXH3 at competitive speeds, even if XXH64 runs slowly. Further details are * explained in the implementation. * * Optimized implementations are provided for AVX512, AVX2, SSE2, NEON, POWER8, * ZVector and scalar targets. This can be controlled with the XXH_VECTOR macro. * * XXH3 offers 2 variants, _64bits and _128bits. * When only 64 bits are needed, prefer calling the _64bits variant, as it * reduces the amount of mixing, resulting in faster speed on small inputs. * * It's also generally simpler to manipulate a scalar return type than a struct. * * The 128-bit version adds additional strength, but it is slightly slower. * * The XXH3 algorithm is still in development. * The results it produces may still change in future versions. * * Results produced by v0.7.x are not comparable with results from v0.7.y. * However, the API is completely stable, and it can safely be used for * ephemeral data (local sessions). * * Avoid storing values in long-term storage until the algorithm is finalized. * XXH3's return values will be officially finalized upon reaching v0.8.0. * * After which, return values of XXH3 and XXH128 will no longer change in * future versions. * * The API supports one-shot hashing, streaming mode, and custom secrets. */ /* XXH3_64bits(): * default 64-bit variant, using default secret and default seed of 0. * It's the fastest variant. */ XXH_PUBLIC_API XXH64_hash_t XXH3_64bits(const void* data, size_t len); /* * XXH3_64bits_withSeed(): * This variant generates a custom secret on the fly * based on default secret altered using the `seed` value. * While this operation is decently fast, note that it's not completely free. * Note: seed==0 produces the same results as XXH3_64bits(). */ XXH_PUBLIC_API XXH64_hash_t XXH3_64bits_withSeed(const void* data, size_t len, XXH64_hash_t seed); /* * XXH3_64bits_withSecret(): * It's possible to provide any blob of bytes as a "secret" to generate the hash. * This makes it more difficult for an external actor to prepare an intentional collision. * The main condition is that secretSize *must* be large enough (>= XXH3_SECRET_SIZE_MIN). * However, the quality of produced hash values depends on secret's entropy. * Technically, the secret must look like a bunch of random bytes. * Avoid "trivial" or structured data such as repeated sequences or a text document. * Whenever unsure about the "randomness" of the blob of bytes, * consider relabelling it as a "custom seed" instead, * and employ "XXH3_generateSecret()" (see below) * to generate a high entropy secret derived from the custom seed. */ #define XXH3_SECRET_SIZE_MIN 136 XXH_PUBLIC_API XXH64_hash_t XXH3_64bits_withSecret(const void* data, size_t len, const void* secret, size_t secretSize); /******* Streaming *******/ /* * Streaming requires state maintenance. * This operation costs memory and CPU. * As a consequence, streaming is slower than one-shot hashing. * For better performance, prefer one-shot functions whenever applicable. */ typedef struct XXH3_state_s XXH3_state_t; XXH_PUBLIC_API XXH3_state_t* XXH3_createState(void); XXH_PUBLIC_API XXH_errorcode XXH3_freeState(XXH3_state_t* statePtr); XXH_PUBLIC_API void XXH3_copyState(XXH3_state_t* dst_state, const XXH3_state_t* src_state); /* * XXH3_64bits_reset(): * Initialize with default parameters. * digest will be equivalent to `XXH3_64bits()`. */ XXH_PUBLIC_API XXH_errorcode XXH3_64bits_reset(XXH3_state_t* statePtr); /* * XXH3_64bits_reset_withSeed(): * Generate a custom secret from `seed`, and store it into `statePtr`. * digest will be equivalent to `XXH3_64bits_withSeed()`. */ XXH_PUBLIC_API XXH_errorcode XXH3_64bits_reset_withSeed(XXH3_state_t* statePtr, XXH64_hash_t seed); /* * XXH3_64bits_reset_withSecret(): * `secret` is referenced, it _must outlive_ the hash streaming session. * Similar to one-shot API, `secretSize` must be >= `XXH3_SECRET_SIZE_MIN`, * and the quality of produced hash values depends on secret's entropy * (secret's content should look like a bunch of random bytes). * When in doubt about the randomness of a candidate `secret`, * consider employing `XXH3_generateSecret()` instead (see below). */ XXH_PUBLIC_API XXH_errorcode XXH3_64bits_reset_withSecret(XXH3_state_t* statePtr, const void* secret, size_t secretSize); XXH_PUBLIC_API XXH_errorcode XXH3_64bits_update (XXH3_state_t* statePtr, const void* input, size_t length); XXH_PUBLIC_API XXH64_hash_t XXH3_64bits_digest (const XXH3_state_t* statePtr); /* note : canonical representation of XXH3 is the same as XXH64 * since they both produce XXH64_hash_t values */ /*-********************************************************************** * XXH3 128-bit variant ************************************************************************/ typedef struct { XXH64_hash_t low64; XXH64_hash_t high64; } XXH128_hash_t; XXH_PUBLIC_API XXH128_hash_t XXH3_128bits(const void* data, size_t len); XXH_PUBLIC_API XXH128_hash_t XXH3_128bits_withSeed(const void* data, size_t len, XXH64_hash_t seed); XXH_PUBLIC_API XXH128_hash_t XXH3_128bits_withSecret(const void* data, size_t len, const void* secret, size_t secretSize); /******* Streaming *******/ /* * Streaming requires state maintenance. * This operation costs memory and CPU. * As a consequence, streaming is slower than one-shot hashing. * For better performance, prefer one-shot functions whenever applicable. * * XXH3_128bits uses the same XXH3_state_t as XXH3_64bits(). * Use already declared XXH3_createState() and XXH3_freeState(). * * All reset and streaming functions have same meaning as their 64-bit counterpart. */ XXH_PUBLIC_API XXH_errorcode XXH3_128bits_reset(XXH3_state_t* statePtr); XXH_PUBLIC_API XXH_errorcode XXH3_128bits_reset_withSeed(XXH3_state_t* statePtr, XXH64_hash_t seed); XXH_PUBLIC_API XXH_errorcode XXH3_128bits_reset_withSecret(XXH3_state_t* statePtr, const void* secret, size_t secretSize); XXH_PUBLIC_API XXH_errorcode XXH3_128bits_update (XXH3_state_t* statePtr, const void* input, size_t length); XXH_PUBLIC_API XXH128_hash_t XXH3_128bits_digest (const XXH3_state_t* statePtr); /* Following helper functions make it possible to compare XXH128_hast_t values. * Since XXH128_hash_t is a structure, this capability is not offered by the language. * Note: For better performance, these functions can be inlined using XXH_INLINE_ALL */ /*! * XXH128_isEqual(): * Return: 1 if `h1` and `h2` are equal, 0 if they are not. */ XXH_PUBLIC_API int XXH128_isEqual(XXH128_hash_t h1, XXH128_hash_t h2); /*! * XXH128_cmp(): * * This comparator is compatible with stdlib's `qsort()`/`bsearch()`. * * return: >0 if *h128_1 > *h128_2 * =0 if *h128_1 == *h128_2 * <0 if *h128_1 < *h128_2 */ XXH_PUBLIC_API int XXH128_cmp(const void* h128_1, const void* h128_2); /******* Canonical representation *******/ typedef struct { unsigned char digest[sizeof(XXH128_hash_t)]; } XXH128_canonical_t; XXH_PUBLIC_API void XXH128_canonicalFromHash(XXH128_canonical_t* dst, XXH128_hash_t hash); XXH_PUBLIC_API XXH128_hash_t XXH128_hashFromCanonical(const XXH128_canonical_t* src); #endif /* XXH_NO_LONG_LONG */ #endif /* XXHASH_H_5627135585666179 */ #if defined(XXH_STATIC_LINKING_ONLY) && !defined(XXHASH_H_STATIC_13879238742) #define XXHASH_H_STATIC_13879238742 /* **************************************************************************** * This section contains declarations which are not guaranteed to remain stable. * They may change in future versions, becoming incompatible with a different * version of the library. * These declarations should only be used with static linking. * Never use them in association with dynamic linking! ***************************************************************************** */ /* * These definitions are only present to allow static allocation * of XXH states, on stack or in a struct, for example. * Never **ever** access their members directly. */ struct XXH32_state_s { XXH32_hash_t total_len_32; XXH32_hash_t large_len; XXH32_hash_t v1; XXH32_hash_t v2; XXH32_hash_t v3; XXH32_hash_t v4; XXH32_hash_t mem32[4]; XXH32_hash_t memsize; XXH32_hash_t reserved; /* never read nor write, might be removed in a future version */ }; /* typedef'd to XXH32_state_t */ #ifndef XXH_NO_LONG_LONG /* defined when there is no 64-bit support */ struct XXH64_state_s { XXH64_hash_t total_len; XXH64_hash_t v1; XXH64_hash_t v2; XXH64_hash_t v3; XXH64_hash_t v4; XXH64_hash_t mem64[4]; XXH32_hash_t memsize; XXH32_hash_t reserved32; /* required for padding anyway */ XXH64_hash_t reserved64; /* never read nor write, might be removed in a future version */ }; /* typedef'd to XXH64_state_t */ #if defined (__STDC_VERSION__) && (__STDC_VERSION__ >= 201112L) /* C11+ */ # include # define XXH_ALIGN(n) alignas(n) #elif defined(__GNUC__) # define XXH_ALIGN(n) __attribute__ ((aligned(n))) #elif defined(_MSC_VER) # define XXH_ALIGN(n) __declspec(align(n)) #else # define XXH_ALIGN(n) /* disabled */ #endif /* Old GCC versions only accept the attribute after the type in structures. */ #if !(defined(__STDC_VERSION__) && (__STDC_VERSION__ >= 201112L)) /* C11+ */ \ && defined(__GNUC__) # define XXH_ALIGN_MEMBER(align, type) type XXH_ALIGN(align) #else # define XXH_ALIGN_MEMBER(align, type) XXH_ALIGN(align) type #endif #define XXH3_INTERNALBUFFER_SIZE 256 #define XXH3_SECRET_DEFAULT_SIZE 192 struct XXH3_state_s { XXH_ALIGN_MEMBER(64, XXH64_hash_t acc[8]); /* used to store a custom secret generated from a seed */ XXH_ALIGN_MEMBER(64, unsigned char customSecret[XXH3_SECRET_DEFAULT_SIZE]); XXH_ALIGN_MEMBER(64, unsigned char buffer[XXH3_INTERNALBUFFER_SIZE]); XXH32_hash_t bufferedSize; XXH32_hash_t reserved32; size_t nbStripesSoFar; XXH64_hash_t totalLen; size_t nbStripesPerBlock; size_t secretLimit; XXH64_hash_t seed; XXH64_hash_t reserved64; const unsigned char* extSecret; /* reference to external secret; * if == NULL, use .customSecret instead */ /* note: there may be some padding at the end due to alignment on 64 bytes */ }; /* typedef'd to XXH3_state_t */ #undef XXH_ALIGN_MEMBER /* When the XXH3_state_t structure is merely emplaced on stack, * it should be initialized with XXH3_INITSTATE() or a memset() * in case its first reset uses XXH3_NNbits_reset_withSeed(). * This init can be omitted if the first reset uses default or _withSecret mode. * This operation isn't necessary when the state is created with XXH3_createState(). * Note that this doesn't prepare the state for a streaming operation, * it's still necessary to use XXH3_NNbits_reset*() afterwards. */ #define XXH3_INITSTATE(XXH3_state_ptr) { (XXH3_state_ptr)->seed = 0; } /* === Experimental API === */ /* Symbols defined below must be considered tied to a specific library version. */ /* * XXH3_generateSecret(): * * Derive a high-entropy secret from any user-defined content, named customSeed. * The generated secret can be used in combination with `*_withSecret()` functions. * The `_withSecret()` variants are useful to provide a higher level of protection than 64-bit seed, * as it becomes much more difficult for an external actor to guess how to impact the calculation logic. * * The function accepts as input a custom seed of any length and any content, * and derives from it a high-entropy secret of length XXH3_SECRET_DEFAULT_SIZE * into an already allocated buffer secretBuffer. * The generated secret is _always_ XXH_SECRET_DEFAULT_SIZE bytes long. * * The generated secret can then be used with any `*_withSecret()` variant. * Functions `XXH3_128bits_withSecret()`, `XXH3_64bits_withSecret()`, * `XXH3_128bits_reset_withSecret()` and `XXH3_64bits_reset_withSecret()` * are part of this list. They all accept a `secret` parameter * which must be very long for implementation reasons (>= XXH3_SECRET_SIZE_MIN) * _and_ feature very high entropy (consist of random-looking bytes). * These conditions can be a high bar to meet, so * this function can be used to generate a secret of proper quality. * * customSeed can be anything. It can have any size, even small ones, * and its content can be anything, even stupidly "low entropy" source such as a bunch of zeroes. * The resulting `secret` will nonetheless provide all expected qualities. * * Supplying NULL as the customSeed copies the default secret into `secretBuffer`. * When customSeedSize > 0, supplying NULL as customSeed is undefined behavior. */ XXH_PUBLIC_API void XXH3_generateSecret(void* secretBuffer, const void* customSeed, size_t customSeedSize); /* simple short-cut to pre-selected XXH3_128bits variant */ XXH_PUBLIC_API XXH128_hash_t XXH128(const void* data, size_t len, XXH64_hash_t seed); #endif /* XXH_NO_LONG_LONG */ #if defined(XXH_INLINE_ALL) || defined(XXH_PRIVATE_API) # define XXH_IMPLEMENTATION #endif #endif /* defined(XXH_STATIC_LINKING_ONLY) && !defined(XXHASH_H_STATIC_13879238742) */ /* ======================================================================== */ /* ======================================================================== */ /* ======================================================================== */ /*-********************************************************************** * xxHash implementation *-********************************************************************** * xxHash's implementation used to be hosted inside xxhash.c. * * However, inlining requires implementation to be visible to the compiler, * hence be included alongside the header. * Previously, implementation was hosted inside xxhash.c, * which was then #included when inlining was activated. * This construction created issues with a few build and install systems, * as it required xxhash.c to be stored in /include directory. * * xxHash implementation is now directly integrated within xxhash.h. * As a consequence, xxhash.c is no longer needed in /include. * * xxhash.c is still available and is still useful. * In a "normal" setup, when xxhash is not inlined, * xxhash.h only exposes the prototypes and public symbols, * while xxhash.c can be built into an object file xxhash.o * which can then be linked into the final binary. ************************************************************************/ #if ( defined(XXH_INLINE_ALL) || defined(XXH_PRIVATE_API) \ || defined(XXH_IMPLEMENTATION) ) && !defined(XXH_IMPLEM_13a8737387) # define XXH_IMPLEM_13a8737387 /* ************************************* * Tuning parameters ***************************************/ /*! * XXH_FORCE_MEMORY_ACCESS: * By default, access to unaligned memory is controlled by `memcpy()`, which is * safe and portable. * * Unfortunately, on some target/compiler combinations, the generated assembly * is sub-optimal. * * The below switch allow selection of a different access method * in the search for improved performance. * Method 0 (default): * Use `memcpy()`. Safe and portable. Default. * Method 1: * `__attribute__((packed))` statement. It depends on compiler extensions * and is therefore not portable. * This method is safe if your compiler supports it, and *generally* as * fast or faster than `memcpy`. * Method 2: * Direct access via cast. This method doesn't depend on the compiler but * violates the C standard. * It can generate buggy code on targets which do not support unaligned * memory accesses. * But in some circumstances, it's the only known way to get the most * performance (example: GCC + ARMv6) * Method 3: * Byteshift. This can generate the best code on old compilers which don't * inline small `memcpy()` calls, and it might also be faster on big-endian * systems which lack a native byteswap instruction. * See https://stackoverflow.com/a/32095106/646947 for details. * Prefer these methods in priority order (0 > 1 > 2 > 3) */ #ifndef XXH_FORCE_MEMORY_ACCESS /* can be defined externally, on command line for example */ # if !defined(__clang__) && defined(__GNUC__) && defined(__ARM_FEATURE_UNALIGNED) && defined(__ARM_ARCH) && (__ARM_ARCH == 6) # define XXH_FORCE_MEMORY_ACCESS 2 # elif !defined(__clang__) && ((defined(__INTEL_COMPILER) && !defined(_WIN32)) || \ (defined(__GNUC__) && (defined(__ARM_ARCH) && __ARM_ARCH >= 7))) # define XXH_FORCE_MEMORY_ACCESS 1 # endif #endif /*! * XXH_ACCEPT_NULL_INPUT_POINTER: * If the input pointer is NULL, xxHash's default behavior is to dereference it, * triggering a segfault. * When this macro is enabled, xxHash actively checks the input for a null pointer. * If it is, the result for null input pointers is the same as a zero-length input. */ #ifndef XXH_ACCEPT_NULL_INPUT_POINTER /* can be defined externally */ # define XXH_ACCEPT_NULL_INPUT_POINTER 0 #endif /*! * XXH_FORCE_ALIGN_CHECK: * This is an important performance trick * for architectures without decent unaligned memory access performance. * It checks for input alignment, and when conditions are met, * uses a "fast path" employing direct 32-bit/64-bit read, * resulting in _dramatically faster_ read speed. * * The check costs one initial branch per hash, which is generally negligible, but not zero. * Moreover, it's not useful to generate binary for an additional code path * if memory access uses same instruction for both aligned and unaligned adresses. * * In these cases, the alignment check can be removed by setting this macro to 0. * Then the code will always use unaligned memory access. * Align check is automatically disabled on x86, x64 & arm64, * which are platforms known to offer good unaligned memory accesses performance. * * This option does not affect XXH3 (only XXH32 and XXH64). */ #ifndef XXH_FORCE_ALIGN_CHECK /* can be defined externally */ # if defined(__i386) || defined(__x86_64__) || defined(__aarch64__) \ || defined(_M_IX86) || defined(_M_X64) || defined(_M_ARM64) /* visual */ # define XXH_FORCE_ALIGN_CHECK 0 # else # define XXH_FORCE_ALIGN_CHECK 1 # endif #endif /*! * XXH_NO_INLINE_HINTS: * * By default, xxHash tries to force the compiler to inline almost all internal * functions. * * This can usually improve performance due to reduced jumping and improved * constant folding, but significantly increases the size of the binary which * might not be favorable. * * Additionally, sometimes the forced inlining can be detrimental to performance, * depending on the architecture. * * XXH_NO_INLINE_HINTS marks all internal functions as static, giving the * compiler full control on whether to inline or not. * * When not optimizing (-O0), optimizing for size (-Os, -Oz), or using * -fno-inline with GCC or Clang, this will automatically be defined. */ #ifndef XXH_NO_INLINE_HINTS # if defined(__OPTIMIZE_SIZE__) /* -Os, -Oz */ \ || defined(__NO_INLINE__) /* -O0, -fno-inline */ # define XXH_NO_INLINE_HINTS 1 # else # define XXH_NO_INLINE_HINTS 0 # endif #endif /*! * XXH_REROLL: * Whether to reroll XXH32_finalize, and XXH64_finalize, * instead of using an unrolled jump table/if statement loop. * * This is automatically defined on -Os/-Oz on GCC and Clang. */ #ifndef XXH_REROLL # if defined(__OPTIMIZE_SIZE__) # define XXH_REROLL 1 # else # define XXH_REROLL 0 # endif #endif /* ************************************* * Includes & Memory related functions ***************************************/ /*! * Modify the local functions below should you wish to use * different memory routines for malloc() and free() */ #include static void* XXH_malloc(size_t s) { return malloc(s); } static void XXH_free(void* p) { free(p); } /*! and for memcpy() */ #include static void* XXH_memcpy(void* dest, const void* src, size_t size) { return memcpy(dest,src,size); } #include /* ULLONG_MAX */ /* ************************************* * Compiler Specific Options ***************************************/ #ifdef _MSC_VER /* Visual Studio warning fix */ # pragma warning(disable : 4127) /* disable: C4127: conditional expression is constant */ #endif #if XXH_NO_INLINE_HINTS /* disable inlining hints */ # if defined(__GNUC__) # define XXH_FORCE_INLINE static __attribute__((unused)) # else # define XXH_FORCE_INLINE static # endif # define XXH_NO_INLINE static /* enable inlining hints */ #elif defined(_MSC_VER) /* Visual Studio */ # define XXH_FORCE_INLINE static __forceinline # define XXH_NO_INLINE static __declspec(noinline) #elif defined(__GNUC__) # define XXH_FORCE_INLINE static __inline__ __attribute__((always_inline, unused)) # define XXH_NO_INLINE static __attribute__((noinline)) #elif defined (__cplusplus) \ || (defined (__STDC_VERSION__) && (__STDC_VERSION__ >= 199901L)) /* C99 */ # define XXH_FORCE_INLINE static inline # define XXH_NO_INLINE static #else # define XXH_FORCE_INLINE static # define XXH_NO_INLINE static #endif /* ************************************* * Debug ***************************************/ /* * XXH_DEBUGLEVEL is expected to be defined externally, typically via the * compiler's command line options. The value must be a number. */ #ifndef XXH_DEBUGLEVEL # ifdef DEBUGLEVEL /* backwards compat */ # define XXH_DEBUGLEVEL DEBUGLEVEL # else # define XXH_DEBUGLEVEL 0 # endif #endif #if (XXH_DEBUGLEVEL>=1) # include /* note: can still be disabled with NDEBUG */ # define XXH_ASSERT(c) assert(c) #else # define XXH_ASSERT(c) ((void)0) #endif /* note: use after variable declarations */ #define XXH_STATIC_ASSERT(c) do { enum { XXH_sa = 1/(int)(!!(c)) }; } while (0) /* ************************************* * Basic Types ***************************************/ #if !defined (__VMS) \ && (defined (__cplusplus) \ || (defined (__STDC_VERSION__) && (__STDC_VERSION__ >= 199901L) /* C99 */) ) # include typedef uint8_t xxh_u8; #else typedef unsigned char xxh_u8; #endif typedef XXH32_hash_t xxh_u32; #ifdef XXH_OLD_NAMES # define BYTE xxh_u8 # define U8 xxh_u8 # define U32 xxh_u32 #endif /* *** Memory access *** */ #if (defined(XXH_FORCE_MEMORY_ACCESS) && (XXH_FORCE_MEMORY_ACCESS==3)) /* * Manual byteshift. Best for old compilers which don't inline memcpy. * We actually directly use XXH_readLE32 and XXH_readBE32. */ #elif (defined(XXH_FORCE_MEMORY_ACCESS) && (XXH_FORCE_MEMORY_ACCESS==2)) /* * Force direct memory access. Only works on CPU which support unaligned memory * access in hardware. */ static xxh_u32 XXH_read32(const void* memPtr) { return *(const xxh_u32*) memPtr; } #elif (defined(XXH_FORCE_MEMORY_ACCESS) && (XXH_FORCE_MEMORY_ACCESS==1)) /* * __pack instructions are safer but compiler specific, hence potentially * problematic for some compilers. * * Currently only defined for GCC and ICC. */ #ifdef XXH_OLD_NAMES typedef union { xxh_u32 u32; } __attribute__((packed)) unalign; #endif static xxh_u32 XXH_read32(const void* ptr) { typedef union { xxh_u32 u32; } __attribute__((packed)) xxh_unalign; return ((const xxh_unalign*)ptr)->u32; } #else /* * Portable and safe solution. Generally efficient. * see: https://stackoverflow.com/a/32095106/646947 */ static xxh_u32 XXH_read32(const void* memPtr) { xxh_u32 val; memcpy(&val, memPtr, sizeof(val)); return val; } #endif /* XXH_FORCE_DIRECT_MEMORY_ACCESS */ /* *** Endianess *** */ typedef enum { XXH_bigEndian=0, XXH_littleEndian=1 } XXH_endianess; /*! * XXH_CPU_LITTLE_ENDIAN: * Defined to 1 if the target is little endian, or 0 if it is big endian. * It can be defined externally, for example on the compiler command line. * * If it is not defined, a runtime check (which is usually constant folded) * is used instead. */ #ifndef XXH_CPU_LITTLE_ENDIAN /* * Try to detect endianness automatically, to avoid the nonstandard behavior * in `XXH_isLittleEndian()` */ # if defined(_WIN32) /* Windows is always little endian */ \ || defined(__LITTLE_ENDIAN__) \ || (defined(__BYTE_ORDER__) && __BYTE_ORDER__ == __ORDER_LITTLE_ENDIAN__) # define XXH_CPU_LITTLE_ENDIAN 1 # elif defined(__BIG_ENDIAN__) \ || (defined(__BYTE_ORDER__) && __BYTE_ORDER__ == __ORDER_BIG_ENDIAN__) # define XXH_CPU_LITTLE_ENDIAN 0 # else /* * runtime test, presumed to simplify to a constant by compiler */ static int XXH_isLittleEndian(void) { /* * Portable and well-defined behavior. * Don't use static: it is detrimental to performance. */ const union { xxh_u32 u; xxh_u8 c[4]; } one = { 1 }; return one.c[0]; } # define XXH_CPU_LITTLE_ENDIAN XXH_isLittleEndian() # endif #endif /* **************************************** * Compiler-specific Functions and Macros ******************************************/ #define XXH_GCC_VERSION (__GNUC__ * 100 + __GNUC_MINOR__) #ifdef __has_builtin # define XXH_HAS_BUILTIN(x) __has_builtin(x) #else # define XXH_HAS_BUILTIN(x) 0 #endif #if !defined(NO_CLANG_BUILTIN) && XXH_HAS_BUILTIN(__builtin_rotateleft32) \ && XXH_HAS_BUILTIN(__builtin_rotateleft64) # define XXH_rotl32 __builtin_rotateleft32 # define XXH_rotl64 __builtin_rotateleft64 /* Note: although _rotl exists for minGW (GCC under windows), performance seems poor */ #elif defined(_MSC_VER) # define XXH_rotl32(x,r) _rotl(x,r) # define XXH_rotl64(x,r) _rotl64(x,r) #else # define XXH_rotl32(x,r) (((x) << (r)) | ((x) >> (32 - (r)))) # define XXH_rotl64(x,r) (((x) << (r)) | ((x) >> (64 - (r)))) #endif #if defined(_MSC_VER) /* Visual Studio */ # define XXH_swap32 _byteswap_ulong #elif XXH_GCC_VERSION >= 403 # define XXH_swap32 __builtin_bswap32 #else static xxh_u32 XXH_swap32 (xxh_u32 x) { return ((x << 24) & 0xff000000 ) | ((x << 8) & 0x00ff0000 ) | ((x >> 8) & 0x0000ff00 ) | ((x >> 24) & 0x000000ff ); } #endif /* *************************** * Memory reads *****************************/ typedef enum { XXH_aligned, XXH_unaligned } XXH_alignment; /* * XXH_FORCE_MEMORY_ACCESS==3 is an endian-independent byteshift load. * * This is ideal for older compilers which don't inline memcpy. */ #if (defined(XXH_FORCE_MEMORY_ACCESS) && (XXH_FORCE_MEMORY_ACCESS==3)) XXH_FORCE_INLINE xxh_u32 XXH_readLE32(const void* memPtr) { const xxh_u8* bytePtr = (const xxh_u8 *)memPtr; return bytePtr[0] | ((xxh_u32)bytePtr[1] << 8) | ((xxh_u32)bytePtr[2] << 16) | ((xxh_u32)bytePtr[3] << 24); } XXH_FORCE_INLINE xxh_u32 XXH_readBE32(const void* memPtr) { const xxh_u8* bytePtr = (const xxh_u8 *)memPtr; return bytePtr[3] | ((xxh_u32)bytePtr[2] << 8) | ((xxh_u32)bytePtr[1] << 16) | ((xxh_u32)bytePtr[0] << 24); } #else XXH_FORCE_INLINE xxh_u32 XXH_readLE32(const void* ptr) { return XXH_CPU_LITTLE_ENDIAN ? XXH_read32(ptr) : XXH_swap32(XXH_read32(ptr)); } static xxh_u32 XXH_readBE32(const void* ptr) { return XXH_CPU_LITTLE_ENDIAN ? XXH_swap32(XXH_read32(ptr)) : XXH_read32(ptr); } #endif XXH_FORCE_INLINE xxh_u32 XXH_readLE32_align(const void* ptr, XXH_alignment align) { if (align==XXH_unaligned) { return XXH_readLE32(ptr); } else { return XXH_CPU_LITTLE_ENDIAN ? *(const xxh_u32*)ptr : XXH_swap32(*(const xxh_u32*)ptr); } } /* ************************************* * Misc ***************************************/ XXH_PUBLIC_API unsigned XXH_versionNumber (void) { return XXH_VERSION_NUMBER; } /* ******************************************************************* * 32-bit hash functions *********************************************************************/ static const xxh_u32 XXH_PRIME32_1 = 0x9E3779B1U; /* 0b10011110001101110111100110110001 */ static const xxh_u32 XXH_PRIME32_2 = 0x85EBCA77U; /* 0b10000101111010111100101001110111 */ static const xxh_u32 XXH_PRIME32_3 = 0xC2B2AE3DU; /* 0b11000010101100101010111000111101 */ static const xxh_u32 XXH_PRIME32_4 = 0x27D4EB2FU; /* 0b00100111110101001110101100101111 */ static const xxh_u32 XXH_PRIME32_5 = 0x165667B1U; /* 0b00010110010101100110011110110001 */ #ifdef XXH_OLD_NAMES # define PRIME32_1 XXH_PRIME32_1 # define PRIME32_2 XXH_PRIME32_2 # define PRIME32_3 XXH_PRIME32_3 # define PRIME32_4 XXH_PRIME32_4 # define PRIME32_5 XXH_PRIME32_5 #endif static xxh_u32 XXH32_round(xxh_u32 acc, xxh_u32 input) { acc += input * XXH_PRIME32_2; acc = XXH_rotl32(acc, 13); acc *= XXH_PRIME32_1; #if defined(__GNUC__) && defined(__SSE4_1__) && !defined(XXH_ENABLE_AUTOVECTORIZE) /* * UGLY HACK: * This inline assembly hack forces acc into a normal register. This is the * only thing that prevents GCC and Clang from autovectorizing the XXH32 * loop (pragmas and attributes don't work for some resason) without globally * disabling SSE4.1. * * The reason we want to avoid vectorization is because despite working on * 4 integers at a time, there are multiple factors slowing XXH32 down on * SSE4: * - There's a ridiculous amount of lag from pmulld (10 cycles of latency on * newer chips!) making it slightly slower to multiply four integers at * once compared to four integers independently. Even when pmulld was * fastest, Sandy/Ivy Bridge, it is still not worth it to go into SSE * just to multiply unless doing a long operation. * * - Four instructions are required to rotate, * movqda tmp, v // not required with VEX encoding * pslld tmp, 13 // tmp <<= 13 * psrld v, 19 // x >>= 19 * por v, tmp // x |= tmp * compared to one for scalar: * roll v, 13 // reliably fast across the board * shldl v, v, 13 // Sandy Bridge and later prefer this for some reason * * - Instruction level parallelism is actually more beneficial here because * the SIMD actually serializes this operation: While v1 is rotating, v2 * can load data, while v3 can multiply. SSE forces them to operate * together. * * How this hack works: * __asm__("" // Declare an assembly block but don't declare any instructions * : // However, as an Input/Output Operand, * "+r" // constrain a read/write operand (+) as a general purpose register (r). * (acc) // and set acc as the operand * ); * * Because of the 'r', the compiler has promised that seed will be in a * general purpose register and the '+' says that it will be 'read/write', * so it has to assume it has changed. It is like volatile without all the * loads and stores. * * Since the argument has to be in a normal register (not an SSE register), * each time XXH32_round is called, it is impossible to vectorize. */ __asm__("" : "+r" (acc)); #endif return acc; } /* mix all bits */ static xxh_u32 XXH32_avalanche(xxh_u32 h32) { h32 ^= h32 >> 15; h32 *= XXH_PRIME32_2; h32 ^= h32 >> 13; h32 *= XXH_PRIME32_3; h32 ^= h32 >> 16; return(h32); } #define XXH_get32bits(p) XXH_readLE32_align(p, align) static xxh_u32 XXH32_finalize(xxh_u32 h32, const xxh_u8* ptr, size_t len, XXH_alignment align) { #define XXH_PROCESS1 do { \ h32 += (*ptr++) * XXH_PRIME32_5; \ h32 = XXH_rotl32(h32, 11) * XXH_PRIME32_1; \ } while (0) #define XXH_PROCESS4 do { \ h32 += XXH_get32bits(ptr) * XXH_PRIME32_3; \ ptr += 4; \ h32 = XXH_rotl32(h32, 17) * XXH_PRIME32_4; \ } while (0) /* Compact rerolled version */ if (XXH_REROLL) { len &= 15; while (len >= 4) { XXH_PROCESS4; len -= 4; } while (len > 0) { XXH_PROCESS1; --len; } return XXH32_avalanche(h32); } else { switch(len&15) /* or switch(bEnd - p) */ { case 12: XXH_PROCESS4; /* fallthrough */ case 8: XXH_PROCESS4; /* fallthrough */ case 4: XXH_PROCESS4; return XXH32_avalanche(h32); case 13: XXH_PROCESS4; /* fallthrough */ case 9: XXH_PROCESS4; /* fallthrough */ case 5: XXH_PROCESS4; XXH_PROCESS1; return XXH32_avalanche(h32); case 14: XXH_PROCESS4; /* fallthrough */ case 10: XXH_PROCESS4; /* fallthrough */ case 6: XXH_PROCESS4; XXH_PROCESS1; XXH_PROCESS1; return XXH32_avalanche(h32); case 15: XXH_PROCESS4; /* fallthrough */ case 11: XXH_PROCESS4; /* fallthrough */ case 7: XXH_PROCESS4; /* fallthrough */ case 3: XXH_PROCESS1; /* fallthrough */ case 2: XXH_PROCESS1; /* fallthrough */ case 1: XXH_PROCESS1; /* fallthrough */ case 0: return XXH32_avalanche(h32); } XXH_ASSERT(0); return h32; /* reaching this point is deemed impossible */ } } #ifdef XXH_OLD_NAMES # define PROCESS1 XXH_PROCESS1 # define PROCESS4 XXH_PROCESS4 #else # undef XXH_PROCESS1 # undef XXH_PROCESS4 #endif XXH_FORCE_INLINE xxh_u32 XXH32_endian_align(const xxh_u8* input, size_t len, xxh_u32 seed, XXH_alignment align) { const xxh_u8* bEnd = input + len; xxh_u32 h32; #if defined(XXH_ACCEPT_NULL_INPUT_POINTER) && (XXH_ACCEPT_NULL_INPUT_POINTER>=1) if (input==NULL) { len=0; bEnd=input=(const xxh_u8*)(size_t)16; } #endif if (len>=16) { const xxh_u8* const limit = bEnd - 15; xxh_u32 v1 = seed + XXH_PRIME32_1 + XXH_PRIME32_2; xxh_u32 v2 = seed + XXH_PRIME32_2; xxh_u32 v3 = seed + 0; xxh_u32 v4 = seed - XXH_PRIME32_1; do { v1 = XXH32_round(v1, XXH_get32bits(input)); input += 4; v2 = XXH32_round(v2, XXH_get32bits(input)); input += 4; v3 = XXH32_round(v3, XXH_get32bits(input)); input += 4; v4 = XXH32_round(v4, XXH_get32bits(input)); input += 4; } while (input < limit); h32 = XXH_rotl32(v1, 1) + XXH_rotl32(v2, 7) + XXH_rotl32(v3, 12) + XXH_rotl32(v4, 18); } else { h32 = seed + XXH_PRIME32_5; } h32 += (xxh_u32)len; return XXH32_finalize(h32, input, len&15, align); } XXH_PUBLIC_API XXH32_hash_t XXH32 (const void* input, size_t len, XXH32_hash_t seed) { #if 0 /* Simple version, good for code maintenance, but unfortunately slow for small inputs */ XXH32_state_t state; XXH32_reset(&state, seed); XXH32_update(&state, (const xxh_u8*)input, len); return XXH32_digest(&state); #else if (XXH_FORCE_ALIGN_CHECK) { if ((((size_t)input) & 3) == 0) { /* Input is 4-bytes aligned, leverage the speed benefit */ return XXH32_endian_align((const xxh_u8*)input, len, seed, XXH_aligned); } } return XXH32_endian_align((const xxh_u8*)input, len, seed, XXH_unaligned); #endif } /******* Hash streaming *******/ XXH_PUBLIC_API XXH32_state_t* XXH32_createState(void) { return (XXH32_state_t*)XXH_malloc(sizeof(XXH32_state_t)); } XXH_PUBLIC_API XXH_errorcode XXH32_freeState(XXH32_state_t* statePtr) { XXH_free(statePtr); return XXH_OK; } XXH_PUBLIC_API void XXH32_copyState(XXH32_state_t* dstState, const XXH32_state_t* srcState) { memcpy(dstState, srcState, sizeof(*dstState)); } XXH_PUBLIC_API XXH_errorcode XXH32_reset(XXH32_state_t* statePtr, XXH32_hash_t seed) { XXH32_state_t state; /* using a local state to memcpy() in order to avoid strict-aliasing warnings */ memset(&state, 0, sizeof(state)); state.v1 = seed + XXH_PRIME32_1 + XXH_PRIME32_2; state.v2 = seed + XXH_PRIME32_2; state.v3 = seed + 0; state.v4 = seed - XXH_PRIME32_1; /* do not write into reserved, planned to be removed in a future version */ memcpy(statePtr, &state, sizeof(state) - sizeof(state.reserved)); return XXH_OK; } XXH_PUBLIC_API XXH_errorcode XXH32_update(XXH32_state_t* state, const void* input, size_t len) { if (input==NULL) #if defined(XXH_ACCEPT_NULL_INPUT_POINTER) && (XXH_ACCEPT_NULL_INPUT_POINTER>=1) return XXH_OK; #else return XXH_ERROR; #endif { const xxh_u8* p = (const xxh_u8*)input; const xxh_u8* const bEnd = p + len; state->total_len_32 += (XXH32_hash_t)len; state->large_len |= (XXH32_hash_t)((len>=16) | (state->total_len_32>=16)); if (state->memsize + len < 16) { /* fill in tmp buffer */ XXH_memcpy((xxh_u8*)(state->mem32) + state->memsize, input, len); state->memsize += (XXH32_hash_t)len; return XXH_OK; } if (state->memsize) { /* some data left from previous update */ XXH_memcpy((xxh_u8*)(state->mem32) + state->memsize, input, 16-state->memsize); { const xxh_u32* p32 = state->mem32; state->v1 = XXH32_round(state->v1, XXH_readLE32(p32)); p32++; state->v2 = XXH32_round(state->v2, XXH_readLE32(p32)); p32++; state->v3 = XXH32_round(state->v3, XXH_readLE32(p32)); p32++; state->v4 = XXH32_round(state->v4, XXH_readLE32(p32)); } p += 16-state->memsize; state->memsize = 0; } if (p <= bEnd-16) { const xxh_u8* const limit = bEnd - 16; xxh_u32 v1 = state->v1; xxh_u32 v2 = state->v2; xxh_u32 v3 = state->v3; xxh_u32 v4 = state->v4; do { v1 = XXH32_round(v1, XXH_readLE32(p)); p+=4; v2 = XXH32_round(v2, XXH_readLE32(p)); p+=4; v3 = XXH32_round(v3, XXH_readLE32(p)); p+=4; v4 = XXH32_round(v4, XXH_readLE32(p)); p+=4; } while (p<=limit); state->v1 = v1; state->v2 = v2; state->v3 = v3; state->v4 = v4; } if (p < bEnd) { XXH_memcpy(state->mem32, p, (size_t)(bEnd-p)); state->memsize = (unsigned)(bEnd-p); } } return XXH_OK; } XXH_PUBLIC_API XXH32_hash_t XXH32_digest (const XXH32_state_t* state) { xxh_u32 h32; if (state->large_len) { h32 = XXH_rotl32(state->v1, 1) + XXH_rotl32(state->v2, 7) + XXH_rotl32(state->v3, 12) + XXH_rotl32(state->v4, 18); } else { h32 = state->v3 /* == seed */ + XXH_PRIME32_5; } h32 += state->total_len_32; return XXH32_finalize(h32, (const xxh_u8*)state->mem32, state->memsize, XXH_aligned); } /******* Canonical representation *******/ /* * The default return values from XXH functions are unsigned 32 and 64 bit * integers. * * The canonical representation uses big endian convention, the same convention * as human-readable numbers (large digits first). * * This way, hash values can be written into a file or buffer, remaining * comparable across different systems. * * The following functions allow transformation of hash values to and from their * canonical format. */ XXH_PUBLIC_API void XXH32_canonicalFromHash(XXH32_canonical_t* dst, XXH32_hash_t hash) { XXH_STATIC_ASSERT(sizeof(XXH32_canonical_t) == sizeof(XXH32_hash_t)); if (XXH_CPU_LITTLE_ENDIAN) hash = XXH_swap32(hash); memcpy(dst, &hash, sizeof(*dst)); } XXH_PUBLIC_API XXH32_hash_t XXH32_hashFromCanonical(const XXH32_canonical_t* src) { return XXH_readBE32(src); } #ifndef XXH_NO_LONG_LONG /* ******************************************************************* * 64-bit hash functions *********************************************************************/ /******* Memory access *******/ typedef XXH64_hash_t xxh_u64; #ifdef XXH_OLD_NAMES # define U64 xxh_u64 #endif /*! * XXH_REROLL_XXH64: * Whether to reroll the XXH64_finalize() loop. * * Just like XXH32, we can unroll the XXH64_finalize() loop. This can be a * performance gain on 64-bit hosts, as only one jump is required. * * However, on 32-bit hosts, because arithmetic needs to be done with two 32-bit * registers, and 64-bit arithmetic needs to be simulated, it isn't beneficial * to unroll. The code becomes ridiculously large (the largest function in the * binary on i386!), and rerolling it saves anywhere from 3kB to 20kB. It is * also slightly faster because it fits into cache better and is more likely * to be inlined by the compiler. * * If XXH_REROLL is defined, this is ignored and the loop is always rerolled. */ #ifndef XXH_REROLL_XXH64 # if (defined(__ILP32__) || defined(_ILP32)) /* ILP32 is often defined on 32-bit GCC family */ \ || !(defined(__x86_64__) || defined(_M_X64) || defined(_M_AMD64) /* x86-64 */ \ || defined(_M_ARM64) || defined(__aarch64__) || defined(__arm64__) /* aarch64 */ \ || defined(__PPC64__) || defined(__PPC64LE__) || defined(__ppc64__) || defined(__powerpc64__) /* ppc64 */ \ || defined(__mips64__) || defined(__mips64)) /* mips64 */ \ || (!defined(SIZE_MAX) || SIZE_MAX < ULLONG_MAX) /* check limits */ # define XXH_REROLL_XXH64 1 # else # define XXH_REROLL_XXH64 0 # endif #endif /* !defined(XXH_REROLL_XXH64) */ #if (defined(XXH_FORCE_MEMORY_ACCESS) && (XXH_FORCE_MEMORY_ACCESS==3)) /* * Manual byteshift. Best for old compilers which don't inline memcpy. * We actually directly use XXH_readLE64 and XXH_readBE64. */ #elif (defined(XXH_FORCE_MEMORY_ACCESS) && (XXH_FORCE_MEMORY_ACCESS==2)) /* Force direct memory access. Only works on CPU which support unaligned memory access in hardware */ static xxh_u64 XXH_read64(const void* memPtr) { return *(const xxh_u64*) memPtr; } #elif (defined(XXH_FORCE_MEMORY_ACCESS) && (XXH_FORCE_MEMORY_ACCESS==1)) /* * __pack instructions are safer, but compiler specific, hence potentially * problematic for some compilers. * * Currently only defined for GCC and ICC. */ #ifdef XXH_OLD_NAMES typedef union { xxh_u32 u32; xxh_u64 u64; } __attribute__((packed)) unalign64; #endif static xxh_u64 XXH_read64(const void* ptr) { typedef union { xxh_u32 u32; xxh_u64 u64; } __attribute__((packed)) xxh_unalign64; return ((const xxh_unalign64*)ptr)->u64; } #else /* * Portable and safe solution. Generally efficient. * see: https://stackoverflow.com/a/32095106/646947 */ static xxh_u64 XXH_read64(const void* memPtr) { xxh_u64 val; memcpy(&val, memPtr, sizeof(val)); return val; } #endif /* XXH_FORCE_DIRECT_MEMORY_ACCESS */ #if defined(_MSC_VER) /* Visual Studio */ # define XXH_swap64 _byteswap_uint64 #elif XXH_GCC_VERSION >= 403 # define XXH_swap64 __builtin_bswap64 #else static xxh_u64 XXH_swap64 (xxh_u64 x) { return ((x << 56) & 0xff00000000000000ULL) | ((x << 40) & 0x00ff000000000000ULL) | ((x << 24) & 0x0000ff0000000000ULL) | ((x << 8) & 0x000000ff00000000ULL) | ((x >> 8) & 0x00000000ff000000ULL) | ((x >> 24) & 0x0000000000ff0000ULL) | ((x >> 40) & 0x000000000000ff00ULL) | ((x >> 56) & 0x00000000000000ffULL); } #endif /* XXH_FORCE_MEMORY_ACCESS==3 is an endian-independent byteshift load. */ #if (defined(XXH_FORCE_MEMORY_ACCESS) && (XXH_FORCE_MEMORY_ACCESS==3)) XXH_FORCE_INLINE xxh_u64 XXH_readLE64(const void* memPtr) { const xxh_u8* bytePtr = (const xxh_u8 *)memPtr; return bytePtr[0] | ((xxh_u64)bytePtr[1] << 8) | ((xxh_u64)bytePtr[2] << 16) | ((xxh_u64)bytePtr[3] << 24) | ((xxh_u64)bytePtr[4] << 32) | ((xxh_u64)bytePtr[5] << 40) | ((xxh_u64)bytePtr[6] << 48) | ((xxh_u64)bytePtr[7] << 56); } XXH_FORCE_INLINE xxh_u64 XXH_readBE64(const void* memPtr) { const xxh_u8* bytePtr = (const xxh_u8 *)memPtr; return bytePtr[7] | ((xxh_u64)bytePtr[6] << 8) | ((xxh_u64)bytePtr[5] << 16) | ((xxh_u64)bytePtr[4] << 24) | ((xxh_u64)bytePtr[3] << 32) | ((xxh_u64)bytePtr[2] << 40) | ((xxh_u64)bytePtr[1] << 48) | ((xxh_u64)bytePtr[0] << 56); } #else XXH_FORCE_INLINE xxh_u64 XXH_readLE64(const void* ptr) { return XXH_CPU_LITTLE_ENDIAN ? XXH_read64(ptr) : XXH_swap64(XXH_read64(ptr)); } static xxh_u64 XXH_readBE64(const void* ptr) { return XXH_CPU_LITTLE_ENDIAN ? XXH_swap64(XXH_read64(ptr)) : XXH_read64(ptr); } #endif XXH_FORCE_INLINE xxh_u64 XXH_readLE64_align(const void* ptr, XXH_alignment align) { if (align==XXH_unaligned) return XXH_readLE64(ptr); else return XXH_CPU_LITTLE_ENDIAN ? *(const xxh_u64*)ptr : XXH_swap64(*(const xxh_u64*)ptr); } /******* xxh64 *******/ static const xxh_u64 XXH_PRIME64_1 = 0x9E3779B185EBCA87ULL; /* 0b1001111000110111011110011011000110000101111010111100101010000111 */ static const xxh_u64 XXH_PRIME64_2 = 0xC2B2AE3D27D4EB4FULL; /* 0b1100001010110010101011100011110100100111110101001110101101001111 */ static const xxh_u64 XXH_PRIME64_3 = 0x165667B19E3779F9ULL; /* 0b0001011001010110011001111011000110011110001101110111100111111001 */ static const xxh_u64 XXH_PRIME64_4 = 0x85EBCA77C2B2AE63ULL; /* 0b1000010111101011110010100111011111000010101100101010111001100011 */ static const xxh_u64 XXH_PRIME64_5 = 0x27D4EB2F165667C5ULL; /* 0b0010011111010100111010110010111100010110010101100110011111000101 */ #ifdef XXH_OLD_NAMES # define PRIME64_1 XXH_PRIME64_1 # define PRIME64_2 XXH_PRIME64_2 # define PRIME64_3 XXH_PRIME64_3 # define PRIME64_4 XXH_PRIME64_4 # define PRIME64_5 XXH_PRIME64_5 #endif static xxh_u64 XXH64_round(xxh_u64 acc, xxh_u64 input) { acc += input * XXH_PRIME64_2; acc = XXH_rotl64(acc, 31); acc *= XXH_PRIME64_1; return acc; } static xxh_u64 XXH64_mergeRound(xxh_u64 acc, xxh_u64 val) { val = XXH64_round(0, val); acc ^= val; acc = acc * XXH_PRIME64_1 + XXH_PRIME64_4; return acc; } static xxh_u64 XXH64_avalanche(xxh_u64 h64) { h64 ^= h64 >> 33; h64 *= XXH_PRIME64_2; h64 ^= h64 >> 29; h64 *= XXH_PRIME64_3; h64 ^= h64 >> 32; return h64; } #define XXH_get64bits(p) XXH_readLE64_align(p, align) static xxh_u64 XXH64_finalize(xxh_u64 h64, const xxh_u8* ptr, size_t len, XXH_alignment align) { #define XXH_PROCESS1_64 do { \ h64 ^= (*ptr++) * XXH_PRIME64_5; \ h64 = XXH_rotl64(h64, 11) * XXH_PRIME64_1; \ } while (0) #define XXH_PROCESS4_64 do { \ h64 ^= (xxh_u64)(XXH_get32bits(ptr)) * XXH_PRIME64_1; \ ptr += 4; \ h64 = XXH_rotl64(h64, 23) * XXH_PRIME64_2 + XXH_PRIME64_3; \ } while (0) #define XXH_PROCESS8_64 do { \ xxh_u64 const k1 = XXH64_round(0, XXH_get64bits(ptr)); \ ptr += 8; \ h64 ^= k1; \ h64 = XXH_rotl64(h64,27) * XXH_PRIME64_1 + XXH_PRIME64_4; \ } while (0) /* Rerolled version for 32-bit targets is faster and much smaller. */ if (XXH_REROLL || XXH_REROLL_XXH64) { len &= 31; while (len >= 8) { XXH_PROCESS8_64; len -= 8; } if (len >= 4) { XXH_PROCESS4_64; len -= 4; } while (len > 0) { XXH_PROCESS1_64; --len; } return XXH64_avalanche(h64); } else { switch(len & 31) { case 24: XXH_PROCESS8_64; /* fallthrough */ case 16: XXH_PROCESS8_64; /* fallthrough */ case 8: XXH_PROCESS8_64; return XXH64_avalanche(h64); case 28: XXH_PROCESS8_64; /* fallthrough */ case 20: XXH_PROCESS8_64; /* fallthrough */ case 12: XXH_PROCESS8_64; /* fallthrough */ case 4: XXH_PROCESS4_64; return XXH64_avalanche(h64); case 25: XXH_PROCESS8_64; /* fallthrough */ case 17: XXH_PROCESS8_64; /* fallthrough */ case 9: XXH_PROCESS8_64; XXH_PROCESS1_64; return XXH64_avalanche(h64); case 29: XXH_PROCESS8_64; /* fallthrough */ case 21: XXH_PROCESS8_64; /* fallthrough */ case 13: XXH_PROCESS8_64; /* fallthrough */ case 5: XXH_PROCESS4_64; XXH_PROCESS1_64; return XXH64_avalanche(h64); case 26: XXH_PROCESS8_64; /* fallthrough */ case 18: XXH_PROCESS8_64; /* fallthrough */ case 10: XXH_PROCESS8_64; XXH_PROCESS1_64; XXH_PROCESS1_64; return XXH64_avalanche(h64); case 30: XXH_PROCESS8_64; /* fallthrough */ case 22: XXH_PROCESS8_64; /* fallthrough */ case 14: XXH_PROCESS8_64; /* fallthrough */ case 6: XXH_PROCESS4_64; XXH_PROCESS1_64; XXH_PROCESS1_64; return XXH64_avalanche(h64); case 27: XXH_PROCESS8_64; /* fallthrough */ case 19: XXH_PROCESS8_64; /* fallthrough */ case 11: XXH_PROCESS8_64; XXH_PROCESS1_64; XXH_PROCESS1_64; XXH_PROCESS1_64; return XXH64_avalanche(h64); case 31: XXH_PROCESS8_64; /* fallthrough */ case 23: XXH_PROCESS8_64; /* fallthrough */ case 15: XXH_PROCESS8_64; /* fallthrough */ case 7: XXH_PROCESS4_64; /* fallthrough */ case 3: XXH_PROCESS1_64; /* fallthrough */ case 2: XXH_PROCESS1_64; /* fallthrough */ case 1: XXH_PROCESS1_64; /* fallthrough */ case 0: return XXH64_avalanche(h64); } } /* impossible to reach */ XXH_ASSERT(0); return 0; /* unreachable, but some compilers complain without it */ } #ifdef XXH_OLD_NAMES # define PROCESS1_64 XXH_PROCESS1_64 # define PROCESS4_64 XXH_PROCESS4_64 # define PROCESS8_64 XXH_PROCESS8_64 #else # undef XXH_PROCESS1_64 # undef XXH_PROCESS4_64 # undef XXH_PROCESS8_64 #endif XXH_FORCE_INLINE xxh_u64 XXH64_endian_align(const xxh_u8* input, size_t len, xxh_u64 seed, XXH_alignment align) { const xxh_u8* bEnd = input + len; xxh_u64 h64; #if defined(XXH_ACCEPT_NULL_INPUT_POINTER) && (XXH_ACCEPT_NULL_INPUT_POINTER>=1) if (input==NULL) { len=0; bEnd=input=(const xxh_u8*)(size_t)32; } #endif if (len>=32) { const xxh_u8* const limit = bEnd - 32; xxh_u64 v1 = seed + XXH_PRIME64_1 + XXH_PRIME64_2; xxh_u64 v2 = seed + XXH_PRIME64_2; xxh_u64 v3 = seed + 0; xxh_u64 v4 = seed - XXH_PRIME64_1; do { v1 = XXH64_round(v1, XXH_get64bits(input)); input+=8; v2 = XXH64_round(v2, XXH_get64bits(input)); input+=8; v3 = XXH64_round(v3, XXH_get64bits(input)); input+=8; v4 = XXH64_round(v4, XXH_get64bits(input)); input+=8; } while (input<=limit); h64 = XXH_rotl64(v1, 1) + XXH_rotl64(v2, 7) + XXH_rotl64(v3, 12) + XXH_rotl64(v4, 18); h64 = XXH64_mergeRound(h64, v1); h64 = XXH64_mergeRound(h64, v2); h64 = XXH64_mergeRound(h64, v3); h64 = XXH64_mergeRound(h64, v4); } else { h64 = seed + XXH_PRIME64_5; } h64 += (xxh_u64) len; return XXH64_finalize(h64, input, len, align); } XXH_PUBLIC_API XXH64_hash_t XXH64 (const void* input, size_t len, XXH64_hash_t seed) { #if 0 /* Simple version, good for code maintenance, but unfortunately slow for small inputs */ XXH64_state_t state; XXH64_reset(&state, seed); XXH64_update(&state, (const xxh_u8*)input, len); return XXH64_digest(&state); #else if (XXH_FORCE_ALIGN_CHECK) { if ((((size_t)input) & 7)==0) { /* Input is aligned, let's leverage the speed advantage */ return XXH64_endian_align((const xxh_u8*)input, len, seed, XXH_aligned); } } return XXH64_endian_align((const xxh_u8*)input, len, seed, XXH_unaligned); #endif } /******* Hash Streaming *******/ XXH_PUBLIC_API XXH64_state_t* XXH64_createState(void) { return (XXH64_state_t*)XXH_malloc(sizeof(XXH64_state_t)); } XXH_PUBLIC_API XXH_errorcode XXH64_freeState(XXH64_state_t* statePtr) { XXH_free(statePtr); return XXH_OK; } XXH_PUBLIC_API void XXH64_copyState(XXH64_state_t* dstState, const XXH64_state_t* srcState) { memcpy(dstState, srcState, sizeof(*dstState)); } XXH_PUBLIC_API XXH_errorcode XXH64_reset(XXH64_state_t* statePtr, XXH64_hash_t seed) { XXH64_state_t state; /* use a local state to memcpy() in order to avoid strict-aliasing warnings */ memset(&state, 0, sizeof(state)); state.v1 = seed + XXH_PRIME64_1 + XXH_PRIME64_2; state.v2 = seed + XXH_PRIME64_2; state.v3 = seed + 0; state.v4 = seed - XXH_PRIME64_1; /* do not write into reserved64, might be removed in a future version */ memcpy(statePtr, &state, sizeof(state) - sizeof(state.reserved64)); return XXH_OK; } XXH_PUBLIC_API XXH_errorcode XXH64_update (XXH64_state_t* state, const void* input, size_t len) { if (input==NULL) #if defined(XXH_ACCEPT_NULL_INPUT_POINTER) && (XXH_ACCEPT_NULL_INPUT_POINTER>=1) return XXH_OK; #else return XXH_ERROR; #endif { const xxh_u8* p = (const xxh_u8*)input; const xxh_u8* const bEnd = p + len; state->total_len += len; if (state->memsize + len < 32) { /* fill in tmp buffer */ XXH_memcpy(((xxh_u8*)state->mem64) + state->memsize, input, len); state->memsize += (xxh_u32)len; return XXH_OK; } if (state->memsize) { /* tmp buffer is full */ XXH_memcpy(((xxh_u8*)state->mem64) + state->memsize, input, 32-state->memsize); state->v1 = XXH64_round(state->v1, XXH_readLE64(state->mem64+0)); state->v2 = XXH64_round(state->v2, XXH_readLE64(state->mem64+1)); state->v3 = XXH64_round(state->v3, XXH_readLE64(state->mem64+2)); state->v4 = XXH64_round(state->v4, XXH_readLE64(state->mem64+3)); p += 32-state->memsize; state->memsize = 0; } if (p+32 <= bEnd) { const xxh_u8* const limit = bEnd - 32; xxh_u64 v1 = state->v1; xxh_u64 v2 = state->v2; xxh_u64 v3 = state->v3; xxh_u64 v4 = state->v4; do { v1 = XXH64_round(v1, XXH_readLE64(p)); p+=8; v2 = XXH64_round(v2, XXH_readLE64(p)); p+=8; v3 = XXH64_round(v3, XXH_readLE64(p)); p+=8; v4 = XXH64_round(v4, XXH_readLE64(p)); p+=8; } while (p<=limit); state->v1 = v1; state->v2 = v2; state->v3 = v3; state->v4 = v4; } if (p < bEnd) { XXH_memcpy(state->mem64, p, (size_t)(bEnd-p)); state->memsize = (unsigned)(bEnd-p); } } return XXH_OK; } XXH_PUBLIC_API XXH64_hash_t XXH64_digest (const XXH64_state_t* state) { xxh_u64 h64; if (state->total_len >= 32) { xxh_u64 const v1 = state->v1; xxh_u64 const v2 = state->v2; xxh_u64 const v3 = state->v3; xxh_u64 const v4 = state->v4; h64 = XXH_rotl64(v1, 1) + XXH_rotl64(v2, 7) + XXH_rotl64(v3, 12) + XXH_rotl64(v4, 18); h64 = XXH64_mergeRound(h64, v1); h64 = XXH64_mergeRound(h64, v2); h64 = XXH64_mergeRound(h64, v3); h64 = XXH64_mergeRound(h64, v4); } else { h64 = state->v3 /*seed*/ + XXH_PRIME64_5; } h64 += (xxh_u64) state->total_len; return XXH64_finalize(h64, (const xxh_u8*)state->mem64, (size_t)state->total_len, XXH_aligned); } /******* Canonical representation *******/ XXH_PUBLIC_API void XXH64_canonicalFromHash(XXH64_canonical_t* dst, XXH64_hash_t hash) { XXH_STATIC_ASSERT(sizeof(XXH64_canonical_t) == sizeof(XXH64_hash_t)); if (XXH_CPU_LITTLE_ENDIAN) hash = XXH_swap64(hash); memcpy(dst, &hash, sizeof(*dst)); } XXH_PUBLIC_API XXH64_hash_t XXH64_hashFromCanonical(const XXH64_canonical_t* src) { return XXH_readBE64(src); } /* ********************************************************************* * XXH3 * New generation hash designed for speed on small keys and vectorization ************************************************************************ */ /* === Compiler specifics === */ #if defined (__STDC_VERSION__) && __STDC_VERSION__ >= 199901L /* >= C99 */ # define XXH_RESTRICT restrict #else /* Note: it might be useful to define __restrict or __restrict__ for some C++ compilers */ # define XXH_RESTRICT /* disable */ #endif #if (defined(__GNUC__) && (__GNUC__ >= 3)) \ || (defined(__INTEL_COMPILER) && (__INTEL_COMPILER >= 800)) \ || defined(__clang__) # define XXH_likely(x) __builtin_expect(x, 1) # define XXH_unlikely(x) __builtin_expect(x, 0) #else # define XXH_likely(x) (x) # define XXH_unlikely(x) (x) #endif #if defined(__GNUC__) # if defined(__AVX2__) # include # elif defined(__SSE2__) # include # elif defined(__ARM_NEON__) || defined(__ARM_NEON) # define inline __inline__ /* circumvent a clang bug */ # include # undef inline # endif #elif defined(_MSC_VER) # include #endif /* * One goal of XXH3 is to make it fast on both 32-bit and 64-bit, while * remaining a true 64-bit/128-bit hash function. * * This is done by prioritizing a subset of 64-bit operations that can be * emulated without too many steps on the average 32-bit machine. * * For example, these two lines seem similar, and run equally fast on 64-bit: * * xxh_u64 x; * x ^= (x >> 47); // good * x ^= (x >> 13); // bad * * However, to a 32-bit machine, there is a major difference. * * x ^= (x >> 47) looks like this: * * x.lo ^= (x.hi >> (47 - 32)); * * while x ^= (x >> 13) looks like this: * * // note: funnel shifts are not usually cheap. * x.lo ^= (x.lo >> 13) | (x.hi << (32 - 13)); * x.hi ^= (x.hi >> 13); * * The first one is significantly faster than the second, simply because the * shift is larger than 32. This means: * - All the bits we need are in the upper 32 bits, so we can ignore the lower * 32 bits in the shift. * - The shift result will always fit in the lower 32 bits, and therefore, * we can ignore the upper 32 bits in the xor. * * Thanks to this optimization, XXH3 only requires these features to be efficient: * * - Usable unaligned access * - A 32-bit or 64-bit ALU * - If 32-bit, a decent ADC instruction * - A 32 or 64-bit multiply with a 64-bit result * - For the 128-bit variant, a decent byteswap helps short inputs. * * The first two are already required by XXH32, and almost all 32-bit and 64-bit * platforms which can run XXH32 can run XXH3 efficiently. * * Thumb-1, the classic 16-bit only subset of ARM's instruction set, is one * notable exception. * * First of all, Thumb-1 lacks support for the UMULL instruction which * performs the important long multiply. This means numerous __aeabi_lmul * calls. * * Second of all, the 8 functional registers are just not enough. * Setup for __aeabi_lmul, byteshift loads, pointers, and all arithmetic need * Lo registers, and this shuffling results in thousands more MOVs than A32. * * A32 and T32 don't have this limitation. They can access all 14 registers, * do a 32->64 multiply with UMULL, and the flexible operand allowing free * shifts is helpful, too. * * Therefore, we do a quick sanity check. * * If compiling Thumb-1 for a target which supports ARM instructions, we will * emit a warning, as it is not a "sane" platform to compile for. * * Usually, if this happens, it is because of an accident and you probably need * to specify -march, as you likely meant to compile for a newer architecture. * * Credit: large sections of the vectorial and asm source code paths * have been contributed by @easyaspi314 */ #if defined(__thumb__) && !defined(__thumb2__) && defined(__ARM_ARCH_ISA_ARM) # warning "XXH3 is highly inefficient without ARM or Thumb-2." #endif /* ========================================== * Vectorization detection * ========================================== */ #define XXH_SCALAR 0 /* Portable scalar version */ #define XXH_SSE2 1 /* SSE2 for Pentium 4 and all x86_64 */ #define XXH_AVX2 2 /* AVX2 for Haswell and Bulldozer */ #define XXH_AVX512 3 /* AVX512 for Skylake and Icelake */ #define XXH_NEON 4 /* NEON for most ARMv7-A and all AArch64 */ #define XXH_VSX 5 /* VSX and ZVector for POWER8/z13 */ #ifndef XXH_VECTOR /* can be defined on command line */ # if defined(__AVX512F__) # define XXH_VECTOR XXH_AVX512 # elif defined(__AVX2__) # define XXH_VECTOR XXH_AVX2 # elif defined(__SSE2__) || defined(_M_AMD64) || defined(_M_X64) || (defined(_M_IX86_FP) && (_M_IX86_FP == 2)) # define XXH_VECTOR XXH_SSE2 # elif defined(__GNUC__) /* msvc support maybe later */ \ && (defined(__ARM_NEON__) || defined(__ARM_NEON)) \ && (defined(__LITTLE_ENDIAN__) /* We only support little endian NEON */ \ || (defined(__BYTE_ORDER__) && __BYTE_ORDER__ == __ORDER_LITTLE_ENDIAN__)) # define XXH_VECTOR XXH_NEON # elif (defined(__PPC64__) && defined(__POWER8_VECTOR__)) \ || (defined(__s390x__) && defined(__VEC__)) \ && defined(__GNUC__) /* TODO: IBM XL */ # define XXH_VECTOR XXH_VSX # else # define XXH_VECTOR XXH_SCALAR # endif #endif /* * Controls the alignment of the accumulator, * for compatibility with aligned vector loads, which are usually faster. */ #ifndef XXH_ACC_ALIGN # if defined(XXH_X86DISPATCH) # define XXH_ACC_ALIGN 64 /* for compatibility with avx512 */ # elif XXH_VECTOR == XXH_SCALAR /* scalar */ # define XXH_ACC_ALIGN 8 # elif XXH_VECTOR == XXH_SSE2 /* sse2 */ # define XXH_ACC_ALIGN 16 # elif XXH_VECTOR == XXH_AVX2 /* avx2 */ # define XXH_ACC_ALIGN 32 # elif XXH_VECTOR == XXH_NEON /* neon */ # define XXH_ACC_ALIGN 16 # elif XXH_VECTOR == XXH_VSX /* vsx */ # define XXH_ACC_ALIGN 16 # elif XXH_VECTOR == XXH_AVX512 /* avx512 */ # define XXH_ACC_ALIGN 64 # endif #endif #if defined(XXH_X86DISPATCH) || XXH_VECTOR == XXH_SSE2 \ || XXH_VECTOR == XXH_AVX2 || XXH_VECTOR == XXH_AVX512 # define XXH_SEC_ALIGN XXH_ACC_ALIGN #else # define XXH_SEC_ALIGN 8 #endif /* * UGLY HACK: * GCC usually generates the best code with -O3 for xxHash. * * However, when targeting AVX2, it is overzealous in its unrolling resulting * in code roughly 3/4 the speed of Clang. * * There are other issues, such as GCC splitting _mm256_loadu_si256 into * _mm_loadu_si128 + _mm256_inserti128_si256. This is an optimization which * only applies to Sandy and Ivy Bridge... which don't even support AVX2. * * That is why when compiling the AVX2 version, it is recommended to use either * -O2 -mavx2 -march=haswell * or * -O2 -mavx2 -mno-avx256-split-unaligned-load * for decent performance, or to use Clang instead. * * Fortunately, we can control the first one with a pragma that forces GCC into * -O2, but the other one we can't control without "failed to inline always * inline function due to target mismatch" warnings. */ #if XXH_VECTOR == XXH_AVX2 /* AVX2 */ \ && defined(__GNUC__) && !defined(__clang__) /* GCC, not Clang */ \ && defined(__OPTIMIZE__) && !defined(__OPTIMIZE_SIZE__) /* respect -O0 and -Os */ # pragma GCC push_options # pragma GCC optimize("-O2") #endif #if XXH_VECTOR == XXH_NEON /* * NEON's setup for vmlal_u32 is a little more complicated than it is on * SSE2, AVX2, and VSX. * * While PMULUDQ and VMULEUW both perform a mask, VMLAL.U32 performs an upcast. * * To do the same operation, the 128-bit 'Q' register needs to be split into * two 64-bit 'D' registers, performing this operation:: * * [ a | b ] * | '---------. .--------' | * | x | * | .---------' '--------. | * [ a & 0xFFFFFFFF | b & 0xFFFFFFFF ],[ a >> 32 | b >> 32 ] * * Due to significant changes in aarch64, the fastest method for aarch64 is * completely different than the fastest method for ARMv7-A. * * ARMv7-A treats D registers as unions overlaying Q registers, so modifying * D11 will modify the high half of Q5. This is similar to how modifying AH * will only affect bits 8-15 of AX on x86. * * VZIP takes two registers, and puts even lanes in one register and odd lanes * in the other. * * On ARMv7-A, this strangely modifies both parameters in place instead of * taking the usual 3-operand form. * * Therefore, if we want to do this, we can simply use a D-form VZIP.32 on the * lower and upper halves of the Q register to end up with the high and low * halves where we want - all in one instruction. * * vzip.32 d10, d11 @ d10 = { d10[0], d11[0] }; d11 = { d10[1], d11[1] } * * Unfortunately we need inline assembly for this: Instructions modifying two * registers at once is not possible in GCC or Clang's IR, and they have to * create a copy. * * aarch64 requires a different approach. * * In order to make it easier to write a decent compiler for aarch64, many * quirks were removed, such as conditional execution. * * NEON was also affected by this. * * aarch64 cannot access the high bits of a Q-form register, and writes to a * D-form register zero the high bits, similar to how writes to W-form scalar * registers (or DWORD registers on x86_64) work. * * The formerly free vget_high intrinsics now require a vext (with a few * exceptions) * * Additionally, VZIP was replaced by ZIP1 and ZIP2, which are the equivalent * of PUNPCKL* and PUNPCKH* in SSE, respectively, in order to only modify one * operand. * * The equivalent of the VZIP.32 on the lower and upper halves would be this * mess: * * ext v2.4s, v0.4s, v0.4s, #2 // v2 = { v0[2], v0[3], v0[0], v0[1] } * zip1 v1.2s, v0.2s, v2.2s // v1 = { v0[0], v2[0] } * zip2 v0.2s, v0.2s, v1.2s // v0 = { v0[1], v2[1] } * * Instead, we use a literal downcast, vmovn_u64 (XTN), and vshrn_n_u64 (SHRN): * * shrn v1.2s, v0.2d, #32 // v1 = (uint32x2_t)(v0 >> 32); * xtn v0.2s, v0.2d // v0 = (uint32x2_t)(v0 & 0xFFFFFFFF); * * This is available on ARMv7-A, but is less efficient than a single VZIP.32. */ /* * Function-like macro: * void XXH_SPLIT_IN_PLACE(uint64x2_t &in, uint32x2_t &outLo, uint32x2_t &outHi) * { * outLo = (uint32x2_t)(in & 0xFFFFFFFF); * outHi = (uint32x2_t)(in >> 32); * in = UNDEFINED; * } */ # if !defined(XXH_NO_VZIP_HACK) /* define to disable */ \ && defined(__GNUC__) \ && !defined(__aarch64__) && !defined(__arm64__) # define XXH_SPLIT_IN_PLACE(in, outLo, outHi) \ do { \ /* Undocumented GCC/Clang operand modifier: %e0 = lower D half, %f0 = upper D half */ \ /* https://github.com/gcc-mirror/gcc/blob/38cf91e5/gcc/config/arm/arm.c#L22486 */ \ /* https://github.com/llvm-mirror/llvm/blob/2c4ca683/lib/Target/ARM/ARMAsmPrinter.cpp#L399 */ \ __asm__("vzip.32 %e0, %f0" : "+w" (in)); \ (outLo) = vget_low_u32 (vreinterpretq_u32_u64(in)); \ (outHi) = vget_high_u32(vreinterpretq_u32_u64(in)); \ } while (0) # else # define XXH_SPLIT_IN_PLACE(in, outLo, outHi) \ do { \ (outLo) = vmovn_u64 (in); \ (outHi) = vshrn_n_u64 ((in), 32); \ } while (0) # endif #endif /* XXH_VECTOR == XXH_NEON */ /* * VSX and Z Vector helpers. * * This is very messy, and any pull requests to clean this up are welcome. * * There are a lot of problems with supporting VSX and s390x, due to * inconsistent intrinsics, spotty coverage, and multiple endiannesses. */ #if XXH_VECTOR == XXH_VSX # if defined(__s390x__) # include # else /* gcc's altivec.h can have the unwanted consequence to unconditionally * #define bool, vector, and pixel keywords, * with bad consequences for programs already using these keywords for other purposes. * The paragraph defining these macros is skipped when __APPLE_ALTIVEC__ is defined. * __APPLE_ALTIVEC__ is _generally_ defined automatically by the compiler, * but it seems that, in some cases, it isn't. * Force the build macro to be defined, so that keywords are not altered. */ # if defined(__GNUC__) && !defined(__APPLE_ALTIVEC__) # define __APPLE_ALTIVEC__ # endif # include # endif typedef __vector unsigned long long xxh_u64x2; typedef __vector unsigned char xxh_u8x16; typedef __vector unsigned xxh_u32x4; # ifndef XXH_VSX_BE # if defined(__BIG_ENDIAN__) \ || (defined(__BYTE_ORDER__) && __BYTE_ORDER__ == __ORDER_BIG_ENDIAN__) # define XXH_VSX_BE 1 # elif defined(__VEC_ELEMENT_REG_ORDER__) && __VEC_ELEMENT_REG_ORDER__ == __ORDER_BIG_ENDIAN__ # warning "-maltivec=be is not recommended. Please use native endianness." # define XXH_VSX_BE 1 # else # define XXH_VSX_BE 0 # endif # endif /* !defined(XXH_VSX_BE) */ # if XXH_VSX_BE /* A wrapper for POWER9's vec_revb. */ # if defined(__POWER9_VECTOR__) || (defined(__clang__) && defined(__s390x__)) # define XXH_vec_revb vec_revb # else XXH_FORCE_INLINE xxh_u64x2 XXH_vec_revb(xxh_u64x2 val) { xxh_u8x16 const vByteSwap = { 0x07, 0x06, 0x05, 0x04, 0x03, 0x02, 0x01, 0x00, 0x0F, 0x0E, 0x0D, 0x0C, 0x0B, 0x0A, 0x09, 0x08 }; return vec_perm(val, val, vByteSwap); } # endif # endif /* XXH_VSX_BE */ /* * Performs an unaligned load and byte swaps it on big endian. */ XXH_FORCE_INLINE xxh_u64x2 XXH_vec_loadu(const void *ptr) { xxh_u64x2 ret; memcpy(&ret, ptr, sizeof(xxh_u64x2)); # if XXH_VSX_BE ret = XXH_vec_revb(ret); # endif return ret; } /* * vec_mulo and vec_mule are very problematic intrinsics on PowerPC * * These intrinsics weren't added until GCC 8, despite existing for a while, * and they are endian dependent. Also, their meaning swap depending on version. * */ # if defined(__s390x__) /* s390x is always big endian, no issue on this platform */ # define XXH_vec_mulo vec_mulo # define XXH_vec_mule vec_mule # elif defined(__clang__) && XXH_HAS_BUILTIN(__builtin_altivec_vmuleuw) /* Clang has a better way to control this, we can just use the builtin which doesn't swap. */ # define XXH_vec_mulo __builtin_altivec_vmulouw # define XXH_vec_mule __builtin_altivec_vmuleuw # else /* gcc needs inline assembly */ /* Adapted from https://github.com/google/highwayhash/blob/master/highwayhash/hh_vsx.h. */ XXH_FORCE_INLINE xxh_u64x2 XXH_vec_mulo(xxh_u32x4 a, xxh_u32x4 b) { xxh_u64x2 result; __asm__("vmulouw %0, %1, %2" : "=v" (result) : "v" (a), "v" (b)); return result; } XXH_FORCE_INLINE xxh_u64x2 XXH_vec_mule(xxh_u32x4 a, xxh_u32x4 b) { xxh_u64x2 result; __asm__("vmuleuw %0, %1, %2" : "=v" (result) : "v" (a), "v" (b)); return result; } # endif /* XXH_vec_mulo, XXH_vec_mule */ #endif /* XXH_VECTOR == XXH_VSX */ /* prefetch * can be disabled, by declaring XXH_NO_PREFETCH build macro */ #if defined(XXH_NO_PREFETCH) # define XXH_PREFETCH(ptr) (void)(ptr) /* disabled */ #else # if defined(_MSC_VER) && (defined(_M_X64) || defined(_M_I86)) /* _mm_prefetch() is not defined outside of x86/x64 */ # include /* https://msdn.microsoft.com/fr-fr/library/84szxsww(v=vs.90).aspx */ # define XXH_PREFETCH(ptr) _mm_prefetch((const char*)(ptr), _MM_HINT_T0) # elif defined(__GNUC__) && ( (__GNUC__ >= 4) || ( (__GNUC__ == 3) && (__GNUC_MINOR__ >= 1) ) ) # define XXH_PREFETCH(ptr) __builtin_prefetch((ptr), 0 /* rw==read */, 3 /* locality */) # else # define XXH_PREFETCH(ptr) (void)(ptr) /* disabled */ # endif #endif /* XXH_NO_PREFETCH */ /* ========================================== * XXH3 default settings * ========================================== */ #define XXH_SECRET_DEFAULT_SIZE 192 /* minimum XXH3_SECRET_SIZE_MIN */ #if (XXH_SECRET_DEFAULT_SIZE < XXH3_SECRET_SIZE_MIN) # error "default keyset is not large enough" #endif /* Pseudorandom secret taken directly from FARSH */ XXH_ALIGN(64) static const xxh_u8 XXH3_kSecret[XXH_SECRET_DEFAULT_SIZE] = { 0xb8, 0xfe, 0x6c, 0x39, 0x23, 0xa4, 0x4b, 0xbe, 0x7c, 0x01, 0x81, 0x2c, 0xf7, 0x21, 0xad, 0x1c, 0xde, 0xd4, 0x6d, 0xe9, 0x83, 0x90, 0x97, 0xdb, 0x72, 0x40, 0xa4, 0xa4, 0xb7, 0xb3, 0x67, 0x1f, 0xcb, 0x79, 0xe6, 0x4e, 0xcc, 0xc0, 0xe5, 0x78, 0x82, 0x5a, 0xd0, 0x7d, 0xcc, 0xff, 0x72, 0x21, 0xb8, 0x08, 0x46, 0x74, 0xf7, 0x43, 0x24, 0x8e, 0xe0, 0x35, 0x90, 0xe6, 0x81, 0x3a, 0x26, 0x4c, 0x3c, 0x28, 0x52, 0xbb, 0x91, 0xc3, 0x00, 0xcb, 0x88, 0xd0, 0x65, 0x8b, 0x1b, 0x53, 0x2e, 0xa3, 0x71, 0x64, 0x48, 0x97, 0xa2, 0x0d, 0xf9, 0x4e, 0x38, 0x19, 0xef, 0x46, 0xa9, 0xde, 0xac, 0xd8, 0xa8, 0xfa, 0x76, 0x3f, 0xe3, 0x9c, 0x34, 0x3f, 0xf9, 0xdc, 0xbb, 0xc7, 0xc7, 0x0b, 0x4f, 0x1d, 0x8a, 0x51, 0xe0, 0x4b, 0xcd, 0xb4, 0x59, 0x31, 0xc8, 0x9f, 0x7e, 0xc9, 0xd9, 0x78, 0x73, 0x64, 0xea, 0xc5, 0xac, 0x83, 0x34, 0xd3, 0xeb, 0xc3, 0xc5, 0x81, 0xa0, 0xff, 0xfa, 0x13, 0x63, 0xeb, 0x17, 0x0d, 0xdd, 0x51, 0xb7, 0xf0, 0xda, 0x49, 0xd3, 0x16, 0x55, 0x26, 0x29, 0xd4, 0x68, 0x9e, 0x2b, 0x16, 0xbe, 0x58, 0x7d, 0x47, 0xa1, 0xfc, 0x8f, 0xf8, 0xb8, 0xd1, 0x7a, 0xd0, 0x31, 0xce, 0x45, 0xcb, 0x3a, 0x8f, 0x95, 0x16, 0x04, 0x28, 0xaf, 0xd7, 0xfb, 0xca, 0xbb, 0x4b, 0x40, 0x7e, }; #ifdef XXH_OLD_NAMES # define kSecret XXH3_kSecret #endif /* * Calculates a 32-bit to 64-bit long multiply. * * Wraps __emulu on MSVC x86 because it tends to call __allmul when it doesn't * need to (but it shouldn't need to anyways, it is about 7 instructions to do * a 64x64 multiply...). Since we know that this will _always_ emit MULL, we * use that instead of the normal method. * * If you are compiling for platforms like Thumb-1 and don't have a better option, * you may also want to write your own long multiply routine here. * * XXH_FORCE_INLINE xxh_u64 XXH_mult32to64(xxh_u64 x, xxh_u64 y) * { * return (x & 0xFFFFFFFF) * (y & 0xFFFFFFFF); * } */ #if defined(_MSC_VER) && defined(_M_IX86) # include # define XXH_mult32to64(x, y) __emulu((unsigned)(x), (unsigned)(y)) #else /* * Downcast + upcast is usually better than masking on older compilers like * GCC 4.2 (especially 32-bit ones), all without affecting newer compilers. * * The other method, (x & 0xFFFFFFFF) * (y & 0xFFFFFFFF), will AND both operands * and perform a full 64x64 multiply -- entirely redundant on 32-bit. */ # define XXH_mult32to64(x, y) ((xxh_u64)(xxh_u32)(x) * (xxh_u64)(xxh_u32)(y)) #endif /* * Calculates a 64->128-bit long multiply. * * Uses __uint128_t and _umul128 if available, otherwise uses a scalar version. */ static XXH128_hash_t XXH_mult64to128(xxh_u64 lhs, xxh_u64 rhs) { /* * GCC/Clang __uint128_t method. * * On most 64-bit targets, GCC and Clang define a __uint128_t type. * This is usually the best way as it usually uses a native long 64-bit * multiply, such as MULQ on x86_64 or MUL + UMULH on aarch64. * * Usually. * * Despite being a 32-bit platform, Clang (and emscripten) define this type * despite not having the arithmetic for it. This results in a laggy * compiler builtin call which calculates a full 128-bit multiply. * In that case it is best to use the portable one. * https://github.com/Cyan4973/xxHash/issues/211#issuecomment-515575677 */ #if defined(__GNUC__) && !defined(__wasm__) \ && defined(__SIZEOF_INT128__) \ || (defined(_INTEGRAL_MAX_BITS) && _INTEGRAL_MAX_BITS >= 128) __uint128_t const product = (__uint128_t)lhs * (__uint128_t)rhs; XXH128_hash_t r128; r128.low64 = (xxh_u64)(product); r128.high64 = (xxh_u64)(product >> 64); return r128; /* * MSVC for x64's _umul128 method. * * xxh_u64 _umul128(xxh_u64 Multiplier, xxh_u64 Multiplicand, xxh_u64 *HighProduct); * * This compiles to single operand MUL on x64. */ #elif defined(_M_X64) || defined(_M_IA64) #ifndef _MSC_VER # pragma intrinsic(_umul128) #endif xxh_u64 product_high; xxh_u64 const product_low = _umul128(lhs, rhs, &product_high); XXH128_hash_t r128; r128.low64 = product_low; r128.high64 = product_high; return r128; #else /* * Portable scalar method. Optimized for 32-bit and 64-bit ALUs. * * This is a fast and simple grade school multiply, which is shown below * with base 10 arithmetic instead of base 0x100000000. * * 9 3 // D2 lhs = 93 * x 7 5 // D2 rhs = 75 * ---------- * 1 5 // D2 lo_lo = (93 % 10) * (75 % 10) = 15 * 4 5 | // D2 hi_lo = (93 / 10) * (75 % 10) = 45 * 2 1 | // D2 lo_hi = (93 % 10) * (75 / 10) = 21 * + 6 3 | | // D2 hi_hi = (93 / 10) * (75 / 10) = 63 * --------- * 2 7 | // D2 cross = (15 / 10) + (45 % 10) + 21 = 27 * + 6 7 | | // D2 upper = (27 / 10) + (45 / 10) + 63 = 67 * --------- * 6 9 7 5 // D4 res = (27 * 10) + (15 % 10) + (67 * 100) = 6975 * * The reasons for adding the products like this are: * 1. It avoids manual carry tracking. Just like how * (9 * 9) + 9 + 9 = 99, the same applies with this for UINT64_MAX. * This avoids a lot of complexity. * * 2. It hints for, and on Clang, compiles to, the powerful UMAAL * instruction available in ARM's Digital Signal Processing extension * in 32-bit ARMv6 and later, which is shown below: * * void UMAAL(xxh_u32 *RdLo, xxh_u32 *RdHi, xxh_u32 Rn, xxh_u32 Rm) * { * xxh_u64 product = (xxh_u64)*RdLo * (xxh_u64)*RdHi + Rn + Rm; * *RdLo = (xxh_u32)(product & 0xFFFFFFFF); * *RdHi = (xxh_u32)(product >> 32); * } * * This instruction was designed for efficient long multiplication, and * allows this to be calculated in only 4 instructions at speeds * comparable to some 64-bit ALUs. * * 3. It isn't terrible on other platforms. Usually this will be a couple * of 32-bit ADD/ADCs. */ /* First calculate all of the cross products. */ xxh_u64 const lo_lo = XXH_mult32to64(lhs & 0xFFFFFFFF, rhs & 0xFFFFFFFF); xxh_u64 const hi_lo = XXH_mult32to64(lhs >> 32, rhs & 0xFFFFFFFF); xxh_u64 const lo_hi = XXH_mult32to64(lhs & 0xFFFFFFFF, rhs >> 32); xxh_u64 const hi_hi = XXH_mult32to64(lhs >> 32, rhs >> 32); /* Now add the products together. These will never overflow. */ xxh_u64 const cross = (lo_lo >> 32) + (hi_lo & 0xFFFFFFFF) + lo_hi; xxh_u64 const upper = (hi_lo >> 32) + (cross >> 32) + hi_hi; xxh_u64 const lower = (cross << 32) | (lo_lo & 0xFFFFFFFF); XXH128_hash_t r128; r128.low64 = lower; r128.high64 = upper; return r128; #endif } /* * Does a 64-bit to 128-bit multiply, then XOR folds it. * * The reason for the separate function is to prevent passing too many structs * around by value. This will hopefully inline the multiply, but we don't force it. */ static xxh_u64 XXH3_mul128_fold64(xxh_u64 lhs, xxh_u64 rhs) { XXH128_hash_t product = XXH_mult64to128(lhs, rhs); return product.low64 ^ product.high64; } /* Seems to produce slightly better code on GCC for some reason. */ XXH_FORCE_INLINE xxh_u64 XXH_xorshift64(xxh_u64 v64, int shift) { XXH_ASSERT(0 <= shift && shift < 64); return v64 ^ (v64 >> shift); } /* * This is a fast avalanche stage, * suitable when input bits are already partially mixed */ static XXH64_hash_t XXH3_avalanche(xxh_u64 h64) { h64 = XXH_xorshift64(h64, 37); h64 *= 0x165667919E3779F9ULL; h64 = XXH_xorshift64(h64, 32); return h64; } /* * This is a stronger avalanche, * inspired by Pelle Evensen's rrmxmx * preferable when input has not been previously mixed */ static XXH64_hash_t XXH3_rrmxmx(xxh_u64 h64, xxh_u64 len) { /* this mix is inspired by Pelle Evensen's rrmxmx */ h64 ^= XXH_rotl64(h64, 49) ^ XXH_rotl64(h64, 24); h64 *= 0x9FB21C651E98DF25ULL; h64 ^= (h64 >> 35) + len ; h64 *= 0x9FB21C651E98DF25ULL; return XXH_xorshift64(h64, 28); } /* ========================================== * Short keys * ========================================== * One of the shortcomings of XXH32 and XXH64 was that their performance was * sub-optimal on short lengths. It used an iterative algorithm which strongly * favored lengths that were a multiple of 4 or 8. * * Instead of iterating over individual inputs, we use a set of single shot * functions which piece together a range of lengths and operate in constant time. * * Additionally, the number of multiplies has been significantly reduced. This * reduces latency, especially when emulating 64-bit multiplies on 32-bit. * * Depending on the platform, this may or may not be faster than XXH32, but it * is almost guaranteed to be faster than XXH64. */ /* * At very short lengths, there isn't enough input to fully hide secrets, or use * the entire secret. * * There is also only a limited amount of mixing we can do before significantly * impacting performance. * * Therefore, we use different sections of the secret and always mix two secret * samples with an XOR. This should have no effect on performance on the * seedless or withSeed variants because everything _should_ be constant folded * by modern compilers. * * The XOR mixing hides individual parts of the secret and increases entropy. * * This adds an extra layer of strength for custom secrets. */ XXH_FORCE_INLINE XXH64_hash_t XXH3_len_1to3_64b(const xxh_u8* input, size_t len, const xxh_u8* secret, XXH64_hash_t seed) { XXH_ASSERT(input != NULL); XXH_ASSERT(1 <= len && len <= 3); XXH_ASSERT(secret != NULL); /* * len = 1: combined = { input[0], 0x01, input[0], input[0] } * len = 2: combined = { input[1], 0x02, input[0], input[1] } * len = 3: combined = { input[2], 0x03, input[0], input[1] } */ { xxh_u8 const c1 = input[0]; xxh_u8 const c2 = input[len >> 1]; xxh_u8 const c3 = input[len - 1]; xxh_u32 const combined = ((xxh_u32)c1 << 16) | ((xxh_u32)c2 << 24) | ((xxh_u32)c3 << 0) | ((xxh_u32)len << 8); xxh_u64 const bitflip = (XXH_readLE32(secret) ^ XXH_readLE32(secret+4)) + seed; xxh_u64 const keyed = (xxh_u64)combined ^ bitflip; return XXH64_avalanche(keyed); } } XXH_FORCE_INLINE XXH64_hash_t XXH3_len_4to8_64b(const xxh_u8* input, size_t len, const xxh_u8* secret, XXH64_hash_t seed) { XXH_ASSERT(input != NULL); XXH_ASSERT(secret != NULL); XXH_ASSERT(4 <= len && len < 8); seed ^= (xxh_u64)XXH_swap32((xxh_u32)seed) << 32; { xxh_u32 const input1 = XXH_readLE32(input); xxh_u32 const input2 = XXH_readLE32(input + len - 4); xxh_u64 const bitflip = (XXH_readLE64(secret+8) ^ XXH_readLE64(secret+16)) - seed; xxh_u64 const input64 = input2 + (((xxh_u64)input1) << 32); xxh_u64 const keyed = input64 ^ bitflip; return XXH3_rrmxmx(keyed, len); } } XXH_FORCE_INLINE XXH64_hash_t XXH3_len_9to16_64b(const xxh_u8* input, size_t len, const xxh_u8* secret, XXH64_hash_t seed) { XXH_ASSERT(input != NULL); XXH_ASSERT(secret != NULL); XXH_ASSERT(8 <= len && len <= 16); { xxh_u64 const bitflip1 = (XXH_readLE64(secret+24) ^ XXH_readLE64(secret+32)) + seed; xxh_u64 const bitflip2 = (XXH_readLE64(secret+40) ^ XXH_readLE64(secret+48)) - seed; xxh_u64 const input_lo = XXH_readLE64(input) ^ bitflip1; xxh_u64 const input_hi = XXH_readLE64(input + len - 8) ^ bitflip2; xxh_u64 const acc = len + XXH_swap64(input_lo) + input_hi + XXH3_mul128_fold64(input_lo, input_hi); return XXH3_avalanche(acc); } } XXH_FORCE_INLINE XXH64_hash_t XXH3_len_0to16_64b(const xxh_u8* input, size_t len, const xxh_u8* secret, XXH64_hash_t seed) { XXH_ASSERT(len <= 16); { if (XXH_likely(len > 8)) return XXH3_len_9to16_64b(input, len, secret, seed); if (XXH_likely(len >= 4)) return XXH3_len_4to8_64b(input, len, secret, seed); if (len) return XXH3_len_1to3_64b(input, len, secret, seed); return XXH64_avalanche(seed ^ (XXH_readLE64(secret+56) ^ XXH_readLE64(secret+64))); } } /* * DISCLAIMER: There are known *seed-dependent* multicollisions here due to * multiplication by zero, affecting hashes of lengths 17 to 240. * * However, they are very unlikely. * * Keep this in mind when using the unseeded XXH3_64bits() variant: As with all * unseeded non-cryptographic hashes, it does not attempt to defend itself * against specially crafted inputs, only random inputs. * * Compared to classic UMAC where a 1 in 2^31 chance of 4 consecutive bytes * cancelling out the secret is taken an arbitrary number of times (addressed * in XXH3_accumulate_512), this collision is very unlikely with random inputs * and/or proper seeding: * * This only has a 1 in 2^63 chance of 8 consecutive bytes cancelling out, in a * function that is only called up to 16 times per hash with up to 240 bytes of * input. * * This is not too bad for a non-cryptographic hash function, especially with * only 64 bit outputs. * * The 128-bit variant (which trades some speed for strength) is NOT affected * by this, although it is always a good idea to use a proper seed if you care * about strength. */ XXH_FORCE_INLINE xxh_u64 XXH3_mix16B(const xxh_u8* XXH_RESTRICT input, const xxh_u8* XXH_RESTRICT secret, xxh_u64 seed64) { #if defined(__GNUC__) && !defined(__clang__) /* GCC, not Clang */ \ && defined(__i386__) && defined(__SSE2__) /* x86 + SSE2 */ \ && !defined(XXH_ENABLE_AUTOVECTORIZE) /* Define to disable like XXH32 hack */ /* * UGLY HACK: * GCC for x86 tends to autovectorize the 128-bit multiply, resulting in * slower code. * * By forcing seed64 into a register, we disrupt the cost model and * cause it to scalarize. See `XXH32_round()` * * FIXME: Clang's output is still _much_ faster -- On an AMD Ryzen 3600, * XXH3_64bits @ len=240 runs at 4.6 GB/s with Clang 9, but 3.3 GB/s on * GCC 9.2, despite both emitting scalar code. * * GCC generates much better scalar code than Clang for the rest of XXH3, * which is why finding a more optimal codepath is an interest. */ __asm__ ("" : "+r" (seed64)); #endif { xxh_u64 const input_lo = XXH_readLE64(input); xxh_u64 const input_hi = XXH_readLE64(input+8); return XXH3_mul128_fold64( input_lo ^ (XXH_readLE64(secret) + seed64), input_hi ^ (XXH_readLE64(secret+8) - seed64) ); } } /* For mid range keys, XXH3 uses a Mum-hash variant. */ XXH_FORCE_INLINE XXH64_hash_t XXH3_len_17to128_64b(const xxh_u8* XXH_RESTRICT input, size_t len, const xxh_u8* XXH_RESTRICT secret, size_t secretSize, XXH64_hash_t seed) { XXH_ASSERT(secretSize >= XXH3_SECRET_SIZE_MIN); (void)secretSize; XXH_ASSERT(16 < len && len <= 128); { xxh_u64 acc = len * XXH_PRIME64_1; if (len > 32) { if (len > 64) { if (len > 96) { acc += XXH3_mix16B(input+48, secret+96, seed); acc += XXH3_mix16B(input+len-64, secret+112, seed); } acc += XXH3_mix16B(input+32, secret+64, seed); acc += XXH3_mix16B(input+len-48, secret+80, seed); } acc += XXH3_mix16B(input+16, secret+32, seed); acc += XXH3_mix16B(input+len-32, secret+48, seed); } acc += XXH3_mix16B(input+0, secret+0, seed); acc += XXH3_mix16B(input+len-16, secret+16, seed); return XXH3_avalanche(acc); } } #define XXH3_MIDSIZE_MAX 240 XXH_NO_INLINE XXH64_hash_t XXH3_len_129to240_64b(const xxh_u8* XXH_RESTRICT input, size_t len, const xxh_u8* XXH_RESTRICT secret, size_t secretSize, XXH64_hash_t seed) { XXH_ASSERT(secretSize >= XXH3_SECRET_SIZE_MIN); (void)secretSize; XXH_ASSERT(128 < len && len <= XXH3_MIDSIZE_MAX); #define XXH3_MIDSIZE_STARTOFFSET 3 #define XXH3_MIDSIZE_LASTOFFSET 17 { xxh_u64 acc = len * XXH_PRIME64_1; int const nbRounds = (int)len / 16; int i; for (i=0; i<8; i++) { acc += XXH3_mix16B(input+(16*i), secret+(16*i), seed); } acc = XXH3_avalanche(acc); XXH_ASSERT(nbRounds >= 8); #if defined(__clang__) /* Clang */ \ && (defined(__ARM_NEON) || defined(__ARM_NEON__)) /* NEON */ \ && !defined(XXH_ENABLE_AUTOVECTORIZE) /* Define to disable */ /* * UGLY HACK: * Clang for ARMv7-A tries to vectorize this loop, similar to GCC x86. * In everywhere else, it uses scalar code. * * For 64->128-bit multiplies, even if the NEON was 100% optimal, it * would still be slower than UMAAL (see XXH_mult64to128). * * Unfortunately, Clang doesn't handle the long multiplies properly and * converts them to the nonexistent "vmulq_u64" intrinsic, which is then * scalarized into an ugly mess of VMOV.32 instructions. * * This mess is difficult to avoid without turning autovectorization * off completely, but they are usually relatively minor and/or not * worth it to fix. * * This loop is the easiest to fix, as unlike XXH32, this pragma * _actually works_ because it is a loop vectorization instead of an * SLP vectorization. */ #pragma clang loop vectorize(disable) #endif for (i=8 ; i < nbRounds; i++) { acc += XXH3_mix16B(input+(16*i), secret+(16*(i-8)) + XXH3_MIDSIZE_STARTOFFSET, seed); } /* last bytes */ acc += XXH3_mix16B(input + len - 16, secret + XXH3_SECRET_SIZE_MIN - XXH3_MIDSIZE_LASTOFFSET, seed); return XXH3_avalanche(acc); } } /* ======= Long Keys ======= */ #define XXH_STRIPE_LEN 64 #define XXH_SECRET_CONSUME_RATE 8 /* nb of secret bytes consumed at each accumulation */ #define XXH_ACC_NB (XXH_STRIPE_LEN / sizeof(xxh_u64)) #ifdef XXH_OLD_NAMES # define STRIPE_LEN XXH_STRIPE_LEN # define ACC_NB XXH_ACC_NB #endif XXH_FORCE_INLINE void XXH_writeLE64(void* dst, xxh_u64 v64) { if (!XXH_CPU_LITTLE_ENDIAN) v64 = XXH_swap64(v64); memcpy(dst, &v64, sizeof(v64)); } /* Several intrinsic functions below are supposed to accept __int64 as argument, * as documented in https://software.intel.com/sites/landingpage/IntrinsicsGuide/ . * However, several environments do not define __int64 type, * requiring a workaround. */ #if !defined (__VMS) \ && (defined (__cplusplus) \ || (defined (__STDC_VERSION__) && (__STDC_VERSION__ >= 199901L) /* C99 */) ) typedef int64_t xxh_i64; #else /* the following type must have a width of 64-bit */ typedef long long xxh_i64; #endif /* * XXH3_accumulate_512 is the tightest loop for long inputs, and it is the most optimized. * * It is a hardened version of UMAC, based off of FARSH's implementation. * * This was chosen because it adapts quite well to 32-bit, 64-bit, and SIMD * implementations, and it is ridiculously fast. * * We harden it by mixing the original input to the accumulators as well as the product. * * This means that in the (relatively likely) case of a multiply by zero, the * original input is preserved. * * On 128-bit inputs, we swap 64-bit pairs when we add the input to improve * cross-pollination, as otherwise the upper and lower halves would be * essentially independent. * * This doesn't matter on 64-bit hashes since they all get merged together in * the end, so we skip the extra step. * * Both XXH3_64bits and XXH3_128bits use this subroutine. */ #if (XXH_VECTOR == XXH_AVX512) || defined(XXH_X86DISPATCH) #ifndef XXH_TARGET_AVX512 # define XXH_TARGET_AVX512 /* disable attribute target */ #endif XXH_FORCE_INLINE XXH_TARGET_AVX512 void XXH3_accumulate_512_avx512(void* XXH_RESTRICT acc, const void* XXH_RESTRICT input, const void* XXH_RESTRICT secret) { XXH_ALIGN(64) __m512i* const xacc = (__m512i *) acc; XXH_ASSERT((((size_t)acc) & 63) == 0); XXH_STATIC_ASSERT(XXH_STRIPE_LEN == sizeof(__m512i)); { /* data_vec = input[0]; */ __m512i const data_vec = _mm512_loadu_si512 (input); /* key_vec = secret[0]; */ __m512i const key_vec = _mm512_loadu_si512 (secret); /* data_key = data_vec ^ key_vec; */ __m512i const data_key = _mm512_xor_si512 (data_vec, key_vec); /* data_key_lo = data_key >> 32; */ __m512i const data_key_lo = _mm512_shuffle_epi32 (data_key, (_MM_PERM_ENUM)_MM_SHUFFLE(0, 3, 0, 1)); /* product = (data_key & 0xffffffff) * (data_key_lo & 0xffffffff); */ __m512i const product = _mm512_mul_epu32 (data_key, data_key_lo); /* xacc[0] += swap(data_vec); */ __m512i const data_swap = _mm512_shuffle_epi32(data_vec, (_MM_PERM_ENUM)_MM_SHUFFLE(1, 0, 3, 2)); __m512i const sum = _mm512_add_epi64(*xacc, data_swap); /* xacc[0] += product; */ *xacc = _mm512_add_epi64(product, sum); } } /* * XXH3_scrambleAcc: Scrambles the accumulators to improve mixing. * * Multiplication isn't perfect, as explained by Google in HighwayHash: * * // Multiplication mixes/scrambles bytes 0-7 of the 64-bit result to * // varying degrees. In descending order of goodness, bytes * // 3 4 2 5 1 6 0 7 have quality 228 224 164 160 100 96 36 32. * // As expected, the upper and lower bytes are much worse. * * Source: https://github.com/google/highwayhash/blob/0aaf66b/highwayhash/hh_avx2.h#L291 * * Since our algorithm uses a pseudorandom secret to add some variance into the * mix, we don't need to (or want to) mix as often or as much as HighwayHash does. * * This isn't as tight as XXH3_accumulate, but still written in SIMD to avoid * extraction. * * Both XXH3_64bits and XXH3_128bits use this subroutine. */ XXH_FORCE_INLINE XXH_TARGET_AVX512 void XXH3_scrambleAcc_avx512(void* XXH_RESTRICT acc, const void* XXH_RESTRICT secret) { XXH_ASSERT((((size_t)acc) & 63) == 0); XXH_STATIC_ASSERT(XXH_STRIPE_LEN == sizeof(__m512i)); { XXH_ALIGN(64) __m512i* const xacc = (__m512i*) acc; const __m512i prime32 = _mm512_set1_epi32((int)XXH_PRIME32_1); /* xacc[0] ^= (xacc[0] >> 47) */ __m512i const acc_vec = *xacc; __m512i const shifted = _mm512_srli_epi64 (acc_vec, 47); __m512i const data_vec = _mm512_xor_si512 (acc_vec, shifted); /* xacc[0] ^= secret; */ __m512i const key_vec = _mm512_loadu_si512 (secret); __m512i const data_key = _mm512_xor_si512 (data_vec, key_vec); /* xacc[0] *= XXH_PRIME32_1; */ __m512i const data_key_hi = _mm512_shuffle_epi32 (data_key, (_MM_PERM_ENUM)_MM_SHUFFLE(0, 3, 0, 1)); __m512i const prod_lo = _mm512_mul_epu32 (data_key, prime32); __m512i const prod_hi = _mm512_mul_epu32 (data_key_hi, prime32); *xacc = _mm512_add_epi64(prod_lo, _mm512_slli_epi64(prod_hi, 32)); } } XXH_FORCE_INLINE XXH_TARGET_AVX512 void XXH3_initCustomSecret_avx512(void* XXH_RESTRICT customSecret, xxh_u64 seed64) { XXH_STATIC_ASSERT((XXH_SECRET_DEFAULT_SIZE & 63) == 0); XXH_STATIC_ASSERT(XXH_SEC_ALIGN == 64); XXH_ASSERT(((size_t)customSecret & 63) == 0); (void)(&XXH_writeLE64); { int const nbRounds = XXH_SECRET_DEFAULT_SIZE / sizeof(__m512i); __m512i const seed = _mm512_mask_set1_epi64(_mm512_set1_epi64((xxh_i64)seed64), 0xAA, -(xxh_i64)seed64); XXH_ALIGN(64) const __m512i* const src = (const __m512i*) XXH3_kSecret; XXH_ALIGN(64) __m512i* const dest = ( __m512i*) customSecret; int i; for (i=0; i < nbRounds; ++i) { /* GCC has a bug, _mm512_stream_load_si512 accepts 'void*', not 'void const*', * this will warn "discards ‘const’ qualifier". */ union { XXH_ALIGN(64) const __m512i* cp; XXH_ALIGN(64) void* p; } remote_const_void; remote_const_void.cp = src + i; dest[i] = _mm512_add_epi64(_mm512_stream_load_si512(remote_const_void.p), seed); } } } #endif #if (XXH_VECTOR == XXH_AVX2) || defined(XXH_X86DISPATCH) #ifndef XXH_TARGET_AVX2 # define XXH_TARGET_AVX2 /* disable attribute target */ #endif XXH_FORCE_INLINE XXH_TARGET_AVX2 void XXH3_accumulate_512_avx2( void* XXH_RESTRICT acc, const void* XXH_RESTRICT input, const void* XXH_RESTRICT secret) { XXH_ASSERT((((size_t)acc) & 31) == 0); { XXH_ALIGN(32) __m256i* const xacc = (__m256i *) acc; /* Unaligned. This is mainly for pointer arithmetic, and because * _mm256_loadu_si256 requires a const __m256i * pointer for some reason. */ const __m256i* const xinput = (const __m256i *) input; /* Unaligned. This is mainly for pointer arithmetic, and because * _mm256_loadu_si256 requires a const __m256i * pointer for some reason. */ const __m256i* const xsecret = (const __m256i *) secret; size_t i; for (i=0; i < XXH_STRIPE_LEN/sizeof(__m256i); i++) { /* data_vec = xinput[i]; */ __m256i const data_vec = _mm256_loadu_si256 (xinput+i); /* key_vec = xsecret[i]; */ __m256i const key_vec = _mm256_loadu_si256 (xsecret+i); /* data_key = data_vec ^ key_vec; */ __m256i const data_key = _mm256_xor_si256 (data_vec, key_vec); /* data_key_lo = data_key >> 32; */ __m256i const data_key_lo = _mm256_shuffle_epi32 (data_key, _MM_SHUFFLE(0, 3, 0, 1)); /* product = (data_key & 0xffffffff) * (data_key_lo & 0xffffffff); */ __m256i const product = _mm256_mul_epu32 (data_key, data_key_lo); /* xacc[i] += swap(data_vec); */ __m256i const data_swap = _mm256_shuffle_epi32(data_vec, _MM_SHUFFLE(1, 0, 3, 2)); __m256i const sum = _mm256_add_epi64(xacc[i], data_swap); /* xacc[i] += product; */ xacc[i] = _mm256_add_epi64(product, sum); } } } XXH_FORCE_INLINE XXH_TARGET_AVX2 void XXH3_scrambleAcc_avx2(void* XXH_RESTRICT acc, const void* XXH_RESTRICT secret) { XXH_ASSERT((((size_t)acc) & 31) == 0); { XXH_ALIGN(32) __m256i* const xacc = (__m256i*) acc; /* Unaligned. This is mainly for pointer arithmetic, and because * _mm256_loadu_si256 requires a const __m256i * pointer for some reason. */ const __m256i* const xsecret = (const __m256i *) secret; const __m256i prime32 = _mm256_set1_epi32((int)XXH_PRIME32_1); size_t i; for (i=0; i < XXH_STRIPE_LEN/sizeof(__m256i); i++) { /* xacc[i] ^= (xacc[i] >> 47) */ __m256i const acc_vec = xacc[i]; __m256i const shifted = _mm256_srli_epi64 (acc_vec, 47); __m256i const data_vec = _mm256_xor_si256 (acc_vec, shifted); /* xacc[i] ^= xsecret; */ __m256i const key_vec = _mm256_loadu_si256 (xsecret+i); __m256i const data_key = _mm256_xor_si256 (data_vec, key_vec); /* xacc[i] *= XXH_PRIME32_1; */ __m256i const data_key_hi = _mm256_shuffle_epi32 (data_key, _MM_SHUFFLE(0, 3, 0, 1)); __m256i const prod_lo = _mm256_mul_epu32 (data_key, prime32); __m256i const prod_hi = _mm256_mul_epu32 (data_key_hi, prime32); xacc[i] = _mm256_add_epi64(prod_lo, _mm256_slli_epi64(prod_hi, 32)); } } } XXH_FORCE_INLINE XXH_TARGET_AVX2 void XXH3_initCustomSecret_avx2(void* XXH_RESTRICT customSecret, xxh_u64 seed64) { XXH_STATIC_ASSERT((XXH_SECRET_DEFAULT_SIZE & 31) == 0); XXH_STATIC_ASSERT((XXH_SECRET_DEFAULT_SIZE / sizeof(__m256i)) == 6); XXH_STATIC_ASSERT(XXH_SEC_ALIGN <= 64); (void)(&XXH_writeLE64); XXH_PREFETCH(customSecret); { __m256i const seed = _mm256_set_epi64x(-(xxh_i64)seed64, (xxh_i64)seed64, -(xxh_i64)seed64, (xxh_i64)seed64); XXH_ALIGN(64) const __m256i* const src = (const __m256i*) XXH3_kSecret; XXH_ALIGN(64) __m256i* dest = ( __m256i*) customSecret; # if defined(__GNUC__) || defined(__clang__) /* * On GCC & Clang, marking 'dest' as modified will cause the compiler: * - do not extract the secret from sse registers in the internal loop * - use less common registers, and avoid pushing these reg into stack * The asm hack causes Clang to assume that XXH3_kSecretPtr aliases with * customSecret, and on aarch64, this prevented LDP from merging two * loads together for free. Putting the loads together before the stores * properly generates LDP. */ __asm__("" : "+r" (dest)); # endif /* GCC -O2 need unroll loop manually */ dest[0] = _mm256_add_epi64(_mm256_stream_load_si256(src+0), seed); dest[1] = _mm256_add_epi64(_mm256_stream_load_si256(src+1), seed); dest[2] = _mm256_add_epi64(_mm256_stream_load_si256(src+2), seed); dest[3] = _mm256_add_epi64(_mm256_stream_load_si256(src+3), seed); dest[4] = _mm256_add_epi64(_mm256_stream_load_si256(src+4), seed); dest[5] = _mm256_add_epi64(_mm256_stream_load_si256(src+5), seed); } } #endif #if (XXH_VECTOR == XXH_SSE2) || defined(XXH_X86DISPATCH) #ifndef XXH_TARGET_SSE2 # define XXH_TARGET_SSE2 /* disable attribute target */ #endif XXH_FORCE_INLINE XXH_TARGET_SSE2 void XXH3_accumulate_512_sse2( void* XXH_RESTRICT acc, const void* XXH_RESTRICT input, const void* XXH_RESTRICT secret) { /* SSE2 is just a half-scale version of the AVX2 version. */ XXH_ASSERT((((size_t)acc) & 15) == 0); { XXH_ALIGN(16) __m128i* const xacc = (__m128i *) acc; /* Unaligned. This is mainly for pointer arithmetic, and because * _mm_loadu_si128 requires a const __m128i * pointer for some reason. */ const __m128i* const xinput = (const __m128i *) input; /* Unaligned. This is mainly for pointer arithmetic, and because * _mm_loadu_si128 requires a const __m128i * pointer for some reason. */ const __m128i* const xsecret = (const __m128i *) secret; size_t i; for (i=0; i < XXH_STRIPE_LEN/sizeof(__m128i); i++) { /* data_vec = xinput[i]; */ __m128i const data_vec = _mm_loadu_si128 (xinput+i); /* key_vec = xsecret[i]; */ __m128i const key_vec = _mm_loadu_si128 (xsecret+i); /* data_key = data_vec ^ key_vec; */ __m128i const data_key = _mm_xor_si128 (data_vec, key_vec); /* data_key_lo = data_key >> 32; */ __m128i const data_key_lo = _mm_shuffle_epi32 (data_key, _MM_SHUFFLE(0, 3, 0, 1)); /* product = (data_key & 0xffffffff) * (data_key_lo & 0xffffffff); */ __m128i const product = _mm_mul_epu32 (data_key, data_key_lo); /* xacc[i] += swap(data_vec); */ __m128i const data_swap = _mm_shuffle_epi32(data_vec, _MM_SHUFFLE(1,0,3,2)); __m128i const sum = _mm_add_epi64(xacc[i], data_swap); /* xacc[i] += product; */ xacc[i] = _mm_add_epi64(product, sum); } } } XXH_FORCE_INLINE XXH_TARGET_SSE2 void XXH3_scrambleAcc_sse2(void* XXH_RESTRICT acc, const void* XXH_RESTRICT secret) { XXH_ASSERT((((size_t)acc) & 15) == 0); { XXH_ALIGN(16) __m128i* const xacc = (__m128i*) acc; /* Unaligned. This is mainly for pointer arithmetic, and because * _mm_loadu_si128 requires a const __m128i * pointer for some reason. */ const __m128i* const xsecret = (const __m128i *) secret; const __m128i prime32 = _mm_set1_epi32((int)XXH_PRIME32_1); size_t i; for (i=0; i < XXH_STRIPE_LEN/sizeof(__m128i); i++) { /* xacc[i] ^= (xacc[i] >> 47) */ __m128i const acc_vec = xacc[i]; __m128i const shifted = _mm_srli_epi64 (acc_vec, 47); __m128i const data_vec = _mm_xor_si128 (acc_vec, shifted); /* xacc[i] ^= xsecret[i]; */ __m128i const key_vec = _mm_loadu_si128 (xsecret+i); __m128i const data_key = _mm_xor_si128 (data_vec, key_vec); /* xacc[i] *= XXH_PRIME32_1; */ __m128i const data_key_hi = _mm_shuffle_epi32 (data_key, _MM_SHUFFLE(0, 3, 0, 1)); __m128i const prod_lo = _mm_mul_epu32 (data_key, prime32); __m128i const prod_hi = _mm_mul_epu32 (data_key_hi, prime32); xacc[i] = _mm_add_epi64(prod_lo, _mm_slli_epi64(prod_hi, 32)); } } } XXH_FORCE_INLINE XXH_TARGET_SSE2 void XXH3_initCustomSecret_sse2(void* XXH_RESTRICT customSecret, xxh_u64 seed64) { XXH_STATIC_ASSERT((XXH_SECRET_DEFAULT_SIZE & 15) == 0); (void)(&XXH_writeLE64); { int const nbRounds = XXH_SECRET_DEFAULT_SIZE / sizeof(__m128i); # if defined(_MSC_VER) && defined(_M_IX86) && _MSC_VER < 1900 // MSVC 32bit mode does not support _mm_set_epi64x before 2015 XXH_ALIGN(16) const xxh_i64 seed64x2[2] = { (xxh_i64)seed64, -(xxh_i64)seed64 }; __m128i const seed = _mm_load_si128((__m128i const*)seed64x2); # else __m128i const seed = _mm_set_epi64x(-(xxh_i64)seed64, (xxh_i64)seed64); # endif int i; XXH_ALIGN(64) const float* const src = (float const*) XXH3_kSecret; XXH_ALIGN(XXH_SEC_ALIGN) __m128i* dest = (__m128i*) customSecret; # if defined(__GNUC__) || defined(__clang__) /* * On GCC & Clang, marking 'dest' as modified will cause the compiler: * - do not extract the secret from sse registers in the internal loop * - use less common registers, and avoid pushing these reg into stack */ __asm__("" : "+r" (dest)); # endif for (i=0; i < nbRounds; ++i) { dest[i] = _mm_add_epi64(_mm_castps_si128(_mm_load_ps(src+i*4)), seed); } } } #endif #if (XXH_VECTOR == XXH_NEON) XXH_FORCE_INLINE void XXH3_accumulate_512_neon( void* XXH_RESTRICT acc, const void* XXH_RESTRICT input, const void* XXH_RESTRICT secret) { XXH_ASSERT((((size_t)acc) & 15) == 0); { XXH_ALIGN(16) uint64x2_t* const xacc = (uint64x2_t *) acc; /* We don't use a uint32x4_t pointer because it causes bus errors on ARMv7. */ uint8_t const* const xinput = (const uint8_t *) input; uint8_t const* const xsecret = (const uint8_t *) secret; size_t i; for (i=0; i < XXH_STRIPE_LEN / sizeof(uint64x2_t); i++) { /* data_vec = xinput[i]; */ uint8x16_t data_vec = vld1q_u8(xinput + (i * 16)); /* key_vec = xsecret[i]; */ uint8x16_t key_vec = vld1q_u8(xsecret + (i * 16)); uint64x2_t data_key; uint32x2_t data_key_lo, data_key_hi; /* xacc[i] += swap(data_vec); */ uint64x2_t const data64 = vreinterpretq_u64_u8(data_vec); uint64x2_t const swapped = vextq_u64(data64, data64, 1); xacc[i] = vaddq_u64 (xacc[i], swapped); /* data_key = data_vec ^ key_vec; */ data_key = vreinterpretq_u64_u8(veorq_u8(data_vec, key_vec)); /* data_key_lo = (uint32x2_t) (data_key & 0xFFFFFFFF); * data_key_hi = (uint32x2_t) (data_key >> 32); * data_key = UNDEFINED; */ XXH_SPLIT_IN_PLACE(data_key, data_key_lo, data_key_hi); /* xacc[i] += (uint64x2_t) data_key_lo * (uint64x2_t) data_key_hi; */ xacc[i] = vmlal_u32 (xacc[i], data_key_lo, data_key_hi); } } } XXH_FORCE_INLINE void XXH3_scrambleAcc_neon(void* XXH_RESTRICT acc, const void* XXH_RESTRICT secret) { XXH_ASSERT((((size_t)acc) & 15) == 0); { uint64x2_t* xacc = (uint64x2_t*) acc; uint8_t const* xsecret = (uint8_t const*) secret; uint32x2_t prime = vdup_n_u32 (XXH_PRIME32_1); size_t i; for (i=0; i < XXH_STRIPE_LEN/sizeof(uint64x2_t); i++) { /* xacc[i] ^= (xacc[i] >> 47); */ uint64x2_t acc_vec = xacc[i]; uint64x2_t shifted = vshrq_n_u64 (acc_vec, 47); uint64x2_t data_vec = veorq_u64 (acc_vec, shifted); /* xacc[i] ^= xsecret[i]; */ uint8x16_t key_vec = vld1q_u8(xsecret + (i * 16)); uint64x2_t data_key = veorq_u64(data_vec, vreinterpretq_u64_u8(key_vec)); /* xacc[i] *= XXH_PRIME32_1 */ uint32x2_t data_key_lo, data_key_hi; /* data_key_lo = (uint32x2_t) (xacc[i] & 0xFFFFFFFF); * data_key_hi = (uint32x2_t) (xacc[i] >> 32); * xacc[i] = UNDEFINED; */ XXH_SPLIT_IN_PLACE(data_key, data_key_lo, data_key_hi); { /* * prod_hi = (data_key >> 32) * XXH_PRIME32_1; * * Avoid vmul_u32 + vshll_n_u32 since Clang 6 and 7 will * incorrectly "optimize" this: * tmp = vmul_u32(vmovn_u64(a), vmovn_u64(b)); * shifted = vshll_n_u32(tmp, 32); * to this: * tmp = "vmulq_u64"(a, b); // no such thing! * shifted = vshlq_n_u64(tmp, 32); * * However, unlike SSE, Clang lacks a 64-bit multiply routine * for NEON, and it scalarizes two 64-bit multiplies instead. * * vmull_u32 has the same timing as vmul_u32, and it avoids * this bug completely. * See https://bugs.llvm.org/show_bug.cgi?id=39967 */ uint64x2_t prod_hi = vmull_u32 (data_key_hi, prime); /* xacc[i] = prod_hi << 32; */ xacc[i] = vshlq_n_u64(prod_hi, 32); /* xacc[i] += (prod_hi & 0xFFFFFFFF) * XXH_PRIME32_1; */ xacc[i] = vmlal_u32(xacc[i], data_key_lo, prime); } } } } #endif #if (XXH_VECTOR == XXH_VSX) XXH_FORCE_INLINE void XXH3_accumulate_512_vsx( void* XXH_RESTRICT acc, const void* XXH_RESTRICT input, const void* XXH_RESTRICT secret) { xxh_u64x2* const xacc = (xxh_u64x2*) acc; /* presumed aligned */ xxh_u64x2 const* const xinput = (xxh_u64x2 const*) input; /* no alignment restriction */ xxh_u64x2 const* const xsecret = (xxh_u64x2 const*) secret; /* no alignment restriction */ xxh_u64x2 const v32 = { 32, 32 }; size_t i; for (i = 0; i < XXH_STRIPE_LEN / sizeof(xxh_u64x2); i++) { /* data_vec = xinput[i]; */ xxh_u64x2 const data_vec = XXH_vec_loadu(xinput + i); /* key_vec = xsecret[i]; */ xxh_u64x2 const key_vec = XXH_vec_loadu(xsecret + i); xxh_u64x2 const data_key = data_vec ^ key_vec; /* shuffled = (data_key << 32) | (data_key >> 32); */ xxh_u32x4 const shuffled = (xxh_u32x4)vec_rl(data_key, v32); /* product = ((xxh_u64x2)data_key & 0xFFFFFFFF) * ((xxh_u64x2)shuffled & 0xFFFFFFFF); */ xxh_u64x2 const product = XXH_vec_mulo((xxh_u32x4)data_key, shuffled); xacc[i] += product; /* swap high and low halves */ #ifdef __s390x__ xacc[i] += vec_permi(data_vec, data_vec, 2); #else xacc[i] += vec_xxpermdi(data_vec, data_vec, 2); #endif } } XXH_FORCE_INLINE void XXH3_scrambleAcc_vsx(void* XXH_RESTRICT acc, const void* XXH_RESTRICT secret) { XXH_ASSERT((((size_t)acc) & 15) == 0); { xxh_u64x2* const xacc = (xxh_u64x2*) acc; const xxh_u64x2* const xsecret = (const xxh_u64x2*) secret; /* constants */ xxh_u64x2 const v32 = { 32, 32 }; xxh_u64x2 const v47 = { 47, 47 }; xxh_u32x4 const prime = { XXH_PRIME32_1, XXH_PRIME32_1, XXH_PRIME32_1, XXH_PRIME32_1 }; size_t i; for (i = 0; i < XXH_STRIPE_LEN / sizeof(xxh_u64x2); i++) { /* xacc[i] ^= (xacc[i] >> 47); */ xxh_u64x2 const acc_vec = xacc[i]; xxh_u64x2 const data_vec = acc_vec ^ (acc_vec >> v47); /* xacc[i] ^= xsecret[i]; */ xxh_u64x2 const key_vec = XXH_vec_loadu(xsecret + i); xxh_u64x2 const data_key = data_vec ^ key_vec; /* xacc[i] *= XXH_PRIME32_1 */ /* prod_lo = ((xxh_u64x2)data_key & 0xFFFFFFFF) * ((xxh_u64x2)prime & 0xFFFFFFFF); */ xxh_u64x2 const prod_even = XXH_vec_mule((xxh_u32x4)data_key, prime); /* prod_hi = ((xxh_u64x2)data_key >> 32) * ((xxh_u64x2)prime >> 32); */ xxh_u64x2 const prod_odd = XXH_vec_mulo((xxh_u32x4)data_key, prime); xacc[i] = prod_odd + (prod_even << v32); } } } #endif /* scalar variants - universal */ XXH_FORCE_INLINE void XXH3_accumulate_512_scalar(void* XXH_RESTRICT acc, const void* XXH_RESTRICT input, const void* XXH_RESTRICT secret) { XXH_ALIGN(XXH_ACC_ALIGN) xxh_u64* const xacc = (xxh_u64*) acc; /* presumed aligned */ const xxh_u8* const xinput = (const xxh_u8*) input; /* no alignment restriction */ const xxh_u8* const xsecret = (const xxh_u8*) secret; /* no alignment restriction */ size_t i; XXH_ASSERT(((size_t)acc & (XXH_ACC_ALIGN-1)) == 0); for (i=0; i < XXH_ACC_NB; i++) { xxh_u64 const data_val = XXH_readLE64(xinput + 8*i); xxh_u64 const data_key = data_val ^ XXH_readLE64(xsecret + i*8); xacc[i ^ 1] += data_val; /* swap adjacent lanes */ xacc[i] += XXH_mult32to64(data_key & 0xFFFFFFFF, data_key >> 32); } } XXH_FORCE_INLINE void XXH3_scrambleAcc_scalar(void* XXH_RESTRICT acc, const void* XXH_RESTRICT secret) { XXH_ALIGN(XXH_ACC_ALIGN) xxh_u64* const xacc = (xxh_u64*) acc; /* presumed aligned */ const xxh_u8* const xsecret = (const xxh_u8*) secret; /* no alignment restriction */ size_t i; XXH_ASSERT((((size_t)acc) & (XXH_ACC_ALIGN-1)) == 0); for (i=0; i < XXH_ACC_NB; i++) { xxh_u64 const key64 = XXH_readLE64(xsecret + 8*i); xxh_u64 acc64 = xacc[i]; acc64 = XXH_xorshift64(acc64, 47); acc64 ^= key64; acc64 *= XXH_PRIME32_1; xacc[i] = acc64; } } XXH_FORCE_INLINE void XXH3_initCustomSecret_scalar(void* XXH_RESTRICT customSecret, xxh_u64 seed64) { /* * We need a separate pointer for the hack below, * which requires a non-const pointer. * Any decent compiler will optimize this out otherwise. */ const xxh_u8* kSecretPtr = XXH3_kSecret; XXH_STATIC_ASSERT((XXH_SECRET_DEFAULT_SIZE & 15) == 0); #if defined(__clang__) && defined(__aarch64__) /* * UGLY HACK: * Clang generates a bunch of MOV/MOVK pairs for aarch64, and they are * placed sequentially, in order, at the top of the unrolled loop. * * While MOVK is great for generating constants (2 cycles for a 64-bit * constant compared to 4 cycles for LDR), long MOVK chains stall the * integer pipelines: * I L S * MOVK * MOVK * MOVK * MOVK * ADD * SUB STR * STR * By forcing loads from memory (as the asm line causes Clang to assume * that XXH3_kSecretPtr has been changed), the pipelines are used more * efficiently: * I L S * LDR * ADD LDR * SUB STR * STR * XXH3_64bits_withSeed, len == 256, Snapdragon 835 * without hack: 2654.4 MB/s * with hack: 3202.9 MB/s */ __asm__("" : "+r" (kSecretPtr)); #endif /* * Note: in debug mode, this overrides the asm optimization * and Clang will emit MOVK chains again. */ XXH_ASSERT(kSecretPtr == XXH3_kSecret); { int const nbRounds = XXH_SECRET_DEFAULT_SIZE / 16; int i; for (i=0; i < nbRounds; i++) { /* * The asm hack causes Clang to assume that kSecretPtr aliases with * customSecret, and on aarch64, this prevented LDP from merging two * loads together for free. Putting the loads together before the stores * properly generates LDP. */ xxh_u64 lo = XXH_readLE64(kSecretPtr + 16*i) + seed64; xxh_u64 hi = XXH_readLE64(kSecretPtr + 16*i + 8) - seed64; XXH_writeLE64((xxh_u8*)customSecret + 16*i, lo); XXH_writeLE64((xxh_u8*)customSecret + 16*i + 8, hi); } } } typedef void (*XXH3_f_accumulate_512)(void* XXH_RESTRICT, const void*, const void*); typedef void (*XXH3_f_scrambleAcc)(void* XXH_RESTRICT, const void*); typedef void (*XXH3_f_initCustomSecret)(void* XXH_RESTRICT, xxh_u64); #if (XXH_VECTOR == XXH_AVX512) #define XXH3_accumulate_512 XXH3_accumulate_512_avx512 #define XXH3_scrambleAcc XXH3_scrambleAcc_avx512 #define XXH3_initCustomSecret XXH3_initCustomSecret_avx512 #elif (XXH_VECTOR == XXH_AVX2) #define XXH3_accumulate_512 XXH3_accumulate_512_avx2 #define XXH3_scrambleAcc XXH3_scrambleAcc_avx2 #define XXH3_initCustomSecret XXH3_initCustomSecret_avx2 #elif (XXH_VECTOR == XXH_SSE2) #define XXH3_accumulate_512 XXH3_accumulate_512_sse2 #define XXH3_scrambleAcc XXH3_scrambleAcc_sse2 #define XXH3_initCustomSecret XXH3_initCustomSecret_sse2 #elif (XXH_VECTOR == XXH_NEON) #define XXH3_accumulate_512 XXH3_accumulate_512_neon #define XXH3_scrambleAcc XXH3_scrambleAcc_neon #define XXH3_initCustomSecret XXH3_initCustomSecret_scalar #elif (XXH_VECTOR == XXH_VSX) #define XXH3_accumulate_512 XXH3_accumulate_512_vsx #define XXH3_scrambleAcc XXH3_scrambleAcc_vsx #define XXH3_initCustomSecret XXH3_initCustomSecret_scalar #else /* scalar */ #define XXH3_accumulate_512 XXH3_accumulate_512_scalar #define XXH3_scrambleAcc XXH3_scrambleAcc_scalar #define XXH3_initCustomSecret XXH3_initCustomSecret_scalar #endif #ifndef XXH_PREFETCH_DIST # ifdef __clang__ # define XXH_PREFETCH_DIST 320 # else # if (XXH_VECTOR == XXH_AVX512) # define XXH_PREFETCH_DIST 512 # else # define XXH_PREFETCH_DIST 384 # endif # endif /* __clang__ */ #endif /* XXH_PREFETCH_DIST */ /* * XXH3_accumulate() * Loops over XXH3_accumulate_512(). * Assumption: nbStripes will not overflow the secret size */ XXH_FORCE_INLINE void XXH3_accumulate( xxh_u64* XXH_RESTRICT acc, const xxh_u8* XXH_RESTRICT input, const xxh_u8* XXH_RESTRICT secret, size_t nbStripes, XXH3_f_accumulate_512 f_acc512) { size_t n; for (n = 0; n < nbStripes; n++ ) { const xxh_u8* const in = input + n*XXH_STRIPE_LEN; XXH_PREFETCH(in + XXH_PREFETCH_DIST); f_acc512(acc, in, secret + n*XXH_SECRET_CONSUME_RATE); } } XXH_FORCE_INLINE void XXH3_hashLong_internal_loop(xxh_u64* XXH_RESTRICT acc, const xxh_u8* XXH_RESTRICT input, size_t len, const xxh_u8* XXH_RESTRICT secret, size_t secretSize, XXH3_f_accumulate_512 f_acc512, XXH3_f_scrambleAcc f_scramble) { size_t const nbStripesPerBlock = (secretSize - XXH_STRIPE_LEN) / XXH_SECRET_CONSUME_RATE; size_t const block_len = XXH_STRIPE_LEN * nbStripesPerBlock; size_t const nb_blocks = (len - 1) / block_len; size_t n; XXH_ASSERT(secretSize >= XXH3_SECRET_SIZE_MIN); for (n = 0; n < nb_blocks; n++) { XXH3_accumulate(acc, input + n*block_len, secret, nbStripesPerBlock, f_acc512); f_scramble(acc, secret + secretSize - XXH_STRIPE_LEN); } /* last partial block */ XXH_ASSERT(len > XXH_STRIPE_LEN); { size_t const nbStripes = ((len - 1) - (block_len * nb_blocks)) / XXH_STRIPE_LEN; XXH_ASSERT(nbStripes <= (secretSize / XXH_SECRET_CONSUME_RATE)); XXH3_accumulate(acc, input + nb_blocks*block_len, secret, nbStripes, f_acc512); /* last stripe */ { const xxh_u8* const p = input + len - XXH_STRIPE_LEN; #define XXH_SECRET_LASTACC_START 7 /* not aligned on 8, last secret is different from acc & scrambler */ f_acc512(acc, p, secret + secretSize - XXH_STRIPE_LEN - XXH_SECRET_LASTACC_START); } } } XXH_FORCE_INLINE xxh_u64 XXH3_mix2Accs(const xxh_u64* XXH_RESTRICT acc, const xxh_u8* XXH_RESTRICT secret) { return XXH3_mul128_fold64( acc[0] ^ XXH_readLE64(secret), acc[1] ^ XXH_readLE64(secret+8) ); } static XXH64_hash_t XXH3_mergeAccs(const xxh_u64* XXH_RESTRICT acc, const xxh_u8* XXH_RESTRICT secret, xxh_u64 start) { xxh_u64 result64 = start; size_t i = 0; for (i = 0; i < 4; i++) { result64 += XXH3_mix2Accs(acc+2*i, secret + 16*i); #if defined(__clang__) /* Clang */ \ && (defined(__arm__) || defined(__thumb__)) /* ARMv7 */ \ && (defined(__ARM_NEON) || defined(__ARM_NEON__)) /* NEON */ \ && !defined(XXH_ENABLE_AUTOVECTORIZE) /* Define to disable */ /* * UGLY HACK: * Prevent autovectorization on Clang ARMv7-a. Exact same problem as * the one in XXH3_len_129to240_64b. Speeds up shorter keys > 240b. * XXH3_64bits, len == 256, Snapdragon 835: * without hack: 2063.7 MB/s * with hack: 2560.7 MB/s */ __asm__("" : "+r" (result64)); #endif } return XXH3_avalanche(result64); } #define XXH3_INIT_ACC { XXH_PRIME32_3, XXH_PRIME64_1, XXH_PRIME64_2, XXH_PRIME64_3, \ XXH_PRIME64_4, XXH_PRIME32_2, XXH_PRIME64_5, XXH_PRIME32_1 } XXH_FORCE_INLINE XXH64_hash_t XXH3_hashLong_64b_internal(const void* XXH_RESTRICT input, size_t len, const void* XXH_RESTRICT secret, size_t secretSize, XXH3_f_accumulate_512 f_acc512, XXH3_f_scrambleAcc f_scramble) { XXH_ALIGN(XXH_ACC_ALIGN) xxh_u64 acc[XXH_ACC_NB] = XXH3_INIT_ACC; XXH3_hashLong_internal_loop(acc, (const xxh_u8*)input, len, (const xxh_u8*)secret, secretSize, f_acc512, f_scramble); /* converge into final hash */ XXH_STATIC_ASSERT(sizeof(acc) == 64); /* do not align on 8, so that the secret is different from the accumulator */ #define XXH_SECRET_MERGEACCS_START 11 XXH_ASSERT(secretSize >= sizeof(acc) + XXH_SECRET_MERGEACCS_START); return XXH3_mergeAccs(acc, (const xxh_u8*)secret + XXH_SECRET_MERGEACCS_START, (xxh_u64)len * XXH_PRIME64_1); } /* * It's important for performance that XXH3_hashLong is not inlined. */ XXH_NO_INLINE XXH64_hash_t XXH3_hashLong_64b_withSecret(const void* XXH_RESTRICT input, size_t len, XXH64_hash_t seed64, const xxh_u8* XXH_RESTRICT secret, size_t secretLen) { (void)seed64; return XXH3_hashLong_64b_internal(input, len, secret, secretLen, XXH3_accumulate_512, XXH3_scrambleAcc); } /* * It's important for performance that XXH3_hashLong is not inlined. * Since the function is not inlined, the compiler may not be able to understand that, * in some scenarios, its `secret` argument is actually a compile time constant. * This variant enforces that the compiler can detect that, * and uses this opportunity to streamline the generated code for better performance. */ XXH_NO_INLINE XXH64_hash_t XXH3_hashLong_64b_default(const void* XXH_RESTRICT input, size_t len, XXH64_hash_t seed64, const xxh_u8* XXH_RESTRICT secret, size_t secretLen) { (void)seed64; (void)secret; (void)secretLen; return XXH3_hashLong_64b_internal(input, len, XXH3_kSecret, sizeof(XXH3_kSecret), XXH3_accumulate_512, XXH3_scrambleAcc); } /* * XXH3_hashLong_64b_withSeed(): * Generate a custom key based on alteration of default XXH3_kSecret with the seed, * and then use this key for long mode hashing. * * This operation is decently fast but nonetheless costs a little bit of time. * Try to avoid it whenever possible (typically when seed==0). * * It's important for performance that XXH3_hashLong is not inlined. Not sure * why (uop cache maybe?), but the difference is large and easily measurable. */ XXH_FORCE_INLINE XXH64_hash_t XXH3_hashLong_64b_withSeed_internal(const void* input, size_t len, XXH64_hash_t seed, XXH3_f_accumulate_512 f_acc512, XXH3_f_scrambleAcc f_scramble, XXH3_f_initCustomSecret f_initSec) { if (seed == 0) return XXH3_hashLong_64b_internal(input, len, XXH3_kSecret, sizeof(XXH3_kSecret), f_acc512, f_scramble); { XXH_ALIGN(XXH_SEC_ALIGN) xxh_u8 secret[XXH_SECRET_DEFAULT_SIZE]; f_initSec(secret, seed); return XXH3_hashLong_64b_internal(input, len, secret, sizeof(secret), f_acc512, f_scramble); } } /* * It's important for performance that XXH3_hashLong is not inlined. */ XXH_NO_INLINE XXH64_hash_t XXH3_hashLong_64b_withSeed(const void* input, size_t len, XXH64_hash_t seed, const xxh_u8* secret, size_t secretLen) { (void)secret; (void)secretLen; return XXH3_hashLong_64b_withSeed_internal(input, len, seed, XXH3_accumulate_512, XXH3_scrambleAcc, XXH3_initCustomSecret); } typedef XXH64_hash_t (*XXH3_hashLong64_f)(const void* XXH_RESTRICT, size_t, XXH64_hash_t, const xxh_u8* XXH_RESTRICT, size_t); XXH_FORCE_INLINE XXH64_hash_t XXH3_64bits_internal(const void* XXH_RESTRICT input, size_t len, XXH64_hash_t seed64, const void* XXH_RESTRICT secret, size_t secretLen, XXH3_hashLong64_f f_hashLong) { XXH_ASSERT(secretLen >= XXH3_SECRET_SIZE_MIN); /* * If an action is to be taken if `secretLen` condition is not respected, * it should be done here. * For now, it's a contract pre-condition. * Adding a check and a branch here would cost performance at every hash. * Also, note that function signature doesn't offer room to return an error. */ if (len <= 16) return XXH3_len_0to16_64b((const xxh_u8*)input, len, (const xxh_u8*)secret, seed64); if (len <= 128) return XXH3_len_17to128_64b((const xxh_u8*)input, len, (const xxh_u8*)secret, secretLen, seed64); if (len <= XXH3_MIDSIZE_MAX) return XXH3_len_129to240_64b((const xxh_u8*)input, len, (const xxh_u8*)secret, secretLen, seed64); return f_hashLong(input, len, seed64, (const xxh_u8*)secret, secretLen); } /* === Public entry point === */ XXH_PUBLIC_API XXH64_hash_t XXH3_64bits(const void* input, size_t len) { return XXH3_64bits_internal(input, len, 0, XXH3_kSecret, sizeof(XXH3_kSecret), XXH3_hashLong_64b_default); } XXH_PUBLIC_API XXH64_hash_t XXH3_64bits_withSecret(const void* input, size_t len, const void* secret, size_t secretSize) { return XXH3_64bits_internal(input, len, 0, secret, secretSize, XXH3_hashLong_64b_withSecret); } XXH_PUBLIC_API XXH64_hash_t XXH3_64bits_withSeed(const void* input, size_t len, XXH64_hash_t seed) { return XXH3_64bits_internal(input, len, seed, XXH3_kSecret, sizeof(XXH3_kSecret), XXH3_hashLong_64b_withSeed); } /* === XXH3 streaming === */ /* * Malloc's a pointer that is always aligned to align. * * This must be freed with `XXH_alignedFree()`. * * malloc typically guarantees 16 byte alignment on 64-bit systems and 8 byte * alignment on 32-bit. This isn't enough for the 32 byte aligned loads in AVX2 * or on 32-bit, the 16 byte aligned loads in SSE2 and NEON. * * This underalignment previously caused a rather obvious crash which went * completely unnoticed due to XXH3_createState() not actually being tested. * Credit to RedSpah for noticing this bug. * * The alignment is done manually: Functions like posix_memalign or _mm_malloc * are avoided: To maintain portability, we would have to write a fallback * like this anyways, and besides, testing for the existence of library * functions without relying on external build tools is impossible. * * The method is simple: Overallocate, manually align, and store the offset * to the original behind the returned pointer. * * Align must be a power of 2 and 8 <= align <= 128. */ static void* XXH_alignedMalloc(size_t s, size_t align) { XXH_ASSERT(align <= 128 && align >= 8); /* range check */ XXH_ASSERT((align & (align-1)) == 0); /* power of 2 */ XXH_ASSERT(s != 0 && s < (s + align)); /* empty/overflow */ { /* Overallocate to make room for manual realignment and an offset byte */ xxh_u8* base = (xxh_u8*)XXH_malloc(s + align); if (base != NULL) { /* * Get the offset needed to align this pointer. * * Even if the returned pointer is aligned, there will always be * at least one byte to store the offset to the original pointer. */ size_t offset = align - ((size_t)base & (align - 1)); /* base % align */ /* Add the offset for the now-aligned pointer */ xxh_u8* ptr = base + offset; XXH_ASSERT((size_t)ptr % align == 0); /* Store the offset immediately before the returned pointer. */ ptr[-1] = (xxh_u8)offset; return ptr; } return NULL; } } /* * Frees an aligned pointer allocated by XXH_alignedMalloc(). Don't pass * normal malloc'd pointers, XXH_alignedMalloc has a specific data layout. */ static void XXH_alignedFree(void* p) { if (p != NULL) { xxh_u8* ptr = (xxh_u8*)p; /* Get the offset byte we added in XXH_malloc. */ xxh_u8 offset = ptr[-1]; /* Free the original malloc'd pointer */ xxh_u8* base = ptr - offset; XXH_free(base); } } XXH_PUBLIC_API XXH3_state_t* XXH3_createState(void) { XXH3_state_t* const state = (XXH3_state_t*)XXH_alignedMalloc(sizeof(XXH3_state_t), 64); if (state==NULL) return NULL; XXH3_INITSTATE(state); return state; } XXH_PUBLIC_API XXH_errorcode XXH3_freeState(XXH3_state_t* statePtr) { XXH_alignedFree(statePtr); return XXH_OK; } XXH_PUBLIC_API void XXH3_copyState(XXH3_state_t* dst_state, const XXH3_state_t* src_state) { memcpy(dst_state, src_state, sizeof(*dst_state)); } static void XXH3_64bits_reset_internal(XXH3_state_t* statePtr, XXH64_hash_t seed, const void* secret, size_t secretSize) { size_t const initStart = offsetof(XXH3_state_t, bufferedSize); size_t const initLength = offsetof(XXH3_state_t, nbStripesPerBlock) - initStart; XXH_ASSERT(offsetof(XXH3_state_t, nbStripesPerBlock) > initStart); XXH_ASSERT(statePtr != NULL); /* set members from bufferedSize to nbStripesPerBlock (excluded) to 0 */ memset((char*)statePtr + initStart, 0, initLength); statePtr->acc[0] = XXH_PRIME32_3; statePtr->acc[1] = XXH_PRIME64_1; statePtr->acc[2] = XXH_PRIME64_2; statePtr->acc[3] = XXH_PRIME64_3; statePtr->acc[4] = XXH_PRIME64_4; statePtr->acc[5] = XXH_PRIME32_2; statePtr->acc[6] = XXH_PRIME64_5; statePtr->acc[7] = XXH_PRIME32_1; statePtr->seed = seed; statePtr->extSecret = (const unsigned char*)secret; XXH_ASSERT(secretSize >= XXH3_SECRET_SIZE_MIN); statePtr->secretLimit = secretSize - XXH_STRIPE_LEN; statePtr->nbStripesPerBlock = statePtr->secretLimit / XXH_SECRET_CONSUME_RATE; } XXH_PUBLIC_API XXH_errorcode XXH3_64bits_reset(XXH3_state_t* statePtr) { if (statePtr == NULL) return XXH_ERROR; XXH3_64bits_reset_internal(statePtr, 0, XXH3_kSecret, XXH_SECRET_DEFAULT_SIZE); return XXH_OK; } XXH_PUBLIC_API XXH_errorcode XXH3_64bits_reset_withSecret(XXH3_state_t* statePtr, const void* secret, size_t secretSize) { if (statePtr == NULL) return XXH_ERROR; XXH3_64bits_reset_internal(statePtr, 0, secret, secretSize); if (secret == NULL) return XXH_ERROR; if (secretSize < XXH3_SECRET_SIZE_MIN) return XXH_ERROR; return XXH_OK; } XXH_PUBLIC_API XXH_errorcode XXH3_64bits_reset_withSeed(XXH3_state_t* statePtr, XXH64_hash_t seed) { if (statePtr == NULL) return XXH_ERROR; if (seed==0) return XXH3_64bits_reset(statePtr); if (seed != statePtr->seed) XXH3_initCustomSecret(statePtr->customSecret, seed); XXH3_64bits_reset_internal(statePtr, seed, NULL, XXH_SECRET_DEFAULT_SIZE); return XXH_OK; } /* Note : when XXH3_consumeStripes() is invoked, * there must be a guarantee that at least one more byte must be consumed from input * so that the function can blindly consume all stripes using the "normal" secret segment */ XXH_FORCE_INLINE void XXH3_consumeStripes(xxh_u64* XXH_RESTRICT acc, size_t* XXH_RESTRICT nbStripesSoFarPtr, size_t nbStripesPerBlock, const xxh_u8* XXH_RESTRICT input, size_t nbStripes, const xxh_u8* XXH_RESTRICT secret, size_t secretLimit, XXH3_f_accumulate_512 f_acc512, XXH3_f_scrambleAcc f_scramble) { XXH_ASSERT(nbStripes <= nbStripesPerBlock); /* can handle max 1 scramble per invocation */ XXH_ASSERT(*nbStripesSoFarPtr < nbStripesPerBlock); if (nbStripesPerBlock - *nbStripesSoFarPtr <= nbStripes) { /* need a scrambling operation */ size_t const nbStripesToEndofBlock = nbStripesPerBlock - *nbStripesSoFarPtr; size_t const nbStripesAfterBlock = nbStripes - nbStripesToEndofBlock; XXH3_accumulate(acc, input, secret + nbStripesSoFarPtr[0] * XXH_SECRET_CONSUME_RATE, nbStripesToEndofBlock, f_acc512); f_scramble(acc, secret + secretLimit); XXH3_accumulate(acc, input + nbStripesToEndofBlock * XXH_STRIPE_LEN, secret, nbStripesAfterBlock, f_acc512); *nbStripesSoFarPtr = nbStripesAfterBlock; } else { XXH3_accumulate(acc, input, secret + nbStripesSoFarPtr[0] * XXH_SECRET_CONSUME_RATE, nbStripes, f_acc512); *nbStripesSoFarPtr += nbStripes; } } /* * Both XXH3_64bits_update and XXH3_128bits_update use this routine. */ XXH_FORCE_INLINE XXH_errorcode XXH3_update(XXH3_state_t* state, const xxh_u8* input, size_t len, XXH3_f_accumulate_512 f_acc512, XXH3_f_scrambleAcc f_scramble) { if (input==NULL) #if defined(XXH_ACCEPT_NULL_INPUT_POINTER) && (XXH_ACCEPT_NULL_INPUT_POINTER>=1) return XXH_OK; #else return XXH_ERROR; #endif { const xxh_u8* const bEnd = input + len; const unsigned char* const secret = (state->extSecret == NULL) ? state->customSecret : state->extSecret; state->totalLen += len; if (state->bufferedSize + len <= XXH3_INTERNALBUFFER_SIZE) { /* fill in tmp buffer */ XXH_memcpy(state->buffer + state->bufferedSize, input, len); state->bufferedSize += (XXH32_hash_t)len; return XXH_OK; } /* total input is now > XXH3_INTERNALBUFFER_SIZE */ #define XXH3_INTERNALBUFFER_STRIPES (XXH3_INTERNALBUFFER_SIZE / XXH_STRIPE_LEN) XXH_STATIC_ASSERT(XXH3_INTERNALBUFFER_SIZE % XXH_STRIPE_LEN == 0); /* clean multiple */ /* * Internal buffer is partially filled (always, except at beginning) * Complete it, then consume it. */ if (state->bufferedSize) { size_t const loadSize = XXH3_INTERNALBUFFER_SIZE - state->bufferedSize; XXH_memcpy(state->buffer + state->bufferedSize, input, loadSize); input += loadSize; XXH3_consumeStripes(state->acc, &state->nbStripesSoFar, state->nbStripesPerBlock, state->buffer, XXH3_INTERNALBUFFER_STRIPES, secret, state->secretLimit, f_acc512, f_scramble); state->bufferedSize = 0; } XXH_ASSERT(input < bEnd); /* Consume input by a multiple of internal buffer size */ if (input+XXH3_INTERNALBUFFER_SIZE < bEnd) { const xxh_u8* const limit = bEnd - XXH3_INTERNALBUFFER_SIZE; do { XXH3_consumeStripes(state->acc, &state->nbStripesSoFar, state->nbStripesPerBlock, input, XXH3_INTERNALBUFFER_STRIPES, secret, state->secretLimit, f_acc512, f_scramble); input += XXH3_INTERNALBUFFER_SIZE; } while (inputbuffer + sizeof(state->buffer) - XXH_STRIPE_LEN, input - XXH_STRIPE_LEN, XXH_STRIPE_LEN); } XXH_ASSERT(input < bEnd); /* Some remaining input (always) : buffer it */ XXH_memcpy(state->buffer, input, (size_t)(bEnd-input)); state->bufferedSize = (XXH32_hash_t)(bEnd-input); } return XXH_OK; } XXH_PUBLIC_API XXH_errorcode XXH3_64bits_update(XXH3_state_t* state, const void* input, size_t len) { return XXH3_update(state, (const xxh_u8*)input, len, XXH3_accumulate_512, XXH3_scrambleAcc); } XXH_FORCE_INLINE void XXH3_digest_long (XXH64_hash_t* acc, const XXH3_state_t* state, const unsigned char* secret) { /* * Digest on a local copy. This way, the state remains unaltered, and it can * continue ingesting more input afterwards. */ memcpy(acc, state->acc, sizeof(state->acc)); if (state->bufferedSize >= XXH_STRIPE_LEN) { size_t const nbStripes = (state->bufferedSize - 1) / XXH_STRIPE_LEN; size_t nbStripesSoFar = state->nbStripesSoFar; XXH3_consumeStripes(acc, &nbStripesSoFar, state->nbStripesPerBlock, state->buffer, nbStripes, secret, state->secretLimit, XXH3_accumulate_512, XXH3_scrambleAcc); /* last stripe */ XXH3_accumulate_512(acc, state->buffer + state->bufferedSize - XXH_STRIPE_LEN, secret + state->secretLimit - XXH_SECRET_LASTACC_START); } else { /* bufferedSize < XXH_STRIPE_LEN */ xxh_u8 lastStripe[XXH_STRIPE_LEN]; size_t const catchupSize = XXH_STRIPE_LEN - state->bufferedSize; XXH_ASSERT(state->bufferedSize > 0); /* there is always some input buffered */ memcpy(lastStripe, state->buffer + sizeof(state->buffer) - catchupSize, catchupSize); memcpy(lastStripe + catchupSize, state->buffer, state->bufferedSize); XXH3_accumulate_512(acc, lastStripe, secret + state->secretLimit - XXH_SECRET_LASTACC_START); } } XXH_PUBLIC_API XXH64_hash_t XXH3_64bits_digest (const XXH3_state_t* state) { const unsigned char* const secret = (state->extSecret == NULL) ? state->customSecret : state->extSecret; if (state->totalLen > XXH3_MIDSIZE_MAX) { XXH_ALIGN(XXH_ACC_ALIGN) XXH64_hash_t acc[XXH_ACC_NB]; XXH3_digest_long(acc, state, secret); return XXH3_mergeAccs(acc, secret + XXH_SECRET_MERGEACCS_START, (xxh_u64)state->totalLen * XXH_PRIME64_1); } /* totalLen <= XXH3_MIDSIZE_MAX: digesting a short input */ if (state->seed) return XXH3_64bits_withSeed(state->buffer, (size_t)state->totalLen, state->seed); return XXH3_64bits_withSecret(state->buffer, (size_t)(state->totalLen), secret, state->secretLimit + XXH_STRIPE_LEN); } #define XXH_MIN(x, y) (((x) > (y)) ? (y) : (x)) XXH_PUBLIC_API void XXH3_generateSecret(void* secretBuffer, const void* customSeed, size_t customSeedSize) { XXH_ASSERT(secretBuffer != NULL); if (customSeedSize == 0) { memcpy(secretBuffer, XXH3_kSecret, XXH_SECRET_DEFAULT_SIZE); return; } XXH_ASSERT(customSeed != NULL); { size_t const segmentSize = sizeof(XXH128_hash_t); size_t const nbSegments = XXH_SECRET_DEFAULT_SIZE / segmentSize; XXH128_canonical_t scrambler; XXH64_hash_t seeds[12]; size_t segnb; XXH_ASSERT(nbSegments == 12); XXH_ASSERT(segmentSize * nbSegments == XXH_SECRET_DEFAULT_SIZE); /* exact multiple */ XXH128_canonicalFromHash(&scrambler, XXH128(customSeed, customSeedSize, 0)); /* * Copy customSeed to seeds[], truncating or repeating as necessary. */ { size_t toFill = XXH_MIN(customSeedSize, sizeof(seeds)); size_t filled = toFill; memcpy(seeds, customSeed, toFill); while (filled < sizeof(seeds)) { toFill = XXH_MIN(filled, sizeof(seeds) - filled); memcpy((char*)seeds + filled, seeds, toFill); filled += toFill; } } /* generate secret */ memcpy(secretBuffer, &scrambler, sizeof(scrambler)); for (segnb=1; segnb < nbSegments; segnb++) { size_t const segmentStart = segnb * segmentSize; XXH128_canonical_t segment; XXH128_canonicalFromHash(&segment, XXH128(&scrambler, sizeof(scrambler), XXH_readLE64(seeds + segnb) + segnb) ); memcpy((char*)secretBuffer + segmentStart, &segment, sizeof(segment)); } } } /* ========================================== * XXH3 128 bits (a.k.a XXH128) * ========================================== * XXH3's 128-bit variant has better mixing and strength than the 64-bit variant, * even without counting the significantly larger output size. * * For example, extra steps are taken to avoid the seed-dependent collisions * in 17-240 byte inputs (See XXH3_mix16B and XXH128_mix32B). * * This strength naturally comes at the cost of some speed, especially on short * lengths. Note that longer hashes are about as fast as the 64-bit version * due to it using only a slight modification of the 64-bit loop. * * XXH128 is also more oriented towards 64-bit machines. It is still extremely * fast for a _128-bit_ hash on 32-bit (it usually clears XXH64). */ XXH_FORCE_INLINE XXH128_hash_t XXH3_len_1to3_128b(const xxh_u8* input, size_t len, const xxh_u8* secret, XXH64_hash_t seed) { /* A doubled version of 1to3_64b with different constants. */ XXH_ASSERT(input != NULL); XXH_ASSERT(1 <= len && len <= 3); XXH_ASSERT(secret != NULL); /* * len = 1: combinedl = { input[0], 0x01, input[0], input[0] } * len = 2: combinedl = { input[1], 0x02, input[0], input[1] } * len = 3: combinedl = { input[2], 0x03, input[0], input[1] } */ { xxh_u8 const c1 = input[0]; xxh_u8 const c2 = input[len >> 1]; xxh_u8 const c3 = input[len - 1]; xxh_u32 const combinedl = ((xxh_u32)c1 <<16) | ((xxh_u32)c2 << 24) | ((xxh_u32)c3 << 0) | ((xxh_u32)len << 8); xxh_u32 const combinedh = XXH_rotl32(XXH_swap32(combinedl), 13); xxh_u64 const bitflipl = (XXH_readLE32(secret) ^ XXH_readLE32(secret+4)) + seed; xxh_u64 const bitfliph = (XXH_readLE32(secret+8) ^ XXH_readLE32(secret+12)) - seed; xxh_u64 const keyed_lo = (xxh_u64)combinedl ^ bitflipl; xxh_u64 const keyed_hi = (xxh_u64)combinedh ^ bitfliph; XXH128_hash_t h128; h128.low64 = XXH64_avalanche(keyed_lo); h128.high64 = XXH64_avalanche(keyed_hi); return h128; } } XXH_FORCE_INLINE XXH128_hash_t XXH3_len_4to8_128b(const xxh_u8* input, size_t len, const xxh_u8* secret, XXH64_hash_t seed) { XXH_ASSERT(input != NULL); XXH_ASSERT(secret != NULL); XXH_ASSERT(4 <= len && len <= 8); seed ^= (xxh_u64)XXH_swap32((xxh_u32)seed) << 32; { xxh_u32 const input_lo = XXH_readLE32(input); xxh_u32 const input_hi = XXH_readLE32(input + len - 4); xxh_u64 const input_64 = input_lo + ((xxh_u64)input_hi << 32); xxh_u64 const bitflip = (XXH_readLE64(secret+16) ^ XXH_readLE64(secret+24)) + seed; xxh_u64 const keyed = input_64 ^ bitflip; /* Shift len to the left to ensure it is even, this avoids even multiplies. */ XXH128_hash_t m128 = XXH_mult64to128(keyed, XXH_PRIME64_1 + (len << 2)); m128.high64 += (m128.low64 << 1); m128.low64 ^= (m128.high64 >> 3); m128.low64 = XXH_xorshift64(m128.low64, 35); m128.low64 *= 0x9FB21C651E98DF25ULL; m128.low64 = XXH_xorshift64(m128.low64, 28); m128.high64 = XXH3_avalanche(m128.high64); return m128; } } XXH_FORCE_INLINE XXH128_hash_t XXH3_len_9to16_128b(const xxh_u8* input, size_t len, const xxh_u8* secret, XXH64_hash_t seed) { XXH_ASSERT(input != NULL); XXH_ASSERT(secret != NULL); XXH_ASSERT(9 <= len && len <= 16); { xxh_u64 const bitflipl = (XXH_readLE64(secret+32) ^ XXH_readLE64(secret+40)) - seed; xxh_u64 const bitfliph = (XXH_readLE64(secret+48) ^ XXH_readLE64(secret+56)) + seed; xxh_u64 const input_lo = XXH_readLE64(input); xxh_u64 input_hi = XXH_readLE64(input + len - 8); XXH128_hash_t m128 = XXH_mult64to128(input_lo ^ input_hi ^ bitflipl, XXH_PRIME64_1); /* * Put len in the middle of m128 to ensure that the length gets mixed to * both the low and high bits in the 128x64 multiply below. */ m128.low64 += (xxh_u64)(len - 1) << 54; input_hi ^= bitfliph; /* * Add the high 32 bits of input_hi to the high 32 bits of m128, then * add the long product of the low 32 bits of input_hi and XXH_PRIME32_2 to * the high 64 bits of m128. * * The best approach to this operation is different on 32-bit and 64-bit. */ if (sizeof(void *) < sizeof(xxh_u64)) { /* 32-bit */ /* * 32-bit optimized version, which is more readable. * * On 32-bit, it removes an ADC and delays a dependency between the two * halves of m128.high64, but it generates an extra mask on 64-bit. */ m128.high64 += (input_hi & 0xFFFFFFFF00000000ULL) + XXH_mult32to64((xxh_u32)input_hi, XXH_PRIME32_2); } else { /* * 64-bit optimized (albeit more confusing) version. * * Uses some properties of addition and multiplication to remove the mask: * * Let: * a = input_hi.lo = (input_hi & 0x00000000FFFFFFFF) * b = input_hi.hi = (input_hi & 0xFFFFFFFF00000000) * c = XXH_PRIME32_2 * * a + (b * c) * Inverse Property: x + y - x == y * a + (b * (1 + c - 1)) * Distributive Property: x * (y + z) == (x * y) + (x * z) * a + (b * 1) + (b * (c - 1)) * Identity Property: x * 1 == x * a + b + (b * (c - 1)) * * Substitute a, b, and c: * input_hi.hi + input_hi.lo + ((xxh_u64)input_hi.lo * (XXH_PRIME32_2 - 1)) * * Since input_hi.hi + input_hi.lo == input_hi, we get this: * input_hi + ((xxh_u64)input_hi.lo * (XXH_PRIME32_2 - 1)) */ m128.high64 += input_hi + XXH_mult32to64((xxh_u32)input_hi, XXH_PRIME32_2 - 1); } /* m128 ^= XXH_swap64(m128 >> 64); */ m128.low64 ^= XXH_swap64(m128.high64); { /* 128x64 multiply: h128 = m128 * XXH_PRIME64_2; */ XXH128_hash_t h128 = XXH_mult64to128(m128.low64, XXH_PRIME64_2); h128.high64 += m128.high64 * XXH_PRIME64_2; h128.low64 = XXH3_avalanche(h128.low64); h128.high64 = XXH3_avalanche(h128.high64); return h128; } } } /* * Assumption: `secret` size is >= XXH3_SECRET_SIZE_MIN */ XXH_FORCE_INLINE XXH128_hash_t XXH3_len_0to16_128b(const xxh_u8* input, size_t len, const xxh_u8* secret, XXH64_hash_t seed) { XXH_ASSERT(len <= 16); { if (len > 8) return XXH3_len_9to16_128b(input, len, secret, seed); if (len >= 4) return XXH3_len_4to8_128b(input, len, secret, seed); if (len) return XXH3_len_1to3_128b(input, len, secret, seed); { XXH128_hash_t h128; xxh_u64 const bitflipl = XXH_readLE64(secret+64) ^ XXH_readLE64(secret+72); xxh_u64 const bitfliph = XXH_readLE64(secret+80) ^ XXH_readLE64(secret+88); h128.low64 = XXH64_avalanche(seed ^ bitflipl); h128.high64 = XXH64_avalanche( seed ^ bitfliph); return h128; } } } /* * A bit slower than XXH3_mix16B, but handles multiply by zero better. */ XXH_FORCE_INLINE XXH128_hash_t XXH128_mix32B(XXH128_hash_t acc, const xxh_u8* input_1, const xxh_u8* input_2, const xxh_u8* secret, XXH64_hash_t seed) { acc.low64 += XXH3_mix16B (input_1, secret+0, seed); acc.low64 ^= XXH_readLE64(input_2) + XXH_readLE64(input_2 + 8); acc.high64 += XXH3_mix16B (input_2, secret+16, seed); acc.high64 ^= XXH_readLE64(input_1) + XXH_readLE64(input_1 + 8); return acc; } XXH_FORCE_INLINE XXH128_hash_t XXH3_len_17to128_128b(const xxh_u8* XXH_RESTRICT input, size_t len, const xxh_u8* XXH_RESTRICT secret, size_t secretSize, XXH64_hash_t seed) { XXH_ASSERT(secretSize >= XXH3_SECRET_SIZE_MIN); (void)secretSize; XXH_ASSERT(16 < len && len <= 128); { XXH128_hash_t acc; acc.low64 = len * XXH_PRIME64_1; acc.high64 = 0; if (len > 32) { if (len > 64) { if (len > 96) { acc = XXH128_mix32B(acc, input+48, input+len-64, secret+96, seed); } acc = XXH128_mix32B(acc, input+32, input+len-48, secret+64, seed); } acc = XXH128_mix32B(acc, input+16, input+len-32, secret+32, seed); } acc = XXH128_mix32B(acc, input, input+len-16, secret, seed); { XXH128_hash_t h128; h128.low64 = acc.low64 + acc.high64; h128.high64 = (acc.low64 * XXH_PRIME64_1) + (acc.high64 * XXH_PRIME64_4) + ((len - seed) * XXH_PRIME64_2); h128.low64 = XXH3_avalanche(h128.low64); h128.high64 = (XXH64_hash_t)0 - XXH3_avalanche(h128.high64); return h128; } } } XXH_NO_INLINE XXH128_hash_t XXH3_len_129to240_128b(const xxh_u8* XXH_RESTRICT input, size_t len, const xxh_u8* XXH_RESTRICT secret, size_t secretSize, XXH64_hash_t seed) { XXH_ASSERT(secretSize >= XXH3_SECRET_SIZE_MIN); (void)secretSize; XXH_ASSERT(128 < len && len <= XXH3_MIDSIZE_MAX); { XXH128_hash_t acc; int const nbRounds = (int)len / 32; int i; acc.low64 = len * XXH_PRIME64_1; acc.high64 = 0; for (i=0; i<4; i++) { acc = XXH128_mix32B(acc, input + (32 * i), input + (32 * i) + 16, secret + (32 * i), seed); } acc.low64 = XXH3_avalanche(acc.low64); acc.high64 = XXH3_avalanche(acc.high64); XXH_ASSERT(nbRounds >= 4); for (i=4 ; i < nbRounds; i++) { acc = XXH128_mix32B(acc, input + (32 * i), input + (32 * i) + 16, secret + XXH3_MIDSIZE_STARTOFFSET + (32 * (i - 4)), seed); } /* last bytes */ acc = XXH128_mix32B(acc, input + len - 16, input + len - 32, secret + XXH3_SECRET_SIZE_MIN - XXH3_MIDSIZE_LASTOFFSET - 16, 0ULL - seed); { XXH128_hash_t h128; h128.low64 = acc.low64 + acc.high64; h128.high64 = (acc.low64 * XXH_PRIME64_1) + (acc.high64 * XXH_PRIME64_4) + ((len - seed) * XXH_PRIME64_2); h128.low64 = XXH3_avalanche(h128.low64); h128.high64 = (XXH64_hash_t)0 - XXH3_avalanche(h128.high64); return h128; } } } XXH_FORCE_INLINE XXH128_hash_t XXH3_hashLong_128b_internal(const void* XXH_RESTRICT input, size_t len, const xxh_u8* XXH_RESTRICT secret, size_t secretSize, XXH3_f_accumulate_512 f_acc512, XXH3_f_scrambleAcc f_scramble) { XXH_ALIGN(XXH_ACC_ALIGN) xxh_u64 acc[XXH_ACC_NB] = XXH3_INIT_ACC; XXH3_hashLong_internal_loop(acc, (const xxh_u8*)input, len, secret, secretSize, f_acc512, f_scramble); /* converge into final hash */ XXH_STATIC_ASSERT(sizeof(acc) == 64); XXH_ASSERT(secretSize >= sizeof(acc) + XXH_SECRET_MERGEACCS_START); { XXH128_hash_t h128; h128.low64 = XXH3_mergeAccs(acc, secret + XXH_SECRET_MERGEACCS_START, (xxh_u64)len * XXH_PRIME64_1); h128.high64 = XXH3_mergeAccs(acc, secret + secretSize - sizeof(acc) - XXH_SECRET_MERGEACCS_START, ~((xxh_u64)len * XXH_PRIME64_2)); return h128; } } /* * It's important for performance that XXH3_hashLong is not inlined. */ XXH_NO_INLINE XXH128_hash_t XXH3_hashLong_128b_default(const void* XXH_RESTRICT input, size_t len, XXH64_hash_t seed64, const void* XXH_RESTRICT secret, size_t secretLen) { (void)seed64; (void)secret; (void)secretLen; return XXH3_hashLong_128b_internal(input, len, XXH3_kSecret, sizeof(XXH3_kSecret), XXH3_accumulate_512, XXH3_scrambleAcc); } /* * It's important for performance that XXH3_hashLong is not inlined. */ XXH_NO_INLINE XXH128_hash_t XXH3_hashLong_128b_withSecret(const void* XXH_RESTRICT input, size_t len, XXH64_hash_t seed64, const void* XXH_RESTRICT secret, size_t secretLen) { (void)seed64; return XXH3_hashLong_128b_internal(input, len, (const xxh_u8*)secret, secretLen, XXH3_accumulate_512, XXH3_scrambleAcc); } XXH_FORCE_INLINE XXH128_hash_t XXH3_hashLong_128b_withSeed_internal(const void* XXH_RESTRICT input, size_t len, XXH64_hash_t seed64, XXH3_f_accumulate_512 f_acc512, XXH3_f_scrambleAcc f_scramble, XXH3_f_initCustomSecret f_initSec) { if (seed64 == 0) return XXH3_hashLong_128b_internal(input, len, XXH3_kSecret, sizeof(XXH3_kSecret), f_acc512, f_scramble); { XXH_ALIGN(XXH_SEC_ALIGN) xxh_u8 secret[XXH_SECRET_DEFAULT_SIZE]; f_initSec(secret, seed64); return XXH3_hashLong_128b_internal(input, len, (const xxh_u8*)secret, sizeof(secret), f_acc512, f_scramble); } } /* * It's important for performance that XXH3_hashLong is not inlined. */ XXH_NO_INLINE XXH128_hash_t XXH3_hashLong_128b_withSeed(const void* input, size_t len, XXH64_hash_t seed64, const void* XXH_RESTRICT secret, size_t secretLen) { (void)secret; (void)secretLen; return XXH3_hashLong_128b_withSeed_internal(input, len, seed64, XXH3_accumulate_512, XXH3_scrambleAcc, XXH3_initCustomSecret); } typedef XXH128_hash_t (*XXH3_hashLong128_f)(const void* XXH_RESTRICT, size_t, XXH64_hash_t, const void* XXH_RESTRICT, size_t); XXH_FORCE_INLINE XXH128_hash_t XXH3_128bits_internal(const void* input, size_t len, XXH64_hash_t seed64, const void* XXH_RESTRICT secret, size_t secretLen, XXH3_hashLong128_f f_hl128) { XXH_ASSERT(secretLen >= XXH3_SECRET_SIZE_MIN); /* * If an action is to be taken if `secret` conditions are not respected, * it should be done here. * For now, it's a contract pre-condition. * Adding a check and a branch here would cost performance at every hash. */ if (len <= 16) return XXH3_len_0to16_128b((const xxh_u8*)input, len, (const xxh_u8*)secret, seed64); if (len <= 128) return XXH3_len_17to128_128b((const xxh_u8*)input, len, (const xxh_u8*)secret, secretLen, seed64); if (len <= XXH3_MIDSIZE_MAX) return XXH3_len_129to240_128b((const xxh_u8*)input, len, (const xxh_u8*)secret, secretLen, seed64); return f_hl128(input, len, seed64, secret, secretLen); } /* === Public XXH128 API === */ XXH_PUBLIC_API XXH128_hash_t XXH3_128bits(const void* input, size_t len) { return XXH3_128bits_internal(input, len, 0, XXH3_kSecret, sizeof(XXH3_kSecret), XXH3_hashLong_128b_default); } XXH_PUBLIC_API XXH128_hash_t XXH3_128bits_withSecret(const void* input, size_t len, const void* secret, size_t secretSize) { return XXH3_128bits_internal(input, len, 0, (const xxh_u8*)secret, secretSize, XXH3_hashLong_128b_withSecret); } XXH_PUBLIC_API XXH128_hash_t XXH3_128bits_withSeed(const void* input, size_t len, XXH64_hash_t seed) { return XXH3_128bits_internal(input, len, seed, XXH3_kSecret, sizeof(XXH3_kSecret), XXH3_hashLong_128b_withSeed); } XXH_PUBLIC_API XXH128_hash_t XXH128(const void* input, size_t len, XXH64_hash_t seed) { return XXH3_128bits_withSeed(input, len, seed); } /* === XXH3 128-bit streaming === */ /* * All the functions are actually the same as for 64-bit streaming variant. * The only difference is the finalizatiom routine. */ static void XXH3_128bits_reset_internal(XXH3_state_t* statePtr, XXH64_hash_t seed, const void* secret, size_t secretSize) { XXH3_64bits_reset_internal(statePtr, seed, secret, secretSize); } XXH_PUBLIC_API XXH_errorcode XXH3_128bits_reset(XXH3_state_t* statePtr) { if (statePtr == NULL) return XXH_ERROR; XXH3_128bits_reset_internal(statePtr, 0, XXH3_kSecret, XXH_SECRET_DEFAULT_SIZE); return XXH_OK; } XXH_PUBLIC_API XXH_errorcode XXH3_128bits_reset_withSecret(XXH3_state_t* statePtr, const void* secret, size_t secretSize) { if (statePtr == NULL) return XXH_ERROR; XXH3_128bits_reset_internal(statePtr, 0, secret, secretSize); if (secret == NULL) return XXH_ERROR; if (secretSize < XXH3_SECRET_SIZE_MIN) return XXH_ERROR; return XXH_OK; } XXH_PUBLIC_API XXH_errorcode XXH3_128bits_reset_withSeed(XXH3_state_t* statePtr, XXH64_hash_t seed) { if (statePtr == NULL) return XXH_ERROR; if (seed==0) return XXH3_128bits_reset(statePtr); if (seed != statePtr->seed) XXH3_initCustomSecret(statePtr->customSecret, seed); XXH3_128bits_reset_internal(statePtr, seed, NULL, XXH_SECRET_DEFAULT_SIZE); return XXH_OK; } XXH_PUBLIC_API XXH_errorcode XXH3_128bits_update(XXH3_state_t* state, const void* input, size_t len) { return XXH3_update(state, (const xxh_u8*)input, len, XXH3_accumulate_512, XXH3_scrambleAcc); } XXH_PUBLIC_API XXH128_hash_t XXH3_128bits_digest (const XXH3_state_t* state) { const unsigned char* const secret = (state->extSecret == NULL) ? state->customSecret : state->extSecret; if (state->totalLen > XXH3_MIDSIZE_MAX) { XXH_ALIGN(XXH_ACC_ALIGN) XXH64_hash_t acc[XXH_ACC_NB]; XXH3_digest_long(acc, state, secret); XXH_ASSERT(state->secretLimit + XXH_STRIPE_LEN >= sizeof(acc) + XXH_SECRET_MERGEACCS_START); { XXH128_hash_t h128; h128.low64 = XXH3_mergeAccs(acc, secret + XXH_SECRET_MERGEACCS_START, (xxh_u64)state->totalLen * XXH_PRIME64_1); h128.high64 = XXH3_mergeAccs(acc, secret + state->secretLimit + XXH_STRIPE_LEN - sizeof(acc) - XXH_SECRET_MERGEACCS_START, ~((xxh_u64)state->totalLen * XXH_PRIME64_2)); return h128; } } /* len <= XXH3_MIDSIZE_MAX : short code */ if (state->seed) return XXH3_128bits_withSeed(state->buffer, (size_t)state->totalLen, state->seed); return XXH3_128bits_withSecret(state->buffer, (size_t)(state->totalLen), secret, state->secretLimit + XXH_STRIPE_LEN); } /* 128-bit utility functions */ #include /* memcmp, memcpy */ /* return : 1 is equal, 0 if different */ XXH_PUBLIC_API int XXH128_isEqual(XXH128_hash_t h1, XXH128_hash_t h2) { /* note : XXH128_hash_t is compact, it has no padding byte */ return !(memcmp(&h1, &h2, sizeof(h1))); } /* This prototype is compatible with stdlib's qsort(). * return : >0 if *h128_1 > *h128_2 * <0 if *h128_1 < *h128_2 * =0 if *h128_1 == *h128_2 */ XXH_PUBLIC_API int XXH128_cmp(const void* h128_1, const void* h128_2) { XXH128_hash_t const h1 = *(const XXH128_hash_t*)h128_1; XXH128_hash_t const h2 = *(const XXH128_hash_t*)h128_2; int const hcmp = (h1.high64 > h2.high64) - (h2.high64 > h1.high64); /* note : bets that, in most cases, hash values are different */ if (hcmp) return hcmp; return (h1.low64 > h2.low64) - (h2.low64 > h1.low64); } /*====== Canonical representation ======*/ XXH_PUBLIC_API void XXH128_canonicalFromHash(XXH128_canonical_t* dst, XXH128_hash_t hash) { XXH_STATIC_ASSERT(sizeof(XXH128_canonical_t) == sizeof(XXH128_hash_t)); if (XXH_CPU_LITTLE_ENDIAN) { hash.high64 = XXH_swap64(hash.high64); hash.low64 = XXH_swap64(hash.low64); } memcpy(dst, &hash.high64, sizeof(hash.high64)); memcpy((char*)dst + sizeof(hash.high64), &hash.low64, sizeof(hash.low64)); } XXH_PUBLIC_API XXH128_hash_t XXH128_hashFromCanonical(const XXH128_canonical_t* src) { XXH128_hash_t h; h.high64 = XXH_readBE64(src); h.low64 = XXH_readBE64(src->digest + 8); return h; } /* Pop our optimization override from above */ #if XXH_VECTOR == XXH_AVX2 /* AVX2 */ \ && defined(__GNUC__) && !defined(__clang__) /* GCC, not Clang */ \ && defined(__OPTIMIZE__) && !defined(__OPTIMIZE_SIZE__) /* respect -O0 and -Os */ # pragma GCC pop_options #endif #endif /* XXH_NO_LONG_LONG */ #endif /* XXH_IMPLEMENTATION */ #if defined (__cplusplus) } #endif rlang/src/internal/sym-unescape.c0000644000176200001440000001032414175213516016542 0ustar liggesusers#include "rlang.h" #include #include #include #include "decl/sym-unescape-decl.h" // Interface functions --------------------------------------------------------- void copy_character(r_obj* tgt, r_obj* src, R_xlen_t len); R_xlen_t unescape_character_in_copy(r_obj* tgt, r_obj* src, R_xlen_t i); r_obj* ffi_symbol(r_obj* chr) { return r_str_as_symbol(r_chr_get(chr, 0)); } r_obj* ffi_sym_as_string(r_obj* sym) { return str_unserialise_unicode(PRINTNAME(sym)); } r_obj* ffi_sym_as_character(r_obj* sym) { r_obj* str = KEEP(ffi_sym_as_string(sym)); r_obj* out = r_str_as_character(str); FREE(1); return out; } r_obj* ffi_unescape_character(r_obj* chr) { R_xlen_t len = Rf_xlength(chr); R_xlen_t i = unescape_character_in_copy(r_null, chr, 0); if (i == len) return chr; r_obj* ret = KEEP(r_alloc_character(len)); copy_character(ret, chr, i); unescape_character_in_copy(ret, chr, i); FREE(1); return ret; } // Private functions ----------------------------------------------------------- static r_obj* unescape_char_to_sexp(char* tmp); static bool has_unicode_escape(const char* chr); static int unescape_char(char* chr); static int unescape_char_found(char* chr); static int process_byte(char* tgt, char* const src, int* len_processed); static bool has_codepoint(const char* src); static bool is_hex(const char chr); void copy_character(r_obj* tgt, r_obj* src, R_xlen_t len) { for (int i = 0; i < len; ++i) { r_chr_poke(tgt, i, r_chr_get(src, i)); } } R_xlen_t unescape_character_in_copy(r_obj* tgt, r_obj* src, R_xlen_t i) { R_xlen_t len = r_length(src); int dry_run = Rf_isNull(tgt); for (; i < len; ++i) { r_obj* old_elt = r_chr_get(src, i); r_obj* new_elt = str_unserialise_unicode(old_elt); if (dry_run) { if (old_elt != new_elt) return i; } else { r_chr_poke(tgt, i, new_elt); } } return i; } r_obj* str_unserialise_unicode(r_obj* r_string) { int ce = Rf_getCharCE(r_string); const char* src = CHAR(r_string); if (!has_unicode_escape(src)) { return r_string; } const char* re_enc = Rf_reEnc(src, ce, CE_UTF8, 0); if (re_enc == src) { // The string was not copied because we're in a UTF-8 locale. // Need to check first if the string has any UTF-8 escapes. int orig_len = strlen(re_enc); char tmp[orig_len + 1]; memcpy(tmp, re_enc, orig_len + 1); return unescape_char_to_sexp(tmp); } else { // The string has been copied so it's safe to use as buffer char* tmp = (char*)re_enc; return unescape_char_to_sexp(tmp); } } static r_obj* unescape_char_to_sexp(char* tmp) { int len = unescape_char(tmp); return Rf_mkCharLenCE(tmp, len, CE_UTF8); } static bool has_unicode_escape(const char* chr) { while (*chr) { if (has_codepoint(chr)) { return true; } ++chr; } return false; } static int unescape_char(char* chr) { int len = 0; while (*chr) { if (has_codepoint(chr)) { return len + unescape_char_found(chr); } else { ++chr; ++len; } } return len; } static int unescape_char_found(char* chr) { char* source = chr; char* target = chr; int len = 0; while (*source) { int len_processed; int len_new = process_byte(target, source, &len_processed); source += len_processed; target += len_new; len += len_new; } *target = 0; return len; } static int process_byte(char* tgt, char* const src, int* len_processed) { if (!has_codepoint(src)) { // Copy only the first character (angle bracket or not), advance *tgt = *src; *len_processed = 1; return 1; } unsigned int codepoint = strtoul(src + strlen(""); // We have 8 bytes space, codepoints occupy less than that: return (int)Rf_ucstoutf8(tgt, codepoint); } static bool has_codepoint(const char* src) { if (src[0] != '<') return false; if (src[1] != 'U') return false; if (src[2] != '+') return false; for (int i = 3; i < 7; ++i) { if (!is_hex(src[i])) return false; } if (src[7] != '>') return false; return true; } static bool is_hex(const char chr) { if (chr >= '0' && chr <= '9') return true; if (chr >= 'A' && chr <= 'F') return true; return false; } rlang/src/internal/vec-raw.c0000644000176200001440000000266214175213516015503 0ustar liggesusers#include #include "rlang.h" r_obj* ffi_raw_deparse_str(r_obj* x, r_obj* prefix, r_obj* suffix) { if (r_typeof(x) != R_TYPE_raw) { r_abort("`x` must be a raw vector."); } const unsigned char* p_x = r_raw_begin(x); r_ssize len_data = r_length(x); const char* s_prefix = ""; r_ssize len_prefix = 0; if (prefix != r_null) { if (!r_is_string(prefix)) { r_abort("`prefix` must be a string or NULL."); } s_prefix = r_chr_get_c_string(prefix, 0); len_prefix = strlen(s_prefix); } const char* s_suffix = ""; r_ssize len_suffix = 0; if (suffix != r_null) { if (!r_is_string(suffix)) { r_abort("`suffix` must be a string or NULL."); } s_suffix = r_chr_get_c_string(suffix, 0); len_suffix = strlen(s_suffix); } r_ssize len = len_prefix + (2 * len_data) + len_suffix; r_obj* buf = KEEP(r_alloc_raw(len)); char* p_buf = (char*) r_raw_begin(buf); memcpy(p_buf, s_prefix, len_prefix); p_buf += len_prefix; const char* lookup = "0123456789abcdef"; for (r_ssize i = 0; i < len_data; ++i) { unsigned char value = p_x[i]; *p_buf++ = lookup[value / 16]; *p_buf++ = lookup[value % 16]; } memcpy(p_buf, s_suffix, len_suffix); p_buf += len_suffix; // Invariant: p_buf == r_raw_begin(buf) + len r_obj* chr_out = KEEP(Rf_mkCharLenCE((char*) r_raw_begin(buf), len, CE_UTF8)); r_obj* out = KEEP(r_str_as_character(chr_out)); FREE(3); return(out); } rlang/src/internal/dots-ellipsis.c0000644000176200001440000000363114707706735016742 0ustar liggesusers#include "rlang.h" static r_obj* ffi_ellipsis_find_dots(r_obj* env) { if (r_typeof(env) != R_TYPE_environment) { r_abort("`env` is a not an environment."); } r_obj* dots = KEEP(r_env_find(env, r_syms.dots)); if (dots == r_syms.unbound) { r_abort("No `...` found."); } FREE(1); return dots; } r_obj* ffi_ellipsis_dots(r_obj* env) { r_obj* dots = ffi_ellipsis_find_dots(env); // Empty dots if (dots == r_syms.missing) { return r_globals.empty_list; } KEEP(dots); int n = r_length(dots); r_obj* out = KEEP(r_alloc_list(n)); r_obj* names = r_alloc_character(n); r_attrib_poke(out, r_syms.names, names); for (int i = 0; i < n; ++i) { r_list_poke(out, i, r_node_car(dots)); r_obj* name = r_node_tag(dots); if (r_typeof(name) == R_TYPE_symbol) { r_chr_poke(names, i, r_sym_string(name)); } else { r_chr_poke(names, i, r_strs.empty); } dots = r_node_cdr(dots); } FREE(2); return out; } static bool ellipsis_promise_forced(r_obj* x) { if (r_typeof(x) != R_TYPE_promise) { return true; } else { return PRVALUE(x) != r_syms.unbound; } } r_obj* ffi_ellipsis_promise_forced(r_obj* x) { return r_lgl(ellipsis_promise_forced(x)); } r_obj* ffi_ellipsis_dots_used(r_obj* env) { r_obj* dots = KEEP(ffi_ellipsis_find_dots(env)); if (dots == r_syms.missing) { FREE(1); return r_true; } while (dots != r_null) { r_obj* elt = r_node_car(dots); if (!ellipsis_promise_forced(elt)) { FREE(1); return r_false; } dots = r_node_cdr(dots); } FREE(1); return r_true; } r_obj* ffi_has_dots_unnamed(r_obj* env) { r_obj* dots = ffi_ellipsis_find_dots(env); if (dots == r_syms.missing) { return r_true; } KEEP(dots); while (dots != r_null) { if (r_node_tag(dots) != r_null) { FREE(1); return r_false; } dots = r_node_cdr(dots); } FREE(1); return r_true; } rlang/src/internal/eval.c0000644000176200001440000000125614741441060015060 0ustar liggesusers#include #include "internal.h" r_obj* ffi_exec(r_obj* call, r_obj* op, r_obj* args, r_obj* rho) { args = r_node_cdr(args); r_obj* fn = KEEP(r_eval(r_sym(".fn"), rho)); r_obj* env = KEEP(r_eval(r_sym(".env"), rho)); r_obj* dots = KEEP(rlang_dots(rho)); r_obj* exec_call = KEEP(rlang_call2(fn, dots, r_null)); r_obj* node = r_node_cdr(exec_call); while (node != r_null) { r_obj* arg = r_node_car(node); // Protect all symbolic arguments from being evaluated if (r_is_symbolic(arg)) { r_node_poke_car(node, r_call2(fns_quote, arg)); } node = r_node_cdr(node); } r_obj* out = r_eval(exec_call, env); FREE(4); return out; } rlang/src/internal/eval-tidy.c0000644000176200001440000003741014741441060016030 0ustar liggesusers#include #include "internal.h" static r_obj* quo_mask_flag_sym = NULL; static r_obj* data_mask_flag_sym = NULL; enum rlang_mask_type { RLANG_MASK_DATA, // Full data mask RLANG_MASK_QUOSURE, // Quosure mask with only `~` binding RLANG_MASK_NONE }; struct rlang_mask_info { r_obj* mask; enum rlang_mask_type type; }; static struct rlang_mask_info mask_info(r_obj* mask) { if (r_typeof(mask) != R_TYPE_environment) { return (struct rlang_mask_info) { r_null, RLANG_MASK_NONE }; } r_obj* flag; flag = r_env_find_anywhere(mask, data_mask_flag_sym); if (flag != r_syms.unbound) { return (struct rlang_mask_info) { flag, RLANG_MASK_DATA }; } flag = r_env_find_anywhere(mask, quo_mask_flag_sym); if (flag != r_syms.unbound) { return (struct rlang_mask_info) { flag, RLANG_MASK_QUOSURE }; } return (struct rlang_mask_info) { r_null, RLANG_MASK_NONE }; } static r_obj* data_pronoun_class = NULL; static r_obj* ctxt_pronoun_class = NULL; static r_obj* data_mask_env_sym = NULL; static r_obj* rlang_new_data_pronoun(r_obj* mask) { r_obj* pronoun = KEEP(r_alloc_list(1)); r_list_poke(pronoun, 0, mask); r_attrib_poke(pronoun, r_syms.class_, data_pronoun_class); FREE(1); return pronoun; } static r_obj* rlang_new_ctxt_pronoun(r_obj* top) { r_obj* pronoun = KEEP(r_alloc_empty_environment(r_env_parent(top))); r_attrib_poke(pronoun, r_syms.class_, ctxt_pronoun_class); FREE(1); return pronoun; } void poke_ctxt_env(r_obj* mask, r_obj* env) { r_obj* ctxt_pronoun = r_env_find(mask, data_mask_env_sym); if (ctxt_pronoun == r_syms.unbound) { r_abort("Internal error: Can't find context pronoun in data mask"); } r_env_poke_parent(ctxt_pronoun, env); } static r_obj* empty_names_chr; static void check_unique_names(r_obj* x) { // Allow empty lists if (!r_length(x)) { return ; } r_obj* names = r_names(x); if (names == r_null) { r_abort("`data` must be uniquely named but does not have names"); } if (vec_find_first_duplicate(names, empty_names_chr, NULL)) { r_abort("`data` must be uniquely named but has duplicate columns"); } } r_obj* ffi_as_data_pronoun(r_obj* x) { int n_kept = 0; switch (r_typeof(x)) { case R_TYPE_logical: case R_TYPE_integer: case R_TYPE_double: case R_TYPE_complex: case R_TYPE_character: case R_TYPE_raw: x = KEEP_N(r_vec_coerce(x, R_TYPE_list), &n_kept); // fallthrough case R_TYPE_list: check_unique_names(x); x = KEEP_N(r_list_as_environment(x, r_envs.empty), &n_kept); break; case R_TYPE_environment: break; default: r_abort("`data` must be an uniquely named vector, list, data frame or environment"); } r_obj* pronoun = rlang_new_data_pronoun(x); FREE(n_kept); return pronoun; } static r_obj* data_mask_top_env_sym = NULL; static void check_data_mask_input(r_obj* env, const char* arg) { if (r_typeof(env) != R_TYPE_environment) { r_abort("Can't create data mask because `%s` must be an environment", arg); } } static void check_data_mask_top(r_obj* bottom, r_obj* top) { r_obj* cur = bottom; while (cur != r_envs.empty) { if (cur == top) { return ; } cur = r_env_parent(cur); } r_abort("Can't create data mask because `top` is not a parent of `bottom`"); } static r_obj* env_sym = NULL; static r_obj* old_sym = NULL; static r_obj* mask_sym = NULL; static r_obj* tilde_fn = NULL; static r_obj* restore_mask_fn = NULL; static void on_exit_restore_lexical_env(r_obj* mask, r_obj* old, r_obj* frame) { r_obj* fn = KEEP(r_clone(restore_mask_fn)); r_obj* env = KEEP(r_alloc_environment(2, r_envs.base)); r_env_poke(env, mask_sym, mask); r_env_poke(env, old_sym, old); r_fn_poke_env(fn, env); r_obj* call = KEEP(r_new_call(fn, r_null)); r_on_exit(call, frame); FREE(3); } r_obj* ffi_new_data_mask(r_obj* bottom, r_obj* top) { r_obj* data_mask; if (bottom == r_null) { bottom = KEEP(r_alloc_environment(10, r_envs.empty)); data_mask = bottom; } else { check_data_mask_input(bottom, "bottom"); // Create a child because we don't know what might be in `bottom` // and we need to clear its contents without deleting any object // created in the data mask environment data_mask = KEEP(r_alloc_environment(10, bottom)); } if (top == r_null) { top = bottom; } else { check_data_mask_input(top, "top"); } if (top != bottom) { check_data_mask_top(bottom, top); } r_obj* ctxt_pronoun = KEEP(rlang_new_ctxt_pronoun(top)); r_env_poke(data_mask, r_syms.tilde, tilde_fn); r_env_poke(data_mask, data_mask_flag_sym, data_mask); r_env_poke(data_mask, data_mask_env_sym, ctxt_pronoun); r_env_poke(data_mask, data_mask_top_env_sym, top); FREE(2); return data_mask; } r_obj* ffi_is_data_mask(r_obj* env) { return r_lgl(mask_info(env).type == RLANG_MASK_DATA); } static r_obj* mask_find(r_obj* env, r_obj* sym) { if (r_typeof(sym) != R_TYPE_symbol) { r_abort("Internal error: Data pronoun must be subset with a symbol"); } r_obj* top_env = r_env_find(env, data_mask_top_env_sym); if (r_typeof(top_env) == R_TYPE_environment) { // Start lookup in the parent if the pronoun wraps a data mask env = r_env_parent(env); } else { // Data pronouns created from lists or data frames are converted // to a simple environment whose ancestry shouldn't be looked up. top_env = env; } int n_kept = 0; KEEP_N(top_env, &n_kept); r_obj* cur = env; do { r_obj* obj = r_env_find(cur, sym); if (r_typeof(obj) == R_TYPE_promise) { KEEP(obj); obj = r_eval(obj, r_envs.empty); FREE(1); } if (obj != r_syms.unbound) { FREE(n_kept); return obj; } if (cur == top_env) { break; } else { cur = r_env_parent(cur); } } while (cur != r_envs.empty); FREE(n_kept); return r_syms.unbound; } r_obj* ffi_data_pronoun_get(r_obj* pronoun, r_obj* sym, r_obj* error_call) { if (r_typeof(pronoun) != R_TYPE_environment) { r_abort("Internal error: Data pronoun must wrap an environment"); } r_obj* obj = mask_find(pronoun, sym); if (obj == r_syms.unbound) { r_obj* call = KEEP(r_parse("abort_data_pronoun(x, call = y)")); r_eval_with_xy(call, sym, error_call, rlang_ns_env); r_abort("Internal error: .data subsetting should have failed earlier"); } r_mark_shared(obj); return obj; } static void warn_env_as_mask_once(void) { const char* msg = "Passing an environment as data mask is deprecated.\n" "Please use `new_data_mask()` to transform your environment to a mask.\n" "\n" " env <- env(foo = \"bar\")\n" "\n" " # Bad:\n" " as_data_mask(env)\n" " eval_tidy(expr, env)\n" "\n" " # Good:\n" " mask <- new_data_mask(env)\n" " eval_tidy(expr, mask)"; deprecate_warn(msg, msg); } static r_obj* data_pronoun_sym = NULL; static r_ssize mask_length(r_ssize n); r_obj* ffi_as_data_mask(r_obj* data) { if (mask_info(data).type == RLANG_MASK_DATA) { return data; } if (data == r_null) { return ffi_new_data_mask(r_null, r_null); } int n_kept = 0; r_obj* bottom = NULL; switch (r_typeof(data)) { case R_TYPE_environment: warn_env_as_mask_once(); bottom = KEEP_N(r_env_clone(data, NULL), &n_kept); break; case R_TYPE_logical: case R_TYPE_integer: case R_TYPE_double: case R_TYPE_complex: case R_TYPE_character: case R_TYPE_raw: data = r_vec_coerce(data, R_TYPE_list); KEEP_N(data, &n_kept); // fallthrough: case R_TYPE_list: { check_unique_names(data); r_obj* names = r_names(data); r_ssize n_mask = mask_length(r_length(data)); bottom = KEEP_N(r_alloc_environment(n_mask, r_envs.empty), &n_kept); if (names != r_null) { r_ssize n = r_length(data); r_obj* const * p_names = r_chr_cbegin(names); r_obj* const * p_data = r_list_cbegin(data); for (r_ssize i = 0; i < n; ++i) { // Ignore empty or missing names r_obj* nm = p_names[i]; if (r_str_is_name(nm)) { r_env_poke(bottom, r_str_as_symbol(nm), p_data[i]); } } } break; } default: r_abort("`data` must be a vector, list, data frame, or environment"); } r_obj* data_mask = KEEP_N(ffi_new_data_mask(bottom, bottom), &n_kept); r_obj* data_pronoun = KEEP_N(ffi_as_data_pronoun(data_mask), &n_kept); r_env_poke(bottom, data_pronoun_sym, data_pronoun); FREE(n_kept); return data_mask; } static r_ssize mask_length(r_ssize n) { r_ssize n_grown = r_double_as_ssize(r_double_mult(r_ssize_as_double(n), 1.05)); return r_ssize_max(n_grown, r_ssize_add(n, 20)); } // For compatibility of the exported C callable // TODO: warn r_obj* ffi_new_data_mask_compat(r_obj* bottom, r_obj* top, r_obj* parent) { return ffi_new_data_mask(bottom, top); } r_obj* ffi_as_data_mask_compat(r_obj* data, r_obj* parent) { return ffi_as_data_mask(data); } static r_obj* tilde_prim = NULL; static r_obj* base_tilde_eval(r_obj* tilde, r_obj* quo_env) { if (r_f_has_env(tilde)) { return tilde; } // Inline the base primitive because overscopes override `~` to make // quosures self-evaluate tilde = KEEP(r_new_call(tilde_prim, r_node_cdr(tilde))); tilde = KEEP(r_eval(tilde, quo_env)); // Change it back because the result still has the primitive inlined r_node_poke_car(tilde, r_syms.tilde); FREE(2); return tilde; } r_obj* env_get_top_binding(r_obj* mask) { r_obj* top = r_env_find(mask, data_mask_top_env_sym); if (top == r_syms.unbound) { r_abort("Internal error: Can't find .top pronoun in data mask"); } if (r_typeof(top) != R_TYPE_environment) { r_abort("Internal error: Unexpected .top pronoun type"); } return top; } static r_obj* env_poke_parent_fn = NULL; static r_obj* env_poke_fn = NULL; r_obj* tilde_eval(r_obj* tilde, r_obj* current_frame, r_obj* caller_frame) { // Remove srcrefs from system call r_attrib_poke(tilde, r_syms.srcref, r_null); if (!is_quosure(tilde)) { return base_tilde_eval(tilde, caller_frame); } if (quo_is_missing(tilde)) { return(r_missing_arg); } r_obj* expr = quo_get_expr(tilde); if (!r_is_symbolic(expr)) { return expr; } r_obj* quo_env = ffi_quo_get_env(tilde); if (r_typeof(quo_env) != R_TYPE_environment) { r_abort("Internal error: Quosure environment is corrupt"); } int n_kept = 0; r_obj* top = r_null; struct rlang_mask_info info = mask_info(caller_frame); switch (info.type) { case RLANG_MASK_DATA: top = KEEP_N(env_get_top_binding(info.mask), &n_kept); // Update `.env` pronoun to current quosure env temporarily poke_ctxt_env(info.mask, quo_env); break; case RLANG_MASK_QUOSURE: top = info.mask; break; case RLANG_MASK_NONE: r_abort("Internal error: Can't find the data mask"); } // Unless the quosure was created in the mask, swap lexical contexts // temporarily by rechaining the top of the mask to the quosure // environment if (!r_env_inherits(quo_env, info.mask, top)) { // Unwind-protect the restoration of original parents on_exit_restore_lexical_env(info.mask, r_env_parent(top), current_frame); r_env_poke_parent(top, quo_env); } FREE(n_kept); return r_eval(expr, info.mask); } r_obj* ffi_tilde_eval(r_obj* call, r_obj* op, r_obj* args, r_obj* rho) { args = r_node_cdr(args); r_obj* tilde = r_node_car(args); args = r_node_cdr(args); r_obj* current_frame = r_node_car(args); args = r_node_cdr(args); r_obj* caller_frame = r_node_car(args); return tilde_eval(tilde, current_frame, caller_frame); } static const char* data_mask_objects_names[4] = { ".__tidyeval_data_mask__.", "~", ".top_env", ".env" }; // Soft-deprecated in rlang 0.2.0 r_obj* ffi_data_mask_clean(r_obj* mask) { r_obj* bottom = r_env_parent(mask); r_obj* top = r_eval(data_mask_top_env_sym, mask); KEEP(top); // Help rchk if (top == r_null) { top = bottom; } // At this level we only want to remove our own stuff r_env_unbind_c_strings(mask, data_mask_objects_names, R_ARR_SIZEOF(data_mask_objects_names)); // Remove everything in the other levels r_obj* env = bottom; r_obj* parent = r_env_parent(top); while (env != parent) { r_obj* nms = KEEP(r_env_names(env)); r_env_unbind_names(env, nms); FREE(1); env = r_env_parent(env); } FREE(1); return mask; } static r_obj* new_quosure_mask(r_obj* env) { r_obj* mask = KEEP(r_alloc_environment(3, env)); r_env_poke(mask, r_syms.tilde, tilde_fn); r_env_poke(mask, quo_mask_flag_sym, mask); FREE(1); return mask; } r_obj* rlang_eval_tidy(r_obj* expr, r_obj* data, r_obj* env) { int n_kept = 0; if (is_quosure(expr)) { env = r_quo_get_env(expr); expr = r_quo_get_expr(expr); } // If there is no data, we only need to mask `~` with the definition // for quosure thunks. Otherwise we create a heavier data mask with // all the masking objects, data pronouns, etc. if (data == r_null) { r_obj* mask = KEEP_N(new_quosure_mask(env), &n_kept); r_obj* out = r_eval(expr, mask); FREE(n_kept); return out; } r_obj* mask = KEEP_N(ffi_as_data_mask(data), &n_kept); r_obj* top = KEEP_N(env_get_top_binding(mask), &n_kept); // Rechain the mask on the new lexical env but don't restore it on // exit. This way leaked masks inherit from a somewhat sensible // environment. We could do better with ALTENV and two-parent data // masks: // // * We'd create a new two-parents evaluation env for each quosure. // The first parent would be the mask and the second the lexical // environment. // // * The data mask top would always inherit from the empty // environment. // // * Look-up in leaked environments would proceed from the data mask // to the appropriate lexical environment (from quosures or from // the `env` argument of eval_tidy()). if (!r_env_inherits(env, mask, top)) { poke_ctxt_env(mask, env); r_env_poke_parent(top, env); } r_obj* out = r_eval(expr, mask); FREE(n_kept); return out; } r_obj* ffi_eval_tidy(r_obj* call, r_obj* op, r_obj* args, r_obj* rho) { args = r_node_cdr(args); r_obj* expr = r_node_car(args); args = r_node_cdr(args); r_obj* data = r_node_car(args); args = r_node_cdr(args); r_obj* env = r_node_car(args); return rlang_eval_tidy(expr, data, env); } void rlang_init_eval_tidy(void) { r_obj* rlang_ns_env = KEEP(r_ns_env("rlang")); tilde_fn = r_eval(r_sym("tilde_eval"), rlang_ns_env); data_pronoun_class = r_chr("rlang_data_pronoun"); r_preserve(data_pronoun_class); ctxt_pronoun_class = r_chr("rlang_ctxt_pronoun"); r_preserve(ctxt_pronoun_class); empty_names_chr = r_alloc_character(2); r_preserve(empty_names_chr); r_chr_poke(empty_names_chr, 0, r_str("")); r_chr_poke(empty_names_chr, 1, r_globals.na_str); quo_mask_flag_sym = r_sym(".__tidyeval_quosure_mask__."); data_mask_flag_sym = r_sym(".__tidyeval_data_mask__."); data_mask_env_sym = r_sym(".env"); data_mask_top_env_sym = r_sym(".top_env"); data_pronoun_sym = r_sym(".data"); tilde_prim = r_base_ns_get("~"); env_poke_parent_fn = rlang_ns_get("env_poke_parent"); env_poke_fn = rlang_ns_get("env_poke"); env_sym = r_sym("env"); old_sym = r_sym("old"); mask_sym = r_sym("mask"); restore_mask_fn = r_parse_eval( "function() { \n" " ctxt_pronoun <- `mask`$.env \n" " if (!is.null(ctxt_pronoun)) { \n" " parent.env(ctxt_pronoun) <- `old` \n" " } \n" " \n" " top <- `mask`$.top_env \n" " if (is.null(top)) { \n" " top <- `mask` \n" " } \n" " \n" " parent.env(top) <- `old` \n" "} \n", r_envs.base ); r_preserve(restore_mask_fn); FREE(1); } rlang/src/internal/dots.c0000644000176200001440000007545714741441060015120 0ustar liggesusers#include #include "dots.h" #include "nse-inject.h" #include "internal.h" #include "squash.h" #include "utils.h" #include "vec.h" enum dots_homonyms { DOTS_HOMONYMS_keep = 0, DOTS_HOMONYMS_first, DOTS_HOMONYMS_last, DOTS_HOMONYMS_error, DOTS_HOMONYMS_SIZE }; enum arg_named { ARG_NAMED_none = 0, ARG_NAMED_minimal, ARG_NAMED_auto }; enum dots_ignore_empty { DOTS_IGNORE_EMPTY_trailing = 0, DOTS_IGNORE_EMPTY_none, DOTS_IGNORE_EMPTY_all, DOTS_IGNORE_EMPTY_SIZE, }; struct dots_capture_info { enum dots_collect type; r_ssize count; enum arg_named named; bool needs_expansion; enum dots_ignore_empty ignore_empty; bool preserve_empty; bool unquote_names; enum dots_homonyms homonyms; bool check_assign; r_obj* (*big_bang_coerce)(r_obj*); bool splice; }; static const char* dots_ignore_empty_c_values[DOTS_IGNORE_EMPTY_SIZE] = { [DOTS_IGNORE_EMPTY_trailing] = "trailing", [DOTS_IGNORE_EMPTY_none] = "none", [DOTS_IGNORE_EMPTY_all] = "all" }; #include "decl/dots-decl.h" r_obj* new_splice_box(r_obj* x) { r_obj* out = KEEP(r_alloc_list(1)); r_list_poke(out, 0, x); r_poke_attrib(out, splice_box_attrib); r_mark_object(out); FREE(1); return out; } bool is_splice_box(r_obj* x) { return r_attrib(x) == splice_box_attrib; } r_obj* ffi_is_splice_box(r_obj* x) { return r_lgl(is_splice_box(x)); } r_obj* rlang_unbox(r_obj* x) { if (r_length(x) != 1) { r_abort("Internal error: Expected a list of size 1 in `rlang_unbox()`."); } return r_list_get(x, 0); } struct dots_capture_info init_capture_info(enum dots_collect type, r_obj* named, r_obj* ignore_empty, r_obj* preserve_empty, r_obj* unquote_names, r_obj* homonyms, r_obj* check_assign, r_obj* (*coercer)(r_obj*), bool splice) { struct dots_capture_info info; info.type = type; info.count = 0; info.needs_expansion = false; info.named = arg_match_named(named); info.ignore_empty = arg_match_ignore_empty(ignore_empty); info.preserve_empty = r_lgl_get(preserve_empty, 0); info.unquote_names = r_lgl_get(unquote_names, 0); info.homonyms = arg_match_homonyms(homonyms); info.check_assign = r_lgl_get(check_assign, 0); info.big_bang_coerce = coercer; info.splice = splice; return info; } static bool has_glue = false; r_obj* ffi_glue_is_here(void) { has_glue = true; return r_null; } static bool has_curly(const char* str) { for (char c = *str; c != '\0'; ++str, c = *str) { if (c == '{') { return true; } } return false; } r_obj* ffi_chr_has_curly(r_obj* x) { if (r_typeof(x) != R_TYPE_character) { r_stop_internal("Expected a character vector."); } r_ssize n = r_length(x); r_obj* const * v_data = r_chr_cbegin(x); for (r_ssize i = 0; i < n; ++i) { if (has_curly(r_str_c_string(v_data[i]))) { return r_true; } } return r_false; } static void require_glue(void) { r_obj* call = KEEP(r_parse("is_installed('glue')")); r_obj* out = KEEP(r_eval(call, rlang_ns_env)); if (!r_is_bool(out)) { r_abort("Internal error: Expected scalar logical from `requireNamespace()`."); } if (!r_lgl_get(out, 0)) { r_abort("Can't use `{` symbols in LHS of `:=` if glue is not installed."); } FREE(2); } static r_obj* glue_embrace(r_obj* lhs, r_obj* env) { if (!r_is_string(lhs) || !has_curly(r_chr_get_c_string(lhs, 0))) { return lhs; } if (!has_glue) { require_glue(); } r_obj* glue_embrace_call = KEEP(r_call2(glue_embrace_fn, lhs)); lhs = r_eval(glue_embrace_call, env); FREE(1); return lhs; } static r_obj* def_unquote_name(r_obj* expr, r_obj* env) { int n_kept = 0; r_obj* lhs = r_node_cadr(expr); struct injection_info info = which_expansion_op(lhs, true); switch (info.op) { case INJECTION_OP_none: lhs = KEEP_N(glue_embrace(lhs, env), &n_kept); break; case INJECTION_OP_uq: lhs = KEEP_N(r_eval(info.operand, env), &n_kept); break; case INJECTION_OP_curly: lhs = KEEP_N(ffi_enquo(info.operand, env), &n_kept); break; case INJECTION_OP_uqs: r_abort("The LHS of `:=` can't be spliced with `!!!`"); case INJECTION_OP_uqn: r_abort("Internal error: Chained `:=` should have been detected earlier"); case INJECTION_OP_fixup: r_abort("The LHS of `:=` must be a string or a symbol"); case INJECTION_OP_dot_data: r_abort("Can't use the `.data` pronoun on the LHS of `:=`"); } // Unwrap quosures for convenience if (is_quosure(lhs)) { lhs = quo_get_expr(lhs); } int err = 0; r_obj* out = r_new_symbol(lhs, &err); if (err) { r_abort("The LHS of `:=` must be a string, not %s.", r_obj_type_friendly(lhs)); } FREE(n_kept); return out; } void signal_retired_splice(void) { const char* msg = "Unquoting language objects with `!!!` is deprecated as of rlang 0.4.0.\n" "Please use `!!` instead.\n" "\n" " # Bad:\n" " dplyr::select(data, !!!enquo(x))\n" "\n" " # Good:\n" " dplyr::select(data, !!enquo(x)) # Unquote single quosure\n" " dplyr::select(data, !!!enquos(x)) # Splice list of quosures\n"; deprecate_warn(msg, msg); } static r_obj* dots_big_bang_coerce(r_obj* x) { switch (r_typeof(x)) { case R_TYPE_null: case R_TYPE_pairlist: case R_TYPE_logical: case R_TYPE_integer: case R_TYPE_double: case R_TYPE_complex: case R_TYPE_character: case R_TYPE_raw: if (r_is_object(x)) { return r_eval_with_x(rlang_as_list_call, x, rlang_ns_env); } else { return r_vec_coerce(x, R_TYPE_list); } case R_TYPE_list: if (r_is_object(x)) { return r_eval_with_x(rlang_as_list_call, x, rlang_ns_env); } else { return x; } case R_TYPE_s4: return r_eval_with_x(rlang_as_list_call, x, rlang_ns_env); case R_TYPE_call: if (r_is_symbol(r_node_car(x), "{")) { return r_vec_coerce(r_node_cdr(x), R_TYPE_list); } // else fallthrough case R_TYPE_symbol: signal_retired_splice(); return r_list(x); default: r_abort( "Can't splice an object of type <%s> because it is not a vector.", r_type_as_c_string(r_typeof(x)) ); } } // Also used in nse-inject.c r_obj* big_bang_coerce_pairlist(r_obj* x, bool deep) { int n_kept = 0; if (r_is_object(x)) { x = KEEP_N(dots_big_bang_coerce(x), &n_kept); } switch (r_typeof(x)) { case R_TYPE_null: case R_TYPE_pairlist: x = r_clone(x); break; case R_TYPE_logical: case R_TYPE_integer: case R_TYPE_double: case R_TYPE_complex: case R_TYPE_character: case R_TYPE_raw: case R_TYPE_list: // Check for length because `Rf_coerceVector()` to pairlist fails // with named empty vectors (#1045) if (r_length(x)) { x = r_vec_coerce(x, R_TYPE_pairlist); } else { x = r_null; } break; case R_TYPE_call: if (deep && r_is_symbol(r_node_car(x), "{")) { x = r_node_cdr(x); break; } // fallthrough case R_TYPE_symbol: { if (deep) { signal_retired_splice(); x = r_new_node(x, r_null); break; } // fallthrough } default: r_abort( "Can't splice an object of type `%s` because it is not a vector", r_type_as_c_string(r_typeof(x)) ); } FREE(n_kept); return x; } static r_obj* dots_big_bang_coerce_pairlist(r_obj* x) { return big_bang_coerce_pairlist(x, false); } static r_obj* dots_big_bang_value(struct dots_capture_info* capture_info, r_obj* value, r_obj* env, bool quosured) { value = KEEP(capture_info->big_bang_coerce(value)); r_ssize n = r_length(value); if (quosured) { if (r_is_shared(value)) { r_obj* tmp = r_clone(value); FREE(1); value = KEEP(tmp); } for (r_ssize i = 0; i < n; ++i) { r_obj* elt = r_list_get(value, i); elt = forward_quosure(elt, env); r_list_poke(value, i, elt); } } // The dots_values() variant does not splice for performance if (capture_info->splice) { capture_info->needs_expansion = true; capture_info->count += n; } value = new_splice_box(value); FREE(1); return value; } static r_obj* dots_big_bang(struct dots_capture_info* capture_info, r_obj* expr, r_obj* env, bool quosured) { r_obj* value = KEEP(r_eval(expr, env)); r_obj* out = dots_big_bang_value(capture_info, value, env, quosured); FREE(1); return out; } static inline r_obj* dot_get_expr(r_obj* dot) { return r_list_get(dot, 0); } static inline r_obj* dot_get_env(r_obj* dot) { return r_list_get(dot, 1); } static r_obj* dots_unquote(r_obj* dots, struct dots_capture_info* capture_info) { capture_info->count = 0; r_ssize n = r_length(dots); bool unquote_names = capture_info->unquote_names; // In the case of `dots_list()` we auto-name inputs eagerly while we // still have access to the defused expression bool needs_autoname = capture_info->type == DOTS_COLLECT_value && capture_info->named == ARG_NAMED_auto; r_obj* node = dots; for (r_ssize i = 0; node != r_null; ++i, node = r_node_cdr(node)) { r_obj* elt = r_node_car(node); r_obj* name = r_node_tag(node); r_obj* expr = dot_get_expr(elt); r_obj* env = dot_get_env(elt); // Unquoting rearranges expressions expr = KEEP(r_node_tree_clone(expr)); if (unquote_names && r_is_call(expr, ":=")) { if (r_node_tag(node) != r_null) { r_abort("Can't supply both `=` and `:=`"); } r_obj* nm = def_unquote_name(expr, env); r_node_poke_tag(node, nm); expr = r_node_cadr(r_node_cdr(expr)); } if (capture_info->check_assign && r_is_call(expr, "<-") && r_peek_option("rlang_dots_disable_assign_warning") == r_null) { r_warn( "Using `<-` as argument is often a mistake.\n" "Do you need to use `=` to match an argument?\n" "\n" "If you really want to use `<-`, please wrap in braces:\n" "\n" " # Bad:\n" " fn(a <- 1)\n" "\n" " # Good:\n" " fn(a = 1) # Match 1 to parameter `a`\n" " fn({ a <- 1 }) # Assign 1 to variable `a`" ); } struct injection_info info = which_expansion_op(expr, unquote_names); enum dots_op dots_op = info.op + (INJECTION_OP_MAX * capture_info->type); bool last = i == n - 1; #define SKIP_MISSING(EXPR, NPROT) \ if (should_ignore(capture_info, EXPR, name, last)) { \ ignore(capture_info, node); \ FREE(NPROT); \ continue; \ } switch (dots_op) { case DOTS_OP_expr_none: case DOTS_OP_expr_uq: case DOTS_OP_expr_fixup: case DOTS_OP_expr_dot_data: case DOTS_OP_expr_curly: expr = call_interp_impl(expr, env, info); SKIP_MISSING(expr, 1) capture_info->count += 1; break; case DOTS_OP_quo_none: case DOTS_OP_quo_uq: case DOTS_OP_quo_fixup: case DOTS_OP_quo_dot_data: case DOTS_OP_quo_curly: expr = KEEP(call_interp_impl(expr, env, info)); expr = forward_quosure(expr, env); SKIP_MISSING(quo_get_expr(expr), 2) FREE(1); capture_info->count += 1; break; case DOTS_OP_value_none: case DOTS_OP_value_fixup: case DOTS_OP_value_dot_data: { SKIP_MISSING(expr, 1) r_obj* orig = expr; if (expr == r_syms.missing) { if (!capture_info->preserve_empty) { r_abort("Argument %d can't be empty.", i + 1); } } else if (env != r_envs.empty) { // Don't evaluate when `env` is the empty environment. This // happens when the argument was forced (and thus already // evaluated), for instance by lapply() or map(). expr = r_eval(expr, env); } r_keep_loc i; KEEP_HERE(expr, &i); if (is_splice_box(expr)) { // Coerce contents of splice boxes to ensure uniform type expr = rlang_unbox(expr); expr = dots_big_bang_value(capture_info, expr, env, false); KEEP_AT(expr, i); } else { if (needs_autoname && r_node_tag(node) == r_null) { r_obj* label = KEEP(r_as_label(orig)); r_node_poke_tag(node, r_str_as_symbol(r_chr_get(label, 0))); FREE(1); } capture_info->count += 1; } FREE(1); break; } case DOTS_OP_value_uq: r_abort("Can't use `!!` in a non-quoting function."); case DOTS_OP_value_curly: r_abort("Can't use `{{` in a non-quoting function."); case DOTS_OP_expr_uqn: case DOTS_OP_quo_uqn: case DOTS_OP_value_uqn: r_abort("`:=` can't be chained."); case DOTS_OP_expr_uqs: expr = dots_big_bang(capture_info, info.operand, env, false); break; case DOTS_OP_quo_uqs: expr = dots_big_bang(capture_info, info.operand, env, true); break; case DOTS_OP_value_uqs: expr = dots_big_bang(capture_info, info.operand, env, false); break; case DOTS_OP_MAX: r_stop_unreachable(); } r_node_poke_car(node, expr); FREE(1); } return dots; } static inline bool should_ignore(struct dots_capture_info* p_capture_info, r_obj* expr, r_obj* name, bool last) { if (expr != r_syms.missing || (name != r_null && name != r_strs.empty)) { return false; } switch (p_capture_info->ignore_empty) { case DOTS_IGNORE_EMPTY_all: return true; case DOTS_IGNORE_EMPTY_trailing: return last; default: return false; } } static inline void ignore(struct dots_capture_info* p_capture_info, r_obj* node) { p_capture_info->needs_expansion = true; r_node_poke_car(node, empty_spliced_arg); } static enum dots_ignore_empty arg_match_ignore_empty(r_obj* ignore_empty) { return r_arg_match(ignore_empty, dots_ignore_empty_values, dots_ignore_empty_arg, r_lazy_missing_arg); } static const char* dots_homonyms_c_values[DOTS_HOMONYMS_SIZE] = { [DOTS_HOMONYMS_keep] = "keep", [DOTS_HOMONYMS_first] = "first", [DOTS_HOMONYMS_last] = "last", [DOTS_HOMONYMS_error] = "error" }; static enum dots_homonyms arg_match_homonyms(r_obj* homonyms) { return r_arg_match(homonyms, dots_homonyms_values, dots_homonyms_arg, r_lazy_missing_arg); } static enum arg_named arg_match_named(r_obj* named) { if (named == r_null) { return ARG_NAMED_none; } if (!r_is_bool(named)) { r_abort("`.named` must be a logical value."); } return r_lgl_get(named, 0) ? ARG_NAMED_auto : ARG_NAMED_minimal; } static r_obj* maybe_auto_name(r_obj* x, enum arg_named named) { r_obj* names = r_names(x); if (named == ARG_NAMED_auto && (names == r_null || r_chr_has(names, ""))) { x = r_eval_with_x(auto_name_call, x, r_envs.base); } return x; } static bool any_name(r_obj* x, bool splice) { while (x != r_null) { if (r_node_tag(x) != r_null) { return true; } r_obj* elt = r_node_car(x); if (splice && is_splice_box(elt)) { if (r_names(rlang_unbox(elt)) != r_null) { return true; } } x = r_node_cdr(x); } return false; } static void check_named_splice(r_obj* node) { if (r_node_tag(node) != r_null) { const char* msg = "`!!!` can't be supplied with a name. Only the operand's names are retained."; deprecate_stop(msg); } } r_obj* dots_as_list(r_obj* dots, struct dots_capture_info* capture_info) { int n_kept = 0; if (r_names(dots) == r_null && r_node_cdr(dots) == r_null && is_splice_box(r_node_car(dots))) { r_obj* out = rlang_unbox(r_node_car(dots)); r_mark_shared(out); return out; } r_obj* out = KEEP_N(r_alloc_list(capture_info->count), &n_kept); r_obj* out_names = r_null; if (capture_info->named != ARG_NAMED_none || any_name(dots, capture_info->splice)) { out_names = KEEP_N(r_alloc_character(capture_info->count), &n_kept); r_attrib_push(out, r_syms.names, out_names); } for (r_ssize count = 0; dots != r_null; dots = r_node_cdr(dots)) { r_obj* elt = r_node_car(dots); if (elt == empty_spliced_arg) { continue; } if (capture_info->splice && is_splice_box(elt)) { check_named_splice(dots); elt = rlang_unbox(elt); r_obj* nms = r_names(elt); r_ssize n = r_length(elt); for (r_ssize i = 0; i < n; ++i) { r_obj* value = r_list_get(elt, i); r_list_poke(out, count, value); r_obj* name = r_nms_get(nms, i); if (name != r_strs.empty) { r_chr_poke(out_names, count, name); } ++count; } } else { r_list_poke(out, count, elt); r_obj* name = r_node_tag(dots); if (name != r_null) { r_chr_poke(out_names, count, r_sym_as_utf8_string(name)); } ++count; } } FREE(n_kept); return out; } r_obj* dots_as_pairlist(r_obj* dots, struct dots_capture_info* capture_info) { r_obj* out = KEEP(r_new_node(r_null, dots)); r_obj* prev = out; while (dots != r_null) { r_obj* elt = r_node_car(dots); if (elt == empty_spliced_arg) { dots = r_node_cdr(dots); r_node_poke_cdr(prev, dots); continue; } if (capture_info->splice && is_splice_box(elt)) { check_named_splice(dots); elt = rlang_unbox(elt); if (elt == r_null) { dots = r_node_cdr(dots); r_node_poke_cdr(prev, dots); continue; } r_node_poke_cdr(prev, elt); r_obj* next = r_node_cdr(dots); r_obj* tail = r_pairlist_tail(elt); r_node_poke_cdr(tail, next); prev = tail; dots = next; continue; } prev = dots; dots = r_node_cdr(dots); } FREE(1); return r_node_cdr(out); } static r_obj* dots_keep(r_obj* dots, r_obj* nms, bool first) { r_ssize n = r_length(dots); r_obj* dups = KEEP(nms_are_duplicated(nms, !first)); r_ssize out_n = n - r_lgl_sum(dups, false); r_obj* out = KEEP(r_alloc_list(out_n)); r_obj* out_nms = KEEP(r_alloc_character(out_n)); r_attrib_push(out, r_syms.names, out_nms); r_obj* const * p_nms = r_chr_cbegin(nms); const int* p_dups = r_lgl_cbegin(dups); for (r_ssize i = 0, out_i = 0; i < n; ++i) { if (!p_dups[i]) { r_list_poke(out, out_i, r_list_get(dots, i)); r_chr_poke(out_nms, out_i, p_nms[i]); ++out_i; } } FREE(3); return out; } static void dots_check_homonyms(r_obj* dots, r_obj* nms) { r_obj* dups = KEEP(nms_are_duplicated(nms, false)); if (r_lgl_sum(dups, false)) { // Forward `error_call` to caller context since this is the one // that determines the homonyms constraints for its users r_obj* env = KEEP(r_peek_frame()); env = KEEP(r_caller_env(env)); struct r_pair args[] = { { r_sym("dots"), dots }, { r_sym("dups"), dups } }; r_exec_n(r_null, abort_dots_homonyms_ns_sym, args, R_ARR_SIZEOF(args), env); r_stop_unreachable(); } FREE(1); } // From capture.c r_obj* capturedots(r_obj* frame); static r_obj* dots_capture(struct dots_capture_info* capture_info, r_obj* frame_env) { r_obj* dots = KEEP(capturedots(frame_env)); dots = dots_unquote(dots, capture_info); FREE(1); return dots; } r_obj* ffi_unescape_character(r_obj*); static r_obj* dots_finalise(struct dots_capture_info* capture_info, r_obj* dots) { int n_prot = 0; r_obj* nms = r_names(dots); // Here handle minimal vs none switch (capture_info->named) { case ARG_NAMED_auto: case ARG_NAMED_minimal: if (nms == r_null) { nms = KEEP_N(r_alloc_character(r_length(dots)), &n_prot); dots = KEEP_N(r_vec_clone(dots), &n_prot); } break; case ARG_NAMED_none: break; } if (nms != r_null) { // Serialised unicode points might arise when unquoting lists // because of the conversion to pairlist nms = KEEP(ffi_unescape_character(nms)); r_attrib_poke_names(dots, nms); dots = KEEP(maybe_auto_name(dots, capture_info->named)); switch (capture_info->homonyms) { case DOTS_HOMONYMS_keep: break; case DOTS_HOMONYMS_first: dots = dots_keep(dots, nms, true); break; case DOTS_HOMONYMS_last: dots = dots_keep(dots, nms, false); break; case DOTS_HOMONYMS_error: dots_check_homonyms(dots, nms); break; default: r_stop_unreachable(); } FREE(2); } FREE(n_prot); return dots; } r_obj* ffi_exprs_interp(r_obj* frame_env, r_obj* named, r_obj* ignore_empty, r_obj* unquote_names, r_obj* homonyms, r_obj* check_assign) { struct dots_capture_info capture_info; capture_info = init_capture_info(DOTS_COLLECT_expr, named, ignore_empty, r_true, unquote_names, homonyms, check_assign, &dots_big_bang_coerce, true); r_obj* dots; dots = KEEP(dots_capture(&capture_info, frame_env)); dots = KEEP(dots_as_list(dots, &capture_info)); dots = dots_finalise(&capture_info, dots); FREE(2); return dots; } r_obj* ffi_quos_interp(r_obj* frame_env, r_obj* named, r_obj* ignore_empty, r_obj* unquote_names, r_obj* homonyms, r_obj* check_assign) { struct dots_capture_info capture_info; capture_info = init_capture_info(DOTS_COLLECT_quo, named, ignore_empty, r_true, unquote_names, homonyms, check_assign, &dots_big_bang_coerce, true); r_obj* dots; dots = KEEP(dots_capture(&capture_info, frame_env)); dots = KEEP(dots_as_list(dots, &capture_info)); dots = KEEP(dots_finalise(&capture_info, dots)); r_obj* attrib = KEEP(r_new_node(r_names(dots), r_clone(quosures_attrib))); r_node_poke_tag(attrib, r_syms.names); r_poke_attrib(dots, attrib); r_mark_object(dots); FREE(4); return dots; } static bool is_spliced_bare_dots_value(r_obj* x) { if (r_typeof(x) != R_TYPE_list) { return false; } if (is_splice_box(x)) { return true; } if (r_is_object(x)) { return false; } return true; } static r_obj* dots_values_impl(r_obj* frame_env, r_obj* named, r_obj* ignore_empty, r_obj* preserve_empty, r_obj* unquote_names, r_obj* homonyms, r_obj* check_assign, bool splice) { struct dots_capture_info capture_info; capture_info = init_capture_info(DOTS_COLLECT_value, named, ignore_empty, preserve_empty, unquote_names, homonyms, check_assign, &dots_big_bang_coerce, splice); r_obj* dots; dots = KEEP(dots_capture(&capture_info, frame_env)); if (capture_info.needs_expansion) { dots = KEEP(dots_as_list(dots, &capture_info)); } else { dots = KEEP(r_vec_coerce(dots, R_TYPE_list)); } dots = dots_finalise(&capture_info, dots); FREE(2); return dots; } r_obj* ffi_dots_values(r_obj* args) { args = r_node_cdr(args); r_obj* env = r_node_car(args); args = r_node_cdr(args); r_obj* named = r_node_car(args); args = r_node_cdr(args); r_obj* ignore_empty = r_node_car(args); args = r_node_cdr(args); r_obj* preserve_empty = r_node_car(args); args = r_node_cdr(args); r_obj* unquote_names = r_node_car(args); args = r_node_cdr(args); r_obj* homonyms = r_node_car(args); args = r_node_cdr(args); r_obj* check_assign = r_node_car(args); r_obj* out = dots_values_impl(env, named, ignore_empty, preserve_empty, unquote_names, homonyms, check_assign, false); return out; } // [[ export() ]] r_obj* rlang_env_dots_values(r_obj* env) { return dots_values_impl(env, r_null, rlang_objs_trailing, r_false, r_true, rlang_objs_keep, r_false, false); } // [[ export() ]] r_obj* rlang_env_dots_list(r_obj* env) { r_obj* out = KEEP(dots_values_impl(env, r_null, rlang_objs_trailing, r_false, r_true, rlang_objs_keep, r_false, true)); out = r_vec_clone_shared(out); FREE(1); return out; } r_obj* ffi_dots_list(r_obj* frame_env, r_obj* named, r_obj* ignore_empty, r_obj* preserve_empty, r_obj* unquote_names, r_obj* homonyms, r_obj* check_assign) { return dots_values_impl(frame_env, named, ignore_empty, preserve_empty, unquote_names, homonyms, check_assign, true); } r_obj* ffi_dots_flat_list(r_obj* frame_env, r_obj* named, r_obj* ignore_empty, r_obj* preserve_empty, r_obj* unquote_names, r_obj* homonyms, r_obj* check_assign) { struct dots_capture_info capture_info; capture_info = init_capture_info(DOTS_COLLECT_value, named, ignore_empty, preserve_empty, unquote_names, homonyms, check_assign, &dots_big_bang_coerce, true); r_obj* dots; dots = KEEP(dots_capture(&capture_info, frame_env)); dots = KEEP(r_vec_coerce(dots, R_TYPE_list)); dots = KEEP(r_squash_if(dots, R_TYPE_list, is_spliced_bare_dots_value, 1)); dots = dots_finalise(&capture_info, dots); FREE(3); return dots; } r_obj* dots_values_node_impl(r_obj* frame_env, r_obj* named, r_obj* ignore_empty, r_obj* preserve_empty, r_obj* unquote_names, r_obj* homonyms, r_obj* check_assign, bool splice) { struct dots_capture_info capture_info; capture_info = init_capture_info(DOTS_COLLECT_value, named, ignore_empty, preserve_empty, unquote_names, homonyms, check_assign, &dots_big_bang_coerce_pairlist, splice); r_obj* dots; dots = KEEP(dots_capture(&capture_info, frame_env)); dots = KEEP(dots_as_pairlist(dots, &capture_info)); // dots = dots_finalise(&capture_info, dots); FREE(2); return dots; } r_obj* ffi_dots_pairlist(r_obj* frame_env, r_obj* named, r_obj* ignore_empty, r_obj* preserve_empty, r_obj* unquote_names, r_obj* homonyms, r_obj* check_assign) { return dots_values_node_impl(frame_env, named, ignore_empty, preserve_empty, unquote_names, homonyms, check_assign, true); } void rlang_init_dots(r_obj* ns) { glue_embrace_fn = r_eval(r_sym("glue_embrace"), ns); auto_name_call = r_parse("rlang:::quos_auto_name(x)"); r_preserve(auto_name_call); abort_dots_homonyms_ns_sym = r_parse("rlang:::abort_dots_homonyms"); r_preserve(abort_dots_homonyms_ns_sym); { r_obj* splice_box_class = KEEP(r_alloc_character(2)); r_chr_poke(splice_box_class, 0, r_str("rlang_box_splice")); r_chr_poke(splice_box_class, 1, r_str("rlang_box")); splice_box_attrib = r_pairlist(splice_box_class); r_preserve(splice_box_attrib); r_mark_shared(splice_box_attrib); r_node_poke_tag(splice_box_attrib, r_syms.class_); FREE(1); } { r_obj* list = KEEP(r_alloc_list(0)); empty_spliced_arg = new_splice_box(list); r_preserve(empty_spliced_arg); r_mark_shared(empty_spliced_arg); FREE(1); } { r_obj* quosures_class = KEEP(r_alloc_character(2)); r_chr_poke(quosures_class, 0, r_str("quosures")); r_chr_poke(quosures_class, 1, r_str("list")); quosures_attrib = r_pairlist(quosures_class); r_preserve(quosures_attrib); r_mark_shared(quosures_attrib); r_node_poke_tag(quosures_attrib, r_syms.class_); FREE(1); } dots_ignore_empty_values = r_chr_n(dots_ignore_empty_c_values, DOTS_IGNORE_EMPTY_SIZE); r_preserve_global(dots_ignore_empty_values); dots_homonyms_values = r_chr_n(dots_homonyms_c_values, DOTS_HOMONYMS_SIZE); r_preserve_global(dots_homonyms_values); dots_ignore_empty_arg = (struct r_lazy) { .x = r_sym(".ignore_empty"), .env = r_null }; dots_homonyms_arg = (struct r_lazy) { .x = r_sym(".homonyms"), .env = r_null }; } static r_obj* auto_name_call = NULL; static r_obj* empty_spliced_arg = NULL; static r_obj* glue_embrace_fn = NULL; static r_obj* dots_homonyms_values = NULL; static r_obj* dots_ignore_empty_values = NULL; static r_obj* quosures_attrib = NULL; static r_obj* splice_box_attrib = NULL; static r_obj* abort_dots_homonyms_ns_sym = NULL; static struct r_lazy dots_homonyms_arg = { 0 }; static struct r_lazy dots_ignore_empty_arg = { 0 }; rlang/src/internal/dots.h0000644000176200001440000000122714741441060015105 0ustar liggesusers#ifndef RLANG_INTERNAL_DOTS_H #define RLANG_INTERNAL_DOTS_H enum dots_collect { DOTS_COLLECT_expr, DOTS_COLLECT_quo, DOTS_COLLECT_value }; #define DOTS_COLLECT_MAX 3 enum dots_op { DOTS_OP_expr_none, DOTS_OP_expr_uq, DOTS_OP_expr_uqs, DOTS_OP_expr_uqn, DOTS_OP_expr_fixup, DOTS_OP_expr_dot_data, DOTS_OP_expr_curly, DOTS_OP_quo_none, DOTS_OP_quo_uq, DOTS_OP_quo_uqs, DOTS_OP_quo_uqn, DOTS_OP_quo_fixup, DOTS_OP_quo_dot_data, DOTS_OP_quo_curly, DOTS_OP_value_none, DOTS_OP_value_uq, DOTS_OP_value_uqs, DOTS_OP_value_uqn, DOTS_OP_value_fixup, DOTS_OP_value_dot_data, DOTS_OP_value_curly, DOTS_OP_MAX }; #endif rlang/src/internal/env.h0000644000176200001440000000102514376112150014717 0ustar liggesusers#ifndef RLANG_INTERNAL_ENV_H #define RLANG_INTERNAL_ENV_H #include void r_env_unbind_anywhere(r_obj* env, r_obj* sym); void r_env_unbind_anywhere_names(r_obj* env, r_obj* names); void r_env_unbind_anywhere_c_string(r_obj* env, const char* name); void r_env_unbind_anywhere_c_strings(r_obj* env, const char** names, r_ssize n); void r_env_unbind_names(r_obj* env, r_obj* names); void r_env_unbind_c_string(r_obj* env, const char* name); void r_env_unbind_c_strings(r_obj* env, const char** strings, r_ssize n); #endif rlang/src/internal/cnd.c0000644000176200001440000001437014375670676014722 0ustar liggesusers#include #include "utils.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'; \ } #include "decl/cnd-decl.h" r_obj* ffi_format_error_arg(r_obj* arg) { switch (r_typeof(arg)) { case R_TYPE_symbol: arg = r_sym_as_utf8_character(arg); break; case R_TYPE_string: arg = r_str_as_character(arg); break; case R_TYPE_call: arg = r_as_label(arg); break; case R_TYPE_character: if (r_length(arg) == 1) break; else goto error; default: error: r_abort("`arg` must be a string or an expression."); } KEEP(arg); r_obj* out = r_eval_with_x(format_arg_call, arg, rlang_ns_env); FREE(1); return out; } const char* rlang_format_error_arg(r_obj* arg) { arg = KEEP(ffi_format_error_arg(arg)); const char* arg_str = r_chr_get_c_string(arg, 0); int n = strlen(arg_str) + 1; // Uses the vmax protection stack. char* out = R_alloc(n, sizeof(char)); memcpy(out, arg_str, n); FREE(1); return out; } struct without_winch_data { r_obj* old_on_error; r_obj* old_use_winch; }; struct stop_internal_data { const char* file; int line; r_obj* call; const char* msg; }; r_no_return void rlang_stop_internal2(const char* file, int line, r_obj* call, const char* fmt, ...) { R_CheckStack2(BUFSIZE); char msg[BUFSIZE]; INTERP(msg, fmt, ...); struct stop_internal_data stop_internal_data = { .file = file, .line = line, .call = call, .msg = msg }; struct r_pair_callback with_winch_data = { .fn = &stop_internal_cb, .data = &stop_internal_data }; struct without_winch_data without_winch_data = { .old_on_error = KEEP(r_peek_option("rlang_backtrace_on_error")), .old_use_winch = KEEP(r_peek_option("rlang_trace_use_winch")) }; R_ExecWithCleanup(&with_winch, &with_winch_data, &without_winch, &without_winch_data); r_abort("unreachable"); } // For compatibility, exported as C callable `rlang_stop_internal` r_no_return void rlang_stop_internal(const char* fn, const char* fmt, ...) { R_CheckStack2(BUFSIZE); char msg[BUFSIZE]; INTERP(msg, fmt, ...); r_obj* call = KEEP(r_call(r_sym(fn))); rlang_stop_internal2("", -1, call, msg); r_abort("unreachable"); } static r_no_return r_obj* stop_internal_cb(void* payload) { struct stop_internal_data* data = (struct stop_internal_data*) payload; struct r_pair args[] = { { r_sym("file"), KEEP(r_chr(data->file)) }, { r_sym("line"), KEEP(r_int(data->line)) }, { r_sym("call"), data->call }, { r_sym("message"), KEEP(r_chr(data->msg)) }, { r_sym("frame"), KEEP(r_peek_frame()) } }; r_exec_mask_n(r_null, r_sym("stop_internal_c_lib"), args, R_ARR_SIZEOF(args), rlang_ns_env); r_abort("unreachable"); } static r_obj* with_winch(void* payload) { r_poke_option("rlang_backtrace_on_error", r_chrs.full); r_poke_option("rlang_trace_use_winch", r_true); struct r_pair_callback* data = (struct r_pair_callback*) payload; return data->fn(data->data); } static void without_winch(void* payload) { struct without_winch_data* data = (struct without_winch_data*) payload; r_poke_option("rlang_backtrace_on_error", data->old_on_error); r_poke_option("rlang_trace_use_winch", data->old_use_winch); } r_obj* ffi_test_stop_internal(void) { r_stop_internal("foo"); return r_null; } // Probably should be implemented at R level r_obj* ffi_new_condition(r_obj* class, r_obj* msg, r_obj* data) { if (msg == r_null) { msg = r_chrs.empty_string; } else if (r_typeof(msg) != R_TYPE_character) { const char* arg = r_format_error_arg(r_sym("message")); const char* what = r_obj_type_friendly(msg); r_abort("%s must be a character vector, not %s.", arg, what); } if (r_typeof(class) != R_TYPE_character) { const char* arg = r_format_error_arg(r_sym("class")); const char* what = r_obj_type_friendly(class); r_abort("%s must be a character vector, not %s.", arg, what); } r_ssize n_data = r_length(data); r_obj* cnd = KEEP(r_alloc_list(n_data + 1)); r_list_poke(cnd, 0, msg); r_vec_poke_n(cnd, 1, data, 0, r_length(cnd) - 1); r_attrib_poke_names(cnd, KEEP(new_condition_names(data))); r_attrib_poke_class(cnd, KEEP(chr_append(class, KEEP(r_str("condition"))))); if (Rf_any_duplicated(r_names(cnd), FALSE)) { r_abort("Condition fields can't have the same name."); } FREE(4); return cnd; } static r_obj* new_condition_names(r_obj* data) { if (!r_is_named(data)) { r_abort("Conditions must have named data fields"); } r_obj* data_nms = r_names(data); if (r_chr_has_any(data_nms, (const char* []) { "message", NULL })) { r_abort("Conditions can't have a `message` data field"); } r_obj* nms = KEEP(r_alloc_character(r_length(data) + 1)); r_chr_poke(nms, 0, r_str("message")); r_vec_poke_n(nms, 1, data_nms, 0, r_length(nms) - 1); FREE(1); return nms; } // `length` is no longer a valid argument const char* rlang_obj_type_friendly_full(r_obj* x, bool value, bool _length) { r_obj* out_obj = KEEP(r_eval_with_xy(obj_type_friendly_call, x, r_lgl(value), rlang_ns_env)); if (!r_is_string(out_obj)) { r_stop_unexpected_type(r_typeof(out_obj)); } const char* out_str = r_chr_get_c_string(out_obj, 0); // Uses the vmax protection stack. int n = strlen(out_str) + 1; char* out = R_alloc(n, sizeof(char)); memcpy(out, out_str, n); FREE(1); return out; } void rlang_init_cnd(r_obj* ns) { format_arg_call = r_parse("format_arg(x)"); r_preserve(format_arg_call); obj_type_friendly_call = r_parse("obj_type_friendly(x, y)"); r_preserve(obj_type_friendly_call); } static r_obj* format_arg_call = NULL; static r_obj* obj_type_friendly_call = NULL; rlang/src/internal/env-binding.c0000644000176200001440000001764414741441060016341 0ustar liggesusers#include #include "internal.h" #include "decl/env-decl.h" r_obj* ffi_env_get(r_obj* env, r_obj* nm, r_obj* inherit, r_obj* last, r_obj* closure_env) { if (r_typeof(env) != R_TYPE_environment) { r_abort("`env` must be an environment."); } if (!r_is_string(nm)) { r_abort("`nm` must be a string."); } if (!r_is_bool(inherit)) { r_abort("`inherit` must be a logical value."); } bool c_inherit = r_lgl_get(inherit, 0); r_obj* sym = r_str_as_symbol(r_chr_get(nm, 0)); return env_get_sym(env, sym, c_inherit, last, closure_env); } static r_obj* env_get_sym(r_obj* env, r_obj* sym, bool inherit, r_obj* last, r_obj* closure_env) { if (r_typeof(last) != R_TYPE_environment) { r_abort("`last` must be an environment."); } r_obj* out; if (inherit) { if (last == r_null) { out = r_env_find_anywhere(env, sym); } else { out = r_env_find_until(env, sym, last); } } else { out = r_env_find(env, sym); } if (r_typeof(out) == R_TYPE_promise) { KEEP(out); out = r_eval(out, r_envs.empty); FREE(1); } if (out == r_syms.unbound) { if (r_env_find(closure_env, r_sym("default")) == r_missing_arg) { struct r_pair args[] = { { r_sym("nm"), KEEP(r_str_as_character(r_sym_string(sym))) } }; r_exec_n(r_null, r_sym("stop_env_get_missing"), args, R_ARR_SIZEOF(args), closure_env); r_stop_unreachable(); } out = r_eval(r_sym("default"), closure_env); } return out; } r_obj* ffi_env_get_list(r_obj* env, r_obj* nms, r_obj* inherit, r_obj* last, r_obj* closure_env) { if (r_typeof(env) != R_TYPE_environment) { r_abort("`env` must be an environment."); } if (r_typeof(nms) != R_TYPE_character) { r_abort("`nm` must be a string."); } if (!r_is_bool(inherit)) { r_abort("`inherit` must be a logical value."); } bool c_inherit = r_lgl_get(inherit, 0); r_ssize n = r_length(nms); r_obj* out = KEEP(r_alloc_list(n)); r_attrib_poke_names(out, nms); r_obj* const * p_nms = r_chr_cbegin(nms); for (r_ssize i = 0; i #include FILE* r_fopen(r_obj* path, const char* mode); #endif rlang/src/internal/call.c0000644000176200001440000001250714741441060015045 0ustar liggesusers#include #include "internal.h" #include "decl/call-decl.h" r_obj* ffi_is_call(r_obj* x, r_obj* name, r_obj* ffi_n, r_obj* ns) { if (r_typeof(x) != R_TYPE_call) { return r_false; } if (ns != r_null) { if (!is_character(ns, -1, OPTION_BOOL_false, OPTION_BOOL_null)) { r_abort("`ns` must be a character vector of namespaces."); } bool found = false; r_obj* const * v_ns = r_chr_cbegin(ns); r_ssize ns_len = r_length(ns); for (r_ssize i = 0; i < ns_len; ++i) { r_obj* elt = v_ns[i]; if ((elt == r_strs.empty && !call_is_namespaced(x, r_null)) || call_is_namespaced(x, elt)) { found = true; break; } } if (!found) { return r_false; } } x = KEEP(call_unnamespace(x)); if (name != r_null) { r_obj* fn = r_node_car(x); if (r_typeof(fn) != R_TYPE_symbol) { FREE(1); return r_false; } switch (r_typeof(name)) { case R_TYPE_symbol: if (fn == name) { goto found_name; } FREE(1); return r_false; // List of symbols case R_TYPE_list: { r_obj* const * v_name = r_list_cbegin(name); r_ssize name_len = r_length(name); for (r_ssize i = 0; i < name_len; ++i) { if (fn == v_name[i]) { goto found_name; } } FREE(1); return r_false; } default: break; } if (!is_character(name, -1, OPTION_BOOL_false, OPTION_BOOL_false)) { r_abort("`name` must be a character vector of names."); } fn = r_sym_string(fn); r_obj* const * v_name = r_chr_cbegin(name); r_ssize name_len = r_length(name); for (r_ssize i = 0; i < name_len; ++i) { if (fn == v_name[i]) { goto found_name; } } FREE(1); return r_false; } found_name: if (ffi_n != r_null) { r_ssize n = validate_n(ffi_n); if (!_r_has_correct_length(r_node_cdr(x), n)) { FREE(1); return r_false; } } FREE(1); return r_true; } static bool call_is_namespaced(r_obj* x, r_obj* ns) { if (r_typeof(x) != R_TYPE_call) { return(false); } r_obj* car = r_node_car(x); if (r_typeof(car) != R_TYPE_call) { return(false); } if (ns != r_null) { r_obj* arg = r_node_cadr(car); if (r_typeof(arg) != R_TYPE_symbol || r_sym_string(arg) != ns) { return false; } } return r_node_car(car) == r_syms.colon2; } static inline r_obj* call_unnamespace(r_obj* x) { if (call_is_namespaced(x, r_null)) { return r_new_call(r_node_cadr(r_node_cdar(x)), r_node_cdr(x)); } else { return x; } } r_obj* rlang_call2(r_obj* fn, r_obj* args, r_obj* ns) { if (r_typeof(fn) == R_TYPE_character) { if (r_length(fn) != 1) { r_abort("`.fn` must be a string, a symbol, a call, or a function"); } fn = r_sym(r_chr_get_c_string(fn, 0)); } else if (!is_callable(fn)) { r_abort("Can't create call to non-callable object"); } int n_kept = 0; if (ns != r_null) { if (!r_is_string(ns)) { r_abort("`ns` must be a string"); } if (r_typeof(fn) != R_TYPE_symbol) { r_abort("`fn` must be a string or symbol when a namespace is supplied"); } ns = r_sym(r_chr_get_c_string(ns, 0)); fn = KEEP_N(r_call3(r_syms.colon2, ns, fn), &n_kept); } r_obj* out = r_new_call(fn, args); FREE(n_kept); return out; } r_obj* ffi_call2(r_obj* call, r_obj* op, r_obj* args, r_obj* env) { args = r_node_cdr(args); r_obj* fn = KEEP(r_eval(r_sym(".fn"), env)); r_obj* ns = KEEP(r_eval(r_sym(".ns"), env)); r_obj* dots = KEEP(rlang_dots(env)); r_obj* out = rlang_call2(fn, dots, ns); FREE(3); return out; } static bool is_callable(r_obj* x) { switch (r_typeof(x)) { case R_TYPE_symbol: case R_TYPE_call: case R_TYPE_closure: case R_TYPE_builtin: case R_TYPE_special: return true; default: return false; } } r_obj* ffi_call_zap_inline(r_obj* x) { if (r_typeof(x) == R_TYPE_call) { r_obj* out = KEEP(r_call_clone(x)); call_zap_inline(out); FREE(1); return out; } else { return call_zap_one(x); } } static void call_zap_inline(r_obj* x) { if (r_node_car(x) == r_syms.function) { call_zap_fn(x); } else { node_zap_inline(x); } } static void node_zap_inline(r_obj* x) { while (x != r_null) { r_node_poke_car(x, call_zap_one(r_node_car(x))); x = r_node_cdr(x); } } static void call_zap_fn(r_obj* x) { // Formals x = r_node_cdr(x); node_zap_inline(r_node_car(x)); // Body x = r_node_cdr(x); r_node_poke_car(x, call_zap_one(r_node_car(x))); // Zap srcref x = r_node_cdr(x); r_node_poke_car(x, r_null); } static r_obj* call_zap_one(r_obj* x) { switch (r_typeof(x)) { case R_TYPE_call: call_zap_inline(x); return x; case R_TYPE_null: case R_TYPE_symbol: return x; // Syntactic literals case R_TYPE_logical: case R_TYPE_integer: case R_TYPE_double: case R_TYPE_character: case R_TYPE_complex: // Not entirely correct for complex if (r_attrib(x) == r_null && r_length(x) == 1) { return x; } else { return type_sum(x); } default: return type_sum(x); } } static r_obj* type_sum(r_obj* x) { return r_eval_with_x(type_sum_call, x, rlang_ns_env); } void rlang_init_call(r_obj* ns) { type_sum_call = r_parse("call_type_sum(x)"); r_preserve_global(type_sum_call); } static r_obj* type_sum_call = NULL; rlang/src/internal/utils.h0000644000176200001440000000201414376147516015304 0ustar liggesusers#ifndef RLANG_INTERNAL_UTILS_H #define RLANG_INTERNAL_UTILS_H #include r_obj* new_preserved_empty_list(void); r_obj* rlang_ns_get(const char* name); r_obj* ffi_enquo(r_obj* sym, r_obj* frame); extern r_obj* rlang_ns_env; void deprecate_soft(const char* msg, const char* id, r_obj* env); void deprecate_warn(const char* id, const char* fmt, ...); void deprecate_stop(const char* fmt, ...); bool r_is_prefixed_call(r_obj* x, const char* name); bool r_is_namespaced_call(r_obj* x, const char* ns, const char* name); bool r_is_namespaced_call_any(r_obj* x, const char* ns, const char** names, int n); static inline r_obj* r_nms_get(r_obj* nms, r_ssize i) { if (nms == r_null) { return r_strs.empty; } else { return r_chr_get(nms, i); } } r_obj* nms_are_duplicated(r_obj* nms, bool from_last); bool vec_find_first_duplicate(r_obj* x, r_obj* except, r_ssize* index); static inline r_obj* r_vec_coerce(r_obj* x, enum r_type to) { return Rf_coerceVector(x, to); } r_obj* chr_detect_dups(r_obj* x); #endif rlang/src/internal/internal.c0000644000176200001440000000364514741441060015751 0ustar liggesusers#include #include "internal.h" #include "globals.c" #include "arg.c" #include "attr.c" #include "call.c" #include "cnd.c" #include "cnd-handlers.c" #include "dots.c" #include "dots-ellipsis.c" #include "encoding.c" #include "env.c" #include "env-binding.c" #include "eval.c" #include "eval-tidy.c" #include "exported.c" #include "nse-inject.c" #include "ast-rotate.c" #include "file.c" #include "fn.c" #include "hash.c" #include "names.c" #include "nse-defuse.c" #include "parse.c" #include "quo.c" #include "replace-na.c" #include "squash.c" #include "standalone-types-check.c" #include "sym-unescape.c" #include "tests.c" #include "utils.c" #include "vec.c" #include "vec-raw.c" #include "weakref.c" #include "init.c" struct rlang_globals_syms rlang_syms; r_obj* rlang_zap = NULL; r_obj* rlang_as_list_call = NULL; r_obj* rlang_objs_keep = NULL; r_obj* rlang_objs_trailing = NULL; r_obj* fns_function = NULL; r_obj* fns_quote = NULL; void rlang_init_internal(r_obj* ns) { rlang_init_globals(ns); rlang_init_utils(); rlang_init_arg(ns); rlang_init_attr(ns); rlang_init_call(ns); rlang_init_cnd(ns); rlang_init_cnd_handlers(ns); rlang_init_dots(ns); rlang_init_expr_interp(); rlang_init_eval_tidy(); rlang_init_fn(); rlang_init_tests(); rlang_syms.c_null = r_sym(".__C_NULL__."); rlang_syms.handlers = r_sym("handlers"); rlang_syms.tryCatch = r_sym("tryCatch"); rlang_syms.withCallingHandlers = r_sym("withCallingHandlers"); rlang_zap = rlang_ns_get("zap!"); rlang_as_list_call = r_parse("rlang_as_list(x)"); r_preserve(rlang_as_list_call); rlang_objs_keep = r_chr("keep"); r_preserve(rlang_objs_keep); rlang_objs_trailing = r_chr("trailing"); r_preserve(rlang_objs_trailing); fns_function = r_eval(r_sym("function"), r_envs.base); fns_quote = r_eval(r_sym("quote"), r_envs.base); /* dots.c - enum dots_op */ RLANG_ASSERT(DOTS_OP_MAX == DOTS_COLLECT_MAX * INJECTION_OP_MAX); } rlang/src/internal/init.c0000644000176200001440000005220314741441060015072 0ustar liggesusers#include #include #include // Library initialisation defined below static r_obj* ffi_init_rlang(r_obj*); static r_obj* ffi_fini_rlang(void); // From version.c extern r_obj* rlang_linked_version(void); static const R_CallMethodDef r_callables[] = { {"ffi_alloc_data_frame", (DL_FUNC) &ffi_alloc_data_frame, 3}, {"ffi_as_data_mask", (DL_FUNC) &ffi_as_data_mask, 1}, {"ffi_as_data_pronoun", (DL_FUNC) &ffi_as_data_pronoun, 1}, {"ffi_attrib", (DL_FUNC) &r_attrib, 1}, {"ffi_c_tests", (DL_FUNC) &ffi_c_tests, 0}, {"ffi_call_has_precedence", (DL_FUNC) &ffi_call_has_precedence, 3}, {"ffi_call_zap_inline", (DL_FUNC) &ffi_call_zap_inline, 1}, {"ffi_chr_get", (DL_FUNC) &ffi_chr_get, 2}, {"ffi_chr_has_curly", (DL_FUNC) &ffi_chr_has_curly, 1}, {"ffi_cnd_signal", (DL_FUNC) &ffi_cnd_signal, 1}, {"ffi_cnd_type", (DL_FUNC) &ffi_cnd_type, 1}, {"ffi_compiled_by_gcc", (DL_FUNC) &ffi_compiled_by_gcc, 0}, {"ffi_data_mask_clean", (DL_FUNC) &ffi_data_mask_clean, 1}, {"ffi_data_pronoun_get", (DL_FUNC) &ffi_data_pronoun_get, 3}, {"ffi_dict_as_df_list", (DL_FUNC) &ffi_dict_as_df_list, 1}, {"ffi_dict_as_list", (DL_FUNC) &ffi_dict_as_list, 1}, {"ffi_dict_del", (DL_FUNC) &ffi_dict_del, 2}, {"ffi_dict_get", (DL_FUNC) &ffi_dict_get, 2}, {"ffi_dict_has", (DL_FUNC) &ffi_dict_has, 2}, {"ffi_dict_it_info", (DL_FUNC) &ffi_dict_it_info, 1}, {"ffi_dict_next", (DL_FUNC) &ffi_dict_it_next, 1}, {"ffi_dict_poke", (DL_FUNC) &ffi_dict_poke, 3}, {"ffi_dict_put", (DL_FUNC) &ffi_dict_put, 3}, {"ffi_dict_resize", (DL_FUNC) &ffi_dict_resize, 2}, {"ffi_dots_flat_list", (DL_FUNC) &ffi_dots_flat_list, 7}, {"ffi_dots_list", (DL_FUNC) &ffi_dots_list, 7}, {"ffi_dots_pairlist", (DL_FUNC) &ffi_dots_pairlist, 7}, {"ffi_duplicate", (DL_FUNC) &ffi_duplicate, 2}, {"ffi_dyn_chr_get", (DL_FUNC) &ffi_dyn_chr_get, 2}, {"ffi_dyn_chr_poke", (DL_FUNC) &ffi_dyn_chr_poke, 3}, {"ffi_dyn_chr_push_back", (DL_FUNC) &ffi_dyn_chr_push_back, 2}, {"ffi_dyn_cpl_get", (DL_FUNC) &ffi_dyn_cpl_get, 2}, {"ffi_dyn_cpl_poke", (DL_FUNC) &ffi_dyn_cpl_poke, 3}, {"ffi_dyn_cpl_push_back", (DL_FUNC) &ffi_dyn_cpl_push_back, 2}, {"ffi_dyn_dbl_get", (DL_FUNC) &ffi_dyn_dbl_get, 2}, {"ffi_dyn_dbl_poke", (DL_FUNC) &ffi_dyn_dbl_poke, 3}, {"ffi_dyn_dbl_push_back", (DL_FUNC) &ffi_dyn_dbl_push_back, 2}, {"ffi_dyn_info", (DL_FUNC) &ffi_dyn_info, 1}, {"ffi_dyn_int_get", (DL_FUNC) &ffi_dyn_int_get, 2}, {"ffi_dyn_int_poke", (DL_FUNC) &ffi_dyn_int_poke, 3}, {"ffi_dyn_int_push_back", (DL_FUNC) &ffi_dyn_int_push_back, 2}, {"ffi_dyn_lgl_get", (DL_FUNC) &ffi_dyn_lgl_get, 2}, {"ffi_dyn_lgl_poke", (DL_FUNC) &ffi_dyn_lgl_poke, 3}, {"ffi_dyn_lgl_push_back", (DL_FUNC) &ffi_dyn_lgl_push_back, 2}, {"ffi_dyn_list_get", (DL_FUNC) &ffi_dyn_list_get, 2}, {"ffi_dyn_list_poke", (DL_FUNC) &ffi_dyn_list_poke, 3}, {"ffi_dyn_list_push_back", (DL_FUNC) &ffi_dyn_list_push_back, 2}, {"ffi_dyn_pop_back", (DL_FUNC) &ffi_dyn_pop_back, 1}, {"ffi_dyn_push_back", (DL_FUNC) &ffi_dyn_push_back, 2}, {"ffi_dyn_push_back_bool", (DL_FUNC) &ffi_dyn_push_back_bool, 2}, {"ffi_dyn_raw_get", (DL_FUNC) &ffi_dyn_raw_get, 2}, {"ffi_dyn_raw_poke", (DL_FUNC) &ffi_dyn_raw_poke, 3}, {"ffi_dyn_raw_push_back", (DL_FUNC) &ffi_dyn_raw_push_back, 2}, {"ffi_dyn_resize", (DL_FUNC) &ffi_dyn_resize, 2}, {"ffi_dyn_unwrap", (DL_FUNC) &ffi_dyn_unwrap, 1}, {"ffi_ellipsis_dots", (DL_FUNC) &ffi_ellipsis_dots, 1}, {"ffi_ellipsis_dots_used", (DL_FUNC) &ffi_ellipsis_dots_used, 1}, {"ffi_ellipsis_promise_forced", (DL_FUNC) &ffi_ellipsis_promise_forced, 1}, {"ffi_enexpr", (DL_FUNC) &ffi_enexpr, 2}, {"ffi_enquo", (DL_FUNC) &ffi_enquo, 2}, {"ffi_ensym", (DL_FUNC) &ffi_ensym, 2}, {"ffi_env_bind", (DL_FUNC) &ffi_env_bind, 5}, {"ffi_env_bind_list", (DL_FUNC) &ffi_env_bind_list, 3}, {"ffi_env_binding_types", (DL_FUNC) &r_env_binding_types, 2}, {"ffi_env_browse", (DL_FUNC) &ffi_env_browse, 2}, {"ffi_env_clone", (DL_FUNC) &r_env_clone, 2}, {"ffi_env_coalesce", (DL_FUNC) &ffi_env_coalesce, 2}, {"ffi_env_frame", (DL_FUNC) &ffi_env_frame, 1}, {"ffi_env_get", (DL_FUNC) &ffi_env_get, 5}, {"ffi_env_get_list", (DL_FUNC) &ffi_env_get_list, 5}, {"ffi_env_has", (DL_FUNC) &ffi_env_has, 3}, {"ffi_env_hash_table", (DL_FUNC) &ffi_env_hash_table, 1}, {"ffi_env_inherits", (DL_FUNC) &ffi_env_inherits, 2}, {"ffi_env_is_browsed", (DL_FUNC) &ffi_env_is_browsed, 1}, {"ffi_env_poke", (DL_FUNC) &ffi_env_poke, 5}, {"ffi_env_poke_parent", (DL_FUNC) &ffi_env_poke_parent, 2}, {"ffi_env_unbind", (DL_FUNC) &ffi_env_unbind, 3}, {"ffi_env_unlock", (DL_FUNC) &ffi_env_unlock, 1}, {"ffi_eval_top", (DL_FUNC) &ffi_eval_top, 2}, {"ffi_exprs_interp", (DL_FUNC) &ffi_exprs_interp, 6}, {"ffi_f_lhs", (DL_FUNC) &r_f_lhs, 1}, {"ffi_f_rhs", (DL_FUNC) &r_f_rhs, 1}, {"ffi_find_var", (DL_FUNC) &ffi_find_var, 2}, {"ffi_find_var_in_frame", (DL_FUNC) &ffi_find_var_in_frame, 2}, {"ffi_fini_rlang", (DL_FUNC) &ffi_fini_rlang, 0}, {"ffi_format_error_arg", (DL_FUNC) &ffi_format_error_arg, 1}, {"ffi_get_expression", (DL_FUNC) &ffi_get_expression, 2}, {"ffi_getppid", (DL_FUNC) &ffi_getppid, 0}, {"ffi_glue_is_here", (DL_FUNC) &ffi_glue_is_here, 0}, {"ffi_has_dots_unnamed", (DL_FUNC) &ffi_has_dots_unnamed, 1}, {"ffi_has_local_precious_list", (DL_FUNC) &ffi_has_local_precious_list, 0}, {"ffi_has_size_one_bool", (DL_FUNC) &ffi_has_size_one_bool, 0}, {"ffi_hash", (DL_FUNC) &ffi_hash, 1}, {"ffi_hash_file", (DL_FUNC) &ffi_hash_file, 1}, {"ffi_hasher_init", (DL_FUNC) &ffi_hasher_init, 0}, {"ffi_hasher_update", (DL_FUNC) &ffi_hasher_update, 2}, {"ffi_hasher_value", (DL_FUNC) &ffi_hasher_value, 1}, {"ffi_init_r_library", (DL_FUNC) &r_init_library, 1}, {"ffi_init_rlang", (DL_FUNC) &ffi_init_rlang, 1}, {"ffi_interp", (DL_FUNC) &ffi_interp, 2}, {"ffi_interrupt", (DL_FUNC) &ffi_interrupt, 0}, {"ffi_is_atomic", (DL_FUNC) &ffi_is_atomic, 2}, {"ffi_is_call", (DL_FUNC) &ffi_is_call, 4}, {"ffi_is_character", (DL_FUNC) &ffi_is_character, 4}, {"ffi_is_closure", (DL_FUNC) &ffi_is_closure, 1}, {"ffi_is_complex", (DL_FUNC) &ffi_is_complex, 3}, {"ffi_is_data_mask", (DL_FUNC) &ffi_is_data_mask, 1}, {"ffi_is_double", (DL_FUNC) &ffi_is_double, 3}, {"ffi_is_finite", (DL_FUNC) &ffi_is_finite, 1}, {"ffi_is_formula", (DL_FUNC) &ffi_is_formula, 3}, {"ffi_is_function", (DL_FUNC) &ffi_is_function, 1}, {"ffi_is_integer", (DL_FUNC) &ffi_is_integer, 2}, {"ffi_is_integerish", (DL_FUNC) &ffi_is_integerish, 3}, {"ffi_is_list", (DL_FUNC) &ffi_is_list, 2}, {"ffi_is_logical", (DL_FUNC) &ffi_is_logical, 2}, {"ffi_is_primitive", (DL_FUNC) &ffi_is_primitive, 1}, {"ffi_is_primitive_eager", (DL_FUNC) &ffi_is_primitive_eager, 1}, {"ffi_is_primitive_lazy", (DL_FUNC) &ffi_is_primitive_lazy, 1}, {"ffi_is_raw", (DL_FUNC) &ffi_is_raw, 2}, {"ffi_is_reference", (DL_FUNC) &ffi_is_reference, 2}, {"ffi_is_splice_box", (DL_FUNC) &ffi_is_splice_box, 1}, {"ffi_is_string", (DL_FUNC) &ffi_is_string, 3}, {"ffi_is_vector", (DL_FUNC) &ffi_is_vector, 2}, {"ffi_is_weakref", (DL_FUNC) &ffi_is_weakref, 1}, {"ffi_length", (DL_FUNC) &ffi_length, 1}, {"ffi_list_compact", (DL_FUNC) &r_list_compact, 1}, {"ffi_list_poke", (DL_FUNC) &ffi_list_poke, 3}, {"ffi_lof_arr_push_back", (DL_FUNC) &ffi_lof_arr_push_back, 3}, {"ffi_lof_info", (DL_FUNC) &ffi_lof_info, 1}, {"ffi_lof_push_back", (DL_FUNC) &ffi_lof_push_back, 1}, {"ffi_lof_unwrap", (DL_FUNC) &ffi_lof_unwrap, 1}, {"ffi_mark_object", (DL_FUNC) &ffi_mark_object, 1}, {"ffi_missing_arg", (DL_FUNC) &ffi_missing_arg, 0}, {"ffi_named", (DL_FUNC) &ffi_named, 2}, {"ffi_names2", (DL_FUNC) &ffi_names2, 2}, {"ffi_names_as_unique", (DL_FUNC) &ffi_names_as_unique, 2}, {"ffi_new_call", (DL_FUNC) &ffi_new_call_node, 2}, {"ffi_new_condition", (DL_FUNC) &ffi_new_condition, 3}, {"ffi_new_data_mask", (DL_FUNC) &ffi_new_data_mask, 2}, {"ffi_new_dict", (DL_FUNC) &ffi_new_dict, 2}, {"ffi_new_dict_iterator", (DL_FUNC) &ffi_new_dict_iterator, 1}, {"ffi_new_dyn_array", (DL_FUNC) &ffi_new_dyn_array, 2}, {"ffi_new_dyn_list_of", (DL_FUNC) &ffi_new_dyn_list_of, 3}, {"ffi_new_dyn_vector", (DL_FUNC) &ffi_new_dyn_vector, 2}, {"ffi_new_formula", (DL_FUNC) &r_new_formula, 3}, {"ffi_new_function", (DL_FUNC) &ffi_new_function, 3}, {"ffi_new_node", (DL_FUNC) &r_new_node, 2}, {"ffi_new_quosure", (DL_FUNC) &ffi_new_quosure, 2}, {"ffi_new_splice_box", (DL_FUNC) &new_splice_box, 1}, {"ffi_new_weakref", (DL_FUNC) &ffi_new_weakref, 4}, {"ffi_nms_are_duplicated", (DL_FUNC) &ffi_test_nms_are_duplicated, 2}, {"ffi_node_caar", (DL_FUNC) &ffi_node_caar, 1}, {"ffi_node_cadr", (DL_FUNC) &ffi_node_cadr, 1}, {"ffi_node_car", (DL_FUNC) &ffi_node_car, 1}, {"ffi_node_cdar", (DL_FUNC) &ffi_node_cdar, 1}, {"ffi_node_cddr", (DL_FUNC) &ffi_node_cddr, 1}, {"ffi_node_cdr", (DL_FUNC) &ffi_node_cdr, 1}, {"ffi_node_poke_caar", (DL_FUNC) &ffi_node_poke_caar, 2}, {"ffi_node_poke_cadr", (DL_FUNC) &ffi_node_poke_cadr, 2}, {"ffi_node_poke_car", (DL_FUNC) &ffi_node_poke_car, 2}, {"ffi_node_poke_cdar", (DL_FUNC) &ffi_node_poke_cdar, 2}, {"ffi_node_poke_cddr", (DL_FUNC) &ffi_node_poke_cddr, 2}, {"ffi_node_poke_cdr", (DL_FUNC) &ffi_node_poke_cdr, 2}, {"ffi_node_poke_tag", (DL_FUNC) &ffi_node_poke_tag, 2}, {"ffi_node_tag", (DL_FUNC) &ffi_node_tag, 1}, {"ffi_node_tree_clone", (DL_FUNC) &r_node_tree_clone, 1}, {"ffi_ns_registry_env", (DL_FUNC) &ffi_ns_registry_env, 0}, {"ffi_obj_address", (DL_FUNC) &ffi_obj_address, 1}, {"ffi_pairlist_rev", (DL_FUNC) &r_pairlist_rev, 1}, {"ffi_peek_srcref", (DL_FUNC) &ffi_peek_srcref, 0}, {"ffi_poke_attrib", (DL_FUNC) &r_poke_attrib, 2}, {"ffi_poke_type", (DL_FUNC) &ffi_poke_type, 2}, {"ffi_precious_dict", (DL_FUNC) &ffi_precious_dict, 0}, {"ffi_preserve", (DL_FUNC) &ffi_preserve, 1}, {"ffi_promise_env", (DL_FUNC) &ffi_promise_env, 2}, {"ffi_promise_expr", (DL_FUNC) &ffi_promise_expr, 2}, {"ffi_promise_value", (DL_FUNC) &ffi_promise_value, 2}, {"ffi_quo_get_env", (DL_FUNC) &ffi_quo_get_env, 1}, {"ffi_quo_get_expr", (DL_FUNC) &ffi_quo_get_expr, 1}, {"ffi_quo_is_call", (DL_FUNC) &ffi_quo_is_call, 1}, {"ffi_quo_is_missing", (DL_FUNC) &ffi_quo_is_missing, 1}, {"ffi_quo_is_null", (DL_FUNC) &ffi_quo_is_null, 1}, {"ffi_quo_is_symbol", (DL_FUNC) &ffi_quo_is_symbol, 1}, {"ffi_quo_is_symbolic", (DL_FUNC) &ffi_quo_is_symbolic, 1}, {"ffi_quo_set_env", (DL_FUNC) &ffi_quo_set_env, 2}, {"ffi_quo_set_expr", (DL_FUNC) &ffi_quo_set_expr, 2}, {"ffi_quos_interp", (DL_FUNC) &ffi_quos_interp, 6}, {"ffi_r_string", (DL_FUNC) &ffi_r_string, 1}, {"ffi_raw_deparse_str", (DL_FUNC) &ffi_raw_deparse_str, 3}, {"ffi_replace_na", (DL_FUNC) &ffi_replace_na, 2}, {"ffi_run_c_test", (DL_FUNC) &ffi_run_c_test, 1}, {"ffi_set_names", (DL_FUNC) &ffi_set_names, 4}, {"ffi_sexp_iterate", (DL_FUNC) &ffi_sexp_iterate, 2}, {"ffi_squash", (DL_FUNC) &ffi_squash, 4}, {"ffi_standalone_check_number_1.0.7", (DL_FUNC) &ffi_standalone_check_number, 7}, {"ffi_standalone_is_bool_1.0.7", (DL_FUNC) &ffi_standalone_is_bool, 3}, {"ffi_sym_as_character", (DL_FUNC) &ffi_sym_as_character, 1}, {"ffi_symbol", (DL_FUNC) &ffi_symbol, 1}, {"ffi_test_Rf_error", (DL_FUNC) &ffi_test_Rf_error, 1}, {"ffi_test_Rf_errorcall", (DL_FUNC) &ffi_test_Rf_errorcall, 2}, {"ffi_test_Rf_warning", (DL_FUNC) &ffi_test_Rf_warning, 1}, {"ffi_test_Rf_warningcall", (DL_FUNC) &ffi_test_Rf_warningcall, 2}, {"ffi_test_attrib_set", (DL_FUNC) &r_attrib_set, 3}, {"ffi_test_base_ns_get", (DL_FUNC) &ffi_test_base_ns_get, 1}, {"ffi_test_chr_append", (DL_FUNC) &chr_append, 2}, {"ffi_test_chr_prepend", (DL_FUNC) &chr_prepend, 2}, {"ffi_test_current_frame", (DL_FUNC) &r_peek_frame, 0}, {"ffi_test_lgl_sum", (DL_FUNC) &ffi_test_lgl_sum, 2}, {"ffi_test_lgl_which", (DL_FUNC) &ffi_test_lgl_which, 2}, {"ffi_test_node_list_clone_until", (DL_FUNC) &ffi_test_node_list_clone_until, 2}, {"ffi_test_obj_encode_utf8", (DL_FUNC) &obj_encode_utf8, 1}, {"ffi_test_parse", (DL_FUNC) &ffi_test_parse, 1}, {"ffi_test_parse_eval", (DL_FUNC) &ffi_test_parse_eval, 2}, {"ffi_test_r_on_exit", (DL_FUNC) &r_on_exit, 2}, {"ffi_test_r_warn", (DL_FUNC) &ffi_test_r_warn, 1}, {"ffi_test_stop_internal", (DL_FUNC) &ffi_test_stop_internal, 1}, {"ffi_test_sys_call", (DL_FUNC) &ffi_test_sys_call, 1}, {"ffi_test_sys_frame", (DL_FUNC) &ffi_test_sys_frame, 1}, {"ffi_true_length", (DL_FUNC) &ffi_true_length, 1}, {"ffi_unescape_character", (DL_FUNC) &ffi_unescape_character, 1}, {"ffi_unmark_object", (DL_FUNC) &ffi_unmark_object, 1}, {"ffi_unpreserve", (DL_FUNC) &ffi_unpreserve, 1}, {"ffi_use_local_precious_list", (DL_FUNC) &ffi_use_local_precious_list, 1}, {"ffi_vec_alloc", (DL_FUNC) &ffi_vec_alloc, 2}, {"ffi_vec_coerce", (DL_FUNC) &ffi_vec_coerce, 2}, {"ffi_vec_poke_n", (DL_FUNC) &ffi_vec_poke_n, 5}, {"ffi_vec_poke_range", (DL_FUNC) &ffi_vec_poke_range, 5}, {"ffi_vec_resize", (DL_FUNC) &ffi_vec_resize, 2}, {"ffi_which_operator", (DL_FUNC) &ffi_which_operator, 1}, {"ffi_wref_key", (DL_FUNC) &ffi_wref_key, 1}, {"ffi_wref_value", (DL_FUNC) &ffi_wref_value, 1}, {"ffi_zap_srcref", (DL_FUNC) &zap_srcref, 1}, {"rlang_linked_version", (DL_FUNC) &rlang_linked_version, 0}, {NULL, NULL, 0} }; static const R_ExternalMethodDef externals[] = { {"ffi_arg_match0", (DL_FUNC) &ffi_arg_match0, 3}, {"ffi_call2", (DL_FUNC) &ffi_call2, 2}, {"ffi_capturearginfo", (DL_FUNC) &ffi_capturearginfo, 2}, {"ffi_capturedots", (DL_FUNC) &ffi_capturedots, 1}, {"ffi_dots_values", (DL_FUNC) &ffi_dots_values, 7}, {"ffi_eval", (DL_FUNC) &ffi_eval, 2}, {"ffi_eval_tidy", (DL_FUNC) &ffi_eval_tidy, 3}, {"ffi_exec", (DL_FUNC) &ffi_exec, 2}, {"ffi_tilde_eval", (DL_FUNC) &ffi_tilde_eval, 3}, {"ffi_try_fetch", (DL_FUNC) &ffi_try_fetch, 1}, {NULL, NULL, 0} }; const struct r_test tests[] = { { "TRUE is TRUE", &test_that_true_is_true }, { "FALSE is FALSE", &test_that_false_is_false }, { NULL, NULL } }; // From xxhash.h extern uint64_t XXH3_64bits(const void*, size_t); r_visible void R_init_rlang(DllInfo* dll) { R_RegisterCCallable("rlang", "rlang_arg_match", (DL_FUNC) &arg_match_legacy); R_RegisterCCallable("rlang", "rlang_arg_match_2", (DL_FUNC) &cci_arg_match); R_RegisterCCallable("rlang", "rlang_as_data_mask_3.0.0", (DL_FUNC) &ffi_as_data_mask); R_RegisterCCallable("rlang", "rlang_as_data_pronoun", (DL_FUNC) &ffi_as_data_pronoun); R_RegisterCCallable("rlang", "rlang_env_unbind", (DL_FUNC) &r_env_unbind); R_RegisterCCallable("rlang", "rlang_eval_tidy", (DL_FUNC) &rlang_eval_tidy); R_RegisterCCallable("rlang", "rlang_format_error_arg", (DL_FUNC) &rlang_format_error_arg); R_RegisterCCallable("rlang", "rlang_is_quosure", (DL_FUNC) &is_quosure); R_RegisterCCallable("rlang", "rlang_names_as_unique", (DL_FUNC) &names_as_unique); R_RegisterCCallable("rlang", "rlang_new_data_mask_3.0.0", (DL_FUNC) &ffi_new_data_mask); R_RegisterCCallable("rlang", "rlang_new_quosure", (DL_FUNC) &ffi_new_quosure); R_RegisterCCallable("rlang", "rlang_obj_type_friendly_full", (DL_FUNC) &rlang_obj_type_friendly_full); R_RegisterCCallable("rlang", "rlang_quo_get_env", (DL_FUNC) &ffi_quo_get_env); R_RegisterCCallable("rlang", "rlang_quo_get_expr", (DL_FUNC) &ffi_quo_get_expr); R_RegisterCCallable("rlang", "rlang_quo_set_env", (DL_FUNC) &ffi_quo_set_env); R_RegisterCCallable("rlang", "rlang_quo_set_expr", (DL_FUNC) &ffi_quo_set_expr); R_RegisterCCallable("rlang", "rlang_stop_internal", (DL_FUNC) &rlang_stop_internal); R_RegisterCCallable("rlang", "rlang_stop_internal2", (DL_FUNC) &rlang_stop_internal2); r_obj* r_as_function(r_obj* x, const char* arg); R_RegisterCCallable("rlang", "rlang_as_function", (DL_FUNC) &r_as_function); R_RegisterCCallable("rlang", "rlang_xxh3_64bits", (DL_FUNC) &XXH3_64bits); // Maturing R_RegisterCCallable("rlang", "rlang_env_dots_list", (DL_FUNC) &rlang_env_dots_list); R_RegisterCCallable("rlang", "rlang_env_dots_values", (DL_FUNC) &rlang_env_dots_values); R_RegisterCCallable("rlang", "rlang_is_splice_box", (DL_FUNC) &is_splice_box); R_RegisterCCallable("rlang", "rlang_obj_encode_utf8", (DL_FUNC) &obj_encode_utf8); R_RegisterCCallable("rlang", "rlang_str_as_symbol", (DL_FUNC) &r_str_as_symbol); R_RegisterCCallable("rlang", "rlang_sym_as_character", (DL_FUNC) &ffi_sym_as_character); R_RegisterCCallable("rlang", "rlang_sym_as_string", (DL_FUNC) &ffi_sym_as_string); R_RegisterCCallable("rlang", "rlang_unbox", (DL_FUNC) &rlang_unbox); // Experimental R_RegisterCCallable("rlang", "rlang_squash_if", (DL_FUNC) &r_squash_if); // Compatibility R_RegisterCCallable("rlang", "rlang_as_data_mask", (DL_FUNC) &ffi_as_data_mask_compat); R_RegisterCCallable("rlang", "rlang_new_data_mask", (DL_FUNC) &ffi_new_data_mask_compat); // Only for debugging - no stability guaranteed R_RegisterCCallable("rlang", "rlang_print_backtrace", (DL_FUNC) &rlang_print_backtrace); R_RegisterCCallable("rlang", "rlang_env_print", (DL_FUNC) &rlang_env_print); R_registerRoutines(dll, NULL, r_callables, NULL, externals); R_useDynamicSymbols(dll, FALSE); } // From "../internal/internal.h" void rlang_init_internal(r_obj* ns); static r_obj* ffi_init_rlang(r_obj* ns) { rlang_init_internal(ns); return r_null; } static r_obj* ffi_fini_rlang(void) { return r_null; } rlang/src/internal/globals.h0000644000176200001440000000023514376112150015554 0ustar liggesusers#ifndef RLANG_INTERNAL_GLOBALS_H #define RLANG_INTERNAL_GLOBALS_H #include struct syms { r_obj* arg_nm; }; extern struct syms syms; #endif rlang/src/internal/ast-rotate.h0000644000176200001440000000136214376112150016216 0ustar liggesusers#ifndef RLANG_INTERNAL_AST_ROTATE_H #define RLANG_INTERNAL_AST_ROTATE_H #include #include "parse.h" static inline bool op_needs_fixup(enum r_operator op) { switch (op) { case R_OP_GREATER: case R_OP_GREATER_EQUAL: case R_OP_LESS: case R_OP_LESS_EQUAL: case R_OP_EQUAL: case R_OP_NOT_EQUAL: case R_OP_PLUS: case R_OP_MINUS: case R_OP_TIMES: case R_OP_RATIO: case R_OP_MODULO: case R_OP_SPECIAL: case R_OP_COLON1: case R_OP_PLUS_UNARY: case R_OP_MINUS_UNARY: return true; default: return false; } } static inline bool is_problematic_op(r_obj* x) { return op_needs_fixup(r_which_operator(x)); } r_obj* fixup_interp(r_obj* x, r_obj* env); r_obj* fixup_interp_first(r_obj* x, r_obj* env); #endif rlang/src/internal/weakref.c0000644000176200001440000000133014741441060015546 0ustar liggesusers#include #include r_obj* ffi_new_weakref(r_obj* key, r_obj* value, r_obj* finalizer, r_obj* on_quit) { if (r_typeof(key) != ENVSXP && r_typeof(key) != EXTPTRSXP) { r_abort("`key` must be an environment or external pointer"); } return R_MakeWeakRef(key, value, finalizer, r_lgl_begin(on_quit)[0]); } r_obj* ffi_wref_key(r_obj* x) { if (r_typeof(x) != WEAKREFSXP) { r_abort("`x` must be a weak reference object"); } return R_WeakRefKey(x); } r_obj* ffi_wref_value(r_obj* x) { if (r_typeof(x) != WEAKREFSXP) { r_abort("`x` must be a weak reference object"); } return R_WeakRefValue(x); } r_obj* ffi_is_weakref(r_obj* x) { return Rf_ScalarLogical(r_typeof(x) == WEAKREFSXP); } rlang/src/internal/quo.c0000644000176200001440000000375514175213516014747 0ustar liggesusers#include static const char* quo_tags[2] = { "quosure", "formula" }; r_obj* new_raw_formula(r_obj* lhs, r_obj* rhs, r_obj* env); r_obj* ffi_new_quosure(r_obj* expr, r_obj* env) { if (r_typeof(env) != R_TYPE_environment) { r_abort("`env` must be an environment"); } r_obj* quo = KEEP(new_raw_formula(r_null, expr, env)); r_attrib_push_classes(quo, quo_tags, R_ARR_SIZEOF(quo_tags)); FREE(1); return quo; } bool is_quosure(r_obj* x) { return r_typeof(x) == R_TYPE_call && r_inherits(x, "quosure"); } inline void check_quosure(r_obj* quo) { if (!is_quosure(quo)) { r_abort("`quo` must be a quosure"); } } r_obj* ffi_quo_get_expr(r_obj* quo) { check_quosure(quo); return r_node_cadr(quo); } r_obj* ffi_quo_set_expr(r_obj* quo, r_obj* expr) { check_quosure(quo); quo = r_clone(quo); r_node_poke_cadr(quo, expr); return quo; } r_obj* ffi_quo_get_env(r_obj* quo) { check_quosure(quo); return r_attrib_get(quo, r_syms.dot_environment); } r_obj* ffi_quo_set_env(r_obj* quo, r_obj* env) { check_quosure(quo); if (r_typeof(env) != R_TYPE_environment) { r_abort("`env` must be an environment"); } return r_attrib_set(quo, r_syms.dot_environment, env); } r_obj* ffi_get_expression(r_obj* x, r_obj* alternate) { switch (r_typeof(x)) { case LANGSXP: if (r_is_formula(x, -1, 0)) { return r_f_rhs(x); } break; // case CLOSXP: // return r_fn_body(x); case VECSXP: if (r_inherits(x, "frame")) { return r_list_get(x, 2); } break; default: break; } if (alternate) { return alternate; } else { return x; } } bool quo_is_missing(r_obj* quo) { return r_node_cadr(quo) == R_MissingArg; } bool quo_is_symbol(r_obj* quo) { return r_typeof(r_node_cadr(quo)) == R_TYPE_symbol; } bool quo_is_call(r_obj* quo) { return r_typeof(r_node_cadr(quo)) == R_TYPE_call; } bool quo_is_symbolic(r_obj* quo) { return r_is_symbolic(r_node_cadr(quo)); } bool quo_is_null(r_obj* quo) { return r_node_cadr(quo) == r_null; } rlang/src/internal/attr.c0000644000176200001440000001444214376112150015103 0ustar liggesusers#include #include "internal.h" #include "vec.h" #include "decl/attr-decl.h" r_obj* ffi_names2(r_obj* x, r_obj* env) { const enum r_type type = r_typeof(x); if (type == R_TYPE_environment) { r_abort("Use `env_names()` for environments."); } // Handle pairlists and language objects specially like `getAttrib()` // does. `r_names()` will not find these names because it has a guarantee // to never allocate. if (type == R_TYPE_pairlist || type == R_TYPE_call) { return node_names(x); } r_obj* nms; if (r_is_object(x)) { nms = KEEP(names_dispatch(x, env)); } else { nms = KEEP(r_names(x)); } if (nms == r_null) { r_ssize n = r_length(x); nms = KEEP(r_alloc_character(n)); r_chr_fill(nms, r_strs.empty, n); } else { nms = KEEP(ffi_replace_na(nms, r_chrs.empty_string)); } FREE(2); return nms; } static r_obj* node_names(r_obj* x) { r_ssize n = r_length(x); r_obj* out = KEEP(r_alloc_character(n)); int i = 0; for(; x != r_null; x = r_node_cdr(x), ++i) { r_obj* tag = r_node_tag(x); if (tag == r_null) { r_chr_poke(out, i, r_strs.empty); } else { r_chr_poke(out, i, PRINTNAME(tag)); } } FREE(1); return out; } r_obj* ffi_set_names(r_obj* x, r_obj* mold, r_obj* nm, r_obj* env) { int n_kept = 0; r_obj* dots = KEEP_N(rlang_dots(env), &n_kept); if (!r_is_vector(x, -1)) { r_abort("`x` must be a vector"); } if (nm == r_null) { x = set_names_dispatch(x, r_null, env); FREE(n_kept); return x; } if (r_is_function(nm) || r_is_formula(nm, -1, -1)) { if (r_names(mold) == r_null) { mold = KEEP_N(eval_as_character(mold, env), &n_kept); } else { mold = KEEP_N(ffi_names2(mold, env), &n_kept); } nm = KEEP_N(rlang_as_function(nm, env), &n_kept); nm = KEEP_N(eval_fn_dots(nm, mold, dots, env), &n_kept); } else { if (r_length(dots) > 0) { nm = KEEP_N(eval_fn_dots(c_fn, nm, dots, env), &n_kept); } nm = KEEP_N(eval_as_character(nm, env), &n_kept); } r_ssize n; if (r_is_object(x)) { n = length_dispatch(x, env); } else { n = r_length(x); } if (r_typeof(nm) != R_TYPE_character) { r_abort("`nm` must be `NULL` or a character vector."); } r_ssize nm_n = r_length(nm); if (nm_n != n) { if (nm_n != 1) { r_abort("The size of `nm` (%d) must be compatible with the size of `x` (%d).", nm_n, n); } // Recycle names vector of size 1. // TODO: ALTREP repetitions? r_obj* val = r_chr_get(nm, 0); nm = KEEP_N(r_alloc_character(n), &n_kept); r_chr_fill(nm, val, n); } if (!is_character(nm, n, OPTION_BOOL_null, OPTION_BOOL_null)) { r_abort("`nm` must be `NULL` or a character vector the same length as `x`"); } x = set_names_dispatch(x, nm, env); FREE(n_kept); return x; } static r_obj* eval_fn_dots(r_obj* fn, r_obj* x, r_obj* dots, r_obj* env) { r_obj* args = KEEP(r_new_node(r_syms.dot_x, dots)); r_obj* call = KEEP(r_new_call(r_syms.dot_fn, args)); // This evaluates `.fn(.x, ...)` // `.x` is the first input, x // `.fn` is the function, fn // The dots are a pairlist already in the call r_env_poke(env, r_syms.dot_x, x); r_env_poke(env, r_syms.dot_fn, fn); r_obj* out = r_eval(call, env); FREE(2); return out; } static inline r_obj* eval_as_character(r_obj* x, r_obj* env) { r_env_poke(env, r_syms.dot_x, x); return r_eval(as_character_call, env); } static inline r_obj* names_dispatch(r_obj* x, r_obj* env) { r_env_poke(env, r_syms.dot_x, x); return r_eval(names_call, env); } // Use `names<-()` rather than setting names directly with `r_attrib_poke_names()` // for genericity and for speed. `names<-()` can shallow duplicate `x`'s // attributes using ALTREP wrappers, which is not in R's public API. static inline r_obj* set_names_dispatch(r_obj* x, r_obj* nm, r_obj* env) { r_env_poke(env, r_syms.dot_x, x); r_env_poke(env, r_syms.dot_y, nm); return r_eval(set_names_call, env); } static inline r_ssize length_dispatch(r_obj* x, r_obj* env) { r_env_poke(env, r_syms.dot_x, x); r_obj* n = KEEP(r_eval(length_call, env)); if (r_length(n) != 1) { r_abort("Object length must have size 1, not %i", r_length(n)); } r_ssize out; switch (r_typeof(n)) { case R_TYPE_integer: out = (r_ssize) r_int_begin(n)[0]; break; case R_TYPE_double: out = r_dbl_begin(n)[0]; break; default: r_abort("Object length has unknown type %s", r_type_as_c_string(r_typeof(n))); } FREE(1); return out; } r_obj* zap_srcref(r_obj* x) { switch (r_typeof(x)) { case R_TYPE_call: return call_zap_srcref(x); case R_TYPE_closure: return fn_zap_srcref(x); case R_TYPE_expression: return expr_vec_zap_srcref(x); default: return x; } } static r_obj* fn_zap_srcref(r_obj* x) { x = KEEP(r_clone(x)); r_fn_poke_body(x, zap_srcref(r_fn_body(x))); r_attrib_poke(x, r_syms.srcref, r_null); FREE(1); return x; } static r_obj* call_zap_srcref(r_obj* x) { x = KEEP(r_clone(x)); attrib_zap_srcref(x); if (r_node_car(x) == r_syms.function) { // Remove `call[[4]]` where the parser stores srcref information // for calls to `function` r_node_poke_cdr(r_node_cddr(x), r_null); } for (r_obj* node = x; node != r_null; node = r_node_cdr(node)) { r_node_poke_car(node, zap_srcref(r_node_car(node))); } FREE(1); return x; } static r_obj* expr_vec_zap_srcref(r_obj* x) { x = KEEP(r_clone(x)); attrib_zap_srcref(x); r_ssize n = r_length(x); r_obj* const * v_x = r_list_cbegin(x); for (r_ssize i = 0; i < n; ++i) { r_list_poke(x, i, zap_srcref(v_x[i])); } FREE(1); return x; } static void attrib_zap_srcref(r_obj* x) { r_attrib_poke(x, r_syms.srcfile, r_null); r_attrib_poke(x, r_syms.srcref, r_null); r_attrib_poke(x, r_syms.wholeSrcref, r_null); } void rlang_init_attr(r_obj* ns) { c_fn = r_eval(r_sym("c"), r_envs.base); as_character_call = r_parse("as.character(.x)"); r_preserve(as_character_call); names_call = r_parse("names(.x)"); r_preserve(names_call); set_names_call = r_parse("`names<-`(.x, .y)"); r_preserve(set_names_call); length_call = r_parse("length(.x)"); r_preserve(length_call); } static r_obj* c_fn = NULL; static r_obj* as_character_call = NULL; static r_obj* names_call = NULL; static r_obj* set_names_call = NULL; static r_obj* length_call = NULL; rlang/src/internal/standalone-types-check.c0000644000176200001440000001064214376112150020474 0ustar liggesusers#include #include enum is_number { IS_NUMBER_true = 0, IS_NUMBER_false = 1, IS_NUMBER_oob = 2 }; #include "decl/standalone-types-check-decl.h" r_obj* ffi_standalone_is_bool(r_obj* x, r_obj* allow_na, r_obj* allow_null) { if (x == r_null) { return r_lgl(r_as_bool(allow_null)); } if (r_typeof(x) != R_TYPE_logical || r_length(x) != 1) { return r_false; } if (r_lgl_get(x, 0) == r_globals.na_lgl) { return r_lgl(r_as_bool(allow_na)); } return r_true; } r_obj* ffi_standalone_check_number(r_obj* x, r_obj* allow_decimal, r_obj* min, r_obj* max, r_obj* allow_infinite, r_obj* allow_na, r_obj* allow_null) { int out = IS_NUMBER_false; switch (r_typeof(x)) { case R_TYPE_null: out = r_as_bool(allow_null) ? IS_NUMBER_true : IS_NUMBER_false; break; case R_TYPE_logical: if (r_length(x) == 1 && r_lgl_get(x, 0) == r_globals.na_lgl) { out = r_as_bool(allow_na) ? IS_NUMBER_true : IS_NUMBER_false; } break; case R_TYPE_integer: out = int_standalone_check_number(x, min, max, allow_na, allow_null); break; case R_TYPE_double: out = dbl_standalone_check_number(x, allow_decimal, min, max, allow_infinite, allow_na, allow_null); break; default: break; } return r_int(out); } static bool is_numeric(r_obj* x) { if (!r_is_object(x)) { return true; } r_obj* call = KEEP(r_call2(r_sym("is.numeric"), x)); r_obj* ffi_out = r_eval(call, r_envs.base); bool out = r_as_bool(ffi_out); FREE(1); return out; } static inline double as_min_or_max(r_obj* ffi_x, const char* arg, double dflt) { if (ffi_x == r_null) { return dflt; } double out = r_arg_as_double(ffi_x, arg); if (isnan(out)) { r_abort("`%s` must be a number, not missing.", arg); } return out; } static enum is_number int_standalone_check_number(r_obj* x, r_obj* ffi_min, r_obj* ffi_max, r_obj* allow_na, r_obj* allow_null) { if (r_length(x) != 1) { return IS_NUMBER_false; } if (!is_numeric(x)) { return IS_NUMBER_false; } int value = r_int_get(x, 0); if (value == r_globals.na_int) { return r_as_bool(allow_na) ? IS_NUMBER_true : IS_NUMBER_false; } if (ffi_min != r_null || ffi_max != r_null) { double min = as_min_or_max(ffi_min, "min", -INFINITY); double max = as_min_or_max(ffi_max, "max", INFINITY); if (value < min || value > max) { return IS_NUMBER_oob; } } return IS_NUMBER_true; } static enum is_number dbl_standalone_check_number(r_obj* x, r_obj* allow_decimal, r_obj* ffi_min, r_obj* ffi_max, r_obj* allow_infinite, r_obj* allow_na, r_obj* allow_null) { if (r_length(x) != 1) { return IS_NUMBER_false; } if (!is_numeric(x)) { return IS_NUMBER_false; } double value = r_dbl_get(x, 0); if (!isfinite(value)) { if (R_IsNA(value)) { return r_as_bool(allow_na) ? IS_NUMBER_true : IS_NUMBER_false; } else if (isnan(value)) { return IS_NUMBER_false; } else { return r_as_bool(allow_infinite) ? IS_NUMBER_true : IS_NUMBER_false; } } if (!r_as_bool(allow_decimal) && !r_dbl_is_whole(value)) { return IS_NUMBER_false; } if (ffi_min != r_null || ffi_max != r_null) { double min = as_min_or_max(ffi_min, "min", -INFINITY); double max = as_min_or_max(ffi_max, "max", INFINITY); if (value < min || value > max) { return IS_NUMBER_oob; } } return IS_NUMBER_true; } rlang/src/internal/exported.c0000644000176200001440000006752614741441060015777 0ustar liggesusers#include #include "../internal/utils.h" #include "../internal/vec.h" // From rlang/vec.c void r_vec_poke_n(r_obj* x, r_ssize offset, r_obj* y, r_ssize from, r_ssize n); void r_vec_poke_range(r_obj* x, r_ssize offset, r_obj* y, r_ssize from, r_ssize to); r_obj* ffi_compiled_by_gcc(void) { #if defined(__GNUC__) && !defined(__clang__) return r_true; #else return r_false; #endif } // cnd.c r_obj* ffi_cnd_signal(r_obj* cnd) { r_cnd_signal(cnd); return r_null; } r_obj* ffi_cnd_type(r_obj* cnd) { enum r_cnd_type type = r_cnd_type(cnd); switch (type) { case R_CND_TYPE_condition: return r_chr("condition"); case R_CND_TYPE_message: return r_chr("message"); case R_CND_TYPE_warning: return r_chr("warning"); case R_CND_TYPE_error: return r_chr("error"); case R_CND_TYPE_interrupt: return r_chr("interrupt"); default: r_abort("Internal error: Unhandled `r_condition_type`"); } } r_obj* ffi_interrupt(void) { r_interrupt(); return r_null; } // df.c r_obj* ffi_alloc_data_frame(r_obj* n_rows, r_obj* names, r_obj* types) { if (!r_is_int(n_rows)) { r_abort("`n_rows` must be an integer value."); } if (r_typeof(names) != R_TYPE_character) { r_abort("`names` must be a character vector."); } if (r_typeof(types) != R_TYPE_integer) { r_abort("`types` must be an integer vector."); } r_ssize n_rows_val = r_int_get(n_rows, 0); r_obj* df = KEEP(r_alloc_df_list(n_rows_val, names, (enum r_type*) r_int_begin(types), r_length(names))); r_init_data_frame(df, n_rows_val); FREE(1); return df; } // dict.c static r_obj* wrap_dict(struct r_dict* p_dict) { return p_dict->shelter; } r_obj* ffi_new_dict(r_obj* size, r_obj* prevent_resize) { if (!r_is_int(size)) { r_abort("`size` must be an integer."); } if (!r_is_bool(prevent_resize)) { r_abort("`prevent_resize` must be a logical value."); } struct r_dict* dict = r_new_dict(r_int_get(size, 0)); dict->prevent_resize = r_lgl_get(prevent_resize, 0); return dict->shelter; } r_obj* ffi_dict_poke(r_obj* dict, r_obj* key, r_obj* value) { struct r_dict* p_dict = r_shelter_deref(dict); r_obj* out = r_dict_poke(p_dict, key, value); return out ? out : rlang_syms.c_null; } r_obj* ffi_dict_put(r_obj* dict, r_obj* key, r_obj* value) { struct r_dict* p_dict = r_shelter_deref(dict); return r_lgl(r_dict_put(p_dict, key, value)); } r_obj* ffi_dict_del(r_obj* dict, r_obj* key) { struct r_dict* p_dict = r_shelter_deref(dict); return r_lgl(r_dict_del(p_dict, key)); } r_obj* ffi_dict_has(r_obj* dict, r_obj* key) { struct r_dict* p_dict = r_shelter_deref(dict); return r_lgl(r_dict_has(p_dict, key)); } r_obj* ffi_dict_get(r_obj* dict, r_obj* key) { struct r_dict* p_dict = r_shelter_deref(dict); return r_dict_get(p_dict, key); } r_obj* ffi_dict_resize(r_obj* dict, r_obj* size) { if (!r_is_int(size)) { r_abort("`size` must be an integer."); } struct r_dict* p_dict = r_shelter_deref(dict); r_dict_resize(p_dict, r_int_get(size, 0)); return r_null; } r_obj* ffi_dict_as_df_list(r_obj* dict) { return r_dict_as_df_list(r_shelter_deref(dict)); } r_obj* ffi_dict_as_list(r_obj* dict) { return r_dict_as_list(r_shelter_deref(dict)); } r_obj* ffi_new_dict_iterator(r_obj* dict) { struct r_dict* p_dict = r_shelter_deref(dict); return r_new_dict_iterator(p_dict)->shelter; } r_obj* ffi_dict_it_info(r_obj* dict_it) { struct r_dict_iterator* p_it = r_shelter_deref(dict_it); const char* v_nms[] = { "key", "value", "i", "n" }; int n = R_ARR_SIZEOF(v_nms); r_obj* info = KEEP(r_alloc_list(n)); r_attrib_poke_names(info, r_chr_n(v_nms, n)); r_list_poke(info, 0, p_it->key); r_list_poke(info, 1, p_it->value); r_list_poke(info, 2, r_len(p_it->i)); r_list_poke(info, 3, r_len(p_it->n)); FREE(1); return info; } r_obj* ffi_dict_it_next(r_obj* dict_it) { struct r_dict_iterator* p_dict_it = r_shelter_deref(dict_it); return r_lgl(r_dict_next(p_dict_it)); } // dyn-array.c // [[ register() ]] r_obj* ffi_new_dyn_vector(r_obj* type, r_obj* capacity) { struct r_dyn_array* arr = r_new_dyn_vector(r_chr_as_r_type(type), r_arg_as_ssize(capacity, "capacity")); return arr->shelter; } // [[ register() ]] r_obj* ffi_new_dyn_array(r_obj* elt_byte_size, r_obj* capacity) { struct r_dyn_array* arr = r_new_dyn_array(r_arg_as_ssize(elt_byte_size, "elt_byte_size"), r_arg_as_ssize(capacity, "capacity")); return arr->shelter; } // [[ register() ]] r_obj* ffi_dyn_unwrap(r_obj* arr) { return r_dyn_unwrap(r_shelter_deref(arr)); } // [[ register() ]] r_obj* ffi_dyn_info(r_obj* arr_sexp) { struct r_dyn_array* arr = r_shelter_deref(arr_sexp); const char* names_c_strs[] = { "count", "capacity", "growth_factor", "type", "elt_byte_size" }; int info_n = R_ARR_SIZEOF(names_c_strs); r_obj* info = KEEP(r_alloc_list(info_n)); r_obj* nms = r_chr_n(names_c_strs, info_n); r_attrib_poke_names(info, nms); r_list_poke(info, 0, r_dbl(arr->count)); r_list_poke(info, 1, r_dbl(arr->capacity)); r_list_poke(info, 2, r_int(arr->growth_factor)); r_list_poke(info, 3, r_type_as_character(arr->type)); r_list_poke(info, 4, r_int(arr->elt_byte_size)); FREE(1); return info; } // [[ register() ]] r_obj* ffi_dyn_push_back(r_obj* arr_sexp, r_obj* x) { struct r_dyn_array* p_arr = r_shelter_deref(arr_sexp); if (!p_arr->barrier_set && r_vec_elt_sizeof(x) != p_arr->elt_byte_size) { r_stop_internal("Incompatible byte sizes %d/%d.", r_vec_elt_sizeof(x), p_arr->elt_byte_size); } switch (p_arr->type) { case R_TYPE_character: case R_TYPE_list: r_dyn_push_back(p_arr, &x); return r_null; default: r_dyn_push_back(p_arr, r_vec_cbegin(x)); return r_null; } } // [[ register() ]] r_obj* ffi_dyn_push_back_bool(r_obj* arr_sexp, r_obj* x_sexp) { struct r_dyn_array* arr = r_shelter_deref(arr_sexp); bool x = r_as_bool(x_sexp); r_dyn_push_back(arr, &x); return r_null; } // [[ register() ]] r_obj* ffi_dyn_pop_back(r_obj* arr_sexp) { struct r_dyn_array* arr = r_shelter_deref(arr_sexp); void* const * out = r_dyn_pop_back(arr); if (arr->type == R_TYPE_list) { return *((r_obj* const *) out); } else { return r_null; } } // [[ register() ]] r_obj* ffi_dyn_resize(r_obj* arr_sexp, r_obj* capacity_sexp) { struct r_dyn_array* arr = r_shelter_deref(arr_sexp); r_dyn_resize(arr, r_arg_as_ssize(capacity_sexp, "capacity")); return r_null; } // [[ register() ]] r_obj* ffi_dyn_lgl_get(r_obj* x, r_obj* i) { return r_lgl(r_dyn_lgl_get(r_shelter_deref(x), r_arg_as_ssize(i, "i"))); } // [[ register() ]] r_obj* ffi_dyn_int_get(r_obj* x, r_obj* i) { return r_int(r_dyn_int_get(r_shelter_deref(x), r_arg_as_ssize(i, "i"))); } // [[ register() ]] r_obj* ffi_dyn_dbl_get(r_obj* x, r_obj* i) { return r_dbl(r_dyn_dbl_get(r_shelter_deref(x), r_arg_as_ssize(i, "i"))); } // [[ register() ]] r_obj* ffi_dyn_cpl_get(r_obj* x, r_obj* i) { return r_cpl(r_dyn_cpl_get(r_shelter_deref(x), r_arg_as_ssize(i, "i"))); } // [[ register() ]] r_obj* ffi_dyn_raw_get(r_obj* x, r_obj* i) { return r_raw(r_dyn_raw_get(r_shelter_deref(x), r_arg_as_ssize(i, "i"))); } // [[ register() ]] r_obj* ffi_dyn_chr_get(r_obj* x, r_obj* i) { return r_dyn_chr_get(r_shelter_deref(x), r_arg_as_ssize(i, "i")); } // [[ register() ]] r_obj* ffi_dyn_list_get(r_obj* x, r_obj* i) { return r_dyn_list_get(r_shelter_deref(x), r_arg_as_ssize(i, "i")); } // [[ register() ]] r_obj* ffi_dyn_lgl_poke(r_obj* x, r_obj* i, r_obj* value) { r_dyn_lgl_poke(r_shelter_deref(x), r_arg_as_ssize(i, "i"), r_as_bool(value)); return r_null; } // [[ register() ]] r_obj* ffi_dyn_int_poke(r_obj* x, r_obj* i, r_obj* value) { r_dyn_int_poke(r_shelter_deref(x), r_arg_as_ssize(i, "i"), r_as_int(value)); return r_null; } // [[ register() ]] r_obj* ffi_dyn_dbl_poke(r_obj* x, r_obj* i, r_obj* value) { r_dyn_dbl_poke(r_shelter_deref(x), r_arg_as_ssize(i, "i"), r_as_double(value)); return r_null; } // [[ register() ]] r_obj* ffi_dyn_cpl_poke(r_obj* x, r_obj* i, r_obj* value) { r_dyn_cpl_poke(r_shelter_deref(x), r_arg_as_ssize(i, "i"), r_as_complex(value)); return r_null; } // [[ register() ]] r_obj* ffi_dyn_raw_poke(r_obj* x, r_obj* i, r_obj* value) { r_dyn_raw_poke(r_shelter_deref(x), r_arg_as_ssize(i, "i"), r_as_char(value)); return r_null; } // [[ register() ]] r_obj* ffi_dyn_chr_poke(r_obj* x, r_obj* i, r_obj* value) { r_dyn_chr_poke(r_shelter_deref(x), r_arg_as_ssize(i, "i"), value); return r_null; } // [[ register() ]] r_obj* ffi_dyn_list_poke(r_obj* x, r_obj* i, r_obj* value) { r_dyn_list_poke(r_shelter_deref(x), r_arg_as_ssize(i, "i"), value); return r_null; } // [[ register() ]] r_obj* ffi_dyn_lgl_push_back(r_obj* x, r_obj* value) { r_dyn_lgl_push_back(r_shelter_deref(x), r_as_bool(value)); return r_null; } // [[ register() ]] r_obj* ffi_dyn_int_push_back(r_obj* x, r_obj* value) { r_dyn_int_push_back(r_shelter_deref(x), r_as_int(value)); return r_null; } // [[ register() ]] r_obj* ffi_dyn_dbl_push_back(r_obj* x, r_obj* value) { r_dyn_dbl_push_back(r_shelter_deref(x), r_as_double(value)); return r_null; } // [[ register() ]] r_obj* ffi_dyn_cpl_push_back(r_obj* x, r_obj* value) { r_dyn_cpl_push_back(r_shelter_deref(x), r_as_complex(value)); return r_null; } // [[ register() ]] r_obj* ffi_dyn_raw_push_back(r_obj* x, r_obj* value) { r_dyn_raw_push_back(r_shelter_deref(x), r_as_char(value)); return r_null; } // [[ register() ]] r_obj* ffi_dyn_chr_push_back(r_obj* x, r_obj* value) { r_dyn_chr_push_back(r_shelter_deref(x), value); return r_null; } // [[ register() ]] r_obj* ffi_dyn_list_push_back(r_obj* x, r_obj* value) { r_dyn_list_push_back(r_shelter_deref(x), value); return r_null; } // [[ register() ]] r_obj* ffi_has_size_one_bool(void) { return r_lgl(sizeof(bool) == 1); } // dyn-list-of.c // [[ register() ]] r_obj* ffi_new_dyn_list_of(r_obj* type, r_obj* capacity, r_obj* width) { struct r_dyn_list_of* lof = r_new_dyn_list_of(r_chr_as_r_type(type), r_arg_as_ssize(capacity, "capacity"), r_arg_as_ssize(width, "width")); return lof->shelter; } enum info_lof { INFO_LOF_count, INFO_LOF_growth_factor, INFO_LOF_arrays, INFO_LOF_width, INFO_LOF_reserve, INFO_LOF_capacity, INFO_LOF_moved_array, INFO_LOF_type, INFO_LOF_elt_byte_size, INFO_LOF_SIZE }; static const char* info_lof_c_strs[INFO_LOF_SIZE] = { "count", "growth_factor", "arrays", "width", "reserve", "capacity", "moved_array", "type", "elt_byte_size", }; // [[ register() ]] r_obj* ffi_lof_info(r_obj* lof) { struct r_dyn_list_of* p_lof = r_shelter_deref(lof); r_obj* info = KEEP(r_alloc_list(INFO_LOF_SIZE)); r_obj* nms = r_chr_n(info_lof_c_strs, INFO_LOF_SIZE); r_attrib_poke_names(info, nms); r_list_poke(info, INFO_LOF_count, r_dbl(p_lof->count)); r_list_poke(info, INFO_LOF_growth_factor, r_int(p_lof->growth_factor)); r_list_poke(info, INFO_LOF_arrays, r_lof_unwrap(p_lof)); r_list_poke(info, INFO_LOF_width, r_len(p_lof->width)); r_list_poke(info, INFO_LOF_reserve, p_lof->reserve); r_list_poke(info, INFO_LOF_capacity, r_len(p_lof->capacity)); r_list_poke(info, INFO_LOF_moved_array, p_lof->p_moved_arr->shelter); r_list_poke(info, INFO_LOF_type, r_type_as_character(p_lof->type)); r_list_poke(info, INFO_LOF_elt_byte_size, r_int(p_lof->elt_byte_size)); FREE(1); return info; } // [[ register() ]] r_obj* ffi_lof_unwrap(r_obj* lof) { return r_lof_unwrap(r_shelter_deref(lof)); } // [[ register() ]] r_obj* ffi_lof_push_back(r_obj* lof) { r_lof_push_back(r_shelter_deref(lof)); return r_null; } // [[ register() ]] r_obj* ffi_lof_arr_push_back(r_obj* lof, r_obj* i, r_obj* value) { struct r_dyn_list_of* p_lof = r_shelter_deref(lof); if (r_typeof(value) != p_lof->type) { r_abort("Can't push value of type %s in dyn-list-of %s", r_type_as_c_string(r_typeof(value)), r_type_as_c_string(p_lof->type)); } r_lof_arr_push_back(p_lof, r_arg_as_ssize(i, "i"), r_vec_begin(value)); return r_null; } // env.c r_obj* ffi_env_poke_parent(r_obj* env, r_obj* new_parent) { if (R_IsNamespaceEnv(env)) { r_abort("Can't change the parent of a namespace environment"); } if (R_IsPackageEnv(env)) { r_abort("Can't change the parent of a package environment"); } if (R_EnvironmentIsLocked(env)) { r_abort("Can't change the parent of a locked environment"); } if (env == r_envs.global) { r_abort("Can't change the parent of the global environment"); } if (env == r_envs.base) { r_abort("Can't change the parent of the base environment"); } if (env == r_envs.empty) { r_abort("Can't change the parent of the empty environment"); } SET_ENCLOS(env, new_parent); return env; } r_obj* ffi_env_frame(r_obj* env) { return FRAME(env); } r_obj* ffi_env_hash_table(r_obj* env) { return HASHTAB(env); } r_obj* ffi_env_inherits(r_obj* env, r_obj* ancestor) { return r_lgl(r_env_inherits(env, ancestor, r_envs.empty)); } r_obj* ffi_env_bind_list(r_obj* env, r_obj* names, r_obj* data) { if (r_typeof(env) != R_TYPE_environment) { r_abort("Internal error: `env` must be an environment."); } if (r_typeof(names) != R_TYPE_character) { r_abort("Internal error: `names` must be a character vector."); } if (r_typeof(data) != R_TYPE_list) { r_abort("Internal error: `data` must be a list."); } r_ssize n = r_length(data); if (n != r_length(names)) { r_abort("Internal error: `data` and `names` must have the same length."); } r_obj* const * p_names = r_chr_cbegin(names); for (r_ssize i = 0; i < n; ++i) { Rf_defineVar(r_str_as_symbol(p_names[i]), r_list_get(data, i), env); } return r_null; } r_obj* ffi_env_browse(r_obj* env, r_obj* value) { if (r_typeof(env) != R_TYPE_environment) { r_abort("`env` must be an environment."); } if (!r_is_bool(value)) { r_abort("`value` must be a single logical value."); } r_obj* old = r_lgl(RDEBUG(env)); SET_RDEBUG(env, r_lgl_get(value, 0)); return old; } r_obj* ffi_env_is_browsed(r_obj* env) { if (r_typeof(env) != R_TYPE_environment) { r_abort("`env` must be an environment."); } return r_lgl(RDEBUG(env)); } r_obj* ffi_ns_registry_env(void) { return R_NamespaceRegistry; } // eval.c r_obj* ffi_eval(r_obj* call, r_obj* op, r_obj* args, r_obj* env) { args = r_node_cdr(args); return Rf_eval(r_node_car(args), r_node_cadr(args)); } r_obj* ffi_eval_top(r_obj* expr, r_obj* env) { int jumped = 0; r_obj* out = R_tryEval(expr, env, &jumped); if (jumped) { r_abort("Top level jump"); } else { return out; } } // fn.c r_obj* ffi_is_function(r_obj* x) { return r_shared_lgl(r_is_function(x)); } r_obj* ffi_is_closure(r_obj* x) { return r_shared_lgl(r_typeof(x) == R_TYPE_closure); } r_obj* ffi_is_primitive(r_obj* x) { return r_shared_lgl(r_is_primitive(x)); } r_obj* ffi_is_primitive_lazy(r_obj* x) { return r_shared_lgl(r_typeof(x) == R_TYPE_special); } r_obj* ffi_is_primitive_eager(r_obj* x) { return r_shared_lgl(r_typeof(x) == R_TYPE_builtin); } // formula.c static int as_optional_bool(r_obj* lgl) { if (lgl == r_null) { return -1; } else { return r_lgl_get(lgl, 0); } } // [[ register() ]] r_obj* ffi_is_formula(r_obj* x, r_obj* scoped, r_obj* lhs) { int scoped_int = as_optional_bool(scoped); int lhs_int = as_optional_bool(lhs); return r_lgl(r_is_formula(x, scoped_int, lhs_int)); } // parse.c #include "../internal/parse.h" r_obj* ffi_call_has_precedence(r_obj* x, r_obj* y, r_obj* side) { int c_side = r_int_get(side, 0); bool has_predence; switch (c_side) { case -1: has_predence = r_lhs_call_has_precedence(x, y); break; case 0: has_predence = r_call_has_precedence(x, y); break; case 1: has_predence = r_rhs_call_has_precedence(x, y); break; default: r_stop_internal("Unexpected `side` value."); } return r_lgl(has_predence); } r_obj* ffi_which_operator(r_obj* call) { const char* op = r_op_as_c_string(r_which_operator(call)); return r_chr(op); } // node.c r_obj* ffi_node_car(r_obj* x) { return CAR(x); } r_obj* ffi_node_cdr(r_obj* x) { return CDR(x); } r_obj* ffi_node_caar(r_obj* x) { return CAAR(x); } r_obj* ffi_node_cadr(r_obj* x) { return CADR(x); } r_obj* ffi_node_cdar(r_obj* x) { return CDAR(x); } r_obj* ffi_node_cddr(r_obj* x) { return CDDR(x); } r_obj* ffi_node_tail(r_obj* x) { while (CDR(x) != r_null) x = CDR(x); return x; } r_obj* ffi_node_poke_car(r_obj* x, r_obj* newcar) { SETCAR(x, newcar); return x; } r_obj* ffi_node_poke_cdr(r_obj* x, r_obj* newcdr) { SETCDR(x, newcdr); return x; } r_obj* ffi_node_poke_caar(r_obj* x, r_obj* newcaar) { SETCAR(CAR(x), newcaar); return x; } r_obj* ffi_node_poke_cadr(r_obj* x, r_obj* newcar) { SETCADR(x, newcar); return x; } r_obj* ffi_node_poke_cdar(r_obj* x, r_obj* newcdar) { SETCDR(CAR(x), newcdar); return x; } r_obj* ffi_node_poke_cddr(r_obj* x, r_obj* newcdr) { SETCDR(CDR(x), newcdr); return x; } r_obj* ffi_node_tag(r_obj* x) { return TAG(x); } r_obj* ffi_node_poke_tag(r_obj* x, r_obj* tag) { SET_TAG(x, tag); return x; } r_obj* rlang_on_exit(r_obj* expr, r_obj* frame) { r_on_exit(expr, frame); return r_null; } // lang.h r_obj* ffi_new_call_node(r_obj* car, r_obj* cdr) { return Rf_lcons(car, cdr); } // quo.h #include "../internal/quo.h" r_obj* ffi_quo_is_missing(r_obj* quo) { check_quosure(quo); return r_lgl(quo_is_missing(quo)); } r_obj* ffi_quo_is_symbol(r_obj* quo) { check_quosure(quo); return r_lgl(quo_is_symbol(quo)); } r_obj* ffi_quo_is_call(r_obj* quo) { check_quosure(quo); return r_lgl(quo_is_call(quo)); } r_obj* ffi_quo_is_symbolic(r_obj* quo) { check_quosure(quo); return r_lgl(quo_is_symbolic(quo)); } r_obj* ffi_quo_is_null(r_obj* quo) { check_quosure(quo); return r_lgl(quo_is_null(quo)); } // sexp.h r_obj* ffi_length(r_obj* x) { return r_int(r_length(x)); } r_obj* ffi_true_length(r_obj* x) { return r_int(XTRUELENGTH(x)); } r_obj* ffi_is_reference(r_obj* x, r_obj* y) { return r_lgl(x == y); } r_obj* ffi_missing_arg(void) { return R_MissingArg; } r_obj* ffi_duplicate(r_obj* x, r_obj* shallow) { if (r_lgl_get(shallow, 0)) { return r_clone(x); } else { return r_copy(x); } } r_obj* ffi_obj_address(r_obj* x) { return r_str_as_character(r_obj_address(x)); } r_obj* ffi_poke_type(r_obj* x, r_obj* type) { SET_TYPEOF(x, Rf_str2type(r_chr_get_c_string(type, 0))); return x; } r_obj* ffi_mark_object(r_obj* x) { SET_OBJECT(x, 1); return x; } r_obj* ffi_unmark_object(r_obj* x) { SET_OBJECT(x, 0); return x; } r_obj* rlang_get_promise(r_obj* x, r_obj* env) { switch (r_typeof(x)) { case R_TYPE_promise: return x; case R_TYPE_character: if (r_length(x) == 1) { x = r_sym(r_chr_get_c_string(x, 0)); } else { goto error; } // fallthrough case R_TYPE_symbol: { r_obj* prom = r_env_find_anywhere(env, x); if (r_typeof(prom) == R_TYPE_promise) { return prom; } // fallthrough } error: default: r_abort("`x` must be or refer to a local promise"); } } r_obj* ffi_promise_expr(r_obj* x, r_obj* env) { r_obj* prom = rlang_get_promise(x, env); return PREXPR(prom); } r_obj* ffi_promise_env(r_obj* x, r_obj* env) { r_obj* prom = rlang_get_promise(x, env); return PRENV(prom); } r_obj* ffi_promise_value(r_obj* x, r_obj* env) { r_obj* prom = rlang_get_promise(x, env); r_obj* value = PRVALUE(prom); if (value == r_syms.unbound) { return r_sym("R_UnboundValue"); } else { return value; } } // Picks up symbols from parent environment to avoid bumping namedness // during promise resolution r_obj* ffi_named(r_obj* x, r_obj* env) { int n_kept = 0; x = PROTECT(Rf_findVarInFrame3(env, x, FALSE)); ++n_kept; if (TYPEOF(x) == PROMSXP) { x = PROTECT(Rf_eval(x, env)); ++n_kept; } UNPROTECT(n_kept); return Rf_ScalarInteger(NAMED(x)); } r_obj* ffi_find_var(r_obj* env, r_obj* sym) { return Rf_findVar(sym, env); } r_obj* ffi_find_var_in_frame(r_obj* env, r_obj* sym) { return Rf_findVarInFrame(env, sym); } r_obj* ffi_chr_get(r_obj* x, r_obj* i) { if (r_typeof(i) != R_TYPE_integer || r_length(i) != 1) { r_abort("`i` must be an integer value."); } int c_i = r_int_get(i, 0); if (c_i < 0 || c_i >= r_length(x)) { r_abort("`i` is out of bound. Note that `r_chr_get()` takes zero-based locations."); } return r_chr_get(x, c_i); } // Returns a copy r_obj* ffi_precious_dict(void) { // From rlang/sexp.c struct r_dict* rlang__precious_dict(void); struct r_dict* p_dict = rlang__precious_dict(); return wrap_dict(p_dict); } r_obj* ffi_preserve(r_obj* x) { r_preserve(x); return r_null; } r_obj* ffi_unpreserve(r_obj* x) { r_unpreserve(x); return r_null; } // vec.h r_obj* ffi_vec_alloc(r_obj* type, r_obj* n) { return Rf_allocVector(Rf_str2type(r_chr_get_c_string(type, 0)), r_int_get(n, 0)); } r_obj* ffi_vec_coerce(r_obj* x, r_obj* type) { return Rf_coerceVector(x, Rf_str2type(r_chr_get_c_string(type, 0))); } r_obj* ffi_vec_poke_n(r_obj* x, r_obj* offset, r_obj* y, r_obj* from, r_obj* n) { r_ssize offset_size = r_arg_as_ssize(offset, "offset") - 1; r_ssize from_size = r_arg_as_ssize(from, "from") - 1; r_ssize n_size = r_arg_as_ssize(n, "n"); r_vec_poke_n(x, offset_size, y, from_size, n_size); return x; } r_obj* ffi_vec_poke_range(r_obj* x, r_obj* offset, r_obj* y, r_obj* from, r_obj* to) { r_ssize offset_size = r_arg_as_ssize(offset, "offset") - 1; r_ssize from_size = r_arg_as_ssize(from, "from") - 1; r_ssize to_size = r_arg_as_ssize(to, "to") - 1; r_vec_poke_range(x, offset_size, y, from_size, to_size); return x; } static int validate_finite(r_obj* finite) { switch (r_typeof(finite)) { case R_TYPE_null: return -1; case R_TYPE_integer: case R_TYPE_double: finite = r_vec_coerce(finite, R_TYPE_logical); case R_TYPE_logical: { int value = r_lgl_get(finite, 0); if (value != r_globals.na_lgl) { return r_lgl_get(finite, 0); } // else fallthrough } default: r_abort("`finite` must be NULL or a scalar logical"); } } r_obj* ffi_is_finite(r_obj* x) { return r_shared_lgl(_r_is_finite(x)); } r_obj* ffi_is_list(r_obj* x, r_obj* n_) { r_ssize n = validate_n(n_); if (r_typeof(x) != R_TYPE_list) { return r_false; } if (n < 0) { return r_true; } return r_shared_lgl(r_length(x) == n); } r_obj* ffi_is_atomic(r_obj* x, r_obj* n_) { r_ssize n = validate_n(n_); return r_shared_lgl(r_is_atomic(x, n)); } r_obj* ffi_is_vector(r_obj* x, r_obj* n_) { r_ssize n = validate_n(n_); return r_shared_lgl(r_is_vector(x, n)); } r_obj* ffi_is_logical(r_obj* x, r_obj* n_) { r_ssize n = validate_n(n_); return r_shared_lgl(r_is_logical(x, n)); } r_obj* ffi_is_integer(r_obj* x, r_obj* n_) { r_ssize n = validate_n(n_); return r_shared_lgl(r_is_integer(x, n, -1)); } r_obj* ffi_is_double(r_obj* x, r_obj* n_, r_obj* finite_) { r_ssize n = validate_n(n_); int finite = validate_finite(finite_); return r_shared_lgl(r_is_double(x, n, finite)); } r_obj* ffi_is_complex(r_obj* x, r_obj* n_, r_obj* finite_) { r_ssize n = validate_n(n_); int finite = validate_finite(finite_); return r_shared_lgl(r_is_complex(x, n, finite)); } r_obj* ffi_is_integerish(r_obj* x, r_obj* n_, r_obj* finite_) { r_ssize n = validate_n(n_); int finite = validate_finite(finite_); return r_shared_lgl(r_is_integerish(x, n, finite)); } static enum option_bool as_option_bool(r_obj* x) { if (x == r_null) { return(OPTION_BOOL_null); } if (r_as_bool(x)) { return OPTION_BOOL_true; } else { return OPTION_BOOL_false; } } r_obj* ffi_is_character(r_obj* x, r_obj* ffi_n, r_obj* ffi_missing, r_obj* ffi_empty) { r_ssize n = validate_n(ffi_n); enum option_bool missing = as_option_bool(ffi_missing); enum option_bool empty = as_option_bool(ffi_empty); return r_shared_lgl(is_character(x, n, missing, empty)); } r_obj* ffi_is_raw(r_obj* x, r_obj* n_) { r_ssize n = validate_n(n_); return r_shared_lgl(r_is_raw(x, n)); } r_obj* ffi_is_string(r_obj* x, r_obj* string, r_obj* empty) { if (r_typeof(x) != R_TYPE_character || r_length(x) != 1) { return r_false; } r_obj* value = r_chr_get(x, 0); if (value == r_globals.na_str) { return r_false; } if (string != r_null) { if (!ffi_is_string(string, r_null, r_null)) { r_abort("`string` must be `NULL` or a string."); } if (empty != r_null) { r_abort("Exactly one of `string` and `empty` must be supplied."); } bool matched = false; r_obj* const * p_string = r_chr_cbegin(string); r_ssize n = r_length(string); for (r_ssize i = 0; i < n; ++i) { if (p_string[i] == value) { matched = true; break; } } if (!matched) { return r_false; } } if (empty != r_null) { if (!r_is_bool(empty)) { r_abort("`empty` must be `NULL` or a logical value."); } bool c_empty = r_as_bool(empty); bool matched = c_empty == (value == r_strs.empty); return r_lgl(matched); } return r_true; } r_obj* ffi_vec_resize(r_obj* x, r_obj* n) { r_ssize n_ssize = r_arg_as_ssize(n, "n"); switch (r_typeof(x)) { case R_TYPE_logical: return r_lgl_resize(x, n_ssize); case R_TYPE_integer: return r_int_resize(x, n_ssize); case R_TYPE_double: return r_dbl_resize(x, n_ssize); case R_TYPE_complex: return r_cpl_resize(x, n_ssize); case R_TYPE_raw: return r_raw_resize(x, n_ssize); case R_TYPE_character: return r_chr_resize(x, n_ssize); case R_TYPE_list: return r_list_resize(x, n_ssize); default: r_stop_unimplemented_type(r_typeof(x)); } } r_obj* ffi_list_poke(r_obj* x, r_obj* i, r_obj* value) { r_list_poke(x, r_arg_as_ssize(i, "i"), value); return r_null; } // walk.c static inline r_obj* protect_missing(r_obj* x) { // FIXME: Include in `exec_` functions? if (x == r_missing_arg || x == r_syms.unbound || r_typeof(x) == R_TYPE_promise) { return r_expr_protect(x); } else { return x; } } // [[ register() ]] r_obj* ffi_sexp_iterate(r_obj* x, r_obj* fn) { struct r_dyn_array* p_out = r_new_dyn_vector(R_TYPE_list, 256); KEEP(p_out->shelter); struct r_dict* p_dict = r_new_dict(1024); KEEP(p_dict->shelter); struct r_sexp_iterator* p_it = r_new_sexp_iterator(x); KEEP(p_it->shelter); for (int i = 0; r_sexp_next(p_it); ++i) { if (i % 100 == 0) { r_yield_interrupt(); } if (p_it->x == r_envs.global) { p_it->skip_incoming = true; continue; } r_obj* x = p_it->x; enum r_type type = p_it->type; int depth = p_it->depth; r_obj* parent = p_it->parent; enum r_sexp_it_relation rel = p_it->rel; r_ssize i = p_it->i; enum r_sexp_it_direction dir = p_it->dir; if (dir == R_SEXP_IT_DIRECTION_incoming && type == R_TYPE_environment && !r_dict_put(p_dict, x, r_null)) { p_it->skip_incoming = true; continue; } struct r_pair args[] = { { r_sym("x"), KEEP(protect_missing(x)) }, { r_sym("addr"), KEEP(r_str_as_character(r_obj_address(x))) }, { r_sym("type"), KEEP(protect_missing(parent)) }, { r_sym("depth"), KEEP(r_type_as_character(type)) }, { r_sym("parent"), KEEP(r_int(depth)) }, { r_sym("rel"), KEEP(r_chr(r_sexp_it_relation_as_c_string(rel))) }, { r_sym("i"), KEEP(r_int(i + 1)) }, { r_sym("dir"), KEEP(r_chr(r_sexp_it_direction_as_c_string(dir))) } }; r_obj* out = KEEP(r_exec_mask_n(r_sym("fn"), fn, args, R_ARR_SIZEOF(args), r_envs.base)); r_dyn_list_push_back(p_out, out); FREE(9); } FREE(3); return r_dyn_unwrap(p_out); } rlang/src/internal/encoding.c0000644000176200001440000001107014741441060015712 0ustar liggesusers#include #include "decl/encoding-decl.h" /* * Recursively encode character vectors as UTF-8 * * A CHARSXP is left untouched if: * - It is the NA_STRING * - It is ASCII, which means the encoding will be "unknown", but is valid UTF-8 * - It is marked as UTF-8 * * Attributes are re-encoded as well. * * ASCII strings will never get marked with an encoding when they go * through `Rf_mkCharLenCE()`, but they will get marked as ASCII. Since * UTF-8 is fully compatible with ASCII, they are treated like UTF-8. * * This converts vectors that are completely marked as Latin-1 to UTF-8, rather * than leaving them as Latin-1. This ensures that two vectors can be compared * consistently if they have both been re-encoded. * * Bytes-encoded vectors are not supported, as they cannot be * converted to UTF-8 by `Rf_translateCharUTF8()`. * * If `x` is not shared (i.e. `r_is_shared(x) == false`), this function will * modify `x` in place. Otherwise, a copy is made. */ r_obj* obj_encode_utf8(r_obj* x) { switch (r_typeof(x)) { case R_TYPE_character: x = chr_encode_utf8(x); break; case R_TYPE_list: x = list_encode_utf8(x); break; default: break; } // For performance, avoid `KEEP()` / `FREE()` when not needed r_obj* attrib = r_attrib(x); if (attrib != r_null) { KEEP(x); x = obj_attrib_encode_utf8(x, attrib); FREE(1); } return x; } // ----------------------------------------------------------------------------- static r_obj* chr_encode_utf8(r_obj* x) { r_ssize size = r_length(x); r_ssize start = chr_find_encoding_start(x, size); if (size == start) { return x; } x = KEEP(r_clone_shared(x)); r_obj* const* p_x = r_chr_cbegin(x); const void* vmax = vmaxget(); for (r_ssize i = start; i < size; ++i) { r_obj* const elt = p_x[i]; if (str_needs_encoding(elt)) { r_chr_poke(x, i, str_encode_utf8(elt)); } } vmaxset(vmax); FREE(1); return x; } static inline r_ssize chr_find_encoding_start(r_obj* x, r_ssize size) { r_obj* const* p_x = r_chr_cbegin(x); for (r_ssize i = 0; i < size; ++i) { r_obj* const elt = p_x[i]; if (str_needs_encoding(elt)) { return i; } } return size; } // ----------------------------------------------------------------------------- static r_obj* list_encode_utf8(r_obj* x) { r_keep_loc pi; KEEP_HERE(x, &pi); r_ssize size = r_length(x); r_obj* const* p_x = r_list_cbegin(x); for (r_ssize i = 0; i < size; ++i) { r_obj* const elt_old = p_x[i]; r_obj* const elt_new = obj_encode_utf8(elt_old); if (elt_old == elt_new) { continue; } KEEP(elt_new); if (r_is_shared(x)) { // Cloned once, at which point `x` is free of references x = r_clone(x); KEEP_AT(x, pi); p_x = r_list_cbegin(x); } r_list_poke(x, i, elt_new); FREE(1); } FREE(1); return x; } // ----------------------------------------------------------------------------- static r_obj* obj_attrib_encode_utf8(r_obj* x, r_obj* attrib) { r_obj* attrib_new = attrib_encode_utf8(attrib); if (attrib_new == attrib) { return x; } KEEP(attrib_new); x = KEEP(r_clone_shared(x)); r_poke_attrib(x, attrib_new); FREE(2); return x; } static r_obj* attrib_encode_utf8(r_obj* x) { r_ssize loc = 0; bool owned = false; r_keep_loc pi; KEEP_HERE(x, &pi); for (r_obj* node = x; node != r_null; node = r_node_cdr(node), ++loc) { r_obj* elt_old = r_node_car(node); r_obj* elt_new = obj_encode_utf8(elt_old); if (elt_old == elt_new) { continue; } KEEP(elt_new); if (!owned) { // Shallow clone entire pairlist if not owned. // Should be fast because these are generally short. x = r_clone(x); KEEP_AT(x, pi); owned = true; node = x; // Restore original positioning post-clone for (r_ssize i = 0; i < loc; ++i) { node = r_node_cdr(node); } } r_node_poke_car(node, elt_new); FREE(1); } FREE(1); return x; } // ----------------------------------------------------------------------------- static inline r_obj* str_encode_utf8(r_obj* x) { return r_str(Rf_translateCharUTF8(x)); } static inline bool str_needs_encoding(r_obj* x) { return (!str_is_ascii_or_utf8(x)) && (x != NA_STRING); } #define MASK_ASCII 8 #define MASK_UTF8 64 // The first 128 values are ASCII, and are the same regardless of the encoding. // Otherwise we enforce UTF-8. static inline bool str_is_ascii_or_utf8(r_obj* x) { const int levels = LEVELS(x); return (levels & MASK_ASCII) || (levels & MASK_UTF8); } #undef MASK_ASCII #undef MASK_UTF8 rlang/src/internal/cnd-handlers.c0000644000176200001440000000520214401326407016466 0ustar liggesusers#include #include "internal.h" #include "decl/cnd-handlers-decl.h" #include "vec-chr.h" r_obj* ffi_try_fetch(r_obj* try_fetch_args) { r_obj* env = r_node_cadr(try_fetch_args); r_obj* handlers = KEEP(rlang_env_dots_list(env)); r_env_poke(env, rlang_syms.handlers, handlers); if (!r_length(handlers)) { FREE(1); return r_eval(r_syms.expr, env); } r_obj* classes = r_names(handlers); if (classes == r_null) { const char* arg = r_format_error_arg(r_syms.dots); r_abort("%s must be named with condition classes.", arg); } int n = r_length(handlers); r_obj* const * v_classes = r_chr_cbegin(classes); // Build handlers arguments with updated index into the `handlers` list. // See `handler_call` at R level for the template. r_obj* args = r_null; r_keep_loc shelter; KEEP_HERE(args, &shelter); r_obj* exiting_args = r_null; r_keep_loc exiting_shelter; KEEP_HERE(exiting_args, &exiting_shelter); for (int i = n - 1; i >= 0; --i) { r_obj* cls = v_classes[i]; if (cls == r_strs.error) { r_obj* exiting_hnd = KEEP(r_call3(r_syms.brackets2, rlang_syms.handlers, r_int(i + 1))); exiting_args = r_new_node(exiting_hnd, exiting_args); KEEP_AT(exiting_args, exiting_shelter); r_node_poke_tag(exiting_args, r_syms.stack_overflow_error); FREE(1); } r_obj* hnd = KEEP(r_copy(hnd_call)); // Picks up `I` r_obj* subscript_node = r_node_cddr(r_node_caar(r_node_cddr(r_node_cadr(r_node_cadr(r_node_cdar(r_node_cdar(r_node_cddr(r_node_cadr(r_node_cdar(r_node_cddr(hnd))))))))))); r_node_poke_car(subscript_node, r_int(i + 1)); // Picks up `CLASS` r_obj* class_node = r_node_cdr(r_node_cdar(r_node_cdar(r_node_cdar(r_node_cddr(r_node_cadr(r_node_cdar(r_node_cddr(hnd)))))))); r_node_poke_car(class_node, r_str_as_character(cls)); args = r_new_node3(hnd, args, r_syms.condition); KEEP_AT(args, shelter); FREE(1); } args = r_new_node(r_syms.expr, args); KEEP_AT(args, shelter); r_obj* call = r_new_call(rlang_syms.withCallingHandlers, args); KEEP_AT(call, shelter); // Wrap in a `tryCatch(stackOverflowError = )` call if there are any // `error` handlers if (exiting_args != r_null) { exiting_args = r_new_node(call, exiting_args); KEEP_AT(exiting_args, exiting_shelter); call = r_new_call(rlang_syms.tryCatch, exiting_args); KEEP_AT(call, shelter); } r_obj* out = r_eval(call, env); FREE(3); return out; } void rlang_init_cnd_handlers(r_obj* ns) { hnd_call = r_eval(r_sym("handler_call"), ns); r_preserve_global(hnd_call); } rlang/src/internal/vec.c0000644000176200001440000001146314741441060014707 0ustar liggesusers#include #include "decl/vec-decl.h" bool r_is_atomic(r_obj* x, r_ssize n) { switch(r_typeof(x)) { case R_TYPE_logical: case R_TYPE_integer: case R_TYPE_double: case R_TYPE_complex: case R_TYPE_character: case RAWSXP: return _r_has_correct_length(x, n); default: return false; } } bool r_is_vector(r_obj* x, r_ssize n) { switch(r_typeof(x)) { case R_TYPE_logical: case R_TYPE_integer: case R_TYPE_double: case R_TYPE_complex: case R_TYPE_character: case RAWSXP: case VECSXP: return _r_has_correct_length(x, n); default: return false; } } bool r_is_logical(r_obj* x, r_ssize n) { return r_typeof(x) == R_TYPE_logical && _r_has_correct_length(x, n); } bool r_is_integer(r_obj* x, r_ssize n, int finite) { if (r_typeof(x) != R_TYPE_integer || !_r_has_correct_length(x, n)) { return false; } if (finite >= 0 && (bool) finite != _r_is_finite(x)) { return false; } return true; } bool r_is_double(r_obj* x, r_ssize n, int finite) { return _r_is_double(x, n, finite); } bool r_is_complex(r_obj* x, r_ssize n, int finite) { return _r_is_complex(x, n, finite); } bool r_is_integerish(r_obj* x, r_ssize n, int finite) { if (r_typeof(x) == R_TYPE_integer) { return r_is_integer(x, n, finite); } if (r_typeof(x) != R_TYPE_double || !_r_has_correct_length(x, n)) { return false; } r_ssize actual_n = r_length(x); const double* p_x = r_dbl_cbegin(x); bool actual_finite = true; for (r_ssize i = 0; i < actual_n; ++i) { double elt = p_x[i]; if (!isfinite(elt)) { actual_finite = false; continue; } if (!r_dbl_is_whole(elt)) { return false; } } if (finite >= 0 && actual_finite != (bool) finite) { return false; } return true; } bool is_character(r_obj* x, r_ssize n, enum option_bool missing, enum option_bool empty) { if (r_typeof(x) != R_TYPE_character) { return false; } if (!_r_has_correct_length(x, n)) { return false; } bool has_missing = missing != OPTION_BOOL_null; bool has_empty = empty != OPTION_BOOL_null; if (!has_missing && !has_empty) { return true; } if (missing == OPTION_BOOL_true && empty == OPTION_BOOL_true) { r_abort("Exactly one of `missing` and `empty` can be `TRUE`."); } n = r_length(x); r_obj* const * v_x = r_chr_cbegin(x); // Could we inspect ALTREP properties for the `missing` case? if (!list_match(v_x, n, r_strs.na, missing)) { return false; } if (!list_match(v_x, n, r_strs.empty, empty)) { return false; } return true; } static bool list_match(r_obj* const * v_x, r_ssize n, r_obj* value, enum option_bool match) { switch (match) { case OPTION_BOOL_null: return true; case OPTION_BOOL_true: for (r_ssize i = 0; i < n; ++i) { if (v_x[i] != value) { return false; } } return true; case OPTION_BOOL_false: for (r_ssize i = 0; i < n; ++i) { if (v_x[i] == value) { return false; } } return true; default: r_stop_unreachable(); } } bool r_is_raw(r_obj* x, r_ssize n) { return r_typeof(x) == R_TYPE_raw && _r_has_correct_length(x, n); } r_ssize validate_n(r_obj* n) { if (n == r_null) { return -1; } switch (r_typeof(n)) { case R_TYPE_integer: case R_TYPE_double: if (r_length(n) == 1) { break; } // fallthrough default: r_abort("`n` must be NULL or a scalar integer"); } return r_arg_as_ssize(n, "n"); } // Coercion ---------------------------------------------------------- static r_obj* vec_coercer(r_obj* to) { switch (r_typeof(to)) { case R_TYPE_logical: return rlang_ns_get("legacy_as_logical"); case R_TYPE_integer: return rlang_ns_get("legacy_as_integer"); case R_TYPE_double: return rlang_ns_get("legacy_as_double"); case R_TYPE_complex: return rlang_ns_get("legacy_as_complex"); case R_TYPE_character: return rlang_ns_get("legacy_as_character"); case RAWSXP: return rlang_ns_get("legacy_as_raw"); default: r_abort("No coercion implemented for `%s`", Rf_type2str(r_typeof(to))); } } void r_vec_poke_coerce_n(r_obj* x, r_ssize offset, r_obj* y, r_ssize from, r_ssize n) { if (r_typeof(y) == r_typeof(x)) { r_vec_poke_n(x, offset, y, from, n); return ; } if (r_is_object(y)) { r_abort("Can't splice S3 objects"); } // FIXME: This callbacks to rlang R coercers with an extra copy. r_obj* coercer = vec_coercer(x); r_obj* call = KEEP(Rf_lang2(coercer, y)); r_obj* coerced = KEEP(r_eval(call, R_BaseEnv)); r_vec_poke_n(x, offset, coerced, from, n); FREE(2); } void r_vec_poke_coerce_range(r_obj* x, r_ssize offset, r_obj* y, r_ssize from, r_ssize to) { r_vec_poke_coerce_n(x, offset, y, from, to - from + 1); } rlang/src/internal/internal.h0000644000176200001440000000305414741441060015750 0ustar liggesusers#ifndef RLANG_INTERNAL_INTERNAL_H #define RLANG_INTERNAL_INTERNAL_H #include #include "arg.h" #include "call.h" #include "globals.h" #include "quo.h" #include "vec.h" struct rlang_globals_syms { r_obj* c_null; r_obj* handlers; r_obj* tryCatch; r_obj* withCallingHandlers; }; extern r_obj* rlang_zap; extern r_obj* rlang_as_list_call; extern r_obj* rlang_objs_keep; extern r_obj* rlang_objs_trailing; extern r_obj* fns_function; extern r_obj* fns_quote; void rlang_init_internal(r_obj* ns); r_obj* rlang_ns_get(const char* name); // From dots.c r_obj* dots_values_node_impl(r_obj* frame_env, r_obj* named, r_obj* ignore_empty, r_obj* preserve_empty, r_obj* unquote_names, r_obj* homonyms, r_obj* check_assign, bool splice); static inline r_obj* rlang_dots(r_obj* env) { return dots_values_node_impl(env, r_false, rlang_objs_trailing, r_true, r_true, rlang_objs_keep, r_false, true); } r_obj* ffi_replace_na(r_obj* x, r_obj* replacement); r_obj* rlang_as_function(r_obj* x, r_obj* env); extern struct rlang_globals_syms rlang_syms; // From cnd.c // Protects with the vmax stack const char* obj_type_friendly(r_obj* x); #endif rlang/src/internal/names.c0000644000176200001440000001053014741441060015227 0ustar liggesusers#include #include #include "internal.h" #include "decl/names-decl.h" // 3 leading '.' + 1 trailing '\0' + 24 characters #define MAX_IOTA_SIZE 28 r_obj* ffi_names_as_unique(r_obj* names, r_obj* quiet) { return names_as_unique(names, r_lgl_get(quiet, 0)); } // [[ export() ]] r_obj* names_as_unique(r_obj* names, bool quiet) { if (is_unique_names(names) && !any_has_suffix(names)) { return names; } r_ssize n = r_length(names); r_obj* new_names = KEEP(r_clone(names)); r_obj* const * v_new_names = r_chr_cbegin(new_names); for (r_ssize i = 0; i < n; ++i) { r_obj* elt = v_new_names[i]; // Set `NA` and dots values to "" so they get replaced by `...n` // later on if (needs_suffix(elt)) { r_chr_poke(new_names, i, r_strs.empty); continue; } // Strip `...n` suffixes const char* nm = r_str_c_string(elt); int pos = suffix_pos(nm); if (pos >= 0) { elt = Rf_mkCharLenCE(nm, pos, Rf_getCharCE(elt)); r_chr_poke(new_names, i, elt); continue; } } // Append all duplicates with a suffix r_obj* dups = KEEP(chr_detect_dups(new_names)); const int* dups_ptr = r_lgl_cbegin(dups); for (r_ssize i = 0; i < n; ++i) { r_obj* elt = v_new_names[i]; if (elt != r_strs.empty && !dups_ptr[i]) { continue; } const char* name = r_str_c_string(elt); int size = strlen(name); int buf_size = size + MAX_IOTA_SIZE; R_CheckStack2(buf_size); char buf[buf_size]; buf[0] = '\0'; memcpy(buf, name, size); int remaining = buf_size - size; int needed = snprintf(buf + size, remaining, "...%" R_PRI_SSIZE, i + 1); if (needed >= remaining) { stop_large_name(); } r_chr_poke(new_names, i, Rf_mkCharLenCE(buf, size + needed, Rf_getCharCE(elt))); } if (!quiet) { names_inform_repair(names, new_names); } FREE(2); return new_names; } static bool is_unique_names(r_obj* names) { if (r_typeof(names) != R_TYPE_character) { r_abort("`names` must be a character vector."); } r_ssize n = r_length(names); r_obj* const * v_names = r_chr_cbegin(names); if (Rf_any_duplicated(names, FALSE)) { return false; } for (r_ssize i = 0; i < n; ++i) { r_obj* elt = v_names[i]; if (needs_suffix(elt)) { return false; } } return true; } static bool any_has_suffix(r_obj* names) { r_ssize n = r_length(names); r_obj* const * v_names = r_chr_cbegin(names); for (r_ssize i = 0; i < n; ++i) { const char* elt = r_str_c_string(v_names[i]); if (suffix_pos(elt) >= 0) { return true; } } return false; } static ptrdiff_t suffix_pos(const char* name) { int n = strlen(name); const char* suffix_end = NULL; int in_dots = 0; bool in_digits = false; for (const char* ptr = name + n - 1; ptr >= name; --ptr) { char c = *ptr; if (in_digits) { if (c == '.') { in_digits = false; in_dots = 1; continue; } if (isdigit(c)) { continue; } goto done; } switch (in_dots) { case 0: if (isdigit(c)) { in_digits = true; continue; } goto done; case 1: case 2: if (c == '.') { ++in_dots; continue; } goto done; case 3: suffix_end = ptr + 1; if (isdigit(c)) { in_dots = 0; in_digits = true; continue; } goto done; default: r_stop_internal("Unexpected state."); }} done: if (suffix_end) { return suffix_end - name; } else { return -1; } } static bool needs_suffix(r_obj* str) { return str == r_strs.na || str == r_strs.dots || str == r_strs.empty || is_dotdotint(r_str_c_string(str)); } static bool is_dotdotint(const char* name) { int n = strlen(name); if (n < 3) { return false; } if (name[0] != '.' || name[1] != '.') { return false; } if (name[2] == '.') { name += 3; } else { name += 2; } return (bool) strtol(name, NULL, 10); } static void names_inform_repair(r_obj* old_names, r_obj* new_names) { r_obj* call = KEEP(r_call3(r_sym("names_inform_repair"), old_names, new_names)); r_eval(call, rlang_ns_env); FREE(1); } static void stop_large_name(void) { r_abort("Can't tidy up name because it is too large."); } rlang/src/internal/nse-defuse.c0000644000176200001440000000102614741441060016162 0ustar liggesusers#include #include "utils.h" // Defined in capture.c r_obj* rlang_capturearginfo(r_obj* call, r_obj* op, r_obj* args, r_obj* rho); r_obj* rlang_capturedots(r_obj* call, r_obj* op, r_obj* args, r_obj* rho); r_obj* ffi_capturearginfo(r_obj* args) { args = r_node_cdr(args); r_obj* env = r_node_car(args); args = r_node_cdr(args); return rlang_capturearginfo(r_null, r_null, args, env); } r_obj* ffi_capturedots(r_obj* args) { args = r_node_cdr(args); return rlang_capturedots(r_null, r_null, args, r_envs.base); } rlang/src/internal/nse-inject.c0000644000176200001440000002601114376147516016201 0ustar liggesusers#include #include "nse-inject.h" #include "ast-rotate.h" #include "utils.h" struct injection_info which_bang_op(r_obj* second, struct injection_info info); struct injection_info which_curly_op(r_obj* second, struct injection_info info); struct injection_info which_uq_op(r_obj* first) { struct injection_info info = init_expansion_info(); if (r_is_call(first, "(")) { r_obj* paren = r_node_cadr(first); if (r_is_call(paren, "(")) { return info; } struct injection_info inner_info = which_uq_op(paren); // Check that `root` is NULL so we don't remove parentheses when // there's an operation tail (i.e. when the parse tree was fixed // up to bind tightly) if (inner_info.op == INJECTION_OP_uq && inner_info.root == r_null) { return inner_info; } else { return info; } } if (r_typeof(first) != R_TYPE_call) { return info; } r_obj* head = r_node_car(first); if (r_typeof(head) != R_TYPE_symbol) { return info; } const char* nm = r_sym_c_string(head); if (strcmp(nm, "!") == 0) { return which_bang_op(r_node_cadr(first), info); } else if (strcmp(nm, "{") == 0) { return which_curly_op(first, info); } else { return info; } } struct injection_info which_bang_op(r_obj* second, struct injection_info info) { if (!r_is_call(second, "!")) { return info; } r_obj* third = r_node_cadr(second); // Need to fill in `info` for `!!` because parse tree might need changes if (!r_is_call(third, "!")) { if (is_problematic_op(third)) { info.op = INJECTION_OP_fixup; info.operand = third; } else { info.op = INJECTION_OP_uq; info.parent = r_node_cdr(second); info.operand = third; } return info; } info.op = INJECTION_OP_uqs; info.operand = r_node_cadr(third); return info; } struct injection_info which_curly_op(r_obj* first, struct injection_info info) { r_obj* first_cdr = r_node_cdr(first); r_obj* second = r_node_car(first_cdr); if (!r_is_call(second, "{") || r_node_cdr(first_cdr) != r_null) { return info; } info.op = INJECTION_OP_curly; info.parent = r_node_cdr(second); info.operand = r_node_cadr(second); return info; } // These functions are questioning and might be soft-deprecated in the // future void signal_uq_soft_deprecation(void) { return ; const char* msg = "`UQ()` is soft-deprecated as of rlang 0.2.0. " "Please use the prefix form of `!!` instead."; deprecate_soft(msg, msg, r_envs.empty); } void signal_uqs_soft_deprecation(void) { return ; const char* msg = "`UQS()` is soft-deprecated as of rlang 0.2.0. " "Please use the prefix form of `!!!` instead."; deprecate_soft(msg, msg, r_envs.empty); } void signal_namespaced_uq_deprecation(void) { deprecate_warn("namespaced rlang::UQ()", "Prefixing `UQ()` with the rlang namespace is deprecated as of rlang 0.3.0.\n" "Please use the non-prefixed form or `!!` instead.\n" "\n" " # Bad:\n" " rlang::expr(mean(rlang::UQ(var) * 100))\n" "\n" " # Ok:\n" " rlang::expr(mean(UQ(var) * 100))\n" "\n" " # Good:\n" " rlang::expr(mean(!!var * 100))\n" ); } void signal_namespaced_uqs_deprecation(void) { deprecate_warn("namespaced rlang::UQS()", "Prefixing `UQS()` with the rlang namespace is deprecated as of rlang 0.3.0.\n" "Please use the non-prefixed form or `!!!` instead.\n" "\n" " # Bad:\n" " rlang::expr(mean(rlang::UQS(args)))\n" "\n" " # Ok:\n" " rlang::expr(mean(UQS(args)))\n" "\n" " # Good:\n" " rlang::expr(mean(!!!args))\n" ); } void maybe_poke_big_bang_op(r_obj* x, struct injection_info* info) { if (r_is_call(x, "!!!")) { if (r_node_cddr(x) != r_null) { r_abort("Can't supply multiple arguments to `!!!`"); } info->op = INJECTION_OP_uqs; info->operand = r_node_cadr(x); return ; } // Handle expressions like foo::`!!`(bar) or foo$`!!`(bar) if (r_is_prefixed_call(x, "!!!")) { const char* name = r_sym_c_string(r_node_caar(x)); r_abort("Prefix form of `!!!` can't be used with `%s`", name); } bool namespaced_uqs = r_is_namespaced_call(x, "rlang", "UQS"); if (namespaced_uqs) { signal_namespaced_uqs_deprecation(); } if (namespaced_uqs || r_is_call(x, "UQS")) { signal_uqs_soft_deprecation(); info->op = INJECTION_OP_uqs; info->operand = r_node_cadr(x); return ; } } static r_obj* dot_data_sym = NULL; struct injection_info which_expansion_op(r_obj* x, bool unquote_names) { struct injection_info info = which_uq_op(x); if (r_typeof(x) != R_TYPE_call) { return info; } if (info.op) { return info; } if (is_problematic_op(x)) { info.op = INJECTION_OP_fixup; return info; } if (unquote_names && r_is_call(x, ":=")) { info.op = INJECTION_OP_uqn; return info; } if (r_is_call(x, "!!")) { info.op = INJECTION_OP_uq; info.operand = r_node_cadr(x); return info; } // Handle expressions like foo::`!!`(bar) or foo$`!!`(bar) if (r_is_prefixed_call(x, "!!")) { info.op = INJECTION_OP_uq; info.operand = r_node_cadr(x); info.parent = r_node_cdr(r_node_cdar(x)); info.root = r_node_car(x); return info; } maybe_poke_big_bang_op(x, &info); if (info.op == INJECTION_OP_uqs) { return info; } // This logic is complicated because rlang::UQ() gets fully unquoted // but not foobar::UQ(). The functional form UI is now retired so // we'll be able to simplify this in the future. if (r_is_prefixed_call(x, "UQ")) { signal_uq_soft_deprecation(); info.op = INJECTION_OP_uq; info.operand = r_node_cadr(x); if (r_is_namespaced_call(x, "rlang", NULL)) { signal_namespaced_uq_deprecation(); } else { info.parent = r_node_cdr(r_node_cdar(x)); info.root = r_node_car(x); } return info; } if (r_is_call(x, "UQ")) { signal_uq_soft_deprecation(); info.op = INJECTION_OP_uq; info.operand = r_node_cadr(x); return info; } if (r_is_call(x, "[[") && r_node_cadr(x) == dot_data_sym) { info.op = INJECTION_OP_dot_data; info.root = x; info.parent = r_node_cddr(x); info.operand = r_node_car(info.parent); // User had to unquote operand manually before .data[[ was unquote syntax struct injection_info nested = which_expansion_op(info.operand, false); if (nested.op == INJECTION_OP_uq) { const char* msg = "It is no longer necessary to unquote within the `.data` pronoun"; deprecate_soft(msg, msg, r_envs.empty); info.operand = nested.operand; } return info; } return info; } struct injection_info is_big_bang_op(r_obj* x) { struct injection_info info = which_uq_op(x); if (info.op != INJECTION_OP_uqs) { maybe_poke_big_bang_op(x, &info); } return info; } static r_obj* bang_bang_teardown(r_obj* value, struct injection_info info) { r_mark_shared(value); if (info.parent != r_null) { r_node_poke_car(info.parent, value); } if (info.root == r_null) { return value; } else { return info.root; } } static r_obj* bang_bang(struct injection_info info, r_obj* env) { r_obj* value = r_eval(info.operand, env); return bang_bang_teardown(value, info); } // From dots.c r_obj* big_bang_coerce_pairlist(r_obj* x, bool deep); r_obj* big_bang(r_obj* operand, r_obj* env, r_obj* prev, r_obj* node) { r_obj* value = KEEP(r_eval(operand, env)); value = big_bang_coerce_pairlist(value, true); if (value == r_null) { // Remove `!!!foo` from pairlist of args r_node_poke_cdr(prev, r_node_cdr(node)); node = prev; } else { // Insert coerced value into existing pairlist of args r_obj* tail = r_pairlist_tail(value); r_node_poke_cdr(tail, r_node_cdr(node)); r_node_poke_cdr(prev, value); node = tail; } FREE(1); return node; } static r_obj* curly_curly(struct injection_info info, r_obj* env) { r_obj* value = ffi_enquo(info.operand, env); return bang_bang_teardown(value, info); } // Defined below static r_obj* call_list_interp(r_obj* x, r_obj* env); static r_obj* node_list_interp(r_obj* x, r_obj* env); static void call_maybe_poke_string_head(r_obj* call); r_obj* call_interp(r_obj* x, r_obj* env) { struct injection_info info = which_expansion_op(x, false); return call_interp_impl(x, env, info); } r_obj* call_interp_impl(r_obj* x, r_obj* env, struct injection_info info) { if (info.op && info.op != INJECTION_OP_fixup && r_node_cdr(x) == r_null) { r_abort("`UQ()` and `UQS()` must be called with an argument"); } switch (info.op) { case INJECTION_OP_none: if (r_typeof(x) != R_TYPE_call) { return x; } else { r_obj* out = call_list_interp(x, env); call_maybe_poke_string_head(out); return out; } case INJECTION_OP_uq: return bang_bang(info, env); case INJECTION_OP_curly: return curly_curly(info, env); case INJECTION_OP_dot_data: { r_obj* out = KEEP(bang_bang(info, env)); // Replace symbols by strings r_obj* subscript_node = r_node_cddr(out); r_obj* subscript = r_node_car(subscript_node); if (is_quosure(subscript)) { subscript = r_node_cadr(subscript); } if (r_typeof(subscript) == R_TYPE_symbol) { subscript = r_sym_as_utf8_character(subscript); r_node_poke_car(subscript_node, subscript); } FREE(1); return out; } case INJECTION_OP_fixup: if (info.operand == r_null) { return fixup_interp(x, env); } else { return fixup_interp_first(info.operand, env); } case INJECTION_OP_uqs: r_abort("Can't use `!!!` at top level."); case INJECTION_OP_uqn: r_abort("Internal error: Deep `:=` unquoting."); } r_stop_unreachable(); } // Make (!!"foo")() and "foo"() equivalent static void call_maybe_poke_string_head(r_obj* call) { r_obj* head = r_node_car(call); if (r_typeof(head) != R_TYPE_character) { return ; } r_ssize n = r_length(head); if (n != 1) { r_abort("Unquoted function name must be a character vector of length 1"); } r_node_poke_car(call, r_sym(r_chr_get_c_string(head, 0))); } static r_obj* call_list_interp(r_obj* x, r_obj* env) { r_node_poke_car(x, call_interp(r_node_car(x), env)); r_node_poke_cdr(x, node_list_interp(r_node_cdr(x), env)); return x; } static r_obj* node_list_interp(r_obj* node, r_obj* env) { r_obj* prev = KEEP(r_new_node(r_null, node)); r_obj* out = prev; while (node != r_null) { r_obj* arg = r_node_car(node); struct injection_info info = which_expansion_op(arg, false); if (info.op == INJECTION_OP_uqs) { node = big_bang(info.operand, env, prev, node); } else { r_node_poke_car(node, call_interp_impl(arg, env, info)); } prev = node; node = r_node_cdr(node); } FREE(1); return r_node_cdr(out); } r_obj* ffi_interp(r_obj* x, r_obj* env) { if (!r_is_environment(env)) { r_abort("`env` must be an environment"); } if (r_typeof(x) != R_TYPE_call) { return x; } // FIXME: Only duplicate the call tree, not the leaves x = KEEP(r_copy(x)); x = call_interp(x, env); FREE(1); return x; } void rlang_init_expr_interp(void) { dot_data_sym = r_sym(".data"); } rlang/src/internal/file.c0000644000176200001440000000203014175213516015043 0ustar liggesusers#include #include "file.h" #ifdef _WIN32 #include #endif // This is needed to support wide character paths on windows. // `path` is a CHARSXP containing the file path. FILE* r_fopen(r_obj* path, const char* mode) { FILE* out; const void* vmax = vmaxget(); #ifdef _WIN32 const char* path_c = Rf_translateCharUTF8(path); // First convert the mode to the wide equivalent. // Only usage is 2 characters ("rb") so max 8 bytes + 2 byte null. wchar_t mode_w[10]; MultiByteToWideChar(CP_UTF8, 0, mode, -1, mode_w, 9); // Then convert the path size_t len = MultiByteToWideChar(CP_UTF8, 0, path_c, -1, NULL, 0); if (len <= 0) { r_abort("Can't convert file to Unicode: %s.", path_c); } wchar_t* buf = (wchar_t*)R_alloc(len, sizeof(wchar_t)); if (buf == NULL) { r_abort("Can't allocate buffer of size %ll.", len); } MultiByteToWideChar(CP_UTF8, 0, path_c, -1, buf, len); out = _wfopen(buf, mode_w); #else out = fopen(Rf_translateChar(path), mode); #endif vmaxset(vmax); return out; } rlang/src/internal/quo.h0000644000176200001440000000106314376112150014735 0ustar liggesusers#ifndef RLANG_INTERNAL_QUO_H #define RLANG_INTERNAL_QUO_H #include r_obj* ffi_new_quosure(r_obj* expr, r_obj* env); bool is_quosure(r_obj* x); r_obj* ffi_get_expression(r_obj* x, r_obj* alternate); r_obj* ffi_quo_get_env(r_obj* quo); r_obj* ffi_quo_get_expr(r_obj* quo); static inline r_obj* quo_get_expr(r_obj* quo) { return r_node_cadr(quo); } void check_quosure(r_obj* x); bool quo_is_missing(r_obj* quo); bool quo_is_symbol(r_obj* quo); bool quo_is_call(r_obj* quo); bool quo_is_symbolic(r_obj* quo); bool quo_is_null(r_obj* quo); #endif rlang/src/internal/decl/0000755000176200001440000000000014741441060014670 5ustar liggesusersrlang/src/internal/decl/names-decl.h0000644000176200001440000000056714375670676017105 0ustar liggesusersr_obj* names_as_unique(r_obj* names, bool quiet); static bool any_has_suffix(r_obj* names); static bool is_unique_names(r_obj* names); static ptrdiff_t suffix_pos(const char* name); static bool needs_suffix(r_obj* str); static void names_inform_repair(r_obj* old_names, r_obj* new_names); static void stop_large_name(void); static bool is_dotdotint(const char* name); rlang/src/internal/decl/encoding-decl.h0000644000176200001440000000064014175213516017540 0ustar liggesusersstatic r_obj* chr_encode_utf8(r_obj* x); static inline r_ssize chr_find_encoding_start(r_obj* x, r_ssize size); static r_obj* list_encode_utf8(r_obj* x); static r_obj* obj_attrib_encode_utf8(r_obj* x, r_obj* attrib); static r_obj* attrib_encode_utf8(r_obj* x); static inline r_obj* str_encode_utf8(r_obj* x); static inline bool str_needs_encoding(r_obj* x); static inline bool str_is_ascii_or_utf8(r_obj* x); rlang/src/internal/decl/ast-rotate-decl.h0000644000176200001440000000077614375670676020067 0ustar liggesusersstatic r_obj* node_list_interp_fixup(r_obj* x, r_obj* parent, r_obj* env, struct ast_rotation_info* rotation_info, bool expand_lhs); static void node_list_interp_fixup_rhs(r_obj* rhs, r_obj* rhs_node, r_obj* parent, r_obj* env, struct ast_rotation_info* info); rlang/src/internal/decl/tests-decl.h0000644000176200001440000000003614175213516017113 0ustar liggesusersstatic r_obj* tests_df_names; rlang/src/internal/decl/dots-decl.h0000644000176200001440000000153514376112150016722 0ustar liggesusersstatic r_obj* auto_name_call; static r_obj* dots_homonyms_values; static r_obj* dots_ignore_empty_values; static r_obj* empty_spliced_arg; static r_obj* glue_embrace_fn; static r_obj* quosures_attrib; static r_obj* splice_box_attrib; static r_obj* abort_dots_homonyms_ns_sym; static struct r_lazy dots_homonyms_arg; static struct r_lazy dots_ignore_empty_arg; r_obj* rlang_ns_get(const char* name); static enum dots_ignore_empty arg_match_ignore_empty(r_obj* ignore_empty); static enum dots_homonyms arg_match_homonyms(r_obj* homonyms); static enum arg_named arg_match_named(r_obj* named); static inline bool should_ignore(struct dots_capture_info* p_capture_info, r_obj* expr, r_obj* name, bool last); static inline void ignore(struct dots_capture_info* p_capture_info, r_obj* node); rlang/src/internal/decl/attr-decl.h0000644000176200001440000000124614376112150016722 0ustar liggesusersstatic r_obj* c_fn; static r_obj* as_character_call; static r_obj* names_call; static r_obj* set_names_call; static r_obj* length_call; static r_obj* node_names(r_obj* x); static r_obj* names_dispatch(r_obj* x, r_obj* env); static inline r_obj* eval_fn_dots(r_obj* fn, r_obj* x, r_obj* dots, r_obj* env); static inline r_obj* eval_as_character(r_obj* x, r_obj* env); static inline r_obj* set_names_dispatch(r_obj* x, r_obj* nm, r_obj* env); static inline r_ssize length_dispatch(r_obj* x, r_obj* env); static r_obj* fn_zap_srcref(r_obj* x); static r_obj* call_zap_srcref(r_obj* x); static r_obj* expr_vec_zap_srcref(r_obj* x); static void attrib_zap_srcref(r_obj* x); rlang/src/internal/decl/sym-unescape-decl.h0000644000176200001440000000006114175213516020360 0ustar liggesusersr_obj* str_unserialise_unicode(r_obj* r_string); rlang/src/internal/decl/cnd-handlers-decl.h0000644000176200001440000000012214375670676020327 0ustar liggesusers// dots.c r_obj* rlang_env_dots_list(r_obj* env); static r_obj* hnd_call = NULL; rlang/src/internal/decl/hash-decl.h0000644000176200001440000000005414175213516016674 0ustar liggesusersstatic r_obj* hash_file_impl(void* p_data); rlang/src/internal/decl/call-decl.h0000644000176200001440000000054714375670676016713 0ustar liggesusersstatic bool call_is_namespaced(r_obj* x, r_obj* ns); static inline r_obj* call_unnamespace(r_obj* x); static bool is_callable(r_obj* x); static void call_zap_inline(r_obj* x); static void node_zap_inline(r_obj* x); static r_obj* call_zap_one(r_obj* x); static void call_zap_fn(r_obj* x); static r_obj* type_sum(r_obj* x); static r_obj* type_sum_call; rlang/src/internal/decl/env-decl.h0000644000176200001440000000025614175213516016545 0ustar liggesusersstatic r_obj* env_get_sym(r_obj* env, r_obj* sym, bool inherit, r_obj* last, r_obj* closure_env); rlang/src/internal/decl/cnd-decl.h0000644000176200001440000000071014375670676016534 0ustar liggesusersstatic r_obj* with_winch(void* payload); static void without_winch(void* payload); static r_no_return r_obj* stop_internal_cb(void* payload); // From rlang/vec-chr.c r_obj* chr_append(r_obj* chr, r_obj* 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); static r_obj* new_condition_names(r_obj* data); static r_obj* format_arg_call; static r_obj* obj_type_friendly_call; rlang/src/internal/decl/arg-decl.h0000644000176200001440000000050614375670676016544 0ustar liggesusersstatic r_obj* stop_arg_match_call; static enum r_type arg_match_arg_nm_type(r_obj* arg_nm); static r_obj* wrap_chr(r_obj* arg); static r_obj* lazy_wrap_chr(struct r_lazy arg); static int arg_match1(r_obj* arg, r_obj* values, struct r_lazy error_arg, struct r_lazy error_call); rlang/src/internal/decl/standalone-types-check-decl.h0000644000176200001440000000133614376112150022315 0ustar liggesusersstatic enum is_number int_standalone_check_number(r_obj* x, r_obj* ffi_min, r_obj* ffi_max, r_obj* allow_na, r_obj* allow_null); static enum is_number dbl_standalone_check_number(r_obj* x, r_obj* allow_decimal, r_obj* ffi_min, r_obj* ffi_max, r_obj* allow_infinite, r_obj* allow_na, r_obj* allow_null); rlang/src/internal/decl/vec-decl.h0000644000176200001440000000021514741441060016521 0ustar liggesusersstatic bool list_match(r_obj* const * v_x, r_ssize n, r_obj* value, enum option_bool match); rlang/src/internal/parse.h0000644000176200001440000000516414376112150015251 0ustar liggesusers#ifndef RLANG_INTERNAL_PARSE_H #define RLANG_INTERNAL_PARSE_H #include // This only includes operators that actually appear in the AST. // Examples of silent operators are `else` and `in`. enum r_operator { R_OP_NONE = 0, R_OP_BREAK, R_OP_NEXT, R_OP_FUNCTION, R_OP_WHILE, R_OP_FOR, R_OP_REPEAT, R_OP_IF, R_OP_QUESTION, R_OP_QUESTION_UNARY, R_OP_ASSIGN1, R_OP_ASSIGN2, R_OP_ASSIGN_EQUAL, R_OP_COLON_EQUAL, R_OP_TILDE, R_OP_TILDE_UNARY, R_OP_OR1, R_OP_OR2, R_OP_AND1, R_OP_AND2, R_OP_BANG1, R_OP_BANG3, R_OP_GREATER, R_OP_GREATER_EQUAL, R_OP_LESS, R_OP_LESS_EQUAL, R_OP_EQUAL, R_OP_NOT_EQUAL, R_OP_PLUS, R_OP_MINUS, R_OP_TIMES, R_OP_RATIO, R_OP_MODULO, R_OP_SPECIAL, R_OP_COLON1, R_OP_BANG2, R_OP_PLUS_UNARY, R_OP_MINUS_UNARY, R_OP_HAT, R_OP_DOLLAR, R_OP_AT, R_OP_COLON2, R_OP_COLON3, R_OP_PARENTHESES, R_OP_BRACKETS1, R_OP_BRACKETS2, R_OP_BRACES, R_OP_EMBRACE, R_OP_MAX }; enum r_operator r_which_operator(r_obj* call); const char* r_op_as_c_string(enum r_operator op); /** * struct r_op_precedence - Information about operator precedence * * @power: Binding power. Absolute value has no meaning, only the * relative ordering between operators has meaning. * @assoc: -1 if left associative, 0 if non-associative, 1 if right associative. * @unary: `false` if a binary operation. * @delimited: `true` if an operation like `(` or `{`. */ struct r_op_precedence { uint8_t power; int8_t assoc; bool unary; bool delimited; }; extern const struct r_op_precedence r_ops_precedence[R_OP_MAX]; /** * r_op_has_precedence() - Does an operation have precedence over another? * * Relies on information in the table of operation metadata * %r_ops_precedence. * * @x The call that was found lower in the AST (i.e. the call that is * supposed to have precedence). * @parent The call that was found earlier in the AST (i.e. the one * that wraps @x). */ bool r_op_has_precedence(enum r_operator x, enum r_operator parent); bool r_rhs_op_has_precedence(enum r_operator rhs, enum r_operator parent); bool r_lhs_op_has_precedence(enum r_operator lhs, enum r_operator parent); static inline bool r_call_has_precedence(r_obj* x, r_obj* parent) { return r_op_has_precedence(r_which_operator(x), r_which_operator(parent)); } static inline bool r_lhs_call_has_precedence(r_obj* lhs, r_obj* parent) { return r_lhs_op_has_precedence(r_which_operator(lhs), r_which_operator(parent)); } static inline bool r_rhs_call_has_precedence(r_obj* rhs, r_obj* parent) { return r_rhs_op_has_precedence(r_which_operator(rhs), r_which_operator(parent)); } #endif rlang/src/internal/vec.h0000644000176200001440000000173414376112150014713 0ustar liggesusers#ifndef RLANG_INTERNAL_VEC_H #define RLANG_INTERNAL_VEC_H #include enum option_bool { OPTION_BOOL_false = -1, OPTION_BOOL_null = 0, OPTION_BOOL_true = 1 }; bool r_is_vector(r_obj* x, r_ssize n); bool r_is_atomic(r_obj* x, r_ssize n); bool _r_is_finite(r_obj* x); bool r_is_logical(r_obj* x, r_ssize n); bool r_is_integerish(r_obj* x, r_ssize n, int finite); bool r_is_integer(r_obj* x, r_ssize n, int finite); bool r_is_double(r_obj* x, r_ssize n, int finite); bool r_is_complex(r_obj* x, r_ssize n, int finite); bool is_character(r_obj* x, r_ssize n, enum option_bool missing, enum option_bool empty); bool r_is_raw(r_obj* x, r_ssize n); r_ssize validate_n(r_obj* n); void r_vec_poke_coerce_n(r_obj* x, r_ssize offset, r_obj* y, r_ssize from, r_ssize n); void r_vec_poke_coerce_range(r_obj* x, r_ssize offset, r_obj* y, r_ssize from, r_ssize to); #endif rlang/src/internal/nse-inject.h0000644000176200001440000000372514401436745016207 0ustar liggesusers#ifndef RLANG_INTERNAL_NSE_INJECT_H #define RLANG_INTERNAL_NSE_INJECT_H #include #include "quo.h" #include "utils.h" #define UQ_N 2 #define UQS_N 2 static const char* uqs_names[UQS_N] = { "UQS", "!!!"}; static inline bool is_maybe_rlang_call(r_obj* x, const char* name) { return r_is_call(x, name) || r_is_namespaced_call(x, "rlang", name); } static inline bool is_maybe_rlang_call_any(r_obj* x, const char** names, int n) { return r_is_call_any(x, names, n) || r_is_namespaced_call_any(x, "rlang", names, n); } static inline bool is_splice_call(r_obj* node) { return is_maybe_rlang_call_any(node, uqs_names, UQS_N); } enum injection_op { INJECTION_OP_none, INJECTION_OP_uq, INJECTION_OP_uqs, INJECTION_OP_uqn, INJECTION_OP_fixup, INJECTION_OP_dot_data, INJECTION_OP_curly }; #define INJECTION_OP_MAX 7 struct injection_info { enum injection_op op; r_obj* operand; // Expression being unquoted r_obj* parent; // Node pointing to the future unquoted value r_obj* root; // Expression wrapping the unquoted value (optional) }; static inline struct injection_info init_expansion_info(void) { struct injection_info info; info.op = INJECTION_OP_none; info.operand = r_null; info.parent = r_null; info.root = r_null; return info; } struct injection_info which_uq_op(r_obj* x); struct injection_info which_expansion_op(r_obj* x, bool unquote_names); struct injection_info is_big_bang_op(r_obj* x); r_obj* big_bang_coerce(r_obj* expr); r_obj* ffi_interp(r_obj* x, r_obj* env); r_obj* call_interp(r_obj* x, r_obj* env); r_obj* call_interp_impl(r_obj* x, r_obj* env, struct injection_info info); static inline r_obj* forward_quosure(r_obj* x, r_obj* env) { switch (r_typeof(x)) { case R_TYPE_call: if (is_quosure(x)) { return x; } // else fallthrough case R_TYPE_symbol: case R_TYPE_closure: return ffi_new_quosure(x, env); default: return ffi_new_quosure(x, r_envs.empty); } } #endif rlang/src/internal.c0000644000176200001440000000003714741441443014132 0ustar liggesusers#include "internal/internal.c" rlang/src/version.c0000644000176200001440000000166314741441060014004 0ustar liggesusers#define R_NO_REMAP #include const char* rlang_version = "1.1.5"; /** * This file records the expected package version in the shared * library (or DLL) of the package. This is useful to check that users * have properly installed your package. Installation issues where the * package is updated but the DLL isn't are common on Windows in * particular. To automatically check that the native library of the * package was properly installed: * * - Register the function below as a C callable under the name * "ffi_linked_version". * * - Call `rlang::check_linked_version(pkg_name)` from your * `.onLoad()` hook. If you don't depend on rlang copy the * compat-linked-version.R file from the rlang repository to your R * folder. Find it at * */ // [[ register() ]] SEXP rlang_linked_version(void) { return Rf_mkString(rlang_version); } rlang/src/Makevars0000644000176200001440000000400714741441060013642 0ustar liggesusersPKG_CPPFLAGS = -I./rlang/ PKG_CFLAGS = $(C_VISIBILITY) lib-files = \ rlang/rlang.h \ rlang/arg.c \ rlang/attrib.c \ rlang/call.c \ rlang/cnd.c \ rlang/c-utils.c \ rlang/debug.c \ rlang/dict.c \ rlang/df.c \ rlang/dyn-array.c \ rlang/dyn-list-of.c \ rlang/env.c \ rlang/env-binding.c \ rlang/eval.c \ rlang/export.c \ rlang/fn.c \ rlang/formula.c \ rlang/globals.c \ rlang/node.c \ rlang/parse.c \ rlang/quo.c \ rlang/rlang.c \ rlang/obj.c \ rlang/stack.c \ rlang/sym.c \ rlang/vec.c \ rlang/vec-chr.c \ rlang/vec-lgl.c \ rlang/vendor.c \ rlang/walk.c lib-cpp-files = \ rlang/cpp/rlang.cpp \ rlang/cpp/vec.cpp internal-files = \ internal/arg.c \ internal/ast-rotate.c \ internal/attr.c \ internal/call.c \ internal/cnd.c \ internal/cnd-handlers.c \ internal/dots.c \ internal/dots-ellipsis.c \ internal/encoding.c \ internal/env.c \ internal/env-binding.c \ internal/eval.c \ internal/eval-tidy.c \ internal/exported.c \ internal/file.c \ internal/fn.c \ internal/globals.c \ internal/hash.c \ internal/init.c \ internal/internal.c \ internal/names.c \ internal/nse-defuse.c \ internal/nse-inject.c \ internal/parse.c \ internal/quo.c \ internal/replace-na.c \ internal/squash.c \ internal/standalone-types-check.c \ internal/sym-unescape.c \ internal/tests.c \ internal/utils.c \ internal/vec.c \ internal/vec-raw.c \ internal/weakref.c all: $(SHLIB) $(SHLIB): rlang.o internal.o rlang.c: $(lib-files) touch rlang.c internal.c: $(internal-files) touch internal.c export.c: $(export-files) touch export.c .PHONY: all rlang/src/rlang/0000755000176200001440000000000014742464552013264 5ustar liggesusersrlang/src/rlang/obj.h0000644000176200001440000000537114741441060014201 0ustar liggesusers#ifndef RLANG_OBJ_H #define RLANG_OBJ_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 void r_mark_object(r_obj* x) { SET_OBJECT(x, 1); } static inline void r_unmark_object(r_obj* x) { SET_OBJECT(x, 0); } static inline bool r_is_object(r_obj* x) { return OBJECT(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); } static inline r_obj* r_clone_shared(r_obj* x) { return r_is_shared(x) ? r_clone(x) : 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_poke_type(r_obj* x, enum r_type type) { SET_TYPEOF(x, type); return 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 rlang/src/rlang/dyn-array.h0000644000176200001440000001251714741441060015335 0ustar liggesusers#ifndef RLANG_DYN_ARRAY_H #define RLANG_DYN_ARRAY_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 rlang/src/rlang/debug.c0000644000176200001440000000120414175213516014503 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_poke(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); } rlang/src/rlang/arg.h0000644000176200001440000000035214741441060014172 0ustar liggesusers#ifndef RLANG_ARG_H #define RLANG_ARG_H extern int (*r_arg_match)(r_obj* arg, r_obj* values, struct r_lazy error_arg, struct r_lazy error_call); #endif rlang/src/rlang/vec-chr.h0000644000176200001440000000344314741441060014754 0ustar liggesusers#ifndef RLANG_VECTOR_CHR_H #define RLANG_VECTOR_CHR_H #include 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 rlang/src/rlang/arg.c0000644000176200001440000000051714375670676014214 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"); } rlang/src/rlang/rlang.h0000644000176200001440000000362214741441060014527 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 #include #define R_NO_REMAP #include #include #include #include #include "rlang-types.h" 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; #include "obj.h" #include "globals.h" #include "altrep.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 "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" #define r_abort_lazy_call(LAZY, ...) \ r_abort_call(KEEP(r_lazy_eval(LAZY)), __VA_ARGS__) #endif rlang/src/rlang/parse.c0000644000176200001440000000132514175213516014533 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; } rlang/src/rlang/dyn-list-of.c0000644000176200001440000001562014375670676015611 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) { memcpy(p, p_elt, p_lof->elt_byte_size); } else { 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; 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; } rlang/src/rlang/node.h0000644000176200001440000000360314741441060014350 0ustar liggesusers#ifndef RLANG_NODE_H #define RLANG_NODE_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_find(r_obj* node, r_obj* tag); r_obj* r_pairlist_rev(r_obj* node); 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 rlang/src/rlang/cpp/0000755000176200001440000000000014375670676014056 5ustar liggesusersrlang/src/rlang/cpp/rlang.cpp0000644000176200001440000000002314175213516015640 0ustar liggesusers#include "vec.cpp" rlang/src/rlang/cpp/vec.cpp0000644000176200001440000000073114375670676015340 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"); } } } rlang/src/rlang/call.h0000644000176200001440000000060714741441060014337 0ustar liggesusers#ifndef RLANG_LANG_H #define RLANG_LANG_H #include "node.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 rlang/src/rlang/fn.c0000644000176200001440000000161414375670676014045 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); } rlang/src/rlang/formula.c0000644000176200001440000000354114175213516015070 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_obj* attrs = KEEP(r_new_node(env, r_null)); r_node_poke_tag(attrs, r_sym(".Environment")); r_poke_attrib(f, attrs); FREE(3); 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_push_class(f, "formula"); FREE(1); return f; } rlang/src/rlang/globals.c0000644000176200001440000000642114422712423015042 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.unbound = R_UnboundValue; 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"); } rlang/src/rlang/env.c0000644000176200001440000002040514707706735014224 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* ns = r_env_find(R_NamespaceRegistry, r_sym(pkg)); if (ns == r_syms.unbound) { r_abort("Can't find namespace `%s`", pkg); } return ns; } static r_obj* ns_env_get(r_obj* env, const char* name) { r_obj* obj = KEEP(r_env_find(env, r_sym(name))); // Can be a promise to a lazyLoadDBfetch() call if (r_typeof(obj) == R_TYPE_promise) { obj = r_eval(obj, r_envs.empty); } if (obj != r_syms.unbound) { FREE(1); return obj; } // Trigger object not found error r_eval(r_sym(name), env); r_stop_unreachable(); } r_obj* r_base_ns_get(const char* name) { return ns_env_get(r_envs.base, name); } r_obj* rlang_ns_get(const char* name) { return ns_env_get(rlang_ns_env, 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) { r_obj* out = KEEP(eval_with_x(env2list_call, env)); #if R_VERSION < R_Version(4, 0, 0) out = env_as_list_compat(env, out); #endif FREE(1); return out; } // On R < 4.0, the active binding function is returned instead of // its value. We invoke the active bindings here to get consistent // behaviour in all supported R versions. #if R_VERSION < R_Version(4, 0, 0) r_obj* env_as_list_compat(r_obj* env, r_obj* out) { r_obj* nms = KEEP(r_env_names(env)); r_obj* types = KEEP(r_env_binding_types(env, nms)); if (types == r_null) { FREE(2); return out; } r_ssize n = r_length(nms); r_obj* const * p_nms = r_chr_cbegin(nms); const int* p_types = r_int_cbegin(types); for (r_ssize i = 0; i < n; ++i) { enum r_env_binding_type type = p_types[i]; if (type == R_ENV_BINDING_TYPE_active) { r_ssize fn_idx = r_chr_detect_index(nms, r_str_c_string(p_nms[i])); if (fn_idx < 0) { r_abort("Internal error: Can't find active binding in list"); } r_obj* fn = r_list_get(out, fn_idx); r_obj* value = r_eval(KEEP(r_call(fn)), r_envs.empty); r_list_poke(out, fn_idx, value); FREE(1); } } FREE(2); return out; } #endif 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* nms = KEEP(r_env_names(from)); r_obj* types = KEEP(r_env_binding_types(from, nms)); if (types == r_null) { env_coalesce_plain(env, from, nms); FREE(2); return; } // In older R versions there is no way of accessing the function of // an active binding except through env2list. This makes it // impossible to preserve active bindings without forcing promises. #if R_VERSION < R_Version(4, 0, 0) r_obj* from_list = KEEP(eval_with_x(env2list_call, from)); #else KEEP(r_null); #endif r_ssize n = r_length(nms); r_obj* const * v_nms = r_chr_cbegin(nms); 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 = r_str_as_symbol(v_nms[i]); if (r_env_has(env, sym)) { continue; } switch (v_types[i]) { case R_ENV_BINDING_TYPE_value: case R_ENV_BINDING_TYPE_promise: r_env_poke(env, sym, r_env_find(from, sym)); break; case R_ENV_BINDING_TYPE_active: { #if R_VERSION < R_Version(4, 0, 0) r_ssize fn_idx = r_chr_detect_index(nms, r_sym_c_string(sym)); if (fn_idx < 0) { r_stop_internal("Can't find active binding in temporary list."); } r_obj* fn = r_list_get(from_list, fn_idx); #else r_obj* fn = R_ActiveBindingFunction(sym, from); #endif r_env_poke_active(env, sym, fn); break; }} } FREE(3); return; } static void env_coalesce_plain(r_obj* env, r_obj* from, r_obj* nms) { r_ssize n = r_length(nms); r_obj* const * v_nms = r_chr_cbegin(nms); for (r_ssize i = 0; i < n; ++i) { r_obj* sym = r_str_as_symbol(v_nms[i]); if (r_env_has(env, sym)) { continue; } r_env_poke(env, sym, r_env_find(from, sym)); } 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); } void r_env_poke_lazy(r_obj* env, r_obj* sym, r_obj* expr, r_obj* eval_env) { KEEP(expr); r_obj* name = KEEP(r_sym_as_utf8_character(sym)); r_node_poke_car(poke_lazy_value_node, expr); r_eval_with_xyz(poke_lazy_call, name, env, eval_env, rlang_ns_env); r_node_poke_car(poke_lazy_value_node, r_null); FREE(2); } #if RLANG_USE_R_EXISTS bool r__env_has(r_obj* env, r_obj* sym) { 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) { 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 #if (R_VERSION < R_Version(4, 0, 0)) void r__env_unbind(r_obj* env, r_obj* sym) { // Check if binding exists to avoid `rm()` warning if (r_env_has(env, sym)) { r_obj* nm = KEEP(r_sym_as_utf8_character(sym)); eval_with_xyz(remove_call, env, nm, r_false); FREE(1); } } #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_find_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); } r_obj* out = r_syms.unbound; while (out == r_syms.unbound && env != r_envs.empty && env != stop) { out = r_env_find(env, sym); env = r_env_parent(env); } return 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 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); poke_lazy_call = r_parse("delayedAssign(x, value = NULL, assign.env = y, eval.env = z)"); r_preserve(poke_lazy_call); poke_lazy_value_node = r_node_cddr(poke_lazy_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* poke_lazy_call = NULL; static r_obj* poke_lazy_value_node = NULL; static r_obj* env2list_call = NULL; static r_obj* list2env_call = NULL; rlang/src/rlang/vec-lgl.h0000644000176200001440000000023514741441060014752 0ustar liggesusers#ifndef RLANG_VECTOR_LGL_H #define RLANG_VECTOR_LGL_H r_ssize r_lgl_sum(r_obj* x, bool na_true); r_obj* r_lgl_which(r_obj* x, bool na_propagate); #endif rlang/src/rlang/c-utils.h0000644000176200001440000000664614741441060015015 0ustar liggesusers#ifndef RLANG_C_UTILS_H #define RLANG_C_UTILS_H #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; } #endif rlang/src/rlang/session.c0000644000176200001440000000276014375670676015130 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 rlang/src/rlang/sym.c0000644000176200001440000000263114375670676014252 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"); } rlang/src/rlang/vec-lgl.c0000644000176200001440000000556214401326407014755 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; } rlang/src/rlang/stack.c0000644000176200001440000000504514375670676014551 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; rlang/src/rlang/eval.c0000644000176200001440000001100714375670676014366 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_poke(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(1, parent)); r_env_poke(env, r_syms.x, x); r_env_poke(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(1, parent)); r_env_poke(env, r_syms.x, x); r_env_poke(env, r_syms.y, y); r_env_poke(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(1, parent)); r_env_poke(env, r_syms.w, w); r_env_poke(env, r_syms.x, x); r_env_poke(env, r_syms.y, y); r_env_poke(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_poke(shared_x_env, r_syms.x, x); r_obj* out = KEEP(r_eval(call, shared_x_env)); // Release for gc r_env_poke(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_poke(shared_xy_env, r_syms.x, x); r_env_poke(shared_xy_env, r_syms.y, y); r_obj* out = KEEP(r_eval(call, shared_xy_env)); // Release for gc r_env_poke(shared_xy_env, r_syms.x, r_null); r_env_poke(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_poke(shared_xyz_env, r_syms.x, x); r_env_poke(shared_xyz_env, r_syms.y, y); r_env_poke(shared_xyz_env, r_syms.z, z); r_obj* out = KEEP(r_eval(call, shared_xyz_env)); // Release for gc r_env_poke(shared_xyz_env, r_syms.x, r_null); r_env_poke(shared_xyz_env, r_syms.y, r_null); r_env_poke(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_poke(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_poke(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 }; rlang/src/rlang/dyn-array.c0000644000176200001440000000610214375670676015345 0ustar liggesusers#include #include "dyn-array.h" #define R_DYN_ARRAY_GROWTH_FACTOR 2 static r_obj* attribs_dyn_array = 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_poke_attrib(shelter, attribs_dyn_array); r_mark_object(shelter); 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) { memcpy(r_dyn_last(p_arr), p_elt, p_arr->elt_byte_size); } else { 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(attribs_dyn_array = r_pairlist(r_chr("rlang_dyn_array"))); r_node_poke_tag(attribs_dyn_array, r_syms.class_); } rlang/src/rlang/env-binding.h0000644000176200001440000000054114741441060015621 0ustar liggesusers#ifndef RLANG_ENV_BINDING_H #define RLANG_ENV_BINDING_H enum r_env_binding_type { R_ENV_BINDING_TYPE_value = 0, R_ENV_BINDING_TYPE_promise, R_ENV_BINDING_TYPE_active }; bool r_env_binding_is_promise(r_obj* env, r_obj* sym); bool r_env_binding_is_active(r_obj* env, r_obj* sym); r_obj* r_env_binding_types(r_obj* env, r_obj* bindings); #endif rlang/src/rlang/rlang.hpp0000644000176200001440000000065514403561346015077 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 rlang/src/rlang/dyn-list-of.h0000644000176200001440000000312214741441060015564 0ustar liggesusers#ifndef RLANG_DYN_LIST_OF_H #define RLANG_DYN_LIST_OF_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 rlang/src/rlang/stack.h0000644000176200001440000000047014741441060014527 0ustar liggesusers#ifndef RLANG_STACK_H #define RLANG_STACK_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 rlang/src/rlang/env.h0000644000176200001440000000554014741441060014215 0ustar liggesusers#ifndef RLANG_ENV_H #define RLANG_ENV_H #include #include 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."); } return ENCLOS(env); } static inline void r_env_poke_parent(r_obj* env, r_obj* new_parent) { SET_ENCLOS(env, new_parent); } 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); } static inline r_obj* r_env_find(r_obj* env, r_obj* sym) { return Rf_findVarInFrame3(env, sym, FALSE); } static inline r_obj* r_env_find_anywhere(r_obj* env, r_obj* sym) { return Rf_findVar(sym, env); } r_obj* r_env_find_until(r_obj* env, r_obj* sym, r_obj* last); // TODO: Enable `R_existsVarInFrame()` when R 4.2 is out #define RLANG_USE_R_EXISTS (1 || R_VERSION < R_Version(4, 2, 0)) 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 return TODO(); #endif } 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. r_obj* env = Rf_allocSExp(R_TYPE_environment); r_env_poke_parent(env, parent); return env; } 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); // Silently ignores bindings that are not defined in `env`. static inline void r_env_unbind(r_obj* env, r_obj* sym) { #if (R_VERSION < R_Version(4, 0, 0)) void r__env_unbind(r_obj*, r_obj*); r__env_unbind(env, sym); #else R_removeVarFromFrame(sym, env); #endif } static inline void r_env_poke(r_obj* env, r_obj* sym, r_obj* value) { KEEP(value); Rf_defineVar(sym, value, env); FREE(1); } void r_env_poke_lazy(r_obj* env, r_obj* sym, r_obj* expr, r_obj* eval_env); static inline void r_env_poke_active(r_obj* env, r_obj* sym, r_obj* fn) { KEEP(fn); r_env_unbind(env, sym); R_MakeActiveBinding(sym, fn, env); FREE(1); } bool r_env_inherits(r_obj* env, r_obj* ancestor, r_obj* top); #endif rlang/src/rlang/cnd.c0000644000176200001440000001136114375670676014206 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_poke(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; } rlang/src/rlang/env-binding.c0000644000176200001440000000462514375670676015647 0ustar liggesusers#include "rlang.h" #include "env.h" bool r_env_binding_is_promise(r_obj* env, r_obj* sym) { r_obj* obj = r_env_find(env, sym); return r_typeof(obj) == R_TYPE_promise && PRVALUE(obj) == r_syms.unbound; } bool r_env_binding_is_active(r_obj* env, r_obj* sym) { return R_BindingIsActive(sym, env); } static r_obj* new_binding_types(r_ssize n) { r_obj* types = r_alloc_integer(n); int* types_ptr = r_int_begin(types); memset(types_ptr, 0, n * sizeof *types_ptr); return types; } static enum r_env_binding_type which_env_binding(r_obj* env, r_obj* sym) { if (r_env_binding_is_active(env, sym)) { // Check for active bindings first, since promise detection triggers // active bindings through `r_env_find()` (#1376) return R_ENV_BINDING_TYPE_active; } if (r_env_binding_is_promise(env, sym)) { return R_ENV_BINDING_TYPE_promise; } return R_ENV_BINDING_TYPE_value; } 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); if (which_env_binding(env, sym)) { 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) + i; while (i < n) { r_obj* sym = binding_as_sym(symbols, bindings, i); *types_ptr = which_env_binding(env, sym); ++i; ++types_ptr; } FREE(1); return types; } rlang/src/rlang/call.c0000644000176200001440000000223214375670676014352 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"); } rlang/src/rlang/df.c0000644000176200001440000000272514375670676014037 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_push(out, r_syms.names, 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; } rlang/src/rlang/c-utils.c0000644000176200001440000000103114375670676015013 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); } rlang/src/rlang/walk.h0000644000176200001440000000733014741441060014362 0ustar liggesusers#ifndef RLANG_INTERNAL_WALK_H #define RLANG_INTERNAL_WALK_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 rlang/src/rlang/globals.h0000644000176200001440000000353414741441060015051 0ustar liggesusers#ifndef RLANG_GLOBALS_H #define RLANG_GLOBALS_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* unbound; 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 rlang/src/rlang/walk.c0000644000176200001440000003036514375670676014405 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(2)); 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); enum r_type type = r_typeof(root); enum sexp_iterator_type it_type = sexp_iterator_type(type, root); bool has_attrib = sexp_node_attrib(type, root) != r_null; 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: child.x = r_attrib(x); 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_node_attrib(child.type, child.x) != r_null; 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 r_obj* sexp_node_attrib(enum r_type type, r_obj* x) { // Strings have private data stored in attributes if (type == R_TYPE_string) { return r_null; } else { return ATTRIB(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 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 BODY(x); case R_TYPE_environment: *p_rel = R_SEXP_IT_RELATION_environment_enclos; return ENCLOS(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 CLOENV(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(); } } rlang/src/rlang/quo.c0000644000176200001440000000113214375670676014241 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"); } rlang/src/rlang/vec-chr.c0000644000176200001440000000356014175213516014753 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; } rlang/src/rlang/formula.h0000644000176200001440000000033014741441060015062 0ustar liggesusers#ifndef RLANG_FORMULA_H #define RLANG_FORMULA_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 rlang/src/rlang/state.h0000644000176200001440000000063114741441060014541 0ustar liggesusers#ifndef RLANG_STATE_H #define RLANG_STATE_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 rlang/src/rlang/altrep.h0000644000176200001440000000043214741441060014707 0ustar liggesusers#ifndef RLANG_ALTREP_H #define RLANG_ALTREP_H #if (R_VERSION < R_Version(3, 5, 0)) || \ (defined(_WIN32) && R_VERSION == R_Version(3, 5, 0)) # define R_HAS_ALTREP 0 #else # define R_HAS_ALTREP 1 #endif #if !R_HAS_ALTREP # define ALTREP(x) false #endif #endif rlang/src/rlang/vec.c0000644000176200001440000002016514375670676014221 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; } #if R_VERSION >= R_Version(3, 4, 0) #define HAS_VIRTUAL_SIZE 1 #else #define HAS_VIRTUAL_SIZE 0 #endif #define RESIZE(R_TYPE, C_TYPE, CONST_DEREF, DEREF) \ do { \ r_ssize x_size = r_length(x); \ if (x_size == size) { \ return x; \ } \ if (!ALTREP(x) && size < x_size && HAS_VIRTUAL_SIZE) { \ SETLENGTH(x, size); \ SET_TRUELENGTH(x, x_size); \ SET_GROWABLE_BIT(x); \ return x; \ } \ \ const C_TYPE* p_x = CONST_DEREF(x); \ r_obj* out = KEEP(r_alloc_vector(R_TYPE, size)); \ C_TYPE* p_out = DEREF(out); \ \ r_ssize cpy_size = (size > x_size) ? x_size : size; \ 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 x_size = r_length(x); \ if (x_size == size) { \ return x; \ } \ if (!ALTREP(x) && size < x_size && HAS_VIRTUAL_SIZE) { \ SETLENGTH(x, size); \ SET_TRUELENGTH(x, x_size); \ SET_GROWABLE_BIT(x); \ return x; \ } \ \ r_obj* const * p_x = CONST_DEREF(x); \ r_obj* out = KEEP(r_alloc_vector(R_TYPE, size)); \ \ r_ssize cpy_size = (size > x_size) ? x_size : size; \ for (r_ssize i = 0; i < cpy_size; ++i) { \ SET(out, i, p_x[i]); \ } \ \ FREE(1); \ return out; \ } while (0) // Compared to `Rf_xlengthgets()` this does not initialise the new // extended locations with `NA` r_obj* r_lgl_resize(r_obj* x, r_ssize size) { RESIZE(R_TYPE_logical, int, r_lgl_cbegin, r_lgl_begin); } r_obj* r_int_resize(r_obj* x, r_ssize size) { RESIZE(R_TYPE_integer, int, r_int_cbegin, r_int_begin); } r_obj* r_dbl_resize(r_obj* x, r_ssize size) { RESIZE(R_TYPE_double, double, r_dbl_cbegin, r_dbl_begin); } r_obj* r_cpl_resize(r_obj* x, r_ssize size) { RESIZE(R_TYPE_complex, r_complex, r_cpl_cbegin, r_cpl_begin); } r_obj* r_raw_resize(r_obj* x, r_ssize size) { RESIZE(R_TYPE_raw, unsigned char, r_raw_cbegin, r_raw_begin); } r_obj* r_chr_resize(r_obj* x, r_ssize size) { RESIZE_BARRIER(R_TYPE_character, r_chr_cbegin, r_chr_poke); } r_obj* r_list_resize(r_obj* x, r_ssize 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; } rlang/src/rlang/session.h0000644000176200001440000000022214741441060015100 0ustar liggesusers#ifndef RLANG_SESSION_H #define RLANG_SESSION_H bool r_is_installed(const char* pkg); bool r_has_colour(void); r_obj* r_getppid(void); #endif rlang/src/rlang/export.h0000644000176200001440000000122714741441060014744 0ustar liggesusers#ifndef RLANG_EXPORT_H #define RLANG_EXPORT_H #include #include #if (defined(R_VERSION) && R_VERSION < R_Version(3, 4, 0)) typedef union {void* p; DL_FUNC fn;} fn_ptr; r_obj* R_MakeExternalPtrFn(DL_FUNC p, r_obj* tag, r_obj* prot); DL_FUNC R_ExternalPtrAddrFn(r_obj* s); #endif 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 rlang/src/rlang/export.c0000644000176200001440000000114514175213516014742 0ustar liggesusers#include "rlang.h" #include "export.h" #include #if (defined(R_VERSION) && R_VERSION < R_Version(3, 4, 0)) r_obj* R_MakeExternalPtrFn(DL_FUNC p, r_obj* tag, r_obj* prot) { fn_ptr ptr; ptr.fn = p; return R_MakeExternalPtr(ptr.p, tag, prot); } DL_FUNC R_ExternalPtrAddrFn(r_obj* s) { fn_ptr ptr; ptr.p = EXTPTR_PTR(s); return ptr.fn; } #endif 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; } rlang/src/rlang/df.h0000644000176200001440000000047514741441060014020 0ustar liggesusers#ifndef RLANG_DF_H #define RLANG_DF_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 rlang/src/rlang/dict.c0000644000176200001440000002024314375670676014364 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)); 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; } rlang/src/rlang/rlang.c0000644000176200001440000000600714640750733014532 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 "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" #include "walk.c" // 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); 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_env(); r_init_library_eval(); r_init_library_fn(); r_init_library_quo(); r_init_library_session(); r_init_library_sym(); r_init_library_stack(); 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); // Return a SEXP so the init function can be called from R return r_null; } bool _r_use_local_precious_list = false; rlang/src/rlang/rlang-types.h0000644000176200001440000000446214741441060015674 0ustar liggesusers#ifndef RLANG_RLANG_TYPES_H #define RLANG_RLANG_TYPES_H #define R_NO_REMAP #include #include // 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)])) #endif rlang/src/rlang/quo.h0000644000176200001440000000037614741441060014233 0ustar liggesusers#ifndef RLANG_QUO_H #define RLANG_QUO_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 rlang/src/rlang/dict.h0000644000176200001440000000235514741441060014351 0ustar liggesusers#ifndef RLANG_DICT_H #define RLANG_DICT_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 rlang/src/rlang/decl/0000755000176200001440000000000014707706735014176 5ustar liggesusersrlang/src/rlang/decl/walk-decl.h0000644000176200001440000000163114175213516016200 0ustar liggesusersstatic inline enum sexp_iterator_type sexp_iterator_type(enum r_type type, r_obj* x); static inline r_obj* sexp_node_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); rlang/src/rlang/decl/obj-decl.h0000644000176200001440000000023314375670676016031 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; rlang/src/rlang/decl/df-decl.h0000644000176200001440000000016214175213516015631 0ustar liggesusersstatic void init_compact_rownames(r_obj* x, r_ssize n_rows); static r_obj* new_compact_rownames(r_ssize n_rows); rlang/src/rlang/decl/dyn-list-of-decl.h0000644000176200001440000000024414175213516017406 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); rlang/src/rlang/decl/dict-decl.h0000644000176200001440000000062614175213516016170 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); rlang/src/rlang/decl/env-decl.h0000644000176200001440000000122514707706735016044 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* poke_lazy_call; static r_obj* poke_lazy_value_node; static r_obj* env2list_call; static r_obj* list2env_call; #if R_VERSION < R_Version(4, 0, 0) static r_obj* env_as_list_compat(r_obj* env, r_obj* out); #endif static void env_coalesce_plain(r_obj* env, r_obj* from, r_obj* nms); rlang/src/rlang/decl/cnd-decl.h0000644000176200001440000000003714375670676016025 0ustar liggesusersstatic r_obj* cnd_signal_call; rlang/src/rlang/decl/stack-decl.h0000644000176200001440000000016414375670676016367 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; rlang/src/rlang/node.c0000644000176200001440000000305414376112150014342 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_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; } 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; } rlang/src/rlang/cnd.h0000644000176200001440000000427714741441060014177 0ustar liggesusers#ifndef RLANG_CND_H #define RLANG_CND_H #include 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 rlang/src/rlang/obj.c0000644000176200001440000000575714401413630014177 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_poke(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; rlang/src/rlang/vendor.c0000644000176200001440000000032114375670676014731 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"); } rlang/src/rlang/attrib.c0000644000176200001440000000733014403566041014706 0ustar liggesusers#include "rlang.h" r_obj* r_attrib_push(r_obj* x, r_obj* tag, r_obj* value) { r_obj* attrs = r_new_node(value, r_attrib(x)); r_node_poke_tag(attrs, tag); r_poke_attrib(x, attrs); return attrs; } /** * - If `sentinel` is found in the first node: `parent_out` is `r_null` * - If `sentinel` is not found: both return value and `parent_out` * are `r_null` * - If `sentinel` is `r_null`, this is like a full shallow duplication * but returns tail node */ r_obj* r_pairlist_clone_until(r_obj* node, r_obj* sentinel, r_obj** parent_out) { r_obj* parent = r_null; r_obj* cur = node; int n_kept = 0; while (true) { if (cur == sentinel) { FREE(n_kept); *parent_out = parent; return node; } // Return NULL if sentinel is not found if (cur == r_null) { FREE(n_kept); *parent_out = r_null; return r_null; } r_obj* tag = r_node_tag(cur); cur = r_new_node(r_node_car(cur), r_node_cdr(cur)); r_node_poke_tag(cur, tag); if (parent == r_null) { KEEP_N(cur, &n_kept); node = cur; } else { r_node_poke_cdr(parent, cur); } parent = cur; cur = r_node_cdr(cur); } r_stop_unreachable(); } r_obj* r_attrs_set_at(r_obj* attrs, r_obj* node, r_obj* value) { r_obj* sentinel = r_node_cdr(node); r_obj* new_node = r_null; attrs = KEEP(r_pairlist_clone_until(attrs, sentinel, &new_node)); r_node_poke_car(new_node, value); FREE(1); return attrs; } r_obj* r_attrs_zap_at(r_obj* attrs, r_obj* node, r_obj* value) { r_obj* sentinel = node; r_obj* new_node = r_null; attrs = KEEP(r_pairlist_clone_until(attrs, sentinel, &new_node)); if (new_node == r_null) { // `node` is the first node of `attrs` attrs = r_node_cdr(attrs); } else { r_node_poke_cdr(new_node, r_node_cdr(node)); } FREE(1); return attrs; } r_obj* r_clone2(r_obj* x) { r_obj* attrs = KEEP(r_attrib(x)); // Prevent attributes from being cloned r_poke_attrib(x, r_null); r_obj* out = r_clone(x); r_poke_attrib(x, attrs); r_poke_attrib(out, attrs); FREE(1); return out; } r_obj* r_attrib_set(r_obj* x, r_obj* tag, r_obj* value) { r_obj* attrs = r_attrib(x); r_obj* out = KEEP(r_clone2(x)); r_obj* node = attrs; while (node != r_null) { if (r_node_tag(node) == tag) { if (value == r_null) { attrs = r_attrs_zap_at(attrs, node, value); } else { attrs = r_attrs_set_at(attrs, node, value); } r_poke_attrib(out, attrs); FREE(1); return out; } node = r_node_cdr(node); } if (value != r_null) { // Just add to the front if attribute does not exist yet attrs = KEEP(r_new_node(out, attrs)); r_node_poke_tag(attrs, tag); r_node_poke_car(attrs, value); r_poke_attrib(out, attrs); FREE(1); } FREE(1); return out; } /** * With push_ prefix, assumes there is no `class` attribute in the * node list merge. This is for low-level construction of objects. */ // Caller must poke the object bit static r_obj* node_push_classes(r_obj* node, const char** tags, r_ssize n) { r_obj* tags_chr = KEEP(r_chr_n(tags, n)); r_obj* attrs = r_new_node(tags_chr, node); r_node_poke_tag(attrs, r_syms.class_); FREE(1); return attrs; } void r_attrib_push_classes(r_obj* x, const char** tags, r_ssize n) { r_obj* attrs = r_attrib(x); attrs = node_push_classes(attrs, tags, n); SET_ATTRIB(x, attrs); SET_OBJECT(x, 1); } void r_attrib_push_class(r_obj* x, const char* tag) { static const char* tags[1] = { "" }; tags[0] = tag; r_attrib_push_classes(x, tags, 1); } 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; } rlang/src/rlang/parse.h0000644000176200001440000000021214741441060014526 0ustar liggesusers#ifndef RLANG_PARSE_H #define RLANG_PARSE_H r_obj* r_parse(const char* str); r_obj* r_parse_eval(const char* str, r_obj* env); #endif rlang/src/rlang/vec.h0000644000176200001440000002653314741441060014207 0ustar liggesusers#ifndef RLANG_VECTOR_H #define RLANG_VECTOR_H #include 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 (r_obj* const *) STRING_PTR(x); } static inline r_obj* const * r_list_cbegin(r_obj* x) { #if (R_VERSION < R_Version(3, 5, 0)) return ((r_obj* const *) STRING_PTR(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) { return Rf_allocVector(type, n); } static inline r_obj* r_alloc_logical(r_ssize n) { return Rf_allocVector(R_TYPE_logical, n); } static inline r_obj* r_alloc_integer(r_ssize n) { return Rf_allocVector(R_TYPE_integer, n); } static inline r_obj* r_alloc_double(r_ssize n) { return Rf_allocVector(R_TYPE_double, n); } static inline r_obj* r_alloc_complex(r_ssize n) { return Rf_allocVector(R_TYPE_complex, n); } static inline r_obj* r_alloc_raw(r_ssize n) { return Rf_allocVector(R_TYPE_raw, n); } static inline r_obj* r_alloc_character(r_ssize n) { return Rf_allocVector(R_TYPE_character, n); } static inline r_obj* r_alloc_list(r_ssize n) { return Rf_allocVector(R_TYPE_list, n); } 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); 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 size); r_obj* r_int_resize(r_obj* x, r_ssize size); r_obj* r_dbl_resize(r_obj* x, r_ssize size); r_obj* r_cpl_resize(r_obj* x, r_ssize size); r_obj* r_raw_resize(r_obj* x, r_ssize size); r_obj* r_chr_resize(r_obj* x, r_ssize size); r_obj* r_list_resize(r_obj* x, r_ssize size); static inline r_obj* r_vec_resize0(enum r_type type, r_obj* x, r_ssize size) { switch (type) { case R_TYPE_logical: return r_lgl_resize(x, size); case R_TYPE_integer: return r_int_resize(x, size); case R_TYPE_double: return r_dbl_resize(x, size); case R_TYPE_complex: return r_cpl_resize(x, size); case R_TYPE_raw: return r_raw_resize(x, size); case R_TYPE_character: return r_chr_resize(x, size); case R_TYPE_list: return r_list_resize(x, size); default: r_stop_unimplemented_type(type); } } static inline r_obj* r_vec_resize(r_obj* x, r_ssize size) { return r_vec_resize0(r_typeof(x), x, 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); 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); 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 rlang/src/rlang/fn.h0000644000176200001440000000171714741441060014032 0ustar liggesusers#ifndef RLANG_FN_H #define RLANG_FN_H static inline r_obj* r_fn_body(r_obj* fn) { return BODY_EXPR(fn); } static inline void r_fn_poke_body(r_obj* fn, r_obj* body) { SET_BODY(fn, body); } static inline r_obj* r_fn_env(r_obj* fn) { return CLOENV(fn); } static inline void r_fn_poke_env(r_obj* fn, r_obj* env) { SET_CLOENV(fn, env); } static inline r_obj* r_new_function(r_obj* formals, r_obj* body, r_obj* env) { SEXP fn = Rf_allocSExp(R_TYPE_closure); SET_FORMALS(fn, formals); SET_BODY(fn, body); SET_CLOENV(fn, env); return fn; } 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 rlang/src/rlang/debug.h0000644000176200001440000000030014741441060014500 0ustar liggesusers#ifndef RLANG_DEBUG_H #define RLANG_DEBUG_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 rlang/src/rlang/eval.h0000644000176200001440000001131314741441060014347 0ustar liggesusers#ifndef RLANG_EVAL_H #define RLANG_EVAL_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 rlang/src/rlang/sym.h0000644000176200001440000000114614741441060014233 0ustar liggesusers#ifndef RLANG_SYM_H #define RLANG_SYM_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 rlang/src/rlang/vendor.h0000644000176200001440000000016014741441060014713 0ustar liggesusers#ifndef RLANG_VENDOR_H #define RLANG_VENDOR_H extern uint64_t (*r_xxh3_64bits)(const void*, size_t); #endif rlang/src/rlang/attrib.h0000644000176200001440000000367614741441060014722 0ustar liggesusers#ifndef RLANG_ATTRIB_H #define RLANG_ATTRIB_H #include "node.h" #include "sym.h" static inline r_obj* r_attrib(r_obj* x) { return ATTRIB(x); } static inline r_obj* r_poke_attrib(r_obj* x, r_obj* attrs) { SET_ATTRIB(x, attrs); return x; } // Unlike Rf_getAttrib(), this never allocates. This also doesn't bump // refcounts or namedness. static inline r_obj* r_attrib_get(r_obj* x, r_obj* tag) { return r_pairlist_get(r_attrib(x), tag); } static inline void r_attrib_poke(r_obj* x, r_obj* sym, r_obj* value) { Rf_setAttrib(x, sym, value); } r_obj* r_attrib_push(r_obj* x, r_obj* tag, r_obj* value); r_obj* r_attrib_set(r_obj* x, r_obj* tag, r_obj* value); static inline r_obj* r_class(r_obj* x) { return r_attrib_get(x, r_syms.class_); } static inline void r_attrib_poke_class(r_obj* x, r_obj* classes) { r_attrib_poke(x, r_syms.class_, classes); } void r_attrib_push_class(r_obj* x, const char* tag); void r_attrib_push_classes(r_obj* x, const char** tags, r_ssize n); static inline r_obj* r_dim(r_obj* x) { return r_attrib_get(x, r_syms.dim); } static inline void r_attrib_poke_dim(r_obj* x, r_obj* dim) { r_attrib_poke(x, r_syms.dim, dim); } static inline r_obj* r_dim_names(r_obj* x) { return r_attrib_get(x, r_syms.dim_names); } static inline void r_attrib_poke_dim_names(r_obj* x, r_obj* dim_names) { r_attrib_poke(x, r_syms.dim_names, dim_names); } static inline r_obj* r_names(r_obj* x) { return r_attrib_get(x, r_syms.names); } static inline void r_attrib_poke_names(r_obj* x, r_obj* nms) { r_attrib_poke(x, r_syms.names, nms); } bool r_is_named(r_obj* x); #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 rlang/src/rlang.c0000644000176200001440000000025314741441443013421 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" rlang/src/config.h0000644000176200001440000000004113336316756013572 0ustar liggesusers#define RLANG_HAS_RINTERFACE_H 1 rlang/NAMESPACE0000644000176200001440000002657414636761731012630 0ustar liggesusers# Generated by roxygen2: do not edit by hand S3method("$",rlang_ctxt_pronoun) S3method("$",rlang_data_pronoun) S3method("$",rlang_fake_data_pronoun) S3method("$<-",quosures) S3method("$<-",rlang_ctxt_pronoun) S3method("$<-",rlang_data_pronoun) S3method("[","rlang:::list_of_conditions") S3method("[",quosure) S3method("[",quosures) S3method("[",rlang_ctxt_pronoun) S3method("[",rlang_data_pronoun) S3method("[",rlang_envs) S3method("[",rlib_bytes) S3method("[<-",quosures) S3method("[[",quosure) S3method("[[",rlang_ctxt_pronoun) S3method("[[",rlang_data_pronoun) S3method("[[",rlang_fake_data_pronoun) S3method("[[",rlib_bytes) S3method("[[<-",quosures) S3method("[[<-",rlang_ctxt_pronoun) S3method("[[<-",rlang_data_pronoun) S3method(Math,quosure) S3method(Ops,quosure) S3method(Ops,rlib_bytes) S3method(Summary,quosure) S3method(as.character,quosure) S3method(as.character,rlang_error) S3method(as.character,rlang_message) S3method(as.character,rlang_warning) S3method(as.character,rlib_bytes) S3method(as.list,quosures) S3method(as_bytes,character) S3method(as_bytes,numeric) S3method(as_bytes,rlib_bytes) S3method(c,quosure) S3method(c,quosures) S3method(c,rlang_envs) S3method(cnd_body,default) S3method(cnd_footer,default) S3method(cnd_header,default) S3method(cnd_header,rlib_error_package_not_found) S3method(conditionMessage,rlang_error) S3method(conditionMessage,rlang_message) S3method(conditionMessage,rlang_warning) S3method(dimnames,rlang_data_pronoun) S3method(format,rlang_error) S3method(format,rlang_message) S3method(format,rlang_trace) S3method(format,rlang_warning) S3method(format,rlib_bytes) S3method(length,rlang_ctxt_pronoun) S3method(length,rlang_data_pronoun) S3method(length,rlang_fake_data_pronoun) S3method(max,rlib_bytes) S3method(mean,quosure) S3method(median,quosure) S3method(min,rlib_bytes) S3method(names,rlang_ctxt_pronoun) S3method(names,rlang_data_pronoun) S3method(names,rlang_fake_data_pronoun) S3method(print,"rlang:::list_of_conditions") S3method(print,quosure) S3method(print,quosures) S3method(print,rlang_box_done) S3method(print,rlang_box_splice) S3method(print,rlang_data_pronoun) S3method(print,rlang_dict) S3method(print,rlang_dyn_array) S3method(print,rlang_envs) S3method(print,rlang_error) S3method(print,rlang_fake_data_pronoun) S3method(print,rlang_lambda_function) S3method(print,rlang_message) S3method(print,rlang_trace) S3method(print,rlang_warning) S3method(print,rlang_zap) S3method(print,rlib_bytes) S3method(quantile,quosure) S3method(rlang_type_sum,Date) S3method(rlang_type_sum,POSIXct) S3method(rlang_type_sum,data.frame) S3method(rlang_type_sum,default) S3method(rlang_type_sum,difftime) S3method(rlang_type_sum,factor) S3method(rlang_type_sum,ordered) S3method(str,quosure) S3method(str,rlang_data_pronoun) S3method(str,rlang_envs) S3method(sum,rlib_bytes) S3method(summary,"rlang:::list_of_conditions") S3method(summary,rlang_error) S3method(summary,rlang_message) S3method(summary,rlang_trace) S3method(summary,rlang_warning) export("!!!") export("!!") export("%<~%") export("%@%") export("%@%<-") export("%|%") export("%||%") export(":=") export("f_env<-") export("f_lhs<-") export("f_rhs<-") export("fn_body<-") export("fn_env<-") export("fn_fmls<-") export("fn_fmls_names<-") export("names2<-") export(.data) export(.env) export(UQ) export(UQS) export(abort) export(are_na) export(arg_match) export(arg_match0) export(as_box) export(as_box_if) export(as_bytes) export(as_character) export(as_closure) export(as_complex) export(as_data_mask) export(as_data_pronoun) export(as_double) export(as_environment) export(as_function) export(as_integer) export(as_label) export(as_list) export(as_logical) export(as_name) export(as_quosure) export(as_quosures) export(as_string) export(as_utf8_character) export(base_env) export(bytes) export(call2) export(call_args) export(call_args_names) export(call_fn) export(call_inspect) export(call_match) export(call_modify) export(call_name) export(call_ns) export(call_standardise) export(caller_arg) export(caller_call) export(caller_env) export(caller_fn) export(calling) export(catch_cnd) export(check_dots_empty) export(check_dots_empty0) export(check_dots_unnamed) export(check_dots_used) export(check_exclusive) export(check_installed) export(check_required) export(child_env) export(chr) export(chr_unserialise_unicode) export(cnd) export(cnd_body) export(cnd_entrace) export(cnd_footer) export(cnd_header) export(cnd_inherits) export(cnd_message) export(cnd_muffle) export(cnd_signal) export(cnd_type) export(coerce_class) export(coerce_type) export(cpl) export(ctxt_frame) export(current_call) export(current_env) export(current_fn) export(data_sym) export(data_syms) export(dbl) export(done) export(dots_list) export(dots_n) export(dots_splice) export(dots_values) export(duplicate) export(empty_env) export(enexpr) export(enexprs) export(englue) export(enquo) export(enquo0) export(enquos) export(enquos0) export(ensym) export(ensyms) export(entrace) export(env) export(env_bind) export(env_bind_active) export(env_bind_lazy) export(env_binding_are_active) export(env_binding_are_lazy) export(env_binding_are_locked) export(env_binding_lock) export(env_binding_unlock) export(env_browse) export(env_bury) export(env_cache) export(env_clone) export(env_coalesce) export(env_depth) export(env_get) export(env_get_list) export(env_has) export(env_inherits) export(env_is_browsed) export(env_is_locked) export(env_is_user_facing) export(env_label) export(env_length) export(env_lock) export(env_name) export(env_names) export(env_parent) export(env_parents) export(env_poke) export(env_poke_parent) export(env_print) export(env_tail) export(env_unbind) export(env_unlock) export(error_call) export(error_cnd) export(eval_bare) export(eval_tidy) export(exec) export(exiting) export(expr) export(expr_deparse) export(expr_interp) export(expr_label) export(expr_name) export(expr_print) export(expr_text) export(exprs) export(exprs_auto_name) export(f_env) export(f_label) export(f_lhs) export(f_name) export(f_rhs) export(f_text) export(ffi_standalone_check_number_1.0.7) export(ffi_standalone_is_bool_1.0.7) export(flatten) export(flatten_chr) export(flatten_cpl) export(flatten_dbl) export(flatten_if) export(flatten_int) export(flatten_lgl) export(flatten_raw) export(fn_body) export(fn_env) export(fn_fmls) export(fn_fmls_names) export(fn_fmls_syms) export(format_error_bullets) export(format_error_call) export(frame_call) export(frame_fn) export(friendly_type) export(get_env) export(get_expr) export(global_entrace) export(global_env) export(global_frame) export(global_handle) export(global_prompt_install) export(has_length) export(has_name) export(hash) export(hash_file) export(have_name) export(inform) export(inherits_all) export(inherits_any) export(inherits_only) export(inject) export(int) export(interrupt) export(invoke) export(is_atomic) export(is_attached) export(is_bare_atomic) export(is_bare_bytes) export(is_bare_character) export(is_bare_complex) export(is_bare_double) export(is_bare_environment) export(is_bare_formula) export(is_bare_integer) export(is_bare_integerish) export(is_bare_list) export(is_bare_logical) export(is_bare_numeric) export(is_bare_raw) export(is_bare_string) export(is_bare_vector) export(is_bool) export(is_box) export(is_bytes) export(is_call) export(is_call_simple) export(is_callable) export(is_character) export(is_chr_na) export(is_closure) export(is_complex) export(is_condition) export(is_copyable) export(is_cpl_na) export(is_dbl_na) export(is_dictionaryish) export(is_done_box) export(is_double) export(is_empty) export(is_environment) export(is_error) export(is_expression) export(is_false) export(is_formula) export(is_function) export(is_installed) export(is_int_na) export(is_integer) export(is_integerish) export(is_interactive) export(is_lambda) export(is_lang) export(is_lgl_na) export(is_list) export(is_logical) export(is_message) export(is_missing) export(is_na) export(is_named) export(is_named2) export(is_namespace) export(is_node) export(is_node_list) export(is_null) export(is_pairlist) export(is_primitive) export(is_primitive_eager) export(is_primitive_lazy) export(is_quosure) export(is_quosures) export(is_raw) export(is_reference) export(is_scalar_atomic) export(is_scalar_bytes) export(is_scalar_character) export(is_scalar_complex) export(is_scalar_double) export(is_scalar_integer) export(is_scalar_integerish) export(is_scalar_list) export(is_scalar_logical) export(is_scalar_raw) export(is_scalar_vector) export(is_scoped) export(is_spliced) export(is_spliced_bare) export(is_string) export(is_symbol) export(is_symbolic) export(is_syntactic_literal) export(is_true) export(is_vector) export(is_warning) export(is_weakref) export(is_zap) export(lang) export(last_error) export(last_messages) export(last_trace) export(last_warnings) export(lgl) export(list2) export(ll) export(local_bindings) export(local_error_call) export(local_interactive) export(local_options) export(local_use_cli) export(locally) export(maybe_missing) export(message_cnd) export(missing_arg) export(na_chr) export(na_cpl) export(na_dbl) export(na_int) export(na_lgl) export(names2) export(names_inform_repair) export(new_box) export(new_call) export(new_character) export(new_complex) export(new_data_mask) export(new_double) export(new_environment) export(new_formula) export(new_function) export(new_integer) export(new_list) export(new_logical) export(new_node) export(new_quosure) export(new_quosures) export(new_raw) export(new_weakref) export(node_caar) export(node_cadr) export(node_car) export(node_cdar) export(node_cddr) export(node_cdr) export(node_poke_caar) export(node_poke_cadr) export(node_poke_car) export(node_poke_cdar) export(node_poke_cddr) export(node_poke_cdr) export(node_poke_tag) export(node_tag) export(ns_env) export(ns_env_name) export(ns_imports_env) export(ns_registry_env) export(obj_address) export(on_load) export(on_package_load) export(pairlist2) export(parse_bytes) export(parse_expr) export(parse_exprs) export(parse_quo) export(parse_quos) export(peek_option) export(peek_options) export(pkg_env) export(pkg_env_name) export(prim_name) export(push_options) export(qq_show) export(quo) export(quo_expr) export(quo_get_env) export(quo_get_expr) export(quo_is_call) export(quo_is_missing) export(quo_is_null) export(quo_is_symbol) export(quo_is_symbolic) export(quo_label) export(quo_name) export(quo_set_env) export(quo_set_expr) export(quo_squash) export(quo_text) export(quos) export(quos_auto_name) export(raw_deparse_str) export(rep_along) export(rep_named) export(reset_message_verbosity) export(reset_warning_verbosity) export(return_from) export(run_on_load) export(scoped_bindings) export(scoped_env) export(scoped_interactive) export(scoped_options) export(search_env) export(search_envs) export(seq2) export(seq2_along) export(set_attrs) export(set_env) export(set_expr) export(set_names) export(signal) export(splice) export(squash) export(squash_chr) export(squash_cpl) export(squash_dbl) export(squash_if) export(squash_int) export(squash_lgl) export(squash_raw) export(string) export(switch_class) export(switch_type) export(sym) export(syms) export(trace_back) export(trace_length) export(try_fetch) export(type_of) export(unbox) export(vec_poke_n) export(vec_poke_range) export(warn) export(warning_cnd) export(with_bindings) export(with_env) export(with_handlers) export(with_interactive) export(with_options) export(wref_key) export(wref_value) export(zap) export(zap_srcref) importFrom(stats,median) importFrom(stats,quantile) importFrom(utils,adist) importFrom(utils,str) useDynLib(rlang, .registration = TRUE) rlang/LICENSE0000644000176200001440000000005314401375321012360 0ustar liggesusersYEAR: 2020 COPYRIGHT HOLDER: rlang authors rlang/NEWS.md0000644000176200001440000031037214741441060012462 0ustar liggesusers# rlang 1.1.5 * We now report full backtraces during knitting (#1769). # rlang 1.1.4 * Added missing C level `r_dyn_raw_push_back()` and `r_dyn_chr_push_back()` utilities (#1699). * `last_trace()` hyperlinks now use the modern `x-r-run` format (#1678). # rlang 1.1.3 * Fix for CRAN checks. * `%||%` is now reexported from base on newer R versions. This avoids conflict messages when attaching or importing rlang. # rlang 1.1.2 * Fixed an off-by-one typo in the traceback source column location (#1633). * `abort()` now respects the base R global option, `options(show.error.messages = FALSE)` (#1630). * `obj_type_friendly()` now only displays the first class of S3 objects (#1622). * `expr_label()` now has back-compatility with respect to changes made by R version 4.4 and `is.atomic(NULL)` (#1655) * Performance improvement in `.rlang_cli_compat()` (#1657). # rlang 1.1.1 * `englue()` now allows omitting `{{`. This is to make it easier to embed in external functions that need to support either `{` and `{{` (#1601). * Fix for CRAN checks. * `stop_input_type()` now handles `I()` input literally in `arg` (#1607, @simonpcouch). * `parse_expr()` and `parse_exprs()` are now faster when `getOption("keep.source")` is `TRUE` (#1603). # rlang 1.1.0 ## Life cycle changes * `dots_splice()` is deprecated. This function was previously in the questioning lifecycle stage as we were moving towards the explicit `!!!` splicing style. * `flatten()`, `squash()`, and their variants are deprecated in favour of `purrr::list_flatten()` and `purrr::list_c()`. * `child_env()` is deprecated in favour of `env()` which has supported creating child environments for several years now. ## Main new features * `last_error()` and `options(rlang_backtrace_on_error = "full")` now print the full backtrace tree by default (except for some hidden frames). The simplified backtraces tended to hide important context too often. Now we show intervening frames in a lighter colour so that they don't distract from the important parts of the backtraces but are still easily inspectable. * `global_entrace()`, `last_warnings()`, and `last_messages()` now support knitr documents. * New `rlang_backtrace_on_warning_report` global option. This is useful in conjunction with `global_entrace()` to get backtraces on warnings inside RMarkdown documents. * `global_entrace()` and `entrace()` now stop entracing warnings and messages after 20 times. This is to avoid a large overhead when 100s or 1000s of warnings are signalled in a loop (#1473). * `abort()`, `warn()`, and `inform()` gain an `.inherit` parameter. This controls whether `parent` is inherited. If `FALSE`, `cnd_inherits()` and `try_fetch()` do not match chained conditions across parents. It's normally `TRUE` by default, but if a warning is chained to an error or a message is chained to a warning or error (downgraded chaining), `.inherit` defaults to `FALSE` (#1573). * `try_fetch()` now looks up condition classes across chained errors (#1534). This makes `try_fetch()` insensitive to changes of implementation or context of evaluation that cause a classed error to suddenly get chained to a contextual error. * `englue()` gained `env`, `error_arg`, and `error_call` arguments to support being wrapped in another function (#1565). * The data-masking documentation for arguments has been imported from dplyr. You can link to it by starting an argument documentation with this button: ``` <[`data-masking`][rlang::args_data_masking]> ``` * `enquos()` and friends gain a `.ignore_null` argument (#1450). * New `env_is_user_facing()` function to determine if an evaluation frame corresponds to a direct usage by the end user (from the global environment or a package being tested) or indirect usage by a third party function. The return value can be overridden by setting the `"rlang_user_facing"` global option. ## Miscellaneous fixes and features * New `check_data_frame()` and `check_logical()` functions in `standalone-types-check.R` (#1587, @mgirlich). * Added `allow_infinite` argument to `check_number_whole()` (#1588, @mgirlich). * The lifecycle standalone file has been updated to match the modern lifecycle tools. * `parse_expr()` now supports vectors of lines (#1540). * Quosures can now be consistently concatenated to lists of quosures (#1446). * Fixed a memory issue that caused excessive duplication in `list2()` and friends (#1491). * Embraced empty arguments are now properly detected and trimmed by `quos()` (#1421). * Fixed an edge case that caused `enquos(.named = NULL)` to return a named list (#1505). * `expr_deparse()` now deparses the embrace operator `{{` on a single line (#1511). * `zap_srcref()` has been rewritten in C for efficiency (#1513). * `zap_srcref()` now supports expression vectors. * The non-error path of `check_dots_unnamed()` has been rewritten in C for efficiency (#1528). * Improved error messages in `englue()` (#1531) and in glue strings in the LHS of `:=` (#1526). * `englue()` now requires size 1 outputs (#1492). This prevents surprising errors or inconsistencies when an interpolated input of size != 1 makes its way into the glue string. * `arg_match()` now throws correct error when supplied a missing value or an empty vector (#1519). * `is_integerish()` now handles negative doubles more consistently with positive ones (@sorhawell, #1530). * New `check_logical()` in `standalone-types-check.R` (#1560). * `quo_squash()` now squashes quosures in function position (#1509). * `is_expression()` now recognises quoted functions (#1499). It now also recognises non-parsable attributes (#1475). * `obj_address()` now supports the missing argument (#1521). * Fixed a `check_installed()` issue with packages removed during the current R session (#1561). * `new_data_mask()` is now slightly faster due to a smaller initial mask size and usage of the C level function `R_NewEnv()` on R >=4.1.0 (#1553). * The C level `r_dyn_*_push_back()` utilities are now faster (#1542). * The C level `r_lgl_sum()` and `r_lgl_which()` helpers are now faster (#1577, with contributions from @mgirlich). * rlang is now compliant with `-Wstrict-prototypes` as requested by CRAN (#1508). # rlang 1.0.6 * `as_closure(seq.int)` now works (#1468). * rlang no longer stores errors and backtraces in a `org:r-lib` environment on the search path. * The low-level function `error_call()` is now exported (#1474). * Fixed an issue that caused a failure about a missing `is_character` function when rlang is installed alongside an old version of vctrs (#1482). * Fixed an issue that caused multiline calls in backtraces. * The C API function `r_lgl_which()` now propagates the names of the input (#1471). * The `pkg_version_info()` function now allows `==` for package version comparison (#1469, @kryekuzhinieri). # rlang 1.0.5 * Fixed backtrace display with calls containing long lists of arguments (#1456). * New `r_obj_type_friendly()` function in the C library (#1463). It interfaces with `obj_type_friendly()` from `compat-obj-type.R` via a C callable. # rlang 1.0.4 * `is_installed()` no longer throws an error with irregular package names. * `is_installed()` and `check_installed()` now properly detect that the base package is installed on older versions of R (#1434). # rlang 1.0.3 * Child errors may now have empty messages to enable this pattern: ``` Error in `my_function()`: Caused by error in `their_function()`: ! Message. ``` * The `rlib_bytes` class now uses prettyunits to format bytes. The bytes are now represented with decimal prefixes instead of binary prefixes. * Supplying a frame environment to the `call` argument of `abort()` now causes the corresponding function call in the backtrace to be highlighted. In addition, if you store the argument name of a failing input in the `arg` error field, the argument is also highlighted in the backtrace. Instead of: ``` cli::cli_abort("{.arg {arg}} must be a foobar.", call = call) ``` You can now write this to benefit from arg highlighting: ``` cli::cli_abort("{.arg {arg}} must be a foobar.", arg = arg, call = call) ``` * `abort(message = )` can now be a function. In this case, it is stored in the `header` field and acts as a `cnd_header()` method invoked when the message is displayed. * New `obj_type_oo()` function in `compat-obj-type.R` (#1426). * `friendly_type_of()` from `compat-obj-type.R` (formerly `compat-friendly-type.R`) is now `obj_type_friendly()`. * `options(backtrace_on_error = "collapse")` and `print(trace, simplify = "collapse")` are deprecated. They fall back to `"none"` with a warning. * `call_match()` now better handles `...` when `dots_expand = FALSE`. * `list2(!!!x)` is now faster when `x` is a list. It is now returned as is instead of being duplicated into a new list. * `abort()` gains a `.trace_bottom` argument to disambiguate from other `.frame`. This allows `cli::cli_abort()` to wrap `abort()` in such a way that `.internal` mentions the correct package to report the error in (#1386). * The `transpose()` compat is now more consistent with purrr when inner names are not congruent (#1346). * New `reset_warning_verbosity()` and `reset_message_verbosity()` functions. These reset the verbosity of messages signalled with `warn()` and `inform()` with the `.frequency` argument. This is useful for testing verbosity in your package (#1414). * `check_dots_empty()` now allows trailing missing arguments (#1390). * Calls to local functions that are not accessible through `::` or `:::` are now marked with `(local)` in backtraces (#1399). * Error messages now mention indexed calls like `foo$bar()`. * New `env_coalesce()` function to copy bindings from one environment to another. Unlike approaches based on looping with `[[<-`, `env_coalesce()` preserves active and lazy bindings. * Chaining errors at top-level (directly in the console instead of in a function) no longer fails (#1405). * Warning style is propagated across parent errors in chained error messages (#1387). * `check_installed()` now works within catch-all `tryCatch(error = )` expressions (#1402, tidyverse/ggplot2#4845). * `arg_match()` and `arg_match0()` now mention the correct call in case of type error (#1388). * `abort()` and `inform()` now print messages to `stdout` in RStudio panes (#1393). * `is_installed()` now detects unsealed namespaces (#1378). This fixes inconsistent behaviour when run within user onLoad hooks. * Source references in backtraces and `last_error()`/`last_trace()` instructions are now clickable in IDEs that support links (#1396). * `compat-cli.R` now supports `style_hyperlink()`. * `abort(.homonyms = "error")` now throws the expected error (#1394). * `env_binding_are_active()` no longer accidentally triggers active bindings (#1376). * Fixed bug in `quo_squash()` with nested quosures containing the missing argument. # rlang 1.0.2 * Backtraces of parent errors are now reused on rethrow. This avoids capturing the same backtrace twice and solves consistency problems by making sure both errors in a chain have the same backtrace. * Fixed backtrace oversimplification when `cnd` is a base error in `abort(parent = cnd)`. * Internal errors thrown with `abort(.internal = TRUE)` now mention the name of the package the error should be reported to. * Backtraces are now separated from error messages with a `---` ruler line (#1368). * The internal bullet formatting routine now ignores unknown names (#1364). This makes it consistent with the cli package, increases resilience against hard-to-detect errors, and increases forward compatibility. * `abort()` and friends no longer calls non-existent functions (e.g. `cli::format_error()` or `cli::format_warning`) when the installed version of cli is too old (#1367, tidyverse/dplyr#6189). * Fixed an OOB subsetting error in `abort()`. # rlang 1.0.1 * New `rlang_call_format_srcrefs` global option (#1349). Similar to `rlang_trace_format_srcrefs`, this option allows turning off the display of srcrefs in error calls. This can be useful for reproducibility but note that srcrefs are already disabled within testthat by default. * `abort(parent = NA)` is now supported to indicate an unchained rethrow. This helps `abort()` detect the condition handling context to create simpler backtraces where this context is hidden by default. * When `parent` is supplied, `abort()` now loops over callers to detect the condition handler frame. This makes it easier to wrap or extract condition handlers in functions without supplying `.frame`. * When `parent` is supplied and `call` points to the condition setup frame (e.g. `withCallingHandlers()` or `try_fetch()`), `call` is replaced with the caller of that setup frame. This provides a more helpful default call. * `is_call()` is now implemented in C for performance. * Fixed performance regression in `trace_back()`. * Fixed a partial matching issue with `header`, `body`, and `footer` condition fields. * `eval_tidy()` calls are no longer mentioned in error messages. # rlang 1.0.0 ## Major changes This release focuses on the rlang errors framework and features extensive changes to the display of error messages. * `abort()` now displays errors as fully bulleted lists. Error headers are displayed with a `!` prefix. See to customise the display of error messages. * `abort()` now displays a full chain of messages when errors are chained with the `parent` argument. Following this change, you should update dplyr to version 1.0.8 to get proper error messages. * `abort()` now displays function calls in which a message originated by default. We have refrained from showing these calls until now to avoid confusing messages when an error is thrown from a helper function that isn't relevant to users. To help with these cases, `abort()` now takes a `call` argument that you can set to `caller_env()` or `parent.frame()` when used in a helper function. The function call corresponding to this environment is retrieved and stored in the condition. * cli formatting is now supported. Use `cli::cli_abort()` to get advanced formatting of error messages, including indented bulleted lists. See . * New `try_fetch()` function for error handling. We recommend to use it for chaining errors. It mostly works like `tryCatch()` with a few important differences. - Compared to `tryCatch()`, `try_fetch()` preserves the call stack. This allows full backtrace capture and allows `recover()` to reach the error site. - Compared to `withCallingHandler()`, `try_fetch()` is able to handle stack overflow errors (this requires R 4.2, unreleased at the time of writing). * The tidy eval documentation has been fully rewritten to reflect current practices. Access it through the "Tidy evaluation" and "Metaprogramming" menus on . ## Breaking changes * The `.data` object exported by rlang now fails when subsetted instead of returning `NULL`. This new error helps you detect when `.data` is used in the wrong context. We've noticed several packages failing after this change because they were using `.data` outside of a data-masking context. For instance the `by` argument of `dplyr::join()` is not data-masked. Previously `dplyr::join(by = .data$foo)` would silently be interpreted as `dplyr::join(by = NULL)`. This is now an error. Another issue is using `.data` inside `ggplot2::labs(...)`. This is not allowed since `labs()` isn't data-masked. * `call_name()` now returns `NULL` instead of `"::"` for calls of the form `foo::bar`. We've noticed some packages do not check for `NULL` results from `call_name()`. Note that many complex calls such as `foo()()`, `foo$bar()` don't have a "name" and cause a `NULL` result. This is why you should always check for `NULL` results when using `call_name()`. We've added the function `is_call_simple()` to make it easier to work safely with `call_name()`. The invariant is that `call_name()` always returns a string when `is_call_simple()` returns `TRUE`. Conversely it always returns `NULL` when `is_call_simple()` retuns `FALSE`. * `is_expression()` now returns `FALSE` for manually constructed expressions that can't be created by the parser. It used to return `TRUE` for any calls, including those that contain injected objects. Consider using `is_call()` or just remove the expression check. In many cases it is fine letting all objects go through when an expression is expected. For instance you can inject objects directly inside dplyr arguments: ``` x <- seq_len(nrow(data)) dplyr::mutate(data, col = !!x) ``` * If a string is supplied to `as_function()` instead of an object (function or formula), the function is looked up in the global environment instead of the calling environment. In general, passing a function name as a string is brittle. It is easy to forget to pass the user environment to `as_function()` and sometimes there is no obvious user environment. The support for strings should be considered a convenience for end users only, not for programmers. Since environment forwarding is easy to mess up, and since the feature is aimed towards end users, `as_function()` now defaults to the global environment. Supply an environment explicitly if that is not correct in your case. * `with_handlers()`, `call_fn()`, and `friendly_type()` are deprecated. * The `action` argument of `check_dots_used()`, `check_dots_unnamed()`, and `check_dots_empty()` is deprecated in favour of the new `error` argument which takes an error handler. * Many functions deprecated in rlang 0.2.0 and 0.3.0 have been removed from the package. ## Fixes and features ### tidyeval * New `englue()` operator to allow string-embracing outside of dynamic dots (#1172). * New `data_sym()` and `data_syms()` functions to create calls of the form `.data$foo`. * `.data` now fails early when it is subsetted outside of a data mask context. This provides a more informative error message (#804, #1133). * `as_label()` now better handles calls to infix operators (#956, r-lib/testthat#1432). This change improves auto-labelled expressions in data-masking functions like `tibble()`, `mutate()`, etc. * The `{{` operator is now detected more strictly (#1087). If additional arguments are supplied through `{`, it is no longer interpreted as an injection operator. * The `.ignore_empty` argument of `enexprs()` and `enquos()` no longer treats named arguments supplied through `...` as empty, consistently with `exprs()` and `quos()` (#1229). * Fixed a hang when a quosure inheriting from a data mask is evaluated in the mask again. * Fixed performance issue when splicing classes that explicitly inherit from list with `!!!` (#1140, r-lib/vctrs#1170). * Attributes of quosure lists are no longer modified by side effect (#1142). * `enquo()`, `enquos()` and variants now support numbered dots like `..1` (#1137). * Fixed a bug in the AST rotation algorithm that caused the `!!` operator to unexpectedly mutate injected objects (#1103). * Fixed AST rotation issue with `!!` involving binary operators (#1125). ### rlang errors * `try_fetch()` is a flexible alternative to both `tryCatch()` and `withCallingHandlers()` (#503). It is also more efficient than `tryCatch()` and creates leaner backtraces. * New `cnd_inherits()` function to detect a class in a chain of errors (#1293). * New `global_entrace()` function, a user-friendly helper for configuring errors in your RProfile. Call it to enrich all base errors and warnings with an rlang backtrace. This enables `last_error()`, `last_warnings()`, `last_messages()`, and `backtrace_on_error` support for all conditions. * New `global_handle()` function to install a default configuration of error handlers. This currently calls `global_entrace()` and `global_prompt_install()`. Expect more to come. * The "Error:" part of error messages is now printed by rlang instead of R. This introduces several cosmetic and informative changes in errors thrown by `abort()`: - The `call` field of error messages is now displayed, as is the default in `base::stop()`. The call is only displayed if it is a simple expression (e.g. no inlined function) and the arguments are not displayed to avoid distracting from the error message. The message is formatted with the tidyverse style (`code` formatting by the cli package if available). - The source location is displayed (as in `base::stop()`) if `call` carries a source reference. Source locations are not displayed when testthat is running to avoid brittle snapshots. - Error headers are always displayed on their own line, with a `"!"` bullet prefix. See to customise this new display. * The display of chained errors created with the `parent` argument of `abort()` has been improved. Chains of errors are now displayed at throw time with the error prefix "Caused by error:". * The `print()` method of rlang errors (commonly invoked with `last_error()`) has been improved: - Display calls if present. - Chained errors are displayed more clearly. * `inform()` and `warn()` messages can now be silenced with the global options `rlib_message_verbosity` and `rlib_warning_verbosity`. * `abort()` now outputs error messages to `stdout` in interactive sessions, following the same approach as `inform()`. * Errors, warnings, and messages generated from rlang are now formatted with cli. This means in practice that long lines are width-wrapped to the terminal size and user themes are applied. This is currently only the case for rlang messages. This special formatting is not applied when `abort()`, `warn()`, and `inform()` are called from another namespace than rlang. See if you'd like to use cli to format condition messages in your package. * `format_error_bullets()` (used as a fallback instead of cli) now treats: - Unnamed elements as unindented line breaks (#1130) - Elements named `"v"` as green ticks (@rossellhayes) - Elements named `" "` as indented line breaks - Elements named `"*"` as normal bullets - Elements named `"!"` as warning bullets For convenience, a fully unnamed vector is interpreted as a vector of `"*"` bullets. * `abort()` gains a `.internal` argument. When set to `TRUE`, a footer bullet is added to `message` to let the user know that the error is internal and that they should report it to the package authors. * `abort()`, `warn()`, and `inform()` gain a `body` argument to supply additional bullets in the error message. * rlang conditions now have `as.character()` methods. Use this generic on conditions to generate a whole error message, including the `Error:` prefix. These methods are implemented as wrappers around `cnd_message()`. * `header` and `footer` methods can now be stored as closures in condition fields of the same name. * `cnd_message()` gains a `prefix` argument to print the message with a full prefix, including `call` field if present and parent messages if the condition is chained. * `cnd_message()` gains an `inherit` argument to control whether to print the messages of parent errors. * Condition constructors now check for duplicate field names (#1268). * `cnd_footer()` now returns the `footer` field by default, if any. * `warn()` and `inform()` now signal conditions of classes `"rlang_warning"` and `"rlang_message"` respectively. * The `body` field of error conditions can now be a character vector. * The error returned by `last_error()` is now stored on the search path as the `.Last.error` binding of the `"org:r-lib"` environment. This is consistent with how the processx package records error conditions. Printing the `.Last.error` object is now equivalent to running `last_error()`. * Added `is_error()`, `is_warning()`, and `is_message()` predicates (#1220). * `interrupt()` no longer fails when interrupts are suspended (#1224). * `warn()` now temporarily sets the `warning.length` global option to the maximum value (8170). The default limit (1000 characters) is especially easy to hit when the message contains a lot of ANSI escapes, as created by the crayon or cli packages (#1211). ### Backtraces * `entrace()` and `global_entrace()` now log warnings and messages with backtraces attached. Run `last_warnings()` or `last_messages()` to inspect the warnings or messages emitted during the last command. * Internal errors now include a winch backtrace if installed. The user is invited to install it if not installed. * Display of rlang backtraces for expected errors in dynamic reports (chunks where `error = TRUE` in knitted documents and RStudio notebooks) is now controlled by the `rlang_backtrace_on_error_report` option. By default, this is set to `"none"`. The display of backtraces for _unexpected_ errors (in chunks where `error` is unset or set to `FALSE`) is still controlled by `rlang_backtrace_on_error`. * The `last_error()` reminder is no longer displayed in RStudio notebooks. * A `knitr::sew()` method is registered for `rlang_error`. This makes it possible to consult `last_error()` (the call must occur in a different chunk than the error) and to set `rlang_backtrace_on_error_report` global options in knitr to display a backtrace for expected errors. If you show rlang backtraces in a knitted document, also set this in a hidden chunk to trim the knitr context from the backtraces: ``` options( rlang_trace_top_env = environment() ) ``` This change replaces an ad hoc mechanism that caused bugs in corner cases (#1205). * The `rlang_trace_top_env` global option for `trace_back()` now detects when backtraces are created within knitr. If the option is not set, its default value becomes `knitr::knit_global()` when knitr is in progress (as determined from `knitr.in.progress` global option). This prevents the knitr evaluation context from appearing in the backtraces (#932). * Namespace changes are now emboldened in backtraces (#946). * Functions defined in the global environments or in local execution environments are now displayed with a space separator in backtraces instead of `::` and `:::`. This avoids making it seem like these frame calls are valid R code ready to be typed in (#902). * Backtraces no longer contain inlined objects to avoid performance issues in edge cases (#1069, r-lib/testthat#1223). * External backtraces in error chains are now separately displayed (#1098). * Trace capture now better handles wrappers of calling handler in case of rethrown chained errors. * Backtraces now print dangling srcrefs (#1206). Paths are shortened to show only three components (two levels of folder and the file). * The root symbol in backtraces is now slightly different so that it can't be confused with a prompt character (#1207). ### Argument intake * `arg_match()` gains a `multiple` argument for cases where zero or several matches are allowed (#1281). * New function `check_required()` to check that an argument is supplied. It produces a more friendly error message than `force()` (#1118). * `check_dots_empty()`, `check_dots_used()`, and `check_dots_unnamed()` have been moved from ellipsis to rlang. The ellipsis package is deprecated and will eventually be archived. We have added `check_dots_empty0()`. It has a different UI but is almost as efficient as checking for `missing(...)`. Use this in very low level functions where a couple microseconds make a difference. * The `arg_nm` argument of `arg_match0()` must now be a string or symbol. * `arg_match()` now mentions the supplied argument (#1113). * `is_installed()` and `check_installed()` gain a `version` argument (#1165). * `check_installed()` now consults the `rlib_restart_package_not_found` global option to determine whether to prompt users to install packages. This also disables the restart mechanism (see below). * `check_installed()` now signals errors of class `rlib_error_package_not_found` with a `rlib_restart_package_not_found` restart. This allows calling handlers to install the required packages and restart the check (#1150). * `is_installed()` and `check_installed()` now support DESCRIPTION-style version requirements like `"rlang (>= 1.0)"`. They also gain `version` and `compare` arguments to supply requirements programmatically. * `check_installed()` gains an `action` argument that is called when the user chooses to install and update missing and outdated packages. * New `check_exclusive()` function to check that only one argument of a set is supplied (#1261). ### R APIs * `on_load()` and `run_on_load()` lets you run `.onLoad()` expressions from any file of your package. `on_package_load()` runs expressions when another package is loaded. (#1284) * The new predicate `is_call_simple()` indicates whether a call has a name and/or a namespace. It provides two invariants: - If `is_call_simple(x)` is `TRUE`, `call_name()` always returns a string. - If `is_call_simple(x, ns = TRUE)` is `TRUE`, `call_ns()` always returns a string. * `call_name()` and `call_ns()` now return `NULL` with calls of the form `foo::bar` (#670). * New `current_call()`, `caller_call()`, and `frame_call()` accessors. New `frame_fn()` accessor. * `env_has()` and the corresponding C-level function no longer force active bindings (#1292). * New `names2<-` replacement function that never adds missing values when names don't have names (#1301). * `zap_srcref()` now preserves attributes of closures. * Objects headers (as printed by `last_error()`, `env_print()`, ...) are now formatted using the `cls` class of the cli package. * `as_function()` gains `arg` and `call` arguments to provide contextual information about erroring inputs. * `is_expression()` now returns `FALSE` for manually constructed expressions that cannot be created by the R parser. * New C callable `rlang_env_unbind()`. This is a wrapper around `R_removeVarFromFrame()` on R >= 4.0.0. On older R this wraps the R function `base::rm()`. Unlike `rm()`, this function does not warn (nor throw) when a binding does not exist. * `friendly_type_of()` now supports missing arguments. * `env_clone()` now properly clones active bindings and avoids forcing promises (#1228). On R < 4.0, promises are still forced. * Fixed an `s3_register()` issue when the registering package is a dependency of the package that exports the generic (#1225). * Added `compat-vctrs.R` file for robust manipulation of data frames in zero-deps packages. * Added `compat-cli.R` file to format message elements consistently with cli in zero-deps packages. * `compat-purrr.R` now longer includes `pluck*` helpers; these used a defintion of pluck that predated purrr (#1159). `*_cpl()` has also been removed. The `map*` wrappers now call `as_function()` so that you can pass short anonymous functions that use `~` (#1157). * `exprs_auto_name()` gains a `repair_auto` argument to make automatic names unique (#1116). * The `.named` argument of `dots_list()` can now be set to `NULL` to give the result default names. With this option, fully unnamed inputs produce a fully unnamed result with `NULL` names instead of a character vector of minimal `""` names (#390). * `is_named2()` is a variant of `is_named()` that always returns `TRUE` for empty vectors (#191). It tests for the property that each element of a vector is named rather than the presence of a `names` attribute. * New `rlib_bytes` class imported from the bench package (#1117). It prints and parses human-friendly sizes. * The `env` argument of `as_function()` now defaults to the global environment. Its previous default was the caller of `as_function()`, which was rarely the correct environment to look in. Since it's hard to remember to pass the user environment and it's sometimes tricky to keep track of it, it's best to consider string lookup as a convenience for end users, not for developers (#1170). * `s3_register()` no longer fails when generic does not exist. This prevents failures when users don't have all the last versions of packages (#1112). * Formulas are now deparsed according to the tidyverse style guide (`~symbol` without space and `~ expression()` with a space). * New `hash_file()`, complementing `hash()`, to generate 128-bit hashes for the data within a file without loading it into R (#1134). * New `env_cache()` function to retrieve a value or create it with a default if it doesn't exist yet (#1081). * `env_get()` and `env_get_list()` gain a `last` argument. Lookup stops in that environment. This can be useful in conjunction with `base::topenv()`. * New `call_match()` function. It is like `match.call()` but also supports matching missing arguments to their defaults in the function definition (#875). `call_standardise()` is deprecated in favour of `call_match()`. * `expr_deparse()` now properly escapes `\` characters in symbols, argument names, and vector names (#1160). * `friendly_type_of()` (from `compat-friendly-type.R`) now supports matrices and arrays (#141). * Updated `env_print()` to use `format_error_bullets()` and consistent tidyverse style (#1154). * `set_names()` now recycles names of size 1 to the size of the input, following the tidyverse recycling rules. * `is_bare_formula()` now handles the `scoped` argument consistently. The default has been changed to `TRUE` for compatibility with the historical default behaviour (#1115). * The "definition" API (`dots_definitions()` etc.) has been archived. * New `is_complex()` predicates to complete the family (#1127). * The C function `r_obj_address()` now properly prefixes addresses with the hexadecimal prefix `0x` on Windows (#1135). * `obj_address()` is now exported. * `%<~%` now actually works. * `XXH3_64bits()` from the XXHash library is now exposed as C callable under the name `rlang_xxh3_64bits()`. # rlang 0.4.12 * Fix for CRAN checks. # rlang 0.4.11 * Fix for CRAN checks. * Fixed a gcc11 warning related to `hash()` (#1088). # rlang 0.4.10 * New `hash()` function to generate 128-bit hashes for arbitrary R objects using the xxHash library. The implementation is modeled after [xxhashlite](https://github.com/coolbutuseless/xxhashlite), created by @coolbutuseless. * New `check_installed()` function. Unlike `is_installed()`, it asks the user whether to install missing packages. If the user accepts, the packages are installed with `pak::pkg_install()` if available, or `utils::install.packages()` otherwise. If the session is non interactive or if the user chooses not to install the packages, the current evaluation is aborted (#1075). * rlang is now licensed as MIT (#1063). * Fixed an issue causing extra empty lines in `inform()` messages with `.frequency` (#1076, @schloerke). * `expr_deparse()` now correctly wraps code using `::` and `:::` (#1072, @krlmlr). # rlang 0.4.9 ## Breaking changes * Dropped support for the R 3.2 series. ## New features * `inject()` evaluates its argument with `!!`, `!!!`, and `{{` support. * New `enquo0()` and `enquos0()` operators for defusing function arguments without automatic injection (unquotation). * `format_error_bullets()` is no longer experimental. The `message` arguments of `abort()`, `warn()`, and `inform()` are automatically passed to that function to make it easy to create messages with regular, info, and error bullets. See `?format_error_bullets` for more information. * New `zap_srcref()` function to recursively remove source references from functions and calls. * A new compat file for the zeallot operator `%<-%` is now available in the rlang repository. * New `%<~%` operator to define a variable lazily. * New `env_browse()` and `env_is_browsed()` functions. `env_browse()` is equivalent to evaluating `browser()` within an environment. It sets the environment to be persistently browsable (or unsets it if `value = FALSE` is supplied). * Functions created from quosures with `as_function()` now print in a more user friendly way. * New `rlang_print_backtrace` C callable for debugging from C interpreters (#1059). ## Bugfixes and improvements * The `.data` pronoun no longer skips functions (#1061). This solves a dplyr issue involving rowwise data frames and list-columns of functions (tidyverse/dplyr#5608). * `as_data_mask()` now intialises environments of the correct size to improve efficiency (#1048). * `eval_bare()`, `eval_tidy()` (#961), and `with_handlers()` (#518) now propagate visibility. * `cnd_signal()` now ignores `NULL` inputs. * Fixed bug that prevented splicing a named empty vector with the `!!!` operator (#1045). * The exit status of is now preserved in non-interactive sessions when `entrace()` is used as an `options(error = )` handler (#1052, rstudio/bookdown#920). * `next` and `break` are now properly deparsed as nullary operators. # rlang 0.4.8 * Backtraces now include native stacks (e.g. from C code) when the [winch](https://r-prof.github.io/winch/) package is installed and `rlang_trace_use_winch` is set to `TRUE` (@krlmlr). * Compatibility with upcoming testthat 3 and magrittr 2 releases. * `get_env()` now returns the proper environment with primitive functions, i.e. the base namespace rather than the base environment (r-lib/downlit#32). * `entrace()` no longer handles non-rlang errors that carry a backtrace. This improves compatibility with packages like callr. * Backtraces of unhandled errors are now displayed without truncation in non-interactive sessions (#856). * `is_interactive()` no longer consults "rstudio.notebook.executing" option (#1031). # rlang 0.4.7 * `cnd_muffle()` now returns `FALSE` instead of failing if the condition is not mufflable (#1022). * `warn()` and `inform()` gain a `.frequency` argument to control how frequently the warning or message should be displayed. * New `raw_deparse_str()` function for converting a raw vector into a string of hexadecimal characters (@krlmlr, #978). * The backtraces of chained errors are no longer decomposed by error context. Instead, the error messages are displayed as a tree to reflect the error ancestry, and the deepest backtrace in the ancestry is displayed. This change simplifies the display (#851) and makes it possible to rethow errors from a calling handler rather than an exiting handler, which we now think is more appropriate because it allows users to `recover()` into the error. * `env_bind()`, `env_bind_active()`, `env_bind_lazy()`, `env_get()`, and `env_get_list()` have been rewritten in C. * `env_poke()` now supports `zap()` sentinels for removing bindings (#1012) and has better support for characters that are not representable in the local encoding. * `env_poke()` has been rewritten in C for performance. * The unicode translation warnings that appeared on Windows with R 4.0 are now fixed. * `env_unbind(inherit = TRUE)` now only removes a binding from the first parent environment that has a binding. It used to remove the bindings from the whole ancestry. The new behaviour doesn't guarantee that a scope doesn't have a binding but it is safer. * `env_has()` is now rewritten in C for performance. * `dots_list()` gains a `.named` argument for auto-naming dots (#957). * It is now possible to subset the `.data` pronoun with quosured symbols or strings (#807). * Expressions like `quote(list("a b" = 1))` are now properly deparsed by `expr_deparse()` (#950). * `parse_exprs()` now preserves names (#808). When a single string produces multiple expressions, the names may be useful to figure out what input produced which expression. * `parse_exprs()` now supports empty expressions (#954). * `list2(!!!x)` no longer evaluates `x` multiple times (#981). * `is_installed()` now properly handles a `pkg` argument of length > 1. Before this it silently tested the first element of `pkg` only and thus always returned `TRUE` if the first package was installed regardless of the actual length of `pkg`. (#991, @salim-b) * `arg_match0()` is a faster version of `arg_match()` for use when performance is at a premium (#997, @krlmlr). # rlang 0.4.6 * `!!!` now uses a combination of `length()`, `names()`, and `[[` to splice S3 and S4 objects. This produces more consistent behaviour than `as.list()` on a wider variety of vector classes (#945, tidyverse/dplyr#4931). # rlang 0.4.5 * `set_names()`, `is_formula()`, and `names2()` are now implemented in C for efficiency. * The `.data` pronoun now accepts symbol subscripts (#836). * Quosure lists now explicitly inherit from `"list"`. This makes them compatible with the vctrs package (#928). * All rlang options are now documented in a centralised place, see `?rlang::faq-options` (#899, @smingerson). * Fixed crash when `env_bindings_are_lazy()` gets improper arguments (#923). * `arg_match()` now detects and suggests possible typos in provided arguments (@jonkeane, #798). * `arg_match()` now gives an error if argument is of length greater than 1 and doesn't exactly match the values input, similar to base `match.arg` (#914, @AliciaSchep) # rlang 0.4.4 * Maintenance release for CRAN. # rlang 0.4.3 * You can now use glue syntax to unquote on the LHS of `:=`. This syntax is automatically available in all functions taking dots with `list2()` and `enquos()`, and thus most of the tidyverse. Note that if you use the glue syntax in an R package, you need to import glue. A single pair of braces triggers normal glue interpolation: ```r df <- data.frame(x = 1:3) suffix <- "foo" df %>% dplyr::mutate("var_{suffix}" := x * 2) #> x var_foo #> 1 1 2 #> 2 2 4 #> 3 3 6 ``` Using a pair of double braces is for labelling a function argument. Technically, this is shortcut for `"{as_label(enquo(arg))}"`. The syntax is similar to the curly-curly syntax for interpolating function arguments: ```r my_wrapper <- function(data, var, suffix = "foo") { data %>% dplyr::mutate("{{ var }}_{suffix}" := {{ var }} * 2) } df %>% my_wrapper(x) #> x x_foo #> 1 1 2 #> 2 2 4 #> 3 3 6 df %>% my_wrapper(sqrt(x)) #> x sqrt(x)_foo #> 1 1 2.000000 #> 2 2 2.828427 #> 3 3 3.464102 ``` * Fixed a bug in magrittr backtraces that caused duplicate calls to appear in the trace. * Fixed a bug in magrittr backtraces that caused wrong call indices. * Empty backtraces are no longer shown when `rlang_backtrace_on_error` is set. * The tidy eval `.env` pronoun is now exported for documentation purposes. * `warn()` and `abort()` now check that either `class` or `message` was supplied. `inform()` allows sending empty message as it is occasionally useful for building user output incrementally. * `flatten()` fails with a proper error when input can't be flattened (#868, #885). * `inform()` now consistently appends a final newline to the message (#880). * `cnd_body.default()` is now properly registered. * `cnd_signal()` now uses the same approach as `abort()` to save unhandled errors to `last_error()`. * Parsable constants like `NaN` and `NA_integer_` are now deparsed by `expr_deparse()` in their parsable form (#890). * Infix operators now stick to their LHS when deparsed by `expr_deparse()` (#890). # rlang 0.4.2 * New `cnd_header()`, `cnd_body()` and `cnd_footer()` generics. These are automatically called by `conditionMessage.rlang_error()`, the default method for all rlang errors. Concretely, this is a way of breaking up lazy generation of error messages with `conditionMessage()` into three independent parts. This provides a lot of flexibility for hierarchies of error classes, for instance you could inherit the body of an error message from a parent class while overriding the header and footer. * The reminder to call `last_error()` is now less confusing thanks to a suggestion by @markhwhiteii. * The functions prefixed in `scoped_` have been renamed to use the more conventional `local_` prefix. For instance, `scoped_bindings()` is now `local_bindings()`. The `scoped_` functions will be deprecated in the next significant version of rlang (0.5.0). * The `.subclass` argument of `abort()`, `warn()` and `inform()` has been renamed to `class`. This is for consistency with our conventions for class constructors documented in https://adv-r.hadley.nz/s3.html#s3-subclassing. * `inform()` now prints messages to the standard output by default in interactive sessions. This makes them appear more like normal output in IDEs such as RStudio. In non-interactive sessions, messages are still printed to standard error to make it easy to redirect messages when running R scripts (#852). * Fixed an error in `trace_back()` when the call stack contains a quosured symbol. * Backtrace is now displayed in full when an error occurs in non-interactive sessions. Previously the backtraces of parent errors were left out. # rlang 0.4.1 * New experimental framework for creating bulleted error messages. See `?cnd_message` for the motivation and an overwiew of the tools we have created to support this approach. In particular, `abort()` now takes character vectors to assemble a bullet list. Elements named `x` are prefixed with a red cross, elements named `i` are prefixed with a blue info symbol, and unnamed elements are prefixed with a bullet. * Capture of backtrace in the context of rethrowing an error from an exiting handler has been improved. The `tryCatch()` context no longer leaks in the high-level backtrace. * Printing an error no longer recommends calling `last_trace()`, unless called from `last_error()`. * `env_clone()` no longer recreates active bindings and is now just an alias for `env2list(as.list(env))`. Unlike `as.list()` which returns the active binding function on R < 4.0, the value of active bindings is consistently used in all versions. * The display of rlang errors derived from parent errors has been improved. The simplified backtrace (as printed by `rlang::last_error()`) no longer includes the parent errors. On the other hand, the full backtrace (as printed by `rlang::last_trace()`) now includes the backtraces of the parent errors. * `cnd_signal()` has improved support for rlang errors created with `error_cnd()`. It now records a backtrace if there isn't one already, and saves the error so it can be inspected with `rlang::last_error()`. * rlang errors are no longer formatted and saved through `conditionMessage()`. This makes it easier to use a `conditionMessage()` method in subclasses created with `abort()`, which is useful to delay expensive generation of error messages until display time. * `abort()` can now be called without error message. This is useful when `conditionMessage()` is used to generate the message at print-time. * Fixed an infinite loop in `eval_tidy()`. It occurred when evaluating a quosure that inherits from the mask itself. * `env_bind()`'s performance has been significantly improved by fixing a bug that caused values to be repeatedly looked up by name. * `cnd_muffle()` now checks that a restart exists before invoking it. The restart might not exist if the condition is signalled with a different function (such as `stop(warning_cnd)`). * `trace_length()` returns the number of frames in a backtrace. * Added internal utility `cnd_entrace()` to add a backtrace to a condition. * `rlang::last_error()` backtraces are no longer displayed in red. * `x %|% y` now also works when `y` is of same length as `x` (@rcannood, #806). * Empty named lists are now deparsed more explicitly as `""`. * Fixed `chr()` bug causing it to return invisibly. # rlang 0.4.0 ## Tidy evaluation ### Interpolate function inputs with the curly-curly operator The main change of this release is the new tidy evaluation operator `{{`. This operator abstracts the quote-and-unquote idiom into a single interpolation step: ``` my_wrapper <- function(data, var, by) { data %>% group_by({{ by }}) %>% summarise(average = mean({{ var }}, na.rm = TRUE)) } ``` `{{ var }}` is a shortcut for `!!enquo(var)` that should be easier on the eyes, and easier to learn and teach. Note that for multiple inputs, the existing documentation doesn't stress enough that you can just pass dots straight to other tidy eval functions. There is no need for quote-and-unquote unless you need to modify the inputs or their names in some way: ``` my_wrapper <- function(data, var, ...) { data %>% group_by(...) %>% summarise(average = mean({{ var }}, na.rm = TRUE)) } ``` ### More robust `.env` pronoun Another improvement to tidy evaluation should make it easier to use the `.env` pronoun. Starting from this release, subsetting an object from the `.env` pronoun now evaluates the corresponding symbol. This makes `.env` more robust, in particular in magrittr pipelines. The following example would previously fail: ``` foo <- 10 mtcars %>% mutate(cyl = cyl * .env$foo) ``` This way, using the `.env` pronoun is now equivalent to unquoting a constant objects, but with an easier syntax: ``` mtcars %>% mutate(cyl = cyl * !!foo) ``` Note that following this change, and despite its name, `.env` is no longer referring to a bare environment. Instead, it is a special shortcut with its own rules. Similarly, the `.data` pronoun is not really a data frame. ## New functions and features * New `pairlist2()` function with splicing support. It preserves missing arguments, which makes it useful for lists of formal parameters for functions. * `is_bool()` is a scalar type predicate that checks whether its input is a single `TRUE` or `FALSE`. Like `is_string()`, it returns `FALSE` when the input is missing. This is useful for type-checking function arguments (#695). * `is_string()` gains a `string` argument. `is_string(x, "foo")` is a shortcut for `is_character(x) && length(x) == 1 && identical(x, "foo")`. * Lists of quosures now have pillar methods for display in tibbles. * `set_names()` now names unnamed input vectors before applying a function. The following expressions are now equivalent: ``` letters %>% set_names() %>% set_names(toupper) letters %>% set_names(toupper) ``` * You can now pass a character vector as message argument for `abort()`, `warn()`, `inform()`, and `signal()`. The vector is collapsed to a single string with a `"\n"` newline separating each element of the input vector (#744). * `maybe_missing()` gains a `default` argument. * New functions for weak references: `new_weakref()`, `weakref_key()`, `weakref_value()`, and `is_weakref()` (@wch, #787). ## Performance * The performance of `exec()` has been improved. It is now on the same order of performance as `do.call()`, though slightly slower. * `call2()` now uses the new `pairlist2()` function internally. This considerably improves its performance. This also means it now preserves empty arguments: ``` call2("fn", 1, , foo = ) #> fn(1, , foo = ) ``` ## Bugfixes and small improvements * `with_handlers()` now installs calling handlers first on the stack, no matter their location in the argument list. This way they always take precedence over exiting handlers, which ensures their side effects (such as logging) take place (#718). * In rlang backtraces, the `global::` prefix is now only added when the function directly inherits from the global environment. Functions inheriting indirectly no longer have a namespace qualifier (#733). * `options(error = rlang::entrace)` now has better support for errors thrown from C (#779). It also saves structured errors in the `error` field of `rlang::last_error()`. * `ns_env()` and `ns_env_name()` (experimental functions) now support functions and environments consisently. They also require an argument from now on. * `is_interactive()` is aware of the `TESTTHAT` environment variable and returns `FALSE` when it is `"true"` (@jennybc, #738). * `fn_fmls()` and variants no longer coerce their input to a closure. Instead, they throw an error. * Fixed an issue in knitr that caused backtraces to print even when `error = TRUE`. * The return object from `as_function()` now inherits from `"function"` (@richierocks, #735). ## Lifecycle We commit to support 5 versions of R. As R 3.6 is about to be released, rlang now requires R 3.2 or greater. We're also continuing our efforts to streamline and narrow the rlang API. * `modify()` and `prepend()` (two experimental functions marked as in the questioning stage since rlang 0.3.0) are now deprecated. Vector functions are now out of scope for rlang. They might be revived in the vctrs or funs packages. * `exiting()` is soft-deprecated because `with_handlers()` treats handlers as exiting by default. * The vector constructors like `lgl()` or `new_logical()` are now in the questioning stage. They are likely to be moved to the vctrs package at some point. Same for the missing values shortcuts like `na_lgl`. * `as_logical()`, `as_integer()`, etc have been soft-deprecated in favour of `vctrs::vec_cast()`. * `type_of()`, `switch_type()`, `coerce_type()`, and friends are soft-deprecated. * The encoding and locale API was summarily archived. This API didn't bring any value and wasn't used on CRAN. * `lang_type_of()`, `switch_lang()`, and `coerce_lang()` were archived. These functions were not used on CRAN or internally. * Subsetting quosures with `[` or `[[` is soft-deprecated. * All functions that were soft-deprecated, deprecated, or defunct in previous releases have been bumped to the next lifecycle stage. # rlang 0.3.2 * Fixed protection issue reported by rchk. * The experimental option `rlang__backtrace_on_error` is no longer experimental and has been renamed to `rlang_backtrace_on_error`. * New "none" option for `rlang_backtrace_on_error`. * Unary operators applied to quosures now give better error messages. * Fixed issue with backtraces of warnings promoted to error, and entraced via `withCallingHandlers()`. The issue didn't affect entracing via top level `options(error = rlang::entrace)` handling. # rlang 0.3.1 This patch release polishes the new backtrace feature introduced in rlang 0.3.0 and solves bugs for the upcoming release of purrr 0.3.0. It also features `as_label()` and `as_name()` which are meant to replace `quo_name()` in the future. Finally, a bunch of deparsing issues have been fixed. ## Backtrace fixes * New `entrace()` condition handler. Add this to your RProfile to enable rlang backtraces for all errors, including warnings promoted to errors: ```r if (requireNamespace("rlang", quietly = TRUE)) { options(error = rlang::entrace) } ``` This handler also works as a calling handler: ```r with_handlers( error = calling(entrace), foo(bar) ) ``` However it's often more practical to use `with_abort()` in that case: ```r with_abort(foo(bar)) ``` * `with_abort()` gains a `classes` argument to promote any kind of condition to an rlang error. * New `last_trace()` shortcut to print the backtrace stored in the `last_error()`. * Backtrace objects now print in full by default. * Calls in backtraces are now numbered according to their position in the call tree. The numbering is non-contiguous for simplified backtraces because of omitted call frames. * `catch_cnd()` gains a `classes` argument to specify which classes of condition to catch. It returns `NULL` if the expected condition could not be caught (#696). ## `as_label()` and `as_name()` The new `as_label()` and `as_name()` functions should be used instead of `quo_name()` to transform objects and quoted expressions to a string. We have noticed that tidy eval users often use `quo_name()` to extract names from quosured symbols. This is not a good use for that function because the way `quo_name()` creates a string is not a well defined operation. For this reason, we are replacing `quo_name()` with two new functions that have more clearly defined purposes, and hopefully better names reflecting those purposes. Use `as_label()` to transform any object to a short human-readable description, and `as_name()` to extract names from (possibly quosured) symbols. Create labels with `as_label()` to: * Display an object in a concise way, for example to labellise axes in a graphical plot. * Give default names to columns in a data frame. In this case, labelling is the first step before name repair. We expect `as_label()` to gain additional parameters in the future, for example to control the maximum width of a label. The way an object is labelled is thus subject to change. On the other hand, `as_name()` transforms symbols back to a string in a well defined manner. Unlike `as_label()`, `as_name()` guarantees the roundtrip symbol -> string -> symbol. In general, if you don't know for sure what kind of object you're dealing with (a call, a symbol, an unquoted constant), use `as_label()` and make no assumption about the resulting string. If you know you have a symbol and need the name of the object it refers to, use `as_name()`. For instance, use `as_label()` with objects captured with `enquo()` and `as_name()` with symbols captured with `ensym()`. Note that `quo_name()` will only be soft-deprecated at the next major version of rlang (0.4.0). At this point, it will start issuing once-per-session warnings in scripts, but not in packages. It will then be deprecated in yet another major version, at which point it will issue once-per-session warnings in packages as well. You thus have plenty of time to change your code. ## Minor fixes and features * New `is_interactive()` function. It serves the same purpose as `base::interactive()` but also checks if knitr is in progress and provides an escape hatch. Use `with_interactive()` and `scoped_interactive()` to override the return value of `is_interactive()`. This is useful in unit tests or to manually turn on interactive features in RMarkdown outputs * `calling()` now boxes its argument. * New `done()` function to box a value. Done boxes are sentinels to indicate early termination of a loop or computation. For instance, it will be used in the purrr package to allow users to shortcircuit a reduction or accumulation. * `new_box()` now accepts additional attributes passed to `structure()`. * Fixed a quotation bug with binary operators of zero or one argument such as `` `/`(1) `` (#652). They are now deparsed and printed properly as well. * New `call_ns()` function to retrieve the namespace of a call. Returns `NULL` if the call is not namespaced. * Top-level S3 objects are now deparsed properly. * Empty `{` blocks are now deparsed on the same line. * Fixed a deparsing issue with symbols containing non-ASCII characters (#691). * `expr_print()` now handles `[` and `[[` operators correctly, and deparses non-syntactic symbols with backticks. * `call_modify()` now respects ordering of unnamed inputs. Before this fix, it would move all unnamed inputs after named ones. * `as_closure()` wrappers now call primitives with positional arguments to avoid edge case issues of argument matching. * `as_closure()` wrappers now dispatch properly on methods defined in the global environment (tidyverse/purrr#459). * `as_closure()` now supports both base-style (`e1` and `e2`) and purrr-style (`.x` and `.y`) arguments with binary primitives. * `exec()` takes `.fn` as first argument instead of `f`, for consistency with other rlang functions. * Fixed infinite loop with quosures created inside a data mask. * Base errors set as `parent` of rlang errors are now printed correctly. # rlang 0.3.0 ## Breaking changes The rlang API is still maturing. In this section, you'll find hard breaking changes. See the life cycle section below for an exhaustive list of API changes. * `quo_text()` now deparses non-syntactic symbols with backticks: ``` quo_text(sym("foo+")) #> [1] "`foo+`" ``` This caused a number of issues in reverse dependencies as `quo_text()` tends to be used for converting symbols to strings. `quo_text()` and `quo_name()` should not be used for this purpose because they are general purpose deparsers. These functions should generally only be used for printing outputs or creating default labels. If you need to convert symbols to strings, please use `as_string()` rather than `quo_text()`. We have extended the documentation of `?quo_text` and `?quo_name` to make these points clearer. * `exprs()` no longer flattens quosures. `exprs(!!!quos(x, y))` is now equivalent to `quos(x, y)`. * The sentinel for removing arguments in `call_modify()` has been changed from `NULL` to `zap()`. This breaking change is motivated by the ambiguity of `NULL` with valid argument values. ```r call_modify(call, arg = NULL) # Add `arg = NULL` to the call call_modify(call, arg = zap()) # Remove the `arg` argument from the call ``` * The `%@%` operator now quotes its input and supports S4 objects. This makes it directly equivalent to `@` except that it extracts attributes for non-S4 objects (#207). * Taking the `env_parent()` of the empty environment is now an error. ## Summary The changes for this version are organised around three main themes: error reporting, tidy eval, and tidy dots. * `abort()` now records backtraces automatically in the error object. Errors thrown with `abort()` invite users to call `rlang::last_error()` to see a backtrace and help identifying where and why the error occurred. The backtraces created by rlang (you can create one manually with `trace_back()`) are printed in a simplified form by default that removes implementation details from the backtrace. To see the full backtrace, call `summary(rlang::last_error())`. `abort()` also gains a `parent` argument. This is meant for situations where you're calling a low level API (to download a file, parse a JSON file, etc) and would like to intercept errors with `base::tryCatch()` or `rlang::with_handlers()` and rethrow them with a high-level message. Call `abort()` with the intercepted error as the `parent` argument. When the user prints `rlang::last_error()`, the backtrace will be shown in two sections corresponding to the high-level and low-level contexts. In order to get segmented backtraces, the low-level error has to be thrown with `abort()`. When that's not the case, you can call the low-level function within `with_abort()` to automatically promote all errors to rlang errors. * The tidy eval changes are mostly for developers of data masking APIs. The main user-facing change is that `.data[[` is now an unquote operator so that `var` in `.data[[var]]` is never masked by data frame columns and always picked from the environment. This makes the pronoun safe for programming in functions. * The `!!!` operator now supports all classed objects like factors. It calls `as.list()` on S3 objects and `as(x, "list")` on S4 objects. * `dots_list()` gains several arguments to control how dots are collected. You can control the selection of arguments with the same name with `.homonyms` (keep first, last, all, or abort). You can also elect to preserve empty arguments with `.preserve_empty`. ## Conditions and errors * New `trace_back()` captures a backtrace. Compared to the base R traceback, it contains additional structure about the relationship between frames. It comes with tools for automatically restricting to frames after a certain environment on the stack, and to simplify when printing. These backtraces are now recorded in errors thrown by `abort()` (see below). * `abort()` gains a `parent` argument to specify a parent error. This is meant for situations where a low-level error is expected (e.g. download or parsing failed) and you'd like to throw an error with higher level information. Specifying the low-level error as parent makes it possible to partition the backtraces based on ancestry. * Errors thrown with `abort()` now embed a backtrace in the condition object. It is no longer necessary to record a trace with a calling handler for such errors. * `with_abort()` runs expressions in a context where all errors are promoted to rlang errors and gain a backtrace. * Unhandled errors thrown by `abort()` are now automatically saved and can be retrieved with `rlang::last_error()`. The error prints with a simplified backtrace. Call `summary(last_error())` to see the full backtrace. * New experimental option `rlang__backtrace_on_error` to display backtraces alongside error messages. See `?rlang::abort` for supported options. * The new `signal()` function completes the `abort()`, `warn()` and `inform()` family. It creates and signals a bare condition. * New `interrupt()` function to simulate an user interrupt from R code. * `cnd_signal()` now dispatches messages, warnings, errors and interrupts to the relevant signalling functions (`message()`, `warning()`, `stop()` and the C function `Rf_onintr()`). This makes it a good choice to resignal a captured condition. * New `cnd_type()` helper to determine the type of a condition (`"condition"`, `"message"`, `"warning"`, `"error"` or `"interrupt"`). * `abort()`, `warn()` and `inform()` now accepts metadata with `...`. The data are stored in the condition and can be examined by user handlers. Consequently all arguments have been renamed and prefixed with a dot (to limit naming conflicts between arguments and metadata names). * `with_handlers()` treats bare functions as exiting handlers (equivalent to handlers supplied to `tryCatch()`). It also supports the formula shortcut for lambda functions (as in purrr). * `with_handlers()` now produces a cleaner stack trace. ## Tidy dots * The input types of `!!!` have been standardised. `!!!` is generally defined on vectors: it takes a vector (typically, a list) and unquotes each element as a separate argument. The standardisation makes `!!!` behave the same in functions taking dots with `list2()` and in quoting functions. `!!!` accepts these types: - Lists, pairlists, and atomic vectors. If they have a class, they are converted with `base::as.list()` to allow S3 dispatch. Following this change, objects like factors can now be spliced without data loss. - S4 objects. These are converted with `as(obj, "list")` before splicing. - Quoted blocks of expressions, i.e. `{ }` calls `!!!` disallows: - Any other objects like functions or environments, but also language objects like formula, symbols, or quosures. Quoting functions used to automatically wrap language objects in lists to make them spliceable. This behaviour is now soft-deprecated and it is no longer valid to write `!!!enquo(x)`. Please unquote scalar objects with `!!` instead. * `dots_list()`, `enexprs()` and `enquos()` gain a `.homonyms` argument to control how to treat arguments with the same name. The default is to keep them. Set it to `"first"` or `"last"` to keep only the first or last occurrences. Set it to `"error"` to raise an informative error about the arguments with duplicated names. * `enexprs()` and `enquos()` now support `.ignore_empty = "all"` with named arguments as well (#414). * `dots_list()` gains a `.preserve_empty` argument. When `TRUE`, empty arguments are stored as missing arguments (see `?missing_arg`). * `dots_list()`, `enexprs()` and `enquos()` gain a `.check_assign` argument. When `TRUE`, a warning is issued when a `<-` call is detected in `...`. No warning is issued if the assignment is wrapped in brackets like `{ a <- 1 }`. The warning lets users know about a possible typo in their code (assigning instead of matching a function parameter) and requires them to be explicit that they really want to assign to a variable by wrapping in parentheses. * `lapply(list(quote(foo)), list2)` no longer evaluates `foo` (#580). ## Tidy eval * You can now unquote quosured symbols as LHS of `:=`. The symbol is automatically unwrapped from the quosure. * Quosure methods have been defined for common operations like `==`. These methods fail with an informative error message suggesting to unquote the quosure (#478, #tidyverse/dplyr#3476). * `as_data_pronoun()` now accepts data masks. If the mask has multiple environments, all of these are looked up when subsetting the pronoun. Function objects stored in the mask are bypassed. * It is now possible to unquote strings in function position. This is consistent with how the R parser coerces strings to symbols. These two expressions are now equivalent: `expr("foo"())` and `expr((!!"foo")())`. * Quosures converted to functions with `as_function()` now support nested quosures. * `expr_deparse()` (used to print quosures at the console) now escapes special characters. For instance, newlines now print as `"\n"` (#484). This ensures that the roundtrip `parse_expr(expr_deparse(x))` is not lossy. * `new_data_mask()` now throws an error when `bottom` is not a child of `top` (#551). * Formulas are now evaluated in the correct environment within `eval_tidy()`. This fixes issues in dplyr and other tidy-evaluation interfaces. * New functions `new_quosures()` and `as_quosures()` to create or coerce to a list of quosures. This is a small S3 class that ensures two invariants on subsetting and concatenation: that each element is a quosure and that the list is always named even if only with a vector of empty strings. ## Environments * `env()` now treats a single unnamed argument as the parent of the new environment. Consequently, `child_env()` is now superfluous and is now in questioning life cycle. * New `current_env()` and `current_fn()` functions to retrieve the current environment or the function being evaluated. They are equivalent to `base::environment()` and `base::sys.function()` called without argument. * `env_get()` and `env_get_list()` gain a `default` argument to provide a default value for non-existing bindings. * `env_poke()` now returns the old value invisibly rather than the input environment. * The new function `env_name()` returns the name of an environment. It always adds the "namespace:" prefix to namespace names. It returns "global" instead of ".GlobalEnv" or "R_GlobalEnv", "empty" instead of "R_EmptyEnv". The companion `env_label()` is like `env_name()` but returns the memory address for anonymous environments. * `env_parents()` now returns a named list. The names are taken with `env_name()`. * `env_parents()` and `env_tail()` now stop at the global environment by default. This can be changed with the `last` argument. The empty environment is always a stopping condition so you can take the parents or the tail of an environment on the search path without changing the default. * New predicates `env_binding_are_active()` and `env_binding_are_lazy()` detect the kind of bindings in an environment. * `env_binding_lock()` and `env_binding_unlock()` allows to lock and unlock multiple bindings. The predicate `env_binding_are_locked()` tests if bindings are locked. * `env_lock()` and `env_is_locked()` lock an environment or test if an environment is locked. * `env_print()` pretty-prints environments. It shows the contents (up to 20 elements) and the properties of the environment. * `is_scoped()` has been soft-deprecated and renamed to `is_attached()`. It now supports environments in addition to search names. * `env_bind_lazy()` and `env_bind_active()` now support quosures. * `env_bind_exprs()` and `env_bind_fns()` are soft-deprecated and renamed to `env_bind_lazy()` and `env_bind_active()` for clarity and consistency. * `env_bind()`, `env_bind_exprs()`, and `env_bind_fns()` now return the list of old binding values (or missing arguments when there is no old value). This makes it easy to restore the original environment state: ``` old <- env_bind(env, foo = "foo", bar = "bar") env_bind(env, !!!old) ``` * `env_bind()` now supports binding missing arguments and removing bindings with zap sentinels. `env_bind(env, foo = )` binds a missing argument and `env_bind(env, foo = zap())` removes the `foo` binding. * The `inherit` argument of `env_get()` and `env_get_list()` has changed position. It now comes after `default`. * `scoped_bindings()` and `with_bindings()` can now be called without bindings. * `env_clone()` now recreates active bindings correctly. * `env_get()` now evaluates promises and active bindings since these are internal objects which should not be exposed at the R level (#554) * `env_print()` calls `get_env()` on its argument, making it easier to see the environment of closures and quosures (#567). * `env_get()` now supports retrieving missing arguments when `inherit` is `FALSE`. ## Calls * `is_call()` now accepts multiple namespaces. For instance `is_call(x, "list", ns = c("", "base"))` will match if `x` is `list()` or if it's `base::list()`: * `call_modify()` has better support for `...` and now treats it like a named argument. `call_modify(call, ... = )` adds `...` to the call and `call_modify(call, ... = NULL)` removes it. * `call_modify()` now preserves empty arguments. It is no longer necessary to use `missing_arg()` to add a missing argument to a call. This is possible thanks to the new `.preserve_empty` option of `dots_list()`. * `call_modify()` now supports removing unexisting arguments (#393) and passing multiple arguments with the same name (#398). The new `.homonyms` argument controls how to treat these arguments. * `call_standardise()` now handles primitive functions like `~` properly (#473). * `call_print_type()` indicates how a call is deparsed and printed at the console by R: prefix, infix, and special form. * The `call_` functions such as `call_modify()` now correctly check that their input is the right type (#187). ## Other improvements and fixes * New function `zap()` returns a sentinel that instructs functions like `env_bind()` or `call_modify()` that objects are to be removed. * New function `rep_named()` repeats value along a character vector of names. * New function `exec()` is a simpler replacement to `invoke()` (#536). `invoke()` has been soft-deprecated. * Lambda functions created from formulas with `as_function()` are now classed. Use `is_lambda()` to check a function was created with the formula shorthand. * `is_integerish()` now supports large double values (#578). * `are_na()` now requires atomic vectors (#558). * The operator `%@%` has now a replacement version to update attributes of an object (#207). * `fn_body()` always returns a `{` block, even if the function has a single expression. For instance `fn_body(function(x) do()) ` returns `quote({ do() })`. * `is_string()` now returns `FALSE` for `NA_character_`. * The vector predicates have been rewritten in C for performance. * The `finite` argument of `is_integerish()` is now `NULL` by default. Missing values are now considered as non-finite for consistency with `base::is.finite()`. * `is_bare_integerish()` and `is_scalar_integerish()` gain a `finite` argument for consistency with `is_integerish()`. * `flatten_if()` and `squash_if()` now handle primitive functions like `base::is.list()` as predicates. * `is_symbol()` now accepts a character vector of names to mach the symbol against. * `parse_exprs()` and `parse_quos()` now support character vectors. Note that the output may be longer than the input as each string may yield multiple expressions (such as `"foo; bar"`). * `parse_quos()` now adds the `quosures` class to its output. ## Lifecycle ### Soft-deprecated functions and arguments rlang 0.3.0 introduces a new warning mechanism for soft-deprecated functions and arguments. A warning is issued, but only under one of these circumstances: * rlang has been attached with a `library()` call. * The deprecated function has been called from the global environment. In addition, deprecation warnings appear only once per session in order to not be disruptive. Deprecation warnings shouldn't make R CMD check fail for packages using testthat. However, `expect_silent()` can transform the warning to a hard failure. #### tidyeval * `.data[[foo]]` is now an unquote operator. This guarantees that `foo` is evaluated in the context rather than the data mask and makes it easier to treat `.data[["bar"]]` the same way as a symbol. For instance, this will help ensuring that `group_by(df, .data[["name"]])` and `group_by(df, name)` produce the same column name. * Automatic naming of expressions now uses a new deparser (still unexported) instead of `quo_text()`. Following this change, automatic naming is now compatible with all object types (via `pillar::type_sum()` if available), prevents multi-line names, and ensures `name` and `.data[["name"]]` are given the same default name. * Supplying a name with `!!!` calls is soft-deprecated. This name is ignored because only the names of the spliced vector are applied. * Quosure lists returned by `quos()` and `enquos()` now have "list-of" behaviour: the types of new elements are checked when adding objects to the list. Consequently, assigning non-quosure objects to quosure lists is now soft-deprecated. Please coerce to a bare list with `as.list()` beforehand. * `as_quosure()` now requires an explicit environment for symbols and calls. This should typically be the environment in which the expression was created. * `names()` and `length()` methods for data pronouns are deprecated. It is no longer valid to write `names(.data)` or `length(.data)`. * Using `as.character()` on quosures is soft-deprecated (#523). #### Miscellaneous * Using `get_env()` without supplying an environment is now soft-deprecated. Please use `current_env()` to retrieve the current environment. * The frame and stack API is soft-deprecated. Some of the functionality has been replaced by `trace_back()`. * The `new_vector_along()` family is soft-deprecated because these functions are longer to type than the equivalent `rep_along()` or `rep_named()` calls without added clarity. * Passing environment wrappers like formulas or functions to `env_` functions is now soft-deprecated. This internal genericity was causing confusion (see issue #427). You should now extract the environment separately before calling these functions. This change concerns `env_depth()`, `env_poke_parent()`, `env_parent<-`, `env_tail()`, `set_env()`, `env_clone()`, `env_inherits()`, `env_bind()`, `scoped_bindings()`, `with_bindings()`, `env_poke()`, `env_has()`, `env_get()`, `env_names()`, `env_bind_exprs()` and `env_bind_fns()`. * `cnd_signal()` now always installs a muffling restart for non-critical conditions. Consequently the `.mufflable` argument has been soft-deprecated and no longer has any effect. ### Deprecated functions and arguments Deprecated functions and arguments issue a warning inconditionally, but only once per session. * Calling `UQ()` and `UQS()` with the rlang namespace qualifier is deprecated as of rlang 0.3.0. Just use the unqualified forms instead: ``` # Bad rlang::expr(mean(rlang::UQ(var) * 100)) # Ok rlang::expr(mean(UQ(var) * 100)) # Good rlang::expr(mean(!!var * 100)) ``` Although soft-deprecated since rlang 0.2.0, `UQ()` and `UQS()` can still be used for now. * The `call` argument of `abort()` and condition constructors is now deprecated in favour of storing full backtraces. * The `.standardise` argument of `call_modify()` is deprecated. Please use `call_standardise()` beforehand. * The `sentinel` argument of `env_tail()` has been deprecated and renamed to `last`. ### Defunct functions and arguments Defunct functions and arguments throw an error when used. * `as_dictionary()` is now defunct. * The experimental function `rst_muffle()` is now defunct. Please use `cnd_muffle()` instead. Unlike its predecessor, `cnd_muffle()` is not generic. It is marked as a calling handler and thus can be passed directly to `with_handlers()` to muffle specific conditions (such as specific subclasses of warnings). * `cnd_inform()`, `cnd_warn()` and `cnd_abort()` are retired and defunct. The old `cnd_message()`, `cnd_warning()`, `cnd_error()` and `new_cnd()` constructors deprecated in rlang 0.2.0 are now defunct. * Modifying a condition with `cnd_signal()` is defunct. In addition, creating a condition with `cnd_signal()` is soft-deprecated, please use the new function [signal()] instead. * `inplace()` has been renamed to `calling()` to follow base R terminology more closely. ### Functions and arguments in the questioning stage We are no longer convinced these functions are the right approach but we do not have a precise alternative yet. * The functions from the restart API are now in the questioning lifecycle stage. It is not clear yet whether we want to recommend restarts as a style of programming in R. * `prepend()` and `modify()` are in the questioning stage, as well as `as_logical()`, `as_character()`, etc. We are still figuring out what vector tools belong in rlang. * `flatten()`, `squash()` and their atomic variants are now in the questioning lifecycle stage. They have slightly different semantics than the flattening functions in purrr and we are currently rethinking our approach to flattening with the new typing facilities of the vctrs package. # rlang 0.2.2 This is a maintenance release that fixes several garbage collection protection issues. # rlang 0.2.1 This is a maintenance release that fixes several tidy evaluation issues. * Functions with tidy dots support now allow splicing atomic vectors. * Quosures no longer capture the current `srcref`. * Formulas are now evaluated in the correct environment by `eval_tidy()`. This fixes issues in dplyr and other tidy-evaluation interfaces. # rlang 0.2.0 This release of rlang is mostly an effort at polishing the tidy evaluation framework. All tidy eval functions and operators have been rewritten in C in order to improve performance. Capture of expression, quasiquotation, and evaluation of quosures are now vastly faster. On the UI side, many of the inconveniences that affected the first release of rlang have been solved: * The `!!` operator now has the precedence of unary `+` and `-` which allows a much more natural syntax: `!!a > b` only unquotes `a` rather than the whole `a > b` expression. * `enquo()` works in magrittr pipes: `mtcars %>% select(!!enquo(var))`. * `enquos()` is a variant of `quos()` that has a more natural interface for capturing multiple arguments and `...`. See the first section below for a complete list of changes to the tidy evaluation framework. This release also polishes the rlang API. Many functions have been renamed as we get a better feel for the consistency and clarity of the API. Note that rlang as a whole is still maturing and some functions are even experimental. In order to make things clearer for users of rlang, we have started to develop a set of conventions to document the current stability of each function. You will now find "lifecycle" sections in documentation topics. In addition we have gathered all lifecycle information in the `?rlang::lifecycle` help page. Please only use functions marked as stable in your projects unless you are prepared to deal with occasional backward incompatible updates. ## Tidy evaluation * The backend for `quos()`, `exprs()`, `list2()`, `dots_list()`, etc is now written in C. This greatly improve the performance of dots capture, especially with the splicing operator `!!!` which now scales much better (you'll see a 1000x performance gain in some cases). The unquoting algorithm has also been improved which makes `enexpr()` and `enquo()` more efficient as well. * The tidy eval `!!` operator now binds tightly. You no longer have to wrap it in parentheses, i.e. `!!x > y` will only unquote `x`. Technically the `!!` operator has the same precedence as unary `-` and `+`. This means that `!!a:b` and `!!a + b` are equivalent to `(!!a):b` and `(!!a) + b`. On the other hand `!!a^b` and `!!a$b` are equivalent to`!!(a^b)` and `!!(a$b)`. * The print method for quosures has been greatly improved. Quosures no longer appear as formulas but as expressions prefixed with `^`; quosures are colourised according to their environment; unquoted objects are displayed between angular brackets instead of code (i.e. an unquoted integer vector is shown as `` rather than `1:2`); unquoted S3 objects are displayed using `pillar::type_sum()` if available. * New `enquos()` function to capture arguments. It treats `...` the same way as `quos()` but can also capture named arguments just like `enquo()`, i.e. one level up. By comparison `quos(arg)` only captures the name `arg` rather than the expression supplied to the `arg` argument. In addition, `enexprs()` is like `enquos()` but like `exprs()` it returns bare expressions. And `ensyms()` expects strings or symbols. * It is now possible to use `enquo()` within a magrittr pipe: ``` select_one <- function(df, var) { df %>% dplyr::select(!!enquo(var)) } ``` Technically, this is because `enquo()` now also captures arguments in parents of the current environment rather than just in the current environment. The flip side of this increased flexibility is that if you made a typo in the name of the variable you want to capture, and if an object of that name exists anywhere in the parent contexts, you will capture that object rather than getting an error. * `quo_expr()` has been renamed to `quo_squash()` in order to better reflect that it is a lossy operation that flattens all nested quosures. * `!!!` now accepts any kind of objects for consistency. Scalar types are treated as vectors of length 1. Previously only symbolic objects like symbols and calls were treated as such. * `ensym()` is a new variant of `enexpr()` that expects a symbol or a string and always returns a symbol. If a complex expression is supplied it fails with an error. * `exprs()` and `quos()` gain a `.unquote_names` arguments to switch off interpretation of `:=` as a name operator. This should be useful for programming on the language targetting APIs such as data.table. * `exprs()` gains a `.named` option to auto-label its arguments (#267). * Functions taking dots by value rather than by expression (e.g. regular functions, not quoting functions) have a more restricted set of unquoting operations. They only support `:=` and `!!!`, and only at top-level. I.e. `dots_list(!!! x)` is valid but not `dots_list(nested_call(!!! x))` (#217). * Functions taking dots with `list2()` or `dots_list()` now support splicing of `NULL` values. `!!! NULL` is equivalent to `!!! list()` (#242). * Capture operators now support evaluated arguments. Capturing a forced or evaluated argument is exactly the same as unquoting that argument: the actual object (even if a vector) is inlined in the expression. Capturing a forced argument occurs when you use `enquo()`, `enexpr()`, etc too late. It also happens when your quoting function is supplied to `lapply()` or when you try to quote the first argument of an S3 method (which is necessarily evaluated in order to detect which class to dispatch to). (#295, #300). * Parentheses around `!!` are automatically removed. This makes the generated expression call cleaner: `(!! sym("name"))(arg)`. Note that removing the parentheses will never affect the actual precedence within the expression as the parentheses are only useful when parsing code as text. The parentheses will also be added by R when printing code if needed (#296). * Quasiquotation now supports `!!` and `!!!` as functional forms: ``` expr(`!!`(var)) quo(call(`!!!`(var))) ``` This is consistent with the way native R operators parses to function calls. These new functional forms are to be preferred to `UQ()` and `UQS()`. We are now questioning the latter and might deprecate them in a future release. * The quasiquotation parser now gives meaningful errors in corner cases to help you figure out what is wrong. * New getters and setters for quosures: `quo_get_expr()`, `quo_get_env()`, `quo_set_expr()`, and `quo_set_env()`. Compared to `get_expr()` etc, these accessors only work on quosures and are slightly more efficient. * `quo_is_symbol()` and `quo_is_call()` now take the same set of arguments as `is_symbol()` and `is_call()`. * `enquo()` and `enexpr()` now deal with default values correctly (#201). * Splicing a list no longer mutates it (#280). ## Conditions * The new functions `cnd_warn()` and `cnd_inform()` transform conditions to warnings or messages before signalling them. * `cnd_signal()` now returns invisibly. * `cnd_signal()` and `cnd_abort()` now accept character vectors to create typed conditions with several S3 subclasses. * `is_condition()` is now properly exported. * Condition signallers such as `cnd_signal()` and `abort()` now accept a call depth as `call` arguments. This allows plucking a call from further up the call stack (#30). * New helper `catch_cnd()`. This is a small wrapper around `tryCatch()` that captures and returns any signalled condition. It returns `NULL` if none was signalled. * `cnd_abort()` now adds the correct S3 classes for error conditions. This fixes error catching, for instance by `testthat::expect_error()`. ## Environments * `env_get_list()` retrieves muliple bindings from an environment into a named list. * `with_bindings()` and `scoped_bindings()` establish temporary bindings in an environment. * `is_namespace()` is a snake case wrapper around `isNamespace()`. ## Various features * New functions `inherits_any()`, `inherits_all()`, and `inherits_only()`. They allow testing for inheritance from multiple classes. The `_any` variant is equivalent to `base::inherits()` but is more explicit about its behaviour. `inherits_all()` checks that all classes are present in order and `inherits_only()` checks that the class vectors are identical. * New `fn_fmls<-` and `fn_fmls_names<-` setters. * New function experimental function `chr_unserialise_unicode()` for turning characters serialised to unicode point form (e.g. ``) to UTF-8. In addition, `as_utf8_character()` now translates those as well. (@krlmlr) * `expr_label()` now supports quoted function definition calls (#275). * `call_modify()` and `call_standardise()` gain an argument to specify an environment. The call definition is looked up in that environment when the call to modify or standardise is not wrapped in a quosure. * `is_symbol()` gains a `name` argument to check that that the symbol name matches a string (#287). * New `rlang_box` class. Its purpose is similar to the `AsIs` class from `base::I()`, i.e. it protects a value temporarily. However it does so by wrapping the value in a scalar list. Use `new_box()` to create a boxed value, `is_box()` to test for a boxed value, and `unbox()` to unbox it. `new_box()` and `is_box()` accept optional subclass. * The vector constructors such as `new_integer()`, `new_double_along()` etc gain a `names` argument. In the case of the `_along` family it defaults to the names of the input vector. ## Bugfixes * When nested quosures are evaluated with `eval_tidy()`, the `.env` pronoun now correctly refers to the current quosure under evaluation (#174). Previously it would always refer to the environment of the outermost quosure. * `as_pairlist()` (part of the experimental API) now supports `NULL` and objects of type pairlist (#397). * Fixed a performance bug in `set_names()` that caused a full copy of the vector names (@jimhester, #366). ## API changes The rlang API is maturing and still in flux. However we have made an effort to better communicate what parts are stable. We will not introduce breaking changes for stable functions unless the payoff for the change is worth the trouble. See `?rlang::lifecycle` for the lifecycle status of exported functions. * The particle "lang" has been renamed to "call": - `lang()` has been renamed to `call2()`. - `new_language()` has ben renamed to `new_call()`. - `is_lang()` has been renamed to `is_call()`. We haven't replaced the `is_unary_lang()` and `is_binary_lang()` because they are redundant with the `n` argument of `is_call()`. - All call accessors such as `lang_fn()`, `lang_name()`, `lang_args()` etc are soft-deprecated and renamed with `call_` prefix. In rlang 0.1 calls were called "language" objects in order to follow the R type nomenclature as returned by `base::typeof()`. We wanted to avoid adding to the confusion between S modes and R types. With hindsight we find it is better to use more meaningful type names. * We now use the term "data mask" instead of "overscope". We think data mask is a more natural name in the context of R. We say that that objects from user data mask objects in the current environment. This makes reference to object masking in the search path which is due to the same mechanism (in technical terms, lexical scoping with hierarchically nested environments). Following this new terminology, the new functions `as_data_mask()` and `new_data_mask()` replace `as_overscope()` and `new_overscope()`. `as_data_mask()` has also a more consistent interface. These functions are only meant for developers of tidy evaluation interfaces. * We no longer require a data mask (previously called overscope) to be cleaned up after evaluation. `overscope_clean()` is thus soft-deprecated without replacement. ### Breaking changes * `!!` now binds tightly in order to match intuitive parsing of tidy eval code, e.g. `!! x > y` is now equivalent to `(!! x) > y`. A corollary of this new syntax is that you now have to be explicit when you want to unquote the whole expression on the right of `!!`. For instance you have to explicitly write `!! (x > y)` to unquote `x > y` rather than just `x`. * `UQ()`, `UQS()` and `:=` now issue an error when called directly. The previous definitions caused surprising results when the operators were invoked in wrong places (i.e. not in quasiquoted arguments). * The prefix form `` `!!`() `` is now an alias to `!!` rather than `UQE()`. This makes it more in line with regular R syntax where operators are parsed as regular calls, e.g. `a + b` is parsed as `` `+`(a, b) `` and both forms are completely equivalent. Also the prefix form `` `!!!`() `` is now equivalent to `!!!`. * `UQE()` is now deprecated in order to simplify the syntax of quasiquotation. Please use `!! get_expr(x)` instead. * `expr_interp()` now returns a formula instead of a quosure when supplied a formula. * `is_quosureish()` and `as_quosureish()` are deprecated. These functions assumed that quosures are formulas but that is only an implementation detail. * `new_cnd()` is now `cnd()` for consistency with other constructors. Also, `cnd_error()`, `cnd_warning()` and `cnd_message()` are now `error_cnd()`, `warning_cnd()` and `message_cnd()` to follow our naming scheme according to which the type of output is a suffix rather than a prefix. * `is_node()` now returns `TRUE` for calls as well and `is_pairlist()` does not return `TRUE` for `NULL` objects. Use `is_node_list()` to determine whether an object either of type `pairlist` or `NULL`. Note that all these functions are still experimental. * `set_names()` no longer automatically splices lists of character vectors as we are moving away from automatic splicing semantics. ### Upcoming breaking changes * Calling the functional forms of unquote operators with the rlang namespace qualifier is soft-deprecated. `UQ()` and `UQS()` are not function calls so it does not make sense to namespace them. Supporting namespace qualifiers complicates the implementation of unquotation and is misleading as to the nature of unquoting (which are syntactic operators at quotation-time rather than function calls at evaluation-time). * We are now questioning `UQ()` and `UQS()` as functional forms of `!!`. If `!!` and `!!!` were native R operators, they would parse to the functional calls `` `!!`() `` and `` `!!!`() ``. This is now the preferred way to unquote with a function call rather than with the operators. We haven't decided yet whether we will deprecate `UQ()` and `UQS()` in the future. In any case we recommend using the new functional forms. * `parse_quosure()` and `parse_quosures()` are soft-deprecated in favour of `parse_quo()` and `parse_quos()`. These new names are consistent with the rule that abbreviated suffixes indicate the return type of a function. In addition the new functions require their callers to explicitly supply an environment for the quosures. * Using `f_rhs()` and `f_env()` on quosures is soft-deprecated. The fact that quosures are formulas is an implementation detail that might change in the future. Please use `quo_get_expr()` and `quo_get_env()` instead. * `quo_expr()` is soft-deprecated in favour of `quo_squash()`. `quo_expr()` was a misnomer because it implied that it was a mere expression acccessor for quosures whereas it was really a lossy operation that squashed all nested quosures. * With the renaming of the `lang` particle to `call`, all these functions are soft-deprecated: `lang()`, `is_lang()`, `lang_fn()`, `lang_name()`, `lang_args()`. In addition, `lang_head()` and `lang_tail()` are soft-deprecated without replacement because these are low level accessors that are rarely needed. * `as_overscope()` is soft-deprecated in favour of `as_data_mask()`. * The node setters were renamed from `mut_node_` prefix to `node_poke_`. This change follows a new naming convention in rlang where mutation is referred to as "poking". * `splice()` is now in questioning stage as it is not needed given the `!!!` operator works in functions taking dots with `dots_list()`. * `lgl_len()`, `int_len()` etc have been soft-deprecated and renamed with `new_` prefix, e.g. `new_logical()` and `new_integer()`. This is for consistency with other non-variadic object constructors. * `ll()` is now an alias to `list2()`. This is consistent with the new `call2()` constructor for calls. `list2()` and `call2()` are versions of `list()` and `call()` that support splicing of lists with `!!!`. `ll()` remains around as a shorthand for users who like its conciseness. * Automatic splicing of lists in vector constructors (e.g. `lgl()`, `chr()`, etc) is now soft-deprecated. Please be explicit with the splicing operator `!!!`. # rlang 0.1.6 * This is a maintenance release in anticipation of a forthcoming change to R's C API (use `MARK_NOT_MUTABLE()` instead of `SET_NAMED()`). * New function `is_reference()` to check whether two objects are one and the same. # rlang 0.1.4 * `eval_tidy()` no longer maps over lists but returns them literally. This behaviour is an overlook from past refactorings and was never documented. # rlang 0.1.2 This hotfix release makes rlang compatible with the R 3.1 branch. # rlang 0.1.1 This release includes two important fixes for tidy evaluation: * Bare formulas are now evaluated in the correct environment in tidyeval functions. * `enquo()` now works properly within compiled functions. Before this release, constants optimised by the bytecode compiler couldn't be enquoted. ## New functions: * The `new_environment()` constructor creates a child of the empty environment and takes an optional named list of data to populate it. Compared to `env()` and `child_env()`, it is meant to create environments as data structures rather than as part of a scope hierarchy. * The `new_call()` constructor creates calls out of a callable object (a function or an expression) and a pairlist of arguments. It is useful to avoid costly internal coercions between lists and pairlists of arguments. ## UI improvements: * `env_child()`'s first argument is now `.parent` instead of `parent`. * `mut_` setters like `mut_attrs()` and environment helpers like `env_bind()` and `env_unbind()` now return their (modified) input invisibly. This follows the tidyverse convention that functions called primarily for their side effects should return their input invisibly. * `is_pairlist()` now returns `TRUE` for `NULL`. We added `is_node()` to test for actual pairlist nodes. In other words, `is_pairlist()` tests for the data structure while `is_node()` tests for the type. ## Bugfixes: * `env()` and `env_child()` can now get arguments whose names start with `.`. Prior to this fix, these arguments were partial-matching on `env_bind()`'s `.env` argument. * The internal `replace_na()` symbol was renamed to avoid a collision with an exported function in tidyverse. This solves an issue occurring in old versions of R prior to 3.3.2 (#133). # rlang 0.1.0 Initial release. rlang/inst/0000755000176200001440000000000014401375263012337 5ustar liggesusersrlang/inst/backtrace-ver0000644000176200001440000000000614175213516014767 0ustar liggesusers1.0.1 rlang/README.md0000644000176200001440000000645114657222325012652 0ustar liggesusersrlang ======================================================= [![Codecov test coverage](https://codecov.io/gh/r-lib/rlang/branch/main/graph/badge.svg)](https://app.codecov.io/gh/r-lib/rlang?branch=main) [![Lifecycle Status](https://img.shields.io/badge/lifecycle-stable-green.svg)](https://lifecycle.r-lib.org/articles/stages.html) [![R-CMD-check](https://github.com/r-lib/rlang/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/r-lib/rlang/actions/workflows/R-CMD-check.yaml) rlang is a collection of frameworks and APIs for programming with R. ## Frameworks Two comprehensive frameworks are implemented in rlang. * __tidy eval__, a programmable [data-masking](https://rlang.r-lib.org/reference/topic-data-mask.html) framework used in tidyverse packages like dplyr and ggplot2. As a user, you will encounter the embracing operator [`{{`](https://rlang.r-lib.org/reference/embrace-operator.html) and name injection with the [glue](https://glue.tidyverse.org/) operators [`"{"`](https://rlang.r-lib.org/reference/glue-operators.html) and [`"{{"`](https://rlang.r-lib.org/reference/glue-operators.html). * __rlang errors__, a set of tools to signal and display errors. This includes backtrace capture with `global_entrace()` and backtrace display with `last_error()` and `last_warnings()`. Use `abort()` to create errors with bullet lists, structured metadata, and error chaining support. The display of error messages is optimised for bullet lists and chained errors and optionally integrates with the cli package (see `local_use_cli()`). ## Argument intake A set of tools help you check, validate, and preprocess arguments. * Checking function arguments, e.g. `arg_match()`, `check_required()`, and `check_exclusive()`. * Checking dots, e.g. `check_dots_used()` and `check_dots_empty()`. * Collecting [dynamic dots](https://rlang.r-lib.org/reference/dyn-dots.html), e.g. `list2()`. These dots support splicing with [`!!!`](https://rlang.r-lib.org/reference/splice-operator.html) and name injection with the [glue](https://glue.tidyverse.org/) operators [`"{"`](https://rlang.r-lib.org/reference/glue-operators.html) and [`"{{"`](https://rlang.r-lib.org/reference/glue-operators.html). ## Programming interfaces rlang provides various interfaces for working with R and R objects. * The R session, e.g. `check_installed()`, `on_load()`, and `on_package_load()`. * Environments, e.g. `env()`, `env_has()`, `env_get()`, `env_bind()`, `env_unbind()`, `env_print()`, and `local_bindings()`. * Evaluation, e.g. `inject()` and `eval_bare()`. * Calls and symbols, e.g. `call2()`, `is_call()`, `is_call_simple()`, `data_sym()`, and `data_syms()`. * Functions, e.g. `new_function()` and `as_function()`. The latter supports the purrr-style formula notation for lambda functions. ## Installation Install the released version of rlang from CRAN: ```r install.packages("rlang") ``` Or install the development version from GitHub with: ```r # install.packages("pak") pak::pkg_install("r-lib/rlang") ``` ## Code of Conduct Please note that the rlang project is released with a [Contributor Code of Conduct](https://rlang.r-lib.org/CODE_OF_CONDUCT.html). By contributing to this project, you agree to abide by its terms. rlang/man/0000755000176200001440000000000014742414044012134 5ustar liggesusersrlang/man/check_required.Rd0000644000176200001440000000164314375670676015425 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/arg.R \name{check_required} \alias{check_required} \title{Check that argument is supplied} \usage{ check_required(x, arg = caller_arg(x), call = caller_env()) } \arguments{ \item{x}{A function argument. Must be a symbol.} \item{arg}{An argument name as a string. This argument will be mentioned in error messages as the input that is at the origin of a problem.} \item{call}{The execution environment of a currently running function, e.g. \code{caller_env()}. The function will be mentioned in error messages as the source of the error. See the \code{call} argument of \code{\link[=abort]{abort()}} for more information.} } \description{ Throws an error if \code{x} is missing. } \examples{ f <- function(x) { check_required(x) } # Fails because `x` is not supplied try(f()) # Succeeds f(NULL) } \seealso{ \code{\link[=arg_match]{arg_match()}} } rlang/man/on_load.Rd0000644000176200001440000000662514603762153014052 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/aaa.R \name{on_load} \alias{on_load} \alias{run_on_load} \alias{on_package_load} \title{Run expressions on load} \usage{ on_load(expr, env = parent.frame(), ns = topenv(env)) run_on_load(ns = topenv(parent.frame())) on_package_load(pkg, expr, env = parent.frame()) } \arguments{ \item{expr}{An expression to run on load.} \item{env}{The environment in which to evaluate \code{expr}. Defaults to the current environment, which is your package namespace if you run \code{on_load()} at top level.} \item{ns}{The namespace in which to hook \code{expr}.} \item{pkg}{Package to hook expression into.} } \description{ \itemize{ \item \code{on_load()} registers expressions to be run on the user's machine each time the package is loaded in memory. This is by contrast to normal R package code which is run once at build time on the packager's machine (e.g. CRAN). \code{on_load()} expressions require \code{run_on_load()} to be called inside \code{\link[=.onLoad]{.onLoad()}}. \item \code{on_package_load()} registers expressions to be run each time another package is loaded. } \code{on_load()} is for your own package and runs expressions when the namespace is not \emph{sealed} yet. This means you can modify existing binding or create new ones. This is not the case with \code{on_package_load()} which runs expressions after a foreign package has finished loading, at which point its namespace is sealed. } \section{When should I run expressions on load?}{ There are two main use cases for running expressions on load: \enumerate{ \item When a side effect, such as registering a method with \code{s3_register()}, must occur in the user session rather than the package builder session. \item To avoid hard-coding objects from other packages in your namespace. If you assign \code{foo::bar} or the result of \code{foo::baz()} in your package, they become constants. Any upstream changes in the \code{foo} package will not be reflected in the objects you've assigned in your namespace. This often breaks assumptions made by the authors of \code{foo} and causes all sorts of issues. Recreating the foreign objects each time your package is loaded makes sure that any such changes will be taken into account. In technical terms, running an expression on load introduces \emph{indirection}. } } \section{Comparison with \code{.onLoad()}}{ \code{on_load()} has the advantage that hooked expressions can appear in any file, in context. This is unlike \code{.onLoad()} which gathers disparate expressions in a single block. \code{on_load()} is implemented via \code{.onLoad()} and requires \code{run_on_load()} to be called from that hook. The expressions inside \code{on_load()} do not undergo static analysis by \verb{R CMD check}. Therefore, it is advisable to only use simple function calls inside \code{on_load()}. } \examples{ quote({ # Not run # First add `run_on_load()` to your `.onLoad()` hook, # then use `on_load()` anywhere in your package .onLoad <- function(lib, pkg) { run_on_load() } # Register a method on load on_load({ s3_register("foo::bar", "my_class") }) # Assign an object on load var <- NULL on_load({ var <- foo() }) # To use `on_package_load()` at top level, wrap it in `on_load()` on_load({ on_package_load("foo", message("foo is loaded")) }) # In functions it can be called directly f <- function() on_package_load("foo", message("foo is loaded")) }) } rlang/man/is_weakref.Rd0000644000176200001440000000042014127057575014547 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/weakref.R \name{is_weakref} \alias{is_weakref} \title{Is object a weak reference?} \usage{ is_weakref(x) } \arguments{ \item{x}{An object to test.} } \description{ Is object a weak reference? } rlang/man/chr_unserialise_unicode.Rd0000644000176200001440000000301214175213516017305 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/utils-encoding.R \name{chr_unserialise_unicode} \alias{chr_unserialise_unicode} \title{Translate unicode points to UTF-8} \usage{ chr_unserialise_unicode(chr) } \arguments{ \item{chr}{A character vector.} } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} For historical reasons, R translates strings to the native encoding when they are converted to symbols. This string-to-symbol conversion is not a rare occurrence and happens for instance to the names of a list of arguments converted to a call by \code{do.call()}. If the string contains unicode characters that cannot be represented in the native encoding, R serialises those as an ASCII sequence representing the unicode point. This is why Windows users with western locales often see strings looking like \verb{}. To alleviate some of the pain, rlang parses strings and looks for serialised unicode points to translate them back to the proper UTF-8 representation. This transformation occurs automatically in functions like \code{\link[=env_names]{env_names()}} and can be manually triggered with \code{as_utf8_character()} and \code{chr_unserialise_unicode()}. } \section{Life cycle}{ This function is experimental. } \examples{ ascii <- "" chr_unserialise_unicode(ascii) identical(chr_unserialise_unicode(ascii), "\u5e78") } \keyword{internal} rlang/man/empty_env.Rd0000644000176200001440000000073214127057575014444 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/env-special.R \name{empty_env} \alias{empty_env} \title{Get the empty environment} \usage{ empty_env() } \description{ The empty environment is the only one that does not have a parent. It is always used as the tail of an environment chain such as the search path (see \code{\link[=search_envs]{search_envs()}}). } \examples{ # Create environments with nothing in scope: child_env(empty_env()) } rlang/man/is_interactive.Rd0000644000176200001440000000262514127057575015451 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/state.R \name{is_interactive} \alias{is_interactive} \alias{local_interactive} \alias{with_interactive} \title{Is R running interactively?} \usage{ is_interactive() local_interactive(value = TRUE, frame = caller_env()) with_interactive(expr, value = TRUE) } \arguments{ \item{value}{A single \code{TRUE} or \code{FALSE}. This overrides the return value of \code{is_interactive()}.} \item{frame}{The environment of a running function which defines the scope of the temporary options. When the function returns, the options are reset to their original values.} \item{expr}{An expression to evaluate with interactivity set to \code{value}.} } \description{ Like \code{\link[base:interactive]{base::interactive()}}, \code{is_interactive()} returns \code{TRUE} when the function runs interactively and \code{FALSE} when it runs in batch mode. It also checks, in this order: \itemize{ \item The \code{rlang_interactive} global option. If set to a single \code{TRUE} or \code{FALSE}, \code{is_interactive()} returns that value immediately. This escape hatch is useful in unit tests or to manually turn on interactive features in RMarkdown outputs. \item Whether knitr or testthat is in progress, in which case \code{is_interactive()} returns \code{FALSE}. } \code{with_interactive()} and \code{local_interactive()} set the global option conveniently. } rlang/man/format_error_bullets.Rd0000644000176200001440000000451414175213516016663 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cnd-message.R \name{format_error_bullets} \alias{format_error_bullets} \title{Format bullets for error messages} \usage{ format_error_bullets(x) } \arguments{ \item{x}{A named character vector of messages. Named elements are prefixed with the corresponding bullet. Elements named with a single space \code{" "} trigger a line break from the previous bullet.} } \description{ \code{format_error_bullets()} takes a character vector and returns a single string (or an empty vector if the input is empty). The elements of the input vector are assembled as a list of bullets, depending on their names: \itemize{ \item Unnamed elements are unindented. They act as titles or subtitles. \item Elements named \code{"*"} are bulleted with a cyan "bullet" symbol. \item Elements named \code{"i"} are bulleted with a blue "info" symbol. \item Elements named \code{"x"} are bulleted with a red "cross" symbol. \item Elements named \code{"v"} are bulleted with a green "tick" symbol. \item Elements named \code{"!"} are bulleted with a yellow "warning" symbol. \item Elements named \code{">"} are bulleted with an "arrow" symbol. \item Elements named \code{" "} start with an indented line break. } For convenience, if the vector is fully unnamed, the elements are formatted as "*" bullets. The bullet formatting for errors follows the idea that sentences in error messages are best kept short and simple. The best way to present the information is in the \code{\link[=cnd_body]{cnd_body()}} method of an error conditon as a bullet list of simple sentences containing a single clause. The info and cross symbols of the bullets provide hints on how to interpret the bullet relative to the general error issue, which should be supplied as \code{\link[=cnd_header]{cnd_header()}}. } \examples{ # All bullets writeLines(format_error_bullets(c("foo", "bar"))) # This is equivalent to writeLines(format_error_bullets(set_names(c("foo", "bar"), "*"))) # Supply named elements to format info, cross, and tick bullets writeLines(format_error_bullets(c(i = "foo", x = "bar", v = "baz", "*" = "quux"))) # An unnamed element breaks the line writeLines(format_error_bullets(c(i = "foo\nbar"))) # A " " element breaks the line within a bullet (with indentation) writeLines(format_error_bullets(c(i = "foo", " " = "bar"))) } rlang/man/notes/0000755000176200001440000000000014375670676013305 5ustar liggesusersrlang/man/notes/handling-introspection.R0000644000176200001440000001764414375670676020126 0ustar liggesusers# This file surveys the possible backtraces created during condition # handling. We are interested in detecting the following frames: # # - Setup frame, e.g. `withCallingHandlers()` or `tryCatch()`. The # caller of this frame is useful as the default `call` when # rethrowing an error. # # - Signal frame, e.g. `stop()`, `warning()`, `signalCondition()`. Can # be a user frame as well when the condition is signalled from C, # e.g. with `Rf_error()`. # # - Handler frame. This is adjascent to the signal frame but may have # various intervening frames in between. Mostly this is about # detecting that we rethrowing from a handler. # # Knowing about these frames is useful for backtrace simplification # (the default display in `rlang::last_error()`) and for figuring out # a good default `call` field. # # # # Backtrace simplification # # We generally want to hide everything between the signal frame and # the handler frame. It's particularly important for the linear # display of backtraces where we subset the last branch of the # backtrace tree. If we didn't clean these frames, the user context # would disappear in favour of (or in the best case be drowned in) # condition handling frames. # # # # Default call inference # # When rethrowing a chained error, the relevant `call` field is the # caller of `withCallingHandlers()`. The backtrace between that setup # frame and the signal frame can be arbitrarily large and there is # currently no way of finding the setup frame with 100% reliability # (there might be several on the stack). f <- function() { throw() } handle <- function(...) { handler_helper() invokeRestart("abort") } handler_helper <- function() { print(rlang::trace_back()) } # Errors - Calling handlers foo <- function(...) { withCallingHandlers(f(), ...) } ### Text error # Setup: 2 # Signal: 5 # Handler: 7 throw <- function() stop("foo") foo(error = handle) #> ▆ #> 1. ├─global foo(error = handle) #> >2. │ ├─base::withCallingHandlers(f(), ...) #> 3. │ └─global f() #> 4. │ └─global throw() #> >5. │ └─base::stop("foo") #> 6. └─base::.handleSimpleError(``, "foo", base::quote(throw())) #> >7. └─global h(simpleError(msg, call)) #> 8. └─global handler_helper() ### Condition error # Setup: 2 # Signal: 5 # Handler: 6 throw <- function() stop(simpleError("foo")) foo(error = handle) #> ▆ #> 1. ├─global foo(error = handle) #> >2. │ ├─base::withCallingHandlers(f(), ...) #> 3. │ └─global f() #> 4. │ └─global throw() #> >5. │ └─base::stop(simpleError("foo")) #> >6. └─global ``(``) #> 7. └─global handler_helper() ### Condition error, simple signal # Setup: 2 # Signal: 5 # Handler: 6 throw <- function() signalCondition(simpleError("foo")) foo(error = handle) #> ▆ #> 1. ├─global foo(error = handle) #> >2. │ ├─base::withCallingHandlers(f(), ...) #> 3. │ └─global f() #> 4. │ └─global throw() #> >5. │ └─base::signalCondition(simpleError("foo")) #> >6. └─global ``(``) #> 7. └─global handler_helper() ### Condition error, demoted to warning # Setup: 2 # Signal: 5 # Handler: 9 throw <- function() warning(simpleError("foo")) foo(error = handle) #> ▆ #> 1. ├─global foo(error = handle) #> >2. │ ├─base::withCallingHandlers(f(), ...) #> 3. │ └─global f() #> 4. │ └─global throw() #> >5. │ └─base::warning(simpleError("foo")) #> 6. │ └─base::withRestarts(...) #> 7. │ └─base withOneRestart(expr, restarts[[1L]]) #> 8. │ └─base doWithOneRestart(return(expr), restart) #> >9. └─global ``(``) #> 10. └─global handler_helper() ### Condition error, demoted to message # Setup: 2 # Signal: 5 # Handler: 10 throw <- function() message(simpleError("foo")) foo(error = handle) #> ▆ #> 1. ├─global foo(error = handle) #> 2. │ ├─base::withCallingHandlers(f(), ...) #> 3. │ └─global f() #> 4. │ └─global throw() #> 5. │ └─base::message(simpleError("foo")) #> 6. │ ├─base::withRestarts(...) #> 7. │ │ └─base withOneRestart(expr, restarts[[1L]]) #> 8. │ │ └─base doWithOneRestart(return(expr), restart) #> 9. │ └─base::signalCondition(cond) #> 10. └─global ``(``) #> 11. └─global handler_helper() ### C-level error # In this case, the signal frame is a user function. # Setup: 2 # Signal: 5 # Handler: 7 throw <- function() rlang:::errorcall(NULL, "foo") foo(error = handle) #> ▆ #> 1. ├─global foo(error = handle) #> >2. │ ├─base::withCallingHandlers(f(), ...) #> 3. │ └─global f() #> 4. │ └─global throw() #> >5. │ └─rlang:::errorcall(NULL, "foo") #> 6. └─base::.handleSimpleError(``, "foo", base::quote(NULL)) #> >7. └─global h(simpleError(msg, call)) #> 8. └─global handler_helper() ### Text warning promoted to error # The stack is not linear between 5 and 11. Compare to the next # backtrace which is linear(ish). # Setup: 2 # Signal: 5 # Handler: 11 throw <- function() { rlang::local_options(warn = 2) warning("foo") } foo(error = handle) #> ▆ #> 1. ├─global foo(error = handle) #> >2. │ ├─base::withCallingHandlers(f(), ...) #> 3. │ └─global f() #> 4. │ └─global throw() #> >5. │ └─base::warning("foo") #> 6. ├─base::.signalSimpleWarning("foo", base::quote(throw())) #> 7. │ └─base::withRestarts(...) #> 8. │ └─base withOneRestart(expr, restarts[[1L]]) #> 9. │ └─base doWithOneRestart(return(expr), restart) #> 10. └─base::.handleSimpleError(...) #> >11. └─global h(simpleError(msg, call)) #> 12. └─global handler_helper() ### Condition warning promoted to error # Setup: 2 # Signal: 5 # Handler: 10 throw <- function() { rlang::local_options(warn = 2) warning(simpleWarning("foo")) } foo(error = handle) #> ▆ #> 1. ├─global foo(error = handle) #> >2. │ ├─base::withCallingHandlers(f(), ...) #> 3. │ └─global f() #> 4. │ └─global throw() #> >5. │ └─base::warning(simpleWarning("foo")) #> 6. │ └─base::withRestarts(...) #> 7. │ └─base withOneRestart(expr, restarts[[1L]]) #> 8. │ └─base doWithOneRestart(return(expr), restart) #> 9. └─base::.handleSimpleError(...) #> >10. └─global h(simpleError(msg, call)) #> 11. └─global handler_helper() ### rlang error # Setup: 2 # Signal: 5 # Handler: 10 throw <- function() rlang::abort("foo") foo(error = handle) #> ▆ #> 1. ├─global foo(error = handle) #> 2. │ ├─base::withCallingHandlers(f(), ...) #> 3. │ └─global f() #> 4. │ └─global throw() #> 5. │ └─rlang::abort("foo") #> 6. │ └─rlang::signal_abort(cnd, .file) at rlang/R/cnd-abort.R:281:2 #> 7. │ └─base::signalCondition(cnd) at rlang/R/cnd-abort.R:641:4 #> 8. └─global ``(``) #> 9. └─global handler_helper() # Errors - Exiting handlers # This is much easier, all the stacks look the same! bar <- function(...) { tryCatch(f(), ...) } # These all produce the same stack throw <- function() stop("foo") throw <- function() stop(simpleError("foo")) throw <- function() rlang:::errorcall(NULL, "foo") throw <- function() { rlang::local_options(warn = 2) warning("foo") } # Setup: 2 # Handler: 5 bar(error = handle) #> ▆ #> 1. └─global bar(error = handle) #> >2. └─base::tryCatch(f(), ...) #> 3. └─base tryCatchList(expr, classes, parentenv, handlers) #> 4. └─base tryCatchOne(expr, names, parentenv, handlers[[1L]]) #> >5. └─value[[3L]](cond) #> 6. └─global handler_helper() # The stack could be larger between 2 and 5 depending on the number of # condition handlers passed to `tryCatch()`. rlang/man/flatten.Rd0000644000176200001440000000556114376150033014065 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/lifecycle-deprecated.R \name{flatten} \alias{flatten} \alias{flatten_lgl} \alias{flatten_int} \alias{flatten_dbl} \alias{flatten_cpl} \alias{flatten_chr} \alias{flatten_raw} \alias{squash} \alias{squash_lgl} \alias{squash_int} \alias{squash_dbl} \alias{squash_cpl} \alias{squash_chr} \alias{squash_raw} \alias{flatten_if} \alias{squash_if} \title{Flatten or squash a list of lists into a simpler vector} \usage{ flatten(x) flatten_lgl(x) flatten_int(x) flatten_dbl(x) flatten_cpl(x) flatten_chr(x) flatten_raw(x) squash(x) squash_lgl(x) squash_int(x) squash_dbl(x) squash_cpl(x) squash_chr(x) squash_raw(x) flatten_if(x, predicate = is_spliced) squash_if(x, predicate = is_spliced) } \arguments{ \item{x}{A list to flatten or squash. The contents of the list can be anything for unsuffixed functions \code{flatten()} and \code{squash()} (as a list is returned), but the contents must match the type for the other functions.} \item{predicate}{A function of one argument returning whether it should be spliced.} } \value{ \code{flatten()} returns a list, \code{flatten_lgl()} a logical vector, \code{flatten_int()} an integer vector, \code{flatten_dbl()} a double vector, and \code{flatten_chr()} a character vector. Similarly for \code{squash()} and the typed variants (\code{squash_lgl()} etc). } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} These functions are deprecated in favour of \code{purrr::list_c()} and \code{purrr::list_flatten()}. \code{flatten()} removes one level hierarchy from a list, while \code{squash()} removes all levels. These functions are similar to \code{\link[=unlist]{unlist()}} but they are type-stable so you always know what the type of the output is. } \examples{ x <- replicate(2, sample(4), simplify = FALSE) x flatten(x) flatten_int(x) # With flatten(), only one level gets removed at a time: deep <- list(1, list(2, list(3))) flatten(deep) flatten(flatten(deep)) # But squash() removes all levels: squash(deep) squash_dbl(deep) # The typed flatten functions remove one level and coerce to an atomic # vector at the same time: flatten_dbl(list(1, list(2))) # Only bare lists are flattened, but you can splice S3 lists # explicitly: foo <- set_attrs(list("bar"), class = "foo") str(flatten(list(1, foo, list(100)))) str(flatten(list(1, splice(foo), list(100)))) # Instead of splicing manually, flatten_if() and squash_if() let # you specify a predicate function: is_foo <- function(x) inherits(x, "foo") || is_bare_list(x) str(flatten_if(list(1, foo, list(100)), is_foo)) # squash_if() does the same with deep lists: deep_foo <- list(1, list(foo, list(foo, 100))) str(deep_foo) str(squash(deep_foo)) str(squash_if(deep_foo, is_foo)) } \keyword{internal} rlang/man/args_data_masking.Rd0000644000176200001440000000752114741441060016063 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/doc-data-masking.R \name{args_data_masking} \alias{args_data_masking} \title{Argument type: data-masking} \description{ This page describes the \verb{} argument modifier which indicates that the argument uses tidy evaluation with \strong{data masking}. If you've never heard of tidy evaluation before, start with \code{vignette("programming", package = "dplyr")}. } \section{Key terms}{ The primary motivation for tidy evaluation in tidyverse packages is that it provides \strong{data masking}, which blurs the distinction between two types of variables: \itemize{ \item \strong{env-variables} are "programming" variables and live in an environment. They are usually created with \verb{<-}. Env-variables can be any type of R object. \item \strong{data-variables} are "statistical" variables and live in a data frame. They usually come from data files (e.g. \code{.csv}, \code{.xls}), or are created by manipulating existing variables. Data-variables live inside data frames, so must be vectors. } } \section{General usage}{ Data masking allows you to refer to variables in the "current" data frame (usually supplied in the \code{.data} argument), without any other prefix. It's what allows you to type (e.g.) \code{filter(diamonds, x == 0 & y == 0 & z == 0)} instead of \code{diamonds[diamonds$x == 0 & diamonds$y == 0 & diamonds$z == 0, ]}. } \section{Indirection}{ The main challenge of data masking arises when you introduce some indirection, i.e. instead of directly typing the name of a variable you want to supply it in a function argument or character vector. There are two main cases: \itemize{ \item If you want the user to supply the variable (or function of variables) in a function argument, embrace the argument, e.g. \code{filter(df, {{ var }})}. \if{html}{\out{
}}\preformatted{dist_summary <- function(df, var) \{ df \%>\% summarise(n = n(), min = min(\{\{ var \}\}), max = max(\{\{ var \}\})) \} mtcars \%>\% dist_summary(mpg) mtcars \%>\% group_by(cyl) \%>\% dist_summary(mpg) }\if{html}{\out{
}} \item If you have the column name as a character vector, use the \code{.data} pronoun, e.g. \code{summarise(df, mean = mean(.data[[var]]))}. \if{html}{\out{
}}\preformatted{for (var in names(mtcars)) \{ mtcars \%>\% count(.data[[var]]) \%>\% print() \} lapply(names(mtcars), function(var) mtcars \%>\% count(.data[[var]])) }\if{html}{\out{
}} (Note that the contents of \code{[[}, e.g. \code{var} above, is never evaluated in the data environment so you don't need to worry about a data-variable called \code{var} causing problems.) } } \section{Dot-dot-dot (...)}{ When this modifier is applied to \code{...}, there is one other useful technique which solves the problem of creating a new variable with a name supplied by the user. Use the interpolation syntax from the glue package: \code{"{var}" := expression}. (Note the use of \verb{:=} instead of \code{=} to enable this syntax). \if{html}{\out{
}}\preformatted{var_name <- "l100km" mtcars \%>\% mutate("\{var_name\}" := 235 / mpg) }\if{html}{\out{
}} Note that \code{...} automatically provides indirection, so you can use it as is (i.e. without embracing) inside a function: \if{html}{\out{
}}\preformatted{grouped_mean <- function(df, var, ...) \{ df \%>\% group_by(...) \%>\% summarise(mean = mean(\{\{ var \}\})) \} }\if{html}{\out{
}} } \seealso{ \itemize{ \item \ifelse{html}{\link[=topic-data-mask]{What is data-masking and why do I need \{\{?}}{\link[=topic-data-mask]{What is data-masking and why do I need curly-curly?}}. \item \ifelse{html}{\link[=topic-data-mask-programming]{Data mask programming patterns}}{\link[=topic-data-mask-programming]{Data mask programming patterns}}. } } \keyword{internal} rlang/man/inject.Rd0000644000176200001440000000311414375670676013717 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/eval.R \name{inject} \alias{inject} \title{Inject objects in an R expression} \usage{ inject(expr, env = caller_env()) } \arguments{ \item{expr}{An argument to evaluate. This argument is immediately evaluated in \code{env} (the current environment by default) with injected objects and expressions.} \item{env}{The environment in which to evaluate \code{expr}. Defaults to the current environment. For expert use only.} } \description{ \code{inject()} evaluates an expression with \link[=quasiquotation]{injection} support. There are three main usages: \itemize{ \item \link[=!!!]{Splicing} lists of arguments in a function call. \item Inline objects or other expressions in an expression with \verb{!!} and \verb{!!!}. For instance to create functions or formulas programmatically. \item Pass arguments to NSE functions that \link[=nse-defuse]{defuse} their arguments without injection support (see for instance \code{\link[=enquo0]{enquo0()}}). You can use \code{{{ arg }}} with functions documented to support quosures. Otherwise, use \code{!!enexpr(arg)}. } } \examples{ # inject() simply evaluates its argument with injection # support. These expressions are equivalent: 2 * 3 inject(2 * 3) inject(!!2 * !!3) # Injection with `!!` can be useful to insert objects or # expressions within other expressions, like formulas: lhs <- sym("foo") rhs <- sym("bar") inject(!!lhs ~ !!rhs + 10) # Injection with `!!!` splices lists of arguments in function # calls: args <- list(na.rm = TRUE, finite = 0.2) inject(mean(1:10, !!!args)) } rlang/man/invoke.Rd0000644000176200001440000000136614375670676013745 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/lifecycle-deprecated.R \name{invoke} \alias{invoke} \title{Invoke a function with a list of arguments} \usage{ invoke(.fn, .args = list(), ..., .env = caller_env(), .bury = c(".fn", "")) } \arguments{ \item{.fn, args, ..., .env, .bury}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}}} } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} Deprecated in rlang 0.4.0 in favour of \code{\link[=exec]{exec()}}. } \keyword{internal} rlang/man/global_handle.Rd0000644000176200001440000000173014375670676015220 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cnd-handlers.R \name{global_handle} \alias{global_handle} \title{Register default global handlers} \usage{ global_handle(entrace = TRUE, prompt_install = TRUE) } \arguments{ \item{entrace}{Passed as \code{enable} argument to \code{\link[=global_entrace]{global_entrace()}}.} \item{prompt_install}{Passed as \code{enable} argument to \code{\link[=global_prompt_install]{global_prompt_install()}}.} } \description{ \code{global_handle()} sets up a default configuration for error, warning, and message handling. It calls: \itemize{ \item \code{\link[=global_entrace]{global_entrace()}} to enable rlang errors and warnings globally. \item \code{\link[=global_prompt_install]{global_prompt_install()}} to recover from \code{packageNotFoundError}s with a user prompt to install the missing package. Note that at the time of writing (R 4.1), there are only very limited situations where this handler works. } } rlang/man/dyn-dots.Rd0000644000176200001440000000361214375670676014207 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/dots.R \name{dyn-dots} \alias{dyn-dots} \alias{tidy-dots} \alias{doc_dots_dynamic} \alias{:=} \title{Dynamic dots features} \description{ The base \code{...} syntax supports: \itemize{ \item \strong{Forwarding} arguments from function to function, matching them along the way to arguments. \item \strong{Collecting} arguments inside data structures, e.g. with \code{\link[=c]{c()}} or \code{\link[=list]{list()}}. } Dynamic dots offer a few additional features, \link[=topic-inject]{injection} in particular: \enumerate{ \item You can \strong{splice} arguments saved in a list with the splice operator \code{\link[=splice-operator]{!!!}}. \item You can \strong{inject} names with \link[=glue-operators]{glue syntax} on the left-hand side of \verb{:=}. \item Trailing commas are ignored, making it easier to copy and paste lines of arguments. } } \section{Add dynamic dots support in your functions}{ If your function takes dots, adding support for dynamic features is as easy as collecting the dots with \code{\link[=list2]{list2()}} instead of \code{\link[=list]{list()}}. See also \code{\link[=dots_list]{dots_list()}}, which offers more control over the collection. In general, passing \code{...} to a function that supports dynamic dots causes your function to inherit the dynamic behaviour. In packages, document dynamic dots with this standard tag: \if{html}{\out{
}}\preformatted{ @param ... <[`dynamic-dots`][rlang::dyn-dots]> What these dots do. }\if{html}{\out{
}} } \examples{ f <- function(...) { out <- list2(...) rev(out) } # Trailing commas are ignored f(this = "that", ) # Splice lists of arguments with `!!!` x <- list(alpha = "first", omega = "last") f(!!!x) # Inject a name using glue syntax if (is_installed("glue")) { nm <- "key" f("{nm}" := "value") f("prefix_{nm}" := "value") } } rlang/man/enquo.Rd0000644000176200001440000001037014376112150013547 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/nse-defuse.R \name{enquo} \alias{enquo} \alias{enquos} \title{Defuse function arguments} \usage{ enquo(arg) enquos( ..., .named = FALSE, .ignore_empty = c("trailing", "none", "all"), .ignore_null = c("none", "all"), .unquote_names = TRUE, .homonyms = c("keep", "first", "last", "error"), .check_assign = FALSE ) } \arguments{ \item{arg}{An unquoted argument name. The expression supplied to that argument is defused and returned.} \item{...}{Names of arguments to defuse.} \item{.named}{If \code{TRUE}, unnamed inputs are automatically named with \code{\link[=as_label]{as_label()}}. This is equivalent to applying \code{\link[=exprs_auto_name]{exprs_auto_name()}} on the result. If \code{FALSE}, unnamed elements are left as is and, if fully unnamed, the list is given minimal names (a vector of \code{""}). If \code{NULL}, fully unnamed results are left with \code{NULL} names.} \item{.ignore_empty}{Whether to ignore empty arguments. Can be one of \code{"trailing"}, \code{"none"}, \code{"all"}. If \code{"trailing"}, only the last argument is ignored if it is empty. Named arguments are not considered empty.} \item{.ignore_null}{Whether to ignore unnamed null arguments. Can be \code{"none"} or \code{"all"}.} \item{.unquote_names}{Whether to treat \verb{:=} as \code{=}. Unlike \code{=}, the \verb{:=} syntax supports \link[=glue-operators]{names injection}.} \item{.homonyms}{How to treat arguments with the same name. The default, \code{"keep"}, preserves these arguments. Set \code{.homonyms} to \code{"first"} to only keep the first occurrences, to \code{"last"} to keep the last occurrences, and to \code{"error"} to raise an informative error and indicate what arguments have duplicated names.} \item{.check_assign}{Whether to check for \verb{<-} calls. When \code{TRUE} a warning recommends users to use \code{=} if they meant to match a function parameter or wrap the \verb{<-} call in curly braces otherwise. This ensures assignments are explicit.} } \value{ \code{enquo()} returns a \link[=topic-quosure]{quosure} and \code{enquos()} returns a list of quosures. } \description{ \code{enquo()} and \code{enquos()} \link[=topic-defuse]{defuse} function arguments. A defused expression can be examined, modified, and injected into other expressions. Defusing function arguments is useful for: \itemize{ \item Creating data-masking functions. \item Interfacing with another \link[=topic-data-mask]{data-masking} function using the \link[=topic-metaprogramming]{defuse-and-inject} pattern. } These are advanced tools. Make sure to first learn about the embrace operator \ifelse{html}{\code{\link[=embrace-operator]{\{\{}}}{\verb{\{\{}} in \ifelse{html}{\link[=topic-data-mask-programming]{Data mask programming patterns}}{\link[=topic-data-mask-programming]{Data mask programming patterns}}. \verb{\{\{} is easier to work with less theory, and it is sufficient in most applications. } \section{Implicit injection}{ Arguments defused with \code{enquo()} and \code{enquos()} automatically gain \link[=topic-inject]{injection} support. \if{html}{\out{
}}\preformatted{my_mean <- function(data, var) \{ var <- enquo(var) dplyr::summarise(data, mean(!!var)) \} # Can now use `!!` and `\{\{` my_mean(mtcars, !!sym("cyl")) }\if{html}{\out{
}} See \code{\link[=enquo0]{enquo0()}} and \code{\link[=enquos0]{enquos0()}} for variants that don't enable injection. } \examples{ # `enquo()` defuses the expression supplied by your user f <- function(arg) { enquo(arg) } f(1 + 1) # `enquos()` works with arguments and dots. It returns a list of # expressions f <- function(...) { enquos(...) } f(1 + 1, 2 * 10) # `enquo()` and `enquos()` enable _injection_ and _embracing_ for # your users g <- function(arg) { f({{ arg }} * 2) } g(100) column <- sym("cyl") g(!!column) } \seealso{ \itemize{ \item \ifelse{html}{\link[=topic-defuse]{Defusing R expressions}}{\link[=topic-defuse]{Defusing R expressions}} for an overview. \item \code{\link[=expr]{expr()}} to defuse your own local expressions. \item \link[=defusing-advanced]{Advanced defusal operators}. \item \code{\link[base:eval]{base::eval()}} and \code{\link[=eval_bare]{eval_bare()}} for resuming evaluation of a defused expression. } } rlang/man/env_bury.Rd0000644000176200001440000000332514375670676014300 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/lifecycle-superseded.R \name{env_bury} \alias{env_bury} \title{Mask bindings by defining symbols deeper in a scope} \usage{ env_bury(.env, ...) } \arguments{ \item{.env}{An environment.} \item{...}{<\link[=dyn-dots]{dynamic}> Named objects (\code{env_bind()}), expressions \code{env_bind_lazy()}, or functions (\code{env_bind_active()}). Use \code{\link[=zap]{zap()}} to remove bindings.} } \value{ A copy of \code{.env} enclosing the new environment containing bindings to \code{...} arguments. } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#superseded}{\figure{lifecycle-superseded.svg}{options: alt='[Superseded]'}}}{\strong{[Superseded]}} This function is superseded. Please use \code{\link[=env]{env()}} (and possibly \code{\link[=set_env]{set_env()}} if you're masking the bindings for another object like a closure or a formula) instead. \code{env_bury()} is like \code{\link[=env_bind]{env_bind()}} but it creates the bindings in a new child environment. This makes sure the new bindings have precedence over old ones, without altering existing environments. Unlike \code{env_bind()}, this function does not have side effects and returns a new environment (or object wrapping that environment). } \examples{ orig_env <- env(a = 10) fn <- set_env(function() a, orig_env) # fn() currently sees `a` as the value `10`: fn() # env_bury() will bury the current scope of fn() behind a new # environment: fn <- env_bury(fn, a = 1000) fn() # Even though the symbol `a` is still defined deeper in the scope: orig_env$a } \seealso{ \code{\link[=env_bind]{env_bind()}}, \code{\link[=env_unbind]{env_unbind()}} } \keyword{internal} rlang/man/new_quosures.Rd0000644000176200001440000000174114127057575015176 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/quo.R \name{new_quosures} \alias{new_quosures} \alias{as_quosures} \alias{is_quosures} \title{Create a list of quosures} \usage{ new_quosures(x) as_quosures(x, env, named = FALSE) is_quosures(x) } \arguments{ \item{x}{A list of quosures or objects to coerce to quosures.} \item{env}{The default environment for the new quosures.} \item{named}{Whether to name the list with \code{\link[=quos_auto_name]{quos_auto_name()}}.} } \description{ This small S3 class provides methods for \code{[} and \code{c()} and ensures the following invariants: \itemize{ \item The list only contains quosures. \item It is always named, possibly with a vector of empty strings. } \code{new_quosures()} takes a list of quosures and adds the \code{quosures} class and a vector of empty names if needed. \code{as_quosures()} calls \code{\link[=as_quosure]{as_quosure()}} on all elements before creating the \code{quosures} object. } rlang/man/exprs_auto_name.Rd0000644000176200001440000000165614375670676015645 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/nse-defuse.R \name{exprs_auto_name} \alias{exprs_auto_name} \alias{quos_auto_name} \title{Ensure that all elements of a list of expressions are named} \usage{ exprs_auto_name( exprs, ..., repair_auto = c("minimal", "unique"), repair_quiet = FALSE ) quos_auto_name(quos) } \arguments{ \item{exprs}{A list of expressions.} \item{...}{These dots are for future extensions and must be empty.} \item{repair_auto}{Whether to repair the automatic names. By default, minimal names are returned. See \code{?vctrs::vec_as_names} for information about name repairing.} \item{repair_quiet}{Whether to inform user about repaired names.} \item{quos}{A list of quosures.} } \description{ This gives default names to unnamed elements of a list of expressions (or expression wrappers such as formulas or quosures), deparsed with \code{\link[=as_label]{as_label()}}. } rlang/man/call_name.Rd0000644000176200001440000000407514375670676014365 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/call.R \name{call_name} \alias{call_name} \alias{call_ns} \alias{is_call_simple} \title{Extract function name or namespace of a call} \usage{ call_name(call) call_ns(call) is_call_simple(x, ns = NULL) } \arguments{ \item{call}{A defused call.} \item{x}{An object to test.} \item{ns}{Whether call is namespaced. If \code{NULL}, \code{is_call_simple()} is insensitive to namespaces. If \code{TRUE}, \code{is_call_simple()} detects namespaced calls. If \code{FALSE}, it detects unnamespaced calls.} } \value{ The function name or namespace as a string, or \code{NULL} if the call is not named or namespaced. } \description{ \code{call_name()} and \code{call_ns()} extract the function name or namespace of \emph{simple} calls as a string. They return \code{NULL} for complex calls. \itemize{ \item Simple calls: \code{foo()}, \code{bar::foo()}. \item Complex calls: \code{foo()()}, \code{bar::foo}, \code{foo$bar()}, \code{(function() NULL)()}. } The \code{is_call_simple()} predicate helps you determine whether a call is simple. There are two invariants you can count on: \enumerate{ \item If \code{is_call_simple(x)} returns \code{TRUE}, \code{call_name(x)} returns a string. Otherwise it returns \code{NULL}. \item If \code{is_call_simple(x, ns = TRUE)} returns \code{TRUE}, \code{call_ns()} returns a string. Otherwise it returns \code{NULL}. } } \examples{ # Is the function named? is_call_simple(quote(foo())) is_call_simple(quote(foo[[1]]())) # Is the function namespaced? is_call_simple(quote(list()), ns = TRUE) is_call_simple(quote(base::list()), ns = TRUE) # Extract the function name from quoted calls: call_name(quote(foo(bar))) call_name(quo(foo(bar))) # Namespaced calls are correctly handled: call_name(quote(base::matrix(baz))) # Anonymous and subsetted functions return NULL: call_name(quote(foo$bar())) call_name(quote(foo[[bar]]())) call_name(quote(foo()())) # Extract namespace of a call with call_ns(): call_ns(quote(base::bar())) # If not namespaced, call_ns() returns NULL: call_ns(quote(bar())) } rlang/man/vec_poke_n.Rd0000644000176200001440000000227314175213516014540 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/vec.R \name{vec_poke_n} \alias{vec_poke_n} \alias{vec_poke_range} \title{Poke values into a vector} \usage{ vec_poke_n(x, start, y, from = 1L, n = length(y)) vec_poke_range(x, start, y, from = 1L, to = length(y) - from + 1L) } \arguments{ \item{x}{The destination vector.} \item{start}{The index indicating where to start modifying \code{x}.} \item{y}{The source vector.} \item{from}{The index indicating where to start copying from \code{y}.} \item{n}{How many elements should be copied from \code{y} to \code{x}.} \item{to}{The index indicating the end of the range to copy from \code{y}.} } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} These tools are for R experts only. They copy elements from \code{y} into \code{x} by mutation. You should only do this if you own \code{x}, i.e. if you have created it or if you are certain that it doesn't exist in any other context. Otherwise you might create unintended side effects that have undefined consequences. } \keyword{internal} rlang/man/env_depth.Rd0000644000176200001440000000122714127057575014412 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/env.R \name{env_depth} \alias{env_depth} \title{Depth of an environment chain} \usage{ env_depth(env) } \arguments{ \item{env}{An environment.} } \value{ An integer. } \description{ This function returns the number of environments between \code{env} and the \link[=empty_env]{empty environment}, including \code{env}. The depth of \code{env} is also the number of parents of \code{env} (since the empty environment counts as a parent). } \examples{ env_depth(empty_env()) env_depth(pkg_env("rlang")) } \seealso{ The section on inheritance in \code{\link[=env]{env()}} documentation. } rlang/man/try_fetch.Rd0000644000176200001440000001304714626342040014414 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cnd-handlers.R \name{try_fetch} \alias{try_fetch} \title{Try an expression with condition handlers} \usage{ try_fetch(expr, ...) } \arguments{ \item{expr}{An R expression.} \item{...}{<\code{\link[=dyn-dots]{dynamic-dots}}> Named condition handlers. The names specify the condition class for which a handler will be called.} } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} \code{try_fetch()} establishes handlers for conditions of a given class (\code{"error"}, \code{"warning"}, \code{"message"}, ...). Handlers are functions that take a condition object as argument and are called when the corresponding condition class has been signalled. A condition handler can: \itemize{ \item \strong{Recover from conditions} with a value. In this case the computation of \code{expr} is aborted and the recovery value is returned from \code{try_fetch()}. Error recovery is useful when you don't want errors to abruptly interrupt your program but resume at the catching site instead. \if{html}{\out{
}}\preformatted{# Recover with the value 0 try_fetch(1 + "", error = function(cnd) 0) }\if{html}{\out{
}} \item \strong{Rethrow conditions}, e.g. using \code{abort(msg, parent = cnd)}. See the \code{parent} argument of \code{\link[=abort]{abort()}}. This is typically done to add information to low-level errors about the high-level context in which they occurred. \if{html}{\out{
}}\preformatted{try_fetch(1 + "", error = function(cnd) abort("Failed.", parent = cnd)) }\if{html}{\out{
}} \item \strong{Inspect conditions}, for instance to log data about warnings or errors. In this case, the handler must return the \code{\link[=zap]{zap()}} sentinel to instruct \code{try_fetch()} to ignore (or zap) that particular handler. The next matching handler is called if any, and errors bubble up to the user if no handler remains. \if{html}{\out{
}}\preformatted{log <- NULL try_fetch(1 + "", error = function(cnd) \{ log <<- cnd zap() \}) }\if{html}{\out{
}} } Whereas \code{tryCatch()} catches conditions (discarding any running code along the way) and then calls the handler, \code{try_fetch()} first calls the handler with the condition on top of the currently running code (fetches it where it stands) and then catches the return value. This is a subtle difference that has implications for the debuggability of your functions. See the comparison with \code{tryCatch()} section below. Another difference between \code{try_fetch()} and the base equivalent is that errors are matched across chains, see the \code{parent} argument of \code{\link[=abort]{abort()}}. This is a useful property that makes \code{try_fetch()} insensitive to changes of implementation or context of evaluation that cause a classed error to suddenly get chained to a contextual error. Note that some chained conditions are not inherited, see the \code{.inherit} argument of \code{\link[=abort]{abort()}} or \code{\link[=warn]{warn()}}. In particular, downgraded conditions (e.g. from error to warning or from warning to message) are not matched across parents. } \section{Stack overflows}{ A stack overflow occurs when a program keeps adding to itself until the stack memory (whose size is very limited unlike heap memory) is exhausted. \if{html}{\out{
}}\preformatted{# A function that calls itself indefinitely causes stack overflows f <- function() f() f() #> Error: C stack usage 9525680 is too close to the limit }\if{html}{\out{
}} Because memory is very limited when these errors happen, it is not possible to call the handlers on the existing program stack. Instead, error conditions are first caught by \code{try_fetch()} and only then error handlers are called. Catching the error interrupts the program up to the \code{try_fetch()} context, which allows R to reclaim stack memory. The practical implication is that error handlers should never assume that the whole call stack is preserved. For instance a \code{\link[=trace_back]{trace_back()}} capture might miss frames. Note that error handlers are only run for stack overflows on R >= 4.2. On older versions of R the handlers are simply not run. This is because these errors do not inherit from the class \code{stackOverflowError} before R 4.2. Consider using \code{\link[=tryCatch]{tryCatch()}} instead with critical error handlers that need to capture all errors on old versions of R. } \section{Comparison with \code{tryCatch()}}{ \code{try_fetch()} generalises \code{tryCatch()} and \code{withCallingHandlers()} in a single function. It reproduces the behaviour of both calling and exiting handlers depending on the return value of the handler. If the handler returns the \code{\link[=zap]{zap()}} sentinel, it is taken as a calling handler that declines to recover from a condition. Otherwise, it is taken as an exiting handler which returns a value from the catching site. The important difference between \code{tryCatch()} and \code{try_fetch()} is that the program in \code{expr} is still fully running when an error handler is called. Because the call stack is preserved, this makes it possible to capture a full backtrace from within the handler, e.g. when rethrowing the error with \code{abort(parent = cnd)}. Technically, \code{try_fetch()} is more similar to (and implemented on top of) \code{\link[base:conditions]{base::withCallingHandlers()}} than \verb{tryCatch().} } rlang/man/topic-error-chaining.Rd0000644000176200001440000003037014626300474016453 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/topic-errors.R \name{topic-error-chaining} \alias{topic-error-chaining} \title{Including contextual information with error chains} \description{ Error chaining is a mechanism for providing contextual information when an error occurs. There are multiple situations in which you might be able to provide context that is helpful to quickly understand the cause or origin of an error: \itemize{ \item Mentioning the \emph{high level context} in which a low level error arised. E.g. chaining a low-level HTTP error to a high-level download error. \item Mentioning the \emph{pipeline step} in which a user error occured. This is a major use-case for NSE interfaces in the tidyverse, e.g. in dplyr, tidymodels or ggplot2. \item Mentioning the \emph{iteration context} in which a user error occurred. For instance, the input file when processing documents, or the iteration number or key when running user code in a loop. } Here is an example of a chained error from dplyr that shows the pipeline step (\code{mutate()}) and the iteration context (group ID) in which a function called by the user failed: \if{html}{\out{
}}\preformatted{add <- function(x, y) x + y mtcars |> dplyr::group_by(cyl) |> dplyr::mutate(new = add(disp, "foo")) #> Error in `dplyr::mutate()`: #> i In argument: `new = add(disp, "foo")`. #> i In group 1: `cyl = 4`. #> Caused by error in `x + y`: #> ! non-numeric argument to binary operator }\if{html}{\out{
}} In all these cases, there are two errors in play, chained together: \enumerate{ \item The \strong{causal error}, which interrupted the current course of action. \item The \strong{contextual error}, which expresses higher-level information when something goes wrong. } There may be more than one contextual error in an error chain, but there is always only one causal error. } \section{Rethrowing errors}{ To create an error chain, you must first capture causal errors when they occur. We recommend using \code{try_fetch()} instead of \code{tryCatch()} or \code{withCallingHandlers()}. \itemize{ \item Compared to \code{tryCatch()}, \code{try_fetch()} fully preserves the context of the error. This is important for debugging because it ensures complete backtraces are reported to users (e.g. via \code{last_error()}) and allows \code{options(error = recover)} to reach into the deepest error context. \item Compared to \code{withCallingHandlers()}, which also preserves the error context, \code{try_fetch()} is able to catch stack overflow errors on R versions >= 4.2.0. } In practice, \code{try_fetch()} works just like \code{tryCatch()}. It takes pairs of error class names and handling functions. To chain an error, simply rethrow it from an error handler by passing it as \code{parent} argument. In this example, we'll create a \code{with_} function. That is, a function that sets up some configuration (in this case, chained errors) before executing code supplied as input: \if{html}{\out{
}}\preformatted{with_chained_errors <- function(expr) \{ try_fetch( expr, error = function(cnd) \{ abort("Problem during step.", parent = cnd) \} ) \} with_chained_errors(1 + "") #> Error in `with_chained_errors()`: #> ! Problem during step. #> Caused by error in `1 + ""`: #> ! non-numeric argument to binary operator }\if{html}{\out{
}} Typically, you'll use this error helper from another user-facing function. \if{html}{\out{
}}\preformatted{my_verb <- function(expr) \{ with_chained_errors(expr) \} my_verb(add(1, "")) #> Error in `with_chained_errors()`: #> ! Problem during step. #> Caused by error in `x + y`: #> ! non-numeric argument to binary operator }\if{html}{\out{
}} Altough we have created a chained error, the error call of the contextual error is not quite right. It mentions the name of the error helper instead of the name of the user-facing function. If you've read \ifelse{html}{\link[=topic-error-call]{Including function calls in error messages}}{\link[=topic-error-call]{Including function calls in error messages}}, you may suspect that we need to pass a \code{call} argument to \code{abort()}. That's exactly what needs to happen to fix the call and backtrace issues: \if{html}{\out{
}}\preformatted{with_chained_errors <- function(expr, call = caller_env()) \{ try_fetch( expr, error = function(cnd) \{ abort("Problem during step.", parent = cnd, call = call) \} ) \} }\if{html}{\out{
}} Now that we've passed the caller environment as \code{call} argument, \code{abort()} automatically picks up the correspondin function call from the execution frame: \if{html}{\out{
}}\preformatted{my_verb(add(1, "")) #> Error in `my_verb()`: #> ! Problem during step. #> Caused by error in `x + y`: #> ! non-numeric argument to binary operator }\if{html}{\out{
}} \subsection{Side note about missing arguments}{ \code{my_verb()} is implemented with a lazy evaluation pattern. The user input kept unevaluated until the error chain context is set up. A downside of this arrangement is that missing argument errors are reported in the wrong context: \if{html}{\out{
}}\preformatted{my_verb() #> Error in `my_verb()`: #> ! Problem during step. #> Caused by error in `my_verb()`: #> ! argument "expr" is missing, with no default }\if{html}{\out{
}} To fix this, simply require these arguments before setting up the chained error context, for instance with the \code{check_required()} input checker exported from rlang: \if{html}{\out{
}}\preformatted{my_verb <- function(expr) \{ check_required(expr) with_chained_errors(expr) \} my_verb() #> Error in `my_verb()`: #> ! `expr` is absent but must be supplied. }\if{html}{\out{
}} } } \section{Taking full ownership of a causal error}{ It is also possible to completely take ownership of a causal error and rethrow it with a more user-friendly error message. In this case, the original error is completely hidden from the end user. Opting for his approach instead of chaining should be carefully considered because hiding the causal error may deprive users from precious debugging information. \itemize{ \item In general, hiding \emph{user errors} (e.g. dplyr inputs) in this way is likely a bad idea. \item It may be appropriate to hide low-level errors, e.g. replacing HTTP errors by a high-level download error. Similarly, tidyverse packages like dplyr are replacing low-level vctrs errors with higher level errors of their own crafting. \item Hiding causal errors indiscriminately should likely be avoided because it may suppress information about unexpected errors. In general, rethrowing an unchained errors should only be done with specific error classes. } To rethow an error without chaining it, and completely take over the causal error from the user point of view, fetch it with \code{try_fetch()} and throw a new error. The only difference with throwing a chained error is that the \code{parent} argument is set to \code{NA}. You could also omit the \code{parent} argument entirely, but passing \code{NA} lets \code{abort()} know it is rethrowing an error from a handler and that it should hide the corresponding error helpers in the backtrace. \if{html}{\out{
}}\preformatted{with_own_scalar_errors <- function(expr, call = caller_env()) \{ try_fetch( expr, vctrs_error_scalar_type = function(cnd) \{ abort( "Must supply a vector.", parent = NA, error = cnd, call = call ) \} ) \} my_verb <- function(expr) \{ check_required(expr) with_own_scalar_errors( vctrs::vec_assert(expr) ) \} my_verb(env()) #> Error in `my_verb()`: #> ! Must supply a vector. }\if{html}{\out{
}} When a low-level error is overtaken, it is good practice to store it in the high-level error object, so that it can be inspected for debugging purposes. In the snippet above, we stored it in the \code{error} field. Here is one way of accessing the original error by subsetting the object returned by \code{last_error()}: \if{html}{\out{
}}\preformatted{rlang::last_error()$error #> #> Error in `my_verb()`: #> ! `expr` must be a vector, not an environment. #> --- #> Backtrace: #> x #> 1. \\-rlang (local) my_verb(env()) }\if{html}{\out{
}} } \section{Case study: Mapping with chained errors}{ One good use case for chained errors is adding information about the iteration state when looping over a set of inputs. To illustrate this, we'll implement a version of \code{map()} / \code{lapply()} that chains an iteration error to any captured user error. Here is a minimal implementation of \code{map()}: \if{html}{\out{
}}\preformatted{my_map <- function(.xs, .fn, ...) \{ out <- new_list(length(.xs)) for (i in seq_along(.xs)) \{ out[[i]] <- .fn(.xs[[i]], ...) \} out \} list(1, 2) |> my_map(add, 100) #> [[1]] #> [1] 101 #> #> [[2]] #> [1] 102 }\if{html}{\out{
}} With this implementation, the user has no idea which iteration failed when an error occurs: \if{html}{\out{
}}\preformatted{list(1, "foo") |> my_map(add, 100) #> Error in `x + y`: #> ! non-numeric argument to binary operator }\if{html}{\out{
}} \subsection{Rethrowing with iteration information}{ To improve on this we'll wrap the loop in a \code{try_fetch()} call that rethrow errors with iteration information. Make sure to call \code{try_fetch()} on the outside of the loop to avoid a massive performance hit: \if{html}{\out{
}}\preformatted{my_map <- function(.xs, .fn, ...) \{ out <- new_list(length(.xs)) i <- 0L try_fetch( for (i in seq_along(.xs)) \{ out[[i]] <- .fn(.xs[[i]], ...) \}, error = function(cnd) \{ abort( sprintf("Problem while mapping element \%d.", i), parent = cnd ) \} ) out \} }\if{html}{\out{
}} And that's it, the error chain created by the rethrowing handler now provides users with the number of the failing iteration: \if{html}{\out{
}}\preformatted{list(1, "foo") |> my_map(add, 100) #> Error in `my_map()`: #> ! Problem while mapping element 2. #> Caused by error in `x + y`: #> ! non-numeric argument to binary operator }\if{html}{\out{
}} } \subsection{Dealing with errors thrown from the mapped function}{ One problem though, is that the user error call is not very informative when the error occurs immediately in the function supplied to \code{my_map()}: \if{html}{\out{
}}\preformatted{my_function <- function(x) \{ if (!is_string(x)) \{ abort("`x` must be a string.") \} \} list(1, "foo") |> my_map(my_function) #> Error in `my_map()`: #> ! Problem while mapping element 1. #> Caused by error in `.fn()`: #> ! `x` must be a string. }\if{html}{\out{
}} Functions have no names by themselves. Only the variable that refers to the function has a name. In this case, the mapped function is passed by argument to the variable \code{.fn}. So, when an error happens, this is the name that is reported to users. One approach to fix this is to inspect the \code{call} field of the error. When we detect a \code{.fn} call, we replace it by the defused code supplied as \code{.fn} argument: \if{html}{\out{
}}\preformatted{my_map <- function(.xs, .fn, ...) \{ # Capture the defused code supplied as `.fn` fn_code <- substitute(.fn) out <- new_list(length(.xs)) for (i in seq_along(.xs)) \{ try_fetch( out[[i]] <- .fn(.xs[[i]], ...), error = function(cnd) \{ # Inspect the `call` field to detect `.fn` calls if (is_call(cnd$call, ".fn")) \{ # Replace `.fn` by the defused code. # Keep existing arguments. cnd$call[[1]] <- fn_code \} abort( sprintf("Problem while mapping element \%s.", i), parent = cnd ) \} ) \} out \} }\if{html}{\out{
}} And voilà! \if{html}{\out{
}}\preformatted{list(1, "foo") |> my_map(my_function) #> Error in `my_map()`: #> ! Problem while mapping element 1. #> Caused by error in `my_function()`: #> ! `x` must be a string. }\if{html}{\out{
}} } } \keyword{internal} rlang/man/new_weakref.Rd0000644000176200001440000000505414127057575014735 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/weakref.R \name{new_weakref} \alias{new_weakref} \title{Create a weak reference} \usage{ new_weakref(key, value = NULL, finalizer = NULL, on_quit = FALSE) } \arguments{ \item{key}{The key for the weak reference. Must be a reference object -- that is, an environment or external pointer.} \item{value}{The value for the weak reference. This can be \code{NULL}, if you want to use the weak reference like a weak pointer.} \item{finalizer}{A function that is run after the key becomes unreachable.} \item{on_quit}{Should the finalizer be run when R exits?} } \description{ A weak reference is a special R object which makes it possible to keep a reference to an object without preventing garbage collection of that object. It can also be used to keep data about an object without preventing GC of the object, similar to WeakMaps in JavaScript. Objects in R are considered \emph{reachable} if they can be accessed by following a chain of references, starting from a \emph{root node}; root nodes are specially-designated R objects, and include the global environment and base environment. As long as the key is reachable, the value will not be garbage collected. This is true even if the weak reference object becomes unreachable. The key effectively prevents the weak reference and its value from being collected, according to the following chain of ownership: \code{weakref <- key -> value}. When the key becomes unreachable, the key and value in the weak reference object are replaced by \code{NULL}, and the finalizer is scheduled to execute. } \examples{ e <- env() # Create a weak reference to e w <- new_weakref(e, finalizer = function(e) message("finalized")) # Get the key object from the weak reference identical(wref_key(w), e) # When the regular reference (the `e` binding) is removed and a GC occurs, # the weak reference will not keep the object alive. rm(e) gc() identical(wref_key(w), NULL) # A weak reference with a key and value. The value contains data about the # key. k <- env() v <- list(1, 2, 3) w <- new_weakref(k, v) identical(wref_key(w), k) identical(wref_value(w), v) # When v is removed, the weak ref keeps it alive because k is still reachable. rm(v) gc() identical(wref_value(w), list(1, 2, 3)) # When k is removed, the weak ref does not keep k or v alive. rm(k) gc() identical(wref_key(w), NULL) identical(wref_value(w), NULL) } \seealso{ \code{\link[=is_weakref]{is_weakref()}}, \code{\link[=wref_key]{wref_key()}} and \code{\link[=wref_value]{wref_value()}}. } \keyword{experimental} rlang/man/op-na-default.Rd0000644000176200001440000000170014175213516015056 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/operators.R \name{op-na-default} \alias{op-na-default} \alias{\%|\%} \title{Replace missing values} \usage{ x \%|\% y } \arguments{ \item{x}{The original values.} \item{y}{The replacement values. Must be of length 1 or the same length as \code{x}.} } \description{ \strong{Note}: This operator is now out of scope for rlang. It will be replaced by a vctrs-powered operator (probably in the \href{https://github.com/tidyverse/funs}{funs package}) at which point the rlang version of \verb{\%|\%} will be deprecated. This infix function is similar to \code{\%||\%} but is vectorised and provides a default value for missing elements. It is faster than using \code{\link[base:ifelse]{base::ifelse()}} and does not perform type conversions. } \examples{ c("a", "b", NA, "c") \%|\% "default" c(1L, NA, 3L, NA, NA) \%|\% (6L:10L) } \seealso{ \link{op-null-default} } \keyword{internal} rlang/man/env_print.Rd0000644000176200001440000000213114127057575014435 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/env.R \name{env_print} \alias{env_print} \title{Pretty-print an environment} \usage{ env_print(env = caller_env()) } \arguments{ \item{env}{An environment, or object that can be converted to an environment by \code{\link[=get_env]{get_env()}}.} } \description{ This prints: \itemize{ \item The \link[=env_label]{label} and the parent label. \item Whether the environment is \link[=env_lock]{locked}. \item The bindings in the environment (up to 20 bindings). They are printed succintly using \code{pillar::type_sum()} (if available, otherwise uses an internal version of that generic). In addition \link[=env_bind_lazy]{fancy bindings} (actives and promises) are indicated as such. \item Locked bindings get a \verb{[L]} tag } Note that printing a package namespace (see \code{\link[=ns_env]{ns_env()}}) with \code{env_print()} will typically tag function bindings as \verb{} until they are evaluated the first time. This is because package functions are lazily-loaded from disk to improve performance when loading a package. } rlang/man/dot-data.Rd0000644000176200001440000000510214375670676014137 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/eval-tidy.R \docType{data} \name{dot-data} \alias{dot-data} \alias{.data} \alias{tidyeval-data} \alias{.env} \title{\code{.data} and \code{.env} pronouns} \description{ The \code{.data} and \code{.env} pronouns make it explicit where to find objects when programming with \link[=topic-data-mask]{data-masked} functions. \if{html}{\out{
}}\preformatted{m <- 10 mtcars \%>\% mutate(disp = .data$disp * .env$m) }\if{html}{\out{
}} \itemize{ \item \code{.data} retrieves data-variables from the data frame. \item \code{.env} retrieves env-variables from the environment. } Because the lookup is explicit, there is no ambiguity between both kinds of variables. Compare: \if{html}{\out{
}}\preformatted{disp <- 10 mtcars \%>\% mutate(disp = .data$disp * .env$disp) mtcars \%>\% mutate(disp = disp * disp) }\if{html}{\out{
}} Note that \code{.data} is only a pronoun, it is not a real data frame. This means that you can't take its names or map a function over the contents of \code{.data}. Similarly, \code{.env} is not an actual R environment. For instance, it doesn't have a parent and the subsetting operators behave differently. } \section{\code{.data} versus the magrittr pronoun \code{.}}{ In a \href{https://magrittr.tidyverse.org/}{magrittr pipeline}, \code{.data} is not necessarily interchangeable with the magrittr pronoun \code{.}. With grouped data frames in particular, \code{.data} represents the current group slice whereas the pronoun \code{.} represents the whole data frame. Always prefer using \code{.data} in data-masked context. } \section{Where does \code{.data} live?}{ The \code{.data} pronoun is automatically created for you by data-masking functions using the \link[=eval_tidy]{tidy eval framework}. You don't need to import \code{rlang::.data} or use \code{library(rlang)} to work with this pronoun. However, the \code{.data} object exported from rlang is useful to import in your package namespace to avoid a \verb{R CMD check} note when referring to objects from the data mask. R does not have any way of knowing about the presence or absence of \code{.data} in a particular scope so you need to import it explicitly or equivalently declare it with \code{utils::globalVariables(".data")}. Note that \code{rlang::.data} is a "fake" pronoun. Do not refer to \code{rlang::.data} with the \verb{rlang::} qualifier in data masking code. Use the unqualified \code{.data} symbol that is automatically put in scope by data-masking functions. } \keyword{datasets} rlang/man/names2.Rd0000644000176200001440000000172514375670676013636 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/attr.R \name{names2} \alias{names2} \alias{names2<-} \title{Get names of a vector} \usage{ names2(x) names2(x) <- value } \arguments{ \item{x}{A vector.} \item{value}{New names.} } \description{ \code{names2()} always returns a character vector, even when an object does not have a \code{names} attribute. In this case, it returns a vector of empty names \code{""}. It also standardises missing names to \code{""}. The replacement variant \verb{names2<-} never adds \code{NA} names and instead fills unnamed vectors with \code{""}. } \examples{ names2(letters) # It also takes care of standardising missing names: x <- set_names(1:3, c("a", NA, "b")) names2(x) # Replacing names with the base `names<-` function may introduce # `NA` values when the vector is unnamed: x <- 1:3 names(x)[1:2] <- "foo" names(x) # Use the `names2<-` variant to avoid this x <- 1:3 names2(x)[1:2] <- "foo" names(x) } rlang/man/last_warnings.Rd0000644000176200001440000000527514401370456015307 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cnd-last.R \name{last_warnings} \alias{last_warnings} \alias{last_messages} \title{Display last messages and warnings} \usage{ last_warnings(n = NULL) last_messages(n = NULL) } \arguments{ \item{n}{How many warnings or messages to display. Defaults to all.} } \description{ \code{last_warnings()} and \code{last_messages()} return a list of all warnings and messages that occurred during the last R command. \code{\link[=global_entrace]{global_entrace()}} must be active in order to log the messages and warnings. By default the warnings and messages are printed with a simplified backtrace, like \code{\link[=last_error]{last_error()}}. Use \code{summary()} to print the conditions with a full backtrace. } \section{Examples}{ Enable backtrace capture with \code{global_entrace()}: \if{html}{\out{
}}\preformatted{global_entrace() }\if{html}{\out{
}} Signal some warnings in nested functions. The warnings inform about which function emitted a warning but they don't provide information about the call stack: \if{html}{\out{
}}\preformatted{f <- function() \{ warning("foo"); g() \} g <- function() \{ warning("bar", immediate. = TRUE); h() \} h <- function() warning("baz") f() #> Warning in g() : bar #> Warning messages: #> 1: In f() : foo #> 2: In h() : baz }\if{html}{\out{
}} Call \code{last_warnings()} to see backtraces for each of these warnings: \if{html}{\out{
}}\preformatted{last_warnings() #> [[1]] #> #> Warning in `f()`: #> foo #> Backtrace: #> x #> 1. \\-global f() #> #> [[2]] #> #> Warning in `g()`: #> bar #> Backtrace: #> x #> 1. \\-global f() #> 2. \\-global g() #> #> [[3]] #> #> Warning in `h()`: #> baz #> Backtrace: #> x #> 1. \\-global f() #> 2. \\-global g() #> 3. \\-global h() }\if{html}{\out{
}} This works similarly with messages: \if{html}{\out{
}}\preformatted{f <- function() \{ inform("Hey!"); g() \} g <- function() \{ inform("Hi!"); h() \} h <- function() inform("Hello!") f() #> Hey! #> Hi! #> Hello! rlang::last_messages() #> [[1]] #> #> Message: #> Hey! #> --- #> Backtrace: #> x #> 1. \\-global f() #> #> [[2]] #> #> Message: #> Hi! #> --- #> Backtrace: #> x #> 1. \\-global f() #> 2. \\-global g() #> #> [[3]] #> #> Message: #> Hello! #> --- #> Backtrace: #> x #> 1. \\-global f() #> 2. \\-global g() #> 3. \\-global h() }\if{html}{\out{
}} } \seealso{ \code{\link[=last_error]{last_error()}} } rlang/man/env_unlock.Rd0000644000176200001440000000057414741441060014571 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/env.R \name{env_unlock} \alias{env_unlock} \title{Unlock an environment} \usage{ env_unlock(env) } \arguments{ \item{env}{An environment.} } \value{ Whether the environment has been unlocked. } \description{ This function should only be used in development tools or interactively. } \keyword{internal} rlang/man/new-vector.Rd0000644000176200001440000000250314175213516014515 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/vec-new.R \name{new-vector} \alias{new-vector} \alias{new_logical} \alias{new_integer} \alias{new_double} \alias{new_character} \alias{new_complex} \alias{new_raw} \alias{new_list} \title{Create vectors matching a given length} \usage{ new_logical(n, names = NULL) new_integer(n, names = NULL) new_double(n, names = NULL) new_character(n, names = NULL) new_complex(n, names = NULL) new_raw(n, names = NULL) new_list(n, names = NULL) } \arguments{ \item{n}{The vector length.} \item{names}{Names for the new vector.} } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#questioning}{\figure{lifecycle-questioning.svg}{options: alt='[Questioning]'}}}{\strong{[Questioning]}} These functions construct vectors of a given length, with attributes specified via dots. Except for \code{new_list()} and \code{new_raw()}, the empty vectors are filled with typed \link{missing} values. This is in contrast to the base function \code{\link[base:vector]{base::vector()}} which creates zero-filled vectors. } \section{Lifecycle}{ These functions are likely to be replaced by a vctrs equivalent in the future. They are in the questioning lifecycle stage. } \examples{ new_list(10) new_logical(10) } \seealso{ rep_along } \keyword{internal} rlang/man/expr_label.Rd0000644000176200001440000000237114375670676014564 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_name} \alias{expr_text} \title{Turn an expression to a label} \usage{ expr_label(expr) expr_name(expr) expr_text(expr, width = 60L, nlines = Inf) } \arguments{ \item{expr}{An expression to labellise.} \item{width}{Width of each line.} \item{nlines}{Maximum number of lines to extract.} } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#questioning}{\figure{lifecycle-questioning.svg}{options: alt='[Questioning]'}}}{\strong{[Questioning]}} \code{expr_text()} turns the expression into a single string, which might be multi-line. \code{expr_name()} is suitable for formatting names. It works best with symbols and scalar types, but also accepts calls. \code{expr_label()} formats the expression nicely for use in messages. } \examples{ # To labellise a function argument, first capture it with # substitute(): fn <- function(x) expr_label(substitute(x)) fn(x:y) # Strings are encoded expr_label("a\nb") # Names and expressions are quoted with `` expr_label(quote(x)) expr_label(quote(a + b + c)) # Long expressions are collapsed expr_label(quote(foo({ 1 + 2 print(x) }))) } \keyword{internal} rlang/man/return_from.Rd0000644000176200001440000000165714375670676015017 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/stack.R \name{return_from} \alias{return_from} \title{Jump to or from a frame} \usage{ return_from(frame, value = NULL) } \arguments{ \item{frame}{An execution environment of a currently running function.} \item{value}{The return value.} } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#questioning}{\figure{lifecycle-questioning.svg}{options: alt='[Questioning]'}}}{\strong{[Questioning]}} While \code{\link[base:function]{base::return()}} can only return from the current local frame, \code{return_from()} will return from any frame on the current evaluation stack, between the global and the currently active context. } \examples{ fn <- function() { g(current_env()) "ignored" } g <- function(env) { h(env) "ignored" } h <- function(env) { return_from(env, "early return") "ignored" } fn() } \keyword{internal} rlang/man/glue-operators.Rd0000644000176200001440000001353214741441453015402 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/nse-inject.R \name{glue-operators} \alias{glue-operators} \title{Name injection with \code{"{"} and \code{"{{"}} \description{ \link[=dyn-dots]{Dynamic dots} (and \link[=topic-data-mask]{data-masked} dots which are dynamic by default) have built-in support for names interpolation with the \href{https://glue.tidyverse.org/}{glue package}. \if{html}{\out{
}}\preformatted{tibble::tibble(foo = 1) #> # A tibble: 1 x 1 #> foo #> #> 1 1 foo <- "name" tibble::tibble("\{foo\}" := 1) #> # A tibble: 1 x 1 #> name #> #> 1 1 }\if{html}{\out{
}} Inside functions, embracing an argument with \ifelse{html}{\code{\link[=embrace-operator]{\{\{}}}{\verb{\{\{}} inserts the expression supplied as argument in the string. This gives an indication on the variable or computation supplied as argument: \if{html}{\out{
}}\preformatted{tib <- function(x) \{ tibble::tibble("var: \{\{ x \}\}" := x) \} tib(1 + 1) #> # A tibble: 1 x 1 #> `var: 1 + 1` #> #> 1 2 }\if{html}{\out{
}} See also \code{\link[=englue]{englue()}} to string-embrace outside of dynamic dots. \if{html}{\out{
}}\preformatted{g <- function(x) \{ englue("var: \{\{ x \}\}") \} g(1 + 1) #> [1] "var: 1 + 1" }\if{html}{\out{
}} Technically, \verb{"\{\{"} \link[=topic-defuse]{defuses} a function argument, calls \code{\link[=as_label]{as_label()}} on the expression supplied as argument, and inserts the result in the string. \subsection{\verb{"\{"} and \verb{"\{\{"}}{ While \code{glue::glue()} only supports \verb{"\{"}, dynamic dots support both \verb{"\{"} and \verb{"\{\{"}. The double brace variant is similar to the embrace operator \ifelse{html}{\code{\link[=embrace-operator]{\{\{}}}{\verb{\{\{}} available in \link[=topic-data-mask]{data-masked} arguments. In the following example, the embrace operator is used in a glue string to name the result with a default name that represents the expression supplied as argument: \if{html}{\out{
}}\preformatted{my_mean <- function(data, var) \{ data \%>\% dplyr::summarise("\{\{ var \}\}" := mean(\{\{ var \}\})) \} mtcars \%>\% my_mean(cyl) #> # A tibble: 1 x 1 #> cyl #> #> 1 6.19 mtcars \%>\% my_mean(cyl * am) #> # A tibble: 1 x 1 #> `cyl * am` #> #> 1 2.06 }\if{html}{\out{
}} \verb{"\{\{"} is only meant for inserting an expression supplied as argument to a function. The result of the expression is not inspected or used. To interpolate a string stored in a variable, use the regular glue operator \verb{"\{"} instead: \if{html}{\out{
}}\preformatted{my_mean <- function(data, var, name = "mean") \{ data \%>\% dplyr::summarise("\{name\}" := mean(\{\{ var \}\})) \} mtcars \%>\% my_mean(cyl) #> # A tibble: 1 x 1 #> mean #> #> 1 6.19 mtcars \%>\% my_mean(cyl, name = "cyl") #> # A tibble: 1 x 1 #> cyl #> #> 1 6.19 }\if{html}{\out{
}} Using the wrong operator causes unexpected results: \if{html}{\out{
}}\preformatted{x <- "name" list2("\{\{ x \}\}" := 1) #> $`"name"` #> [1] 1 list2("\{x\}" := 1) #> $name #> [1] 1 }\if{html}{\out{
}} Ideally, using \verb{\{\{} on regular objects would be an error. However for technical reasons it is not possible to make a distinction between function arguments and ordinary variables. See \ifelse{html}{\link[=topic-embrace-non-args]{Does \{\{ work on regular objects?}}{\link[=topic-embrace-non-args]{Does curly-curly work on regular objects?}} for more information about this limitation. } \subsection{Allow overriding default names}{ The implementation of \code{my_mean()} in the previous section forces a default name onto the result. But what if the caller wants to give it a different name? In functions that take dots, it is possible to just supply a named expression to override the default. In a function like \code{my_mean()} that takes a named argument we need a different approach. This is where \code{\link[=englue]{englue()}} becomes useful. We can pull out the default name creation in another user-facing argument like this: \if{html}{\out{
}}\preformatted{my_mean <- function(data, var, name = englue("\{\{ var \}\}")) \{ data \%>\% dplyr::summarise("\{name\}" := mean(\{\{ var \}\})) \} }\if{html}{\out{
}} Now the user may supply their own name if needed: \if{html}{\out{
}}\preformatted{mtcars \%>\% my_mean(cyl * am) #> # A tibble: 1 x 1 #> `cyl * am` #> #> 1 2.06 mtcars \%>\% my_mean(cyl * am, name = "mean_cyl_am") #> # A tibble: 1 x 1 #> mean_cyl_am #> #> 1 2.06 }\if{html}{\out{
}} } \subsection{What's the deal with \verb{:=}?}{ Name injection in dynamic dots was originally implemented with \verb{:=} instead of \code{=} to allow complex expressions on the LHS: \if{html}{\out{
}}\preformatted{x <- "name" list2(!!x := 1) #> $name #> [1] 1 }\if{html}{\out{
}} Name-injection with glue operations was an extension of this existing feature and so inherited the same interface. However, there is no technical barrier to using glue strings on the LHS of \code{=}. As we are now moving away from \code{\link[=injection-operator]{!!}} for common tasks, we are considering enabling glue strings with \code{=} and superseding \verb{:=} usage. Track the progress of this change in \href{https://github.com/r-lib/rlang/issues/1296}{issue 1296}. } \subsection{Using glue syntax in packages}{ Since rlang does not depend directly on glue, you will have to ensure that glue is installed by adding it to your \verb{Imports:} section. \if{html}{\out{
}}\preformatted{usethis::use_package("glue", "Imports") }\if{html}{\out{
}} } } rlang/man/global_entrace.Rd0000644000176200001440000000442114401331356015361 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cnd-entrace.R \name{global_entrace} \alias{global_entrace} \title{Entrace unexpected errors} \usage{ global_entrace(enable = TRUE, class = c("error", "warning", "message")) } \arguments{ \item{enable}{Whether to enable or disable global handling.} \item{class}{A character vector of one or several classes of conditions to be entraced.} } \description{ \code{global_entrace()} enriches base errors, warnings, and messages with rlang features. \itemize{ \item They are assigned a backtrace. You can configure whether to display a backtrace on error with the \link{rlang_backtrace_on_error} global option. \item They are recorded in \code{\link[=last_error]{last_error()}}, \code{\link[=last_warnings]{last_warnings()}}, or \code{\link[=last_messages]{last_messages()}}. You can inspect backtraces at any time by calling these functions. } Set global entracing in your RProfile with: \if{html}{\out{
}}\preformatted{rlang::global_entrace() }\if{html}{\out{
}} } \section{Inside RMarkdown documents}{ Call \code{global_entrace()} inside an RMarkdown document to cause errors and warnings to be promoted to rlang conditions that include a backtrace. This needs to be done in a separate setup chunk before the first error or warning. This is useful in conjunction with \code{\link{rlang_backtrace_on_error_report}} and \code{\link{rlang_backtrace_on_warning_report}}. To get full entracing in an Rmd document, include this in a setup chunk before the first error or warning is signalled. \if{html}{\out{
}}\preformatted{```\{r setup\} rlang::global_entrace() options(rlang_backtrace_on_warning_report = "full") options(rlang_backtrace_on_error_report = "full") ``` }\if{html}{\out{
}} } \section{Under the hood}{ On R 4.0 and newer, \code{global_entrace()} installs a global handler with \code{globalCallingHandlers()}. On older R versions, \code{entrace()} is set as an \code{option(error = )} handler. The latter method has the disadvantage that only one handler can be set at a time. This means that you need to manually switch between \code{entrace()} and other handlers like \code{\link[=recover]{recover()}}. Also this causes a conflict with IDE handlers (e.g. in RStudio). } rlang/man/check_dots_empty.Rd0000644000176200001440000000346714626342040015756 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/dots-ellipsis.R \name{check_dots_empty} \alias{check_dots_empty} \title{Check that dots are empty} \usage{ check_dots_empty( env = caller_env(), error = NULL, call = caller_env(), action = abort ) } \arguments{ \item{env}{Environment in which to look for \code{...}.} \item{error}{An optional error handler passed to \code{\link[=try_fetch]{try_fetch()}}. Use this e.g. to demote an error into a warning.} \item{call}{The execution environment of a currently running function, e.g. \code{caller_env()}. The function will be mentioned in error messages as the source of the error. See the \code{call} argument of \code{\link[=abort]{abort()}} for more information.} \item{action}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}}} } \description{ \code{...} can be inserted in a function signature to force users to fully name the details arguments. In this case, supplying data in \code{...} is almost always a programming error. This function checks that \code{...} is empty and fails otherwise. } \details{ In packages, document \code{...} with this standard tag: \if{html}{\out{
}}\preformatted{ @inheritParams rlang::args_dots_empty }\if{html}{\out{
}} } \examples{ f <- function(x, ..., foofy = 8) { check_dots_empty() x + foofy } # This fails because `foofy` can't be matched positionally try(f(1, 4)) # This fails because `foofy` can't be matched partially by name try(f(1, foof = 4)) # Thanks to `...`, it must be matched exactly f(1, foofy = 4) } \seealso{ Other dots checking functions: \code{\link{check_dots_unnamed}()}, \code{\link{check_dots_used}()} } \concept{dots checking functions} rlang/man/dev-notes-dots.Rd0000644000176200001440000000227214375670676015322 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/dots.R \name{dev-notes-dots} \alias{dev-notes-dots} \title{Development notes - \code{dots.R}} \description{ Development notes - \code{dots.R} } \section{\code{.__error_call__.} flag in dots collectors}{ Dots collectors like \code{\link[=dots_list]{dots_list()}} are a little tricky because they may error out in different situations. Do we want to forward the context, i.e. set the call flag to the calling environment? Collectors throw errors in these cases: \enumerate{ \item While checking their own parameters, in which case the relevant context is the collector itself and we don't forward. \item While collecting the dots, during evaluation of the supplied arguments. In this case forwarding or not is irrelevant because expressions in \code{...} are evaluated in their own environment which is not connected to the collector's context. \item While collecting the dots, during argument constraints checks such as determined by the \code{.homonyms} argument. In this case we want to forward the context because the caller of the dots collector is the one who determines the constraints for its users. } } \keyword{internal} rlang/man/catch_cnd.Rd0000644000176200001440000000147714127057575014353 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cnd-handlers.R \name{catch_cnd} \alias{catch_cnd} \title{Catch a condition} \usage{ catch_cnd(expr, classes = "condition") } \arguments{ \item{expr}{Expression to be evaluated with a catching condition handler.} \item{classes}{A character vector of condition classes to catch. By default, catches all conditions.} } \value{ A condition if any was signalled, \code{NULL} otherwise. } \description{ This is a small wrapper around \code{tryCatch()} that captures any condition signalled while evaluating its argument. It is useful for situations where you expect a specific condition to be signalled, for debugging, and for unit testing. } \examples{ catch_cnd(10) catch_cnd(abort("an error")) catch_cnd(signal("my_condition", message = "a condition")) } rlang/man/splice.Rd0000644000176200001440000000324214376150033013701 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/dots.R \name{splice} \alias{splice} \alias{is_spliced} \alias{is_spliced_bare} \title{Splice values at dots collection time} \usage{ splice(x) is_spliced(x) is_spliced_bare(x) } \arguments{ \item{x}{A list or vector to splice non-eagerly.} } \description{ The splicing operator \verb{!!!} operates both in values contexts like \code{\link[=list2]{list2()}} and \code{\link[=dots_list]{dots_list()}}, and in metaprogramming contexts like \code{\link[=expr]{expr()}}, \code{\link[=enquos]{enquos()}}, or \code{\link[=inject]{inject()}}. While the end result looks the same, the implementation is different and much more efficient in the value cases. This difference in implementation may cause performance issues for instance when going from: \if{html}{\out{
}}\preformatted{xs <- list(2, 3) list2(1, !!!xs, 4) }\if{html}{\out{
}} to: \if{html}{\out{
}}\preformatted{inject(list2(1, !!!xs, 4)) }\if{html}{\out{
}} In the former case, the performant value-splicing is used. In the latter case, the slow metaprogramming splicing is used. A common practical case where this may occur is when code is wrapped inside a tidyeval context like \code{dplyr::mutate()}. In this case, the metaprogramming operator \verb{!!!} will take over the value-splicing operator, causing an unexpected slowdown. To avoid this in performance-critical code, use \code{splice()} instead of \verb{!!!}: \if{html}{\out{
}}\preformatted{# These both use the fast splicing: list2(1, splice(xs), 4) inject(list2(1, splice(xs), 4)) }\if{html}{\out{
}} } rlang/man/quo_squash.Rd0000644000176200001440000000255614375670676014644 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/quo.R \name{quo_squash} \alias{quo_squash} \title{Squash a quosure} \usage{ quo_squash(quo, warn = FALSE) } \arguments{ \item{quo}{A quosure or expression.} \item{warn}{Whether to warn if the quosure contains other quosures (those will be collapsed). This is useful when you use \code{quo_squash()} in order to make a non-tidyeval API compatible with quosures. In that case, getting rid of the nested quosures is likely to cause subtle bugs and it is good practice to warn the user about it.} } \description{ \code{quo_squash()} flattens all nested quosures within an expression. For example it transforms \verb{^foo(^bar(), ^baz)} to the bare expression \code{foo(bar(), baz)}. This operation is safe if the squashed quosure is used for labelling or printing (see \code{\link[=as_label]{as_label()}}, but note that \code{as_label()} squashes quosures automatically). However if the squashed quosure is evaluated, all expressions of the flattened quosures are resolved in a single environment. This is a source of bugs so it is good practice to set \code{warn} to \code{TRUE} to let the user know about the lossy squashing. } \examples{ # Quosures can contain nested quosures: quo <- quo(wrapper(!!quo(wrappee))) quo # quo_squash() flattens all the quosures and returns a simple expression: quo_squash(quo) } rlang/man/env_poke.Rd0000644000176200001440000000331414375670676014253 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/env-binding.R \name{env_poke} \alias{env_poke} \title{Poke an object in an environment} \usage{ env_poke(env = caller_env(), nm, value, inherit = FALSE, create = !inherit) } \arguments{ \item{env}{An environment.} \item{nm}{Name of binding, a string.} \item{value}{The value for a new binding.} \item{inherit}{Whether to look for bindings in the parent environments.} \item{create}{Whether to create a binding if it does not already exist in the environment.} } \value{ The old value of \code{nm} or a \link[=zap]{zap sentinel} if the binding did not exist yet. } \description{ \code{env_poke()} will assign or reassign a binding in \code{env} if \code{create} is \code{TRUE}. If \code{create} is \code{FALSE} and a binding does not already exists, an error is issued. } \details{ If \code{inherit} is \code{TRUE}, the parents environments are checked for an existing binding to reassign. If not found and \code{create} is \code{TRUE}, a new binding is created in \code{env}. The default value for \code{create} is a function of \code{inherit}: \code{FALSE} when inheriting, \code{TRUE} otherwise. This default makes sense because the inheriting case is mostly for overriding an existing binding. If not found, something probably went wrong and it is safer to issue an error. Note that this is different to the base R operator \verb{<<-} which will create a binding in the global environment instead of the current environment when no existing binding is found in the parents. } \seealso{ \code{\link[=env_bind]{env_bind()}} for binding multiple elements. \code{\link[=env_cache]{env_cache()}} for a variant of \code{env_poke()} designed to cache values. } rlang/man/call_args.Rd0000644000176200001440000000144714375670676014401 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/call.R \name{call_args} \alias{call_args} \alias{call_args_names} \title{Extract arguments from a call} \usage{ call_args(call) call_args_names(call) } \arguments{ \item{call}{A defused call.} } \value{ A named list of arguments. } \description{ Extract arguments from a call } \examples{ call <- quote(f(a, b)) # Subsetting a call returns the arguments converted to a language # object: call[-1] # On the other hand, call_args() returns a regular list that is # often easier to work with: str(call_args(call)) # When the arguments are unnamed, a vector of empty strings is # supplied (rather than NULL): call_args_names(call) } \seealso{ \code{\link[=fn_fmls]{fn_fmls()}} and \code{\link[=fn_fmls_names]{fn_fmls_names()}} } rlang/man/get_env.Rd0000644000176200001440000000537614375670676014106 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/env.R \name{get_env} \alias{get_env} \alias{set_env} \alias{env_poke_parent} \title{Get or set the environment of an object} \usage{ get_env(env, default = NULL) set_env(env, new_env = caller_env()) env_poke_parent(env, new_env) } \arguments{ \item{env}{An environment.} \item{default}{The default environment in case \code{env} does not wrap an environment. If \code{NULL} and no environment could be extracted, an error is issued.} \item{new_env}{An environment to replace \code{env} with.} } \description{ These functions dispatch internally with methods for functions, formulas and frames. If called with a missing argument, the environment of the current evaluation frame is returned. If you call \code{get_env()} with an environment, it acts as the identity function and the environment is simply returned (this helps simplifying code when writing generic functions for environments). } \details{ While \code{set_env()} returns a modified copy and does not have side effects, \code{env_poke_parent()} operates changes the environment by side effect. This is because environments are \link[=is_copyable]{uncopyable}. Be careful not to change environments that you don't own, e.g. a parent environment of a function from a package. } \examples{ # Environment of closure functions: fn <- function() "foo" get_env(fn) # Or of quosures or formulas: get_env(~foo) get_env(quo(foo)) # Provide a default in case the object doesn't bundle an environment. # Let's create an unevaluated formula: f <- quote(~foo) # The following line would fail if run because unevaluated formulas # don't bundle an environment (they didn't have the chance to # record one yet): # get_env(f) # It is often useful to provide a default when you're writing # functions accepting formulas as input: default <- env() identical(get_env(f, default), default) # set_env() can be used to set the enclosure of functions and # formulas. Let's create a function with a particular environment: env <- child_env("base") fn <- set_env(function() NULL, env) # That function now has `env` as enclosure: identical(get_env(fn), env) identical(get_env(fn), current_env()) # set_env() does not work by side effect. Setting a new environment # for fn has no effect on the original function: other_env <- child_env(NULL) set_env(fn, other_env) identical(get_env(fn), other_env) # Since set_env() returns a new function with a different # environment, you'll need to reassign the result: fn <- set_env(fn, other_env) identical(get_env(fn), other_env) } \seealso{ \code{\link[=quo_get_env]{quo_get_env()}} and \code{\link[=quo_set_env]{quo_set_env()}} for versions of \code{\link[=get_env]{get_env()}} and \code{\link[=set_env]{set_env()}} that only work on quosures. } rlang/man/topic-metaprogramming.Rd0000644000176200001440000003300714741441453016736 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/topic-nse.R \name{topic-metaprogramming} \alias{topic-metaprogramming} \title{Metaprogramming patterns} \description{ The patterns covered in this article rely on \emph{metaprogramming}, the ability to defuse, create, expand, and inject R expressions. A good place to start if you're new to programming on the language is the \href{https://adv-r.hadley.nz/metaprogramming.html}{Metaprogramming chapter} of the \href{https://adv-r.hadley.nz}{Advanced R} book. If you haven't already, read \ifelse{html}{\link[=topic-data-mask-programming]{Data mask programming patterns}}{\link[=topic-data-mask-programming]{Data mask programming patterns}} which covers simpler patterns that do not require as much theory to get up to speed. It covers concepts like argument behaviours and the various patterns you can add to your toolbox (forwarding, names, bridge, and transformative patterns). } \section{Forwarding patterns}{ \subsection{Defuse and inject}{ \ifelse{html}{\code{\link[=embrace-operator]{\{\{}}}{\verb{\{\{}} and \code{...} are sufficient for most purposes. Sometimes however, it is necessary to decompose the forwarding action into its two constitutive steps, \link[=topic-defuse]{defusing} and \link[=topic-inject]{injecting}. \verb{\{\{} is the combination of \code{\link[=enquo]{enquo()}} and \code{\link[=injection-operator]{!!}}. These functions are completely equivalent: \if{html}{\out{
}}\preformatted{my_summarise <- function(data, var) \{ data \%>\% dplyr::summarise(\{\{ var \}\}) \} my_summarise <- function(data, var) \{ data \%>\% dplyr::summarise(!!enquo(var)) \} }\if{html}{\out{
}} Passing \code{...} is equivalent to the combination of \code{\link[=enquos]{enquos()}} and \code{\link[=splice-operator]{!!!}}: \if{html}{\out{
}}\preformatted{my_group_by <- function(.data, ...) \{ .data \%>\% dplyr::group_by(...) \} my_group_by <- function(.data, ...) \{ .data \%>\% dplyr::group_by(!!!enquos(...)) \} }\if{html}{\out{
}} The advantage of decomposing the steps is that you gain access to the \link[=topic-defuse]{defused expressions}. Once defused, you can inspect or modify the expressions before injecting them in their target context. } \subsection{Inspecting input labels}{ For instance, here is how to create an automatic name for a defused argument using \code{\link[=as_label]{as_label()}}: \if{html}{\out{
}}\preformatted{f <- function(var) \{ var <- enquo(var) as_label(var) \} f(cyl) #> [1] "cyl" f(1 + 1) #> [1] "1 + 1" }\if{html}{\out{
}} This is essentially equivalent to formatting an argument using \code{\link[=englue]{englue()}}: \if{html}{\out{
}}\preformatted{f2 <- function(var) \{ englue("\{\{ var \}\}") \} f2(1 + 1) #> [1] "1 + 1" }\if{html}{\out{
}} With multiple arguments, use the plural variant \code{\link[=enquos]{enquos()}}. Set \code{.named} to \code{TRUE} to automatically call \code{\link[=as_label]{as_label()}} on the inputs for which the user has not provided a name (the same behaviour as in most dplyr verbs): \if{html}{\out{
}}\preformatted{g <- function(...) \{ vars <- enquos(..., .named = TRUE) names(vars) \} g(cyl, 1 + 1) #> [1] "cyl" "1 + 1" }\if{html}{\out{
}} Just like with \code{dplyr::mutate()}, the user can override automatic names by supplying explicit names: \if{html}{\out{
}}\preformatted{g(foo = cyl, bar = 1 + 1) #> [1] "foo" "bar" }\if{html}{\out{
}} Defuse-and-inject patterns are most useful for transforming inputs. Some applications are explored in the Transformation patterns section. } } \section{Names patterns}{ \subsection{Symbolise and inject}{ The symbolise-and-inject pattern is a \emph{names pattern} that you can use when \code{across(all_of())} is not supported. It consists in creating \link[=topic-defuse]{defused expressions} that refer to the data-variables represented in the names vector. These are then injected in the data mask context. Symbolise a single string with \code{\link[=sym]{sym()}} or \code{\link[=data_sym]{data_sym()}}: \if{html}{\out{
}}\preformatted{var <- "cyl" sym(var) #> cyl data_sym(var) #> .data$cyl }\if{html}{\out{
}} Symbolise a character vector with \code{\link[=syms]{syms()}} or \code{\link[=data_syms]{data_syms()}}. \if{html}{\out{
}}\preformatted{vars <- c("cyl", "am") syms(vars) #> [[1]] #> cyl #> #> [[2]] #> am data_syms(vars) #> [[1]] #> .data$cyl #> #> [[2]] #> .data$am }\if{html}{\out{
}} Simple symbols returned by \code{sym()} and \code{syms()} work in a wider variety of cases (with base functions in particular) but we'll use mostly use \code{data_sym()} and \code{data_syms()} because they are more robust (see \ifelse{html}{\link[=topic-data-mask-ambiguity]{The data mask ambiguity}}{\link[=topic-data-mask-ambiguity]{The data mask ambiguity}}). Note that these do not return \emph{symbols} per se, instead they create \emph{calls} to \code{$} that subset the \code{\link{.data}} pronoun. Since the \code{.data} pronoun is a tidy eval feature, you can't use it in base functions. As a rule, prefer the \code{data_}-prefixed variants when you're injecting in tidy eval functions and the unprefixed functions for base functions. A list of symbols can be injected in data-masked dots with the splice operator \code{\link[=splice-operator]{!!!}}, which injects each element of the list as a separate argument. For instance, to implement a \code{group_by()} variant that takes a character vector of column names, you might write: \if{html}{\out{
}}\preformatted{my_group_by <- function(data, vars) \{ data \%>\% dplyr::group_by(!!!data_syms(vars)) \} my_group_by(vars) }\if{html}{\out{
}} In more complex case, you might want to add R code around the symbols. This requires \emph{transformation} patterns, see the section below. } } \section{Bridge patterns}{ \subsection{\code{mutate()} as a data-mask to selection bridge}{ This is a variant of the \code{transmute()} bridge pattern described in \ifelse{html}{\link[=topic-data-mask-programming]{Data mask programming patterns}}{\link[=topic-data-mask-programming]{Data mask programming patterns}} that does not materialise \code{...} in the intermediate step. Instead, the \code{...} expressions are defused and inspected. Then the expressions, rather than the columns, are spliced in \code{mutate()}. \if{html}{\out{
}}\preformatted{my_pivot_longer <- function(data, ...) \{ # Defuse the dots and inspect the names dots <- enquos(..., .named = TRUE) names <- names(dots) # Pass the inputs to `mutate()` data <- data \%>\% dplyr::mutate(!!!dots) # Select `...` inputs by name with `all_of()` data \%>\% tidyr::pivot_longer(cols = all_of(names)) \} mtcars \%>\% my_pivot_longer(cyl, am = am * 100) }\if{html}{\out{
}} \enumerate{ \item Defuse the \code{...} expressions. The \code{.named} argument ensures unnamed inputs get a default name, just like they would if passed to \code{mutate()}. Take the names of the list of inputs. \item Once we have the names, inject the argument expressions into \code{mutate()} to update the data frame. \item Finally, pass the names to the tidy selection via \href{https://tidyselect.r-lib.org/reference/all_of.html}{\code{all_of()}}. } } } \section{Transformation patterns}{ \subsection{Transforming inputs manually}{ If \code{across()} and variants are not available, you will need to transform the inputs yourself using metaprogramming techniques. To illustrate the technique we'll reimplement \code{my_mean()} and without using \code{across()}. The pattern consists in defusing the input expression, building larger calls around them, and finally inject the modified expressions inside the data-masking functions. We'll start with a single named argument for simplicity: \if{html}{\out{
}}\preformatted{my_mean <- function(data, var) \{ # Defuse the expression var <- enquo(var) # Wrap it in a call to `mean()` var <- expr(mean(!!var, na.rm = TRUE)) # Inject the expanded expression data \%>\% dplyr::summarise(mean = !!var) \} mtcars \%>\% my_mean(cyl) #> # A tibble: 1 x 1 #> mean #> #> 1 6.19 }\if{html}{\out{
}} With \code{...} the technique is similar, though a little more involved. We'll use the plural variants \code{enquos()} and \code{\link{!!!}}. We'll also loop over the variable number of inputs using \code{purrr::map()}. But the pattern is otherwise basically the same: \if{html}{\out{
}}\preformatted{my_mean <- function(.data, ...) \{ # Defuse the dots. Make sure they are automatically named. vars <- enquos(..., .named = TRUE) # Map over each defused expression and wrap it in a call to `mean()` vars <- purrr::map(vars, ~ expr(mean(!!.x, na.rm = TRUE))) # Inject the expressions .data \%>\% dplyr::summarise(!!!vars) \} mtcars \%>\% my_mean(cyl) #> # A tibble: 1 x 1 #> cyl #> #> 1 6.19 }\if{html}{\out{
}} Note that we are inheriting the data-masking behaviour of \code{summarise()} because we have effectively forwarded \code{...} inside that verb. This is different than transformation patterns based on \code{across()} which inherit tidy selection behaviour. In practice, this means the function doesn't support selection helpers and syntax. Instead, it gains the ability to create new vectors on the fly: \if{html}{\out{
}}\preformatted{mtcars \%>\% my_mean(cyl = cyl * 100) #> # A tibble: 1 x 1 #> cyl #> #> 1 619. }\if{html}{\out{
}} } } \section{Base patterns}{ In this section, we review patterns for programming with \emph{base} data-masking functions. They essentially consist in building and evaluating expressions in the data mask. We review these patterns and compare them to rlang idioms. \subsection{Data-masked \code{get()}}{ In the simplest version of this pattern, \code{get()} is called with a variable name to retrieve objects from the data mask: \if{html}{\out{
}}\preformatted{var <- "cyl" with(mtcars, mean(get(var))) #> [1] 6.1875 }\if{html}{\out{
}} This sort of pattern is susceptible to \link[=topic-data-mask-ambiguity]{names collisions}. For instance, the input data frame might contain a variable called \code{var}: \if{html}{\out{
}}\preformatted{df <- data.frame(var = "wrong") with(df, mean(get(var))) #> Error in `get()`: #> ! object 'wrong' not found }\if{html}{\out{
}} In general, prefer symbol injection over \code{get()} to prevent this sort of collisions. With base functions you will need to enable injection operators explicitly using \code{\link[=inject]{inject()}}: \if{html}{\out{
}}\preformatted{inject( with(mtcars, mean(!!sym(var))) ) #> [1] 6.1875 }\if{html}{\out{
}} See \ifelse{html}{\link[=topic-data-mask-ambiguity]{The data mask ambiguity}}{\link[=topic-data-mask-ambiguity]{The data mask ambiguity}} for more information about names collisions. } \subsection{Data-masked \code{parse()} and \code{eval()}}{ A more involved pattern consists in building R code in a string and evaluating it in the mask: \if{html}{\out{
}}\preformatted{var1 <- "am" var2 <- "vs" code <- paste(var1, "==", var2) with(mtcars, mean(eval(parse(text = code)))) #> [1] 0.59375 }\if{html}{\out{
}} As before, the \code{code} variable is vulnerable to \link[=topic-data-mask-ambiguity]{names collisions}. More importantly, if \code{var1} and \code{var2} are user inputs, they could contain \href{https://xkcd.com/327/}{adversarial code}. Evaluating code assembled from strings is always a risky business: \if{html}{\out{
}}\preformatted{var1 <- "(function() \{ Sys.sleep(Inf) # Could be a coin mining routine \})()" var2 <- "vs" code <- paste(var1, "==", var2) with(mtcars, mean(eval(parse(text = code)))) }\if{html}{\out{
}} This is not a big deal if your code is only used internally. However, this code could be part of a public Shiny app which Internet users could exploit. But even internally, parsing is a source of bugs when variable names contain syntactic symbols like \code{-} or \code{:}. \if{html}{\out{
}}\preformatted{var1 <- ":var:" var2 <- "vs" code <- paste(var1, "==", var2) with(mtcars, mean(eval(parse(text = code)))) #> Error in `parse()`: #> ! :1:1: unexpected ':' #> 1: : #> ^ }\if{html}{\out{
}} For these reasons, always prefer to \emph{build} code instead of parsing code. Building variable names with \code{\link[=sym]{sym()}} is a way of sanitising inputs. \if{html}{\out{
}}\preformatted{var1 <- "(function() \{ Sys.sleep(Inf) # Could be a coin mining routine \})()" var2 <- "vs" code <- call("==", sym(var1), sym(var2)) code #> `(function() \{\\n Sys.sleep(Inf) # Could be a coin mining routine\\n\})()` == #> vs }\if{html}{\out{
}} The adversarial input now produces an error: \if{html}{\out{
}}\preformatted{with(mtcars, mean(eval(code))) #> Error: #> ! object '(function() \{\\n Sys.sleep(Inf) # Could be a coin mining routine\\n\})()' not found }\if{html}{\out{
}} Finally, it is recommended to inject the code instead of evaluating it to avoid names collisions: \if{html}{\out{
}}\preformatted{var1 <- "am" var2 <- "vs" code <- call("==", sym(var1), sym(var2)) inject( with(mtcars, mean(!!code)) ) #> [1] 0.59375 }\if{html}{\out{
}} } } \keyword{internal} rlang/man/cnd_signal.Rd0000644000176200001440000000400014375670676014537 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cnd-signal.R \name{cnd_signal} \alias{cnd_signal} \title{Signal a condition object} \usage{ cnd_signal(cnd, ...) } \arguments{ \item{cnd}{A condition object (see \code{\link[=cnd]{cnd()}}). If \code{NULL}, \code{cnd_signal()} returns without signalling a condition.} \item{...}{These dots are for future extensions and must be empty.} } \description{ \code{cnd_signal()} takes a condition as argument and emits the corresponding signal. The type of signal depends on the class of the condition: \itemize{ \item A message is signalled if the condition inherits from \code{"message"}. This is equivalent to signalling with \code{\link[=inform]{inform()}} or \code{\link[base:message]{base::message()}}. \item A warning is signalled if the condition inherits from \code{"warning"}. This is equivalent to signalling with \code{\link[=warn]{warn()}} or \code{\link[base:warning]{base::warning()}}. \item An error is signalled if the condition inherits from \code{"error"}. This is equivalent to signalling with \code{\link[=abort]{abort()}} or \code{\link[base:stop]{base::stop()}}. \item An interrupt is signalled if the condition inherits from \code{"interrupt"}. This is equivalent to signalling with \code{\link[=interrupt]{interrupt()}}. } } \examples{ # The type of signal depends on the class. If the condition # inherits from "warning", a warning is issued: cnd <- warning_cnd("my_warning_class", message = "This is a warning") cnd_signal(cnd) # If it inherits from "error", an error is raised: cnd <- error_cnd("my_error_class", message = "This is an error") try(cnd_signal(cnd)) } \seealso{ \itemize{ \item \code{\link[=cnd_type]{cnd_type()}} to determine the type of a condition. \item \code{\link[=abort]{abort()}}, \code{\link[=warn]{warn()}} and \code{\link[=inform]{inform()}} for creating and signalling structured R conditions in one go. \item \code{\link[=try_fetch]{try_fetch()}} for establishing condition handlers for particular condition classes. } } rlang/man/quo_label.Rd0000644000176200001440000000542014376112150014363 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/quo.R \name{quo_label} \alias{quo_label} \alias{quo_text} \alias{quo_name} \title{Format quosures for printing or labelling} \usage{ quo_label(quo) quo_text(quo, width = 60L, nlines = Inf) quo_name(quo) } \arguments{ \item{quo}{A quosure or expression.} \item{width}{Width of each line.} \item{nlines}{Maximum number of lines to extract.} } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#superseded}{\figure{lifecycle-superseded.svg}{options: alt='[Superseded]'}}}{\strong{[Superseded]}} \strong{Note:} You should now use \code{\link[=as_label]{as_label()}} or \code{\link[=as_name]{as_name()}} instead of \code{quo_name()}. See life cycle section below. These functions take an arbitrary R object, typically an \link[=is_expression]{expression}, and represent it as a string. \itemize{ \item \code{quo_name()} returns an abbreviated representation of the object as a single line string. It is suitable for default names. \item \code{quo_text()} returns a multiline string. For instance block expressions like \code{{ foo; bar }} are represented on 4 lines (one for each symbol, and the curly braces on their own lines). } These deparsers are only suitable for creating default names or printing output at the console. The behaviour of your functions should not depend on deparsed objects. If you are looking for a way of transforming symbols to strings, use \code{\link[=as_string]{as_string()}} instead of \code{quo_name()}. Unlike deparsing, the transformation between symbols and strings is non-lossy and well defined. } \section{Life cycle}{ These functions are superseded. \itemize{ \item \code{\link[=as_label]{as_label()}} and \code{\link[=as_name]{as_name()}} should be used instead of \code{quo_name()}. \code{as_label()} transforms any R object to a string but should only be used to create a default name. Labelisation is not a well defined operation and no assumption should be made about the label. On the other hand, \code{as_name()} only works with (possibly quosured) symbols, but is a well defined and deterministic operation. \item We don't have a good replacement for \code{quo_text()} yet. See \url{https://github.com/r-lib/rlang/issues/636} to follow discussions about a new deparsing API. } } \examples{ # Quosures can contain nested quosures: quo <- quo(foo(!! quo(bar))) quo # quo_squash() unwraps all quosures and returns a raw expression: quo_squash(quo) # This is used by quo_text() and quo_label(): quo_text(quo) # Compare to the unwrapped expression: expr_text(quo) # quo_name() is helpful when you need really short labels: quo_name(quo(sym)) quo_name(quo(!! sym)) } \seealso{ \code{\link[=expr_label]{expr_label()}}, \code{\link[=f_label]{f_label()}} } \keyword{internal} rlang/man/env_parent.Rd0000644000176200001440000000415014137447476014601 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/env.R \name{env_parent} \alias{env_parent} \alias{env_tail} \alias{env_parents} \title{Get parent environments} \usage{ env_parent(env = caller_env(), n = 1) env_tail(env = caller_env(), last = global_env()) env_parents(env = caller_env(), last = global_env()) } \arguments{ \item{env}{An environment.} \item{n}{The number of generations to go up.} \item{last}{The environment at which to stop. Defaults to the global environment. The empty environment is always a stopping condition so it is safe to leave the default even when taking the tail or the parents of an environment on the search path. \code{env_tail()} returns the environment which has \code{last} as parent and \code{env_parents()} returns the list of environments up to \code{last}.} } \value{ An environment for \code{env_parent()} and \code{env_tail()}, a list of environments for \code{env_parents()}. } \description{ \itemize{ \item \code{env_parent()} returns the parent environment of \code{env} if called with \code{n = 1}, the grandparent with \code{n = 2}, etc. \item \code{env_tail()} searches through the parents and returns the one which has \code{\link[=empty_env]{empty_env()}} as parent. \item \code{env_parents()} returns the list of all parents, including the empty environment. This list is named using \code{\link[=env_name]{env_name()}}. } See the section on \emph{inheritance} in \code{\link[=env]{env()}}'s documentation. } \examples{ # Get the parent environment with env_parent(): env_parent(global_env()) # Or the tail environment with env_tail(): env_tail(global_env()) # By default, env_parent() returns the parent environment of the # current evaluation frame. If called at top-level (the global # frame), the following two expressions are equivalent: env_parent() env_parent(base_env()) # This default is more handy when called within a function. In this # case, the enclosure environment of the function is returned # (since it is the parent of the evaluation frame): enclos_env <- env() fn <- set_env(function() env_parent(), enclos_env) identical(enclos_env, fn()) } rlang/man/child_env.Rd0000644000176200001440000000076514376112150014362 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/lifecycle-deprecated.R \name{child_env} \alias{child_env} \title{Create a child environment} \usage{ child_env(.parent, ...) } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} \code{\link[=env]{env()}} now supports creating child environments, please use it instead. } \keyword{internal} rlang/man/type-predicates.Rd0000644000176200001440000000334114626342040015523 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/types.R \name{type-predicates} \alias{type-predicates} \alias{is_list} \alias{is_atomic} \alias{is_vector} \alias{is_integer} \alias{is_double} \alias{is_complex} \alias{is_character} \alias{is_logical} \alias{is_raw} \alias{is_bytes} \alias{is_null} \title{Type predicates} \usage{ is_list(x, n = NULL) is_atomic(x, n = NULL) is_vector(x, n = NULL) is_integer(x, n = NULL) is_double(x, n = NULL, finite = NULL) is_complex(x, n = NULL, finite = NULL) is_character(x, n = NULL) is_logical(x, n = NULL) is_raw(x, n = NULL) is_bytes(x, n = NULL) is_null(x) } \arguments{ \item{x}{Object to be tested.} \item{n}{Expected length of a vector.} \item{finite}{Whether all values of the vector are finite. The non-finite values are \code{NA}, \code{Inf}, \code{-Inf} and \code{NaN}. Setting this to something other than \code{NULL} can be expensive because the whole vector needs to be traversed and checked.} } \description{ These type predicates aim to make type testing in R more consistent. They are wrappers around \code{\link[base:typeof]{base::typeof()}}, so operate at a level beneath S3/S4 etc. } \details{ Compared to base R functions: \itemize{ \item The predicates for vectors include the \code{n} argument for pattern-matching on the vector length. \item Unlike \code{is.atomic()} in R < 4.4.0, \code{is_atomic()} does not return \code{TRUE} for \code{NULL}. Starting in R 4.4.0 \code{is.atomic(NULL)} returns FALSE. \item Unlike \code{is.vector()}, \code{is_vector()} tests if an object is an atomic vector or a list. \code{is.vector} checks for the presence of attributes (other than name). } } \seealso{ \link{bare-type-predicates} \link{scalar-type-predicates} } rlang/man/op-get-attr.Rd0000644000176200001440000000147214127057575014603 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/operators.R \name{op-get-attr} \alias{op-get-attr} \alias{\%@\%} \alias{\%@\%<-} \title{Infix attribute accessor and setter} \usage{ x \%@\% name x \%@\% name <- value } \arguments{ \item{x}{Object} \item{name}{Attribute name} \item{value}{New value for attribute \code{name}.} } \description{ This operator extracts or sets attributes for regular objects and S4 fields for S4 objects. } \examples{ # Unlike `@`, this operator extracts attributes for any kind of # objects: factor(1:3) \%@\% "levels" mtcars \%@\% class mtcars \%@\% class <- NULL mtcars # It also works on S4 objects: .Person <- setClass("Person", slots = c(name = "character", species = "character")) fievel <- .Person(name = "Fievel", species = "mouse") fievel \%@\% name } rlang/man/cnd_muffle.Rd0000644000176200001440000000544414127057575014545 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cnd-handlers.R \name{cnd_muffle} \alias{cnd_muffle} \title{Muffle a condition} \usage{ cnd_muffle(cnd) } \arguments{ \item{cnd}{A condition to muffle.} } \value{ If \code{cnd} is mufflable, \code{cnd_muffle()} jumps to the muffle restart and doesn't return. Otherwise, it returns \code{FALSE}. } \description{ Unlike \code{\link[=exiting]{exiting()}} handlers, \code{\link[=calling]{calling()}} handlers must be explicit that they have handled a condition to stop it from propagating to other handlers. Use \code{cnd_muffle()} within a calling handler (or as a calling handler, see examples) to prevent any other handlers from being called for that condition. } \section{Mufflable conditions}{ Most conditions signalled by base R are muffable, although the name of the restart varies. cnd_muffle() will automatically call the correct restart for you. It is compatible with the following conditions: \itemize{ \item \code{warning} and \code{message} conditions. In this case \code{cnd_muffle()} is equivalent to \code{\link[base:message]{base::suppressMessages()}} and \code{\link[base:warning]{base::suppressWarnings()}}. \item Bare conditions signalled with \code{signal()} or \code{\link[=cnd_signal]{cnd_signal()}}. Note that conditions signalled with \code{\link[base:conditions]{base::signalCondition()}} are not mufflable. \item Interrupts are sometimes signalled with a \code{resume} restart on recent R versions. When this is the case, you can muffle the interrupt with \code{cnd_muffle()}. Check if a restart is available with \code{base::findRestart("resume")}. } If you call \code{cnd_muffle()} with a condition that is not mufflable you will cause a new error to be signalled. \itemize{ \item Errors are not mufflable since they are signalled in critical situations where execution cannot continue safely. \item Conditions captured with \code{\link[base:conditions]{base::tryCatch()}}, \code{\link[=with_handlers]{with_handlers()}} or \code{\link[=catch_cnd]{catch_cnd()}} are no longer mufflable. Muffling restarts \emph{must} be called from a \link{calling} handler. } } \examples{ fn <- function() { inform("Beware!", "my_particular_msg") inform("On your guard!") "foobar" } # Let's install a muffling handler for the condition thrown by `fn()`. # This will suppress all `my_particular_wng` warnings but let other # types of warnings go through: with_handlers(fn(), my_particular_msg = calling(function(cnd) { inform("Dealt with this particular message") cnd_muffle(cnd) }) ) # Note how execution of `fn()` continued normally after dealing # with that particular message. # cnd_muffle() can also be passed to with_handlers() as a calling # handler: with_handlers(fn(), my_particular_msg = calling(cnd_muffle) ) } \keyword{internal} rlang/man/is_function.Rd0000644000176200001440000000770514375670676014775 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/fn.R \name{is_function} \alias{is_function} \alias{is_closure} \alias{is_primitive} \alias{is_primitive_eager} \alias{is_primitive_lazy} \title{Is object a function?} \usage{ is_function(x) is_closure(x) is_primitive(x) is_primitive_eager(x) is_primitive_lazy(x) } \arguments{ \item{x}{Object to be tested.} } \description{ The R language defines two different types of functions: primitive functions, which are low-level, and closures, which are the regular kind of functions. } \details{ Closures are functions written in R, named after the way their arguments are scoped within nested environments (see \url{https://en.wikipedia.org/wiki/Closure_(computer_programming)}). The root environment of the closure is called the closure environment. When closures are evaluated, a new environment called the evaluation frame is created with the closure environment as parent. This is where the body of the closure is evaluated. These closure frames appear on the evaluation stack, as opposed to primitive functions which do not necessarily have their own evaluation frame and never appear on the stack. Primitive functions are more efficient than closures for two reasons. First, they are written entirely in fast low-level code. Second, the mechanism by which they are passed arguments is more efficient because they often do not need the full procedure of argument matching (dealing with positional versus named arguments, partial matching, etc). One practical consequence of the special way in which primitives are passed arguments is that they technically do not have formal arguments, and \code{\link[=formals]{formals()}} will return \code{NULL} if called on a primitive function. Finally, primitive functions can either take arguments lazily, like R closures do, or evaluate them eagerly before being passed on to the C code. The former kind of primitives are called "special" in R terminology, while the latter is referred to as "builtin". \code{is_primitive_eager()} and \code{is_primitive_lazy()} allow you to check whether a primitive function evaluates arguments eagerly or lazily. You will also encounter the distinction between primitive and internal functions in technical documentation. Like primitive functions, internal functions are defined at a low level and written in C. However, internal functions have no representation in the R language. Instead, they are called via a call to \code{\link[base:Internal]{base::.Internal()}} within a regular closure. This ensures that they appear as normal R function objects: they obey all the usual rules of argument passing, and they appear on the evaluation stack as any other closures. As a result, \code{\link[=fn_fmls]{fn_fmls()}} does not need to look in the \code{.ArgsEnv} environment to obtain a representation of their arguments, and there is no way of querying from R whether they are lazy ('special' in R terminology) or eager ('builtin'). You can call primitive functions with \code{\link[=.Primitive]{.Primitive()}} and internal functions with \code{\link[=.Internal]{.Internal()}}. However, calling internal functions in a package is forbidden by CRAN's policy because they are considered part of the private API. They often assume that they have been called with correctly formed arguments, and may cause R to crash if you call them with unexpected objects. } \examples{ # Primitive functions are not closures: is_closure(base::c) is_primitive(base::c) # On the other hand, internal functions are wrapped in a closure # and appear as such from the R side: is_closure(base::eval) # Both closures and primitives are functions: is_function(base::c) is_function(base::eval) # Many primitive functions evaluate arguments eagerly: is_primitive_eager(base::c) is_primitive_eager(base::list) is_primitive_eager(base::`+`) # However, primitives that operate on expressions, like quote() or # substitute(), are lazy: is_primitive_lazy(base::quote) is_primitive_lazy(base::substitute) } rlang/man/new_quosure.Rd0000644000176200001440000000357314375670676015030 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/quo.R \name{new_quosure} \alias{new_quosure} \alias{as_quosure} \alias{is_quosure} \title{Create a quosure from components} \usage{ new_quosure(expr, env = caller_env()) as_quosure(x, env = NULL) is_quosure(x) } \arguments{ \item{expr}{An expression to wrap in a quosure.} \item{env}{The environment in which the expression should be evaluated. Only used for symbols and calls. This should normally be the environment in which the expression was created.} \item{x}{An object to test.} } \description{ \itemize{ \item \code{new_quosure()} wraps any R object (including expressions, formulas, or other quosures) into a \link[=topic-quosure]{quosure}. \item \code{as_quosure()} is similar but it does not rewrap formulas and quosures. } } \examples{ # `new_quosure()` creates a quosure from its components. These are # equivalent: new_quosure(quote(foo), current_env()) quo(foo) # `new_quosure()` always rewraps its input into a new quosure, even # if the input is itself a quosure: new_quosure(quo(foo)) # This is unlike `as_quosure()` which preserves its input if it's # already a quosure: as_quosure(quo(foo)) # `as_quosure()` uses the supplied environment with naked expressions: env <- env(var = "thing") as_quosure(quote(var), env) # If the expression already carries an environment, this # environment is preserved. This is the case for formulas and # quosures: as_quosure(~foo, env) as_quosure(~foo) # An environment must be supplied when the input is a naked # expression: try( as_quosure(quote(var)) ) } \seealso{ \itemize{ \item \code{\link[=enquo]{enquo()}} and \code{\link[=quo]{quo()}} for creating a quosure by \link[=topic-defuse]{argument defusal}. \item \ifelse{html}{\link[=topic-quosure]{What are quosures and when are they needed?}}{\link[=topic-quosure]{What are quosures and when are they needed?}} } } rlang/man/rmd/0000755000176200001440000000000014741441423012716 5ustar liggesusersrlang/man/rmd/topic-data-mask.Rmd0000644000176200001440000001561514375670676016371 0ustar liggesusers```{r, child = "setup.Rmd", include = FALSE} ``` Data-masking is a distinctive feature of R whereby programming is performed directly on a data set, with columns defined as normal objects. ```{r, comment = "#>", collapse = TRUE, error = TRUE} # Unmasked programming mean(mtcars$cyl + mtcars$am) # Referring to columns is an error - Where is the data? mean(cyl + am) # Data-masking with(mtcars, mean(cyl + am)) ``` While data-masking makes it easy to program interactively with data frames, it makes it harder to create functions. Passing data-masked arguments to functions requires injection with the embracing operator `r link("{{")` or, in more complex cases, the injection operator [`!!`]. # Why does data-masking require embracing and injection? Injection (also known as quasiquotation) is a metaprogramming feature that allows you to modify parts of a program. This is needed because under the hood data-masking works by [defusing][topic-defuse] R code to prevent its immediate evaluation. The defused code is resumed later on in a context where data frame columns are defined. Let's see what happens when we pass arguments to a data-masking function like `summarise()` in the normal way: ```{r, comment = "#>", collapse = TRUE, error = TRUE} my_mean <- function(data, var1, var2) { dplyr::summarise(data, mean(var1 + var2)) } my_mean(mtcars, cyl, am) ``` The problem here is that `summarise()` defuses the R code it was supplied, i.e. `mean(var1 + var2)`. Instead we want it to see `mean(cyl + am)`. This is why we need injection, we need to modify that piece of code by injecting the code supplied to the function in place of `var1` and `var2`. To inject a function argument in data-masked context, just embrace it with `{{`: ```{r, comment = "#>", collapse = TRUE} my_mean <- function(data, var1, var2) { dplyr::summarise(data, mean({{ var1 }} + {{ var2 }})) } my_mean(mtcars, cyl, am) ``` See `r link("topic_data_mask_programming")` to learn more about creating functions around data-masking functions. # What does "masking" mean? In normal R programming objects are defined in the current environment, for instance in the global environment or the environment of a function. ```{r, comment = "#>", collapse = TRUE} factor <- 1000 # Can now use `factor` in computations mean(mtcars$cyl * factor) ``` This environment also contains all functions currently in scope. In a script this includes the functions attached with `library()` calls; in a package, the functions imported from other packages. If evaluation was performed only in the data frame, we'd lose track of these objects and functions necessary to perform computations. To keep these objects and functions in scope, the data frame is inserted at the bottom of the current chain of environments. It comes first and has precedence over the user environment. In other words, it _masks_ the user environment. Since masking blends the data and the user environment by giving priority to the former, R can sometimes use a data frame column when you really intended to use a local object. ```{r, comment = "#>", collapse = TRUE} # Defining an env-variable cyl <- 1000 # Referring to a data-variable dplyr::summarise(mtcars, mean(cyl)) ``` The tidy eval framework provides [pronouns][.data] to help disambiguate between the mask and user contexts. It is often a good idea to use these pronouns in production code. ```{r, comment = "#>", collapse = TRUE} cyl <- 1000 mtcars %>% dplyr::summarise( mean_data = mean(.data$cyl), mean_env = mean(.env$cyl) ) ``` Read more about this in `r link("topic_data_mask_ambiguity")`. # How does data-masking work? Data-masking relies on three language features: - [Argument defusal][topic-defuse] with [substitute()] (base R) or [enquo()], [enquos()], and `r link("{{")` (rlang). R code is defused so it can be evaluated later on in a special environment enriched with data. - First class environments. Environments are a special type of list-like object in which defused R code can be evaluated. The named elements in an environment define objects. Lists and data frames can be transformed to environments: ```r as.environment(mtcars) #> ``` - Explicit evaluation with [eval()] (base) or [eval_tidy()] (rlang). When R code is defused, evaluation is interrupted. It can be resumed later on with [eval()]: ```{r, comment = "#>", collapse = TRUE} expr(1 + 1) eval(expr(1 + 1)) ``` By default `eval()` and `eval_tidy()` evaluate in the current environment. ```{r, comment = "#>", collapse = TRUE, error = TRUE} code <- expr(mean(cyl + am)) eval(code) ``` You can supply an optional list or data frame that will be converted to an environment. ```{r, comment = "#>", collapse = TRUE} eval(code, mtcars) ``` Evaluation of defused code then occurs in the context of a data mask. # History The tidyverse embraced the data-masking approach in packages like ggplot2 and dplyr and eventually developed its own programming framework in the rlang package. None of this would have been possible without the following landmark developments from S and R authors. - The S language introduced data scopes with [attach()] (Becker, Chambers and Wilks, The New S Language, 1988). - The S language introduced data-masked formulas in modelling functions (Chambers and Hastie, 1993). - Peter Dalgaard (R team) wrote the frametools package in 1997. It was later included in R as [base::transform()] and [base::subset()]. This API is an important source of inspiration for the dplyr package. It was also the first apparition of _selections_, a variant of data-masking extended and codified later on in the [tidyselect package](https://tidyselect.r-lib.org/articles/syntax.html). - In 2000 Luke Tierney (R team) [changed formulas](https://github.com/wch/r-source/commit/a945ac8e) to keep track of their original environments. This change published in R 1.1.0 was a crucial step towards hygienic data masking, i.e. the proper resolution of symbols in their original environments. Quosures were inspired by the environment-tracking mechanism of formulas. - Luke introduced [base::with()] in 2001. - In 2006 the [data.table package](https://r-datatable.com) included data-masking and selections in the `i` and `j` arguments of the `[` method of a data frame. - The [dplyr package](https://dplyr.tidyverse.org/) was published in 2014. - The rlang package developed tidy eval in 2017 as the data-masking framework of the tidyverse. It introduced the notions of [quosure][topic-quosure], [implicit injection][topic-inject] with `!!` and `!!!`, and [data pronouns][.data]. - In 2019, injection with `{{` was introduced in [rlang 0.4.0](https://www.tidyverse.org/blog/2019/06/rlang-0-4-0/) to simplify the defuse-and-inject pattern. This operator allows R programmers to transport data-masked arguments across functions more intuitively and with minimal boilerplate. # See also * `r link("topic_data_mask_programming")` * `r link("topic_defuse")` rlang/man/rmd/topic-quosure.Rmd0000644000176200001440000001744014375670676016230 0ustar liggesusers```{r, child = "setup.Rmd", include = FALSE} ``` A quosure is a special type of [defused expression][topic-defuse] that keeps track of the original context the expression was written in. The tracking capabilities of quosures is important when interfacing [data-masking][topic-data-mask] functions together because the functions might come from two unrelated environments, like two different packages. # Blending environments Let's take an example where the R user calls the function `summarise_bmi()` from the foo package to summarise a data frame with statistics of a BMI value. Because the `height` variable of their data frame is not in metres, they use a custom function `div100()` to rescale the column. ```r # Global environment of user div100 <- function(x) { x / 100 } dplyr::starwars %>% foo::summarise_bmi(mass, div100(height)) ``` The `summarise_bmi()` function is a data-masking function defined in the namespace of the foo package which looks like this: ```r # Namespace of package foo bmi <- function(mass, height) { mass / height^2 } summarise_bmi <- function(data, mass, height) { data %>% bar::summarise_stats(bmi({{ mass }}, {{ height }})) } ``` The foo package uses the custom function `bmi()` to perform a computation on two vectors. It interfaces with `summarise_stats()` defined in bar, another package whose namespace looks like this: ```r # Namespace of package bar check_numeric <- function(x) { stopifnot(is.numeric(x)) x } summarise_stats <- function(data, var) { data %>% dplyr::transmute( var = check_numeric({{ var }}) ) %>% dplyr::summarise( mean = mean(var, na.rm = TRUE), sd = sd(var, na.rm = TRUE) ) } ``` Again the package bar uses a custom function, `check_numeric()`, to validate its input. It also interfaces with data-masking functions from dplyr (using the [define-a-constant][topic-double-evaluation] trick to avoid issues of double evaluation). There are three data-masking functions simultaneously interfacing in this snippet: - At the bottom, `dplyr::transmute()` takes a data-masked input, and creates a data frame of a single column named `var`. - Before this, `bar::summarise_stats()` takes a data-masked input inside `dplyr::transmute()` and checks it is numeric. - And first of all, `foo::summarise_bmi()` takes two data-masked inputs inside `bar::summarise_stats()` and transforms them to a single BMI value. There is a fourth context, the global environment where `summarise_bmi()` is called with two columns defined in a data frame, one of which is transformed on the fly with the user function `div100()`. All of these contexts (except to some extent the global environment) contain functions that are private and invisible to foreign functions. Yet, the final expanded data-masked expression that is evaluated down the line looks like this (with caret characters indicating the quosure boundaries): ```r dplyr::transmute( var = ^check_numeric(^bmi(^mass, ^div100(height))) ) ``` The role of quosures is to let R know that `check_numeric()` should be found in the bar package, `bmi()` in the foo package, and `div100()` in the global environment. # When should I create quosures? As a tidyverse user you generally don't need to worry about quosures because `{{` and `...` will create them for you. Introductory texts like [Programming with dplyr](https://dplyr.tidyverse.org/articles/programming.html) or the [standard data-mask programming patterns][topic-data-mask-programming] don't even mention the term. In more complex cases you might need to create quosures with [enquo()] or [enquos()] (even though you generally don't need to know or care that these functions return quosures). In this section, we explore when quosures are necessary in these more advanced applications. ## Foreign and local expressions As a rule of thumb, quosures are only needed for arguments defused with [enquo()] or [enquos()] (or with `r link("{{")` which calls `enquo()` implicitly): ```r my_function <- function(var) { var <- enquo(var) their_function(!!var) } # Equivalently my_function <- function(var) { their_function({{ var }}) } ``` Wrapping defused arguments in quosures is needed because expressions supplied as argument comes from a different environment, the environment of your user. For local expressions created in your function, you generally don't need to create quosures: ```{r, comment = "#>", collapse = TRUE} my_mean <- function(data, var) { # `expr()` is sufficient, no need for `quo()` expr <- expr(mean({{ var }})) dplyr::summarise(data, !!expr) } my_mean(mtcars, cyl) ``` Using [quo()] instead of [expr()] would have worked too but it is superfluous because `dplyr::summarise()`, which uses [enquos()], is already in charge of wrapping your expression within a quosure scoped in your environment. The same applies if you evaluate manually. By default, [eval()] and [eval_tidy()] capture your environment: ```{r, comment = "#>", collapse = TRUE} my_mean <- function(data, var) { expr <- expr(mean({{ var }})) eval_tidy(expr, data) } my_mean(mtcars, cyl) ``` ## External defusing An exception to this rule of thumb (wrap foreign expressions in quosures, not your own expressions) arises when your function takes multiple expressions in a list instead of `...`. The preferred approach in that case is to take a tidy selection so that users can combine multiple columns using `c()`. If that is not possible, you can take a list of externally defused expressions: ```r my_group_by <- function(data, vars) { stopifnot(is_quosures(vars)) data %>% dplyr::group_by(!!!vars) } mtcars %>% my_group_by(dplyr::vars(cyl, am)) ``` In this pattern, `dplyr::vars()` defuses expressions externally. It creates a list of quosures because the expressions are passed around from function to function like regular arguments. In fact, `dplyr::vars()` and `ggplot2::vars()` are simple aliases of [quos()]. ```r dplyr::vars(cyl, am) #> > #> #> [[1]] #> #> expr: ^cyl #> env: global #> #> [[2]] #> #> expr: ^am #> env: global ``` For more information about external defusing, see `r link("topic_multiple_columns")`. # Technical description of quosures A quosure carries two things: - An expression (get it with [quo_get_expr()]). - An environment (get it with [quo_get_env()]). And implements these behaviours: - It is _callable_. Evaluation produces a result. For historical reasons, [base::eval()] doesn't support quosure evaluation. Quosures currently require [eval_tidy()]. We would like to fix this limitation in the future. - It is _hygienic_. It evaluates in the tracked environment. - It is _maskable_. If evaluated in a data mask (currently only masks created with [eval_tidy()] or [new_data_mask()]), the mask comes first in scope before the quosure environment. Conceptually, a quosure inherits from two chains of environments, the data mask and the user environment. In practice rlang implements this special scoping by rechaining the top of the data mask to the quosure environment currently under evaluation. There are similarities between promises (the ones R uses to implement lazy evaluation, not the async expressions from the promises package) and quosures. One important difference is that promises are only evaluated once and cache the result for subsequent evaluation. Quosures behave more like calls and can be evaluated repeatedly, potentially in a different data mask. This property is useful to implement split-apply-combine evaluations. # See also - [enquo()] and [enquos()] to defuse function arguments as quosures. This is the main way quosures are created. - [quo()] which is like [expr()] but wraps in a quosure. Usually it is not needed to wrap local expressions yourself. - [quo_get_expr()] and [quo_get_env()] to access quosure components. - [new_quosure()] and [as_quosure()] to assemble a quosure from components. rlang/man/rmd/topic-data-mask-programming.Rmd0000644000176200001440000003260214610374512020662 0ustar liggesusers```{r, child = "setup.Rmd", include = FALSE} ``` [Data-masking][topic-data-mask] functions require special programming patterns when used inside other functions. In this topic we'll review and compare the different patterns that can be used to solve specific problems. If you are a beginner, you might want to start with one of these tutorials: - [Programming with dplyr](https://dplyr.tidyverse.org/articles/programming.html) - [Using ggplot2 in packages](https://ggplot2.tidyverse.org/articles/ggplot2-in-packages.html) If you'd like to go further and learn about defusing and injecting expressions, read the [metaprogramming patterns topic][topic-metaprogramming]. # Choosing a pattern Two main considerations determine which programming pattern you need to wrap a data-masking function: 1. What behaviour does the _wrapped_ function implement? 2. What behaviour should _your_ function implement? Depending on the answers to these questions, you can choose between these approaches: - The __forwarding patterns__ with which your function inherits the behaviour of the function it interfaces with. - The __name patterns__ with which your function takes strings or character vectors of column names. - The __bridge patterns__ with which you change the behaviour of an argument instead of inheriting it. You will also need to use different solutions for single named arguments than for multiple arguments in `...`. # Argument behaviours In a regular function, arguments can be defined in terms of a _type_ of objects that they accept. An argument might accept a character vector, a data frame, a single logical value, etc. Data-masked arguments are more complex. Not only do they generally accept a specific type of objects (for instance `dplyr::mutate()` accepts vectors), they exhibit special computational behaviours. - Data-masked expressions (base): E.g. [transform()], [with()]. Expressions may refer to the columns of the supplied data frame. - Data-masked expressions (tidy eval): E.g. `dplyr::mutate()`, `ggplot2::aes()`. Same as base data-masking but with tidy eval features enabled. This includes [injection operators][topic-inject] such as `r link("{{")` and [`!!`][injection-operator] and the [`.data`] and [`.env`] pronouns. - Data-masked symbols: Same as data-masked arguments but the supplied expressions must be simple column names. This often simplifies things, for instance this is an easy way of avoiding issues of [double evaluation][topic-double-evaluation]. - [Tidy selections](https://tidyselect.r-lib.org/reference/language.html): E.g. `dplyr::select()`, `tidyr::pivot_longer()`. This is an alternative to data masking that supports selection helpers like `starts_with()` or `all_of()`, and implements special behaviour for operators like `c()`, `|` and `&`. Unlike data masking, tidy selection is an interpreted dialect. There is in fact no masking at all. Expressions are either interpreted in the context of the data frame (e.g. `c(cyl, am)` which stands for the union of the columns `cyl` and `am`), or evaluated in the user environment (e.g. `all_of()`, `starts_with()`, and any other expressions). This has implications for inheritance of argument behaviour as we will see below. - [Dynamic dots][doc_dots_dynamic]: These may be data-masked arguments, tidy selections, or just regular arguments. Dynamic dots support injection of multiple arguments with the [`!!!`][splice-operator] operator as well as name injection with [glue][glue-operators] operators. To let users know about the capabilities of your function arguments, document them with the following tags, depending on which set of semantics they inherit from: ``` @param foo <[`data-masked`][dplyr::dplyr_data_masking]> What `foo` does. @param bar <[`tidy-select`][dplyr::dplyr_tidy_select]> What `bar` does. @param ... <[`dynamic-dots`][rlang::dyn-dots]> What these dots do. ``` # Forwarding patterns With the forwarding patterns, arguments inherit the behaviour of the data-masked arguments they are passed in. ## Embrace with `{{` The embrace operator `r link("{{")` is a forwarding syntax for single arguments. You can forward an argument in data-masked context: ```r my_summarise <- function(data, var) { data %>% dplyr::summarise({{ var }}) } ``` Or in tidyselections: ```r my_pivot_longer <- function(data, var) { data %>% tidyr::pivot_longer(cols = {{ var }}) } ``` The function automatically inherits the behaviour of the surrounding context. For instance arguments forwarded to a data-masked context may refer to columns or use the [`.data`] pronoun: ```r mtcars %>% my_summarise(mean(cyl)) x <- "cyl" mtcars %>% my_summarise(mean(.data[[x]])) ``` And arguments forwarded to a tidy selection may use all tidyselect features: ```r mtcars %>% my_pivot_longer(cyl) mtcars %>% my_pivot_longer(vs:gear) mtcars %>% my_pivot_longer(starts_with("c")) x <- c("cyl", "am") mtcars %>% my_pivot_longer(all_of(x)) ``` ## Forward `...` Simple forwarding of `...` arguments does not require any special syntax since dots are already a forwarding syntax. Just pass them to another function like you normally would. This works with data-masked arguments: ```r my_group_by <- function(.data, ...) { .data %>% dplyr::group_by(...) } mtcars %>% my_group_by(cyl = cyl * 100, am) ``` As well as tidy selections: ```r my_select <- function(.data, ...) { .data %>% dplyr::select(...) } mtcars %>% my_select(starts_with("c"), vs:carb) ``` Some functions take a tidy selection in a single named argument. In that case, pass the `...` inside `c()`: ```r my_pivot_longer <- function(.data, ...) { .data %>% tidyr::pivot_longer(c(...)) } mtcars %>% my_pivot_longer(starts_with("c"), vs:carb) ``` Inside a tidy selection, `c()` is not a vector concatenator but a selection combinator. This makes it handy to interface between functions that take `...` and functions that take a single argument. # Names patterns With the names patterns you refer to columns by name with strings or character vectors stored in env-variables. Whereas the forwarding patterns are exclusively used within a function to pass _arguments_, the names patterns can be used anywhere. - In a script, you can loop over a character vector with `for` or `lapply()` and use the [`.data`] pattern to connect a name to its data-variable. A vector can also be supplied all at once to the tidy select helper `all_of()`. - In a function, using the names patterns on function arguments lets users supply regular data-variable names without any of the complications that come with data-masking. ## Subsetting the `.data` pronoun The [`.data`] pronoun is a tidy eval feature that is enabled in all data-masked arguments, just like `r link("{{")`. The pronoun represents the data mask and can be subsetted with `[[` and `$`. These three statements are equivalent: ```r mtcars %>% dplyr::summarise(mean = mean(cyl)) mtcars %>% dplyr::summarise(mean = mean(.data$cyl)) var <- "cyl" mtcars %>% dplyr::summarise(mean = mean(.data[[var]])) ``` The `.data` pronoun can be subsetted in loops: ```{r, comment = "#>", collapse = TRUE} vars <- c("cyl", "am") for (var in vars) print(dplyr::summarise(mtcars, mean = mean(.data[[var]]))) purrr::map(vars, ~ dplyr::summarise(mtcars, mean = mean(.data[[.x]]))) ``` And it can be used to connect function arguments to a data-variable: ```{r, comment = "#>", collapse = TRUE} my_mean <- function(data, var) { data %>% dplyr::summarise(mean = mean(.data[[var]])) } my_mean(mtcars, "cyl") ``` With this implementation, `my_mean()` is completely insulated from data-masking behaviour and is called like an ordinary function. ```{r, comment = "#>", collapse = TRUE} # No masking am <- "cyl" my_mean(mtcars, am) # Programmable my_mean(mtcars, tolower("CYL")) ``` ## Character vector of names The `.data` pronoun can only be subsetted with single column names. It doesn't support single-bracket indexing: ```{r, comment = "#>", collapse = TRUE, error = TRUE} mtcars %>% dplyr::summarise(.data[c("cyl", "am")]) ``` There is no plural variant of `.data` built in tidy eval. Instead, we'll used the `all_of()` operator available in tidy selections to supply character vectors. This is straightforward in functions that take tidy selections, like `tidyr::pivot_longer()`: ```{r, comment = "#>", collapse = TRUE} vars <- c("cyl", "am") mtcars %>% tidyr::pivot_longer(all_of(vars)) ``` If the function does not take a tidy selection, it might be possible to use a _bridge pattern_. This option is presented in the bridge section below. If a bridge is impossible or inconvenient, a little metaprogramming with the [symbolise-and-inject pattern][topic-metaprogramming] can help. # Bridge patterns Sometimes the function you are calling does not implement the behaviour you would like to give to the arguments of your function. To work around this may require a little thought since there is no systematic way of turning one behaviour into another. The general technique consists in forwarding the arguments inside a context that implements the behaviour that you want. Then, find a way to bridge the result to the target verb or function. ## `across()` as a selection to data-mask bridge dplyr 1.0 added support for tidy selections in all verbs via `across()`. This function is normally used for mapping over columns but can also be used to perform a simple selection. For instance, if you'd like to pass an argument to `group_by()` with a tidy-selection interface instead of a data-masked one, use `across()` as a bridge: ```r my_group_by <- function(data, var) { data %>% dplyr::group_by(across({{ var }})) } mtcars %>% my_group_by(starts_with("c")) ``` Since `across()` takes selections in a single argument (unlike `select()` which takes multiple arguments), you can't directly pass `...`. Instead, take them within `c()`, which is the tidyselect way of supplying multiple selections within a single argument: ```r my_group_by <- function(.data, ...) { .data %>% dplyr::group_by(across(c(...))) } mtcars %>% my_group_by(starts_with("c"), vs:gear) ``` ## `across(all_of())` as a names to data mask bridge If instead of forwarding variables in `across()` you pass them to `all_of()`, you create a names to data mask bridge. ```r my_group_by <- function(data, vars) { data %>% dplyr::group_by(across(all_of(vars))) } mtcars %>% my_group_by(c("cyl", "am")) ``` Use this bridge technique to connect vectors of names to a data-masked context. ## `transmute()` as a data-mask to selection bridge Passing data-masked arguments to a tidy selection is a little more tricky and requires a three step process. ```r my_pivot_longer <- function(data, ...) { # Forward `...` in data-mask context with `transmute()` # and save the inputs names inputs <- dplyr::transmute(data, ...) names <- names(inputs) # Update the data with the inputs data <- dplyr::mutate(data, !!!inputs) # Select the inputs by name with `all_of()` tidyr::pivot_longer(data, cols = all_of(names)) } mtcars %>% my_pivot_longer(cyl, am = am * 100) ``` 1. In a first step we pass the `...` expressions to `transmute()`. Unlike `mutate()`, it creates a new data frame from the user inputs. The only goal of this step is to inspect the names in `...`, including the default names created for unnamed arguments. 2. Once we have the names, we inject the arguments into `mutate()` to update the data frame. 3. Finally, we pass the names to the tidy selection via [`all_of()`](https://tidyselect.r-lib.org/reference/all_of.html). # Transformation patterns ## Named inputs versus `...` In the case of a named argument, transformation is easy. We simply surround the embraced input in R code. For instance, the `my_summarise()` function is not exactly useful compared to just calling `summarise()`: ```r my_summarise <- function(data, var) { data %>% dplyr::summarise({{ var }}) } ``` We can make it more useful by adding code around the variable: ```r my_mean <- function(data, var) { data %>% dplyr::summarise(mean = mean({{ var }}, na.rm = TRUE)) } ``` For inputs in `...` however, this technique does not work. We would need some kind of templating syntax for dots that lets us specify R code with a placeholder for the dots elements. This isn't built in tidy eval but you can use operators like `dplyr::across()`, `dplyr::if_all()`, or `dplyr::if_any()`. When that isn't possible, you can template the expression manually. ## Transforming inputs with `across()` The `across()` operation in dplyr is a convenient way of mapping an expression across a set of inputs. We will create a variant of `my_mean()` that computes the `mean()` of all arguments supplied in `...`. The easiest way it to forward the dots to `across()` (which causes `...` to inherit its tidy selection behaviour): ```{r, comment = "#>", collapse = TRUE} my_mean <- function(data, ...) { data %>% dplyr::summarise(across(c(...), ~ mean(.x, na.rm = TRUE))) } mtcars %>% my_mean(cyl, carb) mtcars %>% my_mean(foo = cyl, bar = carb) mtcars %>% my_mean(starts_with("c"), mpg:disp) ``` ## Transforming inputs with `if_all()` and `if_any()` `dplyr::filter()` requires a different operation than `across()` because it needs to combine the logical expressions with `&` or `|`. To solve this problem dplyr introduced the `if_all()` and `if_any()` variants of `across()`. In the following example, we filter all rows for which a set of variables are not equal to their minimum value: ```r filter_non_baseline <- function(.data, ...) { .data %>% dplyr::filter(if_all(c(...), ~ .x != min(.x, na.rm = TRUE))) } mtcars %>% filter_non_baseline(vs, am, gear) ``` rlang/man/rmd/glue-operators.Rmd0000644000176200001440000001030714741441060016330 0ustar liggesusers```{r, child = "setup.Rmd", include = FALSE} ``` [Dynamic dots][dyn-dots] (and [data-masked][topic-data-mask] dots which are dynamic by default) have built-in support for names interpolation with the [glue package](https://glue.tidyverse.org/). ```{r, comment = "#>", collapse = TRUE} tibble::tibble(foo = 1) foo <- "name" tibble::tibble("{foo}" := 1) ``` Inside functions, embracing an argument with `r link("{{")` inserts the expression supplied as argument in the string. This gives an indication on the variable or computation supplied as argument: ```{r, comment = "#>", collapse = TRUE} tib <- function(x) { tibble::tibble("var: {{ x }}" := x) } tib(1 + 1) ``` See also [englue()] to string-embrace outside of dynamic dots. ```{r, comment = "#>", collapse = TRUE} g <- function(x) { englue("var: {{ x }}") } g(1 + 1) ``` Technically, `r text("'{{'")` [defuses][topic-defuse] a function argument, calls [as_label()] on the expression supplied as argument, and inserts the result in the string. ## `r text("'{'")` and `r text("'{{'")` While `glue::glue()` only supports `r text("'{'")`, dynamic dots support both `r text("'{'")` and `r text("'{{'")`. The double brace variant is similar to the embrace operator `r link("{{")` available in [data-masked][topic-data-mask] arguments. In the following example, the embrace operator is used in a glue string to name the result with a default name that represents the expression supplied as argument: ```{r, comment = "#>", collapse = TRUE} my_mean <- function(data, var) { data %>% dplyr::summarise("{{ var }}" := mean({{ var }})) } mtcars %>% my_mean(cyl) mtcars %>% my_mean(cyl * am) ``` `r text("'{{'")` is only meant for inserting an expression supplied as argument to a function. The result of the expression is not inspected or used. To interpolate a string stored in a variable, use the regular glue operator `r text("'{'")` instead: ```{r, comment = "#>", collapse = TRUE} my_mean <- function(data, var, name = "mean") { data %>% dplyr::summarise("{name}" := mean({{ var }})) } mtcars %>% my_mean(cyl) mtcars %>% my_mean(cyl, name = "cyl") ``` Using the wrong operator causes unexpected results: ```{r, comment = "#>", collapse = TRUE} x <- "name" list2("{{ x }}" := 1) list2("{x}" := 1) ``` Ideally, using `{{` on regular objects would be an error. However for technical reasons it is not possible to make a distinction between function arguments and ordinary variables. See `r link("topic_embrace_non_args")` for more information about this limitation. ## Allow overriding default names The implementation of `my_mean()` in the previous section forces a default name onto the result. But what if the caller wants to give it a different name? In functions that take dots, it is possible to just supply a named expression to override the default. In a function like `my_mean()` that takes a named argument we need a different approach. This is where [englue()] becomes useful. We can pull out the default name creation in another user-facing argument like this: ```{r, comment = "#>", collapse = TRUE} my_mean <- function(data, var, name = englue("{{ var }}")) { data %>% dplyr::summarise("{name}" := mean({{ var }})) } ``` Now the user may supply their own name if needed: ```{r, comment = "#>", collapse = TRUE} mtcars %>% my_mean(cyl * am) mtcars %>% my_mean(cyl * am, name = "mean_cyl_am") ``` ## What's the deal with `:=`? Name injection in dynamic dots was originally implemented with `:=` instead of `=` to allow complex expressions on the LHS: ```{r, comment = "#>", collapse = TRUE} x <- "name" list2(!!x := 1) ``` Name-injection with glue operations was an extension of this existing feature and so inherited the same interface. However, there is no technical barrier to using glue strings on the LHS of `=`. As we are now moving away from [`!!`][injection-operator] for common tasks, we are considering enabling glue strings with `=` and superseding `:=` usage. Track the progress of this change in [issue 1296](https://github.com/r-lib/rlang/issues/1296). ## Using glue syntax in packages Since rlang does not depend directly on glue, you will have to ensure that glue is installed by adding it to your `Imports:` section. ```r usethis::use_package("glue", "Imports") ``` rlang/man/rmd/topic-condition-formatting.Rmd0000644000176200001440000000642614741441423020644 0ustar liggesusers```{r, child = "setup.Rmd", include = FALSE} ``` Condition formatting is a set of operations applied to raw inputs for error messages that includes: - Transforming a character vector of lines to a width-wrapped list of error bullets. This makes it easy to write messages in a list format where each bullet conveys a single important point. ```{r, error = TRUE} abort(c( "The error header", "*" = "An error bullet", "i" = "An info bullet", "x" = "A cross bullet" )) ``` See the [tidyverse error style guide](https://style.tidyverse.org/errors.html) for more about this style of error messaging. - Applying style (emphasis, boldness, ...) and colours to message elements. While the rlang package embeds rudimentary formatting routines, the main formatting engine is implemented in the [cli package](https://cli.r-lib.org/). ## Formatting messages with cli By default, rlang uses an internal mechanism to format bullets. It is preferable to delegate formatting to the [cli package](https://cli.r-lib.org/) by using [cli::cli_abort()], [cli::cli_warn()], and [cli::cli_inform()] instead of the rlang versions. These wrappers enable cli formatting with sophisticated paragraph wrapping and bullet indenting that make long lines easier to read. In the following example, a long `!` bullet is broken with an indented newline: ```r rlang::global_entrace(class = "errorr") #> Error in `rlang::global_entrace()`: #> ! `class` must be one of "error", "warning", or "message", #> not "errorr". #> i Did you mean "error"? ``` The cli wrappers also add many features such as interpolation, semantic formatting of text elements, and pluralisation: ```r inform_marbles <- function(n_marbles) { cli::cli_inform(c( "i" = "I have {n_marbles} shiny marble{?s} in my bag.", "v" = "Way to go {.code cli::cli_inform()}!" )) } inform_marbles(1) #> i I have 1 shiny marble in my bag. #> v Way to go `cli::cli_inform()`! inform_marbles(2) #> i I have 2 shiny marbles in my bag. #> v Way to go `cli::cli_inform()`! ``` ## Transitioning from `abort()` to `cli_abort()` If you plan to mass-rename calls from `abort()` to `cli::cli_abort()`, be careful if you assemble error messages from user inputs. If these individual pieces contain cli or glue syntax, this will result in hard-to-debug errors and possibly [unexpected behaviour](https://xkcd.com/327/). ```{r, error = TRUE} user_input <- "{base::stop('Wrong message.', call. = FALSE)}" cli::cli_abort(sprintf("Can't handle input `%s`.", user_input)) ``` To avoid this, protect your error messages by using cli to assemble the pieces: ```{r, error = TRUE} user_input <- "{base::stop('Wrong message.', call. = FALSE)}" cli::cli_abort("Can't handle input {.code {user_input}}.") ``` ## Enabling cli formatting globally To enable cli formatting for all `abort()` calls in your namespace, call [local_use_cli()] in the `onLoad` hook of your package. Using [on_load()] (make sure to call [run_on_load()] in your hook): ```r on_load(local_use_cli()) ``` Enabling cli formatting in `abort()` is useful for: - Transitioning from `abort()` to `cli::cli_abort()` progressively. - Using `abort()` when you'd like to disable interpolation syntax. - Creating error conditions with `error_cnd()`. These condition messages will be automatically formatted with cli as well. rlang/man/rmd/topic-data-mask-ambiguity.Rmd0000644000176200001440000001601114375670676020350 0ustar liggesusers```{r, child = "setup.Rmd", include = FALSE} ``` [Data masking][topic-data-mask] is an R feature that blends programming variables that live inside environments (env-variables) with statistical variables stored in data frames (data-variables). This mixture makes it easy to refer to data frame columns as well as objects defined in the current environment. ```{r, comment = "#>", collapse = TRUE} x <- 100 mtcars %>% dplyr::summarise(mean(disp / x)) ``` However this convenience introduces an ambiguity between data-variables and env-variables which might cause __collisions__. ## Column collisions In the following snippet, are we referring to the env-variable `x` or to the data-variable of the same name? ```{r, comment = "#>", collapse = TRUE} df <- data.frame(x = NA, y = 2) x <- 100 df %>% dplyr::mutate(y = y / x) ``` A column collision occurs when you want to use an object defined outside of the data frame, but a column of the same name happens to exist. ## Object collisions The opposite problem occurs when there is a typo in a data-variable name and an env-variable of the same name exists: ```{r, comment = "#>", collapse = TRUE} df <- data.frame(foo = "right") ffo <- "wrong" df %>% dplyr::mutate(foo = toupper(ffo)) ``` Instead of a typo, it might also be that you were expecting a column in the data frame which is unexpectedly missing. In both cases, if a variable can't be found in the data mask, R looks for variables in the surrounding environment. This isn't what we intended here and it would have been better to fail early with a "Column not found" error. ## Preventing collisions In casual scripts or interactive programming, data mask ambiguity is not a huge deal compared to the payoff of iterating quickly while developing your analysis. However in production code and in package functions, the ambiguity might cause collision bugs in the long run. Fortunately it is easy to be explicit about the scoping of variables with a little more verbose code. This topic lists the solutions and workarounds that have been created to solve ambiguity issues in data masks. ### The `.data` and `.env` pronouns The simplest solution is to use the [`.data`] and [`.env`] pronouns to disambiguate between data-variables and env-variables. ```{r, comment = "#>", collapse = TRUE} df <- data.frame(x = 1, y = 2) x <- 100 df %>% dplyr::mutate(y = .data$y / .env$x) ``` This is especially useful in functions because the data frame is not known in advance and potentially contain masking columns for any of the env-variables in scope in the function: ```{r, comment = "#>", collapse = TRUE} my_rescale <- function(data, var, factor = 10) { data %>% dplyr::mutate("{{ var }}" := {{ var }} / factor) } # This works data.frame(value = 1) %>% my_rescale(value) # Oh no! data.frame(factor = 0, value = 1) %>% my_rescale(value) ``` Subsetting function arguments with `.env` ensures we never hit a masking column: ```{r, comment = "#>", collapse = TRUE} my_rescale <- function(data, var, factor = 10) { data %>% dplyr::mutate("{{ var }}" := {{ var }} / .env$factor) } # Yay! data.frame(factor = 0, value = 1) %>% my_rescale(value) ``` ### Subsetting `.data` with env-variables The [`.data`] pronoun may be used as a name-to-data-mask pattern (see `r link("topic_data_mask_programming")`): ```{r, comment = "#>", collapse = TRUE} var <- "cyl" mtcars %>% dplyr::summarise(mean = mean(.data[[var]])) ``` In this example, the env-variable `var` is used inside the data mask to subset the `.data` pronoun. Does this mean that `var` is at risk of a column collision if the input data frame contains a column of the same name? Fortunately not: ```{r, comment = "#>", collapse = TRUE} var <- "cyl" mtcars2 <- mtcars mtcars2$var <- "wrong" mtcars2 %>% dplyr::summarise(mean = mean(.data[[var]])) ``` The evaluation of `.data[[var]]` is set up in such a way that there is no ambiguity. The `.data` pronoun can only be subsetted with env-variables, not data-variables. Technically, this is because `[[` behaves like an _injection operator_ when applied to `.data`. It is evaluated very early before the data mask is even created. See the `!!` section below. ### Injecting env-variables with `!!` [Injection operators][topic-inject] such as [`!!`][injection-operator] have interesting properties regarding the ambiguity problem. They modify a piece of code early on by injecting objects or other expressions before any data-masking logic comes into play. If you inject the _value_ of a variable, it becomes inlined in the expression. R no longer needs to look up any variable to find the value. Taking the earlier division example, let's use `!!` to inject the value of the env-variable `x` inside the division expression: ```{r, comment = "#>", collapse = TRUE} df <- data.frame(x = NA, y = 2) x <- 100 df %>% dplyr::mutate(y = y / !!x) ``` While injection solves issues of ambiguity, it is a bit heavy handed compared to using the [`.env`] pronoun. Big objects inlined in expressions might cause issues in unexpected places, for instance they might make the calls in a [traceback()] less readable. ## No ambiguity in tidy selections [Tidy selection](https://tidyselect.r-lib.org/reference/language.html) is a dialect of R that optimises column selection in tidyverse packages. Examples of functions that use tidy selections are `dplyr::select()` and `tidyr::pivot_longer()`. Unlike data masking, tidy selections do not suffer from ambiguity. The selection language is designed in such a way that evaluation of expressions is either scoped in the data mask only, or in the environment only. Take this example: ```r mtcars %>% dplyr::select(gear:ncol(mtcars)) ``` `gear` is a symbol supplied to a selection operator `:` and thus scoped in the data mask only. Any other kind of expression, such as `ncol(mtcars)`, is evaluated as normal R code outside of any data context. This is why there is no column collision here: ```{r, comment = "#>", collapse = TRUE} data <- data.frame(x = 1, data = 1:3) data %>% dplyr::select(data:ncol(data)) ``` It is useful to introduce two new terms. Tidy selections distinguish data-expressions and env-expressions: - `data` is a data-expression that refers to the data-variable. - `ncol(data)` is an env-expression that refers to the env-variable. To learn more about the difference between the two kinds of expressions, see the [technical description of the tidy selection syntax](https://tidyselect.r-lib.org/articles/syntax.html). ### Names pattern with `all_of()` `all_of()` is often used in functions as a [programming pattern][topic-data-mask-programming] that connects column names to a data mask, similarly to the [`.data`] pronoun. A simple example is: ```r my_group_by <- function(data, vars) { data %>% dplyr::group_by(across(all_of(vars))) } ``` If tidy selections were affected by the data mask ambiguity, this function would be at risk of a column collision. It would break as soon as the user supplies a data frame containing a `vars` column. However, `all_of()` is an env-expression that is evaluated outside of the data mask, so there is no possibility of collisions. rlang/man/rmd/topic-metaprogramming.Rmd0000644000176200001440000002460214375670676017714 0ustar liggesusers```{r, child = "setup.Rmd", include = FALSE} ``` The patterns covered in this article rely on _metaprogramming_, the ability to defuse, create, expand, and inject R expressions. A good place to start if you're new to programming on the language is the [Metaprogramming chapter](https://adv-r.hadley.nz/metaprogramming.html) of the [Advanced R](https://adv-r.hadley.nz) book. If you haven't already, read `r link("topic_data_mask_programming")` which covers simpler patterns that do not require as much theory to get up to speed. It covers concepts like argument behaviours and the various patterns you can add to your toolbox (forwarding, names, bridge, and transformative patterns). # Forwarding patterns ## Defuse and inject `r link("{{")` and `...` are sufficient for most purposes. Sometimes however, it is necessary to decompose the forwarding action into its two constitutive steps, [defusing][topic-defuse] and [injecting][topic-inject]. `{{` is the combination of [enquo()] and [`!!`][injection-operator]. These functions are completely equivalent: ```r my_summarise <- function(data, var) { data %>% dplyr::summarise({{ var }}) } my_summarise <- function(data, var) { data %>% dplyr::summarise(!!enquo(var)) } ``` Passing `...` is equivalent to the combination of [enquos()] and [`!!!`][splice-operator]: ```r my_group_by <- function(.data, ...) { .data %>% dplyr::group_by(...) } my_group_by <- function(.data, ...) { .data %>% dplyr::group_by(!!!enquos(...)) } ``` The advantage of decomposing the steps is that you gain access to the [defused expressions][topic-defuse]. Once defused, you can inspect or modify the expressions before injecting them in their target context. ## Inspecting input labels For instance, here is how to create an automatic name for a defused argument using [as_label()]: ```{r, comment = "#>", collapse = TRUE} f <- function(var) { var <- enquo(var) as_label(var) } f(cyl) f(1 + 1) ``` This is essentially equivalent to formatting an argument using [englue()]: ```{r} f2 <- function(var) { englue("{{ var }}") } f2(1 + 1) ``` With multiple arguments, use the plural variant [enquos()]. Set `.named` to `TRUE` to automatically call [as_label()] on the inputs for which the user has not provided a name (the same behaviour as in most dplyr verbs): ```{r, comment = "#>", collapse = TRUE} g <- function(...) { vars <- enquos(..., .named = TRUE) names(vars) } g(cyl, 1 + 1) ``` Just like with `dplyr::mutate()`, the user can override automatic names by supplying explicit names: ```{r, comment = "#>", collapse = TRUE} g(foo = cyl, bar = 1 + 1) ``` Defuse-and-inject patterns are most useful for transforming inputs. Some applications are explored in the Transformation patterns section. # Names patterns ## Symbolise and inject The symbolise-and-inject pattern is a _names pattern_ that you can use when `across(all_of())` is not supported. It consists in creating [defused expressions][topic-defuse] that refer to the data-variables represented in the names vector. These are then injected in the data mask context. Symbolise a single string with [sym()] or [data_sym()]: ```{r, comment = "#>", collapse = TRUE} var <- "cyl" sym(var) data_sym(var) ``` Symbolise a character vector with [syms()] or [data_syms()]. ```{r, comment = "#>", collapse = TRUE} vars <- c("cyl", "am") syms(vars) data_syms(vars) ``` Simple symbols returned by `sym()` and `syms()` work in a wider variety of cases (with base functions in particular) but we'll use mostly use `data_sym()` and `data_syms()` because they are more robust (see `r link("topic_data_mask_ambiguity")`). Note that these do not return _symbols_ per se, instead they create _calls_ to `$` that subset the [`.data`] pronoun. Since the `.data` pronoun is a tidy eval feature, you can't use it in base functions. As a rule, prefer the `data_`-prefixed variants when you're injecting in tidy eval functions and the unprefixed functions for base functions. A list of symbols can be injected in data-masked dots with the splice operator [`!!!`][splice-operator], which injects each element of the list as a separate argument. For instance, to implement a `group_by()` variant that takes a character vector of column names, you might write: ```r my_group_by <- function(data, vars) { data %>% dplyr::group_by(!!!data_syms(vars)) } my_group_by(vars) ``` In more complex case, you might want to add R code around the symbols. This requires _transformation_ patterns, see the section below. # Bridge patterns ## `mutate()` as a data-mask to selection bridge This is a variant of the `transmute()` bridge pattern described in `r link("topic_data_mask_programming")` that does not materialise `...` in the intermediate step. Instead, the `...` expressions are defused and inspected. Then the expressions, rather than the columns, are spliced in `mutate()`. ```r my_pivot_longer <- function(data, ...) { # Defuse the dots and inspect the names dots <- enquos(..., .named = TRUE) names <- names(dots) # Pass the inputs to `mutate()` data <- data %>% dplyr::mutate(!!!dots) # Select `...` inputs by name with `all_of()` data %>% tidyr::pivot_longer(cols = all_of(names)) } mtcars %>% my_pivot_longer(cyl, am = am * 100) ``` 1. Defuse the `...` expressions. The `.named` argument ensures unnamed inputs get a default name, just like they would if passed to `mutate()`. Take the names of the list of inputs. 2. Once we have the names, inject the argument expressions into `mutate()` to update the data frame. 3. Finally, pass the names to the tidy selection via [`all_of()`](https://tidyselect.r-lib.org/reference/all_of.html). # Transformation patterns ## Transforming inputs manually If `across()` and variants are not available, you will need to transform the inputs yourself using metaprogramming techniques. To illustrate the technique we'll reimplement `my_mean()` and without using `across()`. The pattern consists in defusing the input expression, building larger calls around them, and finally inject the modified expressions inside the data-masking functions. We'll start with a single named argument for simplicity: ```{r, comment = "#>", collapse = TRUE} my_mean <- function(data, var) { # Defuse the expression var <- enquo(var) # Wrap it in a call to `mean()` var <- expr(mean(!!var, na.rm = TRUE)) # Inject the expanded expression data %>% dplyr::summarise(mean = !!var) } mtcars %>% my_mean(cyl) ``` With `...` the technique is similar, though a little more involved. We'll use the plural variants `enquos()` and [`!!!`]. We'll also loop over the variable number of inputs using `purrr::map()`. But the pattern is otherwise basically the same: ```{r, comment = "#>", collapse = TRUE} my_mean <- function(.data, ...) { # Defuse the dots. Make sure they are automatically named. vars <- enquos(..., .named = TRUE) # Map over each defused expression and wrap it in a call to `mean()` vars <- purrr::map(vars, ~ expr(mean(!!.x, na.rm = TRUE))) # Inject the expressions .data %>% dplyr::summarise(!!!vars) } mtcars %>% my_mean(cyl) ``` Note that we are inheriting the data-masking behaviour of `summarise()` because we have effectively forwarded `...` inside that verb. This is different than transformation patterns based on `across()` which inherit tidy selection behaviour. In practice, this means the function doesn't support selection helpers and syntax. Instead, it gains the ability to create new vectors on the fly: ```{r, comment = "#>", collapse = TRUE} mtcars %>% my_mean(cyl = cyl * 100) ``` # Base patterns In this section, we review patterns for programming with _base_ data-masking functions. They essentially consist in building and evaluating expressions in the data mask. We review these patterns and compare them to rlang idioms. ## Data-masked `get()` In the simplest version of this pattern, `get()` is called with a variable name to retrieve objects from the data mask: ```{r, comment = "#>", collapse = TRUE} var <- "cyl" with(mtcars, mean(get(var))) ``` This sort of pattern is susceptible to [names collisions][topic-data-mask-ambiguity]. For instance, the input data frame might contain a variable called `var`: ```{r, comment = "#>", collapse = TRUE, error = TRUE} df <- data.frame(var = "wrong") with(df, mean(get(var))) ``` In general, prefer symbol injection over `get()` to prevent this sort of collisions. With base functions you will need to enable injection operators explicitly using [inject()]: ```{r, comment = "#>", collapse = TRUE} inject( with(mtcars, mean(!!sym(var))) ) ``` See `r link("topic_data_mask_ambiguity")` for more information about names collisions. ## Data-masked `parse()` and `eval()` A more involved pattern consists in building R code in a string and evaluating it in the mask: ```{r, comment = "#>", collapse = TRUE} var1 <- "am" var2 <- "vs" code <- paste(var1, "==", var2) with(mtcars, mean(eval(parse(text = code)))) ``` As before, the `code` variable is vulnerable to [names collisions][topic-data-mask-ambiguity]. More importantly, if `var1` and `var2` are user inputs, they could contain [adversarial code](https://xkcd.com/327/). Evaluating code assembled from strings is always a risky business: ```r var1 <- "(function() { Sys.sleep(Inf) # Could be a coin mining routine })()" var2 <- "vs" code <- paste(var1, "==", var2) with(mtcars, mean(eval(parse(text = code)))) ``` This is not a big deal if your code is only used internally. However, this code could be part of a public Shiny app which Internet users could exploit. But even internally, parsing is a source of bugs when variable names contain syntactic symbols like `-` or `:`. ```{r, comment = "#>", collapse = TRUE, error = TRUE} var1 <- ":var:" var2 <- "vs" code <- paste(var1, "==", var2) with(mtcars, mean(eval(parse(text = code)))) ``` For these reasons, always prefer to _build_ code instead of parsing code. Building variable names with [sym()] is a way of sanitising inputs. ```{r, comment = "#>", collapse = TRUE} var1 <- "(function() { Sys.sleep(Inf) # Could be a coin mining routine })()" var2 <- "vs" code <- call("==", sym(var1), sym(var2)) code ``` The adversarial input now produces an error: ```{r, comment = "#>", collapse = TRUE, error = TRUE} with(mtcars, mean(eval(code))) ``` Finally, it is recommended to inject the code instead of evaluating it to avoid names collisions: ```{r, comment = "#>", collapse = TRUE} var1 <- "am" var2 <- "vs" code <- call("==", sym(var1), sym(var2)) inject( with(mtcars, mean(!!code)) ) ``` rlang/man/rmd/topic-embrace-constants.Rmd0000644000176200001440000000516514375670676020136 0ustar liggesusers```{r, child = "setup.Rmd", include = FALSE} ``` Function arguments are [defused][topic-defuse] into [quosures][topic-quosure] that keep track of the environment of the defused expression. ```r quo(1 + 1) #> #> expr: ^1 + 1 #> env: global ``` You might have noticed that when constants are supplied, the quosure tracks the empty environment instead of the current environmnent. ```r quos("foo", 1, NULL) #> > #> #> [[1]] #> #> expr: ^"foo" #> env: empty #> #> [[2]] #> #> expr: ^1 #> env: empty #> #> [[3]] #> #> expr: ^NULL #> env: empty ``` The reason for this has to do with compilation of R code which makes it impossible to consistently capture environments of constants from function arguments. Argument defusing relies on the _promise_ mechanism of R for lazy evaluation of arguments. When functions are compiled and R notices that an argument is constant, it avoids creating a promise since they slow down function evaluation. Instead, the function is directly supplied a naked constant instead of constant wrapped in a promise. # Concrete case of promise unwrapping by compilation We can observe this optimisation by calling into the C-level `findVar()` function to capture promises. ```r # Return the object bound to `arg` without triggering evaluation of # promises f <- function(arg) { rlang:::find_var(current_env(), sym("arg")) } # Call `f()` with a symbol or with a constant g <- function(symbolic) { if (symbolic) { f(letters) } else { f("foo") } } # Make sure these small functions are compiled f <- compiler::cmpfun(f) g <- compiler::cmpfun(g) ``` When `f()` is called with a symbolic argument, we get the promise object created by R. ```r g(symbolic = TRUE) #> ``` However, supplying a constant to `"f"` returns the constant directly. ```r g(symbolic = FALSE) #> [1] "foo" ``` Without a promise, there is no way to figure out the original environment of an argument. # Do we need environments for constants? Data-masking APIs in the tidyverse are intentionally designed so that they don't need an environment for constants. - Data-masking APIs should be able to interpret constants. These can arise from normal argument passing as we have seen, or by [injection][topic-inject] with `!!`. There should be no difference between `dplyr::mutate(mtcars, var = cyl)` and `dplyr::mutate(mtcars, var = !!mtcars$cyl)`. - Data-masking is an _evaluation_ idiom, not an _introspective_ one. The behaviour of data-masking function should not depend on the calling environment when a constant (or a symbol evaluating to a given value) is supplied. rlang/man/rmd/topic-inject-out-of-context.Rmd0000644000176200001440000000550614375670676020672 0ustar liggesusers```{r, child = "setup.Rmd", include = FALSE} ``` The [injection operators][topic-inject] `r link("{{")`, [`!!`][injection-operator], and [`!!!`][splice-operator] are an extension of the R syntax developed for tidyverse packages. Because they are not part of base R, they suffer from some limitations. In particular no specific error is thrown when they are used in unexpected places. ## Using `{{` out of context The embrace operator `r link("{{")` is a feature available in [data-masked][topic-data-mask] arguments powered by tidy eval. If you use it elsewhere, it is interpreted as a double `{` wrapping. In the R language, `{` is like `(` but takes multiple expressions instead of one: ```{r, comment = "#>", collapse = TRUE} { 1 # Discarded 2 } list( { message("foo"); 2 } ) ``` Just like you can wrap an expression in as many parentheses as you'd like, you can wrap multiple times with braces: ```{r, comment = "#>", collapse = TRUE} ((1)) {{ 2 }} ``` So nothing prevents you from embracing a function argument in a context where this operation is not implemented. R will just treat the braces like a set of parentheses and silently return the result: ```{r, comment = "#>", collapse = TRUE} f <- function(arg) list({{ arg }}) f(1) ``` This sort of no-effect embracing should be avoided in real code because it falsely suggests that the function supports the tidy eval operator and that something special is happening. However in many cases embracing is done to implement [data masking][topic-data-mask]. It is likely that the function will be called with data-variables references which R won't be able to resolve properly: ```{r, comment = "#>", collapse = TRUE, error = TRUE} my_mean <- function(data, var) { with(data, mean({{ var }})) } my_mean(mtcars, cyl) ``` Since [with()] is a base data-masking function that doesn't support tidy eval operators, the embrace operator does not work and we get an object not found error. ## Using `!!` and `!!!` out of context The injection operators [`!!`] and [`!!!`] are implemented in [data-masked][topic-data-mask] arguments, [dynamic dots][dyn-dots], and within [inject()]. When used in other contexts, they are interpreted by R as double and triple _negations_. Double negation can be used in ordinary code to convert an input to logical: ```{r, comment = "#>", collapse = TRUE} !!10 !!0 ``` Triple negation is essentially the same as simple negation: ```{r, comment = "#>", collapse = TRUE} !10 !!!10 ``` This means that when injection operators are used in the wrong place, they will be interpreted as negation. In the best case scenario you will get a type error: ```{r, comment = "#>", collapse = TRUE, error = TRUE} !"foo" !quote(foo) !quote(foo()) ``` In the worst case, R will silently convert the input to logical. Unfortunately there is no systematic way of checking for these errors. rlang/man/rmd/setup.Rmd0000644000176200001440000000056614422713143014526 0ustar liggesusers```{r, include = FALSE} knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) library(rlang) `%>%` <- magrittr::`%>%` is_installed("dplyr") # Better printing mtcars <- tibble::as_tibble(mtcars) iris <- tibble::as_tibble(iris) options( tibble.print_min = 4, tibble.print_max = 4 ) # Fix Latex error options( cli.unicode = FALSE ) rlang::global_entrace() ``` rlang/man/rmd/topic-error-call.Rmd0000644000176200001440000001052114626326545016550 0ustar liggesusers```{r, child = "setup.Rmd", include = FALSE} ``` Starting with rlang 1.0, `abort()` includes the erroring function in the message by default: ```{r, error = TRUE} my_function <- function() { abort("Can't do that.") } my_function() ``` This works well when `abort()` is called directly within the failing function. However, when the `abort()` call is exported to another function (which we call an "error helper"), we need to be explicit about which function `abort()` is throwing an error for. # Passing the user context There are two main kinds of error helpers: - Simple `abort()` wrappers. These often aim at adding classes and attributes to an error condition in a structured way: ```{r} stop_my_class <- function(message) { abort(message, class = "my_class") } ``` - Input checking functions. An input checker is typically passed an input and an argument name. It throws an error if the input doesn't conform to expectations: ```{r} check_string <- function(x, arg = "x") { if (!is_string(x)) { cli::cli_abort("{.arg {arg}} must be a string.") } } ``` In both cases, the default error call is not very helpful to the end user because it reflects an internal function rather than a user function: ```{r} my_function <- function(x) { check_string(x) stop_my_class("Unimplemented") } ``` ```{r, error = TRUE} my_function(NA) ``` ```{r, error = TRUE} my_function("foo") ``` To fix this, let `abort()` know about the function that it is throwing the error for by passing the corresponding function environment as the `call` argument: ```{r} stop_my_class <- function(message, call = caller_env()) { abort(message, class = "my_class", call = call) } check_string <- function(x, arg = "x", call = caller_env()) { if (!is_string(x)) { cli::cli_abort("{.arg {arg}} must be a string.", call = call) } } ``` ```{r, error = TRUE} my_function(NA) ``` ```{r, error = TRUE} my_function("foo") ``` ## Input checkers and `caller_arg()` The `caller_arg()` helper is useful in input checkers which check an input on the behalf of another function. Instead of hard-coding `arg = "x"`, and forcing the callers to supply it if `"x"` is not the name of the argument being checked, use `caller_arg()`. ```{r} check_string <- function(x, arg = caller_arg(x), call = caller_env()) { if (!is_string(x)) { cli::cli_abort("{.arg {arg}} must be a string.", call = call) } } ``` It is a combination of `substitute()` and `rlang::as_label()` which provides a more generally applicable default: ```{r, error = TRUE} my_function <- function(my_arg) { check_string(my_arg) } my_function(NA) ``` # Side benefit: backtrace trimming Another benefit of passing `caller_env()` as `call` is that it allows `abort()` to automatically hide the error helpers ```{r} my_function <- function() { their_function() } their_function <- function() { error_helper1() } error_helper1 <- function(call = caller_env()) { error_helper2(call = call) } error_helper2 <- function(call = caller_env()) { if (use_call) { abort("Can't do this", call = call) } else { abort("Can't do this") } } ``` ```{r, error = TRUE} use_call <- FALSE their_function() ``` ```{r} rlang::last_error() ``` With the correct `call`, the backtrace is much simpler and lets the user focus on the part of the stack that is relevant to them: ```{r, error = TRUE} use_call <- TRUE their_function() ``` ```{r} rlang::last_error() ``` # testthat workflow Error snapshots are the main way of checking that the correct error call is included in an error message. However you'll need to opt into a new testthat display for warning and error snapshots. With the new display, these are printed by rlang, including the `call` field. This makes it easy to monitor the full appearance of warning and error messages as they are displayed to users. This display is not applied to all packages yet. With testthat 3.1.2, depend explicitly on rlang >= 1.0.0 to opt in. Starting from testthat 3.1.3, depending on rlang, no matter the version, is sufficient to opt in. In the future, the new display will be enabled for all packages. Once enabled, create error snapshots with: ```{r, eval = FALSE} expect_snapshot(error = TRUE, { my_function() }) ``` You'll have to make sure that the snapshot coverage for error messages is sufficient for your package. rlang/man/rmd/topic-defuse.Rmd0000644000176200001440000001524114375670676015775 0ustar liggesusers```{r, child = "setup.Rmd", include = FALSE} ``` When a piece of R code is defused, R doesn't return its value like it normally would. Instead it returns the expression in a special tree-like object that describes how to compute a value. These defused expressions can be thought of as blueprints or recipes for computing values. Using [expr()] we can observe the difference between computing an expression and defusing it: ```{r, comment = "#>", collapse = TRUE} # Return the result of `1 + 1` 1 + 1 # Return the expression `1 + 1` expr(1 + 1) ``` Evaluation of a defused expression can be resumed at any time with [eval()] (see also [eval_tidy()]). ```{r, comment = "#>", collapse = TRUE} # Return the expression `1 + 1` e <- expr(1 + 1) # Return the result of `1 + 1` eval(e) ``` The most common use case for defusing expressions is to resume its evaluation in a [data mask][topic-data-mask]. This makes it possible for the expression to refer to columns of a data frame as if they were regular objects. ```{r, comment = "#>", collapse = TRUE} e <- expr(mean(cyl)) eval(e, mtcars) ``` # Do I need to know about defused expressions? As a tidyverse user you will rarely need to defuse expressions manually with `expr()`, and even more rarely need to resume evaluation with [eval()] or [eval_tidy()]. Instead, you call [data-masking][topic-data-mask] functions which take care of defusing your arguments and resuming them in the context of a data mask. ```{r, comment = "#>", collapse = TRUE} mtcars %>% dplyr::summarise( mean(cyl) # This is defused and data-masked ) ``` It is important to know that a function defuses its arguments because it requires slightly different methods when called from a function. The main thing is that arguments must be transported with the [embrace operator][embrace-operator] `{{`. It allows the data-masking function to defuse the correct expression. ```{r, comment = "#>", collapse = TRUE} my_mean <- function(data, var) { dplyr::summarise(data, mean = mean({{ var }})) } ``` Read more about this in: - `r link("topic_data_mask")` - `r link("topic_data_mask_programming")` # The booby trap analogy The term "defusing" comes from an analogy to the evaluation model in R. As you may know, R uses lazy evaluation, which means that arguments are only evaluated when they are needed for a computation. Let's take two functions, `ignore()` which doesn't do anything with its argument, and `force()` which returns it: ```{r, comment = "#>", collapse = TRUE} ignore <- function(arg) NULL force <- function(arg) arg ignore(warning("boom")) force(warning("boom")) ``` A warning is only emitted when the function actually _triggers_ evaluation of its argument. Evaluation of arguments can be chained by passing them to other functions. If one of the functions ignores its argument, it breaks the chain of evaluation. ```{r, comment = "#>", collapse = TRUE} f <- function(x) g(x) g <- function(y) h(y) h <- function(z) ignore(z) f(warning("boom")) ``` In a way, arguments are like _booby traps_ which explode (evaluate) when touched. Defusing an argument can be seen as defusing the booby trap. ```{r, comment = "#>", collapse = TRUE} expr(force(warning("boom"))) ``` # Types of defused expressions * __Calls__, like `f(1, 2, 3)` or `1 + 1` represent the action of calling a function to compute a new value, such as a vector. * __Symbols__, like `x` or `df`, represent named objects. When the object pointed to by the symbol was defined in a function or in the global environment, we call it an environment-variable. When the object is a column in a data frame, we call it a data-variable. * __Constants__, like `1` or `NULL`. You can create new call or symbol objects by using the defusing function `expr()`: ```r # Create a symbol representing objects called `foo` expr(foo) #> foo # Create a call representing the computation of the mean of `foo` expr(mean(foo, na.rm = TRUE)) #> mean(foo, na.rm = TRUE) # Return a constant expr(1) #> [1] 1 expr(NULL) #> NULL ``` Defusing is not the only way to create defused expressions. You can also assemble them from data: ```r # Assemble a symbol from a string var <- "foo" sym(var) # Assemble a call from strings, symbols, and constants call("mean", sym(var), na.rm = TRUE) ``` # Local expressions versus function arguments There are two main ways to defuse expressions, to which correspond two functions in rlang, [expr()] and [enquo()]: * You can defuse your _own_ R expressions with `expr()`. * You can defuse the expressions supplied by _the user_ of your function with the `en`-prefixed operators, such as `enquo()` and `enquos()`. These operators defuse function arguments. # Defuse and inject One purpose for defusing evaluation of an expression is to interface with [data-masking][topic-data-mask] functions by injecting the expression back into another function with `!!`. This is the [defuse-and-inject pattern][topic-metaprogramming]. ```r my_summarise <- function(data, arg) { # Defuse the user expression in `arg` arg <- enquo(arg) # Inject the expression contained in `arg` # inside a `summarise()` argument data |> dplyr::summarise(mean = mean(!!arg, na.rm = TRUE)) } ``` Defuse-and-inject is usually performed in a single step with the embrace operator `r link("{{")`. ```r my_summarise <- function(data, arg) { # Defuse and inject in a single step with the embracing operator data |> dplyr::summarise(mean = mean({{ arg }}, na.rm = TRUE)) } ``` Using `enquo()` and `!!` separately is useful in more complex cases where you need access to the defused expression instead of just passing it on. # Defused arguments and quosures If you inspect the return values of `expr()` and `enquo()`, you'll notice that the latter doesn't return a raw expression like the former. Instead it returns a [quosure], a wrapper containing an expression and an environment. ```r expr(1 + 1) #> 1 + 1 my_function <- function(arg) enquo(arg) my_function(1 + 1) #> #> expr: ^1 + 1 #> env: global ``` R needs information about the environment to properly evaluate argument expressions because they come from a different context than the current function. For instance when a function in your package calls `dplyr::mutate()`, the quosure environment indicates where all the private functions of your package are defined. Read more about the role of quosures in `r link("topic_quosure")`. # Comparison with base R Defusing is known as _quoting_ in other frameworks. - The equivalent of `expr()` is [base::bquote()]. - The equivalent of `enquo()` is [base::substitute()]. The latter returns a naked expression instead of a quosure. - There is no equivalent for `enquos(...)` but you can defuse dots as a list of naked expressions with `eval(substitute(alist(...)))`. rlang/man/rmd/topic-error-chaining.Rmd0000644000176200001440000002215614375670676017434 0ustar liggesusers```{r, child = "setup.Rmd", include = FALSE} ``` Error chaining is a mechanism for providing contextual information when an error occurs. There are multiple situations in which you might be able to provide context that is helpful to quickly understand the cause or origin of an error: - Mentioning the _high level context_ in which a low level error arised. E.g. chaining a low-level HTTP error to a high-level download error. - Mentioning the _pipeline step_ in which a user error occured. This is a major use-case for NSE interfaces in the tidyverse, e.g. in dplyr, tidymodels or ggplot2. - Mentioning the _iteration context_ in which a user error occurred. For instance, the input file when processing documents, or the iteration number or key when running user code in a loop. Here is an example of a chained error from dplyr that shows the pipeline step (`mutate()`) and the iteration context (group ID) in which a function called by the user failed: ```{r, error = TRUE} add <- function(x, y) x + y mtcars |> dplyr::group_by(cyl) |> dplyr::mutate(new = add(disp, "foo")) ``` In all these cases, there are two errors in play, chained together: 1. The __causal error__, which interrupted the current course of action. 2. The __contextual error__, which expresses higher-level information when something goes wrong. There may be more than one contextual error in an error chain, but there is always only one causal error. # Rethrowing errors To create an error chain, you must first capture causal errors when they occur. We recommend using `try_fetch()` instead of `tryCatch()` or `withCallingHandlers()`. - Compared to `tryCatch()`, `try_fetch()` fully preserves the context of the error. This is important for debugging because it ensures complete backtraces are reported to users (e.g. via `last_error()`) and allows `options(error = recover)` to reach into the deepest error context. - Compared to `withCallingHandlers()`, which also preserves the error context, `try_fetch()` is able to catch stack overflow errors on R versions >= 4.2.0. In practice, `try_fetch()` works just like `tryCatch()`. It takes pairs of error class names and handling functions. To chain an error, simply rethrow it from an error handler by passing it as `parent` argument. In this example, we'll create a `with_` function. That is, a function that sets up some configuration (in this case, chained errors) before executing code supplied as input: ```{r, error = TRUE} with_chained_errors <- function(expr) { try_fetch( expr, error = function(cnd) { abort("Problem during step.", parent = cnd) } ) } with_chained_errors(1 + "") ``` Typically, you'll use this error helper from another user-facing function. ```{r, error = TRUE} my_verb <- function(expr) { with_chained_errors(expr) } my_verb(add(1, "")) ``` Altough we have created a chained error, the error call of the contextual error is not quite right. It mentions the name of the error helper instead of the name of the user-facing function. If you've read `r rlang:::link("topic_error_call")`, you may suspect that we need to pass a `call` argument to `abort()`. That's exactly what needs to happen to fix the call and backtrace issues: ```{r} with_chained_errors <- function(expr, call = caller_env()) { try_fetch( expr, error = function(cnd) { abort("Problem during step.", parent = cnd, call = call) } ) } ``` Now that we've passed the caller environment as `call` argument, `abort()` automatically picks up the correspondin function call from the execution frame: ```{r, error = TRUE} my_verb(add(1, "")) ``` ## Side note about missing arguments `my_verb()` is implemented with a lazy evaluation pattern. The user input kept unevaluated until the error chain context is set up. A downside of this arrangement is that missing argument errors are reported in the wrong context: ```{r, error = TRUE} my_verb() ``` To fix this, simply require these arguments before setting up the chained error context, for instance with the `check_required()` input checker exported from rlang: ```{r, error = TRUE} my_verb <- function(expr) { check_required(expr) with_chained_errors(expr) } my_verb() ``` # Taking full ownership of a causal error It is also possible to completely take ownership of a causal error and rethrow it with a more user-friendly error message. In this case, the original error is completely hidden from the end user. Opting for his approach instead of chaining should be carefully considered because hiding the causal error may deprive users from precious debugging information. - In general, hiding _user errors_ (e.g. dplyr inputs) in this way is likely a bad idea. - It may be appropriate to hide low-level errors, e.g. replacing HTTP errors by a high-level download error. Similarly, tidyverse packages like dplyr are replacing low-level vctrs errors with higher level errors of their own crafting. - Hiding causal errors indiscriminately should likely be avoided because it may suppress information about unexpected errors. In general, rethrowing an unchained errors should only be done with specific error classes. To rethow an error without chaining it, and completely take over the causal error from the user point of view, fetch it with `try_fetch()` and throw a new error. The only difference with throwing a chained error is that the `parent` argument is set to `NA`. You could also omit the `parent` argument entirely, but passing `NA` lets `abort()` know it is rethrowing an error from a handler and that it should hide the corresponding error helpers in the backtrace. ```{r, error = TRUE} with_own_scalar_errors <- function(expr, call = caller_env()) { try_fetch( expr, vctrs_error_scalar_type = function(cnd) { abort( "Must supply a vector.", parent = NA, error = cnd, call = call ) } ) } my_verb <- function(expr) { check_required(expr) with_own_scalar_errors( vctrs::vec_assert(expr) ) } my_verb(env()) ``` When a low-level error is overtaken, it is good practice to store it in the high-level error object, so that it can be inspected for debugging purposes. In the snippet above, we stored it in the `error` field. Here is one way of accessing the original error by subsetting the object returned by `last_error()`: ```{r} rlang::last_error()$error ``` # Case study: Mapping with chained errors One good use case for chained errors is adding information about the iteration state when looping over a set of inputs. To illustrate this, we'll implement a version of `map()` / `lapply()` that chains an iteration error to any captured user error. Here is a minimal implementation of `map()`: ```{r} my_map <- function(.xs, .fn, ...) { out <- new_list(length(.xs)) for (i in seq_along(.xs)) { out[[i]] <- .fn(.xs[[i]], ...) } out } list(1, 2) |> my_map(add, 100) ``` With this implementation, the user has no idea which iteration failed when an error occurs: ```{r, error = TRUE} list(1, "foo") |> my_map(add, 100) ``` ## Rethrowing with iteration information To improve on this we'll wrap the loop in a `try_fetch()` call that rethrow errors with iteration information. Make sure to call `try_fetch()` on the outside of the loop to avoid a massive performance hit: ```{r} my_map <- function(.xs, .fn, ...) { out <- new_list(length(.xs)) i <- 0L try_fetch( for (i in seq_along(.xs)) { out[[i]] <- .fn(.xs[[i]], ...) }, error = function(cnd) { abort( sprintf("Problem while mapping element %d.", i), parent = cnd ) } ) out } ``` And that's it, the error chain created by the rethrowing handler now provides users with the number of the failing iteration: ```{r, error = TRUE} list(1, "foo") |> my_map(add, 100) ``` ## Dealing with errors thrown from the mapped function One problem though, is that the user error call is not very informative when the error occurs immediately in the function supplied to `my_map()`: ```{r, error = TRUE} my_function <- function(x) { if (!is_string(x)) { abort("`x` must be a string.") } } list(1, "foo") |> my_map(my_function) ``` Functions have no names by themselves. Only the variable that refers to the function has a name. In this case, the mapped function is passed by argument to the variable `.fn`. So, when an error happens, this is the name that is reported to users. One approach to fix this is to inspect the `call` field of the error. When we detect a `.fn` call, we replace it by the defused code supplied as `.fn` argument: ```{r} my_map <- function(.xs, .fn, ...) { # Capture the defused code supplied as `.fn` fn_code <- substitute(.fn) out <- new_list(length(.xs)) for (i in seq_along(.xs)) { try_fetch( out[[i]] <- .fn(.xs[[i]], ...), error = function(cnd) { # Inspect the `call` field to detect `.fn` calls if (is_call(cnd$call, ".fn")) { # Replace `.fn` by the defused code. # Keep existing arguments. cnd$call[[1]] <- fn_code } abort( sprintf("Problem while mapping element %s.", i), parent = cnd ) } ) } out } ``` And voilà! ```{r, error = TRUE} list(1, "foo") |> my_map(my_function) ``` rlang/man/rmd/topic-inject.Rmd0000644000176200001440000001271714375670676016003 0ustar liggesusers```{r, child = "setup.Rmd", include = FALSE} ``` The injection operators are extensions of R implemented by rlang to modify a piece of code before R processes it. There are two main families: - The [dynamic dots][dyn-dots] operators, [`!!!`] and `r link("'{'")`. - The [metaprogramming operators][topic-metaprogramming] [`!!`], `r link("{{")`, and `r link("'{{'")`. Splicing with [`!!!`] can also be done in metaprogramming context. # Dots injection Unlike regular `...`, [dynamic dots][dyn-dots] are programmable with injection operators. ## Splicing with `!!!` For instance, take a function like `rbind()` which takes data in `...`. To bind rows, you supply them as separate arguments: ```{r, comment = "#>", collapse = TRUE} rbind(a = 1:2, b = 3:4) ``` But how do you bind a variable number of rows stored in a list? The base R solution is to invoke `rbind()` with `do.call()`: ```{r, comment = "#>", collapse = TRUE} rows <- list(a = 1:2, b = 3:4) do.call("rbind", rows) ``` Functions that implement dynamic dots include a built-in way of folding a list of arguments in `...`. To illustrate this, we'll create a variant of `rbind()` that takes dynamic dots by collecting `...` with [list2()]: ```{r, comment = "#>", collapse = TRUE} rbind2 <- function(...) { do.call("rbind", list2(...)) } ``` It can be used just like `rbind()`: ```{r, comment = "#>", collapse = TRUE} rbind2(a = 1:2, b = 3:4) ``` And a list of arguments can be supplied by _splicing_ the list with [`!!!`]: ```{r, comment = "#>", collapse = TRUE} rbind2(!!!rows, c = 5:6) ``` ## Injecting names with \verb{"\{"} A related problem comes up when an argument name is stored in a variable. With dynamic dots, you can inject the name using [glue syntax](https://glue.tidyverse.org/) with `r link("'{'")`: ```{r, comment = "#>", collapse = TRUE} name <- "foo" rbind2("{name}" := 1:2, bar = 3:4) rbind2("prefix_{name}" := 1:2, bar = 3:4) ``` # Metaprogramming injection [Data-masked][topic-data-mask] arguments support the following injection operators. They can also be explicitly enabled with [inject()]. ## Embracing with `{{` The embracing operator `r link("{{")` is made specially for function arguments. It [defuses][topic-defuse] the expression supplied as argument and immediately injects it in place. The injected argument is then evaluated in another context such as a [data mask][topic-data-mask]. ```{r, comment = "#>", collapse = TRUE} # Inject function arguments that might contain # data-variables by embracing them with {{ }} mean_by <- function(data, by, var) { data %>% dplyr::group_by({{ by }}) %>% dplyr::summarise(avg = mean({{ var }}, na.rm = TRUE)) } # The data-variables `cyl` and `disp` inside the # env-variables `by` and `var` are injected inside `group_by()` # and `summarise()` mtcars %>% mean_by(by = cyl, var = disp) ``` Learn more about this pattern in `r link("topic_data_mask_programming")`. ## Injecting with `!!` Unlike [`!!!`] which injects a list of arguments, the injection operator [`!!`] (pronounced "bang-bang") injects a _single_ object. One use case for `!!` is to substitute an environment-variable (created with `<-`) with a data-variable (inside a data frame). ```{r, comment = "#>", collapse = TRUE} # The env-variable `var` contains a data-symbol object, in this # case a reference to the data-variable `height` var <- data_sym("disp") # We inject the data-variable contained in `var` inside `summarise()` mtcars %>% dplyr::summarise(avg = mean(!!var, na.rm = TRUE)) ``` Another use case is to inject a variable by value to avoid [name collisions][topic-data-mask-ambiguity]. ```{r, comment = "#>", collapse = TRUE} df <- data.frame(x = 1) # This name conflicts with a column in `df` x <- 100 # Inject the env-variable df %>% dplyr::mutate(x = x / !!x) ``` Note that in most cases you don't need injection with `!!`. For instance, the [`.data`] and [`.env`] pronouns provide more intuitive alternatives to injecting a column name and injecting a value. ## Splicing with `!!!` The splice operator [`!!!`] of dynamic dots can also be used in metaprogramming context (inside [data-masked][topic-data-mask] arguments and inside [inject()]). For instance, we could reimplement the `rbind2()` function presented above using `inject()` instead of `do.call()`: ```r rbind2 <- function(...) { inject(rbind(!!!list2(...))) } ``` There are two things going on here. We collect `...` with [list2()] so that the callers of `rbind2()` may use `!!!`. And we use `inject()` so that `rbind2()` itself may use `!!!` to splice the list of arguments passed to `rbind2()`. # Injection in other languages Injection is known as __quasiquotation__ in other programming languages and in computer science. `expr()` is similar to a quasiquotation operator and `!!` is the unquote operator. These terms have a rich history in Lisp languages, and live on in modern languages like [Julia](https://docs.julialang.org/en/v1/manual/metaprogramming/) and [Racket](https://docs.racket-lang.org/reference/quasiquote.html). In base R, quasiquotation is performed with [bquote()]. The main difference between rlang and other languages is that quasiquotation is often implicit instead of explicit. You can use injection operators in any defusing / quoting function (unless that function defuses its argument with a special operator like [enquo0()]). This is not the case in lisp languages for example where injection / unquoting is explicit and only enabled within a backquote. # See also - `r link("topic_inject_out_of_context")` rlang/man/rmd/topic-double-evaluation.Rmd0000644000176200001440000000544714375670676020150 0ustar liggesusers```{r, child = "setup.Rmd", include = FALSE} ``` One inherent risk to metaprogramming is to evaluate multiple times a piece of code that appears to be evaluated only once. Take this data-masking function which takes a single input and produces two summaries: ```{r, comment = "#>", collapse = TRUE} summarise_stats <- function(data, var) { data %>% dplyr::summarise( mean = mean({{ var }}), sd = sd({{ var }}) ) } summarise_stats(mtcars, cyl) ``` This function is perfectly fine if the user supplies simple column names. However, data-masked arguments may also include _computations_. ```{r, comment = "#>", collapse = TRUE} summarise_stats(mtcars, cyl * 100) ``` Computations may be slow and may produce side effects. For these reasons, they should only be performed as many times as they appear in the code (unless explicitly documented, e.g. once per group with grouped data frames). Let's try again with a more complex computation: ```{r, comment = "#>", collapse = TRUE} times100 <- function(x) { message("Takes a long time...") Sys.sleep(0.1) message("And causes side effects such as messages!") x * 100 } summarise_stats(mtcars, times100(cyl)) ``` Because of the side effects and the long running time, it is clear that `summarise_stats()` evaluates its input twice. This is because we've injected a defused expression in two different places. The data-masked expression created down the line looks like this (with caret signs representing [quosure][topic-quosure] boundaries): ```r dplyr::summarise( mean = ^mean(^times100(cyl)), sd = ^sd(^times100(cyl)) ) ``` The `times100(cyl)` expression is evaluated twice, even though it only appears once in the code. We have a double evaluation bug. One simple way to fix it is to assign the defused input to a constant. You can then refer to that constant in the remaining of the code. ```{r, comment = "#>", collapse = TRUE} summarise_stats <- function(data, var) { data %>% dplyr::transmute( var = {{ var }}, ) %>% dplyr::summarise( mean = mean(var), sd = sd(var) ) } ``` The defused input is now evaluated only once because it is injected only once: ```{r, comment = "#>", collapse = TRUE} summarise_stats(mtcars, times100(cyl)) ``` # What about glue strings? `{{` [embracing in glue strings][glue-operators] doesn't suffer from the double evaluation problem: ```{r, comment = "#>", collapse = TRUE} summarise_stats <- function(data, var) { data %>% dplyr::transmute( var = {{ var }}, ) %>% dplyr::summarise( "mean_{{ var }}" := mean(var), "sd_{{ var }}" := sd(var) ) } summarise_stats(mtcars, times100(cyl)) ``` Since a glue string doesn't need the result of an expression, only the original code converted (deparsed) to a string, it doesn't evaluate injected expressions. rlang/man/rmd/topic-condition-customisation.Rmd0000644000176200001440000000643414375670676021413 0ustar liggesusers```{r, child = "setup.Rmd", include = FALSE} ``` Various aspects of the condition messages displayed by [abort()], [warn()], and [inform()] can be customised using options from the [cli](https://cli.r-lib.org) package. # Turning off unicode bullets By default, bulleted lists are prefixed with unicode symbols: \ifelse{latex}{\emph{Not in PDF manual.}}{\if{html}{\out{
}}\preformatted{rlang::abort(c( "The error message.", "*" = "Regular bullet.", "i" = "Informative bullet.", "x" = "Cross bullet.", "v" = "Victory bullet.", ">" = "Arrow bullet." )) #> Error: #> ! The error message. #> • Regular bullet. #> ℹ Informative bullet. #> ✖ Cross bullet. #> ✔ Victory bullet. #> → Arrow bullet. }\if{html}{\out{
}}} Set this option to use simple letters instead: ```r options(cli.condition_unicode_bullets = FALSE) rlang::abort(c( "The error message.", "*" = "Regular bullet.", "i" = "Informative bullet.", "x" = "Cross bullet.", "v" = "Victory bullet.", ">" = "Arrow bullet." )) #> Error: #> ! The error message. #> * Regular bullet. #> i Informative bullet. #> x Cross bullet. #> v Victory bullet. #> > Arrow bullet. ``` # Changing the bullet symbols You can specify what symbol to use for each type of bullet through your cli user theme. For instance, here is how to uniformly use `*` for all bullet kinds: ```r options(cli.user_theme = list( ".cli_rlang .bullet-*" = list(before = "* "), ".cli_rlang .bullet-i" = list(before = "* "), ".cli_rlang .bullet-x" = list(before = "* "), ".cli_rlang .bullet-v" = list(before = "* "), ".cli_rlang .bullet->" = list(before = "* ") )) rlang::abort(c( "The error message.", "*" = "Regular bullet.", "i" = "Informative bullet.", "x" = "Cross bullet.", "v" = "Victory bullet.", ">" = "Arrow bullet." )) #> Error: #> ! The error message. #> * Regular bullet. #> * Informative bullet. #> * Cross bullet. #> * Victory bullet. #> * Arrow bullet. ``` If you want all the bullets to be the same, including the leading bullet, you can achieve this using the `bullet` class: ```r options(cli.user_theme = list( ".cli_rlang .bullet" = list(before = "* ") )) rlang::abort(c( "The error message.", "*" = "Regular bullet.", "i" = "Informative bullet.", "x" = "Cross bullet.", "v" = "Victory bullet.", ">" = "Arrow bullet." )) #> Error: #> * The error message. #> * Regular bullet. #> * Informative bullet. #> * Cross bullet. #> * Victory bullet. #> * Arrow bullet. ``` # Changing the foreground and background colour of error calls When called inside a function, `abort()` displays the function call to help contextualise the error: ```{r, error = TRUE} splash <- function() { abort("Can't splash without water.") } splash() ``` The call is formatted with cli as a `code` element. This is not visible in the manual, but code text is formatted with a highlighted background colour by default. When this can be reliably detected, that background colour is different depending on whether you're using a light or dark theme. You can override the colour of code elements in your cli theme. Here is my personal configuration that fits well with the colour theme I currently use in my IDE: ```r options(cli.user_theme = list( span.code = list( "background-color" = "#3B4252", color = "#E5E9F0" ) )) ``` rlang/man/rmd/topic-multiple-columns.Rmd0000644000176200001440000001201414375670676020026 0ustar liggesusers```{r, child = "setup.Rmd", include = FALSE} ``` In this guide we compare ways of taking multiple columns in a single function argument. As a refresher (see the [programming patterns][topic-data-mask-programming] article), there are two common ways of passing arguments to [data-masking][topic-data-mask] functions. For single arguments, embrace with `r link("{{")`: ```{r, comment = "#>", collapse = TRUE} my_group_by <- function(data, var) { data %>% dplyr::group_by({{ var }}) } my_pivot_longer <- function(data, var) { data %>% tidyr::pivot_longer({{ var }}) } ``` For multiple arguments in `...`, pass them on to functions that also take `...` like `group_by()`, or pass them within `c()` for functions taking tidy selection in a single argument like `pivot_longer()`: ```{r, comment = "#>", collapse = TRUE} # Pass dots through my_group_by <- function(.data, ...) { .data %>% dplyr::group_by(...) } my_pivot_longer <- function(.data, ...) { .data %>% tidyr::pivot_longer(c(...)) } ``` But what if you want to take multiple columns in a single named argument rather than in `...`? # Using tidy selections The idiomatic tidyverse way of taking multiple columns in a single argument is to take a _tidy selection_ (see the [Argument behaviours][topic-data-mask-programming] section). In tidy selections, the syntax for passing multiple columns in a single argument is `c()`: ```r mtcars %>% tidyr::pivot_longer(c(am, cyl, vs)) ``` Since `{{` inherits behaviour, this implementation of `my_pivot_longer()` automatically allows multiple columns passing: ```r my_pivot_longer <- function(data, var) { data %>% tidyr::pivot_longer({{ var }}) } mtcars %>% my_pivot_longer(c(am, cyl, vs)) ``` For `group_by()`, which takes data-masked arguments, we'll use `across()` as a _bridge_ (see [Bridge patterns][topic-data-mask-programming]). ```r my_group_by <- function(data, var) { data %>% dplyr::group_by(across({{ var }})) } mtcars %>% my_group_by(c(am, cyl, vs)) ``` When embracing in tidyselect context or using `across()` is not possible, you might have to implement tidyselect behaviour manually with `tidyselect::eval_select()`. # Using external defusal To implement an argument with tidyselect behaviour, it is necessary to [defuse][topic-defuse] the argument. However defusing an argument which had historically behaved like a regular argument is a rather disruptive breaking change. This is why we could not implement tidy selections in ggplot2 facetting functions like `facet_grid()` and `facet_wrap()`. An alternative is to use external defusal of arguments. This is what formula interfaces do for instance. A modelling function takes a formula in a regular argument and the formula defuses the user code: ```r my_lm <- function(data, f, ...) { lm(f, data, ...) } mtcars %>% my_lm(disp ~ drat) ``` Once created, the defused expressions contained in the formula are passed around like a normal argument. A similar approach was taken to update `facet_` functions to tidy eval. The `vars()` function (a simple alias to [quos()]) is provided so that users can defuse their arguments externally. ```r ggplot2::facet_grid( ggplot2::vars(cyl), ggplot2::vars(am, vs) ) ``` You can implement this approach by simply taking a list of defused expressions as argument. This list can be passed the usual way to other functions taking such lists: ```r my_facet_grid <- function(rows, cols, ...) { ggplot2::facet_grid(rows, cols, ...) } ``` Or it can be spliced with [`!!!`]: ```r my_group_by <- function(data, vars) { stopifnot(is_quosures(vars)) data %>% dplyr::group_by(!!!vars) } mtcars %>% my_group_by(dplyr::vars(cyl, am)) ``` # A non-approach: Parsing lists Intuitively, many programmers who want to take a list of expressions in a single argument try to defuse an argument and parse it. The user is expected to supply multiple arguments within a `list()` expression. When such a call is detected, the arguments are retrieved and spliced with `!!!`. Otherwise, the user is assumed to have supplied a single argument which is injected with `!!`. An implementation along these lines might look like this: ```{r, comment = "#>", collapse = TRUE} my_group_by <- function(data, vars) { vars <- enquo(vars) if (quo_is_call(vars, "list")) { expr <- quo_get_expr(vars) env <- quo_get_env(vars) args <- as_quosures(call_args(expr), env = env) data %>% dplyr::group_by(!!!args) } else { data %>% dplyr::group_by(!!vars) } } ``` This does work in simple cases: ```{r, comment = "#>", collapse = TRUE} mtcars %>% my_group_by(cyl) %>% dplyr::group_vars() mtcars %>% my_group_by(list(cyl, am)) %>% dplyr::group_vars() ``` However this parsing approach quickly shows limits: ```r mtcars %>% my_group_by(list2(cyl, am)) #> Error in `group_by()`: Can't add columns. #> i `..1 = list2(cyl, am)`. #> i `..1` must be size 32 or 1, not 2. ``` Also, it would be better for overall consistency of interfaces to use the tidyselect syntax `c()` for passing multiple columns. In general, we recommend to use either the tidyselect or the external defusal approaches. rlang/man/rmd/topic-embrace-non-args.Rmd0000644000176200001440000000174014375670676017641 0ustar liggesusers```{r, child = "setup.Rmd", include = FALSE} ``` The embrace operator `r link("{{")` should be used exclusively with function arguments: ```r fn <- function(arg) { quo(foo({{ arg }})) } fn(1 + 1) #> #> expr: ^foo(^1 + 1) #> env: 0x7ffd89aac518 ``` However you may have noticed that it also works on regular objects: ```r fn <- function(arg) { arg <- force(arg) quo(foo({{ arg }})) } fn(1 + 1) #> #> expr: ^foo(^2) #> env: 0x7ffd8a633398 ``` In that case, `{{` captures the _value_ of the expression instead of a defused expression. That's because only function arguments can be defused. Note that this issue also applies to [enquo()] (on which `{{` is based). # Why is this not an error? Ideally we would have made `{{` on regular objects an error. However this is not possible because in compiled R code it is not always possible to distinguish a regular variable from a function argument. See `r link("topic_embrace_constants")` for more about this. rlang/man/box.Rd0000644000176200001440000000277714127057575013241 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/s3.R \name{box} \alias{box} \alias{new_box} \alias{is_box} \alias{unbox} \title{Box a value} \usage{ new_box(.x, class = NULL, ...) is_box(x, class = NULL) unbox(box) } \arguments{ \item{class}{For \code{new_box()}, an additional class for the boxed value (in addition to \code{rlang_box}). For \code{is_box()}, a class or vector of classes passed to \code{\link[=inherits_all]{inherits_all()}}.} \item{...}{Additional attributes passed to \code{\link[base:structure]{base::structure()}}.} \item{x, .x}{An R object.} \item{box}{A boxed value to unbox.} } \description{ \code{new_box()} is similar to \code{\link[base:AsIs]{base::I()}} but it protects a value by wrapping it in a scalar list rather than by adding an attribute. \code{unbox()} retrieves the boxed value. \code{is_box()} tests whether an object is boxed with optional class. \code{as_box()} ensures that a value is wrapped in a box. \code{as_box_if()} does the same but only if the value matches a predicate. } \examples{ boxed <- new_box(letters, "mybox") is_box(boxed) is_box(boxed, "mybox") is_box(boxed, "otherbox") unbox(boxed) # as_box() avoids double-boxing: boxed2 <- as_box(boxed, "mybox") boxed2 unbox(boxed2) # Compare to: boxed_boxed <- new_box(boxed, "mybox") boxed_boxed unbox(unbox(boxed_boxed)) # Use `as_box_if()` with a predicate if you need to ensure a box # only for a subset of values: as_box_if(NULL, is_null, "null_box") as_box_if("foo", is_null, "null_box") } rlang/man/call_fn.Rd0000644000176200001440000000120614375670676014041 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/lifecycle-deprecated.R \name{call_fn} \alias{call_fn} \title{Extract function from a call} \usage{ call_fn(call, env = caller_env()) } \arguments{ \item{call, env}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}}} } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} Deprecated in rlang 0.4.11. } \keyword{internal} rlang/man/env_binding_are_active.Rd0000644000176200001440000000130414175213516017066 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/env-binding.R \name{env_binding_are_active} \alias{env_binding_are_active} \alias{env_binding_are_lazy} \title{What kind of environment binding?} \usage{ env_binding_are_active(env, nms = NULL) env_binding_are_lazy(env, nms = NULL) } \arguments{ \item{env}{An environment.} \item{nms}{Names of bindings. Defaults to all bindings in \code{env}.} } \value{ A logical vector as long as \code{nms} and named after it. } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} } \keyword{internal} rlang/man/friendly_type.Rd0000644000176200001440000000125414741441060015277 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/lifecycle-deprecated.R \name{friendly_type} \alias{friendly_type} \title{Format a type for error messages} \usage{ friendly_type(type) } \arguments{ \item{type}{A type as returned by \code{\link[=typeof]{typeof()}}.} } \value{ A string of the prettified type, qualified with an indefinite article. } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} \code{friendly_type()} is deprecated. Please use the \code{standalone-friendly-type.R} file instead. } \keyword{internal} rlang/man/is_callable.Rd0000644000176200001440000000226314137447476014675 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/call.R \name{is_callable} \alias{is_callable} \title{Is an object callable?} \usage{ is_callable(x) } \arguments{ \item{x}{An object to test.} } \description{ A callable object is an object that can appear in the function position of a call (as opposed to argument position). This includes \link[=is_symbolic]{symbolic objects} that evaluate to a function or literal functions embedded in the call. } \details{ Note that strings may look like callable objects because expressions of the form \code{"list"()} are valid R code. However, that's only because the R parser transforms strings to symbols. It is not legal to manually set language heads to strings. } \examples{ # Symbolic objects and functions are callable: is_callable(quote(foo)) is_callable(base::identity) # node_poke_car() lets you modify calls without any checking: lang <- quote(foo(10)) node_poke_car(lang, current_env()) # Use is_callable() to check an input object is safe to put as CAR: obj <- base::identity if (is_callable(obj)) { lang <- node_poke_car(lang, obj) } else { abort("`obj` must be callable") } eval_bare(lang) } \keyword{internal} rlang/man/is_expression.Rd0000644000176200001440000000715714175213516015330 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/expr.R \name{is_expression} \alias{is_expression} \alias{is_syntactic_literal} \alias{is_symbolic} \title{Is an object an expression?} \usage{ is_expression(x) is_syntactic_literal(x) is_symbolic(x) } \arguments{ \item{x}{An object to test.} } \description{ In rlang, an \emph{expression} is the return type of \code{\link[=parse_expr]{parse_expr()}}, the set of objects that can be obtained from parsing R code. Under this definition expressions include numbers, strings, \code{NULL}, symbols, and function calls. These objects can be classified as: \itemize{ \item Symbolic objects, i.e. symbols and function calls (for which \code{is_symbolic()} returns \code{TRUE}) \item Syntactic literals, i.e. scalar atomic objects and \code{NULL} (testable with \code{is_syntactic_literal()}) } \code{is_expression()} returns \code{TRUE} if the input is either a symbolic object or a syntactic literal. If a call, the elements of the call must all be expressions as well. Unparsable calls are not considered expressions in this narrow definition. Note that in base R, there exists \code{\link[=expression]{expression()}} vectors, a data type similar to a list that supports special attributes created by the parser called source references. This data type is not supported in rlang. } \details{ \code{is_symbolic()} returns \code{TRUE} for symbols and calls (objects with type \code{language}). Symbolic objects are replaced by their value during evaluation. Literals are the complement of symbolic objects. They are their own value and return themselves during evaluation. \code{is_syntactic_literal()} is a predicate that returns \code{TRUE} for the subset of literals that are created by R when parsing text (see \code{\link[=parse_expr]{parse_expr()}}): numbers, strings and \code{NULL}. Along with symbols, these literals are the terminating nodes in an AST. Note that in the most general sense, a literal is any R object that evaluates to itself and that can be evaluated in the empty environment. For instance, \code{quote(c(1, 2))} is not a literal, it is a call. However, the result of evaluating it in \code{\link[=base_env]{base_env()}} is a literal(in this case an atomic vector). As the data structure for function arguments, pairlists are also a kind of language objects. However, since they are mostly an internal data structure and can't be returned as is by the parser, \code{is_expression()} returns \code{FALSE} for pairlists. } \examples{ q1 <- quote(1) is_expression(q1) is_syntactic_literal(q1) q2 <- quote(x) is_expression(q2) is_symbol(q2) q3 <- quote(x + 1) is_expression(q3) is_call(q3) # Atomic expressions are the terminating nodes of a call tree: # NULL or a scalar atomic vector: is_syntactic_literal("string") is_syntactic_literal(NULL) is_syntactic_literal(letters) is_syntactic_literal(quote(call())) # Parsable literals have the property of being self-quoting: identical("foo", quote("foo")) identical(1L, quote(1L)) identical(NULL, quote(NULL)) # Like any literals, they can be evaluated within the empty # environment: eval_bare(quote(1L), empty_env()) # Whereas it would fail for symbolic expressions: # eval_bare(quote(c(1L, 2L)), empty_env()) # Pairlists are also language objects representing argument lists. # You will usually encounter them with extracted formals: fmls <- formals(is_expression) typeof(fmls) # Since they are mostly an internal data structure, is_expression() # returns FALSE for pairlists, so you will have to check explicitly # for them: is_expression(fmls) is_pairlist(fmls) } \seealso{ \code{\link[=is_call]{is_call()}} for a call predicate. } rlang/man/englue.Rd0000644000176200001440000000711614376112150013703 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/nse-inject.R \name{englue} \alias{englue} \title{Defuse function arguments with glue} \usage{ englue(x, env = caller_env(), error_call = current_env(), error_arg = "x") } \arguments{ \item{x}{A string to interpolate with glue operators.} \item{env}{User environment where the interpolation data lives in case you're wrapping \code{englue()} in another function.} \item{error_call}{The execution environment of a currently running function, e.g. \code{caller_env()}. The function will be mentioned in error messages as the source of the error. See the \code{call} argument of \code{\link[=abort]{abort()}} for more information.} \item{error_arg}{An argument name as a string. This argument will be mentioned in error messages as the input that is at the origin of a problem.} } \description{ \code{englue()} creates a string with the \link[=glue-operators]{glue operators} \verb{\{} and \verb{\{\{}. These operators are normally used to inject names within \link[=dyn-dots]{dynamic dots}. \code{englue()} makes them available anywhere within a function. \code{englue()} must be used inside a function. \code{englue("{{ var }}")} \link[=topic-defuse]{defuses} the argument \code{var} and transforms it to a string using the default name operation. } \details{ \code{englue("{{ var }}")} is equivalent to \code{as_label(enquo(var))}. It \link[=topic-defuse]{defuses} \code{arg} and transforms the expression to a string with \code{\link[=as_label]{as_label()}}. In dynamic dots, using only \verb{\{} is allowed. In \code{englue()} you must use \verb{\{\{} at least once. Use \code{glue::glue()} for simple interpolation. Before using \code{englue()} in a package, first ensure that glue is installed by adding it to your \verb{Imports:} section. \if{html}{\out{
}}\preformatted{usethis::use_package("glue", "Imports") }\if{html}{\out{
}} } \section{Wrapping \code{englue()}}{ You can provide englue semantics to a user provided string by supplying \code{env}. In this example we create a variant of \code{englue()} that supports a special \code{.qux} pronoun by: \itemize{ \item Creating an environment \code{masked_env} that inherits from the user env, the one where their data lives. \item Overriding the \code{error_arg} and \code{error_call} arguments to point to our own argument name and call environment. This pattern is slightly different from usual error context passing because \code{englue()} is a backend function that uses its own error context by default (and not a checking function that uses \emph{your} error context by default). } \if{html}{\out{
}}\preformatted{my_englue <- function(text) \{ masked_env <- env(caller_env(), .qux = "QUX") englue( text, env = masked_env, error_arg = "text", error_call = current_env() ) \} # Users can then use your wrapper as they would use `englue()`: fn <- function(x) \{ foo <- "FOO" my_englue("\{\{ x \}\}_\{.qux\}_\{foo\}") \} fn(bar) #> [1] "bar_QUX_FOO" }\if{html}{\out{
}} If you are creating a low level package on top of englue(), you should also consider exposing \code{env}, \code{error_arg} and \code{error_call} in your \code{englue()} wrapper so users can wrap your wrapper. } \examples{ g <- function(var) englue("{{ var }}") g(cyl) g(1 + 1) g(!!letters) # These are equivalent to as_label(quote(cyl)) as_label(quote(1 + 1)) as_label(letters) } \seealso{ \itemize{ \item \ifelse{html}{\link[=topic-inject]{Injecting with !!, !!!, and glue syntax}}{\link[=topic-inject]{Injecting with !!, !!!, and glue syntax}} } } rlang/man/check_exclusive.Rd0000644000176200001440000000315014375670676015607 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/arg.R \name{check_exclusive} \alias{check_exclusive} \title{Check that arguments are mutually exclusive} \usage{ check_exclusive(..., .require = TRUE, .frame = caller_env(), .call = .frame) } \arguments{ \item{...}{Function arguments.} \item{.require}{Whether at least one argument must be supplied.} \item{.frame}{Environment where the arguments in \code{...} are defined.} \item{.call}{The execution environment of a currently running function, e.g. \code{caller_env()}. The function will be mentioned in error messages as the source of the error. See the \code{call} argument of \code{\link[=abort]{abort()}} for more information.} } \value{ The supplied argument name as a string. If \code{.require} is \code{FALSE} and no argument is supplied, the empty string \code{""} is returned. } \description{ \code{check_exclusive()} checks that only one argument is supplied out of a set of mutually exclusive arguments. An informative error is thrown if multiple arguments are supplied. } \examples{ f <- function(x, y) { switch( check_exclusive(x, y), x = message("`x` was supplied."), y = message("`y` was supplied.") ) } # Supplying zero or multiple arguments is forbidden try(f()) try(f(NULL, NULL)) # The user must supply one of the mutually exclusive arguments f(NULL) f(y = NULL) # With `.require` you can allow zero arguments f <- function(x, y) { switch( check_exclusive(x, y, .require = FALSE), x = message("`x` was supplied."), y = message("`y` was supplied."), message("No arguments were supplied") ) } f() } rlang/man/env_browse.Rd0000644000176200001440000000135714741441060014577 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/env.R \name{env_browse} \alias{env_browse} \alias{env_is_browsed} \title{Browse environments} \usage{ env_browse(env, value = TRUE) env_is_browsed(env) } \arguments{ \item{env}{An environment.} \item{value}{Whether to browse \code{env}.} } \value{ \code{env_browse()} returns the previous value of \code{env_is_browsed()} (a logical), invisibly. } \description{ \itemize{ \item \code{env_browse(env)} is equivalent to evaluating \code{browser()} in \code{env}. It persistently sets the environment for step-debugging. Supply \code{value = FALSE} to disable browsing. \item \code{env_is_browsed()} is a predicate that inspects whether an environment is being browsed. } } rlang/man/zap_srcref.Rd0000644000176200001440000000153414127057575014575 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/attr.R \name{zap_srcref} \alias{zap_srcref} \title{Zap source references} \usage{ zap_srcref(x) } \arguments{ \item{x}{An R object. Functions and calls are walked recursively.} } \description{ There are a number of situations where R creates source references: \itemize{ \item Reading R code from a file with \code{source()} and \code{parse()} might save source references inside calls to \code{function} and \verb{\{}. \item \code{\link[=sys.call]{sys.call()}} includes a source reference if possible. \item Creating a closure stores the source reference from the call to \code{function}, if any. } These source references take up space and might cause a number of issues. \code{zap_srcref()} recursively walks through expressions and functions to remove all source references. } rlang/man/is_lang.Rd0000644000176200001440000000261314375670676014062 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/lifecycle-deprecated.R \name{is_lang} \alias{is_lang} \title{Is object a call?} \usage{ is_lang(x, name = NULL, n = NULL, ns = NULL) } \arguments{ \item{x}{An object to test. Formulas and quosures are treated literally.} \item{name}{An optional name that the call should match. It is passed to \code{\link[=sym]{sym()}} before matching. This argument is vectorised and you can supply a vector of names to match. In this case, \code{is_call()} returns \code{TRUE} if at least one name matches.} \item{n}{An optional number of arguments that the call should match.} \item{ns}{The namespace of the call. If \code{NULL}, the namespace doesn't participate in the pattern-matching. If an empty string \code{""} and \code{x} is a namespaced call, \code{is_call()} returns \code{FALSE}. If any other string, \code{is_call()} checks that \code{x} is namespaced within \code{ns}. Can be a character vector of namespaces, in which case the call has to match at least one of them, otherwise \code{is_call()} returns \code{FALSE}.} } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} These functions are deprecated, please use \code{\link[=is_call]{is_call()}} and its \code{n} argument instead. } \keyword{internal} rlang/man/scoped_env.Rd0000644000176200001440000000132214375670676014567 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/lifecycle-deprecated.R \name{scoped_env} \alias{scoped_env} \alias{is_scoped} \title{Deprecated \code{scoped} functions} \usage{ scoped_env(nm) is_scoped(nm) } \arguments{ \item{nm}{The name of an environment attached to the search path. Call \code{\link[base:search]{base::search()}} to see what is currently on the path.} } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} These functions are deprecated as of rlang 0.3.0. Please use \code{\link[=is_attached]{is_attached()}} instead. } \keyword{internal} rlang/man/topic-condition-customisation.Rd0000644000176200001440000000774414626300474020442 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/topic-errors.R \name{topic-condition-customisation} \alias{topic-condition-customisation} \title{Customising condition messages} \description{ Various aspects of the condition messages displayed by \code{\link[=abort]{abort()}}, \code{\link[=warn]{warn()}}, and \code{\link[=inform]{inform()}} can be customised using options from the \href{https://cli.r-lib.org}{cli} package. } \section{Turning off unicode bullets}{ By default, bulleted lists are prefixed with unicode symbols: \ifelse{latex}{\emph{Not in PDF manual.}}{\if{html}{\out{
}}\preformatted{rlang::abort(c( "The error message.", "*" = "Regular bullet.", "i" = "Informative bullet.", "x" = "Cross bullet.", "v" = "Victory bullet.", ">" = "Arrow bullet." )) #> Error: #> ! The error message. #> • Regular bullet. #> ℹ Informative bullet. #> ✖ Cross bullet. #> ✔ Victory bullet. #> → Arrow bullet. }\if{html}{\out{
}}} Set this option to use simple letters instead: \if{html}{\out{
}}\preformatted{options(cli.condition_unicode_bullets = FALSE) rlang::abort(c( "The error message.", "*" = "Regular bullet.", "i" = "Informative bullet.", "x" = "Cross bullet.", "v" = "Victory bullet.", ">" = "Arrow bullet." )) #> Error: #> ! The error message. #> * Regular bullet. #> i Informative bullet. #> x Cross bullet. #> v Victory bullet. #> > Arrow bullet. }\if{html}{\out{
}} } \section{Changing the bullet symbols}{ You can specify what symbol to use for each type of bullet through your cli user theme. For instance, here is how to uniformly use \code{*} for all bullet kinds: \if{html}{\out{
}}\preformatted{options(cli.user_theme = list( ".cli_rlang .bullet-*" = list(before = "* "), ".cli_rlang .bullet-i" = list(before = "* "), ".cli_rlang .bullet-x" = list(before = "* "), ".cli_rlang .bullet-v" = list(before = "* "), ".cli_rlang .bullet->" = list(before = "* ") )) rlang::abort(c( "The error message.", "*" = "Regular bullet.", "i" = "Informative bullet.", "x" = "Cross bullet.", "v" = "Victory bullet.", ">" = "Arrow bullet." )) #> Error: #> ! The error message. #> * Regular bullet. #> * Informative bullet. #> * Cross bullet. #> * Victory bullet. #> * Arrow bullet. }\if{html}{\out{
}} If you want all the bullets to be the same, including the leading bullet, you can achieve this using the \code{bullet} class: \if{html}{\out{
}}\preformatted{options(cli.user_theme = list( ".cli_rlang .bullet" = list(before = "* ") )) rlang::abort(c( "The error message.", "*" = "Regular bullet.", "i" = "Informative bullet.", "x" = "Cross bullet.", "v" = "Victory bullet.", ">" = "Arrow bullet." )) #> Error: #> * The error message. #> * Regular bullet. #> * Informative bullet. #> * Cross bullet. #> * Victory bullet. #> * Arrow bullet. }\if{html}{\out{
}} } \section{Changing the foreground and background colour of error calls}{ When called inside a function, \code{abort()} displays the function call to help contextualise the error: \if{html}{\out{
}}\preformatted{splash <- function() \{ abort("Can't splash without water.") \} splash() #> Error in `splash()`: #> ! Can't splash without water. }\if{html}{\out{
}} The call is formatted with cli as a \code{code} element. This is not visible in the manual, but code text is formatted with a highlighted background colour by default. When this can be reliably detected, that background colour is different depending on whether you're using a light or dark theme. You can override the colour of code elements in your cli theme. Here is my personal configuration that fits well with the colour theme I currently use in my IDE: \if{html}{\out{
}}\preformatted{options(cli.user_theme = list( span.code = list( "background-color" = "#3B4252", color = "#E5E9F0" ) )) }\if{html}{\out{
}} } \keyword{internal} rlang/man/env_is_user_facing.Rd0000644000176200001440000000300714401366600016247 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/env.R \name{env_is_user_facing} \alias{env_is_user_facing} \title{Is frame environment user facing?} \usage{ env_is_user_facing(env) } \arguments{ \item{env}{An environment.} } \description{ Detects if \code{env} is user-facing, that is, whether it's an environment that inherits from: \itemize{ \item The global environment, as would happen when called interactively \item A package that is currently being tested } If either is true, we consider \code{env} to belong to an evaluation frame that was called \emph{directly} by the end user. This is by contrast to \emph{indirect} calls by third party functions which are not user facing. For instance the \href{https://lifecycle.r-lib.org/}{lifecycle} package uses \code{env_is_user_facing()} to figure out whether a deprecated function was called directly or indirectly, and select an appropriate verbosity level as a function of that. } \section{Escape hatch}{ You can override the return value of \code{env_is_user_facing()} by setting the global option \code{"rlang_user_facing"} to: \itemize{ \item \code{TRUE} or \code{FALSE}. \item A package name as a string. Then \code{env_is_user_facing(x)} returns \code{TRUE} if \code{x} inherits from the namespace corresponding to that package name. } } \examples{ fn <- function() { env_is_user_facing(caller_env()) } # Direct call of `fn()` from the global env with(global_env(), fn()) # Indirect call of `fn()` from a package with(ns_env("utils"), fn()) } rlang/man/format_error_call.Rd0000644000176200001440000000405314375670676016142 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cnd-abort.R \name{format_error_call} \alias{format_error_call} \alias{error_call} \title{Validate and format a function call for use in error messages} \usage{ format_error_call(call) error_call(call) } \arguments{ \item{call}{The execution environment of a currently running function, e.g. \code{caller_env()}. The function will be mentioned in error messages as the source of the error. See the \code{call} argument of \code{\link[=abort]{abort()}} for more information.} } \value{ Either a string formatted as code or \code{NULL} if a simple call could not be generated. } \description{ \itemize{ \item \code{error_call()} takes either a frame environment or a call. If the input is an environment, \code{error_call()} acts like \code{\link[=frame_call]{frame_call()}} with some additional logic, e.g. for S3 methods and for frames with a \code{\link[=local_error_call]{local_error_call()}}. \item \code{format_error_call()} simplifies its input to a simple call (see section below) and formats the result as code (using cli if available). Use this function to generate the "in" part of an error message from a stack frame call. \code{format_error_call()} first passes its input to \code{error_call()} to fetch calls from frame environments. } } \section{Details of formatting}{ \itemize{ \item The arguments of function calls are stripped. \item Complex function calls containing inlined objects return \code{NULL}. \item Calls to \code{if} preserve the condition since it might be informative. Branches are dropped. \item Calls to operators and other special syntax are formatted using their names rather than the potentially confusing function form. } } \examples{ # Arguments are stripped writeLines(format_error_call(quote(foo(bar, baz)))) # Returns `NULL` with complex calls such as those that contain # inlined functions format_error_call(call2(list)) # Operators are formatted using their names rather than in # function call form writeLines(format_error_call(quote(1 + 2))) } \keyword{internal} rlang/man/new_node.Rd0000644000176200001440000000342614137447476014243 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/node.R \name{new_node} \alias{new_node} \alias{node_car} \alias{node_cdr} \alias{node_caar} \alias{node_cadr} \alias{node_cdar} \alias{node_cddr} \alias{node_poke_car} \alias{node_poke_cdr} \alias{node_poke_caar} \alias{node_poke_cadr} \alias{node_poke_cdar} \alias{node_poke_cddr} \alias{node_tag} \alias{node_poke_tag} \title{Helpers for pairlist and language nodes} \usage{ new_node(car, cdr = NULL) node_car(x) node_cdr(x) node_caar(x) node_cadr(x) node_cdar(x) node_cddr(x) node_poke_car(x, newcar) node_poke_cdr(x, newcdr) node_poke_caar(x, newcar) node_poke_cadr(x, newcar) node_poke_cdar(x, newcdr) node_poke_cddr(x, newcdr) node_tag(x) node_poke_tag(x, newtag) } \arguments{ \item{car, newcar, cdr, newcdr}{The new CAR or CDR for the node. These can be any R objects.} \item{x}{A language or pairlist node. Note that these functions are barebones and do not perform any type checking.} \item{newtag}{The new tag for the node. This should be a symbol.} } \value{ Setters like \code{node_poke_car()} invisibly return \code{x} modified in place. Getters return the requested node component. } \description{ \strong{Important}: These functions are for expert R programmers only. You should only use them if you feel comfortable manipulating low level R data structures at the C level. We export them at the R level in order to make it easy to prototype C code. They don't perform any type checking and can crash R very easily (try to take the CAR of an integer vector --- save any important objects beforehand!). } \seealso{ \code{\link[=duplicate]{duplicate()}} for creating copy-safe objects and \code{\link[base:list]{base::pairlist()}} for an easier way of creating a linked list of nodes. } \keyword{internal} rlang/man/topic-embrace-non-args.Rd0000644000176200001440000000313614375670676016703 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/topic-nse.R \name{topic-embrace-non-args} \alias{topic-embrace-non-args} \title{Does \verb{\{\{} work on regular objects?} \description{ The embrace operator \ifelse{html}{\code{\link[=embrace-operator]{\{\{}}}{\verb{\{\{}} should be used exclusively with function arguments: \if{html}{\out{
}}\preformatted{fn <- function(arg) \{ quo(foo(\{\{ arg \}\})) \} fn(1 + 1) #> #> expr: ^foo(^1 + 1) #> env: 0x7ffd89aac518 }\if{html}{\out{
}} However you may have noticed that it also works on regular objects: \if{html}{\out{
}}\preformatted{fn <- function(arg) \{ arg <- force(arg) quo(foo(\{\{ arg \}\})) \} fn(1 + 1) #> #> expr: ^foo(^2) #> env: 0x7ffd8a633398 }\if{html}{\out{
}} In that case, \verb{\{\{} captures the \emph{value} of the expression instead of a defused expression. That's because only function arguments can be defused. Note that this issue also applies to \code{\link[=enquo]{enquo()}} (on which \verb{\{\{} is based). } \section{Why is this not an error?}{ Ideally we would have made \verb{\{\{} on regular objects an error. However this is not possible because in compiled R code it is not always possible to distinguish a regular variable from a function argument. See \ifelse{html}{\link[=topic-embrace-constants]{Why are strings and other constants enquosed in the empty environment?}}{\link[=topic-embrace-constants]{Why are strings and other constants enquosed in the empty environment?}} for more about this. } \keyword{internal} rlang/man/call_inspect.Rd0000644000176200001440000000122014175213516015057 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/stack.R \name{call_inspect} \alias{call_inspect} \title{Inspect a call} \usage{ call_inspect(...) } \arguments{ \item{...}{Arguments to display in the returned call.} } \description{ This function is a wrapper around \code{\link[base:match.call]{base::match.call()}}. It returns its own function call. } \examples{ # When you call it directly, it simply returns what you typed call_inspect(foo(bar), "" \%>\% identity()) # Pass `call_inspect` to functionals like `lapply()` or `map()` to # inspect the calls they create around the supplied function lapply(1:3, call_inspect) } rlang/man/args_error_context.Rd0000644000176200001440000000322514375670676016357 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cnd-abort.R \name{args_error_context} \alias{args_error_context} \title{Documentation anchor for error arguments} \arguments{ \item{arg}{An argument name as a string. This argument will be mentioned in error messages as the input that is at the origin of a problem.} \item{error_arg}{An argument name as a string. This argument will be mentioned in error messages as the input that is at the origin of a problem.} \item{call}{The execution environment of a currently running function, e.g. \code{caller_env()}. The function will be mentioned in error messages as the source of the error. See the \code{call} argument of \code{\link[=abort]{abort()}} for more information.} \item{error_call}{The execution environment of a currently running function, e.g. \code{caller_env()}. The function will be mentioned in error messages as the source of the error. See the \code{call} argument of \code{\link[=abort]{abort()}} for more information.} } \description{ Use \verb{@inheritParams rlang::args_error_context} in your package to document \code{arg} and \code{call} arguments (or equivalently their prefixed versions \code{error_arg} and \code{error_call}). \itemize{ \item \code{arg} parameters should be formatted as argument (e.g. using cli's \code{.arg} specifier) and included in error messages. See also \code{\link[=caller_arg]{caller_arg()}}. \item \code{call} parameters should be included in error conditions in a field named \code{call}. An easy way to do this is by passing a \code{call} argument to \code{\link[=abort]{abort()}}. See also \code{\link[=local_error_call]{local_error_call()}}. } } rlang/man/as_name.Rd0000644000176200001440000000307414375670676014053 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/deparse.R \name{as_name} \alias{as_name} \title{Extract names from symbols} \usage{ as_name(x) } \arguments{ \item{x}{A string or symbol, possibly wrapped in a \link{quosure}. If a string, the attributes are removed, if any.} } \value{ A character vector of length 1. } \description{ \code{as_name()} converts \link[=sym]{symbols} to character strings. The conversion is deterministic. That is, the roundtrip \code{symbol -> name -> symbol} always gives the same result. \itemize{ \item Use \code{as_name()} when you need to transform a symbol to a string to \emph{refer} to an object by its name. \item Use \code{\link[=as_label]{as_label()}} when you need to transform any kind of object to a string to \emph{represent} that object with a short description. } } \details{ \code{rlang::as_name()} is the \emph{opposite} of \code{\link[base:name]{base::as.name()}}. If you're writing base R code, we recommend using \code{\link[base:name]{base::as.symbol()}} which is an alias of \code{as.name()} that follows a more modern terminology (R types instead of S modes). } \examples{ # Let's create some symbols: foo <- quote(foo) bar <- sym("bar") # as_name() converts symbols to strings: foo as_name(foo) typeof(bar) typeof(as_name(bar)) # as_name() unwraps quosured symbols automatically: as_name(quo(foo)) } \seealso{ \code{\link[=as_label]{as_label()}} for converting any object to a single string suitable as a label. \code{\link[=as_string]{as_string()}} for a lower-level version that doesn't unwrap quosures. } rlang/man/check_dots_used.Rd0000644000176200001440000000443714626342040015556 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/dots-ellipsis.R \name{check_dots_used} \alias{check_dots_used} \title{Check that all dots have been used} \usage{ check_dots_used( env = caller_env(), call = caller_env(), error = NULL, action = deprecated() ) } \arguments{ \item{env}{Environment in which to look for \code{...} and to set up handler.} \item{call}{The execution environment of a currently running function, e.g. \code{caller_env()}. The function will be mentioned in error messages as the source of the error. See the \code{call} argument of \code{\link[=abort]{abort()}} for more information.} \item{error}{An optional error handler passed to \code{\link[=try_fetch]{try_fetch()}}. Use this e.g. to demote an error into a warning.} \item{action}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}}} } \description{ When \code{...} arguments are passed to methods, it is assumed there method will match and use these arguments. If this isn't the case, this often indicates a programming error. Call \code{check_dots_used()} to fail with an error when unused arguments are detected. } \details{ In packages, document \code{...} with this standard tag: \if{html}{\out{
}}\preformatted{ @inheritParams rlang::args_dots_used }\if{html}{\out{
}} \code{check_dots_used()} implicitly calls \code{\link[=on.exit]{on.exit()}} to check that all elements of \code{...} have been used when the function exits. If you use \code{\link[=on.exit]{on.exit()}} elsewhere in your function, make sure to use \code{add = TRUE} so that you don't override the handler set up by \code{check_dots_used()}. } \examples{ f <- function(...) { check_dots_used() g(...) } g <- function(x, y, ...) { x + y } f(x = 1, y = 2) try(f(x = 1, y = 2, z = 3)) try(f(x = 1, y = 2, 3, 4, 5)) # Use an `error` handler to handle the error differently. # For instance to demote the error to a warning: fn <- function(...) { check_dots_empty( error = function(cnd) { warning(cnd) } ) "out" } fn() } \seealso{ Other dots checking functions: \code{\link{check_dots_empty}()}, \code{\link{check_dots_unnamed}()} } \concept{dots checking functions} rlang/man/fn_env.Rd0000644000176200001440000000173714375670676013727 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/fn.R \name{fn_env} \alias{fn_env} \alias{fn_env<-} \title{Return the closure environment of a function} \usage{ fn_env(fn) fn_env(x) <- value } \arguments{ \item{fn, x}{A function.} \item{value}{A new closure environment for the function.} } \description{ Closure environments define the scope of functions (see \code{\link[=env]{env()}}). When a function call is evaluated, R creates an evaluation frame that inherits from the closure environment. This makes all objects defined in the closure environment and all its parents available to code executed within the function. } \details{ \code{fn_env()} returns the closure environment of \code{fn}. There is also an assignment method to set a new closure environment. } \examples{ env <- child_env("base") fn <- with_env(env, function() NULL) identical(fn_env(fn), env) other_env <- child_env("base") fn_env(fn) <- other_env identical(fn_env(fn), other_env) } rlang/man/search_envs.Rd0000644000176200001440000000612714127057575014742 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/env-special.R \name{search_envs} \alias{search_envs} \alias{search_env} \alias{pkg_env} \alias{pkg_env_name} \alias{is_attached} \alias{base_env} \alias{global_env} \title{Search path environments} \usage{ search_envs() search_env(name) pkg_env(pkg) pkg_env_name(pkg) is_attached(x) base_env() global_env() } \arguments{ \item{name}{The name of an environment attached to the search path. Call \code{\link[base:search]{base::search()}} to get the names of environments currently attached to the search path. Note that the search name of a package environment is prefixed with \code{"package:"}.} \item{pkg}{The name of a package.} \item{x}{An environment or a search name.} } \description{ The search path is a chain of environments containing exported functions of attached packages. The API includes: \itemize{ \item \code{\link[base:search]{base::search()}} to get the names of environments attached to the search path. \item \code{search_envs()} returns the environments on the search path as a list. \item \code{pkg_env_name()} takes a bare package name and prefixes it with \code{"package:"}. Attached package environments have search names of the form \code{package:name}. \item \code{pkg_env()} takes a bare package name and returns the scoped environment of packages if they are attached to the search path, and throws an error otherwise. It is a shortcut for \code{search_env(pkg_env_name("pkgname"))}. \item \code{global_env()} and \code{base_env()} (simple aliases for \code{\link[=globalenv]{globalenv()}} and \code{\link[=baseenv]{baseenv()}}). These are respectively the first and last environments of the search path. \item \code{is_attached()} returns \code{TRUE} when its argument (a search name or a package environment) is attached to the search path. } } \section{The search path}{ This chain of environments determines what objects are visible from the global workspace. It contains the following elements: \itemize{ \item The chain always starts with \code{global_env()} and finishes with \code{base_env()} which inherits from the terminal environment \code{empty_env()}. \item Each \code{\link[base:library]{base::library()}} call attaches a new package environment to the search path. Attached packages are associated with a \link[=env_name]{search name}. \item In addition, any list, data frame, or environment can be attached to the search path with \code{\link[base:attach]{base::attach()}}. } } \examples{ # List the search names of environments attached to the search path: search() # Get the corresponding environments: search_envs() # The global environment and the base package are always first and # last in the chain, respectively: envs <- search_envs() envs[[1]] envs[[length(envs)]] # These two environments have their own shortcuts: global_env() base_env() # Packages appear in the search path with a special name. Use # pkg_env_name() to create that name: pkg_env_name("rlang") search_env(pkg_env_name("rlang")) # Alternatively, get the scoped environment of a package with # pkg_env(): pkg_env("utils") } \keyword{internal} rlang/man/is_pairlist.Rd0000644000176200001440000000171013351410654014742 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/node.R \name{is_pairlist} \alias{is_pairlist} \alias{is_node} \alias{is_node_list} \title{Is object a node or pairlist?} \usage{ is_pairlist(x) is_node(x) is_node_list(x) } \arguments{ \item{x}{Object to test.} } \description{ \itemize{ \item \code{is_pairlist()} checks that \code{x} has type \code{pairlist}. \item \code{is_node()} checks that \code{x} has type \code{pairlist} or \code{language}. It tests whether \code{x} is a node that has a CAR and a CDR, including callable nodes (language objects). \item \code{is_node_list()} checks that \code{x} has type \code{pairlist} or \code{NULL}. \code{NULL} is the empty node list. } } \section{Life cycle}{ These functions are experimental. We are still figuring out a good naming convention to refer to the different lisp-like lists in R. } \seealso{ \code{\link[=is_call]{is_call()}} tests for language nodes. } \keyword{internal} rlang/man/f_text.Rd0000644000176200001440000000132014127057575013721 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_name} \alias{f_label} \title{Turn RHS of formula into a string or label} \usage{ f_text(x, width = 60L, nlines = Inf) f_name(x) 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]{expr_text()}} and \code{\link[=expr_label]{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) })) } rlang/man/bare-type-predicates.Rd0000644000176200001440000000314414626342040016433 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/types.R \name{bare-type-predicates} \alias{bare-type-predicates} \alias{is_bare_list} \alias{is_bare_atomic} \alias{is_bare_vector} \alias{is_bare_double} \alias{is_bare_complex} \alias{is_bare_integer} \alias{is_bare_numeric} \alias{is_bare_character} \alias{is_bare_logical} \alias{is_bare_raw} \alias{is_bare_string} \alias{is_bare_bytes} \title{Bare type predicates} \usage{ is_bare_list(x, n = NULL) is_bare_atomic(x, n = NULL) is_bare_vector(x, n = NULL) is_bare_double(x, n = NULL) is_bare_complex(x, n = NULL) is_bare_integer(x, n = NULL) is_bare_numeric(x, n = NULL) is_bare_character(x, n = NULL) is_bare_logical(x, n = NULL) is_bare_raw(x, n = NULL) is_bare_string(x, n = NULL) is_bare_bytes(x, n = NULL) } \arguments{ \item{x}{Object to be tested.} \item{n}{Expected length of a vector.} } \description{ These predicates check for a given type but only return \code{TRUE} for bare R objects. Bare objects have no class attributes. For example, a data frame is a list, but not a bare list. } \details{ \itemize{ \item The predicates for vectors include the \code{n} argument for pattern-matching on the vector length. \item Like \code{\link[=is_atomic]{is_atomic()}} and unlike base R \code{is.atomic()} for R < 4.4.0, \code{is_bare_atomic()} does not return \code{TRUE} for \code{NULL}. Starting in R 4.4.0, \code{is.atomic(NULL)} returns FALSE. \item Unlike base R \code{is.numeric()}, \code{is_bare_double()} only returns \code{TRUE} for floating point numbers. } } \seealso{ \link{type-predicates}, \link{scalar-type-predicates} } rlang/man/last_error.Rd0000644000176200001440000000206714375670676014625 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cnd-last.R \name{last_error} \alias{last_error} \alias{last_trace} \title{Last \code{abort()} error} \usage{ last_error() last_trace(drop = NULL) } \arguments{ \item{drop}{Whether to drop technical calls. These are hidden from users by default, set \code{drop} to \code{FALSE} to see the full backtrace.} } \description{ \itemize{ \item \code{last_error()} returns the last error entraced by \code{\link[=abort]{abort()}} or \code{\link[=global_entrace]{global_entrace()}}. The error is printed with a backtrace in simplified form. \item \code{last_trace()} is a shortcut to return the backtrace stored in the last error. This backtrace is printed in full form. } } \seealso{ \itemize{ \item \code{\link{rlang_backtrace_on_error}} to control what is displayed when an error is thrown. \item \code{\link[=global_entrace]{global_entrace()}} to enable \code{last_error()} logging for all errors. \item \code{\link[=last_warnings]{last_warnings()}} and \code{\link[=last_messages]{last_messages()}}. } } rlang/man/is_dictionaryish.Rd0000644000176200001440000000053514375670676016013 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/attr.R \name{is_dictionaryish} \alias{is_dictionaryish} \title{Is a vector uniquely named?} \usage{ is_dictionaryish(x) } \arguments{ \item{x}{A vector.} } \description{ Like \code{\link[=is_named]{is_named()}} but also checks that names are unique. } \keyword{internal} rlang/man/stack-deprecated.Rd0000644000176200001440000000107114375670676015646 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/lifecycle-deprecated.R \name{stack-deprecated} \alias{stack-deprecated} \alias{ctxt_frame} \alias{global_frame} \title{Call stack information} \usage{ ctxt_frame(n = 1) global_frame() } \arguments{ \item{n}{The number of frames to go back in the stack.} } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} Deprecated as of rlang 0.3.0. } \keyword{internal} rlang/man/new_call.Rd0000644000176200001440000000074614375670676014237 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/node.R \name{new_call} \alias{new_call} \title{Create a new call from components} \usage{ new_call(car, cdr = NULL) } \arguments{ \item{car}{The head of the call. It should be a \link[=is_callable]{callable} object: a symbol, call, or literal function.} \item{cdr}{The tail of the call, i.e. a \link[=new_node]{pairlist} of arguments.} } \description{ Create a new call from components } \keyword{internal} rlang/man/env_bind.Rd0000644000176200001440000001352014375670676014231 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/env-binding.R \name{env_bind} \alias{env_bind} \alias{env_bind_lazy} \alias{env_bind_active} \alias{\%<~\%} \title{Bind symbols to objects in an environment} \usage{ env_bind(.env, ...) env_bind_lazy(.env, ..., .eval_env = caller_env()) env_bind_active(.env, ...) lhs \%<~\% rhs } \arguments{ \item{.env}{An environment.} \item{...}{<\link[=dyn-dots]{dynamic}> Named objects (\code{env_bind()}), expressions \code{env_bind_lazy()}, or functions (\code{env_bind_active()}). Use \code{\link[=zap]{zap()}} to remove bindings.} \item{.eval_env}{The environment where the expressions will be evaluated when the symbols are forced.} \item{lhs}{The variable name to which \code{rhs} will be lazily assigned.} \item{rhs}{An expression lazily evaluated and assigned to \code{lhs}.} } \value{ The input object \code{.env}, with its associated environment modified in place, invisibly. } \description{ These functions create bindings in an environment. The bindings are supplied through \code{...} as pairs of names and values or expressions. \code{env_bind()} is equivalent to evaluating a \verb{<-} expression within the given environment. This function should take care of the majority of use cases but the other variants can be useful for specific problems. \itemize{ \item \code{env_bind()} takes named \emph{values} which are bound in \code{.env}. \code{env_bind()} is equivalent to \code{\link[base:assign]{base::assign()}}. \item \code{env_bind_active()} takes named \emph{functions} and creates active bindings in \code{.env}. This is equivalent to \code{\link[base:bindenv]{base::makeActiveBinding()}}. An active binding executes a function each time it is evaluated. The arguments are passed to \code{\link[=as_function]{as_function()}} so you can supply formulas instead of functions. Remember that functions are scoped in their own environment. These functions can thus refer to symbols from this enclosure that are not actually in scope in the dynamic environment where the active bindings are invoked. This allows creative solutions to difficult problems (see the implementations of \code{dplyr::do()} methods for an example). \item \code{env_bind_lazy()} takes named \emph{expressions}. This is equivalent to \code{\link[base:delayedAssign]{base::delayedAssign()}}. The arguments are captured with \code{\link[=exprs]{exprs()}} (and thus support call-splicing and unquoting) and assigned to symbols in \code{.env}. These expressions are not evaluated immediately but lazily. Once a symbol is evaluated, the corresponding expression is evaluated in turn and its value is bound to the symbol (the expressions are thus evaluated only once, if at all). \item \verb{\%<~\%} is a shortcut for \code{env_bind_lazy()}. It works like \verb{<-} but the RHS is evaluated lazily. } } \section{Side effects}{ Since environments have reference semantics (see relevant section in \code{\link[=env]{env()}} documentation), modifying the bindings of an environment produces effects in all other references to that environment. In other words, \code{env_bind()} and its variants have side effects. Like other side-effecty functions like \code{par()} and \code{options()}, \code{env_bind()} and variants return the old values invisibly. } \examples{ # env_bind() is a programmatic way of assigning values to symbols # with `<-`. We can add bindings in the current environment: env_bind(current_env(), foo = "bar") foo # Or modify those bindings: bar <- "bar" env_bind(current_env(), bar = "BAR") bar # You can remove bindings by supplying zap sentinels: env_bind(current_env(), foo = zap()) try(foo) # Unquote-splice a named list of zaps zaps <- rep_named(c("foo", "bar"), list(zap())) env_bind(current_env(), !!!zaps) try(bar) # It is most useful to change other environments: my_env <- env() env_bind(my_env, foo = "foo") my_env$foo # A useful feature is to splice lists of named values: vals <- list(a = 10, b = 20) env_bind(my_env, !!!vals, c = 30) my_env$b my_env$c # You can also unquote a variable referring to a symbol or a string # as binding name: var <- "baz" env_bind(my_env, !!var := "BAZ") my_env$baz # The old values of the bindings are returned invisibly: old <- env_bind(my_env, a = 1, b = 2, baz = "baz") old # You can restore the original environment state by supplying the # old values back: env_bind(my_env, !!!old) # env_bind_lazy() assigns expressions lazily: env <- env() env_bind_lazy(env, name = { cat("forced!\n"); "value" }) # Referring to the binding will cause evaluation: env$name # But only once, subsequent references yield the final value: env$name # You can unquote expressions: expr <- quote(message("forced!")) env_bind_lazy(env, name = !!expr) env$name # By default the expressions are evaluated in the current # environment. For instance we can create a local binding and refer # to it, even though the variable is bound in a different # environment: who <- "mickey" env_bind_lazy(env, name = paste(who, "mouse")) env$name # You can specify another evaluation environment with `.eval_env`: eval_env <- env(who = "minnie") env_bind_lazy(env, name = paste(who, "mouse"), .eval_env = eval_env) env$name # Or by unquoting a quosure: quo <- local({ who <- "fievel" quo(paste(who, "mouse")) }) env_bind_lazy(env, name = !!quo) env$name # You can create active bindings with env_bind_active(). Active # bindings execute a function each time they are evaluated: fn <- function() { cat("I have been called\n") rnorm(1) } env <- env() env_bind_active(env, symbol = fn) # `fn` is executed each time `symbol` is evaluated or retrieved: env$symbol env$symbol eval_bare(quote(symbol), env) eval_bare(quote(symbol), env) # All arguments are passed to as_function() so you can use the # formula shortcut: env_bind_active(env, foo = ~ runif(1)) env$foo env$foo } \seealso{ \code{\link[=env_poke]{env_poke()}} for binding a single element. } rlang/man/as_box.Rd0000644000176200001440000000145214375670676013721 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/s3.R \name{as_box} \alias{as_box} \alias{as_box_if} \title{Convert object to a box} \usage{ as_box(x, class = NULL) as_box_if(.x, .p, .class = NULL, ...) } \arguments{ \item{x, .x}{An R object.} \item{class, .class}{A box class. If the input is already a box of that class, it is returned as is. If the input needs to be boxed, \code{class} is passed to \code{\link[=new_box]{new_box()}}.} \item{.p}{A predicate function.} \item{...}{Arguments passed to \code{.p}.} } \description{ \itemize{ \item \code{as_box()} boxes its input only if it is not already a box. The class is also checked if supplied. \item \code{as_box_if()} boxes its input only if it not already a box, or if the predicate \code{.p} returns \code{TRUE}. } } rlang/man/args_dots_used.Rd0000644000176200001440000000062514375670676015454 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/dots-ellipsis.R \name{args_dots_used} \alias{args_dots_used} \title{Helper for consistent documentation of used dots} \arguments{ \item{...}{Arguments passed to methods.} } \description{ Use \verb{@inheritParams rlang::args_dots_used} in your package to consistently document \code{...} that must be used. } \keyword{internal} rlang/man/topic-embrace-constants.Rd0000644000176200001440000000644614375670676017202 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/topic-nse.R \name{topic-embrace-constants} \alias{topic-embrace-constants} \title{Why are strings and other constants enquosed in the empty environment?} \description{ Function arguments are \link[=topic-defuse]{defused} into \link[=topic-quosure]{quosures} that keep track of the environment of the defused expression. \if{html}{\out{
}}\preformatted{quo(1 + 1) #> #> expr: ^1 + 1 #> env: global }\if{html}{\out{
}} You might have noticed that when constants are supplied, the quosure tracks the empty environment instead of the current environmnent. \if{html}{\out{
}}\preformatted{quos("foo", 1, NULL) #> > #> #> [[1]] #> #> expr: ^"foo" #> env: empty #> #> [[2]] #> #> expr: ^1 #> env: empty #> #> [[3]] #> #> expr: ^NULL #> env: empty }\if{html}{\out{
}} The reason for this has to do with compilation of R code which makes it impossible to consistently capture environments of constants from function arguments. Argument defusing relies on the \emph{promise} mechanism of R for lazy evaluation of arguments. When functions are compiled and R notices that an argument is constant, it avoids creating a promise since they slow down function evaluation. Instead, the function is directly supplied a naked constant instead of constant wrapped in a promise. } \section{Concrete case of promise unwrapping by compilation}{ We can observe this optimisation by calling into the C-level \code{findVar()} function to capture promises. \if{html}{\out{
}}\preformatted{# Return the object bound to `arg` without triggering evaluation of # promises f <- function(arg) \{ rlang:::find_var(current_env(), sym("arg")) \} # Call `f()` with a symbol or with a constant g <- function(symbolic) \{ if (symbolic) \{ f(letters) \} else \{ f("foo") \} \} # Make sure these small functions are compiled f <- compiler::cmpfun(f) g <- compiler::cmpfun(g) }\if{html}{\out{
}} When \code{f()} is called with a symbolic argument, we get the promise object created by R. \if{html}{\out{
}}\preformatted{g(symbolic = TRUE) #> }\if{html}{\out{
}} However, supplying a constant to \code{"f"} returns the constant directly. \if{html}{\out{
}}\preformatted{g(symbolic = FALSE) #> [1] "foo" }\if{html}{\out{
}} Without a promise, there is no way to figure out the original environment of an argument. } \section{Do we need environments for constants?}{ Data-masking APIs in the tidyverse are intentionally designed so that they don't need an environment for constants. \itemize{ \item Data-masking APIs should be able to interpret constants. These can arise from normal argument passing as we have seen, or by \link[=topic-inject]{injection} with \verb{!!}. There should be no difference between \code{dplyr::mutate(mtcars, var = cyl)} and \code{dplyr::mutate(mtcars, var = !!mtcars$cyl)}. \item Data-masking is an \emph{evaluation} idiom, not an \emph{introspective} one. The behaviour of data-masking function should not depend on the calling environment when a constant (or a symbol evaluating to a given value) is supplied. } } \keyword{internal} rlang/man/is_environment.Rd0000644000176200001440000000061413351410763015462 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/types.R \name{is_environment} \alias{is_environment} \alias{is_bare_environment} \title{Is object an environment?} \usage{ is_environment(x) is_bare_environment(x) } \arguments{ \item{x}{object to test} } \description{ \code{is_bare_environment()} tests whether \code{x} is an environment without a s3 or s4 class. } rlang/man/scoped_interactive.Rd0000644000176200001440000000247214375670676016323 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/lifecycle-deprecated.R \name{scoped_interactive} \alias{scoped_interactive} \alias{scoped_options} \alias{scoped_bindings} \title{Deprecated \code{scoped_} functions} \usage{ scoped_interactive(value = TRUE, frame = caller_env()) scoped_options(..., .frame = caller_env()) scoped_bindings(..., .env = .frame, .frame = caller_env()) } \arguments{ \item{value}{A single \code{TRUE} or \code{FALSE}. This overrides the return value of \code{is_interactive()}.} \item{frame, .frame}{The environment of a running function which defines the scope of the temporary options. When the function returns, the options are reset to their original values.} \item{...}{For \code{local_options()} and \code{push_options()}, named values defining new option values. For \code{peek_options()}, strings or character vectors of option names.} \item{.env}{An environment.} } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} Deprecated as of rlang 0.4.2. Use \code{\link[=local_interactive]{local_interactive()}}, \code{\link[=local_options]{local_options()}}, or \code{\link[=local_bindings]{local_bindings()}} instead. } \keyword{internal} rlang/man/with_handlers.Rd0000644000176200001440000000153414375670676015302 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/lifecycle-deprecated.R \name{with_handlers} \alias{with_handlers} \alias{calling} \alias{exiting} \title{Establish handlers on the stack} \usage{ with_handlers(.expr, ...) calling(handler) exiting(handler) } \arguments{ \item{.expr, ..., handler}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}}} } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} As of rlang 1.0.0, \code{with_handlers()} is deprecated. Use the base functions or the experimental \code{\link[=try_fetch]{try_fetch()}} function instead. } \keyword{internal} rlang/man/expr_interp.Rd0000644000176200001440000000132614375670676015005 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/lifecycle-deprecated.R \name{expr_interp} \alias{expr_interp} \title{Process unquote operators in a captured expression} \usage{ expr_interp(x, env = NULL) } \arguments{ \item{x, env}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}}} } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} \code{expr_interp()} is deprecated, please use \code{\link[=inject]{inject()}} instead. } \keyword{internal} rlang/man/rlang_backtrace_on_error.Rd0000644000176200001440000000732014401331356017430 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cnd-abort.R \name{rlang_backtrace_on_error} \alias{rlang_backtrace_on_error} \alias{add_backtrace} \alias{rlang_backtrace_on_error_report} \alias{rlang_backtrace_on_warning_report} \title{Display backtrace on error} \description{ rlang errors carry a backtrace that can be inspected by calling \code{\link[=last_error]{last_error()}}. You can also control the default display of the backtrace by setting the option \code{rlang_backtrace_on_error} to one of the following values: \itemize{ \item \code{"none"} show nothing. \item \code{"reminder"}, the default in interactive sessions, displays a reminder that you can see the backtrace with \code{\link[=last_error]{last_error()}}. \item \code{"branch"} displays a simplified backtrace. \item \code{"full"}, the default in non-interactive sessions, displays the full tree. } rlang errors are normally thrown with \code{\link[=abort]{abort()}}. If you promote base errors to rlang errors with \code{\link[=global_entrace]{global_entrace()}}, \code{rlang_backtrace_on_error} applies to all errors. } \section{Promote base errors to rlang errors}{ You can use \code{options(error = rlang::entrace)} to promote base errors to rlang errors. This does two things: \itemize{ \item It saves the base error as an rlang object so you can call \code{\link[=last_error]{last_error()}} to print the backtrace or inspect its data. \item It prints the backtrace for the current error according to the \code{rlang_backtrace_on_error} option. } } \section{Warnings and errors in RMarkdown}{ The display of errors depends on whether they're expected (i.e. chunk option \code{error = TRUE}) or unexpected: \itemize{ \item Expected errors are controlled by the global option \code{"rlang_backtrace_on_error_report"} (note the \verb{_report} suffix). The default is \code{"none"} so that your expected errors don't include a reminder to run \code{rlang::last_error()}. Customise this option if you want to demonstrate what the error backtrace will look like. You can also use \code{\link[=last_error]{last_error()}} to display the trace like you would in your session, but it currently only works in the next chunk. \item Unexpected errors are controlled by the global option \code{"rlang_backtrace_on_error"}. The default is \code{"branch"} so you'll see a simplified backtrace in the knitr output to help you figure out what went wrong. } When knitr is running (as determined by the \code{knitr.in.progress} global option), the default top environment for backtraces is set to the chunk environment \code{knitr::knit_global()}. This ensures that the part of the call stack belonging to knitr does not end up in backtraces. If needed, you can override this by setting the \code{rlang_trace_top_env} global option. Similarly to \code{rlang_backtrace_on_error_report}, you can set \code{rlang_backtrace_on_warning_report} inside RMarkdown documents to tweak the display of warnings. This is useful in conjunction with \code{\link[=global_entrace]{global_entrace()}}. Because of technical limitations, there is currently no corresponding \code{rlang_backtrace_on_warning} option for normal R sessions. To get full entracing in an Rmd document, include this in a setup chunk before the first error or warning is signalled. \if{html}{\out{
}}\preformatted{```\{r setup\} rlang::global_entrace() options(rlang_backtrace_on_warning_report = "full") options(rlang_backtrace_on_error_report = "full") ``` }\if{html}{\out{
}} } \examples{ # Display a simplified backtrace on error for both base and rlang # errors: # options( # rlang_backtrace_on_error = "branch", # error = rlang::entrace # ) # stop("foo") } \seealso{ rlang_backtrace_on_warning } rlang/man/fn_fmls.Rd0000644000176200001440000000251714175213516014055 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/fn.R \name{fn_fmls} \alias{fn_fmls} \alias{fn_fmls_names} \alias{fn_fmls_syms} \alias{fn_fmls<-} \alias{fn_fmls_names<-} \title{Extract arguments from a function} \usage{ fn_fmls(fn = caller_fn()) fn_fmls_names(fn = caller_fn()) fn_fmls_syms(fn = caller_fn()) fn_fmls(fn) <- value fn_fmls_names(fn) <- value } \arguments{ \item{fn}{A function. It is looked up in the calling frame if not supplied.} \item{value}{New formals or formals names for \code{fn}.} } \description{ \code{fn_fmls()} returns a named list of formal arguments. \code{fn_fmls_names()} returns the names of the arguments. \code{fn_fmls_syms()} returns formals as a named list of symbols. This is especially useful for forwarding arguments in \link[=lang]{constructed calls}. } \details{ Unlike \code{formals()}, these helpers throw an error with primitive functions instead of returning \code{NULL}. } \examples{ # Extract from current call: fn <- function(a = 1, b = 2) fn_fmls() fn() # fn_fmls_syms() makes it easy to forward arguments: call2("apply", !!! fn_fmls_syms(lapply)) # You can also change the formals: fn_fmls(fn) <- list(A = 10, B = 20) fn() fn_fmls_names(fn) <- c("foo", "bar") fn() } \seealso{ \code{\link[=call_args]{call_args()}} and \code{\link[=call_args_names]{call_args_names()}} } rlang/man/sym.Rd0000644000176200001440000000406114375670676013255 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/sym.R \name{sym} \alias{sym} \alias{syms} \alias{data_sym} \alias{data_syms} \title{Create a symbol or list of symbols} \usage{ sym(x) syms(x) data_sym(x) data_syms(x) } \arguments{ \item{x}{For \code{sym()} and \code{data_sym()}, a string. For \code{syms()} and \code{data_syms()}, a list of strings.} } \value{ For \code{sym()} and \code{syms()}, a symbol or list of symbols. For \code{data_sym()} and \code{data_syms()}, calls of the form \code{.data$foo}. } \description{ Symbols are a kind of \link[=topic-defuse]{defused expression} that represent objects in environments. \itemize{ \item \code{sym()} and \code{syms()} take strings as input and turn them into symbols. \item \code{data_sym()} and \code{data_syms()} create calls of the form \code{.data$foo} instead of symbols. Subsetting the \code{\link{.data}} pronoun is more robust when you expect a data-variable. See \ifelse{html}{\link[=topic-data-mask-ambiguity]{The data mask ambiguity}}{\link[=topic-data-mask-ambiguity]{The data mask ambiguity}}. } Only tidy eval APIs support the \code{\link{.data}} pronoun. With base R functions, use simple symbols created with \code{sym()} or \code{syms()}. } \examples{ # Create a symbol sym("cyl") # Create a list of symbols syms(c("cyl", "am")) # Symbolised names refer to variables eval(sym("cyl"), mtcars) # Beware of scoping issues Cyl <- "wrong" eval(sym("Cyl"), mtcars) # Data symbols are explicitly scoped in the data mask try(eval_tidy(data_sym("Cyl"), mtcars)) # These can only be used with tidy eval functions try(eval(data_sym("Cyl"), mtcars)) # The empty string returns the missing argument: sym("") # This way sym() and as_string() are inverse of each other: as_string(missing_arg()) sym(as_string(missing_arg())) } \seealso{ \itemize{ \item \ifelse{html}{\link[=topic-defuse]{Defusing R expressions}}{\link[=topic-defuse]{Defusing R expressions}} \item \ifelse{html}{\link[=topic-metaprogramming]{Metaprogramming patterns}}{\link[=topic-metaprogramming]{Metaprogramming patterns}} } } rlang/man/wref_key.Rd0000644000176200001440000000066314127057575014254 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/weakref.R \name{wref_key} \alias{wref_key} \alias{wref_value} \title{Get key/value from a weak reference object} \usage{ wref_key(x) wref_value(x) } \arguments{ \item{x}{A weak reference object.} } \description{ Get key/value from a weak reference object } \seealso{ \code{\link[=is_weakref]{is_weakref()}} and \code{\link[=new_weakref]{new_weakref()}}. } rlang/man/injection-operator.Rd0000644000176200001440000001140714375670676016262 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/nse-inject.R \name{injection-operator} \alias{injection-operator} \alias{bang-bang} \alias{!!} \title{Injection operator \verb{!!}} \description{ The \link[=topic-inject]{injection} operator \verb{!!} injects a value or expression inside another expression. In other words, it modifies a piece of code before R evaluates it. There are two main cases for injection. You can inject constant values to work around issues of \link[=topic-data-mask-ambiguity]{scoping ambiguity}, and you can inject \link[=topic-defuse]{defused expressions} like \link[=sym]{symbolised} column names. } \section{Where does \verb{!!} work?}{ \verb{!!} does not work everywhere, you can only use it within certain special functions: \itemize{ \item Functions taking \link[=topic-defuse]{defused} and \link[=topic-data-mask]{data-masked} arguments. Technically, this means function arguments defused with \ifelse{html}{\code{\link[=embrace-operator]{\{\{}}}{\verb{\{\{}} or \code{en}-prefixed operators like \code{\link[=enquo]{enquo()}}, \code{\link[=enexpr]{enexpr()}}, etc. \item Inside \code{\link[=inject]{inject()}}. } All data-masking verbs in the tidyverse support injection operators out of the box. With base functions, you need to use \code{\link[=inject]{inject()}} to enable \verb{!!}. Using \verb{!!} out of context may lead to incorrect results, see \ifelse{html}{\link[=topic-inject-out-of-context]{What happens if I use injection operators out of context?}}{\link[=topic-inject-out-of-context]{What happens if I use injection operators out of context?}}. The examples below are built around the base function \code{\link[=with]{with()}}. Since it's not a tidyverse function we will use \code{\link[=inject]{inject()}} to enable \verb{!!} usage. } \section{Injecting values}{ Data-masking functions like \code{\link[=with]{with()}} are handy because you can refer to column names in your computations. This comes at the price of data mask ambiguity: if you have defined an env-variable of the same name as a data-variable, you get a name collisions. This collision is always resolved by giving precedence to the data-variable (it masks the env-variable): \if{html}{\out{
}}\preformatted{cyl <- c(100, 110) with(mtcars, mean(cyl)) #> [1] 6.1875 }\if{html}{\out{
}} The injection operator offers one way of solving this. Use it to inject the env-variable inside the data-masked expression: \if{html}{\out{
}}\preformatted{inject( with(mtcars, mean(!!cyl)) ) #> [1] 105 }\if{html}{\out{
}} Note that the \code{\link{.env}} pronoun is a simpler way of solving the ambiguity. See \ifelse{html}{\link[=topic-data-mask-ambiguity]{The data mask ambiguity}}{\link[=topic-data-mask-ambiguity]{The data mask ambiguity}} for more about this. } \section{Injecting expressions}{ Injection is also useful for modifying parts of a \link[=topic-defuse]{defused expression}. In the following example we use the \link[=topic-metaprogramming]{symbolise-and-inject pattern} to inject a column name inside a data-masked expression. \if{html}{\out{
}}\preformatted{var <- sym("cyl") inject( with(mtcars, mean(!!var)) ) #> [1] 6.1875 }\if{html}{\out{
}} Since \code{\link[=with]{with()}} is a base function, you can't inject \link[=topic-quosure]{quosures}, only naked symbols and calls. This isn't a problem here because we're injecting the name of a data frame column. If the environment is important, try injecting a pre-computed value instead. } \section{When do I need \verb{!!}?}{ With tidyverse APIs, injecting expressions with \verb{!!} is no longer a common pattern. First, the \code{\link{.env}} pronoun solves the ambiguity problem in a more intuitive way: \if{html}{\out{
}}\preformatted{cyl <- 100 mtcars \%>\% dplyr::mutate(cyl = cyl * .env$cyl) }\if{html}{\out{
}} Second, the embrace operator \ifelse{html}{\code{\link[=embrace-operator]{\{\{}}}{\verb{\{\{}} makes the \link[=topic-metaprogramming]{defuse-and-inject pattern} easier to learn and use. \if{html}{\out{
}}\preformatted{my_mean <- function(data, var) \{ data \%>\% dplyr::summarise(mean(\{\{ var \}\})) \} # Equivalent to my_mean <- function(data, var) \{ data \%>\% dplyr::summarise(mean(!!enquo(var))) \} }\if{html}{\out{
}} \verb{!!} is a good tool to learn for advanced applications but our hope is that it isn't needed for common data analysis cases. } \seealso{ \itemize{ \item \ifelse{html}{\link[=topic-inject]{Injecting with !!, !!!, and glue syntax}}{\link[=topic-inject]{Injecting with !!, !!!, and glue syntax}} \item \ifelse{html}{\link[=topic-metaprogramming]{Metaprogramming patterns}}{\link[=topic-metaprogramming]{Metaprogramming patterns}} } } rlang/man/as_environment.Rd0000644000176200001440000000246414375670676015501 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/env.R \name{as_environment} \alias{as_environment} \title{Coerce to an environment} \usage{ as_environment(x, parent = NULL) } \arguments{ \item{x}{An object to coerce.} \item{parent}{A parent environment, \code{\link[=empty_env]{empty_env()}} by default. This argument is only used when \code{x} is data actually coerced to an environment (as opposed to data representing an environment, like \code{NULL} representing the empty environment).} } \description{ \code{as_environment()} coerces named vectors (including lists) to an environment. The names must be unique. If supplied an unnamed string, it returns the corresponding package environment (see \code{\link[=pkg_env]{pkg_env()}}). } \details{ If \code{x} is an environment and \code{parent} is not \code{NULL}, the environment is duplicated before being set a new parent. The return value is therefore a different environment than \code{x}. } \examples{ # Coerce a named vector to an environment: env <- as_environment(mtcars) # By default it gets the empty environment as parent: identical(env_parent(env), empty_env()) # With strings it is a handy shortcut for pkg_env(): as_environment("base") as_environment("rlang") # With NULL it returns the empty environment: as_environment(NULL) } rlang/man/set_attrs.Rd0000644000176200001440000000113414375670676014453 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/lifecycle-deprecated.R \name{set_attrs} \alias{set_attrs} \title{Add attributes to an object} \usage{ set_attrs(.x, ...) } \arguments{ \item{.x, ...}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}}} } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} } \keyword{internal} rlang/man/entrace.Rd0000644000176200001440000000556114375670676014074 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cnd-entrace.R \name{entrace} \alias{entrace} \alias{cnd_entrace} \title{Add backtrace from error handler} \usage{ entrace(cnd, ..., top = NULL, bottom = NULL) cnd_entrace(cnd, ..., top = NULL, bottom = NULL) } \arguments{ \item{cnd}{When \code{entrace()} is used as a calling handler, \code{cnd} is the condition to handle.} \item{...}{Unused. These dots are for future extensions.} \item{top}{The first frame environment to be included in the backtrace. This becomes the top of the backtrace tree and represents the oldest call in the backtrace. This is needed in particular when you call \code{trace_back()} indirectly or from a larger context, for example in tests or inside an RMarkdown document where you don't want all of the knitr evaluation mechanisms to appear in the backtrace. If not supplied, the \code{rlang_trace_top_env} global option is consulted. This makes it possible to trim the embedding context for all backtraces created while the option is set. If knitr is in progress, the default value for this option is \code{knitr::knit_global()} so that the knitr context is trimmed out of backtraces.} \item{bottom}{The last frame environment to be included in the backtrace. This becomes the rightmost leaf of the backtrace tree and represents the youngest call in the backtrace. Set this when you would like to capture a backtrace without the capture context. Can also be an integer that will be passed to \code{\link[=caller_env]{caller_env()}}.} } \description{ \code{entrace()} is a low level function. See \code{\link[=global_entrace]{global_entrace()}} for a user-friendly way of enriching errors and other conditions from your RProfile. \itemize{ \item \code{entrace()} is meant to be used as a global handler. It enriches conditions with a backtrace. Errors are saved to \code{\link[=last_error]{last_error()}} and rethrown immediately. Messages and warnings are recorded into \code{\link[=last_messages]{last_messages()}} and \code{\link[=last_warnings]{last_warnings()}} and let through. \item \code{cnd_entrace()} adds a backtrace to a condition object, without any other effect. It should be called from a condition handler. } \code{entrace()} also works as an \code{option(error = )} handler for compatibility with versions of R older than 4.0. When used as calling handler, rlang trims the handler invokation context from the backtrace. } \examples{ quote({ # Not run # Set `entrace()` globally in your RProfile globalCallingHandlers(error = rlang::entrace) # On older R versions which don't feature `globalCallingHandlers`, # set the error handler like this: options(error = rlang::entrace) }) } \seealso{ \code{\link[=global_entrace]{global_entrace()}} for configuring errors with \code{entrace()}. \code{\link[=cnd_entrace]{cnd_entrace()}} to manually add a backtrace to a condition. } \keyword{internal} rlang/man/f_rhs.Rd0000644000176200001440000000154313351410454013523 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 or 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) } rlang/man/bytes-class.Rd0000644000176200001440000000211714375670676014676 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/bytes.R \name{bytes-class} \alias{bytes-class} \alias{as_bytes} \alias{parse_bytes} \title{Human readable memory sizes} \usage{ as_bytes(x) parse_bytes(x) } \arguments{ \item{x}{A numeric or character vector. Character representations can use shorthand sizes (see examples).} } \description{ Construct, manipulate and display vectors of byte sizes. These are numeric vectors, so you can compare them numerically, but they can also be compared to human readable values such as '10MB'. \itemize{ \item \code{parse_bytes()} takes a character vector of human-readable bytes and returns a structured bytes vector. \item \code{as_bytes()} is a generic conversion function for objects representing bytes. } Note: A \code{bytes()} constructor will be exported soon. } \details{ These memory sizes are always assumed to be base 1000, rather than 1024. } \examples{ parse_bytes("1") parse_bytes("1K") parse_bytes("1Kb") parse_bytes("1KiB") parse_bytes("1MB") parse_bytes("1KB") < "1MB" sum(parse_bytes(c("1MB", "5MB", "500KB"))) } rlang/man/is_true.Rd0000644000176200001440000000071014137447476014110 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/types.R \name{is_true} \alias{is_true} \alias{is_false} \title{Is object identical to TRUE or FALSE?} \usage{ is_true(x) is_false(x) } \arguments{ \item{x}{object to test} } \description{ These functions bypass R's automatic conversion rules and check that \code{x} is literally \code{TRUE} or \code{FALSE}. } \examples{ is_true(TRUE) is_true(1) is_false(FALSE) is_false(0) } rlang/man/is_formula.Rd0000644000176200001440000000517414175213516014573 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/formula.R \name{is_formula} \alias{is_formula} \alias{is_bare_formula} \title{Is object a formula?} \usage{ is_formula(x, scoped = NULL, lhs = NULL) is_bare_formula(x, scoped = TRUE, lhs = NULL) } \arguments{ \item{x}{An object to test.} \item{scoped}{A boolean indicating whether the quosure is scoped, that is, has a valid environment attribute and inherits from \code{"formula"}. If \code{NULL}, the scope is not inspected.} \item{lhs}{A boolean indicating whether the formula has a left-hand side. If \code{NULL}, the LHS is not inspected and \code{is_formula()} returns \code{TRUE} for both one- and two-sided formulas.} } \description{ \code{is_formula()} tests whether \code{x} is a call to \code{~}. \code{is_bare_formula()} tests in addition that \code{x} does not inherit from anything else than \code{"formula"}. \strong{Note}: When we first implemented \code{is_formula()}, we thought it best to treat unevaluated formulas as formulas by default (see section below). Now we think this default introduces too many edge cases in normal code. We recommend always supplying \code{scoped = TRUE}. Unevaluated formulas can be handled via a \code{is_call(x, "~")} branch. } \section{Dealing with unevaluated formulas}{ At parse time, a formula is a simple call to \code{~} and it does not have a class or an environment. Once evaluated, the \code{~} call becomes a properly structured formula. Unevaluated formulas arise by quotation, e.g. \code{~~foo}, \code{quote(~foo)}, or \code{substitute(arg)} with \code{arg} being supplied a formula. Use the \code{scoped} argument to check whether the formula carries an environment. } \examples{ is_formula(~10) is_formula(10) # If you don't supply `lhs`, both one-sided and two-sided formulas # will return `TRUE` is_formula(disp ~ am) is_formula(~am) # You can also specify whether you expect a LHS: is_formula(disp ~ am, lhs = TRUE) is_formula(disp ~ am, lhs = FALSE) is_formula(~am, lhs = TRUE) is_formula(~am, lhs = FALSE) # Handling of unevaluated formulas is a bit tricky. These formulas # are special because they don't inherit from `"formula"` and they # don't carry an environment (they are not scoped): f <- quote(~foo) f_env(f) # By default unevaluated formulas are treated as formulas is_formula(f) # Supply `scoped = TRUE` to ensure you have an evaluated formula is_formula(f, scoped = TRUE) # By default unevaluated formulas not treated as bare formulas is_bare_formula(f) # If you supply `scoped = TRUE`, they will be considered bare # formulas even though they don't inherit from `"formula"` is_bare_formula(f, scoped = TRUE) } rlang/man/topic-data-mask.Rd0000644000176200001440000002165114741441453015411 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/topic-nse.R \name{topic-data-mask} \alias{topic-data-mask} \title{What is data-masking and why do I need \verb{\{\{}?} \description{ Data-masking is a distinctive feature of R whereby programming is performed directly on a data set, with columns defined as normal objects. \if{html}{\out{
}}\preformatted{# Unmasked programming mean(mtcars$cyl + mtcars$am) #> [1] 6.59375 # Referring to columns is an error - Where is the data? mean(cyl + am) #> Error: #> ! object 'cyl' not found # Data-masking with(mtcars, mean(cyl + am)) #> [1] 6.59375 }\if{html}{\out{
}} While data-masking makes it easy to program interactively with data frames, it makes it harder to create functions. Passing data-masked arguments to functions requires injection with the embracing operator \ifelse{html}{\code{\link[=embrace-operator]{\{\{}}}{\verb{\{\{}} or, in more complex cases, the injection operator \code{\link{!!}}. } \section{Why does data-masking require embracing and injection?}{ Injection (also known as quasiquotation) is a metaprogramming feature that allows you to modify parts of a program. This is needed because under the hood data-masking works by \link[=topic-defuse]{defusing} R code to prevent its immediate evaluation. The defused code is resumed later on in a context where data frame columns are defined. Let's see what happens when we pass arguments to a data-masking function like \code{summarise()} in the normal way: \if{html}{\out{
}}\preformatted{my_mean <- function(data, var1, var2) \{ dplyr::summarise(data, mean(var1 + var2)) \} my_mean(mtcars, cyl, am) #> Error in `dplyr::summarise()`: #> i In argument: `mean(var1 + var2)`. #> Caused by error: #> ! object 'cyl' not found }\if{html}{\out{
}} The problem here is that \code{summarise()} defuses the R code it was supplied, i.e. \code{mean(var1 + var2)}. Instead we want it to see \code{mean(cyl + am)}. This is why we need injection, we need to modify that piece of code by injecting the code supplied to the function in place of \code{var1} and \code{var2}. To inject a function argument in data-masked context, just embrace it with \verb{\{\{}: \if{html}{\out{
}}\preformatted{my_mean <- function(data, var1, var2) \{ dplyr::summarise(data, mean(\{\{ var1 \}\} + \{\{ var2 \}\})) \} my_mean(mtcars, cyl, am) #> # A tibble: 1 x 1 #> `mean(cyl + am)` #> #> 1 6.59 }\if{html}{\out{
}} See \ifelse{html}{\link[=topic-data-mask-programming]{Data mask programming patterns}}{\link[=topic-data-mask-programming]{Data mask programming patterns}} to learn more about creating functions around data-masking functions. } \section{What does "masking" mean?}{ In normal R programming objects are defined in the current environment, for instance in the global environment or the environment of a function. \if{html}{\out{
}}\preformatted{factor <- 1000 # Can now use `factor` in computations mean(mtcars$cyl * factor) #> [1] 6187.5 }\if{html}{\out{
}} This environment also contains all functions currently in scope. In a script this includes the functions attached with \code{library()} calls; in a package, the functions imported from other packages. If evaluation was performed only in the data frame, we'd lose track of these objects and functions necessary to perform computations. To keep these objects and functions in scope, the data frame is inserted at the bottom of the current chain of environments. It comes first and has precedence over the user environment. In other words, it \emph{masks} the user environment. Since masking blends the data and the user environment by giving priority to the former, R can sometimes use a data frame column when you really intended to use a local object. \if{html}{\out{
}}\preformatted{# Defining an env-variable cyl <- 1000 # Referring to a data-variable dplyr::summarise(mtcars, mean(cyl)) #> # A tibble: 1 x 1 #> `mean(cyl)` #> #> 1 6.19 }\if{html}{\out{
}} The tidy eval framework provides \link[=.data]{pronouns} to help disambiguate between the mask and user contexts. It is often a good idea to use these pronouns in production code. \if{html}{\out{
}}\preformatted{cyl <- 1000 mtcars \%>\% dplyr::summarise( mean_data = mean(.data$cyl), mean_env = mean(.env$cyl) ) #> # A tibble: 1 x 2 #> mean_data mean_env #> #> 1 6.19 1000 }\if{html}{\out{
}} Read more about this in \ifelse{html}{\link[=topic-data-mask-ambiguity]{The data mask ambiguity}}{\link[=topic-data-mask-ambiguity]{The data mask ambiguity}}. } \section{How does data-masking work?}{ Data-masking relies on three language features: \itemize{ \item \link[=topic-defuse]{Argument defusal} with \code{\link[=substitute]{substitute()}} (base R) or \code{\link[=enquo]{enquo()}}, \code{\link[=enquos]{enquos()}}, and \ifelse{html}{\code{\link[=embrace-operator]{\{\{}}}{\verb{\{\{}} (rlang). R code is defused so it can be evaluated later on in a special environment enriched with data. \item First class environments. Environments are a special type of list-like object in which defused R code can be evaluated. The named elements in an environment define objects. Lists and data frames can be transformed to environments: \if{html}{\out{
}}\preformatted{as.environment(mtcars) #> }\if{html}{\out{
}} \item Explicit evaluation with \code{\link[=eval]{eval()}} (base) or \code{\link[=eval_tidy]{eval_tidy()}} (rlang). When R code is defused, evaluation is interrupted. It can be resumed later on with \code{\link[=eval]{eval()}}: \if{html}{\out{
}}\preformatted{expr(1 + 1) #> 1 + 1 eval(expr(1 + 1)) #> [1] 2 }\if{html}{\out{
}} By default \code{eval()} and \code{eval_tidy()} evaluate in the current environment. \if{html}{\out{
}}\preformatted{code <- expr(mean(cyl + am)) eval(code) #> Error: #> ! object 'am' not found }\if{html}{\out{
}} You can supply an optional list or data frame that will be converted to an environment. \if{html}{\out{
}}\preformatted{eval(code, mtcars) #> [1] 6.59375 }\if{html}{\out{
}} Evaluation of defused code then occurs in the context of a data mask. } } \section{History}{ The tidyverse embraced the data-masking approach in packages like ggplot2 and dplyr and eventually developed its own programming framework in the rlang package. None of this would have been possible without the following landmark developments from S and R authors. \itemize{ \item The S language introduced data scopes with \code{\link[=attach]{attach()}} (Becker, Chambers and Wilks, The New S Language, 1988). \item The S language introduced data-masked formulas in modelling functions (Chambers and Hastie, 1993). \item Peter Dalgaard (R team) wrote the frametools package in 1997. It was later included in R as \code{\link[base:transform]{base::transform()}} and \code{\link[base:subset]{base::subset()}}. This API is an important source of inspiration for the dplyr package. It was also the first apparition of \emph{selections}, a variant of data-masking extended and codified later on in the \href{https://tidyselect.r-lib.org/articles/syntax.html}{tidyselect package}. \item In 2000 Luke Tierney (R team) \href{https://github.com/wch/r-source/commit/a945ac8e}{changed formulas} to keep track of their original environments. This change published in R 1.1.0 was a crucial step towards hygienic data masking, i.e. the proper resolution of symbols in their original environments. Quosures were inspired by the environment-tracking mechanism of formulas. \item Luke introduced \code{\link[base:with]{base::with()}} in 2001. \item In 2006 the \href{https://r-datatable.com}{data.table package} included data-masking and selections in the \code{i} and \code{j} arguments of the \code{[} method of a data frame. \item The \href{https://dplyr.tidyverse.org/}{dplyr package} was published in 2014. \item The rlang package developed tidy eval in 2017 as the data-masking framework of the tidyverse. It introduced the notions of \link[=topic-quosure]{quosure}, \link[=topic-inject]{implicit injection} with \verb{!!} and \verb{!!!}, and \link[=.data]{data pronouns}. \item In 2019, injection with \verb{\{\{} was introduced in \href{https://www.tidyverse.org/blog/2019/06/rlang-0-4-0/}{rlang 0.4.0} to simplify the defuse-and-inject pattern. This operator allows R programmers to transport data-masked arguments across functions more intuitively and with minimal boilerplate. } } \section{See also}{ \itemize{ \item \ifelse{html}{\link[=topic-data-mask-programming]{Data mask programming patterns}}{\link[=topic-data-mask-programming]{Data mask programming patterns}} \item \ifelse{html}{\link[=topic-defuse]{Defusing R expressions}}{\link[=topic-defuse]{Defusing R expressions}} } } \keyword{internal} rlang/man/quo_expr.Rd0000644000176200001440000000155614375670676014315 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/lifecycle-deprecated.R \name{quo_expr} \alias{quo_expr} \title{Squash a quosure} \usage{ quo_expr(quo, warn = FALSE) } \arguments{ \item{quo}{A quosure or expression.} \item{warn}{Whether to warn if the quosure contains other quosures (those will be collapsed). This is useful when you use \code{quo_squash()} in order to make a non-tidyeval API compatible with quosures. In that case, getting rid of the nested quosures is likely to cause subtle bugs and it is good practice to warn the user about it.} } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} This function is deprecated, please use \code{\link[=quo_squash]{quo_squash()}} instead. } \keyword{internal} rlang/man/is_named.Rd0000644000176200001440000000363114175213516014206 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/attr.R \name{is_named} \alias{is_named} \alias{is_named2} \alias{have_name} \title{Is object named?} \usage{ is_named(x) is_named2(x) have_name(x) } \arguments{ \item{x}{A vector to test.} } \value{ \code{is_named()} and \code{is_named2()} are scalar predicates that return \code{TRUE} or \code{FALSE}. \code{have_name()} is vectorised and returns a logical vector as long as the input. } \description{ \itemize{ \item \code{is_named()} is a scalar predicate that checks that \code{x} has a \code{names} attribute and that none of the names are missing or empty (\code{NA} or \code{""}). \item \code{is_named2()} is like \code{is_named()} but always returns \code{TRUE} for empty vectors, even those that don't have a \code{names} attribute. In other words, it tests for the property that each element of a vector is named. \code{is_named2()} composes well with \code{\link[=names2]{names2()}} whereas \code{is_named()} composes with \code{names()}. \item \code{have_name()} is a vectorised variant. } } \details{ \code{is_named()} always returns \code{TRUE} for empty vectors because } \examples{ # is_named() is a scalar predicate about the whole vector of names: is_named(c(a = 1, b = 2)) is_named(c(a = 1, 2)) # Unlike is_named2(), is_named() returns `FALSE` for empty vectors # that don't have a `names` attribute. is_named(list()) is_named2(list()) # have_name() is a vectorised predicate have_name(c(a = 1, b = 2)) have_name(c(a = 1, 2)) # Empty and missing names are treated as invalid: invalid <- set_names(letters[1:5]) names(invalid)[1] <- "" names(invalid)[3] <- NA is_named(invalid) have_name(invalid) # A data frame normally has valid, unique names is_named(mtcars) have_name(mtcars) # A matrix usually doesn't because the names are stored in a # different attribute mat <- matrix(1:4, 2) colnames(mat) <- c("a", "b") is_named(mat) names(mat) } rlang/man/env_name.Rd0000644000176200001440000000237414127057575014232 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/env-special.R \name{env_name} \alias{env_name} \alias{env_label} \title{Label of an environment} \usage{ env_name(env) env_label(env) } \arguments{ \item{env}{An environment.} } \description{ Special environments like the global environment have their own names. \code{env_name()} returns: \itemize{ \item "global" for the global environment. \item "empty" for the empty environment. \item "base" for the base package environment (the last environment on the search path). \item "namespace:pkg" if \code{env} is the namespace of the package "pkg". \item The \code{name} attribute of \code{env} if it exists. This is how the \link[=search_envs]{package environments} and the \link[=ns_imports_env]{imports environments} store their names. The name of package environments is typically "package:pkg". \item The empty string \code{""} otherwise. } \code{env_label()} is exactly like \code{env_name()} but returns the memory address of anonymous environments as fallback. } \examples{ # Some environments have specific names: env_name(global_env()) env_name(ns_env("rlang")) # Anonymous environments don't have names but are labelled by their # address in memory: env_name(env()) env_label(env()) } rlang/man/are_na.Rd0000644000176200001440000000332714175213516013656 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/vec-na.R \name{are_na} \alias{are_na} \alias{is_na} \alias{is_lgl_na} \alias{is_int_na} \alias{is_dbl_na} \alias{is_chr_na} \alias{is_cpl_na} \title{Test for missing values} \usage{ are_na(x) is_na(x) is_lgl_na(x) is_int_na(x) is_dbl_na(x) is_chr_na(x) is_cpl_na(x) } \arguments{ \item{x}{An object to test} } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#questioning}{\figure{lifecycle-questioning.svg}{options: alt='[Questioning]'}}}{\strong{[Questioning]}} \code{are_na()} checks for missing values in a vector and is equivalent to \code{\link[base:NA]{base::is.na()}}. It is a vectorised predicate, meaning that its output is always the same length as its input. On the other hand, \code{is_na()} is a scalar predicate and always returns a scalar boolean, \code{TRUE} or \code{FALSE}. If its input is not scalar, it returns \code{FALSE}. Finally, there are typed versions that check for particular \link[=missing]{missing types}. } \details{ The scalar predicates accept non-vector inputs. They are equivalent to \code{\link[=is_null]{is_null()}} in that respect. In contrast the vectorised predicate \code{are_na()} requires a vector input since it is defined over vector values. } \section{Life cycle}{ These functions might be moved to the vctrs package at some point. This is why they are marked as questioning. } \examples{ # are_na() is vectorised and works regardless of the type are_na(c(1, 2, NA)) are_na(c(1L, NA, 3L)) # is_na() checks for scalar input and works for all types is_na(NA) is_na(na_dbl) is_na(character(0)) # There are typed versions as well: is_lgl_na(NA) is_lgl_na(na_dbl) } \keyword{internal} rlang/man/switch_type.Rd0000644000176200001440000000460514375670676015013 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/lifecycle-deprecated.R \name{switch_type} \alias{switch_type} \alias{coerce_type} \alias{switch_class} \alias{coerce_class} \title{Dispatch on base types} \usage{ switch_type(.x, ...) coerce_type(.x, .to, ...) switch_class(.x, ...) coerce_class(.x, .to, ...) } \arguments{ \item{.x}{An object from which to dispatch.} \item{...}{Named clauses. The names should be types as returned by \code{\link[=type_of]{type_of()}}.} \item{.to}{This is useful when you switchpatch within a coercing function. If supplied, this should be a string indicating the target type. A catch-all clause is then added to signal an error stating the conversion failure. This type is prettified unless \code{.to} inherits from the S3 class \code{"AsIs"} (see \code{\link[base:AsIs]{base::I()}}).} } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#soft-deprecated}{\figure{lifecycle-soft-deprecated.svg}{options: alt='[Soft-deprecated]'}}}{\strong{[Soft-deprecated]}} \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} \code{switch_type()} is equivalent to \code{\link[base]{switch}(\link{type_of}(x, ...))}, while \code{switch_class()} switchpatches based on \code{class(x)}. The \code{coerce_} versions are intended for type conversion and provide a standard error message when conversion fails. } \examples{ switch_type(3L, double = "foo", integer = "bar", "default" ) # Use the coerce_ version to get standardised error handling when no # type matches: to_chr <- function(x) { coerce_type(x, "a chr", integer = as.character(x), double = as.character(x) ) } to_chr(3L) # Strings have their own type: switch_type("str", character = "foo", string = "bar", "default" ) # Use a fallthrough clause if you need to dispatch on all character # vectors, including strings: switch_type("str", string = , character = "foo", "default" ) # special and builtin functions are treated as primitive, since # there is usually no reason to treat them differently: switch_type(base::list, primitive = "foo", "default" ) switch_type(base::`$`, primitive = "foo", "default" ) # closures are not primitives: switch_type(rlang::switch_type, primitive = "foo", "default" ) } \keyword{internal} rlang/man/is_integerish.Rd0000644000176200001440000000324514127057575015274 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/types.R \name{is_integerish} \alias{is_integerish} \alias{is_bare_integerish} \alias{is_scalar_integerish} \title{Is a vector integer-like?} \usage{ is_integerish(x, n = NULL, finite = NULL) is_bare_integerish(x, n = NULL, finite = NULL) is_scalar_integerish(x, finite = NULL) } \arguments{ \item{x}{Object to be tested.} \item{n}{Expected length of a vector.} \item{finite}{Whether all values of the vector are finite. The non-finite values are \code{NA}, \code{Inf}, \code{-Inf} and \code{NaN}. Setting this to something other than \code{NULL} can be expensive because the whole vector needs to be traversed and checked.} } \description{ These predicates check whether R considers a number vector to be integer-like, according to its own tolerance check (which is in fact delegated to the C library). This function is not adapted to data analysis, see the help for \code{\link[base:integer]{base::is.integer()}} for examples of how to check for whole numbers. Things to consider when checking for integer-like doubles: \itemize{ \item This check can be expensive because the whole double vector has to be traversed and checked. \item Large double values may be integerish but may still not be coercible to integer. This is because integers in R only support values up to \code{2^31 - 1} while numbers stored as double can be much larger. } } \examples{ is_integerish(10L) is_integerish(10.0) is_integerish(10.0, n = 2) is_integerish(10.000001) is_integerish(TRUE) } \seealso{ \code{\link[=is_bare_numeric]{is_bare_numeric()}} for testing whether an object is a base numeric type (a bare double or integer vector). } rlang/man/missing.Rd0000644000176200001440000000443414175213516014102 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/vec-na.R \docType{data} \name{missing} \alias{missing} \alias{na_lgl} \alias{na_int} \alias{na_dbl} \alias{na_chr} \alias{na_cpl} \title{Missing values} \format{ An object of class \code{logical} of length 1. An object of class \code{integer} of length 1. An object of class \code{numeric} of length 1. An object of class \code{character} of length 1. An object of class \code{complex} of length 1. } \usage{ na_lgl na_int na_dbl na_chr na_cpl } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#questioning}{\figure{lifecycle-questioning.svg}{options: alt='[Questioning]'}}}{\strong{[Questioning]}} Missing values are represented in R with the general symbol \code{NA}. They can be inserted in almost all data containers: all atomic vectors except raw vectors can contain missing values. To achieve this, R automatically converts the general \code{NA} symbol to a typed missing value appropriate for the target vector. The objects provided here are aliases for those typed \code{NA} objects. } \details{ Typed missing values are necessary because R needs sentinel values of the same type (i.e. the same machine representation of the data) as the containers into which they are inserted. The official typed missing values are \code{NA_integer_}, \code{NA_real_}, \code{NA_character_} and \code{NA_complex_}. The missing value for logical vectors is simply the default \code{NA}. The aliases provided in rlang are consistently named and thus simpler to remember. Also, \code{na_lgl} is provided as an alias to \code{NA} that makes intent clearer. Since \code{na_lgl} is the default \code{NA}, expressions such as \code{c(NA, NA)} yield logical vectors as no data is available to give a clue of the target type. In the same way, since lists and environments can contain any types, expressions like \code{list(NA)} store a logical \code{NA}. } \section{Life cycle}{ These shortcuts might be moved to the vctrs package at some point. This is why they are marked as questioning. } \examples{ typeof(NA) typeof(na_lgl) typeof(na_int) # Note that while the base R missing symbols cannot be overwritten, # that's not the case for rlang's aliases: na_dbl <- NA typeof(na_dbl) } \keyword{datasets} \keyword{internal} rlang/man/is_namespace.Rd0000644000176200001440000000045614127057575015070 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/env-special.R \name{is_namespace} \alias{is_namespace} \title{Is an object a namespace environment?} \usage{ is_namespace(x) } \arguments{ \item{x}{An object to test.} } \description{ Is an object a namespace environment? } rlang/man/topic-inject.Rd0000644000176200001440000001725714741441453015032 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/topic-nse.R \name{topic-inject} \alias{topic-inject} \alias{quasiquotation} \alias{nse-force} \alias{nse-inject} \title{Injecting with \verb{!!}, \verb{!!!}, and glue syntax} \description{ The injection operators are extensions of R implemented by rlang to modify a piece of code before R processes it. There are two main families: \itemize{ \item The \link[=dyn-dots]{dynamic dots} operators, \code{\link{!!!}} and \ifelse{html}{\code{\link[=glue-operators]{"\{"}}}{\verb{"\{"}}. \item The \link[=topic-metaprogramming]{metaprogramming operators} \code{\link{!!}}, \ifelse{html}{\code{\link[=embrace-operator]{\{\{}}}{\verb{\{\{}}, and \ifelse{html}{\code{\link[=glue-operators]{"\{\{"}}}{\verb{"\{\{"}}. Splicing with \code{\link{!!!}} can also be done in metaprogramming context. } } \section{Dots injection}{ Unlike regular \code{...}, \link[=dyn-dots]{dynamic dots} are programmable with injection operators. \subsection{Splicing with \verb{!!!}}{ For instance, take a function like \code{rbind()} which takes data in \code{...}. To bind rows, you supply them as separate arguments: \if{html}{\out{
}}\preformatted{rbind(a = 1:2, b = 3:4) #> [,1] [,2] #> a 1 2 #> b 3 4 }\if{html}{\out{
}} But how do you bind a variable number of rows stored in a list? The base R solution is to invoke \code{rbind()} with \code{do.call()}: \if{html}{\out{
}}\preformatted{rows <- list(a = 1:2, b = 3:4) do.call("rbind", rows) #> [,1] [,2] #> a 1 2 #> b 3 4 }\if{html}{\out{
}} Functions that implement dynamic dots include a built-in way of folding a list of arguments in \code{...}. To illustrate this, we'll create a variant of \code{rbind()} that takes dynamic dots by collecting \code{...} with \code{\link[=list2]{list2()}}: \if{html}{\out{
}}\preformatted{rbind2 <- function(...) \{ do.call("rbind", list2(...)) \} }\if{html}{\out{
}} It can be used just like \code{rbind()}: \if{html}{\out{
}}\preformatted{rbind2(a = 1:2, b = 3:4) #> [,1] [,2] #> a 1 2 #> b 3 4 }\if{html}{\out{
}} And a list of arguments can be supplied by \emph{splicing} the list with \code{\link{!!!}}: \if{html}{\out{
}}\preformatted{rbind2(!!!rows, c = 5:6) #> [,1] [,2] #> a 1 2 #> b 3 4 #> c 5 6 }\if{html}{\out{
}} } \subsection{Injecting names with \verb{"\{"}}{ A related problem comes up when an argument name is stored in a variable. With dynamic dots, you can inject the name using \href{https://glue.tidyverse.org/}{glue syntax} with \ifelse{html}{\code{\link[=glue-operators]{"\{"}}}{\verb{"\{"}}: \if{html}{\out{
}}\preformatted{name <- "foo" rbind2("\{name\}" := 1:2, bar = 3:4) #> [,1] [,2] #> foo 1 2 #> bar 3 4 rbind2("prefix_\{name\}" := 1:2, bar = 3:4) #> [,1] [,2] #> prefix_foo 1 2 #> bar 3 4 }\if{html}{\out{
}} } } \section{Metaprogramming injection}{ \link[=topic-data-mask]{Data-masked} arguments support the following injection operators. They can also be explicitly enabled with \code{\link[=inject]{inject()}}. \subsection{Embracing with \verb{\{\{}}{ The embracing operator \ifelse{html}{\code{\link[=embrace-operator]{\{\{}}}{\verb{\{\{}} is made specially for function arguments. It \link[=topic-defuse]{defuses} the expression supplied as argument and immediately injects it in place. The injected argument is then evaluated in another context such as a \link[=topic-data-mask]{data mask}. \if{html}{\out{
}}\preformatted{# Inject function arguments that might contain # data-variables by embracing them with \{\{ \}\} mean_by <- function(data, by, var) \{ data \%>\% dplyr::group_by(\{\{ by \}\}) \%>\% dplyr::summarise(avg = mean(\{\{ var \}\}, na.rm = TRUE)) \} # The data-variables `cyl` and `disp` inside the # env-variables `by` and `var` are injected inside `group_by()` # and `summarise()` mtcars \%>\% mean_by(by = cyl, var = disp) #> # A tibble: 3 x 2 #> cyl avg #> #> 1 4 105. #> 2 6 183. #> 3 8 353. }\if{html}{\out{
}} Learn more about this pattern in \ifelse{html}{\link[=topic-data-mask-programming]{Data mask programming patterns}}{\link[=topic-data-mask-programming]{Data mask programming patterns}}. } \subsection{Injecting with \verb{!!}}{ Unlike \code{\link{!!!}} which injects a list of arguments, the injection operator \code{\link{!!}} (pronounced "bang-bang") injects a \emph{single} object. One use case for \verb{!!} is to substitute an environment-variable (created with \verb{<-}) with a data-variable (inside a data frame). \if{html}{\out{
}}\preformatted{# The env-variable `var` contains a data-symbol object, in this # case a reference to the data-variable `height` var <- data_sym("disp") # We inject the data-variable contained in `var` inside `summarise()` mtcars \%>\% dplyr::summarise(avg = mean(!!var, na.rm = TRUE)) #> # A tibble: 1 x 1 #> avg #> #> 1 231. }\if{html}{\out{
}} Another use case is to inject a variable by value to avoid \link[=topic-data-mask-ambiguity]{name collisions}. \if{html}{\out{
}}\preformatted{df <- data.frame(x = 1) # This name conflicts with a column in `df` x <- 100 # Inject the env-variable df \%>\% dplyr::mutate(x = x / !!x) #> x #> 1 0.01 }\if{html}{\out{
}} Note that in most cases you don't need injection with \verb{!!}. For instance, the \code{\link{.data}} and \code{\link{.env}} pronouns provide more intuitive alternatives to injecting a column name and injecting a value. } \subsection{Splicing with \verb{!!!}}{ The splice operator \code{\link{!!!}} of dynamic dots can also be used in metaprogramming context (inside \link[=topic-data-mask]{data-masked} arguments and inside \code{\link[=inject]{inject()}}). For instance, we could reimplement the \code{rbind2()} function presented above using \code{inject()} instead of \code{do.call()}: \if{html}{\out{
}}\preformatted{rbind2 <- function(...) \{ inject(rbind(!!!list2(...))) \} }\if{html}{\out{
}} There are two things going on here. We collect \code{...} with \code{\link[=list2]{list2()}} so that the callers of \code{rbind2()} may use \verb{!!!}. And we use \code{inject()} so that \code{rbind2()} itself may use \verb{!!!} to splice the list of arguments passed to \code{rbind2()}. } } \section{Injection in other languages}{ Injection is known as \strong{quasiquotation} in other programming languages and in computer science. \code{expr()} is similar to a quasiquotation operator and \verb{!!} is the unquote operator. These terms have a rich history in Lisp languages, and live on in modern languages like \href{https://docs.julialang.org/en/v1/manual/metaprogramming/}{Julia} and \href{https://docs.racket-lang.org/reference/quasiquote.html}{Racket}. In base R, quasiquotation is performed with \code{\link[=bquote]{bquote()}}. The main difference between rlang and other languages is that quasiquotation is often implicit instead of explicit. You can use injection operators in any defusing / quoting function (unless that function defuses its argument with a special operator like \code{\link[=enquo0]{enquo0()}}). This is not the case in lisp languages for example where injection / unquoting is explicit and only enabled within a backquote. } \section{See also}{ \itemize{ \item \ifelse{html}{\link[=topic-inject-out-of-context]{What happens if I use injection operators out of context?}}{\link[=topic-inject-out-of-context]{What happens if I use injection operators out of context?}} } } \keyword{internal} rlang/man/as_closure.Rd0000644000176200001440000000303514175213516014564 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/fn.R \name{as_closure} \alias{as_closure} \title{Transform to a closure} \usage{ as_closure(x, env = caller_env()) } \arguments{ \item{x}{A function or formula. If a \strong{function}, it is used as is. If a \strong{formula}, e.g. \code{~ .x + 2}, it is converted to a function with up to two arguments: \code{.x} (single argument) or \code{.x} and \code{.y} (two arguments). The \code{.} placeholder can be used instead of \code{.x}. This allows you to create very compact anonymous functions (lambdas) with up to two inputs. Functions created from formulas have a special class. Use \code{is_lambda()} to test for it. If a \strong{string}, the function is looked up in \code{env}. Note that this interface is strictly for user convenience because of the scoping issues involved. Package developers should avoid supplying functions by name and instead supply them by value.} \item{env}{Environment in which to fetch the function in case \code{x} is a string.} } \description{ \code{as_closure()} is like \code{\link[=as_function]{as_function()}} but also wraps primitive functions inside closures. Some special control flow primitives like \code{if}, \code{for}, or \code{break} can't be wrapped and will cause an error. } \examples{ # Primitive functions are regularised as closures as_closure(list) as_closure("list") # Operators have `.x` and `.y` as arguments, just like lambda # functions created with the formula syntax: as_closure(`+`) as_closure(`~`) } \keyword{internal} rlang/man/trace_back.Rd0000644000176200001440000000675214375670676014534 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/trace.R \name{trace_back} \alias{trace_back} \alias{trace_length} \title{Capture a backtrace} \usage{ trace_back(top = NULL, bottom = NULL) trace_length(trace) } \arguments{ \item{top}{The first frame environment to be included in the backtrace. This becomes the top of the backtrace tree and represents the oldest call in the backtrace. This is needed in particular when you call \code{trace_back()} indirectly or from a larger context, for example in tests or inside an RMarkdown document where you don't want all of the knitr evaluation mechanisms to appear in the backtrace. If not supplied, the \code{rlang_trace_top_env} global option is consulted. This makes it possible to trim the embedding context for all backtraces created while the option is set. If knitr is in progress, the default value for this option is \code{knitr::knit_global()} so that the knitr context is trimmed out of backtraces.} \item{bottom}{The last frame environment to be included in the backtrace. This becomes the rightmost leaf of the backtrace tree and represents the youngest call in the backtrace. Set this when you would like to capture a backtrace without the capture context. Can also be an integer that will be passed to \code{\link[=caller_env]{caller_env()}}.} \item{trace}{A backtrace created by \code{trace_back()}.} } \description{ A backtrace captures the sequence of calls that lead to the current function (sometimes called the call stack). Because of lazy evaluation, the call stack in R is actually a tree, which the \code{print()} method for this object will reveal. Users rarely need to call \code{trace_back()} manually. Instead, signalling an error with \code{\link[=abort]{abort()}} or setting up \code{\link[=global_entrace]{global_entrace()}} is the most common way to create backtraces when an error is thrown. Inspect the backtrace created for the most recent error with \code{\link[=last_error]{last_error()}}. \code{trace_length()} returns the number of frames in a backtrace. } \examples{ # Trim backtraces automatically (this improves the generated # documentation for the rlang website and the same trick can be # useful within knitr documents): options(rlang_trace_top_env = current_env()) f <- function() g() g <- function() h() h <- function() trace_back() # When no lazy evaluation is involved the backtrace is linear # (i.e. every call has only one child) f() # Lazy evaluation introduces a tree like structure identity(identity(f())) identity(try(f())) try(identity(f())) # When printing, you can request to simplify this tree to only show # the direct sequence of calls that lead to `trace_back()` x <- try(identity(f())) x print(x, simplify = "branch") # With a little cunning you can also use it to capture the # tree from within a base NSE function x <- NULL with(mtcars, {x <<- f(); 10}) x # Restore default top env for next example options(rlang_trace_top_env = NULL) # When code is executed indirectly, i.e. via source or within an # RMarkdown document, you'll tend to get a lot of guff at the beginning # related to the execution environment: conn <- textConnection("summary(f())") source(conn, echo = TRUE, local = TRUE) close(conn) # To automatically strip this off, specify which frame should be # the top of the backtrace. This will automatically trim off calls # prior to that frame: top <- current_env() h <- function() trace_back(top) conn <- textConnection("summary(f())") source(conn, echo = TRUE, local = TRUE) close(conn) } rlang/man/new_formula.Rd0000644000176200001440000000074413351410454014742 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/formula.R \name{new_formula} \alias{new_formula} \title{Create a formula} \usage{ new_formula(lhs, rhs, env = caller_env()) } \arguments{ \item{lhs, rhs}{A call, name, or atomic vector.} \item{env}{An environment.} } \value{ A formula object. } \description{ Create a formula } \examples{ new_formula(quote(a), quote(b)) new_formula(NULL, quote(b)) } \seealso{ \code{\link[=new_quosure]{new_quosure()}} } rlang/man/vector-coercion.Rd0000644000176200001440000001033414401331316015515 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/lifecycle-deprecated.R \name{vector-coercion} \alias{vector-coercion} \alias{as_logical} \alias{as_integer} \alias{as_double} \alias{as_complex} \alias{as_character} \alias{as_list} \title{Coerce an object to a base type} \usage{ as_logical(x) as_integer(x) as_double(x) as_complex(x) as_character(x, encoding = NULL) as_list(x) } \arguments{ \item{x}{An object to coerce to a base type.} \item{encoding}{If non-null, set an encoding mark. This is only declarative, no encoding conversion is performed.} } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} These are equivalent to the base functions (e.g. \code{\link[=as.logical]{as.logical()}}, \code{\link[=as.list]{as.list()}}, etc), but perform coercion rather than conversion. This means they are not generic and will not call S3 conversion methods. They only attempt to coerce the base type of their input. In addition, they have stricter implicit coercion rules and will never attempt any kind of parsing. E.g. they will not try to figure out if a character vector represents integers or booleans. Finally, they treat attributes consistently, unlike the base R functions: all attributes except names are removed. } \section{Lifecycle}{ These functions are deprecated in favour of \code{vctrs::vec_cast()}. } \section{Coercion to logical and numeric atomic vectors}{ \itemize{ \item To logical vectors: Integer and integerish double vectors. See \code{\link[=is_integerish]{is_integerish()}}. \item To integer vectors: Logical and integerish double vectors. \item To double vectors: Logical and integer vectors. \item To complex vectors: Logical, integer and double vectors. } } \section{Coercion to character vectors}{ \code{as_character()} and \code{as_string()} have an optional \code{encoding} argument to specify the encoding. R uses this information for internal handling of strings and character vectors. Note that this is only declarative, no encoding conversion is attempted. Note that only \code{as_string()} can coerce symbols to a scalar character vector. This makes the code more explicit and adds an extra type check. } \section{Coercion to lists}{ \code{as_list()} only coerces vector and dictionary types (environments are an example of dictionary type). Unlike \code{\link[base:list]{base::as.list()}}, \code{as_list()} removes all attributes except names. } \section{Effects of removing attributes}{ A technical side-effect of removing the attributes of the input is that the underlying objects has to be copied. This has no performance implications in the case of lists because this is a shallow copy: only the list structure is copied, not the contents (see \code{\link[=duplicate]{duplicate()}}). However, be aware that atomic vectors containing large amounts of data will have to be copied. In general, any attribute modification creates a copy, which is why it is better to avoid using attributes with heavy atomic vectors. Uncopyable objects like environments and symbols are an exception to this rule: in this case, attributes modification happens in place and has side-effects. } \examples{ # Coercing atomic vectors removes attributes with both base R and rlang: x <- structure(TRUE, class = "foo", bar = "baz") as.logical(x) # But coercing lists preserves attributes in base R but not rlang: l <- structure(list(TRUE), class = "foo", bar = "baz") as.list(l) as_list(l) # Implicit conversions are performed in base R but not rlang: as.logical(l) \dontrun{ as_logical(l) } # Conversion methods are bypassed, making the result of the # coercion more predictable: as.list.foo <- function(x) "wrong" as.list(l) as_list(l) # The input is never parsed. E.g. character vectors of numbers are # not converted to numeric types: as.integer("33") \dontrun{ as_integer("33") } # With base R tools there is no way to convert an environment to a # list without either triggering method dispatch, or changing the # original environment. as_list() makes it easy: x <- structure(as_environment(mtcars[1:2]), class = "foobar") as.list.foobar <- function(x) abort("dont call me") as_list(x) } \keyword{internal} rlang/man/local_options.Rd0000644000176200001440000000421314127057575015301 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/state.R \name{local_options} \alias{local_options} \alias{with_options} \alias{push_options} \alias{peek_options} \alias{peek_option} \title{Change global options} \usage{ local_options(..., .frame = caller_env()) with_options(.expr, ...) push_options(...) peek_options(...) peek_option(name) } \arguments{ \item{...}{For \code{local_options()} and \code{push_options()}, named values defining new option values. For \code{peek_options()}, strings or character vectors of option names.} \item{.frame}{The environment of a stack frame which defines the scope of the temporary options. When the frame returns, the options are set back to their original values.} \item{.expr}{An expression to evaluate with temporary options.} \item{name}{An option name as string.} } \value{ For \code{local_options()} and \code{push_options()}, the old option values. \code{peek_option()} returns the current value of an option while the plural \code{peek_options()} returns a list of current option values. } \description{ \itemize{ \item \code{local_options()} changes options for the duration of a stack frame (by default the current one). Options are set back to their old values when the frame returns. \item \code{with_options()} changes options while an expression is evaluated. Options are restored when the expression returns. \item \code{push_options()} adds or changes options permanently. \item \code{peek_option()} and \code{peek_options()} return option values. The former returns the option directly while the latter returns a list. } } \section{Life cycle}{ These functions are experimental. } \examples{ # Store and retrieve a global option: push_options(my_option = 10) peek_option("my_option") # Change the option temporarily: with_options(my_option = 100, peek_option("my_option")) peek_option("my_option") # The scoped variant is useful within functions: fn <- function() { local_options(my_option = 100) peek_option("my_option") } fn() peek_option("my_option") # The plural peek returns a named list: peek_options("my_option") peek_options("my_option", "digits") } \keyword{experimental} rlang/man/arg_match.Rd0000644000176200001440000000452114375670676014373 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/arg.R \name{arg_match} \alias{arg_match} \alias{arg_match0} \title{Match an argument to a character vector} \usage{ arg_match( arg, values = NULL, ..., multiple = FALSE, error_arg = caller_arg(arg), error_call = caller_env() ) arg_match0(arg, values, arg_nm = caller_arg(arg), error_call = caller_env()) } \arguments{ \item{arg}{A symbol referring to an argument accepting strings.} \item{values}{A character vector of possible values that \code{arg} can take.} \item{...}{These dots are for future extensions and must be empty.} \item{multiple}{Whether \code{arg} may contain zero or several values.} \item{error_arg}{An argument name as a string. This argument will be mentioned in error messages as the input that is at the origin of a problem.} \item{error_call}{The execution environment of a currently running function, e.g. \code{caller_env()}. The function will be mentioned in error messages as the source of the error. See the \code{call} argument of \code{\link[=abort]{abort()}} for more information.} \item{arg_nm}{Same as \code{error_arg}.} } \value{ The string supplied to \code{arg}. } \description{ This is equivalent to \code{\link[base:match.arg]{base::match.arg()}} with a few differences: \itemize{ \item Partial matches trigger an error. \item Error messages are a bit more informative and obey the tidyverse standards. } \code{arg_match()} derives the possible values from the \link[=caller_fn]{caller function}. \code{arg_match0()} is a bare-bones version if performance is at a premium. It requires a string as \code{arg} and explicit character \code{values}. For convenience, \code{arg} may also be a character vector containing every element of \code{values}, possibly permuted. In this case, the first element of \code{arg} is used. } \examples{ fn <- function(x = c("foo", "bar")) arg_match(x) fn("bar") # Throws an informative error for mismatches: try(fn("b")) try(fn("baz")) # Use the bare-bones version with explicit values for speed: arg_match0("bar", c("foo", "bar", "baz")) # For convenience: fn1 <- function(x = c("bar", "baz", "foo")) fn3(x) fn2 <- function(x = c("baz", "bar", "foo")) fn3(x) fn3 <- function(x) arg_match0(x, c("foo", "bar", "baz")) fn1() fn2("bar") try(fn3("zoo")) } \seealso{ \code{\link[=check_required]{check_required()}} } rlang/man/is_condition.Rd0000644000176200001440000000057514175213516015114 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cnd.R \name{is_condition} \alias{is_condition} \alias{is_error} \alias{is_warning} \alias{is_message} \title{Is object a condition?} \usage{ is_condition(x) is_error(x) is_warning(x) is_message(x) } \arguments{ \item{x}{An object to test.} } \description{ Is object a condition? } \keyword{internal} rlang/man/has_length.Rd0000644000176200001440000000136114127057575014551 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/attr.R \name{has_length} \alias{has_length} \title{How long is an object?} \usage{ has_length(x, n = NULL) } \arguments{ \item{x}{A R object.} \item{n}{A specific length to test \code{x} with. If \code{NULL}, \code{has_length()} returns \code{TRUE} if \code{x} has length greater than zero, and \code{FALSE} otherwise.} } \description{ This is a function for the common task of testing the length of an object. It checks the length of an object in a non-generic way: \code{\link[base:length]{base::length()}} methods are ignored. } \examples{ has_length(list()) has_length(list(), 0) has_length(letters) has_length(letters, 20) has_length(letters, 26) } \keyword{internal} rlang/man/dots_values.Rd0000644000176200001440000000402714376106521014757 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/dots.R \name{dots_values} \alias{dots_values} \title{Evaluate dots with preliminary splicing} \usage{ dots_values( ..., .ignore_empty = c("trailing", "none", "all"), .preserve_empty = FALSE, .homonyms = c("keep", "first", "last", "error"), .check_assign = FALSE ) } \arguments{ \item{...}{Arguments to evaluate and process splicing operators.} \item{.ignore_empty}{Whether to ignore empty arguments. Can be one of \code{"trailing"}, \code{"none"}, \code{"all"}. If \code{"trailing"}, only the last argument is ignored if it is empty.} \item{.preserve_empty}{Whether to preserve the empty arguments that were not ignored. If \code{TRUE}, empty arguments are stored with \code{\link[=missing_arg]{missing_arg()}} values. If \code{FALSE} (the default) an error is thrown when an empty argument is detected.} \item{.homonyms}{How to treat arguments with the same name. The default, \code{"keep"}, preserves these arguments. Set \code{.homonyms} to \code{"first"} to only keep the first occurrences, to \code{"last"} to keep the last occurrences, and to \code{"error"} to raise an informative error and indicate what arguments have duplicated names.} \item{.check_assign}{Whether to check for \verb{<-} calls. When \code{TRUE} a warning recommends users to use \code{=} if they meant to match a function parameter or wrap the \verb{<-} call in curly braces otherwise. This ensures assignments are explicit.} } \description{ This is a tool for advanced users. It captures dots, processes unquoting and splicing operators, and evaluates them. Unlike \code{\link[=dots_list]{dots_list()}}, it does not flatten spliced objects, instead they are attributed a \code{spliced} class (see \code{\link[=splice]{splice()}}). You can process spliced objects manually, perhaps with a custom predicate (see \code{\link[=flatten_if]{flatten_if()}}). } \examples{ dots <- dots_values(!!! list(1, 2), 3) dots # Flatten the objects marked as spliced: flatten_if(dots, is_spliced) } \keyword{internal} rlang/man/call_standardise.Rd0000644000176200001440000000252214375670676015741 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/lifecycle-deprecated.R \name{call_standardise} \alias{call_standardise} \title{Standardise a call} \usage{ call_standardise(call, env = caller_env()) } \arguments{ \item{call, env}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}}} } \value{ A quosure if \code{call} is a quosure, a raw call otherwise. } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} Deprecated in rlang 0.4.11 in favour of \code{\link[=call_match]{call_match()}}. \code{call_standardise()} was designed for call wrappers that include an environment like formulas or quosures. The function definition was plucked from that environment. However in practice it is rare to use it with wrapped calls, and then it's easy to forget to supply the environment. For these reasons, we have designed \code{\link[=call_match]{call_match()}} as a simpler wrapper around \code{\link[=match.call]{match.call()}}. This is essentially equivalent to \code{\link[base:match.call]{base::match.call()}}, but with experimental handling of primitive functions. } \keyword{internal} rlang/man/env_get.Rd0000644000176200001440000000312014375670676014067 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/env-binding.R \name{env_get} \alias{env_get} \alias{env_get_list} \title{Get an object in an environment} \usage{ env_get(env = caller_env(), nm, default, inherit = FALSE, last = empty_env()) env_get_list( env = caller_env(), nms, default, inherit = FALSE, last = empty_env() ) } \arguments{ \item{env}{An environment.} \item{nm}{Name of binding, a string.} \item{default}{A default value in case there is no binding for \code{nm} in \code{env}.} \item{inherit}{Whether to look for bindings in the parent environments.} \item{last}{Last environment inspected when \code{inherit} is \code{TRUE}. Can be useful in conjunction with \code{\link[base:ns-topenv]{base::topenv()}}.} \item{nms}{Names of bindings, a character vector.} } \value{ An object if it exists. Otherwise, throws an error. } \description{ \code{env_get()} extracts an object from an enviroment \code{env}. By default, it does not look in the parent environments. \code{env_get_list()} extracts multiple objects from an environment into a named list. } \examples{ parent <- child_env(NULL, foo = "foo") env <- child_env(parent, bar = "bar") # This throws an error because `foo` is not directly defined in env: # env_get(env, "foo") # However `foo` can be fetched in the parent environment: env_get(env, "foo", inherit = TRUE) # You can also avoid an error by supplying a default value: env_get(env, "foo", default = "FOO") } \seealso{ \code{\link[=env_cache]{env_cache()}} for a variant of \code{env_get()} designed to cache a value in an environment. } rlang/man/topic-multiple-columns.Rd0000644000176200001440000001442114741441453017055 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/topic-nse.R \name{topic-multiple-columns} \alias{topic-multiple-columns} \title{Taking multiple columns without \code{...}} \description{ In this guide we compare ways of taking multiple columns in a single function argument. As a refresher (see the \link[=topic-data-mask-programming]{programming patterns} article), there are two common ways of passing arguments to \link[=topic-data-mask]{data-masking} functions. For single arguments, embrace with \ifelse{html}{\code{\link[=embrace-operator]{\{\{}}}{\verb{\{\{}}: \if{html}{\out{
}}\preformatted{my_group_by <- function(data, var) \{ data \%>\% dplyr::group_by(\{\{ var \}\}) \} my_pivot_longer <- function(data, var) \{ data \%>\% tidyr::pivot_longer(\{\{ var \}\}) \} }\if{html}{\out{
}} For multiple arguments in \code{...}, pass them on to functions that also take \code{...} like \code{group_by()}, or pass them within \code{c()} for functions taking tidy selection in a single argument like \code{pivot_longer()}: \if{html}{\out{
}}\preformatted{# Pass dots through my_group_by <- function(.data, ...) \{ .data \%>\% dplyr::group_by(...) \} my_pivot_longer <- function(.data, ...) \{ .data \%>\% tidyr::pivot_longer(c(...)) \} }\if{html}{\out{
}} But what if you want to take multiple columns in a single named argument rather than in \code{...}? } \section{Using tidy selections}{ The idiomatic tidyverse way of taking multiple columns in a single argument is to take a \emph{tidy selection} (see the \link[=topic-data-mask-programming]{Argument behaviours} section). In tidy selections, the syntax for passing multiple columns in a single argument is \code{c()}: \if{html}{\out{
}}\preformatted{mtcars \%>\% tidyr::pivot_longer(c(am, cyl, vs)) }\if{html}{\out{
}} Since \verb{\{\{} inherits behaviour, this implementation of \code{my_pivot_longer()} automatically allows multiple columns passing: \if{html}{\out{
}}\preformatted{my_pivot_longer <- function(data, var) \{ data \%>\% tidyr::pivot_longer(\{\{ var \}\}) \} mtcars \%>\% my_pivot_longer(c(am, cyl, vs)) }\if{html}{\out{
}} For \code{group_by()}, which takes data-masked arguments, we'll use \code{across()} as a \emph{bridge} (see \link[=topic-data-mask-programming]{Bridge patterns}). \if{html}{\out{
}}\preformatted{my_group_by <- function(data, var) \{ data \%>\% dplyr::group_by(across(\{\{ var \}\})) \} mtcars \%>\% my_group_by(c(am, cyl, vs)) }\if{html}{\out{
}} When embracing in tidyselect context or using \code{across()} is not possible, you might have to implement tidyselect behaviour manually with \code{tidyselect::eval_select()}. } \section{Using external defusal}{ To implement an argument with tidyselect behaviour, it is necessary to \link[=topic-defuse]{defuse} the argument. However defusing an argument which had historically behaved like a regular argument is a rather disruptive breaking change. This is why we could not implement tidy selections in ggplot2 facetting functions like \code{facet_grid()} and \code{facet_wrap()}. An alternative is to use external defusal of arguments. This is what formula interfaces do for instance. A modelling function takes a formula in a regular argument and the formula defuses the user code: \if{html}{\out{
}}\preformatted{my_lm <- function(data, f, ...) \{ lm(f, data, ...) \} mtcars \%>\% my_lm(disp ~ drat) }\if{html}{\out{
}} Once created, the defused expressions contained in the formula are passed around like a normal argument. A similar approach was taken to update \code{facet_} functions to tidy eval. The \code{vars()} function (a simple alias to \code{\link[=quos]{quos()}}) is provided so that users can defuse their arguments externally. \if{html}{\out{
}}\preformatted{ggplot2::facet_grid( ggplot2::vars(cyl), ggplot2::vars(am, vs) ) }\if{html}{\out{
}} You can implement this approach by simply taking a list of defused expressions as argument. This list can be passed the usual way to other functions taking such lists: \if{html}{\out{
}}\preformatted{my_facet_grid <- function(rows, cols, ...) \{ ggplot2::facet_grid(rows, cols, ...) \} }\if{html}{\out{
}} Or it can be spliced with \code{\link{!!!}}: \if{html}{\out{
}}\preformatted{my_group_by <- function(data, vars) \{ stopifnot(is_quosures(vars)) data \%>\% dplyr::group_by(!!!vars) \} mtcars \%>\% my_group_by(dplyr::vars(cyl, am)) }\if{html}{\out{
}} } \section{A non-approach: Parsing lists}{ Intuitively, many programmers who want to take a list of expressions in a single argument try to defuse an argument and parse it. The user is expected to supply multiple arguments within a \code{list()} expression. When such a call is detected, the arguments are retrieved and spliced with \verb{!!!}. Otherwise, the user is assumed to have supplied a single argument which is injected with \verb{!!}. An implementation along these lines might look like this: \if{html}{\out{
}}\preformatted{my_group_by <- function(data, vars) \{ vars <- enquo(vars) if (quo_is_call(vars, "list")) \{ expr <- quo_get_expr(vars) env <- quo_get_env(vars) args <- as_quosures(call_args(expr), env = env) data \%>\% dplyr::group_by(!!!args) \} else \{ data \%>\% dplyr::group_by(!!vars) \} \} }\if{html}{\out{
}} This does work in simple cases: \if{html}{\out{
}}\preformatted{mtcars \%>\% my_group_by(cyl) \%>\% dplyr::group_vars() #> [1] "cyl" mtcars \%>\% my_group_by(list(cyl, am)) \%>\% dplyr::group_vars() #> [1] "cyl" "am" }\if{html}{\out{
}} However this parsing approach quickly shows limits: \if{html}{\out{
}}\preformatted{mtcars \%>\% my_group_by(list2(cyl, am)) #> Error in `group_by()`: Can't add columns. #> i `..1 = list2(cyl, am)`. #> i `..1` must be size 32 or 1, not 2. }\if{html}{\out{
}} Also, it would be better for overall consistency of interfaces to use the tidyselect syntax \code{c()} for passing multiple columns. In general, we recommend to use either the tidyselect or the external defusal approaches. } \keyword{internal} rlang/man/local_use_cli.Rd0000644000176200001440000000405414375670676015244 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cnd-abort.R \name{local_use_cli} \alias{local_use_cli} \title{Use cli to format error messages} \usage{ local_use_cli(..., format = TRUE, inline = FALSE, frame = caller_env()) } \arguments{ \item{...}{These dots are for future extensions and must be empty.} \item{format}{Whether to use cli at print-time to format messages and bullets.} \item{inline}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} Whether to use cli at throw-time to format the inline parts of a message. This makes it possible to use cli interpolation and formatting with \code{abort()}.} \item{frame}{A package namespace or an environment of a running function.} } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} \code{local_use_cli()} marks a package namespace or the environment of a running function with a special flag that instructs \code{\link[=abort]{abort()}} to use cli to format error messages. This formatting happens lazily, at print-time, in various places: \itemize{ \item When an unexpected error is displayed to the user. \item When a captured error is printed in the console, for instance via \code{\link[=last_error]{last_error()}}. \item When \code{\link[=conditionMessage]{conditionMessage()}} is called. } cli formats messages and bullets with indentation and width-wrapping to produce a polished display of messages. } \section{Usage}{ To use cli formatting automatically in your package: \enumerate{ \item Make sure \code{\link[=run_on_load]{run_on_load()}} is called from your \code{.onLoad()} hook. \item Call \code{on_load(local_use_cli())} at the top level of your namespace. } It is also possible to call \code{local_use_cli()} inside a running function, in which case the flag only applies within that function. } \keyword{internal} rlang/man/inherits_any.Rd0000644000176200001440000000304214127057575015127 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/s3.R \name{inherits_any} \alias{inherits_any} \alias{inherits_all} \alias{inherits_only} \title{Does an object inherit from a set of classes?} \usage{ inherits_any(x, class) inherits_all(x, class) inherits_only(x, class) } \arguments{ \item{x}{An object to test for inheritance.} \item{class}{A character vector of classes.} } \description{ \itemize{ \item \code{inherits_any()} is like \code{\link[base:class]{base::inherits()}} but is more explicit about its behaviour with multiple classes. If \code{classes} contains several elements and the object inherits from at least one of them, \code{inherits_any()} returns \code{TRUE}. \item \code{inherits_all()} tests that an object inherits from all of the classes in the supplied order. This is usually the best way to test for inheritance of multiple classes. \item \code{inherits_only()} tests that the class vectors are identical. It is a shortcut for \code{identical(class(x), class)}. } } \examples{ obj <- structure(list(), class = c("foo", "bar", "baz")) # With the _any variant only one class must match: inherits_any(obj, c("foobar", "bazbaz")) inherits_any(obj, c("foo", "bazbaz")) # With the _all variant all classes must match: inherits_all(obj, c("foo", "bazbaz")) inherits_all(obj, c("foo", "baz")) # The order of classes must match as well: inherits_all(obj, c("baz", "foo")) # inherits_only() checks that the class vectors are identical: inherits_only(obj, c("foo", "baz")) inherits_only(obj, c("foo", "bar", "baz")) } rlang/man/pairlist2.Rd0000644000176200001440000000144114375670676014355 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/call.R \name{pairlist2} \alias{pairlist2} \title{Collect dynamic dots in a pairlist} \usage{ pairlist2(...) } \arguments{ \item{...}{<\link[=dyn-dots]{dynamic}> Arguments stored in the pairlist. Empty arguments are preserved.} } \description{ This pairlist constructor uses \link[=dyn-dots]{dynamic dots}. Use it to manually create argument lists for calls or parameter lists for functions. } \examples{ # Unlike `exprs()`, `pairlist2()` evaluates its arguments. new_function(pairlist2(x = 1, y = 3 * 6), quote(x * y)) new_function(exprs(x = 1, y = 3 * 6), quote(x * y)) # It preserves missing arguments, which is useful for creating # parameters without defaults: new_function(pairlist2(x = , y = 3 * 6), quote(x * y)) } rlang/man/is_symbol.Rd0000644000176200001440000000052613351410763014425 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/sym.R \name{is_symbol} \alias{is_symbol} \title{Is object a symbol?} \usage{ is_symbol(x, name = NULL) } \arguments{ \item{x}{An object to test.} \item{name}{An optional name or vector of names that the symbol should match.} } \description{ Is object a symbol? } rlang/man/is_copyable.Rd0000644000176200001440000000176014127057575014731 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/types.R \name{is_copyable} \alias{is_copyable} \title{Is an object copyable?} \usage{ is_copyable(x) } \arguments{ \item{x}{An object to test.} } \description{ When an object is modified, R generally copies it (sometimes lazily) to enforce \href{https://en.wikipedia.org/wiki/Value_semantics}{value semantics}. However, some internal types are uncopyable. If you try to copy them, either with \verb{<-} or by argument passing, you actually create references to the original object rather than actual copies. Modifying these references can thus have far reaching side effects. } \examples{ # Let's add attributes with structure() to uncopyable types. Since # they are not copied, the attributes are changed in place: env <- env() structure(env, foo = "bar") env # These objects that can only be changed with side effect are not # copyable: is_copyable(env) structure(base::list, foo = "bar") str(base::list) } \keyword{internal} rlang/man/local_error_call.Rd0000644000176200001440000001172214375670676015745 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cnd-abort.R \name{local_error_call} \alias{local_error_call} \title{Set local error call in an execution environment} \usage{ local_error_call(call, frame = caller_env()) } \arguments{ \item{call}{This can be: \itemize{ \item A call to be used as context for an error thrown in that execution environment. \item The \code{NULL} value to show no context. \item An execution environment, e.g. as returned by \code{\link[=caller_env]{caller_env()}}. The \code{\link[=sys.call]{sys.call()}} for that environment is taken as context. }} \item{frame}{The execution environment in which to set the local error call.} } \description{ \code{local_error_call()} is an alternative to explicitly passing a \code{call} argument to \code{\link[=abort]{abort()}}. It sets the call (or a value that indicates where to find the call, see below) in a local binding that is automatically picked up by \code{\link[=abort]{abort()}}. } \section{Motivation for setting local error calls}{ By default \code{\link[=abort]{abort()}} uses the function call of its caller as context in error messages: \if{html}{\out{
}}\preformatted{foo <- function() abort("Uh oh.") foo() #> Error in `foo()`: Uh oh. }\if{html}{\out{
}} This is not always appropriate. For example a function that checks an input on the behalf of another function should reference the latter, not the former: \if{html}{\out{
}}\preformatted{arg_check <- function(arg, error_arg = as_string(substitute(arg))) \{ abort(cli::format_error("\{.arg \{error_arg\}\} is failing.")) \} foo <- function(x) arg_check(x) foo() #> Error in `arg_check()`: `x` is failing. }\if{html}{\out{
}} The mismatch is clear in the example above. \code{arg_check()} does not have any \code{x} argument and so it is confusing to present \code{arg_check()} as being the relevant context for the failure of the \code{x} argument. One way around this is to take a \code{call} or \code{error_call} argument and pass it to \code{abort()}. Here we name this argument \code{error_call} for consistency with \code{error_arg} which is prefixed because there is an existing \code{arg} argument. In other situations, taking \code{arg} and \code{call} arguments might be appropriate. \if{html}{\out{
}}\preformatted{arg_check <- function(arg, error_arg = as_string(substitute(arg)), error_call = caller_env()) \{ abort( cli::format_error("\{.arg \{error_arg\}\} is failing."), call = error_call ) \} foo <- function(x) arg_check(x) foo() #> Error in `foo()`: `x` is failing. }\if{html}{\out{
}} This is the generally recommended pattern for argument checking functions. If you mention an argument in an error message, provide your callers a way to supply a different argument name and a different error call. \code{abort()} stores the error call in the \code{call} condition field which is then used to generate the "in" part of error messages. In more complex cases it's often burdensome to pass the relevant call around, for instance if your checking and throwing code is structured into many different functions. In this case, use \code{local_error_call()} to set the call locally or instruct \code{abort()} to climb the call stack one level to find the relevant call. In the following example, the complexity is not so important that sparing the argument passing makes a big difference. However this illustrates the pattern: \if{html}{\out{
}}\preformatted{arg_check <- function(arg, error_arg = caller_arg(arg), error_call = caller_env()) \{ # Set the local error call local_error_call(error_call) my_classed_stop( cli::format_error("\{.arg \{error_arg\}\} is failing.") ) \} my_classed_stop <- function(message) \{ # Forward the local error call to the caller's local_error_call(caller_env()) abort(message, class = "my_class") \} foo <- function(x) arg_check(x) foo() #> Error in `foo()`: `x` is failing. }\if{html}{\out{
}} } \section{Error call flags in performance-critical functions}{ The \code{call} argument can also be the string \code{"caller"}. This is equivalent to \code{caller_env()} or \code{parent.frame()} but has a lower overhead because call stack introspection is only performed when an error is triggered. Note that eagerly calling \code{caller_env()} is fast enough in almost all cases. If your function needs to be really fast, assign the error call flag directly instead of calling \code{local_error_call()}: \if{html}{\out{
}}\preformatted{.__error_call__. <- "caller" }\if{html}{\out{
}} } \examples{ # Set a context for error messages function() { local_error_call(quote(foo())) local_error_call(sys.call()) } # Disable the context function() { local_error_call(NULL) } # Use the caller's context function() { local_error_call(caller_env()) } } rlang/man/eval_bare.Rd0000644000176200001440000000730714375670676014373 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/eval.R \name{eval_bare} \alias{eval_bare} \title{Evaluate an expression in an environment} \usage{ eval_bare(expr, env = parent.frame()) } \arguments{ \item{expr}{An expression to evaluate.} \item{env}{The environment in which to evaluate the expression.} } \description{ \code{eval_bare()} is a lower-level version of function \code{\link[base:eval]{base::eval()}}. Technically, it is a simple wrapper around the C function \code{Rf_eval()}. You generally don't need to use \code{eval_bare()} instead of \code{eval()}. Its main advantage is that it handles stack-sensitive calls (such as \code{return()}, \code{on.exit()} or \code{parent.frame()}) more consistently when you pass an enviroment of a frame on the call stack. } \details{ These semantics are possible because \code{eval_bare()} creates only one frame on the call stack whereas \code{eval()} creates two frames, the second of which has the user-supplied environment as frame environment. When you supply an existing frame environment to \code{base::eval()} there will be two frames on the stack with the same frame environment. Stack-sensitive functions only detect the topmost of these frames. We call these evaluation semantics "stack inconsistent". Evaluating expressions in the actual frame environment has useful practical implications for \code{eval_bare()}: \itemize{ \item \code{return()} calls are evaluated in frame environments that might be burried deep in the call stack. This causes a long return that unwinds multiple frames (triggering the \code{on.exit()} event for each frame). By contrast \code{eval()} only returns from the \code{eval()} call, one level up. \item \code{on.exit()}, \code{parent.frame()}, \code{sys.call()}, and generally all the stack inspection functions \code{sys.xxx()} are evaluated in the correct frame environment. This is similar to how this type of calls can be evaluated deep in the call stack because of lazy evaluation, when you force an argument that has been passed around several times. } The flip side of the semantics of \code{eval_bare()} is that it can't evaluate \code{break} or \code{next} expressions even if called within a loop. } \examples{ # eval_bare() works just like base::eval() but you have to create # the evaluation environment yourself: eval_bare(quote(foo), env(foo = "bar")) # eval() has different evaluation semantics than eval_bare(). It # can return from the supplied environment even if its an # environment that is not on the call stack (i.e. because you've # created it yourself). The following would trigger an error with # eval_bare(): ret <- quote(return("foo")) eval(ret, env()) # eval_bare(ret, env()) # "no function to return from" error # Another feature of eval() is that you can control surround loops: bail <- quote(break) while (TRUE) { eval(bail) # eval_bare(bail) # "no loop for break/next" error } # To explore the consequences of stack inconsistent semantics, let's # create a function that evaluates `parent.frame()` deep in the call # stack, in an environment corresponding to a frame in the middle of # the stack. For consistency with R's lazy evaluation semantics, we'd # expect to get the caller of that frame as result: fn <- function(eval_fn) { list( returned_env = middle(eval_fn), actual_env = current_env() ) } middle <- function(eval_fn) { deep(eval_fn, current_env()) } deep <- function(eval_fn, eval_env) { expr <- quote(parent.frame()) eval_fn(expr, eval_env) } # With eval_bare(), we do get the expected environment: fn(rlang::eval_bare) # But that's not the case with base::eval(): fn(base::eval) } \seealso{ \code{\link[=eval_tidy]{eval_tidy()}} for evaluation with data mask and quosure support. } rlang/man/done.Rd0000644000176200001440000000142514127057575013363 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/s3.R \name{done} \alias{done} \alias{is_done_box} \title{Box a final value for early termination} \usage{ done(x) is_done_box(x, empty = NULL) } \arguments{ \item{x}{For \code{done()}, a value to box. For \code{is_done_box()}, a value to test.} \item{empty}{Whether the box is empty. If \code{NULL}, \code{is_done_box()} returns \code{TRUE} for all done boxes. If \code{TRUE}, it returns \code{TRUE} only for empty boxes. Otherwise it returns \code{TRUE} only for non-empty boxes.} } \value{ A \link[=new_box]{boxed} value. } \description{ A value boxed with \code{done()} signals to its caller that it should stop iterating. Use it to shortcircuit a loop. } \examples{ done(3) x <- done(3) is_done_box(x) } rlang/man/stack.Rd0000644000176200001440000000277014375670676013557 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/stack.R \name{stack} \alias{stack} \alias{current_call} \alias{current_fn} \alias{current_env} \alias{caller_call} \alias{caller_fn} \alias{caller_env} \alias{frame_call} \alias{frame_fn} \title{Get properties of the current or caller frame} \usage{ current_call() current_fn() current_env() caller_call(n = 1) caller_fn(n = 1) caller_env(n = 1) frame_call(frame = caller_env()) frame_fn(frame = caller_env()) } \arguments{ \item{n}{The number of callers to go back.} \item{frame}{A frame environment of a currently running function, as returned by \code{\link[=caller_env]{caller_env()}}. \code{NULL} is returned if the environment does not exist on the stack.} } \description{ These accessors retrieve properties of frames on the call stack. The prefix indicates for which frame a property should be accessed: \itemize{ \item From the current frame with \code{current_} accessors. \item From a calling frame with \code{caller_} accessors. \item From a matching frame with \code{frame_} accessors. } The suffix indicates which property to retrieve: \itemize{ \item \verb{_fn} accessors return the function running in the frame. \item \verb{_call} accessors return the defused call with which the function running in the frame was invoked. \item \verb{_env} accessors return the execution environment of the function running in the frame. } } \seealso{ \code{\link[=caller_env]{caller_env()}} and \code{\link[=current_env]{current_env()}} } rlang/man/embrace-operator.Rd0000644000176200001440000000250014375670676015670 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/nse-defuse.R \name{embrace-operator} \alias{embrace-operator} \alias{curly-curly} \title{Embrace operator \verb{\{\{}} \description{ The embrace operator \verb{\{\{} is used to create functions that call other \link[=topic-data-mask]{data-masking} functions. It transports a data-masked argument (an argument that can refer to columns of a data frame) from one function to another. \if{html}{\out{
}}\preformatted{my_mean <- function(data, var) \{ dplyr::summarise(data, mean = mean(\{\{ var \}\})) \} }\if{html}{\out{
}} } \section{Under the hood}{ \verb{\{\{} combines \code{\link[=enquo]{enquo()}} and \code{\link[=injection-operator]{!!}} in one step. The snippet above is equivalent to: \if{html}{\out{
}}\preformatted{my_mean <- function(data, var) \{ var <- enquo(var) dplyr::summarise(data, mean = mean(!!var)) \} }\if{html}{\out{
}} } \seealso{ \itemize{ \item \ifelse{html}{\link[=topic-data-mask]{What is data-masking and why do I need \{\{?}}{\link[=topic-data-mask]{What is data-masking and why do I need curly-curly?}} \item \ifelse{html}{\link[=topic-data-mask-programming]{Data mask programming patterns}}{\link[=topic-data-mask-programming]{Data mask programming patterns}} } } rlang/man/figures/0000755000176200001440000000000014375670676013621 5ustar liggesusersrlang/man/figures/lifecycle-questioning.svg0000644000176200001440000000171414127057575020637 0ustar liggesuserslifecyclelifecyclequestioningquestioning rlang/man/figures/lifecycle-stable.svg0000644000176200001440000000167414127057575017551 0ustar liggesuserslifecyclelifecyclestablestable rlang/man/figures/lifecycle-experimental.svg0000644000176200001440000000171614127057575020771 0ustar liggesuserslifecyclelifecycleexperimentalexperimental rlang/man/figures/lifecycle-deprecated.svg0000644000176200001440000000171214127057575020370 0ustar liggesuserslifecyclelifecycledeprecateddeprecated rlang/man/figures/lifecycle-superseded.svg0000644000176200001440000000171314175213516020424 0ustar liggesusers lifecyclelifecyclesupersededsuperseded rlang/man/figures/logo.png0000644000176200001440000006236414375670676015302 0ustar liggesusers‰PNG  IHDRx‹ªb]e /iCCPICC profileHÇ–wTTׇϽwz¡Í0Òz“.0€ô. QfÊà Mlˆ¨@DE €£¡H¬ˆb!(¨`HPb0Š¨¨dFÖJ|yyïåå÷ǽßÚgïs÷Ù{Ÿµ.$O./– ™'àz8ÓW…Gбýx€¦0Y驾AîÁ@$/7zºÈ ü‹Þ Hü¾eèéO§ƒÿOÒ¬T¾È_ÄælN:KÄù"NʤŠí3"¦Æ$ŠF‰™/JPÄrbŽ[䥟}ÙQÌìd[ÄâœSÙÉl1÷ˆx{†#bÄGÄ\N¦ˆo‹X3I˜Ìñ[ql2‡™Š$¶ 8¬x›ˆ˜Ätñrp¤¸/8æ p²âC¹¤¤fó¹qñº.KnjmÍ {r2“8¡?“•Èä³é.)É©L^6‹gþ,qmé¢"[šZ[Zš™~Q¨ÿºø7%îí"½ øÜ3ˆÖ÷‡í¯üRê`ÌŠj³ë[Ì~:¶ wÿ›æ!$E}k¿ñÅyhây‰RmŒ333¸–‘¸ ¿ë:ü }ñ=#ñv¿—‡îʉe “tqÝX)I)B>==•ÉâÐ ÿ<Äÿ8ð¯óXȉåð9€¢yPÜõßûæƒâ›¦:±8÷Ÿýû®p‰ø‘ÎûçLg ù‹kâk Ѐ$È t!0VÀ87°ø`ֈɀ2A.Ø @Øö‚JPêA#h'@8 .€Ëà:¸ î€`Œƒç`¼óa!2Dä!UH 2€Ì d¹A>P ECqB¹Ð¨*…*¡Z¨ú:]€®BÐ=hš‚~…ÞÃL‚©°2¬ Ã Ø ö†ƒá5pœçÀùðN¸®ƒÁíðø:|ŸÃ³@ˆ QC â‚ø!H,ÂG6 …H9R‡´ ]H/r A¦‘w( Š‚¢£ Q¶(OTŠ…JCm@£*QGQí¨Ô-Ô(jõ MF+¡ Ð6h/ô*t:]€.G7 ÛЗÐwÐãè7 ††ÑÁXa<1á˜Ì:L1æ¦s3€ÃÌb±Xy¬Öë‡ebØì~ì1ì9ì vûGÄ©âÌp‡+Ç5áÎâq¸y¼^ oƒ÷óñÙø|=¾ ?ŽŸ'Htv„`Ba3¡‚ÐB¸DxHxE$Õ‰ÖÄ"—¸‰XAàPð4Ð407°7ˆÔô&Ø9¸$øAˆnˆ0¤;T242´1t.Ì5¬4ld•ñªõ«®‡+„sÃ;#°¡ ³«ÝVï]=iY9´FgMÖš«kÖ&­=%ÅŒ:Ž‹nŠþÀôcÖ1gc¼bªcfX.¬}¬çlGv{ŠcÇ)åLÄÚÅ–ÆNÆÙÅ퉛Šwˆ/Ÿæºp+¹/<jæý$.$…%µ&ã’£“Oñdx‰¼ž•”¬”TƒÔ‚Ô‘4›´½i3|o~C:”¾&½S@ýLõ u…[…£öUo3C3OfIgñ²ú²õ³wdOä¸ç|½µŽµ®;W-wsîèz§õµ  1º7jlÌß8¾ÉcÓÑ͉̈́›È3É+Í{½%lKW¾rþ¦ü±­[› $ øÃÛl·ÕlGmçnïßa¾cÿŽO…ìÂkE&EåEŠYÅ×¾2ýªâ«…±;ûK,KîÂìâíÚí°ûh©tiNéØß=íeô²Â²×{£ö^-_V^³°O¸o¤Â§¢s¿æþ]û?TÆWÞ©r®j­VªÞQ=w€}`ð ãÁ–嚢š÷‡¸‡îÖzÔ¶×iוÆÎ8ü´>´¾÷kÆ× E ðŽŒ <ÚÓhÕØؤÔTÒ 7 ›§ŽE»ùë7-†-µ­´Ö¢ãà¸ðø³o£¿:á}¢û$ãdËwZßU·QÚ Û¡öìö™ŽøŽ‘ÎðÎS+NuwÙvµ}oôý‘Ój§«ÎÈž)9K8›vá\ιÙó©ç§/Ä]ëŽê~pqÕÅÛ==ý—¼/]¹ì~ùb¯Sï¹+vWN_µ¹zêãZÇuËëí}}m?XüÐÖoÙß~ÃêFçMë›]ËÎ: ^¸åzëòm¯Û×לּ302tw8rxä.ûî佤{/ïgÜŸ°é!úaá#©Gå•×ý¨÷cëˆåÈ™Q×Ѿ'AOŒ±Æžÿ”þÓ‡ñü§ä§åª“f“§§Ü§n>[ýlüyêóùé‚Ÿ¥®~¡ûâ»_é›Y53þ’ÿrá×âWò¯Ž¼^öº{Ööñ›ä7ós…oåß}Çx×û>ìýÄ|æ쇊z»>yz¸¼°ð÷„óûÌ;¼lbKGDÿÿÿ ½§“ pHYs!7!73XŸztIMEá çD†« IDATxÚì½wœœWuÿÿ¾O›^¶kµ’vTmu¹ÈÆöbŒmLI¥™âP†„Ð[?z 8!ôB°M `ƒ ØÆݲŠ%[]«ímv§—§ÝïÏÌhw5»Ú•E(¯ß}½$¦>Ï=÷žó9ŸS®àOlôôôL&=öÏZ’ÉäLÿôQ{ÿŸÊŠÂíé逬>6€s.«¾õ!àÀC Þÿ'%hñ§"ØiCM&“NõùMÀ›«¯™Õ{Ö«ÿÿðd2¹»ú~pj‚þS²øSlU  $“I»§§§ øàM@;àV?¢Tÿu hÀð-àËÉdr´§§GÜÚ"ùÿüûWǾd2Y©>ÿ&à-À¦ê[Ýš`¥”ÞM‹úm;€Z}¼øR2™üzõ{tÀúc·Íâ\¸  %“I³§§çBà ÀVÀW}«¬Ý£” j8¶ô^8ùî%ð0ð–d2¹³§§G«îf÷Õ6‹?6ÁN¿öd2){zzbÀçWLÛ' ÛvèË ¥dYw†®Öwt! à?¿Šµçÿm³øcÙ­ÕÇ"™LÊêã0ð’ê® vUÀ‚êî”\W’šÈ32œŸ±c;:"²¹5(4M¡œ­*3«êþæi&àÊ­$;WT'Söôô€K€OV… Nß½Š"pl—\®"‡‡²¢R¶Q5e† ¶m@—Q ûÐu×!éé@lðnà¾d2é̺ž?hA‹?Ô];‡ÛsQÕí¹ašÛcÔl¬¢„€l¦,S‘N—Q¢pÒ.B ¥Äq\âMAZZƒD"~„Ç‘µÝ.«š¡æV}øJ2™|¸z=`ÿ!«nñ‡(ØnO;ð>àµ@lºÛSœ®+äsR2™2–å0‡ú%hO Š*hj ÒÚ"4p)ë@lº›5Ü Ü”L&«DŠ3mþA Zü! wšÛc$“I³úü;€·+¹=ªªà8’Ñ‘,™t™JÅFQß–ªzjz–*¦¦¤”†FSS€ŽÎ(B€ëºÓÝ*wš/}øz2™ülõ: Àª©í?!ÿ¡íàénÏåÀ—uÓTäÌ‹Wé©£ÃYLÓAQDCáÕF¥b¡( †¡Í… =U/@3T–,‰Êæ– °mgºg'7%“É«L˜¬¹UBV~ßêxº½M&“.ïééùðk`Ã\Â5M‡£‡RôõNbšN]8 oRH óª®~Îfò…2ÊÂ3¼–éÐß7%òܹnCV •zzz¾Ä«÷0]5º;x·'¼ø×*"¶«–énm»LŒçÍW” R±Øº¹›·Ýø<>öé108YQÓG4Àu]²Ùr]»RB 5vUu·wDhi ¡ë* §/&Yu«Œ*ò~{Õ­JOó~o>´ú)ØÞÞ^z{{ééé‰DB©¹=‰DâU„zCu’˜.\Eض$“)Ñw|Š\¶‚ª*Õײ¹¯zÙe¼ñµW²{ÏqöìíGo@d”Ë6¦yÂFK ~ŸŽ®©Ø¶;ÃOöT²8ñÙ2ÙLUSÐu]¯8QG§úçÀ‹‰Ä`"‘8žL&íD"!‰„¨ ¹··÷OkÏPz2™´ªÏ_‰xq#·GU½ËKO•H¥ d3eE9Éí‘Rð\º}ÉûŸÆueC[ ÷ÝÞÂxëß^¦©üû—~A$ÀqŸŽ”P1-Îߺ’•+Û¹íÇà÷¸®;íRUA$ꧽ=L8âöÜéüvý~€ ðà£Éd²¿Š¶íÿ+~[üví?UÉŠÎYÜ/RJEÁu]†‡²d3å::ž= … €1㵚ÝLËÁ2mcN,T*Þ†òù´:YR,š\wÍ9l;où䉄ý ŠëJt]%÷Ó¹4ZuÙæt««nÕGg»UT;xY!ªL”ÝÓÓsðµª?+O¸`r² G‡s¶çÚy BHÞú·×rË÷îgl<{¡Q1m.8o—]r6ß¾å×äòå9}ã9Á‰ª (Ër¯“Þ¯)tvFeSsP¸®dŽ5%cU·êžªVs«ÏÿNv²r¦ÛàB;{zz~ܬ˜Ë.VÊ6‡Ó<=§pkïB°´3ŽáÓ«¶væl:ŽKKK„s¶tÏëóÎ7\×¥ÑuÌõU®ãÒß7%¯k…9ÆJàîžžžŸ]ÉdR&“ÉnUOOÏs«Ä™lÕÆÖÜžvàõÀ'€‚­8¤Æ r|5¡NGÇ®ë¢(ʼ¨^ÓOµO[ÈBxÃq] ];éwÇ%ÔéZÇï×êQ¯Y–Õ9¾/ÛsÿX¨á®‹p{–WyãÌæ§OL¹d11Q 5‘¯’üÎ…;}´¶FX±¬…>D `œ–<[ÍÆbAÒéB Ÿì>M¥ ¼éõWÑÞåó_½« °Nä !êTg£Eé8’¶¶-m!ü~ ó¹U¾•L&Uå¢ÔB”T·º·'œH$^üðüi¨N«¥´¨ª‡`SE22—+ MSOŠÖcŸòùr=XqºàÚ«¶ðáüãiÆ0ôÈÚfËÆø?qô¤E=×"‚:ÈçM2é’çâù´¹Ü*x6ðÂD"a%‰£Éd²ØÓÓ£Öܪ†;x·çexu=µ¢­zŒ¶–.㺒TªÀÔd‰RѪªÉïk¸®Äu݆»m±T¥m»|úc/çuo¹›>ñeÞõ·ÐÞ;)kDQÙ\ ËrhŠ‡¼€* Ó´ ‡ýuU/]I0dÐÜ-­aÑ Z5=Nþk¼$ÀïWå¥OãH&“'TtÕ€«Õt™­À§€ËÐ4/¦ïÚl¦ÌèhŽB¾x¬i*š¦,Úvþ_ŒZ0`1££=Æ–Í+x|ÇQ&R¹9Q~#Û=—ŠVAj2Ï{ÞþB"áÿöÅŸÏPë®ëE«ƒöŽ0ñ¦@=«dZ¶gmƒÚÀ]À{’ÉäSUœ$«é½ˆê®­¹=ðoÀ+èÉnçÛ9¶dp -³Ù²p]` >ðî?£¥%›ßö´·Å°íßOýV-"ÕÈžÎLœ*ËqÜ:óµX®&,3@Z a_rñY<±ëXÃ…^ӒሥËbÒÐU1-¥wö(ßþ¡êåh€-¦ñŸ/®¢ãÖYþØŒ‘š(ȑᬘ~-BxäÃÒ%M„‚>ö:%É_K>_³ªƒ£½ã s—Ÿ)¢žþŸOç/^´[¿÷À Tÿ»B ŠϾl—_¶žÏùNLÓ>mm¥(¢ž64O¤ ܘL&¿×ÓÓ£(===g¿¾—sìL®7YPÈ›òàþ1†3b¶ì½LDÁÈhš#ÇF¦Ë4R—¥’Éõ/}¡¯!<ýÿ®+±mgN­ 8eú·Ï¼ µð ɪD;xçŸÑÖ­Ûé¥KšxÇß=ÛqgìNq‚¨RJBA÷?´Ÿì”ËV}N~£Î†-Ä×®Q¨½ÇR:0F¡`"Ý“‚&¢*ä0ðß===àÀ³ª[\¯!k!Šð‚ß}iŽž¹|…B¡ÒÀŸno2lÛ! ðÎ÷ßL¾P®&·Íd§²ÙR]…†C>º–6ÓÕÕ<¯Gïóé„‚¾ª¡š¾»öô’Øø6†G§<[ìJü~h$PÿáZt&SšWm/FÈ~ŸN<¬k ]×xÝ =\}åfòùò‚Ô‡ãHÂa[6­@…CÆÈP,š³ys¥*C ¸ø/˜ª¾XgÏUM¡\¶ÎpìhŠ©©"®ë²iý2^öâKêt_£:ÕÎõœ‡B±‚í¸´·Fg¤°zªÛeãúe\ÿÒK)MÊe“ž+6òå/¾Žo|õoBœäjÙ ó/ÿ ÅÊŒkôùtâ± >CÇu%†®±ÿàoyç¢ë*ŽãÅ㱯»¡‡X40Ç^¼ ®Å•k hïSýôö{šnßaš6Îîâc~1K—4’©É"GL02œ£R±gペ/7¡4 8Œçèëbd8‡ëxi)•ŠÅúõËxÕËž…mŸ¸®\ iY]K›¹îêsøõ“Ra”jÕ†³»¸áúË)+H Kb\tá¶_¼v^ÕfmÍ'-ÀZRmJ)ñù4:ZcõÇq‰F¼ñµÏ! žÆ Å ó%#,Ls¹Üqç.ßy ¿ßXÐg Cãàáþù³?ed,]Ï6‘Œ çè=šb|,ßhsiZ#K=1žÇ²NÑ£Ô|Üó«=<ôðA C«Sp‘p€·ÿÝu|õ÷šÌ/Xu9®l¨éÇ£õî¾÷IzôÍM!²Ù¶íR*Y§Tµ€û®éÖëºÆðHšW¾îK¤R¹únBÏ—¹ú9[8px˜ÑÑÌ¢S€¦k°pØr¦K¥i –Õ˜^UÁÔTž‡F3>í„Æ^¶T²˜LˆFýèÆLºSkx× vˆ‚b±B¡P®g2¨Š”>÷…;(•­¡ZMSÏ2>‘›—á©ý–ªNl‚gá95˜qžš¡ò¤”ø;v›‘W}ú¶ùäçò… ¿ÑЮEåü~eN„ímΓ¿XY܈“Hw)å¼;«–ƒ<].rún¦½SåVÔìðéº"Þg‡,•jÐlíPûÌ3!_\Wò±z ©Éšzúir–Ýi}›ÄK7­M¤;Ç*Š7)Wõlª»Bs ¦T2)+u‚¢T2QÕ䂘׮ÛK& Ñu­Ê{4`#!–J&…B¥¾(Ëe/KÃs]$¥²Ùp‘Ôž’Êe³þ!¼ë­ ?_(S*™ BâŽãÖ÷|ðVZ["uLR#VÞøÚ+ ŒÓvß´ÓQcª¢pöæë£R±æT›®+ }Üö“G|sª6]W¹ô’̓ï8J*•ãÚkÎáâ ×22–æ¦ÏýpFÒûÌßpY™hgÆå¬[»„––•ŠEïñqzè ‡ŒÎÈÛ }\véÙC>xð“S.½dçlMÐÕÕL&Sb÷ž^î½o_¿Ü ñ¹RrÙ³Ö³es7K—6‘Ë—xúéA~ý›§(M^ú×Û™JÙ½ç8¹\é¤ûö\)O$î·´D°,§úš·ˆuk:‰F µryæu=gm\Î žÿI6oºˆÿÓ_ãÆØ·ó7}îÔ‹£T2¹ú¹[ùô'¯gíÆuÕ}^@…Oå]ï½…‡>xÂikòÙϼŠÕëW±ýÂwpë¯à]o‘–®jÔ"?™áÖïþ–~è{hšZ%ûO ï÷¼ëÏxÙK¶³dŲª¢ynÿñC¼ç}·òí[>À‘ýxÅ«¿ÈÔT¾žT_›KÓ´ÉæòÄ¢zPÄKš®)$Ùl‰7¼õUbD=-Ó£-D¸¥²‰R¥û\×¥P,óÎ÷ÝÂèXMSçTgù|¿_?¥jqÉèX†x<̵לÃK_¼JÅæîÞÏ‘#£€¯á±m‡%KbEð±}›]{z)—-Z[#¼î5Ïæòçláóÿö®}þ'™œÊÓ²ËÐÝãoßxó7ÏæÎ_ìäž_ކϧñâ¿Þκµ¼ñ WqèÐßú¯ûê¬S¡PáSŸ¼žW¿ârTUð½›ïæwí²žÝ³7¼ùy(Š‚•O‘Í–(ˈY Ó´lV¯lç/ÿìBþçGÓןš38£ª ±hYÕŒgVÀ¥²É%¯£T2Ùýäq ]Ã4î¾w>ŸÞPí:ŽK<䥵{½ÑñÌœõ¸5ôgÙ.~¿ÆË_z)ÇzÇxëÛ¾ÅØXÇqQE¨¡ëûùÙí;øÕ¯ö29•§T2A€c»ôõOð¹h­¬ãÊ+7qÛ®òÝÞdU*7¼ê >õ©ñµoü’|Þ³ÿ?ùÙþó›ofãúe¼ã/àkßü%Á ññ,¯zÅeüù ·!¥äSŸù _úòÝ”Jž½¾ûžÝ9:Ƈ>ø—TL E\Gž„¤+  V%Úñ7Ð|0Ãl\Sº æœdéšJoï8CCSõlG!<>u.¡å ^ñ²gñů¿ƒßø\tM=¥{ãÚ.>ŸŽß¯óî÷ÞÊCd³EŠÅJ½(»‘v)—-R“¹ªª÷ ø‡ý<ùd;wõ.Û/Z[§ô¤ë¥Õøý:;wã+_»§NùéºÊÁƒCüïO£Xªø9gk7¥’I4àù×G<âɽýÜô¯·×ñƒahºÆ¿þçì{jгծ¬.Ê™~©GZ óö÷Ý̱ãc'¥îž ÿÔzTLkaAŠ…ÀøÉ©<™lqÁþŸ®«ìÝ×Oï¾ìØy¬z£r^Xî¸.þ°Ÿ»îÙM_ÿx5Ýgaܶ<ðúk„Ã>š›Ã47G<“ì¸tvÆßåº5àçç¿Ø5i{ÀÆ`×®^J% )¡;ÑN¡Pfýú.Ýmh~o'‰®k3B’®”ø|:?ÿÅuS¶˜¹hR&Sâ•/ý¾È¾ûŠ%ó” d^m;.Š‹Nš }ü*¹U›þpØÊj…w¡qôè¹\yA.À«"li sÅåøó]À%Û×Ѻ´0•)r險5pôÒéB@M%O¥‹8Ž§þü††m;ttÄim€¢òÄGçR>_½v9÷’–rñB`Ú&¿T…Ë.9 ˲Qeñ®­ô Î[Å¡##õ¨Îì57¹! t"?¶ížr5Ÿf JÅ ¶íÌ›ÅXÓfݺNþù×óœk/"3>Á£fðŽŒç¸øâµ\²}Ý¢Ù)Ý×åJI0hà÷ë€`"•«fiȱT´Í©Bªµ Ë:×àJ¢á_úÆݸRòà# ø Êek^–`ÞlÙNÃ:ŽK¡h ûç²ëʆDÃÂ}êá8.­->úá—ðœk·qï]ò…/ÝÉ®]½ŒŽ¥)UÆùÐ^ÇeWniHáÍõk¢Qœ¹êbÕ²3Â!?™LqÑ÷溒HÄO0裯o‚`Ð×PÈŠ"(–L/ý©êÿ˪ xro?¯¿ñë€déÒftMe|"˽jÛàÚîxâ™»·½-Ê žwùu·Ï”§eÞ´i9Ï»îB‡¼ù³)^AKs˜¯áõ¼ã­×±jeGà àeX–¹âÒõ¬J´Ï`°<Íh‰ÅB¬ìngËæ”+ÖÜEsóݘϧÍ÷MmÜEnzæÂïrhšJ"Ñš†š"ôÕ›ùü:Á QÕ™§¿è$`*‡ŒÐ?Â)[Üðê+(*ø|Zy2 B¡Ìó¯;·ÚŒíä©Õt•s¶t“èn#à׸@ ¶í°2ÑÎg>q=wÜönLÓF›ô“õ$ûò𣇠|sιv:7=9•çž{Ÿ$:A@Ôlòó®ÞÊ¢TªüN#?5Ÿ\ššBÓØ4/OyÓ†e\ºý,ì’É3U*º®qìØ?z˜ ¶­æ²KÏæÕ¯¼Œ[ÿûª]†T*ÇûÞûç¬ZÕqo\ó½Çdz<ûº ø8phxÃU{Ÿªª Oñëß>]ï^0ÃL¿×}À™.ZÀ5¾T×µYåÞãß>|JÙZ¼p²ë§Ër8tx3_dýÆeüå_\È-ß½Ûvik‹òñ¼” —Q(TÐ µqÐà”—ãå¹RÒÔæ«_»›Ë.=› ¶­â_?{ÛÎ_ÍÏîØëJ®Ù¥¼ðç³sw/œ¿Ú+£ið½yÆÜìIô®ª*<÷9›)—,~~×NÞóÁï¢(ÃÐêö?ò±fU SY ¾Y°€ky»ëÖ.Áq$ÇûÆÕÒP)[‹ß"‚j½mŸOo8Ù†®z¶Õ¯Õ}í}O pó­¿á5¯îáC½žW½â2²¹2[Ï_ɮǎpË-÷óÒ—lgÅòÖ?¥ˆjd+xR½Pí·EŽø‰DèºÕä½|¾Ìßÿ÷ø—O¿’­[¼æWóš7¾pIñå¯ÜÍCC\²ý,Ï{²®ÂÝj’œ”nÃYÇq¹ã;ÑT…`ÐW§€k žã¸47…¹òŠô¤Î¬€kQ”Ë[øÌÇ_m9¼émÿA&[<#‰ë¶írß}ûÈåJìÙs|Vî“Gð<4Ì÷¾ÿ^IŒD ÈdŠ|êÓÿK:]à‚m«ikb[6_ÿÊÝ|íë÷xdÉôRÑjXïž_î!•ÊqðÐð,åá 2›-ñãÿ}”h$@ïññz¼aèï›à•7|‘¿øó‹XöR|>tºÀcá§wìàíŽí`[ÅB¥ÞPÍqlÛ·^jzÎv­>ùÄokôöó¡ßF<\pŽ¶èé鹯æÈ)%ž›‘{äQo.]Kšø×O¿ Ë´¹ñß&Ÿ/Í™W<Û[H°=`Û¥²y²Š—g-§µB`Y6–å°jU‘°Ÿ\®Äñ¾ /Í(äÃi («í …sâ/9-ÅS̺/Ç‘ärE¤ô’ùJe“`µ¥Ó§>þrÞðú«Hþz×½ðŸio1<2Å÷¿ó÷ì{j€Ï|îv¢s´ejL)—-"‘@½=T#ÿ»Æ;$V6£3JvîÕ:ùŠ ¤yû{¿ƒ[½ÁF*º®ª«m}gçË9ò°š›Â|æ×óÃ?ÂoœÐ¬ rÚwL¿.MSÑuÃGF¼‘t ]×ðùD5wxŽÆ+¤85¾Ì…¡ÒÜ®£ÙPȇ߯3>žãš«Ï!—+qøÈ–ãxé>~ƒ;ïÞÃÀP CWçL˜­1W­lçÂmk¸ù»÷ûg$ .ØÅ[¬­šbd,]OˆŸË†]qÙzÖ®YRxÔzq4Â^^[Á"ÿôÑÿá¡GhmX[½³åu¿)ñ×v—n? MSfÀy]àOöWŬÙh’gζ½xr±hbšN5Ó{ÏÀÀ$ŸøøËhi‰P*™üäg;ˆ„ü^?€ÁÿÞþ?qMSO™é¡(Ëv8oëJþá-Ï£P*ŸVÙÌi¡èSý×TÛàמÇà©ýƒhšJ `ÐÖáð‘цß!%õD¼Å%Š¢P®”ù«?¿£ÇF«“(ê=0ΔKîµ>4ùî-G¥bóý<Èž'û(ä+,]ÚÄ_w%Û·¯CJ¸÷¾}üêWOÒÒ©/ðÅxŽãâ34~ø“Gùþ¢µ9ŠÏåË‹Û“ ±Ás­p¥j› 9Ÿ/cÑH€t¶ÈÀ/<ûycßÓ ³@æ»áFUòÓ'*]@‚H$P§Y»—·pÞ¹«øÕ}{½Xñ´ë+—­*‘sêáUZ8¬Y³„ÏÝt[·¬ ÒáÄ!/’R&ÇØx–_ÿæiþîmß"ö/šª­Ñ»†¡Õë†UÕ+BèhÑÞeÿÁ!f -ÚŸj±I)iŠ‡8wk‚äýOÔXQŠà IDATEASS×uq\¯Bî÷ì&òy͸±`ÖÙu%í1š›B>:J£ê:Ç‘´6GÈzëÇvhmrñ¶5ÜÿÀþº€Ýj9ɳ¶ŸÅ¾ýƒLMåçÜ]5òÆSû÷ñÖ·}‹ç]s7.'ñ£* Óf` Å=¿ÜÃ]w玲-:o®Z @MÞ»R‹X·¶“ý†ê;Õu½üôѱ ƒÃSøªI~ÏHE×6¥Tµ* yâ_°Ç‹ 3Ç Ô.Ðgè¼öÍ_££-ÊøD–ðLäд“‹éTÕ«á­t{ „ÇóÙý¶ë…Ñ5•l®DÅ4 ü´¶Ö’çÄ<‹Ö¥½-J©lU¼c€Ým|øÅ;ß {Ÿ˜ÑóKÓ”9Ó£æ5©‰Dâz¼s¤”E|¶€iJlW0‘–ËP¶À´À•àJY19Þ7 º&PUï¬E¡xE=üæ¹åŠYmÍ+ecS“yž|ªŸt¦¸¨Õ«ª >Ÿ6 +ÂkñðÀC9Ú;vR<¸6™ù|™·¿õ:vîîá-¨ªJ0h êÝï7ˆ„hú©T­JäæoÞˆ¦©<þÄÑz)J>_á‘ÇŽÐ70Ѩzp’ “,âMÙøæØI6X’‹VŒ£Ú6+—©T\ÓŒMJ&2’qÈ$#“’tÎ%† (•A×<õ©kÕƒ-TOðšzd¸ÕC/d]#Èúós±–®ëQugªï‡w&ƒ¦©söºôj——p´wìŒÖ.×Ʀ ËIM枪§>¹Rb[ºÞ8ÅévÐO꿹`ì¸póÝÛáη9.4Eð²«`i³ÎÖu~Ífª(éóS2Ž «dò’1‡þ‹á”CÅrñi¿é‚DUNìpwxÕ wèD±kmÕ6l~·Ny.ßv¾nuµÊú£½£sºƒsúÌ ,(r_ fäµ)B4¼®Ú‚‹FÜø†çòƒ?ÂÄ)¾Íoƒ¥g‡ëqÈi³˜Ê¸ŒMÁƒ{À•.Žk⸂XÖ®¨ )¬X"XÒ¢±~¥N$$Qðk‚D§ÀuÇÇ%Ã)—|IA:S9É‘!]ÆÒ.éœK®$©T¯íH\×[á®ëiוÈúù„5õ7m‘ÔÀbuÁÔz,&²Ø€‰¢x«v!Åo ýn! ò1•. é*K:âU[¼°J‡9AV5yaÆÕ ÈT0´iäàH8ÐkáJÉý»<¡8Nõ»Ü[MÕ- ,k÷Ñ3Ù¸:À•øY×íÇA%¨;øCý:.‚rÅ»SÅ-21Y&ð12V d *¦ÅxÚCºƒ£Še—bÉ¥P˜‡rIR( tEàù èªô8jQk(3›![<7Îy˯Æï×øÂWï&0fº\±ðúŒæ¸^ÎÛ|(^ÓT^{óùçÏþ„L¦È?¼ç;„Ãþ ":\×Å´œ*DÕ²ËF7êI:P¦1EbZ¦'ì² ¥Š``¬¨Ü–Ìã:¹ê‚òºàw¶«´7AG[ˆÕ+tu…YÝa³1!Htéê!":lˆhà–A©àÚ:CC%§,&G³¤ú&]®¤P²yèˆN® ‘+¸‹¥ŠÊä”C± š® )¿Ï‹îb’A¤DÓ”zôi¶ ÎÝšàÀÁ¡zlØ˱ P1­99וT*þØhi‰ ¥¤¥%²(ÊR;µp%ÑH€¥K›9~|œrÅžS5H ÍMa2Ùâ´É‘s„º»âÕ÷ºõ•­­š»æìÍkøÁæ7”ËCø}*í-+—Œ±bE„+. sÍE~¢‘n$Šª†åIÚZ‚t¶åQ·-‡B š"`Yà¨dÓ&ãYÌH’-Èg-&&]Üå/1šÖØu2Y‡HX­ïòÚý¹spé±XÏ}鸮ÇÔ¸×u‰FCüàæ·qÅ5%.‚SS9Þôúç°cç1vì<6'O/„ ­5Z'”Û¹h†›Tà ©‰µs²¹/ûëKøáO?ÂO~ü#£éÆé(UŽõÛ_3ý)ñÒeü¨¡kŒ¥RüêŽø̓Ð5 §jk¥E´6‡Jé„‚*ºî©ë Ø{°Ìowxxw™mg›, —¾Ârq…«ù°Ý–Ã,éØei*ø4qÝ¢£C¥{EÕ+‚lY¯ð¬m®ºTãÊ‹5^z]ˆPS˜ƒGÊTL ˜–kdšl°¸ý~ã¤_/p ÙñÄQzû&ê IUUÎIW3#ç'–NuÒØMšWÀu¿Ñv:>ÌC¢4G¶Fíöìë«ÇYçÔ R¢©:»ŸìãÁ‡VÏ8˜y¦iÓ70Y‘ž¨ÍQ”*ÐŽ £w=èpùvƒµˆÞÑRÁ­TÐâapt„tPt²\%ˆã\)°Ë`Y:¶D‘’@8L4$hk‡k. ðð‡ .=ßÇ*T•Á1*$º¾ðLŽãräØè \Ó&&r”O#û¥¸™.øûÁ å¢ÿP†" d ž}N…›>ÒI[Ô Žæ#¥…ˆb,”Jµ¹kl(ë¢F:¨êGj%Œ¶8åÁqü+[H?ÞKpe_[ B(ØCø•QôxˆÛþ7ÏwïÓyâi1£3ÐïsÌç/ŠÕšf>“!„ ½-zZtÛ|ÈÖ•0$=í㊗§Ðà •L§T@ñÅpMæSQbq¤+Q¢Q¤ì@kÝ„,]1´¶8v¦H`ã6(‡.ëD öSžšBt.í¢"–ð’ןÏŸô3|3ß»)ÆÆõ¾º+wºc¡ IÓTR“y>öO/æ]o{w”Á)ÚF* ÜgÒ7Êë/¡óù›þ†Ë[OÉÕÎå2Ì­ò=×ÇvàÎûm¡0®bàØ6ÒU@A"MP ¡«`™¸ªŠZŽ߀â_…2G ¯EhQ‚>ü±8š Ô@-•(§Èw¬$“’\ºÖá¾ÿéàM×Ç0|:ÓEQ³è½ymo‹Î™?Û›ñûu}ü»÷G=EÆS‚¬ù&{q›Ðë‰üÔÓï_ô.W¼£æÚZ¢ŒMdï׳Í÷<àð®·¶Pœr0‚*vÑ© 4óx?Âè>i¹XS£(ŒcçÇ ”G6“- 0¢(Z NÑE Çq+),TÓBU5ôX[—TR%.»ÀÏ¦Õ ýÃO* (ÞäËù‰UU(+Üø†«1M‹ÞêA!sMOí0ÍÇwãÀ¡aGž&Èj4Š%}‘¼°”’þÔ‚XœF„º¡kõVû Q¤&˜L»|à-¶­.QÉWÐãM`Ú¸å2"?†ÖÞ$Ò’PÌ µtaN•!ЄíÄp²9*éZ8ŽãN !|\éChì‚‹ÑÞŠ3™CæóhQ?BÑØÔYæY—w³jeŒÇw—O[ÄÂJ]›s+‚L¶ÈÐÐTpZ›üúI9ÕgDÀŠðVåÕÏÙLÿÀļ»XQʬ.9^©£8¥*ÎdKõKMà'JXtÀQÀ²$W\æ#¯“ˆ@#Åu ´H;šb „šq-Åœš@ø|hñvìÉ,j|Fl ª¡£–²££Õà¸W`Pz¡æ)§,ôæ8J¼“òp·"`i‚ 3ÎE«S\~… *]î|È!̧EUU0<œ®6QDm6ws XY¸½E¹õ[oeõª%õ u#Ûâ8îŒíB(@EQ˜œ*ð¶7_Ã’%ñƒ×‡Z“äw\AK|±Nl7B¹`€ÚŒS.aZWõaÛ&Š¦¢k9:ŠpuŒ¶Õ¨š7—B D1–¯Dd¨ì½“Jÿo¨Œ=Œ;ùÖÄa„¢£”m”ôª¡¢ˆmÁÂ]tŠÕbv°®2ùÜ—îœÖŸãä/µ,‡çôlâÙ—odÿ¡¡E€*‰¦ªŒŒe˜Hå‘r >CplÐá ׯE‘1œR…b®€ê×ðÇÂŒ?ú°@¨6¶«“;| Ýo£è6B¨îCo‰¡h!,7Â@_v>z|ùÁzË2"«6Pœ(’Ì\ÑŠ4Š+å)CG1Gq­IŠS,ÙÄ9›uVtØìÞï/‚,vÄãAº—·2<šžs!<ã<}5©ª˜s7yl"¼íÆkù—Ï¿ƒU‰öEµÔ4…¡á)lÛY0r¯µÛ­T†ŽÂÉ Ü®o jM0y| T¥a쉃0ð(ñ•ËQÂ]½ô¾' ­½ÛìÀ˜Ãýè«‘¶†]‘¤ŽOhiéX(øðw¯CQšp#‚M×]Jy$‡í†´£7·âÓ'hkÑxÉVÉM78«ÃÁ§¸H)¨Øó«íZSÞüúçò™O\Z ÖO dÍ÷Zí`HÓ´9rà(÷ܻӲÜYJ‡ü¼ú—qðÐÈ)ÄkGÈ…ý’w¾¡“^¦bEÑ„Gú&ËDZÂ(ÅÁµWc—ø–­A’Rïn²c)Â+V£(erýL8J|å:=Hql˜`[ ͉.\"”ûÇ vw“›,n‰’=4ˆ?¢ È,"3Åñ»î'¶¼É)?j¼ i©”óã,UÆxÑÆ2-¡ k;m¢~ÉxFP¶EÃöP³CÞ¿}ðwÞ½›ryn¿w®¬q†‡¨F½oþïßR6-šã¡e.ž°¦^™ÆÙë–bø´j•Ã\D<¨Š@×àœ-Müí+¤².¹Á>JÑ Ë|L Žà¤ãè­ë°Ki¤¢Pœ'uà :V(”&'q‹&V©D¸máöV\ËÁ)¦;|MLbe'zQÊcõ?…31N.´-,±Ši¦ŽMlh]aô%~:Z‚sRZH"¼©&r\«ô2ÑŸ"½L£½yw>iP(–æí@T{%5™?­£r~G# ÐÑ;¥põjºšW¯EÂû>ôߤR¹†½ •jZ0‘¶É]^yMÅìǯO¢)J“#HÕO|Õ:0ZÉ8†ê‹¢ÇZТËq,?–š }ùHe9½OfQ)#ì~ŸÉ®Ûƒ/Å’A´¦e„Z;<š!5­ëÖ£ êl£œ¶°Maøè¾h3é#£¤Žäpd;–/­8ò› Ê•tŸE¹m-•Pˆ­küt´P«Üú©Y,åwÓít‡;;c`Ž‘šÌûOtL­ÚaÛv禅œdi›à#oicåÊV®Þnqð‘ÃH­‰U[ÏAvêCÓ+;ºˆ57ce0üAÆöDMÑV±‚B‰‘t˜¶Iˆ·K¤ªtótmZ]šÂˆµ2yhŒx÷:¶ž…[È`ËLìî§eãZ‚vU+Ò{Ï“V'hY¿ ÍÐ9~×ýøbYVœ+ñEŠLöe˜Ì1–5ɸ}” mŒO‚®Czé”Ñ#:~Ã%Ô¢’9v”¾û¢kŽîÓq‹&#»s æTÂa—`›Aw"ÊÕÛuÞôò0›W¹Üýˆ‹ß€Óö3†¢ÏHô£ú—#%GzǦ‰>wן¡h}’î…k·æ8»%G!oíj%ÚÚJa¬@6'Q´/`h@A ù±-‡¿zñY8ù>îx€ì±Çˆ‡†1ÜAÄØavßñ tEÒ–XI ÇÊæIíÙ‹“—Äb>üáGwô3vdW]JtùYôí6yô¥uËyøÚºpŠvQ%Üf奨¸­ íI#Ãít\´‘5k—SrhB%dUˆéE¾w{|Ã&k YJ¯…ÃB=“ÓÚÁ‹ñ»kg4Ì.æªõŒþUrï¼Ç® Å’Ãs/_É|ú<^så—Ÿ«ñÈ›ö¶0®k09^¢km7•²EkwÒ´± ôXDˆHs;8ŽOsˆ/i"Ø¥iÙrFÇÆFòœsù:TŸÀ̤8úàN,:Ï=Û2(<ð£ß_gåùk°Í)49ÊÀž^Ö\± Ÿ¡àšvܽ—ÖåÅ\Ž_¡8i’Θ¨QŸ_ÅÓЕ<:¶Y"Wiï ³f¥ÃÚeÑ0ì>(0ôùÕ±¦©\|áZü>É©|½9û㢽ÐÖ‚j‹Å;µå×G_ªá…Æ)í‹ß¯òÈý f:¹æ¹›pì"kV·¢*e['•©ÐÒꧥ-Àh_ MQ™Ê¹d3YÚ–6‘ŸÌ"ŒVIoŽEȧÊLôö’/¦hm69Ö7E45Œ-Ut%G9ÛG¬Õ myÅR‘¦`™ô˜K ¹_ÇRŽíK¡¹i Ù,›¶-Ãg„˜*µ35[7Òº¼«((gHfG|´·Ht,RÙ OìNÓ?'ê«Ð;¬ñT¯Ž¡UO,uÔ"¼ÖJ=—mà3¿ž—üåÅ|þ+w ùp÷̨èZ‘×¹ç¬db"wÊ.k5[j[NÕhÐ1vª¦Tr¸d['ÏÞ:AÐ_&‚ÑÁ)Žî#ÞÑƪu Œ` E· 5 ‰jt,iÁ*8²ë+V…ˆ/ д¤…ñÑ»~’Ö¥Vn:›\^gÏ#Gp•&–n>Ÿuçob`ç8NEEÕÂ1Ï7/ZQ„¯©7Ñܵœ¥Ë[ë+£;püKpÃËi :Y*9_$Bß±¾`Ëõ±kw‘ǘ$WÑiK´Ñº´™x[”½ý!tÕkÊÚÚaYWóIO×UŽå—÷íåÖï?€®k§TÕ FÑ^9G…[¿õV.Ú¶šŸÜ¾ƒwðVâñÐœ?âV;«ÞqçNã´8U! R8Ö—%èo"h÷âøÄZû¦°I8¨R(º¸v‘þ£“l\ºŠX“ˆ0ÖÛGkgìŠj128Lvbœå Í­*º6ÉãOŽsî9 â-1*¥1´ Ÿ²]Á×´‹fìJ™\É¢\*ïôƒ9‰YGfY±a)c})\E'Rª¸,]·šƒï$ØÝI¼MÁñ•9º/ϳ^¼„æ'ÞdÝJ‹ýÇMÞùïÙd ^’^6Wæú—\Ê–ÍÝ|ä·aZNý˜]×8v|œýÂÏÉf‹õã€Îˆ öÊMnþæÄb!:ÚcÜôÅŸŸÔí®‘ u];mÂÜu!S¤3pÑÙWl ¡ C­°b¹ÕNqÿ¯÷Ó5iŠYÄÛCR)öí¦½I€´E‚òwo]Í9B†Ck‹Wi_¬øÙ±Óby‡ŽO±1‹e6¥’‰/&36N[wÁ€àø‘AZVœMÓÒ5¸"J´¥‹#;1r¼ŸuÛ6 ¸>Â-Q†çÿó(ëÖÚ, ¦ië iR2Èo ò‰oÃ?}Å¡wH0>å•þ(Š×l¦o`’G;L¾P9É ªªB±T©ŸôvÆÂ…¢*œLå9km'ÿø±ÿáXïøœ‡3ãKÃæU’G¾R᯴¸|s™ŸýèiâmKˆ´t¢è1\£Cû‡h[ÒI´­Ë{ÎQ9úÄ!$mÝíè~]—¬Þ°„Ñá2-«ÎÆß´ dŸOci{Œ#Oõ³æâͨšƒƒBKgœ÷ìféêNüäÈOæ(5²ã9ÆGG‰G|8f…þýÇQD™Î•-äÒi„[$_´)ö±jó ÈI¬´K¾(?4I®,ÊS*8 å|LfäŒQë?½ž¹QØvö†yÆ®ÕëìØy”ûÂ/8Þ?¡k3Ž£Ó4•ÍW0:–yFBµ/€oè ÏÚäðœ‹#˜¢W‹³dÝp%{ÞKâì”rYV¬îâéÇ÷ÓÞêCS-tŸÊY¬áÐÞaïéeÅÊ(®£à:.þ€Aïþ!ZºV ù£Xn_À¡2ÚKÇŠÌBžÂd«"¡lÒ½mé)ØG÷ª‡ŸzŠÕ ¿Q$à/{…qV‰¦á ÀÐB é‘+7tcëÁÖ Z´™;DKWÝ«[Ù²9Ä^D8‚Ã}.‘‚eKlûôß8c(Z×5Âa¿W&§“‚Î%1þùc/ç—÷î¥P,/˜ƒ.–½UÇ…XHpÅù~®º0Àó/ °y}g¯Ž36VF wò¤óº×¯el¼Èž„t…Õë—ãH ³¢22˜f¤w­¬¢{íRTÕÇѽ½ÙwŒp<βÕí|pÿ2ôôn–µ 5GPqúóãŸdÍ–Í4¯[Kv|ŒGï{«" fY¿©ï~{?‰ ë°ˆÒÔ&ÒÜÂ}·ï"ÞAÑu]¡{}·þç>L©°dYaZ¬Z×ÂØh»nÛ‡j%• ±4nò¶×®fí2É‘A—ó¤zå†À³lbLëý;O›­ù››ÂL¤r :»¬/Ù¢³®['œ³VgeW™–xŒ¦¸©hŒLJöcåò&:[|hªM:cqÏ}¬IÄÙ~n;¶i²c×c%V'üt6«¾ ÅB)m¦&+ gü´¶Gik €ªòÔÓ)tÍ$34Âù-£¥½‰á‘ Y[åéÇŽ²þÂsñ tE²Çaš› ûìv&†2´.‰rxÿ$ÇöNrÍK/"U(ÓÖä§ïPŠRzKž»’©)Ë´hoSøÅ­ûÙrŽkÃØT™¶&3] ‚Ÿ¯>|·Ý~Wñ/¨AKÅ´yÓë®â‹_»‹pµÑË3j£´ÐX®¢(L¤ò§®RMÃU Båï_¢±ª«„Ϥr~zïçmRXð „" ‡$ù©1­¾C‡S$–ª¬éRybçq|‘&Œhˆf]E‹†Ø}`Œx\!ÖÈ™ E[G¨&ËÚU\acæÓ\º­‰;~5@…£…0©>¤‚S*Ò¾¤ŽÖ8º01ü·ý ¥{uœîUíK6Ë£”iZ;¢þ(ñvM•ìx`€@SŒ%KC¤Ó¦„NNpŠ–¯ 32T¡ì_J*×ÁïDh~KžZ=WòÏxòTY2gÍ>a»VÆYûWž*.–Ʀ$ï~I‘õ]ˆJš\:E6=…ªÁÚD„xÄ%4‰hyÎ]çã‘]#¸å,KÂ6¬°}sŒGŸâа¤£ÝÏYk;ؼ¡“üd–±‰4ŸWúøì-&R%R§q ôI)ÂúïÛÂïÓ6Á9Tå©çªªõ¹rZ{{]‡M+]^zM/¿Ö༳rí-1–†î%MŒä–´Ç±¦2Ó9HÓ¾j %e -­m¬]³ŒFZ%ô@¬$Ú¢3jóÓÛŸöz,ã¬9;?! Jnúæ^6tkœ¿!L<æ§%`3zµ‹ÚZµJÕº‚,‚?–I[B²N˜Ì¾9s¶ßöýÞ?ΙxZÛ¢xý=ÏVÇ:Y‡ÌP©G'¤+¹ç»†ŸÜ¿ƒ”gíºïÎÕAÎxšß¬èKbE_Î`ë³_¼}šOüÖRºs6㳂Z­i(VþîÖ#\~ázN9¡·NÇ’r ð,Á=›÷196ÎMo:Û6ƒ*ž Ÿøú!^»a'¬í‡¨B‹ Éx&·ß7ȳ‡K¼çÆ3p-Hg\Ûààþi¾vÇNÞõ–³H¥\¢ZD&Q¢ù§ÞÌ)§ösþºN´4ð\›Ã£Uî¼{7½s# 1žk ¢Kº|øS÷ñ†MKÙtþJâ8ÃÀ2$÷Oðùoíä¿¿ó4²¦f¢T!ˆb²))Mî½ÿ0íâ­—ub‰m ¤4I´¦jŒTŠéÑ"O>5EÙêç+w)¢X¿Lž¸®xÛÚ<-i=V‚ïd­\ÝÁäd‰Ùé •JÔIÏј»vS M‚šà¼ÓŸú ¦#mãÊ´>y.IDATØ6µ(ä³?Åu4o9¯%m½acceö*±eOåHN]™¦TJxóݬZ²}Û“¸®C¶Åâñ½3<7\¢«'Íï¿s‡'ªôg Ò¶Ëc»§Y±$Ëź82Y¢³Ýf¾$‚(Vœ}jóóÜ6‡âÌ–e°}Ï(=}9:Ò’$*bY&å‚æΟa¼*9uU;…Š¢TèÈFÜùÀaÊXR£BE©(ˆDZ1S†©Šfÿqjµ„´gÐÚbqÛýCËÏI84b6–×BYhK0TŒX²Èaãé­LÍi ÀvÒ¸–F EP Y–5Ù¸ÂåÁ¾:u»yœEZ-ìb´Èu¤éìLQßÑô¼Û MÀ](” ¾æ]$‰¦»»…l›ÇÌT™éé aP/ø E¥4Ç;.U¤=Òðæ mNÌ]Y²¨•§—I»š\Þ ‰d¦aŠ„SWØ<~8¤¯Ëá’sºhëLÑî*vìæáÇ‘$š×œ´ˆþÞ4m꥘®qëæa–õçXj§q Ŧ³=Ö­.rû½{X·n1ƒ–Œm ®yý ¾ø¯»yv°À o\ƒe*l3`h¢ÀX¡Êôd'­-Ùtă óà#üïºE&Ž’R5¡6'›*0WÌÍΡ“˜H›( ŒcÖ,ñHYŠáñQÓÞž¢PÑœwV/c…€Ï|mËz a`èL›A,\<3dj^ðÇŸá¤þ K{\ Y&6<æ ó€çšÕ ûÆëVÂà(”ªÇ¦_Žcê\GJt´§´ãZ¢i7•bê[:ZLàä憚Ž…ÀJ…eôöµÒšõ˜©0>Zdýº6–÷âW§HbºKý‹[fÉeà¬LN8Ç"—qèt߸†=GBÞñún„i2Ð#YÝçâyŠ°\æÏ¿5ͯYh¯qÆ"“t‹ÃXÙâÎÏÔTM™®vƒN§B2SBÛ‚¡iƒ½Ã%ªqĵvjh6ï›fÇs%^f/8&#Ó!{ÖxxwSVº\tŽGu¦B%d³Oî©1]¬qÓo¬d ;®w0vJp?Ų>‡«.î-¤.R¦`ïÎ åB•Õë=6œ Ib“V[‘ö,bi0•2¹åþ ³UƒM×uБ¶‰´I5TJ&q¨0=¥ZY·:ä-•xߧ%ÛŸmdå…RÐÕ¡½=%Ri­µX˜î×V4À}ø°Èçóà*às@;5@ ä:I4¶ yÏ•9w„¿¼e†—Ú¬XœFZ.“s ¯;Õbn®LD´µ¤˜“~º¯Æ¹Ëú[5årÝ&uæL‚Xpû£%ÞpîÎ<­»>˜„R9ä›wícõ@;OÎ"u„%†—åéCsÜzïN®:ߣ«UD BhÒ¶…ð—·ŒsÃ×Ò×f’²5J[D‰Ò wo=¡‘ mè Í“tgM*1Tç"nùÉ$7^½ž®Î,ZÅDÊ`~¾Ä#ÛàÉ€Mgg)WO=[&—2©(ƒáéúdøR$q-Í¡ƒs á¼eP,T¥g D¤H§-¦ [÷l\×ÎÕõR(E(!éj5PqBÊŠñ<Û‘ÌÍ…ÄdyÛŸN³cP’²bRi‡¾ÅYR)ëØpݤgßîò}îyÚ=ŸÏ·>Øä—‰ç(`i{‘óÖLñ– ;ãzš+ c¾ñà,Ós5n~ãJ²i¥b%±LƒOÞ²‹´ò»—wá9’R¨)a3:¥øÖF¹âœ “¹P‘v%YÏfv>bײ20 “;™¦³ED!¹”ah<[P ß¹¿ÈÛ¯^Ái«[Ða•8P[dR6÷?2Â?Ü9̼­›–f0…ãZ’}œü¹+Èo Ñ&H‰k›lÞ6Èg¿ô$õ>‡6¯¾ï×;ülÁßÞÑÓiqÃ…YŠ…¤N#ÆfŸ¼e–/IsÆ—Z ‘â(fb6æö‡ú<ÎÝØA¡!„f:É0?[fp°Ä®½%Ö-3Øxö †f<Ø2N‹§¹ggÙ6ï¸Ôx!Ü|ø3`Þ÷}òùüÏòÁù|^Uß÷?”Ïçÿø2p&`7S!˜Ìr¤ÐÊîç†isg9u¥Åc+ M%üÖe‹+ÔÇ)XÚÓ§¾{˜žLÈ»/ë¢iÂ0ÁšûfÙ¼WóG7.¢Ý«Ï˜’OD|÷¡iÞqyÙ“­QJð»W÷ðÙoOàfÝiŠ`¼¤yv°LWΠP¨ñÈS!$Ôê†kl6bßhÀo_Þ…©àÙ½ṡõ‡³±dÕòVR¢ÄÝ?zœÎv—ƒCótu¶òãgæié5™š ›ô´[ •jLµ¦yvRóö‹MF&ëSï ‘öly&dq·$ZŠB1Â3´" $LÔ4o9«ƒnƒ¾ÖÓ¶0Œ­möô´28TâÒ Z9qYÈúZ ×Jóùeɶ‰— V= Üäûþ¾|>ÿ³¸ Ò™Ïçñ}h H|ßWù|þíÀŸk›TA-iM¤,N¨ð¶ã¬ë¯rÇÖ ·o«ñþ+3 t”kÓÐ$šHؾ7bY¯G6Uo™¯ÔMF«k³¸Ëdq§ËDYpûö—®w1 éí²‘†Ãàp•ýGŠ\pjŽR9fh¤Œa´eLLCS©%HÛ¢¯¯ÙBÌWodlªÊŸß¼‚5Kê‹.õµìµ ÁuM0 ­+\¼i1hb¶€DðáÏï§3gsU~)®¡™**Bé"mÉøx‰[oÛÅkm–zØÄ”c“±‰'¬îV,îõ°\5?ËŠ9:Ü|m/–TDA‚PµXbéˆíOì+qý¦ ±ðø½]ìJÑ–JhÚᢚ"»€ÿíûþ×òù< Û{t¢‹ïû«¢iˆ¶,ß÷Ã|>o7±›€ÅÍ¿Äšr ÁÙ˧Ø58̇¯ ´$J’Mi¦Ëš¡é#šó×åH»’0ÒdS’Í»*LÍk.9«ƒþNƒXÕ‡‹X-’Âx[7O…’sÖgðlˆcMbZÈ$àû÷O ¿yE?+<¦'˵@1WÜ7ÉþÑ'¯LsÒ²Q¨Èx’(ÌWcµ›XŽT þŽ*7_ÕÇþÑÇHSàš&[öøÁƒ“|â½+Èè*´hÏ¥‘N 'Üþã#ÌWËÜø¦Nj…ì:Pá»÷ÎQM ®½¬ÓOëÂI¥øö÷°õ‰QÞzårVŸÔM[¸2âßÛÅÐh‰k/_†0]¶ïŽ¸g+œi'í‚c)âDÐðæ‚™‡€[€Oú¾_Éçóù¾¯^¬3ây 7‡2}ßOŸŸ¼øoM´ÊªOé×TB“ŽLÀ@÷œ8ÚÅ?ÞÑ’1è±h‡r(1 ƒ®VÍ}O•Ù¶·Æ_× B°¨ÕÕ A ¹k{-$ﺴ‹É¢&cƒNZ+îøé …rÌÆuYVö· µA:íN™ŒùÌ×qÂ2—/ë`x¸ˆ—v0 ‹8N¸åG“\znk–z”C¡zÚm~ðÀŸ+ðæ‹Ú¨*×0š‹Ù3Rcf^Ó‘M±¨­žS¶,ÇPìØ7G{Ö&eÂDh<1>§Y¾8ͦÓÛ q “/ÿh,ÁG?°¨£Â*iGð¹ÞÏÚn:‘où‚ûŸŒÌ8f‚ª÷7Óü-ðEß÷w6piÆè¨&~Q€_DšECeK`cCm_ѸUª4JÕÇ-íèËÎðºµÎ?1M:cÿlÕ}òÍŸynZó– Rô¶ÙD€Žk ÓÅ„~k–E].¿ui¦©cÂP#Q÷ý NYÆ1)Wòš5CSG&c–ö¹ÜûXÂÎC1«û¡ÍƒlFbZšCCŠTÚ¤¿×ehZãHÍ‘Ä\Ìþ‘4R$Øf½¢¥q&²ÁžF`é³¾ï×Ô4nÍÏìàZ.p±†Ú¾¹!Ñâ(­¡´&V&‹sŠ««\³a–¶t‘ÇvÃØœà’sZèî¶Á„è @x[žN¸ëÉy.;Å¡'g€NêCÆ…b>Hp\ƒ>RedFñÛ¥™¯iÒ®Dš’ÙRÂöý!ŽkÒÓæÔ=þD±~¹ÉîÃJYBrÇ£,3â´MO«Äu5}Y‰eÁ\5¢Pr¸í§1Ëû Î>Aá˜×Ó”k#Ó ¦•ðÈÞ;‡»ID'µÀĶÔBíšjH¥ À§€¯ú¾¿÷ßB{^q€ÃŸEpÝìõ GìÚÆ‹éÐÄ âD°¸=¢Óç”ÞaÖ¤èïs98¦ è]$ɦ ÙzPñGפXÕcb»hI%Äq„mhnÛVã¡}ï¿4MG¦.Ž¬ÛyE]%ÚRsÛã!ß~4æ}ohç´˜)Ö;bâX‘¦VKøîCsTÁúIÖ“d¬„‡`ªªYÒ¥XÙ[/HÛM›ÌUbàï€×éfZeHÖõˆØ›6L³éÄ)‚  £Íel"áïî,rÉ6ýYA*c°j±ƒŽ#’0 Xƒ¸'dM¿ÃMJæiYX”KU2i›j˜ð™[+¤2o;ßAª€=£Š±bÌ|b3†˜ˆÑ¢¦PH0´Ä±5#¥„®,ÏIªóŠP»<3ÑÅtuQ"0ú¬æ U Ü ¼×÷ýɆ-Оÿl‰}Å>Øͼî àÕ$Ïó,¥Ð”ƒÎ–+:Fèm)âR&”’Õ=6ó¡"ŽÁ2-n}œÒà$ì~.áÊ ím&†a‘rLl“N $G•ï˜ãÎ}”¢ ¦ˆåÁ/H <Р=w/Ðß÷ãWØWà— U¢‘Äx/pJ³3"¥&I$±’´{Ó\¹aŒ«Ïœ¡T”+’J3óš©"ܹfç4ox­A)zÓ ¤ƒeDQ‚’ÄpÏS1zZ-IÎ3èj5ê*»Ç`dN±²×¡·Çå±g*ܵe–?¼Þ$í&Hà©Á÷?ÛÍÃû;° …G¥¶9nü4ð÷À?6µšÌWØ_ˆ¿ ­Z ¼£Q‘à4Ó*ÄÊÀ³BN^Rà’“Ðß>O%²˜*Â=Ûàà°æ¢³g®Jhu®„Q]œæB80.Ù²[²wHsÂbƒ“WHÚÒÇÔ˜fæåªUÍÎ!0µ ©%ä7H®Üóìp†>µ˜Çç(ÕL<;9Ö¾:@µQóMß÷hO#Ä/âü‚žc<ÇæDÆêÈ76O-P ¥ë›Óré€U]S¬í~Žý㊭{%'.Ö\»)¡P!5ž Q Ž)YÑ+ù‹oÂļÁ’nÁ».©×J¥ƒ0’”#ÅÞ±È0H‚§÷×ضÖ.±¸úì­ƒlÙßE¡Z§=†Ð ŽT³Ô~½áDímªÑÿUÞñ/=À/•ix™ç_i´Õ4äѵn‚¨vˆ$š¢-c M”À@ºÛCÓæÁž!“jv*ƒK‰®vÁL±N›º²&Ý9“D%hÃ$#ž9hêAÜÁT­ŸXÙõÎ ñÏXû€wù¾ÿÓ¹¼ü¢¤÷ðKðfÙ8•Ïç?ü9}a¶JDë–9}ÅaúZb–-6™˜Ô‚Ûöű`xBs`HaXš®vI§db6!Œ T•$Ð -)ƒP9”£eDd16ö8Ô§|Ô÷ýO7¤Uþ"Uñ/=À/“­ÊÿxÐòüú0M 4‚Î⵫gYÔP3Õ„Ñyŗ©$œ{²Éu] dcì©&ÑPª%´Øðµ÷>ÑN.·´Ñ¤j¡šiÏ,pðß÷gAœð•¢=¯z€£ºMß÷ãÆçùFîùŠ&oÛ¨£×*&ý¹*Wœ6ÉÒì$3âo~¬Ø=¦8}•Áϲh•¦ ®#I;‚ Š"‡Í{[Ør°‡é²‡$jTTˆFéQÚsðW¾ï?и€Æ+M{~%>àÍÒ,€÷7ìôÑš¥zÖHR‹ýmsxrœÑ®#H»=)ƒ¹Š¦X…®¬"ãŠú@ðZ7»†[°M!ÕÑj°Ÿñ}ÿ–¦4^òóæh ðKØæ&ZÕ \|hmÐ*SP׿Qb T„k8eé'tÍaš6ÏMkƦCöŒä(ÇK°í6 ÃÄ1Uó¾é….r#ömß÷Ç›“ÿ‘í¯~yZÕ ú’­zwsîyáõ„SÆôç&YÒv“Ñâ':A5}l¶G6¾¾| nò ô/; ¯Z€$96‘qðU`ϯ’hz´ŠÒå8)GêÉíyêE´¯&_U¿„ê6Á’8ŸÏÿõBµîcßO,¤ï~F{š½ã‘íùBã" mðªPÅ¿r¿­Zˆo{Ô+%Þ äx!˜Í>Ü ü¡ïûs/Õ%ðk€ùhÕÙÀÿ®o|/j» ßixÇ6œ'Ùô³¯Z©ý•øE¤y£JàJàCÀÂMxøkß÷o}µÑžÿ¯~ZÕI½£øß÷ËM[¿Úmí‹=ÿ/á*k=IEND®B`‚rlang/man/figures/lifecycle-archived.svg0000644000176200001440000000170714127057575020061 0ustar liggesusers lifecyclelifecyclearchivedarchived rlang/man/figures/lifecycle-defunct.svg0000644000176200001440000000170414127057575017721 0ustar liggesuserslifecyclelifecycledefunctdefunct rlang/man/figures/lifecycle-soft-deprecated.svg0000644000176200001440000000172614127057575021346 0ustar liggesuserslifecyclelifecyclesoft-deprecatedsoft-deprecated rlang/man/figures/lifecycle-maturing.svg0000644000176200001440000000170614127057575020121 0ustar liggesuserslifecyclelifecyclematuringmaturing rlang/man/figures/lifecycle-retired.svg0000644000176200001440000000170514127057575017730 0ustar liggesusers lifecyclelifecycleretiredretired rlang/man/rlib_trace_spec.Rd0000644000176200001440000000355014375670676015567 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/trace.R \name{rlib_trace_spec} \alias{rlib_trace_spec} \title{Backtrace specification} \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} } \section{Structure}{ An r-lib backtrace is a data frame that contains the following columns: \itemize{ \item \code{call}: List of calls. These may carry \code{srcref} objects. \item \code{visible}: Logical vector. If \code{FALSE}, the corresponding call will be hidden from simplified backtraces. \item \code{parent}: Integer vector of parent references (see \code{\link[=sys.parents]{sys.parents()}}) as row numbers. 0 is global. \item \code{namespace}: Character vector of namespaces. \code{NA} for global or no namespace \item \code{scope}: Character vector of strings taking values \code{"::"}, \code{":::"}, \code{"global"}, or \code{"local"}. } A backtrace data frame may contain extra columns. If you add additional columns, make sure to prefix their names with the name of your package or organisation to avoid potential conflicts with future extensions of this spec, e.g. \code{"mypkg_column"}. } \section{Operations}{ \itemize{ \item \strong{Length}. The length of the backtrace is the number of rows of the underlying data. \item \strong{Concatenation}. Performed by row-binding two backtraces. The \code{parent} column of the RHS is shifted by \code{nrow(LHS)} so that the last call of the LHS takes place of the global frame of the RHS. \item \strong{Subsetting}. Performed by slicing the backtrace. After the data frame is sliced, the \code{parent} column is adjusted to the new row indices. Any \code{parent} value that no longer exists in the sliced backtrace is set to 0 (the global frame). } } \keyword{internal} rlang/man/duplicate.Rd0000644000176200001440000000140314375670676014414 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/obj.R \name{duplicate} \alias{duplicate} \title{Duplicate an R object} \usage{ duplicate(x, shallow = FALSE) } \arguments{ \item{x}{An R object. Uncopyable objects like symbols and environments are returned as is (just like with \verb{<-}).} \item{shallow}{Recursive data structures like lists, calls and pairlists are duplicated in full by default. A shallow copy only duplicates the top-level data structure.} } \description{ \code{duplicate()} is an interface to the C-level \code{duplicate()} and \code{shallow_duplicate()} functions. It is mostly meant for users of the C API of R, e.g. for debugging, experimenting, or prototyping C code in R. } \seealso{ pairlist } \keyword{internal} rlang/man/env_clone.Rd0000644000176200001440000000276214375670676014423 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/env.R \name{env_clone} \alias{env_clone} \alias{env_coalesce} \title{Clone or coalesce an environment} \usage{ env_clone(env, parent = env_parent(env)) env_coalesce(env, from) } \arguments{ \item{env}{An environment.} \item{parent}{The parent of the cloned environment.} \item{from}{Environment to copy bindings from.} } \description{ \itemize{ \item \code{env_clone()} creates a new environment containing exactly the same bindings as the input, optionally with a new parent. \item \code{env_coalesce()} copies binding from the RHS environment into the LHS. If the RHS already contains bindings with the same name as in the LHS, those are kept as is. } Both these functions preserve active bindings and promises (the latter are only preserved on R >= 4.0.0). } \examples{ # A clone initially contains the same bindings as the original # environment env <- env(a = 1, b = 2) clone <- env_clone(env) env_print(clone) env_print(env) # But it can acquire new bindings or change existing ones without # impacting the original environment env_bind(clone, a = "foo", c = 3) env_print(clone) env_print(env) # `env_coalesce()` copies bindings from one environment to another lhs <- env(a = 1) rhs <- env(a = "a", b = "b", c = "c") env_coalesce(lhs, rhs) env_print(lhs) # To copy all the bindings from `rhs` into `lhs`, first delete the # conflicting bindings from `rhs` env_unbind(lhs, env_names(rhs)) env_coalesce(lhs, rhs) env_print(lhs) } rlang/man/ns_registry_env.Rd0000644000176200001440000000070014375670676015661 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/env-special.R \name{ns_registry_env} \alias{ns_registry_env} \title{Return the namespace registry env} \usage{ ns_registry_env() } \description{ Note that the namespace registry does not behave like a normal environment because the parent is \code{NULL} instead of the empty environment. This is exported for expert usage in development tools only. } \keyword{internal} rlang/man/cnd_type.Rd0000644000176200001440000000100514127057575014235 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cnd.R \name{cnd_type} \alias{cnd_type} \title{What type is a condition?} \usage{ cnd_type(cnd) } \arguments{ \item{cnd}{A condition object.} } \value{ A string, either \code{"condition"}, \code{"message"}, \code{"warning"}, \code{"error"} or \code{"interrupt"}. } \description{ Use \code{cnd_type()} to check what type a condition is. } \examples{ cnd_type(catch_cnd(abort("Abort!"))) cnd_type(catch_cnd(interrupt())) } \keyword{internal} rlang/man/abort.Rd0000644000176200001440000003310714626342040013533 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cnd-abort.R, R/cnd-signal.R \name{abort} \alias{abort} \alias{warn} \alias{inform} \alias{signal} \alias{reset_warning_verbosity} \alias{reset_message_verbosity} \title{Signal an error, warning, or message} \usage{ abort( message = NULL, class = NULL, ..., call, body = NULL, footer = NULL, trace = NULL, parent = NULL, use_cli_format = NULL, .inherit = TRUE, .internal = FALSE, .file = NULL, .frame = caller_env(), .trace_bottom = NULL, .subclass = deprecated() ) warn( message = NULL, class = NULL, ..., body = NULL, footer = NULL, parent = NULL, use_cli_format = NULL, .inherit = NULL, .frequency = c("always", "regularly", "once"), .frequency_id = NULL, .subclass = deprecated() ) inform( message = NULL, class = NULL, ..., body = NULL, footer = NULL, parent = NULL, use_cli_format = NULL, .inherit = NULL, .file = NULL, .frequency = c("always", "regularly", "once"), .frequency_id = NULL, .subclass = deprecated() ) signal(message = "", class, ..., .subclass = deprecated()) reset_warning_verbosity(id) reset_message_verbosity(id) } \arguments{ \item{message}{The message to display, formatted as a \strong{bulleted list}. The first element is displayed as an \emph{alert} bullet prefixed with \code{!} by default. Elements named \code{"*"}, \code{"i"}, \code{"v"}, \code{"x"}, and \code{"!"} are formatted as regular, info, success, failure, and error bullets respectively. See \ifelse{html}{\link[=topic-condition-formatting]{Formatting messages with cli}}{\link[=topic-condition-formatting]{Formatting messages with cli}} for more about bulleted messaging. If a message is not supplied, it is expected that the message is generated \strong{lazily} through \code{\link[=cnd_header]{cnd_header()}} and \code{\link[=cnd_body]{cnd_body()}} methods. In that case, \code{class} must be supplied. Only \code{inform()} allows empty messages as it is occasionally useful to build user output incrementally. If a function, it is stored in the \code{header} field of the error condition. This acts as a \code{\link[=cnd_header]{cnd_header()}} method that is invoked lazily when the error message is displayed.} \item{class}{Subclass of the condition.} \item{...}{Additional data to be stored in the condition object. If you supply condition fields, you should usually provide a \code{class} argument. You may consider prefixing condition fields with the name of your package or organisation to prevent name collisions.} \item{call}{The execution environment of a currently running function, e.g. \code{call = caller_env()}. The corresponding function call is retrieved and mentioned in error messages as the source of the error. You only need to supply \code{call} when throwing a condition from a helper function which wouldn't be relevant to mention in the message. Can also be \code{NULL} or a \link[=topic-defuse]{defused function call} to respectively not display any call or hard-code a code to display. For more information about error calls, see \ifelse{html}{\link[=topic-error-call]{Including function calls in error messages}}{\link[=topic-error-call]{Including function calls in error messages}}.} \item{body, footer}{Additional bullets.} \item{trace}{A \code{trace} object created by \code{\link[=trace_back]{trace_back()}}.} \item{parent}{Supply \code{parent} when you rethrow an error from a condition handler (e.g. with \code{\link[=try_fetch]{try_fetch()}}). \itemize{ \item If \code{parent} is a condition object, a \emph{chained error} is created, which is useful when you want to enhance an error with more details, while still retaining the original information. \item If \code{parent} is \code{NA}, it indicates an unchained rethrow, which is useful when you want to take ownership over an error and rethrow it with a custom message that better fits the surrounding context. Technically, supplying \code{NA} lets \code{abort()} know it is called from a condition handler. This helps it create simpler backtraces where the condition handling context is hidden by default. } For more information about error calls, see \ifelse{html}{\link[=topic-error-chaining]{Including contextual information with error chains}}{\link[=topic-error-chaining]{Including contextual information with error chains}}.} \item{use_cli_format}{Whether to format \code{message} lazily using \href{https://cli.r-lib.org/}{cli} if available. This results in prettier and more accurate formatting of messages. See \code{\link[=local_use_cli]{local_use_cli()}} to set this condition field by default in your package namespace. If set to \code{TRUE}, \code{message} should be a character vector of individual and unformatted lines. Any newline character \code{"\\\\n"} already present in \code{message} is reformatted by cli's paragraph formatter. See \ifelse{html}{\link[=topic-condition-formatting]{Formatting messages with cli}}{\link[=topic-condition-formatting]{Formatting messages with cli}}.} \item{.inherit}{Whether the condition inherits from \code{parent} according to \code{\link[=cnd_inherits]{cnd_inherits()}} and \code{\link[=try_fetch]{try_fetch()}}. By default, parent conditions of higher severity are not inherited. For instance an error chained to a warning is not inherited to avoid unexpectedly catching an error downgraded to a warning.} \item{.internal}{If \code{TRUE}, a footer bullet is added to \code{message} to let the user know that the error is internal and that they should report it to the package authors. This argument is incompatible with \code{footer}.} \item{.file}{A connection or a string specifying where to print the message. The default depends on the context, see the \code{stdout} vs \code{stderr} section.} \item{.frame}{The throwing context. Used as default for \code{.trace_bottom}, and to determine the internal package to mention in internal errors when \code{.internal} is \code{TRUE}.} \item{.trace_bottom}{Used in the display of simplified backtraces as the last relevant call frame to show. This way, the irrelevant parts of backtraces corresponding to condition handling (\code{\link[=tryCatch]{tryCatch()}}, \code{\link[=try_fetch]{try_fetch()}}, \code{abort()}, etc.) are hidden by default. Defaults to \code{call} if it is an environment, or \code{.frame} otherwise. Without effect if \code{trace} is supplied.} \item{.subclass}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} This argument was renamed to \code{class} in rlang 0.4.2 for consistency with our conventions for class constructors documented in \url{https://adv-r.hadley.nz/s3.html#s3-subclassing}.} \item{.frequency}{How frequently should the warning or message be displayed? By default (\code{"always"}) it is displayed at each time. If \code{"regularly"}, it is displayed once every 8 hours. If \code{"once"}, it is displayed once per session.} \item{.frequency_id}{A unique identifier for the warning or message. This is used when \code{.frequency} is supplied to recognise recurring conditions. This argument must be supplied if \code{.frequency} is not set to \code{"always"}.} \item{id}{The identifying string of the condition that was supplied as \code{.frequency_id} to \code{warn()} or \code{inform()}.} } \description{ These functions are equivalent to base functions \code{\link[base:stop]{base::stop()}}, \code{\link[base:warning]{base::warning()}}, and \code{\link[base:message]{base::message()}}. They signal a condition (an error, warning, or message respectively) and make it easy to supply condition metadata: \itemize{ \item Supply \code{class} to create a classed condition that can be caught or handled selectively, allowing for finer-grained error handling. \item Supply metadata with named \code{...} arguments. This data is stored in the condition object and can be examined by handlers. \item Supply \code{call} to inform users about which function the error occurred in. \item Supply another condition as \code{parent} to create a \link[=topic-error-chaining]{chained condition}. } Certain components of condition messages are formatted with unicode symbols and terminal colours by default. These aspects can be customised, see \ifelse{html}{\link[=topic-condition-customisation]{Customising condition messages}}{\link[=topic-condition-customisation]{Customising condition messages}}. } \details{ \itemize{ \item \code{abort()} throws subclassed errors, see \code{\link[=rlang_error]{"rlang_error"}}. \item \code{warn()} temporarily set the \code{warning.length} global option to the maximum value (8170), unless that option has been changed from the default value. The default limit (1000 characters) is especially easy to hit when the message contains a lot of ANSI escapes, as created by the crayon or cli packages } } \section{Error prefix}{ As with \code{\link[base:stop]{base::stop()}}, errors thrown with \code{abort()} are prefixed with \code{"Error: "}. Calls and source references are included in the prefix, e.g. \verb{"Error in }my_function()\verb{ at myfile.R:1:2:"}. There are a few cosmetic differences: \itemize{ \item The call is stripped from its arguments to keep it simple. It is then formatted using the \href{https://cli.r-lib.org/}{cli package} if available. \item A line break between the prefix and the message when the former is too long. When a source location is included, a line break is always inserted. } If your throwing code is highly structured, you may have to explicitly inform \code{abort()} about the relevant user-facing call to include in the prefix. Internal helpers are rarely relevant to end users. See the \code{call} argument of \code{abort()}. } \section{Backtrace}{ \code{abort()} saves a backtrace in the \code{trace} component of the error condition. You can print a simplified backtrace of the last error by calling \code{\link[=last_error]{last_error()}} and a full backtrace with \code{summary(last_error())}. Learn how to control what is displayed when an error is thrown with \code{\link{rlang_backtrace_on_error}}. } \section{Muffling and silencing conditions}{ Signalling a condition with \code{inform()} or \code{warn()} displays a message in the console. These messages can be muffled as usual with \code{\link[base:message]{base::suppressMessages()}} or \code{\link[base:warning]{base::suppressWarnings()}}. \code{inform()} and \code{warn()} messages can also be silenced with the global options \code{rlib_message_verbosity} and \code{rlib_warning_verbosity}. These options take the values: \itemize{ \item \code{"default"}: Verbose unless the \code{.frequency} argument is supplied. \item \code{"verbose"}: Always verbose. \item \code{"quiet"}: Always quiet. } When set to quiet, the message is not displayed and the condition is not signalled. } \section{\code{stdout} and \code{stderr}}{ By default, \code{abort()} and \code{inform()} print to standard output in interactive sessions. This allows rlang to be in control of the appearance of messages in IDEs like RStudio. There are two situations where messages are streamed to \code{stderr}: \itemize{ \item In non-interactive sessions, messages are streamed to standard error so that R scripts can easily filter them out from normal output by redirecting \code{stderr}. \item If a sink is active (either on output or on messages) messages are always streamd to \code{stderr}. } These exceptions ensure consistency of behaviour in interactive and non-interactive sessions, and when sinks are active. } \examples{ # These examples are guarded to avoid throwing errors if (FALSE) { # Signal an error with a message just like stop(): abort("The error message.") # Unhandled errors are saved automatically by `abort()` and can be # retrieved with `last_error()`. The error prints with a simplified # backtrace: f <- function() try(g()) g <- function() evalq(h()) h <- function() abort("Tilt.") last_error() # Use `summary()` to print the full backtrace and the condition fields: summary(last_error()) # Give a class to the error: abort("The error message", "mypkg_bad_error") # This allows callers to handle the error selectively tryCatch( mypkg_function(), mypkg_bad_error = function(err) { warn(conditionMessage(err)) # Demote the error to a warning NA # Return an alternative value } ) # You can also specify metadata that will be stored in the condition: abort("The error message.", "mypkg_bad_error", data = 1:10) # This data can then be consulted by user handlers: tryCatch( mypkg_function(), mypkg_bad_error = function(err) { # Compute an alternative return value with the data: recover_error(err$data) } ) # If you call low-level APIs it may be a good idea to create a # chained error with the low-level error wrapped in a more # user-friendly error. Use `try_fetch()` to fetch errors of a given # class and rethrow them with the `parent` argument of `abort()`: file <- "http://foo.bar/baz" try( try_fetch( download(file), error = function(err) { msg <- sprintf("Can't download `\%s`", file) abort(msg, parent = err) }) ) # You can also hard-code the call when it's not easy to # forward it from the caller f <- function() { abort("my message", call = call("my_function")) } g <- function() { f() } # Shows that the error occured in `my_function()` try(g()) } } \seealso{ \itemize{ \item \ifelse{html}{\link[=topic-error-call]{Including function calls in error messages}}{\link[=topic-error-call]{Including function calls in error messages}} \item \ifelse{html}{\link[=topic-error-chaining]{Including contextual information with error chains}}{\link[=topic-error-chaining]{Including contextual information with error chains}} } } rlang/man/topic-error-call.Rd0000644000176200001440000001522014741441453015604 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/topic-errors.R \name{topic-error-call} \alias{topic-error-call} \title{Including function calls in error messages} \description{ Starting with rlang 1.0, \code{abort()} includes the erroring function in the message by default: \if{html}{\out{
}}\preformatted{my_function <- function() \{ abort("Can't do that.") \} my_function() #> Error in `my_function()`: #> ! Can't do that. }\if{html}{\out{
}} This works well when \code{abort()} is called directly within the failing function. However, when the \code{abort()} call is exported to another function (which we call an "error helper"), we need to be explicit about which function \code{abort()} is throwing an error for. } \section{Passing the user context}{ There are two main kinds of error helpers: \itemize{ \item Simple \code{abort()} wrappers. These often aim at adding classes and attributes to an error condition in a structured way: \if{html}{\out{
}}\preformatted{stop_my_class <- function(message) \{ abort(message, class = "my_class") \} }\if{html}{\out{
}} \item Input checking functions. An input checker is typically passed an input and an argument name. It throws an error if the input doesn't conform to expectations: \if{html}{\out{
}}\preformatted{check_string <- function(x, arg = "x") \{ if (!is_string(x)) \{ cli::cli_abort("\{.arg \{arg\}\} must be a string.") \} \} }\if{html}{\out{
}} } In both cases, the default error call is not very helpful to the end user because it reflects an internal function rather than a user function: \if{html}{\out{
}}\preformatted{my_function <- function(x) \{ check_string(x) stop_my_class("Unimplemented") \} }\if{html}{\out{
}} \if{html}{\out{
}}\preformatted{my_function(NA) #> Error in `check_string()`: #> ! `x` must be a string. }\if{html}{\out{
}} \if{html}{\out{
}}\preformatted{my_function("foo") #> Error in `stop_my_class()`: #> ! Unimplemented }\if{html}{\out{
}} To fix this, let \code{abort()} know about the function that it is throwing the error for by passing the corresponding function environment as the \code{call} argument: \if{html}{\out{
}}\preformatted{stop_my_class <- function(message, call = caller_env()) \{ abort(message, class = "my_class", call = call) \} check_string <- function(x, arg = "x", call = caller_env()) \{ if (!is_string(x)) \{ cli::cli_abort("\{.arg \{arg\}\} must be a string.", call = call) \} \} }\if{html}{\out{
}} \if{html}{\out{
}}\preformatted{my_function(NA) #> Error in `my_function()`: #> ! `x` must be a string. }\if{html}{\out{
}} \if{html}{\out{
}}\preformatted{my_function("foo") #> Error in `my_function()`: #> ! Unimplemented }\if{html}{\out{
}} \subsection{Input checkers and \code{caller_arg()}}{ The \code{caller_arg()} helper is useful in input checkers which check an input on the behalf of another function. Instead of hard-coding \code{arg = "x"}, and forcing the callers to supply it if \code{"x"} is not the name of the argument being checked, use \code{caller_arg()}. \if{html}{\out{
}}\preformatted{check_string <- function(x, arg = caller_arg(x), call = caller_env()) \{ if (!is_string(x)) \{ cli::cli_abort("\{.arg \{arg\}\} must be a string.", call = call) \} \} }\if{html}{\out{
}} It is a combination of \code{substitute()} and \code{rlang::as_label()} which provides a more generally applicable default: \if{html}{\out{
}}\preformatted{my_function <- function(my_arg) \{ check_string(my_arg) \} my_function(NA) #> Error in `my_function()`: #> ! `my_arg` must be a string. }\if{html}{\out{
}} } } \section{Side benefit: backtrace trimming}{ Another benefit of passing \code{caller_env()} as \code{call} is that it allows \code{abort()} to automatically hide the error helpers \if{html}{\out{
}}\preformatted{my_function <- function() \{ their_function() \} their_function <- function() \{ error_helper1() \} error_helper1 <- function(call = caller_env()) \{ error_helper2(call = call) \} error_helper2 <- function(call = caller_env()) \{ if (use_call) \{ abort("Can't do this", call = call) \} else \{ abort("Can't do this") \} \} }\if{html}{\out{
}} \if{html}{\out{
}}\preformatted{use_call <- FALSE their_function() #> Error in `error_helper2()`: #> ! Can't do this }\if{html}{\out{
}} \if{html}{\out{
}}\preformatted{rlang::last_error() #> #> Error in `error_helper2()`: #> ! Can't do this #> --- #> Backtrace: #> x #> 1. \\-rlang (local) their_function() #> 2. \\-rlang (local) error_helper1() #> 3. \\-rlang (local) error_helper2(call = call) #> Run rlang::last_trace(drop = FALSE) to see 1 hidden frame. }\if{html}{\out{
}} With the correct \code{call}, the backtrace is much simpler and lets the user focus on the part of the stack that is relevant to them: \if{html}{\out{
}}\preformatted{use_call <- TRUE their_function() #> Error in `their_function()`: #> ! Can't do this }\if{html}{\out{
}} \if{html}{\out{
}}\preformatted{rlang::last_error() #> #> Error in `their_function()`: #> ! Can't do this #> --- #> Backtrace: #> x #> 1. \\-rlang (local) their_function() #> Run rlang::last_trace(drop = FALSE) to see 3 hidden frames. }\if{html}{\out{
}} } \section{testthat workflow}{ Error snapshots are the main way of checking that the correct error call is included in an error message. However you'll need to opt into a new testthat display for warning and error snapshots. With the new display, these are printed by rlang, including the \code{call} field. This makes it easy to monitor the full appearance of warning and error messages as they are displayed to users. This display is not applied to all packages yet. With testthat 3.1.2, depend explicitly on rlang >= 1.0.0 to opt in. Starting from testthat 3.1.3, depending on rlang, no matter the version, is sufficient to opt in. In the future, the new display will be enabled for all packages. Once enabled, create error snapshots with: \if{html}{\out{
}}\preformatted{expect_snapshot(error = TRUE, \{ my_function() \}) }\if{html}{\out{
}} You'll have to make sure that the snapshot coverage for error messages is sufficient for your package. } \keyword{internal} rlang/man/check_dots_unnamed.Rd0000644000176200001440000000264214626342040016241 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/dots-ellipsis.R \name{check_dots_unnamed} \alias{check_dots_unnamed} \title{Check that all dots are unnamed} \usage{ check_dots_unnamed( env = caller_env(), error = NULL, call = caller_env(), action = abort ) } \arguments{ \item{env}{Environment in which to look for \code{...}.} \item{error}{An optional error handler passed to \code{\link[=try_fetch]{try_fetch()}}. Use this e.g. to demote an error into a warning.} \item{call}{The execution environment of a currently running function, e.g. \code{caller_env()}. The function will be mentioned in error messages as the source of the error. See the \code{call} argument of \code{\link[=abort]{abort()}} for more information.} \item{action}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}}} } \description{ In functions like \code{paste()}, named arguments in \code{...} are often a sign of misspelled argument names. Call \code{check_dots_unnamed()} to fail with an error when named arguments are detected. } \examples{ f <- function(..., foofy = 8) { check_dots_unnamed() c(...) } f(1, 2, 3, foofy = 4) try(f(1, 2, 3, foof = 4)) } \seealso{ Other dots checking functions: \code{\link{check_dots_empty}()}, \code{\link{check_dots_used}()} } \concept{dots checking functions} rlang/man/topic-defuse.Rd0000644000176200001440000002122114741441453015013 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/topic-nse.R \name{topic-defuse} \alias{topic-defuse} \alias{quotation} \alias{nse-defuse} \title{Defusing R expressions} \description{ When a piece of R code is defused, R doesn't return its value like it normally would. Instead it returns the expression in a special tree-like object that describes how to compute a value. These defused expressions can be thought of as blueprints or recipes for computing values. Using \code{\link[=expr]{expr()}} we can observe the difference between computing an expression and defusing it: \if{html}{\out{
}}\preformatted{# Return the result of `1 + 1` 1 + 1 #> [1] 2 # Return the expression `1 + 1` expr(1 + 1) #> 1 + 1 }\if{html}{\out{
}} Evaluation of a defused expression can be resumed at any time with \code{\link[=eval]{eval()}} (see also \code{\link[=eval_tidy]{eval_tidy()}}). \if{html}{\out{
}}\preformatted{# Return the expression `1 + 1` e <- expr(1 + 1) # Return the result of `1 + 1` eval(e) #> [1] 2 }\if{html}{\out{
}} The most common use case for defusing expressions is to resume its evaluation in a \link[=topic-data-mask]{data mask}. This makes it possible for the expression to refer to columns of a data frame as if they were regular objects. \if{html}{\out{
}}\preformatted{e <- expr(mean(cyl)) eval(e, mtcars) #> [1] 6.1875 }\if{html}{\out{
}} } \section{Do I need to know about defused expressions?}{ As a tidyverse user you will rarely need to defuse expressions manually with \code{expr()}, and even more rarely need to resume evaluation with \code{\link[=eval]{eval()}} or \code{\link[=eval_tidy]{eval_tidy()}}. Instead, you call \link[=topic-data-mask]{data-masking} functions which take care of defusing your arguments and resuming them in the context of a data mask. \if{html}{\out{
}}\preformatted{mtcars \%>\% dplyr::summarise( mean(cyl) # This is defused and data-masked ) #> # A tibble: 1 x 1 #> `mean(cyl)` #> #> 1 6.19 }\if{html}{\out{
}} It is important to know that a function defuses its arguments because it requires slightly different methods when called from a function. The main thing is that arguments must be transported with the \link[=embrace-operator]{embrace operator} \verb{\{\{}. It allows the data-masking function to defuse the correct expression. \if{html}{\out{
}}\preformatted{my_mean <- function(data, var) \{ dplyr::summarise(data, mean = mean(\{\{ var \}\})) \} }\if{html}{\out{
}} Read more about this in: \itemize{ \item \ifelse{html}{\link[=topic-data-mask]{What is data-masking and why do I need \{\{?}}{\link[=topic-data-mask]{What is data-masking and why do I need curly-curly?}} \item \ifelse{html}{\link[=topic-data-mask-programming]{Data mask programming patterns}}{\link[=topic-data-mask-programming]{Data mask programming patterns}} } } \section{The booby trap analogy}{ The term "defusing" comes from an analogy to the evaluation model in R. As you may know, R uses lazy evaluation, which means that arguments are only evaluated when they are needed for a computation. Let's take two functions, \code{ignore()} which doesn't do anything with its argument, and \code{force()} which returns it: \if{html}{\out{
}}\preformatted{ignore <- function(arg) NULL force <- function(arg) arg ignore(warning("boom")) #> NULL force(warning("boom")) #> Warning in force(warning("boom")): boom }\if{html}{\out{
}} A warning is only emitted when the function actually \emph{triggers} evaluation of its argument. Evaluation of arguments can be chained by passing them to other functions. If one of the functions ignores its argument, it breaks the chain of evaluation. \if{html}{\out{
}}\preformatted{f <- function(x) g(x) g <- function(y) h(y) h <- function(z) ignore(z) f(warning("boom")) #> NULL }\if{html}{\out{
}} In a way, arguments are like \emph{booby traps} which explode (evaluate) when touched. Defusing an argument can be seen as defusing the booby trap. \if{html}{\out{
}}\preformatted{expr(force(warning("boom"))) #> force(warning("boom")) }\if{html}{\out{
}} } \section{Types of defused expressions}{ \itemize{ \item \strong{Calls}, like \code{f(1, 2, 3)} or \code{1 + 1} represent the action of calling a function to compute a new value, such as a vector. \item \strong{Symbols}, like \code{x} or \code{df}, represent named objects. When the object pointed to by the symbol was defined in a function or in the global environment, we call it an environment-variable. When the object is a column in a data frame, we call it a data-variable. \item \strong{Constants}, like \code{1} or \code{NULL}. } You can create new call or symbol objects by using the defusing function \code{expr()}: \if{html}{\out{
}}\preformatted{# Create a symbol representing objects called `foo` expr(foo) #> foo # Create a call representing the computation of the mean of `foo` expr(mean(foo, na.rm = TRUE)) #> mean(foo, na.rm = TRUE) # Return a constant expr(1) #> [1] 1 expr(NULL) #> NULL }\if{html}{\out{
}} Defusing is not the only way to create defused expressions. You can also assemble them from data: \if{html}{\out{
}}\preformatted{# Assemble a symbol from a string var <- "foo" sym(var) # Assemble a call from strings, symbols, and constants call("mean", sym(var), na.rm = TRUE) }\if{html}{\out{
}} } \section{Local expressions versus function arguments}{ There are two main ways to defuse expressions, to which correspond two functions in rlang, \code{\link[=expr]{expr()}} and \code{\link[=enquo]{enquo()}}: \itemize{ \item You can defuse your \emph{own} R expressions with \code{expr()}. \item You can defuse the expressions supplied by \emph{the user} of your function with the \code{en}-prefixed operators, such as \code{enquo()} and \code{enquos()}. These operators defuse function arguments. } } \section{Defuse and inject}{ One purpose for defusing evaluation of an expression is to interface with \link[=topic-data-mask]{data-masking} functions by injecting the expression back into another function with \verb{!!}. This is the \link[=topic-metaprogramming]{defuse-and-inject pattern}. \if{html}{\out{
}}\preformatted{my_summarise <- function(data, arg) \{ # Defuse the user expression in `arg` arg <- enquo(arg) # Inject the expression contained in `arg` # inside a `summarise()` argument data |> dplyr::summarise(mean = mean(!!arg, na.rm = TRUE)) \} }\if{html}{\out{
}} Defuse-and-inject is usually performed in a single step with the embrace operator \ifelse{html}{\code{\link[=embrace-operator]{\{\{}}}{\verb{\{\{}}. \if{html}{\out{
}}\preformatted{my_summarise <- function(data, arg) \{ # Defuse and inject in a single step with the embracing operator data |> dplyr::summarise(mean = mean(\{\{ arg \}\}, na.rm = TRUE)) \} }\if{html}{\out{
}} Using \code{enquo()} and \verb{!!} separately is useful in more complex cases where you need access to the defused expression instead of just passing it on. } \section{Defused arguments and quosures}{ If you inspect the return values of \code{expr()} and \code{enquo()}, you'll notice that the latter doesn't return a raw expression like the former. Instead it returns a \link{quosure}, a wrapper containing an expression and an environment. \if{html}{\out{
}}\preformatted{expr(1 + 1) #> 1 + 1 my_function <- function(arg) enquo(arg) my_function(1 + 1) #> #> expr: ^1 + 1 #> env: global }\if{html}{\out{
}} R needs information about the environment to properly evaluate argument expressions because they come from a different context than the current function. For instance when a function in your package calls \code{dplyr::mutate()}, the quosure environment indicates where all the private functions of your package are defined. Read more about the role of quosures in \ifelse{html}{\link[=topic-quosure]{What are quosures and when are they needed?}}{\link[=topic-quosure]{What are quosures and when are they needed?}}. } \section{Comparison with base R}{ Defusing is known as \emph{quoting} in other frameworks. \itemize{ \item The equivalent of \code{expr()} is \code{\link[base:bquote]{base::bquote()}}. \item The equivalent of \code{enquo()} is \code{\link[base:substitute]{base::substitute()}}. The latter returns a naked expression instead of a quosure. \item There is no equivalent for \code{enquos(...)} but you can defuse dots as a list of naked expressions with \code{eval(substitute(alist(...)))}. } } \keyword{internal} rlang/man/ffi_standalone_types_check.Rd0000644000176200001440000000055514376112150017761 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/rlang-package.R \name{ffi_standalone_types_check} \alias{ffi_standalone_types_check} \alias{ffi_standalone_is_bool_1.0.7} \alias{ffi_standalone_check_number_1.0.7} \title{Internal API for standalone-types-check} \description{ Internal API for standalone-types-check } \keyword{internal} rlang/man/fn_body.Rd0000644000176200001440000000156014175213516014046 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/fn.R \name{fn_body} \alias{fn_body} \alias{fn_body<-} \title{Get or set function body} \usage{ fn_body(fn = caller_fn()) fn_body(fn) <- value } \arguments{ \item{fn}{A function. It is looked up in the calling frame if not supplied.} \item{value}{New formals or formals names for \code{fn}.} } \description{ \code{fn_body()} is a simple wrapper around \code{\link[base:body]{base::body()}}. It always returns a \verb{\\\{} expression and throws an error when the input is a primitive function (whereas \code{body()} returns \code{NULL}). The setter version preserves attributes, unlike \verb{body<-}. } \examples{ # fn_body() is like body() but always returns a block: fn <- function() do() body(fn) fn_body(fn) # It also throws an error when used on a primitive function: try(fn_body(base::list)) } rlang/man/exec.Rd0000644000176200001440000000316014375670676013370 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/eval.R \name{exec} \alias{exec} \title{Execute a function} \usage{ exec(.fn, ..., .env = caller_env()) } \arguments{ \item{.fn}{A function, or function name as a string.} \item{...}{<\link[=dyn-dots]{dynamic}> Arguments for \code{.fn}.} \item{.env}{Environment in which to evaluate the call. This will be most useful if \code{.fn} is a string, or the function has side-effects.} } \description{ This function constructs and evaluates a call to \code{.fn}. It has two primary uses: \itemize{ \item To call a function with arguments stored in a list (if the function doesn't support \link[=dyn-dots]{dynamic dots}). Splice the list of arguments with \verb{!!!}. \item To call every function stored in a list (in conjunction with \code{map()}/ \code{\link[=lapply]{lapply()}}) } } \examples{ args <- list(x = c(1:10, 100, NA), na.rm = TRUE) exec("mean", !!!args) exec("mean", !!!args, trim = 0.2) fs <- list(a = function() "a", b = function() "b") lapply(fs, exec) # Compare to do.call it will not automatically inline expressions # into the evaluated call. x <- 10 args <- exprs(x1 = x + 1, x2 = x * 2) exec(list, !!!args) do.call(list, args) # exec() is not designed to generate pretty function calls. This is # most easily seen if you call a function that captures the call: f <- disp ~ cyl exec("lm", f, data = mtcars) # If you need finer control over the generated call, you'll need to # construct it yourself. This may require creating a new environment # with carefully constructed bindings data_env <- env(data = mtcars) eval(expr(lm(!!f, data)), data_env) } rlang/man/dots_n.Rd0000644000176200001440000000065314127057575013726 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/dots.R \name{dots_n} \alias{dots_n} \title{How many arguments are currently forwarded in dots?} \usage{ dots_n(...) } \arguments{ \item{...}{Forwarded arguments.} } \description{ This returns the number of arguments currently forwarded in \code{...} as an integer. } \examples{ fn <- function(...) dots_n(..., baz) fn(foo, bar) } \keyword{internal} rlang/man/type_of.Rd0000644000176200001440000000321414375670676014111 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/lifecycle-deprecated.R \name{type_of} \alias{type_of} \title{Base type of an object} \usage{ type_of(x) } \arguments{ \item{x}{An R object.} } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#soft-deprecated}{\figure{lifecycle-soft-deprecated.svg}{options: alt='[Soft-deprecated]'}}}{\strong{[Soft-deprecated]}} \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} This is equivalent to \code{\link[base:typeof]{base::typeof()}} with a few differences that make dispatching easier: \itemize{ \item The type of one-sided formulas is "quote". \item The type of character vectors of length 1 is "string". \item The type of special and builtin functions is "primitive". } } \examples{ type_of(10L) # Quosures are treated as a new base type but not formulas: type_of(quo(10L)) type_of(~10L) # Compare to base::typeof(): typeof(quo(10L)) # Strings are treated as a new base type: type_of(letters) type_of(letters[[1]]) # This is a bit inconsistent with the core language tenet that data # types are vectors. However, treating strings as a different # scalar type is quite helpful for switching on function inputs # since so many arguments expect strings: switch_type("foo", character = abort("vector!"), string = "result") # Special and builtin primitives are both treated as primitives. # That's because it is often irrelevant which type of primitive an # input is: typeof(list) typeof(`$`) type_of(list) type_of(`$`) } \keyword{internal} rlang/man/cnd_message.Rd0000644000176200001440000000602214375670676014714 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cnd-message.R \name{cnd_message} \alias{cnd_message} \alias{cnd_header} \alias{cnd_body} \alias{cnd_footer} \title{Build an error message from parts} \usage{ cnd_message(cnd, ..., inherit = TRUE, prefix = FALSE) cnd_header(cnd, ...) cnd_body(cnd, ...) cnd_footer(cnd, ...) } \arguments{ \item{cnd}{A condition object.} \item{...}{Arguments passed to methods.} \item{inherit}{Wether to include parent messages. Parent messages are printed with a "Caused by error:" prefix, even if \code{prefix} is \code{FALSE}.} \item{prefix}{Whether to print the full message, including the condition prefix (\verb{Error:}, \verb{Warning:}, \verb{Message:}, or \verb{Condition:}). The prefix mentions the \code{call} field if present, and the \code{srcref} info if present. If \code{cnd} has a \code{parent} field (i.e. the condition is chained), the parent messages are included in the message with a \verb{Caused by} prefix.} } \description{ \code{cnd_message()} assembles an error message from three generics: \itemize{ \item \code{cnd_header()} \item \code{cnd_body()} \item \code{cnd_footer()} } Methods for these generics must return a character vector. The elements are combined into a single string with a newline separator. Bullets syntax is supported, either through rlang (see \code{\link[=format_error_bullets]{format_error_bullets()}}), or through cli if the condition has \code{use_cli_format} set to \code{TRUE}. The default method for the error header returns the \code{message} field of the condition object. The default methods for the body and footer return the the \code{body} and \code{footer} fields if any, or empty character vectors otherwise. \code{cnd_message()} is automatically called by the \code{conditionMessage()} for rlang errors, warnings, and messages. Error classes created with \code{\link[=abort]{abort()}} only need to implement header, body or footer methods. This provides a lot of flexibility for hierarchies of error classes, for instance you could inherit the body of an error message from a parent class while overriding the header and footer. } \section{Overriding header, body, and footer methods}{ Sometimes the contents of an error message depends on the state of your checking routine. In that case, it can be tricky to lazily generate error messages with \code{cnd_header()}, \code{cnd_body()}, and \code{cnd_footer()}: you have the choice between overspecifying your error class hierarchies with one class per state, or replicating the type-checking control flow within the \code{cnd_body()} method. None of these options are ideal. A better option is to define \code{header}, \code{body}, or \code{footer} fields in your condition object. These can be a static string, a \link[=as_function]{lambda-formula}, or a function with the same signature as \code{cnd_header()}, \code{cnd_body()}, or \code{cnd_footer()}. These fields override the message generics and make it easy to generate an error message tailored to the state in which the error was constructed. } rlang/man/as_utf8_character.Rd0000644000176200001440000000351114175213516016011 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/utils-encoding.R \name{as_utf8_character} \alias{as_utf8_character} \title{Coerce to a character vector and attempt encoding conversion} \usage{ as_utf8_character(x) } \arguments{ \item{x}{An object to coerce.} } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} Unlike specifying the \code{encoding} argument in \code{as_string()} and \code{as_character()}, which is only declarative, these functions actually attempt to convert the encoding of their input. There are two possible cases: \itemize{ \item The string is tagged as UTF-8 or latin1, the only two encodings for which R has specific support. In this case, converting to the same encoding is a no-op, and converting to native always works as expected, as long as the native encoding, the one specified by the \code{LC_CTYPE} locale has support for all characters occurring in the strings. Unrepresentable characters are serialised as unicode points: "". \item The string is not tagged. R assumes that it is encoded in the native encoding. Conversion to native is a no-op, and conversion to UTF-8 should work as long as the string is actually encoded in the locale codeset. } When translating to UTF-8, the strings are parsed for serialised unicode points (e.g. strings looking like "U+xxxx") with \code{\link[=chr_unserialise_unicode]{chr_unserialise_unicode()}}. This helps to alleviate the effects of character-to-symbol-to-character roundtrips on systems with non-UTF-8 native encoding. } \examples{ # Let's create a string marked as UTF-8 (which is guaranteed by the # Unicode escaping in the string): utf8 <- "caf\uE9" Encoding(utf8) charToRaw(utf8) } \keyword{internal} rlang/man/defusing-advanced.Rd0000644000176200001440000001436714376112150016001 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/nse-defuse.R \name{defusing-advanced} \alias{defusing-advanced} \alias{enexpr} \alias{exprs} \alias{enexprs} \alias{ensym} \alias{ensyms} \alias{quo} \alias{quos} \alias{enquo0} \alias{enquos0} \title{Advanced defusal operators} \usage{ enexpr(arg) exprs( ..., .named = FALSE, .ignore_empty = c("trailing", "none", "all"), .unquote_names = TRUE ) enexprs( ..., .named = FALSE, .ignore_empty = c("trailing", "none", "all"), .ignore_null = c("none", "all"), .unquote_names = TRUE, .homonyms = c("keep", "first", "last", "error"), .check_assign = FALSE ) ensym(arg) ensyms( ..., .named = FALSE, .ignore_empty = c("trailing", "none", "all"), .ignore_null = c("none", "all"), .unquote_names = TRUE, .homonyms = c("keep", "first", "last", "error"), .check_assign = FALSE ) quo(expr) quos( ..., .named = FALSE, .ignore_empty = c("trailing", "none", "all"), .unquote_names = TRUE ) enquo0(arg) enquos0(...) } \arguments{ \item{arg}{An unquoted argument name. The expression supplied to that argument is defused and returned.} \item{...}{For \code{enexprs()}, \code{ensyms()} and \code{enquos()}, names of arguments to defuse. For \code{exprs()} and \code{quos()}, expressions to defuse.} \item{.named}{If \code{TRUE}, unnamed inputs are automatically named with \code{\link[=as_label]{as_label()}}. This is equivalent to applying \code{\link[=exprs_auto_name]{exprs_auto_name()}} on the result. If \code{FALSE}, unnamed elements are left as is and, if fully unnamed, the list is given minimal names (a vector of \code{""}). If \code{NULL}, fully unnamed results are left with \code{NULL} names.} \item{.ignore_empty}{Whether to ignore empty arguments. Can be one of \code{"trailing"}, \code{"none"}, \code{"all"}. If \code{"trailing"}, only the last argument is ignored if it is empty. Named arguments are not considered empty.} \item{.unquote_names}{Whether to treat \verb{:=} as \code{=}. Unlike \code{=}, the \verb{:=} syntax supports \link[=glue-operators]{names injection}.} \item{.ignore_null}{Whether to ignore unnamed null arguments. Can be \code{"none"} or \code{"all"}.} \item{.homonyms}{How to treat arguments with the same name. The default, \code{"keep"}, preserves these arguments. Set \code{.homonyms} to \code{"first"} to only keep the first occurrences, to \code{"last"} to keep the last occurrences, and to \code{"error"} to raise an informative error and indicate what arguments have duplicated names.} \item{.check_assign}{Whether to check for \verb{<-} calls. When \code{TRUE} a warning recommends users to use \code{=} if they meant to match a function parameter or wrap the \verb{<-} call in curly braces otherwise. This ensures assignments are explicit.} \item{expr}{An expression to defuse.} } \description{ These advanced operators \link[=topic-defuse]{defuse} R expressions. \code{\link[=expr]{expr()}}, \code{\link[=enquo]{enquo()}}, and \code{\link[=enquos]{enquos()}} are sufficient for most purposes but rlang provides these other operations, either for completeness or because they are useful to experts. \itemize{ \item \code{exprs()} is the plural variant of \code{expr()}. It returns a list of expressions. It is like \code{\link[base:list]{base::alist()}} but with \link[=nse-inject]{injection} support. \item \code{quo()} and \code{quos()} are like \code{expr()} and \code{exprs()} but return quosures instead of naked expressions. When you are defusing your own local expressions (by opposition to function arguments where non-local expressions are supplied by your users), there is generally no need to attach the current environment in a quosure. See \ifelse{html}{\link[=topic-quosure]{What are quosures and when are they needed?}}{\link[=topic-quosure]{What are quosures and when are they needed?}}. \item \code{enexpr()} and \code{enexprs()} are like \code{\link[=enquo]{enquo()}} and \code{\link[=enquos]{enquos()}} but return naked expressions instead of quosures. These operators should very rarely be used because they lose track of the environment of defused arguments. \item \code{ensym()} and \code{ensyms()} are like \code{enexpr()} and \code{enexprs()} but they throw an error when the defused expressions are not simple symbols. They also support strings which are interpreted as symbols. These functions are modelled on the behaviour of the left-hand side of \code{=} and \verb{<-} where you can supply symbols and strings interchangeably. \if{html}{\out{
}}\preformatted{"foo" <- NULL list("foo" = NULL) }\if{html}{\out{
}} \item \code{enquo0} and \code{enquos0()} are like \code{enquo()} and \code{enquos()} but without injection support. The injection operators \verb{!!}, \verb{!!!}, and \verb{\{\{} are not processed, instead they are preserved in the defused expression. This makes it possible to defuse expressions that potentially contain injection operators meant for later use. The trade off is that it makes it harder for users to inject expressions in your function. They have to enable injection explicitly with \code{\link[=inject]{inject()}}. None of the features of \link[=dyn-dots]{dynamic dots} are available when defusing with \code{enquos0()}. For instance, trailing empty arguments are not automatically trimmed. } } \examples{ # `exprs()` is the plural variant of `expr()` exprs(foo, bar, bar) # `quo()` and `quos()` are the quosure variants of `expr()` and `exprs()` quo(foo) quos(foo, bar) # `enexpr()` and `enexprs()` are the naked variants of `enquo()` and `enquos()` my_function1 <- function(arg) enexpr(arg) my_function2 <- function(arg, ...) enexprs(arg, ...) my_function1(1 + 1) my_function2(1 + 1, 10 * 2) # `ensym()` and `ensyms()` are symbol variants of `enexpr()` and `enexprs()` my_function3 <- function(arg) ensym(arg) my_function4 <- function(arg, ...) ensyms(arg, ...) # The user must supply symbols my_function3(foo) my_function4(foo, bar) # Complex expressions are an error try(my_function3(1 + 1)) try(my_function4(1 + 1, 10 * 2)) # `enquo0()` and `enquos0()` disable injection operators automatic_injection <- function(x) enquo(x) no_injection <- function(x) enquo0(x) automatic_injection(foo(!!!1:3)) no_injection(foo(!!!1:3)) # Injection can still be done explicitly inject(no_injection(foo(!!!1:3))) } \keyword{internal} rlang/man/faq-options.Rd0000644000176200001440000000213514127057575014675 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/faq.R \name{faq-options} \alias{faq-options} \title{Global options for rlang} \description{ rlang has several options which may be set globally to control behavior. A brief description of each is given here. If any functions are referenced, refer to their documentation for additional details. \itemize{ \item \code{rlang_interactive}: A logical value used by \code{\link[=is_interactive]{is_interactive()}}. This can be set to \code{TRUE} to test interactive behavior in unit tests, for example. \item \code{rlang_backtrace_on_error}: A character string which controls whether backtraces are displayed with error messages, and the level of detail they print. See \link{rlang_backtrace_on_error} for the possible option values. \item \code{rlang_trace_format_srcrefs}: A logical value used to control whether srcrefs are printed as part of the backtrace. \item \code{rlang_trace_top_env}: An environment which will be treated as the top-level environment when printing traces. See \code{\link[=trace_back]{trace_back()}} for examples. } } rlang/man/rlang_error.Rd0000644000176200001440000000405114375670676014760 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cnd.R \name{rlang_error} \alias{rlang_error} \title{Errors of class \code{rlang_error}} \description{ \code{\link[=abort]{abort()}} and \code{\link[=error_cnd]{error_cnd()}} create errors of class \code{"rlang_error"}. The differences with base errors are: \itemize{ \item Implementing \code{conditionMessage()} methods for subclasses of \code{"rlang_error"} is undefined behaviour. Instead, implement the \code{\link[=cnd_header]{cnd_header()}} method (and possibly \code{\link[=cnd_body]{cnd_body()}} and \code{\link[=cnd_footer]{cnd_footer()}}). These methods return character vectors which are assembled by rlang when needed: when \code{\link[=conditionMessage]{conditionMessage.rlang_error()}} is called (e.g. via \code{\link[=try]{try()}}), when the error is displayed through \code{\link[=print]{print()}} or \code{\link[=format]{format()}}, and of course when the error is displayed to the user by \code{\link[=abort]{abort()}}. \item \code{\link[=cnd_header]{cnd_header()}}, \code{\link[=cnd_body]{cnd_body()}}, and \code{\link[=cnd_footer]{cnd_footer()}} methods can be overridden by storing closures in the \code{header}, \code{body}, and \code{footer} fields of the condition. This is useful to lazily generate messages based on state captured in the closure environment. \item \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} The \code{use_cli_format} condition field instructs whether to use cli (or rlang's fallback method if cli is not installed) to format the error message at print time. In this case, the \code{message} field may be a character vector of header and bullets. These are formatted at the last moment to take the context into account (starting position on the screen and indentation). See \code{\link[=local_use_cli]{local_use_cli()}} for automatically setting this field in errors thrown with \code{\link[=abort]{abort()}} within your package. } } rlang/man/env_unbind.Rd0000644000176200001440000000227614127057575014572 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/env-binding.R \name{env_unbind} \alias{env_unbind} \title{Remove bindings from an environment} \usage{ env_unbind(env = caller_env(), nms, inherit = FALSE) } \arguments{ \item{env}{An environment.} \item{nms}{A character vector of binding names to remove.} \item{inherit}{Whether to look for bindings in the parent environments.} } \value{ The input object \code{env} with its associated environment modified in place, invisibly. } \description{ \code{env_unbind()} is the complement of \code{\link[=env_bind]{env_bind()}}. Like \code{env_has()}, it ignores the parent environments of \code{env} by default. Set \code{inherit} to \code{TRUE} to track down bindings in parent environments. } \examples{ env <- env(foo = 1, bar = 2) env_has(env, c("foo", "bar")) # Remove bindings with `env_unbind()` env_unbind(env, c("foo", "bar")) env_has(env, c("foo", "bar")) # With inherit = TRUE, it removes bindings in parent environments # as well: parent <- env(empty_env(), foo = 1, bar = 2) env <- env(parent, foo = "b") env_unbind(env, "foo", inherit = TRUE) env_has(env, c("foo", "bar")) env_has(env, c("foo", "bar"), inherit = TRUE) } rlang/man/rep_along.Rd0000644000176200001440000000156314127057575014407 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/vec-new.R \name{rep_along} \alias{rep_along} \alias{rep_named} \title{Create vectors matching the length of a given vector} \usage{ rep_along(along, x) rep_named(names, x) } \arguments{ \item{along}{Vector whose length determine how many times \code{x} is repeated.} \item{x}{Values to repeat.} \item{names}{Names for the new vector. The length of \code{names} determines how many times \code{x} is repeated.} } \description{ These functions take the idea of \code{\link[=seq_along]{seq_along()}} and apply it to repeating values. } \examples{ x <- 0:5 rep_along(x, 1:2) rep_along(x, 1) # Create fresh vectors by repeating missing values: rep_along(x, na_int) rep_along(x, na_chr) # rep_named() repeats a value along a names vectors rep_named(c("foo", "bar"), list(letters)) } \seealso{ new-vector } rlang/man/call2.Rd0000644000176200001440000000663414626342040013426 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/call.R \name{call2} \alias{call2} \title{Create a call} \usage{ call2(.fn, ..., .ns = NULL) } \arguments{ \item{.fn}{Function to call. Must be a callable object: a string, symbol, call, or a function.} \item{...}{<\link[=dyn-dots]{dynamic}> Arguments for the function call. Empty arguments are preserved.} \item{.ns}{Namespace with which to prefix \code{.fn}. Must be a string or symbol.} } \description{ Quoted function calls are one of the two types of \link[=is_symbolic]{symbolic} objects in R. They represent the action of calling a function, possibly with arguments. There are two ways of creating a quoted call: \itemize{ \item By \link[=nse-defuse]{quoting} it. Quoting prevents functions from being called. Instead, you get the description of the function call as an R object. That is, a quoted function call. \item By constructing it with \code{\link[base:call]{base::call()}}, \code{\link[base:call]{base::as.call()}}, or \code{call2()}. In this case, you pass the call elements (the function to call and the arguments to call it with) separately. } See section below for the difference between \code{call2()} and the base constructors. } \section{Difference with base constructors}{ \code{call2()} is more flexible than \code{base::call()}: \itemize{ \item The function to call can be a string or a \link[=is_callable]{callable} object: a symbol, another call (e.g. a \code{$} or \code{[[} call), or a function to inline. \code{base::call()} only supports strings and you need to use \code{base::as.call()} to construct a call with a callable object. \if{html}{\out{
}}\preformatted{call2(list, 1, 2) as.call(list(list, 1, 2)) }\if{html}{\out{
}} \item The \code{.ns} argument is convenient for creating namespaced calls. \if{html}{\out{
}}\preformatted{call2("list", 1, 2, .ns = "base") # Equivalent to ns_call <- call("::", as.symbol("list"), as.symbol("base")) as.call(list(ns_call, 1, 2)) }\if{html}{\out{
}} \item \code{call2()} has \link[=list2]{dynamic dots} support. You can splice lists of arguments with \verb{!!!} or unquote an argument name with glue syntax. \if{html}{\out{
}}\preformatted{args <- list(na.rm = TRUE, trim = 0) call2("mean", 1:10, !!!args) # Equivalent to as.call(c(list(as.symbol("mean"), 1:10), args)) }\if{html}{\out{
}} } } \section{Caveats of inlining objects in calls}{ \code{call2()} makes it possible to inline objects in calls, both in function and argument positions. Inlining an object or a function has the advantage that the correct object is used in all environments. If all components of the code are inlined, you can even evaluate in the \link[=empty_env]{empty environment}. However inlining also has drawbacks. It can cause issues with NSE functions that expect symbolic arguments. The objects may also leak in representations of the call stack, such as \code{\link[=traceback]{traceback()}}. } \examples{ # fn can either be a string, a symbol or a call call2("f", a = 1) call2(quote(f), a = 1) call2(quote(f()), a = 1) #' Can supply arguments individually or in a list call2(quote(f), a = 1, b = 2) call2(quote(f), !!!list(a = 1, b = 2)) # Creating namespaced calls is easy: call2("fun", arg = quote(baz), .ns = "mypkg") # Empty arguments are preserved: call2("[", quote(x), , drop = ) } \seealso{ \code{\link[=call_modify]{call_modify()}} } rlang/man/env_lock.Rd0000644000176200001440000000276314175213516014234 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/env.R \name{env_lock} \alias{env_lock} \alias{env_is_locked} \title{Lock an environment} \usage{ env_lock(env) env_is_locked(env) } \arguments{ \item{env}{An environment.} } \value{ The old value of \code{env_is_locked()} invisibly. } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} Locked environments cannot be modified. An important example is namespace environments which are locked by R when loaded in a session. Once an environment is locked it normally cannot be unlocked. Note that only the environment as a container is locked, not the individual bindings. You can't remove or add a binding but you can still modify the values of existing bindings. See \code{\link[=env_binding_lock]{env_binding_lock()}} for locking individual bindings. } \examples{ # New environments are unlocked by default: env <- env(a = 1) env_is_locked(env) # Use env_lock() to lock them: env_lock(env) env_is_locked(env) # Now that `env` is locked, it is no longer possible to remove or # add bindings. If run, the following would fail: # env_unbind(env, "a") # env_bind(env, b = 2) # Note that even though the environment as a container is locked, # the individual bindings are still unlocked and can be modified: env$a <- 10 } \seealso{ \code{\link[=env_binding_lock]{env_binding_lock()}} } \keyword{internal} rlang/man/set_expr.Rd0000644000176200001440000000273414375670676014303 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/expr.R \name{set_expr} \alias{set_expr} \alias{get_expr} \title{Set and get an expression} \usage{ set_expr(x, value) get_expr(x, default = x) } \arguments{ \item{x}{An expression, closure, or one-sided formula. In addition, \code{set_expr()} accept frames.} \item{value}{An updated expression.} \item{default}{A default expression to return when \code{x} is not an expression wrapper. Defaults to \code{x} itself.} } \value{ The updated original input for \code{set_expr()}. A raw expression for \code{get_expr()}. } \description{ These helpers are useful to make your function work generically with quosures and raw expressions. First call \code{get_expr()} to extract an expression. Once you're done processing the expression, call \code{set_expr()} on the original object to update the expression. You can return the result of \code{set_expr()}, either a formula or an expression depending on the input type. Note that \code{set_expr()} does not change its input, it creates a new object. } \examples{ f <- ~foo(bar) e <- quote(foo(bar)) frame <- identity(identity(ctxt_frame())) get_expr(f) get_expr(e) get_expr(frame) set_expr(f, quote(baz)) set_expr(e, quote(baz)) } \seealso{ \code{\link[=quo_get_expr]{quo_get_expr()}} and \code{\link[=quo_set_expr]{quo_set_expr()}} for versions of \code{\link[=get_expr]{get_expr()}} and \code{\link[=set_expr]{set_expr()}} that only work on quosures. } \keyword{internal} rlang/man/topic-data-mask-programming.Rd0000644000176200001440000004252114741441453017730 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/topic-nse.R \name{topic-data-mask-programming} \alias{topic-data-mask-programming} \title{Data mask programming patterns} \description{ \link[=topic-data-mask]{Data-masking} functions require special programming patterns when used inside other functions. In this topic we'll review and compare the different patterns that can be used to solve specific problems. If you are a beginner, you might want to start with one of these tutorials: \itemize{ \item \href{https://dplyr.tidyverse.org/articles/programming.html}{Programming with dplyr} \item \href{https://ggplot2.tidyverse.org/articles/ggplot2-in-packages.html}{Using ggplot2 in packages} } If you'd like to go further and learn about defusing and injecting expressions, read the \link[=topic-metaprogramming]{metaprogramming patterns topic}. } \section{Choosing a pattern}{ Two main considerations determine which programming pattern you need to wrap a data-masking function: \enumerate{ \item What behaviour does the \emph{wrapped} function implement? \item What behaviour should \emph{your} function implement? } Depending on the answers to these questions, you can choose between these approaches: \itemize{ \item The \strong{forwarding patterns} with which your function inherits the behaviour of the function it interfaces with. \item The \strong{name patterns} with which your function takes strings or character vectors of column names. \item The \strong{bridge patterns} with which you change the behaviour of an argument instead of inheriting it. } You will also need to use different solutions for single named arguments than for multiple arguments in \code{...}. } \section{Argument behaviours}{ In a regular function, arguments can be defined in terms of a \emph{type} of objects that they accept. An argument might accept a character vector, a data frame, a single logical value, etc. Data-masked arguments are more complex. Not only do they generally accept a specific type of objects (for instance \code{dplyr::mutate()} accepts vectors), they exhibit special computational behaviours. \itemize{ \item Data-masked expressions (base): E.g. \code{\link[=transform]{transform()}}, \code{\link[=with]{with()}}. Expressions may refer to the columns of the supplied data frame. \item Data-masked expressions (tidy eval): E.g. \code{dplyr::mutate()}, \code{ggplot2::aes()}. Same as base data-masking but with tidy eval features enabled. This includes \link[=topic-inject]{injection operators} such as \ifelse{html}{\code{\link[=embrace-operator]{\{\{}}}{\verb{\{\{}} and \code{\link[=injection-operator]{!!}} and the \code{\link{.data}} and \code{\link{.env}} pronouns. \item Data-masked symbols: Same as data-masked arguments but the supplied expressions must be simple column names. This often simplifies things, for instance this is an easy way of avoiding issues of \link[=topic-double-evaluation]{double evaluation}. \item \href{https://tidyselect.r-lib.org/reference/language.html}{Tidy selections}: E.g. \code{dplyr::select()}, \code{tidyr::pivot_longer()}. This is an alternative to data masking that supports selection helpers like \code{starts_with()} or \code{all_of()}, and implements special behaviour for operators like \code{c()}, \code{|} and \code{&}. Unlike data masking, tidy selection is an interpreted dialect. There is in fact no masking at all. Expressions are either interpreted in the context of the data frame (e.g. \code{c(cyl, am)} which stands for the union of the columns \code{cyl} and \code{am}), or evaluated in the user environment (e.g. \code{all_of()}, \code{starts_with()}, and any other expressions). This has implications for inheritance of argument behaviour as we will see below. \item \link[=doc_dots_dynamic]{Dynamic dots}: These may be data-masked arguments, tidy selections, or just regular arguments. Dynamic dots support injection of multiple arguments with the \code{\link[=splice-operator]{!!!}} operator as well as name injection with \link[=glue-operators]{glue} operators. } To let users know about the capabilities of your function arguments, document them with the following tags, depending on which set of semantics they inherit from: \if{html}{\out{
}}\preformatted{@param foo <[`data-masked`][dplyr::dplyr_data_masking]> What `foo` does. @param bar <[`tidy-select`][dplyr::dplyr_tidy_select]> What `bar` does. @param ... <[`dynamic-dots`][rlang::dyn-dots]> What these dots do. }\if{html}{\out{
}} } \section{Forwarding patterns}{ With the forwarding patterns, arguments inherit the behaviour of the data-masked arguments they are passed in. \subsection{Embrace with \verb{\{\{}}{ The embrace operator \ifelse{html}{\code{\link[=embrace-operator]{\{\{}}}{\verb{\{\{}} is a forwarding syntax for single arguments. You can forward an argument in data-masked context: \if{html}{\out{
}}\preformatted{my_summarise <- function(data, var) \{ data \%>\% dplyr::summarise(\{\{ var \}\}) \} }\if{html}{\out{
}} Or in tidyselections: \if{html}{\out{
}}\preformatted{my_pivot_longer <- function(data, var) \{ data \%>\% tidyr::pivot_longer(cols = \{\{ var \}\}) \} }\if{html}{\out{
}} The function automatically inherits the behaviour of the surrounding context. For instance arguments forwarded to a data-masked context may refer to columns or use the \code{\link{.data}} pronoun: \if{html}{\out{
}}\preformatted{mtcars \%>\% my_summarise(mean(cyl)) x <- "cyl" mtcars \%>\% my_summarise(mean(.data[[x]])) }\if{html}{\out{
}} And arguments forwarded to a tidy selection may use all tidyselect features: \if{html}{\out{
}}\preformatted{mtcars \%>\% my_pivot_longer(cyl) mtcars \%>\% my_pivot_longer(vs:gear) mtcars \%>\% my_pivot_longer(starts_with("c")) x <- c("cyl", "am") mtcars \%>\% my_pivot_longer(all_of(x)) }\if{html}{\out{
}} } \subsection{Forward \code{...}}{ Simple forwarding of \code{...} arguments does not require any special syntax since dots are already a forwarding syntax. Just pass them to another function like you normally would. This works with data-masked arguments: \if{html}{\out{
}}\preformatted{my_group_by <- function(.data, ...) \{ .data \%>\% dplyr::group_by(...) \} mtcars \%>\% my_group_by(cyl = cyl * 100, am) }\if{html}{\out{
}} As well as tidy selections: \if{html}{\out{
}}\preformatted{my_select <- function(.data, ...) \{ .data \%>\% dplyr::select(...) \} mtcars \%>\% my_select(starts_with("c"), vs:carb) }\if{html}{\out{
}} Some functions take a tidy selection in a single named argument. In that case, pass the \code{...} inside \code{c()}: \if{html}{\out{
}}\preformatted{my_pivot_longer <- function(.data, ...) \{ .data \%>\% tidyr::pivot_longer(c(...)) \} mtcars \%>\% my_pivot_longer(starts_with("c"), vs:carb) }\if{html}{\out{
}} Inside a tidy selection, \code{c()} is not a vector concatenator but a selection combinator. This makes it handy to interface between functions that take \code{...} and functions that take a single argument. } } \section{Names patterns}{ With the names patterns you refer to columns by name with strings or character vectors stored in env-variables. Whereas the forwarding patterns are exclusively used within a function to pass \emph{arguments}, the names patterns can be used anywhere. \itemize{ \item In a script, you can loop over a character vector with \code{for} or \code{lapply()} and use the \code{\link{.data}} pattern to connect a name to its data-variable. A vector can also be supplied all at once to the tidy select helper \code{all_of()}. \item In a function, using the names patterns on function arguments lets users supply regular data-variable names without any of the complications that come with data-masking. } \subsection{Subsetting the \code{.data} pronoun}{ The \code{\link{.data}} pronoun is a tidy eval feature that is enabled in all data-masked arguments, just like \ifelse{html}{\code{\link[=embrace-operator]{\{\{}}}{\verb{\{\{}}. The pronoun represents the data mask and can be subsetted with \code{[[} and \code{$}. These three statements are equivalent: \if{html}{\out{
}}\preformatted{mtcars \%>\% dplyr::summarise(mean = mean(cyl)) mtcars \%>\% dplyr::summarise(mean = mean(.data$cyl)) var <- "cyl" mtcars \%>\% dplyr::summarise(mean = mean(.data[[var]])) }\if{html}{\out{
}} The \code{.data} pronoun can be subsetted in loops: \if{html}{\out{
}}\preformatted{vars <- c("cyl", "am") for (var in vars) print(dplyr::summarise(mtcars, mean = mean(.data[[var]]))) #> # A tibble: 1 x 1 #> mean #> #> 1 6.19 #> # A tibble: 1 x 1 #> mean #> #> 1 0.406 purrr::map(vars, ~ dplyr::summarise(mtcars, mean = mean(.data[[.x]]))) #> [[1]] #> # A tibble: 1 x 1 #> mean #> #> 1 6.19 #> #> [[2]] #> # A tibble: 1 x 1 #> mean #> #> 1 0.406 }\if{html}{\out{
}} And it can be used to connect function arguments to a data-variable: \if{html}{\out{
}}\preformatted{my_mean <- function(data, var) \{ data \%>\% dplyr::summarise(mean = mean(.data[[var]])) \} my_mean(mtcars, "cyl") #> # A tibble: 1 x 1 #> mean #> #> 1 6.19 }\if{html}{\out{
}} With this implementation, \code{my_mean()} is completely insulated from data-masking behaviour and is called like an ordinary function. \if{html}{\out{
}}\preformatted{# No masking am <- "cyl" my_mean(mtcars, am) #> # A tibble: 1 x 1 #> mean #> #> 1 6.19 # Programmable my_mean(mtcars, tolower("CYL")) #> # A tibble: 1 x 1 #> mean #> #> 1 6.19 }\if{html}{\out{
}} } \subsection{Character vector of names}{ The \code{.data} pronoun can only be subsetted with single column names. It doesn't support single-bracket indexing: \if{html}{\out{
}}\preformatted{mtcars \%>\% dplyr::summarise(.data[c("cyl", "am")]) #> Error in `dplyr::summarise()`: #> i In argument: `.data[c("cyl", "am")]`. #> Caused by error in `.data[c("cyl", "am")]`: #> ! `[` is not supported by the `.data` pronoun, use `[[` or $ instead. }\if{html}{\out{
}} There is no plural variant of \code{.data} built in tidy eval. Instead, we'll used the \code{all_of()} operator available in tidy selections to supply character vectors. This is straightforward in functions that take tidy selections, like \code{tidyr::pivot_longer()}: \if{html}{\out{
}}\preformatted{vars <- c("cyl", "am") mtcars \%>\% tidyr::pivot_longer(all_of(vars)) #> # A tibble: 64 x 11 #> mpg disp hp drat wt qsec vs gear carb name value #> #> 1 21 160 110 3.9 2.62 16.5 0 4 4 cyl 6 #> 2 21 160 110 3.9 2.62 16.5 0 4 4 am 1 #> 3 21 160 110 3.9 2.88 17.0 0 4 4 cyl 6 #> 4 21 160 110 3.9 2.88 17.0 0 4 4 am 1 #> # i 60 more rows }\if{html}{\out{
}} If the function does not take a tidy selection, it might be possible to use a \emph{bridge pattern}. This option is presented in the bridge section below. If a bridge is impossible or inconvenient, a little metaprogramming with the \link[=topic-metaprogramming]{symbolise-and-inject pattern} can help. } } \section{Bridge patterns}{ Sometimes the function you are calling does not implement the behaviour you would like to give to the arguments of your function. To work around this may require a little thought since there is no systematic way of turning one behaviour into another. The general technique consists in forwarding the arguments inside a context that implements the behaviour that you want. Then, find a way to bridge the result to the target verb or function. \subsection{\code{across()} as a selection to data-mask bridge}{ dplyr 1.0 added support for tidy selections in all verbs via \code{across()}. This function is normally used for mapping over columns but can also be used to perform a simple selection. For instance, if you'd like to pass an argument to \code{group_by()} with a tidy-selection interface instead of a data-masked one, use \code{across()} as a bridge: \if{html}{\out{
}}\preformatted{my_group_by <- function(data, var) \{ data \%>\% dplyr::group_by(across(\{\{ var \}\})) \} mtcars \%>\% my_group_by(starts_with("c")) }\if{html}{\out{
}} Since \code{across()} takes selections in a single argument (unlike \code{select()} which takes multiple arguments), you can't directly pass \code{...}. Instead, take them within \code{c()}, which is the tidyselect way of supplying multiple selections within a single argument: \if{html}{\out{
}}\preformatted{my_group_by <- function(.data, ...) \{ .data \%>\% dplyr::group_by(across(c(...))) \} mtcars \%>\% my_group_by(starts_with("c"), vs:gear) }\if{html}{\out{
}} } \subsection{\code{across(all_of())} as a names to data mask bridge}{ If instead of forwarding variables in \code{across()} you pass them to \code{all_of()}, you create a names to data mask bridge. \if{html}{\out{
}}\preformatted{my_group_by <- function(data, vars) \{ data \%>\% dplyr::group_by(across(all_of(vars))) \} mtcars \%>\% my_group_by(c("cyl", "am")) }\if{html}{\out{
}} Use this bridge technique to connect vectors of names to a data-masked context. } \subsection{\code{transmute()} as a data-mask to selection bridge}{ Passing data-masked arguments to a tidy selection is a little more tricky and requires a three step process. \if{html}{\out{
}}\preformatted{my_pivot_longer <- function(data, ...) \{ # Forward `...` in data-mask context with `transmute()` # and save the inputs names inputs <- dplyr::transmute(data, ...) names <- names(inputs) # Update the data with the inputs data <- dplyr::mutate(data, !!!inputs) # Select the inputs by name with `all_of()` tidyr::pivot_longer(data, cols = all_of(names)) \} mtcars \%>\% my_pivot_longer(cyl, am = am * 100) }\if{html}{\out{
}} \enumerate{ \item In a first step we pass the \code{...} expressions to \code{transmute()}. Unlike \code{mutate()}, it creates a new data frame from the user inputs. The only goal of this step is to inspect the names in \code{...}, including the default names created for unnamed arguments. \item Once we have the names, we inject the arguments into \code{mutate()} to update the data frame. \item Finally, we pass the names to the tidy selection via \href{https://tidyselect.r-lib.org/reference/all_of.html}{\code{all_of()}}. } } } \section{Transformation patterns}{ \subsection{Named inputs versus \code{...}}{ In the case of a named argument, transformation is easy. We simply surround the embraced input in R code. For instance, the \code{my_summarise()} function is not exactly useful compared to just calling \code{summarise()}: \if{html}{\out{
}}\preformatted{my_summarise <- function(data, var) \{ data \%>\% dplyr::summarise(\{\{ var \}\}) \} }\if{html}{\out{
}} We can make it more useful by adding code around the variable: \if{html}{\out{
}}\preformatted{my_mean <- function(data, var) \{ data \%>\% dplyr::summarise(mean = mean(\{\{ var \}\}, na.rm = TRUE)) \} }\if{html}{\out{
}} For inputs in \code{...} however, this technique does not work. We would need some kind of templating syntax for dots that lets us specify R code with a placeholder for the dots elements. This isn't built in tidy eval but you can use operators like \code{dplyr::across()}, \code{dplyr::if_all()}, or \code{dplyr::if_any()}. When that isn't possible, you can template the expression manually. } \subsection{Transforming inputs with \code{across()}}{ The \code{across()} operation in dplyr is a convenient way of mapping an expression across a set of inputs. We will create a variant of \code{my_mean()} that computes the \code{mean()} of all arguments supplied in \code{...}. The easiest way it to forward the dots to \code{across()} (which causes \code{...} to inherit its tidy selection behaviour): \if{html}{\out{
}}\preformatted{my_mean <- function(data, ...) \{ data \%>\% dplyr::summarise(across(c(...), ~ mean(.x, na.rm = TRUE))) \} mtcars \%>\% my_mean(cyl, carb) #> # A tibble: 1 x 2 #> cyl carb #> #> 1 6.19 2.81 mtcars \%>\% my_mean(foo = cyl, bar = carb) #> # A tibble: 1 x 2 #> foo bar #> #> 1 6.19 2.81 mtcars \%>\% my_mean(starts_with("c"), mpg:disp) #> # A tibble: 1 x 4 #> cyl carb mpg disp #> #> 1 6.19 2.81 20.1 231. }\if{html}{\out{
}} } \subsection{Transforming inputs with \code{if_all()} and \code{if_any()}}{ \code{dplyr::filter()} requires a different operation than \code{across()} because it needs to combine the logical expressions with \code{&} or \code{|}. To solve this problem dplyr introduced the \code{if_all()} and \code{if_any()} variants of \code{across()}. In the following example, we filter all rows for which a set of variables are not equal to their minimum value: \if{html}{\out{
}}\preformatted{filter_non_baseline <- function(.data, ...) \{ .data \%>\% dplyr::filter(if_all(c(...), ~ .x != min(.x, na.rm = TRUE))) \} mtcars \%>\% filter_non_baseline(vs, am, gear) }\if{html}{\out{
}} } } \keyword{internal} rlang/man/dots_splice.Rd0000644000176200001440000000343114376150033014732 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/lifecycle-deprecated.R \name{dots_splice} \alias{dots_splice} \title{Splice lists} \usage{ dots_splice( ..., .ignore_empty = c("trailing", "none", "all"), .preserve_empty = FALSE, .homonyms = c("keep", "first", "last", "error"), .check_assign = FALSE ) } \arguments{ \item{...}{Arguments to collect in a list. These dots are \link[=dyn-dots]{dynamic}.} \item{.ignore_empty}{Whether to ignore empty arguments. Can be one of \code{"trailing"}, \code{"none"}, \code{"all"}. If \code{"trailing"}, only the last argument is ignored if it is empty.} \item{.preserve_empty}{Whether to preserve the empty arguments that were not ignored. If \code{TRUE}, empty arguments are stored with \code{\link[=missing_arg]{missing_arg()}} values. If \code{FALSE} (the default) an error is thrown when an empty argument is detected.} \item{.homonyms}{How to treat arguments with the same name. The default, \code{"keep"}, preserves these arguments. Set \code{.homonyms} to \code{"first"} to only keep the first occurrences, to \code{"last"} to keep the last occurrences, and to \code{"error"} to raise an informative error and indicate what arguments have duplicated names.} \item{.check_assign}{Whether to check for \verb{<-} calls. When \code{TRUE} a warning recommends users to use \code{=} if they meant to match a function parameter or wrap the \verb{<-} call in curly braces otherwise. This ensures assignments are explicit.} } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} \code{dots_splice()} is like \code{\link[=dots_list]{dots_list()}} but automatically splices list inputs. } \keyword{internal} rlang/man/as_data_mask.Rd0000644000176200001440000001643014723531655015045 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/eval-tidy.R \name{as_data_mask} \alias{as_data_mask} \alias{as_data_pronoun} \alias{new_data_mask} \title{Create a data mask} \usage{ as_data_mask(data) as_data_pronoun(data) new_data_mask(bottom, top = bottom) } \arguments{ \item{data}{A data frame or named vector of masking data.} \item{bottom}{The environment containing masking objects if the data mask is one environment deep. The bottom environment if the data mask comprises multiple environment. If you haven't supplied \code{top}, this \strong{must} be an environment that you own, i.e. that you have created yourself.} \item{top}{The last environment of the data mask. If the data mask is only one environment deep, \code{top} should be the same as \code{bottom}. This \strong{must} be an environment that you own, i.e. that you have created yourself. The parent of \code{top} will be changed by the tidy eval engine and should be considered undetermined. Never make assumption about the parent of \code{top}.} } \value{ A data mask that you can supply to \code{\link[=eval_tidy]{eval_tidy()}}. } \description{ A \link[=topic-data-mask]{data mask} is an environment (or possibly multiple environments forming an ancestry) containing user-supplied objects. Objects in the mask have precedence over objects in the environment (i.e. they mask those objects). Many R functions evaluate quoted expressions in a data mask so these expressions can refer to objects within the user data. These functions let you construct a tidy eval data mask manually. They are meant for developers of tidy eval interfaces rather than for end users. } \section{Why build a data mask?}{ Most of the time you can just call \code{\link[=eval_tidy]{eval_tidy()}} with a list or a data frame and the data mask will be constructed automatically. There are three main use cases for manual creation of data masks: \itemize{ \item When \code{\link[=eval_tidy]{eval_tidy()}} is called with the same data in a tight loop. Because there is some overhead to creating tidy eval data masks, constructing the mask once and reusing it for subsequent evaluations may improve performance. \item When several expressions should be evaluated in the exact same environment because a quoted expression might create new objects that can be referred in other quoted expressions evaluated at a later time. One example of this is \code{tibble::lst()} where new columns can refer to previous ones. \item When your data mask requires special features. For instance the data frame columns in dplyr data masks are implemented with \link[base:delayedAssign]{active bindings}. } } \section{Building your own data mask}{ Unlike \code{\link[base:eval]{base::eval()}} which takes any kind of environments as data mask, \code{\link[=eval_tidy]{eval_tidy()}} has specific requirements in order to support \link[=nse-defuse]{quosures}. For this reason you can't supply bare environments. There are two ways of constructing an rlang data mask manually: \itemize{ \item \code{as_data_mask()} transforms a list or data frame to a data mask. It automatically installs the data pronoun \code{\link{.data}}. \item \code{new_data_mask()} is a bare bones data mask constructor for environments. You can supply a bottom and a top environment in case your data mask comprises multiple environments (see section below). Unlike \code{as_data_mask()} it does not install the \code{.data} pronoun so you need to provide one yourself. You can provide a pronoun constructed with \code{as_data_pronoun()} or your own pronoun class. \code{as_data_pronoun()} will create a pronoun from a list, an environment, or an rlang data mask. In the latter case, the whole ancestry is looked up from the bottom to the top of the mask. Functions stored in the mask are bypassed by the pronoun. } Once you have built a data mask, simply pass it to \code{\link[=eval_tidy]{eval_tidy()}} as the \code{data} argument. You can repeat this as many times as needed. Note that any objects created there (perhaps because of a call to \verb{<-}) will persist in subsequent evaluations. } \section{Top and bottom of data mask}{ In some cases you'll need several levels in your data mask. One good reason is when you include functions in the mask. It's a good idea to keep data objects one level lower than function objects, so that the former cannot override the definitions of the latter (see examples). In that case, set up all your environments and keep track of the bottom child and the top parent. You'll need to pass both to \code{new_data_mask()}. Note that the parent of the top environment is completely undetermined, you shouldn't expect it to remain the same at all times. This parent is replaced during evaluation by \code{\link[=eval_tidy]{eval_tidy()}} to one of the following environments: \itemize{ \item The default environment passed as the \code{env} argument of \code{eval_tidy()}. \item The environment of the current quosure being evaluated, if applicable. } Consequently, all masking data should be contained between the bottom and top environment of the data mask. } \examples{ # Evaluating in a tidy evaluation environment enables all tidy # features: mask <- as_data_mask(mtcars) eval_tidy(quo(letters), mask) # You can install new pronouns in the mask: mask$.pronoun <- as_data_pronoun(list(foo = "bar", baz = "bam")) eval_tidy(quo(.pronoun$foo), mask) # In some cases the data mask can leak to the user, for example if # a function or formula is created in the data mask environment: cyl <- "user variable from the context" fn <- eval_tidy(quote(function() cyl), mask) fn() # If new objects are created in the mask, they persist in the # subsequent calls: eval_tidy(quote(new <- cyl + am), mask) eval_tidy(quote(new * 2), mask) # In some cases your data mask is a whole chain of environments # rather than a single environment. You'll have to use # `new_data_mask()` and let it know about the bottom of the mask # (the last child of the environment chain) and the topmost parent. # A common situation where you'll want a multiple-environment mask # is when you include functions in your mask. In that case you'll # put functions in the top environment and data in the bottom. This # will prevent the data from overwriting the functions. top <- new_environment(list(`+` = base::paste, c = base::paste)) # Let's add a middle environment just for sport: middle <- env(top) # And finally the bottom environment containing data: bottom <- env(middle, a = "a", b = "b", c = "c") # We can now create a mask by supplying the top and bottom # environments: mask <- new_data_mask(bottom, top = top) # This data mask can be passed to eval_tidy() instead of a list or # data frame: eval_tidy(quote(a + b + c), data = mask) # Note how the function `c()` and the object `c` are looked up # properly because of the multi-level structure: eval_tidy(quote(c(a, b, c)), data = mask) # new_data_mask() does not create data pronouns, but # data pronouns can be added manually: mask$.fns <- as_data_pronoun(top) # The `.data` pronoun should generally be created from the # mask. This will ensure data is looked up throughout the whole # ancestry. Only non-function objects are looked up from this # pronoun: mask$.data <- as_data_pronoun(mask) mask$.data$c # Now we can reference values with the pronouns: eval_tidy(quote(c(.data$a, .data$b, .data$c)), data = mask) } rlang/man/cnd_inherits.Rd0000644000176200001440000000674114741441453015107 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cnd.R \name{cnd_inherits} \alias{cnd_inherits} \title{Does a condition or its ancestors inherit from a class?} \usage{ cnd_inherits(cnd, class) } \arguments{ \item{cnd}{A condition to test.} \item{class}{A class passed to \code{\link[=inherits]{inherits()}}.} } \description{ Like any R objects, errors captured with catchers like \code{\link[=tryCatch]{tryCatch()}} have a \code{\link[=class]{class()}} which you can test with \code{\link[=inherits]{inherits()}}. However, with chained errors, the class of a captured error might be different than the error that was originally signalled. Use \code{cnd_inherits()} to detect whether an error or any of its \emph{parent} inherits from a class. Whereas \code{inherits()} tells you whether an object is a particular kind of error, \code{cnd_inherits()} answers the question whether an object is a particular kind of error or has been caused by such an error. Some chained conditions carry parents that are not inherited. See the \code{.inherit} argument of \code{\link[=abort]{abort()}}, \code{\link[=warn]{warn()}}, and \code{\link[=inform]{inform()}}. } \section{Capture an error with \code{cnd_inherits()}}{ Error catchers like \code{\link[=tryCatch]{tryCatch()}} and \code{\link[=try_fetch]{try_fetch()}} can only match the class of a condition, not the class of its parents. To match a class across the ancestry of an error, you'll need a bit of craftiness. Ancestry matching can't be done with \code{tryCatch()} at all so you'll need to switch to \code{\link[=withCallingHandlers]{withCallingHandlers()}}. Alternatively, you can use the experimental rlang function \code{\link[=try_fetch]{try_fetch()}} which is able to perform the roles of both \code{tryCatch()} and \code{withCallingHandlers()}. \subsection{\code{withCallingHandlers()}}{ Unlike \code{tryCatch()}, \code{withCallingHandlers()} does not capture an error. If you don't explicitly jump with an \emph{error} or a \emph{value} throw, nothing happens. Since we don't want to throw an error, we'll throw a value using \code{\link[=callCC]{callCC()}}: \if{html}{\out{
}}\preformatted{f <- function() \{ parent <- error_cnd("bar", message = "Bar") abort("Foo", parent = parent) \} cnd <- callCC(function(throw) \{ withCallingHandlers( f(), error = function(x) if (cnd_inherits(x, "bar")) throw(x) ) \}) class(cnd) #> [1] "rlang_error" "error" "condition" class(cnd$parent) #> [1] "bar" "rlang_error" "error" "condition" }\if{html}{\out{
}} } \subsection{\code{try_fetch()}}{ This pattern is easier with \code{\link[=try_fetch]{try_fetch()}}. Like \code{withCallingHandlers()}, it doesn't capture a matching error right away. Instead, it captures it only if the handler doesn't return a \code{\link[=zap]{zap()}} value. \if{html}{\out{
}}\preformatted{cnd <- try_fetch( f(), error = function(x) if (cnd_inherits(x, "bar")) x else zap() ) class(cnd) #> [1] "rlang_error" "error" "condition" class(cnd$parent) #> [1] "bar" "rlang_error" "error" "condition" }\if{html}{\out{
}} Note that \code{try_fetch()} uses \code{cnd_inherits()} internally. This makes it very easy to match a parent condition: \if{html}{\out{
}}\preformatted{cnd <- try_fetch( f(), bar = function(x) x ) # This is the parent class(cnd) #> [1] "bar" "rlang_error" "error" "condition" }\if{html}{\out{
}} } } rlang/man/env_cache.Rd0000644000176200001440000000174014375670676014361 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/env-binding.R \name{env_cache} \alias{env_cache} \title{Cache a value in an environment} \usage{ env_cache(env, nm, default) } \arguments{ \item{env}{An environment.} \item{nm}{Name of binding, a string.} \item{default}{The default value to store in \code{env} if \code{nm} does not exist yet.} } \value{ Either the value of \code{nm} or \code{default} if it did not exist yet. } \description{ \code{env_cache()} is a wrapper around \code{\link[=env_get]{env_get()}} and \code{\link[=env_poke]{env_poke()}} designed to retrieve a cached value from \code{env}. \itemize{ \item If the \code{nm} binding exists, it returns its value. \item Otherwise, it stores the default value in \code{env} and returns that. } } \examples{ e <- env(a = "foo") # Returns existing binding env_cache(e, "a", "default") # Creates a `b` binding and returns its default value env_cache(e, "b", "default") # Now `b` is defined e$b } rlang/man/string.Rd0000644000176200001440000000276214175213516013741 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/utils-encoding.R \name{string} \alias{string} \title{Create a string} \usage{ string(x, encoding = NULL) } \arguments{ \item{x}{A character vector or a vector or list of string-like objects.} \item{encoding}{If non-null, set an encoding mark. This is only declarative, no encoding conversion is performed.} } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} These base-type constructors allow more control over the creation of strings in R. They take character vectors or string-like objects (integerish or raw vectors), and optionally set the encoding. The string version checks that the input contains a scalar string. } \examples{ # As everywhere in R, you can specify a string with Unicode # escapes. The characters corresponding to Unicode codepoints will # be encoded in UTF-8, and the string will be marked as UTF-8 # automatically: cafe <- string("caf\uE9") Encoding(cafe) charToRaw(cafe) # In addition, string() provides useful conversions to let # programmers control how the string is represented in memory. For # encodings other than UTF-8, you'll need to supply the bytes in # hexadecimal form. If it is a latin1 encoding, you can mark the # string explicitly: cafe_latin1 <- string(c(0x63, 0x61, 0x66, 0xE9), "latin1") Encoding(cafe_latin1) charToRaw(cafe_latin1) } \keyword{internal} rlang/man/topic-quosure.Rd0000644000176200001440000002324514375670676015271 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/topic-nse.R \name{topic-quosure} \alias{topic-quosure} \title{What are quosures and when are they needed?} \description{ A quosure is a special type of \link[=topic-defuse]{defused expression} that keeps track of the original context the expression was written in. The tracking capabilities of quosures is important when interfacing \link[=topic-data-mask]{data-masking} functions together because the functions might come from two unrelated environments, like two different packages. } \section{Blending environments}{ Let's take an example where the R user calls the function \code{summarise_bmi()} from the foo package to summarise a data frame with statistics of a BMI value. Because the \code{height} variable of their data frame is not in metres, they use a custom function \code{div100()} to rescale the column. \if{html}{\out{
}}\preformatted{# Global environment of user div100 <- function(x) \{ x / 100 \} dplyr::starwars \%>\% foo::summarise_bmi(mass, div100(height)) }\if{html}{\out{
}} The \code{summarise_bmi()} function is a data-masking function defined in the namespace of the foo package which looks like this: \if{html}{\out{
}}\preformatted{# Namespace of package foo bmi <- function(mass, height) \{ mass / height^2 \} summarise_bmi <- function(data, mass, height) \{ data \%>\% bar::summarise_stats(bmi(\{\{ mass \}\}, \{\{ height \}\})) \} }\if{html}{\out{
}} The foo package uses the custom function \code{bmi()} to perform a computation on two vectors. It interfaces with \code{summarise_stats()} defined in bar, another package whose namespace looks like this: \if{html}{\out{
}}\preformatted{# Namespace of package bar check_numeric <- function(x) \{ stopifnot(is.numeric(x)) x \} summarise_stats <- function(data, var) \{ data \%>\% dplyr::transmute( var = check_numeric(\{\{ var \}\}) ) \%>\% dplyr::summarise( mean = mean(var, na.rm = TRUE), sd = sd(var, na.rm = TRUE) ) \} }\if{html}{\out{
}} Again the package bar uses a custom function, \code{check_numeric()}, to validate its input. It also interfaces with data-masking functions from dplyr (using the \link[=topic-double-evaluation]{define-a-constant} trick to avoid issues of double evaluation). There are three data-masking functions simultaneously interfacing in this snippet: \itemize{ \item At the bottom, \code{dplyr::transmute()} takes a data-masked input, and creates a data frame of a single column named \code{var}. \item Before this, \code{bar::summarise_stats()} takes a data-masked input inside \code{dplyr::transmute()} and checks it is numeric. \item And first of all, \code{foo::summarise_bmi()} takes two data-masked inputs inside \code{bar::summarise_stats()} and transforms them to a single BMI value. } There is a fourth context, the global environment where \code{summarise_bmi()} is called with two columns defined in a data frame, one of which is transformed on the fly with the user function \code{div100()}. All of these contexts (except to some extent the global environment) contain functions that are private and invisible to foreign functions. Yet, the final expanded data-masked expression that is evaluated down the line looks like this (with caret characters indicating the quosure boundaries): \if{html}{\out{
}}\preformatted{dplyr::transmute( var = ^check_numeric(^bmi(^mass, ^div100(height))) ) }\if{html}{\out{
}} The role of quosures is to let R know that \code{check_numeric()} should be found in the bar package, \code{bmi()} in the foo package, and \code{div100()} in the global environment. } \section{When should I create quosures?}{ As a tidyverse user you generally don't need to worry about quosures because \verb{\{\{} and \code{...} will create them for you. Introductory texts like \href{https://dplyr.tidyverse.org/articles/programming.html}{Programming with dplyr} or the \link[=topic-data-mask-programming]{standard data-mask programming patterns} don't even mention the term. In more complex cases you might need to create quosures with \code{\link[=enquo]{enquo()}} or \code{\link[=enquos]{enquos()}} (even though you generally don't need to know or care that these functions return quosures). In this section, we explore when quosures are necessary in these more advanced applications. \subsection{Foreign and local expressions}{ As a rule of thumb, quosures are only needed for arguments defused with \code{\link[=enquo]{enquo()}} or \code{\link[=enquos]{enquos()}} (or with \ifelse{html}{\code{\link[=embrace-operator]{\{\{}}}{\verb{\{\{}} which calls \code{enquo()} implicitly): \if{html}{\out{
}}\preformatted{my_function <- function(var) \{ var <- enquo(var) their_function(!!var) \} # Equivalently my_function <- function(var) \{ their_function(\{\{ var \}\}) \} }\if{html}{\out{
}} Wrapping defused arguments in quosures is needed because expressions supplied as argument comes from a different environment, the environment of your user. For local expressions created in your function, you generally don't need to create quosures: \if{html}{\out{
}}\preformatted{my_mean <- function(data, var) \{ # `expr()` is sufficient, no need for `quo()` expr <- expr(mean(\{\{ var \}\})) dplyr::summarise(data, !!expr) \} my_mean(mtcars, cyl) #> # A tibble: 1 x 1 #> `mean(cyl)` #> #> 1 6.19 }\if{html}{\out{
}} Using \code{\link[=quo]{quo()}} instead of \code{\link[=expr]{expr()}} would have worked too but it is superfluous because \code{dplyr::summarise()}, which uses \code{\link[=enquos]{enquos()}}, is already in charge of wrapping your expression within a quosure scoped in your environment. The same applies if you evaluate manually. By default, \code{\link[=eval]{eval()}} and \code{\link[=eval_tidy]{eval_tidy()}} capture your environment: \if{html}{\out{
}}\preformatted{my_mean <- function(data, var) \{ expr <- expr(mean(\{\{ var \}\})) eval_tidy(expr, data) \} my_mean(mtcars, cyl) #> [1] 6.1875 }\if{html}{\out{
}} } \subsection{External defusing}{ An exception to this rule of thumb (wrap foreign expressions in quosures, not your own expressions) arises when your function takes multiple expressions in a list instead of \code{...}. The preferred approach in that case is to take a tidy selection so that users can combine multiple columns using \code{c()}. If that is not possible, you can take a list of externally defused expressions: \if{html}{\out{
}}\preformatted{my_group_by <- function(data, vars) \{ stopifnot(is_quosures(vars)) data \%>\% dplyr::group_by(!!!vars) \} mtcars \%>\% my_group_by(dplyr::vars(cyl, am)) }\if{html}{\out{
}} In this pattern, \code{dplyr::vars()} defuses expressions externally. It creates a list of quosures because the expressions are passed around from function to function like regular arguments. In fact, \code{dplyr::vars()} and \code{ggplot2::vars()} are simple aliases of \code{\link[=quos]{quos()}}. \if{html}{\out{
}}\preformatted{dplyr::vars(cyl, am) #> > #> #> [[1]] #> #> expr: ^cyl #> env: global #> #> [[2]] #> #> expr: ^am #> env: global }\if{html}{\out{
}} For more information about external defusing, see \ifelse{html}{\link[=topic-multiple-columns]{Taking multiple columns without ...}}{\link[=topic-multiple-columns]{Taking multiple columns without ...}}. } } \section{Technical description of quosures}{ A quosure carries two things: \itemize{ \item An expression (get it with \code{\link[=quo_get_expr]{quo_get_expr()}}). \item An environment (get it with \code{\link[=quo_get_env]{quo_get_env()}}). } And implements these behaviours: \itemize{ \item It is \emph{callable}. Evaluation produces a result. For historical reasons, \code{\link[base:eval]{base::eval()}} doesn't support quosure evaluation. Quosures currently require \code{\link[=eval_tidy]{eval_tidy()}}. We would like to fix this limitation in the future. \item It is \emph{hygienic}. It evaluates in the tracked environment. \item It is \emph{maskable}. If evaluated in a data mask (currently only masks created with \code{\link[=eval_tidy]{eval_tidy()}} or \code{\link[=new_data_mask]{new_data_mask()}}), the mask comes first in scope before the quosure environment. Conceptually, a quosure inherits from two chains of environments, the data mask and the user environment. In practice rlang implements this special scoping by rechaining the top of the data mask to the quosure environment currently under evaluation. } There are similarities between promises (the ones R uses to implement lazy evaluation, not the async expressions from the promises package) and quosures. One important difference is that promises are only evaluated once and cache the result for subsequent evaluation. Quosures behave more like calls and can be evaluated repeatedly, potentially in a different data mask. This property is useful to implement split-apply-combine evaluations. } \section{See also}{ \itemize{ \item \code{\link[=enquo]{enquo()}} and \code{\link[=enquos]{enquos()}} to defuse function arguments as quosures. This is the main way quosures are created. \item \code{\link[=quo]{quo()}} which is like \code{\link[=expr]{expr()}} but wraps in a quosure. Usually it is not needed to wrap local expressions yourself. \item \code{\link[=quo_get_expr]{quo_get_expr()}} and \code{\link[=quo_get_env]{quo_get_env()}} to access quosure components. \item \code{\link[=new_quosure]{new_quosure()}} and \code{\link[=as_quosure]{as_quosure()}} to assemble a quosure from components. } } \keyword{internal} rlang/man/obj_address.Rd0000644000176200001440000000050014175213516014676 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/obj.R \name{obj_address} \alias{obj_address} \title{Address of an R object} \usage{ obj_address(x) } \arguments{ \item{x}{Any R object.} } \value{ Its address in memory in a string. } \description{ Address of an R object } \keyword{internal} rlang/man/vector-construction.Rd0000644000176200001440000000412414375670676016477 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/vec-new.R \name{vector-construction} \alias{vector-construction} \alias{lgl} \alias{int} \alias{dbl} \alias{cpl} \alias{chr} \alias{bytes} \title{Create vectors} \usage{ lgl(...) int(...) dbl(...) cpl(...) chr(...) bytes(...) } \arguments{ \item{...}{Components of the new vector. Bare lists and explicitly spliced lists are spliced.} } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#questioning}{\figure{lifecycle-questioning.svg}{options: alt='[Questioning]'}}}{\strong{[Questioning]}} The atomic vector constructors are equivalent to \code{\link[=c]{c()}} but: \itemize{ \item They allow you to be more explicit about the output type. Implicit coercions (e.g. from integer to logical) follow the rules described in \link{vector-coercion}. \item They use \link[=dyn-dots]{dynamic dots}. } } \section{Life cycle}{ \itemize{ \item All the abbreviated constructors such as \code{lgl()} will probably be moved to the vctrs package at some point. This is why they are marked as questioning. \item Automatic splicing is soft-deprecated and will trigger a warning in a future version. Please splice explicitly with \verb{!!!}. } } \examples{ # These constructors are like a typed version of c(): c(TRUE, FALSE) lgl(TRUE, FALSE) # They follow a restricted set of coercion rules: int(TRUE, FALSE, 20) # Lists can be spliced: dbl(10, !!! list(1, 2L), TRUE) # They splice names a bit differently than c(). The latter # automatically composes inner and outer names: c(a = c(A = 10), b = c(B = 20, C = 30)) # On the other hand, rlang's constructors use the inner names and issue a # warning to inform the user that the outer names are ignored: dbl(a = c(A = 10), b = c(B = 20, C = 30)) dbl(a = c(1, 2)) # As an exception, it is allowed to provide an outer name when the # inner vector is an unnamed scalar atomic: dbl(a = 1) # Spliced lists behave the same way: dbl(!!! list(a = 1)) dbl(!!! list(a = c(A = 1))) # bytes() accepts integerish inputs bytes(1:10) bytes(0x01, 0xff, c(0x03, 0x05), list(10, 20, 30L)) } rlang/man/caller_arg.Rd0000644000176200001440000000215414375670676014541 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cnd-abort.R \name{caller_arg} \alias{caller_arg} \title{Find the caller argument for error messages} \arguments{ \item{arg}{An argument name in the current function.} } \description{ \code{caller_arg()} is a variant of \code{substitute()} or \code{\link[=ensym]{ensym()}} for arguments that reference other arguments. Unlike \code{substitute()} which returns an expression, \code{caller_arg()} formats the expression as a single line string which can be included in error messages. \itemize{ \item When included in an error message, the resulting label should generally be formatted as argument, for instance using the \code{.arg} in the cli package. \item Use \verb{@inheritParams rlang::args_error_context} to document an \code{arg} or \code{error_arg} argument that takes \code{error_arg()} as default. } } \examples{ arg_checker <- function(x, arg = caller_arg(x), call = caller_env()) { cli::cli_abort("{.arg {arg}} must be a thingy.", arg = arg, call = call) } my_function <- function(my_arg) { arg_checker(my_arg) } try(my_function(NULL)) } rlang/man/names_inform_repair.Rd0000644000176200001440000000204514375670676016464 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/names.R \name{names_inform_repair} \alias{names_inform_repair} \title{Inform about name repair} \usage{ names_inform_repair(old, new) } \arguments{ \item{old}{Original names vector.} \item{new}{Repaired names vector.} } \description{ Inform about name repair } \section{Muffling and silencing messages}{ Name repair messages are signaled with \code{\link[=inform]{inform()}} and are given the class \code{"rlib_message_name_repair"}. These messages can be muffled with \code{\link[base:message]{base::suppressMessages()}}. Name repair messages can also be silenced with the global option \code{rlib_name_repair_verbosity}. This option takes the values: \itemize{ \item \code{"verbose"}: Always verbose. \item \code{"quiet"}: Always quiet. } When set to quiet, the message is not displayed and the condition is not signaled. This is particularly useful for silencing messages during testing when combined with \code{\link[=local_options]{local_options()}}. } \keyword{internal} rlang/man/check_dots_empty0.Rd0000644000176200001440000000123414375670676016050 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/dots-ellipsis.R \name{check_dots_empty0} \alias{check_dots_empty0} \title{Check that dots are empty (low level variant)} \usage{ check_dots_empty0(..., call = caller_env()) } \arguments{ \item{...}{Dots which should be empty.} } \description{ \code{check_dots_empty0()} is a more efficient version of \code{\link[=check_dots_empty]{check_dots_empty()}} with a slightly different interface. Instead of inspecting the current environment for dots, it directly takes \code{...}. It is only meant for very low level functions where a couple microseconds make a difference. } \keyword{internal} rlang/man/global_prompt_install.Rd0000644000176200001440000000142114375670676017031 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cnd-handlers.R \name{global_prompt_install} \alias{global_prompt_install} \title{Prompt user to install missing packages} \usage{ global_prompt_install(enable = TRUE) } \arguments{ \item{enable}{Whether to enable or disable global handling.} } \description{ When enabled, \code{packageNotFoundError} thrown by \code{\link[=loadNamespace]{loadNamespace()}} cause a user prompt to install the missing package and continue without interrupting the current program. This is similar to how \code{\link[=check_installed]{check_installed()}} prompts users to install required packages. It uses the same install strategy, using pak if available and \code{\link[=install.packages]{install.packages()}} otherwise. } rlang/man/topic-inject-out-of-context.Rd0000644000176200001440000000755414741441453017722 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/topic-nse.R \name{topic-inject-out-of-context} \alias{topic-inject-out-of-context} \title{What happens if I use injection operators out of context?} \description{ The \link[=topic-inject]{injection operators} \ifelse{html}{\code{\link[=embrace-operator]{\{\{}}}{\verb{\{\{}}, \code{\link[=injection-operator]{!!}}, and \code{\link[=splice-operator]{!!!}} are an extension of the R syntax developed for tidyverse packages. Because they are not part of base R, they suffer from some limitations. In particular no specific error is thrown when they are used in unexpected places. \subsection{Using \verb{\{\{} out of context}{ The embrace operator \ifelse{html}{\code{\link[=embrace-operator]{\{\{}}}{\verb{\{\{}} is a feature available in \link[=topic-data-mask]{data-masked} arguments powered by tidy eval. If you use it elsewhere, it is interpreted as a double \verb{\{} wrapping. In the R language, \verb{\{} is like \code{(} but takes multiple expressions instead of one: \if{html}{\out{
}}\preformatted{\{ 1 # Discarded 2 \} #> [1] 2 list( \{ message("foo"); 2 \} ) #> foo #> [[1]] #> [1] 2 }\if{html}{\out{
}} Just like you can wrap an expression in as many parentheses as you'd like, you can wrap multiple times with braces: \if{html}{\out{
}}\preformatted{((1)) #> [1] 1 \{\{ 2 \}\} #> [1] 2 }\if{html}{\out{
}} So nothing prevents you from embracing a function argument in a context where this operation is not implemented. R will just treat the braces like a set of parentheses and silently return the result: \if{html}{\out{
}}\preformatted{f <- function(arg) list(\{\{ arg \}\}) f(1) #> [[1]] #> [1] 1 }\if{html}{\out{
}} This sort of no-effect embracing should be avoided in real code because it falsely suggests that the function supports the tidy eval operator and that something special is happening. However in many cases embracing is done to implement \link[=topic-data-mask]{data masking}. It is likely that the function will be called with data-variables references which R won't be able to resolve properly: \if{html}{\out{
}}\preformatted{my_mean <- function(data, var) \{ with(data, mean(\{\{ var \}\})) \} my_mean(mtcars, cyl) #> Error: #> ! object 'cyl' not found }\if{html}{\out{
}} Since \code{\link[=with]{with()}} is a base data-masking function that doesn't support tidy eval operators, the embrace operator does not work and we get an object not found error. } \subsection{Using \verb{!!} and \verb{!!!} out of context}{ The injection operators \code{\link{!!}} and \code{\link{!!!}} are implemented in \link[=topic-data-mask]{data-masked} arguments, \link[=dyn-dots]{dynamic dots}, and within \code{\link[=inject]{inject()}}. When used in other contexts, they are interpreted by R as double and triple \emph{negations}. Double negation can be used in ordinary code to convert an input to logical: \if{html}{\out{
}}\preformatted{!!10 #> [1] TRUE !!0 #> [1] FALSE }\if{html}{\out{
}} Triple negation is essentially the same as simple negation: \if{html}{\out{
}}\preformatted{!10 #> [1] FALSE !!!10 #> [1] FALSE }\if{html}{\out{
}} This means that when injection operators are used in the wrong place, they will be interpreted as negation. In the best case scenario you will get a type error: \if{html}{\out{
}}\preformatted{!"foo" #> Error in `!"foo"`: #> ! invalid argument type !quote(foo) #> Error in `!quote(foo)`: #> ! invalid argument type !quote(foo()) #> Error in `!quote(foo())`: #> ! invalid argument type }\if{html}{\out{
}} In the worst case, R will silently convert the input to logical. Unfortunately there is no systematic way of checking for these errors. } } \keyword{internal} rlang/man/local_bindings.Rd0000644000176200001440000000301014127057575015375 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/env-binding.R \name{local_bindings} \alias{local_bindings} \alias{with_bindings} \title{Temporarily change bindings of an environment} \usage{ local_bindings(..., .env = .frame, .frame = caller_env()) with_bindings(.expr, ..., .env = caller_env()) } \arguments{ \item{...}{Pairs of names and values. These dots support splicing (with value semantics) and name unquoting.} \item{.env}{An environment.} \item{.frame}{The frame environment that determines the scope of the temporary bindings. When that frame is popped from the call stack, bindings are switched back to their original values.} \item{.expr}{An expression to evaluate with temporary bindings.} } \value{ \code{local_bindings()} returns the values of old bindings invisibly; \code{with_bindings()} returns the value of \code{expr}. } \description{ \itemize{ \item \code{local_bindings()} temporarily changes bindings in \code{.env} (which is by default the caller environment). The bindings are reset to their original values when the current frame (or an arbitrary one if you specify \code{.frame}) goes out of scope. \item \code{with_bindings()} evaluates \code{expr} with temporary bindings. When \code{with_bindings()} returns, bindings are reset to their original values. It is a simple wrapper around \code{local_bindings()}. } } \examples{ foo <- "foo" bar <- "bar" # `foo` will be temporarily rebinded while executing `expr` with_bindings(paste(foo, bar), foo = "rebinded") paste(foo, bar) } rlang/man/topic-double-evaluation.Rd0000644000176200001440000001005114376101222017145 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/topic-nse.R \name{topic-double-evaluation} \alias{topic-double-evaluation} \title{The double evaluation problem} \description{ One inherent risk to metaprogramming is to evaluate multiple times a piece of code that appears to be evaluated only once. Take this data-masking function which takes a single input and produces two summaries: \if{html}{\out{
}}\preformatted{summarise_stats <- function(data, var) \{ data \%>\% dplyr::summarise( mean = mean(\{\{ var \}\}), sd = sd(\{\{ var \}\}) ) \} summarise_stats(mtcars, cyl) #> # A tibble: 1 x 2 #> mean sd #> #> 1 6.19 1.79 }\if{html}{\out{
}} This function is perfectly fine if the user supplies simple column names. However, data-masked arguments may also include \emph{computations}. \if{html}{\out{
}}\preformatted{summarise_stats(mtcars, cyl * 100) #> # A tibble: 1 x 2 #> mean sd #> #> 1 619. 179. }\if{html}{\out{
}} Computations may be slow and may produce side effects. For these reasons, they should only be performed as many times as they appear in the code (unless explicitly documented, e.g. once per group with grouped data frames). Let's try again with a more complex computation: \if{html}{\out{
}}\preformatted{times100 <- function(x) \{ message("Takes a long time...") Sys.sleep(0.1) message("And causes side effects such as messages!") x * 100 \} summarise_stats(mtcars, times100(cyl)) #> Takes a long time... #> And causes side effects such as messages! #> Takes a long time... #> And causes side effects such as messages! #> # A tibble: 1 x 2 #> mean sd #> #> 1 619. 179. }\if{html}{\out{
}} Because of the side effects and the long running time, it is clear that \code{summarise_stats()} evaluates its input twice. This is because we've injected a defused expression in two different places. The data-masked expression created down the line looks like this (with caret signs representing \link[=topic-quosure]{quosure} boundaries): \if{html}{\out{
}}\preformatted{dplyr::summarise( mean = ^mean(^times100(cyl)), sd = ^sd(^times100(cyl)) ) }\if{html}{\out{
}} The \code{times100(cyl)} expression is evaluated twice, even though it only appears once in the code. We have a double evaluation bug. One simple way to fix it is to assign the defused input to a constant. You can then refer to that constant in the remaining of the code. \if{html}{\out{
}}\preformatted{summarise_stats <- function(data, var) \{ data \%>\% dplyr::transmute( var = \{\{ var \}\}, ) \%>\% dplyr::summarise( mean = mean(var), sd = sd(var) ) \} }\if{html}{\out{
}} The defused input is now evaluated only once because it is injected only once: \if{html}{\out{
}}\preformatted{summarise_stats(mtcars, times100(cyl)) #> Takes a long time... #> And causes side effects such as messages! #> # A tibble: 1 x 2 #> mean sd #> #> 1 619. 179. }\if{html}{\out{
}} } \section{What about glue strings?}{ \verb{\{\{} \link[=glue-operators]{embracing in glue strings} doesn't suffer from the double evaluation problem: \if{html}{\out{
}}\preformatted{summarise_stats <- function(data, var) \{ data \%>\% dplyr::transmute( var = \{\{ var \}\}, ) \%>\% dplyr::summarise( "mean_\{\{ var \}\}" := mean(var), "sd_\{\{ var \}\}" := sd(var) ) \} summarise_stats(mtcars, times100(cyl)) #> Takes a long time... #> And causes side effects such as messages! #> # A tibble: 1 x 2 #> `mean_times100(cyl)` `sd_times100(cyl)` #> #> 1 619. 179. }\if{html}{\out{
}} Since a glue string doesn't need the result of an expression, only the original code converted (deparsed) to a string, it doesn't evaluate injected expressions. } \keyword{internal} rlang/man/lang.Rd0000644000176200001440000000145214375670676013367 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/lifecycle-deprecated.R \name{lang} \alias{lang} \title{Create a call} \usage{ lang(.fn, ..., .ns = NULL) } \arguments{ \item{.fn}{Function to call. Must be a callable object: a string, symbol, call, or a function.} \item{...}{<\link[=dyn-dots]{dynamic}> Arguments for the function call. Empty arguments are preserved.} \item{.ns}{Namespace with which to prefix \code{.fn}. Must be a string or symbol.} } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} These functions are deprecated, please use \code{\link[=call2]{call2()}} and \code{\link[=new_call]{new_call()}} instead. } \keyword{internal} rlang/man/cnd.Rd0000644000176200001440000000455214375670676013216 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cnd.R \name{cnd} \alias{cnd} \alias{error_cnd} \alias{warning_cnd} \alias{message_cnd} \title{Create a condition object} \usage{ cnd(class, ..., message = "", call = NULL, use_cli_format = NULL) error_cnd( class = NULL, ..., message = "", call = NULL, trace = NULL, parent = NULL, use_cli_format = NULL ) warning_cnd( class = NULL, ..., message = "", call = NULL, use_cli_format = NULL ) message_cnd( class = NULL, ..., message = "", call = NULL, use_cli_format = NULL ) } \arguments{ \item{class}{The condition subclass.} \item{...}{<\link[=dyn-dots]{dynamic}> Named data fields stored inside the condition object.} \item{message}{A default message to inform the user about the condition when it is signalled.} \item{call}{A function call to be included in the error message. If an execution environment of a running function, the corresponding function call is retrieved.} \item{use_cli_format}{Whether to use the cli package to format \code{message}. See \code{\link[=local_use_cli]{local_use_cli()}}.} \item{trace}{A \code{trace} object created by \code{\link[=trace_back]{trace_back()}}.} \item{parent}{A parent condition object.} } \description{ These constructors create subclassed conditions, the objects that power the error, warning, and message system in R. \itemize{ \item \code{cnd()} creates bare conditions that only inherit from \code{condition}. \item Conditions created with \code{error_cnd()}, \code{warning_cnd()}, and \code{message_cnd()} inherit from \code{"error"}, \code{"warning"}, or \code{"message"}. \item \code{error_cnd()} creates subclassed errors. See \code{\link[=rlang_error]{"rlang_error"}}. } Use \code{\link[=cnd_signal]{cnd_signal()}} to emit the relevant signal for a particular condition class. } \examples{ # Create a condition inheriting only from the S3 class "foo": cnd <- cnd("foo") # Signal the condition to potential handlers. Since this is a bare # condition the signal has no effect if no handlers are set up: cnd_signal(cnd) # When a relevant handler is set up, the signal transfers control # to the handler with_handlers(cnd_signal(cnd), foo = function(c) "caught!") tryCatch(cnd_signal(cnd), foo = function(c) "caught!") } \seealso{ \code{\link[=cnd_signal]{cnd_signal()}}, \code{\link[=try_fetch]{try_fetch()}}. } \keyword{internal} rlang/man/ns_env.Rd0000644000176200001440000000175114515704013013713 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/env-special.R \name{ns_env} \alias{ns_env} \alias{ns_imports_env} \alias{ns_env_name} \title{Get the namespace of a package} \usage{ ns_env(x = caller_env()) ns_imports_env(x = caller_env()) ns_env_name(x = caller_env()) } \arguments{ \item{x}{\itemize{ \item For \code{ns_env()}, the name of a package or an environment as a string. \itemize{ \item An environment (the current environment by default). \item A function. } In the latter two cases, the environment ancestry is searched for a namespace with \code{\link[base:ns-topenv]{base::topenv()}}. If the environment doesn't inherit from a namespace, this is an error. }} } \description{ Namespaces are the environment where all the functions of a package live. The parent environments of namespaces are the \code{imports} environments, which contain all the functions imported from other packages. } \seealso{ \code{\link[=pkg_env]{pkg_env()}} } \keyword{internal} rlang/man/eval_tidy.Rd0000644000176200001440000001160714375670676014431 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/eval-tidy.R \name{eval_tidy} \alias{eval_tidy} \title{Evaluate an expression with quosures and pronoun support} \usage{ eval_tidy(expr, data = NULL, env = caller_env()) } \arguments{ \item{expr}{An \link[=topic-defuse]{expression} or \link[=topic-quosure]{quosure} to evaluate.} \item{data}{A data frame, or named list or vector. Alternatively, a data mask created with \code{\link[=as_data_mask]{as_data_mask()}} or \code{\link[=new_data_mask]{new_data_mask()}}. Objects in \code{data} have priority over those in \code{env}. See the section about data masking.} \item{env}{The environment in which to evaluate \code{expr}. This environment is not applicable for quosures because they have their own environments.} } \description{ \code{eval_tidy()} is a variant of \code{\link[base:eval]{base::eval()}} that powers the tidy evaluation framework. Like \code{eval()} it accepts user data as argument. Whereas \code{eval()} simply transforms the data to an environment, \code{eval_tidy()} transforms it to a \link[=topic-data-mask]{data mask} with \code{\link[=as_data_mask]{as_data_mask()}}. Evaluating in a data mask enables the following features: \itemize{ \item \link[=topic-quosure]{Quosures}. Quosures are expressions bundled with an environment. If \code{data} is supplied, objects in the data mask always have precedence over the quosure environment, i.e. the data masks the environment. \item \link[=.data]{Pronouns}. If \code{data} is supplied, the \code{.env} and \code{.data} pronouns are installed in the data mask. \code{.env} is a reference to the calling environment and \code{.data} refers to the \code{data} argument. These pronouns are an escape hatch for the \link[=topic-data-mask-ambiguity]{data mask ambiguity} problem. } } \section{When should eval_tidy() be used instead of eval()?}{ \code{base::eval()} is sufficient for simple evaluation. Use \code{eval_tidy()} when you'd like to support expressions referring to the \code{.data} pronoun, or when you need to support quosures. If you're evaluating an expression captured with \link[=topic-inject]{injection} support, it is recommended to use \code{eval_tidy()} because users may inject quosures. Note that unwrapping a quosure with \code{\link[=quo_get_expr]{quo_get_expr()}} does not guarantee that there is no quosures inside the expression. Quosures might be unquoted anywhere in the expression tree. For instance, the following does not work reliably in the presence of nested quosures: \if{html}{\out{
}}\preformatted{my_quoting_fn <- function(x) \{ x <- enquo(x) expr <- quo_get_expr(x) env <- quo_get_env(x) eval(expr, env) \} # Works: my_quoting_fn(toupper(letters)) # Fails because of a nested quosure: my_quoting_fn(toupper(!!quo(letters))) }\if{html}{\out{
}} } \section{Stack semantics of \code{eval_tidy()}}{ \code{eval_tidy()} always evaluates in a data mask, even when \code{data} is \code{NULL}. Because of this, it has different stack semantics than \code{\link[base:eval]{base::eval()}}: \itemize{ \item Lexical side effects, such as assignment with \verb{<-}, occur in the mask rather than \code{env}. \item Functions that require the evaluation environment to correspond to a frame on the call stack do not work. This is why \code{return()} called from a quosure does not work. \item The mask environment creates a new branch in the tree representation of backtraces (which you can visualise in a \code{\link[=browser]{browser()}} session with \code{lobstr::cst()}). } See also \code{\link[=eval_bare]{eval_bare()}} for more information about these differences. } \examples{ # With simple defused expressions eval_tidy() works the same way as # eval(): fruit <- "apple" vegetable <- "potato" expr <- quote(paste(fruit, vegetable, sep = " or ")) expr eval(expr) eval_tidy(expr) # Both accept a data mask as argument: data <- list(fruit = "banana", vegetable = "carrot") eval(expr, data) eval_tidy(expr, data) # The main difference is that eval_tidy() supports quosures: with_data <- function(data, expr) { quo <- enquo(expr) eval_tidy(quo, data) } with_data(NULL, fruit) with_data(data, fruit) # eval_tidy() installs the `.data` and `.env` pronouns to allow # users to be explicit about variable references: with_data(data, .data$fruit) with_data(data, .env$fruit) } \seealso{ \itemize{ \item \ifelse{html}{\link[=topic-data-mask]{What is data-masking and why do I need \{\{?}}{\link[=topic-data-mask]{What is data-masking and why do I need curly-curly?}}. \item \ifelse{html}{\link[=topic-quosure]{What are quosures and when are they needed?}}{\link[=topic-quosure]{What are quosures and when are they needed?}}. \item \ifelse{html}{\link[=topic-defuse]{Defusing R expressions}}{\link[=topic-defuse]{Defusing R expressions}}. \item \code{\link[=new_data_mask]{new_data_mask()}} and \code{\link[=as_data_mask]{as_data_mask()}} for manually creating data masks. } } rlang/man/is_call.Rd0000644000176200001440000000510214375670676014050 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/call.R \name{is_call} \alias{is_call} \title{Is object a call?} \usage{ is_call(x, name = NULL, n = NULL, ns = NULL) } \arguments{ \item{x}{An object to test. Formulas and quosures are treated literally.} \item{name}{An optional name that the call should match. It is passed to \code{\link[=sym]{sym()}} before matching. This argument is vectorised and you can supply a vector of names to match. In this case, \code{is_call()} returns \code{TRUE} if at least one name matches.} \item{n}{An optional number of arguments that the call should match.} \item{ns}{The namespace of the call. If \code{NULL}, the namespace doesn't participate in the pattern-matching. If an empty string \code{""} and \code{x} is a namespaced call, \code{is_call()} returns \code{FALSE}. If any other string, \code{is_call()} checks that \code{x} is namespaced within \code{ns}. Can be a character vector of namespaces, in which case the call has to match at least one of them, otherwise \code{is_call()} returns \code{FALSE}.} } \description{ This function tests if \code{x} is a \link[=call2]{call}. This is a pattern-matching predicate that returns \code{FALSE} if \code{name} and \code{n} are supplied and the call does not match these properties. } \examples{ is_call(quote(foo(bar))) # You can pattern-match the call with additional arguments: is_call(quote(foo(bar)), "foo") is_call(quote(foo(bar)), "bar") is_call(quote(foo(bar)), quote(foo)) # Match the number of arguments with is_call(): is_call(quote(foo(bar)), "foo", 1) is_call(quote(foo(bar)), "foo", 2) # By default, namespaced calls are tested unqualified: ns_expr <- quote(base::list()) is_call(ns_expr, "list") # You can also specify whether the call shouldn't be namespaced by # supplying an empty string: is_call(ns_expr, "list", ns = "") # Or if it should have a namespace: is_call(ns_expr, "list", ns = "utils") is_call(ns_expr, "list", ns = "base") # You can supply multiple namespaces: is_call(ns_expr, "list", ns = c("utils", "base")) is_call(ns_expr, "list", ns = c("utils", "stats")) # If one of them is "", unnamespaced calls will match as well: is_call(quote(list()), "list", ns = "base") is_call(quote(list()), "list", ns = c("base", "")) is_call(quote(base::list()), "list", ns = c("base", "")) # The name argument is vectorised so you can supply a list of names # to match with: is_call(quote(foo(bar)), c("bar", "baz")) is_call(quote(foo(bar)), c("bar", "foo")) is_call(quote(base::list), c("::", ":::", "$", "@")) } \seealso{ \code{\link[=is_expression]{is_expression()}} } rlang/man/missing_arg.Rd0000644000176200001440000001263414741441453014736 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/arg.R \name{missing_arg} \alias{missing_arg} \alias{is_missing} \alias{maybe_missing} \title{Generate or handle a missing argument} \usage{ missing_arg() is_missing(x) maybe_missing(x, default = missing_arg()) } \arguments{ \item{x}{An object that might be the missing argument.} \item{default}{The object to return if the input is missing, defaults to \code{missing_arg()}.} } \description{ These functions help using the missing argument as a regular R object. \itemize{ \item \code{missing_arg()} generates a missing argument. \item \code{is_missing()} is like \code{\link[base:missing]{base::missing()}} but also supports testing for missing arguments contained in other objects like lists. It is also more consistent with default arguments which are never treated as missing (see section below). \item \code{maybe_missing()} is useful to pass down an input that might be missing to another function, potentially substituting by a default value. It avoids triggering an "argument is missing" error. } } \section{Other ways to reify the missing argument}{ \itemize{ \item \code{base::quote(expr = )} is the canonical way to create a missing argument object. \item \code{expr()} called without argument creates a missing argument. \item \code{quo()} called without argument creates an empty quosure, i.e. a quosure containing the missing argument object. } } \section{\code{is_missing()} and default arguments}{ The base function \code{\link[=missing]{missing()}} makes a distinction between default values supplied explicitly and default values generated through a missing argument: \if{html}{\out{
}}\preformatted{fn <- function(x = 1) base::missing(x) fn() #> [1] TRUE fn(1) #> [1] FALSE }\if{html}{\out{
}} This only happens within a function. If the default value has been generated in a calling function, it is never treated as missing: \if{html}{\out{
}}\preformatted{caller <- function(x = 1) fn(x) caller() #> [1] FALSE }\if{html}{\out{
}} \code{rlang::is_missing()} simplifies these rules by never treating default arguments as missing, even in internal contexts: \if{html}{\out{
}}\preformatted{fn <- function(x = 1) rlang::is_missing(x) fn() #> [1] FALSE fn(1) #> [1] FALSE }\if{html}{\out{
}} This is a little less flexible because you can't specialise behaviour based on implicitly supplied default values. However, this makes the behaviour of \code{is_missing()} and functions using it simpler to understand. } \section{Fragility of the missing argument object}{ The missing argument is an object that triggers an error if and only if it is the result of evaluating a symbol. No error is produced when a function call evaluates to the missing argument object. For instance, it is possible to bind the missing argument to a variable with an expression like \code{x[[1]] <- missing_arg()}. Likewise, \code{x[[1]]} is safe to use as argument, e.g. \code{list(x[[1]])} even when the result is the missing object. However, as soon as the missing argument is passed down between functions through a bare variable, it is likely to cause a missing argument error: \if{html}{\out{
}}\preformatted{x <- missing_arg() list(x) #> Error: #> ! argument "x" is missing, with no default }\if{html}{\out{
}} To work around this, \code{is_missing()} and \code{maybe_missing(x)} use a bit of magic to determine if the input is the missing argument without triggering a missing error. \if{html}{\out{
}}\preformatted{x <- missing_arg() list(maybe_missing(x)) #> [[1]] #> }\if{html}{\out{
}} \code{maybe_missing()} is particularly useful for prototyping meta-programming algorithms in R. The missing argument is a likely input when computing on the language because it is a standard object in formals lists. While C functions are always allowed to return the missing argument and pass it to other C functions, this is not the case on the R side. If you're implementing your meta-programming algorithm in R, use \code{maybe_missing()} when an input might be the missing argument object. } \examples{ # The missing argument usually arises inside a function when the # user omits an argument that does not have a default: fn <- function(x) is_missing(x) fn() # Creating a missing argument can also be useful to generate calls args <- list(1, missing_arg(), 3, missing_arg()) quo(fn(!!! args)) # Other ways to create that object include: quote(expr = ) expr() # It is perfectly valid to generate and assign the missing # argument in a list. x <- missing_arg() l <- list(missing_arg()) # Just don't evaluate a symbol that contains the empty argument. # Evaluating the object `x` that we created above would trigger an # error. # x # Not run # On the other hand accessing a missing argument contained in a # list does not trigger an error because subsetting is a function # call: l[[1]] is.null(l[[1]]) # In case you really need to access a symbol that might contain the # empty argument object, use maybe_missing(): maybe_missing(x) is.null(maybe_missing(x)) is_missing(maybe_missing(x)) # Note that base::missing() only works on symbols and does not # support complex expressions. For this reason the following lines # would throw an error: #> missing(missing_arg()) #> missing(l[[1]]) # while is_missing() will work as expected: is_missing(missing_arg()) is_missing(l[[1]]) } rlang/man/seq2.Rd0000644000176200001440000000147014127057575013310 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/vec.R \name{seq2} \alias{seq2} \alias{seq2_along} \title{Increasing sequence of integers in an interval} \usage{ seq2(from, to) seq2_along(from, x) } \arguments{ \item{from}{The starting point of the sequence.} \item{to}{The end point.} \item{x}{A vector whose length is the end point.} } \value{ An integer vector containing a strictly increasing sequence. } \description{ These helpers take two endpoints and return the sequence of all integers within that interval. For \code{seq2_along()}, the upper endpoint is taken from the length of a vector. Unlike \code{base::seq()}, they return an empty vector if the starting point is a larger integer than the end point. } \examples{ seq2(2, 10) seq2(10, 2) seq(10, 2) seq2_along(10, letters) } rlang/man/has_name.Rd0000644000176200001440000000151414127057575014210 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/attr.R \name{has_name} \alias{has_name} \title{Does an object have an element with this name?} \usage{ has_name(x, name) } \arguments{ \item{x}{A data frame or another named object} \item{name}{Element name(s) to check} } \value{ A logical vector of the same length as \code{name} } \description{ This function returns a logical value that indicates if a data frame or another named object contains an element with a specific name. Note that \code{has_name()} only works with vectors. For instance, environments need the specialised function \code{\link[=env_has]{env_has()}}. } \details{ Unnamed objects are treated as if all names are empty strings. \code{NA} input gives \code{FALSE} as output. } \examples{ has_name(iris, "Species") has_name(mtcars, "gears") } rlang/man/as_function.Rd0000644000176200001440000000366614375670676014767 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/fn.R \name{as_function} \alias{as_function} \alias{is_lambda} \title{Convert to function} \usage{ as_function( x, env = global_env(), ..., arg = caller_arg(x), call = caller_env() ) is_lambda(x) } \arguments{ \item{x}{A function or formula. If a \strong{function}, it is used as is. If a \strong{formula}, e.g. \code{~ .x + 2}, it is converted to a function with up to two arguments: \code{.x} (single argument) or \code{.x} and \code{.y} (two arguments). The \code{.} placeholder can be used instead of \code{.x}. This allows you to create very compact anonymous functions (lambdas) with up to two inputs. Functions created from formulas have a special class. Use \code{is_lambda()} to test for it. If a \strong{string}, the function is looked up in \code{env}. Note that this interface is strictly for user convenience because of the scoping issues involved. Package developers should avoid supplying functions by name and instead supply them by value.} \item{env}{Environment in which to fetch the function in case \code{x} is a string.} \item{...}{These dots are for future extensions and must be empty.} \item{arg}{An argument name as a string. This argument will be mentioned in error messages as the input that is at the origin of a problem.} \item{call}{The execution environment of a currently running function, e.g. \code{caller_env()}. The function will be mentioned in error messages as the source of the error. See the \code{call} argument of \code{\link[=abort]{abort()}} for more information.} } \description{ \code{as_function()} transforms a one-sided formula into a function. This powers the lambda syntax in packages like purrr. } \examples{ f <- as_function(~ .x + 1) f(10) g <- as_function(~ -1 * .) g(4) h <- as_function(~ .x - .y) h(6, 3) # Functions created from a formula have a special class: is_lambda(f) is_lambda(as_function(function() "foo")) } rlang/man/parse_expr.Rd0000644000176200001440000000755214422712073014602 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/parse.R \name{parse_expr} \alias{parse_expr} \alias{parse_exprs} \alias{parse_quo} \alias{parse_quos} \title{Parse R code} \usage{ parse_expr(x) parse_exprs(x) parse_quo(x, env) parse_quos(x, env) } \arguments{ \item{x}{Text containing expressions to parse_expr for \code{parse_expr()} and \code{parse_exprs()}. Can also be an R connection, for instance to a file. If the supplied connection is not open, it will be automatically closed and destroyed.} \item{env}{The environment for the quosures. The \link[=global_env]{global environment} (the default) may be the right choice when you are parsing external user inputs. You might also want to evaluate the R code in an isolated context (perhaps a child of the global environment or of the \link[=base_env]{base environment}).} } \value{ \code{parse_expr()} returns an \link[=is_expression]{expression}, \code{parse_exprs()} returns a list of expressions. Note that for the plural variants the length of the output may be greater than the length of the input. This would happen is one of the strings contain several expressions (such as \code{"foo; bar"}). The names of \code{x} are preserved (and recycled in case of multiple expressions). The \verb{_quo} suffixed variants return quosures. } \description{ These functions parse and transform text into R expressions. This is the first step to interpret or evaluate a piece of R code written by a programmer. \itemize{ \item \code{parse_expr()} returns one expression. If the text contains more than one expression (separated by semicolons or new lines), an error is issued. On the other hand \code{parse_exprs()} can handle multiple expressions. It always returns a list of expressions (compare to \code{\link[base:parse]{base::parse()}} which returns a base::expression vector). All functions also support R connections. \item \code{parse_expr()} concatenates \code{x} with \verb{\\\\n} separators prior to parsing in order to support the roundtrip \code{parse_expr(expr_deparse(x))} (deparsed expressions might be multiline). On the other hand, \code{parse_exprs()} doesn't do any concatenation because it's designed to support named inputs. The names are matched to the expressions in the output, which is useful when a single named string creates multiple expressions. In other words, \code{parse_expr()} supports vector of lines whereas \code{parse_exprs()} expects vectors of complete deparsed expressions. \item \code{parse_quo()} and \code{parse_quos()} are variants that create a \link[=quo]{quosure}. Supply \code{env = current_env()} if you're parsing code to be evaluated in your current context. Supply \code{env = global_env()} when you're parsing external user input to be evaluated in user context. Unlike quosures created with \code{\link[=enquo]{enquo()}}, \code{\link[=enquos]{enquos()}}, or \verb{\{\{}, a parsed quosure never contains injected quosures. It is thus safe to evaluate them with \code{eval()} instead of \code{\link[=eval_tidy]{eval_tidy()}}, though the latter is more convenient as you don't need to extract \code{expr} and \code{env}. } } \details{ Unlike \code{\link[base:parse]{base::parse()}}, these functions never retain source reference information, as doing so is slow and rarely necessary. } \examples{ # parse_expr() can parse any R expression: parse_expr("mtcars \%>\% dplyr::mutate(cyl_prime = cyl / sd(cyl))") # A string can contain several expressions separated by ; or \n parse_exprs("NULL; list()\n foo(bar)") # Use names to figure out which input produced an expression: parse_exprs(c(foo = "1; 2", bar = "3")) # You can also parse source files by passing a R connection. Let's # create a file containing R code: path <- tempfile("my-file.R") cat("1; 2; mtcars", file = path) # We can now parse it by supplying a connection: parse_exprs(file(path)) } \seealso{ \code{\link[base:parse]{base::parse()}} } rlang/man/raw_deparse_str.Rd0000644000176200001440000000160714375670676015634 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/raw.R \name{raw_deparse_str} \alias{raw_deparse_str} \title{Serialize a raw vector to a string} \usage{ raw_deparse_str(x, prefix = NULL, suffix = NULL) } \arguments{ \item{x}{A raw vector.} \item{prefix, suffix}{Prefix and suffix strings, or `NULL.} } \value{ A string. } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} This function converts a raw vector to a hexadecimal string, optionally adding a prefix and a suffix. It is roughly equivalent to \code{paste0(prefix, paste(format(x), collapse = ""), suffix)} and much faster. } \examples{ raw_deparse_str(raw()) raw_deparse_str(charToRaw("string")) raw_deparse_str(raw(10), prefix = "'0x", suffix = "'") } \keyword{internal} rlang/man/env_inherits.Rd0000644000176200001440000000065514127057575015137 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/env.R \name{env_inherits} \alias{env_inherits} \title{Does environment inherit from another environment?} \usage{ env_inherits(env, ancestor) } \arguments{ \item{env}{An environment.} \item{ancestor}{Another environment from which \code{x} might inherit.} } \description{ This returns \code{TRUE} if \code{x} has \code{ancestor} among its parents. } rlang/man/list2.Rd0000644000176200001440000001077414376112150013465 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/dots.R \name{list2} \alias{list2} \alias{ll} \alias{dots_list} \title{Collect dynamic dots in a list} \usage{ list2(...) dots_list( ..., .named = FALSE, .ignore_empty = c("trailing", "none", "all"), .preserve_empty = FALSE, .homonyms = c("keep", "first", "last", "error"), .check_assign = FALSE ) } \arguments{ \item{...}{Arguments to collect in a list. These dots are \link[=dyn-dots]{dynamic}.} \item{.named}{If \code{TRUE}, unnamed inputs are automatically named with \code{\link[=as_label]{as_label()}}. This is equivalent to applying \code{\link[=exprs_auto_name]{exprs_auto_name()}} on the result. If \code{FALSE}, unnamed elements are left as is and, if fully unnamed, the list is given minimal names (a vector of \code{""}). If \code{NULL}, fully unnamed results are left with \code{NULL} names.} \item{.ignore_empty}{Whether to ignore empty arguments. Can be one of \code{"trailing"}, \code{"none"}, \code{"all"}. If \code{"trailing"}, only the last argument is ignored if it is empty.} \item{.preserve_empty}{Whether to preserve the empty arguments that were not ignored. If \code{TRUE}, empty arguments are stored with \code{\link[=missing_arg]{missing_arg()}} values. If \code{FALSE} (the default) an error is thrown when an empty argument is detected.} \item{.homonyms}{How to treat arguments with the same name. The default, \code{"keep"}, preserves these arguments. Set \code{.homonyms} to \code{"first"} to only keep the first occurrences, to \code{"last"} to keep the last occurrences, and to \code{"error"} to raise an informative error and indicate what arguments have duplicated names.} \item{.check_assign}{Whether to check for \verb{<-} calls. When \code{TRUE} a warning recommends users to use \code{=} if they meant to match a function parameter or wrap the \verb{<-} call in curly braces otherwise. This ensures assignments are explicit.} } \value{ A list containing the \code{...} inputs. } \description{ \code{list2(...)} is equivalent to \code{list(...)} with a few additional features, collectively called \link[=dyn-dots]{dynamic dots}. While \code{list2()} hard-code these features, \code{dots_list()} is a lower-level version that offers more control. } \details{ For historical reasons, \code{dots_list()} creates a named list by default. By comparison \code{list2()} implements the preferred behaviour of only creating a names vector when a name is supplied. } \examples{ # Let's create a function that takes a variable number of arguments: numeric <- function(...) { dots <- list2(...) num <- as.numeric(dots) set_names(num, names(dots)) } numeric(1, 2, 3) # The main difference with list(...) is that list2(...) enables # the `!!!` syntax to splice lists: x <- list(2, 3) numeric(1, !!! x, 4) # As well as unquoting of names: nm <- "yup!" numeric(!!nm := 1) # One useful application of splicing is to work around exact and # partial matching of arguments. Let's create a function taking # named arguments and dots: fn <- function(data, ...) { list2(...) } # You normally cannot pass an argument named `data` through the dots # as it will match `fn`'s `data` argument. The splicing syntax # provides a workaround: fn("wrong!", data = letters) # exact matching of `data` fn("wrong!", dat = letters) # partial matching of `data` fn(some_data, !!!list(data = letters)) # no matching # Empty trailing arguments are allowed: list2(1, ) # But non-trailing empty arguments cause an error: try(list2(1, , )) # Use the more configurable `dots_list()` function to preserve all # empty arguments: list3 <- function(...) dots_list(..., .preserve_empty = TRUE) # Note how the last empty argument is still ignored because # `.ignore_empty` defaults to "trailing": list3(1, , ) # The list with preserved empty arguments is equivalent to: list(1, missing_arg()) # Arguments with duplicated names are kept by default: list2(a = 1, a = 2, b = 3, b = 4, 5, 6) # Use the `.homonyms` argument to keep only the first of these: dots_list(a = 1, a = 2, b = 3, b = 4, 5, 6, .homonyms = "first") # Or the last: dots_list(a = 1, a = 2, b = 3, b = 4, 5, 6, .homonyms = "last") # Or raise an informative error: try(dots_list(a = 1, a = 2, b = 3, b = 4, 5, 6, .homonyms = "error")) # dots_list() can be configured to warn when a `<-` call is # detected: my_list <- function(...) dots_list(..., .check_assign = TRUE) my_list(a <- 1) # There is no warning if the assignment is wrapped in braces. # This requires users to be explicit about their intent: my_list({ a <- 1 }) } rlang/man/is_installed.Rd0000644000176200001440000000711014375670676015115 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/session.R \name{is_installed} \alias{is_installed} \alias{check_installed} \title{Are packages installed in any of the libraries?} \usage{ is_installed(pkg, ..., version = NULL, compare = NULL) check_installed( pkg, reason = NULL, ..., version = NULL, compare = NULL, action = NULL, call = caller_env() ) } \arguments{ \item{pkg}{The package names. Can include version requirements, e.g. \code{"pkg (>= 1.0.0)"}.} \item{...}{These dots must be empty.} \item{version}{Minimum versions for \code{pkg}. If supplied, must be the same length as \code{pkg}. \code{NA} elements stand for any versions.} \item{compare}{A character vector of comparison operators to use for \code{version}. If supplied, must be the same length as \code{version}. If \code{NULL}, \code{>=} is used as default for all elements. \code{NA} elements in \code{compare} are also set to \code{>=} by default.} \item{reason}{Optional string indicating why is \code{pkg} needed. Appears in error messages (if non-interactive) and user prompts (if interactive).} \item{action}{An optional function taking \code{pkg} and \code{...} arguments. It is called by \code{check_installed()} when the user chooses to update outdated packages. The function is passed the missing and outdated packages as a character vector of names.} \item{call}{The execution environment of a currently running function, e.g. \code{caller_env()}. The function will be mentioned in error messages as the source of the error. See the \code{call} argument of \code{\link[=abort]{abort()}} for more information.} } \value{ \code{is_installed()} returns \code{TRUE} if \emph{all} package names provided in \code{pkg} are installed, \code{FALSE} otherwise. \code{check_installed()} either doesn't return or returns \code{NULL}. } \description{ These functions check that packages are installed with minimal side effects. If installed, the packages will be loaded but not attached. \itemize{ \item \code{is_installed()} doesn't interact with the user. It simply returns \code{TRUE} or \code{FALSE} depending on whether the packages are installed. \item In interactive sessions, \code{check_installed()} asks the user whether to install missing packages. If the user accepts, the packages are installed with \code{pak::pkg_install()} if available, or \code{\link[utils:install.packages]{utils::install.packages()}} otherwise. If the session is non interactive or if the user chooses not to install the packages, the current evaluation is aborted. } You can disable the prompt by setting the \code{rlib_restart_package_not_found} global option to \code{FALSE}. In that case, missing packages always cause an error. } \section{Handling package not found errors}{ \code{check_installed()} signals error conditions of class \code{rlib_error_package_not_found}. The error includes \code{pkg} and \code{version} fields. They are vectorised and may include several packages. The error is signalled with a \code{rlib_restart_package_not_found} restart on the stack to allow handlers to install the required packages. To do so, add a \link[=withCallingHandlers]{calling handler} for \code{rlib_error_package_not_found}, install the required packages, and invoke the restart without arguments. This restarts the check from scratch. The condition is not signalled in non-interactive sessions, in the restarting case, or if the \code{rlib_restart_package_not_found} user option is set to \code{FALSE}. } \examples{ is_installed("utils") is_installed(c("base", "ggplot5")) is_installed(c("base", "ggplot5"), version = c(NA, "5.1.0")) } rlang/man/expr.Rd0000644000176200001440000000302614375670676013423 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/nse-defuse.R \name{expr} \alias{expr} \title{Defuse an R expression} \arguments{ \item{expr}{An expression to defuse.} } \description{ \code{expr()} \link[=topic-defuse]{defuses} an R expression with \link[=injection-operator]{injection} support. It is equivalent to \code{\link[base:bquote]{base::bquote()}}. } \examples{ # R normally returns the result of an expression 1 + 1 # `expr()` defuses the expression that you have supplied and # returns it instead of its value expr(1 + 1) expr(toupper(letters)) # It supports _injection_ with `!!` and `!!!`. This is a convenient # way of modifying part of an expression by injecting other # objects. var <- "cyl" expr(with(mtcars, mean(!!sym(var)))) vars <- c("cyl", "am") expr(with(mtcars, c(!!!syms(vars)))) # Compare to the normal way of building expressions call("with", call("mean", sym(var))) call("with", call2("c", !!!syms(vars))) } \seealso{ \itemize{ \item \ifelse{html}{\link[=topic-defuse]{Defusing R expressions}}{\link[=topic-defuse]{Defusing R expressions}} for an overview. \item \code{\link[=enquo]{enquo()}} to defuse non-local expressions from function arguments. \item \link[=defusing-advanced]{Advanced defusal operators}. \item \code{\link[=sym]{sym()}} and \code{\link[=call2]{call2()}} for building expressions (symbols and calls respectively) programmatically. \item \code{\link[base:eval]{base::eval()}} and \code{\link[=eval_bare]{eval_bare()}} for resuming evaluation of a defused expression. } } rlang/man/with_env.Rd0000644000176200001440000000405714375670676014275 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/lifecycle-deprecated.R \name{with_env} \alias{with_env} \alias{locally} \title{Evaluate an expression within a given environment} \usage{ with_env(env, expr) locally(expr) } \arguments{ \item{env}{An environment within which to evaluate \code{expr}. Can be an object with a \code{\link[=get_env]{get_env()}} method.} \item{expr}{An expression to evaluate.} } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} These functions evaluate \code{expr} within a given environment (\code{env} for \code{with_env()}, or the child of the current environment for \code{locally}). They rely on \code{\link[=eval_bare]{eval_bare()}} which features a lighter evaluation mechanism than base R \code{\link[base:eval]{base::eval()}}, and which also has some subtle implications when evaluting stack sensitive functions (see help for \code{\link[=eval_bare]{eval_bare()}}). \code{locally()} is equivalent to the base function \code{\link[base:eval]{base::local()}} but it produces a much cleaner evaluation stack, and has stack-consistent semantics. It is thus more suited for experimenting with the R language. } \examples{ # with_env() is handy to create formulas with a given environment: env <- child_env("rlang") f <- with_env(env, ~new_formula()) identical(f_env(f), env) # Or functions with a given enclosure: fn <- with_env(env, function() NULL) identical(get_env(fn), env) # Unlike eval() it doesn't create duplicates on the evaluation # stack. You can thus use it e.g. to create non-local returns: fn <- function() { g(current_env()) "normal return" } g <- function(env) { with_env(env, return("early return")) } fn() # Since env is passed to as_environment(), it can be any object with an # as_environment() method. For strings, the pkg_env() is returned: with_env("base", ~mtcars) # This can be handy to put dictionaries in scope: with_env(mtcars, cyl) } \keyword{internal} rlang/man/is_empty.Rd0000644000176200001440000000052413351410454014251 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/types.R \name{is_empty} \alias{is_empty} \title{Is object an empty vector or NULL?} \usage{ is_empty(x) } \arguments{ \item{x}{object to test} } \description{ Is object an empty vector or NULL? } \examples{ is_empty(NULL) is_empty(list()) is_empty(list(NULL)) } rlang/man/env.Rd0000644000176200001440000000733214376112150013214 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/env.R \name{env} \alias{env} \alias{new_environment} \title{Create a new environment} \usage{ env(...) new_environment(data = list(), parent = empty_env()) } \arguments{ \item{..., data}{<\link[=dyn-dots]{dynamic}> Named values. You can supply one unnamed to specify a custom parent, otherwise it defaults to the current environment.} \item{parent}{A parent environment.} } \description{ These functions create new environments. \itemize{ \item \code{env()} creates a child of the current environment by default and takes a variable number of named objects to populate it. \item \code{new_environment()} creates a child of the empty environment by default and takes a named list of objects to populate it. } } \section{Environments as objects}{ Environments are containers of uniquely named objects. Their most common use is to provide a scope for the evaluation of R expressions. Not all languages have first class environments, i.e. can manipulate scope as regular objects. Reification of scope is one of the most powerful features of R as it allows you to change what objects a function or expression sees when it is evaluated. Environments also constitute a data structure in their own right. They are a collection of uniquely named objects, subsettable by name and modifiable by reference. This latter property (see section on reference semantics) is especially useful for creating mutable OO systems (cf the \href{https://github.com/r-lib/R6}{R6 package} and the \href{https://ggplot2.tidyverse.org/articles/extending-ggplot2.html}{ggproto system} for extending ggplot2). } \section{Inheritance}{ All R environments (except the \link[=empty_env]{empty environment}) are defined with a parent environment. An environment and its grandparents thus form a linear hierarchy that is the basis for \href{https://en.wikipedia.org/wiki/Scope_(computer_science)}{lexical scoping} in R. When R evaluates an expression, it looks up symbols in a given environment. If it cannot find these symbols there, it keeps looking them up in parent environments. This way, objects defined in child environments have precedence over objects defined in parent environments. The ability of overriding specific definitions is used in the tidyeval framework to create powerful domain-specific grammars. A common use of masking is to put data frame columns in scope. See for example \code{\link[=as_data_mask]{as_data_mask()}}. } \section{Reference semantics}{ Unlike regular objects such as vectors, environments are an \link[=is_copyable]{uncopyable} object type. This means that if you have multiple references to a given environment (by assigning the environment to another symbol with \verb{<-} or passing the environment as argument to a function), modifying the bindings of one of those references changes all other references as well. } \examples{ # env() creates a new environment that inherits from the current # environment by default env <- env(a = 1, b = "foo") env$b identical(env_parent(env), current_env()) # Supply one unnamed argument to inherit from another environment: env <- env(base_env(), a = 1, b = "foo") identical(env_parent(env), base_env()) # Both env() and child_env() support tidy dots features: objs <- list(b = "foo", c = "bar") env <- env(a = 1, !!! objs) env$c # You can also unquote names with the definition operator `:=` var <- "a" env <- env(!!var := "A") env$a # Use new_environment() to create containers with the empty # environment as parent: env <- new_environment() env_parent(env) # Like other new_ constructors, it takes an object rather than dots: new_environment(list(a = "foo", b = "bar")) } \seealso{ \code{\link[=env_has]{env_has()}}, \code{\link[=env_bind]{env_bind()}}. } rlang/man/call_match.Rd0000644000176200001440000000464614175213516014525 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/call.R \name{call_match} \alias{call_match} \title{Match supplied arguments to function definition} \usage{ call_match( call = NULL, fn = NULL, ..., defaults = FALSE, dots_env = NULL, dots_expand = TRUE ) } \arguments{ \item{call}{A call. The arguments will be matched to \code{fn}.} \item{fn}{A function definition to match arguments to.} \item{...}{These dots must be empty.} \item{defaults}{Whether to match missing arguments to their defaults.} \item{dots_env}{An execution environment where to find dots. If supplied and dots exist in this environment, and if \code{call} includes \code{...}, the forwarded dots are matched to numbered dots (e.g. \code{..1}, \code{..2}, etc). By default this is set to the empty environment which means that \code{...} expands to nothing.} \item{dots_expand}{If \code{FALSE}, arguments passed through \code{...} will not be spliced into \code{call}. Instead, they are gathered in a pairlist and assigned to an argument named \code{...}. Gathering dots arguments is useful if you need to separate them from the other named arguments. Note that the resulting call is not meant to be evaluated since R does not support passing dots through a named argument, even if named \code{"..."}.} } \description{ \code{call_match()} is like \code{\link[=match.call]{match.call()}} with these differences: \itemize{ \item It supports matching missing argument to their defaults in the function definition. \item It requires you to be a little more specific in some cases. Either all arguments are inferred from the call stack or none of them are (see the Inference section). } } \section{Inference from the call stack}{ When \code{call} is not supplied, it is inferred from the call stack along with \code{fn} and \code{dots_env}. \itemize{ \item \code{call} and \code{fn} are inferred from the calling environment: \code{sys.call(sys.parent())} and \code{sys.function(sys.parent())}. \item \code{dots_env} is inferred from the caller of the calling environment: \code{caller_env(2)}. } If \code{call} is supplied, then you must supply \code{fn} as well. Also consider supplying \code{dots_env} as it is set to the empty environment when not inferred. } \examples{ # `call_match()` supports matching missing arguments to their # defaults fn <- function(x = "default") fn call_match(quote(fn()), fn) call_match(quote(fn()), fn, defaults = TRUE) } rlang/man/prim_name.Rd0000644000176200001440000000051614127057575014405 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/fn.R \name{prim_name} \alias{prim_name} \title{Name of a primitive function} \usage{ prim_name(prim) } \arguments{ \item{prim}{A primitive function such as \code{\link[base:c]{base::c()}}.} } \description{ Name of a primitive function } \keyword{internal} rlang/man/as_label.Rd0000644000176200001440000000365214375670676014214 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/deparse.R \name{as_label} \alias{as_label} \title{Create a default name for an R object} \usage{ as_label(x) } \arguments{ \item{x}{An object.} } \description{ \code{as_label()} transforms R objects into a short, human-readable description. You can use labels to: \itemize{ \item Display an object in a concise way, for example to labellise axes in a graphical plot. \item Give default names to columns in a data frame. In this case, labelling is the first step before name repair. } See also \code{\link[=as_name]{as_name()}} for transforming symbols back to a string. Unlike \code{as_label()}, \code{as_name()} is a well defined operation that guarantees the roundtrip symbol -> string -> symbol. In general, if you don't know for sure what kind of object you're dealing with (a call, a symbol, an unquoted constant), use \code{as_label()} and make no assumption about the resulting string. If you know you have a symbol and need the name of the object it refers to, use \code{\link[=as_name]{as_name()}}. For instance, use \code{as_label()} with objects captured with \code{enquo()} and \code{as_name()} with symbols captured with \code{ensym()}. } \section{Transformation to string}{ \itemize{ \item Quosures are \link[=quo_squash]{squashed} before being labelled. \item Symbols are transformed to string with \code{as_string()}. \item Calls are abbreviated. \item Numbers are represented as such. \item Other constants are represented by their type, such as \verb{} or \verb{}. } } \examples{ # as_label() is useful with quoted expressions: as_label(expr(foo(bar))) as_label(expr(foobar)) # It works with any R object. This is also useful for quoted # arguments because the user might unquote constant objects: as_label(1:3) as_label(base::list) } \seealso{ \code{\link[=as_name]{as_name()}} for transforming symbols back to a string deterministically. } rlang/man/UQ.Rd0000644000176200001440000000103714375670676012772 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/lifecycle-deprecated.R \name{UQ} \alias{UQ} \alias{UQS} \title{Deprecated \code{UQ()} and \code{UQS()} operators} \usage{ UQ(x) UQS(x) } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} These operators are deprecated in favour of \code{\link[=injection-operator]{!!}} and \code{\link[=splice-operator]{!!!}}. } \keyword{internal} rlang/man/scalar-type-predicates.Rd0000644000176200001440000000246414175213516016777 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/types.R \name{scalar-type-predicates} \alias{scalar-type-predicates} \alias{is_scalar_list} \alias{is_scalar_atomic} \alias{is_scalar_vector} \alias{is_scalar_integer} \alias{is_scalar_double} \alias{is_scalar_complex} \alias{is_scalar_character} \alias{is_scalar_logical} \alias{is_scalar_raw} \alias{is_string} \alias{is_scalar_bytes} \alias{is_bool} \title{Scalar type predicates} \usage{ is_scalar_list(x) is_scalar_atomic(x) is_scalar_vector(x) is_scalar_integer(x) is_scalar_double(x) is_scalar_complex(x) is_scalar_character(x) is_scalar_logical(x) is_scalar_raw(x) is_string(x, string = NULL) is_scalar_bytes(x) is_bool(x) } \arguments{ \item{x}{object to be tested.} \item{string}{A string to compare to \code{x}. If a character vector, returns \code{TRUE} if at least one element is equal to \code{x}.} } \description{ These predicates check for a given type and whether the vector is "scalar", that is, of length 1. In addition to the length check, \code{is_string()} and \code{is_bool()} return \code{FALSE} if their input is missing. This is useful for type-checking arguments, when your function expects a single string or a single \code{TRUE} or \code{FALSE}. } \seealso{ \link{type-predicates}, \link{bare-type-predicates} } rlang/man/args_dots_empty.Rd0000644000176200001440000000066514375670676015656 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/dots-ellipsis.R \name{args_dots_empty} \alias{args_dots_empty} \title{Helper for consistent documentation of empty dots} \arguments{ \item{...}{These dots are for future extensions and must be empty.} } \description{ Use \verb{@inheritParams rlang::args_dots_empty} in your package to consistently document \code{...} that must be empty. } \keyword{internal} rlang/man/env_names.Rd0000644000176200001440000000325414127057575014413 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/env-binding.R \name{env_names} \alias{env_names} \alias{env_length} \title{Names and numbers of symbols bound in an environment} \usage{ env_names(env) env_length(env) } \arguments{ \item{env}{An environment.} } \value{ A character vector of object names. } \description{ \code{env_names()} returns object names from an enviroment \code{env} as a character vector. All names are returned, even those starting with a dot. \code{env_length()} returns the number of bindings. } \section{Names of symbols and objects}{ Technically, objects are bound to symbols rather than strings, since the R interpreter evaluates symbols (see \code{\link[=is_expression]{is_expression()}} for a discussion of symbolic objects versus literal objects). However it is often more convenient to work with strings. In rlang terminology, the string corresponding to a symbol is called the \emph{name} of the symbol (or by extension the name of an object bound to a symbol). } \section{Encoding}{ There are deep encoding issues when you convert a string to symbol and vice versa. Symbols are \emph{always} in the native encoding. If that encoding (let's say latin1) cannot support some characters, these characters are serialised to ASCII. That's why you sometimes see strings looking like \verb{}, especially if you're running Windows (as R doesn't support UTF-8 as native encoding on that platform). To alleviate some of the encoding pain, \code{env_names()} always returns a UTF-8 character vector (which is fine even on Windows) with ASCII unicode points translated back to UTF-8. } \examples{ env <- env(a = 1, b = 2) env_names(env) } rlang/man/qq_show.Rd0000644000176200001440000000235314741441453014112 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/nse-inject.R \name{qq_show} \alias{qq_show} \title{Show injected expression} \arguments{ \item{expr}{An expression involving \link[=topic-inject]{injection operators}.} } \description{ \code{qq_show()} helps examining \link[=topic-inject]{injected expressions} inside a function. This is useful for learning about injection and for debugging injection code. } \section{Examples}{ \code{qq_show()} shows the intermediary expression before it is evaluated by R: \if{html}{\out{
}}\preformatted{list2(!!!1:3) #> [[1]] #> [1] 1 #> #> [[2]] #> [1] 2 #> #> [[3]] #> [1] 3 qq_show(list2(!!!1:3)) #> list2(1L, 2L, 3L) }\if{html}{\out{
}} It is especially useful inside functions to reveal what an injected expression looks like: \if{html}{\out{
}}\preformatted{my_mean <- function(data, var) \{ qq_show(data \%>\% dplyr::summarise(mean(\{\{ var \}\}))) \} mtcars \%>\% my_mean(cyl) #> data \%>\% dplyr::summarise(mean(^cyl)) }\if{html}{\out{
}} } \seealso{ \itemize{ \item \ifelse{html}{\link[=topic-inject]{Injecting with !!, !!!, and glue syntax}}{\link[=topic-inject]{Injecting with !!, !!!, and glue syntax}} } } rlang/man/hash.Rd0000644000176200001440000000271614175213516013355 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/hash.R \name{hash} \alias{hash} \alias{hash_file} \title{Hashing} \usage{ hash(x) hash_file(path) } \arguments{ \item{x}{An object.} \item{path}{A character vector of paths to the files to be hashed.} } \value{ \itemize{ \item For \code{hash()}, a single character string containing the hash. \item For \code{hash_file()}, a character vector containing one hash per file. } } \description{ \itemize{ \item \code{hash()} hashes an arbitrary R object. \item \code{hash_file()} hashes the data contained in a file. } The generated hash is guaranteed to be reproducible across platforms that have the same endianness and are using the same R version. } \details{ These hashers use the XXH128 hash algorithm of the xxHash library, which generates a 128-bit hash. Both are implemented as streaming hashes, which generate the hash with minimal extra memory usage. For \code{hash()}, objects are converted to binary using R's native serialization tools. On R >= 3.5.0, serialization version 3 is used, otherwise version 2 is used. See \code{\link[=serialize]{serialize()}} for more information about the serialization version. } \examples{ hash(c(1, 2, 3)) hash(mtcars) authors <- file.path(R.home("doc"), "AUTHORS") copying <- file.path(R.home("doc"), "COPYING") hashes <- hash_file(c(authors, copying)) hashes # If you need a single hash for multiple files, # hash the result of `hash_file()` hash(hashes) } rlang/man/call_modify.Rd0000644000176200001440000000563214175213516014714 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/call.R \name{call_modify} \alias{call_modify} \title{Modify the arguments of a call} \usage{ call_modify( .call, ..., .homonyms = c("keep", "first", "last", "error"), .standardise = NULL, .env = caller_env() ) } \arguments{ \item{.call}{Can be a call, a formula quoting a call in the right-hand side, or a frame object from which to extract the call expression.} \item{...}{<\link[=dyn-dots]{dynamic}> Named or unnamed expressions (constants, names or calls) used to modify the call. Use \code{\link[=zap]{zap()}} to remove arguments. Empty arguments are preserved.} \item{.homonyms}{How to treat arguments with the same name. The default, \code{"keep"}, preserves these arguments. Set \code{.homonyms} to \code{"first"} to only keep the first occurrences, to \code{"last"} to keep the last occurrences, and to \code{"error"} to raise an informative error and indicate what arguments have duplicated names.} \item{.standardise, .env}{Deprecated as of rlang 0.3.0. Please call \code{\link[=call_match]{call_match()}} manually.} } \value{ A quosure if \code{.call} is a quosure, a call otherwise. } \description{ If you are working with a user-supplied call, make sure the arguments are standardised with \code{\link[=call_match]{call_match()}} before modifying the call. } \examples{ call <- quote(mean(x, na.rm = TRUE)) # Modify an existing argument call_modify(call, na.rm = FALSE) call_modify(call, x = quote(y)) # Remove an argument call_modify(call, na.rm = zap()) # Add a new argument call_modify(call, trim = 0.1) # Add an explicit missing argument: call_modify(call, na.rm = ) # Supply a list of new arguments with `!!!` newargs <- list(na.rm = NULL, trim = 0.1) call <- call_modify(call, !!!newargs) call # Remove multiple arguments by splicing zaps: newargs <- rep_named(c("na.rm", "trim"), list(zap())) call <- call_modify(call, !!!newargs) call # Modify the `...` arguments as if it were a named argument: call <- call_modify(call, ... = ) call call <- call_modify(call, ... = zap()) call # When you're working with a user-supplied call, standardise it # beforehand in case it includes unmatched arguments: user_call <- quote(matrix(x, nc = 3)) call_modify(user_call, ncol = 1) # `call_match()` applies R's argument matching rules. Matching # ensures you're modifying the intended argument. user_call <- call_match(user_call, matrix) user_call call_modify(user_call, ncol = 1) # By default, arguments with the same name are kept. This has # subtle implications, for instance you can move an argument to # last position by removing it and remapping it: call <- quote(foo(bar = , baz)) call_modify(call, bar = NULL, bar = missing_arg()) # You can also choose to keep only the first or last homonym # arguments: args <- list(bar = NULL, bar = missing_arg()) call_modify(call, !!!args, .homonyms = "first") call_modify(call, !!!args, .homonyms = "last") } rlang/man/quosure-tools.Rd0000644000176200001440000000700314375670676015305 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/quo.R \name{quosure-tools} \alias{quosure-tools} \alias{quosure} \alias{quo_is_missing} \alias{quo_is_symbol} \alias{quo_is_call} \alias{quo_is_symbolic} \alias{quo_is_null} \alias{quo_get_expr} \alias{quo_get_env} \alias{quo_set_expr} \alias{quo_set_env} \title{Quosure getters, setters and predicates} \usage{ quo_is_missing(quo) quo_is_symbol(quo, name = NULL) quo_is_call(quo, name = NULL, n = NULL, ns = NULL) quo_is_symbolic(quo) quo_is_null(quo) quo_get_expr(quo) quo_get_env(quo) quo_set_expr(quo, expr) quo_set_env(quo, env) } \arguments{ \item{quo}{A quosure to test.} \item{name}{The name of the symbol or function call. If \code{NULL} the name is not tested.} \item{n}{An optional number of arguments that the call should match.} \item{ns}{The namespace of the call. If \code{NULL}, the namespace doesn't participate in the pattern-matching. If an empty string \code{""} and \code{x} is a namespaced call, \code{is_call()} returns \code{FALSE}. If any other string, \code{is_call()} checks that \code{x} is namespaced within \code{ns}. Can be a character vector of namespaces, in which case the call has to match at least one of them, otherwise \code{is_call()} returns \code{FALSE}.} \item{expr}{A new expression for the quosure.} \item{env}{A new environment for the quosure.} } \description{ These tools inspect and modify \link[=topic-quosure]{quosures}, a type of \link[=topic-defuse]{defused expression} that includes a reference to the context where it was created. A quosure is guaranteed to evaluate in its original environment and can refer to local objects safely. \itemize{ \item You can access the quosure components with \code{quo_get_expr()} and \code{quo_get_env()}. \item The \code{quo_} prefixed predicates test the expression of a quosure, \code{quo_is_missing()}, \code{quo_is_symbol()}, etc. } All \code{quo_} prefixed functions expect a quosure and will fail if supplied another type of object. Make sure the input is a quosure with \code{\link[=is_quosure]{is_quosure()}}. } \section{Empty quosures and missing arguments}{ When missing arguments are captured as quosures, either through \code{\link[=enquo]{enquo()}} or \code{\link[=quos]{quos()}}, they are returned as an empty quosure. These quosures contain the \link[=missing_arg]{missing argument} and typically have the \link[=empty_env]{empty environment} as enclosure. Use \code{quo_is_missing()} to test for a missing argument defused with \code{\link[=enquo]{enquo()}}. } \examples{ quo <- quo(my_quosure) quo # Access and set the components of a quosure: quo_get_expr(quo) quo_get_env(quo) quo <- quo_set_expr(quo, quote(baz)) quo <- quo_set_env(quo, empty_env()) quo # Test wether an object is a quosure: is_quosure(quo) # If it is a quosure, you can use the specialised type predicates # to check what is inside it: quo_is_symbol(quo) quo_is_call(quo) quo_is_null(quo) # quo_is_missing() checks for a special kind of quosure, the one # that contains the missing argument: quo() quo_is_missing(quo()) fn <- function(arg) enquo(arg) fn() quo_is_missing(fn()) } \seealso{ \itemize{ \item \code{\link[=quo]{quo()}} for creating quosures by \link[=topic-defuse]{argument defusal}. \item \code{\link[=new_quosure]{new_quosure()}} and \code{\link[=as_quosure]{as_quosure()}} for assembling quosures from components. \item \ifelse{html}{\link[=topic-quosure]{What are quosures and when are they needed?}}{\link[=topic-quosure]{What are quosures and when are they needed?}} for an overview. } } rlang/man/topic-condition-formatting.Rd0000644000176200001440000001067014741441453017704 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/topic-errors.R \name{topic-condition-formatting} \alias{topic-condition-formatting} \title{Formatting messages with cli} \description{ Condition formatting is a set of operations applied to raw inputs for error messages that includes: \itemize{ \item Transforming a character vector of lines to a width-wrapped list of error bullets. This makes it easy to write messages in a list format where each bullet conveys a single important point. \if{html}{\out{
}}\preformatted{abort(c( "The error header", "*" = "An error bullet", "i" = "An info bullet", "x" = "A cross bullet" )) #> Error: #> ! The error header #> * An error bullet #> i An info bullet #> x A cross bullet }\if{html}{\out{
}} See the \href{https://style.tidyverse.org/errors.html}{tidyverse error style guide} for more about this style of error messaging. \item Applying style (emphasis, boldness, ...) and colours to message elements. } While the rlang package embeds rudimentary formatting routines, the main formatting engine is implemented in the \href{https://cli.r-lib.org/}{cli package}. \subsection{Formatting messages with cli}{ By default, rlang uses an internal mechanism to format bullets. It is preferable to delegate formatting to the \href{https://cli.r-lib.org/}{cli package} by using \code{\link[cli:cli_abort]{cli::cli_abort()}}, \code{\link[cli:cli_abort]{cli::cli_warn()}}, and \code{\link[cli:cli_abort]{cli::cli_inform()}} instead of the rlang versions. These wrappers enable cli formatting with sophisticated paragraph wrapping and bullet indenting that make long lines easier to read. In the following example, a long \code{!} bullet is broken with an indented newline: \if{html}{\out{
}}\preformatted{rlang::global_entrace(class = "errorr") #> Error in `rlang::global_entrace()`: #> ! `class` must be one of "error", "warning", or "message", #> not "errorr". #> i Did you mean "error"? }\if{html}{\out{
}} The cli wrappers also add many features such as interpolation, semantic formatting of text elements, and pluralisation: \if{html}{\out{
}}\preformatted{inform_marbles <- function(n_marbles) \{ cli::cli_inform(c( "i" = "I have \{n_marbles\} shiny marble\{?s\} in my bag.", "v" = "Way to go \{.code cli::cli_inform()\}!" )) \} inform_marbles(1) #> i I have 1 shiny marble in my bag. #> v Way to go `cli::cli_inform()`! inform_marbles(2) #> i I have 2 shiny marbles in my bag. #> v Way to go `cli::cli_inform()`! }\if{html}{\out{
}} } \subsection{Transitioning from \code{abort()} to \code{cli_abort()}}{ If you plan to mass-rename calls from \code{abort()} to \code{cli::cli_abort()}, be careful if you assemble error messages from user inputs. If these individual pieces contain cli or glue syntax, this will result in hard-to-debug errors and possibly \href{https://xkcd.com/327/}{unexpected behaviour}. \if{html}{\out{
}}\preformatted{user_input <- "\{base::stop('Wrong message.', call. = FALSE)\}" cli::cli_abort(sprintf("Can't handle input `\%s`.", user_input)) #> Error: #> ! ! Could not evaluate cli `\{\}` expression: `base::stop('Wrong...`. #> Caused by error: #> ! Wrong message. }\if{html}{\out{
}} To avoid this, protect your error messages by using cli to assemble the pieces: \if{html}{\out{
}}\preformatted{user_input <- "\{base::stop('Wrong message.', call. = FALSE)\}" cli::cli_abort("Can't handle input \{.code \{user_input\}\}.") #> Error: #> ! Can't handle input `\{base::stop('Wrong message.', call. = FALSE)\}`. }\if{html}{\out{
}} } \subsection{Enabling cli formatting globally}{ To enable cli formatting for all \code{abort()} calls in your namespace, call \code{\link[=local_use_cli]{local_use_cli()}} in the \code{onLoad} hook of your package. Using \code{\link[=on_load]{on_load()}} (make sure to call \code{\link[=run_on_load]{run_on_load()}} in your hook): \if{html}{\out{
}}\preformatted{on_load(local_use_cli()) }\if{html}{\out{
}} Enabling cli formatting in \code{abort()} is useful for: \itemize{ \item Transitioning from \code{abort()} to \code{cli::cli_abort()} progressively. \item Using \code{abort()} when you'd like to disable interpolation syntax. \item Creating error conditions with \code{error_cnd()}. These condition messages will be automatically formatted with cli as well. } } } \keyword{internal} rlang/man/op-null-default.Rd0000644000176200001440000000100013563526752015434 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/operators.R \name{op-null-default} \alias{op-null-default} \alias{\%||\%} \title{Default value for \code{NULL}} \usage{ x \%||\% y } \arguments{ \item{x, y}{If \code{x} is NULL, will return \code{y}; otherwise returns \code{x}.} } \description{ This infix function makes it easy to replace \code{NULL}s with a default value. It's inspired by the way that Ruby's or operation (\code{||}) works. } \examples{ 1 \%||\% 2 NULL \%||\% 2 } rlang/man/zap.Rd0000644000176200001440000000152214127057575013226 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/s3.R \name{zap} \alias{zap} \alias{is_zap} \title{Create zap objects} \usage{ zap() is_zap(x) } \arguments{ \item{x}{An object to test.} } \description{ \code{zap()} creates a sentinel object that indicates that an object should be removed. For instance, named zaps instruct \code{\link[=env_bind]{env_bind()}} and \code{\link[=call_modify]{call_modify()}} to remove those objects from the environment or the call. The advantage of zap objects is that they unambiguously signal the intent of removing an object. Sentinels like \code{NULL} or \code{\link[=missing_arg]{missing_arg()}} are ambiguous because they represent valid R objects. } \examples{ # Create one zap object: zap() # Create a list of zaps: rep(list(zap()), 3) rep_named(c("foo", "bar"), list(zap())) } rlang/man/env_has.Rd0000644000176200001440000000170214127057575014057 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/env-binding.R \name{env_has} \alias{env_has} \title{Does an environment have or see bindings?} \usage{ env_has(env = caller_env(), nms, inherit = FALSE) } \arguments{ \item{env}{An environment.} \item{nms}{A character vector of binding names for which to check existence.} \item{inherit}{Whether to look for bindings in the parent environments.} } \value{ A named logical vector as long as \code{nms}. } \description{ \code{env_has()} is a vectorised predicate that queries whether an environment owns bindings personally (with \code{inherit} set to \code{FALSE}, the default), or sees them in its own environment or in any of its parents (with \code{inherit = TRUE}). } \examples{ parent <- child_env(NULL, foo = "foo") env <- child_env(parent, bar = "bar") # env does not own `foo` but sees it in its parent environment: env_has(env, "foo") env_has(env, "foo", inherit = TRUE) } rlang/man/is_reference.Rd0000644000176200001440000000254214127057575015070 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/types.R \name{is_reference} \alias{is_reference} \title{Is an object referencing another?} \usage{ is_reference(x, y) } \arguments{ \item{x, y}{R objects.} } \description{ There are typically two situations where two symbols may refer to the same object. \itemize{ \item R objects usually have copy-on-write semantics. This is an optimisation that ensures that objects are only copied if needed. When you copy a vector, no memory is actually copied until you modify either the original object or the copy is modified. Note that the copy-on-write optimisation is an implementation detail that is not guaranteed by the specification of the R language. \item Assigning an \link[=is_copyable]{uncopyable} object (like an environment) creates a reference. These objects are never copied even if you modify one of the references. } } \examples{ # Reassigning an uncopyable object such as an environment creates a # reference: env <- env() ref <- env is_reference(ref, env) # Due to copy-on-write optimisation, a copied vector can # temporarily reference the original vector: vec <- 1:10 copy <- vec is_reference(copy, vec) # Once you modify on of them, the copy is triggered in the # background and the objects cease to reference each other: vec[[1]] <- 100 is_reference(copy, vec) } \keyword{internal} rlang/man/as_string.Rd0000644000176200001440000000355414127057575014434 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/sym.R \name{as_string} \alias{as_string} \title{Cast symbol to string} \usage{ as_string(x) } \arguments{ \item{x}{A string or symbol. If a string, the attributes are removed, if any.} } \value{ A character vector of length 1. } \description{ \code{as_string()} converts \link[=sym]{symbols} to character strings. } \section{Unicode tags}{ Unlike \code{\link[base:name]{base::as.symbol()}} and \code{\link[base:name]{base::as.name()}}, \code{as_string()} automatically transforms unicode tags such as \code{""} to the proper UTF-8 character. This is important on Windows because: \itemize{ \item R on Windows has no UTF-8 support, and uses native encoding instead. \item The native encodings do not cover all Unicode characters. For example, Western encodings do not support CKJ characters. \item When a lossy UTF-8 -> native transformation occurs, uncovered characters are transformed to an ASCII unicode tag like \code{""}. \item Symbols are always encoded in native. This means that transforming the column names of a data frame to symbols might be a lossy operation. \item This operation is very common in the tidyverse because of data masking APIs like dplyr where data frames are transformed to environments. While the names of a data frame are stored as a character vector, the bindings of environments are stored as symbols. } Because it reencodes the ASCII unicode tags to their UTF-8 representation, the string -> symbol -> string roundtrip is more stable with \code{as_string()}. } \examples{ # Let's create some symbols: foo <- quote(foo) bar <- sym("bar") # as_string() converts symbols to strings: foo as_string(foo) typeof(bar) typeof(as_string(bar)) } \seealso{ \code{\link[=as_name]{as_name()}} for a higher-level variant of \code{as_string()} that automatically unwraps quosures. } rlang/man/env_binding_lock.Rd0000644000176200001440000000320414175213516015715 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/env-binding.R \name{env_binding_lock} \alias{env_binding_lock} \alias{env_binding_unlock} \alias{env_binding_are_locked} \title{Lock or unlock environment bindings} \usage{ env_binding_lock(env, nms = NULL) env_binding_unlock(env, nms = NULL) env_binding_are_locked(env, nms = NULL) } \arguments{ \item{env}{An environment.} \item{nms}{Names of bindings. Defaults to all bindings in \code{env}.} } \value{ \code{env_binding_are_unlocked()} returns a logical vector as long as \code{nms} and named after it. \code{env_binding_lock()} and \code{env_binding_unlock()} return the old value of \code{env_binding_are_unlocked()} invisibly. } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} Locked environment bindings trigger an error when an attempt is made to redefine the binding. } \examples{ # Bindings are unlocked by default: env <- env(a = "A", b = "B") env_binding_are_locked(env) # But can optionally be locked: env_binding_lock(env, "a") env_binding_are_locked(env) # If run, the following would now return an error because `a` is locked: # env_bind(env, a = "foo") # with_env(env, a <- "bar") # Let's unlock it. Note that the return value indicate which # bindings were locked: were_locked <- env_binding_unlock(env) were_locked # Now that it is unlocked we can modify it again: env_bind(env, a = "foo") with_env(env, a <- "bar") env$a } \seealso{ \code{\link[=env_lock]{env_lock()}} for locking an environment. } \keyword{internal} rlang/man/expr_print.Rd0000644000176200001440000000414014375670676014635 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/expr.R \name{expr_print} \alias{expr_print} \alias{expr_deparse} \title{Print an expression} \usage{ expr_print(x, ...) expr_deparse(x, ..., width = peek_option("width")) } \arguments{ \item{x}{An object or expression to print.} \item{...}{Arguments passed to \code{expr_deparse()}.} \item{width}{The width of the deparsed or printed expression. Defaults to the global option \code{width}.} } \value{ \code{expr_deparse()} returns a character vector of lines. \code{expr_print()} returns its input invisibly. } \description{ \code{expr_print()}, powered by \code{expr_deparse()}, is an alternative printer for R expressions with a few improvements over the base R printer. \itemize{ \item It colourises \link[=nse-defuse]{quosures} according to their environment. Quosures from the global environment are printed normally while quosures from local environments are printed in unique colour (or in italic when all colours are taken). \item It wraps inlined objects in angular brackets. For instance, an integer vector unquoted in a function call (e.g. \code{expr(foo(!!(1:3)))}) is printed like this: \verb{foo()} while by default R prints the code to create that vector: \code{foo(1:3)} which is ambiguous. \item It respects the width boundary (from the global option \code{width}) in more cases. } } \examples{ # It supports any object. Non-symbolic objects are always printed # within angular brackets: expr_print(1:3) expr_print(function() NULL) # Contrast this to how the code to create these objects is printed: expr_print(quote(1:3)) expr_print(quote(function() NULL)) # The main cause of non-symbolic objects in expressions is # quasiquotation: expr_print(expr(foo(!!(1:3)))) # Quosures from the global environment are printed normally: expr_print(quo(foo)) expr_print(quo(foo(!!quo(bar)))) # Quosures from local environments are colourised according to # their environments (if you have crayon installed): local_quo <- local(quo(foo)) expr_print(local_quo) wrapper_quo <- local(quo(bar(!!local_quo, baz))) expr_print(wrapper_quo) } rlang/man/new_function.Rd0000644000176200001440000000307114375670676015143 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/fn.R \name{new_function} \alias{new_function} \title{Create a function} \usage{ new_function(args, body, env = caller_env()) } \arguments{ \item{args}{A named list or pairlist of default arguments. Note that if you want arguments that don't have defaults, you'll need to use the special function \code{\link[=pairlist2]{pairlist2()}}. If you need quoted defaults, use \code{\link[=exprs]{exprs()}}.} \item{body}{A language object representing the code inside the function. Usually this will be most easily generated with \code{\link[base:substitute]{base::quote()}}} \item{env}{The parent environment of the function, defaults to the calling environment of \code{new_function()}} } \description{ This constructs a new function given its three components: list of arguments, body code and parent environment. } \examples{ f <- function() letters g <- new_function(NULL, quote(letters)) identical(f, g) # Pass a list or pairlist of named arguments to create a function # with parameters. The name becomes the parameter name and the # argument the default value for this parameter: new_function(list(x = 10), quote(x)) new_function(pairlist2(x = 10), quote(x)) # Use `exprs()` to create quoted defaults. Compare: new_function(pairlist2(x = 5 + 5), quote(x)) new_function(exprs(x = 5 + 5), quote(x)) # Pass empty arguments to omit defaults. `list()` doesn't allow # empty arguments but `pairlist2()` does: new_function(pairlist2(x = , y = 5 + 5), quote(x + y)) new_function(exprs(x = , y = 5 + 5), quote(x + y)) } rlang/man/splice-operator.Rd0000644000176200001440000001644014741441453015543 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/nse-inject.R \name{splice-operator} \alias{splice-operator} \alias{!!!} \title{Splice operator \verb{!!!}} \description{ The splice operator \verb{!!!} implemented in \link[=dyn-dots]{dynamic dots} injects a list of arguments into a function call. It belongs to the family of \link[=topic-inject]{injection} operators and provides the same functionality as \code{\link[=do.call]{do.call()}}. The two main cases for splice injection are: \itemize{ \item Turning a list of inputs into distinct arguments. This is especially useful with functions that take data in \code{...}, such as \code{\link[base:cbind]{base::rbind()}}. \if{html}{\out{
}}\preformatted{dfs <- list(mtcars, mtcars) inject(rbind(!!!dfs)) }\if{html}{\out{
}} \item Injecting \link[=topic-defuse]{defused expressions} like \link[=sym]{symbolised} column names. For tidyverse APIs, this second case is no longer as useful since dplyr 1.0 and the \code{across()} operator. } } \section{Where does \verb{!!!} work?}{ \verb{!!!} does not work everywhere, you can only use it within certain special functions: \itemize{ \item Functions taking \link[=dyn-dots]{dynamic dots} like \code{\link[=list2]{list2()}}. \item Functions taking \link[=topic-defuse]{defused} and \link[=topic-data-mask]{data-masked} arguments, which are dynamic by default. \item Inside \code{\link[=inject]{inject()}}. } Most tidyverse functions support \verb{!!!} out of the box. With base functions you need to use \code{\link[=inject]{inject()}} to enable \verb{!!!}. Using the operator out of context may lead to incorrect results, see \ifelse{html}{\link[=topic-inject-out-of-context]{What happens if I use injection operators out of context?}}{\link[=topic-inject-out-of-context]{What happens if I use injection operators out of context?}}. } \section{Splicing a list of arguments}{ Take a function like \code{\link[base:cbind]{base::rbind()}} that takes data in \code{...}. This sort of functions takes a variable number of arguments. \if{html}{\out{
}}\preformatted{df1 <- data.frame(x = 1) df2 <- data.frame(x = 2) rbind(df1, df2) #> x #> 1 1 #> 2 2 }\if{html}{\out{
}} Passing individual arguments is only possible for a fixed amount of arguments. When the arguments are in a list whose length is variable (and potentially very large), we need a programmatic approach like the splicing syntax \verb{!!!}: \if{html}{\out{
}}\preformatted{dfs <- list(df1, df2) inject(rbind(!!!dfs)) #> x #> 1 1 #> 2 2 }\if{html}{\out{
}} Because \code{rbind()} is a base function we used \code{\link[=inject]{inject()}} to explicitly enable \verb{!!!}. However, many functions implement \link[=list2]{dynamic dots} with \verb{!!!} implicitly enabled out of the box. \if{html}{\out{
}}\preformatted{tidyr::expand_grid(x = 1:2, y = c("a", "b")) #> # A tibble: 4 x 2 #> x y #> #> 1 1 a #> 2 1 b #> 3 2 a #> 4 2 b xs <- list(x = 1:2, y = c("a", "b")) tidyr::expand_grid(!!!xs) #> # A tibble: 4 x 2 #> x y #> #> 1 1 a #> 2 1 b #> 3 2 a #> 4 2 b }\if{html}{\out{
}} Note how the expanded grid has the right column names. That's because we spliced a \emph{named} list. Splicing causes each name of the list to become an argument name. \if{html}{\out{
}}\preformatted{tidyr::expand_grid(!!!set_names(xs, toupper)) #> # A tibble: 4 x 2 #> X Y #> #> 1 1 a #> 2 1 b #> 3 2 a #> 4 2 b }\if{html}{\out{
}} } \section{Splicing a list of expressions}{ Another usage for \verb{!!!} is to inject \link[=topic-defuse]{defused expressions} into \link[=topic-data-mask]{data-masked} dots. However this usage is no longer a common pattern for programming with tidyverse functions and we recommend using other patterns if possible. First, instead of using the \link[=topic-data-mask-programming]{defuse-and-inject pattern} with \code{...}, you can simply pass them on as you normally would. These two expressions are completely equivalent: \if{html}{\out{
}}\preformatted{my_group_by <- function(.data, ...) \{ .data \%>\% dplyr::group_by(!!!enquos(...)) \} # This equivalent syntax is preferred my_group_by <- function(.data, ...) \{ .data \%>\% dplyr::group_by(...) \} }\if{html}{\out{
}} Second, more complex applications such as \link[=topic-metaprogramming]{transformation patterns} can be solved with the \code{across()} operation introduced in dplyr 1.0. Say you want to take the \code{mean()} of all expressions in \code{...}. Before \code{across()}, you had to defuse the \code{...} expressions, wrap them in a call to \code{mean()}, and inject them in \code{summarise()}. \if{html}{\out{
}}\preformatted{my_mean <- function(.data, ...) \{ # Defuse dots and auto-name them exprs <- enquos(..., .named = TRUE) # Wrap the expressions in a call to `mean()` exprs <- purrr::map(exprs, ~ call("mean", .x, na.rm = TRUE)) # Inject them .data \%>\% dplyr::summarise(!!!exprs) \} }\if{html}{\out{
}} It is much easier to use \code{across()} instead: \if{html}{\out{
}}\preformatted{my_mean <- function(.data, ...) \{ .data \%>\% dplyr::summarise(across(c(...), ~ mean(.x, na.rm = TRUE))) \} }\if{html}{\out{
}} } \section{Performance of injected dots and dynamic dots}{ Take this \link[=dyn-dots]{dynamic dots} function: \if{html}{\out{
}}\preformatted{n_args <- function(...) \{ length(list2(...)) \} }\if{html}{\out{
}} Because it takes dynamic dots you can splice with \verb{!!!} out of the box. \if{html}{\out{
}}\preformatted{n_args(1, 2) #> [1] 2 n_args(!!!mtcars) #> [1] 11 }\if{html}{\out{
}} Equivalently you could enable \verb{!!!} explicitly with \code{\link[=inject]{inject()}}. \if{html}{\out{
}}\preformatted{inject(n_args(!!!mtcars)) #> [1] 11 }\if{html}{\out{
}} While the result is the same, what is going on under the hood is completely different. \code{\link[=list2]{list2()}} is a dots collector that special-cases \verb{!!!} arguments. On the other hand, \code{\link[=inject]{inject()}} operates on the language and creates a function call containing as many arguments as there are elements in the spliced list. If you supply a list of size 1e6, \code{inject()} is creating one million arguments before evaluation. This can be much slower. \if{html}{\out{
}}\preformatted{xs <- rep(list(1), 1e6) system.time( n_args(!!!xs) ) #> user system elapsed #> 0.009 0.000 0.009 system.time( inject(n_args(!!!xs)) ) #> user system elapsed #> 0.445 0.012 0.457 }\if{html}{\out{
}} The same issue occurs when functions taking dynamic dots are called inside a data-masking function like \code{dplyr::mutate()}. The mechanism that enables \verb{!!!} injection in these arguments is the same as in \code{inject()}. } \seealso{ \itemize{ \item \ifelse{html}{\link[=topic-inject]{Injecting with !!, !!!, and glue syntax}}{\link[=topic-inject]{Injecting with !!, !!!, and glue syntax}} \item \code{\link[=inject]{inject()}} \item \code{\link[=exec]{exec()}} } } rlang/man/set_names.Rd0000644000176200001440000000325514375670676014427 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/attr.R \name{set_names} \alias{set_names} \title{Set names of a vector} \usage{ set_names(x, nm = x, ...) } \arguments{ \item{x}{Vector to name.} \item{nm, ...}{Vector of names, the same length as \code{x}. If length 1, \code{nm} is recycled to the length of \code{x} following the recycling rules of the tidyverse.. You can specify names in the following ways: \itemize{ \item If not supplied, \code{x} will be named to \code{as.character(x)}. \item If \code{x} already has names, you can provide a function or formula to transform the existing names. In that case, \code{...} is passed to the function. \item Otherwise if \code{...} is supplied, \code{x} is named to \code{c(nm, ...)}. \item If \code{nm} is \code{NULL}, the names are removed (if present). }} } \description{ This is equivalent to \code{\link[stats:setNames]{stats::setNames()}}, with more features and stricter argument checking. } \section{Life cycle}{ \code{set_names()} is stable and exported in purrr. } \examples{ set_names(1:4, c("a", "b", "c", "d")) set_names(1:4, letters[1:4]) set_names(1:4, "a", "b", "c", "d") # If the second argument is ommitted a vector is named with itself set_names(letters[1:5]) # Alternatively you can supply a function set_names(1:10, ~ letters[seq_along(.)]) set_names(head(mtcars), toupper) # If the input vector is unnamed, it is first named after itself # before the function is applied: set_names(letters, toupper) # `...` is passed to the function: set_names(head(mtcars), paste0, "_foo") # If length 1, the second argument is recycled to the length of the first: set_names(1:3, "foo") set_names(list(), "") } rlang/man/topic-data-mask-ambiguity.Rd0000644000176200001440000002117714741441453017404 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/topic-nse.R \name{topic-data-mask-ambiguity} \alias{topic-data-mask-ambiguity} \title{The data mask ambiguity} \description{ \link[=topic-data-mask]{Data masking} is an R feature that blends programming variables that live inside environments (env-variables) with statistical variables stored in data frames (data-variables). This mixture makes it easy to refer to data frame columns as well as objects defined in the current environment. \if{html}{\out{
}}\preformatted{x <- 100 mtcars \%>\% dplyr::summarise(mean(disp / x)) #> # A tibble: 1 x 1 #> `mean(disp/x)` #> #> 1 2.31 }\if{html}{\out{
}} However this convenience introduces an ambiguity between data-variables and env-variables which might cause \strong{collisions}. \subsection{Column collisions}{ In the following snippet, are we referring to the env-variable \code{x} or to the data-variable of the same name? \if{html}{\out{
}}\preformatted{df <- data.frame(x = NA, y = 2) x <- 100 df \%>\% dplyr::mutate(y = y / x) #> x y #> 1 NA NA }\if{html}{\out{
}} A column collision occurs when you want to use an object defined outside of the data frame, but a column of the same name happens to exist. } \subsection{Object collisions}{ The opposite problem occurs when there is a typo in a data-variable name and an env-variable of the same name exists: \if{html}{\out{
}}\preformatted{df <- data.frame(foo = "right") ffo <- "wrong" df \%>\% dplyr::mutate(foo = toupper(ffo)) #> foo #> 1 WRONG }\if{html}{\out{
}} Instead of a typo, it might also be that you were expecting a column in the data frame which is unexpectedly missing. In both cases, if a variable can't be found in the data mask, R looks for variables in the surrounding environment. This isn't what we intended here and it would have been better to fail early with a "Column not found" error. } \subsection{Preventing collisions}{ In casual scripts or interactive programming, data mask ambiguity is not a huge deal compared to the payoff of iterating quickly while developing your analysis. However in production code and in package functions, the ambiguity might cause collision bugs in the long run. Fortunately it is easy to be explicit about the scoping of variables with a little more verbose code. This topic lists the solutions and workarounds that have been created to solve ambiguity issues in data masks. \subsection{The \code{.data} and \code{.env} pronouns}{ The simplest solution is to use the \code{\link{.data}} and \code{\link{.env}} pronouns to disambiguate between data-variables and env-variables. \if{html}{\out{
}}\preformatted{df <- data.frame(x = 1, y = 2) x <- 100 df \%>\% dplyr::mutate(y = .data$y / .env$x) #> x y #> 1 1 0.02 }\if{html}{\out{
}} This is especially useful in functions because the data frame is not known in advance and potentially contain masking columns for any of the env-variables in scope in the function: \if{html}{\out{
}}\preformatted{my_rescale <- function(data, var, factor = 10) \{ data \%>\% dplyr::mutate("\{\{ var \}\}" := \{\{ var \}\} / factor) \} # This works data.frame(value = 1) \%>\% my_rescale(value) #> value #> 1 0.1 # Oh no! data.frame(factor = 0, value = 1) \%>\% my_rescale(value) #> factor value #> 1 0 Inf }\if{html}{\out{
}} Subsetting function arguments with \code{.env} ensures we never hit a masking column: \if{html}{\out{
}}\preformatted{my_rescale <- function(data, var, factor = 10) \{ data \%>\% dplyr::mutate("\{\{ var \}\}" := \{\{ var \}\} / .env$factor) \} # Yay! data.frame(factor = 0, value = 1) \%>\% my_rescale(value) #> factor value #> 1 0 0.1 }\if{html}{\out{
}} } \subsection{Subsetting \code{.data} with env-variables}{ The \code{\link{.data}} pronoun may be used as a name-to-data-mask pattern (see \ifelse{html}{\link[=topic-data-mask-programming]{Data mask programming patterns}}{\link[=topic-data-mask-programming]{Data mask programming patterns}}): \if{html}{\out{
}}\preformatted{var <- "cyl" mtcars \%>\% dplyr::summarise(mean = mean(.data[[var]])) #> # A tibble: 1 x 1 #> mean #> #> 1 6.19 }\if{html}{\out{
}} In this example, the env-variable \code{var} is used inside the data mask to subset the \code{.data} pronoun. Does this mean that \code{var} is at risk of a column collision if the input data frame contains a column of the same name? Fortunately not: \if{html}{\out{
}}\preformatted{var <- "cyl" mtcars2 <- mtcars mtcars2$var <- "wrong" mtcars2 \%>\% dplyr::summarise(mean = mean(.data[[var]])) #> # A tibble: 1 x 1 #> mean #> #> 1 6.19 }\if{html}{\out{
}} The evaluation of \code{.data[[var]]} is set up in such a way that there is no ambiguity. The \code{.data} pronoun can only be subsetted with env-variables, not data-variables. Technically, this is because \code{[[} behaves like an \emph{injection operator} when applied to \code{.data}. It is evaluated very early before the data mask is even created. See the \verb{!!} section below. } \subsection{Injecting env-variables with \verb{!!}}{ \link[=topic-inject]{Injection operators} such as \code{\link[=injection-operator]{!!}} have interesting properties regarding the ambiguity problem. They modify a piece of code early on by injecting objects or other expressions before any data-masking logic comes into play. If you inject the \emph{value} of a variable, it becomes inlined in the expression. R no longer needs to look up any variable to find the value. Taking the earlier division example, let's use \verb{!!} to inject the value of the env-variable \code{x} inside the division expression: \if{html}{\out{
}}\preformatted{df <- data.frame(x = NA, y = 2) x <- 100 df \%>\% dplyr::mutate(y = y / !!x) #> x y #> 1 NA 0.02 }\if{html}{\out{
}} While injection solves issues of ambiguity, it is a bit heavy handed compared to using the \code{\link{.env}} pronoun. Big objects inlined in expressions might cause issues in unexpected places, for instance they might make the calls in a \code{\link[=traceback]{traceback()}} less readable. } } \subsection{No ambiguity in tidy selections}{ \href{https://tidyselect.r-lib.org/reference/language.html}{Tidy selection} is a dialect of R that optimises column selection in tidyverse packages. Examples of functions that use tidy selections are \code{dplyr::select()} and \code{tidyr::pivot_longer()}. Unlike data masking, tidy selections do not suffer from ambiguity. The selection language is designed in such a way that evaluation of expressions is either scoped in the data mask only, or in the environment only. Take this example: \if{html}{\out{
}}\preformatted{mtcars \%>\% dplyr::select(gear:ncol(mtcars)) }\if{html}{\out{
}} \code{gear} is a symbol supplied to a selection operator \code{:} and thus scoped in the data mask only. Any other kind of expression, such as \code{ncol(mtcars)}, is evaluated as normal R code outside of any data context. This is why there is no column collision here: \if{html}{\out{
}}\preformatted{data <- data.frame(x = 1, data = 1:3) data \%>\% dplyr::select(data:ncol(data)) #> data #> 1 1 #> 2 2 #> 3 3 }\if{html}{\out{
}} It is useful to introduce two new terms. Tidy selections distinguish data-expressions and env-expressions: \itemize{ \item \code{data} is a data-expression that refers to the data-variable. \item \code{ncol(data)} is an env-expression that refers to the env-variable. } To learn more about the difference between the two kinds of expressions, see the \href{https://tidyselect.r-lib.org/articles/syntax.html}{technical description of the tidy selection syntax}. \subsection{Names pattern with \code{all_of()}}{ \code{all_of()} is often used in functions as a \link[=topic-data-mask-programming]{programming pattern} that connects column names to a data mask, similarly to the \code{\link{.data}} pronoun. A simple example is: \if{html}{\out{
}}\preformatted{my_group_by <- function(data, vars) \{ data \%>\% dplyr::group_by(across(all_of(vars))) \} }\if{html}{\out{
}} If tidy selections were affected by the data mask ambiguity, this function would be at risk of a column collision. It would break as soon as the user supplies a data frame containing a \code{vars} column. However, \code{all_of()} is an env-expression that is evaluated outside of the data mask, so there is no possibility of collisions. } } } \keyword{internal} rlang/man/interrupt.Rd0000644000176200001440000000060714375670676014503 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cnd-signal.R \name{interrupt} \alias{interrupt} \title{Simulate interrupt condition} \usage{ interrupt() } \description{ \code{interrupt()} simulates a user interrupt of the kind that is signalled with \code{Ctrl-C}. It is currently not possible to create custom interrupt condition objects. } \keyword{internal} rlang/man/rlang-package.Rd0000644000176200001440000000211514401416540015111 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/rlang-package.R \docType{package} \name{rlang-package} \alias{rlang} \alias{rlang-package} \title{rlang: Functions for Base Types and Core R and 'Tidyverse' Features} \description{ \if{html}{\figure{logo.png}{options: style='float: right' alt='logo' width='120'}} A toolbox for working with base types, core R features like the condition system, and core 'Tidyverse' features like tidy evaluation. } \seealso{ Useful links: \itemize{ \item \url{https://rlang.r-lib.org} \item \url{https://github.com/r-lib/rlang} \item Report bugs at \url{https://github.com/r-lib/rlang/issues} } } \author{ \strong{Maintainer}: Lionel Henry \email{lionel@posit.co} Authors: \itemize{ \item Hadley Wickham \email{hadley@posit.co} } Other contributors: \itemize{ \item mikefc \email{mikefc@coolbutuseless.com} (Hash implementation based on Mike's xxhashlite) [copyright holder] \item Yann Collet (Author of the embedded xxHash library) [copyright holder] \item Posit, PBC [copyright holder, funder] } } \keyword{internal} rlang/DESCRIPTION0000644000176200001440000000320214742464552013075 0ustar liggesusersPackage: rlang Version: 1.1.5 Title: Functions for Base Types and Core R and 'Tidyverse' Features Description: A toolbox for working with base types, core R features like the condition system, and core 'Tidyverse' features like tidy evaluation. Authors@R: c( person("Lionel", "Henry", ,"lionel@posit.co", c("aut", "cre")), person("Hadley", "Wickham", ,"hadley@posit.co", "aut"), person(given = "mikefc", email = "mikefc@coolbutuseless.com", role = "cph", comment = "Hash implementation based on Mike's xxhashlite"), person(given = "Yann", family = "Collet", role = "cph", comment = "Author of the embedded xxHash library"), person(given = "Posit, PBC", role = c("cph", "fnd")) ) License: MIT + file LICENSE ByteCompile: true Biarch: true Depends: R (>= 3.5.0) Imports: utils Suggests: cli (>= 3.1.0), covr, crayon, fs, glue, knitr, magrittr, methods, pillar, rmarkdown, stats, testthat (>= 3.0.0), tibble, usethis, vctrs (>= 0.2.3), withr Enhances: winch Encoding: UTF-8 RoxygenNote: 7.3.2 URL: https://rlang.r-lib.org, https://github.com/r-lib/rlang BugReports: https://github.com/r-lib/rlang/issues Config/testthat/edition: 3 Config/Needs/website: dplyr, tidyverse/tidytemplate NeedsCompilation: yes Packaged: 2025-01-17 08:43:17 UTC; lionel Author: Lionel Henry [aut, cre], Hadley Wickham [aut], mikefc [cph] (Hash implementation based on Mike's xxhashlite), Yann Collet [cph] (Author of the embedded xxHash library), Posit, PBC [cph, fnd] Maintainer: Lionel Henry Repository: CRAN Date/Publication: 2025-01-17 14:30:02 UTC