zeallot/ 0000755 0001762 0000144 00000000000 15015306442 011724 5 ustar ligges users zeallot/tests/ 0000755 0001762 0000144 00000000000 14775576725 013117 5 ustar ligges users zeallot/tests/testthat/ 0000755 0001762 0000144 00000000000 15015306442 014726 5 ustar ligges users zeallot/tests/testthat/test-utils.R 0000644 0001762 0000144 00000000000 15010640533 017151 0 ustar ligges users zeallot/tests/testthat/test-error-handling.R 0000644 0001762 0000144 00000001777 15013205715 020754 0 ustar ligges users test_that("error halts assignment", { expect_error(c(x, y) %<-% c(1, b)) expect_error(x, "object 'x' not found") expect_error(y, "object 'y' not found") }) test_that("force non-zeallot errors early", { g <- function() { stop("stop here") 1 } f <- function() { g() } err <- expect_error(c(x, y) %<-% list(1, f())) err_trace <- lapply(rev(err$trace$call), deparse) expect_equal(err_trace[[1]], "g()") expect_equal(err_trace[[2]], "f()") expect_equal(err_trace[[3]], "force(value)") expect_equal(err_trace[[4]], "c(x, y) %<-% list(1, f())") }) test_that("warning allows assignment", { f <- function() { warning("giving an f") "f" } expect_warning(c(x) %<-% list(f()), "giving an f") expect_equal(x, "f") }) test_that("message allows assignment", { echo <- function(expr) { message(deparse(substitute(expr))) expr } expect_message( c(x, y) %<-% c(1, echo(1 + 1)), "1 + 1", fixed = TRUE ) expect_equal(x, 1) expect_equal(y, 2) }) zeallot/tests/testthat/test-collectors.R 0000644 0001762 0000144 00000002630 15013206545 020201 0 ustar ligges users test_that("collect start", { c(.., y) %<-% 1:5 expect_equal(y, 5) c(..x, y) %<-% 1:5 expect_equal(x, list(1, 2, 3, 4)) expect_equal(y, 5) }) test_that("collect middle", { c(x, .., z) %<-% 1:5 expect_equal(x, 1) expect_equal(z, 5) c(x, ..y, z) %<-% 5:1 expect_equal(x, 5) expect_equal(y, list(4, 3, 2)) expect_equal(z, 1) }) test_that("collect end", { c(x, ..) %<-% 1:3 expect_equal(x, 1) c(x, ..y) %<-% 1:3 expect_equal(x, 1) expect_equal(y, list(2, 3)) }) test_that("defaults to NULL", { c(x, ..y) %<-% list(1) expect_equal(x, 1) expect_equal(y, NULL) }) test_that("default values", { c(x, ..y = NA) %<-% list(1) expect_equal(x, 1) expect_equal(y, NA) }) test_that("trailing excess collector does nothing", { c(x, ..) %<-% list(1) expect_equal(x, 1) expect_error(.., "object '..' not found") }) test_that("leading excess collector is ignored", { c(.., x) %<-% list(1) expect_equal(x, 1) expect_error(.., "object '..' not found") c(..y, x) %<-% list(2) expect_equal(x, 2) expect_equal(y, NULL) }) test_that("old syntax is deprecated", { expect_warning(c(x, ...y) %<-% list(1), "collector syntax has changed") expect_silent(c(x, ...y) %<-% list(1)) dep_warn_reset() expect_warning(c(x, ...y) %<-% list(1), " [*] `[.]{3}y` => `[.]{2}y`") dep_warn_reset() expect_warning(list(1) %->% c(x, ...y), "collector syntax has changed") }) zeallot/tests/testthat/test-pipe.R 0000644 0001762 0000144 00000000255 15013266631 016770 0 ustar ligges users test_that("native pipe", { 1:5 |> vapply(\(x) x <= 1, logical(1)) %->% c(x, ..y) expect_equal(x, TRUE) expect_equal(y, list(FALSE, FALSE, FALSE, FALSE)) }) zeallot/tests/testthat/test-destructure.R 0000644 0001762 0000144 00000001247 15010640533 020400 0 ustar ligges users test_that("included data.frame implementation", { c(mpg, cyl, .., carb) %<-% mtcars expect_equal(mpg, mtcars$mpg) expect_equal(cyl, mtcars$cyl) expect_equal(carb, mtcars$carb) }) test_that("included summary implementation", { summ <- summary(lm(mpg ~ cyl, mtcars)) c(., terms) %<-% summ expect_equal(terms, summ$terms) }) test_that("custom implementation", { registerS3method("destructure", "Date", function(x) { ymd <- strftime(x, "%Y-%m-%d") pieces <- strsplit(ymd, "-", fixed = TRUE) as.numeric(pieces[[1]]) }) c(year, month, day) %<-% as.Date("2000-01-10") expect_equal(year, 2000) expect_equal(month, 1) expect_equal(day, 10) }) zeallot/tests/testthat/test-zeallous.R 0000644 0001762 0000144 00000004743 15010640533 017671 0 ustar ligges users test_that("prevent no visible bindings", { skip_if_not_installed("codetools") nums <- function() { c(one, two) %<-% list(1, 2) four %<-% 4 c(one, two, three, four) } problems <- "" codetools::checkUsage( fun = nums, report = function(x) { problems <<- paste0(problems, x) } ) expect_false(grepl("one", problems)) expect_false(grepl("two", problems)) expect_false(grepl("four", problems)) expect_true(grepl("three", problems)) }) test_that("more variables left-side", { skip_if_not_installed("codetools") nums <- function() { c(one, two, three) %<-% list(1, 2, 3) c(one, two, three) } problems <- "" codetools::checkUsage( fun = nums, report = function(x) { problems <<- paste0(problems, x) } ) expect_false(grepl("one", problems)) expect_false(grepl("two", problems)) expect_false(grepl("three", problems)) }) test_that("more complex right-side", { skip_if_not_installed("codetools") nums <- function() { c(one, two) %<-% { list(1, 2) } c(one, two) } problems <- "" codetools::checkUsage( fun = nums, report = function(x) { problems <<- paste0(problems, x) } ) expect_false(grepl("one", problems)) expect_false(grepl("two", problems)) }) test_that("collectors are properly recognized", { skip_if_not_installed("codetools") func <- function() { c(first, ..middle, last) %<-% list(1, 2, 3, 4) c(first, middle, last) } problems <- "" codetools::checkUsage( fun = nums, report = function(x) { problems <<- paste0(problems, x) } ) expect_false(grepl("first", problems)) expect_false(grepl("..middle", problems)) expect_false(grepl("middle", problems)) expect_false(grepl("last", problems)) # func <- function() { # c(first, ...) %<-% list(1, 2, 3, 4) # # last # first # } # # problems <- "" # # codetools::checkUsage( # fun = nums, # report = function(x) { # problems <<- paste0(problems, x) # } # ) # # expect_false(grepl("first", problems)) # expect_false(grepl("...", problems)) }) test_that("if statement one-liner", { skip_if_not_installed("codetools") if_one_liner <- function() { if (TRUE) c(x, y) %<-% list(1, 2) c(x, y) } problems <- "" codetools::checkUsage( fun = if_one_liner, report = function(x) { problems <<- paste0(problems, x) } ) expect_false(grepl("x", problems)) expect_false(grepl("y", problems)) }) zeallot/tests/testthat/test-operator.R 0000644 0001762 0000144 00000004315 15010640533 017661 0 ustar ligges users test_that("standard assignment", { x %<-% 1 expect_equal(x, 1) y %<-% list(1, 2, 3) expect_equal(y, list(1, 2, 3)) 1 %->% z expect_equal(z, 1) }) test_that("invisibly returns `value`", { expect_equal((x %<-% 1), 1) expect_equal(c(x, y) %<-% c(1, 2), c(1, 2)) }) test_that("multiple assignment", { c(x, y) %<-% list(1, 2) expect_equal(x, 1) expect_equal(y, 2) }) test_that("in-place assignment", { l <- list() c(l[[1]], l[[2]]) %<-% list(3, 4) expect_equal(l[[1]], 3) expect_equal(l[[2]], 4) e <- new.env(parent = emptyenv()) c(e$hello) %<-% list("world") expect_equal(e$hello, "world") }) test_that("nested assignment", { c(c(x, y), z) %<-% list(list(1, 2), 3) expect_equal(x, 1) expect_equal(y, 2) expect_equal(z, 3) }) test_that("skip value using .", { c(x, ., z) %<-% list(1, 2, 3) expect_equal(x, 1) expect_equal(z, 3) expect_false(exists(".", inherits = FALSE)) }) test_that("default values", { c(x, y = 2) %<-% list(1) expect_equal(x, 1) expect_equal(y, 2) c(x, y = 3, z = 4) %<-% list(2) expect_equal(x, 2) expect_equal(y, 3) expect_equal(z, 4) c(x, y = NULL) %<-% list(3) expect_equal(x, 3) expect_equal(y, NULL) }) test_that("default values get ignored", { c(x = 3, y = 4) %<-% list(1, 2) expect_equal(x, 1) expect_equal(y, 2) }) test_that("assignment by name", { c(y=) %<-% list(x = 1, y = 2) expect_equal(y, 2) c(y=, z=) %<-% list(x = 3, y = 4, z = 5) expect_equal(y, 4) expect_equal(z, 5) }) test_that("assignment by name affects positional assignments", { c(x=, y) %<-% list(y = 4, x = 2) expect_equal(x, 2) expect_equal(y, 2) }) test_that("assign symbols", { x %<-% quote(y) c(y) %<-% list(quote(z)) expect_equal(x, quote(y)) expect_equal(y, quote(z)) }) test_that("assign NULL", { x %<-% NULL c(y) %<-% list(NULL) expect_equal(x, NULL) expect_equal(y, NULL) }) test_that("positional variables expect values", { expect_error(c(x, y) %<-% list(1), "missing value for variable `y`") expect_error(c(x=, y) %<-% list(1), "missing value for variable `y") }) test_that("trailing skip does nothing", { c(x, .) %<-% list(1) expect_equal(x, 1) expect_error(., "object '.' not found") }) zeallot/tests/testthat.R 0000644 0001762 0000144 00000000072 14775576725 015101 0 ustar ligges users library(testthat) library(zeallot) test_check("zeallot") zeallot/MD5 0000644 0001762 0000144 00000003303 15015306442 012233 0 ustar ligges users c441241853301b6d7e8c47a32f3fb0e7 *DESCRIPTION 81bb22d15833c773c4959b88d9eeb041 *LICENSE acad0e6df79594463f7afd3a45aabde1 *NAMESPACE edcb339206f1831c052afe3383440021 *NEWS.md d095a5023a6b9f3d32091dc0a6033ec9 *R/destructure.R 8427799994ae4f73c0fe4ac68c81e5b0 *R/operator.R dbbff15c68b972b85076c753c1a4c2ec *R/unpack.R 8eeb4cee5009b23e6436d10d2ebe141f *R/utils-collectors.R cf5877bef479b641d6e13e37695dae51 *R/utils-errors.R dff1051fb5cc3ea36eb11bca73cf5160 *R/utils-vars.R 3660e95ea6c13ec7f6a61ef8ab204513 *R/utils.R 0367c69e86a410f4a7ce6a75f99c44c4 *R/zeallot.R 01d50e44dae9891e6a9967726baae958 *R/zeallous.R 90edad4e53b5139485457a38e02f17f9 *R/zzz.R dc8a003f3a87e74bc6ad6c617d9666dc *README.md a4fe3d7e1101c006877f033168d3d215 *build/vignette.rds 4f5c595d4c00338da997b4a528e6bbc1 *inst/doc/unpacking-assignment.R 6042d8a0322db52b815acc8a02b22bbf *inst/doc/unpacking-assignment.Rmd 6c47c47b0b4180fe88b74995a00a344a *inst/doc/unpacking-assignment.html 211b2e2231f5a43900e380f1b5e1fc29 *man/destructure.Rd 2e17ac60a94d1df5010e426e1b17eb6f *man/operator.Rd 7f720dc705f67a462acdd6edf00cf283 *man/zeallot.Rd a0fefdfa83c5e55a8f37785226f3d209 *man/zeallous.Rd 6a5da9164f3f30e99da941b75a0b3dd2 *tests/testthat.R 39f8ea7963a9b3e5d33f39348e134b86 *tests/testthat/test-collectors.R 2f9ddf2b46e6671133411e7ee429edf9 *tests/testthat/test-destructure.R 9170c6b41e39af277d79473dfa5274a9 *tests/testthat/test-error-handling.R a37e60ede6f6e9582ace4225ab37592e *tests/testthat/test-operator.R 4d7c86ba557bf338a80ed09cf18ecd59 *tests/testthat/test-pipe.R d41d8cd98f00b204e9800998ecf8427e *tests/testthat/test-utils.R c77391e7bbf5f2e9e8326802f9492ca4 *tests/testthat/test-zeallous.R 6042d8a0322db52b815acc8a02b22bbf *vignettes/unpacking-assignment.Rmd zeallot/R/ 0000755 0001762 0000144 00000000000 15013100574 012121 5 ustar ligges users zeallot/R/utils-vars.R 0000644 0001762 0000144 00000003657 15013202424 014365 0 ustar ligges users var_name <- function(var) { n <- if (is_named(var)) { names(var) } else { car(var) } if (is_deprecated_collector(n)) { deprecated_collector_warn() deprecated_collector_name(n) } else if (is_collector(n)) { collector_name(n) } else { as.character(n) } } var_symbol <- function(var) { as.symbol(var_name(var)) } var_has_default <- function(var) { is_named(var) } var_default <- function(var) { if (!var_has_default(var)) { return() } car(var) } var_value <- function(var, val, lookup) { if (var_is_empty(var)) { lookup[[var_name(var)]] } else if (val_is_null(val) && var_has_default(var)) { var_default(var) } else { car(val) } } val_is_null <- function(val) { is.null(car(val)) } var_is_empty <- function(var) { isTRUE(car(var) == quote("")) } var_is_skip <- function(var) { identical(car(var), quote(.)) } var_is_anonymous_collector <- function(var) { if (identical(car(var), quote(...))) { deprecated_collector_warn() return(TRUE) } identical(car(var), quote(..)) } var_is_collector <- function(var) { length(var) == 1 && (is_collector(car(var)) || is_deprecated_collector(car(var))) } var_search <- function(expr) { switch( typeof(expr), language = var_search_language(as.list(expr)), symbol = var_search_symbol(list(expr)) ) } var_search_next <- function(vars) { if (is_empty_list(vars)) { return() } c( switch( peek_type(vars), language = var_search_language(as.list(car(vars))), collector = var_search_collector(first(vars)), symbol = var_search_symbol(first(vars)) ), var_search_next(cdr(vars)) ) } var_search_language <- function(vars) { switch( as.character(car(vars)), c = var_search_next(cdr(vars)) ) } var_search_symbol <- function(var) { var_name(var) } var_search_collector <- function(var) { c(paste0("..", var_name(var)), var_name(var)) } zeallot/R/utils-errors.R 0000644 0001762 0000144 00000001017 15013104354 014715 0 ustar ligges users local_error_call <- function() { sys_calls <- sys.calls() assignment_calls <- grepl("(%<-%|%->%)", as.character(sys_calls)) if (!any(assignment_calls)) { return() } sys_calls[assignment_calls][[1]] } local_error_cnd <- function(msg) { errorCondition( message = msg, class = "zeallot_assignment_error", call = local_error_call() ) } local_error_stop <- function(..., sep = "", collapse = "\n") { stop( local_error_cnd( paste(..., sep = sep, collapse = collapse) ) ) } zeallot/R/zzz.R 0000644 0001762 0000144 00000000066 15000064774 013112 0 ustar ligges users .onLoad <- function(libname, pkgname) { zeallous() } zeallot/R/utils-collectors.R 0000644 0001762 0000144 00000003110 15013206557 015556 0 ustar ligges users is_collector <- function(x) { isTRUE(startsWith(as.character(x), "..")) } collector_name <- function(x) { sub("^[.]{2}", "", as.character(x)) } is_deprecated_collector <- function(x) { isTRUE(startsWith(as.character(x), "...")) } deprecated_collector_name <- function(x) { sub("^[.]{3}", "", as.character(x)) } dep_warn_env <- list2env(list(warn = TRUE), parent = emptyenv()) dep_warn_reset <- function() { (dep_warn_env$warn <- TRUE) } dep_warn_once <- function(cnd) { if (isTRUE(dep_warn_env$warn)) { dep_warn_env$warn <- FALSE warning(cnd) } } dep_warn_call <- function() { sys_calls <- sys.calls() assignment_calls <- grepl("([.]{3}.+%<-%|%->%.+[.]{3})", as.character(sys_calls)) if (!any(assignment_calls)) { return() } sys_calls[assignment_calls][[1]] } dep_warn_suggest_fix <- function(call) { if (length(call) == 0) { return() } call_str <- paste(deparse(call), collapse = " ") collector_str <- regmatches(call_str, regexpr("[.]{3}[^\\s,\\)]+", call_str, perl = TRUE)) collector_fix <- sub("...", "..", collector_str, fixed = TRUE) paste0("`", collector_str, "` => `", collector_fix, "`") } dep_warn_msg <- function(call) { paste0( "collector syntax has changed,\n", " * Please use `..` instead of `...`\n", " * ", dep_warn_suggest_fix(call) ) } dep_warn_cond <- function() { call <- dep_warn_call() warningCondition( message = dep_warn_msg(call), class = "deprecated_collector_warning", call = call ) } deprecated_collector_warn <- function() { dep_warn_once(dep_warn_cond()) } zeallot/R/unpack.R 0000644 0001762 0000144 00000003723 15013104407 013531 0 ustar ligges users unpack <- function( vars, vals ) { switch( typeof(vars), language = unpack_language(list(vars), list(vals), vals), symbol = list(list(vars, vals)) ) } unpack_next <- function( vars, vals, lookup = list() ) { if (is_empty_list(vars)) { return() } switch( peek_type(vars), language = unpack_language(vars, vals, lookup), symbol = unpack_symbol(vars, vals, lookup), collector = unpack_collector(vars, vals, lookup) ) } unpack_language <- function( vars, vals, lookup = list() ) { lang <- as.list(car(vars)) switch( peek_symbol(lang), `[[` = , `[` = , `$` = unpack_extract(vars, vals), `c` = c( unpack_next(cdr(lang), destructure(car(vals)), car(vals)), unpack_next(cdr(vars), cdr(vals), lookup) ), local_error_stop( "unexpected call `", deparse(lang[[1]], backtick = TRUE), "`" ) ) } unpack_symbol <- function( vars, vals, lookup = list() ) { var <- first(vars) val <- first(vals) if (var_is_skip(var) || var_is_anonymous_collector(var)) { return(unpack_next(cdr(vars), cdr(vals), lookup)) } if (is_empty_list(vals) && !var_has_default(var)) { local_error_stop( "missing value for variable `", var_name(var), "`" ) } prepend( list(var_symbol(var), var_value(var, val, lookup)), unpack_next(cdr(vars), cdr(vals), lookup) ) } unpack_extract <- function( vars, vals, lookup = list() ) { prepend( list(car(vars), car(vals)), unpack_next(cdr(vars), cdr(vals), lookup) ) } unpack_collector <- function( vars, vals, lookup = list() ) { if (length(vars) == length(vals)) { unpack_symbol(vars, vals, lookup) } else if (length(vars) > length(vals)) { c( unpack_symbol(first(vars), list(NULL)), unpack_next(cdr(vars), vals, lookup) ) } else if (length(vars) < length(vals)) { unpack_collector(vars, list_compress(vals, length(vars)), lookup) } } zeallot/R/utils.R 0000644 0001762 0000144 00000002407 15010640533 013410 0 ustar ligges users is_named <- function(x) { any(names(x) != "") } is_empty_list <- function(x) { length(x) == 0 && identical(class(x), "list") } peek_symbol <- function(x) { as.character(car(x)) } peek_type <- function(x) { if (is_named(first(x))) { n <- names(first(x)) if (is_collector(n) || is_deprecated_collector(n)) { return("collector") } else { return("symbol") } } if (var_is_collector(first(x))) { return("collector") } typeof(car(x)) } first <- function(x) { x[1] } car <- function(cons) { cons[[1]] } cdr <- function(cons) { cons[-1] } prepend <- function(x, y) { if (is.null(x)) { y } else { c(list(x), y) } } list_compress <- function(x, len) { stopifnot( is.list(x) ) if (length(x) <= len) { return(x) } list_compress(c(list(c(x[[1]], x[2])), x[c(-1, -2)]), len) } list_assign <- function(x, envir = parent.frame()) { if (is_empty_list(x)) { return() } pair <- car(x) name <- pair[[1]] value <- pair[[2]] eval(call("<-", name, bquote(quote(.(value)))), envir = envir) list_assign(cdr(x), envir) } attempt_assign <- function(expr, call = sys.call(-1)) { tryCatch( error = function(cnd) { stop(simpleError(conditionMessage(cnd), call)) }, expr ) } zeallot/R/zeallot.R 0000644 0001762 0000144 00000000603 14775576725 013752 0 ustar ligges users #' Multiple, unpacking, and destructuring assignment in R #' #' zeallot provides a \code{\link{\%<-\%}} operator to perform multiple #' assignment in R. To get started with zeallot be sure to read over the #' introductory vignette on unpacking assignment, #' \code{vignette('unpacking-assignment')}. #' #' @seealso \code{\link{\%<-\%}} #' #' @docType package #' @name zeallot "_PACKAGE" zeallot/R/zeallous.R 0000644 0001762 0000144 00000003645 15010640533 014113 0 ustar ligges users is_assignment <- function(x) { x == "%<-%" || x == "%->%" } usage_handler_empty <- function(expr, walker) { } usage_handler_default <- function(expr, walker) { exprs_list <- as.list(expr) exprs_lengths <- lengths(exprs_list) exprs_possible <- exprs_list[exprs_lengths == 3] for (e in exprs_possible) { if (is_assignment(e[[1]])) { var_names <- var_search(e[[2]]) if (length(var_names) > 0) { walker$startCollectLocals(var_names, character(), walker) } } } } add_usage_handler <- function(handlers, nm, f) { stopifnot( is.character(nm), is.function(f) ) prev_handler <- handlers[[nm]] if (is.null(prev_handler)) { prev_handler <- usage_handler_empty } handlers[[nm]] <- function(expr, walker) { f(expr, walker) prev_handler(expr, walker) } invisible(handlers) } #' Allow zeallous assignment #' #' Using zeallot within an R package may cause `R CMD check` to raise NOTEs #' concerning variables with `"no visible binding"`. To avoid these NOTEs, #' include a call to `zeallous()` in a package's `.onLoad()` function. #' #' The `R CMD check` process uses a package `{codetools}` to check for assigned #' variables. However, due to the non-standard nature of zeallot assignment the #' codetools package does not identify these variables. To work around this, the #' `zeallous()` function modifies the variables found by codetools to avoid #' the NOTEs raised by `R CMD check`. #' #' @export #' #' @examples #' #' .onLoad <- function(libname, pkgname) { #' zeallous() #' } #' zeallous <- function() { if (!requireNamespace("codetools", quietly = TRUE)) { return() } codetools <- asNamespace("codetools") usage_handlers <- codetools$collectUsageHandlers if (!is.environment(usage_handlers)) { return() } add_usage_handler(usage_handlers, "{", usage_handler_default) add_usage_handler(usage_handlers, "if", usage_handler_default) } zeallot/R/operator.R 0000644 0001762 0000144 00000007724 15013454600 014113 0 ustar ligges users #' Multiple assignment operators #' #' Assign values to name(s). #' #' @param x A name structure, see section below. #' #' @param value A list of values, vector of values, or \R object to assign. #' #' @section Name Structure: #' #' **The basics** #' #' At its simplest, the name structure is a single variable name, in which #' case \code{\%<-\%} and \code{\%->\%} perform regular assignment, \code{x #' \%<-\% list(1, 2, 3)} or \code{list(1, 2, 3) \%->\% x}. #' #' To specify multiple variable names use `c()`, for example \code{c(x, y, z) #' \%<-\% c(1, 2, 3)}. #' #' When `value` is neither an atomic vector nor a list, \code{\%<-\%} and #' \code{\%->\%} will try to destructure `value` into a list before assigning #' variables, see [destructure()]. #' #' **In-place assignment** #' #' One may also assign into a list or environment, \code{c(x, x[[1]]) \%<-\% #' list(list(), 1)}. #' #' **Nested names** #' #' One can also nest calls to `c()`, `c(x, c(y, z))`. This nested structure is #' used to unpack nested values, \code{c(x, c(y, z)) \%<-\% list(1, list(2, #' 3))}. #' #' **Collector variables** #' #' To gather extra values from the beginning, middle, or end of `value` use a #' collector variable. Collector variables are indicated with the `..` #' prefix, \code{c(..x, y) \%<-\% list(1, 2, 3, 4)}. #' #' **Skipping values** #' #' Use `.` in place of a variable name to skip a value without raising an error #' or assigning the value, \code{c(x, ., z) \%<-\% list(1, 2, 3)}. #' #' Use `..` to skip multiple values without raising an error or assigning the #' values, \code{c(w, .., z) \%<-\% list(1, NA, NA, 4)}. #' #' **Default values** #' #' Use `=` with a value to specify a default value for a variable, #' \code{c(x, y = NULL) \%<-\% list(1)}. #' #' Unfortunately, using a default value with in-place assignment raises an error #' because of \R's syntax, \code{c(x, x[[1]] = 1) \%<-\% list(list())}. #' #' **Named assignment** #' #' Use `=` _without_ a value to assign values by name, `c(two=) %<-% #' list(one = 1, two = 2, three = 3)`. #' #' @return #' #' \code{\%<-\%} and \code{\%->\%} invisibly return `value`. #' #' These operators are used primarily for their assignment side-effect. #' \code{\%<-\%} and \code{\%->\%} assign into the environment in which they #' are evaluated. #' #' @seealso #' #' For more on unpacking custom objects please refer to #' [destructure()]. #' #' @name operator #' @export #' @examples #' # Basic usage #' c(x, y) %<-% list(0, 1) #' #' # Unpack and assign nested values #' c(c(x, y), z) %<-% list(list(2, 3), list(3, 4)) #' #' # Assign columns of data frame #' c(eruptions, waiting) %<-% faithful #' #' # Assign specific columns by name #' c(mpg=, hp=, gear=) %<-% mtcars #' #' # Alternatively, assign a column by position #' c(first_col, .., last_col) %<-% mtcars #' #' # Skip initial values, assign final value #' todo_list <- list("1. Make food", "2. Pack lunch", "3. Save world") #' #' c(.., final_todo) %<-% todo_list #' #' # Assign first name, skip middle initial, assign last name #' c(first_name, ., last_name) %<-% c("Ursula", "K", "Le Guin") #' #' # Unpack nested values w/ nested names #' fibs <- list(1, list(2, list(3, list(5)))) #' #' c(f2, c(f3, c(f4, c(f5)))) %<-% fibs #' #' # Unpack first numeric, leave rest #' c(f2, ..rest) %<-% unlist(fibs) #' #' # Swap values without using temporary variables #' c(a, b) %<-% c("eh", "bee") #' #' c(a, b) %<-% c(b, a) #' #' # Handle missing values with default values #' parse_time <- function(x) { #' strsplit(x, " ")[[1]] #' } #' #' c(hour, period = NA) %<-% parse_time("10:00 AM") #' #' c(hour, period = NA) %<-% parse_time("15:00") #' #' # Right operator #' list(1, 2, "a", "b", "c") %->% c(x, y, ..z) #' `%<-%` <- function(x, value) { force(value) pairs <- unpack(substitute(x), value) list_assign(pairs, parent.frame()) invisible(value) } #' @rdname operator #' @export `%->%` <- function(value, x) { force(value) pairs <- unpack(substitute(x), value) list_assign(pairs, parent.frame()) invisible(value) } zeallot/R/destructure.R 0000644 0001762 0000144 00000003245 15010640533 014622 0 ustar ligges users #' Destructure an object #' #' `destructure` is used during unpacking assignment to coerce an object into a #' list. Individual elements of the list are assigned to names on the left-hand #' side of the unpacking assignment expression. #' #' @param x An \R object. #' #' @details #' #' New implementations of `destructure` can be very simple. A new `destructure` #' implementation might only strip away the class of a custom object and return #' the underlying list structure. Alternatively, an object might destructure #' into a nested set of values and may require a more complicated #' implementation. In either case, new implementations must return a list object #' so \code{\%<-\%} can handle the returned value(s). #' #' @seealso \code{\link{\%<-\%}} #' #' @export #' #' @examples #' #' # Data frames become a list of columns #' destructure(faithful) #' #' # A simple shape class #' shape <- function(sides = 4, color = "red") { #' structure( #' list(sides = sides, color = color), #' class = "shape" #' ) #' } #' #' \dontrun{ #' # Cannot destructure the shape object _yet_ #' c(sides, color) %<-% shape() #' } #' #' # Implement a new destructure method for the shape class #' destructure.shape <- function(x) { #' unclass(x) #' } #' #' # Now we can destructure shape objects #' c(sides, color) %<-% shape() #' #' c(sides, color) %<-% shape(3, "green") #' destructure <- function(x) { UseMethod("destructure") } #' @rdname destructure #' @export destructure.data.frame <- function(x) { as.list(x) } #' @rdname destructure #' @export destructure.summary.lm <- function(x) { unclass(x) } #' @rdname destructure #' @export destructure.default <- function(x) { as.list(x) } zeallot/vignettes/ 0000755 0001762 0000144 00000000000 15013554124 013734 5 ustar ligges users zeallot/vignettes/unpacking-assignment.Rmd 0000644 0001762 0000144 00000015146 15013241224 020526 0 ustar ligges users --- title: "Unpacking Assignment" date: "`r Sys.Date()`" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Unpacking Assignment} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- ```{R, include = FALSE} knitr::opts_chunk$set(collapse = TRUE, comment = "#>") library(zeallot) ``` ## Getting Started The *zeallot* package defines an operator for *unpacking assignment*, sometimes called *parallel assignment* or *destructuring assignment* in other programming languages. The operator is written as `%<-%` and used like this. ```{r} c(lat, lng) %<-% list(38.061944, -122.643889) ``` The result is that the list is unpacked into its elements, and the elements are assigned to `lat` and `lng`. ```{r} lat lng ``` You can also unpack the elements of a vector. ```{r} c(lat, lng) %<-% c(38.061944, -122.643889) lat lng ``` You can unpack much longer structures, too, of course, such as the 6-part summary of a vector. ```{r} c(min_wt, q1_wt, med_wt, mean_wt, q3_wt, max_wt) %<-% summary(mtcars$wt) min_wt q1_wt med_wt mean_wt q3_wt max_wt ``` If the left-hand side and right-hand sides do not match, an error is raised. This guards against missing or unexpected values. ```{r, error=TRUE} c(stg1, stg2, stg3) %<-% list("Moe", "Donald") ``` ```{r, error=TRUE} c(stg1, stg2, stg3) %<-% list("Moe", "Larry", "Curley", "Donald") ``` ### Unpacking a returned value A common use-case is when a function returns a list of values and you want to extract the individual values. In this example, the list of values returned by `coords_list()` is unpacked into the variables `lat` and `lng`. ```{r} # # A function which returns a list of 2 numeric values. # coords_list <- function() { list(38.061944, -122.643889) } c(lat, lng) %<-% coords_list() lat lng ``` In this next example, we call a function that returns a vector. ```{r} # # Convert cartesian coordinates to polar # to_polar = function(x, y) { c(sqrt(x^2 + y^2), atan(y / x)) } c(radius, angle) %<-% to_polar(12, 5) radius angle ``` ### Example: Intercept and slope of regression You can directly unpack the coefficients of a simple linear regression into the intercept and slope. ```{r} c(inter, slope) %<-% coef(lm(mpg ~ cyl, data = mtcars)) inter slope ``` ### Example: Unpacking the result of `safely` The *purrr* package includes the `safely` function. It wraps a given function to create a new, "safe" version of the original function. ```{R, eval = require("purrr")} safe_log <- purrr::safely(log) ``` The safe version returns a list of two items. The first item is the result of calling the original function, assuming no error occurred; or `NULL` if an error did occur. The second item is the error, if an error occurred; or `NULL` if no error occurred. Whether or not the original function would have thrown an error, the safe version will never throw an error. ```{r, eval = require("purrr")} pair <- safe_log(10) pair$result pair$error ``` ```{r, eval = require("purrr")} pair <- safe_log("donald") pair$result pair$error ``` You can tighten and clarify calls to the safe function by using `%<-%`. ```{r, eval = require("purrr")} c(res, err) %<-% safe_log(10) res err ``` ## Unpacking a data frame A data frame is simply a list of columns, so the *zeallot* assignment does what you expect. It unpacks the data frame into individual columns. ```{r} c(mpg=, cyl=, dist=, hp=) %<-% mtcars cyl ``` ### Example: List of data frames Bear in mind, a list of data frames is still just a list. The assignment will extract the list elements (which are data frames) but not unpack the data frames themselves. ```{R} c(gear3, gear4, gear5) %<-% split(mtcars, ~ gear) head(gear3) head(gear4) gear5 ``` The `%<-%` operator assigned four data frames to four variables, leaving the data frames intact. ## Custom classes *zeallot* includes implementations of `destructure` for data frames and linear model summaries. However, because `destructure` is a generic function, you can define new implementations for custom classes. When defining a new implementation keep in mind the return value must be a list so the values are properly unpacked. ## Trailing values: the "everything else" clause In some cases, you want the first few elements of a list or vector but do not care about the trailing elements. The `summary.lm` function, for example, returns a list of 11 values, and you may want only the first few. Fortunately, there is a way to capture those first few and say "don't worry about everything else". ```{r} lm_mpg_cyl <- lm(mpg ~ cyl, data = mtcars) c(lmc_call, lmc_terms, lmc_residuals, ..rest) %<-% summary(lm_mpg_cyl) lmc_call lmc_terms head(lmc_residuals) ``` The collector variable `rest` captures everything else. ```{r} str(rest) ``` Because `..rest` is prefixed with `..` a variable called `rest` is created for the trailing values of the list. ## Leading values and middle values In addition to collecting trailing values, you can also collect initial values and assign specific remaining values. ```{r} c(..skip, e, f) %<-% list(1, 2, 3, 4, 5) skip e f ``` Or you can assign the first value, skip values, and then assign the last value. ```{r} c(begin, ..middle, end) %<-% list(1, 2, 3, 4, 5) begin middle end ``` ## Skipped values: anonymous elements You can skip one or more values using a period (`.`) instead of a variable name. ```{r} c(x, ., z) %<-% list(1, 2, 3) x z ``` You can skip many values with the anonymous collector (`..`). ```{r} c(begin, .., end) %<-% list("hello", "blah", list("blah"), "blah", "world!") begin end ``` You can mix skips and collectors together to selectively keep and discard elements. ```{r} c(begin, ., ..middle, end) %<-% list(1, 2, 3, 4, 5) begin middle end ``` ## Default values: handle missing values You can specify a default value for a left-hand side variable using `=`, similar to specifying the default value of a function argument. This comes in handy when the number of elements returned by a function cannot be guaranteed. `tail()` for example may return fewer elements than asked for. ```{r} nums <- c(1, 2) c(x, y) %<-% tail(nums, 2) x y ``` However, if we tried to get the last 3 elements an error would be raised because `tail(nums, 3)` still returns only 2 values. ```{r, error = TRUE} c(x, y, z) %<-% tail(nums, 3) ``` We can fix the problem by specifying a default value for `z`. ```{r} c(x, y, z = NULL) %<-% tail(nums, 3) x y z ``` ## Swapping values A handy trick is swapping values without the use of a temporary variable. ```{r} c(first, last) %<-% c("Ai", "Genly") first last c(first, last) %<-% c(last, first) first last ``` or ```{r} cat <- "meow" dog <- "bark" c(cat, dog, fish) %<-% c(dog, cat, dog) cat dog fish ``` zeallot/NAMESPACE 0000644 0001762 0000144 00000000321 15010640533 013134 0 ustar ligges users # Generated by roxygen2: do not edit by hand S3method(destructure,data.frame) S3method(destructure,default) S3method(destructure,summary.lm) export("%->%") export("%<-%") export(destructure) export(zeallous) zeallot/LICENSE 0000644 0001762 0000144 00000000053 14775576725 012760 0 ustar ligges users YEAR: 2017 COPYRIGHT HOLDER: Nathan Teetor zeallot/NEWS.md 0000644 0001762 0000144 00000010131 15013553362 013021 0 ustar ligges users # zeallot 0.2.0 ## Breaking changes * The collector syntax has changed. The previous syntax `...` was incompatible with `R CMD check` and would raise the error "... may be used in an incorrect context". The new syntax `..` (double dots instead of triple) avoids this error. (#62) ```R # new c(x, ..) %<-% list(1, 2, 3) # old c(x, ...) %<-% list(1, 2, 3) ``` * The `destructure` methods for the Date, character, and complex classes have been removed. ## New features * Values may now be assigned by name. The new syntax allows assigning a value to a variable by name instead of position. (#47) ```R c(disp=, gear=) %<-% mtcars ``` * For package developers, the new function `zeallous()` will prevent `R CMD check` from raising visible binding errors for variables assigned using `%<-%`. Call the function from a package's `.onLoad` function. (#57) ```R .onLoad <- function(libname, pkgname) { zeallous() } ``` ## Major improvements * Collector variables now default to an empty list instead of raising an error when there are no values to collect. (#56) ```R c(x, ..y) %<-% list(1) ``` * Trailing anonymous collectors and value skips no longer raise errors. ```R c(x, ..) %<-% list(1) c(y, .) %<-% list(1) ``` ## Minor improvements * Error messages have been simplified. * R versions >= 3.2 are formally supported. # zeallot 0.1.0 ## Major Improvements * Bumped to stable version. ## Minor Improvements * Removed outdate language in the unpacking assignment vignette. (#36) ## Bug Fixes * Destructuring objects with multiple classes will no longer raise a warning. (#35) # zeallot 0.0.6.1 ## Bug Fixes * Resolved problem where collector variables would not be assigned the correct default value. (#34) # zeallot 0.0.6 ## Major Improvements * The left-hand side may now contain calls to `[[`, `[`, and `$` allowing assignment of parts of objects. The parent object must already exist, otherwise an error is raised. (@rafaqz, #32) # zeallot 0.0.5 ## Major Changes * The bracket and colon syntax has been completely removed, users will now see an "unexpected call `{`" error message when attempting to use the old syntax. Please use the `c()` syntax for the name structure. ## Major Improvements * A `%->%` operator has been added. The right operator performs the same operation as `%<-%` with the name structure on the right-hand side and the values to assign on the left-hand side. * `=` may be used to specify the default value of a variable. A default value is used when there are an insufficient number of values. # zeallot 0.0.4 ## Major Changes * The bracket and colon syntax has been deprecated in favor of a lighter syntax which uses calls to `c()`. Documentation and vignettes has been updated accordingly. Using the old syntax now raises a warning and will be removed in future versions of zeallot. (@hadley, #21) ## Minor Improvements * `%<-%` can now be used for regular assignment. (@hadley, #17) * `...` can now be used to skip multiple values without assigning those values and is recommended over the previously suggested `....`. (@hadley, #18) ## Miscellaneous Changes * `massign()` is no longer exported. ## Bug Fixes * Numerics on left-hand side are no longer unintentionally quoted, thus no longer treated as valid variable names, and will now raise an error. (@hadley, #20) * Language objects on left-hand side are no longer treated as symbols and will now raise an error. (@hadley, #20) # zeallot 0.0.3 * see 0.0.2.1 notes for additional updates ## Minor Improvements * Examples now consistently put spaces around colons separating left-hand side variables, e.g. `a : b` instead of `a: b`. ## Bug Fixes * When unpacking an atomic vector, a collector variable will now collect values as a vector. Previously, values were collected as a list (#14). # zeallot 0.0.2.1 * Not on CRAN, changes will appear under version 0.0.3 * Added missing URL and BugReports fields to DESCRIPTION * Fixed broken badges in README # zeallot 0.0.2 * Initial CRAN release * zeallot 0.0.1 may be installed from GitHub zeallot/inst/ 0000755 0001762 0000144 00000000000 15013554124 012701 5 ustar ligges users zeallot/inst/doc/ 0000755 0001762 0000144 00000000000 15013554124 013446 5 ustar ligges users zeallot/inst/doc/unpacking-assignment.R 0000644 0001762 0000144 00000010121 15013554124 017711 0 ustar ligges users ## ----include = FALSE---------------------------------------------------------- knitr::opts_chunk$set(collapse = TRUE, comment = "#>") library(zeallot) ## ----------------------------------------------------------------------------- c(lat, lng) %<-% list(38.061944, -122.643889) ## ----------------------------------------------------------------------------- lat lng ## ----------------------------------------------------------------------------- c(lat, lng) %<-% c(38.061944, -122.643889) lat lng ## ----------------------------------------------------------------------------- c(min_wt, q1_wt, med_wt, mean_wt, q3_wt, max_wt) %<-% summary(mtcars$wt) min_wt q1_wt med_wt mean_wt q3_wt max_wt ## ----error=TRUE--------------------------------------------------------------- try({ c(stg1, stg2, stg3) %<-% list("Moe", "Donald") }) ## ----error=TRUE--------------------------------------------------------------- try({ c(stg1, stg2, stg3) %<-% list("Moe", "Larry", "Curley", "Donald") }) ## ----------------------------------------------------------------------------- # # A function which returns a list of 2 numeric values. # coords_list <- function() { list(38.061944, -122.643889) } c(lat, lng) %<-% coords_list() lat lng ## ----------------------------------------------------------------------------- # # Convert cartesian coordinates to polar # to_polar = function(x, y) { c(sqrt(x^2 + y^2), atan(y / x)) } c(radius, angle) %<-% to_polar(12, 5) radius angle ## ----------------------------------------------------------------------------- c(inter, slope) %<-% coef(lm(mpg ~ cyl, data = mtcars)) inter slope ## ----eval = require("purrr")-------------------------------------------------- safe_log <- purrr::safely(log) ## ----eval = require("purrr")-------------------------------------------------- pair <- safe_log(10) pair$result pair$error ## ----eval = require("purrr")-------------------------------------------------- pair <- safe_log("donald") pair$result pair$error ## ----eval = require("purrr")-------------------------------------------------- c(res, err) %<-% safe_log(10) res err ## ----------------------------------------------------------------------------- c(mpg=, cyl=, dist=, hp=) %<-% mtcars cyl ## ----------------------------------------------------------------------------- c(gear3, gear4, gear5) %<-% split(mtcars, ~ gear) head(gear3) head(gear4) gear5 ## ----------------------------------------------------------------------------- lm_mpg_cyl <- lm(mpg ~ cyl, data = mtcars) c(lmc_call, lmc_terms, lmc_residuals, ..rest) %<-% summary(lm_mpg_cyl) lmc_call lmc_terms head(lmc_residuals) ## ----------------------------------------------------------------------------- str(rest) ## ----------------------------------------------------------------------------- c(..skip, e, f) %<-% list(1, 2, 3, 4, 5) skip e f ## ----------------------------------------------------------------------------- c(begin, ..middle, end) %<-% list(1, 2, 3, 4, 5) begin middle end ## ----------------------------------------------------------------------------- c(x, ., z) %<-% list(1, 2, 3) x z ## ----------------------------------------------------------------------------- c(begin, .., end) %<-% list("hello", "blah", list("blah"), "blah", "world!") begin end ## ----------------------------------------------------------------------------- c(begin, ., ..middle, end) %<-% list(1, 2, 3, 4, 5) begin middle end ## ----------------------------------------------------------------------------- nums <- c(1, 2) c(x, y) %<-% tail(nums, 2) x y ## ----error = TRUE------------------------------------------------------------- try({ c(x, y, z) %<-% tail(nums, 3) }) ## ----------------------------------------------------------------------------- c(x, y, z = NULL) %<-% tail(nums, 3) x y z ## ----------------------------------------------------------------------------- c(first, last) %<-% c("Ai", "Genly") first last c(first, last) %<-% c(last, first) first last ## ----------------------------------------------------------------------------- cat <- "meow" dog <- "bark" c(cat, dog, fish) %<-% c(dog, cat, dog) cat dog fish zeallot/inst/doc/unpacking-assignment.html 0000644 0001762 0000144 00000132022 15013554124 020461 0 ustar ligges users
The zeallot package defines an operator for unpacking
assignment, sometimes called parallel assignment or
destructuring assignment in other programming languages. The
operator is written as %<-% and used like this.
The result is that the list is unpacked into its elements, and the
elements are assigned to lat and lng.
You can also unpack the elements of a vector.
You can unpack much longer structures, too, of course, such as the 6-part summary of a vector.
c(min_wt, q1_wt, med_wt, mean_wt, q3_wt, max_wt) %<-% summary(mtcars$wt)
min_wt
#> [1] 1.513
q1_wt
#> [1] 2.58125
med_wt
#> [1] 3.325
mean_wt
#> [1] 3.21725
q3_wt
#> [1] 3.61
max_wt
#> [1] 5.424If the left-hand side and right-hand sides do not match, an error is raised. This guards against missing or unexpected values.
c(stg1, stg2, stg3) %<-% list("Moe", "Donald")
#> Error in c(stg1, stg2, stg3) %<-% list("Moe", "Donald"): missing value for variable `stg3`A common use-case is when a function returns a list of values and you
want to extract the individual values. In this example, the list of
values returned by coords_list() is unpacked into the
variables lat and lng.
#
# A function which returns a list of 2 numeric values.
#
coords_list <- function() {
list(38.061944, -122.643889)
}
c(lat, lng) %<-% coords_list()
lat
#> [1] 38.06194
lng
#> [1] -122.6439In this next example, we call a function that returns a vector.
You can directly unpack the coefficients of a simple linear regression into the intercept and slope.
safelyThe purrr package includes the safely function.
It wraps a given function to create a new, “safe” version of the
original function.
The safe version returns a list of two items. The first item is the
result of calling the original function, assuming no error occurred; or
NULL if an error did occur. The second item is the error,
if an error occurred; or NULL if no error occurred. Whether
or not the original function would have thrown an error, the safe
version will never throw an error.
pair <- safe_log("donald")
pair$result
#> NULL
pair$error
#> <simpleError in .Primitive("log")(x, base): non-numeric argument to mathematical function>You can tighten and clarify calls to the safe function by using
%<-%.
A data frame is simply a list of columns, so the zeallot assignment does what you expect. It unpacks the data frame into individual columns.
c(mpg=, cyl=, dist=, hp=) %<-% mtcars
cyl
#> [1] 6 6 4 6 8 6 8 4 4 6 6 8 8 8 8 8 8 4 4 4 4 8 8 8 8 4 4 4 8 6 8 4Bear in mind, a list of data frames is still just a list. The assignment will extract the list elements (which are data frames) but not unpack the data frames themselves.
c(gear3, gear4, gear5) %<-% split(mtcars, ~ gear)
head(gear3)
#> mpg cyl disp hp drat wt qsec vs am gear carb
#> Hornet 4 Drive 21.4 6 258.0 110 3.08 3.215 19.44 1 0 3 1
#> Hornet Sportabout 18.7 8 360.0 175 3.15 3.440 17.02 0 0 3 2
#> Valiant 18.1 6 225.0 105 2.76 3.460 20.22 1 0 3 1
#> Duster 360 14.3 8 360.0 245 3.21 3.570 15.84 0 0 3 4
#> Merc 450SE 16.4 8 275.8 180 3.07 4.070 17.40 0 0 3 3
#> Merc 450SL 17.3 8 275.8 180 3.07 3.730 17.60 0 0 3 3
head(gear4)
#> mpg cyl disp hp drat wt qsec vs am gear carb
#> Mazda RX4 21.0 6 160.0 110 3.90 2.620 16.46 0 1 4 4
#> Mazda RX4 Wag 21.0 6 160.0 110 3.90 2.875 17.02 0 1 4 4
#> Datsun 710 22.8 4 108.0 93 3.85 2.320 18.61 1 1 4 1
#> Merc 240D 24.4 4 146.7 62 3.69 3.190 20.00 1 0 4 2
#> Merc 230 22.8 4 140.8 95 3.92 3.150 22.90 1 0 4 2
#> Merc 280 19.2 6 167.6 123 3.92 3.440 18.30 1 0 4 4
gear5
#> mpg cyl disp hp drat wt qsec vs am gear carb
#> Porsche 914-2 26.0 4 120.3 91 4.43 2.140 16.7 0 1 5 2
#> Lotus Europa 30.4 4 95.1 113 3.77 1.513 16.9 1 1 5 2
#> Ford Pantera L 15.8 8 351.0 264 4.22 3.170 14.5 0 1 5 4
#> Ferrari Dino 19.7 6 145.0 175 3.62 2.770 15.5 0 1 5 6
#> Maserati Bora 15.0 8 301.0 335 3.54 3.570 14.6 0 1 5 8The %<-% operator assigned four data frames to four
variables, leaving the data frames intact.
zeallot includes implementations of destructure
for data frames and linear model summaries. However, because
destructure is a generic function, you can define new
implementations for custom classes. When defining a new implementation
keep in mind the return value must be a list so the values are properly
unpacked.
In some cases, you want the first few elements of a list or vector
but do not care about the trailing elements. The summary.lm
function, for example, returns a list of 11 values, and you may want
only the first few. Fortunately, there is a way to capture those first
few and say “don’t worry about everything else”.
lm_mpg_cyl <- lm(mpg ~ cyl, data = mtcars)
c(lmc_call, lmc_terms, lmc_residuals, ..rest) %<-% summary(lm_mpg_cyl)
lmc_call
#> lm(formula = mpg ~ cyl, data = mtcars)
lmc_terms
#> mpg ~ cyl
#> attr(,"variables")
#> list(mpg, cyl)
#> attr(,"factors")
#> cyl
#> mpg 0
#> cyl 1
#> attr(,"term.labels")
#> [1] "cyl"
#> attr(,"order")
#> [1] 1
#> attr(,"intercept")
#> [1] 1
#> attr(,"response")
#> [1] 1
#> attr(,".Environment")
#> <environment: R_GlobalEnv>
#> attr(,"predvars")
#> list(mpg, cyl)
#> attr(,"dataClasses")
#> mpg cyl
#> "numeric" "numeric"
head(lmc_residuals)
#> Mazda RX4 Mazda RX4 Wag Datsun 710 Hornet 4 Drive
#> 0.3701643 0.3701643 -3.5814159 0.7701643
#> Hornet Sportabout Valiant
#> 3.8217446 -2.5298357The collector variable rest captures everything
else.
str(rest)
#> List of 15
#> $ : num 37.9
#> $ : num -2.88
#> $ : num 2.07
#> $ : num 0.322
#> $ : num 18.3
#> $ : num -8.92
#> $ : num 8.37e-18
#> $ : num 6.11e-10
#> $ aliased : Named logi [1:2] FALSE FALSE
#> ..- attr(*, "names")= chr [1:2] "(Intercept)" "cyl"
#> $ sigma : num 3.21
#> $ df : int [1:3] 2 30 2
#> $ r.squared : num 0.726
#> $ adj.r.squared: num 0.717
#> $ fstatistic : Named num [1:3] 79.6 1 30
#> ..- attr(*, "names")= chr [1:3] "value" "numdf" "dendf"
#> $ cov.unscaled : num [1:2, 1:2] 0.4185 -0.0626 -0.0626 0.0101
#> ..- attr(*, "dimnames")=List of 2
#> .. ..$ : chr [1:2] "(Intercept)" "cyl"
#> .. ..$ : chr [1:2] "(Intercept)" "cyl"Because ..rest is prefixed with .. a
variable called rest is created for the trailing values of
the list.
In addition to collecting trailing values, you can also collect initial values and assign specific remaining values.
c(..skip, e, f) %<-% list(1, 2, 3, 4, 5)
skip
#> [[1]]
#> [1] 1
#>
#> [[2]]
#> [1] 2
#>
#> [[3]]
#> [1] 3
e
#> [1] 4
f
#> [1] 5Or you can assign the first value, skip values, and then assign the last value.
You can skip one or more values using a period (.)
instead of a variable name.
You can skip many values with the anonymous collector
(..).
c(begin, .., end) %<-% list("hello", "blah", list("blah"), "blah", "world!")
begin
#> [1] "hello"
end
#> [1] "world!"You can mix skips and collectors together to selectively keep and discard elements.
You can specify a default value for a left-hand side variable using
=, similar to specifying the default value of a function
argument. This comes in handy when the number of elements returned by a
function cannot be guaranteed. tail() for example may
return fewer elements than asked for.
However, if we tried to get the last 3 elements an error would be
raised because tail(nums, 3) still returns only 2
values.
c(x, y, z) %<-% tail(nums, 3)
#> Error in c(x, y, z) %<-% tail(nums, 3): missing value for variable `z`We can fix the problem by specifying a default value for
z.
A handy trick is swapping values without the use of a temporary variable.
c(first, last) %<-% c("Ai", "Genly")
first
#> [1] "Ai"
last
#> [1] "Genly"
c(first, last) %<-% c(last, first)
first
#> [1] "Genly"
last
#> [1] "Ai"or