Merge 8fba681 into 6f760b0

DeclareDesign · Jan 7, 2019 · 9a8bec7 · 9a8bec7
2 parents 6f760b0 + 8fba681
commit 9a8bec7
Show file tree

Hide file tree

Showing 4 changed files with 53 additions and 17 deletions.
diff --git a/NAMESPACE b/NAMESPACE
@@ -117,6 +117,7 @@ importFrom(stats,var)
 importFrom(stats,vcov)
 importFrom(utils,bibentry)
 importFrom(utils,capture.output)
+importFrom(utils,compareVersion)
 importFrom(utils,data)
 importFrom(utils,getS3method)
 importFrom(utils,head)

diff --git a/R/expand_design.R b/R/expand_design.R
@@ -49,27 +49,26 @@ expand_design <- function(designer, ..., expand = TRUE, prefix = "design") {
 
   if (length(dots_quos) == 0) return(designer())
 
-  T <- function(zx,ix) do.call(mapply, 
+  # transpose
+  transp <- function(zx,ix) do.call(mapply, 
                                append(mapply(`[`, zx, ix, SIMPLIFY = FALSE), 
-                                      list(FUN=list, SIMPLIFY=FALSE), 
+                                      list(FUN = list, SIMPLIFY = FALSE), 
                                       after = 0)
                                )
-
 
   args <- list(...)
   args <- lapply(args, function(x) if(is.function(x)) list(x) else x)
 
   ix <- lapply(args, seq_along)
   ix <- if(expand) expand.grid(ix) else data.frame(ix)
-
 
-  designs <- lapply(T(args, ix), do.call, what=designer)
+  designs <- lapply(transp(args, ix), do.call, what = designer)
 
   args_names <- lapply(dots_quos, expand_args_names)
 
   designs <- mapply(structure, 
                     designs, 
-                    parameters=T(args_names, ix), 
+                    parameters = transp(args_names, ix), 
                     SIMPLIFY = FALSE)
 
 

diff --git a/R/simulate_design.R b/R/simulate_design.R
@@ -85,6 +85,8 @@ simulate_design <- function(..., sims = 500) {
   parameters_df <- rbind_disjoint(parameters_df_list)
   parameters_df <- data.frame(lapply(parameters_df, type_convert), stringsAsFactors = FALSE)
 
+  simulations_df <- merge(simulations_df, parameters_df, by = "design_label", sort = FALSE, all = TRUE)
+
   simulations_df <- simulations_df[, reorder_columns(parameters_df, simulations_df), drop = FALSE]
 
   attr(simulations_df, "parameters") <- parameters_df
@@ -204,16 +206,17 @@ simulate_single_design <- function(design, sims) {
     }
   }
 
-  if (!is_empty(attr(design, "parameters"))) {
-    simulations_df <-
-      data.frame(
-        simulations_df[, 1, drop = FALSE],
-        as_list(attr(design, "parameters")),
-        simulations_df[, -1, drop = FALSE], 
-        stringsAsFactors = FALSE
-      )
-  }
-  simulations_df <- data.frame(lapply(simulations_df, type_convert), stringsAsFactors = FALSE)
+  # removed for now
+  # if (!is_empty(attr(design, "parameters"))) {
+  #   simulations_df <-
+  #     data.frame(
+  #       simulations_df[, 1, drop = FALSE],
+  #       as_list(attr(design, "parameters")),
+  #       simulations_df[, -1, drop = FALSE], 
+  #       stringsAsFactors = FALSE
+  #     )
+  # }
+  # simulations_df <- data.frame(lapply(simulations_df, type_convert), stringsAsFactors = FALSE)
   simulations_df
 }
 
@@ -244,6 +247,13 @@ infer_names <- function(x, type = "design") {
   inferred_names
 }
 
+# TODO: remove this when 3.6 comes out
+# for version 3.4 compatibility
+#' @importFrom utils compareVersion
 type_convert <- function(x) {
-  if (inherits(x, "character")) type.convert(x, as.is = TRUE) else x
+  if(compareVersion("3.5", paste(R.Version()$major, R.Version()$minor, sep = ".")) == -1){
+    if (inherits(x, "character") || inherits(x, "factor")) type.convert(x, as.is = TRUE) else x
+  } else {
+    if (inherits(x, "character")) type.convert(x, as.is = TRUE) else x
+  }
 }
diff --git a/tests/testthat/test-diagnose-design.R b/tests/testthat/test-diagnose-design.R
@@ -248,3 +248,29 @@ test_that("more term",{
 
 })
 
+test_that("diagnose_design does not reclass the variable N", {
+  skip_if(compareVersion("3.5", paste(R.Version()$major, R.Version()$minor, sep = ".")) == 1)
+  # works for redesign
+  design <-
+    declare_population(N = 5, noise = rnorm(N)) +
+       declare_estimand(mean_noise = mean(noise))
+
+  designs <- redesign(design, N = 5:10) 
+  dx <- diagnose_design(designs, sims = 50, bootstrap_sims = FALSE)
+
+  expect_equal(class(dx$simulations_df$N), "integer") 
+  expect_equal(class(dx$diagnosands_df$N), "integer")
+
+  # works for expand_design
+  designer <- function(N = 5) {
+    declare_population(N = N, noise = rnorm(N)) +
+    declare_estimand(mean_noise = mean(noise))
+  }
+
+  designs <- expand_design(designer, N = 5:10) 
+  dx <- diagnose_design(designs, sims = 50, bootstrap_sims = FALSE)
+
+  expect_equal(class(dx$simulations_df$N), "integer") 
+  expect_equal(class(dx$diagnosands_df$N), "integer")
+
+})