[NM-59] Add input comparison table metadata

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: hintr
 Title: R API for calling naomi district level HIV model
-Version: 1.2.3
+Version: 1.2.4
 Authors@R: 
     person(given = "Robert",
            family = "Ashton",

NEWS.md

@@ -1,3 +1,7 @@
+# hintr 1.2.4
+
+* Add a new endpoint `/chart-data/input-comparison` for returning data and metadata for input comparison barchart.
+
 # hintr 1.2.3
 
 * Add checks that a rehydrated project is valid. It checks that:

R/api.R

@@ -5,6 +5,7 @@ api_build <- function(queue, validate = FALSE, logger = NULL) {
   api$handle(endpoint_baseline_combined())
   api$handle(endpoint_validate_survey_programme())
   api$handle(endpoint_input_time_series_plot())
+  api$handle(endpoint_input_comparison_plot())
   api$handle(endpoint_review_input_metadata())
   api$handle(endpoint_model_options())
   api$handle(endpoint_model_options_validate())
@@ -181,6 +182,18 @@ endpoint_input_time_series_plot <- function() {
                                     returning = response)
 }
 
+endpoint_input_comparison_plot <- function() {
+  input <- porcelain::porcelain_input_body_json(
+    "input", "InputComparisonRequest.schema", schema_root())
+  response <- porcelain::porcelain_returning_json(
+    "InputComparisonResponse.schema", schema_root())
+  porcelain::porcelain_endpoint$new("POST",
+                                    "/chart-data/input-comparison",
+                                    input_comparison,
+                                    input,
+                                    returning = response)
+}
+
 endpoint_review_input_metadata <- function() {
   input <- porcelain::porcelain_input_body_json(
     "input", "ReviewInputFilterMetadataRequest.schema", schema_root())

R/endpoints.R

@@ -165,7 +165,7 @@ get_review_input_filter_types <- function(input, types, area_level_options) {
     list(
       id = scalar("area"),
       column_id = scalar("area_id"),
-      optons = json_verbatim("null"),
+      options = json_verbatim("null"),
       use_shape_regions = scalar(TRUE)
     ),
     list(

R/filters.R

@@ -282,9 +282,9 @@ get_quarter_label <- function(calendar_quarter) {
   naomi::calendar_quarter_labels(calendar_quarter)
 }
 
-get_year_filters <- function(data) {
+get_year_filters <- function(data, decreasing = TRUE) {
   years <- unique(data$year)
-  years <- sort(years, decreasing = TRUE)
+  years <- sort(years, decreasing = decreasing)
   lapply(years, function(year) {
     list(id = scalar(as.character(year)),
          label = scalar(as.character(year)))

R/input-comparison.R

@@ -0,0 +1,279 @@
+input_comparison <- function(input) {
+  input <- jsonlite::fromJSON(input)
+
+  withCallingHandlers({
+    if (is.null(input$programme) && is.null(input$anc)) {
+      stop("Cannot build input comparison plot without either programme or anc data")
+    }
+    if (!is.null(input$programme)) {
+      assert_file_exists(input$programme$path)
+    }
+    if (!is.null(input$anc)) {
+      assert_file_exists(input$anc$path)
+    }
+    assert_file_exists(input$shape$path)
+    assert_file_exists(input$pjnz$path)
+    data <- as.data.frame(
+      naomi::prepare_spectrum_naomi_comparison(input$programme$path,
+                                               input$anc$path,
+                                               input$shape$path,
+                                               input$pjnz$path))
+    metadata <- build_input_comparison_metadata(data)
+    list(
+      data = data,
+      metadata = metadata,
+      warnings = list()
+    )
+  },
+  error = function(e) {
+    hintr_error(api_error_msg(e), "FAILED_TO_GENERATE_INPUT_COMPARISON")
+  })
+}
+
+get_filter_options_translated <- function(data, key, values = NULL) {
+  to_translate <- unique(data[[key]])
+  if (!is.null(values)) {
+    to_translate <- to_translate[to_translate %in% values]
+  }
+  lapply(to_translate, function(value) {
+    list(id = scalar(value),
+         label = scalar(t_(toupper(value))))
+  })
+}
+
+get_filter_options <- function(data, key) {
+  lapply(unique(data[[key]]), function(value) {
+    list(id = scalar(value),
+         label = scalar(to_upper_first(value)))
+  })
+}
+
+build_input_comparison_metadata <- function(data) {
+  indicator_metadata <- get_indicator_metadata("input_comparison", "barchart",
+                                               list(iso3 = "default"))
+  data_indicators <- unique(data$indicator)
+  present_indicators <- indicator_metadata[indicator_metadata$indicator %in% data_indicators, ]
+  indicator_options <- construct_filter(present_indicators, "indicator", "name")
+  indicator_ids <- vcapply(indicator_options, "[[", "id")
+  indicator_labels <- vcapply(indicator_options, "[[", "label")
+  indicator_id_label_map <- setNames(indicator_labels, indicator_ids)
+  indicator_filter <- list(
+    id = scalar("indicator"),
+    column_id = scalar("indicator"),
+    options = indicator_options
+  )
+  area_name_filter <- list(
+    id = scalar("area_name"),
+    column_id = scalar("area_name"),
+    options = get_filter_options(data, "area_name")
+  )
+  year_filter <- list(
+    id = scalar("year"),
+    column_id = scalar("year"),
+    options = get_year_filters(data, decreasing = FALSE)
+  )
+  group_ids <- unique(data$group)
+  group_filter <- list(
+    id = scalar("group"),
+    column_id = scalar("group"),
+    options = get_filter_options(data, "group")
+  )
+  list(
+    filterTypes = list(
+      indicator_filter,
+      area_name_filter,
+      year_filter,
+      group_filter
+    ),
+    indicators = indicator_metadata,
+    plotSettingsControl = list(
+      inputComparisonBarchart = get_input_barchart_settings(
+        indicator_ids,
+        group_ids,
+        indicator_id_label_map),
+      inputComparisonTable = get_input_table_settings(indicator_id_label_map,
+                                                      group_ids)
+    )
+  )
+}
+
+get_input_barchart_settings <- function(indicator_ids,
+                                        group_ids,
+                                        indicator_id_label_map) {
+  plot_types <- list(
+    "number_on_art_adult_both" = list(
+      indicator = "number_on_art",
+      group = "art_adult_both",
+      label = t_("NUMBER_ON_ART_ADULT_BOTH")
+    ),
+    "number_on_art_adult_female" = list(
+      indicator = "number_on_art",
+      group = "art_adult_female",
+      label = t_("NUMBER_ON_ART_ADULT_FEMALE")
+    ),
+    "number_on_art_adult_male" = list(
+      indicator = "number_on_art",
+      group = "art_adult_male",
+      label = t_("NUMBER_ON_ART_ADULT_MALE")
+    ),
+    "number_on_art_children" = list(
+      indicator = "number_on_art",
+      group = "art_children",
+      label = t_("NUMBER_ON_ART_CHILDREN")
+    ),
+    "anc_already_art" = list(
+      indicator = "anc_already_art",
+      group = "anc_adult_female",
+      label = indicator_id_label_map["anc_already_art"]
+    ),
+    "anc_clients" = list(
+      indicator = "anc_clients",
+      group = "anc_adult_female",
+      label = indicator_id_label_map["anc_clients"]
+    ),
+    "anc_known_pos" = list(
+      indicator = "anc_known_pos",
+      group = "anc_adult_female",
+      label = indicator_id_label_map["anc_known_pos"]
+    ),
+    "anc_tested" = list(
+      indicator = "anc_tested",
+      group = "anc_adult_female",
+      label = indicator_id_label_map["anc_tested"]
+    ),
+    "anc_tested_pos" = list(
+      indicator = "anc_tested_pos",
+      group = "anc_adult_female",
+      label = indicator_id_label_map["anc_tested_pos"]
+    )
+  )
+  plot_type_options <- lapply(names(plot_types), function(plot_type) {
+    type <- plot_types[[plot_type]]
+    if (!(type$indicator %in% indicator_ids) || !(type$group %in% group_ids)) {
+      return(NULL)
+    }
+    list(
+      id = scalar(plot_type),
+      label = scalar(type$label),
+      effect = list(
+        setFilterValues = list(
+          indicator = type$indicator,
+          group = type$group
+        )
+      )
+    )
+  })
+  plot_type_options <- plot_type_options[!vlapply(plot_type_options, is.null)]
+
+  default_filter_ids <- c("indicator", "area_name", "year", "group")
+  default_set_filters <- lapply(default_filter_ids, get_filter_from_id)
+
+  list(
+    defaultEffect = list(
+      setFilters = default_set_filters,
+      setHidden = c("indicator", "year", "group"),
+      setMultiple = c("year")
+    ),
+    plotSettings = list(
+      list(
+        id = scalar("plot_type"),
+        label = scalar(t_("INPUT_TIME_SERIES_COLUMN_PLOT_TYPE")),
+        options = plot_type_options
+      )
+    )
+  )
+}
+
+get_input_table_settings <- function(indicator_id_label_map, group_ids) {
+  art_indicators <- "number_on_art"
+  art_groups <- c("art_adult_both", "art_adult_females", "art_adult_males",
+                  "art_children")
+  anc_indicators <- c("anc_already_art", "anc_clients", "anc_known_pos",
+                      "anc_tested", "anc_tested_pos")
+  anc_groups <- "anc_adult_female"
+  indicator_to_control_option <- function(indicator_id) {
+    if (indicator_id %in% art_indicators) {
+      groups <- art_groups[art_groups %in% group_ids]
+    } else if (indicator_id %in% anc_indicators) {
+      groups <- anc_groups[anc_groups %in% group_ids]
+    } else {
+      hintr_error(sprintf("Unknown input table indicator '%s'.", indicator_id),
+                  "UNKNOWN_INDICATOR")
+    }
+    list(
+      id = scalar(indicator_id),
+      label = scalar(indicator_id_label_map[[indicator_id]]),
+      effect = list(
+        setFilterValues = list(
+          indicator = indicator_id,
+          group = groups
+        )
+      )
+    )
+  }
+  indicator_control_options <- lapply(names(indicator_id_label_map),
+                                      indicator_to_control_option)
+  default_filter_ids <- c("indicator", "area_name", "year", "group")
+  default_set_filters <- lapply(default_filter_ids, get_filter_from_id)
+  list(
+    defaultEffect = list(
+      setFilters = default_set_filters,
+      customPlotEffect = list(
+        row = c("area_name", "year"),
+        column = "group"
+      ),
+      setMultiple = c("area_name", "year", "group")
+    ),
+    plotSettings = list(
+      list(
+        id = scalar("indicator_control"),
+        label = scalar(t_("OUTPUT_FILTER_INDICATOR")),
+        options = indicator_control_options
+      )
+    )
+  )
+}
+
+get_table_presets <- function(filter_types) {
+  detail_options <- get_filter_option_ids(filter_types, "detail")
+  list(
+    list(
+      id = scalar("sex_by_area"),
+      label = scalar(t_("TABLE_SEX_BY_AREA")),
+      effect = list(
+        setFilters = lapply(
+          c("indicator", "area", "detail", "period", "sex", "age"),
+          get_filter_from_id),
+        ## Hide the area ID as we want people to just select the detail level
+        ## and see all rows within that level. Having the area filter available
+        ## too makes this confusing, but we need area to exist for picking
+        ## up the row labels
+        setHidden = c("area"),
+        setMultiple = c("sex", "area"),
+        setFilterValues = list(
+          detail = detail_options[length(detail_options)]
+        ),
+        customPlotEffect = list(
+          row = c("area"),
+          column = c("sex")
+        )
+      )
+    ),
+    list(
+      id = scalar("sex_by_5_year_age_group"),
+      label = scalar(t_("TABLE_SEX_BY_5_YEAR_AGE_GROUP")),
+      effect = list(
+        setFilters = lapply(c("indicator", "area", "period", "sex", "age"),
+                            get_filter_from_id),
+        setMultiple = c("sex", "age"),
+        setFilterValues = list(
+          age = naomi::get_five_year_age_groups()
+        ),
+        customPlotEffect = list(
+          row = c("age"),
+          column = c("sex")
+        )
+      )
+    )
+  )
+}

R/metadata.R

@@ -2,17 +2,6 @@ get_plotting_metadata <- function(...) {
   naomi::get_plotting_metadata(...)
 }
 
-get_barchart_metadata <- function(output, data_type = "output") {
-  metadata <- naomi::get_metadata()
-  metadata <- metadata[
-    metadata$data_type == data_type & metadata$plot_type == "barchart",
-    c("indicator", "value_column", "error_low_column", "error_high_column",
-      "indicator_column", "indicator_value", "indicator_sort_order",
-      "name", "scale", "accuracy", "format")
-  ]
-  metadata[order(metadata$indicator_sort_order), ]
-}
-
 get_indicator_metadata <- function(data_type, plot_type, data) {
   iso3 <- get_country_iso3(data$area_id)
   metadata <- get_plotting_metadata(iso3)
@@ -447,7 +436,9 @@ get_label_for_id <- function(id) {
       "calibrate_indicator" = "OUTPUT_FILTER_INDICATOR",
       "type" = "OUTPUT_FILTER_TYPE",
       "spectrum_region" = "OUTPUT_FILTER_SPECTRUM_REGION",
-      "source" = "OUTPUT_FILTER_DATA_TYPE"
+      "source" = "OUTPUT_FILTER_DATA_TYPE",
+      "area_name" = "OUTPUT_FILTER_AREA",
+      "year" = "INPUT_TIME_SERIES_COLUMN_YEAR"
     )
   )
 }

inst/schema/InputComparisonData.schema.json

@@ -0,0 +1,5 @@
+{
+  "$schema": "http://json-schema.org/draft-04/schema#",
+  "type": "array",
+  "items": { "$ref": "InputComparisonRow.schema.json" }
+}