From bc13fa96bb36613cd61c6795e028f5d1f96ee0df Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Mon, 28 Nov 2022 15:36:38 +0100 Subject: [PATCH 01/68] add function gather_fails --- R/gather_fails.R | 169 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 169 insertions(+) create mode 100644 R/gather_fails.R diff --git a/R/gather_fails.R b/R/gather_fails.R new file mode 100644 index 00000000..de1869ff --- /dev/null +++ b/R/gather_fails.R @@ -0,0 +1,169 @@ + +#' send input validation messages to output +#' +#' Captures messages from `InputValidator` objects and collates them +#' into one message passed to `validate`. +#' +#' `shiny::validate` is used to withhold rendering of an output element until +#' certain conditions are met and a print a validation message in place +#' of the output element. +#' `shinyvalidate` allows to validate input elements and display specific messages +#' in their respective input widgets. +#' This function is a hybrid solution. Given an `InputValidator` object, +#' it extracts messages from inputs that fail validation and places them all in one +#' validation message that is passed to a `validate`/`need` call. +#' This way the input validator messages are repeated in the output. +#' +#' \code{gather_fails} accepts one `InputValidator` +#' and can add a header to its validation messages. +#' \code{gather_fails_com} accepts an arbitrary number of `InputValidator`s +#' and prints all messages together under one header. +#' \code{gather_fails_grp} accepts a \strong{list} of `InputValidator`s +#' and prints messages in groups. If elements of \code{validators} are named, +#' the names are used as headers for their respective message groups. +#' +#' +#' @name gather_fails +#' +#' @param iv object of class `InputValidator` +#' @param header `character(1)` optional generic validation message +#' @param ... arguments passed to `shiny::validate` +#' @param validators optionally named `list` of `InputValidator` objects, see\code{Details} +#' +#' @return +#' Returns NULL if the final validation call passes and a `shiny.silent.error` if it fails. +#' +#' @seealso \code{\link{[shinyvalidate::InputValidator]}} \code{\link{[shiny::validate]}} +#' +#' @examples +#' library(shiny) +#' library(shinyvalidate) +#' +#' ui <- fluidPage( +#' selectInput("method", "validation method", c("hierarchical", "combined", "grouped")), +#' sidebarLayout( +#' sidebarPanel( +#' selectInput("letter", "select a letter:", c(letters[1:3], LETTERS[4:6])), +#' selectInput("number", "select a number:", 1:6), +#' br(), +#' selectInput("color", "select a color:", +#' c("black", "indianred2", "springgreen2", "cornflowerblue"), +#' multiple = TRUE), +#' sliderInput("size", "select point size:", +#' min = 0.1, max = 4, value = 0.25) +#' ), +#' mainPanel(plotOutput('plot')) +#' ) +#' ) +#' +#' server <- function(input, output) { +#' # set up input validation +#' iv <- InputValidator$new() +#' iv$add_rule("letter", sv_in_set(LETTERS, "choose a capital letter")) +#' iv$add_rule("number", ~ if (as.integer(.) %% 2L == 1L) "choose an even number") +#' iv$enable() +#' # more input validation +#' iv_par <- InputValidator$new() +#' iv_par$add_rule("color", ~ if (is.null(.)) "choose a color") +#' iv_par$add_rule("color", ~ if (length(.) > 1L) "choose only one color") +#' iv_par$add_rule("size", sv_between(left = 0.5, right = 3, +#' message_fmt = "choose a value between {left} and {right}")) +#' iv_par$enable() +#' +#' +#' output$plot <- renderPlot({ +#' # validate output +#' switch(input[["method"]], +#' "hierarchical" = { +#' gather_fails(iv) +#' gather_fails(iv_par, "Set proper graphical parameters") +#' }, +#' "combined" = gather_fails_com(iv, iv_par), +#' "grouped" = gather_fails_grp(list( +#' "Some inputs require attention" = iv, +#' "Set proper graphical parameters" = iv_par +#' ))) +#' +#' plot(eruptions ~ waiting, faithful, las = 1, pch = 16, +#' col = input[["color"]], cex = input[["size"]]) +#' }) +#' } +#' +#' if (interactive()) { +#' shinyApp(ui, server) +#' } + + +#' @rdname gather_fials +#' @export +gather_fails <- function(iv, header = "Some inputs require attention", ...) { + checkmate::assert_class(iv, "InputValidator") + checkmate::assert_string(header, null.ok = TRUE) + + fail_messages <- gather_messages(iv) + failings <- add_header(fail_messages, header) + + shiny::validate(shiny::need(is.null(failings), failings), ...) +} + + +#' @rdname gather_fials +#' @export +gather_fails_com <- function(..., header = "Some inputs require attention") { + vals <- list(...) + lapply(vals, checkmate::assert_class, "InputValidator") + checkmate::assert_string(header, null.ok = TRUE) + + fail_messages <- unlist(lapply(vals, gather_messages)) + failings <- add_header(fail_messages, header) + + shiny::validate(shiny::need(is.null(failings), failings)) +} + + +#' @rdname gather_fials +#' @export +gather_fails_grp <- function(validators, ...) { + checkmate::assert_list(validators, types = "InputValidator") + + # Since some or all names may be NULL, mapply cannot be used here, a loop is required. + fail_messages <- vector("list", length(validators)) + for (v in seq_along(validators)) { + fail_messages[[v]] <- gather_and_add(validators[[v]], names(validators)[v]) + } + + failings <- unlist(fail_messages) + + shiny::validate(shiny::need(is.null(failings), failings), ...) +} + + +### internal functions + +#' @keywords internal +# internal used by all methods +# collate failing messages from validator +gather_messages <- function(iv) { + status <- iv$validate() + failing_inputs <- Filter(Negate(is.null), status) + unique(lapply(failing_inputs, function(x) x[["message"]])) +} + + +#' @keywords internal +# internal used by all hierarchical and combined methods +# format failing messages with optional header message +add_header <- function(messages, header) { + if (length(messages) > 0L) { + c(paste0(header, "\n"), unlist(messages), "\n") + } else NULL +} + +#' @keywords internal +# collate failing messages with optional header message +# internal used by grouped method +gather_and_add <- function(iv, header) { + fail_messages <- gather_messages(iv) + failings <- add_header(fail_messages, header) + failings +} From 7473a838dba6ff8238b5a3bc49f7d10104af008b Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Mon, 28 Nov 2022 15:37:21 +0100 Subject: [PATCH 02/68] gather_fails in tm_g_a_oview --- R/tm_g_ae_oview.R | 58 ++++++++++++++++++++--------------------------- 1 file changed, 25 insertions(+), 33 deletions(-) diff --git a/R/tm_g_ae_oview.R b/R/tm_g_ae_oview.R index be0dc970..321dbed5 100644 --- a/R/tm_g_ae_oview.R +++ b/R/tm_g_ae_oview.R @@ -120,7 +120,8 @@ 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 +233,9 @@ 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() - decorate_output <- srv_g_decorate(id = NULL, plt = plot_r, plot_height = plot_height, plot_width = plot_width) + 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 @@ -285,34 +281,30 @@ 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() - validate(need(iv_comp$is_valid(), "Misspecification error: please observe red flags in the encodings.")) + validate(need(is.factor(ANL[[input$arm_var]]), "Selected arm variable must be a factor." )) 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")) + + # set up and enable input validator(s) + iv <- shinyvalidate::InputValidator$new() + iv$add_rule("arm_var", shinyvalidate::sv_required( + message = "Arm Variable is required")) + iv$add_rule("flag_var_anl", shinyvalidate::sv_required( + message = "At least one Flag is required")) + iv$add_rule("arm_trt", shinyvalidate::sv_not_equal( + input$arm_ref, + message_fmt = "Control and Treatment must be different")) + iv$add_rule("arm_ref", shinyvalidate::sv_not_equal( + input$arm_trt, + message_fmt = "Control and Treatment must be different")) + iv$enable() + + # intercept validator messages + gather_fails(iv) + + validate(need(all(c(input$arm_trt, input$arm_ref) %in% unique(ANL[[input$arm_var]])), + "Plot loading")) q1 <- teal.code::eval_code( teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)), From 07dc66ea6a19ec10cac1f80b043d5cc68f90e166 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Tue, 29 Nov 2022 13:52:57 +0100 Subject: [PATCH 03/68] update examples --- R/gather_fails.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/gather_fails.R b/R/gather_fails.R index de1869ff..2ecac5a5 100644 --- a/R/gather_fails.R +++ b/R/gather_fails.R @@ -64,7 +64,7 @@ #' iv$enable() #' # more input validation #' iv_par <- InputValidator$new() -#' iv_par$add_rule("color", ~ if (is.null(.)) "choose a color") +#' iv_par$add_rule("color", sv_required(message = "choose a color")) #' iv_par$add_rule("color", ~ if (length(.) > 1L) "choose only one color") #' iv_par$add_rule("size", sv_between(left = 0.5, right = 3, #' message_fmt = "choose a value between {left} and {right}")) From f5898831cf5a7792971b7d77059d34efdcb0f15c Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Tue, 29 Nov 2022 13:53:19 +0100 Subject: [PATCH 04/68] replace validate with shinyvalidate --- R/tm_g_ae_oview.R | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/R/tm_g_ae_oview.R b/R/tm_g_ae_oview.R index 321dbed5..a9020c3e 100644 --- a/R/tm_g_ae_oview.R +++ b/R/tm_g_ae_oview.R @@ -282,14 +282,16 @@ srv_g_ae_oview <- function(id, output_q <- reactive({ ANL <- data[[dataname]]() # nolint - validate(need(is.factor(ANL[[input$arm_var]]), "Selected arm variable must be a factor." )) - validate(need(nlevels(ANL[[input$arm_var]]) > 1, "Arm needs to have at least 2 levels")) - validate_has_data(ANL, min_nrow = 10) + teal::validate_has_data(ANL, min_nrow = 10) # set up and enable input validator(s) 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[[req(.)]])) + "Arm Var must be a factor variable") + iv$add_rule("arm_var", ~ if (length(unique(ANL[[req(.)]])) < 2) + "This Arm Var has no groups to compare") iv$add_rule("flag_var_anl", shinyvalidate::sv_required( message = "At least one Flag is required")) iv$add_rule("arm_trt", shinyvalidate::sv_not_equal( @@ -300,7 +302,7 @@ srv_g_ae_oview <- function(id, message_fmt = "Control and Treatment must be different")) iv$enable() - # intercept validator messages + # collate validator messages gather_fails(iv) validate(need(all(c(input$arm_trt, input$arm_ref) %in% unique(ANL[[input$arm_var]])), From 3e7e800540e33d2a85148f8e8fe31393636e50ec Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Tue, 29 Nov 2022 14:11:46 +0100 Subject: [PATCH 05/68] use validations in tm_g_ae_sub --- R/tm_g_ae_sub.R | 57 ++++++++++++++++++++++--------------------------- 1 file changed, 26 insertions(+), 31 deletions(-) diff --git a/R/tm_g_ae_sub.R b/R/tm_g_ae_sub.R index fea6541d..cc13de0c 100644 --- a/R/tm_g_ae_sub.R +++ b/R/tm_g_ae_sub.R @@ -184,9 +184,6 @@ 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() decorate_output <- srv_g_decorate( id = NULL, @@ -289,40 +286,38 @@ 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( + + # set up and enable input validator(s) + 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[[req(.)]])) + "Arm Var must be a factor variable, contact developer") + iv$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( + message_fmt = "Control and Treatment must be different")) + iv$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.")) + message_fmt = "Control and Treatment must be different")) + iv$add_rule("groups", shinyvalidate::sv_in_set( + names(ANL), + message_fmt = "Groups must be a variable in ANL")) + iv$add_rule("groups", shinyvalidate::sv_in_set( + names(ADSL), + message_fmt = "Groups must be a variable in ADSL")) + iv$enable() + + # collate validator messages + gather_fails(iv) - 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." - ) - ) + all(c(input$arm_trt, input$arm_ref) %in% levels(ADSL[[input$arm_var]])) && + all(c(input$arm_trt, input$arm_ref) %in% levels(ANL[[input$arm_var]])), + "Plot loading" + )) group_labels <- lapply(seq_along(input$groups), function(x) { items <- input[[sprintf("groups__%s", x)]] From 3d80d6464f321427439a2f9bb1c35633f4dbf453 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Tue, 29 Nov 2022 14:35:49 +0100 Subject: [PATCH 06/68] use validations in tm_g_butterfly --- R/tm_g_butterfly.R | 66 +++++++++++++++++++++------------------------- 1 file changed, 30 insertions(+), 36 deletions(-) diff --git a/R/tm_g_butterfly.R b/R/tm_g_butterfly.R index 627fc490..3a0c33d2 100644 --- a/R/tm_g_butterfly.R +++ b/R/tm_g_butterfly.R @@ -269,11 +269,6 @@ 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() options <- reactiveValues(r = NULL, l = NULL) vars <- reactiveValues(r = NULL, l = NULL) @@ -360,6 +355,36 @@ srv_g_butterfly <- function(id, data, filter_panel_api, reporter, dataname, labe ADSL <- data[["ADSL"]]() # nolint ANL <- data[[dataname]]() # nolint + teal::validate_has_data(ADSL, min_nrow = 0, msg = "ADSL Data is empty") + teal::validate_has_data(ANL, min_nrow = 0, msg = "ANL Data is empty") + + 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[[req(.)]])) + "Right Dichotomization Variable must be a factor variable, contact developer") + iv$add_rule("left_var", ~ if (!is.factor(ANL[[req(.)]])) + "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() + + # collate validator messages + gather_fails(iv) + + validate( + need( + any(c(ADSL[[input$right_var]] %in% input$right_val, ADSL[[input$left_var]] %in% input$left_val)), + "ADSL Data contains no observations for either of the selected dichotomization values (filtered out?)" + ) + ) + right_var <- isolate(input$right_var) left_var <- isolate(input$left_var) right_val <- input$right_val @@ -372,37 +397,6 @@ srv_g_butterfly <- function(id, data, filter_panel_api, reporter, dataname, labe sort_by_var <- input$sort_by_var filter_var <- input$filter_var - 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") - ) - - 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?)" - ) - ) - # 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)) From c77cbb683e1533d99ef1de0e84cb285cee975b13 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Tue, 29 Nov 2022 15:17:46 +0100 Subject: [PATCH 07/68] use validations in tm_g_events_ternm_id --- R/tm_g_events_term_id.R | 58 ++++++++++++++++++----------------------- 1 file changed, 26 insertions(+), 32 deletions(-) diff --git a/R/tm_g_events_term_id.R b/R/tm_g_events_term_id.R index 6417b332..9a8eda92 100644 --- a/R/tm_g_events_term_id.R +++ b/R/tm_g_events_term_id.R @@ -213,10 +213,6 @@ 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() decorate_output <- srv_g_decorate( id = NULL, plt = plot_r, plot_height = plot_height, plot_width = plot_width @@ -240,8 +236,7 @@ srv_g_events_term_id <- function(id, }) - observeEvent(input$sort, - handlerExpr = { + observeEvent(input$sort, { sort <- if (is.null(input$sort)) " " else input$sort updateTextInput( session, @@ -260,15 +255,12 @@ srv_g_events_term_id <- function(id, ignoreNULL = FALSE ) - observeEvent(input$arm_var, - ignoreNULL = TRUE, - handlerExpr = { + observeEvent(input$arm_var, { 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 +279,37 @@ 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." - )) - - iv_comp <- shinyvalidate::InputValidator$new() - iv_comp$add_rule("arm_trt", shinyvalidate::sv_not_equal( + 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")) + iv$add_rule("arm_var", ~ if (!is.factor(ANL[[req(.)]])) + "Arm Var must be a factor variable, contact developer") + iv$add_rule("arm_var", ~ if (length(unique(ANL[[req(.)]])) < 2L) + "Selected Arm Var has not enough treatments to compare") + iv$add_rule("arm_trt", shinyvalidate::sv_in_set( + unique(ANL[[req(input$arm_var)]]), + message_fmt = "No subjects in Treatment")) + iv$add_rule("arm_ref", shinyvalidate::sv_in_set( + unique(ANL[[req(input$arm_var)]]), + message_fmt = "No subjects in Control")) + iv$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( + message_fmt = "Control and Treatment must be different")) + iv$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.")) + message_fmt = "Control and Treatment must be different")) + iv$enable() - 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." - )) + # collate validator messages + gather_fails(iv) adsl_vars <- unique(c("USUBJID", "STUDYID", input$arm_var)) # nolint anl_vars <- c("USUBJID", "STUDYID", input$term) # nolint @@ -333,7 +327,7 @@ 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 = "ANL needs at least 10 data points") q2 <- teal.code::eval_code( q1, From d803659bc5f946457e10432e8d09ed06469bbaf4 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Tue, 29 Nov 2022 18:25:55 +0100 Subject: [PATCH 08/68] use validations in tm_g_spiderplot --- R/tm_g_spiderplot.R | 64 +++++++++++++++++++++++++-------------------- 1 file changed, 35 insertions(+), 29 deletions(-) diff --git a/R/tm_g_spiderplot.R b/R/tm_g_spiderplot.R index 4856f8b7..387cf138 100644 --- a/R/tm_g_spiderplot.R +++ b/R/tm_g_spiderplot.R @@ -229,24 +229,44 @@ srv_g_spider <- function(id, data, filter_panel_api, reporter, dataname, label, moduleServer(id, function(input, output, session) { vals <- reactiveValues(spiderplot = NULL) # 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() - # render plot output_q <- reactive({ # get datasets --- ADSL <- data[["ADSL"]]() # nolint ADTR <- data[[dataname]]() # nolint + teal::validate_has_data(ADSL, min_nrow = 0, msg = sprintf("%s data has zero rows", "ADSL")) + teal::validate_has_data(ADTR, min_nrow = 0, msg = sprintf("%s data has zero rows", dataname)) + + # set up and enable input validator(s) + 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("marker_var", shinyvalidate::sv_required( + message = "Marker Symbol Variable is required")) + iv$add_rule("line_colorby_var", shinyvalidate::sv_required( + message = "Color Variable is required")) + fac_dupl <- function(value, other) { + # another possible test: + # if (length(setdiff(intersect(value, other), "")) > 0L) + if (length(value) * length(other) > 0 & 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(as_numeric_from_comma_sep_str(.))) + "Vertical Reference Line(s) are invalid") + iv$add_rule("href_line", ~ if (anyNA(as_numeric_from_comma_sep_str(.))) + "Horizontal Reference Line(s) are invalid") + iv$enable() + + # collate validator messages + gather_fails(iv) + paramcd <- input$paramcd # nolint x_var <- input$x_var y_var <- input$y_var @@ -259,9 +279,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(input$vref_line) + href_line <- as_numeric_from_comma_sep_str(input$href_line) # define variables --- # if variable is not in ADSL, then take from domain VADs @@ -304,20 +324,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( From cedcbb5e77c0c2ccd6b46f335124e318b1da9045 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Tue, 29 Nov 2022 19:04:12 +0100 Subject: [PATCH 09/68] use validations in tm_g_swimlane --- R/tm_g_swimlane.R | 87 +++++++++++++++++++++-------------------------- 1 file changed, 38 insertions(+), 49 deletions(-) diff --git a/R/tm_g_swimlane.R b/R/tm_g_swimlane.R index 06d96801..899e7708 100644 --- a/R/tm_g_swimlane.R +++ b/R/tm_g_swimlane.R @@ -275,10 +275,6 @@ 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() - # if marker position is NULL, then hide options for marker shape and color output$marker_shape_sel <- renderUI({ if (dataname == "ADSL" || is.null(marker_shape_var) || is.null(input$marker_pos_var)) { @@ -309,26 +305,55 @@ srv_g_swimlane <- function(id, # create plot output_q <- reactive({ - validate(need(iv$is_valid(), "Misspecification error: please observe red flags in the encodings.")) - - # 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") { + validate_has_data(ADSL, min_nrow = 3) + validate_has_variable(ADSL, adsl_vars) + } else { + anl <- data[[dataname]]() + validate_has_data(anl, min_nrow = 3) + 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" + )) + } + + + # set up and enable input validator(s) + 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(as_numeric_from_comma_sep_str(.))) + "Vertical Reference Line(s) are invalid") + iv$enable() + + # collate validator messages + gather_fails(iv) + # 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 +365,9 @@ srv_g_swimlane <- function(id, marker_shape_var <- input$marker_shape_var marker_color_var <- input$marker_color_var } - - 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, From 2917c8bf9e23ebb476f1f16c5b91af877b5c90ec Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Tue, 29 Nov 2022 20:22:42 +0100 Subject: [PATCH 10/68] use validations in tm_g_waterfall --- R/tm_g_waterfall.R | 137 ++++++++++++++++++++++++--------------------- 1 file changed, 73 insertions(+), 64 deletions(-) diff --git a/R/tm_g_waterfall.R b/R/tm_g_waterfall.R index fe08ebbf..11671466 100644 --- a/R/tm_g_waterfall.R +++ b/R/tm_g_waterfall.R @@ -293,15 +293,77 @@ srv_g_waterfall <- function(id, moduleServer(id, function(input, output, session) { output_q <- reactive({ - iv <- shinyvalidate::InputValidator$new() - iv$add_rule("bar_var", shinyvalidate::sv_required()) - iv$add_rule("bar_paramcd", shinyvalidate::sv_required()) - iv$enable() - adsl <- data[["ADSL"]]() adtr <- data[[dataname_tr]]() adrs <- data[[dataname_rs]]() + # validate data rows + validate_has_data(adsl, min_nrow = 2) + validate_has_data(adtr, min_nrow = 2) + 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 + validate_has_variable(adsl, adsl_vars) + validate_has_variable(adrs, adrs_vars) + validate_has_variable(adtr, adtr_vars) + + + + # set up and enable input validator(s) + iv <- shinyvalidate::InputValidator$new() + 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")) + + # If reference lines are requested + iv$add_rule("href_line", ~ if (anyNA(as_numeric_from_comma_sep_str(.))) + "Horizontal Reference Line(s) are invalid") + + 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("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 positive number") + iv$add_rule("gap_point_val", ~ if (!checkmate::test_integerish(suppressWarnings(as.numeric(.)), lower = 1)) + "Fractions are not allowed in Break High Bars") + 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 positive number") + iv$add_rule("ytick_at", ~ if (!checkmate::test_integerish(suppressWarnings(as.numeric(.)), lower = 1)) + "Fractions are not allowed in Y-axis Interval") + iv$enable() + + # collate validator messages + gather_fails(iv) + + + # get variables bar_var <- input$bar_var bar_paramcd <- input$bar_paramcd add_label_var_sl <- input$add_label_var_sl @@ -312,30 +374,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 <- 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 +401,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)), From de1c988975f2d1320c5b3c914e79635661ced708 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Tue, 29 Nov 2022 20:24:29 +0100 Subject: [PATCH 11/68] minor edits --- R/tm_g_ae_oview.R | 4 ++-- R/tm_g_ae_sub.R | 2 +- R/tm_g_butterfly.R | 5 +++-- R/tm_g_events_term_id.R | 1 + R/tm_g_waterfall.R | 14 +++++++------- 5 files changed, 14 insertions(+), 12 deletions(-) diff --git a/R/tm_g_ae_oview.R b/R/tm_g_ae_oview.R index a9020c3e..7adeba41 100644 --- a/R/tm_g_ae_oview.R +++ b/R/tm_g_ae_oview.R @@ -282,7 +282,7 @@ srv_g_ae_oview <- function(id, output_q <- reactive({ ANL <- data[[dataname]]() # nolint - teal::validate_has_data(ANL, min_nrow = 10) + teal::validate_has_data(ANL, min_nrow = 10, msg = sprintf("%s has not enough data", dataname)) # set up and enable input validator(s) iv <- shinyvalidate::InputValidator$new() @@ -291,7 +291,7 @@ srv_g_ae_oview <- function(id, iv$add_rule("arm_var", ~ if (!is.factor(ANL[[req(.)]])) "Arm Var must be a factor variable") iv$add_rule("arm_var", ~ if (length(unique(ANL[[req(.)]])) < 2) - "This Arm Var has no groups to compare") + "Selected Arm Var has not enough treatments to compare") iv$add_rule("flag_var_anl", shinyvalidate::sv_required( message = "At least one Flag is required")) iv$add_rule("arm_trt", shinyvalidate::sv_not_equal( diff --git a/R/tm_g_ae_sub.R b/R/tm_g_ae_sub.R index cc13de0c..26af3189 100644 --- a/R/tm_g_ae_sub.R +++ b/R/tm_g_ae_sub.R @@ -287,7 +287,7 @@ srv_g_ae_sub <- function(id, ANL <- data[[dataname]]() # nolint ADSL <- data[["ADSL"]]() # nolint - validate_has_data(ANL, min_nrow = 10) + teal::validate_has_data(ANL, min_nrow = 10, msg = sprintf("%s has not enough data", dataname)) # set up and enable input validator(s) iv <- shinyvalidate::InputValidator$new() diff --git a/R/tm_g_butterfly.R b/R/tm_g_butterfly.R index 3a0c33d2..17f6262f 100644 --- a/R/tm_g_butterfly.R +++ b/R/tm_g_butterfly.R @@ -355,9 +355,10 @@ srv_g_butterfly <- function(id, data, filter_panel_api, reporter, dataname, labe ADSL <- data[["ADSL"]]() # nolint ANL <- data[[dataname]]() # nolint - teal::validate_has_data(ADSL, min_nrow = 0, msg = "ADSL Data is empty") - teal::validate_has_data(ANL, min_nrow = 0, msg = "ANL Data is empty") + 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)) + # set up and enable input validator(s) iv <- shinyvalidate::InputValidator$new() iv$add_rule("category_var", shinyvalidate::sv_required( message = "Category Variable is required")) diff --git a/R/tm_g_events_term_id.R b/R/tm_g_events_term_id.R index 9a8eda92..1a06efdf 100644 --- a/R/tm_g_events_term_id.R +++ b/R/tm_g_events_term_id.R @@ -285,6 +285,7 @@ srv_g_events_term_id <- function(id, output_q <- reactive({ ANL <- data[[dataname]]() # nolint + # set up and enable input validator(s) iv <- shinyvalidate::InputValidator$new() iv$add_rule("term", shinyvalidate::sv_required( message = "Term Variable is required")) diff --git a/R/tm_g_waterfall.R b/R/tm_g_waterfall.R index 11671466..8c5046a0 100644 --- a/R/tm_g_waterfall.R +++ b/R/tm_g_waterfall.R @@ -298,9 +298,9 @@ srv_g_waterfall <- function(id, adrs <- data[[dataname_rs]]() # validate data rows - validate_has_data(adsl, min_nrow = 2) - validate_has_data(adtr, min_nrow = 2) - validate_has_data(adrs, min_nrow = 2) + 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", @@ -311,9 +311,9 @@ srv_g_waterfall <- function(id, adrs_paramcd <- unique(c(input$add_label_paramcd_rs, input$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) + teal::validate_has_variable(adsl, adsl_vars) + teal::validate_has_variable(adrs, adrs_vars) + teal::validate_has_variable(adtr, adtr_vars) @@ -453,7 +453,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, From 976252cd67352832a4e984de60d50964458651da Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Wed, 30 Nov 2022 13:42:53 +0100 Subject: [PATCH 12/68] use validations in tm_g_heat_bygrade --- R/tm_g_heat_bygrade.R | 110 ++++++++++++++++++++---------------------- 1 file changed, 53 insertions(+), 57 deletions(-) diff --git a/R/tm_g_heat_bygrade.R b/R/tm_g_heat_bygrade.R index dad9f1a2..b90dd8cd 100644 --- a/R/tm_g_heat_bygrade.R +++ b/R/tm_g_heat_bygrade.R @@ -315,14 +315,12 @@ srv_g_heatmap_bygrade <- function(id, checkmate::assert_class(data, "tdata") 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 + 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 @@ -352,62 +350,64 @@ srv_g_heatmap_bygrade <- function(id, }) 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.")) - 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 = " ") - )) + teal::validate_has_data(ADSL, min_nrow = 0, msg = sprintf("%s contains no data", sl_dataname)) - validate(need( - checkmate::test_logical(ADEX[[input$ongo_var]], min.len = 1, any.missing = FALSE), - "Study Ongoing Status must be a logical variable" - )) + # set up and enable input validator(s) + 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 (!is.null(input$id_var) && input$id_var %in% .) + sprintf("Deselect %s in Annotation Variables", req(input$id_var))) + iv$add_rule("heat_var", shinyvalidate::sv_required( + message = "Heat Variable is required")) + iv$enable() - validate(need( - all(anno_var %in% names(ADSL)), - paste("Please only select annotation variable(s) in", sl_dataname, sep = " ") - )) + # set up conditional validator + 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")) + 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))) + iv_cm$add_rule("conmed_var", ~ if (!is.factor(ADCM[[req(.)]])) + "Study Ongoing Status must be a factor variable") + iv_cm$add_rule("conmed_level", ~if (length(.) > 3L) + "No more than three Conmed Levels are allowed") + iv_cm$enable() - validate(need( - !(input$id_var %in% anno_var), - paste("Please de-select", input$id_var, "in annotation variable(s)", sep = " ") - )) + # collate validator messages + gather_fails_com(iv, iv_cm) - if (isTRUE(input$plot_cm)) { - ADCM <- data[[cm_dataname]]() # nolint - validate( - need( - input$conmed_var %in% names(ADCM), - paste("Please select a Conmed Variable in", cm_dataname, sep = " ") - ) - ) - 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" - )) - } + validate(need( + all(input$conmed_level %in% unique(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.")) teal.code::eval_code( teal.code::new_qenv(tdata2env(data), code = teal::get_code_tdata(data)), @@ -423,15 +423,11 @@ srv_g_heatmap_bygrade <- function(id, ) } else { teal.code::eval_code( - teal.code::new_qenv(tdata2env(data), code = teal.code::get_code(data)), + teal.code::new_qenv(tdata2env(data), code = teal::get_code_tdata(data)), code = quote(conmed_data <- conmed_var <- NULL) ) } - validate( - need(length(input$conmed_level) <= 3, "Please select no more than 3 conmed levels") - ) - q2 <- teal.code::eval_code( q1, code = bquote({ From fc1bfcf3518b15e0aa1ec58cbcb379ae7595c1bc Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Wed, 30 Nov 2022 15:05:30 +0100 Subject: [PATCH 13/68] use validations in tm_g_patient_profile --- R/tm_g_patient_profile.R | 122 +++++++++++++++++++-------------------- 1 file changed, 60 insertions(+), 62 deletions(-) diff --git a/R/tm_g_patient_profile.R b/R/tm_g_patient_profile.R index 11a48d4a..05682446 100644 --- a/R/tm_g_patient_profile.R +++ b/R/tm_g_patient_profile.R @@ -426,11 +426,6 @@ srv_g_patient_profile <- function(id, checkmate::assert_class(data, "tdata") 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() # only show the check box when domain data is available observeEvent(ae_dataname, { @@ -509,6 +504,55 @@ srv_g_patient_profile <- function(id, # render plot output_q <- reactive({ + + # set up and enable input validator(s) + iv <- shinyvalidate::InputValidator$new() + iv$add_rule("sl_start_date", shinyvalidate::sv_required( + message = "Date variable is required")) + iv$add_rule("ex_var", shinyvalidate::sv_required( + message = "Exposure variable is required")) + 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(ADAE[[.]])) > length(ae_line_col_opt)) + "Not enough colors provided Adverse Event line color, unselect") + iv$add_rule("rs_var", shinyvalidate::sv_required( + message = "Tumor response variable is required")) + iv$add_rule("cm_var", shinyvalidate::sv_required( + message = "Concomitant medicine variable is required")) + 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 (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(as_numeric_from_comma_sep_str(.))) + "Study Days Range is invalid") + iv$add_rule("x_limit", ~ if (length(as_numeric_from_comma_sep_str(.)) != 2L) + "Study Days Range must be two values") + iv$add_rule("x_limit", ~ if (!identical(order(as_numeric_from_comma_sep_str(.)), 1:2)) + "Study Days Range mut be: first lower, then upper limit") + rule_dataset <- function(value) { + if (!any(c(input$select_ae, input$select_ex, input$select_rs, input$select_cm, input$select_lb))) + "Select at least one ADaM data set" + } + iv$add_rule("select_ae", rule_dataset) + iv$add_rule("select_ex", rule_dataset) + iv$add_rule("select_rs", rule_dataset) + iv$add_rule("select_cm", rule_dataset) + iv$add_rule("select_lb", rule_dataset) + + iv$enable() + + # collate validator messages + gather_fails(iv) + # get inputs --- patient_id <- input$patient_id # nolint sl_start_date <- input$sl_start_date # nolint @@ -521,13 +565,6 @@ srv_g_patient_profile <- function(id, 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", @@ -567,7 +604,7 @@ srv_g_patient_profile <- function(id, ADEX <- NULL # nolint } else { ADEX <- data[[ex_dataname]]() # nolint - validate_has_variable(ADEX, adex_vars) + teal::validate_has_variable(ADEX, adex_vars) } } else { ADEX <- NULL # nolint @@ -578,7 +615,7 @@ srv_g_patient_profile <- function(id, ADAE <- NULL # nolint } else { ADAE <- data[[ae_dataname]]() # nolint - validate_has_variable(ADAE, adae_vars) + teal::validate_has_variable(ADAE, adae_vars) } } else { ADAE <- NULL # nolint @@ -589,7 +626,7 @@ srv_g_patient_profile <- function(id, ADRS <- NULL # nolint } else { ADRS <- data[[rs_dataname]]() # nolint - validate_has_variable(ADRS, adrs_vars) + teal::validate_has_variable(ADRS, adrs_vars) } } else { ADRS <- NULL # nolint @@ -600,7 +637,7 @@ srv_g_patient_profile <- function(id, ADCMD <- NULL # nolint } else { ADCM <- data[[cm_dataname]]() # nolint - validate_has_variable(ADCM, adcm_vars) + teal::validate_has_variable(ADCM, adcm_vars) } } else { ADCM <- NULL # nolint @@ -611,24 +648,12 @@ srv_g_patient_profile <- function(id, ADLB <- NULL # nolint } else { ADLB <- data[[lb_dataname]]() # nolint - validate_has_variable(ADLB, adlb_vars) + teal::validate_has_variable(ADLB, adlb_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, @@ -648,6 +673,11 @@ srv_g_patient_profile <- function(id, } ) + # Check that at least 1 dataset is selected + validate( + need(any(select_plot), "Please select an ADaM dataset.") + ) + names(select_plot) <- possible_plot empty_rs <- FALSE @@ -687,7 +717,7 @@ srv_g_patient_profile <- function(id, paste( "Subject", patient_id, - "not found in the dataset. Have they been filtered out by filtering in the filter panel?" + "not found in the dataset. Perhaps they have been filtered out by the filter panel?" ) ) ) @@ -704,9 +734,6 @@ srv_g_patient_profile <- function(id, } q1 <- if (select_plot["ae"]) { - validate( - need(!is.null(input$ae_var), "Please select an adverse event variable.") - ) if (all(ADAE$USUBJID %in% ADSL$USUBJID)) { qq <- teal.code::eval_code( q1, @@ -792,9 +819,6 @@ srv_g_patient_profile <- function(id, } 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, @@ -837,9 +861,6 @@ srv_g_patient_profile <- function(id, } 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, @@ -890,9 +911,6 @@ srv_g_patient_profile <- function(id, } 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, @@ -948,11 +966,7 @@ srv_g_patient_profile <- function(id, } 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({ @@ -1001,13 +1015,6 @@ srv_g_patient_profile <- function(id, 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 <- c(empty_ex, empty_ae, empty_rs, empty_cm, empty_lb) @@ -1038,15 +1045,6 @@ srv_g_patient_profile <- function(id, 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({ From dad84814eb417ff4ec4e2584261962f83e48c6fa Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Wed, 30 Nov 2022 16:29:21 +0100 Subject: [PATCH 14/68] fix validations of selected values --- R/tm_g_ae_oview.R | 9 ++++++--- R/tm_g_ae_sub.R | 13 ++++++------- R/tm_g_heat_bygrade.R | 7 +++---- 3 files changed, 15 insertions(+), 14 deletions(-) diff --git a/R/tm_g_ae_oview.R b/R/tm_g_ae_oview.R index 7adeba41..76e9bf96 100644 --- a/R/tm_g_ae_oview.R +++ b/R/tm_g_ae_oview.R @@ -300,14 +300,17 @@ srv_g_ae_oview <- function(id, iv$add_rule("arm_ref", shinyvalidate::sv_not_equal( input$arm_trt, message_fmt = "Control and Treatment must be different")) + iv$add_rule("arm_trt", shinyvalidate::sv_in_set( + set = unique(ANL[[req(input$arm_var)]]), + message_fmt = "Treatment not found in Arm Variable")) + iv$add_rule("arm_ref", shinyvalidate::sv_in_set( + set = unique(ANL[[req(input$arm_var)]]), + message_fmt = "Control not found in Arm Variable")) iv$enable() # collate validator messages gather_fails(iv) - validate(need(all(c(input$arm_trt, input$arm_ref) %in% unique(ANL[[input$arm_var]])), - "Plot loading")) - q1 <- teal.code::eval_code( teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)), code = as.expression(c( diff --git a/R/tm_g_ae_sub.R b/R/tm_g_ae_sub.R index 26af3189..7b384147 100644 --- a/R/tm_g_ae_sub.R +++ b/R/tm_g_ae_sub.R @@ -307,18 +307,17 @@ srv_g_ae_sub <- function(id, iv$add_rule("groups", shinyvalidate::sv_in_set( names(ADSL), message_fmt = "Groups must be a variable in ADSL")) + iv$add_rule("arm_trt", shinyvalidate::sv_in_set( + set = unique(ANL[[req(input$arm_var)]]), + message_fmt = "Treatment not found in Arm Variable")) + iv$add_rule("arm_ref", shinyvalidate::sv_in_set( + set = unique(ANL[[req(input$arm_var)]]), + message_fmt = "Control not found in Arm Variable")) iv$enable() # collate validator messages gather_fails(iv) - validate( - need( - all(c(input$arm_trt, input$arm_ref) %in% levels(ADSL[[input$arm_var]])) && - all(c(input$arm_trt, input$arm_ref) %in% levels(ANL[[input$arm_var]])), - "Plot loading" - )) - group_labels <- lapply(seq_along(input$groups), function(x) { items <- input[[sprintf("groups__%s", x)]] if (length(items) > 0) { diff --git a/R/tm_g_heat_bygrade.R b/R/tm_g_heat_bygrade.R index b90dd8cd..b38a37d2 100644 --- a/R/tm_g_heat_bygrade.R +++ b/R/tm_g_heat_bygrade.R @@ -397,15 +397,14 @@ srv_g_heatmap_bygrade <- function(id, "Study Ongoing Status must be a factor variable") iv_cm$add_rule("conmed_level", ~if (length(.) > 3L) "No more than three Conmed Levels are allowed") + iv_cm$add_rule("conmed_level", shinyvalidate::sv_in_set( + set = unique(ADCM[[req(input$conmed_var)]]), + message_fmt = "Updating Conmed Levels")) iv_cm$enable() # collate validator messages gather_fails_com(iv, iv_cm) - validate(need( - all(input$conmed_level %in% unique(ADCM[[input$conmed_var]])), - "Updating Conmed Levels")) - q1 <- if (isTRUE(input$plot_cm)) { conmed_var <- input$conmed_var From b29540cb5a5f59d5a5775ed058b5a849ce6c4f38 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Thu, 1 Dec 2022 11:49:57 +0100 Subject: [PATCH 15/68] apply review and clean up --- R/tm_g_ae_oview.R | 16 ++++++---------- R/tm_g_ae_sub.R | 12 ++++-------- R/tm_g_butterfly.R | 9 +++------ R/tm_g_events_term_id.R | 13 ++++--------- R/tm_g_heat_bygrade.R | 5 +---- R/tm_g_patient_profile.R | 3 --- R/tm_g_spiderplot.R | 6 +----- R/tm_g_swimlane.R | 11 ++++------- R/tm_g_waterfall.R | 8 -------- 9 files changed, 23 insertions(+), 60 deletions(-) diff --git a/R/tm_g_ae_oview.R b/R/tm_g_ae_oview.R index 76e9bf96..07206403 100644 --- a/R/tm_g_ae_oview.R +++ b/R/tm_g_ae_oview.R @@ -284,14 +284,13 @@ srv_g_ae_oview <- function(id, teal::validate_has_data(ANL, min_nrow = 10, msg = sprintf("%s has not enough data", dataname)) - # set up and enable input validator(s) 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[[req(.)]])) "Arm Var must be a factor variable") - iv$add_rule("arm_var", ~ if (length(unique(ANL[[req(.)]])) < 2) - "Selected Arm Var has not enough treatments to compare") + iv$add_rule("arm_var", ~ if (length(levels(ANL[[req(.)]])) < 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")) iv$add_rule("arm_trt", shinyvalidate::sv_not_equal( @@ -300,17 +299,14 @@ srv_g_ae_oview <- function(id, iv$add_rule("arm_ref", shinyvalidate::sv_not_equal( input$arm_trt, message_fmt = "Control and Treatment must be different")) - iv$add_rule("arm_trt", shinyvalidate::sv_in_set( - set = unique(ANL[[req(input$arm_var)]]), - message_fmt = "Treatment not found in Arm Variable")) - iv$add_rule("arm_ref", shinyvalidate::sv_in_set( - set = unique(ANL[[req(input$arm_var)]]), - message_fmt = "Control not found in Arm Variable")) iv$enable() - # collate validator messages gather_fails(iv) + validate(need(input$arm_trt %in% unique(ANL[[input$arm_var]]) || + input$arm_ref %in% unique(ANL[[input$arm_var]]), + "Treatment or Control not found in Arm Variable. Filtered out?")) + q1 <- teal.code::eval_code( teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)), code = as.expression(c( diff --git a/R/tm_g_ae_sub.R b/R/tm_g_ae_sub.R index 7b384147..6856de8a 100644 --- a/R/tm_g_ae_sub.R +++ b/R/tm_g_ae_sub.R @@ -289,7 +289,6 @@ srv_g_ae_sub <- function(id, teal::validate_has_data(ANL, min_nrow = 10, msg = sprintf("%s has not enough data", dataname)) - # set up and enable input validator(s) iv <- shinyvalidate::InputValidator$new() iv$add_rule("arm_var", shinyvalidate::sv_required( message = "Arm Variable is required")) @@ -307,17 +306,14 @@ srv_g_ae_sub <- function(id, iv$add_rule("groups", shinyvalidate::sv_in_set( names(ADSL), message_fmt = "Groups must be a variable in ADSL")) - iv$add_rule("arm_trt", shinyvalidate::sv_in_set( - set = unique(ANL[[req(input$arm_var)]]), - message_fmt = "Treatment not found in Arm Variable")) - iv$add_rule("arm_ref", shinyvalidate::sv_in_set( - set = unique(ANL[[req(input$arm_var)]]), - message_fmt = "Control not found in Arm Variable")) iv$enable() - # collate validator messages gather_fails(iv) + validate(need(input$arm_trt %in% unique(ANL[[input$arm_var]]) || + input$arm_ref %in% unique(ANL[[input$arm_var]]), + "Treatment or Control not found in Arm Variable. Filtered out?")) + group_labels <- lapply(seq_along(input$groups), function(x) { items <- input[[sprintf("groups__%s", x)]] if (length(items) > 0) { diff --git a/R/tm_g_butterfly.R b/R/tm_g_butterfly.R index 17f6262f..141f9cd1 100644 --- a/R/tm_g_butterfly.R +++ b/R/tm_g_butterfly.R @@ -358,7 +358,6 @@ srv_g_butterfly <- function(id, data, filter_panel_api, reporter, dataname, labe 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)) - # set up and enable input validator(s) iv <- shinyvalidate::InputValidator$new() iv$add_rule("category_var", shinyvalidate::sv_required( message = "Category Variable is required")) @@ -376,15 +375,13 @@ srv_g_butterfly <- function(id, data, filter_panel_api, reporter, dataname, labe message = "At least one value of Left Dichotomization Variable must be selected")) iv$enable() - # collate validator messages gather_fails(iv) validate( need( - any(c(ADSL[[input$right_var]] %in% input$right_val, ADSL[[input$left_var]] %in% input$left_val)), - "ADSL Data contains no observations for either of the selected dichotomization values (filtered out?)" - ) - ) + input$right_val %in% ADSL[[input$right_var]] && + input$left_val %in% ADSL[[input$right_var]], + "No observations for selected dichotomization values (filtered out?)")) right_var <- isolate(input$right_var) left_var <- isolate(input$left_var) diff --git a/R/tm_g_events_term_id.R b/R/tm_g_events_term_id.R index 1a06efdf..333b6528 100644 --- a/R/tm_g_events_term_id.R +++ b/R/tm_g_events_term_id.R @@ -285,7 +285,6 @@ srv_g_events_term_id <- function(id, output_q <- reactive({ ANL <- data[[dataname]]() # nolint - # set up and enable input validator(s) iv <- shinyvalidate::InputValidator$new() iv$add_rule("term", shinyvalidate::sv_required( message = "Term Variable is required")) @@ -293,14 +292,6 @@ srv_g_events_term_id <- function(id, message = "Arm Variable is required")) iv$add_rule("arm_var", ~ if (!is.factor(ANL[[req(.)]])) "Arm Var must be a factor variable, contact developer") - iv$add_rule("arm_var", ~ if (length(unique(ANL[[req(.)]])) < 2L) - "Selected Arm Var has not enough treatments to compare") - iv$add_rule("arm_trt", shinyvalidate::sv_in_set( - unique(ANL[[req(input$arm_var)]]), - message_fmt = "No subjects in Treatment")) - iv$add_rule("arm_ref", shinyvalidate::sv_in_set( - unique(ANL[[req(input$arm_var)]]), - message_fmt = "No subjects in Control")) iv$add_rule("arm_trt", shinyvalidate::sv_not_equal( input$arm_ref, message_fmt = "Control and Treatment must be different")) @@ -312,6 +303,10 @@ srv_g_events_term_id <- function(id, # collate validator messages gather_fails(iv) + validate(need(input$arm_trt %in% unique(ANL[[req(input$arm_var)]]) && + input$arm_ref %in% unique(ANL[[req(input$arm_var)]]), + "Cannot generate plot. No subjects in both Control and Treatment arms.")) + adsl_vars <- unique(c("USUBJID", "STUDYID", input$arm_var)) # nolint anl_vars <- c("USUBJID", "STUDYID", input$term) # nolint diff --git a/R/tm_g_heat_bygrade.R b/R/tm_g_heat_bygrade.R index b38a37d2..e5db25e7 100644 --- a/R/tm_g_heat_bygrade.R +++ b/R/tm_g_heat_bygrade.R @@ -359,7 +359,6 @@ srv_g_heatmap_bygrade <- function(id, teal::validate_has_data(ADSL, min_nrow = 0, msg = sprintf("%s contains no data", sl_dataname)) - # set up and enable input validator(s) iv <- shinyvalidate::InputValidator$new() iv$add_rule("id_var", shinyvalidate::sv_required( message = "ID Variable is required")) @@ -379,13 +378,12 @@ srv_g_heatmap_bygrade <- function(id, 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 (!is.null(input$id_var) && input$id_var %in% .) + iv$add_rule("anno_var", ~ if (isTRUE(input$id_var %in% .)) sprintf("Deselect %s in Annotation Variables", req(input$id_var))) iv$add_rule("heat_var", shinyvalidate::sv_required( message = "Heat Variable is required")) iv$enable() - # set up conditional validator iv_cm <- shinyvalidate::InputValidator$new() iv_cm$condition(~ isTRUE(input$plot_cm)) iv_cm$add_rule("conmed_var", shinyvalidate::sv_required( @@ -402,7 +400,6 @@ srv_g_heatmap_bygrade <- function(id, message_fmt = "Updating Conmed Levels")) iv_cm$enable() - # collate validator messages gather_fails_com(iv, iv_cm) q1 <- if (isTRUE(input$plot_cm)) { diff --git a/R/tm_g_patient_profile.R b/R/tm_g_patient_profile.R index 05682446..8fca2ff5 100644 --- a/R/tm_g_patient_profile.R +++ b/R/tm_g_patient_profile.R @@ -505,7 +505,6 @@ srv_g_patient_profile <- function(id, # render plot output_q <- reactive({ - # set up and enable input validator(s) iv <- shinyvalidate::InputValidator$new() iv$add_rule("sl_start_date", shinyvalidate::sv_required( message = "Date variable is required")) @@ -547,10 +546,8 @@ srv_g_patient_profile <- function(id, iv$add_rule("select_rs", rule_dataset) iv$add_rule("select_cm", rule_dataset) iv$add_rule("select_lb", rule_dataset) - iv$enable() - # collate validator messages gather_fails(iv) # get inputs --- diff --git a/R/tm_g_spiderplot.R b/R/tm_g_spiderplot.R index 387cf138..3c01a46a 100644 --- a/R/tm_g_spiderplot.R +++ b/R/tm_g_spiderplot.R @@ -238,7 +238,6 @@ srv_g_spider <- function(id, data, filter_panel_api, reporter, dataname, label, teal::validate_has_data(ADSL, min_nrow = 0, msg = sprintf("%s data has zero rows", "ADSL")) teal::validate_has_data(ADTR, min_nrow = 0, msg = sprintf("%s data has zero rows", dataname)) - # set up and enable input validator(s) iv <- shinyvalidate::InputValidator$new() iv$add_rule("paramcd", shinyvalidate::sv_required( message = "Parameter is required")) @@ -251,9 +250,7 @@ srv_g_spider <- function(id, data, filter_panel_api, reporter, dataname, label, iv$add_rule("line_colorby_var", shinyvalidate::sv_required( message = "Color Variable is required")) fac_dupl <- function(value, other) { - # another possible test: - # if (length(setdiff(intersect(value, other), "")) > 0L) - if (length(value) * length(other) > 0 & anyDuplicated(c(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) @@ -264,7 +261,6 @@ srv_g_spider <- function(id, data, filter_panel_api, reporter, dataname, label, "Horizontal Reference Line(s) are invalid") iv$enable() - # collate validator messages gather_fails(iv) paramcd <- input$paramcd # nolint diff --git a/R/tm_g_swimlane.R b/R/tm_g_swimlane.R index 899e7708..b775d152 100644 --- a/R/tm_g_swimlane.R +++ b/R/tm_g_swimlane.R @@ -321,12 +321,12 @@ srv_g_swimlane <- function(id, input$bar_var, input$bar_color_var, input$sort_var, input$anno_txt_var)) if (dataname == "ADSL") { - validate_has_data(ADSL, min_nrow = 3) - validate_has_variable(ADSL, adsl_vars) + teal::validate_has_data(ADSL, min_nrow = 3) + teal::validate_has_variable(ADSL, adsl_vars) } else { anl <- data[[dataname]]() - validate_has_data(anl, min_nrow = 3) - validate_has_variable(anl, anl_vars) + 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), @@ -334,8 +334,6 @@ srv_g_swimlane <- function(id, )) } - - # set up and enable input validator(s) iv <- shinyvalidate::InputValidator$new() iv$add_rule("bar_var", shinyvalidate::sv_required( message = "Bar Length is required")) @@ -344,7 +342,6 @@ srv_g_swimlane <- function(id, "Vertical Reference Line(s) are invalid") iv$enable() - # collate validator messages gather_fails(iv) diff --git a/R/tm_g_waterfall.R b/R/tm_g_waterfall.R index 8c5046a0..94efa235 100644 --- a/R/tm_g_waterfall.R +++ b/R/tm_g_waterfall.R @@ -315,23 +315,16 @@ srv_g_waterfall <- function(id, teal::validate_has_variable(adrs, adrs_vars) teal::validate_has_variable(adtr, adtr_vars) - - - # set up and enable input validator(s) iv <- shinyvalidate::InputValidator$new() 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")) - - # If reference lines are requested iv$add_rule("href_line", ~ if (anyNA(as_numeric_from_comma_sep_str(.))) "Horizontal Reference Line(s) are invalid") - iv$add_rule("add_label_paramcd_rs", shinyvalidate::sv_optional()) iv$add_rule("add_label_paramcd_rs", shinyvalidate::sv_in_set( set = adrs$PARAMCD, @@ -359,7 +352,6 @@ srv_g_waterfall <- function(id, "Fractions are not allowed in Y-axis Interval") iv$enable() - # collate validator messages gather_fails(iv) From b6b54f54321c6c80cc283ceb6c8d52b32d40587c Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Thu, 1 Dec 2022 12:25:45 +0100 Subject: [PATCH 16/68] add namespace prefixes for gather_fails --- R/tm_g_ae_oview.R | 2 +- R/tm_g_ae_sub.R | 2 +- R/tm_g_butterfly.R | 2 +- R/tm_g_events_term_id.R | 2 +- R/tm_g_heat_bygrade.R | 2 +- R/tm_g_patient_profile.R | 2 +- R/tm_g_spiderplot.R | 2 +- R/tm_g_swimlane.R | 2 +- R/tm_g_waterfall.R | 2 +- 9 files changed, 9 insertions(+), 9 deletions(-) diff --git a/R/tm_g_ae_oview.R b/R/tm_g_ae_oview.R index 07206403..7ba29386 100644 --- a/R/tm_g_ae_oview.R +++ b/R/tm_g_ae_oview.R @@ -301,7 +301,7 @@ srv_g_ae_oview <- function(id, message_fmt = "Control and Treatment must be different")) iv$enable() - gather_fails(iv) + teal::gather_fails(iv) validate(need(input$arm_trt %in% unique(ANL[[input$arm_var]]) || input$arm_ref %in% unique(ANL[[input$arm_var]]), diff --git a/R/tm_g_ae_sub.R b/R/tm_g_ae_sub.R index 6856de8a..c0e8a3ff 100644 --- a/R/tm_g_ae_sub.R +++ b/R/tm_g_ae_sub.R @@ -308,7 +308,7 @@ srv_g_ae_sub <- function(id, message_fmt = "Groups must be a variable in ADSL")) iv$enable() - gather_fails(iv) + teal::gather_fails(iv) validate(need(input$arm_trt %in% unique(ANL[[input$arm_var]]) || input$arm_ref %in% unique(ANL[[input$arm_var]]), diff --git a/R/tm_g_butterfly.R b/R/tm_g_butterfly.R index 141f9cd1..ffa7f64d 100644 --- a/R/tm_g_butterfly.R +++ b/R/tm_g_butterfly.R @@ -375,7 +375,7 @@ srv_g_butterfly <- function(id, data, filter_panel_api, reporter, dataname, labe message = "At least one value of Left Dichotomization Variable must be selected")) iv$enable() - gather_fails(iv) + teal::gather_fails(iv) validate( need( diff --git a/R/tm_g_events_term_id.R b/R/tm_g_events_term_id.R index 333b6528..48f70f2e 100644 --- a/R/tm_g_events_term_id.R +++ b/R/tm_g_events_term_id.R @@ -301,7 +301,7 @@ srv_g_events_term_id <- function(id, iv$enable() # collate validator messages - gather_fails(iv) + teal::gather_fails(iv) validate(need(input$arm_trt %in% unique(ANL[[req(input$arm_var)]]) && input$arm_ref %in% unique(ANL[[req(input$arm_var)]]), diff --git a/R/tm_g_heat_bygrade.R b/R/tm_g_heat_bygrade.R index e5db25e7..92a40133 100644 --- a/R/tm_g_heat_bygrade.R +++ b/R/tm_g_heat_bygrade.R @@ -400,7 +400,7 @@ srv_g_heatmap_bygrade <- function(id, message_fmt = "Updating Conmed Levels")) iv_cm$enable() - gather_fails_com(iv, iv_cm) + teal::gather_fails_com(iv, iv_cm) q1 <- if (isTRUE(input$plot_cm)) { conmed_var <- input$conmed_var diff --git a/R/tm_g_patient_profile.R b/R/tm_g_patient_profile.R index 8fca2ff5..53a2eeeb 100644 --- a/R/tm_g_patient_profile.R +++ b/R/tm_g_patient_profile.R @@ -548,7 +548,7 @@ srv_g_patient_profile <- function(id, iv$add_rule("select_lb", rule_dataset) iv$enable() - gather_fails(iv) + teal::gather_fails(iv) # get inputs --- patient_id <- input$patient_id # nolint diff --git a/R/tm_g_spiderplot.R b/R/tm_g_spiderplot.R index 3c01a46a..2ce37506 100644 --- a/R/tm_g_spiderplot.R +++ b/R/tm_g_spiderplot.R @@ -261,7 +261,7 @@ srv_g_spider <- function(id, data, filter_panel_api, reporter, dataname, label, "Horizontal Reference Line(s) are invalid") iv$enable() - gather_fails(iv) + teal::gather_fails(iv) paramcd <- input$paramcd # nolint x_var <- input$x_var diff --git a/R/tm_g_swimlane.R b/R/tm_g_swimlane.R index b775d152..1927b4df 100644 --- a/R/tm_g_swimlane.R +++ b/R/tm_g_swimlane.R @@ -342,7 +342,7 @@ srv_g_swimlane <- function(id, "Vertical Reference Line(s) are invalid") iv$enable() - gather_fails(iv) + teal::gather_fails(iv) # VARIABLE GETTERS diff --git a/R/tm_g_waterfall.R b/R/tm_g_waterfall.R index 94efa235..dbd0740e 100644 --- a/R/tm_g_waterfall.R +++ b/R/tm_g_waterfall.R @@ -352,7 +352,7 @@ srv_g_waterfall <- function(id, "Fractions are not allowed in Y-axis Interval") iv$enable() - gather_fails(iv) + teal::gather_fails(iv) # get variables From b2ee629fdf30827d85ef43d17c136d8b426ac625 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Thu, 1 Dec 2022 12:26:07 +0100 Subject: [PATCH 17/68] move gather_fails to teal package --- R/gather_fails.R | 169 ----------------------------------------------- 1 file changed, 169 deletions(-) delete mode 100644 R/gather_fails.R diff --git a/R/gather_fails.R b/R/gather_fails.R deleted file mode 100644 index 2ecac5a5..00000000 --- a/R/gather_fails.R +++ /dev/null @@ -1,169 +0,0 @@ - -#' send input validation messages to output -#' -#' Captures messages from `InputValidator` objects and collates them -#' into one message passed to `validate`. -#' -#' `shiny::validate` is used to withhold rendering of an output element until -#' certain conditions are met and a print a validation message in place -#' of the output element. -#' `shinyvalidate` allows to validate input elements and display specific messages -#' in their respective input widgets. -#' This function is a hybrid solution. Given an `InputValidator` object, -#' it extracts messages from inputs that fail validation and places them all in one -#' validation message that is passed to a `validate`/`need` call. -#' This way the input validator messages are repeated in the output. -#' -#' \code{gather_fails} accepts one `InputValidator` -#' and can add a header to its validation messages. -#' \code{gather_fails_com} accepts an arbitrary number of `InputValidator`s -#' and prints all messages together under one header. -#' \code{gather_fails_grp} accepts a \strong{list} of `InputValidator`s -#' and prints messages in groups. If elements of \code{validators} are named, -#' the names are used as headers for their respective message groups. -#' -#' -#' @name gather_fails -#' -#' @param iv object of class `InputValidator` -#' @param header `character(1)` optional generic validation message -#' @param ... arguments passed to `shiny::validate` -#' @param validators optionally named `list` of `InputValidator` objects, see\code{Details} -#' -#' @return -#' Returns NULL if the final validation call passes and a `shiny.silent.error` if it fails. -#' -#' @seealso \code{\link{[shinyvalidate::InputValidator]}} \code{\link{[shiny::validate]}} -#' -#' @examples -#' library(shiny) -#' library(shinyvalidate) -#' -#' ui <- fluidPage( -#' selectInput("method", "validation method", c("hierarchical", "combined", "grouped")), -#' sidebarLayout( -#' sidebarPanel( -#' selectInput("letter", "select a letter:", c(letters[1:3], LETTERS[4:6])), -#' selectInput("number", "select a number:", 1:6), -#' br(), -#' selectInput("color", "select a color:", -#' c("black", "indianred2", "springgreen2", "cornflowerblue"), -#' multiple = TRUE), -#' sliderInput("size", "select point size:", -#' min = 0.1, max = 4, value = 0.25) -#' ), -#' mainPanel(plotOutput('plot')) -#' ) -#' ) -#' -#' server <- function(input, output) { -#' # set up input validation -#' iv <- InputValidator$new() -#' iv$add_rule("letter", sv_in_set(LETTERS, "choose a capital letter")) -#' iv$add_rule("number", ~ if (as.integer(.) %% 2L == 1L) "choose an even number") -#' iv$enable() -#' # more input validation -#' iv_par <- InputValidator$new() -#' iv_par$add_rule("color", sv_required(message = "choose a color")) -#' iv_par$add_rule("color", ~ if (length(.) > 1L) "choose only one color") -#' iv_par$add_rule("size", sv_between(left = 0.5, right = 3, -#' message_fmt = "choose a value between {left} and {right}")) -#' iv_par$enable() -#' -#' -#' output$plot <- renderPlot({ -#' # validate output -#' switch(input[["method"]], -#' "hierarchical" = { -#' gather_fails(iv) -#' gather_fails(iv_par, "Set proper graphical parameters") -#' }, -#' "combined" = gather_fails_com(iv, iv_par), -#' "grouped" = gather_fails_grp(list( -#' "Some inputs require attention" = iv, -#' "Set proper graphical parameters" = iv_par -#' ))) -#' -#' plot(eruptions ~ waiting, faithful, las = 1, pch = 16, -#' col = input[["color"]], cex = input[["size"]]) -#' }) -#' } -#' -#' if (interactive()) { -#' shinyApp(ui, server) -#' } - - -#' @rdname gather_fials -#' @export -gather_fails <- function(iv, header = "Some inputs require attention", ...) { - checkmate::assert_class(iv, "InputValidator") - checkmate::assert_string(header, null.ok = TRUE) - - fail_messages <- gather_messages(iv) - failings <- add_header(fail_messages, header) - - shiny::validate(shiny::need(is.null(failings), failings), ...) -} - - -#' @rdname gather_fials -#' @export -gather_fails_com <- function(..., header = "Some inputs require attention") { - vals <- list(...) - lapply(vals, checkmate::assert_class, "InputValidator") - checkmate::assert_string(header, null.ok = TRUE) - - fail_messages <- unlist(lapply(vals, gather_messages)) - failings <- add_header(fail_messages, header) - - shiny::validate(shiny::need(is.null(failings), failings)) -} - - -#' @rdname gather_fials -#' @export -gather_fails_grp <- function(validators, ...) { - checkmate::assert_list(validators, types = "InputValidator") - - # Since some or all names may be NULL, mapply cannot be used here, a loop is required. - fail_messages <- vector("list", length(validators)) - for (v in seq_along(validators)) { - fail_messages[[v]] <- gather_and_add(validators[[v]], names(validators)[v]) - } - - failings <- unlist(fail_messages) - - shiny::validate(shiny::need(is.null(failings), failings), ...) -} - - -### internal functions - -#' @keywords internal -# internal used by all methods -# collate failing messages from validator -gather_messages <- function(iv) { - status <- iv$validate() - failing_inputs <- Filter(Negate(is.null), status) - unique(lapply(failing_inputs, function(x) x[["message"]])) -} - - -#' @keywords internal -# internal used by all hierarchical and combined methods -# format failing messages with optional header message -add_header <- function(messages, header) { - if (length(messages) > 0L) { - c(paste0(header, "\n"), unlist(messages), "\n") - } else NULL -} - -#' @keywords internal -# collate failing messages with optional header message -# internal used by grouped method -gather_and_add <- function(iv, header) { - fail_messages <- gather_messages(iv) - failings <- add_header(fail_messages, header) - failings -} From 3380b6b3887339110ce897a7b17ec3b50be63ce7 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Thu, 1 Dec 2022 12:26:22 +0100 Subject: [PATCH 18/68] update DESCRIPTION --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 43e1ba06..76b72a7f 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -65,4 +65,4 @@ Encoding: UTF-8 Language: en-US LazyData: true Roxygen: list(markdown = TRUE) -RoxygenNote: 7.2.1 +RoxygenNote: 7.2.2 From 325043068b653e8edabfabb14539aeff304471d0 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Wed, 7 Dec 2022 13:10:20 +0100 Subject: [PATCH 19/68] update NEWS --- NEWS.md | 1 + 1 file changed, 1 insertion(+) diff --git a/NEWS.md b/NEWS.md index 9df107f2..0e24e5d6 100644 --- a/NEWS.md +++ b/NEWS.md @@ -3,6 +3,7 @@ * 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. ### Breaking changes From 78a7203100605a85e60ce414a5afdeef697d979d Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Wed, 7 Dec 2022 13:10:52 +0100 Subject: [PATCH 20/68] changed 'gather_fails' to 'validate_inputs' --- R/tm_g_ae_oview.R | 2 +- R/tm_g_ae_sub.R | 2 +- R/tm_g_butterfly.R | 2 +- R/tm_g_events_term_id.R | 3 +-- R/tm_g_heat_bygrade.R | 2 +- R/tm_g_patient_profile.R | 2 +- R/tm_g_spiderplot.R | 2 +- R/tm_g_swimlane.R | 2 +- R/tm_g_waterfall.R | 2 +- 9 files changed, 9 insertions(+), 10 deletions(-) diff --git a/R/tm_g_ae_oview.R b/R/tm_g_ae_oview.R index 7ba29386..6c5b92aa 100644 --- a/R/tm_g_ae_oview.R +++ b/R/tm_g_ae_oview.R @@ -301,7 +301,7 @@ srv_g_ae_oview <- function(id, message_fmt = "Control and Treatment must be different")) iv$enable() - teal::gather_fails(iv) + teal::validate_inputs(iv) validate(need(input$arm_trt %in% unique(ANL[[input$arm_var]]) || input$arm_ref %in% unique(ANL[[input$arm_var]]), diff --git a/R/tm_g_ae_sub.R b/R/tm_g_ae_sub.R index c0e8a3ff..4b82a834 100644 --- a/R/tm_g_ae_sub.R +++ b/R/tm_g_ae_sub.R @@ -308,7 +308,7 @@ srv_g_ae_sub <- function(id, message_fmt = "Groups must be a variable in ADSL")) iv$enable() - teal::gather_fails(iv) + teal::validate_inputs(iv) validate(need(input$arm_trt %in% unique(ANL[[input$arm_var]]) || input$arm_ref %in% unique(ANL[[input$arm_var]]), diff --git a/R/tm_g_butterfly.R b/R/tm_g_butterfly.R index ffa7f64d..deccea6d 100644 --- a/R/tm_g_butterfly.R +++ b/R/tm_g_butterfly.R @@ -375,7 +375,7 @@ srv_g_butterfly <- function(id, data, filter_panel_api, reporter, dataname, labe message = "At least one value of Left Dichotomization Variable must be selected")) iv$enable() - teal::gather_fails(iv) + teal::validate_inputs(iv) validate( need( diff --git a/R/tm_g_events_term_id.R b/R/tm_g_events_term_id.R index 48f70f2e..1caa821a 100644 --- a/R/tm_g_events_term_id.R +++ b/R/tm_g_events_term_id.R @@ -300,8 +300,7 @@ srv_g_events_term_id <- function(id, message_fmt = "Control and Treatment must be different")) iv$enable() - # collate validator messages - teal::gather_fails(iv) + teal::validate_inputs(iv) validate(need(input$arm_trt %in% unique(ANL[[req(input$arm_var)]]) && input$arm_ref %in% unique(ANL[[req(input$arm_var)]]), diff --git a/R/tm_g_heat_bygrade.R b/R/tm_g_heat_bygrade.R index 92a40133..e134f733 100644 --- a/R/tm_g_heat_bygrade.R +++ b/R/tm_g_heat_bygrade.R @@ -400,7 +400,7 @@ srv_g_heatmap_bygrade <- function(id, message_fmt = "Updating Conmed Levels")) iv_cm$enable() - teal::gather_fails_com(iv, iv_cm) + teal::validate_inputs(iv, iv_cm) q1 <- if (isTRUE(input$plot_cm)) { conmed_var <- input$conmed_var diff --git a/R/tm_g_patient_profile.R b/R/tm_g_patient_profile.R index 53a2eeeb..117994db 100644 --- a/R/tm_g_patient_profile.R +++ b/R/tm_g_patient_profile.R @@ -548,7 +548,7 @@ srv_g_patient_profile <- function(id, iv$add_rule("select_lb", rule_dataset) iv$enable() - teal::gather_fails(iv) + teal::validate_inputs(iv) # get inputs --- patient_id <- input$patient_id # nolint diff --git a/R/tm_g_spiderplot.R b/R/tm_g_spiderplot.R index 2ce37506..626bfe62 100644 --- a/R/tm_g_spiderplot.R +++ b/R/tm_g_spiderplot.R @@ -261,7 +261,7 @@ srv_g_spider <- function(id, data, filter_panel_api, reporter, dataname, label, "Horizontal Reference Line(s) are invalid") iv$enable() - teal::gather_fails(iv) + teal::validate_inputs(iv) paramcd <- input$paramcd # nolint x_var <- input$x_var diff --git a/R/tm_g_swimlane.R b/R/tm_g_swimlane.R index 1927b4df..5f251528 100644 --- a/R/tm_g_swimlane.R +++ b/R/tm_g_swimlane.R @@ -342,7 +342,7 @@ srv_g_swimlane <- function(id, "Vertical Reference Line(s) are invalid") iv$enable() - teal::gather_fails(iv) + teal::validate_inputs(iv) # VARIABLE GETTERS diff --git a/R/tm_g_waterfall.R b/R/tm_g_waterfall.R index dbd0740e..ff6bedff 100644 --- a/R/tm_g_waterfall.R +++ b/R/tm_g_waterfall.R @@ -352,7 +352,7 @@ srv_g_waterfall <- function(id, "Fractions are not allowed in Y-axis Interval") iv$enable() - teal::gather_fails(iv) + teal::validate_inputs(iv) # get variables From 221b250ed75b96b8795c8bc167c5befb7af84c2e Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Wed, 7 Dec 2022 12:16:02 +0000 Subject: [PATCH 21/68] [skip actions] Restyle files --- R/tm_g_ae_oview.R | 43 ++++++++++++++++++----------- R/tm_g_ae_sub.R | 29 ++++++++++++-------- R/tm_g_butterfly.R | 30 ++++++++++++-------- R/tm_g_events_term_id.R | 35 +++++++++++++++--------- R/tm_g_heat_bygrade.R | 59 +++++++++++++++++++++++++--------------- R/tm_g_patient_profile.R | 52 +++++++++++++++++++++-------------- R/tm_g_spiderplot.R | 28 ++++++++++++------- R/tm_g_swimlane.R | 27 +++++++++++------- R/tm_g_waterfall.R | 56 ++++++++++++++++++++++++-------------- 9 files changed, 225 insertions(+), 134 deletions(-) diff --git a/R/tm_g_ae_oview.R b/R/tm_g_ae_oview.R index 6c5b92aa..bcdd48b7 100644 --- a/R/tm_g_ae_oview.R +++ b/R/tm_g_ae_oview.R @@ -120,8 +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], @@ -233,9 +235,10 @@ srv_g_ae_oview <- function(id, checkmate::assert_class(data, "tdata") moduleServer(id, function(input, output, session) { - - decorate_output <- srv_g_decorate(id = NULL, plt = plot_r, - plot_height = plot_height, plot_width = plot_width) + 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 @@ -286,26 +289,34 @@ srv_g_ae_oview <- function(id, 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[[req(.)]])) - "Arm Var must be a factor variable") - iv$add_rule("arm_var", ~ if (length(levels(ANL[[req(.)]])) < 2L) - "Selected Arm Var must have at least two levels") + message = "Arm Variable is required" + )) + iv$add_rule("arm_var", ~ if (!is.factor(ANL[[req(.)]])) { + "Arm Var must be a factor variable" + }) + iv$add_rule("arm_var", ~ if (length(levels(ANL[[req(.)]])) < 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")) + message = "At least one Flag is required" + )) iv$add_rule("arm_trt", shinyvalidate::sv_not_equal( input$arm_ref, - message_fmt = "Control and Treatment must be different")) + message_fmt = "Control and Treatment must be different" + )) iv$add_rule("arm_ref", shinyvalidate::sv_not_equal( input$arm_trt, - message_fmt = "Control and Treatment must be different")) + message_fmt = "Control and Treatment must be different" + )) iv$enable() teal::validate_inputs(iv) - validate(need(input$arm_trt %in% unique(ANL[[input$arm_var]]) || - input$arm_ref %in% unique(ANL[[input$arm_var]]), - "Treatment or Control not found in Arm Variable. Filtered out?")) + validate(need( + input$arm_trt %in% unique(ANL[[input$arm_var]]) || + input$arm_ref %in% unique(ANL[[input$arm_var]]), + "Treatment or Control not found in Arm Variable. Filtered out?" + )) q1 <- teal.code::eval_code( teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)), diff --git a/R/tm_g_ae_sub.R b/R/tm_g_ae_sub.R index 4b82a834..545c686a 100644 --- a/R/tm_g_ae_sub.R +++ b/R/tm_g_ae_sub.R @@ -184,7 +184,6 @@ srv_g_ae_sub <- function(id, checkmate::assert_class(data, "tdata") moduleServer(id, function(input, output, session) { - decorate_output <- srv_g_decorate( id = NULL, plt = plot_r, @@ -291,28 +290,36 @@ srv_g_ae_sub <- function(id, 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[[req(.)]])) - "Arm Var must be a factor variable, contact developer") + message = "Arm Variable is required" + )) + iv$add_rule("arm_var", ~ if (!is.factor(ANL[[req(.)]])) { + "Arm Var must be a factor variable, contact developer" + }) iv$add_rule("arm_trt", shinyvalidate::sv_not_equal( input$arm_ref, - message_fmt = "Control and Treatment must be different")) + message_fmt = "Control and Treatment must be different" + )) iv$add_rule("arm_ref", shinyvalidate::sv_not_equal( input$arm_trt, - message_fmt = "Control and Treatment must be different")) + message_fmt = "Control and Treatment must be different" + )) iv$add_rule("groups", shinyvalidate::sv_in_set( names(ANL), - message_fmt = "Groups must be a variable in ANL")) + message_fmt = "Groups must be a variable in ANL" + )) iv$add_rule("groups", shinyvalidate::sv_in_set( names(ADSL), - message_fmt = "Groups must be a variable in ADSL")) + message_fmt = "Groups must be a variable in ADSL" + )) iv$enable() teal::validate_inputs(iv) - validate(need(input$arm_trt %in% unique(ANL[[input$arm_var]]) || - input$arm_ref %in% unique(ANL[[input$arm_var]]), - "Treatment or Control not found in Arm Variable. Filtered out?")) + validate(need( + input$arm_trt %in% unique(ANL[[input$arm_var]]) || + input$arm_ref %in% unique(ANL[[input$arm_var]]), + "Treatment or Control not found in Arm Variable. Filtered out?" + )) group_labels <- lapply(seq_along(input$groups), function(x) { items <- input[[sprintf("groups__%s", x)]] diff --git a/R/tm_g_butterfly.R b/R/tm_g_butterfly.R index deccea6d..a743cae2 100644 --- a/R/tm_g_butterfly.R +++ b/R/tm_g_butterfly.R @@ -269,7 +269,6 @@ srv_g_butterfly <- function(id, data, filter_panel_api, reporter, dataname, labe checkmate::assert_class(data, "tdata") moduleServer(id, function(input, output, session) { - options <- reactiveValues(r = NULL, l = NULL) vars <- reactiveValues(r = NULL, l = NULL) @@ -360,19 +359,26 @@ srv_g_butterfly <- function(id, data, filter_panel_api, reporter, dataname, labe iv <- shinyvalidate::InputValidator$new() iv$add_rule("category_var", shinyvalidate::sv_required( - message = "Category Variable is required")) + message = "Category Variable is required" + )) iv$add_rule("right_var", shinyvalidate::sv_required( - message = "Right Dichotomization Variable is 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[[req(.)]])) - "Right Dichotomization Variable must be a factor variable, contact developer") - iv$add_rule("left_var", ~ if (!is.factor(ANL[[req(.)]])) - "Left Dichotomization Variable must be a factor variable, contact developer") + message = "Left Dichotomization Variable is required" + )) + iv$add_rule("right_var", ~ if (!is.factor(ANL[[req(.)]])) { + "Right Dichotomization Variable must be a factor variable, contact developer" + }) + iv$add_rule("left_var", ~ if (!is.factor(ANL[[req(.)]])) { + "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")) + 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")) + message = "At least one value of Left Dichotomization Variable must be selected" + )) iv$enable() teal::validate_inputs(iv) @@ -381,7 +387,9 @@ srv_g_butterfly <- function(id, data, filter_panel_api, reporter, dataname, labe need( input$right_val %in% ADSL[[input$right_var]] && input$left_val %in% ADSL[[input$right_var]], - "No observations for selected dichotomization values (filtered out?)")) + "No observations for selected dichotomization values (filtered out?)" + ) + ) right_var <- isolate(input$right_var) left_var <- isolate(input$left_var) diff --git a/R/tm_g_events_term_id.R b/R/tm_g_events_term_id.R index 1caa821a..5ee8690d 100644 --- a/R/tm_g_events_term_id.R +++ b/R/tm_g_events_term_id.R @@ -213,7 +213,6 @@ srv_g_events_term_id <- function(id, checkmate::assert_class(data, "tdata") moduleServer(id, function(input, output, session) { - decorate_output <- srv_g_decorate( id = NULL, plt = plot_r, plot_height = plot_height, plot_width = plot_width ) @@ -236,7 +235,8 @@ srv_g_events_term_id <- function(id, }) - observeEvent(input$sort, { + observeEvent(input$sort, + { sort <- if (is.null(input$sort)) " " else input$sort updateTextInput( session, @@ -255,7 +255,8 @@ srv_g_events_term_id <- function(id, ignoreNULL = FALSE ) - observeEvent(input$arm_var, { + observeEvent(input$arm_var, + { arm_var <- input$arm_var ANL <- data[[dataname]]() # nolint @@ -279,7 +280,8 @@ srv_g_events_term_id <- function(id, selected = choices[trt_index], choices = choices ) - }, ignoreNULL = TRUE + }, + ignoreNULL = TRUE ) output_q <- reactive({ @@ -287,24 +289,31 @@ srv_g_events_term_id <- function(id, iv <- shinyvalidate::InputValidator$new() iv$add_rule("term", shinyvalidate::sv_required( - message = "Term Variable is required")) + message = "Term Variable is required" + )) iv$add_rule("arm_var", shinyvalidate::sv_required( - message = "Arm Variable is required")) - iv$add_rule("arm_var", ~ if (!is.factor(ANL[[req(.)]])) - "Arm Var must be a factor variable, contact developer") + message = "Arm Variable is required" + )) + iv$add_rule("arm_var", ~ if (!is.factor(ANL[[req(.)]])) { + "Arm Var must be a factor variable, contact developer" + }) iv$add_rule("arm_trt", shinyvalidate::sv_not_equal( input$arm_ref, - message_fmt = "Control and Treatment must be different")) + message_fmt = "Control and Treatment must be different" + )) iv$add_rule("arm_ref", shinyvalidate::sv_not_equal( input$arm_trt, - message_fmt = "Control and Treatment must be different")) + message_fmt = "Control and Treatment must be different" + )) iv$enable() teal::validate_inputs(iv) - validate(need(input$arm_trt %in% unique(ANL[[req(input$arm_var)]]) && - input$arm_ref %in% unique(ANL[[req(input$arm_var)]]), - "Cannot generate plot. No subjects in both Control and Treatment arms.")) + validate(need( + input$arm_trt %in% unique(ANL[[req(input$arm_var)]]) && + input$arm_ref %in% unique(ANL[[req(input$arm_var)]]), + "Cannot generate plot. No subjects in both Control and Treatment arms." + )) adsl_vars <- unique(c("USUBJID", "STUDYID", input$arm_var)) # nolint anl_vars <- c("USUBJID", "STUDYID", input$term) # nolint diff --git a/R/tm_g_heat_bygrade.R b/R/tm_g_heat_bygrade.R index e134f733..233794c1 100644 --- a/R/tm_g_heat_bygrade.R +++ b/R/tm_g_heat_bygrade.R @@ -315,12 +315,12 @@ srv_g_heatmap_bygrade <- function(id, checkmate::assert_class(data, "tdata") moduleServer(id, function(input, output, session) { - decorate_output <- srv_g_decorate( id = NULL, plt = plot_r, plot_height = plot_height, - plot_width = plot_width) # nolint + plot_width = plot_width + ) # nolint font_size <- decorate_output$font_size pws <- decorate_output$pws @@ -361,43 +361,58 @@ srv_g_heatmap_bygrade <- function(id, iv <- shinyvalidate::InputValidator$new() iv$add_rule("id_var", shinyvalidate::sv_required( - message = "ID Variable is required")) + message = "ID Variable is required" + )) iv$add_rule("visit_var", shinyvalidate::sv_required( - message = "Visit Variable is required")) + message = "Visit Variable is required" + )) iv$add_rule("ongo_var", shinyvalidate::sv_required( - message = "Study Ongoing Status Variable is 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") + 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") + 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", req(input$id_var))) + 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", req(input$id_var)) + }) iv$add_rule("heat_var", shinyvalidate::sv_required( - message = "Heat Variable is required")) + message = "Heat Variable is required" + )) iv$enable() 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")) + message = "Conmed Variable is required" + )) 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))) - iv_cm$add_rule("conmed_var", ~ if (!is.factor(ADCM[[req(.)]])) - "Study Ongoing Status must be a factor variable") - iv_cm$add_rule("conmed_level", ~if (length(.) > 3L) - "No more than three Conmed Levels are allowed") + message_fmt = sprintf("Conmed Variable must be a variable in %s", cm_dataname) + )) + iv_cm$add_rule("conmed_var", ~ if (!is.factor(ADCM[[req(.)]])) { + "Study Ongoing Status must be a factor variable" + }) + iv_cm$add_rule("conmed_level", ~ if (length(.) > 3L) { + "No more than three Conmed Levels are allowed" + }) iv_cm$add_rule("conmed_level", shinyvalidate::sv_in_set( set = unique(ADCM[[req(input$conmed_var)]]), - message_fmt = "Updating Conmed Levels")) + message_fmt = "Updating Conmed Levels" + )) iv_cm$enable() teal::validate_inputs(iv, iv_cm) diff --git a/R/tm_g_patient_profile.R b/R/tm_g_patient_profile.R index 117994db..db2542bf 100644 --- a/R/tm_g_patient_profile.R +++ b/R/tm_g_patient_profile.R @@ -426,7 +426,6 @@ srv_g_patient_profile <- function(id, checkmate::assert_class(data, "tdata") moduleServer(id, function(input, output, session) { - # only show the check box when domain data is available observeEvent(ae_dataname, { if (!is.na(ae_dataname)) { @@ -504,42 +503,55 @@ srv_g_patient_profile <- function(id, # render plot output_q <- reactive({ - iv <- shinyvalidate::InputValidator$new() iv$add_rule("sl_start_date", shinyvalidate::sv_required( - message = "Date variable is required")) + message = "Date variable is required" + )) iv$add_rule("ex_var", shinyvalidate::sv_required( - message = "Exposure variable is required")) + message = "Exposure variable is required" + )) iv$add_rule("ae_var", shinyvalidate::sv_required( - message = "Adverse Event variable is 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(ADAE[[.]])) > length(ae_line_col_opt)) - "Not enough colors provided Adverse Event line color, unselect") + iv$add_rule("ae_line_var", ~ if (length(levels(ADAE[[.]])) > length(ae_line_col_opt)) { + "Not enough colors provided Adverse Event line color, unselect" + }) iv$add_rule("rs_var", shinyvalidate::sv_required( - message = "Tumor response variable is required")) + message = "Tumor response variable is required" + )) iv$add_rule("cm_var", shinyvalidate::sv_required( - message = "Concomitant medicine variable is required")) + message = "Concomitant medicine variable is required" + )) iv$add_rule("lb_var", shinyvalidate::sv_required( - message = "Lab variable is required")) + message = "Lab variable is required" + )) iv$add_rule("lb_var_show", shinyvalidate::sv_required( - message = "At least one Lab value is required")) + message = "At least one Lab value is required" + )) rule_diff <- function(value, other) { - if (any(value == other)) + if (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(as_numeric_from_comma_sep_str(.))) - "Study Days Range is invalid") - iv$add_rule("x_limit", ~ if (length(as_numeric_from_comma_sep_str(.)) != 2L) - "Study Days Range must be two values") - iv$add_rule("x_limit", ~ if (!identical(order(as_numeric_from_comma_sep_str(.)), 1:2)) - "Study Days Range mut be: first lower, then upper limit") + message = "Study Days Range is required" + )) + iv$add_rule("x_limit", ~ if (anyNA(as_numeric_from_comma_sep_str(.))) { + "Study Days Range is invalid" + }) + iv$add_rule("x_limit", ~ if (length(as_numeric_from_comma_sep_str(.)) != 2L) { + "Study Days Range must be two values" + }) + iv$add_rule("x_limit", ~ if (!identical(order(as_numeric_from_comma_sep_str(.)), 1:2)) { + "Study Days Range mut be: first lower, then upper limit" + }) rule_dataset <- function(value) { - if (!any(c(input$select_ae, input$select_ex, input$select_rs, input$select_cm, input$select_lb))) + if (!any(c(input$select_ae, input$select_ex, input$select_rs, input$select_cm, input$select_lb))) { "Select at least one ADaM data set" + } } iv$add_rule("select_ae", rule_dataset) iv$add_rule("select_ex", rule_dataset) diff --git a/R/tm_g_spiderplot.R b/R/tm_g_spiderplot.R index 626bfe62..4fa2eca4 100644 --- a/R/tm_g_spiderplot.R +++ b/R/tm_g_spiderplot.R @@ -240,25 +240,33 @@ srv_g_spider <- function(id, data, filter_panel_api, reporter, dataname, label, iv <- shinyvalidate::InputValidator$new() iv$add_rule("paramcd", shinyvalidate::sv_required( - message = "Parameter is required")) + message = "Parameter is required" + )) iv$add_rule("x_var", shinyvalidate::sv_required( - message = "X Axis Variable is required")) + message = "X Axis Variable is required" + )) iv$add_rule("y_var", shinyvalidate::sv_required( - message = "Y Axis Variable is required")) + message = "Y Axis Variable is required" + )) iv$add_rule("marker_var", shinyvalidate::sv_required( - message = "Marker Symbol Variable is required")) + message = "Marker Symbol Variable is required" + )) iv$add_rule("line_colorby_var", shinyvalidate::sv_required( - message = "Color Variable is required")) + message = "Color Variable is required" + )) fac_dupl <- function(value, other) { - if (length(value) * length(other) > 0L & anyDuplicated(c(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(as_numeric_from_comma_sep_str(.))) - "Vertical Reference Line(s) are invalid") - iv$add_rule("href_line", ~ if (anyNA(as_numeric_from_comma_sep_str(.))) - "Horizontal Reference Line(s) are invalid") + iv$add_rule("vref_line", ~ if (anyNA(as_numeric_from_comma_sep_str(.))) { + "Vertical Reference Line(s) are invalid" + }) + iv$add_rule("href_line", ~ if (anyNA(as_numeric_from_comma_sep_str(.))) { + "Horizontal Reference Line(s) are invalid" + }) iv$enable() teal::validate_inputs(iv) diff --git a/R/tm_g_swimlane.R b/R/tm_g_swimlane.R index 5f251528..3f00b103 100644 --- a/R/tm_g_swimlane.R +++ b/R/tm_g_swimlane.R @@ -309,16 +309,21 @@ srv_g_swimlane <- function(id, validate(need( (length(data) == 1 && dataname == "ADSL") || (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." - ))) + "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 - 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)) + 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) @@ -336,10 +341,12 @@ srv_g_swimlane <- function(id, iv <- shinyvalidate::InputValidator$new() iv$add_rule("bar_var", shinyvalidate::sv_required( - message = "Bar Length is required")) + message = "Bar Length is required" + )) # If reference lines are requested - iv$add_rule("vref_line", ~ if (anyNA(as_numeric_from_comma_sep_str(.))) - "Vertical Reference Line(s) are invalid") + iv$add_rule("vref_line", ~ if (anyNA(as_numeric_from_comma_sep_str(.))) { + "Vertical Reference Line(s) are invalid" + }) iv$enable() teal::validate_inputs(iv) diff --git a/R/tm_g_waterfall.R b/R/tm_g_waterfall.R index ff6bedff..e06de510 100644 --- a/R/tm_g_waterfall.R +++ b/R/tm_g_waterfall.R @@ -303,8 +303,10 @@ srv_g_waterfall <- function(id, 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) + 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")) @@ -317,39 +319,51 @@ srv_g_waterfall <- function(id, iv <- shinyvalidate::InputValidator$new() iv$add_rule("bar_var", shinyvalidate::sv_required( - message = "Bar Height is required")) + message = "Bar Height is required" + )) iv$add_rule("bar_paramcd", shinyvalidate::sv_required( - message = "Tumor Burden Parameter is 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("href_line", ~ if (anyNA(as_numeric_from_comma_sep_str(.))) - "Horizontal Reference Line(s) are invalid") + message_fmt = "All values of Tumor Burden Parameter must be elements of ADTR PARAMCD" + )) + iv$add_rule("href_line", ~ if (anyNA(as_numeric_from_comma_sep_str(.))) { + "Horizontal Reference Line(s) are invalid" + }) 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")) + 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) + 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")) + set = adrs$PARAMCD, + message_fmt = "Annotation Parameters must be elements of ADRS PARAMCD" + )) 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 positive number") - iv$add_rule("gap_point_val", ~ if (!checkmate::test_integerish(suppressWarnings(as.numeric(.)), lower = 1)) - "Fractions are not allowed in Break High Bars") + iv$add_rule("gap_point_val", ~ if (!checkmate::test_number(suppressWarnings(as.numeric(.)), lower = 1)) { + "Break High Bars must be a positive number" + }) + iv$add_rule("gap_point_val", ~ if (!checkmate::test_integerish(suppressWarnings(as.numeric(.)), lower = 1)) { + "Fractions are not allowed in Break High Bars" + }) 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 positive number") - iv$add_rule("ytick_at", ~ if (!checkmate::test_integerish(suppressWarnings(as.numeric(.)), lower = 1)) - "Fractions are not allowed in Y-axis Interval") + 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 positive number" + }) + iv$add_rule("ytick_at", ~ if (!checkmate::test_integerish(suppressWarnings(as.numeric(.)), lower = 1)) { + "Fractions are not allowed in Y-axis Interval" + }) iv$enable() teal::validate_inputs(iv) From cb9d781827819948555badf4a3175fb76ee21d5a Mon Sep 17 00:00:00 2001 From: Nikolas Burkoff Date: Thu, 8 Dec 2022 09:36:23 +0000 Subject: [PATCH 22/68] trigger From 133bbe1ea0830383f950cb60b164c4f4389912cf Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Thu, 8 Dec 2022 13:58:51 +0100 Subject: [PATCH 23/68] apply code review --- R/tm_g_ae_oview.R | 6 +++--- R/tm_g_ae_sub.R | 2 +- R/tm_g_butterfly.R | 8 ++++---- R/tm_g_events_term_id.R | 7 ++++--- R/tm_g_heat_bygrade.R | 4 ++-- R/tm_g_spiderplot.R | 12 ++++++------ R/tm_g_swimlane.R | 28 ++++++++++++++-------------- R/tm_g_waterfall.R | 23 +++++++++-------------- 8 files changed, 43 insertions(+), 47 deletions(-) diff --git a/R/tm_g_ae_oview.R b/R/tm_g_ae_oview.R index bcdd48b7..dc47fc67 100644 --- a/R/tm_g_ae_oview.R +++ b/R/tm_g_ae_oview.R @@ -291,10 +291,10 @@ srv_g_ae_oview <- function(id, iv$add_rule("arm_var", shinyvalidate::sv_required( message = "Arm Variable is required" )) - iv$add_rule("arm_var", ~ if (!is.factor(ANL[[req(.)]])) { + iv$add_rule("arm_var", ~ if (!is.factor(ANL[[.]])) { "Arm Var must be a factor variable" }) - iv$add_rule("arm_var", ~ if (length(levels(ANL[[req(.)]])) < 2L) { + iv$add_rule("arm_var", ~ if (length(levels(ANL[[.]])) < 2L) { "Selected Arm Var must have at least two levels" }) iv$add_rule("flag_var_anl", shinyvalidate::sv_required( @@ -315,7 +315,7 @@ srv_g_ae_oview <- function(id, validate(need( input$arm_trt %in% unique(ANL[[input$arm_var]]) || input$arm_ref %in% unique(ANL[[input$arm_var]]), - "Treatment or Control not found in Arm Variable. Filtered out?" + "Treatment or Control not found in Arm Variable. Perhaps they have been filtered out?" )) q1 <- teal.code::eval_code( diff --git a/R/tm_g_ae_sub.R b/R/tm_g_ae_sub.R index 545c686a..ba4b70b5 100644 --- a/R/tm_g_ae_sub.R +++ b/R/tm_g_ae_sub.R @@ -318,7 +318,7 @@ srv_g_ae_sub <- function(id, validate(need( input$arm_trt %in% unique(ANL[[input$arm_var]]) || input$arm_ref %in% unique(ANL[[input$arm_var]]), - "Treatment or Control not found in Arm Variable. Filtered out?" + "Treatment or Control not found in Arm Variable. Perhaps they have been filtered out?" )) group_labels <- lapply(seq_along(input$groups), function(x) { diff --git a/R/tm_g_butterfly.R b/R/tm_g_butterfly.R index a743cae2..5aa713f3 100644 --- a/R/tm_g_butterfly.R +++ b/R/tm_g_butterfly.R @@ -367,10 +367,10 @@ srv_g_butterfly <- function(id, data, filter_panel_api, reporter, dataname, labe iv$add_rule("left_var", shinyvalidate::sv_required( message = "Left Dichotomization Variable is required" )) - iv$add_rule("right_var", ~ if (!is.factor(ANL[[req(.)]])) { + 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[[req(.)]])) { + 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( @@ -385,8 +385,8 @@ srv_g_butterfly <- function(id, data, filter_panel_api, reporter, dataname, labe validate( need( - input$right_val %in% ADSL[[input$right_var]] && - input$left_val %in% ADSL[[input$right_var]], + 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?)" ) ) diff --git a/R/tm_g_events_term_id.R b/R/tm_g_events_term_id.R index 5ee8690d..3518a768 100644 --- a/R/tm_g_events_term_id.R +++ b/R/tm_g_events_term_id.R @@ -294,7 +294,7 @@ srv_g_events_term_id <- function(id, iv$add_rule("arm_var", shinyvalidate::sv_required( message = "Arm Variable is required" )) - iv$add_rule("arm_var", ~ if (!is.factor(ANL[[req(.)]])) { + iv$add_rule("arm_var", ~ if (!is.factor(ANL[[.]])) { "Arm Var must be a factor variable, contact developer" }) iv$add_rule("arm_trt", shinyvalidate::sv_not_equal( @@ -312,7 +312,7 @@ srv_g_events_term_id <- function(id, validate(need( input$arm_trt %in% unique(ANL[[req(input$arm_var)]]) && input$arm_ref %in% unique(ANL[[req(input$arm_var)]]), - "Cannot generate plot. No subjects in both Control and Treatment arms." + "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 @@ -331,7 +331,8 @@ srv_g_events_term_id <- function(id, ) ) - teal::validate_has_data(q1[["ANL"]], min_nrow = 10, msg = "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 233794c1..d00a40d8 100644 --- a/R/tm_g_heat_bygrade.R +++ b/R/tm_g_heat_bygrade.R @@ -387,7 +387,7 @@ srv_g_heatmap_bygrade <- function(id, 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", req(input$id_var)) + sprintf("Deselect %s in Annotation Variables", input$id_var) }) iv$add_rule("heat_var", shinyvalidate::sv_required( message = "Heat Variable is required" @@ -403,7 +403,7 @@ srv_g_heatmap_bygrade <- function(id, set = names(ADCM), message_fmt = sprintf("Conmed Variable must be a variable in %s", cm_dataname) )) - iv_cm$add_rule("conmed_var", ~ if (!is.factor(ADCM[[req(.)]])) { + iv_cm$add_rule("conmed_var", ~ if (!is.factor(ADCM[[.]])) { "Study Ongoing Status must be a factor variable" }) iv_cm$add_rule("conmed_level", ~ if (length(.) > 3L) { diff --git a/R/tm_g_spiderplot.R b/R/tm_g_spiderplot.R index 4fa2eca4..9f488f3c 100644 --- a/R/tm_g_spiderplot.R +++ b/R/tm_g_spiderplot.R @@ -235,9 +235,6 @@ srv_g_spider <- function(id, data, filter_panel_api, reporter, dataname, label, ADSL <- data[["ADSL"]]() # nolint ADTR <- data[[dataname]]() # nolint - teal::validate_has_data(ADSL, min_nrow = 0, msg = sprintf("%s data has zero rows", "ADSL")) - teal::validate_has_data(ADTR, min_nrow = 0, msg = sprintf("%s data has zero rows", dataname)) - iv <- shinyvalidate::InputValidator$new() iv$add_rule("paramcd", shinyvalidate::sv_required( message = "Parameter is required" @@ -255,7 +252,7 @@ srv_g_spider <- function(id, data, filter_panel_api, reporter, dataname, label, message = "Color Variable is required" )) fac_dupl <- function(value, other) { - if (length(value) * length(other) > 0L & anyDuplicated(c(value, other))) { + if (length(value) * length(other) > 0L && anyDuplicated(c(value, other))) { "X- and Y-facet Variables must not overlap" } } @@ -271,6 +268,9 @@ srv_g_spider <- function(id, data, filter_panel_api, reporter, dataname, label, teal::validate_inputs(iv) + teal::validate_has_data(ADSL, min_nrow = 0, msg = sprintf("%s data has zero rows", "ADSL")) + teal::validate_has_data(ADTR, min_nrow = 0, msg = sprintf("%s data has zero rows", dataname)) + paramcd <- input$paramcd # nolint x_var <- input$x_var y_var <- input$y_var @@ -284,8 +284,8 @@ srv_g_spider <- function(id, data, filter_panel_api, reporter, dataname, label, href_line <- input$href_line # reference lines preprocessing - vref_line <- as_numeric_from_comma_sep_str(input$vref_line) - href_line <- as_numeric_from_comma_sep_str(input$href_line) + 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 diff --git a/R/tm_g_swimlane.R b/R/tm_g_swimlane.R index 3f00b103..9a38dfe1 100644 --- a/R/tm_g_swimlane.R +++ b/R/tm_g_swimlane.R @@ -305,6 +305,19 @@ srv_g_swimlane <- function(id, # create plot output_q <- 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() + + teal::validate_inputs(iv) + validate(need("ADSL" %in% names(data), "'ADSL' not included in data")) validate(need( (length(data) == 1 && dataname == "ADSL") || @@ -339,19 +352,6 @@ srv_g_swimlane <- function(id, )) } - 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(as_numeric_from_comma_sep_str(.))) { - "Vertical Reference Line(s) are invalid" - }) - iv$enable() - - teal::validate_inputs(iv) - - # VARIABLE GETTERS # lookup bar variables bar_var <- input$bar_var @@ -369,7 +369,7 @@ srv_g_swimlane <- function(id, marker_shape_var <- input$marker_shape_var marker_color_var <- input$marker_color_var } - vref_line <- as_numeric_from_comma_sep_str(debounce(reactive(input$vref_line), 1500)()) + vref_line <- suppressWarnings(as_numeric_from_comma_sep_str(debounce(reactive(input$vref_line), 1500)())) q1 <- teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) diff --git a/R/tm_g_waterfall.R b/R/tm_g_waterfall.R index e06de510..e130490c 100644 --- a/R/tm_g_waterfall.R +++ b/R/tm_g_waterfall.R @@ -328,16 +328,13 @@ srv_g_waterfall <- function(id, set = adtr$PARAMCD, message_fmt = "All values of Tumor Burden Parameter must be elements of ADTR PARAMCD" )) - iv$add_rule("href_line", ~ if (anyNA(as_numeric_from_comma_sep_str(.))) { - "Horizontal Reference Line(s) are invalid" - }) 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) { + if (length(value) > 0L && length(other) > 0L) { "Only one \"Label to Bars\" is allowed" } } @@ -348,21 +345,19 @@ srv_g_waterfall <- function(id, set = adrs$PARAMCD, message_fmt = "Annotation Parameters must be elements of ADRS PARAMCD" )) - 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 positive number" - }) - iv$add_rule("gap_point_val", ~ if (!checkmate::test_integerish(suppressWarnings(as.numeric(.)), lower = 1)) { - "Fractions are not allowed in Break High Bars" + 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 positive number" + "Y-axis Interval must be a single positive number" }) - iv$add_rule("ytick_at", ~ if (!checkmate::test_integerish(suppressWarnings(as.numeric(.)), lower = 1)) { - "Fractions are not allowed in Y-axis Interval" + 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() @@ -380,7 +375,7 @@ 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 <- as_numeric_from_comma_sep_str(href_line) + href_line <- suppressWarnings(as_numeric_from_comma_sep_str(href_line)) if (gap_point_val == "") { gap_point_val <- NULL From 1f63bf40ac7b7635cc556d5c43f4a98b4ff88c84 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Thu, 8 Dec 2022 18:48:55 +0100 Subject: [PATCH 24/68] update DESCRIPTION --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 76b72a7f..d6fe7714 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, From f667bac2cfd5d343ced5a3fb42d3e2fe9240c326 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Fri, 9 Dec 2022 12:07:33 +0100 Subject: [PATCH 25/68] add workflow badges to README --- README.md | 18 +++++++++++++++++- 1 file changed, 17 insertions(+), 1 deletion(-) diff --git a/README.md b/README.md index bec3a1aa..44fd4044 100644 --- a/README.md +++ b/README.md @@ -1,7 +1,23 @@ # 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) +[![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/) +[![Release 🎈](https://github.com/insightsengineering/teal.osprey/actions/workflows/release.yaml/badge.svg)](https://github.com/insightsengineering/teal.osprey/releases) +[![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) +![GitHub Repo stars](https://img.shields.io/github/stars/insightsengineering/teal.osprey?style=social) + +![GitHub commit activity](https://img.shields.io/github/commit-activity/m/insightsengineering/teal.osprey) +![GitHub contributors](https://img.shields.io/github/contributors/insightsengineering/teal.osprey) +![GitHub last commit](https://img.shields.io/github/last-commit/insightsengineering/teal.osprey) +![GitHub pull requests](https://img.shields.io/github/issues-pr/insightsengineering/teal.osprey) +![GitHub repo size](https://img.shields.io/github/repo-size/insightsengineering/teal.osprey) +![GitHub language count](https://img.shields.io/github/languages/count/insightsengineering/teal.osprey) +[![Project Status: Active – The project has reached a stable, usable state and is being actively developed.](https://www.repostatus.org/badges/latest/active.svg)](https://www.repostatus.org/#active) +[![Current Version](https://img.shields.io/github/r-package/v/insightsengineering/teal.osprey/main?color=purple\&label=package%20version)](https://github.com/insightsengineering/teal.osprey/tree/main) +[![Open Issues](https://img.shields.io/github/issues-raw/insightsengineering/teal.osprey?color=red\&label=open%20issues)](https://github.com/insightsengineering/teal.osprey/issues?q=is%3Aissue+is%3Aopen+sort%3Aupdated-desc) The teal.osprey package provides community contributed `teal` modules of the analysis functions from the [osprey](https://insightsengineering.github.io/osprey/) R package. From 21b6b439ba057b0936121908dd934057b4a57efc Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Fri, 9 Dec 2022 12:45:57 +0100 Subject: [PATCH 26/68] update code review --- R/tm_g_ae_sub.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/tm_g_ae_sub.R b/R/tm_g_ae_sub.R index ba4b70b5..8ae85fda 100644 --- a/R/tm_g_ae_sub.R +++ b/R/tm_g_ae_sub.R @@ -305,7 +305,7 @@ srv_g_ae_sub <- function(id, )) iv$add_rule("groups", shinyvalidate::sv_in_set( names(ANL), - message_fmt = "Groups must be a variable in ANL" + message_fmt = sprintf("Groups must be a variable in %s", dataname) )) iv$add_rule("groups", shinyvalidate::sv_in_set( names(ADSL), From a7608a137d1e1c69440e8502ab5d726022f63209 Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Fri, 9 Dec 2022 11:49:40 +0000 Subject: [PATCH 27/68] [skip actions] Restyle files --- R/tm_g_events_term_id.R | 6 ++++-- R/tm_g_swimlane.R | 1 - 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/R/tm_g_events_term_id.R b/R/tm_g_events_term_id.R index 3518a768..8221df86 100644 --- a/R/tm_g_events_term_id.R +++ b/R/tm_g_events_term_id.R @@ -331,8 +331,10 @@ srv_g_events_term_id <- function(id, ) ) - teal::validate_has_data(q1[["ANL"]], min_nrow = 10, - msg = "Analysis data set must have 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_swimlane.R b/R/tm_g_swimlane.R index 9a38dfe1..55297238 100644 --- a/R/tm_g_swimlane.R +++ b/R/tm_g_swimlane.R @@ -305,7 +305,6 @@ srv_g_swimlane <- function(id, # create plot output_q <- reactive({ - iv <- shinyvalidate::InputValidator$new() iv$add_rule("bar_var", shinyvalidate::sv_required( message = "Bar Length is required" From 905d4f86d50a0f8a34937b9e4298410d79de65bf Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Fri, 9 Dec 2022 13:15:43 +0100 Subject: [PATCH 28/68] rework patient_profile module --- R/tm_g_patient_profile.R | 219 ++++++++++----------------------------- 1 file changed, 57 insertions(+), 162 deletions(-) diff --git a/R/tm_g_patient_profile.R b/R/tm_g_patient_profile.R index db2542bf..b0596c05 100644 --- a/R/tm_g_patient_profile.R +++ b/R/tm_g_patient_profile.R @@ -304,14 +304,9 @@ 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")) + uiOutput(ns("select_ADaM_output")) ), teal.widgets::optionalSelectInput( ns("sl_start_date"), @@ -324,7 +319,8 @@ ui_g_patient_profile <- function(id, ...) { ) ), conditionalPanel( - paste0("input['", ns("select_ex"), "']"), + condition = "input['select_ADaM'].includes('ADEX')", + ns = ns, selectInput( ns("ex_var"), "Exposure variable", @@ -334,7 +330,8 @@ ui_g_patient_profile <- function(id, ...) { ) ), conditionalPanel( - paste0("input['", ns("select_ae"), "']"), + condition = "input['select_ADaM'].includes('ADAE')", + ns = ns, teal.widgets::optionalSelectInput( ns("ae_var"), "Adverse Event variable", @@ -351,7 +348,8 @@ ui_g_patient_profile <- function(id, ...) { ) ), conditionalPanel( - paste0("input['", ns("select_rs"), "']"), + condition = "input['select_ADaM'].includes('ADRS')", + ns = ns, teal.widgets::optionalSelectInput( ns("rs_var"), "Tumor response variable", @@ -361,7 +359,8 @@ ui_g_patient_profile <- function(id, ...) { ) ), conditionalPanel( - paste0("input['", ns("select_cm"), "']"), + condition = "input['select_ADaM'].includes('ADCM')", + ns = ns, teal.widgets::optionalSelectInput( ns("cm_var"), "Concomitant medicine variable", @@ -371,7 +370,8 @@ ui_g_patient_profile <- function(id, ...) { ) ), conditionalPanel( - paste0("input['", ns("select_lb"), "']"), + condition = "input['select_ADaM'].includes('ADLB')", + ns = ns, teal.widgets::optionalSelectInput( ns("lb_var"), "Lab variable", @@ -426,69 +426,26 @@ srv_g_patient_profile <- function(id, checkmate::assert_class(data, "tdata") moduleServer(id, function(input, output, session) { - # 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) - ) - }) - } - }) - observeEvent(ex_dataname, { - if (!is.na(ex_dataname)) { - output$select_ex_output <- renderUI({ - checkboxInput( - session$ns("select_ex"), - "ADEX", - value = !is.na(ex_dataname) - ) - }) - } - }) - - observeEvent(rs_dataname, { - if (!is.na(rs_dataname)) { - output$select_rs_output <- renderUI({ - checkboxInput( - session$ns("select_rs"), - "ADRS", - value = !is.na(rs_dataname) - ) - }) - } - }) - - observeEvent(cm_dataname, { - if (!is.na(cm_dataname)) { - output$select_cm_output <- renderUI({ - checkboxInput( - session$ns("select_cm"), - "ADCM", - value = !is.na(cm_dataname) - ) - }) - } + # only show the check box when domain data is available + checkboxes <- c(ex_dataname, ae_dataname, rs_dataname, lb_dataname, cm_dataname) + checkboxes <- checkboxes[!is.na(checkboxes)] + output$select_ADaM_output <- renderUI({ + tagList( + helpText("Select", tags$code("ADaM"), "Domains"), + checkboxGroupInput(inputId = session$ns("select_ADaM"), + label = NULL, + choices = checkboxes, + selected = checkboxes) + ) }) - observeEvent(lb_dataname, { - if (!is.na(lb_dataname)) { - output$select_lb_output <- renderUI({ - checkboxInput( - session$ns("select_lb"), - "ADLB", - value = !is.na(lb_dataname) - ) - }) - } + select_plot <- reactive({ + vapply(checkboxes, function(x) x %in% req(input$select_ADaM), logical(1L)) }) - observeEvent(input$select_lb, { - req(input$select_lb == TRUE && !is.null(input$lb_var)) + observeEvent(select_plot(), { + req(select_plot()["ADLB"]) && !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 @@ -504,6 +461,8 @@ srv_g_patient_profile <- function(id, # render plot output_q <- 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" )) @@ -548,16 +507,6 @@ srv_g_patient_profile <- function(id, iv$add_rule("x_limit", ~ if (!identical(order(as_numeric_from_comma_sep_str(.)), 1:2)) { "Study Days Range mut be: first lower, then upper limit" }) - rule_dataset <- function(value) { - if (!any(c(input$select_ae, input$select_ex, input$select_rs, input$select_cm, input$select_lb))) { - "Select at least one ADaM data set" - } - } - iv$add_rule("select_ae", rule_dataset) - iv$add_rule("select_ex", rule_dataset) - iv$add_rule("select_rs", rule_dataset) - iv$add_rule("select_cm", rule_dataset) - iv$add_rule("select_lb", rule_dataset) iv$enable() teal::validate_inputs(iv) @@ -608,86 +557,32 @@ srv_g_patient_profile <- function(id, # 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 - teal::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 - teal::validate_has_variable(ADAE, adae_vars) - } - } else { - ADAE <- NULL # nolint + ADEX <- NULL + if (("ADEX" %in% input$select_ADaM) && !is.na(ex_dataname)) { + ADEX <- data[[ex_dataname]]() + teal::validate_has_variable(ADEX, adex_vars) } - - if (!is.null(input$select_rs)) { - if (input$select_rs == FALSE | is.na(rs_dataname)) { - ADRS <- NULL # nolint - } else { - ADRS <- data[[rs_dataname]]() # nolint - teal::validate_has_variable(ADRS, adrs_vars) - } - } else { - ADRS <- NULL # nolint + ADAE <- NULL + if (("ADAE" %in% input$select_ADaM) && !is.na(ae_dataname)) { + ADAE <- data[[ae_dataname]]() + teal::validate_has_variable(ADAE, adae_vars) } - - if (!is.null(input$select_cm)) { - if (input$select_cm == FALSE | is.na(cm_dataname)) { - ADCMD <- NULL # nolint - } else { - ADCM <- data[[cm_dataname]]() # nolint - teal::validate_has_variable(ADCM, adcm_vars) - } - } else { - ADCM <- NULL # nolint + ADRS <- NULL + if (("ADRS" %in% input$select_ADaM) && !is.na(rs_dataname)) { + ADRS <- data[[rs_dataname]]() + teal::validate_has_variable(ADRS, adrs_vars) } - - if (!is.null(input$select_lb)) { - if (input$select_lb == FALSE | is.na(lb_dataname)) { - ADLB <- NULL # nolint - } else { - ADLB <- data[[lb_dataname]]() # nolint - teal::validate_has_variable(ADLB, adlb_vars) - } - } else { - ADLB <- NULL # nolint + ADCM <- NULL + if (("ADCM" %in% input$select_ADaM) && !is.na(cm_dataname)) { + ADCM <- data[[cm_dataname]]() + teal::validate_has_variable(ADCM, adcm_vars) + } + ADLB <- NULL + if (("ADLB" %in% input$select_ADaM) && !is.na(lb_dataname)) { + ADLB <- data[[lb_dataname]]() + teal::validate_has_variable(ADLB, adlb_vars) } - - 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 - } - ) - - # Check that at least 1 dataset is selected - validate( - need(any(select_plot), "Please select an ADaM dataset.") - ) - - names(select_plot) <- possible_plot empty_rs <- FALSE empty_ae <- FALSE @@ -742,7 +637,7 @@ srv_g_patient_profile <- function(id, teal.code::eval_code(q1, code = quote(ae_line_col_name <- NULL)) } - q1 <- if (select_plot["ae"]) { + q1 <- if (select_plot()["ADAE"]) { if (all(ADAE$USUBJID %in% ADSL$USUBJID)) { qq <- teal.code::eval_code( q1, @@ -827,7 +722,7 @@ srv_g_patient_profile <- function(id, teal.code::eval_code(q1, code = bquote(ae <- NULL)) } - q1 <- if (select_plot["rs"]) { + q1 <- if (select_plot()["ADRS"]) { if (all(ADRS$USUBJID %in% ADSL$USUBJID)) { qq <- teal.code::eval_code( q1, @@ -869,7 +764,7 @@ srv_g_patient_profile <- function(id, teal.code::eval_code(q1, code = bquote(rs <- NULL)) } - q1 <- if (select_plot["cm"]) { + q1 <- if (select_plot()["ADCM"]) { if (all(ADCM$USUBJID %in% ADSL$USUBJID)) { qq <- teal.code::eval_code( q1, @@ -919,7 +814,7 @@ srv_g_patient_profile <- function(id, teal.code::eval_code(q1, code = bquote(cm <- NULL)) } - q1 <- if (select_plot["ex"]) { + q1 <- if (select_plot()["ADEX"]) { if (all(ADEX$USUBJID %in% ADSL$USUBJID)) { qq <- teal.code::eval_code( q1, @@ -974,7 +869,7 @@ srv_g_patient_profile <- function(id, teal.code::eval_code(q1, code = quote(ex <- NULL)) } - q1 <- if (select_plot["lb"]) { + q1 <- if (select_plot()["ADLB"]) { if (all(ADLB$USUBJID %in% ADSL$USUBJID)) { qq <- teal.code::eval_code( q1, @@ -1028,16 +923,16 @@ srv_g_patient_profile <- function(id, empty_data_check <- c(empty_ex, empty_ae, empty_rs, empty_cm, empty_lb) validate(need( - any(!empty_data_check & select_plot), + 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)) { + 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 = ", "), + paste(c(names(select_plot())[empty_data_check & select_plot()]), collapse = ", "), " domain." ), duration = 8, From 9f1de3e58dab94e383019811b9215756cead88e2 Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Fri, 9 Dec 2022 12:19:06 +0000 Subject: [PATCH 29/68] [skip actions] Restyle files --- R/tm_g_patient_profile.R | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/R/tm_g_patient_profile.R b/R/tm_g_patient_profile.R index b0596c05..ae87295d 100644 --- a/R/tm_g_patient_profile.R +++ b/R/tm_g_patient_profile.R @@ -426,17 +426,18 @@ srv_g_patient_profile <- function(id, checkmate::assert_class(data, "tdata") moduleServer(id, function(input, output, session) { - # only show the check box when domain data is available checkboxes <- c(ex_dataname, ae_dataname, rs_dataname, lb_dataname, cm_dataname) checkboxes <- checkboxes[!is.na(checkboxes)] output$select_ADaM_output <- renderUI({ tagList( helpText("Select", tags$code("ADaM"), "Domains"), - checkboxGroupInput(inputId = session$ns("select_ADaM"), - label = NULL, - choices = checkboxes, - selected = checkboxes) + checkboxGroupInput( + inputId = session$ns("select_ADaM"), + label = NULL, + choices = checkboxes, + selected = checkboxes + ) ) }) @@ -462,7 +463,8 @@ srv_g_patient_profile <- function(id, output_q <- reactive({ iv <- shinyvalidate::InputValidator$new() iv$add_rule("select_ADaM", shinyvalidate::sv_required( - message = "At least one ADaM data set is required")) + message = "At least one ADaM data set is required" + )) iv$add_rule("sl_start_date", shinyvalidate::sv_required( message = "Date variable is required" )) From 05128304c53cad3cae9ce348f25d520086a0e837 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Fri, 9 Dec 2022 15:20:07 +0100 Subject: [PATCH 30/68] adjust patient_profile module --- R/tm_g_patient_profile.R | 138 +++++++++++++++++++++------------------ 1 file changed, 74 insertions(+), 64 deletions(-) diff --git a/R/tm_g_patient_profile.R b/R/tm_g_patient_profile.R index ae87295d..b8a475e8 100644 --- a/R/tm_g_patient_profile.R +++ b/R/tm_g_patient_profile.R @@ -428,25 +428,24 @@ srv_g_patient_profile <- function(id, moduleServer(id, function(input, output, session) { # only show the check box when domain data is available checkboxes <- c(ex_dataname, ae_dataname, rs_dataname, lb_dataname, cm_dataname) - checkboxes <- checkboxes[!is.na(checkboxes)] output$select_ADaM_output <- renderUI({ tagList( helpText("Select", tags$code("ADaM"), "Domains"), checkboxGroupInput( inputId = session$ns("select_ADaM"), label = NULL, - choices = checkboxes, - selected = checkboxes + choices = checkboxes[!is.na(checkboxes)], + selected = checkboxes[!is.na(checkboxes)] ) ) }) select_plot <- reactive({ - vapply(checkboxes, function(x) x %in% req(input$select_ADaM), logical(1L)) + vapply(checkboxes, function(x) x %in% input$select_ADaM, logical(1L)) }) observeEvent(select_plot(), { - req(select_plot()["ADLB"]) && !is.null(input$lb_var) + req(isTRUE(select_plot()[lb_dataname])) && !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 @@ -468,35 +467,45 @@ srv_g_patient_profile <- function(id, iv$add_rule("sl_start_date", shinyvalidate::sv_required( message = "Date variable is required" )) - iv$add_rule("ex_var", shinyvalidate::sv_required( - message = "Exposure variable is required" - )) - 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(ADAE[[.]])) > length(ae_line_col_opt)) { - "Not enough colors provided Adverse Event line color, unselect" - }) - iv$add_rule("rs_var", shinyvalidate::sv_required( - message = "Tumor response variable is required" - )) - iv$add_rule("cm_var", shinyvalidate::sv_required( - message = "Concomitant medicine variable is required" - )) - 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 (any(value == other)) { - "Lab variable and Lab value must be different" + if (isTRUE(select_plot()[ex_dataname])) { + iv$add_rule("ex_var", shinyvalidate::sv_required( + message = "Exposure variable is required" + )) + } + 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(ADAE[[.]])) > length(ae_line_col_opt)) { + "Not enough colors provided Adverse Event line color, unselect" + }) + } + if (isTRUE(select_plot()[rs_dataname])) { + iv$add_rule("rs_var", shinyvalidate::sv_required( + message = "Tumor response variable is required" + )) + } + if (isTRUE(select_plot()[cm_dataname])) { + iv$add_rule("cm_var", shinyvalidate::sv_required( + message = "Concomitant medicine variable is required" + )) + } + 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 (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("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" )) @@ -559,29 +568,28 @@ srv_g_patient_profile <- function(id, # get ADSL dataset --- ADSL <- data[[sl_dataname]]() # nolint - ADEX <- NULL - if (("ADEX" %in% input$select_ADaM) && !is.na(ex_dataname)) { + if ((ex_dataname %in% input$select_ADaM) && !is.na(ex_dataname)) { ADEX <- data[[ex_dataname]]() teal::validate_has_variable(ADEX, adex_vars) } ADAE <- NULL - if (("ADAE" %in% input$select_ADaM) && !is.na(ae_dataname)) { + if ((ae_dataname %in% input$select_ADaM) && !is.na(ae_dataname)) { ADAE <- data[[ae_dataname]]() teal::validate_has_variable(ADAE, adae_vars) } ADRS <- NULL - if (("ADRS" %in% input$select_ADaM) && !is.na(rs_dataname)) { + if ((rs_dataname %in% input$select_ADaM) && !is.na(rs_dataname)) { ADRS <- data[[rs_dataname]]() teal::validate_has_variable(ADRS, adrs_vars) } ADCM <- NULL - if (("ADCM" %in% input$select_ADaM) && !is.na(cm_dataname)) { + if ((cm_dataname %in% input$select_ADaM) && !is.na(cm_dataname)) { ADCM <- data[[cm_dataname]]() teal::validate_has_variable(ADCM, adcm_vars) } ADLB <- NULL - if (("ADLB" %in% input$select_ADaM) && !is.na(lb_dataname)) { + if ((lb_dataname %in% input$select_ADaM) && !is.na(lb_dataname)) { ADLB <- data[[lb_dataname]]() teal::validate_has_variable(ADLB, adlb_vars) } @@ -639,7 +647,7 @@ srv_g_patient_profile <- function(id, teal.code::eval_code(q1, code = quote(ae_line_col_name <- NULL)) } - q1 <- if (select_plot()["ADAE"]) { + q1 <- if (isTRUE(select_plot()[ae_dataname])) { if (all(ADAE$USUBJID %in% ADSL$USUBJID)) { qq <- teal.code::eval_code( q1, @@ -663,8 +671,8 @@ srv_g_patient_profile <- function(id, ) ) + (ASTDT >= as.Date(substr( - as.character(eval(parse(text = .(sl_start_date), keep.source = FALSE))), 1, 10 - )))) %>% + as.character(eval(parse(text = .(sl_start_date), keep.source = FALSE))), 1, 10 + )))) %>% filter(!is.na(AENDT)) %>% mutate(AENDY = as.numeric( difftime( @@ -678,8 +686,8 @@ srv_g_patient_profile <- function(id, ) ) + (AENDT >= as.Date(substr( # nolint - as.character(eval(parse(text = .(sl_start_date), keep.source = FALSE))), 1, 10 - )))) %>% + 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)] @@ -711,7 +719,7 @@ srv_g_patient_profile <- function(id, ) ) ) - ADAE <- qq[["ADAE"]] # nolint + ADAE <- qq[[ae_dataname]] # nolint if (is.null(ADAE) | nrow(ADAE) == 0) { empty_ae <- TRUE } @@ -724,7 +732,7 @@ srv_g_patient_profile <- function(id, teal.code::eval_code(q1, code = bquote(ae <- NULL)) } - q1 <- if (select_plot()["ADRS"]) { + q1 <- if (isTRUE(select_plot()[rs_dataname])) { if (all(ADRS$USUBJID %in% ADSL$USUBJID)) { qq <- teal.code::eval_code( q1, @@ -745,15 +753,15 @@ srv_g_patient_profile <- function(id, units = "days" )) + (ADT >= as.Date(substr( - as.character(eval(parse(text = .(sl_start_date), keep.source = FALSE))), 1, 10 - ))) + 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 + ADRS <- qq[[rs_dataname]] # nolint if (is.null(ADRS) || nrow(ADRS) == 0) { empty_rs <- TRUE } @@ -766,7 +774,7 @@ srv_g_patient_profile <- function(id, teal.code::eval_code(q1, code = bquote(rs <- NULL)) } - q1 <- if (select_plot()["ADCM"]) { + q1 <- if (isTRUE(select_plot()[cm_dataname])) { if (all(ADCM$USUBJID %in% ADSL$USUBJID)) { qq <- teal.code::eval_code( q1, @@ -783,8 +791,8 @@ srv_g_patient_profile <- function(id, units = "days" )) + (ASTDT >= as.Date(substr( - as.character(eval(parse(text = .(sl_start_date), keep.source = FALSE))), 1, 10 - )))) %>% + as.character(eval(parse(text = .(sl_start_date), keep.source = FALSE))), 1, 10 + )))) %>% filter(!is.na(AENDT)) %>% mutate(AENDY = as.numeric(difftime( AENDT, @@ -792,18 +800,18 @@ srv_g_patient_profile <- function(id, units = "days" )) + (AENDT >= as.Date(substr( - as.character(eval(parse(text = .(sl_start_date), keep.source = FALSE))), 1, 10 - )))) %>% + 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), ] + & is.na(ADCM$ASTDY) == FALSE), ] } cm <- list(data = data.frame(ADCM), var = as.vector(ADCM[, .(cm_var)])) }) ) - ADCM <- qq[["ADCM"]] # nolint + ADCM <- qq[[cm_dataname]] # nolint if (is.null(ADCM) | nrow(ADCM) == 0) { empty_cm <- TRUE } @@ -816,7 +824,7 @@ srv_g_patient_profile <- function(id, teal.code::eval_code(q1, code = bquote(cm <- NULL)) } - q1 <- if (select_plot()["ADEX"]) { + q1 <- if (isTRUE(select_plot()[ex_dataname])) { if (all(ADEX$USUBJID %in% ADSL$USUBJID)) { qq <- teal.code::eval_code( q1, @@ -850,7 +858,7 @@ srv_g_patient_profile <- function(id, 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)))) + as.Date(substr(as.character(eval(parse(text = .(sl_start_date)))), 1, 10)))) }) %>% Reduce(rbind, .) %>% as.data.frame() %>% @@ -858,7 +866,7 @@ srv_g_patient_profile <- function(id, ex <- list(data = data.frame(ADEX), var = as.vector(ADEX[, .(ex_var)])) }) ) - ADEX <- qq[["ADEX"]] # nolint + ADEX <- qq[[ex_dataname]] # nolint if (is.null(ADEX) | nrow(ADEX) == 0) { empty_ex <- TRUE } @@ -871,7 +879,7 @@ srv_g_patient_profile <- function(id, teal.code::eval_code(q1, code = quote(ex <- NULL)) } - q1 <- if (select_plot()["ADLB"]) { + q1 <- if (isTRUE(select_plot()[lb_dataname])) { if (all(ADLB$USUBJID %in% ADSL$USUBJID)) { qq <- teal.code::eval_code( q1, @@ -901,14 +909,14 @@ srv_g_patient_profile <- function(id, units = "days" )) + (ADT >= as.Date(substr( - as.character(eval(parse(text = .(sl_start_date), keep.source = FALSE))), 1, 10 - )))) %>% + 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)])) }) ) - ADLB <- qq[["ADLB"]] # nolint + ADLB <- qq[[lb_dataname]] # nolint if (is.null(ADLB) | nrow(ADLB) == 0) { empty_lb <- TRUE } @@ -922,7 +930,9 @@ srv_g_patient_profile <- function(id, } # 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) + empty_data_check <- structure( + c(empty_ex, empty_ae, empty_rs, empty_lb, empty_cm), + names = checkboxes) validate(need( any(!empty_data_check & select_plot()), @@ -934,7 +944,7 @@ srv_g_patient_profile <- function(id, showNotification( paste0( "This subject does not have information in the ", - paste(c(names(select_plot())[empty_data_check & select_plot()]), collapse = ", "), + paste(checkboxes[empty_data_check & select_plot()], collapse = ", "), " domain." ), duration = 8, From fa5bf0ac0be5f872ac56ad36ca8985d517d00b43 Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Fri, 9 Dec 2022 14:23:25 +0000 Subject: [PATCH 31/68] [skip actions] Restyle files --- R/tm_g_patient_profile.R | 31 ++++++++++++++++--------------- 1 file changed, 16 insertions(+), 15 deletions(-) diff --git a/R/tm_g_patient_profile.R b/R/tm_g_patient_profile.R index b8a475e8..05f3fbe8 100644 --- a/R/tm_g_patient_profile.R +++ b/R/tm_g_patient_profile.R @@ -671,8 +671,8 @@ srv_g_patient_profile <- function(id, ) ) + (ASTDT >= as.Date(substr( - as.character(eval(parse(text = .(sl_start_date), keep.source = FALSE))), 1, 10 - )))) %>% + as.character(eval(parse(text = .(sl_start_date), keep.source = FALSE))), 1, 10 + )))) %>% filter(!is.na(AENDT)) %>% mutate(AENDY = as.numeric( difftime( @@ -686,8 +686,8 @@ srv_g_patient_profile <- function(id, ) ) + (AENDT >= as.Date(substr( # nolint - as.character(eval(parse(text = .(sl_start_date), keep.source = FALSE))), 1, 10 - )))) %>% + 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)] @@ -753,8 +753,8 @@ srv_g_patient_profile <- function(id, units = "days" )) + (ADT >= as.Date(substr( - as.character(eval(parse(text = .(sl_start_date), keep.source = FALSE))), 1, 10 - ))) + 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) @@ -791,8 +791,8 @@ srv_g_patient_profile <- function(id, units = "days" )) + (ASTDT >= as.Date(substr( - as.character(eval(parse(text = .(sl_start_date), keep.source = FALSE))), 1, 10 - )))) %>% + as.character(eval(parse(text = .(sl_start_date), keep.source = FALSE))), 1, 10 + )))) %>% filter(!is.na(AENDT)) %>% mutate(AENDY = as.numeric(difftime( AENDT, @@ -800,12 +800,12 @@ srv_g_patient_profile <- function(id, units = "days" )) + (AENDT >= as.Date(substr( - as.character(eval(parse(text = .(sl_start_date), keep.source = FALSE))), 1, 10 - )))) %>% + 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), ] + & is.na(ADCM$ASTDY) == FALSE), ] } cm <- list(data = data.frame(ADCM), var = as.vector(ADCM[, .(cm_var)])) }) @@ -858,7 +858,7 @@ srv_g_patient_profile <- function(id, 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)))) + as.Date(substr(as.character(eval(parse(text = .(sl_start_date)))), 1, 10)))) }) %>% Reduce(rbind, .) %>% as.data.frame() %>% @@ -909,8 +909,8 @@ srv_g_patient_profile <- function(id, units = "days" )) + (ADT >= as.Date(substr( - as.character(eval(parse(text = .(sl_start_date), keep.source = FALSE))), 1, 10 - )))) %>% + 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)])) }) @@ -932,7 +932,8 @@ srv_g_patient_profile <- function(id, # 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) + names = checkboxes + ) validate(need( any(!empty_data_check & select_plot()), From ba68b65796f73b9e076088d31d2290522273e0d6 Mon Sep 17 00:00:00 2001 From: Nikolas Burkoff Date: Fri, 9 Dec 2022 14:26:10 +0000 Subject: [PATCH 32/68] trigger From 980b4a2e011b924e7db1d1940202b756df7cffa7 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Mon, 12 Dec 2022 15:35:21 +0100 Subject: [PATCH 33/68] move ivs to reactives, fix bugs --- R/tm_g_ae_oview.R | 51 +++++++++--------- R/tm_g_ae_sub.R | 56 ++++++++++---------- R/tm_g_butterfly.R | 61 ++++++++++++---------- R/tm_g_events_term_id.R | 45 ++++++++-------- R/tm_g_heat_bygrade.R | 100 +++++++++++++++++++++--------------- R/tm_g_patient_profile.R | 73 ++++++++++++++------------ R/tm_g_spiderplot.R | 26 ++++++---- R/tm_g_swimlane.R | 29 ++++++----- R/tm_g_waterfall.R | 54 ++++++++++--------- man/tm_g_butterfly.Rd | 4 +- man/tm_g_patient_profile.Rd | 2 +- man/tm_g_swimlane.Rd | 4 +- man/tm_g_waterfall.Rd | 4 +- 13 files changed, 284 insertions(+), 225 deletions(-) diff --git a/R/tm_g_ae_oview.R b/R/tm_g_ae_oview.R index dc47fc67..5735f8fb 100644 --- a/R/tm_g_ae_oview.R +++ b/R/tm_g_ae_oview.R @@ -235,6 +235,32 @@ srv_g_ae_oview <- function(id, checkmate::assert_class(data, "tdata") moduleServer(id, function(input, output, session) { + + iv <- reactive({ + ANL <- data[[dataname]]() # 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" + }) + iv$add_rule("arm_var", ~ if (length(levels(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 @@ -287,30 +313,7 @@ srv_g_ae_oview <- function(id, teal::validate_has_data(ANL, min_nrow = 10, msg = sprintf("%s has not enough data", dataname)) - 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 (length(levels(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" - )) - iv$add_rule("arm_trt", shinyvalidate::sv_not_equal( - input$arm_ref, - message_fmt = "Control and Treatment must be different" - )) - iv$add_rule("arm_ref", shinyvalidate::sv_not_equal( - input$arm_trt, - message_fmt = "Control and Treatment must be different" - )) - iv$enable() - - teal::validate_inputs(iv) + teal::validate_inputs(iv()) validate(need( input$arm_trt %in% unique(ANL[[input$arm_var]]) || diff --git a/R/tm_g_ae_sub.R b/R/tm_g_ae_sub.R index 8ae85fda..d232632c 100644 --- a/R/tm_g_ae_sub.R +++ b/R/tm_g_ae_sub.R @@ -184,6 +184,35 @@ srv_g_ae_sub <- function(id, checkmate::assert_class(data, "tdata") moduleServer(id, function(input, output, session) { + + 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, plt = plot_r, @@ -288,32 +317,7 @@ srv_g_ae_sub <- function(id, teal::validate_has_data(ANL, min_nrow = 10, msg = sprintf("%s has not enough data", dataname)) - 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[[req(.)]])) { - "Arm Var must be a factor variable, contact developer" - }) - iv$add_rule("arm_trt", shinyvalidate::sv_not_equal( - input$arm_ref, - message_fmt = "Control and Treatment must be different" - )) - iv$add_rule("arm_ref", shinyvalidate::sv_not_equal( - input$arm_trt, - message_fmt = "Control and Treatment must be different" - )) - 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() - - teal::validate_inputs(iv) + teal::validate_inputs(iv()) validate(need( input$arm_trt %in% unique(ANL[[input$arm_var]]) || diff --git a/R/tm_g_butterfly.R b/R/tm_g_butterfly.R index 5aa713f3..e291f7f4 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,6 +269,37 @@ srv_g_butterfly <- function(id, data, filter_panel_api, reporter, dataname, labe checkmate::assert_class(data, "tdata") moduleServer(id, function(input, output, session) { + + 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) @@ -357,31 +388,7 @@ srv_g_butterfly <- function(id, data, filter_panel_api, reporter, dataname, labe 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 <- 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() - - teal::validate_inputs(iv) + teal::validate_inputs(iv()) validate( need( diff --git a/R/tm_g_events_term_id.R b/R/tm_g_events_term_id.R index 8221df86..f6abc990 100644 --- a/R/tm_g_events_term_id.R +++ b/R/tm_g_events_term_id.R @@ -213,6 +213,29 @@ srv_g_events_term_id <- function(id, checkmate::assert_class(data, "tdata") moduleServer(id, function(input, output, session) { + + iv <- reactive({ + ANL <- data[[dataname]]() # nolint + + 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" + )) + 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$enable() + iv + }) + decorate_output <- srv_g_decorate( id = NULL, plt = plot_r, plot_height = plot_height, plot_width = plot_width ) @@ -287,27 +310,7 @@ srv_g_events_term_id <- function(id, output_q <- reactive({ ANL <- data[[dataname]]() # nolint - 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" - )) - iv$add_rule("arm_var", ~ if (!is.factor(ANL[[.]])) { - "Arm Var must be a factor variable, contact developer" - }) - iv$add_rule("arm_trt", shinyvalidate::sv_not_equal( - input$arm_ref, - message_fmt = "Control and Treatment must be different" - )) - iv$add_rule("arm_ref", shinyvalidate::sv_not_equal( - input$arm_trt, - message_fmt = "Control and Treatment must be different" - )) - iv$enable() - - teal::validate_inputs(iv) + teal::validate_inputs(iv()) validate(need( input$arm_trt %in% unique(ANL[[req(input$arm_var)]]) && diff --git a/R/tm_g_heat_bygrade.R b/R/tm_g_heat_bygrade.R index d00a40d8..83db4766 100644 --- a/R/tm_g_heat_bygrade.R +++ b/R/tm_g_heat_bygrade.R @@ -315,41 +315,8 @@ srv_g_heatmap_bygrade <- function(id, checkmate::assert_class(data, "tdata") moduleServer(id, function(input, output, session) { - 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) - ) - }) - } - }) - - 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 - ) - }) - - output_q <- reactive({ + iv <- reactive({ ADSL <- data[[sl_dataname]]() # nolint ADEX <- data[[ex_dataname]]() # nolint ADAE <- data[[ae_dataname]]() # nolint @@ -357,8 +324,6 @@ srv_g_heatmap_bygrade <- function(id, ADCM <- data[[cm_dataname]]() # nolint } - teal::validate_has_data(ADSL, min_nrow = 0, msg = sprintf("%s contains no data", sl_dataname)) - iv <- shinyvalidate::InputValidator$new() iv$add_rule("id_var", shinyvalidate::sv_required( message = "ID Variable is required" @@ -393,6 +358,15 @@ srv_g_heatmap_bygrade <- function(id, message = "Heat Variable is required" )) iv$enable() + iv + }) + 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 + } iv_cm <- shinyvalidate::InputValidator$new() iv_cm$condition(~ isTRUE(input$plot_cm)) @@ -409,13 +383,57 @@ srv_g_heatmap_bygrade <- function(id, iv_cm$add_rule("conmed_level", ~ if (length(.) > 3L) { "No more than three Conmed Levels are allowed" }) - iv_cm$add_rule("conmed_level", shinyvalidate::sv_in_set( - set = unique(ADCM[[req(input$conmed_var)]]), - message_fmt = "Updating Conmed Levels" - )) iv_cm$enable() + iv_cm + }) + + 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) + ) + }) + } + }) + + 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 + ) + }) + + output_q <- 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 + } + + teal::validate_has_data(ADSL, min_nrow = 0, msg = sprintf("%s contains no data", sl_dataname)) + + teal::validate_inputs(iv(), iv_cm()) - teal::validate_inputs(iv, iv_cm) + validate(need(input$conmed_level %in% unique(ADCM[[input$conmed_var]]), "Updating Conmed Levels")) q1 <- if (isTRUE(input$plot_cm)) { conmed_var <- input$conmed_var diff --git a/R/tm_g_patient_profile.R b/R/tm_g_patient_profile.R index 05f3fbe8..273c1e04 100644 --- a/R/tm_g_patient_profile.R +++ b/R/tm_g_patient_profile.R @@ -119,7 +119,7 @@ #' LBSTRESN = as.numeric(LBSTRESC) #' ) #' -#' x <- init( +#' app <- init( #' data = cdisc_data( #' cdisc_dataset("ADSL", ADSL, #' code = "ADSL <- synthetic_cdisc_data(\"latest\")$adsl" @@ -444,8 +444,12 @@ srv_g_patient_profile <- function(id, vapply(checkboxes, function(x) x %in% input$select_ADaM, logical(1L)) }) - observeEvent(select_plot(), { - req(isTRUE(select_plot()[lb_dataname])) && !is.null(input$lb_var) + observeEvent({ + select_plot() + input$lb_var + }, { + req(select_plot()[lb_dataname]) + req (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 @@ -458,8 +462,7 @@ srv_g_patient_profile <- function(id, ) }) - # render plot - output_q <- reactive({ + iv <- reactive({ iv <- shinyvalidate::InputValidator$new() iv$add_rule("select_ADaM", shinyvalidate::sv_required( message = "At least one ADaM data set is required" @@ -499,7 +502,7 @@ srv_g_patient_profile <- function(id, message = "At least one Lab value is required" )) rule_diff <- function(value, other) { - if (any(value == other)) { + if (isTRUE(any(value == other))) { "Lab variable and Lab value must be different" } } @@ -509,18 +512,22 @@ srv_g_patient_profile <- function(id, iv$add_rule("x_limit", shinyvalidate::sv_required( message = "Study Days Range is required" )) - iv$add_rule("x_limit", ~ if (anyNA(as_numeric_from_comma_sep_str(.))) { + 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(as_numeric_from_comma_sep_str(.)) != 2L) { + 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(as_numeric_from_comma_sep_str(.)), 1:2)) { + 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 + }) - teal::validate_inputs(iv) + # render plot + output_q <- reactive({ + teal::validate_inputs(iv()) # get inputs --- patient_id <- input$patient_id # nolint @@ -568,29 +575,29 @@ srv_g_patient_profile <- function(id, # get ADSL dataset --- ADSL <- data[[sl_dataname]]() # nolint - ADEX <- NULL + ADEX <- NULL # nolint if ((ex_dataname %in% input$select_ADaM) && !is.na(ex_dataname)) { - ADEX <- data[[ex_dataname]]() + ADEX <- data[[ex_dataname]]() # nolint teal::validate_has_variable(ADEX, adex_vars) } - ADAE <- NULL + ADAE <- NULL # nolint if ((ae_dataname %in% input$select_ADaM) && !is.na(ae_dataname)) { ADAE <- data[[ae_dataname]]() teal::validate_has_variable(ADAE, adae_vars) } - ADRS <- NULL + ADRS <- NULL # nolint if ((rs_dataname %in% input$select_ADaM) && !is.na(rs_dataname)) { - ADRS <- data[[rs_dataname]]() + ADRS <- data[[rs_dataname]]() # nolint teal::validate_has_variable(ADRS, adrs_vars) } - ADCM <- NULL + ADCM <- NULL # nolint if ((cm_dataname %in% input$select_ADaM) && !is.na(cm_dataname)) { - ADCM <- data[[cm_dataname]]() + ADCM <- data[[cm_dataname]]() # nolint teal::validate_has_variable(ADCM, adcm_vars) } - ADLB <- NULL + ADLB <- NULL # nolint if ((lb_dataname %in% input$select_ADaM) && !is.na(lb_dataname)) { - ADLB <- data[[lb_dataname]]() + ADLB <- data[[lb_dataname]]() # nolint teal::validate_has_variable(ADLB, adlb_vars) } @@ -671,8 +678,8 @@ srv_g_patient_profile <- function(id, ) ) + (ASTDT >= as.Date(substr( - as.character(eval(parse(text = .(sl_start_date), keep.source = FALSE))), 1, 10 - )))) %>% + as.character(eval(parse(text = .(sl_start_date), keep.source = FALSE))), 1, 10 + )))) %>% filter(!is.na(AENDT)) %>% mutate(AENDY = as.numeric( difftime( @@ -686,8 +693,8 @@ srv_g_patient_profile <- function(id, ) ) + (AENDT >= as.Date(substr( # nolint - as.character(eval(parse(text = .(sl_start_date), keep.source = FALSE))), 1, 10 - )))) %>% + 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)] @@ -753,8 +760,8 @@ srv_g_patient_profile <- function(id, units = "days" )) + (ADT >= as.Date(substr( - as.character(eval(parse(text = .(sl_start_date), keep.source = FALSE))), 1, 10 - ))) + 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) @@ -791,8 +798,8 @@ srv_g_patient_profile <- function(id, units = "days" )) + (ASTDT >= as.Date(substr( - as.character(eval(parse(text = .(sl_start_date), keep.source = FALSE))), 1, 10 - )))) %>% + as.character(eval(parse(text = .(sl_start_date), keep.source = FALSE))), 1, 10 + )))) %>% filter(!is.na(AENDT)) %>% mutate(AENDY = as.numeric(difftime( AENDT, @@ -800,12 +807,12 @@ srv_g_patient_profile <- function(id, units = "days" )) + (AENDT >= as.Date(substr( - as.character(eval(parse(text = .(sl_start_date), keep.source = FALSE))), 1, 10 - )))) %>% + 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), ] + & is.na(ADCM$ASTDY) == FALSE), ] } cm <- list(data = data.frame(ADCM), var = as.vector(ADCM[, .(cm_var)])) }) @@ -858,7 +865,7 @@ srv_g_patient_profile <- function(id, 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)))) + as.Date(substr(as.character(eval(parse(text = .(sl_start_date)))), 1, 10)))) }) %>% Reduce(rbind, .) %>% as.data.frame() %>% @@ -909,8 +916,8 @@ srv_g_patient_profile <- function(id, units = "days" )) + (ADT >= as.Date(substr( - as.character(eval(parse(text = .(sl_start_date), keep.source = FALSE))), 1, 10 - )))) %>% + 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)])) }) diff --git a/R/tm_g_spiderplot.R b/R/tm_g_spiderplot.R index 9f488f3c..83059905 100644 --- a/R/tm_g_spiderplot.R +++ b/R/tm_g_spiderplot.R @@ -227,11 +227,8 @@ 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 - # render plot - output_q <- reactive({ - # get datasets --- + iv <- reactive({ ADSL <- data[["ADSL"]]() # nolint ADTR <- data[[dataname]]() # nolint @@ -245,12 +242,12 @@ srv_g_spider <- function(id, data, filter_panel_api, reporter, dataname, label, iv$add_rule("y_var", shinyvalidate::sv_required( message = "Y Axis Variable is required" )) - iv$add_rule("marker_var", shinyvalidate::sv_required( - message = "Marker Symbol 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" @@ -258,15 +255,24 @@ srv_g_spider <- function(id, data, filter_panel_api, reporter, dataname, label, } 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(as_numeric_from_comma_sep_str(.))) { + 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(as_numeric_from_comma_sep_str(.))) { + 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({ + # get datasets --- + ADSL <- data[["ADSL"]]() # nolint + ADTR <- data[[dataname]]() # nolint - teal::validate_inputs(iv) + teal::validate_inputs(iv()) teal::validate_has_data(ADSL, min_nrow = 0, msg = sprintf("%s data has zero rows", "ADSL")) teal::validate_has_data(ADTR, min_nrow = 0, msg = sprintf("%s data has zero rows", dataname)) diff --git a/R/tm_g_swimlane.R b/R/tm_g_swimlane.R index 55297238..0457f29f 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,6 +275,20 @@ srv_g_swimlane <- function(id, checkmate::assert_class(data, "tdata") moduleServer(id, function(input, output, session) { + + 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({ if (dataname == "ADSL" || is.null(marker_shape_var) || is.null(input$marker_pos_var)) { @@ -305,17 +319,8 @@ srv_g_swimlane <- function(id, # create plot output_q <- 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() - teal::validate_inputs(iv) + teal::validate_inputs(iv()) validate(need("ADSL" %in% names(data), "'ADSL' not included in data")) validate(need( diff --git a/R/tm_g_waterfall.R b/R/tm_g_waterfall.R index e130490c..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,31 +292,11 @@ 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]]() - # 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) - iv <- shinyvalidate::InputValidator$new() iv$add_rule("bar_var", shinyvalidate::sv_required( message = "Bar Height is required" @@ -360,9 +340,35 @@ srv_g_waterfall <- function(id, "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) - teal::validate_inputs(iv) + 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 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_patient_profile.Rd b/man/tm_g_patient_profile.Rd index aad4bf7e..7653e3f7 100644 --- a/man/tm_g_patient_profile.Rd +++ b/man/tm_g_patient_profile.Rd @@ -180,7 +180,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" 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{ From f46296b92b5afed20079c0580ab35ad34885f31f Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Mon, 12 Dec 2022 15:42:33 +0100 Subject: [PATCH 34/68] amend DEWSCRIPTION and NEWS --- DESCRIPTION | 1 - NEWS.md | 1 + 2 files changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index d6fe7714..c36111fa 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -31,7 +31,6 @@ Imports: ggplot2, lifecycle, logger (>= 0.2.0), - purrr, shinyvalidate, teal.code (>= 0.2.0), teal.logger (>= 0.1.1), diff --git a/NEWS.md b/NEWS.md index 0e24e5d6..9d70ae04 100644 --- a/NEWS.md +++ b/NEWS.md @@ -4,6 +4,7 @@ * 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. ### Breaking changes From 2e0d4eacf7f88952d7aa5bf407e211055cd9f59a Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Mon, 12 Dec 2022 15:18:43 +0000 Subject: [PATCH 35/68] [skip actions] Restyle files --- R/tm_g_ae_oview.R | 1 - R/tm_g_ae_sub.R | 1 - R/tm_g_butterfly.R | 1 - R/tm_g_events_term_id.R | 1 - R/tm_g_heat_bygrade.R | 1 - R/tm_g_patient_profile.R | 63 +++++++++++++++++++++------------------- R/tm_g_spiderplot.R | 1 - R/tm_g_swimlane.R | 2 -- 8 files changed, 33 insertions(+), 38 deletions(-) diff --git a/R/tm_g_ae_oview.R b/R/tm_g_ae_oview.R index 5735f8fb..9de4baf2 100644 --- a/R/tm_g_ae_oview.R +++ b/R/tm_g_ae_oview.R @@ -235,7 +235,6 @@ srv_g_ae_oview <- function(id, checkmate::assert_class(data, "tdata") moduleServer(id, function(input, output, session) { - iv <- reactive({ ANL <- data[[dataname]]() # nolint diff --git a/R/tm_g_ae_sub.R b/R/tm_g_ae_sub.R index d232632c..39ea3610 100644 --- a/R/tm_g_ae_sub.R +++ b/R/tm_g_ae_sub.R @@ -184,7 +184,6 @@ srv_g_ae_sub <- function(id, checkmate::assert_class(data, "tdata") moduleServer(id, function(input, output, session) { - iv <- reactive({ ANL <- data[[dataname]]() # nolint ADSL <- data[["ADSL"]]() # nolint diff --git a/R/tm_g_butterfly.R b/R/tm_g_butterfly.R index e291f7f4..bef9bef2 100644 --- a/R/tm_g_butterfly.R +++ b/R/tm_g_butterfly.R @@ -269,7 +269,6 @@ srv_g_butterfly <- function(id, data, filter_panel_api, reporter, dataname, labe checkmate::assert_class(data, "tdata") moduleServer(id, function(input, output, session) { - iv <- reactive({ ADSL <- data[["ADSL"]]() # nolint ANL <- data[[dataname]]() # nolint diff --git a/R/tm_g_events_term_id.R b/R/tm_g_events_term_id.R index f6abc990..17f2e9f6 100644 --- a/R/tm_g_events_term_id.R +++ b/R/tm_g_events_term_id.R @@ -213,7 +213,6 @@ srv_g_events_term_id <- function(id, checkmate::assert_class(data, "tdata") moduleServer(id, function(input, output, session) { - iv <- reactive({ ANL <- data[[dataname]]() # nolint diff --git a/R/tm_g_heat_bygrade.R b/R/tm_g_heat_bygrade.R index 83db4766..46b20770 100644 --- a/R/tm_g_heat_bygrade.R +++ b/R/tm_g_heat_bygrade.R @@ -315,7 +315,6 @@ srv_g_heatmap_bygrade <- function(id, checkmate::assert_class(data, "tdata") moduleServer(id, function(input, output, session) { - iv <- reactive({ ADSL <- data[[sl_dataname]]() # nolint ADEX <- data[[ex_dataname]]() # nolint diff --git a/R/tm_g_patient_profile.R b/R/tm_g_patient_profile.R index 273c1e04..6289cb39 100644 --- a/R/tm_g_patient_profile.R +++ b/R/tm_g_patient_profile.R @@ -444,23 +444,26 @@ srv_g_patient_profile <- function(id, vapply(checkboxes, function(x) x %in% input$select_ADaM, logical(1L)) }) - observeEvent({ - select_plot() - input$lb_var - }, { - req(select_plot()[lb_dataname]) - req (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 + observeEvent( + { + select_plot() + input$lb_var + }, + { + req(select_plot()[lb_dataname]) + req(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 - ) - }) + updateSelectInput( + session, + "lb_var_show", + selected = choices_selected, + choices = choices + ) + } + ) iv <- reactive({ iv <- shinyvalidate::InputValidator$new() @@ -678,8 +681,8 @@ srv_g_patient_profile <- function(id, ) ) + (ASTDT >= as.Date(substr( - as.character(eval(parse(text = .(sl_start_date), keep.source = FALSE))), 1, 10 - )))) %>% + as.character(eval(parse(text = .(sl_start_date), keep.source = FALSE))), 1, 10 + )))) %>% filter(!is.na(AENDT)) %>% mutate(AENDY = as.numeric( difftime( @@ -693,8 +696,8 @@ srv_g_patient_profile <- function(id, ) ) + (AENDT >= as.Date(substr( # nolint - as.character(eval(parse(text = .(sl_start_date), keep.source = FALSE))), 1, 10 - )))) %>% + 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)] @@ -760,8 +763,8 @@ srv_g_patient_profile <- function(id, units = "days" )) + (ADT >= as.Date(substr( - as.character(eval(parse(text = .(sl_start_date), keep.source = FALSE))), 1, 10 - ))) + 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) @@ -798,8 +801,8 @@ srv_g_patient_profile <- function(id, units = "days" )) + (ASTDT >= as.Date(substr( - as.character(eval(parse(text = .(sl_start_date), keep.source = FALSE))), 1, 10 - )))) %>% + as.character(eval(parse(text = .(sl_start_date), keep.source = FALSE))), 1, 10 + )))) %>% filter(!is.na(AENDT)) %>% mutate(AENDY = as.numeric(difftime( AENDT, @@ -807,12 +810,12 @@ srv_g_patient_profile <- function(id, units = "days" )) + (AENDT >= as.Date(substr( - as.character(eval(parse(text = .(sl_start_date), keep.source = FALSE))), 1, 10 - )))) %>% + 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), ] + & is.na(ADCM$ASTDY) == FALSE), ] } cm <- list(data = data.frame(ADCM), var = as.vector(ADCM[, .(cm_var)])) }) @@ -865,7 +868,7 @@ srv_g_patient_profile <- function(id, 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)))) + as.Date(substr(as.character(eval(parse(text = .(sl_start_date)))), 1, 10)))) }) %>% Reduce(rbind, .) %>% as.data.frame() %>% @@ -916,8 +919,8 @@ srv_g_patient_profile <- function(id, units = "days" )) + (ADT >= as.Date(substr( - as.character(eval(parse(text = .(sl_start_date), keep.source = FALSE))), 1, 10 - )))) %>% + 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)])) }) diff --git a/R/tm_g_spiderplot.R b/R/tm_g_spiderplot.R index 83059905..97305d57 100644 --- a/R/tm_g_spiderplot.R +++ b/R/tm_g_spiderplot.R @@ -227,7 +227,6 @@ srv_g_spider <- function(id, data, filter_panel_api, reporter, dataname, label, checkmate::assert_class(data, "tdata") moduleServer(id, function(input, output, session) { - iv <- reactive({ ADSL <- data[["ADSL"]]() # nolint ADTR <- data[[dataname]]() # nolint diff --git a/R/tm_g_swimlane.R b/R/tm_g_swimlane.R index 0457f29f..a04fdb30 100644 --- a/R/tm_g_swimlane.R +++ b/R/tm_g_swimlane.R @@ -275,7 +275,6 @@ srv_g_swimlane <- function(id, checkmate::assert_class(data, "tdata") moduleServer(id, function(input, output, session) { - iv <- reactive({ iv <- shinyvalidate::InputValidator$new() iv$add_rule("bar_var", shinyvalidate::sv_required( @@ -319,7 +318,6 @@ srv_g_swimlane <- function(id, # create plot output_q <- reactive({ - teal::validate_inputs(iv()) validate(need("ADSL" %in% names(data), "'ADSL' not included in data")) From dbd52a3c7221f12c458e798df13c6309d6705658 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Wed, 14 Dec 2022 10:29:28 +0100 Subject: [PATCH 36/68] apply code review --- R/tm_g_ae_oview.R | 5 ++--- R/tm_g_ae_sub.R | 3 +-- R/tm_g_events_term_id.R | 3 +-- 3 files changed, 4 insertions(+), 7 deletions(-) diff --git a/R/tm_g_ae_oview.R b/R/tm_g_ae_oview.R index 9de4baf2..84cff253 100644 --- a/R/tm_g_ae_oview.R +++ b/R/tm_g_ae_oview.R @@ -245,7 +245,7 @@ srv_g_ae_oview <- function(id, iv$add_rule("arm_var", ~ if (!is.factor(ANL[[.]])) { "Arm Var must be a factor variable" }) - iv$add_rule("arm_var", ~ if (length(levels(ANL[[.]])) < 2L) { + 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( @@ -315,8 +315,7 @@ srv_g_ae_oview <- function(id, teal::validate_inputs(iv()) validate(need( - input$arm_trt %in% unique(ANL[[input$arm_var]]) || - input$arm_ref %in% unique(ANL[[input$arm_var]]), + 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?" )) diff --git a/R/tm_g_ae_sub.R b/R/tm_g_ae_sub.R index 39ea3610..17d4c6e3 100644 --- a/R/tm_g_ae_sub.R +++ b/R/tm_g_ae_sub.R @@ -319,8 +319,7 @@ srv_g_ae_sub <- function(id, teal::validate_inputs(iv()) validate(need( - input$arm_trt %in% unique(ANL[[input$arm_var]]) || - input$arm_ref %in% unique(ANL[[input$arm_var]]), + 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?" )) diff --git a/R/tm_g_events_term_id.R b/R/tm_g_events_term_id.R index 17f2e9f6..13d8916d 100644 --- a/R/tm_g_events_term_id.R +++ b/R/tm_g_events_term_id.R @@ -312,8 +312,7 @@ srv_g_events_term_id <- function(id, teal::validate_inputs(iv()) validate(need( - input$arm_trt %in% unique(ANL[[req(input$arm_var)]]) && - input$arm_ref %in% unique(ANL[[req(input$arm_var)]]), + 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." )) From 127d9a2c624a724416d7bb05e8692235e0f46a10 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Wed, 14 Dec 2022 10:58:11 +0100 Subject: [PATCH 37/68] apply more code review --- R/tm_g_heat_bygrade.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/tm_g_heat_bygrade.R b/R/tm_g_heat_bygrade.R index 46b20770..b2cef427 100644 --- a/R/tm_g_heat_bygrade.R +++ b/R/tm_g_heat_bygrade.R @@ -432,7 +432,7 @@ srv_g_heatmap_bygrade <- function(id, teal::validate_inputs(iv(), iv_cm()) - validate(need(input$conmed_level %in% unique(ADCM[[input$conmed_var]]), "Updating Conmed Levels")) + validate(need(input$conmed_level %in% ADCM[[input$conmed_var]], "Updating Conmed Levels")) q1 <- if (isTRUE(input$plot_cm)) { conmed_var <- input$conmed_var From 532b4c7a7cd4a71d90327f8359b0a719cd858b21 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Wed, 14 Dec 2022 12:06:30 +0100 Subject: [PATCH 38/68] linter --- R/tm_g_patient_profile.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/tm_g_patient_profile.R b/R/tm_g_patient_profile.R index 6289cb39..0049eb4d 100644 --- a/R/tm_g_patient_profile.R +++ b/R/tm_g_patient_profile.R @@ -585,7 +585,7 @@ srv_g_patient_profile <- function(id, } ADAE <- NULL # nolint if ((ae_dataname %in% input$select_ADaM) && !is.na(ae_dataname)) { - ADAE <- data[[ae_dataname]]() + ADAE <- data[[ae_dataname]]() # nolint teal::validate_has_variable(ADAE, adae_vars) } ADRS <- NULL # nolint From a448b028600fddd6328cb4833405d31a843735a3 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Wed, 14 Dec 2022 13:21:49 +0100 Subject: [PATCH 39/68] more review of patient_profile --- R/tm_g_patient_profile.R | 112 ++++++++++++------------------------ man/tm_g_patient_profile.Rd | 74 ++++++------------------ 2 files changed, 54 insertions(+), 132 deletions(-) diff --git a/R/tm_g_patient_profile.R b/R/tm_g_patient_profile.R index 0049eb4d..6e262c33 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} @@ -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") @@ -211,16 +184,11 @@ 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,8 @@ 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) @@ -286,7 +256,6 @@ ui_g_patient_profile <- function(id, ...) { a <- list(...) ns <- NS(id) - shiny::tagList( include_css_files("custom"), teal.widgets::standard_layout( @@ -444,13 +413,8 @@ srv_g_patient_profile <- function(id, vapply(checkboxes, function(x) x %in% input$select_ADaM, logical(1L)) }) - observeEvent( - { - select_plot() - input$lb_var - }, - { - req(select_plot()[lb_dataname]) + if (!is.na(lb_dataname)) { + observeEvent(input$lb_var, { req(input$lb_var) ADLB <- data[[lb_dataname]]() # nolint choices <- unique(ADLB[[input$lb_var]]) @@ -462,8 +426,8 @@ srv_g_patient_profile <- function(id, selected = choices_selected, choices = choices ) - } - ) + }) + } iv <- reactive({ iv <- shinyvalidate::InputValidator$new() @@ -579,27 +543,27 @@ srv_g_patient_profile <- function(id, ADSL <- data[[sl_dataname]]() # nolint ADEX <- NULL # nolint - if ((ex_dataname %in% input$select_ADaM) && !is.na(ex_dataname)) { + if (isTRUE(select_plot()[ex_dataname])) { ADEX <- data[[ex_dataname]]() # nolint teal::validate_has_variable(ADEX, adex_vars) } ADAE <- NULL # nolint - if ((ae_dataname %in% input$select_ADaM) && !is.na(ae_dataname)) { + if (isTRUE(select_plot()[ae_dataname])) { ADAE <- data[[ae_dataname]]() # nolint teal::validate_has_variable(ADAE, adae_vars) } ADRS <- NULL # nolint - if ((rs_dataname %in% input$select_ADaM) && !is.na(rs_dataname)) { + if (isTRUE(select_plot()[rs_dataname])) { ADRS <- data[[rs_dataname]]() # nolint teal::validate_has_variable(ADRS, adrs_vars) } ADCM <- NULL # nolint - if ((cm_dataname %in% input$select_ADaM) && !is.na(cm_dataname)) { + if (isTRUE(select_plot()[cm_dataname])) { ADCM <- data[[cm_dataname]]() # nolint teal::validate_has_variable(ADCM, adcm_vars) } ADLB <- NULL # nolint - if ((lb_dataname %in% input$select_ADaM) && !is.na(lb_dataname)) { + if (isTRUE(select_plot()[lb_dataname])) { ADLB <- data[[lb_dataname]]() # nolint teal::validate_has_variable(ADLB, adlb_vars) } diff --git a/man/tm_g_patient_profile.Rd b/man/tm_g_patient_profile.Rd index 7653e3f7..45d0c019 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 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 @@ -226,11 +189,6 @@ app <- 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") From 9bbf16e38bc1c36ce350c7e3ae0ee37d1c22708c Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Wed, 14 Dec 2022 13:22:08 +0100 Subject: [PATCH 40/68] apply review of ~heat_bygrade --- R/tm_g_heat_bygrade.R | 22 ++++++++++------------ 1 file changed, 10 insertions(+), 12 deletions(-) diff --git a/R/tm_g_heat_bygrade.R b/R/tm_g_heat_bygrade.R index b2cef427..e097e44d 100644 --- a/R/tm_g_heat_bygrade.R +++ b/R/tm_g_heat_bygrade.R @@ -395,17 +395,15 @@ srv_g_heatmap_bygrade <- function(id, 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) - ) - }) - } - }) + if (!is.na(cm_dataname)) { + output$plot_cm_output <- renderUI({ + checkboxInput( + session$ns("plot_cm"), + "Yes", + value = !is.na(cm_dataname) + ) + }) + } observeEvent(input$plot_cm, { ADCM <- data[[cm_dataname]]() # nolint @@ -428,7 +426,7 @@ srv_g_heatmap_bygrade <- function(id, ADCM <- data[[cm_dataname]]() # nolint } - teal::validate_has_data(ADSL, min_nrow = 0, msg = sprintf("%s contains no data", sl_dataname)) + teal::validate_has_data(ADSL, min_nrow = 1, msg = sprintf("%s contains no data", sl_dataname)) teal::validate_inputs(iv(), iv_cm()) From bb06f3cf1b10e866ce8c1da3d82aeac2aed09570 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Wed, 14 Dec 2022 14:05:01 +0100 Subject: [PATCH 41/68] apply review to spiderplot --- R/tm_g_spiderplot.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/tm_g_spiderplot.R b/R/tm_g_spiderplot.R index 97305d57..ca1af247 100644 --- a/R/tm_g_spiderplot.R +++ b/R/tm_g_spiderplot.R @@ -273,8 +273,8 @@ srv_g_spider <- function(id, data, filter_panel_api, reporter, dataname, label, teal::validate_inputs(iv()) - teal::validate_has_data(ADSL, min_nrow = 0, msg = sprintf("%s data has zero rows", "ADSL")) - teal::validate_has_data(ADTR, min_nrow = 0, msg = sprintf("%s data has zero rows", dataname)) + 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 From 24eb0f11aade9f5f36a52fc692c7a2391ff47f49 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Wed, 14 Dec 2022 15:39:19 +0100 Subject: [PATCH 42/68] more review patient_profile --- R/tm_g_patient_profile.R | 29 ++++++++++++++++++++--------- 1 file changed, 20 insertions(+), 9 deletions(-) diff --git a/R/tm_g_patient_profile.R b/R/tm_g_patient_profile.R index 6e262c33..3d8a2ea9 100644 --- a/R/tm_g_patient_profile.R +++ b/R/tm_g_patient_profile.R @@ -288,7 +288,7 @@ ui_g_patient_profile <- function(id, ...) { ) ), conditionalPanel( - condition = "input['select_ADaM'].includes('ADEX')", + condition = sprintf("input['select_ADaM'].includes('%s')", a$ex_dataname), ns = ns, selectInput( ns("ex_var"), @@ -299,7 +299,7 @@ ui_g_patient_profile <- function(id, ...) { ) ), conditionalPanel( - condition = "input['select_ADaM'].includes('ADAE')", + condition = sprintf("input['select_ADaM'].includes('%s')", a$ae_dataname), ns = ns, teal.widgets::optionalSelectInput( ns("ae_var"), @@ -317,7 +317,7 @@ ui_g_patient_profile <- function(id, ...) { ) ), conditionalPanel( - condition = "input['select_ADaM'].includes('ADRS')", + condition = sprintf("input['select_ADaM'].includes('%s')", a$rs_dataname), ns = ns, teal.widgets::optionalSelectInput( ns("rs_var"), @@ -328,7 +328,7 @@ ui_g_patient_profile <- function(id, ...) { ) ), conditionalPanel( - condition = "input['select_ADaM'].includes('ADCM')", + condition = sprintf("input['select_ADaM'].includes('%s')", a$cm_dataname), ns = ns, teal.widgets::optionalSelectInput( ns("cm_var"), @@ -339,7 +339,7 @@ ui_g_patient_profile <- function(id, ...) { ) ), conditionalPanel( - condition = "input['select_ADaM'].includes('ADLB')", + condition = sprintf("input['select_ADaM'].includes('%s')", a$lb_dataname), ns = ns, teal.widgets::optionalSelectInput( ns("lb_var"), @@ -394,9 +394,17 @@ srv_g_patient_profile <- function(id, with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelApi") checkmate::assert_class(data, "tdata") + checkboxes <- c(ex_dataname, ae_dataname, rs_dataname, lb_dataname, cm_dataname) + + 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)) + + moduleServer(id, function(input, output, session) { # only show the check box when domain data is available - checkboxes <- c(ex_dataname, ae_dataname, rs_dataname, lb_dataname, cm_dataname) output$select_ADaM_output <- renderUI({ tagList( helpText("Select", tags$code("ADaM"), "Domains"), @@ -829,7 +837,8 @@ srv_g_patient_profile <- function(id, ) %>% 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( + 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)))) @@ -879,7 +888,8 @@ srv_g_patient_profile <- function(id, 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)), + as.Date(substr(as.character( + eval(parse(text = .(sl_start_date), keep.source = FALSE))), 1, 10)), units = "days" )) + (ADT >= as.Date(substr( @@ -906,7 +916,8 @@ srv_g_patient_profile <- function(id, # 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 + # names = checkboxes + names = names(checkboxes) ) validate(need( From 8295598ed3a3b00348daf5b329a08eb2cdba4af4 Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Wed, 14 Dec 2022 14:42:38 +0000 Subject: [PATCH 43/68] [skip actions] Restyle files --- R/tm_g_patient_profile.R | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/R/tm_g_patient_profile.R b/R/tm_g_patient_profile.R index 3d8a2ea9..c638cb8e 100644 --- a/R/tm_g_patient_profile.R +++ b/R/tm_g_patient_profile.R @@ -211,7 +211,8 @@ tm_g_patient_profile <- function(label = "Patient Profile Plot", 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) + 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) @@ -838,7 +839,8 @@ srv_g_patient_profile <- function(id, 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)) + 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)))) @@ -889,7 +891,8 @@ srv_g_patient_profile <- function(id, mutate(ADY = as.numeric(difftime( .data$ADT, as.Date(substr(as.character( - eval(parse(text = .(sl_start_date), keep.source = FALSE))), 1, 10)), + eval(parse(text = .(sl_start_date), keep.source = FALSE)) + ), 1, 10)), units = "days" )) + (ADT >= as.Date(substr( From ded2d75fdcdfcdf48085c978455b7d96fc807ed7 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Wed, 14 Dec 2022 15:52:25 +0100 Subject: [PATCH 44/68] update NEWS --- NEWS.md | 1 + 1 file changed, 1 insertion(+) diff --git a/NEWS.md b/NEWS.md index 8b7c887f..462458ea 100644 --- a/NEWS.md +++ b/NEWS.md @@ -5,6 +5,7 @@ * 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. +* Removed redundant formal arguments from add added argument checks to `tm_g_patient_profile`. ### Breaking changes From 6e069b715cd77ae96e2b335f0114fe3aa2db9e3d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dawid=20Ka=C5=82=C4=99dkowski?= Date: Thu, 15 Dec 2022 07:32:35 +0100 Subject: [PATCH 45/68] Move checkbox init to UI --- R/tm_g_patient_profile.R | 25 ++++++++++--------------- 1 file changed, 10 insertions(+), 15 deletions(-) diff --git a/R/tm_g_patient_profile.R b/R/tm_g_patient_profile.R index c638cb8e..d7daf93c 100644 --- a/R/tm_g_patient_profile.R +++ b/R/tm_g_patient_profile.R @@ -256,6 +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"), @@ -275,8 +276,15 @@ ui_g_patient_profile <- function(id, ...) { selected = a$patient_id$selected ), div( - class = "pretty-left-border", - uiOutput(ns("select_ADaM_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"), @@ -405,19 +413,6 @@ srv_g_patient_profile <- function(id, moduleServer(id, function(input, output, session) { - # only show the check box when domain data is available - output$select_ADaM_output <- renderUI({ - tagList( - helpText("Select", tags$code("ADaM"), "Domains"), - checkboxGroupInput( - inputId = session$ns("select_ADaM"), - label = NULL, - choices = checkboxes[!is.na(checkboxes)], - selected = checkboxes[!is.na(checkboxes)] - ) - ) - }) - select_plot <- reactive({ vapply(checkboxes, function(x) x %in% input$select_ADaM, logical(1L)) }) From 9103936031492fa18239a64c5dec71a0af9ff436 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dawid=20Ka=C5=82=C4=99dkowski?= Date: Thu, 15 Dec 2022 10:16:38 +0100 Subject: [PATCH 46/68] fix calls --- R/tm_g_patient_profile.R | 429 ++++++++++++++++++--------------------- 1 file changed, 200 insertions(+), 229 deletions(-) diff --git a/R/tm_g_patient_profile.R b/R/tm_g_patient_profile.R index d7daf93c..fec8f564 100644 --- a/R/tm_g_patient_profile.R +++ b/R/tm_g_patient_profile.R @@ -580,26 +580,23 @@ srv_g_patient_profile <- function(id, 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)) - ) + 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 @@ -618,8 +615,10 @@ srv_g_patient_profile <- function(id, 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)]) + 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)) @@ -629,71 +628,49 @@ srv_g_patient_profile <- function(id, if (all(ADAE$USUBJID %in% ADSL$USUBJID)) { qq <- teal.code::eval_code( q1, - code = bquote({ - # ADAE - ADAE <- ADAE[, .(adae_vars)] # nolint - - 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" - ) - ) - + (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)] - }) + 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 = 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)) - } + 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 ) ) ) @@ -704,40 +681,37 @@ srv_g_patient_profile <- function(id, 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)) + teal.code::eval_code(q1, code = quote(ae <- NULL)) } q1 <- if (isTRUE(select_plot()[rs_dataname])) { 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)])) - }) + 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) { @@ -746,47 +720,45 @@ srv_g_patient_profile <- function(id, qq } else { empty_rs <- TRUE - teal.code::eval_code(q1, id = "rs call", expression = bquote(rs <- NULL)) + teal.code::eval_code(q1, expression = quote(rs <- NULL)) } } else { - teal.code::eval_code(q1, code = bquote(rs <- NULL)) + teal.code::eval_code(q1, code = quote(rs <- NULL)) } q1 <- if (isTRUE(select_plot()[cm_dataname])) { 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), ] + 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])) } - cm <- list(data = data.frame(ADCM), var = as.vector(ADCM[, .(cm_var)])) - }) + ) ) ADCM <- qq[[cm_dataname]] # nolint @@ -799,52 +771,52 @@ srv_g_patient_profile <- function(id, teal.code::eval_code(q1, code = quote(cm <- NULL)) } } else { - teal.code::eval_code(q1, code = bquote(cm <- NULL)) + teal.code::eval_code(q1, code = quote(cm <- NULL)) } q1 <- if (isTRUE(select_plot()[ex_dataname])) { 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" + 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), unit = "days")) + + (as.Date(ASTDT) >= as.Date(sl_start_date)) ) - ) %>% - 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)])) - }) + }) %>% + 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) { @@ -863,39 +835,35 @@ srv_g_patient_profile <- function(id, if (all(ADLB$USUBJID %in% ADSL$USUBJID)) { 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)])) - }) + 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[[lb_dataname]] # nolint @@ -908,7 +876,7 @@ srv_g_patient_profile <- function(id, teal.code::eval_code(q1, code = quote(lb <- NULL)) } } else { - teal.code::eval_code(q1, code = bquote(lb <- NULL)) + teal.code::eval_code(q1, code = quote(lb <- NULL)) } # Check the subject has information in at least one selected domain @@ -947,20 +915,23 @@ srv_g_patient_profile <- function(id, 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)) - ) - plot - }) + code = substitute( + env = list(patient_id = patient_id), + 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 + } + ) ) }) From 94cd61227759e23d9b6b8c750aa0f381c9447c6a Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Thu, 15 Dec 2022 09:21:57 +0000 Subject: [PATCH 47/68] [skip actions] Restyle files --- R/tm_g_patient_profile.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/tm_g_patient_profile.R b/R/tm_g_patient_profile.R index fec8f564..f8c7749c 100644 --- a/R/tm_g_patient_profile.R +++ b/R/tm_g_patient_profile.R @@ -649,7 +649,7 @@ srv_g_patient_profile <- function(id, (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] @@ -860,7 +860,7 @@ srv_g_patient_profile <- function(id, 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])) } ) From 6f8f767574111de3870747ff8e50259405bb9a9d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dawid=20Ka=C5=82=C4=99dkowski?= Date: Thu, 15 Dec 2022 10:56:37 +0100 Subject: [PATCH 48/68] Fixing sl_dataname in the g_patient_profile call --- R/tm_g_patient_profile.R | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/R/tm_g_patient_profile.R b/R/tm_g_patient_profile.R index fec8f564..ec85aa01 100644 --- a/R/tm_g_patient_profile.R +++ b/R/tm_g_patient_profile.R @@ -916,7 +916,10 @@ srv_g_patient_profile <- function(id, q1 <- teal.code::eval_code( q1, code = substitute( - env = list(patient_id = patient_id), + env = list( + patient_id = patient_id, + ADSL = as.name(sl_dataname) + ), expr = { plot <- osprey::g_patient_profile( ex = ex, @@ -924,7 +927,7 @@ srv_g_patient_profile <- function(id, rs = rs, cm = cm, lb = lb, - arrow_end_day = ADSL$max_day, + arrow_end_day = ADSL[["max_day"]], xlim = x_limit, xlab = "Study Day", title = paste("Patient Profile: ", patient_id) From bfe2d76000554534013441e31093aef9a958f41a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dawid=20Ka=C5=82=C4=99dkowski?= Date: Thu, 15 Dec 2022 11:17:47 +0100 Subject: [PATCH 49/68] fix --- R/tm_g_patient_profile.R | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/R/tm_g_patient_profile.R b/R/tm_g_patient_profile.R index 4613d9af..25d057bf 100644 --- a/R/tm_g_patient_profile.R +++ b/R/tm_g_patient_profile.R @@ -882,8 +882,7 @@ srv_g_patient_profile <- function(id, # 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 - names = names(checkboxes) + names = checkboxes ) validate(need( From fdefc393cfcec97864d42c6a13896ef33e385df3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dawid=20Ka=C5=82=C4=99dkowski?= Date: Thu, 15 Dec 2022 11:20:06 +0100 Subject: [PATCH 50/68] fix --- R/tm_g_patient_profile.R | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/R/tm_g_patient_profile.R b/R/tm_g_patient_profile.R index 25d057bf..2950b1fe 100644 --- a/R/tm_g_patient_profile.R +++ b/R/tm_g_patient_profile.R @@ -402,19 +402,19 @@ 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") - - checkboxes <- c(ex_dataname, ae_dataname, rs_dataname, lb_dataname, cm_dataname) - 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)) - moduleServer(id, function(input, output, session) { select_plot <- reactive({ - vapply(checkboxes, function(x) x %in% input$select_ADaM, logical(1L)) + vapply( + c(ex_dataname, ae_dataname, rs_dataname, lb_dataname, cm_dataname), + function(x) x %in% input$select_ADaM, + logical(1L) + ) }) if (!is.na(lb_dataname)) { From 4c675ed6b4f7a7f533aba0f034cf8347debe86b7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dawid=20Ka=C5=82=C4=99dkowski?= Date: Thu, 15 Dec 2022 12:27:04 +0100 Subject: [PATCH 51/68] fix heat_by_grade and reload docs --- R/tm_g_heat_bygrade.R | 107 ++++++++++++++++++------------------ man/tm_g_heat_bygrade.Rd | 2 +- man/tm_g_patient_profile.Rd | 2 +- 3 files changed, 55 insertions(+), 56 deletions(-) diff --git a/R/tm_g_heat_bygrade.R b/R/tm_g_heat_bygrade.R index e097e44d..a3efd0e1 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,6 +319,10 @@ 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 <- reactive({ @@ -396,82 +406,71 @@ srv_g_heatmap_bygrade <- function(id, pws <- decorate_output$pws if (!is.na(cm_dataname)) { - output$plot_cm_output <- renderUI({ - checkboxInput( - session$ns("plot_cm"), - "Yes", - value = !is.na(cm_dataname) + observeEvent(input$conmed_var, { + ADCM <- data[[cm_dataname]]() # nolint + choices <- levels(ADCM[[input$conmed_var]]) + + updateSelectInput( + session, + "conmed_level", + selected = choices[1:3], + choices = choices ) }) } - 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 - ) - }) - output_q <- 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 - } teal::validate_has_data(ADSL, min_nrow = 1, msg = sprintf("%s contains no data", sl_dataname)) - teal::validate_inputs(iv(), iv_cm()) - validate(need(input$conmed_level %in% ADCM[[input$conmed_var]], "Updating Conmed Levels")) - q1 <- if (isTRUE(input$plot_cm)) { - conmed_var <- input$conmed_var - - 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::get_code_tdata(data)), - code = quote(conmed_data <- conmed_var <- NULL) + 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({ + qenv <- teal.code::eval_code( + qenv, + code = bquote( plot <- osprey::g_heat_bygrade( id_var = .(input$id_var), - exp_data = ADEX %>% filter(PARCAT1 == "INDIVIDUAL"), + exp_data = .(as.name(ex_dataname)) %>% filter(PARCAT1 == "INDIVIDUAL"), visit_var = .(input$visit_var), ongo_var = .(input$ongo_var), - anno_data = ADSL[c(.(input$anno_var), .(input$id_var))], + anno_data = .(as.name(sl_dataname))[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_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 = conmed_data, - conmed_var = conmed_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/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 45d0c019..fb5fbe2a 100644 --- a/man/tm_g_patient_profile.Rd +++ b/man/tm_g_patient_profile.Rd @@ -42,7 +42,7 @@ argument of \code{\link[teal]{init}}} 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 to omit from analysis} +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} From 14738f4baf60099f513d35b3b64945717bb13a95 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dawid=20Ka=C5=82=C4=99dkowski?= Date: Thu, 15 Dec 2022 12:44:29 +0100 Subject: [PATCH 52/68] fix checkboxes error --- R/tm_g_patient_profile.R | 15 +++++---------- 1 file changed, 5 insertions(+), 10 deletions(-) diff --git a/R/tm_g_patient_profile.R b/R/tm_g_patient_profile.R index 2950b1fe..dea0f470 100644 --- a/R/tm_g_patient_profile.R +++ b/R/tm_g_patient_profile.R @@ -407,19 +407,14 @@ srv_g_patient_profile <- function(id, 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) { - select_plot <- reactive({ - vapply( - c(ex_dataname, ae_dataname, rs_dataname, lb_dataname, cm_dataname), - function(x) x %in% input$select_ADaM, - logical(1L) - ) - }) + select_plot <- reactive( + vapply(checkboxes, function(x) x %in% input$select_ADaM, logical(1L)) + ) if (!is.na(lb_dataname)) { - observeEvent(input$lb_var, { - req(input$lb_var) + 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 From dac01ad80cd5065ef5e911c0eaf110050c1bfe41 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Wed, 21 Dec 2022 12:57:44 +0100 Subject: [PATCH 53/68] fix example --- R/tm_g_patient_profile.R | 2 +- man/tm_g_patient_profile.Rd | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/R/tm_g_patient_profile.R b/R/tm_g_patient_profile.R index dea0f470..97a0d834 100644 --- a/R/tm_g_patient_profile.R +++ b/R/tm_g_patient_profile.R @@ -178,7 +178,7 @@ #' ) #' ) #' if (interactive()) { -#' shinyApp(x$ui, x$server) +#' shinyApp(app$ui, app$server) #' } #' tm_g_patient_profile <- function(label = "Patient Profile Plot", diff --git a/man/tm_g_patient_profile.Rd b/man/tm_g_patient_profile.Rd index fb5fbe2a..1eefade7 100644 --- a/man/tm_g_patient_profile.Rd +++ b/man/tm_g_patient_profile.Rd @@ -224,7 +224,7 @@ app <- init( ) ) if (interactive()) { - shinyApp(x$ui, x$server) + shinyApp(app$ui, app$server) } } From adb5b68e4fbd9aa302071a5a0d5dc2698f01bc11 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Wed, 21 Dec 2022 12:59:04 +0100 Subject: [PATCH 54/68] indentation --- R/tm_g_patient_profile.R | 758 +++++++++++++++++++-------------------- 1 file changed, 379 insertions(+), 379 deletions(-) diff --git a/R/tm_g_patient_profile.R b/R/tm_g_patient_profile.R index 97a0d834..ec5b6dee 100644 --- a/R/tm_g_patient_profile.R +++ b/R/tm_g_patient_profile.R @@ -211,7 +211,7 @@ tm_g_patient_profile <- function(label = "Patient Profile Plot", 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 + 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) @@ -493,444 +493,444 @@ srv_g_patient_profile <- function(id, # render plot output_q <- 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 - )) + 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 - ADEX <- NULL # nolint - if (isTRUE(select_plot()[ex_dataname])) { - ADEX <- data[[ex_dataname]]() # nolint - teal::validate_has_variable(ADEX, adex_vars) - } - ADAE <- NULL # nolint - if (isTRUE(select_plot()[ae_dataname])) { - ADAE <- data[[ae_dataname]]() # nolint - teal::validate_has_variable(ADAE, adae_vars) - } - ADRS <- NULL # nolint - if (isTRUE(select_plot()[rs_dataname])) { - ADRS <- data[[rs_dataname]]() # nolint - teal::validate_has_variable(ADRS, adrs_vars) - } - ADCM <- NULL # nolint - if (isTRUE(select_plot()[cm_dataname])) { - ADCM <- data[[cm_dataname]]() # nolint - teal::validate_has_variable(ADCM, adcm_vars) - } - ADLB <- NULL # nolint - if (isTRUE(select_plot()[lb_dataname])) { - ADLB <- data[[lb_dataname]]() # nolint - teal::validate_has_variable(ADLB, adlb_vars) - } + ADEX <- NULL # nolint + if (isTRUE(select_plot()[ex_dataname])) { + ADEX <- data[[ex_dataname]]() # nolint + teal::validate_has_variable(ADEX, adex_vars) + } + ADAE <- NULL # nolint + if (isTRUE(select_plot()[ae_dataname])) { + ADAE <- data[[ae_dataname]]() # nolint + teal::validate_has_variable(ADAE, adae_vars) + } + ADRS <- NULL # nolint + if (isTRUE(select_plot()[rs_dataname])) { + ADRS <- data[[rs_dataname]]() # nolint + teal::validate_has_variable(ADRS, adrs_vars) + } + ADCM <- NULL # nolint + if (isTRUE(select_plot()[cm_dataname])) { + ADCM <- data[[cm_dataname]]() # nolint + teal::validate_has_variable(ADCM, adcm_vars) + } + ADLB <- NULL # nolint + if (isTRUE(select_plot()[lb_dataname])) { + ADLB <- data[[lb_dataname]]() # nolint + teal::validate_has_variable(ADLB, adlb_vars) + } - 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 = 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)) - ) - } - ) - ) - - # ADSL with single subject - validate( - need( - nrow(q1[["ADSL"]]) >= 1, - paste( - "Subject", - patient_id, - "not found in the dataset. Perhaps they have been filtered out by the filter panel?" + 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 = 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)) + ) + } ) ) - ) - # name for ae_line_col - q1 <- if (!is.null(ae_line_col_var) && is.data.frame(ADAE)) { - teal.code::eval_code( - q1, - 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] + # ADSL with single subject + validate( + need( + nrow(q1[["ADSL"]]) >= 1, + paste( + "Subject", + patient_id, + "not found in the dataset. Perhaps they have been filtered out by the filter panel?" + ) ) ) - } else { - teal.code::eval_code(q1, code = quote(ae_line_col_name <- NULL)) - } - q1 <- if (isTRUE(select_plot()[ae_dataname])) { - 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 = 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] - } + 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] ) - ) %>% - teal.code::eval_code( + ) + } else { + teal.code::eval_code(q1, code = quote(ae_line_col_name <- NULL)) + } + + 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), - 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 + sl_start_date = as.name(sl_start_date), + ae_line_col_var = ae_line_col_var, + adae_vars = adae_vars ), - 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 + 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 + ) ) ) - ) - ADAE <- qq[[ae_dataname]] # 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 = quote(ae <- NULL)) } - } else { - teal.code::eval_code(q1, code = quote(ae <- NULL)) - } - 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])) - } + 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) { + 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, expression = quote(rs <- NULL)) + teal.code::eval_code(q1, code = quote(rs <- NULL)) } - } else { - teal.code::eval_code(q1, code = quote(rs <- NULL)) - } - 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), ] + 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])) } - cm <- list(data = data.frame(ADCM), var = as.vector(ADCM[, cm_var])) - } + ) ) - ) - ADCM <- qq[[cm_dataname]] # 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 = quote(cm <- NULL)) - } - 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), unit = "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])) - } + 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) { + 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 (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])) - } + 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[[lb_dataname]] # 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 = quote(lb <- NULL)) - } - # 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 <- structure( + c(empty_ex, empty_ae, empty_rs, empty_lb, empty_cm), + names = checkboxes + ) - 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(checkboxes[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"]] - } - - q1 <- teal.code::eval_code( - q1, - 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 - } + 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_r <- reactive(output_q()[["plot"]]) From 1080a5454fa5f442e05400aff555654b55960bc6 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Wed, 21 Dec 2022 12:59:35 +0100 Subject: [PATCH 55/68] add debouce to plot in patient_profile --- R/tm_g_patient_profile.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/tm_g_patient_profile.R b/R/tm_g_patient_profile.R index ec5b6dee..0db05e9c 100644 --- a/R/tm_g_patient_profile.R +++ b/R/tm_g_patient_profile.R @@ -932,7 +932,7 @@ srv_g_patient_profile <- function(id, ) }) - plot_r <- reactive(output_q()[["plot"]]) + plot_r <- shiny::debounce(reactive(output_q()[["plot"]]), millis = 200) pws <- teal.widgets::plot_with_settings_srv( id = "patientprofileplot", From 52b9b5e787ed1b8f61beb9b024daea656cc138fd Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Wed, 21 Dec 2022 13:03:11 +0100 Subject: [PATCH 56/68] add debouce to plot in heat_bygrade --- R/tm_g_heat_bygrade.R | 99 +++++++++++++++++++++++-------------------- 1 file changed, 52 insertions(+), 47 deletions(-) diff --git a/R/tm_g_heat_bygrade.R b/R/tm_g_heat_bygrade.R index a3efd0e1..feafad1f 100644 --- a/R/tm_g_heat_bygrade.R +++ b/R/tm_g_heat_bygrade.R @@ -419,59 +419,64 @@ srv_g_heatmap_bygrade <- function(id, }) } - output_q <- reactive({ - ADSL <- data[[sl_dataname]]() # nolint - ADEX <- data[[ex_dataname]]() # nolint - ADAE <- data[[ae_dataname]]() # nolint + output_q <- shiny::debounce( + millis = 200, + r = reactive({ + ADSL <- data[[sl_dataname]]() # nolint + ADEX <- data[[ex_dataname]]() # nolint + ADAE <- data[[ae_dataname]]() # nolint - teal::validate_has_data(ADSL, min_nrow = 1, msg = sprintf("%s contains no data", sl_dataname)) - teal::validate_inputs(iv(), iv_cm()) - validate(need(input$conmed_level %in% ADCM[[input$conmed_var]], "Updating Conmed Levels")) + 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")) + } - 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] - } + 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] + } + ) ) - ) - } + } - 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), + 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(qenv, quote(plot)) - }) + teal.code::eval_code(qenv, quote(plot)) + }) + ) plot_r <- reactive(output_q()[["plot"]]) From 27b19dd1349ef01c82b89d7eb63fa33d3e74622c Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Wed, 21 Dec 2022 13:29:09 +0100 Subject: [PATCH 57/68] add validation to heat_bygrade --- R/tm_g_heat_bygrade.R | 2 ++ 1 file changed, 2 insertions(+) diff --git a/R/tm_g_heat_bygrade.R b/R/tm_g_heat_bygrade.R index feafad1f..920702f3 100644 --- a/R/tm_g_heat_bygrade.R +++ b/R/tm_g_heat_bygrade.R @@ -389,6 +389,8 @@ srv_g_heatmap_bygrade <- function(id, 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" }) From 74c5da46700887ad51b64868d1a62820d006c621 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Wed, 21 Dec 2022 13:29:24 +0100 Subject: [PATCH 58/68] move debounce in patient_profile --- R/tm_g_patient_profile.R | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/R/tm_g_patient_profile.R b/R/tm_g_patient_profile.R index 0db05e9c..693a893f 100644 --- a/R/tm_g_patient_profile.R +++ b/R/tm_g_patient_profile.R @@ -492,7 +492,9 @@ srv_g_patient_profile <- function(id, }) # render plot - output_q <- reactive({ + output_q <- shiny::debounce( + millis = 200, + r = reactive({ teal::validate_inputs(iv()) # get inputs --- @@ -931,8 +933,9 @@ srv_g_patient_profile <- function(id, ) ) }) + ) - plot_r <- shiny::debounce(reactive(output_q()[["plot"]]), millis = 200) + plot_r <- reactive(output_q()[["plot"]]) pws <- teal.widgets::plot_with_settings_srv( id = "patientprofileplot", From 4fd69ce2554b461da559518ecd1db8a9936afe22 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Wed, 21 Dec 2022 13:41:51 +0100 Subject: [PATCH 59/68] update validation in events_term_id --- R/tm_g_events_term_id.R | 15 ++++++--------- 1 file changed, 6 insertions(+), 9 deletions(-) diff --git a/R/tm_g_events_term_id.R b/R/tm_g_events_term_id.R index 13d8916d..41803a92 100644 --- a/R/tm_g_events_term_id.R +++ b/R/tm_g_events_term_id.R @@ -214,8 +214,6 @@ srv_g_events_term_id <- function(id, moduleServer(id, function(input, output, session) { iv <- reactive({ - ANL <- data[[dataname]]() # nolint - iv <- shinyvalidate::InputValidator$new() iv$add_rule("term", shinyvalidate::sv_required( message = "Term Variable is required" @@ -223,9 +221,6 @@ srv_g_events_term_id <- function(id, 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" } @@ -311,10 +306,12 @@ srv_g_events_term_id <- function(id, teal::validate_inputs(iv()) - validate(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." - )) + 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 From 800ccf7539718d01ddb23c5b7d20e1a6eac9aa36 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Wed, 21 Dec 2022 13:45:41 +0100 Subject: [PATCH 60/68] add debounce in butterfly --- R/tm_g_butterfly.R | 179 +++++++++++++++++++++++---------------------- 1 file changed, 91 insertions(+), 88 deletions(-) diff --git a/R/tm_g_butterfly.R b/R/tm_g_butterfly.R index bef9bef2..063b6f1b 100644 --- a/R/tm_g_butterfly.R +++ b/R/tm_g_butterfly.R @@ -380,115 +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 - 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)) + 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)) - teal::validate_inputs(iv()) + teal::validate_inputs(iv()) - 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?)" + 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?)" + ) ) - ) - 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 + 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 - # 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))) + # 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))) - adsl_vars <- unique(c("USUBJID", "STUDYID", varlist_from_adsl)) # nolint - anl_vars <- unique(c("USUBJID", "STUDYID", varlist_from_anl)) # nolint + adsl_vars <- unique(c("USUBJID", "STUDYID", varlist_from_adsl)) # nolint + anl_vars <- unique(c("USUBJID", "STUDYID", varlist_from_anl)) # nolint - 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 - }) - ) - - 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"]]) From 82f7c80365b2ae143acaf6816d9f77bb3386b502 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Wed, 21 Dec 2022 13:47:39 +0100 Subject: [PATCH 61/68] add debounce in ae_sub --- R/tm_g_ae_sub.R | 111 +++++++++++++++++++++++++----------------------- 1 file changed, 57 insertions(+), 54 deletions(-) diff --git a/R/tm_g_ae_sub.R b/R/tm_g_ae_sub.R index 17d4c6e3..07f38635 100644 --- a/R/tm_g_ae_sub.R +++ b/R/tm_g_ae_sub.R @@ -310,66 +310,69 @@ srv_g_ae_sub <- function(id, }) }) - output_q <- reactive({ - ANL <- data[[dataname]]() # nolint - ADSL <- data[["ADSL"]]() # nolint + output_q <- shiny::debounce( + millis = 200, + r = reactive({ + ANL <- data[[dataname]]() # nolint + ADSL <- data[["ADSL"]]() # nolint - teal::validate_has_data(ANL, min_nrow = 10, msg = sprintf("%s has not enough data", dataname)) + teal::validate_has_data(ANL, min_nrow = 10, msg = sprintf("%s has not enough data", dataname)) - teal::validate_inputs(iv()) + teal::validate_inputs(iv()) - 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?" - )) + 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 <- 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))) - } + 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) - )) - ) - }) + 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"]]) From 56416fadac040a067a31a106f18e718de86e557e Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Wed, 21 Dec 2022 13:55:44 +0100 Subject: [PATCH 62/68] add debounce in ae_oview --- R/tm_g_ae_oview.R | 81 ++++++++++++++++++++++++----------------------- 1 file changed, 42 insertions(+), 39 deletions(-) diff --git a/R/tm_g_ae_oview.R b/R/tm_g_ae_oview.R index 84cff253..712a1dd1 100644 --- a/R/tm_g_ae_oview.R +++ b/R/tm_g_ae_oview.R @@ -307,50 +307,53 @@ srv_g_ae_oview <- function(id, ) }) - output_q <- reactive({ - ANL <- data[[dataname]]() # nolint - - teal::validate_has_data(ANL, min_nrow = 10, msg = sprintf("%s has not enough data", dataname)) + output_q <- shiny::debounce( + millis = 200, + r = reactive({ + ANL <- data[[dataname]]() # nolint - teal::validate_inputs(iv()) + teal::validate_has_data(ANL, min_nrow = 10, msg = sprintf("%s has not enough data", dataname)) - 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?" - )) + teal::validate_inputs(iv()) - 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]))) + 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?" )) - ) - 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) - )) - ) - }) + 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"]]) From aeb6563730ff6091e18eb8f9c8285c78b907e927 Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Wed, 21 Dec 2022 13:06:57 +0000 Subject: [PATCH 63/68] [skip actions] Restyle files --- R/tm_g_ae_oview.R | 4 ++-- R/tm_g_events_term_id.R | 3 ++- R/tm_g_heat_bygrade.R | 3 ++- R/tm_g_patient_profile.R | 4 ++-- 4 files changed, 8 insertions(+), 6 deletions(-) diff --git a/R/tm_g_ae_oview.R b/R/tm_g_ae_oview.R index 712a1dd1..f00265d8 100644 --- a/R/tm_g_ae_oview.R +++ b/R/tm_g_ae_oview.R @@ -326,8 +326,8 @@ srv_g_ae_oview <- function(id, 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]))) + select(all_of(.(input$flag_var_anl))) %>% + rename_at(vars(.(input$flag_var_anl)), function(x) paste0(x, ": ", anl_labels[x]))) )) ) diff --git a/R/tm_g_events_term_id.R b/R/tm_g_events_term_id.R index 41803a92..ff4da4e3 100644 --- a/R/tm_g_events_term_id.R +++ b/R/tm_g_events_term_id.R @@ -311,7 +311,8 @@ srv_g_events_term_id <- function(id, 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 diff --git a/R/tm_g_heat_bygrade.R b/R/tm_g_heat_bygrade.R index 920702f3..0f871268 100644 --- a/R/tm_g_heat_bygrade.R +++ b/R/tm_g_heat_bygrade.R @@ -390,7 +390,8 @@ srv_g_heatmap_bygrade <- function(id, "Study Ongoing Status must be a factor variable" }) iv_cm$add_rule("conmed_level", shinyvalidate::sv_required( - "Select Conmed Levels")) + "Select Conmed Levels" + )) iv_cm$add_rule("conmed_level", ~ if (length(.) > 3L) { "No more than three Conmed Levels are allowed" }) diff --git a/R/tm_g_patient_profile.R b/R/tm_g_patient_profile.R index 693a893f..263142be 100644 --- a/R/tm_g_patient_profile.R +++ b/R/tm_g_patient_profile.R @@ -211,7 +211,7 @@ tm_g_patient_profile <- function(label = "Patient Profile Plot", 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 + 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) @@ -751,7 +751,7 @@ srv_g_patient_profile <- function(id, 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), ] + & is.na(ADCM$ASTDY) == FALSE), ] } cm <- list(data = data.frame(ADCM), var = as.vector(ADCM[, cm_var])) } From 5d718631209181806d550bd1f44896d7fc519154 Mon Sep 17 00:00:00 2001 From: Nikolas Burkoff Date: Wed, 21 Dec 2022 16:13:16 +0000 Subject: [PATCH 64/68] trigger From 0ae47bceac85520fd46dedaa3c79a65428be6bac Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Thu, 22 Dec 2022 15:47:43 +0100 Subject: [PATCH 65/68] bug fix and NEWS update --- NEWS.md | 3 ++- R/tm_g_patient_profile.R | 4 ++-- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/NEWS.md b/NEWS.md index 462458ea..05fa8f78 100644 --- a/NEWS.md +++ b/NEWS.md @@ -5,13 +5,14 @@ * 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. -* Removed redundant formal arguments from add added argument checks to `tm_g_patient_profile`. +* 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_patient_profile.R b/R/tm_g_patient_profile.R index 263142be..242a88cf 100644 --- a/R/tm_g_patient_profile.R +++ b/R/tm_g_patient_profile.R @@ -446,8 +446,8 @@ srv_g_patient_profile <- function(id, message = "Adverse Event variable is required" )) iv$add_rule("ae_line_var", shinyvalidate::sv_optional()) - iv$add_rule("ae_line_var", ~ if (length(levels(ADAE[[.]])) > length(ae_line_col_opt)) { - "Not enough colors provided Adverse Event line color, unselect" + 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" }) } if (isTRUE(select_plot()[rs_dataname])) { From 65a1daf4514300b9e60d582782b6e97e4dce83dd Mon Sep 17 00:00:00 2001 From: "27856297+dependabot-preview[bot]@users.noreply.github.com" <27856297+dependabot-preview[bot]@users.noreply.github.com> Date: Thu, 22 Dec 2022 14:56:14 +0000 Subject: [PATCH 66/68] [skip actions] Roxygen Man Pages Auto Update --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 841b27fb..2c7857ac 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -64,4 +64,4 @@ Encoding: UTF-8 Language: en-US LazyData: true Roxygen: list(markdown = TRUE) -RoxygenNote: 7.2.2 +RoxygenNote: 7.2.3 From 146305c8f4a2d9f45a0ac8cb785376140b222dc3 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Tue, 3 Jan 2023 09:30:43 +0100 Subject: [PATCH 67/68] trigger checks From 83e23544ea9d55e4cded06cf321cb972b213376d Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Tue, 3 Jan 2023 11:43:28 +0100 Subject: [PATCH 68/68] trigger checks again