Nothing
###############################################################################
# Copies an environment chain
#' @importFrom rlang env_clone
env_deep_copy <- function(e) {
# Cloning the CheckExEnv causes examples to autofail, it has delayedAssign("F", stop())
if (environmentName(e) == "CheckExEnv") {
e
} else if (identical(e, emptyenv())) {
emptyenv()
} else if (identical(e, globalenv())) {
env_clone(e)
} else {
env_clone(e, Recall(parent.env(e)))
}
# don't clone attached packages
}
###############################################################################
# For set of dots, copy environment chain, reusing the new env if possible
# to save memory
#' @importFrom rlang env_clone
dots_env_copy <- function(dots) {
eprev <- NULL
for (i in seq_along(dots)) {
ecurrent <- environment(dots[[i]])
if (!is.null(ecurrent)) {
if (!identical(ecurrent, eprev)) {
eprev <- ecurrent
eclone <- env_deep_copy(ecurrent)
}
environment(dots[[i]]) <- eclone
}
}
dots
}
# Given a function and dots, rename dots based on how things will positionally match
#' @importFrom rlang is_empty is_scalar_character get_expr
rename_dots <- function(handler, dots) {
initial_call <- match.call(handler, as.call(get_expr(quo(handler(!!!dots)))))
free_vars <- setdiff(names(formals(handler)), names(initial_call))
if(length(free_vars) > 0 & !any(c('data', '.data') %in% names(dots))) {
# first check if ^data argument was already provided by user in dots.
# DD data param in this comment
dot_is_data <- vapply(lapply(dots, get_expr), identical, TRUE, quote(data))
if(!any(dot_is_data)) {
# To make handlers quasi-compatible with hadley naming of functions
# eg .data and not data
# If there is neither a data or .data, match positional argument #1
data_arg <- list(quote(data))
data_arg_name <- names(formals(handler)) %i% c('data', '.data')
if(is_scalar_character(data_arg_name)) {
names(data_arg) <- data_arg_name
}
dots <- append(dots, data_arg, after = FALSE)
is_implicit_data_arg(dots) <- TRUE
}
}
if (is_empty(dots)) {
return(dots)
}
f <- function(...) as.list(match.call(handler)[-1])
# Match positions to parameter names of handler, copy names onto dots.
# Defensive, will help when handlers are wrapped in HOF
d_idx <- setNames(seq_along(dots), names(dots))
d_idx <- eval_tidy(quo(f(!!!d_idx)))
d_idx <- unlist(d_idx)
d_idx <- d_idx[names(d_idx) != "" ]
names(dots)[d_idx] <- names(d_idx)
dots
}
# Returns a new function(data) which calls FUN(data, dots)
currydata <- function(FUN, dots) {
quoData <- quo((FUN)(!!!dots))
quoNoData <- quo((FUN)(!!!(dots[names(dots) != 'data'])))
function(data = NULL) {
#message(quo)
# used for declare_model with no seed data provided, in which case null is not the same as missing.
# Unfortunately, steps do not know at time of declaration if they are in first position or not;
# combining steps into design happens after.
# This could in theory be caught be a design validation function for declare_model.
eval_tidy(if (is.null(data) & is_implicit_data_arg(dots)) quoNoData else quoData, data = list(data = data))
}
}
# Implementation for declarations
# captures the dots and handler, and returns a function that calls the handler with dots
# also deals with labeling and can trigger step validation
#' @importFrom rlang enquo
declaration_template <- function(..., handler, label = NULL) {
# message("Declared")
dots <- as.list(quos(..., label = !!label))
this <- attributes(sys.function())
if (!"label" %in% names(formals(handler))) {
dots$label <- NULL
}
dots <- rename_dots(handler, dots)
dots <- dots_env_copy(dots)
ret <- build_step(currydata(handler, dots),
handler = handler,
dots = dots,
label = label,
step_type = this$step_type,
causal_type = this$causal_type,
call = match.call())
validate(handler, ret, dots, label)
}
# data structure for steps
build_step <- function(curried_fn, handler, dots, label, step_type, causal_type, call) {
structure(
curried_fn,
handler = handler,
dots = dots,
label = label,
step_type = step_type,
causal_type = causal_type,
call = call,
class = c("design_step", "dd", "function")
)
}
# generate declaration steps (eg declare_model) by setting the default handler and metadata
make_declarations <- function(default_handler, step_type, causal_type = "dgp", default_label, strictDataParam = TRUE) {
declaration <- declaration_template
formals(declaration)$handler <- substitute(default_handler)
if (!missing(default_label)) {
formals(declaration)$label <- default_label
}
structure(
declaration,
class = c("declaration", "function"),
step_type = step_type,
causal_type = causal_type,
strictDataParam = strictDataParam
)
}
###############################################################################
# internal helpers for step-specific validation code
# set on a handler (see eg reveal_outcomes_handler)
# called at declare time
#
# to debug, use debug(DeclareDesign:::validation_fn(DeclareDesign:::reveal_outcomes_handler))
validation_fn <- function(f) {
attr(f, "validation_fn")
}
`validation_fn<-` <- with_validation_fn <- function(x, value) {
attr(x, "validation_fn") <- value
x
}
has_validation_fn <- function(f) {
is.function(validation_fn(f))
}
validate <- function(handler, ret, dots, label) {
if(is.character(label) && length(label) > 1)
declare_time_error("Please provide only one label.", ret)
if (has_validation_fn(handler)) {
validation_fn(handler)(ret, dots, label)
} else {
ret
}
}
###############################################################################
# used to inherit roxygen docs
#' @param ... arguments to be captured, and later passed to the handler
#' @param handler a tidy-in, tidy-out function
#' @param label a string describing the step
#' @keywords internal
declare_internal_inherit_params <- make_declarations(function(data, ...) data.frame(BLNK = "MSG", stringsAsFactors = TRUE), step_type = "BLNKMSG")
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.