diff --git a/R/aaa.R b/R/aaa.R index f70bd73c..6fa6f601 100644 --- a/R/aaa.R +++ b/R/aaa.R @@ -76,11 +76,18 @@ currydata <- function(FUN, dots, addDataArg = TRUE, strictDataParam = TRUE, clon quoNoData <- quo((FUN)(!!!dots)) if (addDataArg && !"data" %in% names(dots) && !".data" %in% names(dots)) { - dots <- append(dots, list(data = quote(data)), after = FALSE) + # To make handlers quasi-compatible with hadley naming of functions + # eg .data and not data + hadley_naming <- ".data" %in% names(formals(FUN)) + + data_arg <- list(data = quote(data)) + if(hadley_naming) names(data_arg) <- ".data" + dots <- append(dots, data_arg, after = FALSE) } quo <- quo((FUN)(!!!dots)) + if (isTRUE(strictDataParam)) { function(data) eval_tidy(quo, data = list(data = data)) } else { diff --git a/R/design_helper_functions.R b/R/design_helper_functions.R index fce2569a..c2785fb0 100644 --- a/R/design_helper_functions.R +++ b/R/design_helper_functions.R @@ -228,6 +228,8 @@ dots_to_list_of_designs <- function(...) { #' @export print_code <- function(design) { + check_design_class_single(design) + # if there is not a code attribute, construct code via the calls for each step # and the call for the declare step @@ -261,6 +263,9 @@ print_code <- function(design) { #' #' @export cite_design <- function(design, ...) { + + check_design_class_single(design) + citation <- attr(design, "citation") if (class(citation) == "bibentry") { print(citation, style = "bibtex", ... = ...) diff --git a/R/draw_functions.R b/R/draw_functions.R index dd15db0a..059c131c 100644 --- a/R/draw_functions.R +++ b/R/draw_functions.R @@ -50,11 +50,14 @@ draw_estimands <- function(...) apply_on_design_dots(draw_estimands_single_desig draw_estimates <- function(...) apply_on_design_dots(draw_estimates_single_design, ...) draw_estimates_single_design <- function(design) { - results <- list("estimator" = vector("list", length(design))) - run_design_internal(design, results = results)$estimates_df + get_function_internal( + design, -9, 1, length(design), function(x) TRUE, + list("estimator" = vector("list", length(design))), "estimates_df") } draw_estimands_single_design <- function(design) { - results <- list("estimand" = vector("list", length(design))) - run_design_internal(design, results = results)$estimands_df + get_function_internal( + design, -9, 1, length(design), function(x) TRUE, + list("estimand" = vector("list", length(design))), "estimands_df") } + diff --git a/R/get_functions.R b/R/get_functions.R index 79d89f21..a4ba7d41 100644 --- a/R/get_functions.R +++ b/R/get_functions.R @@ -54,8 +54,18 @@ draw_sample <- function(design, data = NULL, start = 1, end = length(design)) { design, data, start, end, function(x) attr(x, "step_type") %in% "sampling") } + +# utilities + +check_design_class_single <- function(design) { + if(!inherits(design, "design")) + stop("Please send a single design object to the design argument, typically created using the + operator.", call. = FALSE) +} + get_function_internal <- function(design, data = NULL, start, end, pred, results = list(current_df = 0), what = "current_df") { + check_design_class_single(design) + if(identical(data, -9)){ # Special NULL for draw_data data <- NULL diff --git a/R/modify_design.R b/R/modify_design.R index cca10304..4f40ba78 100644 --- a/R/modify_design.R +++ b/R/modify_design.R @@ -65,12 +65,16 @@ NULL #' #' @export insert_step <- function(design, new_step, before, after) { + check_design_class_single(design) + if (missing(before)) before <- NULL if (missing(after)) after <- NULL insert_step_(design, new_step, before, after, enexpr(new_step)) } insert_step_ <- function(design, new_step, before = NULL, after = NULL, new_step_expr) { + check_design_class_single(design) + if (is.null(after)) { if (is.null(before)) { stop("Must provide either before or after to add_step()") @@ -96,6 +100,8 @@ insert_step_ <- function(design, new_step, before = NULL, after = NULL, new_step #' #' delete_step(design, my_assignment) delete_step <- function(design, step) { + check_design_class_single(design) + i <- find_step(design, step, "delete") construct_design(design[-i]) } @@ -105,6 +111,8 @@ delete_step <- function(design, step) { #' @examples #' replace_step(design, my_assignment, declare_step(dplyr::mutate, words = "income")) replace_step <- function(design, step, new_step) { + check_design_class_single(design) + i <- find_step(design, step, "replace") new_step <- wrap_step(new_step, enexpr(new_step)) design[i] <- new_step diff --git a/R/redesign.R b/R/redesign.R index 6eb2ef32..cbb0e6ac 100644 --- a/R/redesign.R +++ b/R/redesign.R @@ -64,6 +64,8 @@ #' @export redesign <- function(design, ..., expand = TRUE) { + check_design_class_single(design) + f <- function(...) { clone_design_edit(design, ...) } diff --git a/R/set_citation.R b/R/set_citation.R index 64b10c2c..d2992c4f 100644 --- a/R/set_citation.R +++ b/R/set_citation.R @@ -32,6 +32,8 @@ set_citation <- year = NULL, description = "Unpublished research design declaration", citation = NULL) { + check_design_class_single(design) + if (!is.null(citation)) { cite <- citation } else { diff --git a/R/set_diagnosands.R b/R/set_diagnosands.R index c251e382..e681332a 100644 --- a/R/set_diagnosands.R +++ b/R/set_diagnosands.R @@ -2,7 +2,7 @@ #' #' A researcher often has a set of diagnosands in mind to appropriately assess the quality of a design. \code{set_diagnosands} sets the default diagnosands for a design, so that later readers can assess the design on the same terms as the original author. Readers can also use \code{diagnose_design} to diagnose the design using any other set of diagnosands. #' -#' @param design A design typically created using the + operator +#' @param x A design typically created using the + operator, or a simulations data.frame created by \code{simulate_design}. #' @param diagnosands A set of diagnosands created by \code{\link{declare_diagnosands}} #' #' @return a design object with a diagnosand attribute @@ -23,11 +23,19 @@ #' #' \dontrun{ #' diagnose_design(design) +#' +#' simulations_df <- simulate_design(design) +#' +#' simulations_df <- set_diagnosands(simulations_df, design) +#' +#' diagnose_design(simulations_df) +#' #' } #' #' @export -set_diagnosands <- function(design, diagnosands = default_diagnosands) { - attr(design, "diagnosands") <- diagnosands +set_diagnosands <- function(x, diagnosands = default_diagnosands) { + + attr(x, "diagnosands") <- diagnosands - design + x } diff --git a/man/set_diagnosands.Rd b/man/set_diagnosands.Rd index 96b94d74..fa47c01b 100644 --- a/man/set_diagnosands.Rd +++ b/man/set_diagnosands.Rd @@ -4,10 +4,10 @@ \alias{set_diagnosands} \title{Set the diagnosands for a design} \usage{ -set_diagnosands(design, diagnosands = default_diagnosands) +set_diagnosands(x, diagnosands = default_diagnosands) } \arguments{ -\item{design}{A design typically created using the + operator} +\item{x}{A design typically created using the + operator, or a simulations data.frame created by \code{simulate_design}.} \item{diagnosands}{A set of diagnosands created by \code{\link{declare_diagnosands}}} } @@ -33,6 +33,13 @@ design <- set_diagnosands(design, diagnosands) \dontrun{ diagnose_design(design) + +simulations_df <- simulate_design(design) + +simulations_df <- set_diagnosands(simulations_df, design) + +diagnose_design(simulations_df) + } } diff --git a/tests/testthat/test-allow-custom-functions.R b/tests/testthat/test-allow-custom-functions.R index 6ebb07a3..79666c76 100644 --- a/tests/testthat/test-allow-custom-functions.R +++ b/tests/testthat/test-allow-custom-functions.R @@ -33,3 +33,14 @@ test_that("a dplyr pipeline can be used in a design", { expect_equal(names(dat), c("ID", "my_var")) }) + +# Use dyplr functions as handlers ? + +test_that("dplyr functions can be handlers", { + + design2 <- declare_population(N = 5, X = rnorm(N)) + declare_step(Y = 4, handler = mutate) + + df <- draw_data(design2) + + expect_equal(df$Y, rep(4,5)) +}) diff --git a/tests/testthat/test-get-star.R b/tests/testthat/test-get-star.R index b9914a32..afad085c 100644 --- a/tests/testthat/test-get-star.R +++ b/tests/testthat/test-get-star.R @@ -17,6 +17,12 @@ dat <- draw_data(design) dat$Z <- NULL dat$Z_cond_prob <- NULL +test_that("error when send list of designs to draw_data", { + + expect_error(draw_data(list(design, design)), "Please send a single design object to the design argument, typically created using the \\+ operator.") + +}) + test_that("get_ works", { dat_with_Z <- draw_assignment(design, dat)