Skip to content

Commit

Permalink
fix: Fixed unused factor level handling (for SVN categorisation, spec…
Browse files Browse the repository at this point in the history 
…ifically); added some unit tests too
  • Loading branch information
@simpar1471
simpar1471 committed Nov 11, 2024
1 parent 18762f0 commit 96beb45
Show file tree
Hide file tree
Showing 3 changed files with 185 additions and 120 deletions.
12 changes: 11 additions & 1 deletion R/growth_categorise.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -308,7 +308,16 @@ categorise_sfga_internal <- function(p, severe) {
#' @noRd
categorise_svn_internal <- function(p, gest_days) {
is_preterm <- gest_days < 259
opt_unused_levels <- gigs_option_get(option = "handle_unused_levels",
silent = TRUE)
on.exit({
gigs_option_set(option = "handle_unused_levels",
new_value = opt_unused_levels, silent = TRUE)
})
gigs_option_set("handle_unused_levels", "keep_silent", TRUE)
sfga <- categorise_sfga_internal(p, severe = FALSE)
gigs_option_set(option = "handle_unused_levels",
new_value = opt_unused_levels, silent = TRUE)
sfga_lvls <- levels(sfga)
levels <- c(paste("Preterm", sfga_lvls), paste("Term", sfga_lvls))

Expand Down Expand Up @@ -418,6 +427,7 @@ handle_factor_levels <- function(fct, outcome) {
cli::cli_abort(c("!" = "`outcome` must be one of {.val {outcome_opts}}",
"i" = "`outcome` was {.val {outcome}}."),
call = rlang::current_env(),
class = "gigs_handle_fctr_lvls_bad_outcome_str",
.internal = TRUE
)
}
Expand Down Expand Up @@ -447,8 +457,8 @@ handle_factor_levels <- function(fct, outcome) {
class = "gigs_dropping_unused_fctr_lvls"
)
}
return(fct_dropped)
}
return(fct_dropped)
}
}

Expand Down
21 changes: 19 additions & 2 deletions tests/testthat/test-conversion.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -499,10 +499,27 @@ test_that("GIGS conversion functions warn on bad `family` or `acronym`", {
}
})

test_that("Conversion fns fail correctly if (not) providing `sex`", {
for (fn_name in conv_fns) {
gigs_fn <- getFromNamespace(fn_name, ns = "gigs")
zyp <- zyp_cache[[fn_name]]

expect_error(
gigs_fn(zyp, 5, "M", "ig_fet", "hefwfga"),
class = "gigs_sex_not_null_for_ig_fet"
)

expect_error(
gigs_fn(zyp, 5, NULL, "ig_nbs", "wfga"),
class = "gigs_sex_null_for_not_ig_fet"
)
}
})

# Testing of `report_units()` --------------------------------------------------

