Merge pull request #197 from CDU-data-science-team/195-colour-code-th…

…e-categories-and-sentiment-columns

complete 0.9 milestone and some stakeholders' actions

NAMESPACE

@@ -11,14 +11,10 @@ export(get_api_pred_url)
 export(get_pred_from_url)
 export(html_decoder)
 export(matched_comments)
-export(plot_fft_spc)
 export(return_search_text)
 export(run_app)
-export(split_data_spc)
 export(tidy_all_trusts)
 export(track_api_job)
-export(verbatim_comments)
-export(verbatim_summary)
 import(shiny)
 import(shinydashboard)
 importFrom(config,get)

R/app_server.R

@@ -12,6 +12,15 @@ app_server <- function(input, output, session) {
  Sys.setenv("R_CONFIG_ACTIVE" = set_trust_config(session$groups))
  }
  cat("Trust name:", get_golem_config("trust_name"), " \n")
+
+ # determine if user has admin right - if to show the data-management tab
+ if (!isTRUE(getOption('golem.app.prod'))) {
+ admin_user <- TRUE # set to true in development env
+ } else{
+ # get from session data of Connect environment - in production env
+ admin_user <- is_admin_user(session$groups)
+ }
+ cat("Admin right:", admin_user, " \n")
 
  # Create DB connection pool
  pool <- get_pool()
@@ -299,35 +308,28 @@ app_server <- function(input, output, session) {
  mod_header_message_server("messageMenu", pool, db_data, data_exists)
 
  ## combine ALL sub-modules----
- mod_patient_experience_server("patient_experience_ui_1")
+ mod_patient_experience_server("patient_experience_ui_1", admin_user)
 
  ## sub-modules
 
  mod_documentation_page_server("documentation_page")
 
  mod_trend_server("trend_ui_1", filter_data, data_exists)
 
- mod_summary_server("summary_ui_1", data_exists)
-
  mod_summary_record_server("summary_record_1", db_data, filter_data)
 
- mod_data_management_server("data_management_1", db_conn = pool, filter_data, data_exists, user)
-
- mod_fft_server("fft_ui_1", filter_data = filter_data)
-
- mod_report_builder_server(
- "report_builder_ui_1",
- filter_data = filter_data,
- all_inputs = all_inputs,
- data_exists = data_exists
- )
-
- mod_click_tables_server("click_tables_ui", filter_data = filter_data, data_exists = data_exists)
+ mod_click_tables_server("click_tables_ui", filter_data = filter_data,
+ data_exists = data_exists)
+
+ mod_complex_comments_server("complex_comments_1", filter_data, data_exists)
 
  mod_search_text_server("search_text_ui_1", filter_data = filter_data)
 
  mod_trend_overlap_server("trend_overlap_ui", filter_data, data_exists)
 
  mod_demographics_server("demographics_ui_1", filter_data, data_exists
  )
+
+ mod_data_management_server("data_management_1", db_conn = pool, 
+ filter_data, data_exists, user)
 }

R/app_ui.R

