Merge branch 'master' into whitespace

R/declare_diagnosands.R

@@ -4,6 +4,7 @@
 #' @param keep_defaults A flag for whether to report the default diagnosands. Defaults to \code{TRUE}.
 #' @param subset A subset of the simulations data frame within which to calculate diagnosands e.g. \code{subset = p.value < .05}.
 #' @param alpha Alpha significance level. Defaults to \code{.05}.
+#' @param na.rm logical. Should simulations with missing estimates be dropped? Defaults to TRUE.
 #' @param label Label for the set of diagnosands.
 #' @param data a data.frame
 #'
@@ -13,14 +14,15 @@
 #' will contain the step label. This can be used as an additional dimension for use in diagnosis.
 #'
 #'
-#' @importFrom rlang eval_tidy quos  is_quosure quo_is_call %||%
+#' @importFrom rlang eval_tidy quos is_quosure quo_is_call %||%
 #' @rdname declare_diagnosands
 diagnosand_handler <- function(data, ...,
                                select,
                                subtract,
                                keep_defaults = TRUE,
                                subset = NULL,
                                alpha = 0.05,
+                               na.rm = TRUE,
                                label) {
   options <- quos(...)
 
@@ -66,16 +68,34 @@ diagnosand_handler <- function(data, ...,
   }
 
   ret <- vector("list", length(options))
+
+  if(na.rm){
+    n_row_original <- nrow(data)
+    data <- na.omit(data)
+    n_deleted <- n_row_original - nrow(data)
+
+    na_ret <- data.frame(diagnosand_label = "n_deleted",
+                         diagnosand = n_deleted,
+                         stringsAsFactors = FALSE)
+  }
+
   for (i in seq_along(options)) {
     ret[i] <- eval_tidy(options[[i]], data = data)
   }
+
   ret <- simplify2array(ret)
-
+
+  ret <- 
   data.frame(
     diagnosand_label = names(options),
     diagnosand = ret,
     stringsAsFactors = FALSE
   )
+
+  if(na.rm){
+    ret <- rbind_disjoint(list(ret, na_ret))
+  }
+  ret
 }
 
 
