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)
 })