Make dashboard reactive to concept selection (#31)

* Make plots reactive to the selected row in datatable

* Add asserts for monthly count plot

* Only show plots when row is selected

* Add data getters with temporary dummy data

* Add basic unit tests for datatable module

* Test that concepts selection works

* Use data getters in app logic

* Adapt monthly_count plot to use correct column names

* Test that `stat_numeric_plot` processes data correctly

* Format data for numeric stats boxplot

* Update docs

* Ignore `.renvignore` for package builds

* Add concept name as plot title for numeric stats plot

* Add reactivity tests for numeric stats plot

* Add reactivity tests for monthly counts module

* Test monthly count plot helper

* Update docs

* Add note about batch processing of concepts

.Rbuildignore

@@ -10,3 +10,4 @@ $run_dev.*
 ^LICENSE\.md$
 ^\.github$
 ^\.lintr$
+^\.renvignore$

DESCRIPTION

@@ -13,7 +13,9 @@ Imports:
     shiny (>= 1.9.1),
     DBI,
     duckdb,
-    glue
+    glue,
+    tidyr,
+    withr
 Suggests:
     devtools,
     usethis,

R/app_server.R

@@ -5,24 +5,20 @@
 #' @import shiny
 #' @noRd
 app_server <- function(input, output, session) {
-  # TODO: to be replaced by real data, which should be reactive so it responds to filtering options
-  mock_data <- data.frame(
-    concept_id = c(2212648, 2617206, 2212406),
-    name = c(
-      "Blood count; complete (CBC), automated (Hgb, Hct, RBC, WBC and platelet count) and automated differential WBC count", # nolint
-      "Prostate specific antigen test (psa)",
-      "Homocysteine"
-    ),
-    person_count = c(7080, 960, 10),
-    records_per_person = c(4.37, 1.12, 1.06)
-  )
-  mock_data <- reactiveVal(mock_data)
+  # Get the input tables
+  concepts_table <- get_concepts_table()
+  monthly_counts <- get_monthly_counts()
+  summary_stats <- get_summary_stats()
 
-  selected_data <- mod_select_concepts_server("select_concepts", mock_data)
+  selected_data <- mod_select_concepts_server("select_concepts", concepts_table)
+  mod_date_range_server("date_range")
+
+  selected_row <- mod_datatable_server("totals", selected_data)
+
+  # TODO: refactor monthly_count and stat_numeric modules into a single module
+  # https://github.com/UCLH-Foundry/omop-data-catalogue/issues/30
+  mod_monthly_count_server("monthly_count", monthly_counts, selected_row)
+  mod_stat_numeric_server("stat_numeric", summary_stats, selected_row)
 
-  mod_date_range_server("date_range_1")
-  mod_datatable_server("totals", selected_data)
-  mod_monthly_count_server("monthly_count_1")
-  mod_stat_numeric_server("stat_numeric_1")
   mod_export_tab_server("export_tab", selected_data)
 }

R/app_ui.R

@@ -15,14 +15,14 @@ app_ui <- function(request) {
       sidebar = sidebar(
         title = "Filtering options",
         mod_select_concepts_ui("select_concepts"),
-        mod_date_range_ui("date_range_1"),
+        mod_date_range_ui("date_range"),
       ),
       nav_panel(
         title = "Dashboard",
         card(mod_datatable_ui("totals")),
         layout_columns(
-          card(mod_monthly_count_ui("monthly_count_1")),
-          card(mod_stat_numeric_ui("stat_numeric_1"))
+          card(mod_monthly_count_ui("monthly_count")),
+          card(mod_stat_numeric_ui("stat_numeric"))
         )
       ),
       nav_panel(

R/fct_monthly_count_plot.R

@@ -1,17 +1,34 @@
 #' monthly_count_plot
 #'
-#' @description A fct function
+#' Generates a bar plot of the number of records per month for a given concept.
 #'
-#' @return The return value, if any, from executing the function.
+#' Expects the input data to have the following columns:
+#' - `date_year`: The year of the date.
+#' - `date_month`: The month of the date.
+#' - `person_count`: The number of records for the given month.
 #'
-#' @importFrom ggplot2 ggplot aes geom_bar ggtitle xlab ylab
+#' @param monthly_counts A data frame containing the monthly counts.
+#' @param plot_title The title for the plot.
+#'
+#' @return A ggplot2 object containing the bar plot, or `NULL` if no data is provided.
 #'
+#' @importFrom ggplot2 ggplot aes geom_bar ggtitle xlab ylab
 #' @noRd
-monthly_count_plot <- function(monthly_counts, name) {
-  date <- record_count <- NULL
-  ggplot(monthly_counts, aes(x = date, y = record_count)) +
+monthly_count_plot <- function(monthly_counts, plot_title) {
+  stopifnot(is.data.frame(monthly_counts))
+  stopifnot(is.character(plot_title))
+  stopifnot(all(c("date_year", "date_month", "person_count") %in% colnames(monthly_counts)))
+
+  monthly_counts$date <- .convert_to_date(monthly_counts$date_year, monthly_counts$date_month)
+
+  date <- person_count <- NULL
+  ggplot(monthly_counts, aes(x = date, y = person_count)) +
     geom_bar(stat = "identity") +
-    ggtitle(name) +
+    ggtitle(plot_title) +
     xlab("Month") +
     ylab("Number of records")
 }
+
+.convert_to_date <- function(date_year, date_month) {
+  as.Date(paste0(date_year, "-", date_month, "-01"))
+}

R/fct_stat_numeric_plot.R

@@ -1,14 +1,25 @@
 #' stat_numeric_plot
 #'
-#' @description A fct function
+#' Generates a boxplot of the summary statistics for a numeric concept.
+#' Uses pre-calculated `mean` and `sd` to generate the boxplot.
 #'
-#' @return The return value, if any, from executing the function.
+#' Expects the input data to have the following columns:
+#' - `concept_id`: The concept ID.
+#' - `summary_attribute`: The type of the summary attribute, e.g. `mean` or `sd`.
+#' - `value_as_number`: The value of the summary attribute as a numeric value.
+#'
+#' @param summary_stats A `data.frame` containing the summary statistics.
+#' @param plot_title A `character`, to be used as title of the plot.
+#'
+#' @return A `ggplot2` object.
 #'
 #' @importFrom ggplot2 ggplot aes geom_boxplot
 #' @noRd
-stat_numeric_plot <- function(summary_stat) {
-  mean <- sd <- concept <- NULL
-  ggplot(summary_stat, aes(x = concept)) +
+stat_numeric_plot <- function(summary_stats, plot_title) {
+  processed_stats <- .process_summary_stats(summary_stats)
+
+  mean <- sd <- concept_id <- NULL
+  ggplot(processed_stats, aes(x = factor(concept_id))) +
     geom_boxplot(
       aes(
         lower = mean - sd,
@@ -18,5 +29,21 @@ stat_numeric_plot <- function(summary_stat) {
         ymax = mean + 3 * sd
       ),
       stat = "identity"
-    )
+    ) +
+    xlab(NULL) +
+    ggtitle(plot_title)
+}
+
+.process_summary_stats <- function(summary_stats) {
+  # We expect only single concept ID at this point
+  # NOTE: this might change when we support bundles of concepts, in which case we might want to
+  # display the entire batch in one plot
+  stopifnot("Expecting a single concept ID" = length(unique(summary_stats$concept_id)) == 1)
+  stopifnot(c("concept_id", "summary_attribute", "value_as_number") %in% names(summary_stats))
+
+  tidyr::pivot_wider(summary_stats,
+    id_cols = "concept_id",
+    names_from = "summary_attribute",
+    values_from = "value_as_number"
+  )
 }

R/mod_datatable.R

@@ -18,6 +18,8 @@ mod_datatable_ui <- function(id) {
 #'
 #' @param data A reactive data.frame containing the data to be displayed
 #'
+#' @return The selected row as a reactive object
+#'
 #' @noRd
 mod_datatable_server <- function(id, data) {
   stopifnot(is.reactive(data))
@@ -28,5 +30,7 @@ mod_datatable_server <- function(id, data) {
       selected = 1,
       target = "row"
     ))
+
+    reactive(data()[input$datatable_rows_selected, ])
   })
 }

R/mod_monthly_count.R

@@ -1,6 +1,6 @@
 #' monthly_count UI Function
 #'
-#' @description A shiny Module.
+#' Displays the monthly count plot.
 #'
 #' @param id,input,output,session Internal parameters for {shiny}.
 #'
@@ -16,18 +16,32 @@ mod_monthly_count_ui <- function(id) {
 
 #' monthly_count Server Functions
 #'
+#' Generates the monthly count plot for a given concept. When no concept was selected,
+#' an empty plot is generated.
+#'
+#' @param data `data.frame` containing the data to be plotted.
+#' @param selected_concept Reactive value containing the selected concept, used for filtering
+#'
 #' @noRd
-mod_monthly_count_server <- function(id) {
+mod_monthly_count_server <- function(id, data, selected_concept) {
+  stopifnot(is.data.frame(data))
+  stopifnot(is.reactive(selected_concept))
+
+
   moduleServer(id, function(input, output, session) {
-    # TODO: how to get the data?
-    # Need to get the input data and filter it based on the selected timeframe and selected row
-    # see https://stackoverflow.com/a/77039776/11801854
-    monthly_count <- data.frame(
-      date = c("2020-01", "2020-02", "2020-03", "2020-04"),
-      record_count = c(120, 250, 281, 220)
-    )
+    ## Filter data based on selected_row
+    selected_concept_id <- reactive(selected_concept()$concept_id)
+    selected_concept_name <- reactive(selected_concept()$concept_name)
+    filtered_monthly_counts <- reactive({
+      if (!length(selected_concept_id())) {
+        return(NULL)
+      }
+      data[data$concept_id == selected_concept_id(), ]
+    })
     output$monthly_count_plot <- renderPlot({
-      monthly_count_plot(monthly_count, "SELECTED ROW")
+      ## Return empty plot if no data is selected
+      if (is.null(filtered_monthly_counts())) return(NULL)
+      monthly_count_plot(filtered_monthly_counts(), selected_concept_name())
     })
   })
 }

R/mod_select_concepts.R

@@ -16,19 +16,24 @@ mod_select_concepts_ui <- function(id) {
 
 #' select_concepts Server Functions
 #'
-#' @param data A reactive data.frame containing the data from which to select the concepts
+#' @param concepts_table A reactive data.frame containing the data from which to select the concepts
 #'
 #' @return A reactive data.frame filtered on the selected concepts
 #'
 #' @noRd
-mod_select_concepts_server <- function(id, data) {
-  stopifnot(is.reactive(data))
+mod_select_concepts_server <- function(id, concepts_table) {
+  stopifnot("concept_name" %in% names(concepts_table))
 
   moduleServer(id, function(input, output, session) {
-    observeEvent(data(), {
-      updateSelectInput(session, "select_concepts", choices = data()$name, selected = data()$name)
+    ## Make concepts table reactive so that it can be updated
+    concepts_table <- reactiveVal(concepts_table)
+    observeEvent(concepts_table(), {
+      updateSelectInput(session, "select_concepts",
+        choices = concepts_table()$concept_name,
+        ## Have all present concepts selected by default
+        selected = concepts_table()$concept_name
+      )
     })
-
-    reactive(data()[data()$name %in% input$select_concepts, ])
+    reactive(concepts_table()[concepts_table()$concept_name %in% input$select_concepts, ])
   })
 }

R/mod_stat_numeric.R

@@ -1,6 +1,6 @@
 #' stat_numeric UI Function
 #'
-#' @description A shiny Module.
+#' Displays the boxplot of the summary statistics for a numeric concept.
 #'
 #' @param id,input,output,session Internal parameters for {shiny}.
 #'
@@ -16,18 +16,34 @@ mod_stat_numeric_ui <- function(id) {
 
 #' stat_numeric Server Functions
 #'
+#' Generates the boxplot of the summary statistics for a numeric concept.
+#' When no concept was selected, an empty plot is returned.
+#'
+#' @param data `data.frame` containing the data to be plotted.
+#' @param selected_concept Reactive value containing the selected concept, used for filtering
+#'
 #' @noRd
-mod_stat_numeric_server <- function(id) {
+mod_stat_numeric_server <- function(id, data, selected_concept) {
+  stopifnot(is.data.frame(data))
+  stopifnot(is.reactive(selected_concept))
+
   moduleServer(id, function(input, output, session) {
-    summary_stat <- data.frame(
-      concept = "SELECTED ROW",
-      sd = 0.8280661,
-      mean = 5.843
-    )
+    # Filter data based on the selected row
+    selected_concept_id <- reactive(selected_concept()$concept_id)
+    selected_concept_name <- reactive(selected_concept()$concept_name)
+
+    ## When no row selected, return an empty plot
+    filtered_summary_stats <- reactive({
+      if (!length(selected_concept_id())) {
+        return(NULL)
+      }
+      data[data$concept_id == selected_concept_id(), ]
+    })
 
     output$stat_numeric_plot <- renderPlot({
-      # TODO: move this to a separate function
-      stat_numeric_plot(summary_stat)
+      ## Return empty plot if no data is selected
+      if (is.null(filtered_summary_stats())) return(NULL)
+      stat_numeric_plot(filtered_summary_stats(), selected_concept_name())
     })
   })
 }

R/utils_get_data.R

@@ -0,0 +1,63 @@
+#' Get input data for the app
+#'
+#' Utility functions to retrieve the input data for the app from the database.
+#'
+#' @noRd
+get_concepts_table <- function() {
+  if (golem::app_dev()) {
+    return(data.frame(
+      concept_id = c(40213251, 133834, 4057420),
+      concept_name = c(
+        "varicella virus vaccine",
+        "Atopic dermatitis",
+        "Catheter ablation of tissue of heart"
+      ),
+      domain_id = c("Drug", "Condition", "Procedure"),
+      vocabulary_id = c("CVX", "SNOMED", "SNOMED"),
+      concept_class_id = c("CVX", "Clinical Finding", "Procedure"),
+      standard_concept = c("S", "S", "S"),
+      concept_code = c("21", "24079001", "18286008")
+    ))
+  }
+
+  con <- connect_to_test_db()
+  withr::defer(DBI::dbDisconnect(con))
+  DBI::dbReadTable(con, "calypso_concepts")
+}
+
+get_monthly_counts <- function() {
+  if (golem::app_dev()) {
+    return(
+      data.frame(
+        concept_id = c(
+          rep(c(40213251, 133834, 4057420), each = 3)
+        ),
+        date_year = c(2019L, 2020L, 2020L, 2019L, 2020L, 2020L, 2020L, 2019L, 2019L),
+        date_month = c(4L, 3L, 5L, 5L, 8L, 4L, 11L, 6L, 3L),
+        person_count = c(1, 1, 3, 4, 2, 3, 2, 4, 1),
+        records_per_person = c(1, 1, 1, 1, 1, 1, 1, 1, 1)
+      )
+    )
+  }
+
+  con <- connect_to_test_db()
+  withr::defer(DBI::dbDisconnect(con))
+  DBI::dbReadTable(con, "calypso_monthly_counts")
+}
+
+get_summary_stats <- function() {
+  if (golem::app_dev()) {
+    return(
+      data.frame(
+        concept_id = rep(c(40213251, 133834, 4057420), each = 2),
+        summary_attribute = rep(c("mean", "sd"), times = 3),
+        value_as_string = rep(NA, 6),
+        value_as_number = c(1.5, 0.5, 2.5, 0.7, 3.5, 0.8)
+      )
+    )
+  }
+
+  con <- connect_to_test_db()
+  withr::defer(DBI::dbDisconnect(con))
+  DBI::dbReadTable(con, "calypso_summary_stats")
+}