Merge branch 'dev' into ac-95

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: clinsight
 Title: ClinSight
-Version: 0.1.0.9000
+Version: 0.1.0.9004
 Authors@R: c(
     person("Leonard Daniël", "Samson", , "[email protected]", role = c("cre", "aut"),
            comment = c(ORCID = "0000-0002-6252-7639")),

NEWS.md

@@ -1,6 +1,9 @@
 # clinsight (development version)
 
 - Added `pkgdown` GHA workflow to automatically update documentation site with PRs & pushes to `main` and `dev`
+- Generalized `merge_meta_with_data()` to allow user-defined processing functions.
+- Added a feature where, in applicable tables, a user can navigate to a form by double-clicking a table row.
+- Fixed warnings in `apply_edc_specific_changes` due to the use of a vector within `dplyr::select`.
 
 # clinsight 0.1.0
 

R/fct_appdata.R

@@ -64,9 +64,8 @@ get_raw_csv_data <- function(
 merge_meta_with_data <- function(
     data,
     meta,
-    expected_columns = c("LBORNR_Lower", "LBORNR_Upper", "LBORRESU", 
-                         "LBORRESUOTH", "LBREASND", "unit", 
-                         "lower_limit", "upper_limit", "LBCLSIG")
+    expected_columns = c("lower_limit", "upper_limit", "unit", 
+                         "significance", "reason_notdone")
 ){
   stopifnot(is.data.frame(data))
   stopifnot(inherits(meta, "list"))
@@ -75,49 +74,87 @@ merge_meta_with_data <- function(
   synch_time <- attr(data, "synch_time") %||% ""
   merged_data <- data |> 
     rename_raw_data(column_names = meta$column_names) |> 
-    readr::type_convert(clinsight_col_specs) |> 
+    readr::type_convert(clinsight_col_specs) |>
+    apply_custom_functions(meta$settings$pre_merge_fns) |>
     add_timevars_to_data() |> 
     # fix MC values before merging:
     fix_multiple_choice_vars(expected_vars = meta$items_expanded$var) |> 
     dplyr::right_join(meta$items_expanded, by = "var") |> 
-    dplyr::filter(!is.na(item_value)) |> 
+    dplyr::filter(!is.na(item_value)) |>
+    apply_custom_functions(meta$settings$pre_pivot_fns) |>
     dplyr::mutate(
-      suffix = ifelse(item_name == "ECG interpretation", "LBCLSIG", suffix),
-      suffix = ifelse(is.na(suffix), "VAL", suffix),
-      # TODO: improve code below to handle exceptions in a more general manner
-      suffix = ifelse(suffix %in% c("LBORRES", "VSORRES", "EGORRES") | 
-                        item_group %in% c("Cytogenetics", "General"), 
-                      "VAL", suffix)
+      suffix_names = suffix_names %|_|% ifelse(is.na(suffix) | grepl("ORRES$", suffix) | item_group == "General", "VAL", suffix)
     ) |> 
-    dplyr::select(-var) |> 
+    dplyr::select(-var, -suffix) |> 
     dplyr::mutate(
       edit_date_time = max(edit_date_time, na.rm = TRUE), 
       .by = c(subject_id, item_name, event_name, event_repeat)
     ) |> 
-    tidyr::pivot_wider(names_from = suffix, values_from = item_value) |> 
+    tidyr::pivot_wider(names_from = suffix_names, values_from = item_value) |> 
     add_missing_columns(expected_columns) |> 
-    dplyr::mutate(
-      LBORNR_Lower = as.numeric(ifelse(!is.na(lower_limit), lower_limit, LBORNR_Lower)),
-      LBORNR_Upper = as.numeric(ifelse(!is.na(upper_limit), upper_limit, LBORNR_Upper)),
-      LBORRESU     = ifelse(is.na(LBORRESU), unit, LBORRESU),
-      LBORRESU     = ifelse(LBORRESU == "Other", LBORRESUOTH, LBORRESU),
-      LBORRESU     = ifelse(is.na(LBORRESU), "(unit missing)", LBORRESU)
-    ) |> 
-    dplyr::select(-c(lower_limit, upper_limit, unit, LBORRESUOTH)) |> 
+    apply_custom_functions(meta$settings$post_pivot_fns) |>
     dplyr::rename(
-      "lower_lim" = LBORNR_Lower,
-      "upper_lim" = LBORNR_Upper,
-      "item_unit" = LBORRESU,
-      "significance" = LBCLSIG,
-      "item_value" = VAL,
-      "reason_notdone" = LBREASND
+      "lower_lim" = lower_limit,
+      "upper_lim" = upper_limit,
+      "item_unit" = unit,
+      "item_value" = VAL
     ) |> 
-    apply_study_specific_fixes() 
+    dplyr::mutate(region = region %|_|% "Missing") |> 
+    apply_custom_functions(meta$settings$post_merge_fns)
   attr(merged_data, "synch_time") <- synch_time
   merged_data
 }
 
 
+#' Apply study-specific suffix fixes
+#' 
+#' These changes are study/EDC-specific and part of the legacy code for ClinSight.
+#' 
+#' @param data A data frame
+#' 
+#' @return A data frame.
+apply_study_specific_suffix_fixes <- function(data) {
+  dplyr::mutate(data,
+    suffix = ifelse(item_name == "ECG interpretation", "LBCLSIG", suffix),
+    suffix = ifelse(is.na(suffix), "VAL", suffix),
+    # TODO: improve code below to handle exceptions in a more general manner
+    suffix_names = ifelse(suffix %in% c("LBORRES", "VSORRES", "EGORRES") | 
+                      item_group %in% c("Cytogenetics", "General"), 
+                    "VAL", suffix)
+  )
+}
+
+#' Apply EDC-specific suffix fixes
+#' 
+#' These changes are study/EDC-specific and part of the legacy code for ClinSight.
+#' 
+#' @param data A data frame
+#' @param expected_columns A character vector with the columns that should be
+#'   expected in the data frame. If missing, these columns will be added with
+#'   missing data (thus, will be made explicitly missing).
+#' 
+#' @return A data frame.
+apply_edc_specific_changes <- function(
+    data, 
+    expected_columns = c("LBORNR_Lower", "LBORNR_Upper", "LBORRESU", 
+                         "LBORRESUOTH", "LBCLSIG", "LBREASND")
+) {
+  data |> 
+    add_missing_columns(expected_columns) |> 
+    dplyr::mutate(
+      lower_limit    = as.numeric(ifelse(!is.na(lower_limit), lower_limit, LBORNR_Lower)),
+      upper_limit    = as.numeric(ifelse(!is.na(upper_limit), upper_limit, LBORNR_Upper)),
+      LBORRESU       = ifelse(is.na(LBORRESU), unit, LBORRESU),
+      LBORRESU       = ifelse(LBORRESU == "Other", LBORRESUOTH, LBORRESU),
+      LBORRESU       = ifelse(is.na(LBORRESU), "(unit missing)", LBORRESU),
+      unit           = LBORRESU,
+      significance   = LBCLSIG,
+      reason_notdone = LBREASND
+    ) |> 
+    dplyr::select(-dplyr::all_of(expected_columns))
+}
+
+
 #' Apply study-specific fixes
 #'
 #' These changes are probably study-specific and need to be changed accordingly.
@@ -186,6 +223,19 @@ apply_study_specific_fixes <- function(
     )
 }
 
+#' Apply custom modification functions
+#' 
+#' @param data A data frame (for example, raw data merged).
+#' @param functions A character vector containing the names of the functions to
+#'   apply to the data. Default is NULL.
+#' @param .default A character vector containing the names of the functions to
+#'   apply if none are provided. Default is "identity".
+apply_custom_functions <- function(data, functions = NULL, .default = "identity") {
+  Reduce(\(x1, x2) do.call(x2, list(x1)), # Apply next function to output of previous
+         functions %||% .default, # Apply default functions if no additional functions provided
+         init = data) # Initialize with the data object
+}
+
 #' Get appdata
 #'  
 #' Converts data to a list of data frames in the expected format to be used by the 

R/fct_data_helpers.R

@@ -29,6 +29,11 @@ get_metadata <- function(
   meta <- lapply(sheets, function(x){
     readxl::read_excel(filepath, sheet = x, col_types = "text")
   })
+
+  meta$settings <- meta$settings |> 
+    lapply(\(x) as.character(na.omit(x))) |> 
+    Filter(f = length)
+
   if(length(expand_tab_items[nchar(expand_tab_items) > 0 ] ) == 0) return(meta)
   if("items_expanded" %in% names(meta)) warning({
     "Table 'items_expanded' already present. The old table will be overwritten."
@@ -146,31 +151,31 @@ add_timevars_to_data <- function(
     dplyr::mutate(
       edit_date_time = as.POSIXct(edit_date_time, tz = "UTC"),
       event_date = as.Date(event_date),
-      day = event_date - min(event_date, na.rm = TRUE), 
-      vis_day = ifelse(event_id %in% c("SCR", "VIS", "VISEXT", "VISVAR", "FU1", "FU2"), day, NA),
+      day = day %|_|% {event_date - min(event_date, na.rm = TRUE)}, 
+      vis_day = ifelse(grepl("^SCR|^VIS|^FU", event_id, ignore.case = TRUE), day, NA),
       vis_num = as.numeric(factor(vis_day))-1,
-      event_name = dplyr::case_when(
-        event_id == "SCR"    ~ "Screening",
-        event_id %in% c("VIS", "VISEXT", "VISVAR")    ~ paste0("Visit ", vis_num),
-        grepl("^FU[[:digit:]]+", event_id)  ~ paste0("Visit ", vis_num, "(FU)"),
-        event_id == "UN"     ~ paste0("Unscheduled visit ", event_repeat),
-        event_id == "EOT"    ~ "EoT",
-        event_id == "EXIT"   ~ "Exit",
-        form_id %in% c("AE", "CM", "CP", "MH", "MH", "MHTR", "PR", "ST", "CMTR", "CMHMA") ~ "Any visit",
-        TRUE                ~ paste0("Other (", event_name, ")")
+      event_name = event_name %|_|% dplyr::case_when(
+        grepl("^SCR", event_id, ignore.case = TRUE) ~ "Screening",
+        grepl("^VIS", event_id, ignore.case = TRUE) ~ paste0("Visit ", vis_num),
+        grepl("^FU[[:digit:]]+", event_id, ignore.case = TRUE) ~ paste0("Visit ", vis_num, "(FU)"),
+        grepl("^UN", event_id, ignore.case = TRUE) ~ paste0("Unscheduled visit ", event_repeat),
+        toupper(event_id) == "EOT"    ~ "EoT",
+        toupper(event_id) == "EXIT"   ~ "Exit",
+        grepl("^AE|^CM|^CP|^MH|^PR|^ST", form_id) ~ "Any visit",
+        .default = paste0("Other (", event_id, ")")
       ),
-      event_label = dplyr::case_when(
+      event_label = event_label %|_|% dplyr::case_when(
         !is.na(vis_num)   ~ paste0("V", vis_num),
-        event_id == "UN"   ~ paste0("UV", event_repeat),
-        TRUE              ~ event_name
+        grepl("^UN", event_id, ignore.case = TRUE)   ~ paste0("UV", event_repeat),
+        .default = event_name
       ),
       .by = subject_id
     ) |> 
     dplyr::arrange(
       factor(site_code, levels = order_string(site_code)),
       factor(subject_id, levels = order_string(subject_id))
     )
-  if(any(grepl("^Other ", df$event_name))) warning(
+  if(any(is.na(df$event_name) | grepl("^Other ", df$event_name))) warning(
     "Undefined Events detected. Please verify data before proceeding."
   )
   df

R/fct_utils.R

@@ -706,3 +706,14 @@ custom_config_path <- function(
 ){
   Sys.getenv("CONFIG_PATH", app_sys("golem-config.yml")) 
 }
+
+dblclick_to_form <- function(bttn_ns) {
+  DT::JS(
+    "table.on('dblclick', 'tbody tr', function(t) {",
+    "t.currentTarget.classList.add('selected');",
+    "var tblID = $(t.target).closest('.datatables').attr('id')",
+    "var inputName = tblID + '_rows_selected'",
+    "Shiny.setInputValue(inputName, t.currentTarget.rowIndex)",
+    "document.getElementById(", deparse(NS(bttn_ns, "go_to_form")), ").click();",
+    "})"
+  )}

R/global.R

@@ -109,7 +109,9 @@ utils::globalVariables(
     "unit", 
     "vars", 
     "vis_day",
-    "event_id"
+    "event_id",
+    "region",
+    "suffix_names"
   )
 )
 

R/golem_utils_server.R

@@ -52,3 +52,21 @@ drop_nulls <- function(x) {
     x
   }
 }
+
+#' If x does not exist, return y, otherwise return x
+#' 
+#' @param x,y two elements to test, one potentially not existent
+#' @param verbose logical, indicating whether warning message should be displayed.
+#' 
+#' @noRd
+#' 
+#' @examples
+#' mtcars2 %|_|% mtcars
+"%|_|%" <- function(x, y, verbose = TRUE) {
+  if (exists(deparse1(substitute(x)), envir = parent.frame())) {
+    if (verbose) cat("Using user supplied", deparse(deparse1(substitute(x))), "instead of deriving.\n")
+    x
+  } else {
+    y
+  }
+}

R/mod_navigate_review.R

@@ -129,7 +129,8 @@ mod_navigate_review_server <- function(
       df <- modal_rev_data() 
       df[["reviewed"]] <- NULL 
       if(!input$show_all_data) df$subject_id <- NULL
-      datatable_custom(df, table_names)
+      datatable_custom(df, table_names,
+                       callback = dblclick_to_form(ns("go_to_form")))
     }) 
 
     queries_table_data <- reactive({

R/mod_queries.R

@@ -147,7 +147,8 @@ mod_queries_server <- function(id, r, navinfo, all_forms, db_path, table_names){
       datatable_custom(
         initial_queries()[query_cols], 
         table_names, 
-        title = table_title
+        title = table_title,
+        callback = dblclick_to_form(ns("go_to_form"))
       )
     })
 

R/mod_start_page.R

@@ -86,7 +86,8 @@ mod_start_page_server <- function(id, r, rev_data, navinfo, all_forms, table_nam
       bold_rows <- which(rev_data$overview()[["needs_review"]])
       tab <- datatable_custom(
         dplyr::select(rev_data$overview(), -needs_review), 
-        rename_vars = table_names
+        rename_vars = table_names,
+        callback = dblclick_to_form(ns("go_to_patient"))
       )
       if(length(bold_rows) == 0) return(tab)
       DT::formatStyle(

data-raw/internal_data.R

@@ -34,7 +34,6 @@ clinsight_col_specs <- c(
   "subject_id" = "c", 
   "event_id" = "c", 
   "event_date" = "D", 
-  "event_name" = "c", 
   "event_repeat" = "i", 
   "form_id" = "c", 
   "form_repeat" = "i", 

inst/golem-config.yml

@@ -1,6 +1,6 @@
 default:
   golem_name: clinsight
-  golem_version: 0.1.0.9000
+  golem_version: 0.1.0.9005
   app_prod: no
   user_identification: test_user
   study_data: !expr clinsight::clinsightful_data