diff --git a/DESCRIPTION b/DESCRIPTION index 4eccaca8..7d77ce90 100644 --- a/DESCRIPTION +++ b/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", , "lsamson@gcp-service.com", role = c("cre", "aut"), comment = c(ORCID = "0000-0002-6252-7639")), diff --git a/NEWS.md b/NEWS.md index 3f0648d4..54711f0f 100644 --- a/NEWS.md +++ b/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 diff --git a/R/fct_appdata.R b/R/fct_appdata.R index f0ab2b9a..9dfe2e27 100644 --- a/R/fct_appdata.R +++ b/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 diff --git a/R/fct_data_helpers.R b/R/fct_data_helpers.R index eb3555b9..d627d244 100644 --- a/R/fct_data_helpers.R +++ b/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,23 +151,23 @@ 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 ) |> @@ -170,7 +175,7 @@ add_timevars_to_data <- function( 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 diff --git a/R/fct_utils.R b/R/fct_utils.R index bac5e9ab..112b1509 100644 --- a/R/fct_utils.R +++ b/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();", + "})" + )} diff --git a/R/global.R b/R/global.R index 777d21a2..68e661f1 100644 --- a/R/global.R +++ b/R/global.R @@ -109,7 +109,9 @@ utils::globalVariables( "unit", "vars", "vis_day", - "event_id" + "event_id", + "region", + "suffix_names" ) ) diff --git a/R/golem_utils_server.R b/R/golem_utils_server.R index 69be451b..907d64cd 100644 --- a/R/golem_utils_server.R +++ b/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 + } +} diff --git a/R/mod_navigate_review.R b/R/mod_navigate_review.R index 5e14bf03..1d9afdbf 100644 --- a/R/mod_navigate_review.R +++ b/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({ diff --git a/R/mod_queries.R b/R/mod_queries.R index 4160a406..f5e45da4 100644 --- a/R/mod_queries.R +++ b/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")) ) }) diff --git a/R/mod_start_page.R b/R/mod_start_page.R index cd926ced..6301cd2c 100644 --- a/R/mod_start_page.R +++ b/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( diff --git a/R/sysdata.rda b/R/sysdata.rda index 0e2f6218..aaebb8b1 100644 Binary files a/R/sysdata.rda and b/R/sysdata.rda differ diff --git a/data-raw/internal_data.R b/data-raw/internal_data.R index a388f16d..08b35fb6 100644 --- a/data-raw/internal_data.R +++ b/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", diff --git a/data-raw/metadata.xlsx b/data-raw/metadata.xlsx index 182428f7..60b2fea7 100644 Binary files a/data-raw/metadata.xlsx and b/data-raw/metadata.xlsx differ diff --git a/data/metadata.rda b/data/metadata.rda index c26affad..63c728e4 100644 Binary files a/data/metadata.rda and b/data/metadata.rda differ diff --git a/inst/golem-config.yml b/inst/golem-config.yml index d45b8ce7..75b2d72f 100644 --- a/inst/golem-config.yml +++ b/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 diff --git a/man/apply_custom_functions.Rd b/man/apply_custom_functions.Rd new file mode 100644 index 00000000..fbd645bf --- /dev/null +++ b/man/apply_custom_functions.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fct_appdata.R +\name{apply_custom_functions} +\alias{apply_custom_functions} +\title{Apply custom modification functions} +\usage{ +apply_custom_functions(data, functions = NULL, .default = "identity") +} +\arguments{ +\item{data}{A data frame (for example, raw data merged).} + +\item{functions}{A character vector containing the names of the functions to +apply to the data. Default is NULL.} + +\item{.default}{A character vector containing the names of the functions to +apply if none are provided. Default is "identity".} +} +\description{ +Apply custom modification functions +} diff --git a/man/apply_edc_specific_changes.Rd b/man/apply_edc_specific_changes.Rd new file mode 100644 index 00000000..4c056f89 --- /dev/null +++ b/man/apply_edc_specific_changes.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fct_appdata.R +\name{apply_edc_specific_changes} +\alias{apply_edc_specific_changes} +\title{Apply EDC-specific suffix fixes} +\usage{ +apply_edc_specific_changes( + data, + expected_columns = c("LBORNR_Lower", "LBORNR_Upper", "LBORRESU", "LBORRESUOTH", + "LBCLSIG", "LBREASND") +) +} +\arguments{ +\item{data}{A data frame} + +\item{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).} +} +\value{ +A data frame. +} +\description{ +These changes are study/EDC-specific and part of the legacy code for ClinSight. +} diff --git a/man/apply_study_specific_suffix_fixes.Rd b/man/apply_study_specific_suffix_fixes.Rd new file mode 100644 index 00000000..7aa7b9e1 --- /dev/null +++ b/man/apply_study_specific_suffix_fixes.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fct_appdata.R +\name{apply_study_specific_suffix_fixes} +\alias{apply_study_specific_suffix_fixes} +\title{Apply study-specific suffix fixes} +\usage{ +apply_study_specific_suffix_fixes(data) +} +\arguments{ +\item{data}{A data frame} +} +\value{ +A data frame. +} +\description{ +These changes are study/EDC-specific and part of the legacy code for ClinSight. +} diff --git a/man/merge_meta_with_data.Rd b/man/merge_meta_with_data.Rd index de890352..80a3dbb5 100644 --- a/man/merge_meta_with_data.Rd +++ b/man/merge_meta_with_data.Rd @@ -7,8 +7,8 @@ merge_meta_with_data( 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") ) } \arguments{ diff --git a/tests/testthat/_snaps/app_feature_01/app-feature-1-001.json b/tests/testthat/_snaps/app_feature_01/app-feature-1-001.json index 5ff57208..bd076b6a 100644 --- a/tests/testthat/_snaps/app_feature_01/app-feature-1-001.json +++ b/tests/testthat/_snaps/app_feature_01/app-feature-1-001.json @@ -83,7 +83,6 @@ ] }, "main_sidebar_1-synch_info-db_synch_info": "EDC Sync date:
2023-09-15 10:10:00 UTC

EDC latest data: 2023-09-14 15:17:00", - "navigate_participants_1-status": "BEL_04_772<\/b>
Sex:<\/b> Male
Age:<\/b> 78yrs.
Status:<\/b> Enrolled
ECOG:<\/b> 0
Dx:<\/b> Syndrome O", "navigate_participants_1-subject_info": { "html": "
\n
\n
\n
\n <\/i>\n <\/div>\n
\n

BEL_08_45<\/p>\n

Male, 64yrs.<\/p>\n <\/div>\n <\/div>\n <\/div>\n