@@ -222,7 +242,18 @@ validation_fn(diagnosand_handler) <- function(ret, dots, label) {
 #'
 declare_diagnosands <- make_declarations(diagnosand_handler, "diagnosand", "diagnosands")
 
-default_diagnosands <- function(data, alpha = .05) {
+default_diagnosands <- function(data, alpha = .05, na.rm = TRUE){
+
+  if(na.rm){
+    n_row_original <- nrow(data)
+    data <- na.omit(data)
+    n_deleted <- n_row_original - nrow(data)
+
+    na_ret <- data.frame(diagnosand_label = "n_deleted",
+                         diagnosand = n_deleted,
+                         stringsAsFactors = FALSE)
+  }
+
   estimate <- data$estimate %||% NA
   estimand <- data$estimand %||% NA
   p.value <- data$p.value %||% NA
@@ -239,7 +270,8 @@ default_diagnosands <- function(data, alpha = .05) {
   mean_se <- mean(std.error)
   type_s_rate <- mean((sign(estimate) != sign(estimand))[p.value < alpha])
   mean_estimand <- mean(estimand)
-
+
+  ret <- 
   data.frame(
     diagnosand_label = c(
       "bias",
@@ -262,6 +294,13 @@ default_diagnosands <- function(data, alpha = .05) {
       mean_se,
       type_s_rate,
       mean_estimand
-    )
+    ), 
+    stringsAsFactors = FALSE
   )
+
+  if(na.rm){
+    ret <- rbind_disjoint(list(ret, na_ret))
+  }
+
+  ret
 }

tests/testthat/test-bootstrap-diagnosands.R

@@ -30,8 +30,7 @@ test_that("test diagnosands", {
   # default set
 
   diagnosis <- diagnose_design(my_design, sims = 2, bootstrap_sims = 2)
-
-  expect_equal(dim(diagnosis$diagnosands_df), c(2, 23))
+  expect_equal(dim(diagnosis$diagnosands_df), c(2,25))
 
   expect_equal(dim(diagnosis$simulations_df), c(4, 14))
 })

tests/testthat/test-diagnosands.R

@@ -90,7 +90,8 @@ test_that("test diagnosands without estimands", {
   diagnosis <- diagnose_design(my_design2, sims = 2, diagnosands = my_dig, bootstrap_sims = FALSE)
 
 
-  expect_equal(dim(diagnosis$diagnosands_df), c(1, 6))
+  expect_equal(dim(diagnosis$diagnosands_df), c(1,7))
+
 })
 
 
@@ -158,17 +159,30 @@ test_that("diagnosis, no estimator", {
     declare_estimand(foo = 2, bar = 3)
 
   diagnosand <- declare_diagnosands(z = mean(estimand > 0), keep_defaults = FALSE)
-
+
+
   expect_equivalent(
-    diagnose_design(d, diagnosands = diagnosand, sims = 5, bootstrap_sims = 5)$diagnosands_df,
-    structure(list(
-      design_label = structure(c(1L, 1L), .Label = "d", class = "factor"),
-      estimand_label = c("bar", "foo"), z = c(1, 1), `se(z)` = c(
-        0,
-        0
-      ), n_sims = c(5L, 5L)
-    ), row.names = c(NA, -2L), class = "data.frame")
-  )
+    diagnose_design(
+      d,
+      diagnosands = diagnosand,
+      sims = 5,
+      bootstrap_sims = 5
+    )$diagnosands_df,
+    structure(
+      list(
+        design_label = structure(c(1L, 1L), .Label = "d", class = "factor"),
+        estimand_label = c("bar", "foo"),
+        z = c(1, 1),
+        `se(z)` = c(0,
+                    0),
+        n_deleted = c(0, 0),
+        `se(n_deleted)` = c(0, 0),
+        n_sims = c(5L,
+                   5L)
+      ),
+      class = "data.frame",
+      row.names = c(NA,-2L)
+    ))
 })
 
 test_that("Overriding join conditions", {
@@ -210,41 +224,39 @@ test_that("Overriding join conditions", {
 test_that("diagnosis, NAs if no estimand", {
   ols <- declare_estimator(extra ~ group)
   d <- declare_population(sleep) + ols
-
-  sleep_ols <- structure(list(
-    design_label = structure(1L, .Label = "d", class = "factor"),
-    estimator_label = "estimator", term = "group2",
-    bias = NA_real_, `se(bias)` = NA_real_, rmse = NA_real_,
-    `se(rmse)` = NA_real_, power = 0, `se(power)` = 0, coverage = NA_real_,
-    `se(coverage)` = NA_real_, mean_estimate = 1.58, `se(mean_estimate)` = 0,
-    sd_estimate = 0, `se(sd_estimate)` = 0, mean_se = 0.849091017238762,
-    `se(mean_se)` = 0, type_s_rate = NaN, `se(type_s_rate)` = NA_real_,
-    mean_estimand = NA_real_, `se(mean_estimand)` = NA_real_,
-    n_sims = 4L
-  ), row.names = c(NA, -1L), class = "data.frame")
-
-  expect_equivalent(diagnose_design(d, sims = 4, bootstrap_sims = 5)$diagnosands_df, sleep_ols)
+
+  sleep_ols <-
+    structure(list(design_label = structure(1L, .Label = "d", class = "factor"), 
+                   estimator_label = "estimator", term = "group2", bias = NA_real_, 
+                   `se(bias)` = NA_real_, rmse = NA_real_, `se(rmse)` = NA_real_, 
+                   power = 0, `se(power)` = 0, coverage = NA_real_, `se(coverage)` = NA_real_, 
+                   mean_estimate = 1.58, `se(mean_estimate)` = 0, sd_estimate = 0, 
+                   `se(sd_estimate)` = 0, mean_se = 0.849091017238762, `se(mean_se)` = 0, 
+                   type_s_rate = NaN, `se(type_s_rate)` = NA_real_, mean_estimand = NA_real_, 
+                   `se(mean_estimand)` = NA_real_, n_deleted = 0, `se(n_deleted)` = 0, 
+                   n_sims = 4L), class = "data.frame", row.names = c(NA, -1L
+                   ))
+
+expect_equivalent(diagnose_design(d, sims = 4, bootstrap_sims = 5)$diagnosands_df, sleep_ols)
+
+
 })
 
 test_that("diagnosis, NAs if no estimand", {
   mu <- declare_estimand(mean(extra))
   d <- declare_population(sleep) + mu
-
-  sleep_ols <- structure(list(
-    design_label = structure(1L, .Label = "d", class = "factor"),
-    estimand_label = "estimand", bias = NA_real_, `se(bias)` = NA_real_,
-    rmse = NA_real_, `se(rmse)` = NA_real_, power = NA_real_,
-    `se(power)` = NA_real_, coverage = NA_real_, `se(coverage)` = NA_real_,
-    mean_estimate = NA_real_, `se(mean_estimate)` = NA_real_,
-    sd_estimate = NA_real_, `se(sd_estimate)` = NA_real_, mean_se = NA_real_,
-    `se(mean_se)` = NA_real_, type_s_rate = NA_real_, `se(type_s_rate)` = NA_real_,
-    mean_estimand = 1.54, `se(mean_estimand)` = 0, n_sims = 4L
-  ), row.names = c(
-    NA,
-    -1L
-  ), class = "data.frame")
-
-  expect_equivalent(diagnose_design(d, sims = 4)$diagnosands_df, sleep_ols)
+
+  sleep_ols <- structure(list(design_label = structure(1L, .Label = "d", class = "factor"), 
+                                    estimand_label = "estimand", bias = NA_real_, `se(bias)` = NA_real_, 
+                                    rmse = NA_real_, `se(rmse)` = NA_real_, power = NA_real_, 
+                                    `se(power)` = NA_real_, coverage = NA_real_, `se(coverage)` = NA_real_, 
+                                    mean_estimate = NA_real_, `se(mean_estimate)` = NA_real_, 
+                                    sd_estimate = NA_real_, `se(sd_estimate)` = NA_real_, mean_se = NA_real_, 
+                                    `se(mean_se)` = NA_real_, type_s_rate = NA_real_, `se(type_s_rate)` = NA_real_, 
+                                    mean_estimand = 1.54, `se(mean_estimand)` = 0, n_deleted = 0, 
+                                    `se(n_deleted)` = 0, n_sims = 4L), class = "data.frame", row.names = c(NA, 
+                                                                                                           -1L))
+    expect_equivalent(diagnose_design(d, sims = 4)$diagnosands_df, sleep_ols)
 })
 
 test_that("error if diagnosand not named", {
@@ -258,24 +270,23 @@ test_that("select, subtract, add diagnosands", {
   my_diags <- declare_diagnosands(new_diag = mean(estimate - estimand))
   dx <- diagnose_design(my_design, diagnosands = my_diags, sims = 4, bootstrap_sims = FALSE)
 
-  expect_true(all(dx$diagnosand_names %in% c(
-    "new_diag", "bias", "rmse", "power", "coverage", "mean_estimate",
-    "sd_estimate", "mean_se", "type_s_rate", "mean_estimand"
-  )))
-
+
+  expect_true(all(dx$diagnosand_names %in% c("new_diag", "bias", "rmse", "power", "coverage", "mean_estimate", 
+                                 "sd_estimate", "mean_se", "type_s_rate", "mean_estimand", "n_deleted")))
+
   # add a diagnosand, dont keep
   my_diags <- declare_diagnosands(new_diag = mean(estimate - estimand), keep_defaults = FALSE)
   dx <- diagnose_design(my_design, diagnosands = my_diags, sims = 4, bootstrap_sims = FALSE)
-  expect_true(all(dx$diagnosand_names %in% c("new_diag")))
-
+  expect_true(all(dx$diagnosand_names %in% c("new_diag", "n_deleted")))
+  
   # select
   my_diags <- declare_diagnosands(select = bias, keep_defaults = TRUE)
   dx <- diagnose_design(my_design, diagnosands = my_diags, sims = 4, bootstrap_sims = FALSE)
-  expect_true(all(dx$diagnosand_names %in% c("bias")))
-
+  expect_true(all(dx$diagnosand_names %in% c("bias", "n_deleted")))
+  
   my_diags <- declare_diagnosands(select = c(bias, rmse))
   dx <- diagnose_design(my_design, diagnosands = my_diags, sims = 4, bootstrap_sims = FALSE)
-  expect_true(all(dx$diagnosand_names %in% c("bias", "rmse")))
+  expect_true(all(dx$diagnosand_names %in% c("bias", "rmse", "n_deleted")))
 
 
   # subtract
@@ -316,3 +327,53 @@ test_that("declare time errors", {
   )
   expect_error(declare_diagnosands(keep_defaults = FALSE), "No diagnosands were declared.")
 })
+
+
+test_that("missingness",{
+
+  my_population <- declare_population(N = 50, noise = rnorm(N))
+  fixed_pop <-  my_population()
+  my_pop <- declare_population(fixed_pop)
+
+  my_odd_estimator <- function(data) {
+    estimate = rnorm(1)
+    if(estimate > 0){
+      estimate <- NA
+    }
+    data.frame(estimate = estimate)
+  }
+  # my_odd_estimator(my_pop)
+  estimator <- declare_estimator(handler = my_odd_estimator)
+  des <- my_pop + estimator
+
+  dx <- diagnose_design(des, sims = 50, bootstrap_sims = FALSE)
+  expect_equal(
+    names(dx$diagnosands_df),
+    c(
+      "design_label",
+      "bias",
+      "rmse",
+      "power",
+      "coverage",
+      "mean_estimate",
+      "sd_estimate",
+      "mean_se",
+      "type_s_rate",
+      "mean_estimand",
+      "n_deleted",
+      "n_sims"
+    )
+  )
+
+  diags <- declare_diagnosands(select = c(mean_estimate), na.rm = TRUE)
+  dx <- diagnose_design(des, sims = 50, diagnosands = diags, bootstrap_sims = FALSE)
+  expect_equal(names(dx$diagnosands_df), c("design_label", "mean_estimate", "n_deleted", "n_sims"))
+
+  diags <- declare_diagnosands(select = c(mean_estimate), na.rm = FALSE)
+  dx <- diagnose_design(des, sims = 50, diagnosands = diags, bootstrap_sims = FALSE)
+  expect_equal(names(dx$diagnosands_df), c("design_label", "mean_estimate", "n_sims"))
+
+
+})
+
+