Merge pull request #5 from WorldHealthOrganization/month60

Add the ability to analyze observations with age = 60 months

.github/workflows/R-CMD-check.yaml

@@ -2,9 +2,9 @@
 # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help
 on:
   push:
-    branches: [main, master]
+    branches: [main]
   pull_request:
-    branches: [main, master]
+    branches: [main]
 
 name: R-CMD-check
 
@@ -29,18 +29,15 @@ jobs:
       R_KEEP_PKG_SOURCE: yes
 
     steps:
-      - uses: actions/checkout@v2
-
-      - uses: r-lib/actions/setup-pandoc@v1
-
-      - uses: r-lib/actions/setup-r@v1
+      - uses: actions/checkout@v4
+      - uses: r-lib/actions/setup-pandoc@v2
+      - uses: r-lib/actions/setup-r@v2
         with:
           r-version: ${{ matrix.config.r }}
           http-user-agent: ${{ matrix.config.http-user-agent }}
           use-public-rspm: true
-
-      - uses: r-lib/actions/setup-r-dependencies@v1
+      - uses: r-lib/actions/setup-r-dependencies@v2
         with:
-          extra-packages: rcmdcheck
-
-      - uses: r-lib/actions/check-r-package@v1
+          extra-packages: any::rcmdcheck
+          needs: check
+      - uses: r-lib/actions/check-r-package@v2

DESCRIPTION

@@ -18,7 +18,7 @@ Description: Provides WHO 2007 References for School-age Children and
 License: GPL (>= 3)
 Encoding: UTF-8
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.1.2
+RoxygenNote: 7.3.2
 Depends: 
     R (>= 3.5.0)
 Imports:

NEWS.md

@@ -1,5 +1,8 @@
 # anthroplus (development version)
 
+* The package now supports observations with age >= 60 months. Previously there
+  was a cutoff at 61 months excluding observations with 60 months.
+
 # anthroplus 0.9.0
 
 * Initial release

R/prevalence.R

@@ -20,7 +20,7 @@
 #' If not all parameter values have equal length, parameter values will be
 #' repeated to match the maximum length.
 #'
-#' Only cases with age_in_months between 61 (including) and 228 months
+#' Only cases with age_in_months between 60 (including) and 228 months
 #' (including) are used for the analysis. The rest will be ignored.
 #'
 #' @inheritParams anthroplus_zscores
@@ -88,7 +88,7 @@
 #'
 #' Note that weight-for-age results are NA for the groups "All" and the two
 #' "Sex" groups, as the indicator is only defined for age in months
-#' between 61 and 120.
+#' between 60 and 120.
 #'
 #' @examples
 #' set.seed(1)
@@ -132,18 +132,18 @@ anthroplus_prevalence <- function(sex,
   }
   old_rows <- nrow(input)
   input <- input[!is.na(input$age_in_months) &
-    input$age_in_months >= 61 &
+    input$age_in_months >= 60 &
     input$age_in_months <= 228, , drop = FALSE]
   if (nrow(input) == 0) {
     stop(
-      "All age values are either NA or < 61 or > 228, which excludes all",
+      "All age values are either NA or < 60 or > 228, which excludes all",
       " cases from the analysis.",
       call. = FALSE
     )
   } else if (nrow(input) < old_rows) {
     warning(
       old_rows - nrow(input),
-      " row(s) with age NA or age < 61 months or > 228 months were excluded",
+      " row(s) with age NA or age < 60 months or > 228 months were excluded",
       " from the computation."
     )
   }
