Merge pull request #33 from nteetor/assign-anything

Assign parts of objects

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: zeallot
 Type: Package
 Title: Multiple, Unpacking, and Destructuring Assignment
-Version: 0.0.5
+Version: 0.0.6
 Authors@R: c(
     person(given = "Nathan", family = "Teetor", email = "[email protected]", role = c("aut", "cre")),
     person(given = "Paul", family = "Teetor", role = "ctb"))

NEWS.md

@@ -1,3 +1,11 @@
+# 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 in question must already
+  exist, otherwise an error is raised. (@rafaqz, #32)
+
 # zeallot 0.0.5
 
 ## Major Changes

R/operator.R

@@ -21,6 +21,11 @@
 #' \code{\%->\%} will try to destructure `value` into a list before assigning
 #' variables, see [destructure()].
 #'
+#' **object parts**
+#'
+#' Like assigning a variable, one may also assign part of an object, \code{c(x,
+#' x[[1]]) \%<-\% list(list(), 1)}.
+#'
 #' **nested names**
 #'
 #' One can also nest calls to `c()` when needed, `c(x, c(y, z))`. This nested
@@ -46,6 +51,10 @@
 #' Use `=` to specify a default value for a variable, \code{c(x, y = NULL)
 #' \%<-\% tail(1, 2)}.
 #'
+#' When assigning part of an object a default value may not be specified because
+#' of the syntax enforced by \R. The following would raise an `"unexpected '='
+#' ..."` error, \code{c(x, x[[1]] = 1) \%<-\% list(list())}.
+#'
 #' @return
 #'
 #' \code{\%<-\%} and \code{\%->\%} invisibly return `value`.
@@ -232,10 +241,19 @@ multi_assign <- function(x, value, env) {
   rhs <- value
 
   #
-  # standard assignment, no calls (i.e. `c`) found
+  # all lists or environemnts referenced in lhs must already exist
+  #
+  check_extract_calls(lhs, env)
+
+  #
+  # standard assignment
   #
   if (is.null(internals)) {
-    assign(as.character(ast), value, envir = env)
+    if (is.language(lhs)) {
+      assign_extract(lhs, value, envir = env)
+    } else {
+      assign(lhs, value, envir = env)
+    }
     return(invisible(value))
   }
 
@@ -266,6 +284,11 @@ multi_assign <- function(x, value, env) {
     name <- t[["name"]]
     val <- t[["value"]]
 
+    if (is.language(name)) {
+      assign_extract(name, val, envir = env)
+      next
+    }
+
     #
     # collector variable names retain the leading "..." in order to revert
     # list values back to vectors if necessary

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()
     }

R/utils.R

@@ -1,7 +1,3 @@
-is_Date <- function(x) {
-  inherits(x, 'Date')
-}
-
 is_list <- function(x) {
   class(x) == 'list'
 }
@@ -16,67 +12,148 @@ cdr <- function(cons) {
   cons[-1]
 }
 
-default <- function(x) {
+names2 <- function(x) {
+  if (is.null(names(x))) rep.int("", length(x)) else names(x)
+}
+
+#
+# the default attribute is used by `variables()` and `pair_off()` to know when
+# to assign a variable its default value
+#
+get_default <- function(x) {
   attr(x, "default", exact = TRUE)
 }
 
 has_default <- function(x) {
-  vapply(x, function(i) !is.null(attr(i, "default")), logical(1))
+  vapply(x, function(i) !is.null(get_default(i)), logical(1))
 }
 
+#
+# append any default values onto the end of a list of values, used in
+# `pair_off()` to extend the current set of values thereby avoiding an
+# incorrect number of values error
+#
 add_defaults <- function(names, values, env) {
   where <- which(has_default(names))
-  defaults <- lapply(names[where], default)[where > length(values)]
+  defaults <- lapply(names[where], get_default)[where > length(values)]
   evaled <- lapply(defaults, eval, envir = env)
 
   append(values, evaled)
 }
 
-names2 <- function(x) {
-  if (is.null(names(x))) rep.int("", length(x)) else names(x)
+#
+# traverse nested extract op calls to find the extractee, e.g. `x[[1]][[1]]`
+#
+traverse_to_extractee <- function(call) {
+  if (is.language(call) && is.symbol(call)) {
+    return(call)
+  }
+  traverse_to_extractee(call[[2]])
 }
 
-tree <- function(x) {
-  if (length(x) == 1 && is.language(x) && !is.symbol(x)) {
-    return(x)
+#
+# used by multi_assign to confirm all extractees exist
+#
+check_extract_calls <- function(lhs, envir) {
+  if (is.character(lhs)) {
+    return()
   }
 
-  x <- as.list(x)
-
-  if (length(x) == 1 && length(x[[1]]) <= 1) {
-    if (names2(x) != "") {
-      return(list(as.symbol("="), as.symbol(names(x)), x[[1]]))
+  if (is.language(lhs)) {
+    extractee <- traverse_to_extractee(lhs)
+    if (!exists(as.character(extractee), envir = envir, inherits = FALSE)) {
+      stop_invalid_lhs(object_does_not_exist(extractee))
+    } else {
+      return()
     }
+  }
+
+  unlist(lapply(lhs, check_extract_calls, envir = envir))
+}
+
+is_extract_op <- function(x) {
+  if (length(x) < 1) {
+    return(FALSE)
+  }
+
+  (as.character(x) %in% c("[", "[[", "$"))
+}
 
-    return(x[[1]])
+is_valid_call <- function(x) {
+  if (length(x) < 1) {
+    return(FALSE)
   }
 
-  append(
-    tree(x[[1]]),
-    lapply(seq_along(x[-1]), function(i) tree(x[-1][i]))
+  (x == "c" || x == "=" || is_extract_op(x))
+}
+
+#
+# used by multi_assign to assign list elements in the calling environment
+#
+assign_extract <- function(call, value, envir = parent.frame()) {
+  replacee <- call("<-", call, value)
+  eval(replacee, envir = envir)
+  invisible(value)
+}
+
+#
+# parses a substituted expression to create a tree-like list structure,
+# perserves calls to extract ops instead of converting them to lists
+#
+tree <- function(x) {
+  if (length(x) == 1) {
+    return(x)
+  }
+
+  if (is_extract_op(x[[1]])) {
+    return(x)
+  }
+
+  lapply(
+    seq_along(as.list(x)),
+    function(i) {
+      if (names2(x[i]) != "") {
+        return(list(as.symbol("="), names2(x[i]), x[[i]]))
+      } else {
+        tree(x[[i]])
+      }
+    }
   )
 }
 
+#
+# given a tree-like list structure returns a character vector of the function
+# calls, used by multi_assign to determine if performing standard assignment or
+# multiple assignment
+#
 calls <- function(x) {
   if (!is_list(x)) {
     return(NULL)
   }
 
   this <- car(x)
 
-  if (this != "c" && this != "=") {
+  if (!is_valid_call(this)) {
     stop_invalid_lhs(unexpected_call(this))
   }
 
   c(as.character(this), unlist(lapply(cdr(x), calls)))
 }
 
+#
+# given a tree-like list structure, returns a nested list of the variables
+# in the tree, will also associated default values with variables
+#
 variables <- function(x) {
   if (!is_list(x)) {
     if (x == "") {
       stop_invalid_lhs(empty_variable(x))
     }
 
+    if (is.language(x) && length(x) > 1 && is_extract_op(x[[1]])) {
+      return(x)
+    }
+
     if (!is.symbol(x)) {
       stop_invalid_lhs(unexpected_variable(x))
     }
@@ -108,6 +185,10 @@ incorrect_number_of_values <- function() {
   "incorrect number of values"
 }
 
+object_does_not_exist <- function(obj) {
+  paste0("object `", obj, "` does not exist in calling environment")
+}
+
 empty_variable <- function(obj) {
   paste("found empty variable, check for extraneous commas")
 }
@@ -138,3 +219,7 @@ stop_invalid_rhs <- function(message, call = sys.call(-1), ...) {
   cond <- condition(c("invalid_rhs", "error"), message, call, ...)
   stop(cond)
 }
+
+is_invalid_side_error <- function(e) {
+  inherits(e, c("invalid_lhs", "invalid_rhs"))
+}