binding_types <- function() {
c("source", "target")
}
## This is the workhorse function that generates the right sort of
## active binding function for binding to a target (going via
## `remake_make1()`) or something from the managed environment (a
## simple `get()`).
make_active_binding_function <- function(obj, name, type) {
file_path <- normalizePath(obj$file)
dir_path <- dirname(file_path)
file_name <- basename(file_path)
force(name)
if (!(type %in% binding_types())) {
stop("Unknown binding type ", type)
}
function(value) {
if (missing(value)) {
old_wd <- setwd(dir_path)
on.exit(setwd(old_wd), add = TRUE)
if (type == "target") {
fetch(name, remake_file = file_name, verbose = FALSE)
} else if (type == "source") {
obj$store$env$env[[name]]
}
} else {
stop(sprintf('"%s" is managed by remake and is read-only', name),
call.=FALSE)
}
}
}
##' @export
print.target_placeholder <- function(x, ...) {
cat(sprintf("<target %s>\n", x$name))
}
## This is almost certainly going to be doing too much, but I want to
## collect *all* the functionality here for now. Some of this stuff
## will be better as free functions, really.
##
## Each manager will keep track of as single environment; this will
## get triggered by things like `remake_bindings`. We will need a
## second manager that globally keeps track of which environment each
## remakefile is associated with, but that's a problem for later; for
## now we'll assume that the global environment is the only place
## things get put and just check there.
binding_manager <- R6Class(
"binding_manager",
public=list(
envir=NULL, # environment where bindings are stored
files=character(0), # files we know about
bindings=character(0), # name of each binding
type=character(0), # type of each binding
file=character(0), # file associated with each binding
initialize=function(envir) {
self$envir <- envir
},
create_bindings=function(filename) {
obj <- remake(filename)
self$set_bindings("source", obj)
self$set_bindings("target", obj)
},
delete_bindings=function(filename) {
names <- self$list_bindings(filename)
rm(list=names, envir=self$envir)
self$drop_bindings(filename)
invisible(names)
},
reload_bindings=function(type, obj) {
file <- obj$file
if (!is.null(file) && file %in% self$files) {
self$set_bindings(type, obj)
}
},
set_bindings=function(type, obj) {
if (type == "target") {
names <- remake_list_targets(obj, "object")
} else if (type == "source") {
.remake_initialize_packages(obj)
names <- ls(obj$store$env$env, all.names=TRUE)
} else {
stop("Unknown type ", type)
}
file <- obj$file
## 1. Check:
normal <- filter_active_bindings(names, self$envir, normal=TRUE)
if (length(normal) > 0L) {
stop("Bindings would overwrite normal variables: ",
paste(normal, collapse=", "))
}
## 2. Check that known bindings match files
existing <- self$bindings %in% names
if (any(existing)) {
if (any(self$file[existing] != file)) {
stop("Clash of files")
}
if (any(self$type[existing] != type)) {
stop("Clash of types")
}
}
## 3. Set the bindings up
new_bindings <- setdiff(names, self$bindings)
for (i in setdiff(names, self$bindings)) {
makeActiveBinding(i, make_active_binding_function(obj, i, type),
self$envir)
}
## 4. Do the book keeping
self$files <- union(self$files, file)
self$bindings <- c(self$bindings, new_bindings)
self$type <- c(self$type, rep_len(type, length(new_bindings)))
self$file <- c(self$file, rep_len(file, length(new_bindings)))
invisible(NULL)
},
## Helpers:
list_bindings=function(file) {
filter_active_bindings(self$bindings[self$file == file], self$envir)
},
drop_bindings=function(file) {
keep <- self$file != file
self$bindings <- self$bindings[keep]
self$file <- self$file[keep]
self$type <- self$type[keep]
self$files <- setdiff(self$files, file)
},
clear=function() {
rm(list=filter_active_bindings(self$bindings, self$envir),
envir=self$envir)
self$file <- character(0)
self$type <- character(0)
self$files <- character(0)
self$bindings <- character(0)
}
))
## One global instance at the package level:
global_active_bindings <- binding_manager$new(.GlobalEnv)
filter_active_bindings <- function(names, envir, normal=FALSE) {
names <- intersect(names, ls(envir, all.names=TRUE))
is_binding <- vlapply(names, bindingIsActive, envir)
names[if (normal) !is_binding else is_binding]
}
is_active_binding <- function(sym_name, envir=.GlobalEnv) {
exists(sym_name, envir, inherits=FALSE) && bindingIsActive(sym_name, envir)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.