Skip to content

Commit

Permalink
refactor coverage classifier functions; fix #64
Browse files Browse the repository at this point in the history
  • Loading branch information
ernestguevarra committed Dec 26, 2024
1 parent 0224366 commit d2fa20c
Show file tree
Hide file tree
Showing 6 changed files with 153 additions and 109 deletions.
4 changes: 3 additions & 1 deletion NAMESPACE
Original file line number Diff line number Diff line change
Expand Up @@ -2,13 +2,15 @@

S3method(plot,lqasSim)
S3method(print,lqasClass)
export(classify_coverage)
export(get_n_cases)
export(get_n_clusters)
export(get_sample_d)
export(get_sample_n)
export(get_sampling_clusters)
export(get_sampling_list)
export(lqas_classify)
export(lqas_classify_)
export(lqas_classify_coverage)
export(lqas_get_class_prob)
export(lqas_simulate_population)
export(lqas_simulate_run)
Expand Down
139 changes: 83 additions & 56 deletions R/03-classify_coverage.R
Original file line number Diff line number Diff line change
@@ -1,96 +1,123 @@
#'
#' Classify coverage results
#' LQAS classifier
#'
#' @param n_in Number (integer) of cases found in the programme
#' @param n_total Number (integer) of children under 5 years sampled
#' @param standard Decision rule standard/s. Should be between 0 and 1. At
#' least one standard should be provided for a two-tier coverage classifier.
#' Two standards should be provided for a three-tier coverage classifier.
#' Default is a three-tier classifier with rule set at 0.2 and 0.5.
#' @param n Number of cases found.
#' @param n_total Number sampled.
#' @param threshold Decision rule threshold/s. Should be between 0 and 1. At
#' least one threshold should be provided for a two-tier classifier. Two
#' thresholds should be provided for a three-tier classifier. Default is a
#' three-tier classifier with rule set at 0.2 and 0.5.
#'
#' @return A character value or vector indicating coverage classification. If
#' `standard` is a single value, returns **"Satisfactory"** if coverage is
#' above `standard` and **"Not satisfactory"** if coverage is below or
#' equal to `standard`. If `standard` is two values, returns **"Low"** if
#' coverage is below or equal to lower standard, **"High"** if coverage is
#' above the higher standard, and **"Moderate"** for all other coverage
#' values.
#' @returns A character value or vector indicating classification. If
#' `threshold` is a single value, the generic function returns *1* if `n` is
#' greater than the threshold else *0*. The coverage classifier
#' function returns **"Satisfactory"** if `n` is greater than the threshold
#' else **"Not satisfactory"**. If `threshold` is two values, the generic
#' function returns *1* if `n` is greater than the first threshold and *2* if
#' `n` is greater than the second threshold else *0*. The CMAM coverage
#' classifier returns **"Low"** if `n` is below or equal to lower threshold,
#' **"High"** if `n` is above the higher threshold, and **"Moderate"** for
#' all other values of `n`.
#'
#' @author Ernest Guevarra
#'
#' @examples
#' classify_coverage(n_in = 6, n_total = 40)
#' with(survey_data,
#' classify_coverage(n_in = in_cases, n_total = n)
#' )
#' lqas_classify_coverage(n = 6, n_total = 40)
#' with(survey_data, lqas_classify_coverage(n = in_cases, n_total = n))
#'
#' @export
#' @rdname lqas_classify
#'

classify_coverage <- function(n_in, n_total, standard = c(0.2, 0.5)) {
coverage_class <- Map(
f = classify_coverage_,
n_in = as.list(n_in),
n_total = as.list(n_total),
standard = rep(list(standard), length(n_in))
)

unlist(coverage_class)
}

#'
#' @noRd
#'

