diff --git a/DESCRIPTION b/DESCRIPTION index 89f619953e..cff814cd64 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -48,6 +48,7 @@ Imports: scales, shiny, shinyjs, + shinyvalidate, shinyWidgets, stats, styler, diff --git a/NEWS.md b/NEWS.md index 6d651d33ff..31da117342 100644 --- a/NEWS.md +++ b/NEWS.md @@ -9,6 +9,7 @@ * Replaced `synthetic_cdisc_data` with refactored `synthetic_cdisc_dataset` function to speed up dataset loading in tests/examples. * Added new GEE module `tm_a_gee`. * Added interface for selecting an interaction term to `tm_t_ancova`. +* Updated encodings input checks to use `shinyvalidate::InputValidator` instead of `shiny::validate` for better UI experience. ### Miscellaneous * Package now uses `scda.2022` rather than `scda.2021` in SUGGESTS. diff --git a/R/arm_ref_comp.R b/R/arm_ref_comp.R index 2aca41b5d8..2dffc8d3f4 100644 --- a/R/arm_ref_comp.R +++ b/R/arm_ref_comp.R @@ -20,39 +20,55 @@ #' stop the whole observer if FALSE. #' @param input_id (`character`) unique id that the buckets will be referenced with. #' @param output_id (`character`) name of the UI id that the output will be written to. -#' +#' @return Returns a `shinyvalidate::InputValidator` which checks that there is at least one reference +#' and comparison arm #' @keywords internal #' #' @examples -#' ds <- teal:::get_dummy_datasets() #' #' arm_ref_comp <- list(ARMCD = list(ref = "ARM A", comp = c("ARM B"))) -#' arm_var <- choices_selected(c("ARM", "ARMCD"), "ARM") -#' if (interactive()) { -#' shinyApp( -#' ui = fluidPage( +#' arm_var <- choices_selected(c("ARM", "ARMCD"), "ARMCD") +#' +#' adsl <- data.frame(ARM = c("ARM 1", "ARM 2"), ARMCD = c("ARM A", "ARM B")) +#' +#' ui <- fluidPage( +#' sidebarLayout( +#' sidebarPanel( #' teal.widgets::optionalSelectInput( #' "arm", #' "Treatment Variable", #' choices = arm_var$choices, #' selected = arm_var$selected #' ), -#' shiny::uiOutput("arms_buckets"), +#' shiny::uiOutput("arms_buckets") #' ), -#' server = function(input, output, session) { -#' shiny::isolate({ -#' teal.modules.clinical:::arm_ref_comp_observer( -#' session, -#' input, -#' output, -#' id_arm_var = "arm", -#' datasets = ds, -#' arm_ref_comp = arm_ref_comp, -#' module = "example" -#' ) -#' }) -#' } +#' mainPanel( +#' shiny::textOutput("result") +#' ) #' ) +#' ) +#' +#' server <- function(input, output, session) { +#' iv_arm_ref <- teal.modules.clinical:::arm_ref_comp_observer( +#' session, +#' input, +#' output, +#' id_arm_var = "arm", +#' data = adsl, +#' arm_ref_comp = arm_ref_comp, +#' module = "example" +#' ) +#' +#' output$result <- shiny::renderText({ +#' iv <- shinyvalidate::InputValidator$new() +#' iv$add_validator(iv_arm_ref) +#' iv$enable() +#' teal::validate_inputs(iv) +#' "Valid selection has been made!" +#' }) +#' } +#' if (interactive()) { +#' shiny::shinyApp(ui, server) #' } arm_ref_comp_observer <- function(session, input, @@ -66,22 +82,27 @@ arm_ref_comp_observer <- function(session, on_off = shiny::reactive(TRUE), input_id = "buckets", output_id = "arms_buckets") { - # uses observe because observeEvent evaluates only when on_off() is switched - # not necessarily when variables are dropped + iv <- shinyvalidate::InputValidator$new() + iv1 <- shinyvalidate::InputValidator$new() + iv2 <- shinyvalidate::InputValidator$new() + iv2$condition(~ iv1$is_valid()) + iv1$add_rule(id_arm_var, shinyvalidate::sv_required("Treatment variable must be selected")) + iv2$add_rule(input_id, ~ if (length(.[[id_ref]]) == 0) "A reference arm must be selected") + iv2$add_rule(input_id, ~ if (length(.[[id_comp]]) == 0) "A comparison arm must be selected") + iv$add_validator(iv1) + iv$add_validator(iv2) + + output[[output_id]] <- shiny::renderUI({ - if (!is.null(on_off()) && on_off()) { + if (isTRUE(on_off())) { df <- if (shiny::is.reactive(data)) { data() } else { data } - check_arm_ref_comp(arm_ref_comp, df, module) ## throws an error if there are issues - arm_var <- input[[id_arm_var]] - - # validations here don't produce nice UI message (it's observe and not render output) but it prevent red errors - teal::validate_has_elements(arm_var, "Treatment variable name is empty.") + arm_var <- shiny::req(input[[id_arm_var]]) arm <- df[[arm_var]] teal::validate_has_elements(arm, "Treatment variable is empty.") @@ -112,6 +133,8 @@ arm_ref_comp_observer <- function(session, ) } }) + + return(iv) } #' Check if the Treatment variable is reference or compare @@ -132,7 +155,6 @@ check_arm_ref_comp <- function(x, df_to_check, module) { stop(msg, "needs to be a list or NULL") } - vars <- names(x) if (is.null(vars) || any(vars == "")) { stop(msg, "is not named") @@ -142,7 +164,6 @@ check_arm_ref_comp <- function(x, df_to_check, module) { stop(msg, "refers to variables that are not in the data") } - Map( x, vars, f = function(xi, var) { diff --git a/R/tm_a_gee.R b/R/tm_a_gee.R index d9532b1196..1c92d94215 100644 --- a/R/tm_a_gee.R +++ b/R/tm_a_gee.R @@ -216,15 +216,13 @@ tm_a_gee <- function(label, args <- as.list(environment()) data_extract_list <- list( - arm_var = teal.modules.clinical::cs_to_des_select(arm_var, dataname = parentname), - paramcd = teal.modules.clinical::cs_to_des_filter(paramcd, dataname = dataname), - id_var = teal.modules.clinical::cs_to_des_select(id_var, dataname = dataname), - visit_var = teal.modules.clinical::cs_to_des_select(visit_var, dataname = dataname), - cov_var = teal.modules.clinical::cs_to_des_select(cov_var, dataname = dataname, multiple = TRUE), - split_covariates = teal.modules.clinical::cs_to_des_select(teal.modules.clinical::split_choices(cov_var), - dataname = dataname, multiple = TRUE - ), - aval_var = teal.modules.clinical::cs_to_des_select(aval_var, dataname = dataname) + arm_var = cs_to_des_select(arm_var, dataname = parentname), + paramcd = cs_to_des_filter(paramcd, dataname = dataname), + id_var = cs_to_des_select(id_var, dataname = dataname), + visit_var = cs_to_des_select(visit_var, dataname = dataname), + cov_var = cs_to_des_select(cov_var, dataname = dataname, multiple = TRUE), + split_covariates = cs_to_des_select(split_choices(cov_var), dataname = dataname, multiple = TRUE), + aval_var = cs_to_des_select(aval_var, dataname = dataname) ) teal::module( @@ -308,13 +306,11 @@ ui_gee <- function(id, ...) { data_extract_spec = a$arm_var, is_single_dataset = is_single_dataset_value ), - shinyjs::hidden(shiny::uiOutput(ns("arms_buckets"))), shinyjs::hidden( + shiny::uiOutput(ns("arms_buckets")), shiny::helpText( id = ns("help_text"), "Multiple reference groups are automatically combined into a single group." - ) - ), - shinyjs::hidden( + ), shiny::checkboxInput( ns("combine_comp_arms"), "Combine all comparison groups?", @@ -358,7 +354,7 @@ ui_gee <- function(id, ...) { selected = "t_gee_lsmeans" ) ), - forms = tagList( + forms = shiny::tagList( teal.widgets::verbatim_popup_ui(ns("warning"), button_label = "Show Warnings"), teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code") ), @@ -391,14 +387,14 @@ srv_gee <- function(id, shiny::moduleServer(id, function(input, output, session) { ## split_covariates ---- - shiny::observeEvent(input[[teal.modules.clinical::extract_input("cov_var", dataname)]], + shiny::observeEvent(input[[extract_input("cov_var", dataname)]], ignoreNULL = FALSE, { # update covariates as actual variables - split_interactions_values <- teal.modules.clinical::split_interactions( - input[[teal.modules.clinical::extract_input("cov_var", dataname)]] + split_interactions_values <- split_interactions( + input[[extract_input("cov_var", dataname)]] ) - arm_var_value <- input[[teal.modules.clinical::extract_input("arm_var", parentname)]] + arm_var_value <- input[[extract_input("arm_var", parentname)]] arm_in_cov <- length(intersect(split_interactions_values, arm_var_value)) >= 1L if (arm_in_cov) { split_covariates_selected <- setdiff(split_interactions_values, arm_var_value) @@ -407,7 +403,7 @@ srv_gee <- function(id, } teal.widgets::updateOptionalSelectInput( session, - inputId = teal.modules.clinical::extract_input("split_covariates", dataname), + inputId = extract_input("split_covariates", dataname), selected = split_covariates_selected ) } @@ -418,15 +414,14 @@ srv_gee <- function(id, session, input, output, - id_arm_var = teal.modules.clinical::extract_input("arm_var", parentname), + id_arm_var = extract_input("arm_var", parentname), data = data[[parentname]], arm_ref_comp = arm_ref_comp, module = "tm_a_gee" ) ## data_merge_modules ---- - anl_inputs <- teal.transform::merge_expression_module( - datasets = data, + selector_list <- teal.transform::data_extract_multiple_srv( data_extract = list( arm_var = arm_var, paramcd = paramcd, @@ -435,6 +430,36 @@ srv_gee <- function(id, split_covariates = split_covariates, aval_var = aval_var ), + datasets = data, + select_validation_rule = list( + aval_var = shinyvalidate::sv_required("An analysis variable is required"), + arm_var = shinyvalidate::sv_required("A treatment variable is required"), + id_var = shinyvalidate::sv_required("A Subject identifier is required"), + visit_var = shinyvalidate::sv_required("A visit variable is required") + ), + filter_validation_rule = list( + paramcd = shinyvalidate::sv_required("An endpoint is required") + ) + ) + + iv_r <- shiny::reactive({ + iv <- shinyvalidate::InputValidator$new() + iv$add_rule("conf_level", shinyvalidate::sv_required("Please choose a confidence level.")) + iv$add_rule( + "conf_level", + shinyvalidate::sv_between( + 0, 1, + inclusive = c(FALSE, FALSE), + message_fmt = "Confidence level must be between 0 and 1" + ) + ) + iv$add_rule("cor_struct", shinyvalidate::sv_required("Please choose a correlation structure")) + teal.transform::compose_and_enable_validators(iv, selector_list) + }) + + anl_inputs <- teal.transform::merge_expression_srv( + datasets = data, + selector_list = selector_list, merge_function = "dplyr::inner_join", join_keys = get_join_keys(data) ) @@ -446,7 +471,7 @@ srv_gee <- function(id, join_keys = get_join_keys(data) ) - anl_q <- reactive({ + anl_q <- shiny::reactive({ teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) %>% teal.code::eval_code(as.expression(anl_inputs()$expr)) %>% teal.code::eval_code(as.expression(adsl_inputs()$expr)) @@ -461,16 +486,22 @@ srv_gee <- function(id, # Initially hide the output title because there is no output yet. shinyjs::show("gee_title") - # To do in production: add validations. + validate_checks <- shiny::reactive({ + teal::validate_inputs(iv_r()) + + # To do in production: add validations. + NULL + }) ## table_r ---- table_q <- shiny::reactive({ + validate_checks() output_table <- input$output_table conf_level <- as.numeric(input$conf_level) col_source <- merged$anl_input_r()$columns_source filter_info <- merged$anl_input_r()$filter_info - req(output_table) + shiny::req(output_table) basic_table_args$subtitles <- paste0( "Analysis Variable: ", col_source$aval_var, @@ -521,15 +552,15 @@ srv_gee <- function(id, teal.widgets::verbatim_popup_srv( id = "warning", - verbatim_content = reactive(teal.code::get_warnings(table_q())), + verbatim_content = shiny::reactive(teal.code::get_warnings(table_q())), title = "Warning", - disabled = reactive(is.null(teal.code::get_warnings(table_q()))) + disabled = shiny::reactive(is.null(teal.code::get_warnings(table_q()))) ) # Render R code teal.widgets::verbatim_popup_srv( id = "rcode", - verbatim_content = reactive(teal.code::get_code(table_q())), + verbatim_content = shiny::reactive(teal.code::get_code(table_q())), title = label ) diff --git a/R/tm_a_mmrm.R b/R/tm_a_mmrm.R index 1bea322ce1..e633ef5cfb 100644 --- a/R/tm_a_mmrm.R +++ b/R/tm_a_mmrm.R @@ -803,7 +803,7 @@ ui_mmrm <- function(id, ...) { ) ) ), - forms = tagList( + forms = shiny::tagList( teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"), teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") ), @@ -858,16 +858,78 @@ srv_mmrm <- function(id, ) }) - anl_inputs <- teal.transform::merge_expression_module( - datasets = data, + arm_ref_comp_iv <- arm_ref_comp_observer( + session, + input, + output, + id_arm_var = extract_input("arm_var", parentname), # From UI. + data = data[[parentname]], + arm_ref_comp = arm_ref_comp, + module = "tm_mmrm" + ) + + selector_list <- teal.transform::data_extract_multiple_srv( data_extract = list( arm_var = arm_var, paramcd = paramcd, id_var = id_var, visit_var = visit_var, split_covariates = split_covariates, + cov_var = cov_var, # only needed for validation see selector_list_without_cov reactive aval_var = aval_var ), + datasets = data, + select_validation_rule = list( + aval_var = shinyvalidate::sv_required("'Analysis Variable' field is not selected"), + visit_var = shinyvalidate::sv_required("'Visit Variable' field is not selected"), + arm_var = shinyvalidate::sv_required("'Treatment Variable' field is not selected"), + id_var = shinyvalidate::sv_required("'Subject Identifier' field is not selected"), + # validation on cov_var + cov_var = function(value) { + if (length(selector_list()$visit_var()$select) == 0) { + return(NULL) + } + if ("BASE:AVISIT" %in% value && selector_list()$visit_var()$select == "AVISITN") { + paste( + "'BASE:AVISIT' is not a valid covariate when 'AVISITN' is selected as visit variable.", + "Please deselect 'BASE:AVISIT' as a covariate or change visit variable to 'AVISIT'." + ) + } else if ("BASE:AVISITN" %in% value && selector_list()$visit_var()$select == "AVISIT") { + paste( + "'BASE:AVISITN' is not a valid covariate when 'AVISIT' is selected as visit variable.", + "Please deselect 'BASE:AVISITN' as a covariate or change visit variable to 'AVISITN'." + ) + } + } + ), + filter_validation_rule = list( + paramcd = shinyvalidate::sv_required("'Select Endpoint' field is not selected") + ) + ) + + # selector_list includes cov_var as it is needed for validation rules + # but it is not needed for the merge so it is removed here + selector_list_without_cov <- shiny::reactive({ + selector_list()[names(selector_list()) != "cov_var"] + }) + + iv_r <- shiny::reactive({ + iv <- shinyvalidate::InputValidator$new() + iv$add_validator(arm_ref_comp_iv) + iv$add_rule("conf_level", shinyvalidate::sv_required("'Confidence Level' field is not selected")) + iv$add_rule( + "conf_level", + shinyvalidate::sv_between( + 0, 1, + message_fmt = "Confidence level must be between 0 and 1" + ) + ) + teal.transform::compose_and_enable_validators(iv, selector_list) + }) + + anl_inputs <- teal.transform::merge_expression_srv( + datasets = data, + selector_list = selector_list_without_cov, join_keys = get_join_keys(data), merge_function = "dplyr::inner_join" ) @@ -879,7 +941,7 @@ srv_mmrm <- function(id, anl_name = "ANL_ADSL" ) - anl_q <- reactive({ + anl_q <- shiny::reactive({ qenv <- teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) qenv2 <- teal.code::eval_code(qenv, as.expression(anl_inputs()$expr)) teal.code::eval_code(qenv2, as.expression(adsl_merge_inputs()$expr)) @@ -929,16 +991,6 @@ srv_mmrm <- function(id, } }) - arm_ref_comp_observer( - session, - input, - output, - id_arm_var = extract_input("arm_var", parentname), # From UI. - data = data[[parentname]], - arm_ref_comp = arm_ref_comp, - module = "tm_mmrm" - ) - # Event handler: # Show either the plot or the table output. shiny::observeEvent(input$output_function, { @@ -1035,7 +1087,7 @@ srv_mmrm <- function(id, mmrm_inputs_reactive <- shiny::reactive({ shinyjs::disable("button_start") disable_r_code(TRUE) - + teal::validate_inputs(iv_r()) encoding_inputs <- lapply( sync_inputs, function(x) { @@ -1051,35 +1103,8 @@ srv_mmrm <- function(id, adsl_filtered <- anl_q()[["ADSL"]] anl_filtered <- anl_q()[[dataname]] - shiny::validate( - shiny::need( - encoding_inputs[[extract_input("aval_var", dataname)]], "`Analysis Variable` field is not selected" - ), - shiny::need( - encoding_inputs[[extract_input("paramcd", dataname, filter = TRUE)]], - "`Select Endpoint` field is not selected" - ), - shiny::need(encoding_inputs[[extract_input("visit_var", dataname)]], "`Visit Variable` field is not selected"), - shiny::need(encoding_inputs[[extract_input("id_var", dataname)]], "`Subject Identifier` field is not selected"), - shiny::need(encoding_inputs[["conf_level"]], "`Confidence Level` field is not selected"), - shiny::need(nrow(adsl_filtered) > 1 && nrow(anl_filtered) > 1, "Filtered data has zero rows"), - shiny::need( - !("BASE:AVISIT" %in% encoding_inputs[[extract_input("cov_var", dataname)]] & - encoding_inputs[[extract_input("visit_var", dataname)]] != "AVISIT"), - paste( - "`BASE:AVISIT` is not a valid covariate when `AVISITN` is selected as visit variable.", - "Please deselect `BASE:AVISIT` as a covariate or change visit variable to `AVISIT`." - ) - ), - shiny::need( - !("BASE:AVISITN" %in% encoding_inputs[[extract_input("cov_var", dataname)]] & - encoding_inputs[[extract_input("visit_var", dataname)]] != "AVISITN"), - paste( - "`BASE:AVISITN` is not a valid covariate when `AVISIT` is selected as visit variable.", - "Please deselect `BASE:AVISITN` as a covariate or change visit variable to `AVISITN`." - ) - ) - ) + teal::validate_has_data(adsl_filtered, min_nrow = 1) + teal::validate_has_data(anl_filtered, min_nrow = 1) validate_checks() c(list(adsl_filtered = adsl_filtered, anl_filtered = anl_filtered), encoding_inputs) }) @@ -1193,11 +1218,6 @@ srv_mmrm <- function(id, split(anl_data, anl_data[[input_visit_var]]), levels(anl_data[[input_visit_var]]) ) - - shiny::validate(shiny::need( - input$conf_level >= 0 && input$conf_level <= 1, - "Please choose a confidence level between 0 and 1" - )) }) # Connector: @@ -1379,7 +1399,7 @@ srv_mmrm <- function(id, all_q <- shiny::reactive({ if (!is.null(plot_q()) && !is.null(table_q())) { - join(plot_q(), table_q()) + teal.code::join(plot_q(), table_q()) } else if (!is.null(plot_q())) { plot_q() } else { @@ -1421,6 +1441,7 @@ srv_mmrm <- function(id, # Optimizer that was selected. output$optimizer_selected <- shiny::renderText({ # First reassign reactive sources: + shiny::req(iv_r()$is_valid()) fit_stack <- try(mmrm_fit(), silent = TRUE) result <- if (!inherits(fit_stack, "try-error")) { fit <- fit_stack[["fit"]] @@ -1430,30 +1451,31 @@ srv_mmrm <- function(id, } } currnt_state <- !state_has_changed() - what_to_return <- if (input$button_start > shiny::isolate(state$button_start)) { - state$button_start <- input$button_start - state$optimizer <- result - result - } else if (currnt_state) { - shiny::isolate(state$optimizer) - } else { - NULL - } + what_to_return <- + if (input$button_start > shiny::isolate(state$button_start)) { + state$button_start <- input$button_start + state$optimizer <- result + result + } else if (currnt_state) { + shiny::isolate(state$optimizer) + } else { + NULL + } return(what_to_return) }) teal.widgets::verbatim_popup_srv( id = "warning", - verbatim_content = reactive(teal.code::get_warnings(all_q())), + verbatim_content = shiny::reactive(teal.code::get_warnings(all_q())), title = "Warning", - disabled = reactive(disable_r_code() || is.null(teal.code::get_warnings(all_q()))) + disabled = shiny::reactive(disable_r_code() || is.null(teal.code::get_warnings(all_q()))) ) # Show R code once button is pressed. teal.widgets::verbatim_popup_srv( id = "rcode", - verbatim_content = reactive(teal.code::get_code(all_q())), + verbatim_content = shiny::reactive(teal.code::get_code(all_q())), disabled = disable_r_code, title = "R Code for the Current MMRM Analysis" ) diff --git a/R/tm_g_barchart_simple.R b/R/tm_g_barchart_simple.R index 80fdfbd1c5..3a9329b450 100644 --- a/R/tm_g_barchart_simple.R +++ b/R/tm_g_barchart_simple.R @@ -300,7 +300,7 @@ ui_g_barchart_simple <- function(id, ...) { ) ) ), - forms = tagList( + forms = shiny::tagList( teal.widgets::verbatim_popup_ui(ns("warning"), button_label = "Show Warnings"), teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code") ), @@ -325,18 +325,58 @@ srv_g_barchart_simple <- function(id, checkmate::assert_class(data, "tdata") shiny::moduleServer(id, function(input, output, session) { - anl_inputs <- teal.transform::merge_expression_module( + rule_dupl <- function(others) { + function(value) { + othervals <- lapply( + Filter(Negate(is.null), selector_list()[others]), # some selectors could be ommited in tm_g_barchart_simple + function(x) x()$select + ) + vars <- c(value, unlist(othervals)) + dups <- unique(vars[duplicated(vars)]) + if (value %in% dups) { + paste("Duplicated value:", value, collapse = ", ") + } + } + } + + selector_list <- teal.transform::data_extract_multiple_srv( + data_extract = list(x = x, fill = fill, x_facet = x_facet, y_facet = y_facet), datasets = data, - join_keys = get_join_keys(data), - data_extract = list(x = x, fill = fill, x_facet = x_facet, y_facet = y_facet) + select_validation_rule = list( + x = shinyvalidate::compose_rules( + shinyvalidate::sv_required("Please select an x-variable"), + rule_dupl(others = c("fill", "x_facet", "y_facet")) + ), + fill = shinyvalidate::compose_rules( + shinyvalidate::sv_optional(), + rule_dupl(others = c("x", "x_facet", "y_facet")) + ), + x_facet = shinyvalidate::compose_rules( + shinyvalidate::sv_optional(), + rule_dupl(others = c("fill", "x", "y_facet")) + ), + y_facet = shinyvalidate::compose_rules( + shinyvalidate::sv_optional(), + rule_dupl(others = c("fill", "x_facet", "x")) + ) + ), + dataset_validation_rule = list( + fill = NULL, + x_facet = NULL, + y_facet = NULL + ) ) - validate_checks <- reactive( - shiny::validate({ - shiny::need(anl_inputs()$columns_source$x, "Please select an x-variable") - }) - ) + iv_r <- shiny::reactive({ + iv <- shinyvalidate::InputValidator$new() + teal.transform::compose_and_enable_validators(iv, selector_list) + }) + anl_inputs <- teal.transform::merge_expression_srv( + datasets = data, + join_keys = get_join_keys(data), + selector_list = selector_list + ) anl_q <- shiny::reactive({ qenv <- teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) @@ -393,8 +433,9 @@ srv_g_barchart_simple <- function(id, }) all_q <- shiny::reactive({ - validate_checks() + teal::validate_inputs(iv_r()) groupby_vars <- as.list(r_groupby_vars()) # so $ access works below + ANL <- count_q()[["ANL"]] # nolint qenv2 <- teal.code::eval_code(count_q(), substitute( env = list(groupby_vars = paste(groupby_vars, collapse = ", ")), @@ -423,10 +464,10 @@ srv_g_barchart_simple <- function(id, plot_call <- make_barchart_simple_call( y_name = get_n_name(groupby_vars), - x_name = groupby_vars$x_name, - fill_name = groupby_vars$fill_name, - x_facet_name = groupby_vars$x_facet_name, - y_facet_name = groupby_vars$y_facet_name, + x_name = groupby_vars$x, + fill_name = groupby_vars$fill, + x_facet_name = groupby_vars$x_facet, + y_facet_name = groupby_vars$y_facet, label_bars = input$label_bars, barlayout = input$barlayout, flip_axis = input$flip_axis, @@ -446,12 +487,14 @@ srv_g_barchart_simple <- function(id, plot_r <- shiny::reactive(all_q()[["plot"]]) - output$table <- shiny::renderTable(all_q()[["counts"]]) + output$table <- shiny::renderTable({ + shiny::req(iv_r()$is_valid()) + all_q()[["counts"]] + }) - # reactive vars + # get grouping variables # NULL: not present in UI, vs character(0): no selection - - # returns named vector of non-NULL variables to group by + ## returns named vector of non-NULL variables to group by r_groupby_vars <- function() { x_name <- if (is.null(x)) NULL else as.vector(anl_inputs()$columns_source$x) fill_name <- if (is.null(fill)) NULL else as.vector(anl_inputs()$columns_source$fill) @@ -464,18 +507,10 @@ srv_g_barchart_simple <- function(id, if (identical(x_facet_name, character(0))) x_facet_name <- NULL if (identical(y_facet_name, character(0))) y_facet_name <- NULL - res <- c( + c( x_name = x_name, fill_name = fill_name, x_facet_name = x_facet_name, y_facet_name = y_facet_name ) # c() -> NULL entries are omitted - - # at least one category must be specified - shiny::validate(shiny::need( - length(res) > 0, # c() removes NULL entries - "Must specify at least one of x, fill, x_facet and y_facet." - )) - - res } # Insert the plot into a plot with settings module from teal.widgets @@ -488,14 +523,14 @@ srv_g_barchart_simple <- function(id, teal.widgets::verbatim_popup_srv( id = "warning", - verbatim_content = reactive(teal.code::get_warnings(all_q())), + verbatim_content = shiny::reactive(teal.code::get_warnings(all_q())), title = "Warning", - disabled = reactive(is.null(teal.code::get_warnings(all_q()))) + disabled = shiny::reactive(is.null(teal.code::get_warnings(all_q()))) ) teal.widgets::verbatim_popup_srv( id = "rcode", - verbatim_content = reactive(teal.code::get_code(all_q())), + verbatim_content = shiny::reactive(teal.code::get_code(all_q())), title = "Bar Chart" ) @@ -572,21 +607,13 @@ make_barchart_simple_call <- function(y_name, rotate_y_label = FALSE, expand_y_range = 0, ggplot2_args = teal.widgets::ggplot2_args()) { - # c() filters out NULL - plot_vars <- c(x_name, fill_name, x_facet_name, y_facet_name) - shiny::validate( - shiny::need( - !any(duplicated(plot_vars)), - paste("Duplicated variable(s):", paste(plot_vars[duplicated(plot_vars)], collapse = ", ")) - ) - ) checkmate::assert_string(y_name) checkmate::assert_string(x_name, null.ok = TRUE) checkmate::assert_string(fill_name, null.ok = TRUE) checkmate::assert_string(x_facet_name, null.ok = TRUE) checkmate::assert_string(y_facet_name, null.ok = TRUE) + checkmate::assert_character(c(x_name, fill_name, x_facet_name, y_facet_name)) checkmate::assert_flag(label_bars) - checkmate::assert_character(plot_vars, min.len = 1) checkmate::assert_scalar(expand_y_range) barlayout <- match.arg(barlayout) checkmate::assert_flag(flip_axis, null.ok = TRUE) diff --git a/R/tm_g_ci.R b/R/tm_g_ci.R index 72acc1dddb..4df7ba3d02 100644 --- a/R/tm_g_ci.R +++ b/R/tm_g_ci.R @@ -329,7 +329,7 @@ ui_g_ci <- function(id, ...) { # nolint ), teal.transform::data_extract_ui( id = ns("y_var"), - label = "Analyzed Value (y axis)", + label = "Analysis Value (y axis)", data_extract_spec = args$y_var ), teal.transform::data_extract_ui( @@ -352,7 +352,7 @@ ui_g_ci <- function(id, ...) { # nolint selected = args$stat ) ), - forms = tagList( + forms = shiny::tagList( teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"), teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") ), @@ -377,46 +377,56 @@ srv_g_ci <- function(id, # nolint checkmate::assert_class(data, "tdata") shiny::moduleServer(id, function(input, output, session) { - anl_inputs <- teal.transform::merge_expression_module( - datasets = data, + selector_list <- teal.transform::data_extract_multiple_srv( data_extract = list(x_var = x_var, y_var = y_var, color = color), - join_keys = get_join_keys(data) + datasets = data, + select_validation_rule = list( + x_var = shinyvalidate::sv_required("Select a treatment (x axis)"), + y_var = shinyvalidate::sv_required("Select an analysis value (y axis)") + ), + filter_validation_rule = list( + y_var = shinyvalidate::sv_required(message = "Please select the filters.") + ) + ) + + iv_r <- shiny::reactive({ + iv <- shinyvalidate::InputValidator$new() + iv$add_rule("conf_level", shinyvalidate::sv_required("Please choose a confidence level")) + iv$add_rule( + "conf_level", + shinyvalidate::sv_between(0, 1, message_fmt = "Please choose a confidence level between 0 and 1") + ) + teal.transform::compose_and_enable_validators(iv, selector_list) + }) + + anl_inputs <- teal.transform::merge_expression_srv( + datasets = data, + join_keys = get_join_keys(data), + selector_list = selector_list ) - anl_q <- reactive( + anl_q <- shiny::reactive( teal.code::eval_code( object = teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)), code = as.expression(anl_inputs()$expr) ) ) - validate_data <- shiny::reactive({ - shiny::validate( - shiny::need( - length(anl_inputs()$columns_source$x_var) > 0, - "Select a treatment (x axis)." - ) - ) - shiny::validate( - shiny::need( - length(anl_inputs()$columns_source$y_var) > 0, - "Select an analyzed value (y axis)." - ) - ) + all_q <- shiny::reactive({ + teal::validate_inputs(iv_r()) teal::validate_has_data(anl_q()[["ANL"]], min_nrow = 2) - shiny::validate(shiny::need( - input$conf_level >= 0 && input$conf_level <= 1, - "Please choose a confidence level between 0 and 1" - )) - }) - - all_q <- shiny::reactive({ - validate_data() x <- anl_inputs()$columns_source$x_var y <- anl_inputs()$columns_source$y_var color <- anl_inputs()$columns_source$color + shiny::validate( + shiny::need( + !all(is.na(anl_q()[["ANL"]][[y]])), + "No valid data. Please check the filtering option for analysis value (y axis)" + ) + ) + x_label <- column_annotation_label(data[[attr(x, "dataname")]](), x) y_label <- column_annotation_label(data[[attr(y, "dataname")]](), y) color_label <- if (length(color)) { @@ -455,14 +465,14 @@ srv_g_ci <- function(id, # nolint teal.widgets::verbatim_popup_srv( id = "warning", - verbatim_content = reactive(teal.code::get_warnings(all_q())), + verbatim_content = shiny::reactive(teal.code::get_warnings(all_q())), title = "Warning", - disabled = reactive(is.null(teal.code::get_warnings(all_q()))) + disabled = shiny::reactive(is.null(teal.code::get_warnings(all_q()))) ) teal.widgets::verbatim_popup_srv( id = "rcode", - verbatim_content = reactive(teal.code::get_code(all_q())), + verbatim_content = shiny::reactive(teal.code::get_code(all_q())), title = label ) diff --git a/R/tm_g_forest_rsp.R b/R/tm_g_forest_rsp.R index 8992707551..ba6049f58c 100644 --- a/R/tm_g_forest_rsp.R +++ b/R/tm_g_forest_rsp.R @@ -446,7 +446,7 @@ ui_g_forest_rsp <- function(id, ...) { ) ) ), - forms = tagList( + forms = shiny::tagList( teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"), teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") ), @@ -479,7 +479,7 @@ srv_g_forest_rsp <- function(id, shiny::moduleServer(id, function(input, output, session) { # Setup arm variable selection, default reference arms, and default # comparison arms for encoding panel - arm_ref_comp_observer( + iv_arm_ref <- arm_ref_comp_observer( session, input, output, @@ -489,8 +489,7 @@ srv_g_forest_rsp <- function(id, module = "tm_t_tte" ) - anl_inputs <- teal.transform::merge_expression_module( - datasets = data, + selector_list <- teal.transform::data_extract_multiple_srv( data_extract = list( arm_var = arm_var, subgroup_var = subgroup_var, @@ -498,6 +497,29 @@ srv_g_forest_rsp <- function(id, paramcd = paramcd, aval_var = aval_var ), + datasets = data, + select_validation_rule = list( + aval_var = shinyvalidate::sv_required("An analysis variable is required"), + arm_var = shinyvalidate::sv_required("A treatment variable is required") + ), + filter_validation_rule = list(paramcd = shinyvalidate::sv_required(message = "Please select Endpoint filter.")) + ) + + iv_r <- shiny::reactive({ + iv <- shinyvalidate::InputValidator$new() + iv$add_rule("conf_level", shinyvalidate::sv_required("Please choose a confidence level between 0 and 1")) + iv$add_rule( + "conf_level", + shinyvalidate::sv_between(0, 1, message_fmt = "Please choose a confidence level between {left} and {right}") + ) + iv$add_rule("responders", shinyvalidate::sv_required("`Responders` field is empty")) + iv$add_validator(iv_arm_ref) + teal.transform::compose_and_enable_validators(iv, selector_list, c("arm_var", "aval_var", "paramcd")) + }) + + anl_inputs <- teal.transform::merge_expression_srv( + datasets = data, + selector_list = selector_list, merge_function = "dplyr::inner_join", join_keys = get_join_keys(data) ) @@ -509,7 +531,7 @@ srv_g_forest_rsp <- function(id, anl_name = "ANL_ADSL" ) - anl_q <- reactive({ + anl_q <- shiny::reactive({ q <- teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) qenv <- teal.code::eval_code(q, as.expression(anl_inputs()$expr)) teal.code::eval_code(qenv, as.expression(adsl_inputs()$expr)) @@ -521,7 +543,7 @@ srv_g_forest_rsp <- function(id, input[[extract_input("paramcd", paramcd$filter[[1]]$dataname, filter = TRUE)]] ), handlerExpr = { - req(anl_q()) + shiny::req(anl_q()) anl <- anl_q()[["ANL"]] aval_var <- anl_inputs()$columns_source$aval_var paramcd_level <- unlist(anl_inputs()$filter_info$paramcd[[1]]$selected) @@ -564,7 +586,8 @@ srv_g_forest_rsp <- function(id, # Prepare the analysis environment (filter data, check data, populate envir). validate_checks <- shiny::reactive({ - req(anl_q()) + teal::validate_inputs(iv_r()) + shiny::req(anl_q()) qenv <- anl_q() adsl_filtered <- qenv[[parentname]] anl_filtered <- qenv[[dataname]] @@ -644,20 +667,6 @@ srv_g_forest_rsp <- function(id, ) } - shiny::validate(shiny::need( - input$conf_level >= 0 && input$conf_level <= 1, - "Please choose a confidence level between 0 and 1" - )) - - shiny::validate( - shiny::need(checkmate::test_string(input_aval_var), "Analysis variable should be a single column."), - shiny::need(input$responders, "`Responders` field is empty."), - shiny::need( - input[[extract_input("paramcd", paramcd$filter[[1]]$dataname, filter = TRUE)]], - "`Select Endpoint` is not selected." - ) - ) - validate_has_data(qenv[["ANL"]], min_nrow = 1) NULL }) @@ -692,7 +701,7 @@ srv_g_forest_rsp <- function(id, teal.code::eval_code(qenv, as.expression(my_calls)) }) - plot_r <- reactive(all_q()[["p"]]) + plot_r <- shiny::reactive(all_q()[["p"]]) pws <- teal.widgets::plot_with_settings_srv( id = "myplot", @@ -703,14 +712,14 @@ srv_g_forest_rsp <- function(id, teal.widgets::verbatim_popup_srv( id = "warning", - verbatim_content = reactive(teal.code::get_warnings(all_q())), + verbatim_content = shiny::reactive(teal.code::get_warnings(all_q())), title = "Warning", - disabled = reactive(is.null(teal.code::get_warnings(all_q()))) + disabled = shiny::reactive(is.null(teal.code::get_warnings(all_q()))) ) teal.widgets::verbatim_popup_srv( id = "rcode", - verbatim_content = reactive(teal.code::get_code(all_q())), + verbatim_content = shiny::reactive(teal.code::get_code(all_q())), title = label ) diff --git a/R/tm_g_forest_tte.R b/R/tm_g_forest_tte.R index 33fcbf79f7..4e7b58b81b 100644 --- a/R/tm_g_forest_tte.R +++ b/R/tm_g_forest_tte.R @@ -451,7 +451,7 @@ ui_g_forest_tte <- function(id, ...) { ) ) ), - forms = tagList( + forms = shiny::tagList( teal.widgets::verbatim_popup_ui(ns("warning"), button_label = "Show Warnings"), teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code") ), @@ -484,7 +484,7 @@ srv_g_forest_tte <- function(id, shiny::moduleServer(id, function(input, output, session) { # Setup arm variable selection, default reference arms, and default # comparison arms for encoding panel - arm_ref_comp_observer( + iv_arm_ref <- arm_ref_comp_observer( session, input, output, @@ -494,8 +494,7 @@ srv_g_forest_tte <- function(id, module = "tm_g_forest_tte" ) - anl_inputs <- teal.transform::merge_expression_module( - datasets = data, + selector_list <- teal.transform::data_extract_multiple_srv( data_extract = list( arm_var = arm_var, paramcd = paramcd, @@ -505,7 +504,30 @@ srv_g_forest_tte <- function(id, cnsr_var = cnsr_var, time_unit_var = time_unit_var ), + datasets = data, + select_validation_rule = list( + aval_var = shinyvalidate::sv_required("An analysis variable is required"), + cnsr_var = shinyvalidate::sv_required("A censor variable is required"), + arm_var = shinyvalidate::sv_required("A treatment variable is required") + ), + filter_validation_rule = list(paramcd = shinyvalidate::sv_required(message = "Please select Endpoint filter.")) + ) + + iv_r <- shiny::reactive({ + iv <- shinyvalidate::InputValidator$new() + iv$add_rule("conf_level", shinyvalidate::sv_required("Please choose a confidence level")) + iv$add_rule( + "conf_level", + shinyvalidate::sv_between(0, 1, message_fmt = "Confidence level must be between 0 and 1") + ) + iv$add_validator(iv_arm_ref) + teal.transform::compose_and_enable_validators(iv, selector_list) + }) + + anl_inputs <- teal.transform::merge_expression_srv( + datasets = data, join_keys = get_join_keys(data), + selector_list = selector_list, merge_function = "dplyr::inner_join" ) @@ -516,13 +538,14 @@ srv_g_forest_tte <- function(id, anl_name = "ANL_ADSL" ) - anl_q <- reactive({ + anl_q <- shiny::reactive({ q <- teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) qenv <- teal.code::eval_code(q, as.expression(anl_inputs()$expr)) teal.code::eval_code(qenv, as.expression(adsl_inputs()$expr)) }) validate_checks <- shiny::reactive({ + teal::validate_inputs(iv_r()) qenv <- anl_q() adsl_filtered <- qenv[[parentname]] anl_filtered <- qenv[[dataname]] @@ -574,21 +597,10 @@ srv_g_forest_tte <- function(id, do.call(what = "validate_standard_inputs", validate_args) - shiny::validate(shiny::need( - input$conf_level >= 0 && input$conf_level <= 1, - "Please choose a confidence level between 0 and 1" - )) - shiny::validate(shiny::need( length(anl[[input_paramcd]]) > 0, "Value of the endpoint variable should not be empty." )) - shiny::validate( - shiny::need(checkmate::test_string(input_aval_var), "Analysis variable should be a single column.") - ) - shiny::validate( - shiny::need(checkmate::test_string(input_cnsr_var), "Censor variable should be a single column.") - ) NULL }) @@ -636,14 +648,14 @@ srv_g_forest_tte <- function(id, teal.widgets::verbatim_popup_srv( id = "warning", - verbatim_content = reactive(teal.code::get_warnings(all_q())), + verbatim_content = shiny::reactive(teal.code::get_warnings(all_q())), title = "Warning", - disabled = reactive(is.null(teal.code::get_warnings(all_q()))) + disabled = shiny::reactive(is.null(teal.code::get_warnings(all_q()))) ) teal.widgets::verbatim_popup_srv( id = "rcode", - verbatim_content = reactive(teal.code::get_code(all_q())), + verbatim_content = shiny::reactive(teal.code::get_code(all_q())), title = "R Code for the Current Time-to-Event Forest Plot" ) diff --git a/R/tm_g_ipp.R b/R/tm_g_ipp.R index b679c43086..645470eddb 100644 --- a/R/tm_g_ipp.R +++ b/R/tm_g_ipp.R @@ -443,7 +443,7 @@ ui_g_ipp <- function(id, ...) { ) ) ), - forms = tagList( + forms = shiny::tagList( teal.widgets::verbatim_popup_ui(ns("warning"), button_label = "Show Warnings"), teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code") ), @@ -474,7 +474,7 @@ srv_g_ipp <- function(id, checkmate::assert_class(data, "tdata") shiny::moduleServer(id, function(input, output, session) { - anl_inputs <- teal.transform::merge_expression_module( + selector_list <- teal.transform::data_extract_multiple_srv( datasets = data, data_extract = list( arm_var = arm_var, @@ -485,6 +485,27 @@ srv_g_ipp <- function(id, visit_var = visit_var, base_var = base_var ), + select_validation_rule = list( + aval_var = shinyvalidate::sv_required("A Parameter values over Time must be selected"), + avalu_var = shinyvalidate::sv_required("An Analysis Variable Unit must be selected"), + visit_var = shinyvalidate::sv_required("A Timepoint Variable must be selected"), + id_var = shinyvalidate::sv_required("A Patient ID must be selected"), + base_var = shinyvalidate::sv_required("Baseline Parameter Values must be selected") + ), + filter_validation_rule = list( + paramcd = shinyvalidate::sv_required(message = "Please select Parameter filter."), + arm_var = shinyvalidate::sv_required(message = "Please select Arm filter.") + ) + ) + + iv_r <- shiny::reactive({ + iv <- shinyvalidate::InputValidator$new() + teal.transform::compose_and_enable_validators(iv, selector_list) + }) + + anl_inputs <- teal.transform::merge_expression_srv( + datasets = data, + selector_list = selector_list, merge_function = "dplyr::inner_join", join_keys = get_join_keys(data) ) @@ -496,7 +517,7 @@ srv_g_ipp <- function(id, anl_name = "ANL_ADSL" ) - anl_q <- reactive({ + anl_q <- shiny::reactive({ q <- teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) qenv <- teal.code::eval_code(q, as.expression(anl_inputs()$expr)) teal.code::eval_code(qenv, as.expression(adsl_inputs()$expr)) @@ -504,6 +525,8 @@ srv_g_ipp <- function(id, # Prepare the analysis environment (filter data, check data, populate envir). validate_checks <- shiny::reactive({ + teal::validate_inputs(iv_r()) + qenv <- anl_q() adsl_filtered <- qenv[[parentname]] anl_filtered <- qenv[[dataname]] @@ -536,15 +559,6 @@ srv_g_ipp <- function(id, ) do.call(what = "validate_standard_inputs", validate_args) - - shiny::validate( - shiny::need(checkmate::test_string(input_aval_var), "Analysis variable should be a single column.") - ) - - shiny::validate( - shiny::need(checkmate::test_string(input_visit_var), "Please select a timepoint variable.") - ) - NULL }) @@ -599,14 +613,14 @@ srv_g_ipp <- function(id, teal.widgets::verbatim_popup_srv( id = "warning", - verbatim_content = reactive(teal.code::get_warnings(all_q())), + verbatim_content = shiny::reactive(teal.code::get_warnings(all_q())), title = "Warning", - disabled = reactive(is.null(teal.code::get_warnings(all_q()))) + disabled = shiny::reactive(is.null(teal.code::get_warnings(all_q()))) ) teal.widgets::verbatim_popup_srv( id = "rcode", - verbatim_content = reactive(teal.code::get_code(all_q())), + verbatim_content = shiny::reactive(teal.code::get_code(all_q())), title = label ) diff --git a/R/tm_g_km.R b/R/tm_g_km.R index ed2acbbfcc..da0c27d06c 100644 --- a/R/tm_g_km.R +++ b/R/tm_g_km.R @@ -597,7 +597,7 @@ ui_g_km <- function(id, ...) { ) ) ), - forms = tagList( + forms = shiny::tagList( teal.widgets::verbatim_popup_ui(ns("warning"), button_label = "Show Warnings"), teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code") ), @@ -634,7 +634,7 @@ srv_g_km <- function(id, shiny::moduleServer(id, function(input, output, session) { # Setup arm variable selection, default reference arms and default # comparison arms for encoding panel - arm_ref_comp_observer( + iv_arm_ref <- arm_ref_comp_observer( session, input, output, @@ -645,8 +645,7 @@ srv_g_km <- function(id, on_off = shiny::reactive(input$compare_arms) ) - anl_inputs <- teal.transform::merge_expression_module( - datasets = data, + selector_list <- teal.transform::data_extract_multiple_srv( data_extract = list( aval_var = aval_var, cnsr_var = cnsr_var, @@ -656,11 +655,58 @@ srv_g_km <- function(id, facet_var = facet_var, time_unit_var = time_unit_var ), - merge_function = "dplyr::inner_join", - join_keys = get_join_keys(data) + datasets = data, + select_validation_rule = list( + aval_var = shinyvalidate::sv_required("An analysis variable is required"), + cnsr_var = shinyvalidate::sv_required("A censor variable is required"), + arm_var = shinyvalidate::sv_required("A treatment variable is required") + ), + filter_validation_rule = list( + paramcd = shinyvalidate::sv_required("An endpoint is required") + ) ) - anl_q <- reactive({ + iv_r <- shiny::reactive({ + iv <- shinyvalidate::InputValidator$new() + + if (isTRUE(input$compare_arms)) { + iv$add_validator(iv_arm_ref) + } + + iv$add_rule("font_size", shinyvalidate::sv_required("Plot tables font size must be greater than or equal to 5")) + iv$add_rule("font_size", shinyvalidate::sv_gte(5, "Plot tables font size must be greater than or equal to 5")) + iv$add_rule("conf_level", shinyvalidate::sv_required("Please choose a confidence level")) + iv$add_rule( + "conf_level", + shinyvalidate::sv_between( + 0, 1, + inclusive = c(FALSE, FALSE), + message_fmt = "Confidence level must be between 0 and 1" + ) + ) + iv$add_rule("xticks", shinyvalidate::sv_optional()) + iv$add_rule( + "xticks", + function(value) { + val <- as_numeric_from_comma_sep_str(value, sep = ";") + if (anyNA(val) || any(val < 0)) { + "All break intervals for x-axis must be non-negative numbers separated by semicolons" + } else if (all(val == 0)) { + "At least one break interval for x-axis must be > 0" + } + } + ) + teal.transform::compose_and_enable_validators(iv, selector_list) + }) + + anl_inputs <- teal.transform::merge_expression_srv( + datasets = data, + join_keys = get_join_keys(data), + selector_list = selector_list, + merge_function = "dplyr::inner_join" + ) + + anl_q <- shiny::reactive({ teal.code::eval_code( teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)), code = as.expression(anl_inputs()$expr) @@ -668,6 +714,8 @@ srv_g_km <- function(id, }) validate_checks <- shiny::reactive({ + teal::validate_inputs(iv_r()) + qenv <- anl_q() adsl_filtered <- qenv[[parentname]] anl_filtered <- qenv[[dataname]] @@ -680,10 +728,6 @@ srv_g_km <- function(id, input_cnsr_var <- as.vector(anl_m$columns_source$cnsr_var) input_paramcd <- unlist(paramcd$filter)["vars_selected"] input_time_unit_var <- as.vector(anl_m$columns_source$time_unit_var) - input_xticks <- gsub(";", ",", trimws(input$xticks)) %>% - strsplit(",") %>% - unlist() %>% - as.numeric() # validate inputs validate_args <- list( @@ -706,28 +750,6 @@ srv_g_km <- function(id, } do.call(what = "validate_standard_inputs", validate_args) - # validate xticks - if (length(input_xticks) == 0) { - input_xticks <- NULL - } else { - shiny::validate(shiny::need(all(!is.na(input_xticks)), "Not all values entered were numeric")) - shiny::validate(shiny::need(all(input_xticks >= 0), "All break intervals for x-axis must be non-negative")) - shiny::validate(shiny::need(any(input_xticks > 0), "At least one break interval for x-axis must be positive")) - } - - shiny::validate(shiny::need( - input$conf_level > 0 && input$conf_level < 1, - "Please choose a confidence level between 0 and 1" - )) - - shiny::validate( - shiny::need(checkmate::test_string(input_aval_var), "Analysis variable should be a single column.") - ) - shiny::validate(shiny::need(checkmate::test_string(input_cnsr_var), "Censor variable should be a single column.")) - - # validate font size - shiny::validate(shiny::need(input$font_size >= 5, "Plot tables font size must be greater than or equal to 5.")) - NULL }) @@ -740,13 +762,8 @@ srv_g_km <- function(id, anl <- qenv[["ANL"]] # nolint teal::validate_has_data(anl, 2) - input_xticks <- gsub(";", ",", trimws(input$xticks)) %>% - strsplit(",") %>% - unlist() %>% - as.numeric() - - if (length(input_xticks) == 0) { - input_xticks <- NULL + input_xticks <- if (!is.null(input$xticks)) { + as_numeric_from_comma_sep_str(input$xticks, sep = ";") } input_paramcd <- as.character(unique(anl[[as.vector(anl_m$columns_source$paramcd)]])) @@ -792,14 +809,14 @@ srv_g_km <- function(id, teal.widgets::verbatim_popup_srv( id = "warning", - verbatim_content = reactive(teal.code::get_warnings(all_q())), + verbatim_content = shiny::reactive(teal.code::get_warnings(all_q())), title = "Warning", - disabled = reactive(is.null(teal.code::get_warnings(all_q()))) + disabled = shiny::reactive(is.null(teal.code::get_warnings(all_q()))) ) teal.widgets::verbatim_popup_srv( id = "rcode", - verbatim_content = reactive(teal.code::get_code(all_q())), + verbatim_content = shiny::reactive(teal.code::get_code(all_q())), title = label ) diff --git a/R/tm_g_lineplot.R b/R/tm_g_lineplot.R index 25b9131d2f..c2c91bf2ce 100644 --- a/R/tm_g_lineplot.R +++ b/R/tm_g_lineplot.R @@ -309,7 +309,7 @@ tm_g_lineplot <- function(label, strata = cs_to_des_select(strata, dataname = parentname), param = cs_to_des_filter(param, dataname = dataname), x = cs_to_des_select(x, dataname = dataname, multiple = FALSE), - y = cs_to_des_select(y, dataname = dataname), + y = cs_to_des_select(y, dataname = dataname, multiple = FALSE), y_unit = cs_to_des_select(y_unit, dataname = dataname), paramcd = cs_to_des_select(paramcd, dataname = dataname) ) @@ -484,7 +484,7 @@ ui_g_lineplot <- function(id, ...) { ) ) ), - forms = tagList( + forms = shiny::tagList( teal.widgets::verbatim_popup_ui(ns("warning"), button_label = "Show Warnings"), teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code") ), @@ -518,14 +518,42 @@ srv_g_lineplot <- function(id, checkmate::assert_class(data, "tdata") shiny::moduleServer(id, function(input, output, session) { - anl_inputs <- teal.transform::merge_expression_module( - datasets = data, + selector_list <- teal.transform::data_extract_multiple_srv( data_extract = list(x = x, y = y, strata = strata, paramcd = paramcd, y_unit = y_unit, param = param), + datasets = data, + select_validation_rule = list( + x = shinyvalidate::sv_required("Please select a time variable"), + y = shinyvalidate::sv_required("Please select an analysis variable"), + strata = shinyvalidate::sv_required("Please select a treatment variable") + ), + filter_validation_rule = list( + param = shinyvalidate::sv_required(message = "Please select Biomarker filter.") + ) + ) + + iv_r <- shiny::reactive({ + iv <- shinyvalidate::InputValidator$new() + iv$add_rule("conf_level", shinyvalidate::sv_required("Please choose a confidence level")) + iv$add_rule( + "conf_level", + shinyvalidate::sv_between( + 0, 1, + message_fmt = "Please choose a confidence level between 0 and 1", inclusive = c(FALSE, FALSE) + ) + ) + iv$add_rule("interval", shinyvalidate::sv_required("Please select an interval for the midpoint statistic")) + iv$add_rule("whiskers", shinyvalidate::sv_required("At least one of the whiskers must be selected")) + teal.transform::compose_and_enable_validators(iv, selector_list) + }) + + anl_inputs <- teal.transform::merge_expression_srv( + datasets = data, join_keys = get_join_keys(data), + selector_list = selector_list, merge_function = "dplyr::inner_join" ) - anl_q <- reactive({ + anl_q <- shiny::reactive({ teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) %>% teal.code::eval_code(as.expression(anl_inputs()$expr)) }) @@ -533,6 +561,8 @@ srv_g_lineplot <- function(id, merged <- list(anl_input_r = anl_inputs, anl_q = anl_q) validate_checks <- shiny::reactive({ + teal::validate_inputs(iv_r()) + adsl_filtered <- merged$anl_q()[[parentname]] anl_filtered <- merged$anl_q()[[dataname]] @@ -557,22 +587,7 @@ srv_g_lineplot <- function(id, validate_args <- append(validate_args, list(min_n_levels_armvar = NULL)) } - # Validate whiskers - shiny::validate(shiny::need(length(input$whiskers) > 0, "At least one of the whiskers must be selected.")) - - # Validate interval - shiny::validate(shiny::need(length(input$interval) > 0, "Need to select an interval for the midpoint statistic.")) - do.call(what = "validate_standard_inputs", validate_args) - - shiny::validate(shiny::need( - input$conf_level > 0 && input$conf_level < 1, - "Please choose a confidence level between 0 and 1" - )) - - shiny::validate(shiny::need(checkmate::test_string(input_y), "Analysis variable should be a single column.")) - shiny::validate(shiny::need(checkmate::test_string(input_x_var), "Time variable should be a single column.")) - NULL }) @@ -619,14 +634,14 @@ srv_g_lineplot <- function(id, teal.widgets::verbatim_popup_srv( id = "warning", - verbatim_content = reactive(teal.code::get_warnings(all_q())), + verbatim_content = shiny::reactive(teal.code::get_warnings(all_q())), title = "Warning", - disabled = reactive(is.null(teal.code::get_warnings(all_q()))) + disabled = shiny::reactive(is.null(teal.code::get_warnings(all_q()))) ) teal.widgets::verbatim_popup_srv( id = "rcode", - verbatim_content = reactive(teal.code::get_code(all_q())), + verbatim_content = shiny::reactive(teal.code::get_code(all_q())), title = label ) diff --git a/R/tm_g_pp_adverse_events.R b/R/tm_g_pp_adverse_events.R index 4388fcce1d..3be70305f7 100644 --- a/R/tm_g_pp_adverse_events.R +++ b/R/tm_g_pp_adverse_events.R @@ -392,7 +392,7 @@ ui_g_adverse_events <- function(id, ...) { ) ) ), - forms = tagList( + forms = shiny::tagList( teal.widgets::verbatim_popup_ui(ns("warning"), button_label = "Show Warnings"), teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code") ), @@ -453,8 +453,7 @@ srv_g_adverse_events <- function(id, ) # Adverse events tab ---- - anl_inputs <- teal.transform::merge_expression_module( - datasets = data, + selector_list <- teal.transform::data_extract_multiple_srv( data_extract = Filter( Negate(is.null), list( @@ -467,50 +466,44 @@ srv_g_adverse_events <- function(id, decod = decod ) ), + datasets = data, + select_validation_rule = list( + aeterm = shinyvalidate::sv_required("Please select AETERM variable."), + tox_grade = shinyvalidate::sv_required("Please select AETOXGR variable."), + causality = shinyvalidate::sv_required("Please select AEREL variable."), + outcome = shinyvalidate::sv_required("Please select AEOUT variable."), + action = shinyvalidate::sv_required("Please select AEACN variable."), + time = shinyvalidate::sv_required("Please select ASTDY variable."), + decod = shinyvalidate::sv_required("Please select ANRIND variable.") + ) + ) + + iv_r <- shiny::reactive({ + iv <- shinyvalidate::InputValidator$new() + iv$add_rule("patient_id", shinyvalidate::sv_required("Please select a patient")) + teal.transform::compose_and_enable_validators(iv, selector_list) + }) + + anl_inputs <- teal.transform::merge_expression_srv( + datasets = data, + selector_list = selector_list, join_keys = get_join_keys(data) ) - anl_q <- reactive( + anl_q <- shiny::reactive( teal.code::eval_code( teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)), as.expression(anl_inputs()$expr) ) ) all_q <- shiny::reactive({ - shiny::validate(shiny::need(patient_id(), "Please select a patient.")) + teal::validate_inputs(iv_r()) anl_m <- anl_inputs() qenv <- anl_q() ANL <- qenv[["ANL"]] # nolint teal::validate_has_data(ANL[ANL[[patient_col]] == input$patient_id, ], min_nrow = 1) - shiny::validate( - shiny::need( - input[[extract_input("aeterm", dataname)]], - "Please select AETERM variable." - ), - shiny::need( - input[[extract_input("tox_grade", dataname)]], - "Please select AETOXGR variable." - ), - shiny::need( - input[[extract_input("causality", dataname)]], - "Please select AEREL variable." - ), - shiny::need( - input[[extract_input("outcome", dataname)]], - "Please select AEOUT variable." - ), - shiny::need( - input[[extract_input("action", dataname)]], - "Please select AEACN variable." - ), - shiny::need( - input[[extract_input("time", dataname)]], - "Please select ASTDY variable." - ) - ) - qenv2 <- teal.code::eval_code( qenv, substitute( @@ -543,7 +536,10 @@ srv_g_adverse_events <- function(id, options = list(pageLength = input$table_rows) ) - plot_r <- shiny::reactive(all_q()[["plot"]]) + plot_r <- shiny::reactive({ + shiny::req(iv_r()$is_valid()) + all_q()[["plot"]] + }) pws <- teal.widgets::plot_with_settings_srv( id = "chart", @@ -554,14 +550,14 @@ srv_g_adverse_events <- function(id, teal.widgets::verbatim_popup_srv( id = "warning", - verbatim_content = reactive(teal.code::get_warnings(all_q())), + verbatim_content = shiny::reactive(teal.code::get_warnings(all_q())), title = "Warning", - disabled = reactive(is.null(teal.code::get_warnings(all_q()))) + disabled = shiny::reactive(is.null(teal.code::get_warnings(all_q()))) ) teal.widgets::verbatim_popup_srv( id = "rcode", - verbatim_content = reactive(teal.code::get_code(all_q())), + verbatim_content = shiny::reactive(teal.code::get_code(all_q())), title = label ) diff --git a/R/tm_g_pp_patient_timeline.R b/R/tm_g_pp_patient_timeline.R index a9eeec5543..d1c30090b6 100644 --- a/R/tm_g_pp_patient_timeline.R +++ b/R/tm_g_pp_patient_timeline.R @@ -687,7 +687,7 @@ ui_g_patient_timeline <- function(id, ...) { ) ) ), - forms = tagList( + forms = shiny::tagList( teal.widgets::verbatim_popup_ui(ns("warning"), button_label = "Show Warnings"), teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code") ), @@ -751,25 +751,69 @@ srv_g_patient_timeline <- function(id, ignoreInit = TRUE ) + # Patient timeline tab ---- - anl_inputs <- teal.transform::merge_expression_module( - datasets = data, - join_keys = get_join_keys(data), + check_box <- shiny::reactive(input$relday_x_axis) + + check_relative <- function(main_param, return_name) { + function(value) { + if (length(selector_list()[[main_param]]()$select) > 0 && length(value) == 0) { + sprintf("Please add %s", return_name) + } + } + } + + rule_one_parameter <- function(other) { + function(value) { + if (length(value) == 0L && length(selector_list()[[other]]()$select) == 0L) { + "At least one parameter must be selected." + } + } + } + + selector_list <- teal.transform::data_extract_multiple_srv( data_extract = list( dsrelday_start = dsrelday_start, dsrelday_end = dsrelday_end, aerelday_start = aerelday_start, aerelday_end = aerelday_end, aeterm = aeterm, aetime_start = aetime_start, aetime_end = aetime_end, dstime_start = dstime_start, dstime_end = dstime_end, cmdecod = cmdecod + ), + datasets = data, + select_validation_rule = list( + # aeterm + aeterm = rule_one_parameter("cmdecod"), + aerelday_start = check_relative("aeterm", "AE start date."), + aerelday_end = check_relative("aeterm", "AE end date."), + aetime_start = check_relative("aeterm", "AE start date."), + aetime_end = check_relative("aeterm", "AE end date."), + # cmdecod + cmdecod = rule_one_parameter("aeterm"), + dsrelday_start = check_relative("cmdecod", "Medication start date."), + dsrelday_end = check_relative("cmdecod", "Medication end date."), + dstime_start = check_relative("cmdecod", "Medication start date."), + dstime_end = check_relative("cmdecod", "Medication end date.") ) ) - anl_q <- reactive({ + iv_r <- shiny::reactive({ + iv <- shinyvalidate::InputValidator$new() + iv$add_rule("patient_id", shinyvalidate::sv_required("Please select a patient")) + teal.transform::compose_and_enable_validators(iv, selector_list) + }) + + anl_inputs <- teal.transform::merge_expression_srv( + datasets = data, + join_keys = get_join_keys(data), + selector_list = selector_list + ) + + anl_q <- shiny::reactive({ teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) %>% teal.code::eval_code(as.expression(anl_inputs()$expr)) }) all_q <- shiny::reactive({ - shiny::validate(shiny::need(patient_id(), "Please select a patient.")) + teal::validate_inputs(iv_r()) aeterm <- input[[extract_input("aeterm", dataname_adae)]] aetime_start <- input[[extract_input("aetime_start", dataname_adae)]] @@ -796,11 +840,6 @@ srv_g_patient_timeline <- function(id, (sum(stats::complete.cases(p_time_data_pat[, c(aetime_start, aetime_end)])) > 0 || sum(stats::complete.cases(p_time_data_pat[, c(dstime_start, dstime_end)])) > 0), "Selected patient is not in dataset (either due to filtering or missing values). Consider relaxing filters." - ), - shiny::need( - input$relday_x_axis || (isFALSE(ae_chart_vars_null) || isFALSE(ds_chart_vars_null)), - "The sections of the plot (Adverse Events and Medication) do not have enough input variables. - Please select the appropriate input variables." ) ) @@ -836,11 +875,6 @@ srv_g_patient_timeline <- function(id, (sum(stats::complete.cases(p_time_data_pat[, c(aerelday_start_name, aerelday_end_name)])) > 0 || sum(stats::complete.cases(p_time_data_pat[, c(dsrelday_start_name, dsrelday_end_name)])) > 0), "Selected patient is not in dataset (either due to filtering or missing values). Consider relaxing filters." - ), - shiny::need( - !input$relday_x_axis || (isFALSE(aerel_chart_vars_null) || isFALSE(dsrel_chart_vars_null)), - "The sections of the plot (Adverse Events and Medication) do not have enough input variables. - Please select the appropriate input variables." ) ) @@ -887,14 +921,14 @@ srv_g_patient_timeline <- function(id, teal.widgets::verbatim_popup_srv( id = "warning", - verbatim_content = reactive(teal.code::get_warnings(all_q())), + verbatim_content = shiny::reactive(teal.code::get_warnings(all_q())), title = "Warning", - disabled = reactive(is.null(teal.code::get_warnings(all_q()))) + disabled = shiny::reactive(is.null(teal.code::get_warnings(all_q()))) ) teal.widgets::verbatim_popup_srv( id = "rcode", - verbatim_content = reactive(teal.code::get_code(all_q())), + verbatim_content = shiny::reactive(teal.code::get_code(all_q())), title = label ) diff --git a/R/tm_g_pp_therapy.R b/R/tm_g_pp_therapy.R index 1a8ee378bb..81acc30b69 100644 --- a/R/tm_g_pp_therapy.R +++ b/R/tm_g_pp_therapy.R @@ -539,7 +539,7 @@ ui_g_therapy <- function(id, ...) { ) ) ), - forms = tagList( + forms = shiny::tagList( teal.widgets::verbatim_popup_ui(ns("warning"), button_label = "Show Warnings"), teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code") ), @@ -601,18 +601,41 @@ srv_g_therapy <- function(id, ) # Therapy tab ---- - anl_inputs <- teal.transform::merge_expression_module( - datasets = data, - join_keys = get_join_keys(data), + selector_list <- teal.transform::data_extract_multiple_srv( data_extract = list( atirel = atirel, cmdecod = cmdecod, cmindc = cmindc, cmdose = cmdose, cmtrt = cmtrt, cmdosu = cmdosu, cmroute = cmroute, cmdosfrq = cmdosfrq, cmstdy = cmstdy, cmendy = cmendy ), + datasets = data, + select_validation_rule = list( + atirel = shinyvalidate::sv_required("Please select ATIREL variable."), + cmdecod = shinyvalidate::sv_required("Please select medication decoding variable."), + cmindc = shinyvalidate::sv_required("Please select CMINDC variable."), + cmdose = shinyvalidate::sv_required("Please select CMDOSE variable."), + cmtrt = shinyvalidate::sv_required("Please select CMTRT variable."), + cmdosu = shinyvalidate::sv_required("Please select CMDOSU variable."), + cmroute = shinyvalidate::sv_required("Please select CMROUTE variable."), + cmdosfrq = shinyvalidate::sv_required("Please select CMDOSFRQ variable."), + cmstdy = shinyvalidate::sv_required("Please select CMSTDY variable."), + cmendy = shinyvalidate::sv_required("Please select CMENDY variable.") + ) + ) + + iv_r <- shiny::reactive({ + iv <- shinyvalidate::InputValidator$new() + iv$add_rule("patient_id", shinyvalidate::sv_required("Please select a patient.")) + teal.transform::compose_and_enable_validators(iv, selector_list) + }) + + anl_inputs <- teal.transform::merge_expression_srv( + datasets = data, + join_keys = get_join_keys(data), + selector_list = selector_list, merge_function = "dplyr::left_join" ) - anl_q <- reactive({ + anl_q <- shiny::reactive({ teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) %>% teal.code::eval_code(as.expression(anl_inputs()$expr)) }) @@ -620,50 +643,11 @@ srv_g_therapy <- function(id, merged <- list(anl_input_r = anl_inputs, anl_q = anl_q) all_q <- shiny::reactive({ - shiny::validate(shiny::need(patient_id(), "Please select a patient.")) teal::validate_has_data(merged$anl_q()[["ANL"]], 1) + teal::validate_inputs(iv_r()) + shiny::validate( - shiny::need( - input[[extract_input("atirel", dataname)]], - "Please select ATIREL variable." - ), - shiny::need( - input[[extract_input("cmdecod", dataname)]], - "Please select Medication decoding variable." - ), - shiny::need( - input[[extract_input("cmindc", dataname)]], - "Please select CMINDC variable." - ), - shiny::need( - input[[extract_input("cmdose", dataname)]], - "Please select CMDOSE variable." - ), - shiny::need( - input[[extract_input("cmtrt", dataname)]], - "Please select CMTRT variable." - ), - shiny::need( - input[[extract_input("cmdosu", dataname)]], - "Please select CMDOSU variable." - ), - shiny::need( - input[[extract_input("cmroute", dataname)]], - "Please select CMROUTE variable." - ), - shiny::need( - input[[extract_input("cmdosfrq", dataname)]], - "Please select CMDOSFRQ variable." - ), - shiny::need( - input[[extract_input("cmstdy", dataname)]], - "Please select CMSTDY variable." - ), - shiny::need( - input[[extract_input("cmendy", dataname)]], - "Please select CMENDY variable." - ), shiny::need( nrow(merged$anl_q()[["ANL"]][input$patient_id == merged$anl_q()[["ANL"]][, patient_col], ]) > 0, "Selected patient is not in dataset (either due to filtering or missing values). Consider relaxing filters." @@ -708,7 +692,10 @@ srv_g_therapy <- function(id, options = list(pageLength = input$therapy_table_rows) ) - plot_r <- shiny::reactive(all_q()[["therapy_plot"]]) + plot_r <- shiny::reactive({ + shiny::req(iv_r()$is_valid()) + all_q()[["therapy_plot"]] + }) pws <- teal.widgets::plot_with_settings_srv( id = "therapy_plot", @@ -719,14 +706,14 @@ srv_g_therapy <- function(id, teal.widgets::verbatim_popup_srv( id = "warning", - verbatim_content = reactive(teal.code::get_warnings(all_q())), + verbatim_content = shiny::reactive(teal.code::get_warnings(all_q())), title = "Warning", - disabled = reactive(is.null(teal.code::get_warnings(all_q()))) + disabled = shiny::reactive(is.null(teal.code::get_warnings(all_q()))) ) teal.widgets::verbatim_popup_srv( id = "rcode", - verbatim_content = reactive(teal.code::get_code(all_q())), + verbatim_content = shiny::reactive(teal.code::get_code(all_q())), title = label ) diff --git a/R/tm_g_pp_vitals.R b/R/tm_g_pp_vitals.R index 17091f76ff..c03dcc5398 100644 --- a/R/tm_g_pp_vitals.R +++ b/R/tm_g_pp_vitals.R @@ -259,6 +259,9 @@ tm_g_pp_vitals <- function(label, checkmate::assert_class(pre_output, classes = "shiny.tag", null.ok = TRUE) checkmate::assert_class(post_output, classes = "shiny.tag", null.ok = TRUE) checkmate::assert_class(ggplot2_args, "ggplot2_args") + checkmate::assert_multi_class(paramcd, c("choices_selected", "data_extract_spec"), null.ok = TRUE) + checkmate::assert_multi_class(aval, c("choices_selected", "data_extract_spec"), null.ok = TRUE) + checkmate::assert_multi_class(xaxis, c("choices_selected", "data_extract_spec"), null.ok = TRUE) args <- as.list(environment()) data_extract_list <- list( @@ -339,7 +342,7 @@ ui_g_vitals <- function(id, ...) { ) ) ), - forms = tagList( + forms = shiny::tagList( teal.widgets::verbatim_popup_ui(ns("warning"), button_label = "Show Warnings"), teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code") ), @@ -396,14 +399,42 @@ srv_g_vitals <- function(id, ) # Vitals tab ---- - anl_inputs <- teal.transform::merge_expression_module( + + selector_list <- teal.transform::data_extract_multiple_srv( + data_extract = list(paramcd = paramcd, xaxis = xaxis, aval = aval), + datasets = data, + select_validation_rule = list( + paramcd = shinyvalidate::sv_required( + "Please select PARAMCD variable." + ), + xaxis = shinyvalidate::sv_required( + "Please select Vitals x-axis variable." + ), + aval = shinyvalidate::sv_required( + "Please select AVAL variable." + ) + ) + ) + + iv_r <- shiny::reactive({ + iv <- shinyvalidate::InputValidator$new() + iv$add_rule("patient_id", shinyvalidate::sv_required( + "Please select a patient." + )) + iv$add_rule("paramcd_levels_vals", shinyvalidate::sv_required( + "Please select PARAMCD variable levels." + )) + teal.transform::compose_and_enable_validators(iv, selector_list) + }) + + anl_inputs <- teal.transform::merge_expression_srv( datasets = data, join_keys = get_join_keys(data), - data_extract = list(paramcd = paramcd, xaxis = xaxis, aval = aval), + selector_list = selector_list, merge_function = "dplyr::left_join" ) - anl_q <- reactive({ + anl_q <- shiny::reactive({ teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) %>% teal.code::eval_code(as.expression(anl_inputs()$expr)) }) @@ -441,26 +472,11 @@ srv_g_vitals <- function(id, }) all_q <- shiny::reactive({ - shiny::validate(shiny::need(patient_id(), "Please select a patient.")) teal::validate_has_data(merged$anl_q()[["ANL"]], 1) + teal::validate_inputs(iv_r()) + shiny::validate( - shiny::need( - input[[extract_input("paramcd", dataname)]], - "Please select PARAMCD variable." - ), - shiny::need( - input[["paramcd_levels_vals"]], - "Please select PARAMCD variable levels." - ), - shiny::need( - input[[extract_input("xaxis", dataname)]], - "Please select Vitals x-axis variable." - ), - shiny::need( - input[[extract_input("aval", dataname)]], - "Please select AVAL variable." - ), shiny::need( nrow(merged$anl_q()[["ANL"]][input$patient_id == merged$anl_q()[["ANL"]][, patient_col], ]) > 0, "Selected patient is not in dataset (either due to filtering or missing values). Consider relaxing filters." @@ -503,14 +519,14 @@ srv_g_vitals <- function(id, teal.widgets::verbatim_popup_srv( id = "warning", - verbatim_content = reactive(teal.code::get_warnings(all_q())), + verbatim_content = shiny::reactive(teal.code::get_warnings(all_q())), title = "Warning", - disabled = reactive(is.null(teal.code::get_warnings(all_q()))) + disabled = shiny::reactive(is.null(teal.code::get_warnings(all_q()))) ) teal.widgets::verbatim_popup_srv( id = "rcode", - verbatim_content = reactive(teal.code::get_code(all_q())), + verbatim_content = shiny::reactive(teal.code::get_code(all_q())), title = label ) diff --git a/R/tm_t_abnormality.R b/R/tm_t_abnormality.R index f5425adc25..103954ad02 100644 --- a/R/tm_t_abnormality.R +++ b/R/tm_t_abnormality.R @@ -466,7 +466,7 @@ ui_t_abnormality <- function(id, ...) { ) ) ), - forms = tagList( + forms = shiny::tagList( teal.widgets::verbatim_popup_ui(ns("warning"), button_label = "Show Warnings"), teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code") ), @@ -499,8 +499,7 @@ srv_t_abnormality <- function(id, checkmate::assert_class(data, "tdata") shiny::moduleServer(id, function(input, output, session) { - anl_inputs <- teal.transform::merge_expression_module( - datasets = data, + selector_list <- teal.transform::data_extract_multiple_srv( data_extract = list( arm_var = arm_var, id_var = id_var, @@ -509,7 +508,41 @@ srv_t_abnormality <- function(id, baseline_var = baseline_var, treatment_flag_var = treatment_flag_var ), + datasets = data, + select_validation_rule = list( + arm_var = shinyvalidate::sv_required( + "Please select a treatment variable." + ), + by_vars = shinyvalidate::sv_required( + "Please select a Row By Variable." + ), + id_var = shinyvalidate::sv_required( + "Please select a subject identifier." + ), + grade = shinyvalidate::sv_required( + "Please select a grade variable." + ), + baseline_var = shinyvalidate::sv_required( + "Please select a baseline grade variable." + ), + treatment_flag_var = shinyvalidate::sv_required( + "Please select indicator value for on treatment records." + ) + ) + ) + + iv_r <- shiny::reactive({ + iv <- shinyvalidate::InputValidator$new() + iv$add_rule("treatment_flag", shinyvalidate::sv_required( + "Please select indicator value for on treatment records." + )) + teal.transform::compose_and_enable_validators(iv, selector_list) + }) + + anl_inputs <- teal.transform::merge_expression_srv( + datasets = data, join_keys = get_join_keys(data), + selector_list = selector_list, merge_function = "dplyr::inner_join" ) @@ -520,7 +553,7 @@ srv_t_abnormality <- function(id, anl_name = "ANL_ADSL" ) - anl_q <- reactive({ + anl_q <- shiny::reactive({ teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) %>% teal.code::eval_code(as.expression(anl_inputs()$expr)) %>% teal.code::eval_code(as.expression(adsl_inputs()$expr)) @@ -536,6 +569,8 @@ srv_t_abnormality <- function(id, adsl_filtered <- merged$anl_q()[[parentname]] anl_filtered <- merged$anl_q()[[dataname]] + teal::validate_inputs(iv_r()) + input_arm_var <- names(merged$anl_input_r()$columns_source$arm_var) input_id_var <- names(merged$anl_input_r()$columns_source$id_var) input_by_vars <- names(merged$anl_input_r()$columns_source$by_vars) @@ -543,15 +578,6 @@ srv_t_abnormality <- function(id, input_baseline_var <- names(merged$anl_input_r()$columns_source$baseline_var) input_treatment_flag_var <- names(merged$anl_input_r()$columns_source$treatment_flag_var) - shiny::validate( - shiny::need(input_arm_var, "Please select a treatment variable."), - shiny::need(input_grade, "Please select a grade variable."), - shiny::need(input_by_vars, "Please select a Row By Variable."), - shiny::need(input_id_var, "Please select a subject identifier."), - shiny::need(input_baseline_var, "Please select a baseline grade variable."), - shiny::need(input_treatment_flag_var, "Please select an on treatment flag variable."), - shiny::need(input$treatment_flag, "Please select indicator value for on treatment records.") - ) # validate inputs validate_standard_inputs( adsl = adsl_filtered, @@ -608,15 +634,15 @@ srv_t_abnormality <- function(id, teal.widgets::verbatim_popup_srv( id = "warning", - verbatim_content = reactive(teal.code::get_warnings(all_q())), + verbatim_content = shiny::reactive(teal.code::get_warnings(all_q())), title = "Warning", - disabled = reactive(is.null(teal.code::get_warnings(all_q()))) + disabled = shiny::reactive(is.null(teal.code::get_warnings(all_q()))) ) # Render R code. teal.widgets::verbatim_popup_srv( id = "rcode", - verbatim_content = reactive(teal.code::get_code(all_q())), + verbatim_content = shiny::reactive(teal.code::get_code(all_q())), title = label ) diff --git a/R/tm_t_abnormality_by_worst_grade.R b/R/tm_t_abnormality_by_worst_grade.R index cc05e70322..7bedfb5426 100644 --- a/R/tm_t_abnormality_by_worst_grade.R +++ b/R/tm_t_abnormality_by_worst_grade.R @@ -226,7 +226,6 @@ template_abnormality_by_worst_grade <- function(parentname, # nolint #' @export #' #' @examples -#' #' library(scda) #' library(dplyr) #' @@ -323,8 +322,8 @@ tm_t_abnormality_by_worst_grade <- function(label, # nolint checkmate::assert_string(label) checkmate::assert_string(dataname) checkmate::assert_string(parentname) - checkmate::assert_class(id_var, "choices_selected") checkmate::assert_class(arm_var, "choices_selected") + checkmate::assert_class(id_var, "choices_selected") checkmate::assert_class(paramcd, "choices_selected") checkmate::assert_class(atoxgr_var, "choices_selected") checkmate::assert_class(worst_high_flag_var, "choices_selected") @@ -388,8 +387,13 @@ ui_t_abnormality_by_worst_grade <- function(id, ...) { # nolint shiny::tags$label("Encodings", class = "text-primary"), teal.transform::datanames_input( a[c( - "arm_var", "id_var", "paramcd", - "atoxgr_var", "worst_high_flag_var", "worst_low_flag_var", "worst_flag_indicator" + "arm_var", + "id_var", + "paramcd", + "atoxgr_var", + "worst_high_flag_var", + "worst_low_flag_var", + "worst_flag_indicator" )] ), teal.transform::data_extract_ui( @@ -448,7 +452,7 @@ ui_t_abnormality_by_worst_grade <- function(id, ...) { # nolint ) ) ), - forms = tagList( + forms = shiny::tagList( teal.widgets::verbatim_popup_ui(ns("warning"), button_label = "Show Warnings"), teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code") ), @@ -479,14 +483,38 @@ srv_t_abnormality_by_worst_grade <- function(id, # nolint checkmate::assert_class(data, "tdata") shiny::moduleServer(id, function(input, output, session) { - anl_inputs <- teal.transform::merge_expression_module( - datasets = data, - join_keys = get_join_keys(data), + selector_list <- teal.transform::data_extract_multiple_srv( data_extract = list( - arm_var = arm_var, id_var = id_var, paramcd = paramcd, - atoxgr_var = atoxgr_var, worst_high_flag_var = worst_high_flag_var, + arm_var = arm_var, + id_var = id_var, + paramcd = paramcd, + atoxgr_var = atoxgr_var, + worst_high_flag_var = worst_high_flag_var, worst_low_flag_var = worst_low_flag_var ), + datasets = data, + select_validation_rule = list( + arm_var = shinyvalidate::sv_required("Please select a treatment variable."), + id_var = shinyvalidate::sv_required("Please select a Subject Identifier."), + atoxgr_var = shinyvalidate::sv_required("Please select Analysis Toxicity Grade variable."), + worst_low_flag_var = shinyvalidate::sv_required("Please select the Worst Low Grade flag variable."), + worst_high_flag_var = shinyvalidate::sv_required("Please select the Worst High Grade flag variable."), + worst_flag_indicator = shinyvalidate::sv_required("Please select the value indicating worst grade.") + ), + filter_validation_rule = list( + paramcd = shinyvalidate::sv_required("Please select at least one Laboratory parameter.") + ) + ) + + iv_r <- shiny::reactive({ + iv <- shinyvalidate::InputValidator$new() + teal.transform::compose_and_enable_validators(iv, selector_list) + }) + + anl_inputs <- teal.transform::merge_expression_srv( + selector_list = selector_list, + datasets = data, + join_keys = get_join_keys(data), merge_function = "dplyr::inner_join" ) @@ -497,7 +525,7 @@ srv_t_abnormality_by_worst_grade <- function(id, # nolint anl_name = "ANL_ADSL" ) - anl_q <- reactive({ + anl_q <- shiny::reactive({ teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) %>% teal.code::eval_code(as.expression(anl_inputs()$expr)) %>% teal.code::eval_code(as.expression(adsl_inputs()$expr)) @@ -515,27 +543,15 @@ srv_t_abnormality_by_worst_grade <- function(id, # nolint anl <- merged$anl_q()[["ANL"]] input_arm_var <- names(merged$anl_input_r()$columns_source$arm_var) - input_id_var <- names(merged$anl_input_r()$columns_source$id_var) input_paramcd_var <- names(merged$anl_input_r()$columns_source$paramcd) input_atoxgr <- names(merged$anl_input_r()$columns_source$atoxgr_var) input_worst_high_flag_var <- names(merged$anl_input_r()$columns_source$worst_high_flag_var) input_worst_low_flag_var <- names(merged$anl_input_r()$columns_source$worst_low_flag_var) - shiny::validate( - shiny::need(input_arm_var, "Please select a treatment variable."), - shiny::need(input_worst_high_flag_var, "Please select the Worst High Grade flag variable."), - shiny::need(input_worst_low_flag_var, "Please select the Worst Low Grade flag variable."), - shiny::need(input_atoxgr, "Please select Analysis Toxicity Grade variable."), - shiny::need(input_id_var, "Please select a Subject Identifier."), - shiny::need(input$worst_flag_indicator, "Please select the value indicating worst grade."), - ) + teal::validate_inputs(iv_r()) if (length(input_paramcd_var) > 0) { shiny::validate( - shiny::need( - length(merged$anl_q()[["ANL"]][[input_paramcd_var]]) > 0, - "Please select at least one Laboratory parameter." - ), shiny::need( is.factor(merged$anl_q()[["ANL"]][[input_paramcd_var]]), "Parameter variable should be a factor." @@ -549,13 +565,19 @@ srv_t_abnormality_by_worst_grade <- function(id, # nolint all(as.character(unique(merged$anl_q()[["ANL"]][[input_atoxgr]])) %in% as.character(c(-4:4))), "All grade values should be within -4:4 range." ), - shiny::need(is.factor(merged$anl_q()[["ANL"]][[input_atoxgr]]), "Grade variable should be a factor.") + shiny::need( + is.factor(merged$anl_q()[["ANL"]][[input_atoxgr]]), + "Grade variable should be a factor." + ) ) } if (length(input_atoxgr) > 0) { shiny::validate( - shiny::need(is.factor(merged$anl_q()[["ANL"]][[input_atoxgr]]), "Treatment variable should be a factor."), + shiny::need( + is.factor(merged$anl_q()[["ANL"]][[input_atoxgr]]), + "Treatment variable should be a factor." + ), ) } @@ -604,15 +626,15 @@ srv_t_abnormality_by_worst_grade <- function(id, # nolint teal.widgets::verbatim_popup_srv( id = "warning", - verbatim_content = reactive(teal.code::get_warnings(all_q())), + verbatim_content = shiny::reactive(teal.code::get_warnings(all_q())), title = "Warning", - disabled = reactive(is.null(teal.code::get_warnings(all_q()))) + disabled = shiny::reactive(is.null(teal.code::get_warnings(all_q()))) ) # Render R code. teal.widgets::verbatim_popup_srv( id = "rcode", - verbatim_content = reactive(teal.code::get_code(all_q())), + verbatim_content = shiny::reactive(teal.code::get_code(all_q())), title = label ) diff --git a/R/tm_t_ancova.R b/R/tm_t_ancova.R index d6887a68a5..07778b0392 100644 --- a/R/tm_t_ancova.R +++ b/R/tm_t_ancova.R @@ -525,7 +525,7 @@ tm_t_ancova <- function(label, args <- c(as.list(environment())) if (is.null(interact_var)) { - interact_var <- choices_selected( + interact_var <- teal.transform::choices_selected( choices = cov_var$choices, selected = NULL ) @@ -604,11 +604,11 @@ ui_ancova <- function(id, ...) { shiny::uiOutput( ns("arms_buckets"), title = paste( - "Multiple reference groups are automatically combined into a single group when more than one", - "value is selected." + "Multiple reference groups are automatically combined into a single group", + "when more than one value is selected." ) ), - shiny::helpText("Multiple reference groups are automatically combined into a single group."), + shiny::uiOutput(ns("helptext_ui")), shiny::checkboxInput( ns("combine_comp_arms"), "Combine all comparison groups?", @@ -656,7 +656,7 @@ ui_ancova <- function(id, ...) { ) ) ), - forms = tagList( + forms = shiny::tagList( teal.widgets::verbatim_popup_ui(ns("warning"), button_label = "Show Warnings"), teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code") ), @@ -689,7 +689,7 @@ srv_ancova <- function(id, shiny::moduleServer(id, function(input, output, session) { # Setup arm variable selection, default reference arms, and default # comparison arms for encoding panel. - arm_ref_comp_observer( + iv_arco <- arm_ref_comp_observer( session, input, output, @@ -699,8 +699,7 @@ srv_ancova <- function(id, module = "tm_ancova" ) - anl_inputs <- teal.transform::merge_expression_module( - datasets = data, + selector_list <- teal.transform::data_extract_multiple_srv( data_extract = list( arm_var = arm_var, aval_var = aval_var, @@ -709,8 +708,35 @@ srv_ancova <- function(id, paramcd = paramcd, interact_var = interact_var ), - merge_function = "dplyr::inner_join", - join_keys = get_join_keys(data) + datasets = data, + select_validation_rule = list( + arm_var = shinyvalidate::sv_required("Arm variable cannot be empty."), + aval_var = shinyvalidate::sv_required("Analysis variable cannot be empty."), + cov_var = shinyvalidate::sv_optional(), + interact_var = shinyvalidate::sv_optional() + ), + filter_validation_rule = list( + avisit = shinyvalidate::sv_required("`Analysis Visit` field cannot be empty."), + paramcd = shinyvalidate::sv_required("`Select Endpoint` is not selected.") + ) + ) + + iv_r <- shiny::reactive({ + iv <- shinyvalidate::InputValidator$new() + iv$add_rule("conf_level", shinyvalidate::sv_required("Please choose a confidence level.")) + iv$add_rule("conf_level", shinyvalidate::sv_between( + 0, 1, + message_fmt = "Confdence level must be between {left} and {right}." + )) + iv$add_validator(iv_arco) + teal.transform::compose_and_enable_validators(iv, selector_list) + }) + + anl_inputs <- teal.transform::merge_expression_srv( + selector_list = selector_list, + datasets = data, + join_keys = get_join_keys(data), + merge_function = "dplyr::inner_join" ) adsl_inputs <- teal.transform::merge_expression_module( @@ -720,7 +746,7 @@ srv_ancova <- function(id, join_keys = get_join_keys(data) ) - anl_q <- reactive({ + anl_q <- shiny::reactive({ teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) %>% teal.code::eval_code(as.expression(anl_inputs()$expr)) %>% teal.code::eval_code(as.expression(adsl_inputs()$expr)) @@ -732,6 +758,12 @@ srv_ancova <- function(id, anl_q = anl_q ) + output$helptext_ui <- shiny::renderUI({ + if (length(selector_list()$arm_var()$select) != 0) { + shiny::helpText("Multiple reference groups are automatically combined into a single group.") + } + }) + # Event handler: # Update interact_y choices to all levels of selected interact_var shiny::observeEvent( @@ -768,6 +800,8 @@ srv_ancova <- function(id, adsl_filtered <- merged$anl_q()[[parentname]] anl_filtered <- merged$anl_q()[[dataname]] + teal::validate_inputs(iv_r()) + input_arm_var <- as.vector(merged$anl_input_r()$columns_source$arm_var) input_aval_var <- as.vector(merged$anl_input_r()$columns_source$aval_var) input_cov_var <- as.vector(merged$anl_input_r()$columns_source$cov_var) @@ -793,11 +827,7 @@ srv_ancova <- function(id, # Other validations. shiny::validate(shiny::need( - length(input_aval_var) > 0, - "Analysis variable cannot be empty." - )) - shiny::validate(shiny::need( - length(input_arm_var) > 0 && length(unique(adsl_filtered[[input_arm_var]])) > 1, + length(unique(adsl_filtered[[input_arm_var]])) > 1, "ANCOVA table needs at least 2 arm groups to make comparisons." )) # check that there is at least one record with no missing data @@ -813,20 +843,6 @@ srv_ancova <- function(id, !any(all_NA_dataset$all_NA), "ANCOVA table cannot be calculated as all values are missing for one visit for (at least) one arm." )) - shiny::validate(shiny::need( - input$conf_level >= 0 && input$conf_level <= 1, - "Please choose a confidence level between 0 and 1" - )) - - shiny::validate(shiny::need( - input[[extract_input("avisit", avisit$filter[[1]]$dataname, filter = TRUE)]], - "`Analysis Visit` field cannot be empty" - )) - - shiny::validate(shiny::need( - input[[extract_input("paramcd", paramcd$filter[[1]]$dataname, filter = TRUE)]], - "`Select Endpoint` is not selected." - )) if (input$include_interact) { if (!is.null(input_interact_var) && length(input_interact_var) > 0) { @@ -924,15 +940,15 @@ srv_ancova <- function(id, teal.widgets::verbatim_popup_srv( id = "warning", - verbatim_content = reactive(teal.code::get_warnings(table_q())), + verbatim_content = shiny::reactive(teal.code::get_warnings(table_q())), title = "Warning", - disabled = reactive(is.null(teal.code::get_warnings(table_q()))) + disabled = shiny::reactive(is.null(teal.code::get_warnings(table_q()))) ) # Render R code. teal.widgets::verbatim_popup_srv( id = "rcode", - verbatim_content = reactive(teal.code::get_code(table_q())), + verbatim_content = shiny::reactive(teal.code::get_code(table_q())), title = label ) diff --git a/R/tm_t_binary_outcome.R b/R/tm_t_binary_outcome.R index a766f25a6f..2961096b09 100644 --- a/R/tm_t_binary_outcome.R +++ b/R/tm_t_binary_outcome.R @@ -710,7 +710,7 @@ ui_t_binary_outcome <- function(id, ...) { is_single_dataset = is_single_dataset_value ) ), - forms = tagList( + forms = shiny::tagList( teal.widgets::verbatim_popup_ui(ns("warning"), button_label = "Show Warnings"), teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code") ), @@ -743,20 +743,46 @@ srv_t_binary_outcome <- function(id, shiny::moduleServer(id, function(input, output, session) { # Setup arm variable selection, default reference arms, and default # comparison arms for encoding panel - arm_ref_comp_observer( + iv_arm_ref <- arm_ref_comp_observer( session, input, output, id_arm_var = extract_input("arm_var", parentname), data = data[[parentname]], arm_ref_comp = arm_ref_comp, - module = "tm_t_tte", + module = "tm_t_binary_outcome", on_off = shiny::reactive(input$compare_arms) ) - anl_inputs <- teal.transform::merge_expression_module( - datasets = data, + selector_list <- teal.transform::data_extract_multiple_srv( data_extract = list(arm_var = arm_var, paramcd = paramcd, strata_var = strata_var, aval_var = aval_var), + datasets = data, + select_validation_rule = list( + aval_var = shinyvalidate::sv_required("An analysis variable is required"), + arm_var = shinyvalidate::sv_required("A treatment variable is required") + ), + filter_validation_rule = list(paramcd = shinyvalidate::sv_required(message = "Please select a filter.")) + ) + + iv_r <- shiny::reactive({ + iv <- shinyvalidate::InputValidator$new() + + if (isTRUE(input$compare_arms)) { + iv$add_validator(iv_arm_ref) + } + + iv$add_rule("responders", shinyvalidate::sv_required("`Responders` field is empty")) + iv$add_rule("conf_level", shinyvalidate::sv_required("Please choose a confidence level between 0 and 1")) + iv$add_rule( + "conf_level", + shinyvalidate::sv_between(0, 1, message_fmt = "Please choose a confidence level between {left} and {right}") + ) + teal.transform::compose_and_enable_validators(iv, selector_list, c("arm_var", "aval_var", "paramcd")) + }) + + anl_inputs <- teal.transform::merge_expression_srv( + datasets = data, + selector_list = selector_list, merge_function = "dplyr::inner_join", join_keys = get_join_keys(data) ) @@ -768,7 +794,7 @@ srv_t_binary_outcome <- function(id, anl_name = "ANL_ADSL" ) - anl_q <- reactive({ + anl_q <- shiny::reactive({ q <- teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) qenv <- teal.code::eval_code(q, as.expression(anl_inputs()$expr)) teal.code::eval_code(qenv, as.expression(adsl_inputs()$expr)) @@ -815,6 +841,7 @@ srv_t_binary_outcome <- function(id, ) validate_check <- shiny::reactive({ + teal::validate_inputs(iv_r()) adsl_filtered <- anl_q()[[parentname]] anl_filtered <- anl_q()[[dataname]] anl <- anl_q()[["ANL"]] @@ -883,11 +910,6 @@ srv_t_binary_outcome <- function(id, } ) - shiny::validate( - shiny::need(checkmate::test_string(input_aval_var), "Analysis variable should be a single column."), - shiny::need(input$responders, "`Responders` field is empty") - ) - if (is.list(default_responses)) { shiny::validate( shiny::need( @@ -900,11 +922,6 @@ srv_t_binary_outcome <- function(id, ) } - shiny::validate(shiny::need( - input$conf_level >= 0 && input$conf_level <= 1, - "Please choose a confidence level between 0 and 1" - )) - NULL }) @@ -975,15 +992,15 @@ srv_t_binary_outcome <- function(id, teal.widgets::verbatim_popup_srv( id = "warning", - verbatim_content = reactive(teal.code::get_warnings(table_q())), + verbatim_content = shiny::reactive(teal.code::get_warnings(table_q())), title = "Warning", - disabled = reactive(is.null(teal.code::get_warnings(table_q()))) + disabled = shiny::reactive(is.null(teal.code::get_warnings(table_q()))) ) # Render R code. teal.widgets::verbatim_popup_srv( id = "rcode", - verbatim_content = reactive({ + verbatim_content = shiny::reactive({ teal.code::get_code(table_q()) }), title = label diff --git a/R/tm_t_coxreg.R b/R/tm_t_coxreg.R index a99917a486..4c5c6bc8db 100644 --- a/R/tm_t_coxreg.R +++ b/R/tm_t_coxreg.R @@ -725,7 +725,7 @@ ui_t_coxreg <- function(id, ...) { ) ) ), - forms = tagList( + forms = shiny::tagList( teal.widgets::verbatim_popup_ui(ns("warning"), button_label = "Show Warnings"), teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code") ), @@ -756,7 +756,7 @@ srv_t_coxreg <- function(id, shiny::moduleServer(id, function(input, output, session) { # Observer to update reference and comparison arm input options. - arm_ref_comp_observer( + iv_arm_ref <- arm_ref_comp_observer( session, input, output, @@ -766,9 +766,40 @@ srv_t_coxreg <- function(id, module = "tm_t_coxreg" ) - anl_inputs <- teal.transform::merge_expression_module( - datasets = data, - join_keys = get_join_keys(data), + use_interactions <- shiny::reactive({ + input$type == "Univariate" && isTRUE(input$interactions) + }) + + overlap_rule <- function(other_var, var_name) { + function(value) { + if (length(intersect(value, selector_list()[[other_var]]()$select)) > 0) { + sprintf("`%s` and `%s` variables should not overlap", var_name[1], var_name[2]) + } + } + } + + select_validation_rule <- list( + aval_var = shinyvalidate::sv_required("An analysis variable is required"), + cnsr_var = shinyvalidate::sv_required("A censor variable is required"), + arm_var = shinyvalidate::compose_rules( + shinyvalidate::sv_required("A treatment variable is required"), + overlap_rule("strata_var", c("Treatment", "Strata")), + overlap_rule("cov_var", c("Treatment", "Covariate")) + ), + strata_var = shinyvalidate::compose_rules( + overlap_rule("arm_var", c("Treatment", "Strata")), + overlap_rule("cov_var", c("Covariate", "Strata")) + ), + cov_var = shinyvalidate::compose_rules( + overlap_rule("arm_var", c("Treatment", "Covariate")), + overlap_rule("strata_var", c("Covariate", "Strata")), + ~ if (use_interactions() && length(.) == 0) { + "If interactions are selected at least one covariate should be specified." + } + ) + ) + + selector_list <- teal.transform::data_extract_multiple_srv( data_extract = list( arm_var = arm_var, paramcd = paramcd, @@ -777,10 +808,58 @@ srv_t_coxreg <- function(id, cnsr_var = cnsr_var, cov_var = cov_var ), + datasets = data, + select_validation_rule = select_validation_rule, + filter_validation_rule = list( + paramcd = shinyvalidate::sv_required("An endpoint is required") + ) + ) + + + numeric_level_validation <- function(val) { + # need to explicitly evaluate 'val' here to ensure + # the correct label is shown - if this is not done + # then the last value of "val" is the label for all cases + v <- val + ~ if (anyNA(as_numeric_from_comma_sep_str(.))) { + paste("Numeric interaction level(s) should be specified for", v) + } + } + + + iv_r <- shiny::reactive({ + iv <- shinyvalidate::InputValidator$new() + iv$add_validator(iv_arm_ref) + iv$add_rule("conf_level", shinyvalidate::sv_required("Please choose a confidence level")) + iv$add_rule( + "conf_level", + shinyvalidate::sv_between(0, 1, message_fmt = "Confidence level must be between 0 and 1") + ) + iv$add_rule("pval_method", ~ if (length(selector_list()$strata_var()$select) > 0 && . != "wald") { + "Only Wald tests are supported for models with strata." + }) + # add rules for interaction_var text inputs + + for (val in interaction_var_r()) { + iv$add_rule( + paste0("interact_", val), + shinyvalidate::sv_required(paste("Interaction level(s) should be specified for", val)) + ) + iv$add_rule( + paste0("interact_", val), numeric_level_validation(val) + ) + } + teal.transform::compose_and_enable_validators(iv, selector_list) + }) + + anl_inputs <- teal.transform::merge_expression_srv( + datasets = data, + join_keys = get_join_keys(data), + selector_list = selector_list, merge_function = "dplyr::inner_join" ) - anl_q <- reactive({ + anl_q <- shiny::reactive({ teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) %>% teal.code::eval_code(as.expression(anl_inputs()$expr)) }) @@ -802,22 +881,29 @@ srv_t_coxreg <- function(id, ) } - output$interaction_input <- shiny::renderUI({ + interaction_var_r <- shiny::reactive({ # exclude cases when increments are not necessary and # finally accessing the UI-rendering function defined above. - if (!is.null(input$interactions) && input$interactions) { + if (use_interactions()) { input_cov_var <- as.vector(merged$anl_input_r()$columns_source$cov_var) dataset <- merged$anl_q()[[dataname]] cov_is_numeric <- vapply(dataset[input_cov_var], is.numeric, logical(1)) - interaction_var <- input_cov_var[cov_is_numeric] - if (length(interaction_var) > 0 && length(input_cov_var) > 0) { - lapply(interaction_var, open_textinput, dataset = dataset) - } + input_cov_var[cov_is_numeric] + } else { + NULL + } + }) + + output$interaction_input <- shiny::renderUI({ + if (length(interaction_var_r()) > 0) { + lapply(interaction_var_r(), open_textinput, dataset = merged$anl_q()[[dataname]]) } }) ## Prepare the call evaluation environment ---- validate_checks <- shiny::reactive({ + teal::validate_inputs(iv_r()) + adsl_filtered <- merged$anl_q()[[parentname]] anl_filtered <- merged$anl_q()[[dataname]] @@ -848,27 +934,6 @@ srv_t_coxreg <- function(id, validate_args <- append(validate_args, list(min_n_levels_armvar = NULL)) } - shiny::validate(shiny::need( - input$conf_level >= 0 && input$conf_level <= 1, - "Please choose a confidence level between 0 and 1" - )) - - teal::validate_no_intersection( - input_arm_var, - input_strata_var, - "`Treatment` and `Strata` variables should not be overlapped." - ) - teal::validate_no_intersection( - input_arm_var, - input_cov_var, - "`Treatment` and `Covariate` variables should not be overlapped." - ) - teal::validate_no_intersection( - input_strata_var, - input_cov_var, - "`Strata` and `Covariate` variables should not be overlapped." - ) - do.call(what = "validate_standard_inputs", validate_args) arm_n <- base::table(anl_filtered[[input_arm_var]]) @@ -882,47 +947,13 @@ srv_t_coxreg <- function(id, "Each treatment group should have at least 2 records." )) - # validate p-value method - if (length(input_strata_var) > 0) { - shiny::validate(shiny::need( - input$pval_method == "wald", - "Only Wald tests are supported for models with strata." - )) - } - - if (input$type == "Multivariate") { - shiny::validate(shiny::need( - input$interactions == FALSE, - "Interaction is only supported for univariate models." - )) - } - - if (!is.null(input$interactions) && input$interactions) { - shiny::validate(shiny::need( - (length(input_cov_var) > 0), - "If interactions are selected at least one covariate should be specified." - )) - } - - if (!is.null(input$interactions) && input$interactions && length(interaction_var) > 0) { - shiny::validate(shiny::need( - all(vapply(at(), function(x) length(x) > 0, logical(1))), - "Please specify all the interaction levels." - )) - } - - shiny::validate( - shiny::need(checkmate::test_string(input_aval_var), "Analysis variable should be a single column.") - ) - shiny::validate(shiny::need(checkmate::test_string(input_cnsr_var), "Censor variable should be a single column.")) - # validate covariate has at least two levels shiny::validate( shiny::need( all(vapply(anl_filtered[input_cov_var], FUN = function(x) { length(unique(x)) > 1 }, logical(1))), - "All covariate needs to have at least two levels" + "All covariates needs to have at least two levels" ) ) @@ -939,8 +970,7 @@ srv_t_coxreg <- function(id, function(x) { cov <- input[[paste0("interact_", x)]] if (!is.null(cov)) { - vec <- strsplit(cov, split = ",") - as.numeric(unlist(vec)) + as_numeric_from_comma_sep_str(cov) } } ) @@ -955,7 +985,7 @@ srv_t_coxreg <- function(id, cov_var <- as.vector(anl$columns_source$cov_var) cov_var <- if (length(cov_var) > 0) cov_var else NULL - at <- if (!is.null(input$interactions) && input$interactions) at() else list() + at <- if (use_interactions()) at() else list() arm_var <- as.vector(anl$columns_source$arm_var) cnsr_var <- as.vector(anl$columns_source$cnsr_var) aval_var <- as.vector(anl$columns_source$aval_var) @@ -965,7 +995,7 @@ srv_t_coxreg <- function(id, pval_method = input$pval_method, ties = input$ties, conf_level = as.numeric(input$conf_level), - interaction = `if`(is.null(input$interactions), FALSE, input$interactions) + interaction = `if`(!use_interactions(), FALSE, input$interactions) ) if (multivariate) { @@ -1081,14 +1111,14 @@ srv_t_coxreg <- function(id, teal.widgets::verbatim_popup_srv( id = "warning", - verbatim_content = reactive(teal.code::get_warnings(all_q())), + verbatim_content = shiny::reactive(teal.code::get_warnings(all_q())), title = "Warning", - disabled = reactive(is.null(teal.code::get_warnings(all_q()))) + disabled = shiny::reactive(is.null(teal.code::get_warnings(all_q()))) ) teal.widgets::verbatim_popup_srv( id = "rcode", - verbatim_content = reactive(teal.code::get_code(all_q())), + verbatim_content = shiny::reactive(teal.code::get_code(all_q())), title = "R Code for the Current (Multi-variable) Cox proportional hazard regression model" ) diff --git a/R/tm_t_events.R b/R/tm_t_events.R index 0773addc0a..f067ffcd1d 100644 --- a/R/tm_t_events.R +++ b/R/tm_t_events.R @@ -611,7 +611,7 @@ ui_t_events_byterm <- function(id, ...) { ) ) ), - forms = tagList( + forms = shiny::tagList( teal.widgets::verbatim_popup_ui(ns("warning"), button_label = "Show Warnings"), teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code") ), @@ -639,11 +639,42 @@ srv_t_events_byterm <- function(id, checkmate::assert_class(data, "tdata") shiny::moduleServer(id, function(input, output, session) { - anl_inputs <- teal.transform::merge_expression_module( - datasets = data, + selector_list <- teal.transform::data_extract_multiple_srv( data_extract = list(arm_var = arm_var, hlt = hlt, llt = llt), - merge_function = "dplyr::inner_join", - join_keys = get_join_keys(data) + datasets = data, + select_validation_rule = list( + arm_var = ~ if (length(.) != 1 && length(.) != 2) { + "Please select 1 or 2 treatment variable values" + }, + hlt = ~ if (length(selector_list()$llt()$select) + length(.) == 0) { + "Please select at least one of \"LOW LEVEL TERM\" or \"HIGH LEVEL TERM\" variables." + }, + llt = ~ if (length(selector_list()$hlt()$select) + length(.) == 0) { + "Please select at least one of \"LOW LEVEL TERM\" or \"HIGH LEVEL TERM\" variables." + } + ) + ) + + iv_r <- shiny::reactive({ + iv <- shinyvalidate::InputValidator$new() + iv$add_rule("prune_freq", shinyvalidate::sv_required("Please provide an Incidence Rate between 0 and 100 (%).")) + iv$add_rule( + "prune_freq", + shinyvalidate::sv_between(0, 100, message_fmt = "Please provide an Incidence Rate between 0 and 100 (%).") + ) + iv$add_rule("prune_diff", shinyvalidate::sv_required("Please provide a Difference Rate between 0 and 100 (%).")) + iv$add_rule( + "prune_diff", + shinyvalidate::sv_between(0, 100, message_fmt = "Please provide a Difference Rate between 0 and 100 (%).") + ) + teal.transform::compose_and_enable_validators(iv, selector_list) + }) + + anl_inputs <- teal.transform::merge_expression_srv( + datasets = data, + join_keys = get_join_keys(data), + selector_list = selector_list, + merge_function = "dplyr::inner_join" ) adsl_inputs <- teal.transform::merge_expression_module( @@ -653,7 +684,7 @@ srv_t_events_byterm <- function(id, join_keys = get_join_keys(data) ) - anl_q <- reactive({ + anl_q <- shiny::reactive({ teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) %>% teal.code::eval_code(as.expression(anl_inputs()$expr)) %>% teal.code::eval_code(as.expression(adsl_inputs()$expr)) @@ -666,6 +697,8 @@ srv_t_events_byterm <- function(id, ) validate_checks <- shiny::reactive({ + teal::validate_inputs(iv_r()) + adsl_filtered <- merged$anl_q()[[parentname]] anl_filtered <- merged$anl_q()[[dataname]] @@ -676,8 +709,6 @@ srv_t_events_byterm <- function(id, ) shiny::validate( - shiny::need(input_arm_var, "Please select a treatment variable"), - shiny::need(length(input_arm_var) <= 2, "Please limit treatment variables within two"), if (length(input_arm_var) >= 1) { shiny::need(is.factor(adsl_filtered[[input_arm_var[[1]]]]), "Treatment variable is not a factor.") }, @@ -690,20 +721,6 @@ srv_t_events_byterm <- function(id, ) } ) - teal::validate_has_elements( - input_level_term, - "Please select at least one of \"LOW LEVEL TERM\" or \"HIGH LEVEL TERM\" variables." - ) - shiny::validate( - shiny::need( - input$prune_freq >= 0 && input$prune_freq <= 100, - "Please provide an Incidence Rate between 0 and 100 (%)." - ), - shiny::need( - input$prune_diff >= 0 && input$prune_diff <= 100, - "Please provide a Difference Rate between 0 and 100 (%)." - ) - ) # validate inputs validate_standard_inputs( @@ -757,15 +774,15 @@ srv_t_events_byterm <- function(id, teal.widgets::verbatim_popup_srv( id = "warning", - verbatim_content = reactive(teal.code::get_warnings(table_q())), + verbatim_content = shiny::reactive(teal.code::get_warnings(table_q())), title = "Warning", - disabled = reactive(is.null(teal.code::get_warnings(table_q()))) + disabled = shiny::reactive(is.null(teal.code::get_warnings(table_q()))) ) # Render R code. teal.widgets::verbatim_popup_srv( id = "rcode", - verbatim_content = reactive(teal.code::get_code(table_q())), + verbatim_content = shiny::reactive(teal.code::get_code(table_q())), title = label ) diff --git a/R/tm_t_events_by_grade.R b/R/tm_t_events_by_grade.R index 6aa9b57b55..c1a3e4dee2 100644 --- a/R/tm_t_events_by_grade.R +++ b/R/tm_t_events_by_grade.R @@ -957,7 +957,7 @@ ui_t_events_by_grade <- function(id, ...) { ) ) ), - forms = tagList( + forms = shiny::tagList( teal.widgets::verbatim_popup_ui(ns("warning"), button_label = "Show Warnings"), teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code") ), @@ -987,9 +987,52 @@ srv_t_events_by_grade <- function(id, checkmate::assert_class(data, "tdata") shiny::moduleServer(id, function(input, output, session) { - anl_inputs <- teal.transform::merge_expression_module( - datasets = data, + selector_list <- teal.transform::data_extract_multiple_srv( data_extract = list(arm_var = arm_var, hlt = hlt, llt = llt, grade = grade), + datasets = data, + select_validation_rule = list( + arm_var = shinyvalidate::sv_required("A treatment variable is required"), + grade = shinyvalidate::sv_required("An event grade is required"), + hlt = ~ if (length(selector_list()$llt()$select) + length(.) == 0) { + "Please select at least one of \"LOW LEVEL TERM\" or \"HIGH LEVEL TERM\" variables." + }, + llt = shinyvalidate::compose_rules( + ~ if (length(selector_list()$hlt()$select) + length(.) == 0) { + "Please select at least one of \"LOW LEVEL TERM\" or \"HIGH LEVEL TERM\" variables." + }, + ~ if (col_by_grade() && length(.) == 0) { + "Low Level Term must be present when grade groupings are displayed in nested columns." + } + ) + ) + ) + + col_by_grade <- shiny::reactive({ + input$col_by_grade + }) + + iv_r <- shiny::reactive({ + iv <- shinyvalidate::InputValidator$new() + iv$add_rule( + "prune_freq", shinyvalidate::sv_required("Please provide an Incidence Rate between 0 and 100 (%).") + ) + iv$add_rule( + "prune_freq", + shinyvalidate::sv_between(0, 100, message_fmt = "Please provide an Incidence Rate between 0 and 100 (%).") + ) + iv$add_rule( + "prune_diff", shinyvalidate::sv_required("Please provide a Difference Rate between 0 and 100 (%).") + ) + iv$add_rule( + "prune_diff", + shinyvalidate::sv_between(0, 100, message_fmt = "Please provide a Difference Rate between 0 and 100 (%).") + ) + teal.transform::compose_and_enable_validators(iv, selector_list) + }) + + anl_inputs <- teal.transform::merge_expression_srv( + datasets = data, + selector_list = selector_list, join_keys = get_join_keys(data), merge_function = "dplyr::inner_join" ) @@ -1001,7 +1044,7 @@ srv_t_events_by_grade <- function(id, anl_name = "ANL_ADSL" ) - anl_q <- reactive({ + anl_q <- shiny::reactive({ teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) %>% teal.code::eval_code(as.expression(anl_inputs()$expr)) %>% teal.code::eval_code(as.expression(adsl_inputs()$expr)) @@ -1014,6 +1057,8 @@ srv_t_events_by_grade <- function(id, ) validate_checks <- shiny::reactive({ + teal::validate_inputs(iv_r()) + adsl_filtered <- merged$anl_q()[[parentname]] anl_filtered <- merged$anl_q()[[dataname]] adsl_keys <- merged$adsl_input_r()$keys @@ -1025,14 +1070,6 @@ srv_t_events_by_grade <- function(id, ) input_grade <- as.vector(merged$anl_input_r()$columns_source$grade) - shiny::validate( - shiny::need(input_arm_var, "Please select a treatment variable"), - shiny::need(input_grade, "Please select a grade variable") - ) - teal::validate_has_elements( - input_level_term, - "Please select at least one of \"LOW LEVEL TERM\" or \"HIGH LEVEL TERM\" variables.\n If the module is for displaying adverse events with grading groups in nested columns, \"LOW LEVEL TERM\" cannot be empty" # nolint - ) shiny::validate( shiny::need(is.factor(adsl_filtered[[input_arm_var]]), "Treatment variable is not a factor.") ) @@ -1052,24 +1089,6 @@ srv_t_events_by_grade <- function(id, ) ) } - shiny::validate( - shiny::need( - input$prune_freq >= 0 && input$prune_freq <= 100, - "Please provide an Incidence Rate between 0 and 100 (%)." - ), - shiny::need( - input$prune_diff >= 0 && input$prune_diff <= 100, - "Please provide a Difference Rate between 0 and 100 (%)." - ) - ) - if (input$col_by_grade) { - shiny::validate( - shiny::need( - as.vector(merged$anl_input_r()$columns_source$llt), - "Low Level Term must be present for nested grade grouping display." - ) - ) - } # validate inputs validate_standard_inputs( @@ -1148,15 +1167,15 @@ srv_t_events_by_grade <- function(id, teal.widgets::verbatim_popup_srv( id = "warning", - verbatim_content = reactive(teal.code::get_warnings(table_q())), + verbatim_content = shiny::reactive(teal.code::get_warnings(table_q())), title = "Warning", - disabled = reactive(is.null(teal.code::get_warnings(table_q()))) + disabled = shiny::reactive(is.null(teal.code::get_warnings(table_q()))) ) # Render R code. teal.widgets::verbatim_popup_srv( id = "rcode", - verbatim_content = reactive(teal.code::get_code(table_q())), + verbatim_content = shiny::reactive(teal.code::get_code(table_q())), title = label ) diff --git a/R/tm_t_events_patyear.R b/R/tm_t_events_patyear.R index b0c6796482..7df56b2d87 100644 --- a/R/tm_t_events_patyear.R +++ b/R/tm_t_events_patyear.R @@ -358,7 +358,7 @@ ui_events_patyear <- function(id, ...) { ) ) ), - forms = tagList( + forms = shiny::tagList( teal.widgets::verbatim_popup_ui(ns("warning"), button_label = "Show Warnings"), teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code") ), @@ -404,8 +404,7 @@ srv_events_patyear <- function(id, } }) - anl_inputs <- teal.transform::merge_expression_module( - datasets = data, + selector_list <- teal.transform::data_extract_multiple_srv( data_extract = list( arm_var = arm_var, paramcd = paramcd, @@ -413,6 +412,36 @@ srv_events_patyear <- function(id, avalu_var = avalu_var, events_var = events_var ), + datasets = data, + select_validation_rule = list( + arm_var = ~ if (length(.) != 1 && length(.) != 2) "Please select exactly 1 or 2 treatment variables", + aval_var = shinyvalidate::sv_required("Analysis Variable is required"), + events_var = shinyvalidate::sv_required("Events Variable is required") + ), + filter_validation_rule = list( + paramcd = shinyvalidate::sv_required("A Event Type Parameter is required") + ) + ) + + iv_r <- shiny::reactive({ + iv <- shinyvalidate::InputValidator$new() + iv$add_rule("conf_level", shinyvalidate::sv_required("Please choose a confidence level")) + iv$add_rule( + "conf_level", + shinyvalidate::sv_between( + 0, 1, + inclusive = c(FALSE, FALSE), + message_fmt = "Confidence level must be between 0 and 1" + ) + ) + iv$add_rule("conf_method", shinyvalidate::sv_required("A CI method is required")) + iv$add_rule("time_unit_output", shinyvalidate::sv_required("Time Unit for AE Rate is required")) + teal.transform::compose_and_enable_validators(iv, selector_list) + }) + + anl_inputs <- teal.transform::merge_expression_srv( + datasets = data, + selector_list = selector_list, join_keys = get_join_keys(data), merge_function = "dplyr::inner_join" ) @@ -424,7 +453,7 @@ srv_events_patyear <- function(id, anl_name = "ANL_ADSL" ) - anl_q <- reactive({ + anl_q <- shiny::reactive({ teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) %>% teal.code::eval_code(as.expression(anl_inputs()$expr)) %>% teal.code::eval_code(as.expression(adsl_inputs()$expr)) @@ -438,6 +467,7 @@ srv_events_patyear <- function(id, # Prepare the analysis environment (filter data, check data, populate envir). validate_checks <- shiny::reactive({ + teal::validate_inputs(iv_r()) adsl_filtered <- merged$anl_q()[[parentname]] anl_filtered <- merged$anl_q()[[dataname]] @@ -456,26 +486,12 @@ srv_events_patyear <- function(id, arm_var = input_arm_var ) - shiny::validate(shiny::need( - input$conf_level > 0 && input$conf_level < 1, - "Please choose a confidence level between 0 and 1" - )) - shiny::validate( - shiny::need(checkmate::test_string(input_aval_var), "`Analysis Variable` should be a single column."), - shiny::need(checkmate::test_string(input_events_var), "Events variable should be a single column."), - shiny::need(input$conf_method, "`CI Method` field is not selected."), - shiny::need(input$time_unit_output, "`Time Unit for AE Rate (in Patient-Years)` field is empty."), - shiny::need( - input[[extract_input("paramcd", paramcd$filter[[1]]$dataname, filter = TRUE)]], - "`Select an Event Type Parameter is not selected." - ), shiny::need( !any(is.na(merged$anl_q()[["ANL"]][[input_events_var]])), "`Event Variable` for selected parameter includes NA values." ) ) - NULL }) @@ -530,15 +546,15 @@ srv_events_patyear <- function(id, teal.widgets::verbatim_popup_srv( id = "warning", - verbatim_content = reactive(teal.code::get_warnings(table_q())), + verbatim_content = shiny::reactive(teal.code::get_warnings(table_q())), title = "Warning", - disabled = reactive(is.null(teal.code::get_warnings(table_q()))) + disabled = shiny::reactive(is.null(teal.code::get_warnings(table_q()))) ) # Render R code. teal.widgets::verbatim_popup_srv( id = "rcode", - verbatim_content = reactive(teal.code::get_code(table_q())), + verbatim_content = shiny::reactive(teal.code::get_code(table_q())), title = label ) diff --git a/R/tm_t_events_summary.R b/R/tm_t_events_summary.R index 41218a3ad0..da9fd9cce0 100644 --- a/R/tm_t_events_summary.R +++ b/R/tm_t_events_summary.R @@ -790,7 +790,7 @@ ui_t_events_summary <- function(id, ...) { ) ) ), - forms = tagList( + forms = shiny::tagList( teal.widgets::verbatim_popup_ui(ns("warning"), button_label = "Show Warnings"), teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code") ), @@ -833,9 +833,26 @@ srv_t_events_summary <- function(id, data_extract_vars[["flag_var_aesi"]] <- flag_var_aesi } - anl_inputs <- teal.transform::merge_expression_module( - datasets = data, + selector_list <- teal.transform::data_extract_multiple_srv( data_extract = data_extract_vars, + datasets = data, + select_validation_rule = list( + arm_var = ~ if (length(.) != 1 && length(.) != 2) "Please select exactly 1 or 2 treatment variables", + dthfl_var = shinyvalidate::sv_required("Death Flag Variable is requried"), + dcsreas_var = shinyvalidate::sv_required("Study Discontinuation Reason Variable is required"), + aeseq_var = shinyvalidate::sv_required("AE Sequence Variable is required"), + llt = shinyvalidate::sv_required("AE Term Variable is required") + ) + ) + + iv_r <- shiny::reactive({ + iv <- shinyvalidate::InputValidator$new() + teal.transform::compose_and_enable_validators(iv, selector_list) + }) + + anl_inputs <- teal.transform::merge_expression_srv( + datasets = data, + selector_list = selector_list, join_keys = get_join_keys(data), merge_function = "dplyr::inner_join" ) @@ -847,7 +864,7 @@ srv_t_events_summary <- function(id, anl_name = "ANL_ADSL" ) - anl_q <- reactive({ + anl_q <- shiny::reactive({ teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) %>% teal.code::eval_code(as.expression(anl_inputs()$expr)) %>% teal.code::eval_code(as.expression(adsl_inputs()$expr)) @@ -860,6 +877,8 @@ srv_t_events_summary <- function(id, ) validate_checks <- shiny::reactive({ + teal::validate_inputs(iv_r()) + adsl_filtered <- merged$anl_q()[[parentname]] anl_filtered <- merged$anl_q()[[dataname]] @@ -880,14 +899,10 @@ srv_t_events_summary <- function(id, input_llt <- as.vector(merged$anl_input_r()$columns_source$llt) shiny::validate( - shiny::need(input_arm_var, "Please select a treatment variable"), - shiny::need(length(input_arm_var) <= 2, "Please limit treatment variables within two"), - if (length(input_arm_var) >= 1) { - shiny::need(is.factor(adsl_filtered[[input_arm_var[[1]]]]), "Treatment variable is not a factor.") - }, + shiny::need(is.factor(adsl_filtered[[input_arm_var[[1]]]]), "Treatment variable is not a factor."), if (length(input_arm_var) == 2) { shiny::need( - is.factor(adsl_filtered[[input_arm_var[[2]]]]) & all(!adsl_filtered[[input_arm_var[[2]]]] %in% c( + is.factor(adsl_filtered[[input_arm_var[[2]]]]) && all(!adsl_filtered[[input_arm_var[[2]]]] %in% c( "", NA )), "Please check nested treatment variable which needs to be a factor without NA or empty strings." @@ -969,14 +984,14 @@ srv_t_events_summary <- function(id, teal.widgets::verbatim_popup_srv( id = "warning", - verbatim_content = reactive(teal.code::get_warnings(table_q())), + verbatim_content = shiny::reactive(teal.code::get_warnings(table_q())), title = "Warning", - disabled = reactive(is.null(teal.code::get_warnings(table_q()))) + disabled = shiny::reactive(is.null(teal.code::get_warnings(table_q()))) ) teal.widgets::verbatim_popup_srv( id = "rcode", - verbatim_content = reactive(teal.code::get_code(table_q())), + verbatim_content = shiny::reactive(teal.code::get_code(table_q())), title = label ) diff --git a/R/tm_t_exposure.R b/R/tm_t_exposure.R index 66077ba6e3..eb1eccfa7e 100644 --- a/R/tm_t_exposure.R +++ b/R/tm_t_exposure.R @@ -460,7 +460,7 @@ ui_t_exposure <- function(id, ...) { ) ) ), - forms = tagList( + forms = shiny::tagList( teal.widgets::verbatim_popup_ui(ns("warning"), button_label = "Show Warnings"), teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code") ), @@ -491,9 +491,16 @@ srv_t_exposure <- function(id, with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") checkmate::assert_class(data, "tdata") shiny::moduleServer(id, function(input, output, session) { - anl_inputs <- teal.transform::merge_expression_module( - datasets = data, - join_keys = get_join_keys(data), + rule_intersection <- function(other) { + function(value) { + others <- selector_list()[[other]]()$select + if (length(intersect(value, others)) > 0L) { + "Column by and row by variables should not be the same." + } + } + } + + selector_list <- teal.transform::data_extract_multiple_srv( data_extract = list( id_var = id_var, paramcd = paramcd, @@ -503,6 +510,35 @@ srv_t_exposure <- function(id, aval_var = aval_var, avalu_var = avalu_var ), + datasets = data, + select_validation_rule = list( + id_var = shinyvalidate::sv_required("Subject Identifier is required"), + col_by_var = shinyvalidate::compose_rules( + shinyvalidate::sv_optional(), + rule_intersection("row_by_var") + ), + row_by_var = shinyvalidate::compose_rules( + shinyvalidate::sv_required("Please select a row by variable."), + rule_intersection("col_by_var") + ), + aval_var = shinyvalidate::sv_required("Please select an analysis variable."), + avalu_var = shinyvalidate::sv_required("Please select an analysis unit variable.") + ), + filter_validation_rule = list( + paramcd = shinyvalidate::sv_required("Please select a parameter value."), + parcat = shinyvalidate::sv_required("Please select a parameter category value.") + ) + ) + + iv_r <- shiny::reactive({ + iv <- shinyvalidate::InputValidator$new() + teal.transform::compose_and_enable_validators(iv, selector_list) + }) + + anl_inputs <- teal.transform::merge_expression_srv( + datasets = data, + selector_list = selector_list, + join_keys = get_join_keys(data), merge_function = "dplyr::inner_join" ) @@ -513,7 +549,7 @@ srv_t_exposure <- function(id, anl_name = "ANL_ADSL" ) - anl_q <- reactive({ + anl_q <- shiny::reactive({ teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) %>% teal.code::eval_code(as.expression(anl_inputs()$expr)) %>% teal.code::eval_code(as.expression(adsl_inputs()$expr)) @@ -529,6 +565,8 @@ srv_t_exposure <- function(id, adsl_filtered <- merged$anl_q()[[parentname]] anl_filtered <- merged$anl_q()[[dataname]] + teal::validate_inputs(iv_r()) + input_paramcd <- unlist(paramcd$filter)["vars_selected"] input_id_var <- names(merged$anl_input_r()$columns_source$id_var) input_row_by_var <- names(merged$anl_input_r()$columns_source$row_by_var) @@ -537,24 +575,6 @@ srv_t_exposure <- function(id, input_aval_var <- names(merged$anl_input_r()$columns_source$aval_var) input_avalu_var <- names(merged$anl_input_r()$columns_source$avalu_var) - shiny::validate( - shiny::need(input_row_by_var, "Please select a row by variable."), - shiny::need(input_aval_var, "Please select an analysis variable."), - shiny::need(input_avalu_var, "Please select an analysis unit variable."), - shiny::need( - input[[extract_input("parcat", parcat$filter[[1]]$dataname, filter = TRUE)]], - "Please select a parameter category value." - ), - shiny::need( - input[[extract_input("paramcd", paramcd$filter[[1]]$dataname, filter = TRUE)]], - "Please select a parameter value." - ), - teal::validate_no_intersection( - input[[extract_input("col_by_var", parentname)]], - input[[extract_input("row_by_var", dataname)]], - "Column by and row by variables should not be the same." - ) - ) # validate inputs validate_standard_inputs( adsl = adsl_filtered, @@ -622,15 +642,15 @@ srv_t_exposure <- function(id, teal.widgets::verbatim_popup_srv( id = "warning", - verbatim_content = reactive(teal.code::get_warnings(all_q())), + verbatim_content = shiny::reactive(teal.code::get_warnings(all_q())), title = "Warning", - disabled = reactive(is.null(teal.code::get_warnings(all_q()))) + disabled = shiny::reactive(is.null(teal.code::get_warnings(all_q()))) ) # Render R code. teal.widgets::verbatim_popup_srv( id = "rcode", - verbatim_content = reactive(teal.code::get_code(all_q())), + verbatim_content = shiny::reactive(teal.code::get_code(all_q())), title = label ) diff --git a/R/tm_t_logistic.R b/R/tm_t_logistic.R index 47b549e239..8508408f58 100644 --- a/R/tm_t_logistic.R +++ b/R/tm_t_logistic.R @@ -304,7 +304,11 @@ tm_t_logistic <- function(label, checkmate::assert_string(label) checkmate::assert_string(dataname) checkmate::assert_string(parentname) - checkmate::assert_class(avalc_var, classes = "choices_selected") + checkmate::assert_multi_class(arm_var, c("choices_selected", "data_extract_spec"), null.ok = TRUE) + checkmate::assert_list(arm_ref_comp, names = "named", null.ok = TRUE) + checkmate::assert_multi_class(paramcd, c("choices_selected", "data_extract_spec")) + checkmate::assert_multi_class(cov_var, c("choices_selected", "data_extract_spec")) + checkmate::assert_multi_class(avalc_var, c("choices_selected", "data_extract_spec")) checkmate::assert_class(conf_level, classes = "choices_selected") checkmate::assert_class(pre_output, classes = "shiny.tag", null.ok = TRUE) checkmate::assert_class(post_output, classes = "shiny.tag", null.ok = TRUE) @@ -315,8 +319,8 @@ tm_t_logistic <- function(label, data_extract_list <- list( arm_var = `if`(is.null(arm_var), NULL, cs_to_des_select(arm_var, dataname = parentname)), paramcd = cs_to_des_filter(paramcd, dataname = dataname), - avalc_var = cs_to_des_select(avalc_var, dataname = dataname), - cov_var = cs_to_des_select(cov_var, dataname = dataname, multiple = TRUE) + cov_var = cs_to_des_select(cov_var, dataname = dataname, multiple = TRUE), + avalc_var = cs_to_des_select(avalc_var, dataname = dataname) ) module( @@ -427,7 +431,7 @@ ui_t_logistic <- function(id, ...) { fixed = a$conf_level$fixed ) ), - forms = tagList( + forms = shiny::tagList( teal.widgets::verbatim_popup_ui(ns("warning"), button_label = "Show Warnings"), teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code") ), @@ -458,7 +462,7 @@ srv_t_logistic <- function(id, shiny::moduleServer(id, function(input, output, session) { # Observer to update reference and comparison arm input options. - arm_ref_comp_observer( + iv_arco <- arm_ref_comp_observer( session, input, output, @@ -468,10 +472,60 @@ srv_t_logistic <- function(id, module = "tm_t_logistic" ) - anl_inputs <- teal.transform::merge_expression_module( + selector_list <- teal.transform::data_extract_multiple_srv( + data_extract = list( + arm_var = arm_var, + paramcd = paramcd, + avalc_var = avalc_var, + cov_var = cov_var + ), + datasets = data, + select_validation_rule = list( + arm_var = shinyvalidate::sv_required("Treatment Variable is empty"), + avalc_var = shinyvalidate::sv_required("Analysis variable is empty"), + cov_var = shinyvalidate::sv_required("`Covariates` field is empty") + ), + filter_validation_rule = list( + paramcd = shinyvalidate::sv_required("`Select Endpoint` field is empty") + ) + ) + + iv_r <- shiny::reactive({ + iv <- shinyvalidate::InputValidator$new() + iv$add_rule("responders", shinyvalidate::sv_required("`Responders` field is empty")) + iv$add_rule("conf_level", shinyvalidate::sv_required("Please choose a confidence level.")) + iv$add_rule("conf_level", shinyvalidate::sv_between( + 0, 1, + message_fmt = "Confdence level must be between {left} and {right}." + )) + iv$add_validator(iv_arco) + # Conditional validator for interaction values. + iv_int <- shinyvalidate::InputValidator$new() + iv_int$condition(~ length(input$interaction_var) > 0L && + is.numeric(merged$anl_q()[["ANL"]][[input$interaction_var]])) + iv_int$add_rule("interaction_values", shinyvalidate::sv_required( + "If interaction is specified the level should be entered." + )) + iv_int$add_rule( + "interaction_values", + ~ if (anyNA(as_numeric_from_comma_sep_str(.))) { + "Interaction levels are invalid." + } + ) + iv_int$add_rule( + "interaction_values", + ~ if (any(duplicated(as_numeric_from_comma_sep_str(.)))) { + "Interaction levels must be unique." + } + ) + iv$add_validator(iv_int) + teal.transform::compose_and_enable_validators(iv, selector_list) + }) + + anl_inputs <- teal.transform::merge_expression_srv( + selector_list = selector_list, datasets = data, join_keys = get_join_keys(data), - data_extract = list(arm_var = arm_var, paramcd = paramcd, avalc_var = avalc_var, cov_var = cov_var), merge_function = "dplyr::inner_join" ) @@ -482,7 +536,7 @@ srv_t_logistic <- function(id, anl_name = "ANL_ADSL" ) - anl_q <- reactive({ + anl_q <- shiny::reactive({ teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) %>% teal.code::eval_code(as.expression(anl_inputs()$expr)) %>% teal.code::eval_code(as.expression(adsl_inputs()$expr)) @@ -547,6 +601,8 @@ srv_t_logistic <- function(id, adsl_filtered <- anl_q()[[parentname]] anl_filtered <- anl_q()[[dataname]] + validate_inputs(iv_r()) + input_arm_var <- as.vector(merged$anl_input_r()$columns_source$arm_var) input_avalc_var <- as.vector(merged$anl_input_r()$columns_source$avalc_var) input_cov_var <- as.vector(merged$anl_input_r()$columns_source$cov_var) @@ -554,13 +610,8 @@ srv_t_logistic <- function(id, input_interaction_var <- input$interaction_var input_interaction_at <- input_interaction_var[input_interaction_var %in% input_cov_var] - interaction_flag <- length(input_interaction_at) != 0 - at_values <- if (is.null(input$interaction_values)) { - NA - } else { - unlist(as_num(input$interaction_values)) - } + at_values <- as_numeric_from_comma_sep_str(input$interaction_values) # validate inputs validate_args <- list( @@ -574,11 +625,6 @@ srv_t_logistic <- function(id, min_nrow = 4 ) - shiny::validate(shiny::need( - input$conf_level >= 0 && input$conf_level <= 1, - "Please choose a confidence level between 0 and 1" - )) - # validate arm levels if (!is.null(arm_var)) { if (length(input_arm_var) > 0 && length(unique(adsl_filtered[[input_arm_var]])) == 1) { @@ -599,19 +645,6 @@ srv_t_logistic <- function(id, )) } - shiny::validate( - shiny::need(checkmate::test_string(input_avalc_var), "Analysis variable should be a single column."), - shiny::need(input$responders, "`Responders` field is empty") - ) - - # validate interaction values - if (interaction_flag && (is.numeric(merged$anl_q()[["ANL"]][[input_interaction_at]]))) { - shiny::validate(shiny::need( - !is.na(at_values), - "If interaction is specified the level should be entered." - )) - } - # validate covariate has at least two levels shiny::validate( shiny::need( @@ -641,11 +674,7 @@ srv_t_logistic <- function(id, interaction_var <- input$interaction_var interaction_flag <- length(interaction_var) != 0 - at_values <- if (is.null(input$interaction_values)) { - NA - } else { - unlist(as_num(input$interaction_values)) - } + at_values <- as_numeric_from_comma_sep_str(input$interaction_values) at_flag <- interaction_flag && is.numeric(ANL[[interaction_var]]) cov_var <- names(merged$anl_input_r()$columns_source$cov_var) @@ -680,14 +709,14 @@ srv_t_logistic <- function(id, teal.widgets::verbatim_popup_srv( id = "warning", - verbatim_content = reactive(teal.code::get_warnings(all_q())), + verbatim_content = shiny::reactive(teal.code::get_warnings(all_q())), title = "Warning", - disabled = reactive(is.null(teal.code::get_warnings(all_q()))) + disabled = shiny::reactive(is.null(teal.code::get_warnings(all_q()))) ) teal.widgets::verbatim_popup_srv( id = "rcode", - verbatim_content = reactive(teal.code::get_code(all_q())), + verbatim_content = shiny::reactive(teal.code::get_code(all_q())), title = label ) diff --git a/R/tm_t_mult_events.R b/R/tm_t_mult_events.R index a400f2e675..9fd7ada44d 100644 --- a/R/tm_t_mult_events.R +++ b/R/tm_t_mult_events.R @@ -429,7 +429,7 @@ ui_t_mult_events_byterm <- function(id, ...) { ) ) ), - forms = tagList( + forms = shiny::tagList( teal.widgets::verbatim_popup_ui(ns("warning"), button_label = "Show Warnings"), teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code") ), @@ -458,19 +458,32 @@ srv_t_mult_events_byterm <- function(id, checkmate::assert_class(data, "tdata") shiny::moduleServer(id, function(input, output, session) { - anl_merge_inputs <- teal.transform::merge_expression_module( - id = "anl_merge", - datasets = data, - join_keys = get_join_keys(data), + selector_list <- teal.transform::data_extract_multiple_srv( data_extract = list( arm_var = arm_var, seq_var = seq_var, hlt = hlt, llt = llt ), - merge_function = "dplyr::inner_join" + datasets = data, + select_validation_rule = list( + arm_var = shinyvalidate::sv_required("Please select a treatment variable"), + llt = shinyvalidate::sv_required("Please select a \"LOW LEVEL TERM\" variable") + ) ) + iv_r <- shiny::reactive({ + iv <- shinyvalidate::InputValidator$new() + teal.transform::compose_and_enable_validators(iv, selector_list, c("arm_var", "llt")) + }) + + anl_merge_inputs <- teal.transform::merge_expression_srv( + id = "anl_merge", + datasets = data, + join_keys = get_join_keys(data), + selector_list = selector_list, + merge_function = "dplyr::inner_join" + ) adsl_merge_inputs <- teal.transform::merge_expression_module( id = "adsl_merge", @@ -480,13 +493,14 @@ srv_t_mult_events_byterm <- function(id, anl_name = "ANL_ADSL" ) - anl_q <- reactive({ + anl_q <- shiny::reactive({ qenv <- teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) qenv2 <- teal.code::eval_code(qenv, as.expression(anl_merge_inputs()$expr)) teal.code::eval_code(qenv2, as.expression(adsl_merge_inputs()$expr)) }) validate_checks <- shiny::reactive({ + teal::validate_inputs(iv_r()) adsl_filtered <- anl_q()[[parentname]] anl_filtered <- anl_q()[[dataname]] @@ -497,8 +511,6 @@ srv_t_mult_events_byterm <- function(id, input_hlt <- as.vector(anl_m$columns_source$hlt) input_llt <- as.vector(anl_m$columns_source$llt) - shiny::validate(shiny::need(input_arm_var, "Please select a treatment variable")) - shiny::validate(shiny::need(input_llt, "Please select a \"LOW LEVEL TERM\" variable")) shiny::validate( shiny::need(is.factor(adsl_filtered[[input_arm_var]]), "Treatment variable is not a factor.") @@ -563,15 +575,15 @@ srv_t_mult_events_byterm <- function(id, teal.widgets::verbatim_popup_srv( id = "warning", - verbatim_content = reactive(teal.code::get_warnings(all_q())), + verbatim_content = shiny::reactive(teal.code::get_warnings(all_q())), title = "Warning", - disabled = reactive(is.null(teal.code::get_warnings(all_q()))) + disabled = shiny::reactive(is.null(teal.code::get_warnings(all_q()))) ) # Render R code. teal.widgets::verbatim_popup_srv( id = "rcode", - verbatim_content = reactive(teal.code::get_code(all_q())), + verbatim_content = shiny::reactive(teal.code::get_code(all_q())), title = label ) diff --git a/R/tm_t_pp_basic_info.R b/R/tm_t_pp_basic_info.R index 6a9ea757a3..e4f316a343 100644 --- a/R/tm_t_pp_basic_info.R +++ b/R/tm_t_pp_basic_info.R @@ -143,7 +143,7 @@ ui_t_basic_info <- function(id, ...) { is_single_dataset = is_single_dataset_value ) ), - forms = tagList( + forms = shiny::tagList( teal.widgets::verbatim_popup_ui(ns("warning"), button_label = "Show Warnings"), teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code") ), @@ -194,27 +194,34 @@ srv_t_basic_info <- function(id, ) # Basic Info tab ---- - anl_inputs <- teal.transform::merge_expression_module( + selector_list <- teal.transform::data_extract_multiple_srv( + data_extract = list(vars = vars), + datasets = data, + select_validation_rule = list( + vars = shinyvalidate::sv_required("Please select basic info variables") + ) + ) + + iv_r <- shiny::reactive({ + iv <- shinyvalidate::InputValidator$new() + iv$add_rule("patient_id", shinyvalidate::sv_required("Please select a patient")) + teal.transform::compose_and_enable_validators(iv, selector_list) + }) + + anl_inputs <- teal.transform::merge_expression_srv( datasets = data, join_keys = get_join_keys(data), - data_extract = list(vars = vars), + selector_list = selector_list, merge_function = "dplyr::left_join" ) - anl_q <- reactive({ + anl_q <- shiny::reactive({ teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) %>% teal.code::eval_code(as.expression(anl_inputs()$expr)) }) all_q <- shiny::reactive({ - shiny::validate(shiny::need(patient_id(), "Please select a patient.")) - shiny::validate( - shiny::need( - anl_inputs()$columns_source$vars, - "Please select basic info variables." - ) - ) - + teal::validate_inputs(iv_r()) my_calls <- template_basic_info( dataname = "ANL", vars = anl_inputs()$columns_source$vars @@ -243,14 +250,14 @@ srv_t_basic_info <- function(id, teal.widgets::verbatim_popup_srv( id = "warning", - verbatim_content = reactive(teal.code::get_warnings(all_q())), + verbatim_content = shiny::reactive(teal.code::get_warnings(all_q())), title = "Warning", - disabled = reactive(is.null(teal.code::get_warnings(all_q()))) + disabled = shiny::reactive(is.null(teal.code::get_warnings(all_q()))) ) teal.widgets::verbatim_popup_srv( id = "rcode", - verbatim_content = reactive(teal.code::get_code(all_q())), + verbatim_content = shiny::reactive(teal.code::get_code(all_q())), title = label ) diff --git a/R/tm_t_pp_laboratory.R b/R/tm_t_pp_laboratory.R index 2bac4ab414..8fe19fc9e2 100644 --- a/R/tm_t_pp_laboratory.R +++ b/R/tm_t_pp_laboratory.R @@ -276,7 +276,7 @@ ui_g_laboratory <- function(id, ...) { choices = NULL ) ), - forms = tagList( + forms = shiny::tagList( teal.widgets::verbatim_popup_ui(ns("warning"), button_label = "Show Warnings"), teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code") ), @@ -344,9 +344,7 @@ srv_g_laboratory <- function(id, ) # Laboratory values tab ---- - anl_inputs <- teal.transform::merge_expression_module( - datasets = data, - join_keys = get_join_keys(data), + selector_list <- teal.transform::data_extract_multiple_srv( data_extract = list( timepoints = timepoints, aval = aval, @@ -354,43 +352,37 @@ srv_g_laboratory <- function(id, param = param, paramcd = paramcd, anrind = anrind + ), + datasets = data, + select_validation_rule = list( + timepoints = shinyvalidate::sv_required("Please select timepoints variable."), + aval = shinyvalidate::sv_required("Please select AVAL variable."), + avalu = shinyvalidate::sv_required("Please select AVALU variable."), + param = shinyvalidate::sv_required("Please select PARAM variable."), + paramcd = shinyvalidate::sv_required("Please select PARAMCD variable."), + anrind = shinyvalidate::sv_required("Please select ANRIND variable.") ) ) - anl_q <- reactive({ + iv_r <- shiny::reactive({ + iv <- shinyvalidate::InputValidator$new() + iv$add_rule("patient_id", shinyvalidate::sv_required("Please select a patient")) + teal.transform::compose_and_enable_validators(iv, selector_list) + }) + + anl_inputs <- teal.transform::merge_expression_srv( + datasets = data, + join_keys = get_join_keys(data), + selector_list = selector_list + ) + + anl_q <- shiny::reactive({ teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) %>% teal.code::eval_code(as.expression(anl_inputs()$expr)) }) all_q <- shiny::reactive({ - shiny::validate(shiny::need(patient_id(), "Please select a patient.")) - - shiny::validate( - shiny::need( - input[[extract_input("timepoints", dataname)]], - "Please select timepoints variable." - ), - shiny::need( - input[[extract_input("aval", dataname)]], - "Please select AVAL variable." - ), - shiny::need( - input[[extract_input("avalu", dataname)]], - "Please select AVALU variable." - ), - shiny::need( - input[[extract_input("param", dataname)]], - "Please select PARAM variable." - ), - shiny::need( - input[[extract_input("paramcd", dataname)]], - "Please select PARAMCD variable." - ), - shiny::need( - input[[extract_input("anrind", dataname)]], - "Please select ANRIND variable." - ) - ) + teal::validate_inputs(iv_r()) labor_calls <- template_laboratory( dataname = "ANL", @@ -433,14 +425,14 @@ srv_g_laboratory <- function(id, teal.widgets::verbatim_popup_srv( id = "warning", - verbatim_content = reactive(teal.code::get_warnings(all_q())), + verbatim_content = shiny::reactive(teal.code::get_warnings(all_q())), title = "Warning", - disabled = reactive(is.null(teal.code::get_warnings(all_q()))) + disabled = shiny::reactive(is.null(teal.code::get_warnings(all_q()))) ) teal.widgets::verbatim_popup_srv( id = "rcode", - verbatim_content = reactive(teal.code::get_code(all_q())), + verbatim_content = shiny::reactive(teal.code::get_code(all_q())), title = label ) diff --git a/R/tm_t_pp_medical_history.R b/R/tm_t_pp_medical_history.R index 33fffaac7b..ebc481ce1f 100644 --- a/R/tm_t_pp_medical_history.R +++ b/R/tm_t_pp_medical_history.R @@ -214,7 +214,7 @@ ui_t_medical_history <- function(id, ...) { is_single_dataset = is_single_dataset_value ) ), - forms = tagList( + forms = shiny::tagList( teal.widgets::verbatim_popup_ui(ns("warning"), button_label = "Show Warnings"), teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code") ), @@ -266,34 +266,38 @@ srv_t_medical_history <- function(id, ) # Medical history tab ---- - anl_inputs <- teal.transform::merge_expression_module( + selector_list <- teal.transform::data_extract_multiple_srv( + data_extract = list(mhterm = mhterm, mhbodsys = mhbodsys, mhdistat = mhdistat), + datasets = data, + select_validation_rule = list( + mhterm = shinyvalidate::sv_required("Please select MHTERM variable."), + mhbodsys = shinyvalidate::sv_required("Please select MHBODSYS variable."), + mhdistat = shinyvalidate::sv_required("Please select MHDISTAT variable.") + ) + ) + + iv_r <- shiny::reactive({ + iv <- shinyvalidate::InputValidator$new() + iv$add_rule("patient_id", shinyvalidate::sv_required("Please select a patient")) + teal.transform::compose_and_enable_validators(iv, selector_list) + }) + + anl_inputs <- teal.transform::merge_expression_srv( datasets = data, join_keys = get_join_keys(data), - data_extract = list(mhterm = mhterm, mhbodsys = mhbodsys, mhdistat = mhdistat), + selector_list = selector_list, merge_function = "dplyr::left_join" ) - anl_q <- reactive({ + anl_q <- shiny::reactive({ teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) %>% teal.code::eval_code(as.expression(anl_inputs()$expr)) }) all_q <- shiny::reactive({ - shiny::validate(shiny::need(patient_id(), "Please select a patient.")) + teal::validate_inputs(iv_r()) shiny::validate( - shiny::need( - input[[extract_input("mhterm", dataname)]], - "Please select MHTERM variable." - ), - shiny::need( - input[[extract_input("mhbodsys", dataname)]], - "Please select MHBODSYS variable." - ), - shiny::need( - input[[extract_input("mhdistat", dataname)]], - "Please select MHDISTAT variable." - ), shiny::need( nrow(anl_q()[["ANL"]][anl_q()[["ANL"]][[patient_col]] == patient_id(), ]) > 0, "Patient has no data about medical history." @@ -330,14 +334,14 @@ srv_t_medical_history <- function(id, teal.widgets::verbatim_popup_srv( id = "warning", - verbatim_content = reactive(teal.code::get_warnings(all_q())), + verbatim_content = shiny::reactive(teal.code::get_warnings(all_q())), title = "Warning", - disabled = reactive(is.null(teal.code::get_warnings(all_q()))) + disabled = shiny::reactive(is.null(teal.code::get_warnings(all_q()))) ) teal.widgets::verbatim_popup_srv( id = "rcode", - verbatim_content = reactive(teal.code::get_code(all_q())), + verbatim_content = shiny::reactive(teal.code::get_code(all_q())), title = label ) diff --git a/R/tm_t_pp_prior_medication.R b/R/tm_t_pp_prior_medication.R index a1bc17f00b..8d4221c458 100644 --- a/R/tm_t_pp_prior_medication.R +++ b/R/tm_t_pp_prior_medication.R @@ -243,7 +243,7 @@ ui_t_prior_medication <- function(id, ...) { is_single_dataset = is_single_dataset_value ) ), - forms = tagList( + forms = shiny::tagList( teal.widgets::verbatim_popup_ui(ns("warning"), button_label = "Show Warnings"), teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code") ), @@ -272,6 +272,28 @@ srv_t_prior_medication <- function(id, shiny::moduleServer(id, function(input, output, session) { patient_id <- shiny::reactive(input$patient_id) + selector_list <- teal.transform::data_extract_multiple_srv( + data_extract = list( + atirel = atirel, + cmdecod = cmdecod, + cmindc = cmindc, + cmstdy = cmstdy + ), + datasets = data, + select_validation_rule = list( + atirel = shinyvalidate::sv_required("An ATIREL variable is required"), + cmdecod = shinyvalidate::sv_required("A medication decoding variable is required"), + cmindc = shinyvalidate::sv_required("A CMINDC variable is required"), + cmstdy = shinyvalidate::sv_required("A CMSTDY variable is required") + ) + ) + + iv_r <- shiny::reactive({ + iv <- shinyvalidate::InputValidator$new() + iv$add_rule("patient_id", shinyvalidate::sv_required("Please select patient id")) + teal.transform::compose_and_enable_validators(iv, selector_list) + }) + # Init patient_data_base <- shiny::reactive(unique(data[[parentname]]()[[patient_col]])) teal.widgets::updateOptionalSelectInput( @@ -298,39 +320,20 @@ srv_t_prior_medication <- function(id, ) # Prior medication tab ---- - anl_inputs <- teal.transform::merge_expression_module( + anl_inputs <- teal.transform::merge_expression_srv( datasets = data, + selector_list = selector_list, join_keys = get_join_keys(data), - data_extract = list(atirel = atirel, cmdecod = cmdecod, cmindc = cmindc, cmstdy = cmstdy), merge_function = "dplyr::left_join" ) - anl_q <- reactive({ + anl_q <- shiny::reactive({ teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) %>% teal.code::eval_code(as.expression(anl_inputs()$expr)) }) all_q <- shiny::reactive({ - shiny::validate(shiny::need(patient_id(), "Please select a patient.")) - - shiny::validate( - shiny::need( - input[[extract_input("atirel", dataname)]], - "Please select ATIREL variable." - ), - shiny::need( - input[[extract_input("cmdecod", dataname)]], - "Please select Medication decoding variable." - ), - shiny::need( - input[[extract_input("cmindc", dataname)]], - "Please select CMINDC variable." - ), - shiny::need( - input[[extract_input("cmstdy", dataname)]], - "Please select CMSTDY variable." - ) - ) + teal::validate_inputs(iv_r()) my_calls <- template_prior_medication( dataname = "ANL", @@ -363,14 +366,14 @@ srv_t_prior_medication <- function(id, teal.widgets::verbatim_popup_srv( id = "warning", - verbatim_content = reactive(teal.code::get_warnings(all_q())), + verbatim_content = shiny::reactive(teal.code::get_warnings(all_q())), title = "Warning", - disabled = reactive(is.null(teal.code::get_warnings(all_q()))) + disabled = shiny::reactive(is.null(teal.code::get_warnings(all_q()))) ) teal.widgets::verbatim_popup_srv( id = "rcode", - verbatim_content = reactive(teal.code::get_code(all_q())), + verbatim_content = shiny::reactive(teal.code::get_code(all_q())), title = label ) diff --git a/R/tm_t_shift_by_arm.R b/R/tm_t_shift_by_arm.R index a15e1f7eac..33c700e5d8 100644 --- a/R/tm_t_shift_by_arm.R +++ b/R/tm_t_shift_by_arm.R @@ -364,7 +364,7 @@ ui_shift_by_arm <- function(id, ...) { ) ) ), - forms = tagList( + forms = shiny::tagList( teal.widgets::verbatim_popup_ui(ns("warning"), button_label = "Show Warnings"), teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code") ), @@ -394,9 +394,7 @@ srv_shift_by_arm <- function(id, with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") checkmate::assert_class(data, "tdata") shiny::moduleServer(id, function(input, output, session) { - anl_inputs <- teal.transform::merge_expression_module( - datasets = data, - join_keys = get_join_keys(data), + selector_list <- teal.transform::data_extract_multiple_srv( data_extract = list( arm_var = arm_var, paramcd = paramcd, @@ -405,6 +403,32 @@ srv_shift_by_arm <- function(id, base_var = base_var, treatment_flag_var = treatment_flag_var ), + datasets = data, + select_validation_rule = list( + aval_var = shinyvalidate::sv_required("An analysis range indicator required"), + arm_var = shinyvalidate::sv_required("A treatment variable is required"), + treatment_flag_var = shinyvalidate::sv_required("An on treatment flag variable is required"), + base_var = shinyvalidate::sv_required("A baseline reference range indicator is required") + ), + filter_validation_rule = list( + paramcd = shinyvalidate::sv_required("An endpoint is required"), + visit_var = shinyvalidate::sv_required("A visit is required") + ) + ) + + iv_r <- shiny::reactive({ + iv <- shinyvalidate::InputValidator$new() + iv$add_rule( + "treatment_flag", + shinyvalidate::sv_required("An indicator value for on treatment records is required") + ) + teal.transform::compose_and_enable_validators(iv, selector_list) + }) + + anl_inputs <- teal.transform::merge_expression_srv( + datasets = data, + join_keys = get_join_keys(data), + selector_list = selector_list, merge_function = "dplyr::inner_join" ) @@ -415,7 +439,7 @@ srv_shift_by_arm <- function(id, anl_name = "ANL_ADSL" ) - anl_q <- reactive({ + anl_q <- shiny::reactive({ teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) %>% teal.code::eval_code(as.expression(anl_inputs()$expr)) %>% teal.code::eval_code(as.expression(adsl_inputs()$expr)) @@ -429,6 +453,8 @@ srv_shift_by_arm <- function(id, # validate inputs validate_checks <- shiny::reactive({ + teal::validate_inputs(iv_r()) + adsl_filtered <- merged$anl_q()[[parentname]] anl_filtered <- merged$anl_q()[[dataname]] @@ -438,16 +464,13 @@ srv_shift_by_arm <- function(id, input_treatment_flag_var <- names(merged$anl_input_r()$columns_source$treatment_flag_var) shiny::validate( - shiny::need(input_arm_var, "Please select a treatment variable"), shiny::need( nrow(merged$anl_q()[["ANL"]]) > 0, paste0( "Please make sure the analysis dataset is not empty or\n", "endpoint parameter and analysis visit are selected." ) - ), - shiny::need(input_treatment_flag_var, "Please select an on treatment flag variable."), - shiny::need(input$treatment_flag, "Please select indicator value for on treatment records.") + ) ) validate_standard_inputs( @@ -492,15 +515,15 @@ srv_shift_by_arm <- function(id, # Render R code. teal.widgets::verbatim_popup_srv( id = "rcode", - verbatim_content = reactive(teal.code::get_code(all_q())), + verbatim_content = shiny::reactive(teal.code::get_code(all_q())), title = label ) teal.widgets::verbatim_popup_srv( id = "warning", - verbatim_content = reactive(teal.code::get_warnings(all_q())), + verbatim_content = shiny::reactive(teal.code::get_warnings(all_q())), title = "Warning", - disabled = reactive(is.null(teal.code::get_warnings(all_q()))) + disabled = shiny::reactive(is.null(teal.code::get_warnings(all_q()))) ) ### REPORTER diff --git a/R/tm_t_shift_by_arm_by_worst.R b/R/tm_t_shift_by_arm_by_worst.R index a842ebab4b..5e18bde679 100644 --- a/R/tm_t_shift_by_arm_by_worst.R +++ b/R/tm_t_shift_by_arm_by_worst.R @@ -387,7 +387,7 @@ ui_shift_by_arm_by_worst <- function(id, ...) { ) ) ), - forms = tagList( + forms = shiny::tagList( teal.widgets::verbatim_popup_ui(ns("warning"), button_label = "Show Warnings"), teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code") ), @@ -417,17 +417,41 @@ srv_shift_by_arm_by_worst <- function(id, with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") checkmate::assert_class(data, "tdata") shiny::moduleServer(id, function(input, output, session) { - anl_inputs <- teal.transform::merge_expression_module( - datasets = data, - join_keys = get_join_keys(data), + selector_list <- teal.transform::data_extract_multiple_srv( data_extract = list( arm_var = arm_var, - paramcd = paramcd, + treatment_flag_var = treatment_flag_var, worst_flag_var = worst_flag_var, aval_var = aval_var, base_var = base_var, - treatment_flag_var = treatment_flag_var + paramcd = paramcd + ), + datasets = data, + select_validation_rule = list( + arm_var = shinyvalidate::sv_required("A treatment variable is required"), + treatment_flag_var = shinyvalidate::sv_required("A treatment flag variable is required"), + worst_flag_var = shinyvalidate::sv_required("A worst flag variable is required"), + aval_var = shinyvalidate::sv_required("An analysis range indicator required"), + base_var = shinyvalidate::sv_required("A baseline reference range indicator is required") ), + filter_validation_rule = list( + paramcd = shinyvalidate::sv_required("An endpoint is required") + ) + ) + + iv_r <- shiny::reactive({ + iv <- shinyvalidate::InputValidator$new() + iv$add_rule( + "treatment_flag", + shinyvalidate::sv_required("An indicator value for on treatment records is required") + ) + teal.transform::compose_and_enable_validators(iv, selector_list) + }) + + anl_inputs <- teal.transform::merge_expression_srv( + datasets = data, + selector_list = selector_list, + join_keys = get_join_keys(data), merge_function = "dplyr::inner_join" ) @@ -438,7 +462,7 @@ srv_shift_by_arm_by_worst <- function(id, anl_name = "ANL_ADSL" ) - anl_q <- reactive({ + anl_q <- shiny::reactive({ teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) %>% teal.code::eval_code(as.expression(anl_inputs()$expr)) %>% teal.code::eval_code(as.expression(adsl_inputs()$expr)) @@ -452,17 +476,16 @@ srv_shift_by_arm_by_worst <- function(id, # validate inputs validate_checks <- shiny::reactive({ + teal::validate_inputs(iv_r()) + adsl_filtered <- merged$anl_q()[[parentname]] anl_filtered <- merged$anl_q()[[dataname]] input_arm_var <- names(merged$anl_input_r()$columns_source$arm_var) input_aval_var <- names(merged$anl_input_r()$columns_source$aval_var) input_base_var <- names(merged$anl_input_r()$columns_source$base_var) - input_treatment_flag_var <- names(merged$anl_input_r()$columns_source$treatment_flag_var) - input_worst_flag_var <- names(merged$anl_input_r()$columns_source$worst_flag_var) shiny::validate( - shiny::need(input_arm_var, "Please select a treatment variable"), shiny::need( nrow(merged$anl_q()[["ANL"]]) > 0, paste0( @@ -470,9 +493,6 @@ srv_shift_by_arm_by_worst <- function(id, "endpoint parameter and analysis visit are selected." ) ), - shiny::need(input_treatment_flag_var, "Please select an on treatment flag variable."), - shiny::need(input$treatment_flag, "Please select indicator value for on treatment records."), - shiny::need(input_worst_flag_var, "Please select a worst flag variable."), shiny::need( length(unique(merged$anl_q()[["ANL"]][[input_aval_var]])) < 50, paste( @@ -532,15 +552,15 @@ srv_shift_by_arm_by_worst <- function(id, teal.widgets::verbatim_popup_srv( id = "warning", - verbatim_content = reactive(teal.code::get_warnings(all_q())), + verbatim_content = shiny::reactive(teal.code::get_warnings(all_q())), title = "Warning", - disabled = reactive(is.null(teal.code::get_warnings(all_q()))) + disabled = shiny::reactive(is.null(teal.code::get_warnings(all_q()))) ) # Render R code. teal.widgets::verbatim_popup_srv( id = "rcode", - verbatim_content = reactive(teal.code::get_code(all_q())), + verbatim_content = shiny::reactive(teal.code::get_code(all_q())), title = label ) diff --git a/R/tm_t_shift_by_grade.R b/R/tm_t_shift_by_grade.R index 70755b5bd4..da0531d3d8 100644 --- a/R/tm_t_shift_by_grade.R +++ b/R/tm_t_shift_by_grade.R @@ -718,7 +718,7 @@ ui_t_shift_by_grade <- function(id, ...) { ) ) ), - forms = tagList( + forms = shiny::tagList( teal.widgets::verbatim_popup_ui(ns("warning"), button_label = "Show Warnings"), teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code") ), @@ -751,9 +751,7 @@ srv_t_shift_by_grade <- function(id, checkmate::assert_class(data, "tdata") shiny::moduleServer(id, function(input, output, session) { - anl_inputs <- teal.transform::merge_expression_module( - datasets = data, - join_keys = get_join_keys(data), + selector_list <- teal.transform::data_extract_multiple_srv( data_extract = list( arm_var = arm_var, visit_var = visit_var, @@ -763,6 +761,30 @@ srv_t_shift_by_grade <- function(id, anl_toxgrade_var = anl_toxgrade_var, base_toxgrade_var = base_toxgrade_var ), + datasets = data, + select_validation_rule = list( + base_toxgrade_var = shinyvalidate::sv_required("A baseline toxicity grade is required"), + anl_toxgrade_var = shinyvalidate::sv_required("An analysis toxicity grade is required"), + visit_var = shinyvalidate::sv_required("An analysis visit is required"), + arm_var = shinyvalidate::sv_required("A treatment variable is required"), + worst_flag_var = shinyvalidate::sv_required("A worst treatment flag is required"), + id_var = shinyvalidate::sv_required("A subject identifier is required.") + ), + filter_validation_rule = list( + paramcd = shinyvalidate::sv_required("A laboratory parameter is required") + ) + ) + + iv_r <- shiny::reactive({ + iv <- shinyvalidate::InputValidator$new() + iv$add_rule("worst_flag_indicator", shinyvalidate::sv_required("Please select the value indicating worst grade.")) + teal.transform::compose_and_enable_validators(iv, selector_list) + }) + + anl_inputs <- teal.transform::merge_expression_srv( + datasets = data, + join_keys = get_join_keys(data), + selector_list = selector_list, merge_function = "dplyr::inner_join" ) @@ -773,7 +795,7 @@ srv_t_shift_by_grade <- function(id, anl_name = "ANL_ADSL" ) - anl_q <- reactive({ + anl_q <- shiny::reactive({ teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) %>% teal.code::eval_code(as.expression(anl_inputs()$expr)) %>% teal.code::eval_code(as.expression(adsl_inputs()$expr)) @@ -786,6 +808,7 @@ srv_t_shift_by_grade <- function(id, ) validate_checks <- shiny::reactive({ + teal::validate_inputs(iv_r()) adsl_filtered <- merged$anl_q()[[parentname]] anl_filtered <- merged$anl_q()[[dataname]] @@ -798,13 +821,6 @@ srv_t_shift_by_grade <- function(id, input_anl_toxgrade_var <- names(merged$anl_input_r()$columns_source$anl_toxgrade_var) input_base_toxgrade_var <- names(merged$anl_input_r()$columns_source$base_toxgrade_var) - shiny::validate( - shiny::need(input_worst_flag_var, "Please select the worst flag variable."), - shiny::need(input_paramcd, "Please select Laboratory parameter."), - shiny::need(input_id_var, "Please select a subject identifier."), - shiny::need(input$worst_flag_indicator, "Please select the value indicating worst grade.") - ) - # validate inputs validate_standard_inputs( adsl = adsl_filtered, @@ -852,15 +868,15 @@ srv_t_shift_by_grade <- function(id, teal.widgets::verbatim_popup_srv( id = "warning", - verbatim_content = reactive(teal.code::get_warnings(all_q())), + verbatim_content = shiny::reactive(teal.code::get_warnings(all_q())), title = "Warning", - disabled = reactive(is.null(teal.code::get_warnings(all_q()))) + disabled = shiny::reactive(is.null(teal.code::get_warnings(all_q()))) ) # Render R code. teal.widgets::verbatim_popup_srv( id = "rcode", - verbatim_content = reactive(teal.code::get_code(all_q())), + verbatim_content = shiny::reactive(teal.code::get_code(all_q())), title = label ) diff --git a/R/tm_t_smq.R b/R/tm_t_smq.R index 6dd3f634d2..a8608dfbb4 100644 --- a/R/tm_t_smq.R +++ b/R/tm_t_smq.R @@ -509,7 +509,7 @@ ui_t_smq <- function(id, ...) { ) ) ), - forms = tagList( + forms = shiny::tagList( teal.widgets::verbatim_popup_ui(ns("warning"), button_label = "Show Warnings"), teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code") ), @@ -536,15 +536,35 @@ srv_t_smq <- function(id, with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") checkmate::assert_class(data, "tdata") shiny::moduleServer(id, function(input, output, session) { - anl_inputs <- teal.transform::merge_expression_module( - datasets = data, + selector_list <- teal.transform::data_extract_multiple_srv( data_extract = list( + scopes = scopes, + llt = llt, arm_var = arm_var, id_var = id_var, - baskets = baskets, - scopes = scopes, - llt = llt + baskets = baskets ), + datasets = data, + select_validation_rule = list( + scopes = shinyvalidate::sv_required("A scope variable is required"), + llt = shinyvalidate::sv_required("A low level term variable is required"), + arm_var = shinyvalidate::compose_rules( + shinyvalidate::sv_required("At least one treatment variable is required"), + ~ if (length(.) > 2) "Please select no more than two treatment variables" + ), + id_var = shinyvalidate::sv_required("An id variable is required"), + baskets = shinyvalidate::sv_required("At least one basket is required") + ) + ) + + iv_r <- shiny::reactive({ + iv <- shinyvalidate::InputValidator$new() + teal.transform::compose_and_enable_validators(iv, selector_list) + }) + + anl_inputs <- teal.transform::merge_expression_srv( + datasets = data, + selector_list = selector_list, join_keys = get_join_keys(data), merge_function = "dplyr::inner_join" ) @@ -556,7 +576,7 @@ srv_t_smq <- function(id, anl_name = "ANL_ADSL" ) - anl_q <- reactive({ + anl_q <- shiny::reactive({ teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) %>% teal.code::eval_code(as.expression(anl_inputs()$expr)) %>% teal.code::eval_code(as.expression(adsl_inputs()$expr)) @@ -569,6 +589,7 @@ srv_t_smq <- function(id, ) validate_checks <- shiny::reactive({ + teal::validate_inputs(iv_r()) adsl_filtered <- merged$anl_q()[[parentname]] anl_filtered <- merged$anl_q()[[dataname]] @@ -578,14 +599,6 @@ srv_t_smq <- function(id, input_scopes <- names(merged$anl_input_r()$columns_source$scopes) input_llt <- names(merged$anl_input_r()$columns_source$llt) - shiny::validate( - shiny::need(input_id_var, "Please select a subject identifier."), - shiny::need(length(input_arm_var) <= 2, "Please limit arm variables within two"), - shiny::need(input_baskets, "Please select the SMQ/CQ baskets."), - shiny::need(input_scopes, "Please select the scope variables."), - shiny::need(input_llt, "Please select the low level term."), - shiny::need(input_arm_var, "Please select the arm variable.") - ) # validate inputs validate_standard_inputs( adsl = adsl_filtered, @@ -629,15 +642,15 @@ srv_t_smq <- function(id, teal.widgets::verbatim_popup_srv( id = "warning", - verbatim_content = reactive(teal.code::get_warnings(all_q())), + verbatim_content = shiny::reactive(teal.code::get_warnings(all_q())), title = "Warning", - disabled = reactive(is.null(teal.code::get_warnings(all_q()))) + disabled = shiny::reactive(is.null(teal.code::get_warnings(all_q()))) ) # Render R code. teal.widgets::verbatim_popup_srv( id = "rcode", - verbatim_content = reactive(teal.code::get_code(all_q())), + verbatim_content = shiny::reactive(teal.code::get_code(all_q())), title = label ) diff --git a/R/tm_t_summary.R b/R/tm_t_summary.R index ba038f3c3f..e5ac78b6b2 100644 --- a/R/tm_t_summary.R +++ b/R/tm_t_summary.R @@ -397,7 +397,7 @@ ui_summary <- function(id, ...) { ) ) ), - forms = tagList( + forms = shiny::tagList( teal.widgets::verbatim_popup_ui(ns("warning"), button_label = "Show Warnings"), teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code") ), @@ -424,10 +424,27 @@ srv_summary <- function(id, with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") checkmate::assert_class(data, "tdata") shiny::moduleServer(id, function(input, output, session) { - anl_inputs <- teal.transform::merge_expression_module( + selector_list <- teal.transform::data_extract_multiple_srv( + data_extract = list(arm_var = arm_var, summarize_vars = summarize_vars), + datasets = data, + select_validation_rule = list( + summarize_vars = shinyvalidate::sv_required("Please select a summarize variable"), + arm_var = ~ if (length(.) != 1 && length(.) != 2) { + "Please select 1 or 2 column variables" + } + ) + ) + + iv_r <- shiny::reactive({ + iv <- shinyvalidate::InputValidator$new() + iv$add_rule("numeric_stats", shinyvalidate::sv_required("Please select at least one statistic to display.")) + teal.transform::compose_and_enable_validators(iv, selector_list) + }) + + anl_inputs <- teal.transform::merge_expression_srv( id = "anl_merge", datasets = data, - data_extract = list(arm_var = arm_var, summarize_vars = summarize_vars), + selector_list = selector_list, join_keys = get_join_keys(data), merge_function = "dplyr::inner_join" ) @@ -435,12 +452,12 @@ srv_summary <- function(id, adsl_inputs <- teal.transform::merge_expression_module( id = "adsl_merge", datasets = data, - join_keys = get_join_keys(data), data_extract = list(arm_var = arm_var), + join_keys = get_join_keys(data), anl_name = "ANL_ADSL" ) - anl_q <- reactive({ + anl_q <- shiny::reactive({ teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) %>% teal.code::eval_code(as.expression(anl_inputs()$expr)) %>% teal.code::eval_code(as.expression(adsl_inputs()$expr)) @@ -471,6 +488,7 @@ srv_summary <- function(id, # validate inputs validate_checks <- shiny::reactive({ + teal::validate_inputs(iv_r()) adsl_filtered <- merged$anl_q()[[parentname]] anl_filtered <- merged$anl_q()[[dataname]] anl <- merged$anl_q()[["ANL"]] @@ -488,24 +506,18 @@ srv_summary <- function(id, "i.e. USUBJID is different in each row" ) ), - shiny::need(input_arm_var, "Please select a treatment variable"), - shiny::need(input_summarize_vars, "Please select a summarize variable"), shiny::need( !any(vapply(anl_filtered[, input_summarize_vars], inherits, c("Date", "POSIXt"), FUN.VALUE = logical(1) )), "Date and POSIXt variables are not supported, please select other variables" ), - shiny::need(length(input_arm_var) <= 2, "Please limit column variables within two"), if (length(input_arm_var) == 2) { shiny::need( - is.factor(adsl_filtered[[input_arm_var[[2]]]]) & all(!adsl_filtered[[input_arm_var[[2]]]] %in% c( - "", NA - )), + is.factor(adsl_filtered[[input_arm_var[[2]]]]) & all(!adsl_filtered[[input_arm_var[[2]]]] %in% c("", NA)), "Please check nested treatment variable which needs to be a factor without NA or empty strings." ) - }, - shiny::need(!is.null(input$numeric_stats), "Please select at least one statistic to display.") + } ) validate_standard_inputs( @@ -548,15 +560,15 @@ srv_summary <- function(id, teal.widgets::verbatim_popup_srv( id = "warning", - verbatim_content = reactive(teal.code::get_warnings(all_q())), + verbatim_content = shiny::reactive(teal.code::get_warnings(all_q())), title = "Warning", - disabled = reactive(is.null(teal.code::get_warnings(all_q()))) + disabled = shiny::reactive(is.null(teal.code::get_warnings(all_q()))) ) # Render R code. teal.widgets::verbatim_popup_srv( id = "rcode", - verbatim_content = reactive(teal.code::get_code(all_q())), + verbatim_content = shiny::reactive(teal.code::get_code(all_q())), title = label ) diff --git a/R/tm_t_summary_by.R b/R/tm_t_summary_by.R index 989eadd34d..75c845dd9c 100644 --- a/R/tm_t_summary_by.R +++ b/R/tm_t_summary_by.R @@ -557,7 +557,7 @@ ui_summary_by <- function(id, ...) { ) ) ), - forms = tagList( + forms = shiny::tagList( teal.widgets::verbatim_popup_ui(ns("warning"), button_label = "Show Warnings"), teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code") ), @@ -590,14 +590,34 @@ srv_summary_by <- function(id, checkmate::assert_class(data, "tdata") shiny::moduleServer(id, function(input, output, session) { - vars <- list(arm_var = arm_var, id_var = id_var, by_vars = by_vars, summarize_vars = summarize_vars) + vars <- list(arm_var = arm_var, id_var = id_var, summarize_vars = summarize_vars, by_vars = by_vars) + if (!is.null(paramcd)) { vars[["paramcd"]] <- paramcd } - anl_inputs <- teal.transform::merge_expression_module( + validation_rules <- list( + arm_var = shinyvalidate::sv_required("Please select a treatment variable."), + id_var = shinyvalidate::sv_required("Please select a subject identifier."), + summarize_vars = shinyvalidate::sv_required("Please select a summarize variable.") + ) + + selector_list <- teal.transform::data_extract_multiple_srv( data_extract = vars, datasets = data, + select_validation_rule = validation_rules, + filter_validation_rule = list(paramcd = shinyvalidate::sv_required(message = "Please select a filter.")) + ) + + iv_r <- shiny::reactive({ + iv <- shinyvalidate::InputValidator$new() + iv$add_rule("numeric_stats", shinyvalidate::sv_required("Please select at least one statistic to display.")) + teal.transform::compose_and_enable_validators(iv, selector_list) + }) + + anl_inputs <- teal.transform::merge_expression_srv( + selector_list = selector_list, + datasets = data, join_keys = get_join_keys(data), merge_function = "dplyr::inner_join" ) @@ -610,7 +630,7 @@ srv_summary_by <- function(id, anl_name = "ANL_ADSL" ) - anl_q <- reactive({ + anl_q <- shiny::reactive({ teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) %>% teal.code::eval_code(as.expression(anl_inputs()$expr)) %>% teal.code::eval_code(as.expression(adsl_inputs()$expr)) @@ -624,6 +644,7 @@ srv_summary_by <- function(id, # Prepare the analysis environment (filter data, check data, populate envir). validate_checks <- shiny::reactive({ + teal::validate_inputs(iv_r()) adsl_filtered <- merged$anl_q()[[parentname]] anl_filtered <- merged$anl_q()[[dataname]] @@ -634,18 +655,6 @@ srv_summary_by <- function(id, input_paramcd <- `if`(is.null(paramcd), NULL, unlist(paramcd$filter)["vars_selected"]) # validate inputs - shiny::validate( - shiny::need(input_arm_var, "Please select a treatment variable."), - shiny::need(input_id_var, "Please select a subject identifier."), - shiny::need(input_summarize_vars, "Please select a summarize variable."), - if (!all(input_summarize_vars %in% names(adsl_filtered))) { - shiny::need( - input[[extract_input("paramcd", paramcd$filter[[1]]$dataname, filter = TRUE)]], - "`Select Endpoint` is not selected." - ) - }, - shiny::need(!is.null(input$numeric_stats), "Please select at least one statistic to display.") - ) validate_standard_inputs( adsl = adsl_filtered, adslvars = c("USUBJID", "STUDYID", input_arm_var), @@ -701,15 +710,15 @@ srv_summary_by <- function(id, teal.widgets::verbatim_popup_srv( id = "warning", - verbatim_content = reactive(teal.code::get_warnings(all_q())), + verbatim_content = shiny::reactive(teal.code::get_warnings(all_q())), title = "Warning", - disabled = reactive(is.null(teal.code::get_warnings(all_q()))) + disabled = shiny::reactive(is.null(teal.code::get_warnings(all_q()))) ) # Render R code. teal.widgets::verbatim_popup_srv( id = "rcode", - verbatim_content = reactive(teal.code::get_code(all_q())), + verbatim_content = shiny::reactive(teal.code::get_code(all_q())), title = label ) diff --git a/R/tm_t_tte.R b/R/tm_t_tte.R index e29f557832..6974e3b6a5 100644 --- a/R/tm_t_tte.R +++ b/R/tm_t_tte.R @@ -569,7 +569,7 @@ ui_t_tte <- function(id, ...) { condition = paste0("input['", ns("compare_arms"), "']"), shiny::div( shiny::uiOutput(ns("arms_buckets")), - shiny::helpText("Multiple reference groups are automatically combined into a single group."), + shiny::uiOutput(ns("helptext_ui")), shiny::checkboxInput( ns("combine_comp_arms"), "Combine all comparison groups?", @@ -687,7 +687,7 @@ ui_t_tte <- function(id, ...) { ) ) ), - forms = tagList( + forms = shiny::tagList( teal.widgets::verbatim_popup_ui(ns("warning"), button_label = "Show Warnings"), teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code") ), @@ -720,7 +720,7 @@ srv_t_tte <- function(id, shiny::moduleServer(id, function(input, output, session) { # Setup arm variable selection, default reference arms, and default # comparison arms for encoding panel - arm_ref_comp_observer( + iv_arm_ref <- arm_ref_comp_observer( session, input, output, @@ -731,8 +731,7 @@ srv_t_tte <- function(id, on_off = shiny::reactive(input$compare_arms) ) - anl_merge_inputs <- teal.transform::merge_expression_module( - datasets = data, + selector_list <- teal.transform::data_extract_multiple_srv( data_extract = list( arm_var = arm_var, paramcd = paramcd, @@ -742,6 +741,55 @@ srv_t_tte <- function(id, event_desc_var = event_desc_var, time_unit_var = time_unit_var ), + datasets = data, + select_validation_rule = list( + aval_var = shinyvalidate::sv_required("An analysis variable is required"), + cnsr_var = shinyvalidate::sv_required("A censor variable is required"), + arm_var = shinyvalidate::sv_required("A treatment variable is required"), + event_desc_var = shinyvalidate::sv_required("An event description variable is required"), + time_unit_var = shinyvalidate::sv_required("A Time unit variable is required") + ), + filter_validation_rule = list( + paramcd = shinyvalidate::sv_required("An endpoint is required") + ) + ) + + output$helptext_ui <- shiny::renderUI({ + shiny::req(selector_list()$arm_var()$select) + shiny::helpText("Multiple reference groups are automatically combined into a single group.") + }) + + iv_r <- shiny::reactive({ + iv <- shinyvalidate::InputValidator$new() + + if (isTRUE(input$compare_arms)) { + iv$add_validator(iv_arm_ref) + } + + iv$add_rule("conf_level_coxph", shinyvalidate::sv_required("Please choose a hazard ratio confidence level")) + iv$add_rule( + "conf_level_coxph", shinyvalidate::sv_between( + 0, 1, + message_fmt = "Hazard ratio confidence level must between 0 and 1" + ) + ) + iv$add_rule("conf_level_survfit", shinyvalidate::sv_required("Please choose a KM confidence level")) + iv$add_rule( + "conf_level_survfit", shinyvalidate::sv_between( + 0, 1, + message_fmt = "KM confidence level must between 0 and 1" + ) + ) + iv$add_rule( + "probs_survfit", + ~ if (!is.null(.) && .[1] == .[2]) "KM Estimate Percentiles cannot have a range of size 0" + ) + teal.transform::compose_and_enable_validators(iv, selector_list) + }) + + anl_merge_inputs <- teal.transform::merge_expression_srv( + datasets = data, + selector_list = selector_list, join_keys = get_join_keys(data), merge_function = "dplyr::inner_join" ) @@ -753,7 +801,7 @@ srv_t_tte <- function(id, anl_name = "ANL_ADSL" ) - anl_q <- reactive({ + anl_q <- shiny::reactive({ qenv <- teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) qenv1 <- teal.code::eval_code(qenv, as.expression(anl_merge_inputs()$expr)) teal.code::eval_code(qenv1, as.expression(adsl_merge_inputs()$expr)) @@ -761,6 +809,7 @@ srv_t_tte <- function(id, # Prepare the analysis environment (filter data, check data, populate envir). validate_checks <- shiny::reactive({ + teal::validate_inputs(iv_r()) adsl_filtered <- anl_q()[[parentname]] anl_filtered <- anl_q()[[dataname]] anl <- anl_q()[["ANL"]] @@ -799,36 +848,12 @@ srv_t_tte <- function(id, do.call(what = "validate_standard_inputs", validate_args) - shiny::validate(shiny::need( - input$conf_level_coxph >= 0 && input$conf_level_coxph <= 1, - "Please choose a confidence level between 0 and 1" - )) - - shiny::validate(shiny::need( - input$conf_level_survfit >= 0 && input$conf_level_survfit <= 1, - "Please choose a confidence level between 0 and 1" - )) - - shiny::validate( - shiny::need(checkmate::test_string(input_aval_var), "Analysis variable should be a single column.") - ) - shiny::validate(shiny::need(checkmate::test_string(input_cnsr_var), "Censor variable should be a single column.")) - shiny::validate(shiny::need( - checkmate::test_string(input_event_desc), - "Event description variable should be a single column." - )) - # check that there is at least one record with no missing data shiny::validate(shiny::need( !all(is.na(anl[[input_aval_var]])), "ANCOVA table cannot be calculated as all values are missing." )) - shiny::validate(shiny::need( - length(input[[extract_input("paramcd", paramcd$filter[[1]]$dataname, filter = TRUE)]]) > 0, - "`Select Endpoint` field is NULL" - )) - NULL }) @@ -886,14 +911,14 @@ srv_t_tte <- function(id, teal.widgets::verbatim_popup_srv( id = "warning", - verbatim_content = reactive(teal.code::get_warnings(all_q())), + verbatim_content = shiny::reactive(teal.code::get_warnings(all_q())), title = "Warning", - disabled = reactive(is.null(teal.code::get_warnings(all_q()))) + disabled = shiny::reactive(is.null(teal.code::get_warnings(all_q()))) ) teal.widgets::verbatim_popup_srv( id = "rcode", - verbatim_content = reactive(teal.code::get_code(all_q())), + verbatim_content = shiny::reactive(teal.code::get_code(all_q())), title = label ) diff --git a/R/utils.R b/R/utils.R index 535988ae70..3e9ac8a572 100644 --- a/R/utils.R +++ b/R/utils.R @@ -872,3 +872,13 @@ get_paramcd_label <- function(anl, paramcd) { label_paramcd }) } + +as_numeric_from_comma_sep_str <- function(input_string, sep = ",") { + if (!is.null(input_string) && trimws(input_string) != "") { + split_string <- unlist(strsplit(trimws(input_string), sep)) + split_as_numeric <- suppressWarnings(as.numeric(split_string)) + } else { + split_as_numeric <- NULL + } + return(split_as_numeric) +} diff --git a/man/arm_ref_comp_observer.Rd b/man/arm_ref_comp_observer.Rd index abc5b808a0..3cdf748d6e 100644 --- a/man/arm_ref_comp_observer.Rd +++ b/man/arm_ref_comp_observer.Rd @@ -49,40 +49,59 @@ stop the whole observer if FALSE.} \item{output_id}{(\code{character}) name of the UI id that the output will be written to.} } +\value{ +Returns a \code{shinyvalidate::InputValidator} which checks that there is at least one reference +and comparison arm +} \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}} Updates the reference and comparison Treatments when the selected Treatment variable changes } \examples{ -ds <- teal:::get_dummy_datasets() arm_ref_comp <- list(ARMCD = list(ref = "ARM A", comp = c("ARM B"))) -arm_var <- choices_selected(c("ARM", "ARMCD"), "ARM") -if (interactive()) { - shinyApp( - ui = fluidPage( +arm_var <- choices_selected(c("ARM", "ARMCD"), "ARMCD") + +adsl <- data.frame(ARM = c("ARM 1", "ARM 2"), ARMCD = c("ARM A", "ARM B")) + +ui <- fluidPage( + sidebarLayout( + sidebarPanel( teal.widgets::optionalSelectInput( "arm", "Treatment Variable", choices = arm_var$choices, selected = arm_var$selected ), - shiny::uiOutput("arms_buckets"), + shiny::uiOutput("arms_buckets") ), - server = function(input, output, session) { - shiny::isolate({ - teal.modules.clinical:::arm_ref_comp_observer( - session, - input, - output, - id_arm_var = "arm", - datasets = ds, - arm_ref_comp = arm_ref_comp, - module = "example" - ) - }) - } + mainPanel( + shiny::textOutput("result") + ) + ) +) + +server <- function(input, output, session) { + iv_arm_ref <- teal.modules.clinical:::arm_ref_comp_observer( + session, + input, + output, + id_arm_var = "arm", + data = adsl, + arm_ref_comp = arm_ref_comp, + module = "example" ) + + output$result <- shiny::renderText({ + iv <- shinyvalidate::InputValidator$new() + iv$add_validator(iv_arm_ref) + iv$enable() + teal::validate_inputs(iv) + "Valid selection has been made!" + }) +} +if (interactive()) { + shiny::shinyApp(ui, server) } } \keyword{internal} diff --git a/man/tm_t_abnormality_by_worst_grade.Rd b/man/tm_t_abnormality_by_worst_grade.Rd index c3becd48bc..802de2bc1b 100644 --- a/man/tm_t_abnormality_by_worst_grade.Rd +++ b/man/tm_t_abnormality_by_worst_grade.Rd @@ -95,7 +95,6 @@ For more details, see the vignette: \code{vignette("custom-basic-table-arguments Teal Module: Laboratory test results with highest grade post-baseline } \examples{ - library(scda) library(dplyr) diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R index b65b35776d..d7a617fd36 100644 --- a/tests/testthat/test-utils.R +++ b/tests/testthat/test-utils.R @@ -409,3 +409,18 @@ testthat::test_that("cs_to_des_select creates data_extract_spec with ordered = T ) ) }) + +testthat::test_that("as_numeric_from_comma_sep_str returns NULL if blank string or NULL entered", { + testthat::expect_null(as_numeric_from_comma_sep_str(NULL)) + testthat::expect_null(as_numeric_from_comma_sep_str(" ")) +}) + +testthat::test_that("as_numeric_from_comma_sep_str returns numeric vector of numbers", { + testthat::expect_equal(as_numeric_from_comma_sep_str("3,4,5.56"), c(3, 4, 5.56)) + testthat::expect_equal(as_numeric_from_comma_sep_str("3,4 ,v"), c(3, 4, NA)) +}) + +testthat::test_that("as_numeric_from_comma_sep_str respects sep argument", { + testthat::expect_equal(as_numeric_from_comma_sep_str("3,4,5", sep = ";"), as.numeric(NA)) + testthat::expect_equal(as_numeric_from_comma_sep_str("3 %% 4 %% 154.32", sep = "%%"), c(3, 4, 154.32)) +})