refactor estimators and create tests for boot_bw; fix #32; fix #36

DESCRIPTION

@@ -22,6 +22,7 @@ License: GPL-3
 Depends: R (>= 3.0.1)
 Imports: 
     car,
+    cli,
     doParallel,
     foreach,
     parallel,

NAMESPACE

@@ -12,6 +12,9 @@ export(boot_bw_weight)
 export(recode)
 importFrom(car,bcPower)
 importFrom(car,powerTransform)
+importFrom(cli,cli_abort)
+importFrom(cli,cli_alert_success)
+importFrom(cli,cli_bullets)
 importFrom(doParallel,registerDoParallel)
 importFrom(foreach,"%dopar%")
 importFrom(foreach,foreach)

R/bbw.R

@@ -66,6 +66,7 @@
 #' @importFrom parallel makeCluster
 #' @importFrom foreach foreach %dopar%
 #' @importFrom doParallel registerDoParallel
+#' @importFrom cli cli_abort cli_bullets cli_alert_success
 #'
 "_PACKAGE"
 

R/bootClassic.R

@@ -12,16 +12,29 @@
 #'
 #' @examples
 #' # Example call to bootClassic function
-#'
-#' meanResults <- bootClassic(x = indicatorsHH, params = "anc1")
+#' sampled_clusters <- boot_bw_sample_clusters(
+#'   x = indicatorsHH, w = boot_bw_weight(villageData)
+#' )
+#' 
+#' boot <- boot_bw_sample_within_clusters(sampled_clusters)
+#' 
+#' bootClassic(boot, "anc1")
 #'
 #' @export
 #'
 
 bootClassic <- function(x, params) {
+  ## Check params ----
+  params <- check_params(x = x, params = params)
+
+  ## Create concatenating vector ----
   result <- vector(mode = "numeric", length = length(params))
+
+  ## Apply mean to each param ----
   for(i in seq_len(length(params))) {
     result[i]  <- mean(x[[params[i]]], na.rm = TRUE)
   }
-  return(result)
+
+  ## Return result ----
+  result
 }

R/bootProbit.R

@@ -1,5 +1,4 @@
-################################################################################
-#
+#' 
 #' PROBIT statistics function for bootstrap estimation
 #'
 #' @param x A data frame with **primary sampling unit (PSU)** in column named
@@ -14,39 +13,45 @@
 #'   of interest with length equal to `length(params)`
 #'
 #' @examples
-#'
 #' # Example call to bootBW function:
-#'
-#' bootPROBIT(x = indicatorsCH1,
+#' sampled_clusters <- boot_bw_sample_clusters(
+#'   x = indicatorsCH1, w = boot_bw_weight(villageData)
+#' )
+#' 
+#' boot <- boot_bw_sample_within_clusters(sampled_clusters)
+#' 
+#' bootPROBIT(x = boot,
 #'            params = "muac1",
 #'            threshold = 115)
 #'
 #' @export
 #'
-#
-################################################################################
 
 bootPROBIT <- function(x, params, threshold = THRESHOLD) {
+  ## Check params ----
+  params <- check_params(x = x, params = params)
+
   ## Get data
   d <- x[[params[1]]]
 
-  ## Shift data to the left to avoid "commutation instability" when :
+  ## Shift data to the left to avoid "commutation instability" when : ----
   ##   max(x) / min(x)
   ## is small (i.e. close to unity).
   shift <- min(min(d, na.rm = TRUE), threshold) - 1
   d <- d - shift
   threshold <- threshold - shift
 
-  ## Box-cox transformation
+  ## Box-cox transformation ----
   lambda <- car::powerTransform(d)$lambda
   d <- car::bcPower(d, lambda)
   threshold <- car::bcPower(threshold, lambda)
   m <- mean(d, na.rm = TRUE)
   s <- stats::sd(d, na.rm = T)
 
-  ## PROBIT estimate
+  ## PROBIT estimate ----
   x <- stats::pnorm(q = threshold, mean = m, sd = s)
+  names(x) <- NULL
 
-  ## Return x
-  return(x)
+  ## Return x ----
+  x
 }

R/utils.R

