Merge pull request #3 from WorldHealthOrganization/feature/composite-indicators

Feature/composite indicators

Author: dirkschumacher

DESCRIPTION

@@ -41,8 +41,9 @@ Collate:
     'indicators-iodine.R'
     'measurements.R'
     'concepts.R'
-    'indicators-iron-deficiency-anaemia.R'
+    'indicators-composite.R'
     'indicators-export.R'
+    'indicators-iron-deficiency-anaemia.R'
     'package-micronutrients.R'
     'prevalence.R'
     'utils.R'

NAMESPACE

@@ -1,9 +1,31 @@
 # Generated by roxygen2: do not edit by hand
 
+S3method(format,composite_indicator)
 S3method(format,indicator)
 S3method(format,vctrs_measurement)
+S3method(indicator_abbreviated_name,composite_indicator)
+S3method(indicator_abbreviated_name,indicator)
+S3method(indicator_agg_prevalence_categories,composite_indicator)
+S3method(indicator_agg_prevalence_categories,indicator)
+S3method(indicator_drop_columns,composite_indicator)
+S3method(indicator_drop_columns,indicator)
+S3method(indicator_export_value_name,composite_indicator)
+S3method(indicator_export_value_name,indicator)
+S3method(indicator_name,composite_indicator)
+S3method(indicator_name,indicator)
+S3method(indicator_prevalence_categories,composite_indicator)
+S3method(indicator_prevalence_categories,indicator)
+S3method(indicator_rename_columns,composite_indicator)
+S3method(indicator_rename_columns,indicator)
+S3method(indicator_reorder_columns,composite_indicator)
+S3method(indicator_reorder_columns,indicator)
+S3method(indicator_value_concept,composite_indicator)
+S3method(indicator_value_concept,indicator)
 S3method(iodine_is_implausible,default)
 S3method(levels,indicator)
+S3method(prevalence_report_short,composite_indicator)
+S3method(prevalence_report_short,indicator)
+S3method(print,composite_indicator)
 S3method(print,indicator)
 S3method(required_concepts,indicator)
 S3method(required_concepts,indicator_adjustment)
@@ -23,7 +45,6 @@ export(adjustment_ferritin_arithmetic_correction)
 export(adjustment_ferritin_cutoff)
 export(adjustment_ferritin_regression_correction)
 export(adjustment_ferritin_rm_agp_crp)
-export(adjustment_none)
 export(indicator_anaemia)
 export(indicator_ferritin)
 export(indicator_ida)

R/adjustments-export.R

@@ -1,3 +1,6 @@
+#' Indicator adjustment methods
+#'
+#' This can be used to signal no adjustment for an indicator.
 #' @rdname adjustments
 #' @include indicators-ferritin.R
 #' @export
