Merge pull request #513 from mrc-ide/comparison-metadata

Update comparison metadata to new format
hivtools · May 20, 2024 · a472994 · a472994
2 parents e066455 + 3086489
commit a472994
Show file tree

Hide file tree

Showing 10 changed files with 120 additions and 212 deletions.
diff --git a/.github/workflows/docker.yaml b/.github/workflows/docker.yaml
@@ -2,9 +2,9 @@ name: Build Docker Image
 
 on:
   push:
-    branches: [main, master, tmp-epic-plot-cleanup-input]
+    branches: [main, master, tmp-epic-plot-cleanup-input, new-calibrate-metadata]
   pull_request:
-    branches: [main, master, tmp-epic-plot-cleanup-input]
+    branches: [main, master, tmp-epic-plot-cleanup-input, new-calibrate-metadata]
 
 jobs:
   docker:

diff --git a/R/endpoints.R b/R/endpoints.R
@@ -692,20 +692,16 @@ comparison_plot <- function(queue) {
     ## Strip tibble class to work with helper functions which rely on
     ## converting to vector when selecting 1 column
     data <- as.data.frame(data)
-    data <- data[, c("area_id", "area_name", "age_group", "sex",
-                   "calendar_quarter", "indicator", "source", "mean",
-                   "lower", "upper")]
-    filters <- get_comparison_plot_filters(data)
-    selections <- get_comparison_barchart_selections(data, filters)
+
+    filter_types <- get_comparison_plot_filters(data)
     list(
-      data = data,
-      plottingMetadata = list(
-        barchart = list(
-          indicators = get_barchart_metadata(data, "comparison"),
-          filters = filters,
-          defaults = selections[[1]],
-          selections = selections
-        )
+      data = data[, c("area_id", "area_name", "area_level", "age_group", "sex",
+                      "calendar_quarter", "indicator", "source", "mean",
+                      "lower", "upper")],
+      metadata = list(
+        filterTypes = filter_types,
+        indicators = get_indicator_metadata("comparison", "barchart", data),
+        plotSettingsControl = get_comparison_plot_settings_control(filter_types)
       )
     )
   }

diff --git a/R/filters.R b/R/filters.R
@@ -197,129 +197,45 @@ get_calibrate_plot_filters <- function(data) {
 
 get_comparison_plot_filters <- function(data) {
   list(
+    list(
+      id = scalar("indicator"),
+      column_id = scalar("indicator"),
+      options = get_indicator_options("comparison")
+    ),
     list(
       id = scalar("area"),
       column_id = scalar("area_id"),
-      label = scalar(t_("OUTPUT_FILTER_AREA")),
       options = json_verbatim("null"),
       use_shape_regions = scalar(TRUE)
     ),
     list(
-      id = scalar("quarter"),
+      id = scalar("detail"),
+      column_id = scalar("area_level"),
+      options = get_area_level_filters(data)
+    ),
+    list(
+      id = scalar("period"),
       column_id = scalar("calendar_quarter"),
-      label = scalar(t_("OUTPUT_FILTER_PERIOD")),
       options = get_quarter_filters(data)
     ),
     list(
       id = scalar("sex"),
       column_id = scalar("sex"),
-      label = scalar(t_("OUTPUT_FILTER_SEX")),
       options = get_sex_filters(data)
     ),
     list(
       id = scalar("age"),
       column_id = scalar("age_group"),
-      label = scalar(t_("OUTPUT_FILTER_AGE")),
       options = get_age_filters(data)
     ),
     list(
       id = scalar("source"),
       column_id = scalar("source"),
-      label = scalar(t_("OUTPUT_FILTER_DATA_TYPE")),
       options = get_source_filters(data)
     )
   )
 }
 
-get_barchart_defaults <- function(output, output_filters) {
-  list(
-    indicator_id = scalar("prevalence"),
-    x_axis_id = scalar("age"),
-    disaggregate_by_id = scalar("sex"),
-    selected_filter_options = list(
-      area = get_area_id_filter_default(output),
-      period = get_selected_mappings(output_filters, "period")[2],
-      sex = get_selected_mappings(output_filters, "sex", c("female", "male")),
-      age = get_selected_mappings(output_filters, "age",
-                                  naomi::get_five_year_age_groups())
-    )
-  )
-}
-
-get_comparison_barchart_selections <- function(output, filters) {
-  area_default <- get_area_id_filter_default(output)
-  five_year_age_groups <- get_selected_mappings(
-    filters, "age", naomi::get_five_year_age_groups())
-  all_sexes <- get_selected_mappings(filters, "sex")
-  both <- get_selected_mappings(filters, "sex", "both")
-  female <- get_selected_mappings(filters, "sex", "female")
-  survey_quarter <- get_selected_mappings(filters, "quarter")[2]
-  source = get_selected_mappings(filters, "source")
-  fifteen_to_49 <- get_selected_mappings(filters, "age", "Y015_049")
-  list(
-    list(
-      indicator_id = scalar("prevalence"),
-      x_axis_id = scalar("age"),
-      disaggregate_by_id = scalar("source"),
-      selected_filter_options = list(
-        area = area_default,
-        quarter = survey_quarter,
-        sex = both,
-        age = five_year_age_groups,
-        source = source
-      )
-    ),
-    list(
-      indicator_id = scalar("art_coverage"),
-      x_axis_id = scalar("age"),
-      disaggregate_by_id = scalar("source"),
-      selected_filter_options = list(
-        area = area_default,
-        quarter = survey_quarter,
-        sex = both,
-        age = five_year_age_groups,
-        source = source
-      )
-    ),
-    list(
-      indicator_id = scalar("art_current"),
-      x_axis_id = scalar("sex"),
-      disaggregate_by_id = scalar("source"),
-      selected_filter_options = list(
-        area = area_default,
-        quarter = survey_quarter,
-        sex = all_sexes,
-        age = get_selected_mappings(filters, "age", "Y015_999"),
-        source = source
-      )
-    ),
-    list(
-      indicator_id = scalar("anc_prevalence_age_matched"),
-      x_axis_id = scalar("sex"),
-      disaggregate_by_id = scalar("source"),
-      selected_filter_options = list(
-        area = area_default,
-        quarter = survey_quarter,
-        sex = female,
-        age = fifteen_to_49,
-        source = source
-      )
-    ),
-    list(
-      indicator_id = scalar("anc_art_coverage_age_matched"),
-      x_axis_id = scalar("sex"),
-      disaggregate_by_id = scalar("source"),
-      selected_filter_options = list(
-        area = area_default,
-        quarter = survey_quarter,
-        sex = female,
-        age = fifteen_to_49,
-        source = source
-      )
-    )
-  )
-}
-
 #' Get selected id-label mapping from list of filter options or column mappings
 #'
 #' Gets the id to label mapping of a particular type matching a set of IDs.
@@ -353,18 +269,6 @@ get_selected_mappings <- function(mappings, type, ids = NULL, key = "options") {
   selected
 }
 
-get_area_id_filter_default <- function(output) {
-  ## We expect the areas to be returned in order - return the first region
-  ## level as the default
-  option <- output[1, c("area_id", "area_name")]
-  list(
-    list(
-      id = scalar(option$area_id),
-      label = scalar(option$area_name)
-    )
-  )
-}
-
 get_quarter_filters <- function(data) {
   calendar_quarters <- unique(data$calendar_quarter)
   calendar_quarters <- sort(calendar_quarters, decreasing = TRUE)

diff --git a/R/metadata.R b/R/metadata.R
@@ -82,12 +82,6 @@ get_output_plot_settings_control <- function() {
   )
 }
 
-get_calibrate_plot_settings_control <- function(filter_types) {
-  list(
-    calibrate = get_calibration_plot_settings(filter_types)
-  )
-}
-
 get_choropleth_settings <- function() {
   filter_ids <- c("indicator", "detail", "area", "period", "sex", "age")
   list(
@@ -123,6 +117,12 @@ get_barchart_settings <- function() {
   )
 }
 
+get_calibrate_plot_settings_control <- function(filter_types) {
+  list(
+    calibrate = get_calibration_plot_settings(filter_types)
+  )
+}
+
 get_calibration_plot_settings <- function(filter_types) {
   calibrate_only_settings <- list(
     list(
@@ -163,6 +163,66 @@ get_calibration_plot_settings <- function(filter_types) {
   )
 }
 
+get_comparison_plot_settings_control <- function(filter_types) {
+  list(
+    comparison = get_comparison_plot_settings(filter_types)
+  )
+}
+
+get_comparison_plot_settings <- function(filter_types) {
+  x_axis_filters <- c("period", "sex", "age")
+  default_filter_ids <- c(c("indicator", "area", "source"),
+                          x_axis_filters)
+  default_filters <- lapply(default_filter_ids, get_filter_from_id)
+  all_filters <- c(default_filters, list(get_filter_from_id("detail")))
+
+  area_x_axis_effect <- list(
+    id = scalar("area"),
+    label = scalar(get_label_for_id("area")),
+    effect = list(
+      setMultiple = "area",
+      setFilters = all_filters
+    )
+  )
+  ## TODO: In current plot when you change indicator, it updates
+  ## the filters. We could support this same behaviour by making
+  ## indicator a plot control which updates the filter values
+  ## including a hidden "indicator" filter which would be the value
+  ## actually used for filtering the data. But let's check what we
+  ## actually want to do. Would have to set the x-axis too, which I don't
+  ## think we can support yet.
+  ## TODO: Set the x-axis default value to "age"
+  list(
+    defaultEffect = list(
+      setFilters = default_filters,
+      setFilterValues = list(
+        indicator = c("prevalence"),
+        period = get_filter_option_ids(filter_types, "period")[2],
+        age = naomi::get_five_year_age_groups()
+      ),
+      setHidden = c(
+        "source"
+      )
+    ),
+    ## disaggregate plot settings are not visible as users cannot
+    ## change these in the comparison plot
+    plotSettings = list(
+      list(
+        id = scalar("x_axis"),
+        label = scalar(t_("OUTPUT_BARCHART_X_AXIS")),
+        options = c(lapply(x_axis_filters, get_x_axis_or_disagg_by_option),
+                    list(area_x_axis_effect))
+      ),
+      list(
+        id = scalar("disagg_by"),
+        label = scalar(t_("OUTPUT_BARCHART_DISAGG_BY")),
+        options = list(get_x_axis_or_disagg_by_option("source")),
+        hidden = scalar(TRUE)
+      )
+    )
+  )
+}
+
 get_filter_option_ids <- function(filter_types, type) {
   selected <- NULL
   for (filter in filter_types) {
@@ -270,7 +330,8 @@ get_label_for_id <- function(id) {
       "indicator" = "OUTPUT_FILTER_INDICATOR",
       "calibrate_indicator" = "OUTPUT_FILTER_INDICATOR",
       "type" = "OUTPUT_FILTER_TYPE",
-      "spectrum_region" = "OUTPUT_FILTER_SPECTRUM_REGION"
+      "spectrum_region" = "OUTPUT_FILTER_SPECTRUM_REGION",
+      "source" = "OUTPUT_FILTER_DATA_TYPE"
     )
   )
 }
diff --git a/inst/comparison_plot_mock.rds b/inst/comparison_plot_mock.rds
diff --git a/inst/schema/ComparisonPlotMetadata.schema.json b/inst/schema/ComparisonPlotMetadata.schema.json
@@ -0,0 +1,23 @@
+{
+  "$schema": "http://json-schema.org/draft-04/schema#",
+  "type": "object",
+  "properties": {
+    "filterTypes": {
+      "type": "array",
+      "items": { "$ref": "FilterTypes.schema.json" }
+    },
+    "indicators": {
+      "type": "array",
+      "items": { "$ref": "ChoroplethIndicatorMetadata.schema.json" }
+    },
+    "plotSettingsControl": {
+      "type": "object",
+      "properties": {
+        "comparison": { "$ref": "PlotSettingsControl.schema.json" }
+      },
+      "additionalProperties": false,
+      "required": [ "comparison" ]
+    }
+  },
+  "required": [ "filterTypes", "indicators", "plotSettingsControl" ]
+}
diff --git a/inst/schema/ComparisonPlotResponse.schema.json b/inst/schema/ComparisonPlotResponse.schema.json
@@ -3,15 +3,8 @@
   "type": "object",
   "properties": {
     "data": { "$ref": "ComparisonPlotData.schema.json" },
-    "plottingMetadata": {
-      "type": "object",
-      "properties": {
-        "barchart": { "$ref": "ComparisonBarchartMetadata.schema.json" }
-      },
-      "additionalProperties": false,
-      "required": [ "barchart" ]
-    }
+    "metadata": { "$ref": "ComparisonPlotMetadata.schema.json" }
   },
   "additionalProperties": false,
-  "required": [ "data", "plottingMetadata" ]
+  "required": [ "data", "metadata" ]
 }
diff --git a/inst/schema/ComparisonPlotRow.schema.json b/inst/schema/ComparisonPlotRow.schema.json
@@ -8,6 +8,9 @@
     "area_name": {
       "type": "string"
     },
+    "area_level": {
+      "type": "number"
+    },
     "sex": {
       "type": "string"
     },

diff --git a/tests/testthat/test-02-api.R b/tests/testthat/test-02-api.R
@@ -1116,13 +1116,13 @@ test_that("can get comparison plot data", {
 
   expect_equal(response$status_code, 200)
   response_data <- response$data
-  expect_setequal(names(response_data), c("data", "plottingMetadata"))
+  expect_setequal(names(response_data), c("data", "metadata"))
   expect_setequal(names(response_data$data),
                   c("area_id", "area_name", "age_group", "sex",
                     "calendar_quarter", "indicator", "source", "mean",
                     "lower", "upper"))
   expect_true(nrow(response_data$data) > 0)
-  expect_equal(names(response_data$plottingMetadata), "barchart")
+  expect_equal(names(response_data$metadata), "barchart")
   expect_setequal(names(response_data$plottingMetadata$barchart),
                   c("indicators", "filters", "defaults", "selections"))