Merge branch 'master' into fix-reshape-diagnosis

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 {

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", ... = ...)

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")
 }
+

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

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

R/redesign.R

@@ -64,6 +64,8 @@
 
 #' @export
 redesign <- function(design, ..., expand = TRUE) {
+  check_design_class_single(design)
+
   f <- function(...) {
     clone_design_edit(design, ...)
   }

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 {

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
 }

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))
+})

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)