DEV: Implement design_effect for variable design and update tests

Also moved input checks for prevalence and correlation to generic

NAMESPACE

@@ -2,11 +2,11 @@
 
 S3method(as.character,pool_strat)
 S3method(design_effect,fixed_design)
+S3method(design_effect,variable_design)
 S3method(format,pool_strat)
 S3method(print,pool_strat)
 S3method(print,power_size_results)
 export(design_effect)
-export(design_effect_random)
 export(detection_errors)
 export(detection_errors_cluster)
 export(fi_pool)

R/design_effect.R

@@ -13,7 +13,7 @@
 #' (`design_effect(fixed_design, ...)`) or variable sample sizes 
 #' (`design_effect(variable_design, ...)`).
 #'
-#' @param x sample_design
+#' @param x a sample_design object 
 #' @param prevalence numeric The proportion of units that carry the marker of
 #'   interest (i.e. true positive). Must be be a numeric value between 0 and 1,
 #'   inclusive of both.
@@ -26,15 +26,21 @@
 #'   different clusters.
 #' @param form string The distribution used to model the cluster-level
 #'   prevalence and correlation of units within cluster. Select one of "beta",
-#'   "logitnorm" or "cloglognorm". See details.
-#' @param ... 
+#'   "logitnorm" or "cloglognorm".
+#' @param ... additional parameters
 #'
 #' @return A numeric value of the design effect `D`.
 #' @export
 #' 
 #' @examples
 #' design_effect(fixed_design(10, 2), prevalence = 0.01, correlation = 0.05)
-design_effect <- function(x, ...) {
+#' 
+#' vd <- variable_design(nb_catch(10, 13), pool_target_number(20))
+#' design_effect(vd, prevalence = 0.01, correlation = 0.05)
+design_effect <- function(x, prevalence, correlation, form, ...) {
+  check_in_range2(prevalence)
+  check_in_range2(correlation)
+  # No input check for form as done in downstream functions/methods
   UseMethod("design_effect")
 }
 
@@ -46,10 +52,6 @@ design_effect.fixed_design <- function(x,
                                        correlation,
                                        form = "beta") {
 
-  check_in_range2(prevalence)
-  check_in_range2(correlation)
-  # No input check for form as done in downstream functions/methods
-
   x$pool_number * x$pool_size * fi_pool(pool_size = 1, prevalence, x$sensitivity, x$specificity) *
     solve(fi_pool_cluster(
       x$pool_size, x$pool_number, prevalence,
@@ -58,18 +60,16 @@ design_effect.fixed_design <- function(x,
 }
 
 #' @rdname design_effect
+#' @method design_effect variable_design
 #' @export
-design_effect_random <- function(catch_dist,
-                                 pool_strat,
-                                 prevalence,
-                                 correlation,
-                                 sensitivity,
-                                 specificity,
-                                 form = "beta") {
+design_effect.variable_design <- function(x,
+                                          prevalence,
+                                          correlation,
+                                          form = "beta") {
 
-  mean(catch_dist) * fi_pool(pool_size = 1, prevalence, sensitivity, specificity) *
+  mean(x$catch_dist) * fi_pool(pool_size = 1, prevalence, x$sensitivity, x$specificity) *
     solve(fi_pool_cluster_random(
-      catch_dist, pool_strat, prevalence,
-      correlation, sensitivity, specificity, form)
+      x$catch_dist, x$pool_strat, prevalence,
+      correlation, x$sensitivity, x$specificity, form)
     )[1, 1]
 }

tests/testthat/test-design_effect.R

@@ -1,10 +1,9 @@
-# fixtures ----
+# fixed_design ----
 fd <- fixed_design(
   pool_size = 5, pool_number = 10, sensitivity = 0.99, specificity = 0.95
 )
 
-# fixed_design ----
-test_that("design_effect() gives consistent output for basic tests", {
+test_that("fixed design_effect() gives consistent output for basic tests", {
   # This one has reasonable inputs
   expect_equal(
     design_effect(fd, prevalence = 0.01, correlation = 0.05),
@@ -33,5 +32,18 @@ test_that("design_effect() fails for some very unusual parameters because integr
   )
 })
 
-### design_effect_random() ----
+### variable_design() ----
+vd_target <- variable_design(nb_catch(5, 7), pool_target_number(10))
+vd_max <- variable_design(nb_catch(5, 7), pool_max_size(10))
+
+test_that("variable design_effect()", {
+  expect_equal(
+    design_effect(vd_target, prevalence = 0.01, correlation = 0.05),
+    1.256262, tolerance = 1e-6
+  )
+  expect_equal(
+    design_effect(vd_max, prevalence = 0.01, correlation = 0.05),
+    3.726256, tolerance = 1e-6
+  )
+})
 

tests/testthat/test-sample_design.R

@@ -30,7 +30,6 @@ test_that("fixed_design bad inputs caught", {
 
 # variable_design ----
 ## fixtures ----
-
 var_target <- variable_design(
   catch_dist = nb_catch(5, 10), 
   pool_strat = pool_target_number(20)