From 727e64f013c69f966ca7c902211c9d06492ed16b Mon Sep 17 00:00:00 2001
From: Dirk Schumacher <mail@dirk-schumacher.net>
Date: Fri, 7 Feb 2025 11:11:41 +0100
Subject: [PATCH 1/2] Use fixed extreme case CIs in prevalence calculations

---
 NAMESPACE                        |  2 --
 R/prevalence-simple.R            |  2 +-
 R/prevalence-survey.R            | 15 ++++++++++++---
 anthro.Rproj                     |  1 +
 tests/testthat/test-prevalence.R | 16 ++++++++++++++++
 5 files changed, 30 insertions(+), 6 deletions(-)

diff --git a/NAMESPACE b/NAMESPACE
index d004407..968146d 100644
--- a/NAMESPACE
+++ b/NAMESPACE
@@ -20,10 +20,8 @@ export(anthro_zscores)
 importFrom(stats,aggregate)
 importFrom(stats,as.formula)
 importFrom(stats,confint)
-importFrom(stats,glm)
 importFrom(stats,plogis)
 importFrom(stats,qt)
-importFrom(stats,quasibinomial)
 importFrom(stats,sd)
 importFrom(stats,setNames)
 importFrom(survey,degf)
diff --git a/R/prevalence-simple.R b/R/prevalence-simple.R
index b97b323..dad571a 100644
--- a/R/prevalence-simple.R
+++ b/R/prevalence-simple.R
@@ -101,7 +101,7 @@ compute_and_aggregate <- function(
   data
 }
 
-#' @importFrom stats glm plogis qt quasibinomial
+#' @importFrom stats plogis qt
 logit_rate_estimate <- function(x, N, empty_data_prototype) {
   x <- x[!is.na(x)]
   if (length(x) == 0) {
diff --git a/R/prevalence-survey.R b/R/prevalence-survey.R
index eced62a..97788fd 100644
--- a/R/prevalence-survey.R
+++ b/R/prevalence-survey.R
@@ -65,7 +65,6 @@ compute_prevalence_zscore_summaries_by.survey_design <- function(
   )
 }
 
-
 #' @export
 compute_prevalence_sample_size_by.survey_design <- function(
     data, indicator, subset_col_name) {
@@ -104,7 +103,6 @@ compute_prevalence_sample_size_by.survey_design <- function(
   )
 }
 
-
 #' @export
 compute_prevalence_estimates_for_column_by.survey_design <- function(
     data, indicator_name, subset_col_name, prev_col_name) {
@@ -131,7 +129,7 @@ compute_prevalence_estimates_for_column_by.survey_design <- function(
     na.rm.all = TRUE,
     level = 1 - prevalence_significance_level
   )[, 3L:4L]
-  data.frame(
+  res <- data.frame(
     Group = as.character(mean_est_prev[[subset_col_name]]),
     r = mean_est_prev[[prev_col_name]] * 100,
     se = survey::SE(mean_est_prev) * 100,
@@ -139,4 +137,15 @@ compute_prevalence_estimates_for_column_by.survey_design <- function(
     ul = mean_est_ci_prev$ci_u * 100,
     stringsAsFactors = FALSE
   )
+  # For the extreme cases of `r = 0` and `r = 1` we set the CIs
+  # to [0,0] and [1,1] respectively. Mostly for the convenience
+  # of the human user who consumes the prevalence estimates and to be
+  # in line with the method of the `simple` computation.
+  boundary_0 <- res$r == 0
+  boundary_1 <- res$r == 1
+  res$ll[boundary_0] <- 0
+  res$ul[boundary_0] <- 0
+  res$ll[boundary_1] <- 1
+  res$ul[boundary_1] <- 1
+  res
 }
diff --git a/anthro.Rproj b/anthro.Rproj
index 4a22320..e66015b 100644
--- a/anthro.Rproj
+++ b/anthro.Rproj
@@ -1,4 +1,5 @@
 Version: 1.0
+ProjectId: 16901b22-6b7e-4e48-b8f9-c12418c40896
 
 RestoreWorkspace: No
 SaveWorkspace: No
diff --git a/tests/testthat/test-prevalence.R b/tests/testthat/test-prevalence.R
index c5a1d2b..d9f7b8f 100644
--- a/tests/testthat/test-prevalence.R
+++ b/tests/testthat/test-prevalence.R
@@ -362,6 +362,22 @@ test_that("Cluster/strata/sw information is passed correctly to survey", {
   expect_equal(
     observed$HAZ_unwpop, as.numeric(expected_total_unweighted[2])
   )
+
+  # we also enforce that the cis
+  HA_2_WH_2_r_se_0 <- res$HA_2_WH_2_r == 0 & res$HA_2_WH_2_se == 0
+  expect_true(
+    all(res$HA_2_WH_2_ll[HA_2_WH_2_r_se_0] == 0, na.rm = TRUE)
+  )
+  expect_true(
+    all(res$HA_2_WH_2_ul[HA_2_WH_2_r_se_0] == 0, na.rm = TRUE)
+  )
+  WH_3_r_se_0 <- res$WH_3_r == 0 & res$WH_3_se == 0
+  expect_true(
+    all(res$WH_3_ll[WH_3_r_se_0] == 0, na.rm = TRUE)
+  )
+  expect_true(
+    all(res$WH_3_ul[WH_3_r_se_0] == 0, na.rm = TRUE)
+  )
 })
 
 test_that("pop/unwpop are 0 if no values in that group", {

From ab16995be899f144faae2e25a08cea9ab636ad7f Mon Sep 17 00:00:00 2001
From: Dirk Schumacher <mail@consulting.dirk-schumacher.net>
Date: Tue, 27 Jan 2026 10:04:22 +0100
Subject: [PATCH 2/2] Fix formatting

---
 tests/testthat/test-prevalence-simple-estimates.R | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/tests/testthat/test-prevalence-simple-estimates.R b/tests/testthat/test-prevalence-simple-estimates.R
index 1a53d16..e4137c9 100644
--- a/tests/testthat/test-prevalence-simple-estimates.R
+++ b/tests/testthat/test-prevalence-simple-estimates.R
@@ -69,7 +69,7 @@ test_that("survey and approximation with sw results are equal within tolerance",
 
 test_that("sw > 0 is approximated correctly within tolerance", {
   res <- anthro_prevalence(
-    sex = c(1,2,1),
+    sex = c(1, 2, 1),
     age = c(50, 50, NA_real_),
     is_age_in_month = TRUE,
     weight = 80,