From 1ce7869aebea083ef126d2a0327760788fd612e3 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski <114988527+chlebowa@users.noreply.github.com> Date: Tue, 3 Jan 2023 14:50:29 +0100 Subject: [PATCH] `shinyvalidate` improvements (#199) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Closes [this issue](https://github.com/insightsengineering/teal.osprey/issues/185) Following the introduction of `validate_inputs` to `teal` by [#199](https://github.com/insightsengineering/teal/pull/786), this PR: + changes all possible input validations from `validate` calls to `shinyvalidate` input validators + passes all validators to `validate_input` funcitons Signed-off-by: Aleksander Chlebowski <114988527+chlebowa@users.noreply.github.com> Co-authored-by: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Co-authored-by: Nikolas Burkoff Co-authored-by: Dawid Kałędkowski Co-authored-by: 27856297+dependabot-preview[bot]@users.noreply.github.com <27856297+dependabot-preview[bot]@users.noreply.github.com> --- DESCRIPTION | 5 +- NEWS.md | 4 + R/tm_g_ae_oview.R | 142 +++-- R/tm_g_ae_sub.R | 170 +++--- R/tm_g_butterfly.R | 235 +++---- R/tm_g_events_term_id.R | 64 +- R/tm_g_heat_bygrade.R | 267 ++++---- R/tm_g_patient_profile.R | 1153 ++++++++++++++++------------------- R/tm_g_spiderplot.R | 73 ++- R/tm_g_swimlane.R | 93 ++- R/tm_g_waterfall.R | 146 +++-- README.md | 2 + man/tm_g_butterfly.Rd | 4 +- man/tm_g_heat_bygrade.Rd | 2 +- man/tm_g_patient_profile.Rd | 78 +-- man/tm_g_swimlane.Rd | 4 +- man/tm_g_waterfall.Rd | 4 +- 17 files changed, 1176 insertions(+), 1270 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 62b8650d..2c7857ac 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -23,7 +23,7 @@ Depends: osprey (>= 0.1.15), R (>= 3.6), shiny, - teal (>= 0.12.0) + teal (>= 0.12.0.9013) Imports: checkmate, dplyr, @@ -31,7 +31,6 @@ Imports: ggplot2, lifecycle, logger (>= 0.2.0), - purrr, shinyvalidate, teal.code (>= 0.2.0), teal.logger (>= 0.1.1), @@ -65,4 +64,4 @@ Encoding: UTF-8 Language: en-US LazyData: true Roxygen: list(markdown = TRUE) -RoxygenNote: 7.2.1 +RoxygenNote: 7.2.3 diff --git a/NEWS.md b/NEWS.md index 5c37d3a9..05fa8f78 100644 --- a/NEWS.md +++ b/NEWS.md @@ -3,12 +3,16 @@ * Examples now use `scda.2022` instead of `scda.2021`. * Fixed crash in `tm_g_heat_bygrade` when not plotting `Conmed`. * Added validation to `tm_g_spiderplot.R` that checks if there are duplicates in X and Y facet variables. +* Improved input validation and used the `teal::validate_inputs` mechanism to send validation messages to the output panel. +* Removed `purrr` from dependencies. +* Added argument checks to `tm_g_patient_profile`. ### Breaking changes * Replaced `chunks` with simpler `qenv` class. * Replaced `datasets` argument containing `FilteredData` with the new arguments `data` (`tdata` object) and `filter_panel_api` (`FilterPanelAPI`). * Updated `arm_var` to point to the factor column in `ANL`. It can't be a character column anymore. +* Removed redundant formal arguments from `tm_g_patient_profile`. # teal.osprey 0.1.15 diff --git a/R/tm_g_ae_oview.R b/R/tm_g_ae_oview.R index be0dc970..f00265d8 100644 --- a/R/tm_g_ae_oview.R +++ b/R/tm_g_ae_oview.R @@ -120,7 +120,10 @@ tm_g_ae_oview <- function(label, ) ) checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) - checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") + checkmate::assert_numeric(plot_height[1], + lower = plot_height[2], upper = plot_height[3], + .var.name = "plot_height" + ) checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) checkmate::assert_numeric( plot_width[1], @@ -232,14 +235,35 @@ srv_g_ae_oview <- function(id, checkmate::assert_class(data, "tdata") moduleServer(id, function(input, output, session) { - iv <- shinyvalidate::InputValidator$new() - iv$add_rule("arm_var", shinyvalidate::sv_required()) - iv$add_rule("flag_var_anl", shinyvalidate::sv_required( - message = "Please select at least one flag" - )) - iv$enable() + iv <- reactive({ + ANL <- data[[dataname]]() # nolint - decorate_output <- srv_g_decorate(id = NULL, plt = plot_r, plot_height = plot_height, plot_width = plot_width) + iv <- shinyvalidate::InputValidator$new() + iv$add_rule("arm_var", shinyvalidate::sv_required( + message = "Arm Variable is required" + )) + iv$add_rule("arm_var", ~ if (!is.factor(ANL[[.]])) { + "Arm Var must be a factor variable" + }) + iv$add_rule("arm_var", ~ if (nlevels(ANL[[.]]) < 2L) { + "Selected Arm Var must have at least two levels" + }) + iv$add_rule("flag_var_anl", shinyvalidate::sv_required( + message = "At least one Flag is required" + )) + rule_diff <- function(value, other) { + if (isTRUE(value == other)) "Control and Treatment must be different" + } + iv$add_rule("arm_trt", rule_diff, other = input$arm_ref) + iv$add_rule("arm_ref", rule_diff, other = input$arm_trt) + iv$enable() + iv + }) + + decorate_output <- srv_g_decorate( + id = NULL, plt = plot_r, + plot_height = plot_height, plot_width = plot_width + ) font_size <- decorate_output$font_size pws <- decorate_output$pws @@ -283,69 +307,53 @@ srv_g_ae_oview <- function(id, ) }) - output_q <- reactive({ - ANL <- data[[dataname]]() # nolint - validate(need(iv$is_valid(), "Misspecification error: please observe red flags in the encodings.")) - validate(need( - is.factor(ANL[[input$arm_var]]), - "Selected arm variable needs to be a factor." - )) - validate(need(input$flag_var_anl, "Please select at least one flag.")) - iv_comp <- shinyvalidate::InputValidator$new() - iv_comp$add_rule("arm_trt", shinyvalidate::sv_not_equal( - input$arm_ref, - message_fmt = "Must not be equal to Control" - )) - iv_comp$add_rule("arm_ref", shinyvalidate::sv_not_equal( - input$arm_trt, - message_fmt = "Must not be equal to Treatment" - )) - iv_comp$enable() + output_q <- shiny::debounce( + millis = 200, + r = reactive({ + ANL <- data[[dataname]]() # nolint - validate(need(iv_comp$is_valid(), "Misspecification error: please observe red flags in the encodings.")) - validate(need(nlevels(ANL[[input$arm_var]]) > 1, "Arm needs to have at least 2 levels")) - validate_has_data(ANL, min_nrow = 10) - if (all(c(input$arm_trt, input$arm_ref) %in% ANL[[input$arm_var]])) { - iv_an <- shinyvalidate::InputValidator$new() - iv_an$add_rule("arm_ref", shinyvalidate::sv_in_set(set = ANL[[input$arm_var]])) - iv_an$add_rule("arm_trt", shinyvalidate::sv_in_set(set = ANL[[input$arm_var]])) - iv_an$enable() - validate(need(iv_an$is_valid(), "Misspecification error: please observe red flags in the encodings.")) - } - validate(need(all(c(input$arm_trt, input$arm_ref) %in% unique(ANL[[input$arm_var]])), "Plot loading")) + teal::validate_has_data(ANL, min_nrow = 10, msg = sprintf("%s has not enough data", dataname)) - q1 <- teal.code::eval_code( - teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)), - code = as.expression(c( - bquote(anl_labels <- formatters::var_labels(.(as.name(dataname)), fill = FALSE)), - bquote(flags <- .(as.name(dataname)) %>% - select(all_of(.(input$flag_var_anl))) %>% - rename_at(vars(.(input$flag_var_anl)), function(x) paste0(x, ": ", anl_labels[x]))) - )) - ) + teal::validate_inputs(iv()) - teal.code::eval_code( - q1, - code = as.expression(c( - bquote( - plot <- osprey::g_events_term_id( - term = flags, - id = .(as.name(dataname))[["USUBJID"]], - arm = .(as.name(dataname))[[.(input$arm_var)]], - arm_N = table(ADSL[[.(input$arm_var)]]), - ref = .(input$arm_ref), - trt = .(input$arm_trt), - diff_ci_method = .(input$diff_ci_method), - conf_level = .(input$conf_level), - axis_side = .(input$axis), - fontsize = .(font_size()), - draw = TRUE - ) - ), - quote(plot) + validate(need( + input$arm_trt %in% ANL[[input$arm_var]] && input$arm_ref %in% ANL[[input$arm_var]], + "Treatment or Control not found in Arm Variable. Perhaps they have been filtered out?" )) - ) - }) + + q1 <- teal.code::eval_code( + teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)), + code = as.expression(c( + bquote(anl_labels <- formatters::var_labels(.(as.name(dataname)), fill = FALSE)), + bquote(flags <- .(as.name(dataname)) %>% + select(all_of(.(input$flag_var_anl))) %>% + rename_at(vars(.(input$flag_var_anl)), function(x) paste0(x, ": ", anl_labels[x]))) + )) + ) + + teal.code::eval_code( + q1, + code = as.expression(c( + bquote( + plot <- osprey::g_events_term_id( + term = flags, + id = .(as.name(dataname))[["USUBJID"]], + arm = .(as.name(dataname))[[.(input$arm_var)]], + arm_N = table(ADSL[[.(input$arm_var)]]), + ref = .(input$arm_ref), + trt = .(input$arm_trt), + diff_ci_method = .(input$diff_ci_method), + conf_level = .(input$conf_level), + axis_side = .(input$axis), + fontsize = .(font_size()), + draw = TRUE + ) + ), + quote(plot) + )) + ) + }) + ) plot_r <- reactive(output_q()[["plot"]]) diff --git a/R/tm_g_ae_sub.R b/R/tm_g_ae_sub.R index fea6541d..07f38635 100644 --- a/R/tm_g_ae_sub.R +++ b/R/tm_g_ae_sub.R @@ -184,9 +184,33 @@ srv_g_ae_sub <- function(id, checkmate::assert_class(data, "tdata") moduleServer(id, function(input, output, session) { - iv <- shinyvalidate::InputValidator$new() - iv$add_rule("arm_var", shinyvalidate::sv_required()) - iv$enable() + iv <- reactive({ + ANL <- data[[dataname]]() # nolint + ADSL <- data[["ADSL"]]() # nolint + + iv <- shinyvalidate::InputValidator$new() + iv$add_rule("arm_var", shinyvalidate::sv_required( + message = "Arm Variable is required" + )) + iv$add_rule("arm_var", ~ if (!is.factor(ANL[[.]])) { + "Arm Var must be a factor variable, contact developer" + }) + rule_diff <- function(value, other) { + if (isTRUE(value == other)) "Control and Treatment must be different" + } + iv$add_rule("arm_trt", rule_diff, other = input$arm_ref) + iv$add_rule("arm_ref", rule_diff, other = input$arm_trt) + iv$add_rule("groups", shinyvalidate::sv_in_set( + names(ANL), + message_fmt = sprintf("Groups must be a variable in %s", dataname) + )) + iv$add_rule("groups", shinyvalidate::sv_in_set( + names(ADSL), + message_fmt = "Groups must be a variable in ADSL" + )) + iv$enable() + iv + }) decorate_output <- srv_g_decorate( id = NULL, @@ -286,91 +310,69 @@ srv_g_ae_sub <- function(id, }) }) - output_q <- reactive({ - ANL <- data[[dataname]]() # nolint - ADSL <- data[["ADSL"]]() # nolint - validate_has_data(ANL, min_nrow = 10) - iv_comp <- shinyvalidate::InputValidator$new() - iv_comp$add_rule("arm_trt", shinyvalidate::sv_not_equal( - input$arm_ref, - message_fmt = "Must not be equal to Control" - )) - iv_comp$add_rule("arm_ref", shinyvalidate::sv_not_equal( - input$arm_trt, - message_fmt = "Must not be equal to Treatment" - )) - iv_comp$enable() - validate(need(iv_comp$is_valid(), "Misspecification error: please observe red flags in the encodings.")) - - validate(need(iv$is_valid(), "Misspecification error: please observe red flags in the encodings.")) - validate(need( - is.factor(ANL[[input$arm_var]]), - "Selected arm variable needs to be a factor. Contact the app developer." - )) - validate( - need( - all(c(input$arm_trt, input$arm_ref) %in% levels(ADSL[[input$arm_var]])), - "Updating treatment and control selections." - ) - ) - validate( - need( - all(c(input$arm_trt, input$arm_ref) %in% levels(ANL[[input$arm_var]])), - "The dataset does not contain subjects with AE events from both the control and treatment arms." - ), - need( - all(input$groups %in% names(ANL)) & all(input$groups %in% names(ADSL)), - "Check all selected subgroups are columns in ADAE and ADSL." - ) - ) + output_q <- shiny::debounce( + millis = 200, + r = reactive({ + ANL <- data[[dataname]]() # nolint + ADSL <- data[["ADSL"]]() # nolint - group_labels <- lapply(seq_along(input$groups), function(x) { - items <- input[[sprintf("groups__%s", x)]] - if (length(items) > 0) { - l <- lapply(seq_along(items), function(y) { - input[[sprintf("groups__%s__level__%s", x, y)]] - }) - names(l) <- items - l[["Total"]] <- input[[sprintf("groups__%s__level__%s", x, "all")]] - l - } - }) + teal::validate_has_data(ANL, min_nrow = 10, msg = sprintf("%s has not enough data", dataname)) - group_labels_call <- if (length(unlist(group_labels)) == 0) { - quote(group_labels <- NULL) - } else { - bquote(group_labels <- setNames(.(group_labels), .(input$groups))) - } + teal::validate_inputs(iv()) - q1 <- teal.code::eval_code( - teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)), - code = group_labels_call - ) - q2 <- teal.code::eval_code(q1, code = "") - teal.code::eval_code( - q2, - code = as.expression(c( - bquote( - plot <- osprey::g_ae_sub( - id = .(as.name(dataname))$USUBJID, - arm = as.factor(.(as.name(dataname))[[.(input$arm_var)]]), - arm_sl = as.character(ADSL[[.(input$arm_var)]]), - trt = .(input$arm_trt), - ref = .(input$arm_ref), - subgroups = .(as.name(dataname))[.(input$groups)], - subgroups_sl = ADSL[.(input$groups)], - subgroups_levels = group_labels, - conf_level = .(input$conf_level), - diff_ci_method = .(input$ci), - fontsize = .(font_size()), - arm_n = .(input$arm_n), - draw = TRUE - ) - ), - quote(plot) + validate(need( + input$arm_trt %in% ANL[[input$arm_var]] && input$arm_ref %in% ANL[[input$arm_var]], + "Treatment or Control not found in Arm Variable. Perhaps they have been filtered out?" )) - ) - }) + + group_labels <- lapply(seq_along(input$groups), function(x) { + items <- input[[sprintf("groups__%s", x)]] + if (length(items) > 0) { + l <- lapply(seq_along(items), function(y) { + input[[sprintf("groups__%s__level__%s", x, y)]] + }) + names(l) <- items + l[["Total"]] <- input[[sprintf("groups__%s__level__%s", x, "all")]] + l + } + }) + + group_labels_call <- if (length(unlist(group_labels)) == 0) { + quote(group_labels <- NULL) + } else { + bquote(group_labels <- setNames(.(group_labels), .(input$groups))) + } + + q1 <- teal.code::eval_code( + teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)), + code = group_labels_call + ) + q2 <- teal.code::eval_code(q1, code = "") + teal.code::eval_code( + q2, + code = as.expression(c( + bquote( + plot <- osprey::g_ae_sub( + id = .(as.name(dataname))$USUBJID, + arm = as.factor(.(as.name(dataname))[[.(input$arm_var)]]), + arm_sl = as.character(ADSL[[.(input$arm_var)]]), + trt = .(input$arm_trt), + ref = .(input$arm_ref), + subgroups = .(as.name(dataname))[.(input$groups)], + subgroups_sl = ADSL[.(input$groups)], + subgroups_levels = group_labels, + conf_level = .(input$conf_level), + diff_ci_method = .(input$ci), + fontsize = .(font_size()), + arm_n = .(input$arm_n), + draw = TRUE + ) + ), + quote(plot) + )) + ) + }) + ) plot_r <- reactive(output_q()[["plot"]]) diff --git a/R/tm_g_butterfly.R b/R/tm_g_butterfly.R index 627fc490..063b6f1b 100644 --- a/R/tm_g_butterfly.R +++ b/R/tm_g_butterfly.R @@ -81,11 +81,11 @@ #' dataname = "ADAE", #' right_var = choices_selected( #' selected = "SEX", -#' choices = c("DOSE", "SEX", "ARM", "RACE", "flag1", "flag2", "flag3") +#' choices = c("SEX", "ARM", "RACE") #' ), #' left_var = choices_selected( #' selected = "RACE", -#' choices = c("DOSE", "SEX", "ARM", "RACE", "flag1", "flag2", "flag3") +#' choices = c("SEX", "ARM", "RACE") #' ), #' category_var = choices_selected(selected = "AEBODSYS", choices = c("AEDECOD", "AEBODSYS")), #' color_by_var = choices_selected(selected = "AETOXGR", choices = c("AETOXGR", "None")), @@ -269,11 +269,35 @@ srv_g_butterfly <- function(id, data, filter_panel_api, reporter, dataname, labe checkmate::assert_class(data, "tdata") moduleServer(id, function(input, output, session) { - iv <- shinyvalidate::InputValidator$new() - iv$add_rule("category_var", shinyvalidate::sv_required()) - iv$add_rule("right_var", shinyvalidate::sv_required()) - iv$add_rule("left_var", shinyvalidate::sv_required()) - iv$enable() + iv <- reactive({ + ADSL <- data[["ADSL"]]() # nolint + ANL <- data[[dataname]]() # nolint + + iv <- shinyvalidate::InputValidator$new() + iv$add_rule("category_var", shinyvalidate::sv_required( + message = "Category Variable is required" + )) + iv$add_rule("right_var", shinyvalidate::sv_required( + message = "Right Dichotomization Variable is required" + )) + iv$add_rule("left_var", shinyvalidate::sv_required( + message = "Left Dichotomization Variable is required" + )) + iv$add_rule("right_var", ~ if (!is.factor(ANL[[.]])) { + "Right Dichotomization Variable must be a factor variable, contact developer" + }) + iv$add_rule("left_var", ~ if (!is.factor(ANL[[.]])) { + "Left Dichotomization Variable must be a factor variable, contact developer" + }) + iv$add_rule("right_val", shinyvalidate::sv_required( + message = "At least one value of Right Dichotomization Variable must be selected" + )) + iv$add_rule("left_val", shinyvalidate::sv_required( + message = "At least one value of Left Dichotomization Variable must be selected" + )) + iv$enable() + iv + }) options <- reactiveValues(r = NULL, l = NULL) vars <- reactiveValues(r = NULL, l = NULL) @@ -356,133 +380,118 @@ srv_g_butterfly <- function(id, data, filter_panel_api, reporter, dataname, labe ignoreNULL = FALSE ) - output_q <- reactive({ - ADSL <- data[["ADSL"]]() # nolint - ANL <- data[[dataname]]() # nolint + output_q <- shiny::debounce( + millis = 200, + r = reactive({ + ADSL <- data[["ADSL"]]() # nolint + ANL <- data[[dataname]]() # nolint - right_var <- isolate(input$right_var) - left_var <- isolate(input$left_var) - right_val <- input$right_val - left_val <- input$left_val - category_var <- input$category_var - color_by_var <- input$color_by_var - count_by_var <- input$count_by_var - legend_on <- input$legend_on - facet_var <- input$facet_var - sort_by_var <- input$sort_by_var - filter_var <- input$filter_var + teal::validate_has_data(ADSL, min_nrow = 0, msg = sprintf("%s Data is empty", "ADSL")) + teal::validate_has_data(ANL, min_nrow = 0, msg = sprintf("%s Data is empty", dataname)) - iv_len <- shinyvalidate::InputValidator$new() - iv_len$add_rule("right_val", shinyvalidate::sv_required("Please select at least one")) - iv_len$add_rule("left_val", shinyvalidate::sv_required("Please select at least one")) - iv_len$enable() - validate(need(iv_len$is_valid(), "Misspecification error: please observe red flags in the encodings.")) - - validate( - need(category_var, "Please select a category variable."), - need(nrow(ADSL) > 0, "ADSL Data has no rows"), - need(nrow(ANL) > 0, "ADAE Data has no rows"), - need(right_var, "'Right Dichotomization Variable' not selected"), - need(left_var, "'Left Dichotomization Variable' not selected") - ) + teal::validate_inputs(iv()) - validate( - need(length(right_val) > 0, "No values of 'Right Dichotomization Variable' are checked"), - need(length(left_val) > 0, "No values of 'Left Dichotomization Variable' are checked"), - need( - is.factor(ANL[[right_var]]), - "Selected 'Right Dichotomization Variable' variable needs to be a factor. Contact an app developer." - ), - need( - is.factor(ANL[[left_var]]), - "Selected 'Right Dichotomization Variable' variable needs to be a factor. Contact an app developer." - ), - need( - any(c(ADSL[[right_var]] %in% right_val, ADSL[[left_var]] %in% left_val)), - "ADSL Data contains no rows with either of the selected left or right dichotomization values (filtered out?)" + validate( + need( + all(input$right_val %in% ADSL[[input$right_var]]) && + all(input$left_val %in% ADSL[[input$left_var]]), + "No observations for selected dichotomization values (filtered out?)" + ) ) - ) - # if variable is not in ADSL, then take from domain VADs - varlist <- c(category_var, color_by_var, facet_var, filter_var, right_var, left_var) - varlist_from_adsl <- intersect(varlist, names(ADSL)) - varlist_from_anl <- intersect(varlist, setdiff(names(ANL), names(ADSL))) + right_var <- isolate(input$right_var) + left_var <- isolate(input$left_var) + right_val <- input$right_val + left_val <- input$left_val + category_var <- input$category_var + color_by_var <- input$color_by_var + count_by_var <- input$count_by_var + legend_on <- input$legend_on + facet_var <- input$facet_var + sort_by_var <- input$sort_by_var + filter_var <- input$filter_var - adsl_vars <- unique(c("USUBJID", "STUDYID", varlist_from_adsl)) # nolint - anl_vars <- unique(c("USUBJID", "STUDYID", varlist_from_anl)) # nolint + # if variable is not in ADSL, then take from domain VADs + varlist <- c(category_var, color_by_var, facet_var, filter_var, right_var, left_var) + varlist_from_adsl <- intersect(varlist, names(ADSL)) + varlist_from_anl <- intersect(varlist, setdiff(names(ANL), names(ADSL))) - q1 <- teal.code::eval_code( - teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)), - code = bquote({ - ADSL <- ADSL[, .(adsl_vars)] %>% as.data.frame() # nolint - ANL <- .(as.name(dataname))[, .(anl_vars)] %>% as.data.frame() # nolint - }) - ) + adsl_vars <- unique(c("USUBJID", "STUDYID", varlist_from_adsl)) # nolint + anl_vars <- unique(c("USUBJID", "STUDYID", varlist_from_anl)) # nolint - if (!("NULL" %in% filter_var) && !is.null(filter_var)) { q1 <- teal.code::eval_code( - q1, - code = bquote( - ANL <- quick_filter(.(filter_var), ANL) %>% # nolint - droplevels() %>% - as.data.frame() - ) + teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)), + code = bquote({ + ADSL <- ADSL[, .(adsl_vars)] %>% as.data.frame() # nolint + ANL <- .(as.name(dataname))[, .(anl_vars)] %>% as.data.frame() # nolint + }) ) - } - q1 <- teal.code::eval_code( - q1, - code = bquote({ - ANL_f <- left_join(ADSL, ANL, by = c("USUBJID", "STUDYID")) %>% as.data.frame() # nolint - ANL_f <- na.omit(ANL_f) # nolint - }) - ) + if (!("NULL" %in% filter_var) && !is.null(filter_var)) { + q1 <- teal.code::eval_code( + q1, + code = bquote( + ANL <- quick_filter(.(filter_var), ANL) %>% # nolint + droplevels() %>% + as.data.frame() + ) + ) + } - if (!is.null(right_val) && !is.null(right_val)) { q1 <- teal.code::eval_code( q1, code = bquote({ - right <- ANL_f[, .(right_var)] %in% .(right_val) - right_name <- paste(.(right_val), collapse = " - ") - left <- ANL_f[, .(left_var)] %in% .(left_val) - left_name <- paste(.(left_val), collapse = " - ") + ANL_f <- left_join(ADSL, ANL, by = c("USUBJID", "STUDYID")) %>% as.data.frame() # nolint + ANL_f <- na.omit(ANL_f) # nolint }) ) - } - if (!is.null(right_val) && !is.null(left_val)) { - q1 <- teal.code::eval_code( - q1, - code = bquote( - plot <- osprey::g_butterfly( - category = ANL_f[, .(category_var)], - right_flag = right, - left_flag = left, - group_names = c(right_name, left_name), - block_count = .(count_by_var), - block_color = .(if (color_by_var != "None") { - bquote(ANL_f[, .(color_by_var)]) - } else { - NULL - }), - id = ANL_f$USUBJID, - facet_rows = .(if (!is.null(facet_var)) { - bquote(ANL_f[, .(facet_var)]) - } else { - NULL - }), - x_label = .(count_by_var), - y_label = .(category_var), - legend_label = .(color_by_var), - sort_by = .(sort_by_var), - show_legend = .(legend_on) + if (!is.null(right_val) && !is.null(right_val)) { + q1 <- teal.code::eval_code( + q1, + code = bquote({ + right <- ANL_f[, .(right_var)] %in% .(right_val) + right_name <- paste(.(right_val), collapse = " - ") + left <- ANL_f[, .(left_var)] %in% .(left_val) + left_name <- paste(.(left_val), collapse = " - ") + }) + ) + } + + if (!is.null(right_val) && !is.null(left_val)) { + q1 <- teal.code::eval_code( + q1, + code = bquote( + plot <- osprey::g_butterfly( + category = ANL_f[, .(category_var)], + right_flag = right, + left_flag = left, + group_names = c(right_name, left_name), + block_count = .(count_by_var), + block_color = .(if (color_by_var != "None") { + bquote(ANL_f[, .(color_by_var)]) + } else { + NULL + }), + id = ANL_f$USUBJID, + facet_rows = .(if (!is.null(facet_var)) { + bquote(ANL_f[, .(facet_var)]) + } else { + NULL + }), + x_label = .(count_by_var), + y_label = .(category_var), + legend_label = .(color_by_var), + sort_by = .(sort_by_var), + show_legend = .(legend_on) + ) ) ) - ) - } + } - teal.code::eval_code(q1, quote(plot)) - }) + teal.code::eval_code(q1, quote(plot)) + }) + ) plot_r <- reactive(output_q()[["plot"]]) diff --git a/R/tm_g_events_term_id.R b/R/tm_g_events_term_id.R index 6417b332..ff4da4e3 100644 --- a/R/tm_g_events_term_id.R +++ b/R/tm_g_events_term_id.R @@ -213,10 +213,22 @@ srv_g_events_term_id <- function(id, checkmate::assert_class(data, "tdata") moduleServer(id, function(input, output, session) { - iv <- shinyvalidate::InputValidator$new() - iv$add_rule("arm_var", shinyvalidate::sv_required()) - iv$add_rule("term", shinyvalidate::sv_required()) - iv$enable() + iv <- reactive({ + iv <- shinyvalidate::InputValidator$new() + iv$add_rule("term", shinyvalidate::sv_required( + message = "Term Variable is required" + )) + iv$add_rule("arm_var", shinyvalidate::sv_required( + message = "Arm Variable is required" + )) + rule_diff <- function(value, other) { + if (isTRUE(value == other)) "Control and Treatment must be different" + } + iv$add_rule("arm_trt", rule_diff, other = input$arm_ref) + iv$add_rule("arm_ref", rule_diff, other = input$arm_trt) + iv$enable() + iv + }) decorate_output <- srv_g_decorate( id = NULL, plt = plot_r, plot_height = plot_height, plot_width = plot_width @@ -241,7 +253,7 @@ srv_g_events_term_id <- function(id, observeEvent(input$sort, - handlerExpr = { + { sort <- if (is.null(input$sort)) " " else input$sort updateTextInput( session, @@ -261,14 +273,12 @@ srv_g_events_term_id <- function(id, ) observeEvent(input$arm_var, - ignoreNULL = TRUE, - handlerExpr = { + { arm_var <- input$arm_var ANL <- data[[dataname]]() # nolint choices <- levels(ANL[[arm_var]]) - validate(need(length(choices) > 0, "Please include multiple treatment")) if (length(choices) == 1) { trt_index <- 1 } else { @@ -287,35 +297,22 @@ srv_g_events_term_id <- function(id, selected = choices[trt_index], choices = choices ) - } + }, + ignoreNULL = TRUE ) output_q <- reactive({ ANL <- data[[dataname]]() # nolint - validate(need(iv$is_valid(), "Misspecification error: please observe red flags in the encodings.")) - - validate(need( - is.factor(ANL[[input$arm_var]]), - "Selected arm variable needs to be a factor. Contact an app developer." - )) + teal::validate_inputs(iv()) - iv_comp <- shinyvalidate::InputValidator$new() - iv_comp$add_rule("arm_trt", shinyvalidate::sv_not_equal( - input$arm_ref, - message_fmt = "Must not be equal to Control" - )) - iv_comp$add_rule("arm_ref", shinyvalidate::sv_not_equal( - input$arm_trt, - message_fmt = "Must not be equal to Treatment" - )) - iv_comp$enable() - validate(need(iv_comp$is_valid(), "Misspecification error: please observe red flags in the encodings.")) - - validate(need( - all(c(input$arm_trt, input$arm_ref) %in% unique(ANL[[input$arm_var]])), - "Cannot generate plot. The dataset does not contain subjects from both the control and treatment arms." - )) + shiny::validate( + shiny::need(is.factor(ANL[[input$arm_var]]), "Arm Var must be a factor variable. Contact developer."), + shiny::need( + input$arm_trt %in% ANL[[req(input$arm_var)]] && input$arm_ref %in% ANL[[req(input$arm_var)]], + "Cannot generate plot. The dataset does not contain subjects from both the control and treatment arms." + ) + ) adsl_vars <- unique(c("USUBJID", "STUDYID", input$arm_var)) # nolint anl_vars <- c("USUBJID", "STUDYID", input$term) # nolint @@ -333,7 +330,10 @@ srv_g_events_term_id <- function(id, ) ) - validate(need(nrow(q1[["ANL"]]) > 10, "ANL needs at least 10 data points")) + teal::validate_has_data(q1[["ANL"]], + min_nrow = 10, + msg = "Analysis data set must have at least 10 data points" + ) q2 <- teal.code::eval_code( q1, diff --git a/R/tm_g_heat_bygrade.R b/R/tm_g_heat_bygrade.R index dad9f1a2..0f871268 100644 --- a/R/tm_g_heat_bygrade.R +++ b/R/tm_g_heat_bygrade.R @@ -151,7 +151,7 @@ tm_g_heat_bygrade <- function(label, sl_dataname, ex_dataname, ae_dataname, - cm_dataname, + cm_dataname = NA, id_var, visit_var, ongo_var, @@ -265,7 +265,13 @@ ui_g_heatmap_bygrade <- function(id, ...) { helpText("Plot conmed"), div( class = "pretty-left-border", - uiOutput(ns("plot_cm_output")) + if (!is.na(args$cm_dataname)) { + checkboxInput( + ns("plot_cm"), + "Yes", + value = !is.na(args$cm_dataname) + ) + } ), conditionalPanel( paste0("input['", ns("plot_cm"), "']"), @@ -313,144 +319,167 @@ srv_g_heatmap_bygrade <- function(id, with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") checkmate::assert_class(data, "tdata") + if (!is.na(sl_dataname)) checkmate::assert_names(sl_dataname, subset.of = names(data)) + if (!is.na(ex_dataname)) checkmate::assert_names(ex_dataname, subset.of = names(data)) + if (!is.na(ae_dataname)) checkmate::assert_names(ae_dataname, subset.of = names(data)) + if (!is.na(cm_dataname)) checkmate::assert_names(cm_dataname, subset.of = names(data)) moduleServer(id, function(input, output, session) { - iv <- shinyvalidate::InputValidator$new() - iv$add_rule("heat_var", shinyvalidate::sv_required()) - iv$add_rule("id_var", shinyvalidate::sv_required()) - iv$add_rule("visit_var", shinyvalidate::sv_required()) - iv$add_rule("ongo_var", shinyvalidate::sv_required()) - iv$enable() - - decorate_output <- srv_g_decorate(id = NULL, plt = plot_r, plot_height = plot_height, plot_width = plot_width) # nolint - font_size <- decorate_output$font_size - pws <- decorate_output$pws - - observeEvent(cm_dataname, { - if (!is.na(cm_dataname)) { - output$plot_cm_output <- renderUI({ - checkboxInput( - session$ns("plot_cm"), - "Yes", - value = !is.na(cm_dataname) - ) - }) + iv <- reactive({ + ADSL <- data[[sl_dataname]]() # nolint + ADEX <- data[[ex_dataname]]() # nolint + ADAE <- data[[ae_dataname]]() # nolint + if (isTRUE(input$plot_cm)) { + ADCM <- data[[cm_dataname]]() # nolint } - }) - - observeEvent(input$plot_cm, { - ADCM <- data[[cm_dataname]]() # nolint - req(input$conmed_var) - choices <- levels(ADCM[[input$conmed_var]]) - updateSelectInput( - session, - "conmed_level", - selected = choices[1:3], - choices = choices - ) + iv <- shinyvalidate::InputValidator$new() + iv$add_rule("id_var", shinyvalidate::sv_required( + message = "ID Variable is required" + )) + iv$add_rule("visit_var", shinyvalidate::sv_required( + message = "Visit Variable is required" + )) + iv$add_rule("ongo_var", shinyvalidate::sv_required( + message = "Study Ongoing Status Variable is required" + )) + iv$add_rule("ongo_var", shinyvalidate::sv_in_set( + set = names(ADEX), + message_fmt = sprintf("Study Ongoing Status must be a variable in %s", ex_dataname) + )) + iv$add_rule("ongo_var", ~ if (!is.logical(ADEX[[req(.)]])) { + "Study Ongoing Status must be a logical variable" + }) + iv$add_rule("anno_var", shinyvalidate::sv_required( + message = "Annotation Variables is required" + )) + iv$add_rule("anno_var", ~ if (length(.) > 2L) { + "No more than two Annotation Variables are allowed" + }) + iv$add_rule("anno_var", shinyvalidate::sv_in_set( + set = names(ADSL), + message_fmt = sprintf("Study Ongoing Status must be a variable in %s", sl_dataname) + )) + iv$add_rule("anno_var", ~ if (isTRUE(input$id_var %in% .)) { + sprintf("Deselect %s in Annotation Variables", input$id_var) + }) + iv$add_rule("heat_var", shinyvalidate::sv_required( + message = "Heat Variable is required" + )) + iv$enable() + iv }) - - output_q <- reactive({ - iv_len <- shinyvalidate::InputValidator$new() - anno_var <- input$anno_var - iv_len$add_rule("anno_var", function(x) if (length(x) > 2) "Please include no more than 2 annotation variables.") - iv_len$enable() - validate(need(iv_len$is_valid(), "Misspecification error: please observe red flags in the encodings.")) - validate(need(iv$is_valid(), "Misspecification error: please observe red flags in the encodings.")) - + iv_cm <- reactive({ ADSL <- data[[sl_dataname]]() # nolint ADEX <- data[[ex_dataname]]() # nolint ADAE <- data[[ae_dataname]]() # nolint + if (isTRUE(input$plot_cm)) { + ADCM <- data[[cm_dataname]]() # nolint + } - validate(need(nrow(ADSL) > 0, "Please select at least one subject")) - validate(need( - input$ongo_var %in% names(ADEX), - paste("Study Ongoing Status must be a variable in", ex_dataname, sep = " ") + iv_cm <- shinyvalidate::InputValidator$new() + iv_cm$condition(~ isTRUE(input$plot_cm)) + iv_cm$add_rule("conmed_var", shinyvalidate::sv_required( + message = "Conmed Variable is required" )) - - validate(need( - checkmate::test_logical(ADEX[[input$ongo_var]], min.len = 1, any.missing = FALSE), - "Study Ongoing Status must be a logical variable" + iv_cm$add_rule("conmed_var", shinyvalidate::sv_in_set( + set = names(ADCM), + message_fmt = sprintf("Conmed Variable must be a variable in %s", cm_dataname) )) - - validate(need( - all(anno_var %in% names(ADSL)), - paste("Please only select annotation variable(s) in", sl_dataname, sep = " ") + iv_cm$add_rule("conmed_var", ~ if (!is.factor(ADCM[[.]])) { + "Study Ongoing Status must be a factor variable" + }) + iv_cm$add_rule("conmed_level", shinyvalidate::sv_required( + "Select Conmed Levels" )) + iv_cm$add_rule("conmed_level", ~ if (length(.) > 3L) { + "No more than three Conmed Levels are allowed" + }) + iv_cm$enable() + iv_cm + }) - validate(need( - !(input$id_var %in% anno_var), - paste("Please de-select", input$id_var, "in annotation variable(s)", sep = " ") - )) + decorate_output <- srv_g_decorate( + id = NULL, + plt = plot_r, + plot_height = plot_height, + plot_width = plot_width + ) # nolint + font_size <- decorate_output$font_size + pws <- decorate_output$pws - if (isTRUE(input$plot_cm)) { + if (!is.na(cm_dataname)) { + observeEvent(input$conmed_var, { ADCM <- data[[cm_dataname]]() # nolint - validate( - need( - input$conmed_var %in% names(ADCM), - paste("Please select a Conmed Variable in", cm_dataname, sep = " ") - ) + choices <- levels(ADCM[[input$conmed_var]]) + + updateSelectInput( + session, + "conmed_level", + selected = choices[1:3], + choices = choices ) - validate(need( - is.factor(ADCM[[input$conmed_var]]), - "Conmed Variable should be a factor" - )) - validate(need( - all(input$conmed_level %in% levels(ADCM[[input$conmed_var]])), - "Updating Conmed Levels" - )) - } + }) + } - q1 <- if (isTRUE(input$plot_cm)) { - iv_cm <- shinyvalidate::InputValidator$new() - conmed_var <- input$conmed_var - iv_cm$add_rule("conmed_var", shinyvalidate::sv_required()) - iv_cm$enable() - validate(need(iv_cm$is_valid(), "Misspecification error: please observe red flags in the encodings.")) + output_q <- shiny::debounce( + millis = 200, + r = reactive({ + ADSL <- data[[sl_dataname]]() # nolint + ADEX <- data[[ex_dataname]]() # nolint + ADAE <- data[[ae_dataname]]() # nolint - teal.code::eval_code( - teal.code::new_qenv(tdata2env(data), code = teal::get_code_tdata(data)), - code = bquote({ - conmed_data <- ADCM %>% - filter(!!sym(.(conmed_var)) %in% .(input$conmed_level)) - conmed_var <- .(conmed_var) - conmed_data[[conmed_var]] <- - factor(conmed_data[[conmed_var]], levels = unique(conmed_data[[conmed_var]])) - formatters::var_labels(conmed_data)[conmed_var] <- - formatters::var_labels(ADCM, fill = FALSE)[conmed_var] - }) - ) - } else { - teal.code::eval_code( - teal.code::new_qenv(tdata2env(data), code = teal.code::get_code(data)), - code = quote(conmed_data <- conmed_var <- NULL) - ) - } + teal::validate_has_data(ADSL, min_nrow = 1, msg = sprintf("%s contains no data", sl_dataname)) + teal::validate_inputs(iv(), iv_cm()) + if (isTRUE(input$plot_cm)) { + shiny::validate(shiny::need(all(input$conmed_level %in% ADCM[[input$conmed_var]]), "Updating Conmed Levels")) + } - validate( - need(length(input$conmed_level) <= 3, "Please select no more than 3 conmed levels") - ) + qenv <- teal.code::new_qenv(tdata2env(data), code = teal::get_code_tdata(data)) + if (isTRUE(input$plot_cm)) { + ADCM <- data[[cm_dataname]]() # nolint + qenv <- teal.code::eval_code( + qenv, + code = substitute( + env = list( + ADCM = as.name(cm_dataname), + conmed_var = input$conmed_var, + conmed_var_name = as.name(input$conmed_var), + conmed_level = input$conmed_level + ), + expr = { + conmed_data <- ADCM %>% + filter(conmed_var_name %in% conmed_level) + conmed_data[[conmed_var]] <- + factor(conmed_data[[conmed_var]], levels = unique(conmed_data[[conmed_var]])) + formatters::var_labels(conmed_data)[conmed_var] <- + formatters::var_labels(ADCM, fill = FALSE)[conmed_var] + } + ) + ) + } - q2 <- teal.code::eval_code( - q1, - code = bquote({ - plot <- osprey::g_heat_bygrade( - id_var = .(input$id_var), - exp_data = ADEX %>% filter(PARCAT1 == "INDIVIDUAL"), - visit_var = .(input$visit_var), - ongo_var = .(input$ongo_var), - anno_data = ADSL[c(.(input$anno_var), .(input$id_var))], - anno_var = .(input$anno_var), - heat_data = ADAE %>% select(!!.(input$id_var), !!.(input$visit_var), !!.(input$heat_var)), - heat_color_var = .(input$heat_var), - conmed_data = conmed_data, - conmed_var = conmed_var + qenv <- teal.code::eval_code( + qenv, + code = bquote( + plot <- osprey::g_heat_bygrade( + id_var = .(input$id_var), + exp_data = .(as.name(ex_dataname)) %>% filter(PARCAT1 == "INDIVIDUAL"), + visit_var = .(input$visit_var), + ongo_var = .(input$ongo_var), + anno_data = .(as.name(sl_dataname))[c(.(input$anno_var), .(input$id_var))], + anno_var = .(input$anno_var), + heat_data = .(as.name(ae_dataname)) %>% + select(.(as.name(input$id_var)), .(as.name(input$visit_var)), .(as.name(input$heat_var))), + heat_color_var = .(input$heat_var), + conmed_data = .(if (isTRUE(input$plot_cm)) as.name("conmed_data")), + conmed_var = .(if (isTRUE(input$plot_cm)) input$conmed_var), + ) ) - }) - ) - teal.code::eval_code(q2, quote(plot)) - }) + ) + teal.code::eval_code(qenv, quote(plot)) + }) + ) plot_r <- reactive(output_q()[["plot"]]) diff --git a/R/tm_g_patient_profile.R b/R/tm_g_patient_profile.R index 11a48d4a..242a88cf 100644 --- a/R/tm_g_patient_profile.R +++ b/R/tm_g_patient_profile.R @@ -11,57 +11,35 @@ #' @param sl_dataname (\code{character}) subject level dataset name, #' needs to be available in the list passed to the \code{data} #' argument of \code{\link[teal]{init}} -#' @param ex_dataname (\code{character}) exposures dataset name, -#' needs to be available in the list passed to the \code{data} -#' argument of \code{\link[teal]{init}} \cr -#' specify to \code{NA} if no exposure data is available -#' @param ae_dataname (\code{character}) adverse events dataset name, -#' needs to be available in the list passed to the \code{data} -#' argument of \code{\link[teal]{init}} \cr -#' specify to \code{NA} if no adverse events data is available -#' @param rs_dataname (\code{character}) response dataset name, -#' needs to be available in the list passed to the \code{data} -#' argument of \code{\link[teal]{init}} \cr -#' specify to \code{NA} if no response data is available -#' @param cm_dataname (\code{character}) concomitant medications dataset name, -#' needs to be available in the list passed to the \code{data} -#' argument of \code{\link[teal]{init}} \cr -#' specify to \code{NA} if no concomitant medications data is available -#' @param lb_dataname (\code{character}) labs dataset name, -#' needs to be available in the list passed to the \code{data} -#' argument of \code{\link[teal]{init}} \cr -#' specify to \code{NA} if no labs data is available -#' @param show_ex_plot boolean value of whether exposures plot is shown, -#' default is \code{TRUE} -#' @param show_ae_plot boolean value of whether adverse events plot is shown, -#' default is \code{TRUE} -#' @param show_rs_plot boolean value of whether response plot is shown, -#' default is \code{TRUE} -#' @param show_cm_plot boolean value of whether concomitant medications -#' plot is shown, default is \code{TRUE} -#' @param show_lb_plot boolean value of whether labs plot is shown, -#' default is \code{TRUE} -#' @param sl_start_date (\code{choices_selected}) study start date variable, usually set to treatment -#' start date or randomization date +#' @param ex_dataname,ae_dataname,rs_dataname,cm_dataname,lb_dataname +#' (\code{character(1)}) names of exposure, adverse events, response, +#' concomitant medications, and labs datasets, respectively; +#' must be available in the list passed to the \code{data} +#' argument of \code{\link[teal]{init}}\cr +#' set to NA (default) to omit from analysis +#' @param sl_start_date (\code{choices_selected}) study start date variable, usually set to +#' treatment start date or randomization date #' @param ex_var (\code{choices_selected}) exposure variable to plot as each line \cr -#' leave unspecified or set to \code{NULL} if exposure data is not available +#' leave unspecified or set to \code{NULL} if exposure data is not available #' @param ae_var (\code{choices_selected}) adverse event variable to plot as each line \cr -#' leave unspecified or set to \code{NULL} if adverse events data is not available +#' leave unspecified or set to \code{NULL} if adverse events data is not available #' @param ae_line_col_var (\code{choices_selected}) variable for coloring AE lines \cr -#' leave unspecified or set to \code{NULL} if adverse events data is not available -#' @param ae_line_col_opt aesthetic values to map color values (named vector to map color values to each name). -#' If not \code{NULL}, please make sure this contains all possible values for \code{ae_line_col_var} values. \cr -#' leave unspecified or set to \code{NULL} if adverse events data is not available +#' leave unspecified or set to \code{NULL} if adverse events data is not available +#' @param ae_line_col_opt aesthetic values to map color values +#' (named vector to map color values to each name). +#' If not \code{NULL}, please make sure this contains all possible +#' values for \code{ae_line_col_var} values. \cr +#' leave unspecified or set to \code{NULL} if adverse events data is not available #' @param rs_var (\code{choices_selected}) response variable to plot as each line \cr -#' leave unspecified or set to \code{NULL} if response data is not available +#' leave unspecified or set to \code{NULL} if response data is not available #' @param cm_var (\code{choices_selected}) concomitant medication variable -#' to plot as each line \cr -#' leave unspecified or set to \code{NULL} if concomitant medications data is not available +#' to plot as each line \cr +#' leave unspecified or set to \code{NULL} if concomitant medications data is not available #' @param lb_var (\code{choices_selected}) lab variable to plot as each line \cr -#' leave unspecified or set to \code{NULL} if labs data is not available +#' leave unspecified or set to \code{NULL} if labs data is not available #' @param x_limit a single \code{character} string with two numbers -#' separated by a comma indicating the x-axis limit, -#' default is \code{"-28, 365"} +#' separated by a comma indicating the x-axis limit, +#' default is \code{"-28, 365"} #' #' @author Xuefeng Hou (houx14) \email{houx14@gene.com} #' @author Tina Cho (chot) \email{tina.cho@roche.com} @@ -119,7 +97,7 @@ #' LBSTRESN = as.numeric(LBSTRESC) #' ) #' -#' x <- init( +#' app <- init( #' data = cdisc_data( #' cdisc_dataset("ADSL", ADSL, #' code = "ADSL <- synthetic_cdisc_data(\"latest\")$adsl" @@ -165,11 +143,6 @@ #' rs_dataname = "ADRS", #' cm_dataname = "ADCM", #' lb_dataname = "ADLB", -#' show_ex_plot = TRUE, -#' show_ae_plot = TRUE, -#' show_rs_plot = TRUE, -#' show_cm_plot = FALSE, -#' show_lb_plot = TRUE, #' sl_start_date = choices_selected( #' selected = "TRTSDTM", #' choices = c("TRTSDTM", "RANDDT") @@ -205,22 +178,17 @@ #' ) #' ) #' if (interactive()) { -#' shinyApp(x$ui, x$server) +#' shinyApp(app$ui, app$server) #' } #' tm_g_patient_profile <- function(label = "Patient Profile Plot", patient_id, sl_dataname, - ex_dataname, - ae_dataname, - rs_dataname, - cm_dataname, - lb_dataname, - show_ex_plot = TRUE, - show_ae_plot = TRUE, - show_rs_plot = TRUE, - show_cm_plot = TRUE, - show_lb_plot = TRUE, + ex_dataname = NA, + ae_dataname = NA, + rs_dataname = NA, + cm_dataname = NA, + lb_dataname = NA, sl_start_date, ex_var = NULL, ae_var = NULL, @@ -242,6 +210,9 @@ tm_g_patient_profile <- function(label = "Patient Profile Plot", checkmate::assert_string(rs_dataname, na.ok = TRUE) checkmate::assert_string(cm_dataname, na.ok = TRUE) checkmate::assert_string(lb_dataname, na.ok = TRUE) + checkmate::assert_character(c(sl_dataname, ex_dataname, rs_dataname, cm_dataname, lb_dataname), + any.missing = TRUE, all.missing = FALSE + ) checkmate::assert_class(sl_start_date, classes = "choices_selected") checkmate::assert_class(ex_var, classes = "choices_selected", null.ok = TRUE) checkmate::assert_class(ae_var, classes = "choices_selected", null.ok = TRUE) @@ -285,7 +256,7 @@ tm_g_patient_profile <- function(label = "Patient Profile Plot", ui_g_patient_profile <- function(id, ...) { a <- list(...) ns <- NS(id) - + checkboxes <- c(a$ex_dataname, a$ae_dataname, a$rs_dataname, a$lb_dataname, a$cm_dataname) shiny::tagList( include_css_files("custom"), @@ -304,14 +275,16 @@ ui_g_patient_profile <- function(id, ...) { choices = a$patient_id$choices, selected = a$patient_id$selected ), - helpText("Select", tags$code("ADaM"), "Domains"), div( - class = "pretty-left-border", - uiOutput(ns("select_ae_output")), - uiOutput(ns("select_ex_output")), - uiOutput(ns("select_rs_output")), - uiOutput(ns("select_cm_output")), - uiOutput(ns("select_lb_output")) + tagList( + helpText("Select", tags$code("ADaM"), "Domains"), + checkboxGroupInput( + inputId = ns("select_ADaM"), + label = NULL, + choices = checkboxes[!is.na(checkboxes)], + selected = checkboxes[!is.na(checkboxes)] + ) + ) ), teal.widgets::optionalSelectInput( ns("sl_start_date"), @@ -324,7 +297,8 @@ ui_g_patient_profile <- function(id, ...) { ) ), conditionalPanel( - paste0("input['", ns("select_ex"), "']"), + condition = sprintf("input['select_ADaM'].includes('%s')", a$ex_dataname), + ns = ns, selectInput( ns("ex_var"), "Exposure variable", @@ -334,7 +308,8 @@ ui_g_patient_profile <- function(id, ...) { ) ), conditionalPanel( - paste0("input['", ns("select_ae"), "']"), + condition = sprintf("input['select_ADaM'].includes('%s')", a$ae_dataname), + ns = ns, teal.widgets::optionalSelectInput( ns("ae_var"), "Adverse Event variable", @@ -351,7 +326,8 @@ ui_g_patient_profile <- function(id, ...) { ) ), conditionalPanel( - paste0("input['", ns("select_rs"), "']"), + condition = sprintf("input['select_ADaM'].includes('%s')", a$rs_dataname), + ns = ns, teal.widgets::optionalSelectInput( ns("rs_var"), "Tumor response variable", @@ -361,7 +337,8 @@ ui_g_patient_profile <- function(id, ...) { ) ), conditionalPanel( - paste0("input['", ns("select_cm"), "']"), + condition = sprintf("input['select_ADaM'].includes('%s')", a$cm_dataname), + ns = ns, teal.widgets::optionalSelectInput( ns("cm_var"), "Concomitant medicine variable", @@ -371,7 +348,8 @@ ui_g_patient_profile <- function(id, ...) { ) ), conditionalPanel( - paste0("input['", ns("select_lb"), "']"), + condition = sprintf("input['select_ADaM'].includes('%s')", a$lb_dataname), + ns = ns, teal.widgets::optionalSelectInput( ns("lb_var"), "Lab variable", @@ -424,647 +402,538 @@ srv_g_patient_profile <- function(id, with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelApi") checkmate::assert_class(data, "tdata") - + if (!is.na(ex_dataname)) checkmate::assert_names(ex_dataname, subset.of = names(data)) + if (!is.na(ae_dataname)) checkmate::assert_names(ae_dataname, subset.of = names(data)) + if (!is.na(rs_dataname)) checkmate::assert_names(rs_dataname, subset.of = names(data)) + if (!is.na(lb_dataname)) checkmate::assert_names(lb_dataname, subset.of = names(data)) + if (!is.na(cm_dataname)) checkmate::assert_names(cm_dataname, subset.of = names(data)) + checkboxes <- c(ex_dataname, ae_dataname, rs_dataname, lb_dataname, cm_dataname) moduleServer(id, function(input, output, session) { - iv <- shinyvalidate::InputValidator$new() - iv$add_rule("sl_start_date", shinyvalidate::sv_required()) - iv$add_rule("lb_var_show", shinyvalidate::sv_required()) - iv$add_rule("ae_var", shinyvalidate::sv_required()) - iv$enable() + select_plot <- reactive( + vapply(checkboxes, function(x) x %in% input$select_ADaM, logical(1L)) + ) - # only show the check box when domain data is available - observeEvent(ae_dataname, { - if (!is.na(ae_dataname)) { - output$select_ae_output <- renderUI({ - checkboxInput( - session$ns("select_ae"), - "ADAE", - value = !is.na(ae_dataname) - ) - }) - } - }) + if (!is.na(lb_dataname)) { + observeEvent(input$lb_var, ignoreNULL = TRUE, { + ADLB <- data[[lb_dataname]]() # nolint + choices <- unique(ADLB[[input$lb_var]]) + choices_selected <- if (length(choices) > 5) choices[1:5] else choices + + updateSelectInput( + session, + "lb_var_show", + selected = choices_selected, + choices = choices + ) + }) + } - observeEvent(ex_dataname, { - if (!is.na(ex_dataname)) { - output$select_ex_output <- renderUI({ - checkboxInput( - session$ns("select_ex"), - "ADEX", - value = !is.na(ex_dataname) - ) - }) + iv <- reactive({ + iv <- shinyvalidate::InputValidator$new() + iv$add_rule("select_ADaM", shinyvalidate::sv_required( + message = "At least one ADaM data set is required" + )) + iv$add_rule("sl_start_date", shinyvalidate::sv_required( + message = "Date variable is required" + )) + if (isTRUE(select_plot()[ex_dataname])) { + iv$add_rule("ex_var", shinyvalidate::sv_required( + message = "Exposure variable is required" + )) } - }) - - observeEvent(rs_dataname, { - if (!is.na(rs_dataname)) { - output$select_rs_output <- renderUI({ - checkboxInput( - session$ns("select_rs"), - "ADRS", - value = !is.na(rs_dataname) - ) + if (isTRUE(select_plot()[ae_dataname])) { + iv$add_rule("ae_var", shinyvalidate::sv_required( + message = "Adverse Event variable is required" + )) + iv$add_rule("ae_line_var", shinyvalidate::sv_optional()) + iv$add_rule("ae_line_var", ~ if (length(levels(data[[ae_dataname]]()[[.]])) > length(ae_line_col_opt)) { + "Not enough colors provided for Adverse Event line color, unselect" }) } - }) - - observeEvent(cm_dataname, { - if (!is.na(cm_dataname)) { - output$select_cm_output <- renderUI({ - checkboxInput( - session$ns("select_cm"), - "ADCM", - value = !is.na(cm_dataname) - ) - }) + if (isTRUE(select_plot()[rs_dataname])) { + iv$add_rule("rs_var", shinyvalidate::sv_required( + message = "Tumor response variable is required" + )) } - }) - - observeEvent(lb_dataname, { - if (!is.na(lb_dataname)) { - output$select_lb_output <- renderUI({ - checkboxInput( - session$ns("select_lb"), - "ADLB", - value = !is.na(lb_dataname) - ) - }) + if (isTRUE(select_plot()[cm_dataname])) { + iv$add_rule("cm_var", shinyvalidate::sv_required( + message = "Concomitant medicine variable is required" + )) } - }) - - observeEvent(input$select_lb, { - req(input$select_lb == TRUE && !is.null(input$lb_var)) - ADLB <- data[[lb_dataname]]() # nolint - choices <- unique(ADLB[[input$lb_var]]) - choices_selected <- if (length(choices) > 5) choices[1:5] else choices - - updateSelectInput( - session, - "lb_var_show", - selected = choices_selected, - choices = choices - ) + if (isTRUE(select_plot()[lb_dataname])) { + iv$add_rule("lb_var", shinyvalidate::sv_required( + message = "Lab variable is required" + )) + iv$add_rule("lb_var_show", shinyvalidate::sv_required( + message = "At least one Lab value is required" + )) + rule_diff <- function(value, other) { + if (isTRUE(any(value == other))) { + "Lab variable and Lab value must be different" + } + } + iv$add_rule("lb_var", rule_diff, other = input$lb_var_show) + iv$add_rule("lb_var_show", rule_diff, other = input$lb_var) + } + iv$add_rule("x_limit", shinyvalidate::sv_required( + message = "Study Days Range is required" + )) + iv$add_rule("x_limit", ~ if (anyNA(suppressWarnings(as_numeric_from_comma_sep_str(.)))) { + "Study Days Range is invalid" + }) + iv$add_rule("x_limit", ~ if (length(suppressWarnings(as_numeric_from_comma_sep_str(.))) != 2L) { + "Study Days Range must be two values" + }) + iv$add_rule("x_limit", ~ if (!identical(order(suppressWarnings(as_numeric_from_comma_sep_str(.))), 1:2)) { + "Study Days Range mut be: first lower, then upper limit" + }) + iv$enable() + iv }) # render plot - output_q <- reactive({ - # get inputs --- - patient_id <- input$patient_id # nolint - sl_start_date <- input$sl_start_date # nolint - ae_var <- input$ae_var - ae_line_col_var <- input$ae_line_var - rs_var <- input$rs_var - cm_var <- input$cm_var - ex_var <- input$ex_var - lb_var <- input$lb_var - x_limit <- input$x_limit - lb_var_show <- input$lb_var_show - - iv$add_rule("cm_var", shinyvalidate::sv_required()) - iv$add_rule("rs_var", shinyvalidate::sv_required()) - iv$add_rule("ex_var", shinyvalidate::sv_required()) - iv$add_rule("lb_var", shinyvalidate::sv_required()) - iv$add_rule("x_limit", shinyvalidate::sv_required()) - validate(need(iv$is_valid(), "Misspecification error: please observe red flags in the encodings.")) - - adrs_vars <- unique(c( - "USUBJID", "STUDYID", "PARAMCD", - "PARAM", "AVALC", "AVAL", "ADY", - "ADT", rs_var - )) - adae_vars <- unique(c( - "USUBJID", "STUDYID", "ASTDT", - "AENDT", "AESOC", "AEDECOD", - "AESER", "AETOXGR", "AEREL", - "ASTDY", "AENDY", - ae_var, ae_line_col_var - )) - adcm_vars <- unique(c( - "USUBJID", "STUDYID", "ASTDT", - "AENDT", "ASTDT", "CMDECOD", - "ASTDY", "AENDY", "CMCAT", - cm_var - )) - adex_vars <- unique(c( - "USUBJID", "STUDYID", "ASTDT", - "AENDT", "PARCAT2", "AVAL", - "AVALU", "PARAMCD", "PARCAT1", - "PARCAT2", ex_var - )) - adlb_vars <- unique(c( - "USUBJID", "STUDYID", "ANRIND", "LBSEQ", - "PARAMCD", "BASETYPE", "ADT", "AVISITN", - "LBSTRESN", "LBCAT", "LBTESTCD", - lb_var - )) + output_q <- shiny::debounce( + millis = 200, + r = reactive({ + teal::validate_inputs(iv()) + + # get inputs --- + patient_id <- input$patient_id # nolint + sl_start_date <- input$sl_start_date # nolint + ae_var <- input$ae_var + ae_line_col_var <- input$ae_line_var + rs_var <- input$rs_var + cm_var <- input$cm_var + ex_var <- input$ex_var + lb_var <- input$lb_var + x_limit <- input$x_limit + lb_var_show <- input$lb_var_show + + adrs_vars <- unique(c( + "USUBJID", "STUDYID", "PARAMCD", + "PARAM", "AVALC", "AVAL", "ADY", + "ADT", rs_var + )) + adae_vars <- unique(c( + "USUBJID", "STUDYID", "ASTDT", + "AENDT", "AESOC", "AEDECOD", + "AESER", "AETOXGR", "AEREL", + "ASTDY", "AENDY", + ae_var, ae_line_col_var + )) + adcm_vars <- unique(c( + "USUBJID", "STUDYID", "ASTDT", + "AENDT", "ASTDT", "CMDECOD", + "ASTDY", "AENDY", "CMCAT", + cm_var + )) + adex_vars <- unique(c( + "USUBJID", "STUDYID", "ASTDT", + "AENDT", "PARCAT2", "AVAL", + "AVALU", "PARAMCD", "PARCAT1", + "PARCAT2", ex_var + )) + adlb_vars <- unique(c( + "USUBJID", "STUDYID", "ANRIND", "LBSEQ", + "PARAMCD", "BASETYPE", "ADT", "AVISITN", + "LBSTRESN", "LBCAT", "LBTESTCD", + lb_var + )) - # get ADSL dataset --- - ADSL <- data[[sl_dataname]]() # nolint + # get ADSL dataset --- + ADSL <- data[[sl_dataname]]() # nolint - if (!is.null(input$select_ex)) { - if (input$select_ex == FALSE | is.na(ex_dataname)) { - ADEX <- NULL # nolint - } else { - ADEX <- data[[ex_dataname]]() # nolint - validate_has_variable(ADEX, adex_vars) - } - } else { ADEX <- NULL # nolint - } - - if (!is.null(input$select_ae)) { - if (input$select_ae == FALSE | is.na(ae_dataname)) { - ADAE <- NULL # nolint - } else { - ADAE <- data[[ae_dataname]]() # nolint - validate_has_variable(ADAE, adae_vars) + if (isTRUE(select_plot()[ex_dataname])) { + ADEX <- data[[ex_dataname]]() # nolint + teal::validate_has_variable(ADEX, adex_vars) } - } else { ADAE <- NULL # nolint - } - - if (!is.null(input$select_rs)) { - if (input$select_rs == FALSE | is.na(rs_dataname)) { - ADRS <- NULL # nolint - } else { - ADRS <- data[[rs_dataname]]() # nolint - validate_has_variable(ADRS, adrs_vars) + if (isTRUE(select_plot()[ae_dataname])) { + ADAE <- data[[ae_dataname]]() # nolint + teal::validate_has_variable(ADAE, adae_vars) } - } else { ADRS <- NULL # nolint - } - - if (!is.null(input$select_cm)) { - if (input$select_cm == FALSE | is.na(cm_dataname)) { - ADCMD <- NULL # nolint - } else { - ADCM <- data[[cm_dataname]]() # nolint - validate_has_variable(ADCM, adcm_vars) + if (isTRUE(select_plot()[rs_dataname])) { + ADRS <- data[[rs_dataname]]() # nolint + teal::validate_has_variable(ADRS, adrs_vars) } - } else { ADCM <- NULL # nolint - } - - if (!is.null(input$select_lb)) { - if (input$select_lb == FALSE | is.na(lb_dataname)) { - ADLB <- NULL # nolint - } else { - ADLB <- data[[lb_dataname]]() # nolint - validate_has_variable(ADLB, adlb_vars) + if (isTRUE(select_plot()[cm_dataname])) { + ADCM <- data[[cm_dataname]]() # nolint + teal::validate_has_variable(ADCM, adcm_vars) } - } else { ADLB <- NULL # nolint - } - - # check color assignment - if (!is.null(ae_line_col_opt)) { - validate(need( - is.null(ae_line_col_var) || length(levels(ADAE[[ae_line_col_var]])) <= length(ae_line_col_opt), - paste( - "Please check ae_line_col_opt contains all possible values for ae_line_col_var values.", - "Or specify ae_line_col_opt as NULL.", - sep = "\n" - ) - )) - } - - possible_plot <- c("ex", "ae", "rs", "cm", "lb") - datanames <- c( - ex_dataname, - ae_dataname, - rs_dataname, - cm_dataname, - lb_dataname - ) - input_select <- purrr::map_lgl(datanames, is.na) - - select_plot <- purrr::map2_lgl( - input_select, possible_plot, - ~ if (!.x && paste("select", .y, sep = "_") %in% names(input)) { - input[[paste("select", .y, sep = "_")]] - } else { - FALSE + if (isTRUE(select_plot()[lb_dataname])) { + ADLB <- data[[lb_dataname]]() # nolint + teal::validate_has_variable(ADLB, adlb_vars) } - ) - - names(select_plot) <- possible_plot - empty_rs <- FALSE - empty_ae <- FALSE - empty_cm <- FALSE - empty_ex <- FALSE - empty_lb <- FALSE + empty_rs <- FALSE + empty_ae <- FALSE + empty_cm <- FALSE + empty_ex <- FALSE + empty_lb <- FALSE - q1 <- teal.code::eval_code( - teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)), - code = bquote({ - ADSL <- ADSL %>% # nolint - group_by(.data$USUBJID) - ADSL$max_date <- pmax( # nolint - as.Date(ADSL$LSTALVDT), - as.Date(ADSL$DTHDT), - na.rm = TRUE - ) - ADSL <- ADSL %>% # nolint - mutate( - max_date = pmax(as.Date(LSTALVDT), as.Date(DTHDT), na.rm = TRUE), - max_day = as.numeric( - as.Date(.data$max_date) - as.Date( - eval(parse(text = .(sl_start_date), keep.source = FALSE)) + q1 <- teal.code::eval_code( + teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)), + code = substitute( + env = list( + ADSL = as.name(sl_dataname), + sl_start_date = as.name(sl_start_date), + patient_id = patient_id + ), + expr = { + ADSL <- ADSL %>% # nolint + filter(USUBJID == patient_id) %>% + group_by(.data$USUBJID) %>% + mutate( + max_date = pmax(as.Date(LSTALVDT), as.Date(DTHDT), na.rm = TRUE), + max_day = as.numeric(difftime(as.Date(.data$max_date), as.Date(sl_start_date), units = "days")) + + (as.Date(.data$max_date) >= as.Date(sl_start_date)) ) - ) - + (as.Date(.data$max_date) >= as.Date(eval(parse(text = .(sl_start_date))))) - ) %>% - filter(USUBJID == .(patient_id)) - }) - ) - - # ADSL with single subject - validate( - need( - nrow(q1[["ADSL"]]) >= 1, - paste( - "Subject", - patient_id, - "not found in the dataset. Have they been filtered out by filtering in the filter panel?" + } ) ) - ) - - # name for ae_line_col - q1 <- if (!is.null(ae_line_col_var) && is.data.frame(ADAE)) { - teal.code::eval_code( - q1, - code = - bquote(ae_line_col_name <- formatters::var_labels(ADAE, fill = FALSE)[.(ae_line_col_var)]) - ) - } else { - teal.code::eval_code(q1, code = quote(ae_line_col_name <- NULL)) - } - q1 <- if (select_plot["ae"]) { + # ADSL with single subject validate( - need(!is.null(input$ae_var), "Please select an adverse event variable.") + need( + nrow(q1[["ADSL"]]) >= 1, + paste( + "Subject", + patient_id, + "not found in the dataset. Perhaps they have been filtered out by the filter panel?" + ) + ) ) - if (all(ADAE$USUBJID %in% ADSL$USUBJID)) { - qq <- teal.code::eval_code( + + # name for ae_line_col + q1 <- if (!is.null(ae_line_col_var) && is.data.frame(ADAE)) { + teal.code::eval_code( q1, - code = bquote({ - # ADAE - ADAE <- ADAE[, .(adae_vars)] # nolint + code = substitute( + env = list(ADAE = as.name(ae_dataname), ae_line_col_var = ae_line_col_var), + expr = ae_line_col_name <- formatters::var_labels(ADAE, fill = FALSE)[ae_line_col_var] + ) + ) + } else { + teal.code::eval_code(q1, code = quote(ae_line_col_name <- NULL)) + } - ADAE <- ADSL %>% # nolint - left_join(ADAE, by = c("STUDYID", "USUBJID")) %>% # nolint - as.data.frame() %>% - filter(!is.na(ASTDT)) %>% - mutate(ASTDY = as.numeric( - difftime( - ASTDT, - as.Date(substr( - as.character(eval(parse( - text = .(sl_start_date) - ))), 1, 10 - )), - units = "days" - ) - ) - + (ASTDT >= as.Date(substr( - as.character(eval(parse(text = .(sl_start_date), keep.source = FALSE))), 1, 10 - )))) %>% - filter(!is.na(AENDT)) %>% - mutate(AENDY = as.numeric( - difftime( - AENDT, - as.Date(substr( - as.character(eval(parse( - text = .(sl_start_date) - ))), 1, 10 - )), - units = "days" + q1 <- if (isTRUE(select_plot()[ae_dataname])) { + if (all(ADAE$USUBJID %in% ADSL$USUBJID)) { + qq <- teal.code::eval_code( + q1, + code = substitute( + env = list( + ADSL = as.name(sl_dataname), + ADAE = as.name(ae_dataname), + sl_start_date = as.name(sl_start_date), + ae_line_col_var = ae_line_col_var, + adae_vars = adae_vars + ), + expr = { + # ADAE + ADAE <- ADAE[, adae_vars] # nolint + + ADAE <- ADSL %>% # nolint + left_join(ADAE, by = c("STUDYID", "USUBJID")) %>% # nolint + as.data.frame() %>% + filter(!is.na(ASTDT), !is.na(AENDT)) %>% + mutate( + ASTDY = as.numeric(difftime(ASTDT, as.Date(sl_start_date), units = "days")) + + (ASTDT >= as.Date(sl_start_date)), + AENDY = as.numeric(difftime(AENDT, as.Date(sl_start_date), units = "days")) + + (AENDT >= as.Date(sl_start_date)) + ) %>% + select(c(adae_vars, ASTDY, AENDY)) + formatters::var_labels(ADAE)[ae_line_col_var] <- # nolint + formatters::var_labels(ADAE, fill = FALSE)[ae_line_col_var] + } + ) + ) %>% + teal.code::eval_code( + code = substitute( + env = list( + ADAE = as.name(ae_dataname), + ae_var = ae_var, + line_col = if (!is.null(ae_line_col_var)) bquote(as.vector(ADAE[, .(ae_line_col_var)])) else NULL, + line_col_legend = ae_line_col_var, + line_col_opt = ae_line_col_opt + ), + expr = ae <- list( + data = data.frame(ADAE), + var = as.vector(ADAE[, ae_var]), + line_col = line_col, + line_col_legend = line_col_legend, + line_col_opt = line_col_opt ) ) - + (AENDT >= as.Date(substr( # nolint - as.character(eval(parse(text = .(sl_start_date), keep.source = FALSE))), 1, 10 - )))) %>% - select(c(.(adae_vars), ASTDY, AENDY)) - formatters::var_labels(ADAE)[.(ae_line_col_var)] <- # nolint - formatters::var_labels(ADAE, fill = FALSE)[.(ae_line_col_var)] - }) - ) %>% - teal.code::eval_code( - code = call( - "<-", - as.name("ae"), - call( - "list", - data = bquote(data.frame(ADAE)), - var = bquote(as.vector(ADAE[, .(ae_var)])), - line_col = if (!is.null(ae_line_col_var)) { - bquote(as.vector(ADAE[, .(ae_line_col_var)])) - } else { - NULL - }, - line_col_legend = if (!is.null(ae_line_col_var)) { - quote(ae_line_col_name) - } else { - NULL - }, - line_col_opt = if (is.null(ae_line_col_var)) { - NULL - } else { - bquote(.(ae_line_col_opt)) - } - ) ) - ) - ADAE <- qq[["ADAE"]] # nolint - if (is.null(ADAE) | nrow(ADAE) == 0) { + ADAE <- qq[[ae_dataname]] # nolint + if (is.null(ADAE) | nrow(ADAE) == 0) { + empty_ae <- TRUE + } + qq + } else { empty_ae <- TRUE + teal.code::eval_code(q1, code = quote(ae <- NULL)) } - qq } else { - empty_ae <- TRUE - teal.code::eval_code(q1, code = bquote(ae <- NULL)) + teal.code::eval_code(q1, code = quote(ae <- NULL)) } - } else { - teal.code::eval_code(q1, code = bquote(ae <- NULL)) - } - q1 <- if (select_plot["rs"]) { - validate( - need(!is.null(rs_var), "Please select a tumor response variable.") - ) - if (all(ADRS$USUBJID %in% ADSL$USUBJID)) { - qq <- teal.code::eval_code( - q1, - code = bquote({ - ADRS <- ADRS[, .(adrs_vars)] # nolint - ADRS <- ADSL %>% # nolint - left_join(ADRS, by = c("STUDYID", "USUBJID")) %>% # nolint - as.data.frame() %>% - mutate( - ADY = as.numeric(difftime( - ADT, - as.Date(substr( - as.character(eval(parse( - text = .(sl_start_date), - keep.source = FALSE - ))), 1, 10 - )), - units = "days" - )) - + (ADT >= as.Date(substr( - as.character(eval(parse(text = .(sl_start_date), keep.source = FALSE))), 1, 10 - ))) - ) %>% - select(USUBJID, PARAMCD, PARAM, AVALC, AVAL, ADY, ADT) %>% - filter(is.na(ADY) == FALSE) - rs <- list(data = data.frame(ADRS), var = as.vector(ADRS[, .(rs_var)])) - }) - ) - ADRS <- qq[["ADRS"]] # nolint - if (is.null(ADRS) || nrow(ADRS) == 0) { + q1 <- if (isTRUE(select_plot()[rs_dataname])) { + if (all(ADRS$USUBJID %in% ADSL$USUBJID)) { + qq <- teal.code::eval_code( + q1, + code = substitute( + env = list( + ADRS = as.name(rs_dataname), + adrs_vars = adrs_vars, + sl_start_date = as.name(sl_start_date), + rs_var = rs_var + ), + expr = { + ADRS <- ADRS[, adrs_vars] # nolint + ADRS <- ADSL %>% # nolint + left_join(ADRS, by = c("STUDYID", "USUBJID")) %>% # nolint + as.data.frame() %>% + mutate( + ADY = as.numeric(difftime(ADT, as.Date(sl_start_date), units = "days")) + + (ADT >= as.Date(sl_start_date)) + ) %>% + select(USUBJID, PARAMCD, PARAM, AVALC, AVAL, ADY, ADT) %>% + filter(is.na(ADY) == FALSE) + rs <- list(data = data.frame(ADRS), var = as.vector(ADRS[, rs_var])) + } + ) + ) + ADRS <- qq[[rs_dataname]] # nolint + if (is.null(ADRS) || nrow(ADRS) == 0) { + empty_rs <- TRUE + } + qq + } else { empty_rs <- TRUE + teal.code::eval_code(q1, expression = quote(rs <- NULL)) } - qq } else { - empty_rs <- TRUE - teal.code::eval_code(q1, id = "rs call", expression = bquote(rs <- NULL)) + teal.code::eval_code(q1, code = quote(rs <- NULL)) } - } else { - teal.code::eval_code(q1, code = bquote(rs <- NULL)) - } - q1 <- if (select_plot["cm"]) { - validate( - need(!is.null(cm_var), "Please select a concomitant medication variable.") - ) - if (all(ADCM$USUBJID %in% ADSL$USUBJID)) { - qq <- teal.code::eval_code( - q1, - code = bquote({ - # ADCM - ADCM <- ADCM[, .(adcm_vars)] # nolint - ADCM <- ADSL %>% # nolint - left_join(ADCM, by = c("STUDYID", "USUBJID")) %>% # nolint - as.data.frame() %>% - filter(!is.na(ASTDT)) %>% - mutate(ASTDY = as.numeric(difftime( - ASTDT, - as.Date(substr(as.character(eval(parse(text = .(sl_start_date), keep.source = FALSE))), 1, 10)), - units = "days" - )) - + (ASTDT >= as.Date(substr( - as.character(eval(parse(text = .(sl_start_date), keep.source = FALSE))), 1, 10 - )))) %>% - filter(!is.na(AENDT)) %>% - mutate(AENDY = as.numeric(difftime( - AENDT, - as.Date(substr(as.character(eval(parse(text = .(sl_start_date), keep.source = FALSE))), 1, 10)), - units = "days" - )) - + (AENDT >= as.Date(substr( - as.character(eval(parse(text = .(sl_start_date), keep.source = FALSE))), 1, 10 - )))) %>% - select(USUBJID, ASTDT, AENDT, ASTDY, AENDY, !!quo(.(cm_var))) - if (length(unique(ADCM$USUBJID)) > 0) { - ADCM <- ADCM[which(ADCM$AENDY >= -28 | is.na(ADCM$AENDY) == TRUE # nolint - & is.na(ADCM$ASTDY) == FALSE), ] - } - cm <- list(data = data.frame(ADCM), var = as.vector(ADCM[, .(cm_var)])) - }) - ) + q1 <- if (isTRUE(select_plot()[cm_dataname])) { + if (all(ADCM$USUBJID %in% ADSL$USUBJID)) { + qq <- teal.code::eval_code( + q1, + code = substitute( + env = list( + ADSL = as.name(sl_dataname), + ADCM = as.name(cm_dataname), + sl_start_date = as.name(sl_start_date), + adcm_vars = adcm_vars, + cm_var = cm_var + ), + expr = { + # ADCM + ADCM <- ADCM[, adcm_vars] # nolint + ADCM <- ADSL %>% # nolint + left_join(ADCM, by = c("STUDYID", "USUBJID")) %>% # nolint + as.data.frame() %>% + filter(!is.na(ASTDT), !is.na(AENDT)) %>% + mutate( + ASTDY = as.numeric(difftime(ASTDT, as.Date(sl_start_date), units = "days")) + + (ASTDT >= as.Date(sl_start_date)), + AENDY = as.numeric(difftime(AENDT, as.Date(sl_start_date), units = "days")) + + (AENDT >= as.Date(sl_start_date)) + ) %>% + select(USUBJID, ASTDT, AENDT, ASTDY, AENDY, !!quo(cm_var)) + if (length(unique(ADCM$USUBJID)) > 0) { + ADCM <- ADCM[which(ADCM$AENDY >= -28 | is.na(ADCM$AENDY) == TRUE # nolint + & is.na(ADCM$ASTDY) == FALSE), ] + } + cm <- list(data = data.frame(ADCM), var = as.vector(ADCM[, cm_var])) + } + ) + ) - ADCM <- qq[["ADCM"]] # nolint - if (is.null(ADCM) | nrow(ADCM) == 0) { + ADCM <- qq[[cm_dataname]] # nolint + if (is.null(ADCM) | nrow(ADCM) == 0) { + empty_cm <- TRUE + } + qq + } else { empty_cm <- TRUE + teal.code::eval_code(q1, code = quote(cm <- NULL)) } - qq } else { - empty_cm <- TRUE teal.code::eval_code(q1, code = quote(cm <- NULL)) } - } else { - teal.code::eval_code(q1, code = bquote(cm <- NULL)) - } - q1 <- if (select_plot["ex"]) { - validate( - need(!is.null(ex_var), "Please select an exposure variable.") - ) - if (all(ADEX$USUBJID %in% ADSL$USUBJID)) { - qq <- teal.code::eval_code( - q1, - code = bquote({ - # ADEX - ADEX <- ADEX[, .(adex_vars)] # nolint - ADEX <- ADSL %>% # nolint - left_join(ADEX, by = c("STUDYID", "USUBJID")) %>% # nolint - as.data.frame() %>% - filter(PARCAT1 == "INDIVIDUAL" & PARAMCD == "DOSE" & !is.na(AVAL)) %>% - filter(!is.na(ASTDT)) %>% - select( - USUBJID, ASTDT, PARCAT2, - AVAL, AVALU, PARAMCD, !!quo(.(sl_start_date)) - ) - ADEX <- split(ADEX, ADEX$USUBJID) %>% # nolint - lapply(function(pinfo) { - pinfo %>% - arrange(PARCAT2, PARAMCD, ASTDT) %>% - ungroup() %>% - mutate(diff = c(0, diff(AVAL, lag = 1))) %>% - mutate( - Modification = case_when( - diff < 0 ~ "Decrease", - diff > 0 ~ "Increase", - diff == 0 ~ "None" - ) - ) %>% - mutate(ASTDT_dur = as.numeric( - as.Date(substr(as.character(ASTDT), 1, 10)) - - as.Date(substr(as.character(eval(parse(text = .(sl_start_date), keep.source = FALSE))), 1, 10)) - ) - + (as.Date(substr(as.character(ASTDT), 1, 10)) >= - as.Date(substr(as.character(eval(parse(text = .(sl_start_date)))), 1, 10)))) - }) %>% - Reduce(rbind, .) %>% - as.data.frame() %>% - select(-diff) - ex <- list(data = data.frame(ADEX), var = as.vector(ADEX[, .(ex_var)])) - }) - ) - ADEX <- qq[["ADEX"]] # nolint - if (is.null(ADEX) | nrow(ADEX) == 0) { + q1 <- if (isTRUE(select_plot()[ex_dataname])) { + if (all(ADEX$USUBJID %in% ADSL$USUBJID)) { + qq <- teal.code::eval_code( + q1, + code = substitute( + env = list( + ADSL = as.name(sl_dataname), + ADEX = as.name(ex_dataname), + adex_vars = adex_vars, + sl_start_date = as.name(sl_start_date), + ex_var = ex_var + ), + expr = { + # ADEX + ADEX <- ADEX[, adex_vars] # nolint + ADEX <- ADSL %>% # nolint + left_join(ADEX, by = c("STUDYID", "USUBJID")) %>% # nolint + as.data.frame() %>% + filter(PARCAT1 == "INDIVIDUAL" & PARAMCD == "DOSE" & !is.na(AVAL) & !is.na(ASTDT)) %>% + select(USUBJID, ASTDT, PARCAT2, AVAL, AVALU, PARAMCD, sl_start_date) + + ADEX <- split(ADEX, ADEX$USUBJID) %>% # nolint + lapply(function(pinfo) { + pinfo %>% + arrange(PARCAT2, PARAMCD, ASTDT) %>% + ungroup() %>% + mutate( + diff = c(0, diff(AVAL, lag = 1)), + Modification = case_when( + diff < 0 ~ "Decrease", + diff > 0 ~ "Increase", + diff == 0 ~ "None" + ), + ASTDT_dur = as.numeric(difftime(as.Date(ASTDT), as.Date(sl_start_date), units = "days")) + + (as.Date(ASTDT) >= as.Date(sl_start_date)) + ) + }) %>% + Reduce(rbind, .) %>% + as.data.frame() %>% + select(-diff) + ex <- list(data = data.frame(ADEX), var = as.vector(ADEX[, ex_var])) + } + ) + ) + ADEX <- qq[[ex_dataname]] # nolint + if (is.null(ADEX) | nrow(ADEX) == 0) { + empty_ex <- TRUE + } + qq + } else { empty_ex <- TRUE + teal.code::eval_code(q1, code = quote(ex <- NULL)) } - qq } else { - empty_ex <- TRUE teal.code::eval_code(q1, code = quote(ex <- NULL)) } - } else { - teal.code::eval_code(q1, code = quote(ex <- NULL)) - } - - q1 <- if (select_plot["lb"]) { - validate( - need(!is.null(lb_var), "Please select a lab variable.") - ) - if (all(ADLB$USUBJID %in% ADSL$USUBJID)) { - validate(need(lb_var_show != lb_var, "Lab variable and lab values must differ")) - qq <- teal.code::eval_code( - q1, - code = bquote({ - ADLB <- ADLB[, .(adlb_vars)] # nolint - ADLB <- ADSL %>% # nolint - left_join(ADLB, by = c("STUDYID", "USUBJID")) %>% - as.data.frame() %>% - group_by(USUBJID) %>% - mutate(ANRIND = factor( - .data$ANRIND, - levels = c("HIGH", "LOW", "NORMAL") - )) %>% - filter( - !is.na(.data$LBSTRESN) & !is.na(.data$ANRIND) - ) %>% - as.data.frame() %>% - select( - USUBJID, STUDYID, LBSEQ, PARAMCD, BASETYPE, ADT, AVISITN, !!quo(.(sl_start_date)), - LBTESTCD, ANRIND, !!quo(.(lb_var)) - ) - ADLB <- ADLB %>% # nolint - mutate(ADY = as.numeric(difftime( - .data$ADT, - as.Date(substr(as.character(eval(parse(text = .(sl_start_date), keep.source = FALSE))), 1, 10)), - units = "days" - )) - + (ADT >= as.Date(substr( - as.character(eval(parse(text = .(sl_start_date), keep.source = FALSE))), 1, 10 - )))) %>% - filter(.data[[.(lb_var)]] %in% .(lb_var_show)) - lb <- list(data = data.frame(ADLB), var = as.vector(ADLB[, .(lb_var)])) - }) - ) + q1 <- if (isTRUE(select_plot()[lb_dataname])) { + if (all(ADLB$USUBJID %in% ADSL$USUBJID)) { + qq <- teal.code::eval_code( + q1, + code = substitute( + env = list( + ADLB = as.name(lb_dataname), + ADSL = as.name(sl_dataname), + adlb_vars = adlb_vars, + sl_start_date = as.name(sl_start_date), + lb_var = lb_var, + lb_var_show = lb_var_show + ), + expr = { + ADLB <- ADLB[, adlb_vars] # nolint + ADLB <- ADSL %>% # nolint + left_join(ADLB, by = c("STUDYID", "USUBJID")) %>% + as.data.frame() %>% + mutate( + ANRIND = factor(.data$ANRIND, levels = c("HIGH", "LOW", "NORMAL")) + ) %>% + filter(!is.na(.data$LBSTRESN) & !is.na(.data$ANRIND) & .data[[lb_var]] %in% lb_var_show) %>% + as.data.frame() %>% + select( + USUBJID, STUDYID, LBSEQ, PARAMCD, BASETYPE, ADT, AVISITN, sl_start_date, LBTESTCD, ANRIND, lb_var + ) %>% # nolint + mutate( + ADY = as.numeric(difftime(.data$ADT, as.Date(sl_start_date), units = "days")) + + (ADT >= as.Date(sl_start_date)) + ) + lb <- list(data = data.frame(ADLB), var = as.vector(ADLB[, lb_var])) + } + ) + ) - ADLB <- qq[["ADLB"]] # nolint - if (is.null(ADLB) | nrow(ADLB) == 0) { + ADLB <- qq[[lb_dataname]] # nolint + if (is.null(ADLB) | nrow(ADLB) == 0) { + empty_lb <- TRUE + } + qq + } else { empty_lb <- TRUE + teal.code::eval_code(q1, code = quote(lb <- NULL)) } - qq } else { - empty_lb <- TRUE teal.code::eval_code(q1, code = quote(lb <- NULL)) } - } else { - teal.code::eval_code(q1, code = bquote(lb <- NULL)) - } - - - # Check that at least 1 dataset is selected - validate( - need(any(select_plot), "Please select an ADaM dataset.") - ) + # Check the subject has information in at least one selected domain + empty_data_check <- structure( + c(empty_ex, empty_ae, empty_rs, empty_lb, empty_cm), + names = checkboxes + ) - # Check the subject has information in at least one selected domain - empty_data_check <- c(empty_ex, empty_ae, empty_rs, empty_cm, empty_lb) + validate(need( + any(!empty_data_check & select_plot()), + "The subject does not have information in any selected domain." + )) - validate(need( - any(!empty_data_check & select_plot), - "The subject does not have information in any selected domain." - )) + # Check the subject has information in all the selected domains + if (any(empty_data_check & select_plot())) { + showNotification( + paste0( + "This subject does not have information in the ", + paste(checkboxes[empty_data_check & select_plot()], collapse = ", "), + " domain." + ), + duration = 8, + type = "warning" + ) + } - # Check the subject has information in all the selected domains - if (any(empty_data_check & select_plot)) { - showNotification( - paste0( - "This subject does not have information in the ", - paste(c(possible_plot[(empty_data_check & select_plot)]), collapse = ", "), - " domain." - ), - duration = 8, - type = "warning" - ) - } + # Convert x_limit to numeric vector + if (!is.null(x_limit) || x_limit != "") { + q1 <- teal.code::eval_code( + q1, + code = bquote(x_limit <- as.numeric(unlist(strsplit(.(x_limit), ",")))) + ) + x_limit <- q1[["x_limit"]] + } - # Convert x_limit to numeric vector - if (!is.null(x_limit) || x_limit != "") { q1 <- teal.code::eval_code( q1, - code = bquote(x_limit <- as.numeric(unlist(strsplit(.(x_limit), ",")))) - ) - x_limit <- q1[["x_limit"]] - } - - validate(need( - all(!is.na(x_limit)) & all(!is.infinite(x_limit)), - "Not all values entered for study days range were numeric." - )) - validate(need( - x_limit[1] < x_limit[2], - "The lower limit for study days range should come first." - )) - - q1 <- teal.code::eval_code( - q1, - code = bquote({ - plot <- osprey::g_patient_profile( - ex = ex, - ae = ae, - rs = rs, - cm = cm, - lb = lb, - arrow_end_day = ADSL$max_day, - xlim = x_limit, - xlab = "Study Day", - title = paste("Patient Profile: ", .(patient_id)) + code = substitute( + env = list( + patient_id = patient_id, + ADSL = as.name(sl_dataname) + ), + expr = { + plot <- osprey::g_patient_profile( + ex = ex, + ae = ae, + rs = rs, + cm = cm, + lb = lb, + arrow_end_day = ADSL[["max_day"]], + xlim = x_limit, + xlab = "Study Day", + title = paste("Patient Profile: ", patient_id) + ) + plot + } ) - plot - }) - ) - }) + ) + }) + ) plot_r <- reactive(output_q()[["plot"]]) diff --git a/R/tm_g_spiderplot.R b/R/tm_g_spiderplot.R index 4856f8b7..ca1af247 100644 --- a/R/tm_g_spiderplot.R +++ b/R/tm_g_spiderplot.R @@ -227,19 +227,43 @@ srv_g_spider <- function(id, data, filter_panel_api, reporter, dataname, label, checkmate::assert_class(data, "tdata") moduleServer(id, function(input, output, session) { - vals <- reactiveValues(spiderplot = NULL) # nolint + iv <- reactive({ + ADSL <- data[["ADSL"]]() # nolint + ADTR <- data[[dataname]]() # nolint - iv <- shinyvalidate::InputValidator$new() - iv$add_rule("paramcd", shinyvalidate::sv_required()) - iv$add_rule("x_var", shinyvalidate::sv_required()) - iv$add_rule("y_var", shinyvalidate::sv_required()) - iv$add_rule("marker_var", shinyvalidate::sv_required()) - iv$add_rule("line_colorby_var", shinyvalidate::sv_required()) - fac_dupl <- function(x, y) length(x) * length(y) > 0 & anyDuplicated(c(x, y)) - msg_dupl <- "X- and Y-facet variables must not be duplicated." - iv$add_rule("xfacet_var", ~ if (fac_dupl(input$xfacet_var, input$yfacet_var)) msg_dupl) - iv$add_rule("yfacet_var", ~ if (fac_dupl(input$xfacet_var, input$yfacet_var)) msg_dupl) - iv$enable() + iv <- shinyvalidate::InputValidator$new() + iv$add_rule("paramcd", shinyvalidate::sv_required( + message = "Parameter is required" + )) + iv$add_rule("x_var", shinyvalidate::sv_required( + message = "X Axis Variable is required" + )) + iv$add_rule("y_var", shinyvalidate::sv_required( + message = "Y Axis Variable is required" + )) + iv$add_rule("line_colorby_var", shinyvalidate::sv_required( + message = "Color Variable is required" + )) + iv$add_rule("marker_var", shinyvalidate::sv_required( + message = "Marker Symbol Variable is required" + )) + fac_dupl <- function(value, other) { + if (length(value) * length(other) > 0L && anyDuplicated(c(value, other))) { + "X- and Y-facet Variables must not overlap" + } + } + iv$add_rule("xfacet_var", fac_dupl, other = input$yfacet_var) + iv$add_rule("yfacet_var", fac_dupl, other = input$xfacet_var) + iv$add_rule("vref_line", ~ if (anyNA(suppressWarnings(as_numeric_from_comma_sep_str(.)))) { + "Vertical Reference Line(s) are invalid" + }) + iv$add_rule("href_line", ~ if (anyNA(suppressWarnings(as_numeric_from_comma_sep_str(.)))) { + "Horizontal Reference Line(s) are invalid" + }) + iv$enable() + }) + + vals <- reactiveValues(spiderplot = NULL) # nolint # render plot output_q <- reactive({ @@ -247,6 +271,11 @@ srv_g_spider <- function(id, data, filter_panel_api, reporter, dataname, label, ADSL <- data[["ADSL"]]() # nolint ADTR <- data[[dataname]]() # nolint + teal::validate_inputs(iv()) + + teal::validate_has_data(ADSL, min_nrow = 1, msg = sprintf("%s data has zero rows", "ADSL")) + teal::validate_has_data(ADTR, min_nrow = 1, msg = sprintf("%s data has zero rows", dataname)) + paramcd <- input$paramcd # nolint x_var <- input$x_var y_var <- input$y_var @@ -259,9 +288,9 @@ srv_g_spider <- function(id, data, filter_panel_api, reporter, dataname, label, vref_line <- input$vref_line href_line <- input$href_line - validate(need(iv$is_valid(), "Misspecification error: please observe red flags in the encodings.")) - validate(need(nrow(ADSL) > 0, "ADSL data has zero rows")) - validate(need(nrow(ADTR) > 0, paste(dataname, "data has zero rows"))) + # reference lines preprocessing + vref_line <- as_numeric_from_comma_sep_str(vref_line) + href_line <- as_numeric_from_comma_sep_str(href_line) # define variables --- # if variable is not in ADSL, then take from domain VADs @@ -304,20 +333,6 @@ srv_g_spider <- function(id, data, filter_panel_api, reporter, dataname, label, }) ) - # reference lines preprocessing - vertical - vref_line <- as_numeric_from_comma_sep_str(vref_line) - validate(need( - all(!is.na(vref_line)), - "Please enter a comma separated set of numeric values for the vertical reference line(s)" - )) - - # reference lines preprocessing - horizontal - href_line <- as_numeric_from_comma_sep_str(href_line) - validate(need( - all(!is.na(href_line)), - "Please enter a comma separated set of numeric values for the horizontal reference line(s)" - )) - # label q1 <- if (anno_txt_var) { teal.code::eval_code( diff --git a/R/tm_g_swimlane.R b/R/tm_g_swimlane.R index 06d96801..a04fdb30 100644 --- a/R/tm_g_swimlane.R +++ b/R/tm_g_swimlane.R @@ -49,7 +49,7 @@ #' base::rbind(ADRS %>% dplyr::filter(PARAMCD == "OVRINV" & AVALC != "NE")) %>% #' arrange(USUBJID) #' -#' x <- init( +#' app <- init( #' data = cdisc_data( #' cdisc_dataset("ADSL", ADSL, code = "ADSL <- rADSL"), #' cdisc_dataset("ADRS", ADRS, @@ -97,7 +97,7 @@ #' ) #' ) #' if (interactive()) { -#' shinyApp(x$ui, x$server) +#' shinyApp(app$ui, app$server) #' } #' tm_g_swimlane <- function(label, @@ -275,9 +275,18 @@ srv_g_swimlane <- function(id, checkmate::assert_class(data, "tdata") moduleServer(id, function(input, output, session) { - iv <- shinyvalidate::InputValidator$new() - iv$add_rule("bar_var", shinyvalidate::sv_required()) - iv$enable() + iv <- reactive({ + iv <- shinyvalidate::InputValidator$new() + iv$add_rule("bar_var", shinyvalidate::sv_required( + message = "Bar Length is required" + )) + # If reference lines are requested + iv$add_rule("vref_line", ~ if (anyNA(suppressWarnings(as_numeric_from_comma_sep_str(.)))) { + "Vertical Reference Line(s) are invalid" + }) + iv$enable() + iv + }) # if marker position is NULL, then hide options for marker shape and color output$marker_shape_sel <- renderUI({ @@ -309,26 +318,48 @@ srv_g_swimlane <- function(id, # create plot output_q <- reactive({ - validate(need(iv$is_valid(), "Misspecification error: please observe red flags in the encodings.")) + teal::validate_inputs(iv()) - # DATA GETTERS validate(need("ADSL" %in% names(data), "'ADSL' not included in data")) validate(need( (length(data) == 1 && dataname == "ADSL") || - (length(data) >= 2 && dataname != "ADSL"), - "Please either add just 'ADSL' as dataname when just ADSL is available - In case 2 datasets are available ADSL is not supposed to be the dataname." + (length(data) >= 2 && dataname != "ADSL"), paste( + "Please either add just 'ADSL' as dataname when just ADSL is available.", + "In case 2 datasets are available ADSL is not supposed to be the dataname." + ) )) ADSL <- data[["ADSL"]]() # nolint - q1 <- teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) + anl_vars <- unique(c( + "USUBJID", "STUDYID", + input$marker_pos_var, input$marker_shape_var, input$marker_color_var + )) # nolint + adsl_vars <- unique(c( + "USUBJID", "STUDYID", + input$bar_var, input$bar_color_var, input$sort_var, input$anno_txt_var + )) + + if (dataname == "ADSL") { + teal::validate_has_data(ADSL, min_nrow = 3) + teal::validate_has_variable(ADSL, adsl_vars) + } else { + anl <- data[[dataname]]() + teal::validate_has_data(anl, min_nrow = 3) + teal::validate_has_variable(anl, anl_vars) + + validate(need( + !any(c(marker_pos_var, marker_shape_var, marker_color_var) %in% adsl_vars), + "marker-related variables need to come from marker data" + )) + } # VARIABLE GETTERS # lookup bar variables bar_var <- input$bar_var bar_color_var <- input$bar_color_var sort_var <- input$sort_var + anno_txt_var <- input$anno_txt_var # Check if marker inputs can be used if (dataname == "ADSL") { @@ -340,45 +371,9 @@ srv_g_swimlane <- function(id, marker_shape_var <- input$marker_shape_var marker_color_var <- input$marker_color_var } + vref_line <- suppressWarnings(as_numeric_from_comma_sep_str(debounce(reactive(input$vref_line), 1500)())) - anno_txt_var <- input$anno_txt_var - - # If reference lines are requested - vref_line <- as_numeric_from_comma_sep_str(debounce(reactive(input$vref_line), 1500)()) - validate(need( - all(!is.na(vref_line)), - "Please enter a comma separated set of numeric values for the reference line(s)" - )) - - # validate input values - if (dataname == "ADSL") { - validate_has_data(ADSL, min_nrow = 3) - validate_has_variable(ADSL, c("USUBJID", "STUDYID", bar_var, bar_color_var, sort_var, anno_txt_var)) - } else { - anl <- data[[dataname]]() - validate_has_data(ADSL, min_nrow = 3) - validate_has_variable(ADSL, c("USUBJID", "STUDYID", bar_var, bar_color_var, sort_var, anno_txt_var)) - - validate_has_data(anl, min_nrow = 3) - validate_has_variable( - anl, - unique(c("USUBJID", "STUDYID", marker_pos_var, marker_shape_var, marker_color_var)) - ) - } - - # DATA / VARIABLE VALIDATIONS - - adsl_vars <- unique(c("USUBJID", "STUDYID", bar_var, bar_color_var, sort_var, anno_txt_var)) - - if (dataname != "ADSL") { - anl_vars <- unique(c("USUBJID", "STUDYID", marker_pos_var, marker_shape_var, marker_color_var)) # nolint - validate(need( - !any(c(marker_pos_var, marker_shape_var, marker_color_var) %in% adsl_vars), - "marker-related variables need to come from marker data" - )) - } - - # WRITE VARIABLES TO qenv + q1 <- teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) q2 <- teal.code::eval_code( q1, diff --git a/R/tm_g_waterfall.R b/R/tm_g_waterfall.R index fe08ebbf..8368fd82 100644 --- a/R/tm_g_waterfall.R +++ b/R/tm_g_waterfall.R @@ -54,7 +54,7 @@ #' #' ADSL$SEX <- factor(ADSL$SEX, levels = unique(ADSL$SEX)) #' -#' x <- teal::init( +#' app <- teal::init( #' data = cdisc_data( #' cdisc_dataset("ADSL", ADSL, #' code = "ADSL <- rADSL @@ -87,7 +87,7 @@ #' ) #' ) #' if (interactive()) { -#' shinyApp(x$ui, x$server) +#' shinyApp(app$ui, app$server) #' } tm_g_waterfall <- function(label, dataname_tr = "ADTR", @@ -292,16 +292,85 @@ srv_g_waterfall <- function(id, checkmate::assert_class(data, "tdata") moduleServer(id, function(input, output, session) { - output_q <- reactive({ + iv <- reactive({ + adsl <- data[["ADSL"]]() + adtr <- data[[dataname_tr]]() + adrs <- data[[dataname_rs]]() + iv <- shinyvalidate::InputValidator$new() - iv$add_rule("bar_var", shinyvalidate::sv_required()) - iv$add_rule("bar_paramcd", shinyvalidate::sv_required()) + iv$add_rule("bar_var", shinyvalidate::sv_required( + message = "Bar Height is required" + )) + iv$add_rule("bar_paramcd", shinyvalidate::sv_required( + message = "Tumor Burden Parameter is required" + )) + iv$add_rule("bar_paramcd", shinyvalidate::sv_in_set( + set = adtr$PARAMCD, + message_fmt = "All values of Tumor Burden Parameter must be elements of ADTR PARAMCD" + )) + iv$add_rule("add_label_paramcd_rs", shinyvalidate::sv_optional()) + iv$add_rule("add_label_paramcd_rs", shinyvalidate::sv_in_set( + set = adrs$PARAMCD, + message_fmt = "ADRS Label must be an element of ADRS PARAMCD" + )) + rule_excl <- function(value, other) { + if (length(value) > 0L && length(other) > 0L) { + "Only one \"Label to Bars\" is allowed" + } + } + iv$add_rule("add_label_paramcd_rs", rule_excl, other = input$add_label_var_sl) + iv$add_rule("add_label_var_sl", rule_excl, other = input$add_label_paramcd_rs) + iv$add_rule("anno_txt_paramcd_rs", shinyvalidate::sv_optional()) + iv$add_rule("anno_txt_paramcd_rs", shinyvalidate::sv_in_set( + set = adrs$PARAMCD, + message_fmt = "Annotation Parameters must be elements of ADRS PARAMCD" + )) + iv$add_rule("href_line", shinyvalidate::sv_optional()) + iv$add_rule("href_line", ~ if (anyNA(suppressWarnings(as_numeric_from_comma_sep_str(.)))) { + "Horizontal Reference Line(s) are invalid" + }) + iv$add_rule("ytick_at", shinyvalidate::sv_required( + message = "Y-axis Interval is required" + )) + iv$add_rule("ytick_at", ~ if (!checkmate::test_number(suppressWarnings(as.numeric(.)), lower = 1)) { + "Y-axis Interval must be a single positive number" + }) + iv$add_rule("gap_point_val", shinyvalidate::sv_optional()) + iv$add_rule("gap_point_val", ~ if (!checkmate::test_number(suppressWarnings(as.numeric(.)), lower = 1)) { + "Break High Bars must be a single positive number" + }) iv$enable() + iv + }) + output_q <- reactive({ adsl <- data[["ADSL"]]() adtr <- data[[dataname_tr]]() adrs <- data[[dataname_rs]]() + # validate data rows + teal::validate_has_data(adsl, min_nrow = 2) + teal::validate_has_data(adtr, min_nrow = 2) + teal::validate_has_data(adrs, min_nrow = 2) + + adsl_vars <- unique( + c( + "USUBJID", "STUDYID", + input$bar_color_var, input$sort_var, input$add_label_var_sl, input$anno_txt_var_sl, input$facet_var + ) + ) + adtr_vars <- unique(c("USUBJID", "STUDYID", "PARAMCD", input$bar_var)) + adrs_vars <- unique(c("USUBJID", "STUDYID", "PARAMCD", "AVALC")) + adrs_paramcd <- unique(c(input$add_label_paramcd_rs, input$anno_txt_paramcd_rs)) + + # validate data input + teal::validate_has_variable(adsl, adsl_vars) + teal::validate_has_variable(adrs, adrs_vars) + teal::validate_has_variable(adtr, adtr_vars) + + teal::validate_inputs(iv()) + + # get variables bar_var <- input$bar_var bar_paramcd <- input$bar_paramcd add_label_var_sl <- input$add_label_var_sl @@ -312,30 +381,15 @@ srv_g_waterfall <- function(id, href_line <- input$href_line gap_point_val <- input$gap_point_val show_value <- input$show_value # nolint + href_line <- suppressWarnings(as_numeric_from_comma_sep_str(href_line)) - validate(need( - length(add_label_paramcd_rs) == 0 || length(add_label_var_sl) == 0, - "`Add ADSL Label to Bars` and `Add ADRS Label to Bars` fields cannot both have values simultaneously." - )) - - # validate data rows - validate_has_data(adsl, min_nrow = 2) - validate_has_data(adtr, min_nrow = 2) - validate_has_data(adrs, min_nrow = 2) - - validate_in( - bar_paramcd, - adtr$PARAMCD, - "Tumor burden parameter is not selected or is not found in ADTR PARAMCD." - ) - if (!is.null(add_label_paramcd_rs)) { - validate_in(add_label_paramcd_rs, adrs$PARAMCD, "Response parameter cannot be found in ADRS PARAMCD.") - } - if (!is.null(anno_txt_paramcd_rs)) { - validate_in(anno_txt_paramcd_rs, adrs$PARAMCD, "Response parameter cannot be found in ADRS PARAMCD.") + if (gap_point_val == "") { + gap_point_val <- NULL + } else { + gap_point_val <- as.numeric(gap_point_val) } + ytick_at <- as.numeric(ytick_at) - # get variables bar_color_var <- if (!is.null(input$bar_color_var) && input$bar_color_var != "None" && input$bar_color_var != "") { @@ -354,44 +408,6 @@ srv_g_waterfall <- function(id, NULL } - # If reference lines are requested - href_line <- as_numeric_from_comma_sep_str(href_line) - validate(need( - all(!is.na(href_line)), - "Please enter a comma separated set of numeric values for the reference line(s)" - )) - - # If gap point is requested - if (gap_point_val != "" || is.null(gap_point_val)) { - gap_point_val <- as.numeric(gap_point_val) - validate(need( - !anyNA(gap_point_val), - "Value entered for break point was not numeric" - )) - } else { - gap_point_val <- NULL - } - - # If y tick is requested - if (ytick_at != "" || is.null(ytick_at)) { - ytick_at <- as.numeric(ytick_at) - validate(need(!anyNA(ytick_at), "Value entered for Y-axis interval was not numeric")) - } else { - ytick_at <- 20 - } - - adsl_vars <- unique( - c("USUBJID", "STUDYID", bar_color_var, sort_var, add_label_var_sl, anno_txt_var_sl, facet_var) - ) - adtr_vars <- unique(c("USUBJID", "STUDYID", "PARAMCD", bar_var)) - adrs_vars <- unique(c("USUBJID", "STUDYID", "PARAMCD", "AVALC")) - adrs_paramcd <- unique(c(add_label_paramcd_rs, anno_txt_paramcd_rs)) - - # validate data input - validate_has_variable(adsl, adsl_vars) - validate_has_variable(adrs, adrs_vars) - validate_has_variable(adtr, adtr_vars) - # write variables to qenv q1 <- teal.code::eval_code( teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)), @@ -444,7 +460,7 @@ srv_g_waterfall <- function(id, ) ) - validate_one_row_per_id(qq1[["rs_sub"]], key = c("STUDYID", "USUBJID", "PARAMCD")) + teal::validate_one_row_per_id(qq1[["rs_sub"]], key = c("STUDYID", "USUBJID", "PARAMCD")) teal.code::eval_code( qq1, diff --git a/README.md b/README.md index b552b4cc..e323217f 100644 --- a/README.md +++ b/README.md @@ -1,8 +1,10 @@ # teal.osprey +[![Release 🎈](https://github.com/insightsengineering/teal.osprey/actions/workflows/release.yaml/badge.svg)](https://github.com/insightsengineering/teal.osprey/releases) [![Check 🛠](https://github.com/insightsengineering/teal.osprey/actions/workflows/check.yaml/badge.svg)](https://github.com/insightsengineering/teal.osprey/actions/workflows/check.yaml) [![Docs 📚](https://github.com/insightsengineering/teal.osprey/actions/workflows/docs.yaml/badge.svg)](https://insightsengineering.github.io/teal.osprey/) + [![Code Coverage 📔](https://raw.githubusercontent.com/insightsengineering/teal.osprey/_xml_coverage_reports/data/main/badge.svg)](https://raw.githubusercontent.com/insightsengineering/teal.osprey/_xml_coverage_reports/data/main/coverage.xml) ![GitHub forks](https://img.shields.io/github/forks/insightsengineering/teal.osprey?style=social) diff --git a/man/tm_g_butterfly.Rd b/man/tm_g_butterfly.Rd index 97c41dad..8a697d6c 100644 --- a/man/tm_g_butterfly.Rd +++ b/man/tm_g_butterfly.Rd @@ -127,11 +127,11 @@ app <- init( dataname = "ADAE", right_var = choices_selected( selected = "SEX", - choices = c("DOSE", "SEX", "ARM", "RACE", "flag1", "flag2", "flag3") + choices = c("SEX", "ARM", "RACE") ), left_var = choices_selected( selected = "RACE", - choices = c("DOSE", "SEX", "ARM", "RACE", "flag1", "flag2", "flag3") + choices = c("SEX", "ARM", "RACE") ), category_var = choices_selected(selected = "AEBODSYS", choices = c("AEDECOD", "AEBODSYS")), color_by_var = choices_selected(selected = "AETOXGR", choices = c("AETOXGR", "None")), diff --git a/man/tm_g_heat_bygrade.Rd b/man/tm_g_heat_bygrade.Rd index a436b314..dc712301 100644 --- a/man/tm_g_heat_bygrade.Rd +++ b/man/tm_g_heat_bygrade.Rd @@ -9,7 +9,7 @@ tm_g_heat_bygrade( sl_dataname, ex_dataname, ae_dataname, - cm_dataname, + cm_dataname = NA, id_var, visit_var, ongo_var, diff --git a/man/tm_g_patient_profile.Rd b/man/tm_g_patient_profile.Rd index aad4bf7e..1eefade7 100644 --- a/man/tm_g_patient_profile.Rd +++ b/man/tm_g_patient_profile.Rd @@ -8,16 +8,11 @@ tm_g_patient_profile( label = "Patient Profile Plot", patient_id, sl_dataname, - ex_dataname, - ae_dataname, - rs_dataname, - cm_dataname, - lb_dataname, - show_ex_plot = TRUE, - show_ae_plot = TRUE, - show_rs_plot = TRUE, - show_cm_plot = TRUE, - show_lb_plot = TRUE, + ex_dataname = NA, + ae_dataname = NA, + rs_dataname = NA, + cm_dataname = NA, + lb_dataname = NA, sl_start_date, ex_var = NULL, ae_var = NULL, @@ -43,48 +38,14 @@ menu item label of the module in the teal app.} needs to be available in the list passed to the \code{data} argument of \code{\link[teal]{init}}} -\item{ex_dataname}{(\code{character}) exposures dataset name, -needs to be available in the list passed to the \code{data} -argument of \code{\link[teal]{init}} \cr -specify to \code{NA} if no exposure data is available} - -\item{ae_dataname}{(\code{character}) adverse events dataset name, -needs to be available in the list passed to the \code{data} -argument of \code{\link[teal]{init}} \cr -specify to \code{NA} if no adverse events data is available} - -\item{rs_dataname}{(\code{character}) response dataset name, -needs to be available in the list passed to the \code{data} -argument of \code{\link[teal]{init}} \cr -specify to \code{NA} if no response data is available} - -\item{cm_dataname}{(\code{character}) concomitant medications dataset name, -needs to be available in the list passed to the \code{data} -argument of \code{\link[teal]{init}} \cr -specify to \code{NA} if no concomitant medications data is available} - -\item{lb_dataname}{(\code{character}) labs dataset name, -needs to be available in the list passed to the \code{data} -argument of \code{\link[teal]{init}} \cr -specify to \code{NA} if no labs data is available} - -\item{show_ex_plot}{boolean value of whether exposures plot is shown, -default is \code{TRUE}} - -\item{show_ae_plot}{boolean value of whether adverse events plot is shown, -default is \code{TRUE}} - -\item{show_rs_plot}{boolean value of whether response plot is shown, -default is \code{TRUE}} - -\item{show_cm_plot}{boolean value of whether concomitant medications -plot is shown, default is \code{TRUE}} - -\item{show_lb_plot}{boolean value of whether labs plot is shown, -default is \code{TRUE}} +\item{ex_dataname, ae_dataname, rs_dataname, cm_dataname, lb_dataname}{(\code{character(1)}) names of exposure, adverse events, response, +concomitant medications, and labs datasets, respectively; +must be available in the list passed to the \code{data} +argument of \code{\link[teal]{init}}\cr +set to NA (default) to omit from analysis} -\item{sl_start_date}{(\code{choices_selected}) study start date variable, usually set to treatment -start date or randomization date} +\item{sl_start_date}{(\code{choices_selected}) study start date variable, usually set to +treatment start date or randomization date} \item{ex_var}{(\code{choices_selected}) exposure variable to plot as each line \cr leave unspecified or set to \code{NULL} if exposure data is not available} @@ -95,8 +56,10 @@ leave unspecified or set to \code{NULL} if adverse events data is not available} \item{ae_line_col_var}{(\code{choices_selected}) variable for coloring AE lines \cr leave unspecified or set to \code{NULL} if adverse events data is not available} -\item{ae_line_col_opt}{aesthetic values to map color values (named vector to map color values to each name). -If not \code{NULL}, please make sure this contains all possible values for \code{ae_line_col_var} values. \cr +\item{ae_line_col_opt}{aesthetic values to map color values +(named vector to map color values to each name). +If not \code{NULL}, please make sure this contains all possible +values for \code{ae_line_col_var} values. \cr leave unspecified or set to \code{NULL} if adverse events data is not available} \item{rs_var}{(\code{choices_selected}) response variable to plot as each line \cr @@ -180,7 +143,7 @@ ADLB <- latest_data$adlb \%>\% LBSTRESN = as.numeric(LBSTRESC) ) -x <- init( +app <- init( data = cdisc_data( cdisc_dataset("ADSL", ADSL, code = "ADSL <- synthetic_cdisc_data(\"latest\")$adsl" @@ -226,11 +189,6 @@ x <- init( rs_dataname = "ADRS", cm_dataname = "ADCM", lb_dataname = "ADLB", - show_ex_plot = TRUE, - show_ae_plot = TRUE, - show_rs_plot = TRUE, - show_cm_plot = FALSE, - show_lb_plot = TRUE, sl_start_date = choices_selected( selected = "TRTSDTM", choices = c("TRTSDTM", "RANDDT") @@ -266,7 +224,7 @@ x <- init( ) ) if (interactive()) { - shinyApp(x$ui, x$server) + shinyApp(app$ui, app$server) } } diff --git a/man/tm_g_swimlane.Rd b/man/tm_g_swimlane.Rd index 9b1e9c76..65377994 100644 --- a/man/tm_g_swimlane.Rd +++ b/man/tm_g_swimlane.Rd @@ -95,7 +95,7 @@ ADRS <- ADRS \%>\% base::rbind(ADRS \%>\% dplyr::filter(PARAMCD == "OVRINV" & AVALC != "NE")) \%>\% arrange(USUBJID) -x <- init( +app <- init( data = cdisc_data( cdisc_dataset("ADSL", ADSL, code = "ADSL <- rADSL"), cdisc_dataset("ADRS", ADRS, @@ -143,7 +143,7 @@ x <- init( ) ) if (interactive()) { - shinyApp(x$ui, x$server) + shinyApp(app$ui, app$server) } } diff --git a/man/tm_g_waterfall.Rd b/man/tm_g_waterfall.Rd index ea510b7d..49fbf44c 100644 --- a/man/tm_g_waterfall.Rd +++ b/man/tm_g_waterfall.Rd @@ -107,7 +107,7 @@ ADTR <- rADTR ADSL$SEX <- factor(ADSL$SEX, levels = unique(ADSL$SEX)) -x <- teal::init( +app <- teal::init( data = cdisc_data( cdisc_dataset("ADSL", ADSL, code = "ADSL <- rADSL @@ -140,7 +140,7 @@ x <- teal::init( ) ) if (interactive()) { - shinyApp(x$ui, x$server) + shinyApp(app$ui, app$server) } } \author{