Merge branch 'development' into public-view

R/app_ui.R

@@ -23,16 +23,11 @@ app_ui <- function(request) {
  icon = shiny::icon("comment"),
  selected = TRUE
  ),
- uiOutput("filter_location_1") |>
- shinycssloaders::withSpinner(),
- uiOutput("filter_location_2") |>
- shinycssloaders::withSpinner(),
- uiOutput("filter_location_3") |>
- shinycssloaders::withSpinner(),
- mod_demographics_selection_ui("demographics_selection_1") |>
- shinycssloaders::withSpinner(),
- uiOutput("date_filter_ui") |>
- shinycssloaders::withSpinner(),
+ uiOutput("filter_location_1"),
+ uiOutput("filter_location_2"),
+ uiOutput("filter_location_3"),
+ mod_demographics_selection_ui("demographics_selection_1"),
+ uiOutput("date_filter_ui"),
  style = "color: black;" # ensure all text are black
  )
  ),

R/demographic_graphs.R

@@ -6,26 +6,30 @@
 #'
 #' @return a plotly object
 #' @noRd
-compare_demographics <- function(pass_data, variable, score_column = list("fft")) {
- score_column <- unlist(score_column[!vapply(score_column, is.null, TRUE)])
-
+compare_demographics <- function(pass_data, variable, score_column = "fft") {
+
+ if (score_column == "fft"){
+ pass_data <- pass_data %>%
+ dplyr::filter(.data[[score_column]] <= 5)
+ }
+
  p <- pass_data %>%
  dplyr::filter(!is.na(.data[[variable]])) %>%
  dplyr::group_by(.data[[variable]]) %>%
  dplyr::summarise(across(all_of(score_column), ~ mean(.x, na.rm = TRUE)),
  n = dplyr::n()
  ) %>%
  dplyr::filter(n > 10) %>%
- dplyr::mutate(dplyr::across(where(is.numeric), ~ round(. * 20, 1))) %>%
  dplyr::select(-n) %>%
+ dplyr::mutate(dplyr::across(where(is.numeric), ~ 100 - round(. * 20, 1))) %>%
  tidyr::pivot_longer(-all_of(variable)) %>%
  ggplot2::ggplot(ggplot2::aes(
  x = .data[[variable]], y = value,
  group = name, fill = name
  )) +
  ggplot2::geom_col(position = "dodge") +
  add_theme_nhs() +
- ggplot2::ylab("%") +
+ ggplot2::ylab(sprintf("%s %s score", "%",score_column)) +
  ggplot2::ylim(0, 100) +
  ggplot2::coord_flip() +
  ggplot2::theme(
@@ -64,7 +68,8 @@ demographic_distribution <- function(pass_data, variable, return_ggplot = FALSE)
  legend.position = "none",
  axis.title = ggplot2::element_text(size = 12),
  axis.text = ggplot2::element_text(size = 11),
- )
+ ) +
+ ggplot2::ylab("Number of comments")
 
  if (return_ggplot) {
  return(
@@ -76,8 +81,7 @@ demographic_distribution <- function(pass_data, variable, return_ggplot = FALSE)
  ) +
  ggplot2::theme(
  axis.text.x = ggplot2::element_text(angle = 45, vjust = 1.2, hjust=1)
- ) +
- ggplot2::ylab("Number of comments")
+ )
  )
  }
 

R/mod_demographics.R