#' @srrstats {G5.4, G5.4c} Tests ensure that `gigs` functions can be used to
#' replicate published growth charts, within a tolerance.
#' @srrstats {G5.4, G5.4c} Tests ensure that `report_units()` prints the right
#' messages.
#' @srrstats {G5.2, G5.2a, G5.2b} Explicit tests of error and warning behaviour.
test_that("The `report_units()` function works as expected", {
family <- "ig_fet"
Expand Down
272 changes: 155 additions & 117 deletions tests/testthat/test-growth_categorise.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -17,124 +17,162 @@ test_that("Size-for-GA categorisation works as expected", {
levels = c("SGA(<3)", sfga_lvls)
)

expect_equal(sfga, sfga_expected)
expect_equal(sfga_severe, sfga_severe_expected)
expect_equal(sfga, sfga_expected)
expect_equal(sfga_severe, sfga_severe_expected)
})

test_that(
desc = "SVN categorisation works as expected",
code = {
centile <- c(0.01, 0.029, 0.031, 0.09, 0.10, 0.11, 0.89, 0.91, 0.999)
gest_days <- seq(250, 290, 5)
svn <- categorise_svn(centile, gest_days = gest_days)

svn_lvls <- paste(c(rep_len("Preterm", 3), rep_len("Term", 3)),
rep.int(c("SGA", "AGA", "LGA"), times = 2))
svn_chr <- paste0(
c(rep.int("Preterm ", 2), rep.int("Term ", 7)),
c("SGA", "SGA", "SGA", "SGA", "AGA", "AGA", "AGA", "LGA", "LGA")
)
expect_equal(svn, expected = factor(svn_chr, levels = svn_lvls))
}
)

test_that(
desc = "Stunting categorisation works as expected",
code = {
lhaz <- c(-6.5, -6, -3.1, -3, -2.9, -2, -1.9, -0.5, -.5, 3, 4.999, 6, 6.5)
stunting_lvls <- c("stunting_severe", "stunting", "not_stunting")
stunting_outlier_lvls <- c(stunting_lvls, "outlier")

stunting_expected <- factor(
c(rep(stunting_lvls[1], 4),
rep(stunting_lvls[2], 2),
rep(stunting_lvls[3], 7)), levels = stunting_lvls)
stunting_outliers_expected <- factor(
c(rep(stunting_outlier_lvls[4], 1),
rep(stunting_outlier_lvls[1], 3),
rep(stunting_outlier_lvls[2], 2),
rep(stunting_outlier_lvls[3], 6),
rep(stunting_outlier_lvls[4], 1)), levels = stunting_outlier_lvls)


stunting <- categorise_stunting(lhaz, outliers = FALSE)
stunting_outliers <- categorise_stunting(lhaz, outliers = TRUE)
expect_equal(stunting, stunting_expected)
expect_equal(stunting_outliers, stunting_outliers_expected)
}
)

test_that(
desc = "Wasting categorisation works as expected",
code = {
wlz <- c(-5.5, -5, -3.1, -3, -2.9, -2, -1.9, -0.5, -1.9, 2, 4.999, 5, 5.5)
wasting_lvls <- c("wasting_severe", "wasting", "not_wasting", "overweight")
wasting_outlier_lvls <- c(wasting_lvls, "outlier")

wasting_expected <- factor(
c(rep(wasting_lvls[1], 4),
rep(wasting_lvls[2], 2),
rep(wasting_lvls[3], 3),
rep(wasting_lvls[4], 4)), levels = wasting_lvls)
wasting_outliers_expected <- factor(
c(rep(wasting_outlier_lvls[5], 1),
rep(wasting_outlier_lvls[1], 3),
rep(wasting_outlier_lvls[2], 2),
rep(wasting_outlier_lvls[3], 3),
rep(wasting_outlier_lvls[4], 3),
rep(wasting_outlier_lvls[5], 1)), levels = wasting_outlier_lvls)

wasting <- categorise_wasting(wlz, outliers = FALSE)
wasting_outliers <- categorise_wasting(wlz, outliers = TRUE)
expect_equal(wasting, wasting_expected)
expect_equal(wasting_outliers, wasting_outliers_expected)
}
)

test_that(
desc = "Wasting categorisation works as expected",
code = {
waz <- c(-6.5, -6, -3.1, -3, -2.9, -2, -1.9, -0.5, -1.9, 2, 4.999, 5, 5.5)
wfa_lvls <- c("underweight_severe", "underweight", "normal_weight",
"overweight")
wfa_outlier_lvls <- c(wfa_lvls, "outlier")

wfa_expected <- factor(
c(rep(wfa_lvls[1], 4),
rep(wfa_lvls[2], 2),
rep(wfa_lvls[3], 3),
rep(wfa_lvls[4], 4)), levels = wfa_lvls)
wfa_outliers_expected <- factor(
c(rep(wfa_outlier_lvls[5], 1),
rep(wfa_outlier_lvls[1], 3),
rep(wfa_outlier_lvls[2], 2),
rep(wfa_outlier_lvls[3], 3),
rep(wfa_outlier_lvls[4], 3),
rep(wfa_outlier_lvls[5], 1)), levels = wfa_outlier_lvls)

wfa <- categorise_wfa(waz, outliers = FALSE)
wfa_outliers <- categorise_wfa(waz, outliers = TRUE)
expect_equal(wfa, wfa_expected)
expect_equal(wfa_outliers, wfa_outliers_expected)
test_that("SVN categorisation works as expected", {
centile <- c(0.01, 0.029, 0.031, 0.09, 0.10, 0.11, 0.89, 0.91, 0.999)
gest_days <- seq(250, 290, 5)
svn <- categorise_svn(centile, gest_days = gest_days)

svn_lvls <- paste(c(rep_len("Preterm", 3), rep_len("Term", 3)),
rep.int(c("SGA", "AGA", "LGA"), times = 2))
svn_chr <- paste0(
c(rep.int("Preterm ", 2), rep.int("Term ", 7)),
c("SGA", "SGA", "SGA", "SGA", "AGA", "AGA", "AGA", "LGA", "LGA")
)
expect_equal(svn, expected = factor(svn_chr, levels = svn_lvls))
})

test_that("Stunting categorisation works as expected", {
lhaz <- c(-6.5, -6, -3.1, -3, -2.9, -2, -1.9, -0.5, -.5, 3, 4.999, 6, 6.5)
stunting_lvls <- c("stunting_severe", "stunting", "not_stunting")
stunting_outlier_lvls <- c(stunting_lvls, "outlier")

stunting_expected <- factor(
c(rep(stunting_lvls[1], 4),
rep(stunting_lvls[2], 2),
rep(stunting_lvls[3], 7)), levels = stunting_lvls)
stunting_outliers_expected <- factor(
c(rep(stunting_outlier_lvls[4], 1),
rep(stunting_outlier_lvls[1], 3),
rep(stunting_outlier_lvls[2], 2),
rep(stunting_outlier_lvls[3], 6),
rep(stunting_outlier_lvls[4], 1)), levels = stunting_outlier_lvls)


stunting <- categorise_stunting(lhaz, outliers = FALSE)
stunting_outliers <- categorise_stunting(lhaz, outliers = TRUE)
expect_equal(stunting, stunting_expected)
expect_equal(stunting_outliers, stunting_outliers_expected)
})

test_that("Wasting categorisation works as expected", {
wlz <- c(-5.5, -5, -3.1, -3, -2.9, -2, -1.9, -0.5, -1.9, 2, 4.999, 5, 5.5)
wasting_lvls <- c("wasting_severe", "wasting", "not_wasting", "overweight")
wasting_outlier_lvls <- c(wasting_lvls, "outlier")

wasting_expected <- factor(
c(rep(wasting_lvls[1], 4),
rep(wasting_lvls[2], 2),
rep(wasting_lvls[3], 3),
rep(wasting_lvls[4], 4)), levels = wasting_lvls)
wasting_outliers_expected <- factor(
c(rep(wasting_outlier_lvls[5], 1),
rep(wasting_outlier_lvls[1], 3),
rep(wasting_outlier_lvls[2], 2),
rep(wasting_outlier_lvls[3], 3),
rep(wasting_outlier_lvls[4], 3),
rep(wasting_outlier_lvls[5], 1)), levels = wasting_outlier_lvls)

wasting <- categorise_wasting(wlz, outliers = FALSE)
wasting_outliers <- categorise_wasting(wlz, outliers = TRUE)
expect_equal(wasting, wasting_expected)
expect_equal(wasting_outliers, wasting_outliers_expected)
})

test_that("Wasting categorisation works as expected", {
waz <- c(-6.5, -6, -3.1, -3, -2.9, -2, -1.9, -0.5, -1.9, 2, 4.999, 5, 5.5)
wfa_lvls <- c("underweight_severe", "underweight", "normal_weight",
"overweight")
wfa_outlier_lvls <- c(wfa_lvls, "outlier")

wfa_expected <- factor(
c(rep(wfa_lvls[1], 4),
rep(wfa_lvls[2], 2),
rep(wfa_lvls[3], 3),
rep(wfa_lvls[4], 4)), levels = wfa_lvls)
wfa_outliers_expected <- factor(
c(rep(wfa_outlier_lvls[5], 1),
rep(wfa_outlier_lvls[1], 3),
rep(wfa_outlier_lvls[2], 2),
rep(wfa_outlier_lvls[3], 3),
rep(wfa_outlier_lvls[4], 3),
rep(wfa_outlier_lvls[5], 1)), levels = wfa_outlier_lvls)

wfa <- categorise_wfa(waz, outliers = FALSE)
wfa_outliers <- categorise_wfa(waz, outliers = TRUE)
expect_equal(wfa, wfa_expected)
expect_equal(wfa_outliers, wfa_outliers_expected)
})

test_that("Head size categorisation works as expected", {
hcaz <- c(-3.5, -3, -2.999, -2.001, -2, -1.999, 0 , 1.999, 2, 2.001, 2.999,
3, 3.5)
headsize_lvls <- c("microcephaly_severe", "microcephaly", "normal_headcirc",
"macrocephaly", "macrocephaly_severe")

headsize_expected <- factor(
c(rep(headsize_lvls[1], 2),
rep(headsize_lvls[2], 3),
rep(headsize_lvls[3], 3),
rep(headsize_lvls[4], 3),
rep(headsize_lvls[5], 2)), levels = headsize_lvls)

headsize <- categorise_headsize(hcaz)
expect_equal(headsize, headsize_expected)
})

# Test handling of unused factor levels ----------------------------------------

# There are no associated srr tags specifically for handling unused factor
# levels in package outputs.
test_that("After categoristaion, unused factor levels can be flagged", {
run_categorise_fn <- function(name, cat_fn) {
keep_warn <- if (name != "svn") {
cat_fn(0.5)
} else {
cat_fn(0.5, 260)
}
}
)

test_that(
desc = "Head size categorisation works as expected",
code = {
hcaz <- c(-3.5, -3, -2.999, -2.001, -2, -1.999, 0 , 1.999, 2, 2.001, 2.999,
3, 3.5)
headsize_lvls <- c("microcephaly_severe", "microcephaly", "normal_headcirc",
"macrocephaly", "macrocephaly_severe")

headsize_expected <- factor(
c(rep(headsize_lvls[1], 2),
rep(headsize_lvls[2], 3),
rep(headsize_lvls[3], 3),
rep(headsize_lvls[4], 3),
rep(headsize_lvls[5], 2)), levels = headsize_lvls)

headsize <- categorise_headsize(hcaz)
expect_equal(headsize, headsize_expected)

#' Set off internal error in [handle_factor_levels()], for coverage reasons
expect_error(
handle_factor_levels(fct = categorise_sfga(0.95, FALSE),
outcome = "BAD OUTCOME"),
class = "gigs_handle_fctr_lvls_bad_outcome_str",
regexp = "`outcome` must be one of"
)

for (name in c("sfga", "svn", "stunting", "wasting", "wfa", "headsize")) {
categorise_fn <- getFromNamespace(paste("categorise", name, sep = "_"),
ns = "gigs")

gigs_option_set(option = "handle_unused_levels",
new_value = "keep_warn", silent = TRUE)
expect_message(keep_warn <- run_categorise_fn(name, categorise_fn),
regexp = "Unused factor levels kept")

gigs_option_set(option = "handle_unused_levels",
new_value = "keep_silent", silent = TRUE)
expect_no_message(keep_silent <- run_categorise_fn(name, categorise_fn))
expect_equal(keep_warn, keep_silent)

gigs_option_set(option = "handle_unused_levels",
new_value = "drop_warn", silent = TRUE)
expect_message(drop_warn <- run_categorise_fn(name, categorise_fn),
regexp = "Unused factor levels dropped")

gigs_option_set(option = "handle_unused_levels",
new_value = "drop_silent", silent = TRUE)
expect_no_message(drop_silent <- run_categorise_fn(name, categorise_fn))

expect_equal(drop_warn, drop_silent)
expect_false(all(levels(keep_silent) == levels(drop_silent)))
}
)

# Set back to default value for other tests
gigs_option_set(option = "handle_unused_levels", new_value = "keep_warn",
silent = TRUE)
})

0 comments on commit 96beb45

Please sign in to comment.