classify_coverage_ <- function(n_in, n_total, standard = c(0.2, 0.5)) {
## Check that standard/s is/are numeric
if (!all(is.numeric(standard))) {
lqas_classify_ <- function(n, n_total, threshold = c(0.2, 0.5)) {
## Check that threshold/s is/are numeric
if (!all(is.numeric(threshold))) {
stop(
"Standard/s should be numeric. Check your values.", call. = TRUE
"Threshold/s should be numeric. Check your values.", call. = TRUE
)
}

## Sort rule to ensure that first value is the smaller value
standard <- sort(standard)

## Check that standard is between 0 and 1
if (any(standard < 0 | standard > 1)) {
threshold <- sort(threshold)
## Check that threshold is between 0 and 1
if (any(threshold < 0 | threshold > 1)) {
stop(
"Standard/s should be between 0 and 1. Check your values.", call. = TRUE
"Threshold/s should be between 0 and 1. Check your values.",
call. = TRUE
)
}

## Check that difference between standards is at least 0.3
if (length(standard) == 2) {
if ((standard[2] - standard[1]) < 0.3) {
## Check that difference between thresholds is at least 0.3
if (length(threshold) == 2) {
if ((threshold[2] - threshold[1]) < 0.3) {
warning(
"Difference between lower and upper standards is less than 0.3. ",
"Difference between lower and upper thresholds is less than 0.3. ",
"This may cause gross mis-classification.",
call. = TRUE
)
}
}

## Get d
d <- n_total * standard

d <- n_total * threshold
## Two-tier classification
if (length(d) == 1) {
coverage_class <- ifelse(n_in > d, "Satisfactory", "Not satisfactory")
coverage_class <- ifelse(n > d, 1, 0)
}

## Three-tier classification
if (length(d) == 2) {
coverage_class <- ifelse(
n_in > d[2], "High",
n > d[2], 2,
ifelse(
n_in <= d[1], "Low", "Moderate"
n <= d[1], 0, 1
)
)
}

coverage_class
}

#'
#' @export
#' @rdname lqas_classify
#'

lqas_classify <- function(n, n_total, threshold = c(0.2, 0.5)) {
Map(
f = lqas_classify_,
n = as.list(n),
n_total = as.list(n_total),
threshold = rep(list(threshold), length(n))
) |>
unlist()
}

#'
#' @export
#' @rdname lqas_classify
#'

lqas_classify_coverage <- function(n, n_total, threshold = c(0.2, 0.5)) {
coverage_class <- lqas_classify(
n = n, n_total = n_total, threshold = threshold
)

if (length(threshold) == 1) {
coverage_label <- ifelse(
coverage_class == 1, "Satisfactory", "Not satisfactory"
)
} else {
coverage_label <- ifelse(
coverage_class == 0, "Low",
ifelse(
coverage_class == 1, "Moderate", "High"
)
)
}

## Return coverage_label ----
coverage_label
}
40 changes: 0 additions & 40 deletions man/classify_coverage.Rd

This file was deleted.

47 changes: 47 additions & 0 deletions man/lqas_classify.Rd

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

3 changes: 2 additions & 1 deletion pkgdown/_pkgdown.yml
Original file line number Diff line number Diff line change
Expand Up @@ -51,7 +51,8 @@ reference:
- starts_with("get_sampling")

- title: Coverage classifier
contents: classify_coverage
contents:
- starts_with("lqas_classify")

- title: Tests for SLEAC classifier performance
contents:
Expand Down
29 changes: 18 additions & 11 deletions tests/testthat/test-03-classify_coverage.R
Original file line number Diff line number Diff line change
@@ -1,31 +1,38 @@

# Tests for lqas_classify functions --------------------------------------------

test_that("output is character", {
expect_type(classify_coverage(n_in = 6, n_total = 40), "character")
expect_type(lqas_classify_coverage(n = 6, n_total = 40), "character")

expect_type(
classify_coverage(
n_in = survey_data$in_cases, n_total = survey_data$n
lqas_classify_coverage(
n = survey_data$in_cases, n_total = survey_data$n
), "character"
)

expect_type(
classify_coverage(n_in = 6, n_total = 40, standard = 0.5), "character"
lqas_classify_coverage(n = 6, n_total = 40, threshold = 0.5),
"character"
)

expect_type(
classify_coverage(
n_in = survey_data$in_cases, n_total = survey_data$n, standard = 0.5
), "character"
lqas_classify_coverage(
n = survey_data$in_cases, n_total = survey_data$n, threshold = 0.5
),
"character"
)
})


test_that("errors and warnings show correctly", {
expect_warning(
classify_coverage(n_in = 6, n_total = 40, standard = c(0.4, 0.5))
lqas_classify_coverage(n = 6, n_total = 40, threshold = c(0.4, 0.5))
)

expect_error(
classify_coverage(n_in = 6, n_total = 40, standard = c("0.4", "0.5"))
lqas_classify_coverage(n = 6, n_total = 40, threshold = c("0.4", "0.5"))
)

expect_error(
classify_coverage(n_in = 6, n_total = 40, standard = c(0.4, 1.2))
lqas_classify_coverage(n = 6, n_total = 40, threshold = c(0.4, 1.2))
)
})

0 comments on commit d2fa20c

Please sign in to comment.