# SOURCE: https://raw.githubusercontent.com/r-lib/R6/41f942af11b4b350a83f3fac2071d4e8998ae0de/R/clone.R
# This function will be added as a method to R6 objects, with the name 'clone',
# and with the environment changed.
generator_funs$clone_method <- function(deep = FALSE) {
# Need to embed these utility functions inside this closure because the
# environment of this function will change.
assign_func_envs <- function(objs, target_env) {
if (is_void(target_env)) return(objs)
lapply(objs, function(x) {
if (is.function(x)) environment(x) <- target_env
x
})
}
list2env2 <- function(x, envir = NULL, parent = emptyenv(),
hash = (length(x) > 100),
size = max(29L, length(x)),
empty_to_null = TRUE) {
if (is_void(envir)) {
envir <- new.env(hash = hash, parent = parent, size = size)
}
if (length(x) == 0) {
if (empty_to_null)
return(NULL)
else
return(envir)
}
list2env(x, envir)
}
clone_super <- function(old_enclos_env, new_enclos_env, public_bind_env,
has_private, private_bind_env)
{
old_super_bind_env <- old_enclos_env$super
if (is_void(old_super_bind_env))
return()
# Copy all the methods from the old super binding env to the new one, and
# set their enclosing env to a new one.
super_copies <- as.list.environment(old_super_bind_env, all.names = TRUE)
# Degenerate case: super env is empty
if (length(super_copies) == 0) {
new_enclos_env$super <- new.env(parent = emptyenv(), hash = FALSE)
return()
}
# All items in the old_super_bind_env must be functions; to get the
# old_super_enclos_env, simply call environment() on one of them. Doing it
# this way lets us avoid storing an explicit pointer to the super_enclos_env
# in the original super_bind_env. This doesn't work as well for avoiding
# storing the enclos_env in the original public_bind_env, because there are
# many possible items there. We can't assume that just any item is a
# function -- and even if we do find a function, it's not guaranteed that
# it's a method. It may be a function (with a different parent env) that was
# added after the object was created.
old_super_enclos_env <- environment(super_copies[[1]])
# Create new super enclos env and populate with self and private.
new_super_enclos_env <- new.env(parent = parent.env(old_super_enclos_env),
hash = FALSE)
new_super_enclos_env$self <- public_bind_env
if (has_private)
new_super_enclos_env$private <- private_bind_env
new_super_bind_env <- new.env(parent = emptyenv(), hash = FALSE)
# Fix up environments for methods
super_copies <- assign_func_envs(super_copies, new_super_enclos_env)
# Separate active from non-active items
active_idx <- vapply(names(super_copies), bindingIsActive, env = old_super_bind_env,
TRUE)
active_copies <- super_copies[active_idx]
non_active_copies <- super_copies[!active_idx]
# Copy over items
list2env2(non_active_copies, new_super_bind_env)
if (length(active_copies) > 0) {
for (name in names(active_copies)) {
makeActiveBinding(name, active_copies[[name]], new_super_bind_env)
}
}
new_enclos_env$super <- new_super_bind_env
# Recurse
clone_super(old_super_enclos_env, new_super_enclos_env, public_bind_env,
has_private, private_bind_env)
}
# ------------------------------------------------------------------
old_enclos_env <- .subset2(self, ".__enclos_env__")
if (!is.environment(old_enclos_env)) {
stop("clone() must be called from an R6 object.")
}
old_public_bind_env <- self
old_private_bind_env <- old_enclos_env$private
has_private <- !is_void(old_private_bind_env)
# Figure out if we're in a portable class object
portable <- !identical(old_public_bind_env, old_enclos_env)
# Set up stuff for deep clones
if (deep) {
if (has_private && is.function(old_private_bind_env$deep_clone)) {
# Get private$deep_clone, if available.
deep_clone <- old_private_bind_env$deep_clone
} else {
# If there's no private$deep_clone, then this default function will copy
# fields that are R6 objects.
deep_clone <- function(name, value) {
# Check if it's an R6 object.
if (is.environment(value) && !is_void(value$`.__enclos_env__`)) {
return(value$clone(deep = TRUE))
}
value
}
}
}
# Create the new binding and enclosing environments
if (portable) {
if (has_private) {
private_bind_env <- new.env(emptyenv(), hash = FALSE)
}
public_bind_env <- new.env(emptyenv(), hash = FALSE)
new_enclos_env <- new.env(parent.env(old_enclos_env), hash = FALSE)
} else {
if (has_private) {
private_bind_env <- new.env(parent.env(old_private_bind_env), hash = FALSE)
public_bind_env <- new.env(private_bind_env, hash = FALSE)
} else {
public_bind_env <- new.env(parent.env(old_public_bind_env), hash = FALSE)
}
new_enclos_env <- public_bind_env
}
# Copy members ----------------------------------------------------
# Copy the old objects, fix up method environments, and put them into the
# new binding environment.
public_copies <- as.list.environment(old_public_bind_env, all.names = TRUE)
# If non-portable, `self` will be there; make sure not to copy it.
if (!portable) {
public_copies$self <- NULL
}
# Don't copy .__enclos_env__
public_copies <- public_copies[setdiff(names(public_copies), ".__enclos_env__")]
public_copies <- assign_func_envs(public_copies, new_enclos_env)
# Separate active and non-active bindings
active_idx <- vapply(names(public_copies), bindingIsActive, env = old_public_bind_env,
logical(1))
active_copies <- public_copies[active_idx]
public_copies <- public_copies[!active_idx]
if (deep) {
public_copies <- mapply(deep_clone, names(public_copies), public_copies,
SIMPLIFY = FALSE)
}
# Copy in public and active bindings
list2env2(public_copies, public_bind_env)
if (length(active_copies) > 0) {
for (name in names(active_copies)) {
makeActiveBinding(name, active_copies[[name]], public_bind_env)
}
}
# Copy private members
if (has_private) {
private_copies <- as.list.environment(old_private_bind_env, all.names = TRUE)
if (deep) {
private_copies <- mapply(deep_clone, names(private_copies), private_copies,
SIMPLIFY = FALSE)
}
private_copies <- assign_func_envs(private_copies, new_enclos_env)
list2env2(private_copies, private_bind_env)
}
# Clone super object -------------------------------------------
clone_super(old_enclos_env, new_enclos_env, public_bind_env, has_private,
private_bind_env)
# Add refs to other environments in the object --------------------
public_bind_env$`.__enclos_env__` <- new_enclos_env
# Add self and (optional) private pointer ---------------------------
new_enclos_env$self <- public_bind_env
if (has_private)
new_enclos_env$private <- private_bind_env
class(public_bind_env) <- class(old_public_bind_env)
# Lock --------------------------------------------------------------
# Copy locked state of environment
if (environmentIsLocked(old_public_bind_env)) {
lockEnvironment(public_bind_env)
}
if (has_private && environmentIsLocked(old_private_bind_env)) {
lockEnvironment(private_bind_env)
}
# Always lock methods
# We inspect the names in public_copies instead public_bind_env, because
# ls() is so slow for environments. R 3.2.0 introduced the sorted=FALSE
# option, which makes ls() much faster, so at some point we'll be able to
# switch to that.
for (name in names(public_copies)) {
if (is.function(.subset2(public_bind_env, name)))
lockBinding(name, public_bind_env)
}
if (has_private) {
for (name in names(private_copies)) {
if (is.function(private_bind_env[[name]]))
lockBinding(name, private_bind_env)
}
}
public_bind_env
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.