diff --git a/R/operator.R b/R/operator.R index 7c44398..38cc542 100644 --- a/R/operator.R +++ b/R/operator.R @@ -195,6 +195,9 @@ }, invalid_rhs = function(e) { stop("invalid `%<-%` right-hand side, ", e$message, call. = FALSE) + }, + error = function(e) { + stop("problem in `%<-%`, ", e$message, call. = FALSE) } ) } @@ -209,6 +212,9 @@ }, invalid_rhs = function(e) { stop("invalid `%->%` left-hand side, ", e$message, call. = FALSE) + }, + error = function(e) { + stop("problem in `%->%`, ", e$message, call. = FALSE) } ) } @@ -235,7 +241,10 @@ multi_assign <- function(x, value, env) { # standard assignment, no calls (i.e. `c`) found # if (is.null(internals)) { - assign(as.character(ast), value, envir = env) + assign(lhs, value, envir = env) + return(invisible(value)) + } else if (length(internals) == 1 && internals %in% c("[[", "[", "$")) { + replace_assign(lhs, value, envir = env) return(invisible(value)) } @@ -266,6 +275,11 @@ multi_assign <- function(x, value, env) { name <- t[["name"]] val <- t[["value"]] + if (is.language(name)) { + replace_assign(name, val, envir = env) + next + } + # # collector variable names retain the leading "..." in order to revert # list values back to vectors if necessary diff --git a/R/pair-off.R b/R/pair-off.R index b0721a5..8f9a234 100644 --- a/R/pair-off.R +++ b/R/pair-off.R @@ -1,5 +1,5 @@ pair_off <- function(names, values, env) { - if (is.character(names)) { + if (is.character(names) || is.language(names)) { if (names == ".") { return() } diff --git a/R/utils.R b/R/utils.R index 2c485ae..5cbf838 100644 --- a/R/utils.R +++ b/R/utils.R @@ -16,6 +16,10 @@ cdr <- function(cons) { cons[-1] } +names2 <- function(x) { + if (is.null(names(x))) rep.int("", length(x)) else names(x) +} + default <- function(x) { attr(x, "default", exact = TRUE) } @@ -32,8 +36,10 @@ add_defaults <- function(names, values, env) { append(values, evaled) } -names2 <- function(x) { - if (is.null(names(x))) rep.int("", length(x)) else names(x) +replace_assign <- function(call, value, envir = parent.frame()) { + replacee <- call("<-", call, value) + eval(replacee, envir = envir) + invisible(value) } tree <- function(x) { @@ -64,7 +70,7 @@ calls <- function(x) { this <- car(x) - if (this != "c" && this != "=") { + if (!(as.character(this) %in% c("c", "=", "$", "[", "[["))) { stop_invalid_lhs(unexpected_call(this)) } @@ -95,6 +101,10 @@ variables <- function(x) { attr(var, "default") <- default return(var) + } else if (car(x) == "$" || car(x) == "[[" || car(x) == "[") { + parts <- as.call(x) + + return(parts) } lapply(cdr(x), variables)