@@ -25,12 +28,3 @@ adjustment_ferritin_rm_agp_crp <- function() {
 adjustment_ferritin_cutoff <- function() {
   ferritin_adjustment_cutoff
 }
-
-#' Indicator adjustment methods
-#'
-#' This can be used to signal no adjustment for an indicator.
-#' @rdname adjustments
-#' @export
-adjustment_none <- function() {
-  no_adjustment
-}

R/classifications.R

@@ -15,7 +15,6 @@
 #' @param CRP (Optional) A vector of C-reactive protein (CRP) measurements (in mg/L), used to adjust for inflammation.
 #' @param AGP (Optional) A vector of alpha-1-acid glycoprotein (AGP) measurements (in g/L), used to adjust for inflammation.
 #' @param ferritin (Optional) A vector of ferritin measurements (in \\u00b5gg/L).
-#' @param ida (Optional) A vector of iron deficiency measurements.
 #' @param iodine (Optional) A vector of iodine measurements (in \\u00b5gg/L).
 #' @param haemoglobin (Optional) A vector of haemoglobin measurements (in g/L).
 #' @param altitude (Optional) A numeric vector representing elevation above sea level (in meters), used to adjust for altitude-related effects. Elevation is a compulsory variable and it should always be reported in the dataset. Even when no elevation data is collected, a variable for 'elevation' should be created and set as "0" for all individuals without reported elevation. When elevation is not reported, that individual case will be excluded from the analysis and considered as 'missing'
@@ -59,7 +58,6 @@ individual_classification <- function(
   CRP = NULL,
   AGP = NULL,
   ferritin = NULL,
-  ida = NULL,
   iodine = NULL,
   haemoglobin = NULL,
   altitude = NULL,
@@ -77,7 +75,6 @@ individual_classification <- function(
     AGP = AGP,
     iodine = iodine,
     ferritin = ferritin,
-    ida = ida,
     haemoglobin = haemoglobin,
     altitude = altitude,
     is_smoker = is_smoker,
@@ -98,7 +95,6 @@ classify_data_internal <- function(
   CRP = NULL,
   AGP = NULL,
   ferritin = NULL,
-  ida = NULL,
   iodine = NULL,
   haemoglobin = NULL,
   altitude = NULL,
@@ -109,6 +105,7 @@ classify_data_internal <- function(
   malaria = NULL,
   .format_column_names = TRUE
 ) {
+  indicators <- flatten_indicators(indicators)
   validate_indicators(indicators)
   concept_list <- concepts_from_args(
     sex = sex,
@@ -119,7 +116,6 @@ classify_data_internal <- function(
     AGP = AGP,
     iodine = iodine,
     ferritin = ferritin,
-    ida = ida,
     haemoglobin = haemoglobin,
     altitude = altitude,
     is_smoker = is_smoker,
@@ -131,7 +127,12 @@ classify_data_internal <- function(
   cols <- names(concept_list$values)
 
   values <- lapply(indicators, function(x) {
-    concept_list$values[[x$value_concept]]
+    value_concept <- indicator_value_concept(x)
+    if (is.null(value_concept)) {
+      NULL
+    } else {
+      concept_list$values[[value_concept]]
+    }
   })
   results <- indicators_compute_all(indicators, values, concept_list$values)
   names(results) <- NULL
@@ -147,7 +148,13 @@ classify_data_internal <- function(
 
 validate_indicators <- function(indicators) {
   stopifnot(is.list(indicators))
-  stopifnot(all(vapply(indicators, is_indicator, logical(1L))))
+  stopifnot(all(vapply(
+    indicators,
+    function(x) {
+      is_indicator(x) || is_composite_indicator(x)
+    },
+    logical(1L)
+  )))
 }
 
 not_null <- function(x) {

R/concepts.R

@@ -269,16 +269,6 @@ concepts <- concepts_list(
     prototype = measurement_mcg_l(NA_real_),
     is_implausible = is_ferritin_implausible
   ),
-  ## ida ----
-  concept(
-    key = "ida",
-    label = "Iron deficiency",
-    accept = concept_acceptor(iron_deficiency_acceptor, "TODO"),
-    standardizer = identity,
-    validator = iron_deficiency_validator,
-    prototype = NA
-    # is_implausible = iron_deficiency_implausible
-  ),
   ## AGP ----
   concept(
     key = "AGP",

R/indicators-composite.R

@@ -0,0 +1,98 @@
+composite_indicator <- function(
+  name,
+  abbreviated_name,
+  compute_function,
+  prevalence_categories,
+  requires_indicators
+) {
+  structure(
+    list(
+      name = name,
+      compute_function = compute_function,
+      abbreviated_name = abbreviated_name,
+      prevalence_categories = prevalence_categories,
+      required_indicators = requires_indicators
+    ),
+    class = "composite_indicator"
+  )
+}
+
+is_composite_indicator <- function(x) {
+  inherits(x, "composite_indicator")
+}
+
+#' @exportS3Method
+indicator_name.composite_indicator <- function(indicator) {
+  indicator$name
+}
+
+#' @exportS3Method
+indicator_value_concept.composite_indicator <- function(x) {
+  NULL
+}
+
+#' @exportS3Method
+indicator_abbreviated_name.composite_indicator <- function(indicator) {
+  indicator$abbreviated_name
+}
+
+#' @exportS3Method
+prevalence_report_short.composite_indicator <- function(indicator) {
+  TRUE
+}
+
+#' @exportS3Method
+indicator_prevalence_categories.composite_indicator <- function(indicator) {
+  indicator$prevalence_categories
+}
+
+#' @exportS3Method
+indicator_agg_prevalence_categories.composite_indicator <- function(indicator) {
+  NULL
+}
+
+#' @exportS3Method
+indicator_rename_columns.composite_indicator <- function(
+  indicator,
+  report_type
+) {
+  list(
+    short = NULL,
+    long = NULL
+  )
+}
+
+#' @exportS3Method
+indicator_reorder_columns.composite_indicator <- function(
+  indicator,
+  report_type
+) {
+  list(
+    short = NULL,
+    long = NULL
+  )
+}
+
+#' @exportS3Method
+indicator_drop_columns.composite_indicator <- function(indicator, report_type) {
+  NULL
+}
+
+#' @exportS3Method
+indicator_export_value_name.composite_indicator <- function(indicator) {
+  indicator$abbreviated_name
+}
+
+
+#' @export
+format.composite_indicator <- function(x, ...) {
+  paste0(
+    "Indicator: ",
+    x$name
+  )
+}
+
+#' @export
+print.composite_indicator <- function(x, ...) {
+  cat(format(x), "\n")
+}

R/indicators-export.R

@@ -6,25 +6,34 @@
 #' @include indicators-anaemia.R
 #' @rdname indicators
 #' @export
-indicator_anaemia <- function() anaemia_indicator
+indicator_anaemia <- function() {
+  anaemia_indicator
+}
 
 #' @param ferritin_adjustment the adjustment method for ferritin.
 #' @include indicators-ferritin.R
 #' @rdname indicators
 #' @export
-indicator_ferritin <- function(ferritin_adjustment = adjustment_none()) {
-  ferritin_indicator(ferritin_adjustment)
+indicator_ferritin <- function(ferritin_adjustment) {
+  stopifnot(is_adjustment(ferritin_adjustment))
+  list(
+    ferritin_indicator(no_adjustment),
+    ferritin_indicator(ferritin_adjustment)
+  )
 }
 
-#' @param ferritin_adjustment the adjustment method for ferritin.
 #' @rdname indicators
-#' @include indicators-iron-deficiency-anaemia.R
 #' @export
-indicator_ida <- function(ferritin_adjustment = adjustment_none()) {
-  ida_indicator(ferritin_adjustment)
+indicator_ida <- function() {
+  list(
+    ida_indicator_unadjusted,
+    ida_indicator_adjusted
+  )
 }
 
 #' @include indicators-iodine.R
 #' @rdname indicators
 #' @export
-indicator_iodine <- function() iodine_indicator
+indicator_iodine <- function() {
+  iodine_indicator
+}