@@ -21,8 +21,7 @@ app_ui <- function(request) {
  menuItem("Qualitative Data Categorisation",
  tabName = "experiences-user",
  icon = shiny::icon("comment"),
- selected = TRUE,
- badgeLabel = "dev", badgeColor = "green"
+ selected = TRUE
  ),
  uiOutput("filter_location_1"),
  uiOutput("filter_location_2"),
@@ -37,33 +36,11 @@ app_ui <- function(request) {
  fresh::use_theme(nhs_shiny_theme()), # use fresh object theme to style the whole dashboard
  # Leave this function for adding external resources
  golem_add_external_resources(),
- HTML('<a href="https://github.com/CDU-data-science-team/experiencesdashboard"
- class="github-corner" aria-label="View source on GitHub"><svg width="80"
- height="80" viewBox="0 0 250 250" style="fill:#64CEAA; color:#fff; position:
- absolute; top: 50; border: 0; right: 0;" aria-hidden="true"><path d="M0,0
- L115,115 L130,115 L142,142 L250,250 L250,0 Z"></path><path d="M128.3,109.0
- C113.8,99.7 119.0,89.6 119.0,89.6 C122.0,82.7 120.5,78.6 120.5,78.6
- C119.2,72.0 123.4,76.3 123.4,76.3 C127.3,80.9 125.5,87.3 125.5,87.3
- C122.9,97.6 130.6,101.9 134.4,103.2" fill="currentColor"
- style="transform-origin: 130px 106px;" class="octo-arm"></path><path
- d="M115.0,115.0 C114.9,115.1 118.7,116.5 119.8,115.4 L133.7,101.6
- C136.9,99.2 139.9,98.4 142.2,98.6 C133.8,88.0 127.5,74.4 143.8,58.0
- C148.5,53.4 154.0,51.2 159.7,51.0 C160.3,49.4 163.2,43.6 171.4,40.1
- C171.4,40.1 176.1,42.5 178.8,56.2 C183.1,58.6 187.2,61.8 190.9,65.4
- C194.5,69.0 197.7,73.2 200.1,77.6 C213.8,80.2 216.3,84.9 216.3,84.9
- C212.7,93.1 206.9,96.0 205.4,96.6 C205.1,102.4 203.0,107.8 198.3,112.5
- C181.9,128.9 168.3,122.5 157.7,114.1 C157.9,116.9 156.7,120.9 152.7,124.9
- L141.0,136.5 C139.8,137.7 141.6,141.9 141.8,141.8 Z" fill="currentColor"
- class="octo-body"></path></svg></a><style>.github-corner:hover
- .octo-arm{animation:octocat-wave 560ms ease-in-out}@keyframes
- octocat-wave{0%,100%{transform:rotate(0)}20%,
- 60%{transform:rotate(-25deg)}40%,80%{transform:rotate(10deg)}}@media
- (max-width:500px){.github-corner:hover .octo-arm{animation:none}.github-corner
- .octo-arm{animation:octocat-wave 560ms ease-in-out}}</style>'),
  tabItems(
  tabItem(
  tabName = "experiences-user",
- mod_patient_experience_ui("patient_experience_ui_1")
+ mod_patient_experience_ui("patient_experience_ui_1") |>
+ shinycssloaders::withSpinner()
  )
  )
  )

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/fct_app_server-helpers.R

@@ -22,6 +22,13 @@ set_trust_config <- function(groups) {
  }
 }
 
+#' determine if the user as admin right to edit data
+#' @param groups session$group
+#' @noRd
+is_admin_user <- function(groups) {
+ "experiencedashboard-admins" %in% groups
+}
+
 get_location_data <- function(date_filter, select_location_1, select_location_2, select_location_3) {
  return_data <- date_filter
 

R/golem_utils_server.R

@@ -87,6 +87,16 @@ header_links <- function() {
  ),
  class = "dropdown"
  ),
+ tags$li(
+ a(
+ onclick = "onclick =window.open('https://github.com/CDU-data-science-team/experiencesdashboard')",
+ href = NULL,
+ icon("github", prefer_type = "solid"),
+ title = "Visit project GitHub page",
+ style = "cursor: pointer;"
+ ),
+ class = "dropdown"
+ ),
  class = "dropdown"
  )
 }
@@ -405,7 +415,7 @@ get_sentiment_text <- function(value) {
  value == 3 ~ "Neutral/Mixed",
  value == 4 ~ "Negative",
  value == 5 ~ "Negative",
- TRUE ~ NA
+ TRUE ~ NA_character_
  )
 }
 

R/golem_utils_ui.R

@@ -212,6 +212,26 @@ with_red_stars <- function(text) {
 }
 
 
+#' Add color to header 4 text
+#'
+#' Adds a red star at the end of the text
+#' (for example for indicating mandatory fields).
+#'
+#' @param text the HTLM text to put before the red star
+#'
+#' @return an html element
+#' @noRd
+#'
+#' @examples
+#' colored_h4("Enter your name here")
+#'
+#' @importFrom htmltools tags
+colored_h4 <- function(text, color = "#005EB8") {
+ tags$h4(
+ text,
+ style = paste("color:", color)
+ )
+}
 
 #' Repeat tags$br
 #'