@@ -72,7 +72,7 @@ mod_demographics_server <- function(id, filter_data, data_exists) {
  ),
  hr(),
  pre("The below chart shows the average percentage of FFT score for each group in the demographic feature.",
- "Note: Categories with fewer than 10 individuals are excluded",
+ "Note: Only 1-5 point FFT scores are considered and categories with fewer than 10 individuals are excluded",
  style = "background-color:#005EB8; color:#fff"
  ),
  fluidRow(

R/mod_trend.R

@@ -24,6 +24,10 @@ mod_trend_server <- function(id, filter_data, data_exists) {
  moduleServer(id, function(input, output, session) {
  ns <- session$ns
 
+ white_pre <- function(text) {
+ pre(text, style = "background-color:white")
+ }
+
  # Super UI ----
  output$dynamic_trendUI <- renderUI({
  # Only show module contents if the data from the database is not empty
@@ -32,14 +36,17 @@ mod_trend_server <- function(id, filter_data, data_exists) {
  )
 
  fluidPage(
- p(HTML(paste0("
- This page provides a timeline visual to show when comments have been 
+ p(HTML(paste0(
+ "
+ This page provides a timeline visual to show when comments have been
  received for the different categories and sub-categories, it is intended
- to help with identifying patterns within this, before you drill down 
+ to help with identifying patterns within this, before you drill down
  into the underling comments. To get further detail about how to use the
  timeline visual, please see the ",
- enurl("https://cdu-data-science-team.github.io/PatientExperience-QDC/dashboard/#distribution-of-comments-over-time",
- "Patient Experience – QDC documentation page.")
+ enurl(
+ "https://cdu-data-science-team.github.io/PatientExperience-QDC/dashboard/#distribution-of-comments-over-time",
+ "Patient Experience – QDC documentation page."
+ )
  ))),
  strong("Click on a box to see the comments for that month on the table below."),
  fluidRow(
@@ -99,20 +106,19 @@ mod_trend_server <- function(id, filter_data, data_exists) {
  # server code ----
  ## trend plot for the super-category ----
  super_plot_source <- ns("event_id-1") # to get user data from the super category plot
- 
+
  output$super_category_trend_plot <- plotly::renderPlotly({
-
  filter_data()$single_labeled_filter_data %>%
  make_trend_data() %>%
  plot_trend("super_category", source = super_plot_source) %>%
  plotly::event_register("plotly_click")
-
  })
 
  ## the comments tables - super category ----
  return_data <- reactive({
-
  data <- filter_data()$single_labeled_filter_data
+ selected_date <- NULL
+ super_category_selected <- NULL
 
  if (isTruthy(plotly::event_data("plotly_click", source = super_plot_source, priority = "event"))) {
  d <- plotly::event_data("plotly_click", source = super_plot_source, priority = "event")
@@ -129,39 +135,62 @@ mod_trend_server <- function(id, filter_data, data_exists) {
  format(as.Date(date), "%Y-%m") == selected_date
  )
  }
-
- return(prep_data_for_comment_table(data))
+
+ return(
+ list(
+ date = selected_date,
+ cat = super_category_selected,
+ data = prep_data_for_comment_table(data)
+ )
+ )
  })
 
  output$dynamic_super_category_table <- renderUI({
-
- mod_comment_download_server(ns("comment_download_1"), return_data(), filepath = "super_category-trend-")
-
+ if (!is.null(return_data()$date)) {
+ tagList(
+ sprintf(
+ "Data Shown in table: Date (%s) and sub-category (%s)",
+ strong(return_data()$date), strong(return_data()$cat)
+ ) |>
+ HTML() |> white_pre(),
+ mod_comment_download_server(ns("comment_download_1"),
+ return_data()$data,
+ filepath = "super_category-trend-"
+ )
+ )
+ } else {
+ tagList(
+ white_pre("Data Shown in table: All the data."),
+ mod_comment_download_server(ns("comment_download_1"),
+ return_data()$data,
+ filepath = "super_category-trend-"
+ )
+ )
+ }
  })
- 
+
  ## trend plot for the sub-category ----
  sub_plot_source <- ns("event_id-2") # to get user data from the sub category plot
  output$sub_category_trend_plot <- plotly::renderPlotly({
-
  req(!is.null(input$select_super_category))
- 
+
  filter_data()$single_labeled_filter_data %>%
  make_trend_data(selected_super_category = input$select_super_category) %>%
  plot_trend(
- "category", 
- source = sub_plot_source, 
+ "category",
+ source = sub_plot_source,
  super_category = input$select_super_category
- )
-
+ )
  })
 
  ## the comments tables - sub category ----
  return_data2 <- reactive({
-
  req(!is.null(input$select_super_category))
- 
- data <- filter_data()$single_labeled_filter_data %>% 
+
+ data <- filter_data()$single_labeled_filter_data %>%
  dplyr::filter(super_category == input$select_super_category)
+ date_selected <- NULL
+ category_selected <- NULL
 
  if (isTruthy(plotly::event_data("plotly_click", source = sub_plot_source, priority = "event"))) {
  sub_d <- plotly::event_data("plotly_click", source = sub_plot_source, priority = "event")
@@ -177,17 +206,49 @@ mod_trend_server <- function(id, filter_data, data_exists) {
  category == sub_category_selected,
  format(as.Date(date), "%Y-%m") == selected_date
  )
-
- if (nrow(return_data) > 0) data <- return_data
+
+ if (nrow(return_data) > 0) {
+ data <- return_data
+ category_selected <- sub_category_selected
+ date_selected <- selected_date
+ }
  }
-
- return(prep_data_for_comment_table(data))
+
+ return(
+ list(
+ date = date_selected,
+ cat = category_selected,
+ data = prep_data_for_comment_table(data)
+ )
+ )
  })
 
  output$dynamic_sub_category_table <- renderUI({
-
- mod_comment_download_server(ns("comment_download_2"), return_data2(), filepath = "sub_category-trend-")
-
+ if (!is.null(return_data2()$date)) {
+ tagList(
+ sprintf(
+ "Data Shown in table: Date (%s) and sub-category (%s)",
+ strong(return_data2()$date), strong(return_data2()$cat)
+ ) |>
+ HTML() |> white_pre(),
+ mod_comment_download_server(ns("comment_download_2"),
+ return_data2()$data,
+ filepath = "sub_category-trend-"
+ )
+ )
+ } else {
+ tagList(
+ sprintf(
+ "Data shown in table: All the data in %s",
+ strong(input$select_super_category)
+ ) |>
+ HTML() |> white_pre(),
+ mod_comment_download_server(ns("comment_download_2"),
+ return_data2()$data,
+ filepath = "sub_category-trend-"
+ )
+ )
+ }
  })
  })
 }

tests/testthat/_snaps/app_ui.md

@@ -47,41 +47,11 @@
   <span>Qualitative Data Categorisation</span>
   </a>
   </li>
-  <div class="shiny-spinner-output-container shiny-spinner-hideui ">
-  <div class="load-container shiny-spinner-hidden load1">
-  <div id="spinner-ba78c668609eded639a2da304050c63b" class="loader">Loading...</div>
-  </div>
-  <div style="height:400px" class="shiny-spinner-placeholder"></div>
-  <div id="filter_location_1" class="shiny-html-output"></div>
-  </div>
-  <div class="shiny-spinner-output-container shiny-spinner-hideui ">
-  <div class="load-container shiny-spinner-hidden load1">
-  <div id="spinner-ae523cbb0fef0e4fb09426547ef6afd4" class="loader">Loading...</div>
-  </div>
-  <div style="height:400px" class="shiny-spinner-placeholder"></div>
-  <div id="filter_location_2" class="shiny-html-output"></div>
-  </div>
-  <div class="shiny-spinner-output-container shiny-spinner-hideui ">
-  <div class="load-container shiny-spinner-hidden load1">
-  <div id="spinner-5cca906c3668b5351d4ab80410c66d21" class="loader">Loading...</div>
-  </div>
-  <div style="height:400px" class="shiny-spinner-placeholder"></div>
-  <div id="filter_location_3" class="shiny-html-output"></div>
-  </div>
-  <div class="shiny-spinner-output-container shiny-spinner-hideui ">
-  <div class="load-container shiny-spinner-hidden load1">
-  <div id="spinner-2b76e3f63a54a1dc3a6b988bf6694a55" class="loader">Loading...</div>
-  </div>
-  <div style="height:400px" class="shiny-spinner-placeholder"></div>
-  <div id="demographics_selection_1-dynamic_demographics_selection" class="shiny-html-output"></div>
-  </div>
-  <div class="shiny-spinner-output-container shiny-spinner-hideui ">
-  <div class="load-container shiny-spinner-hidden load1">
-  <div id="spinner-cd508d165900c436725416866cd0513a" class="loader">Loading...</div>
-  </div>
-  <div style="height:400px" class="shiny-spinner-placeholder"></div>
-  <div id="date_filter_ui" class="shiny-html-output"></div>
-  </div>
+  <div id="filter_location_1" class="shiny-html-output"></div>
+  <div id="filter_location_2" class="shiny-html-output"></div>
+  <div id="filter_location_3" class="shiny-html-output"></div>
+  <div id="demographics_selection_1-dynamic_demographics_selection" class="shiny-html-output"></div>
+  <div id="date_filter_ui" class="shiny-html-output"></div>
   </ul>
   </section>
   </aside>

tests/testthat/test-demographic_graphs.R

@@ -13,7 +13,7 @@ test_that("demographic_distribution functions works: return ggplot object", {
 test_that("compare_demographics functions works", {
 
  result2 <- unique_data %>%
- compare_demographics(variable = "age", score_column = list("fft"))
+ compare_demographics(variable = "age", score_column = "fft")
  expect_true(inherits(result2, "plotly"))
  expect_snapshot(result2)
 })