Python 3-style unpacking for variable assignment.

python_style_unpacking.R

# 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(`%,*%<-`))
# }