@@ -241,7 +261,7 @@ rep_br <- function(times = 1) {
 #'
 #' @importFrom htmltools tags
 enurl <- function(url, text) {
- tags$a(href = url, text)
+ tags$a(href = url, text, target = "_blank")
 }
 
 #' Columns wrappers

R/mod_click_tables.R

@@ -10,7 +10,8 @@
 mod_click_tables_ui <- function(id) {
  ns <- NS(id)
  tagList(
- uiOutput(ns("dynamic_click_tableUI"))
+ uiOutput(ns("dynamic_click_tableUI")) |>
+ shinycssloaders::withSpinner()
  )
 }
 
@@ -27,12 +28,20 @@ mod_click_tables_server <- function(id, filter_data, data_exists, comment_type =
  )
 
  fluidPage(
- h5("Click a row to see comments related to that sub-category"),
- DT::DTOutput(ns("table")) %>%
+ p("The boxes below show the volume of comments/responders in the data 
+ after applying the filters at the side."),
+ mod_summary_record_ui("summary_record_1") |>
+ shinycssloaders::withSpinner(),
+ # hr(),
+ p("This table shows how many comments there are for each 
+ sub-category before you drill down into the underlying comments."),
+ strong("Please click a row to see comments related to that sub-category"),
+ DT::DTOutput(ns("table")) |>
  shinycssloaders::withSpinner(),
  hr(),
  h5("Please select a Sub-category from the table above in other to drill down the table below"),
- uiOutput(ns("comment_table"))
+ uiOutput(ns("comment_table")) |>
+ shinycssloaders::withSpinner()
  )
  })
 
@@ -70,7 +79,7 @@ mod_click_tables_server <- function(id, filter_data, data_exists, comment_type =
 
  print(category_selected)
 
- data <- filter_data()$single_labeled_filter_data %>%
+ data <- filter_data()$single_labeled_filter_data |>
  dplyr::filter(category == category_selected)
  }
 

R/mod_comment_download.R

@@ -47,7 +47,7 @@ mod_comment_download_server <- function(id, return_data, filepath) {
  return(
  tagList(
  fluidRow(
- downloadButton(ns("download_comments"), "Download data",
+ downloadButton(ns("download_comments"), "Download data from table",
  icon = icon("download")
  ),
  DT::DTOutput(ns("dynamic_comment_table"))

R/mod_comment_download_utils_helper.R

@@ -8,6 +8,9 @@ prep_data_for_comment_table <- function(comment_data, in_tidy_format = TRUE) {
  if (in_tidy_format) {
  comment_data <- comment_data %>%
  single_to_multi_label()
+ } else{
+ comment_data <- comment_data %>%
+ clean_super_category()
  }
 
  stopifnot("values in 'comment ID' should be unique. Did you forget to set `in_tidy_format = TRUE`?" = comment_data$comment_id %>% duplicated() %>% sum() == 0)
@@ -31,6 +34,11 @@ prep_data_for_comment_table <- function(comment_data, in_tidy_format = TRUE) {
  )
  }
 
+ comment_data <- comment_data %>%
+ dplyr::mutate(
+ across(any_of(c("comment_type", "fft")), as.factor)
+ )
+
  # rename the column name to be more user friendly
  colnames(comment_data) <- c(
  "Date", "FFT Question", "FFT Score", "Comment Sentiment",
@@ -42,19 +50,32 @@ prep_data_for_comment_table <- function(comment_data, in_tidy_format = TRUE) {
  return(comment_data)
 }
 
+# internal function to color code the sentiment
+sentiment_color_code <- function() {
+ c(
+ Positive = "#009639",
+ `Neutral/Mixed` = "#E8EDEE",
+ Negative = "#DA291C"
+ )
+}
+
 #' Internal function for the comment datatable
 #'
-#' @param data a dataframe
+#' @param data a dataframe, preferable data from `prep_data_for_comment_table()`
+#' @param sentiment_column string, name of the sentiment column in the data
 #' @return a formatted datatable
 #'
 #' @noRd
-render_comment_table <- function(data) {
+render_comment_table <- function(data, sentiment_column = "Comment Sentiment") {
  return(
  DT::datatable(
  data,
  options = list(
  dom = "ipt",
- columnDefs = list(list(width = "500px", targets = c(4))), # ensure the comment column is wider on bigger screen
+ columnDefs = list(
+ list(width = "500px", targets = c(4)), # ensure the comment column is wider on bigger screen
+ list(searchable = FALSE, targets = 0) # remove filtering feature from the first column
+ ),
  initComplete = dt_nhs_header(),
  pageLength = 50,
  scrollX = TRUE,
@@ -63,6 +84,13 @@ render_comment_table <- function(data) {
  filter = "top",
  rownames = FALSE,
  class = "display cell-border compact stripe",
- )
+ ) |>
+ DT::formatStyle(
+ columns = sentiment_column,
+ backgroundColor = DT::styleEqual(
+ names(sentiment_color_code()),
+ sentiment_color_code()
+ )
+ )
  )
 }