@@ -246,8 +246,8 @@ cbind_year_month_columns <- function(prev_results) {
       "Total (15-19)", "Total (15-19)" # female/male 3
     ),
     `Months` = c(
-      "(61-228)",
-      "(61-228)", "(61-228)",
+      "(60-228)",
+      "(60-228)", "(60-228)",
       paste0("(", gsub(" mo", "", prev_age_group_labels, fixed = TRUE), ")"),
       wider_labels,
       c(wider_labels[1], wider_labels[1]),
@@ -265,7 +265,7 @@ cbind_year_month_columns <- function(prev_results) {
 }
 
 prev_age_group_labels <- c(
-  "61-71 mo",
+  "60-71 mo",
   "72-83 mo",
   "84-95 mo",
   "96-107 mo",
@@ -281,10 +281,11 @@ prev_age_group_labels <- c(
   "216-227 mo",
   "228-228 mo"
 )
+
 prev_age_groups <- function(age_in_months) {
   stopifnot(is.numeric(age_in_months), all(age_in_months <= 228, na.rm = TRUE))
   cut_breaks <- c(
-    61, 72, 84, 96, 108, 120, 132,
+    60, 72, 84, 96, 108, 120, 132,
     144, 156, 168, 180, 192, 204, 216, 228, 229
   )
   cut(age_in_months,
@@ -295,13 +296,14 @@ prev_age_groups <- function(age_in_months) {
 }
 
 prev_wider_age_group_labels <- c(
-  "61-119 mo",
+  "60-119 mo",
   "120-179 mo",
   "180-228 mo"
 )
+
 prev_wider_age_groups <- function(age_in_months) {
   stopifnot(is.numeric(age_in_months), all(age_in_months <= 228, na.rm = TRUE))
-  cut_breaks <- c(61, 120, 180, 229)
+  cut_breaks <- c(60, 120, 180, 229)
   cut(age_in_months,
     breaks = cut_breaks,
     labels = prev_wider_age_group_labels,

R/zscores.R

@@ -30,9 +30,9 @@
 #' @details
 #' The following age cutoffs are used:
 #' \itemize{
-#' \item{Height-for-age} age between 61 and 228 months inclusive
-#' \item{Weight-for-age} age between 61 and 120 months inclusive
-#' \item{BMI-for-age} age between 61 and 228 months inclusive
+#' \item{Height-for-age} age between 60 and 228 months inclusive
+#' \item{Weight-for-age} age between 60 and 120 months inclusive
+#' \item{BMI-for-age} age between 60 and 228 months inclusive
 #' }
 #'
 #' @return A data.frame with three types of columns. Columns starting with a
@@ -215,7 +215,7 @@ zscore_indicator <- function(sex,
   }
   zscores <- zscore_fun(measure, m, l, s)
   has_invalid_valid_age <- is.na(age_in_months) |
-    !(age_in_months >= 61 & age_in_months <= age_upper_bound)
+    !(age_in_months >= 60 & age_in_months <= age_upper_bound)
   zscores[has_invalid_valid_age] <- NA_real_
   zscores
 }

data-raw/growthstandards/bfawho2007.txt

@@ -1,4 +1,5 @@
 sex	age	l	m	s
+1	60	-0.7151	15.2679	0.08366
 1	61	-0.7387	15.2641	0.08390
 1	62	-0.7621	15.2616	0.08414
 1	63	-0.7856	15.2604	0.08439
@@ -168,6 +169,7 @@ sex	age	l	m	s
 1	227	-0.8578	22.1514	0.12939
 1	228	-0.8419	22.1883	0.12948
 1	229	-0.8419	22.1883	0.12948
+2	60	-0.8702	15.2453	0.09646
 2	61	-0.8886	15.2441	0.09692
 2	62	-0.9068	15.2434	0.09738
 2	63	-0.9248	15.2433	0.09783

data-raw/growthstandards/hfawho2007.txt

@@ -1,4 +1,5 @@
 sex	age	l	m	s
+1	60	1	109.7265	0.04156
 1	61	1	110.2647	0.04164
 1	62	1	110.8006	0.04172
 1	63	1	111.3338	0.04180
@@ -168,6 +169,7 @@ sex	age	l	m	s
 1	227	1	176.5211	0.04142
 1	228	1	176.5432	0.04134
 1	229	1	176.5432	0.04134
+2	60	1	109.0725	0.04346
 2	61	1	109.6016	0.04355
 2	62	1	110.1258	0.04364
 2	63	1	110.6451	0.04373

data-raw/growthstandards/package.R

@@ -2,7 +2,7 @@ check_df <- function(df) {
   stopifnot(all(colnames(df) == c("sex", "age", "l", "m", "s")))
   stopifnot(all(apply(df, 2, is.numeric)))
   stopifnot(all(df[["sex"]] %in% c(1, 2)))
-  stopifnot(all(df[["age"]] > 60))
+  stopifnot(all(df[["age"]] >= 60))
 }
 
 bfa_growth_standards <- read.csv("data-raw/growthstandards/bfawho2007.txt", sep = "\t")

data-raw/growthstandards/wfawho2007.txt

@@ -1,4 +1,5 @@
 sex	age	l	m	s
+1	60	-0.1922	18.3328	0.12947
 1	61	-0.2026	18.5057	0.12988
 1	62	-0.2130	18.6802	0.13028
 1	63	-0.2234	18.8563	0.13067
@@ -60,6 +61,7 @@ sex	age	l	m	s
 1	119	-0.6752	30.8854	0.16213
 1	120	-0.6764	31.1586	0.16305
 1	121	-0.6764	31.1586	0.16305
+2	60	-0.4650	18.0823	0.14240
 2	61	-0.4681	18.2579	0.14295
 2	62	-0.4711	18.4329	0.14350
 2	63	-0.4742	18.6073	0.14404

tests/testthat/test-prevalence.R

@@ -32,10 +32,10 @@ test_that("strata are considered correctly", {
   check_with_survey(input, strata = strata)
 })
 
-test_that("age only between 61 and 229 is considered", {
+test_that("age only between 60 and 229 is considered", {
   input <- readRDS("test_dataset_who2007.rds")
   input$agemons <- input$agemons * 2
-  input_filtered <- input[input$agemons >= 61 & input$agemons <= 228, ]
+  input_filtered <- input[input$agemons >= 60 & input$agemons <= 228, ]
   expect_warning(
     res1 <- anthroplus_prevalence(
       input$sex,
@@ -88,7 +88,7 @@ test_that("it fails if all values are filtered out", {
   expect_error(
     anthroplus_prevalence(
       1,
-      60,
+      59,
       "n",
       100,
       35,
@@ -212,3 +212,8 @@ test_that("age in months = 228 is part of the age group", {
   expect_false(is.na(prev_wider_age_groups(228)))
   expect_false(is.na(prev_age_groups(228)))
 })
+
+test_that("age in months = 60 is part of the age group", {
+  expect_false(is.na(prev_wider_age_groups(60)))
+  expect_false(is.na(prev_age_groups(60)))
+})

tests/testthat/test-zscores.R

@@ -24,6 +24,21 @@ test_that("zscore references match from previous implementation", {
   expect_equal(result$age_in_months, data$agemons)
 })
 
+test_that("computes correct value for age ~ 60 months", {
+  res <- anthroplus_zscores(
+    sex = c(2, 2),
+    age_in_months = c(60.32, 60.911701),
+    height_in_cm = c(113.8, 113.6),
+    weight_in_kg = c(18.7, 20.5)
+  )
+  expect_equal(res$zwfa, c(0.21, 0.79))
+  expect_equal(res$fwfa, c(0, 0))
+  expect_equal(res$zbfa, c(-0.58, 0.42))
+  expect_equal(res$fbfa, c(0, 0))
+  expect_equal(res$zhfa, c(0.96, 0.85))
+  expect_equal(res$fhfa, c(0, 0))
+})
+
 test_that("different sex encodings work", {
   expect_equal(
     anthroplus_zscores(1, 120, height_in_cm = 60, weight_in_kg = 30),
@@ -104,7 +119,7 @@ test_that("oedema = y implies NA for weight-for-age and bmi-for-age", {
   expect_false(is.na(res2$fbfa))
 })
 
-test_that("Age upper bounds are inclusive", {
+test_that("age upper bounds are inclusive", {
   res <- anthroplus_zscores(
     1, c(120, 228, 120.1, 228.1),
     height_in_cm = 60,
@@ -114,3 +129,28 @@ test_that("Age upper bounds are inclusive", {
   expect_equal(is.na(res$zwfa), c(FALSE, TRUE, TRUE, TRUE))
   expect_equal(is.na(res$zbfa), c(FALSE, FALSE, FALSE, TRUE))
 })
+
+test_that("age >= 60 months is supported", {
+  res <- anthroplus_zscores(
+    1, 60,
+    height_in_cm = 60,
+    weight_in_kg = 30
+  )
+  expect_false(is.na(res$zhfa))
+  expect_false(is.na(res$zwfa))
+  expect_false(is.na(res$zbfa))
+})
+
+test_that("age < 60 months results in all NA scores and flags", {
+  res <- anthroplus_zscores(
+    1, 59,
+    height_in_cm = 60,
+    weight_in_kg = 30
+  )
+  expect_true(is.na(res$zhfa))
+  expect_true(is.na(res$zwfa))
+  expect_true(is.na(res$zbfa))
+  expect_true(is.na(res$fhfa))
+  expect_true(is.na(res$fwfa))
+  expect_true(is.na(res$fbfa))
+})