Proof-of-concept of general assignment function and related functions

assign_general.R

library(rlang)
library(assertthat)
library(magrittr)
library(glue)
library(tibble)

## Takes LHS and RHS as strings
assign_general_ <- function(lhs, rhs, envir) {
    expr <- parse(text=glue("{lhs} <- {rhs}"))
    eval(expr, envir)
}

## Like assign, but allows arbitrary left-hand side expression
assign_general <- function(x, value, pos, envir) {
    lhs <- enquo(x)
    rhs <- enquo(value)
    if (missing(envir)) {
        if (missing(pos)) {
            ## Take env from arguments
            envir <- f_env(lhs)
            ## I think this is always true?
            assert_that(identical(f_env(rhs), envir) ||
                        identical(f_env(rhs), emptyenv()))
        } else {
            envir = as.environment(position)
        }
    }
    assert_that(is_env(envir))
    assign_general_(f_text(lhs), f_text(rhs), envir)
}

## Same as assign_general, but takes a single definition (rlang ':='
## operator) instead of separate arguments for
assign_definition <- function(def, envir=environment(def)) {
    assert_that(is_definition(def))
    lhs <- expr_text(f_lhs(def))
    rhs <- expr_text(f_rhs(def))
    assign_general_(lhs, rhs, envir)
}

## This all works
assign_general(a, list())
assign_general(a[[1]], 5)
assign_definition(a[[2]] := list())
assign_general(a[[2]]$element, a[[1]])
## Supports unquoting
i <- 2
elem_name <- "second_element"
assign_general(a[[ !!i ]][[ !!elem_name ]], 7, envir=globalenv())
a
local(assign_general(a[[1]], 6))
## Not modified in gloabl env
a

is_unnamed <- function (x)
{
    nms <- names(x)
    if (is_null(nms)) {
        return(TRUE)
    }
    if (all(nms == "" | is.na(nms))) {
        return(TRUE)
    }
    FALSE
}

## Use in magrittr pipelines to assign to arbitrary locations inside
## complex structures.
assign_into <- function(x, ...) {
    defs <- dots_definitions(...)
    assert_that(length(defs$dots) == 0)
    defs <- defs$defs
    e <- new.env(parent=as.environment(-1))
    e$`.` <- x
    for (def in defs) {
        assign_general_(f_text(def$lhs), f_text(def$rhs), e)
    }
    e$`.`
}

df <- tibble(x=1:10) %>%
    ## Arbitrary LHS involving '.'
    assign_into(.$y := (.$x^2),
                .$y[5] := .$y[5] * 10,
                attr(.$y, "someattr") := 5)
df
df$y

example_transcript.txt

> library(rlang)
> library(assertthat)
> library(magrittr)
> library(glue)
> library(tibble)
> 
> ## Takes LHS and RHS as strings
> assign_general_ <- function(lhs, rhs, envir) {
+     expr <- parse(text=glue("{lhs} <- {rhs}"))
+     eval(expr, envir)
+ }
> 
> ## Like assign, but allows arbitrary left-hand side expression
> assign_general <- function(x, value, pos, envir) {
+     lhs <- enquo(x)
+     rhs <- enquo(value)
+     if (missing(envir)) {
+         if (missing(pos)) {
+             ## Take env from arguments
+             envir <- f_env(lhs)
+             ## I think this is always true?
+             assert_that(identical(f_env(rhs), envir) ||
+                         identical(f_env(rhs), emptyenv()))
+         } else {
+             envir = as.environment(position)
+         }
+     }
+     assert_that(is_env(envir))
+     assign_general_(f_text(lhs), f_text(rhs), envir)
+ }
> 
> ## Same as assign_general, but takes a single definition (rlang ':='
> ## operator) instead of separate arguments for
> assign_definition <- function(def, envir=environment(def)) {
+     assert_that(is_definition(def))
+     lhs <- expr_text(f_lhs(def))
+     rhs <- expr_text(f_rhs(def))
+     assign_general_(lhs, rhs, envir)
+ }
> 
> ## This all works
> assign_general(a, list())
> assign_general(a[[1]], 5)
> assign_definition(a[[2]] := list())
> assign_general(a[[2]]$element, a[[1]])
> ## Supports unquoting
> i <- 2
> elem_name <- "second_element"
> assign_general(a[[ !!i ]][[ !!elem_name ]], 7, envir=globalenv())
> a
[[1]]
[1] 5

[[2]]
[[2]]$element
[1] 5

[[2]]$second_element
[1] 7


> local(assign_general(a[[1]], 6))
> ## Not modified in gloabl env
> a
[[1]]
[1] 5

[[2]]
[[2]]$element
[1] 5

[[2]]$second_element
[1] 7


> 
> is_unnamed <- function (x)
+ {
+     nms <- names(x)
+     if (is_null(nms)) {
+         return(TRUE)
+     }
+     if (all(nms == "" | is.na(nms))) {
+         return(TRUE)
+     }
+     FALSE
+ }
> 
> ## Use in magrittr pipelines to assign to arbitrary locations inside
> ## complex structures.
> assign_into <- function(x, ...) {
+     defs <- dots_definitions(...)
+     assert_that(length(defs$dots) == 0)
+     defs <- defs$defs
+     e <- new.env(parent=as.environment(-1))
+     e$`.` <- x
+     for (def in defs) {
+         assign_general_(f_text(def$lhs), f_text(def$rhs), e)
+     }
+     e$`.`
+ }
> 
> df <- tibble(x=1:10) %>%
+     ## Arbitrary LHS involving '.'
+     assign_into(.$y := (.$x^2),
+                 .$y[5] := .$y[5] * 10,
+                 attr(.$y, "someattr") := 5)
> df
# A tibble: 10 x 2
       x     y
   <int> <dbl>
 1     1     1
 2     2     4
 3     3     9
 4     4    16
 5     5   250
 6     6    36
 7     7    49
 8     8    64
 9     9    81
10    10   100
> df$y
 [1]   1   4   9  16 250  36  49  64  81 100
attr(,"someattr")
[1] 5
>