169 add functionality for flagging and retrieving flagged comments

NAMESPACE

@@ -6,7 +6,7 @@ export(api_pred)
 export(calculate_table)
 export(clean_dataframe)
 export(demographic_distribution)
-export(drop_na_for_col)
+export(drop_na_by_col)
 export(get_api_pred_url)
 export(get_pred_from_url)
 export(html_decoder)

R/app_server.R

@@ -277,7 +277,7 @@ app_server <- function(input, output, session) {
     # Transform the sentiment column
     return_data <- return_data %>% 
       transform_sentiment() %>% 
-      drop_na_for_col(c('category', 'super_category', 'sentiment'))
+      drop_na_by_col(c('category', 'super_category', 'sentiment'))
 
     # also return a dataset with unique individuals
     unique_data <- return_data %>%

R/golem_utils_server.R

@@ -128,7 +128,7 @@ to_string <- function(x) {
 #' @param column_name The name of the column holding the comma separated labels
 #' @param n_labels maximum number of labels assigned to any row
 #'
-#' @return A dataframe with a row per comment per comment type. columns returned are 
+#' @return A dataframe with a row per comment per comment type. columns returned are
 #' "comment_id", "comment_type", "date", "comment_txt", "fft", "sentiment", "category", "super_category"
 #' @noRd
 single_to_multi_label <- function(sl_data) {
@@ -349,7 +349,7 @@ assign_highlevel_categories <- function(sub_cats) {
   )
 }
 
-#' Attempt to parse a date column from character to date 
+#' Attempt to parse a date column from character to date
 #'
 #' @param data a dataframe
 #' @param date_column the name of the date column (default to 'date')
@@ -358,20 +358,20 @@ assign_highlevel_categories <- function(sub_cats) {
 #'
 #' @noRd
 parse_date <- function(data, date_column = "date") {
-
   if (inherits(data$date, "character")) {
-
-    data <- data %>% 
-      dplyr::filter(date != ' ',
-                    date !='',
-                    !is.na(date))
-
+    data <- data %>%
+      dplyr::filter(
+        date != " ",
+        date != "",
+        !is.na(date)
+      )
+
     suppressWarnings({
       parsed_data <- data %>%
         dplyr::mutate(
           date = lubridate::as_date(.data$date, format = c("%d-%m-%y", "%d/%m/%y", "%d-%m-%Y", "%d/%m/%Y", "%d %m %y", "%d %m %Y"))
         )
-      
+
       # try this if the dates are not well parsed (i.e. if the column contain NA)
       # parse it automatically
       if (any(is.na(parsed_data$date))) {
@@ -381,7 +381,7 @@ parse_date <- function(data, date_column = "date") {
           )
       }
     })
-    
+
     stopifnot("date column can't be parse" = !any(is.na(parsed_data$date)))
     return(parsed_data)
   } else {
@@ -414,15 +414,15 @@ get_sentiment_text <- function(value) {
 #' @param sentiment_column string, name of the sentiment column
 #'
 #' @noRd
-transform_sentiment <- function(data, sentiment_column = 'sentiment') {
+transform_sentiment <- function(data, sentiment_column = "sentiment") {
   data %>%
     dplyr::mutate(sentiment = get_sentiment_text(!!rlang::sym(sentiment_column))) %>%
     dplyr::mutate(
       sentiment = factor(!!rlang::sym(sentiment_column), levels = c("Positive", "Neutral/Mixed", "Negative"))
     )
 }
 
-#' Find rows containing missing values in all specified 
+#' Find rows containing missing values in all specified
 #' column while keeping rows where any contains values
 #'
 #' @param df A data frame
@@ -432,18 +432,39 @@ transform_sentiment <- function(data, sentiment_column = 'sentiment') {
 #'
 #' @return data frame
 #' @export
-drop_na_for_col <- function(df, vars, negate = TRUE) {
-
+drop_na_by_col <- function(df, vars, negate = TRUE) {
   diff <- setdiff(vars, names(df))
   stopifnot("Some column doesn't exist in data" = length(diff) == 0)
-  
+
   if (negate) {
     return(
-      df %>% 
+      df %>%
         dplyr::filter(rowSums(is.na(dplyr::select(., dplyr::all_of(vars)))) != length(vars))
     )
   }
-  
-  df %>% 
+
+  df %>%
     dplyr::filter(rowSums(is.na(dplyr::select(., dplyr::all_of(vars)))) == length(vars))
 }
+
+#' add NHS blue color to the table header
+#' @noRd
+dt_nhs_header <- function() {
+  DT::JS(
+    "function(settings, json) {
+    $(this.api().table().header()).css({'background-color': '#005EB8', 'color': '#fff'});
+    }"
+  )
+}
+
+#' remove the duplicate id in namespace id of sub modules
+#'
+#' @param id ID object passed to the module serve.
+#' see `shiny::moduleServer()`
+#' @param session session object pass to the module server.
+#' see `shiny::moduleServer()`
+#'
+#' @noRd
+get_module_id <- function(id, session) {
+  sub(paste0(id, "$"), "", session$ns(id))
+}

R/golem_utils_ui.R

@@ -195,10 +195,13 @@ jq_hide <- function(id) {
 #' with_red_star("Enter your name here")
 #'
 #' @importFrom htmltools tags HTML
-with_red_star <- function(text) {
+with_red_stars <- function(text) {
   htmltools::tags$span(
     HTML(
       paste0(
+        htmltools::tags$span(
+          style = "color:red", "*"
+        ),
         text,
         htmltools::tags$span(
           style = "color:red", "*"
@@ -310,21 +313,57 @@ col_1 <- function(...) {
 #' #' @importFrom markdown markdownToHTML
 #' #' @importFrom htmltools HTML
 #' includeRMarkdown <- function(path){
+#' #'
+#' #'   md <- tempfile(fileext = '.md')
+#' #'
+#' #'   on.exit(unlink(md),add = TRUE)
+#' #'
+#' #'   rmarkdown::render(
+#' #'     path,
+#' #'     output_format = 'md_document',
+#' #'     output_dir = tempdir(),
+#' #'     output_file = md,quiet = TRUE
+#' #'     )
+#' #'
+#' #'   html <- markdown::markdownToHTML(md, fragment.only = TRUE)
+#' #'
+#' #'   Encoding(html) <- "UTF-8"
+#' #'
+#' #'   return(HTML(html))
+#' #' }
+
+#' Internal function to add 2 group of checkboxs to a datatable
+#' in a sub-module based on values from two columns within the data
 #'
-#'   md <- tempfile(fileext = '.md')
-#'
-#'   on.exit(unlink(md),add = TRUE)
-#'
-#'   rmarkdown::render(
-#'     path,
-#'     output_format = 'md_document',
-#'     output_dir = tempdir(),
-#'     output_file = md,quiet = TRUE
-#'     )
-#'
-#'   html <- markdown::markdownToHTML(md, fragment.only = TRUE)
-#'
-#'   Encoding(html) <- "UTF-8"
+#' @param inputId unique input id to access the box
+#' @param module_id id used to call the module, see `get_module_id()`
+#' @param flag_value integer, value 1 or 0 (from a column containing 1, 0)
+#' used to check (1) or uncheck (0) the box when the table loads
+#' @param bad_value integer, value 1 or 0 from the (from a column containing
+#'  1, 0) used to check (1) or uncheck (0) the box when the table loads
 #'
-#'   return(HTML(html))
-#' }
+#' @return string, A list of HTML elements
+#' @noRd
+add_checkbox_buttons <- function(inputId, module_id, flag_value, bad_value) {
+  flag_value <- ifelse(flag_value, "checked", "uncheck")
+  bad_value <- ifelse(bad_value, "checked", "uncheck")
+
+  glue::glue('
+<div class="form-group">
+  <div class="checkbox">
+    <label>
+      <input id="flag_{inputId}" type="checkbox" class="shiny-input-checkbox"
+       {flag_value} onclick=get_check_info(this,"{module_id}")>
+       <span><i class="fa-solid fa-flag" style="color:green"></i></span>
+    </label>
+  </div>
+  <div class="checkbox">
+    <label>
+      <input id="bad_{inputId}" type="checkbox" class="shiny-input-checkbox"
+       {bad_value} onclick=get_check_info(this,"{module_id}")>
+       <span><i class="fa-solid fa-circle-xmark" style="color:red"></i></span>
+    </label>
+  </div>
+</div>
+')
+}

R/mod_click_tables.R

@@ -21,13 +21,6 @@ mod_click_tables_server <- function(id, filter_data, data_exists, comment_type =
   moduleServer(id, function(input, output, session) {
     ns <- session$ns
 
-    # add NHS blue color to the Datatable header
-    initComplete <- DT::JS(
-      "function(settings, json) {",
-      "$(this.api().table().header()).css({'background-color': '#005EB8', 'color': '#fff'});",
-      "}"
-    )
-
     output$dynamic_click_tableUI <- renderUI({
       validate(
         need(data_exists, "Sub-Category Table will appear here")
@@ -64,7 +57,7 @@ mod_click_tables_server <- function(id, filter_data, data_exists, comment_type =
           lengthMenu = c(10, 15, 20, 50),
           dom = "Blfrtip",
           buttons = c("copy", "csv", "excel", "pdf", "print"),
-          initComplete = initComplete
+          initComplete = dt_nhs_header()
         )
       )
     })

R/mod_comment_download_utils_helper.R

@@ -5,15 +5,14 @@
 #' @return a formatted datatable
 #' @noRd
 prep_data_for_comment_table <- function(comment_data, in_tidy_format = TRUE) {
-
   if (in_tidy_format) {
     comment_data <- comment_data %>%
       single_to_multi_label()
   }
 
   stopifnot("values in 'comment ID' should be unique. Did you forget to set `in_tidy_format = TRUE`?" = comment_data$comment_id %>% duplicated() %>% sum() == 0)
 
-  # Select the important column and format the "category", "super_category", and "comment_type" to be more user friendly 
+  # Select the important column and format the "category", "super_category", and "comment_type" to be more user friendly
   comment_data <- comment_data %>%
     dplyr::select(date, comment_type, fft, sentiment, comment_txt, category, super_category) %>%
     dplyr::mutate(
@@ -50,20 +49,13 @@ prep_data_for_comment_table <- function(comment_data, in_tidy_format = TRUE) {
 #'
 #' @noRd
 render_comment_table <- function(data) {
-  # add NHS blue color to the table header
-  initcomplete <- DT::JS(
-    "function(settings, json) {",
-    "$(this.api().table().header()).css({'background-color': '#005EB8', 'color': '#fff'});",
-    "}"
-  )
-
   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
-        initComplete = initcomplete,
+        initComplete = dt_nhs_header(),
         pageLength = 50,
         scrollX = TRUE,
         selection = "single"