@@ -0,0 +1,62 @@
+#'
+#' Check variables
+#' 
+#' @keywords internal
+#' 
+
+check_params <- function(x, params) {
+  params_in <- params[which(params %in% names(x))]
+  params_out <- params[which(!params %in% names(x))]
+
+  if (length(params_in) == 0) {
+    if (length(params) > 1) {
+      cli::cli_abort(
+        "{.val {params}} are not variables in {.arg x}"
+      )
+    } else {
+      cli::cli_abort(
+        "{.val {params}} is not a variable in {.arg x}"
+      )
+    }
+  } else {
+    if (length(params_in) == length(params)) {
+      if (length(params) == 1) {
+        cli::cli_alert_success(
+          "{.val {params}} is a variable in {.arg x}"
+        )
+      } else {
+        cli::cli_alert_success(
+          "{.val {params}} are variables in {.arg x}"
+        )
+      }
+    } else {
+      if (length(params_in) == 1) {
+        cli::cli_bullets(
+          c(
+            "v" = "{.val {params_in}} is a variable in {.arg x}",
+            "!" = ifelse(
+              length(params_out) > 1,
+              "{.val {params_out}} are not variables in {.arg x}",
+              "{.val {params_out}} is not a variable in {.arg x}"
+            ),
+            "i" = "Returning {.val {params_in}}"
+          )
+        )
+      } else {
+        cli::cli_bullets(
+          c(
+            "v" = "{.val {params_in}} are variables in {.arg x}",
+            "!" = ifelse(
+              length(params_out) > 1,
+              "{.val {params_out}} are not variables in {.arg x}",
+              "{.val {params_out}} is not a variable in {.arg x}"
+            ),
+            "i" = "Returning {.val {params_in}}"
+          )
+        )
+      }
+    }
+  }
+
+  params_in
+}

inst/WORDLIST

@@ -15,6 +15,7 @@ PSU
 PSUs
 RapidSurveys
 Ruel
+codecov
 doi
 ncol
 nrow

tests/testthat/test-boot_bw.R

@@ -0,0 +1,27 @@
+# Tests for boot_bw functions --------------------------------------------------
+
+test_that("boot_bw_weight works as expected", {
+  expect_s3_class(boot_bw_weight(villageData), "data.frame")
+  expect_true(
+    all(
+      c("psu", "pop", "weight", "cumWeight") %in% 
+        names(boot_bw_weight(villageData))
+    )
+  )
+  expect_type(
+    boot_bw_sample_clusters(
+      indicatorsHH, w = boot_bw_weight(villageData), index = TRUE
+    ),
+    "integer"
+  )
+})
+
+mean_boot <- boot_bw(
+  x = indicatorsHH, w = boot_bw_weight(villageData),
+  statistic = bootClassic, params = "anc1", replicates = 9
+)
+
+test_that("boot_bw works as expected", {
+  expect_s3_class(mean_boot, "data.frame")
+})
+

tests/testthat/test_bootClassic.R

@@ -1,13 +1,27 @@
-library(bbw)
-context("Bootstrap function for means/proportions")
+# Tests for bootClassic --------------------------------------------------------
 
-xMean <- bootClassic(x = indicatorsHH,
-                     params = c("anc1", "anc2", "anc3", "anc4"))
+boot <- boot_bw_sample_clusters(
+  indicatorsHH, boot_bw_weight(villageData)
+) |> 
+  boot_bw_sample_within_clusters()
+
+xMean <- bootClassic(
+  x = boot, params = c("anc1", "anc2", "anc3", "anc4")
+)
 
 test_that("xMean is a numeric vector", {
-  expect_is(xMean, "numeric")
+  expect_type(xMean, "double")
 })
 
 test_that("xMean length is length of params", {
   expect_equal(length(xMean), 4)
 })
+
+test_that("bootClassic errors and messages as expected", {
+  expect_error(bootClassic(boot, c("anc")))
+  expect_message(bootClassic(boot, c("anc", "anc1")))
+  expect_message(bootClassic(boot, c("anc", "anc1", "anc2")))
+  expect_message(bootClassic(boot, c("anc", "test", "anc1", "anc2")))
+})
+
+

tests/testthat/test_bootProbit.R

@@ -1,10 +1,17 @@
-library(bbw)
-context("Bootstrap function for PROBIT")
+# Tests for bootPROBIT ---------------------------------------------------------
 
-xProbit <- bootPROBIT(x = indicatorsCH1,
+boot <- boot_bw_sample_clusters(indicatorsCH1, boot_bw_weight(villageData)) |> 
+  boot_bw_sample_within_clusters()
+
+xProbit <- bootPROBIT(x = boot,
                       params = "muac1",
                       threshold = 115)
 
 test_that("xProbit is a numeric vector", {
   expect_is(xProbit, "numeric")
 })
+
+test_that("bootPROBIT errors and messages work as expected", {
+  expect_error(bootPROBIT(boot, "test"))
+  expect_error(bootPROBIT(boot, c("test", "not")))
+})