Add option to control removal of implausible measures

NEWS.md

@@ -1,5 +1,21 @@
 # anthro (development version)
 
+## Method
+
+* `anthro_zscores` and `anthro_prevalence` have a new `control` parameter.
+  With this parameter you can control the certain behavior of the computation.
+  With this release `remove_implausible_measures` can be used to control if
+  implausible measures are set to `NA`. See the readme for more information.
+
+  The default behavior is *not* to remove implausible measures anymore. This
+  change in default settings can result in different results compared to
+  previous versions of the package.
+
+* When `remove_implausible_measures` is `TRUE` and a child younger than 9 months
+  was measured standing, then in addition to `cmeasure` being set to `NA` now
+  also `clenhei` is set to `NA. This impacts z-score and prevalence calculations
+  based on these two values.
+
 ## Performance
 
 * For inputs with `cluster/strata = NULL` and `sw = NULL or 1` a faster

R/prevalence.R

@@ -184,7 +184,10 @@ anthro_prevalence <- function(sex,
                               gregion = NA_character_,
                               wealthq = NA_character_,
                               mothered = NA_character_,
-                              othergr = NA_character_) {
+                              othergr = NA_character_,
+                              control = list(
+                                remove_implausible_measures = FALSE
+                              )) {
   # the other variables are being checked by anthro_zscores
   assert_character_or_numeric(typeres)
   assert_character_or_numeric(gregion)
@@ -227,7 +230,8 @@ anthro_prevalence <- function(sex,
     weight = input[["weight"]],
     lenhei = input[["lenhei"]],
     measure = input[["measure"]],
-    oedema = input[["oedema"]]
+    oedema = input[["oedema"]],
+    control = control
   )
   zscores_orig <- zscores
   stopifnot(c("zlen", "zwei", "zwfl", "zbmi") %in% colnames(zscores))

R/z-score.R

@@ -83,6 +83,18 @@
 #'             BUT they are treated as being < -3 SD in the weight-related
 #'             indicator prevalence (\code{\link{anthro_prevalence}})
 #'             estimation.
+#' @param control An optional list to control the behavior of the computation.
+#' Setting `remove_implausible_measures` to `TRUE` sets implausible measures to
+#' `NA`. A measure is considered implausible if its value is `"h"` and
+#' `age_in_months < 9`. If `remove_implausible_measures` is not `TRUE` or missing,
+#' the adjustment is not applied.
+#'
+#' If `remove_implausible_measures` is `TRUE`:
+#' For children under 9 months old, height measurements recorded in a 'standing'
+#' position, rather than the expected 'lying' position, are excluded from the
+#' analysis. In these instances,
+#' the \code{cmeasure} and \code{clenhei} variables are set to missing since this
+#' is deemed to be an error.
 #'
 #'
 #' @return A data.frame with three types of columns. Columns starting with a
@@ -167,7 +179,10 @@ anthro_zscores <- function(sex,
                            armc = NA_real_,
                            triskin = NA_real_,
                            subskin = NA_real_,
-                           oedema = "n") {
+                           oedema = "n",
+                           control = list(
+                             remove_implausible_measures = FALSE
+                           )) {
   assert_logical(is_age_in_month)
   assert_length(is_age_in_month, 1L)
   assert_character_or_numeric(sex)
@@ -190,6 +205,12 @@ anthro_zscores <- function(sex,
     allowed = c("n", "y", "N", "Y", "2", "1", NA_character_)
   )
 
+  # extract control options
+  if (!is.list(control)) {
+    control <- list()
+  }
+  remove_implausible_measures <- isTRUE(control[["remove_implausible_measures"]])
+
   # make all input lengths equal
   max_len <- pmax(
     length(sex),
@@ -227,15 +248,22 @@ anthro_zscores <- function(sex,
   age_in_days <- age_to_days(age, is_age_in_month = is_age_in_month)
   age_in_months <- age_to_months(age, is_age_in_month = is_age_in_month)
 
-  # we consider a height measure for children younger than 9 months as
-  # implausible
-  measure_implausible <- !is.na(cmeasure) &
-    !is.na(age_in_months) &
-    cmeasure == "h" &
-    age_in_months < 9
-  cmeasure[measure_implausible] <- NA_character_
+  # we assume everything is plausible by default
+  measure_implausible <- rep.int(FALSE, length(cmeasure))
+  if (remove_implausible_measures) {
+    # we consider a height measure for children younger than 9 months as
+    # implausible
+    measure_implausible <- !is.na(cmeasure) &
+      !is.na(age_in_months) &
+      cmeasure == "h" &
+      age_in_months < 9
+    cmeasure[measure_implausible] <- NA_character_
+  }
 
   clenhei <- adjust_lenhei(age_in_days, cmeasure, lenhei)
+  if (remove_implausible_measures) {
+    clenhei[measure_implausible] <- NA_real_
+  }
 
   cbmi <- weight / ((clenhei / 100)^2)
   cbind(

anthro.Rproj

@@ -1,4 +1,5 @@
 Version: 1.0
+ProjectId: f48ead27-57f4-40f2-998a-e1596291137c
 
 RestoreWorkspace: No
 SaveWorkspace: No

tests/testthat/test-prevalence-simple-estimates.R

@@ -37,3 +37,34 @@ test_that("zscore estimates should not overflow", {
     zscore_estimate(x, length(x), data.frame())
   )
 })
+
+test_that("prevalence is computed without measure adjustment by default", {
+  n <- 10
+  data <- data.frame(
+    sex = 1:2,
+    age = 1:10,
+    weight = 20,
+    lenhei = 80,
+    measure = "h"
+  )
+  res_default <- anthro_prevalence(
+    data$sex,
+    data$age,
+    is_age_in_month = TRUE,
+    weight = data$weight,
+    lenhei = data$lenhei,
+    measure = data$measure
+  )
+  res_no_adjustment <- anthro_prevalence(
+    data$sex,
+    data$age,
+    is_age_in_month = TRUE,
+    weight = data$weight,
+    lenhei = data$lenhei,
+    measure = data$measure,
+    control = list(
+      remove_implausible_measures = FALSE
+    )
+  )
+  expect_equal(res_default, res_no_adjustment)
+})

tests/testthat/test-zscores.R

@@ -183,10 +183,13 @@ test_that("young children with measured standing will not be adjusted", {
     sex = 1, age = c(8, 9),
     is_age_in_month = TRUE,
     lenhei = 60,
-    measure = "h"
+    measure = "h",
+    control = list(
+      remove_implausible_measures = TRUE
+    )
   )
-  expect_equal(res$clenhei, c(60, 60.7))
-  expect_equal(res$zlen, c(-4.81, -5.02), tolerance = 0.01)
+  expect_equal(res$clenhei, c(NA_real_, 60.7))
+  expect_equal(res$zlen, c(NA_real_, -5.02), tolerance = 0.01)
   expect_equal(res$cmeasure, c(NA_character_, "h"))
 })
 
@@ -241,3 +244,50 @@ test_that("clenhei takes the measure argument into account correctly", {
   expect_equal(res$clenhei, c(77.5, 77.5))
   expect_equal(res$zlen, c(-2.55, -2.55))
 })
+
+test_that("removal of implausible cmeasures can be controlled", {
+  res_default <- anthro_zscores(
+    sex = 2,
+    age = c(8, 9),
+    lenhei = 77.5,
+    weight = 8.8,
+    is_age_in_month = TRUE,
+    measure = c("h", "h")
+  )
+  res_adjustment <- anthro_zscores(
+    sex = 2,
+    age = c(8, 9),
+    lenhei = 77.5,
+    weight = 8.8,
+    is_age_in_month = TRUE,
+    measure = c("h", "h"),
+    control = list(
+      remove_implausible_measures = TRUE
+    )
+  )
+  expect_equal(res_adjustment$cmeasure, c(NA_character_, "h"))
+  expect_equal(res_default$cmeasure, c("h", "h"))
+})
+
+test_that("default behaviour is that no measurements are removed", {
+  res_default <- anthro_zscores(
+    sex = 2,
+    age = c(8, 9),
+    lenhei = 77.5,
+    weight = 8.8,
+    is_age_in_month = TRUE,
+    measure = c("h", "h")
+  )
+  res_no_adjustment <- anthro_zscores(
+    sex = 2,
+    age = c(8, 9),
+    lenhei = 77.5,
+    weight = 8.8,
+    is_age_in_month = TRUE,
+    measure = c("h", "h"),
+    control = list(
+      remove_implausible_measures = FALSE
+    )
+  )
+  expect_equal(res_default, res_no_adjustment)
+})