Skip to content

Instantly share code, notes, and snippets.

@burchill
Last active July 5, 2020 22:51
Show Gist options
  • Save burchill/119a8f4d1f5a49c260f1cc676bd0d159 to your computer and use it in GitHub Desktop.
Save burchill/119a8f4d1f5a49c260f1cc676bd0d159 to your computer and use it in GitHub Desktop.
Python 3-style unpacking for variable assignment.
# Imitating Python 3 unpacking in R. (requires `rlang`)
# The following code lets you unpack variables for assignment in R like you do in Python
# Examples: python ~> R
# - `a, *b, c = [1,2,3,4]` ~> `a %,*% b %,% c <- c(1,2,3,4)`
# - variables now: a = 1, b = c(2,3), c = 4
# - `a, *b, c = 1, "C"` ~> `a %,*% b %,% c <- 1 %,% "C"`
# - variables now: a = 1, b = NULL, c = "C"
#
# If you are using the `%,%` operator on the righthand side of the assignment, remember that the order of
# order of operations in R is weird with infix operators. You should add parentheses to any values that are calls.
# E.g., `... <- 1 + 1 %,% TRUE || FALSE %,% "A"` will mess stuff up.
# Do: `... <- (1 + 1) %,% (TRUE || FALSE) %,% "A"` instead.
# Right now, you can't star the first assigning variable (e.g., `*a, b, c`), but what would a reasonable usecase be?
#
# IMPORTANT NOTE:
# This code runs into a snag when the left-most assigning variable (`a` in the cases above) has not yet been defined.
# You can either:
# 1) uncomment the code at the end of this gist, which will overwrite some basic operators (`<-` and `=`),
# (This will make these functions automatically create the first variable and set it to NULL, in ALL situations within scope)
# 2) make sure the first variable is always defined, or
# 3) not use this code
`%,%` <- function(lhs, rhs) {
if (deparse(substitute(lhs)) != "*tmp*") {
move_over(lhs, rhs)
} else {
check_if_symbol(substitute(rhs))
incr(lhs)
}
}
`%,*%` <- function(lhs, rhs) {
if (deparse(substitute(lhs)) != "*tmp*") {
stop("Cannot star supplied values")
} else {
if (is_lhs_count(lhs) && has_star(lhs))
stop("Cannot have two starred variables in assignment")
check_if_symbol(substitute(rhs))
give_star(incr(lhs))
}
}
`%,%<-` <- function(lhs, rhs, value) {
check_if_symbol(substitute(rhs))
l <- shared_proc(lhs, rhs, value, is_starred = FALSE)
assign(deparse(substitute(rhs)), l[[2]], envir = parent.frame())
l[[1]]
}
`%,*%<-` <- function(lhs, rhs, value) {
check_if_symbol(substitute(rhs))
l <- shared_proc(lhs, rhs, value, is_starred = TRUE)
assign(deparse(substitute(rhs)), l[[2]], envir = parent.frame())
l[[1]]
}
shared_proc <- function(lhs, rhs, value, is_starred = FALSE) {
first_time <- FALSE
# This means the rhs wasn't separated and this is the start
# of assignment
if (!is_rhs_container(value)) {
value <- rhs_from_val(value)
first_time <- TRUE
}
starred <- is_starred || is_rhs_starred(value) ||
(is_lhs_count(lhs) && has_star(lhs))
counter <- if (is_lhs_count(lhs)) expose(lhs) + 1 else 1
len <- rhs_len(value)
if (first_time) {
if (!starred) {
if (counter + 1 != len)
stop(counter + 1, " variables receiving assignment, ",
"but ", len, " values supplied")
} else if (counter > len) {
stop(counter + 1, " variables receiving assignment, ",
"but ", len, " values supplied")
}
}
if (is_starred) {
list(rhs_head(value, counter), rhs_tail(value, counter+1))
} else {
list(rhs_head(value, len-1), rhs_tail(value, len))
}
}
check_if_symbol <- function(x) {
if (!rlang::is_symbol(x))
stop("`%,%` can only separate bare variable names ",
"(not ", deparse(x), ")", call. = FALSE)
}
# RHS container functions -----------------------------
move_over <- function(lhs, rhs) {
if (is_rhs_container(lhs))
add_to(lhs, rhs)
else
add_to(rhs_enclose(lhs), rhs)
}
is_rhs_starred <- function(x) {
assert_rhs(x)
attr(x, "star")
}
assert_rhs <- function(x) {
if (!is_rhs_container(x))
stop("Expecting a 'rhs-container' object")
}
rhs_enclose <- function(x, extra_l = TRUE, star = FALSE) {
if (extra_l) x <- list(x)
structure(list(x), star = star, class = "rhs-container")
}
rhs_from_val <- function(x) {
rhs_enclose(x, extra_l = FALSE, star = FALSE)
}
add_to <- function(rc, x) {
assert_rhs(rc)
rhs_enclose(
append(rc[[1]], x), extra_l = FALSE,
star = is_rhs_starred(rc))
}
is_rhs_container <- function(x) inherits(x, "rhs-container")
rhs_len <- function(x) {
assert_rhs(x)
length(x[[1]])
}
rhs_head <- function(x, n, rm_star = FALSE) {
assert_rhs(x)
star <- !rm_star && is_rhs_starred(x)
if (n==1)
x[[1]][[1]]
else
rhs_enclose(x[[1]][1:n], FALSE, star = star)
}
rhs_tail <- function(x, n) {
assert_rhs(x)
len <- rhs_len(x)
if (n > len)
getOption("default_empty_val", NULL)
else if (n == len)
x[[1]][[n]]
else
x[[1]][n:len]
}
`print.rhs-container` <- function(..., warn = TRUE) {
if (warn)
warning(
"Value on the righthand side of an ",
"assignment separated by `%,% produce an ",
"'rhs-container' object internally. If you are ",
"seeing this, it generally means something ",
"has gone wrong. Make sure that calls ",
"between `%,%` have parentheses around them.",
immediate. = TRUE
)
print.default(...)
}
`as.logical.rhs-container` <- function(...) cannot_convert("logicals")
`as.character.rhs-container` <- function(...) cannot_convert("characters")
`as.numeric.rhs-container` <- function(...) cannot_convert("numerics")
`as.integer.rhs-container` <- function(...) cannot_convert("integers")
`as.double.rhs-container` <- function(...) cannot_convert("doubles")
`as.data.frame.rhs-container` <- function(...) cannot_convert("data.frames")
cannot_convert <- function(type) {
stop(
"'rhs-container' objects cannot be converted ",
"into ", type, ". ",
"Make sure that values separated by `%,%` ",
"on the righthand side of assignments are ",
"properly surrounded by parentheses."
)
}
# lhs container functions ------------------------------------
give_star <- function(x) {
assert_lhs(x)
`attr<-`(x, "star", TRUE)
}
has_star <- function(x) {
assert_lhs(x)
attr(x, "star")
}
assert_lhs <- function(x) {
if (!is_lhs_count(x))
stop("Expecting a 'lhs-count' object")
}
incr <- function(x) {
if (is_lhs_count(x)) `[[<-`(x, 1, x[[1]]+1) else count()
}
is_lhs_count <- function(x) inherits(x, "lhs-count")
count <- function() structure(list(1), star=FALSE, class = c("lhs-count"))
expose <- function(x) {
assert_lhs(x)
x[[1]]
}
`print.lhs-count` <- function(..., warn = TRUE) {
if (warn)
warning(
"Variables on the lefthand side of an ",
"assignment separated by `%,% produce an ",
"'lhs-count' object internally. If you are ",
"seeing this, it generally means something ",
"has gone wrong",
immediate. = TRUE
)
print.default(...)
}
# # Overwriting assignment operators -------------------------------
# `<-` <- function(x, value) {
# find_and_assign(match.call(), parent.frame())
# clean_do(f = base::`<-`, l = list(x = substitute(x), value = substitute(value)),
# e = parent.frame(), call = match.call())
# }
# `=` <- function(x, value) {
# find_and_assign(match.call(), parent.frame())
# clean_do(f = base::`=`, l = list(x = substitute(x), value = substitute(value)),
# e = parent.frame(), call = match.call())
# }
# find_and_assign <- function(expr, check_envir, make_envir = check_envir) {
# base::`<-`(`<-`, base::`<-`)
# has_my_infix <- FALSE
# while (is.call(expr)) {
# if (is_my_infix(expr[[1]])) has_my_infix <- TRUE
# prev_call <- expr
# if (has_my_infix && !is_my_infix(prev_call[[1]]))
# stop("`%,%` can only separate bare variable names ",
# "(not `", deparse(prev_call), "`)", call. = FALSE)
# expr <- expr[[2]]
# }
# if (!has_my_infix) return()
# if (!rlang::is_symbol(expr))
# stop("`%,%` can only separate bare variable names ",
# "(not ", deparse(expr), ")", call. = FALSE)
# var <- rlang::as_string(expr)
# if (!exists(var, envir = check_envir))
# assign(var, NULL, envir = make_envir)
# }
# clean_do <- function(f, l, e, call) {
# base::`<-`(`=`, base::`=`)
# tryCatch(
# do.call(f, l, envir = e, quote = FALSE),
# error = function(err) {
# err$call = call
# stop(err)
# })
# }
# is_my_infix <- function(expr) {
# identical(expr, quote(`%,%`)) || identical(expr, quote(`%,*%`)) ||
# identical(expr, quote(`%,%<-`)) || identical(expr, quote(`%,*%<-`))
# }
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment