unenclose is not copying

[schloerke]

Hey Hadley,

R is mapping memory different and is changing values after they have been evaluated. R 3.3.0 is changing variables after functions have been pryr::unenclose'd.

Any ideas on a fix?

This worked in R 3.2.latest (can't remember, but it was before I upgraded).

Small example:

# ans$A should return "A", all functions of ans currently return "C"

# plays bad memory tricks. 
run <- function() {
  myList <- list()

  for (item in c("A", "B", "C")) {
    my_fn <- function() { item }
    cat("my_fn: "); print(my_fn)
    cat("my_fn: "); print(pryr::unenclose(my_fn))
    myList[[item]] <- pryr::unenclose(my_fn)
    cat("myList:\n"); print(myList)
  }

  myList
}

ans <- run()
# my_fn: function() { item }
# <environment: 0x7fe7762670d8>
# my_fn: function () 
# {
#     "A"
# }
# myList:
# $A
# function () 
# {
#     "A"
# }
# 
# my_fn: function() { item }
# <environment: 0x7fe7762670d8>
# my_fn: function () 
# {
#     "B"
# }
# myList:
# $A
# function () 
# {
#     "B"
# }
# 
# $B
# function () 
# {
#     "B"
# }
# 
# my_fn: function() { item }
# <environment: 0x7fe7762670d8>
# my_fn: function () 
# {
#     "C"
# }
# myList:
# $A
# function () 
# {
#     "C"
# }
# 
# $B
# function () 
# {
#     "C"
# }
# 
# $C
# function () 
# {
#     "C"
# }

ans
# $A
# function () 
# {
#     "C"
# }
# 
# $B
# function () 
# {
#     "C"
# }
# 
# $C 
# function () 
# {
#     "C"
# }


# works as expected
run2 <- function() {
  myVec <- c("A", "B", "C")
  names(myVec) <- myVec
  myList <- lapply(myVec, function(item) {
    myItem <- force(item)
    my_fn <- function() { myItem }
    cat("my_fn: "); print(my_fn)
    my_fn <- pryr::unenclose(my_fn)
    environment(my_fn) <- globalenv()
    cat("my_fn: "); print(my_fn)
    my_fn
  })
  myList
}

ans2 <- run2()
# my_fn: function() { myItem }
# <environment: 0x7fe77624a150>
# my_fn: function () 
# {
#     "A"
# }
# my_fn: function() { myItem }
# <environment: 0x7fe77544ca00>
# my_fn: function () 
# {
#     "B"
# }
# my_fn: function() { myItem }
# <environment: 0x7fe7758e90e8>
# my_fn: function () 
# {
#     "C"
# }
ans2
# $A
# function () 
# {
#     "A"
# }
# 
# $B
# function () 
# {
#     "B"
# }
# 
# $C
# function () 
# {
#     "C"
# }

[schloerke]

my_list <- (function() {
  ret_fn <- function(item) {
    function() {
      item
    }
  }
  lapply(c("A", "B", "C"), ret_fn)
})()
my_list[[1]]
# function() {
#       item
#     }
# <environment: 0x7fe777e97468>

# correct env, wrong value
pryr::unenclose(my_list[[1]])
# function () 
# {
#     X[[i]]
# }
# <environment: 0x7fe777e97b88>

The error is stemming from substitute_q within unenclose.

substitute_q(body(my_list[[1]]), environment(my_list[[1]]))
# {
#     X[[i]]
# }

I found a solution using modify_lang to change the value of the body. While it's a recursive call (which means slower execution), it works.

my_unenclose <- function(f) {
  stopifnot(is.function(f))

  env <- environment(f)
  ls_env <- ls(envir = env)

  a_to_b <- function(x) {
    if (is.name(x)) {
      dep_x <- deparse(x)
      if (dep_x %in% ls_env) {
        return(get(dep_x, envir = env))
      }
    }
    x
  }

  body <- modify_lang(body(f), a_to_b)
  pryr::make_function(formals(f), body, parent.env(env))
}
my_unenclose(my_list[[1]])
# function () 
# {
#     "A"
# }
# <environment: 0x7fe777e97b88>

Applying this to issue #35, it still works.

tag <- function(tag) {
  force(tag)
  function(...) {
    args <- list(...)
    attribs <- html_attributes(named(args))
    children <- unlist(escape(unnamed(args)))

    html(paste0(
      "<", tag, attribs, ">",
      paste(children, collapse = ""),
      "</", tag, ">"
    ))
  }
}
void_tag <- function(tag) {
  force(tag)
  function(...) {
    args <- list(...)
    if (length(unnamed(args)) > 0) {
      stop("Tag ", tag, " can not have children", call. = FALSE)
    }
    attribs <- html_attributes(named(args))

    html(paste0("<", tag, attribs, " />"))
  }
}
tags <- c("a", "abbr", "address", "article", "aside", "audio", 
  "b","bdi", "bdo", "blockquote", "body", "button", "canvas", 
  "caption","cite", "code", "colgroup", "data", "datalist", 
  "dd", "del","details", "dfn", "div", "dl", "dt", "em", 
  "eventsource","fieldset", "figcaption", "figure", "footer", 
  "form", "h1", "h2", "h3", "h4", "h5", "h6", "head", "header", 
  "hgroup", "html", "i","iframe", "ins", "kbd", "label", 
  "legend", "li", "mark", "map","menu", "meter", "nav", 
  "noscript", "object", "ol", "optgroup", "option", "output", 
  "p", "pre", "progress", "q", "ruby", "rp","rt", "s", "samp", 
  "script", "section", "select", "small", "span", "strong", 
  "style", "sub", "summary", "sup", "table", "tbody", "td", 
  "textarea", "tfoot", "th", "thead", "time", "title", "tr",
  "u", "ul", "var", "video")

void_tags <- c("area", "base", "br", "col", "command", "embed",
  "hr", "img", "input", "keygen", "link", "meta", "param", 
  "source", "track", "wbr")

tag_fs <- c(
  setNames(lapply(tags, tag), tags),
  setNames(lapply(void_tags, void_tag), void_tags)
)

my_unenclose(tag_fs$command)
# function (...) 
# {
#     args <- list(...)
#     if (length(unnamed(args)) > 0) {
#         stop("Tag ", "command", " can not have children", call. = FALSE)
#     }
#     attribs <- html_attributes(named(args))
#     html(paste0("<", "command", attribs, " />"))
# }

Applying to original situation:

run <- function() {
  myList <- list()

  for (item in c("A", "B", "C")) {
    my_fn <- function() { item }
    myList[[item]] <- my_unenclose(my_fn)
  }

  myList
}
run()
# $A
# function () 
# {
#     "A"
# }
# 
# $B
# function () 
# {
#     "B"
# }
# 
# $C
# function () 
# {
#     "C"
# }

[schloerke]

@wch Any ideas on this one?

This seems more like a R-core problem. :-/

[schloerke]

Should use rlang::expr_interp instead