diff --git a/.github/workflows/check.yaml b/.github/workflows/check.yaml index 4e97c780..b39112e0 100644 --- a/.github/workflows/check.yaml +++ b/.github/workflows/check.yaml @@ -10,6 +10,7 @@ on: - ready_for_review branches: - main + - redesign_extraction@main push: branches: - main diff --git a/.lintr b/.lintr index 33fb8ec3..b26207c8 100644 --- a/.lintr +++ b/.lintr @@ -2,6 +2,7 @@ linters: linters_with_defaults( line_length_linter = line_length_linter(120), cyclocomp_linter = NULL, object_usage_linter = NULL, + pipe_consistency_linter = NULL, object_name_linter = object_name_linter( styles = c("snake_case", "symbols"), regexes = c(ANL = "^ANL_?[0-9A-Za-z_]*$", ADaM = "^r?AD[A-Z]{2,5}_?[0-9A-Za-z_]*$") diff --git a/DESCRIPTION b/DESCRIPTION index 27648b22..e1fb1474 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -25,6 +25,7 @@ Depends: R (>= 3.6), shiny (>= 1.8.1), teal (>= 1.1.0), + teal.picks (>= 0.1.0), teal.transform (>= 0.7.0) Imports: bslib (>= 0.8.0), @@ -46,23 +47,26 @@ Suggests: logger (>= 0.4.0), nestcolor (>= 0.1.0), rmarkdown (>= 2.23), + shinytest2 (>= 0.4.1), testthat (>= 3.2.3), withr (>= 3.0.0) Remotes: - insightsengineering/osprey + insightsengineering/osprey, + insightsengineering/teal.picks Config/Needs/verdepcheck: insightsengineering/osprey, rstudio/shiny, - insightsengineering/teal, insightsengineering/teal.slice, - insightsengineering/teal.transform, mllg/checkmate, tidyverse/dplyr, + insightsengineering/teal, insightsengineering/teal.picks, + insightsengineering/teal.slice, insightsengineering/teal.transform, + mllg/checkmate, tidyverse/dplyr, insightsengineering/formatters, tidyverse/ggplot2, r-lib/lifecycle, daroczig/logger, rstudio/shinyvalidate, insightsengineering/teal.code, insightsengineering/teal.logger, insightsengineering/teal.reporter, insightsengineering/teal.widgets, insightsengineering/tern, tidyverse/tidyr, yihui/knitr, insightsengineering/nestcolor, - rstudio/rmarkdown, insightsengineering/teal.data, r-lib/testthat, + rstudio/rmarkdown, rstudio/shinytest2, insightsengineering/teal.data, r-lib/testthat, r-lib/withr Config/Needs/website: insightsengineering/nesttemplate Encoding: UTF-8 Language: en-US LazyData: true Roxygen: list(markdown = TRUE) -RoxygenNote: 7.3.3 +Config/roxygen2/version: 8.0.0 diff --git a/NAMESPACE b/NAMESPACE index 9d07d672..18f3d101 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -8,6 +8,7 @@ export(tm_g_ae_oview) export(tm_g_ae_sub) export(tm_g_butterfly) export(tm_g_events_term_id) +export(tm_g_events_term_id.picks) export(tm_g_heat_bygrade) export(tm_g_patient_profile) export(tm_g_spiderplot) @@ -19,4 +20,5 @@ import(formatters) import(osprey) import(shiny) import(teal) +import(teal.picks) import(teal.transform) diff --git a/NEWS.md b/NEWS.md index f0d8b7be..b8b1b3f2 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,8 @@ # teal.osprey 0.4.0.9002 +- Migrated modules from `teal.transform` to `teal.picks`. +- Added shinytest2 tests. + # teal.osprey 0.4.0 diff --git a/R/teal.osprey.R b/R/teal.osprey.R index 1831c221..13d3fb10 100644 --- a/R/teal.osprey.R +++ b/R/teal.osprey.R @@ -4,6 +4,6 @@ #' the analysis functions from `osprey` package. See package [website](https://insightsengineering.github.io/osprey/). #' This enables `teal` app developers to easily create applications making use of the `osprey` analysis functions. #' -#' @import dplyr osprey shiny teal formatters teal.transform +#' @import dplyr osprey shiny teal formatters teal.picks teal.transform #' @keywords internal "_PACKAGE" diff --git a/R/tm_g_ae_oview.R b/R/tm_g_ae_oview.R index 67126e8d..f40cdf29 100644 --- a/R/tm_g_ae_oview.R +++ b/R/tm_g_ae_oview.R @@ -7,15 +7,16 @@ #' @inheritParams teal.widgets::standard_layout #' @inheritParams teal::module #' @inheritParams argument_convention -#' @param flag_var_anl ([`teal.transform::choices_selected`]) -#' `choices_selected` object with variables used to count adverse event +#' @param flag_var_anl Either a ([`teal.transform::choices_selected`]) +#' `choices_selected` object or a (`[teal.picks::variables()]`) +#' object with variables used to count adverse event #' sub-groups (e.g. Serious events, Related events, etc.) -#' +#' @param dataname (`character(1)`) Name of the events dataset. Required when +#' using the default method with [choices_selected][teal.transform::choices_selected()]. +#' Ignored by the `.picks` method. #' @inherit argument_convention return #' @inheritSection teal::example_module Reporting #' -#' @export -#' #' @examples #' data <- teal_data() %>% #' within({ @@ -43,27 +44,21 @@ #' } #' ADAE <- .add_event_flags(ADAE) #' }) -#' #' join_keys(data) <- default_cdisc_join_keys[names(data)] -#' #' ADAE <- data[["ADAE"]] -#' #' app <- init( #' data = data, #' modules = modules( #' tm_g_ae_oview( #' label = "AE Overview", #' dataname = "ADAE", -#' arm_var = choices_selected( -#' selected = "ACTARM", -#' choices = c("ACTARM", "ACTARMCD") +#' arm_var = variables( +#' choices = dplyr::starts_with("ACTARM"), +#' selected = "ACTARMCD" #' ), -#' flag_var_anl = choices_selected( -#' selected = "AEREL1", -#' choices = variable_choices( -#' ADAE, -#' c("TMPFL_SER", "TMPFL_REL", "TMPFL_GR5", "AEREL1", "AEREL2") -#' ), +#' flag_var_anl = variables( +#' choices = c("TMPFL_SER", "TMPFL_REL", "TMPFL_GR5", "AEREL1", "AEREL2"), +#' selected = "AEREL1" #' ), #' plot_height = c(600, 200, 2000) #' ) @@ -72,36 +67,84 @@ #' if (interactive()) { #' shinyApp(app$ui, app$server) #' } -#' -tm_g_ae_oview <- function(label, - dataname, - arm_var, - flag_var_anl, - fontsize = c(5, 3, 7), - plot_height = c(600L, 200L, 2000L), - plot_width = NULL, - transformators = list()) { +#' @export +tm_g_ae_oview <- function( + label, + dataname, + arm_var, + flag_var_anl, + fontsize = c(5, 3, 7), + plot_height = c(600L, 200L, 2000L), + plot_width = NULL, + transformators = list() +) { message("Initializing tm_g_ae_oview") - checkmate::assert_class(arm_var, classes = "choices_selected") - checkmate::assert_class(flag_var_anl, classes = "choices_selected") + + arm_var <- migrate_choices_selected_to_variables(arm_var) + flag_var_anl <- migrate_choices_selected_to_variables(flag_var_anl) + + arm_var <- create_picks_helper(teal.picks::datasets(dataname), arm_var) + flag_var_anl <- create_picks_helper(teal.picks::datasets(dataname), flag_var_anl) + + if (teal.picks::is_pick_multiple(arm_var$variables)) { + warning( + "`arm_var` accepts only a single variable selection. ", + "Forcing `teal.picks::variables(multiple)` to FALSE." + ) + attr(arm_var$variables, "multiple") <- FALSE + } + + if (teal.picks::is_pick_multiple(flag_var_anl$variables)) { + warning( + "`flag_var_anl` accepts only a single variable selection. ", + "Forcing `teal.picks::variables(multiple)` to FALSE." + ) + attr(flag_var_anl$variables, "multiple") <- FALSE + } + checkmate::assert( checkmate::check_number(fontsize, finite = TRUE), checkmate::assert( combine = "and", .var.name = "fontsize", - checkmate::check_numeric(fontsize, len = 3, any.missing = FALSE, finite = TRUE), - checkmate::check_numeric(fontsize[1], lower = fontsize[2], upper = fontsize[3]) + checkmate::check_numeric( + fontsize, + len = 3, + any.missing = FALSE, + finite = TRUE + ), + checkmate::check_numeric( + fontsize[1], + lower = fontsize[2], + upper = fontsize[3] + ) ) ) - checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) - checkmate::assert_numeric(plot_height[1], - lower = plot_height[2], upper = plot_height[3], + checkmate::assert_numeric( + plot_height, + len = 3, + any.missing = FALSE, + finite = TRUE + ) + checkmate::assert_numeric( + plot_height[1], + lower = plot_height[2], + upper = plot_height[3], .var.name = "plot_height" ) - checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) + checkmate::assert_numeric( + plot_width, + len = 3, + any.missing = FALSE, + null.ok = TRUE, + finite = TRUE + ) checkmate::assert_numeric( plot_width[1], - lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" + lower = plot_width[2], + upper = plot_width[3], + null.ok = TRUE, + .var.name = "plot_width" ) args <- as.list(environment()) @@ -109,52 +152,45 @@ tm_g_ae_oview <- function(label, module( label = label, server = srv_g_ae_oview, - server_args = list( - label = label, - dataname = dataname, - plot_height = plot_height, - plot_width = plot_width - ), + server_args = args[names(args) %in% names(formals(srv_g_ae_oview))], ui = ui_g_ae_oview, - ui_args = args, + ui_args = args[names(args) %in% names(formals(ui_g_ae_oview))], transformators = transformators, datanames = c("ADSL", dataname) ) } -ui_g_ae_oview <- function(id, ...) { +ui_g_ae_oview <- function( + id, + arm_var, + flag_var_anl, + fontsize +) { ns <- NS(id) - args <- list(...) + teal.widgets::standard_layout( output = teal.widgets::white_small_well( plot_decorate_output(id = ns(NULL)) ), encoding = tags$div( - teal.widgets::optionalSelectInput( - ns("arm_var"), - "Arm Variable", - choices = get_choices(args$arm_var$choices), - selected = args$arm_var$selected, - multiple = FALSE + tags$label("Encodings", class = "text-primary"), + tags$div( + tags$strong("Arm variable"), + teal.picks::picks_ui(id = ns("arm_var"), picks = arm_var) + ), + tags$div( + tags$strong("Flag variables"), + teal.picks::picks_ui(id = ns("flag_var_anl"), picks = flag_var_anl) ), selectInput( ns("arm_ref"), "Control", - choices = get_choices(args$arm_var$choices), - selected = args$arm_var$selected + choices = NULL ), selectInput( ns("arm_trt"), "Treatment", - choices = get_choices(args$arm_var$choices), - selected = args$arm_var$selected - ), - selectInput( - ns("flag_var_anl"), - "Flags", - choices = get_choices(args$flag_var_anl$choices), - selected = args$flag_var_anl$selected, - multiple = TRUE + choices = NULL ), teal.widgets::panel_item( "Confidence interval settings", @@ -182,7 +218,7 @@ ui_g_ae_oview <- function(id, ...) { ), ui_g_decorate( ns(NULL), - fontsize = args$fontsize, + fontsize = fontsize, titles = "AE Overview", footnotes = "" ) @@ -190,45 +226,42 @@ ui_g_ae_oview <- function(id, ...) { ) } -srv_g_ae_oview <- function(id, - data, - dataname, - label, - plot_height, - plot_width) { +srv_g_ae_oview <- function( + id, + data, + arm_var, + flag_var_anl, + plot_height, + plot_width +) { checkmate::assert_class(data, "reactive") checkmate::assert_class(isolate(data()), "teal_data") moduleServer(id, function(input, output, session) { - teal.logger::log_shiny_input_changes(input, namespace = "teal.osprey") - iv <- reactive({ - ANL <- data()[[dataname]] + # Initialize picks selectors + selectors <- teal.picks::picks_srv( + picks = list( + arm_var = arm_var, + flag_var_anl = flag_var_anl + ), + data = data + ) - iv <- shinyvalidate::InputValidator$new() - iv$add_rule("arm_var", shinyvalidate::sv_required( - message = "Arm Variable is required" - )) - iv$add_rule("arm_var", ~ if (!is.factor(ANL[[.]])) { - "Arm Var must be a factor variable" - }) - iv$add_rule("arm_var", ~ if (nlevels(ANL[[.]]) < 2L) { - "Selected Arm Var must have at least two levels" - }) - iv$add_rule("flag_var_anl", shinyvalidate::sv_required( - message = "At least one Flag is required" - )) - rule_diff <- function(value, other) { - if (isTRUE(value == other)) "Control and Treatment must be different" - } - iv$add_rule("arm_trt", rule_diff, other = input$arm_ref) - iv$add_rule("arm_ref", rule_diff, other = input$arm_trt) - iv$enable() - iv - }) + # Merge datasets based on picks selections + merged <- teal.picks::merge_srv( + "merge", + data = data, + selectors = selectors, + output_name = "ANL" + ) + + teal.logger::log_shiny_input_changes(input, namespace = "teal.osprey") decorate_output <- srv_g_decorate( - id = NULL, plt = plot_r, - plot_height = plot_height, plot_width = plot_width + id = NULL, + plt = plot_r, + plot_height = plot_height, + plot_width = plot_width ) font_size <- decorate_output$font_size pws <- decorate_output$pws @@ -237,7 +270,8 @@ srv_g_ae_oview <- function(id, req(!is.null(input$diff_ci_method) && !is.null(input$conf_level)) diff_ci_method <- input$diff_ci_method conf_level <- input$conf_level - updateTextAreaInput(session, + updateTextAreaInput( + session, "foot", value = sprintf( "Note: %d%% CI is calculated using %s", @@ -247,11 +281,13 @@ srv_g_ae_oview <- function(id, ) }) - observeEvent(input$arm_var, ignoreNULL = TRUE, { - ANL <- data()[[dataname]] - arm_var <- input$arm_var - arm_val <- ANL[[arm_var]] - choices <- levels(arm_val) + observeEvent(merged$variables()$arm_var, { + arm_var_name <- merged$variables()$arm_var + arm_dataset <- selectors$arm_var()$datasets$selected + req(arm_var_name, arm_dataset) + + arm_data <- data()[[arm_dataset]] + choices <- levels(arm_data[[arm_var_name]]) if (length(choices) == 1) { trt_index <- 1 @@ -276,48 +312,77 @@ srv_g_ae_oview <- function(id, output_q <- shiny::debounce( millis = 200, r = reactive({ - obj <- data() - teal.reporter::teal_card(obj) <- + qenv <- merged$data() + + arm_var_name <- selectors$arm_var()$variables$selected + arm_dataset <- selectors$arm_var()$datasets$selected + + teal.reporter::teal_card(qenv) <- c( - teal.reporter::teal_card(obj), + teal.reporter::teal_card(qenv), teal.reporter::teal_card("## Module's output(s)") ) - obj <- teal.code::eval_code(obj, "library(dplyr)") + qenv <- teal.code::eval_code(qenv, "library(dplyr)") + + ANL <- qenv[["ANL"]] - ANL <- obj[[dataname]] + arm_var_name <- merged$variables()$arm_var + flag_var_name <- merged$variables()$flag_var_anl - teal::validate_has_data(ANL, min_nrow = 10, msg = sprintf("%s has not enough data", dataname)) + teal::validate_has_data( + ANL, + min_nrow = 10, + msg = "Analysis data set must have at least 10 data points" + ) - teal::validate_inputs(iv()) + # Original variable name and dataset for arm_N calculation on the source dataset + arm_var_orig <- selectors$arm_var()$variables$selected + arm_dataset <- selectors$arm_var()$datasets$selected + + shiny::validate( + shiny::need( + length(flag_var_name) > 0, + "A Flag Variable needs to be selected." + ), + shiny::need( + length(arm_var_name) > 0, + "An Arm Variable needs to be selected." + ) + ) validate(need( - input$arm_trt %in% ANL[[input$arm_var]] && input$arm_ref %in% ANL[[input$arm_var]], + input$arm_trt %in% + ANL[[arm_var_name]] && + input$arm_ref %in% ANL[[arm_var_name]], "Treatment or Control not found in Arm Variable. Perhaps they have been filtered out?" )) - - q1 <- obj %>% + q1 <- qenv %>% teal.code::eval_code( code = as.expression(c( - bquote(anl_labels <- formatters::var_labels(.(as.name(dataname)), fill = FALSE)), + bquote(anl_labels <- formatters::var_labels(ANL, fill = FALSE)), bquote( - flags <- .(as.name(dataname)) %>% - select(all_of(.(input$flag_var_anl))) %>% - rename_at(vars(.(input$flag_var_anl)), function(x) paste0(x, ": ", anl_labels[x])) + flags <- ANL %>% + select(all_of(.(flag_var_name))) %>% + rename_at(.(flag_var_name), function(x) { + paste0(x, ": ", anl_labels[x]) + }) ) )) ) - teal.reporter::teal_card(q1) <- c(teal.reporter::teal_card(q1), "### Plot") - + teal.reporter::teal_card(q1) <- c( + teal.reporter::teal_card(q1), + "### Plot" + ) teal.code::eval_code( q1, code = as.expression(c( bquote( plot <- osprey::g_events_term_id( term = flags, - id = .(as.name(dataname))[["USUBJID"]], - arm = .(as.name(dataname))[[.(input$arm_var)]], - arm_N = table(ADSL[[.(input$arm_var)]]), + id = ANL$USUBJID, + arm = ANL[[.(arm_var_name)]], + arm_N = table(ANL[[.(arm_var_name)]]), ref = .(input$arm_ref), trt = .(input$arm_trt), diff_ci_method = .(input$diff_ci_method), diff --git a/R/tm_g_events_term_id.R b/R/tm_g_events_term_id.R index 5a9cea52..6d4db895 100644 --- a/R/tm_g_events_term_id.R +++ b/R/tm_g_events_term_id.R @@ -1,14 +1,15 @@ #' Events by Term Plot Teal Module #' -#' @description -#' -#' Display Events by Term plot as a shiny module +#' Display an events-by-term plot as a Shiny module using [teal.picks::picks()] encodings. #' #' @inheritParams teal.widgets::standard_layout #' @inheritParams teal::module #' @inheritParams argument_convention -#' @param term_var [teal.transform::choices_selected] object with all available choices -#' and pre-selected option names that can be used to specify the term for events +#' @param term_var (`picks`)\cr +#' [teal.picks::picks()] object for the event term variable (single selection). +#' @param arm_var (`picks`)\cr +#' [teal.picks::picks()] object for the treatment arm variable (single selection). +#' The arm variable must be a factor in the analysis data. #' #' @inherit argument_convention return #' @inheritSection teal::example_module Reporting @@ -32,17 +33,19 @@ #' modules = modules( #' tm_g_events_term_id( #' label = "Common AE", -#' dataname = "ADAE", -#' term_var = choices_selected( -#' selected = "AEDECOD", -#' choices = c( -#' "AEDECOD", "AETERM", -#' "AEHLT", "AELLT", "AEBODSYS" +#' term_var = teal.picks::picks( +#' teal.picks::datasets("ADAE"), +#' teal.picks::variables( +#' choices = teal.picks::is_categorical(min.len = 2), +#' selected = "AEDECOD" #' ) #' ), -#' arm_var = choices_selected( -#' selected = "ACTARMCD", -#' choices = c("ACTARM", "ACTARMCD") +#' arm_var = teal.picks::picks( +#' teal.picks::datasets("ADSL"), +#' teal.picks::variables( +#' choices = teal.picks::is_categorical(min.len = 2), +#' selected = "ACTARMCD" +#' ) #' ), #' plot_height = c(600, 200, 2000) #' ) @@ -52,18 +55,38 @@ #' shinyApp(app$ui, app$server) #' } #' -tm_g_events_term_id <- function(label, - dataname, - term_var, - arm_var, +tm_g_events_term_id <- function(label = "Common AE", + term_var = teal.picks::picks( + teal.picks::datasets(), + teal.picks::variables( + choices = teal.picks::is_categorical(min.len = 2), + selected = 1L + ) + ), + arm_var = teal.picks::picks( + teal.picks::datasets(), + teal.picks::variables( + choices = teal.picks::is_categorical(min.len = 2), + selected = 1L + ) + ), fontsize = c(5, 3, 7), plot_height = c(600L, 200L, 2000L), plot_width = NULL, transformators = list()) { - message("Initializing tm_g_events_term_id") checkmate::assert_string(label) - checkmate::assert_class(term_var, classes = "choices_selected") - checkmate::assert_class(arm_var, classes = "choices_selected") + + checkmate::assert_class(term_var, "picks", .var.name = "term_var") + checkmate::assert_false( + teal.picks::is_pick_multiple(term_var$variables), + .var.name = "`term_var` must use variables(..., multiple = FALSE)" + ) + checkmate::assert_class(arm_var, "picks", .var.name = "arm_var") + checkmate::assert_false( + teal.picks::is_pick_multiple(arm_var$variables), + .var.name = "`arm_var` must use variables(..., multiple = FALSE)" + ) + checkmate::assert( checkmate::check_number(fontsize, finite = TRUE), checkmate::assert( @@ -74,60 +97,61 @@ tm_g_events_term_id <- function(label, ) ) checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) - checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") + checkmate::assert_numeric( + plot_height[1], + lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height" + ) checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) checkmate::assert_numeric( plot_width[1], - lower = plot_width[2], - upper = plot_width[3], - null.ok = TRUE, - .var.name = "plot_width" + lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" ) + pick_slots <- list(term_var = term_var, arm_var = arm_var) + all_datanames <- .picks_all_datanames(pick_slots) + args <- as.list(environment()) module( label = label, - server = srv_g_events_term_id, - server_args = list(label = label, dataname = dataname, plot_height = plot_height, plot_width = plot_width), ui = ui_g_events_term_id, - ui_args = args, + server = srv_g_events_term_id, + ui_args = args[names(args) %in% names(formals(ui_g_events_term_id))], + server_args = args[names(args) %in% names(formals(srv_g_events_term_id))], transformators = transformators, - datanames = c("ADSL", dataname) + datanames = all_datanames ) } -ui_g_events_term_id <- function(id, ...) { +#' @keywords internal +ui_g_events_term_id <- function(id, + term_var, + arm_var, + fontsize) { ns <- NS(id) - args <- list(...) teal.widgets::standard_layout( output = teal.widgets::white_small_well( plot_decorate_output(id = ns(NULL)) ), encoding = tags$div( - teal.widgets::optionalSelectInput( - ns("term"), - "Term Variable", - choices = get_choices(args$term_var$choices), - selected = args$term_var$selected + tags$label("Encodings", class = "text-primary"), tags$br(), + tags$div( + tags$label("Term variable"), + teal.picks::picks_ui(id = ns("term_var"), picks = term_var) ), - teal.widgets::optionalSelectInput( - ns("arm_var"), - "Arm Variable", - choices = get_choices(args$arm_var$choices), - selected = args$arm_var$selected + tags$div( + tags$label("Arm variable"), + teal.picks::picks_ui(id = ns("arm_var"), picks = arm_var) ), selectInput( ns("arm_ref"), "Control", - choices = get_choices(args$arm_var$choices), - selected = args$arm_var$selected + choices = NULL ), selectInput( ns("arm_trt"), "Treatment", - choices = get_choices(args$arm_var$choices), - selected = args$arm_var$selected + choices = NULL ), teal.widgets::optionalSelectInput( ns("sort"), @@ -179,14 +203,15 @@ ui_g_events_term_id <- function(id, ...) { value = c(-0.5, 0.5), step = 0.01 ), - checkboxInput(ns("reverse"), + checkboxInput( + ns("reverse"), "Reverse Order", value = FALSE ) ), ui_g_decorate( ns(NULL), - fontsize = args$fontsize, + fontsize = fontsize, titles = "Common AE Table", footnotes = "" ) @@ -194,87 +219,58 @@ ui_g_events_term_id <- function(id, ...) { ) } +#' @keywords internal srv_g_events_term_id <- function(id, data, - dataname, - label, + term_var, + arm_var, plot_height, plot_width) { checkmate::assert_class(data, "reactive") - checkmate::assert_class(shiny::isolate(data()), "teal_data") + checkmate::assert_class(isolate(data()), "teal_data") moduleServer(id, function(input, output, session) { teal.logger::log_shiny_input_changes(input, namespace = "teal.osprey") - iv <- reactive({ - iv <- shinyvalidate::InputValidator$new() - iv$add_rule("term", shinyvalidate::sv_required( - message = "Term Variable is required" - )) - iv$add_rule("arm_var", shinyvalidate::sv_required( - message = "Arm Variable is required" - )) - rule_diff <- function(value, other) { - if (isTRUE(value == other)) "Control and Treatment must be different" - } - iv$add_rule("arm_trt", rule_diff, other = input$arm_ref) - iv$add_rule("arm_ref", rule_diff, other = input$arm_trt) - iv$enable() - iv - }) - decorate_output <- srv_g_decorate( - id = NULL, plt = plot_r, plot_height = plot_height, plot_width = plot_width + anl_selectors <- teal.picks::picks_srv( + id = "", + picks = list(term_var = term_var, arm_var = arm_var), + data = data ) - font_size <- decorate_output$font_size - pws <- decorate_output$pws - observeEvent(list(input$diff_ci_method, input$conf_level), { - req(!is.null(input$diff_ci_method) && !is.null(input$conf_level)) - diff_ci_method <- input$diff_ci_method - conf_level <- input$conf_level - updateTextAreaInput( - session, - "foot", - value = sprintf( - "Note: %d%% CI is calculated using %s", - round(conf_level * 100), - name_ci(diff_ci_method) + data_with_card <- reactive({ + obj <- data() + teal.reporter::teal_card(obj) <- + c( + teal.reporter::teal_card(obj), + teal.reporter::teal_card("## Module's output(s)") ) - ) + obj }) - observeEvent(input$sort, - { - sort <- if (is.null(input$sort)) " " else input$sort - updateTextInput( - session, - "title", - value = sprintf( - "Common AE Table %s", - c( - "term" = "Sorted by Term", - "riskdiff" = "Sorted by Risk Difference", - "meanrisk" = "Sorted by Mean Risk", - " " = "" - )[sort] - ) - ) - }, - ignoreNULL = FALSE + merged_anl <- teal.picks::merge_srv( + "merge_anl", + data = data_with_card, + selectors = anl_selectors, + output_name = "ANL", + join_fun = "dplyr::inner_join" ) - observeEvent(input$arm_var, + anl_q <- merged_anl$data + merge_vars <- merged_anl$variables + + observeEvent(anl_selectors$arm_var(), { - arm_var <- input$arm_var - ANL <- data()[[dataname]] + arm_selector <- anl_selectors$arm_var() + req(arm_selector) + arm_var_name <- arm_selector$variables$selected + arm_dataset <- arm_selector$datasets$selected + req(arm_var_name, arm_dataset) - choices <- levels(ANL[[arm_var]]) + arm_data <- data()[[arm_dataset]] + choices <- levels(arm_data[[arm_var_name]]) - if (length(choices) == 1) { - trt_index <- 1 - } else { - trt_index <- 2 - } + trt_index <- if (length(choices) == 1L) 1L else 2L updateSelectInput( session, @@ -292,57 +288,104 @@ srv_g_events_term_id <- function(id, ignoreNULL = TRUE ) - output_q <- reactive({ - obj <- data() - teal.reporter::teal_card(obj) <- - c( - teal.reporter::teal_card(obj), - teal.reporter::teal_card("## Module's output(s)") + observeEvent(input$sort, + { + sort <- if (is.null(input$sort)) " " else input$sort + updateTextInput( + session, + "title", + value = sprintf( + "Common AE Table %s", + c( + "term" = "Sorted by Term", + "riskdiff" = "Sorted by Risk Difference", + "meanrisk" = "Sorted by Mean Risk", + " " = "" + )[sort] + ) ) + }, + ignoreNULL = FALSE + ) - ANL <- obj[[dataname]] + observeEvent(list(input$diff_ci_method, input$conf_level), { + req(!is.null(input$diff_ci_method) && !is.null(input$conf_level)) + diff_ci_method <- input$diff_ci_method + conf_level <- input$conf_level + updateTextAreaInput( + session, + "foot", + value = sprintf( + "Note: %d%% CI is calculated using %s", + round(conf_level * 100), + name_ci(diff_ci_method) + ) + ) + }) - teal::validate_inputs(iv()) + decorate_output <- srv_g_decorate( + id = NULL, + plt = plot_r, + plot_height = plot_height, + plot_width = plot_width + ) + font_size <- decorate_output$font_size + pws <- decorate_output$pws - shiny::validate( - shiny::need(is.factor(ANL[[input$arm_var]]), "Arm Var must be a factor variable. Contact developer."), - shiny::need( - input$arm_trt %in% ANL[[req(input$arm_var)]] && input$arm_ref %in% ANL[[req(input$arm_var)]], - "Cannot generate plot. The dataset does not contain subjects from both the control and treatment arms." + output_q <- reactive({ + merged_vars <- merge_vars() + validate( + need( + length(merged_vars[["term_var"]]) > 0L, + "Please select a term variable" + ), + need( + length(merged_vars[["arm_var"]]) > 0L, + "Please select an arm variable" ) ) - adsl_vars <- unique(c("USUBJID", "STUDYID", input$arm_var)) - anl_vars <- c("USUBJID", "STUDYID", input$term) + term_var_name <- merged_vars[["term_var"]][[1L]] + arm_var_name <- merged_vars[["arm_var"]][[1L]] - q1 <- teal.code::eval_code( - obj, - code = bquote( - ANL <- merge( - x = ADSL[, .(adsl_vars), drop = FALSE], - y = .(as.name(dataname))[, .(anl_vars), drop = FALSE], - all.x = FALSE, - all.y = FALSE, - by = c("USUBJID", "STUDYID") - ) + arm_selector <- anl_selectors$arm_var() + arm_var_orig <- arm_selector$variables$selected + arm_dataset <- arm_selector$datasets$selected + + qenv <- anl_q() + ANL <- qenv[["ANL"]] + + validate( + need( + is.factor(ANL[[arm_var_name]]), + "Arm Variable must be a factor variable." + ), + need( + input$arm_trt %in% ANL[[arm_var_name]] && input$arm_ref %in% ANL[[arm_var_name]], + "Cannot generate plot. The dataset does not contain subjects from both the control and treatment arms." + ), + need( + !isTRUE(input$arm_trt == input$arm_ref), + "Control and Treatment must be different." ) ) - teal::validate_has_data(q1[["ANL"]], + teal::validate_has_data( + ANL, min_nrow = 10, msg = "Analysis data set must have at least 10 data points" ) - teal.reporter::teal_card(q1) <- c(teal.reporter::teal_card(q1), "### Plot") + teal.reporter::teal_card(qenv) <- c(teal.reporter::teal_card(qenv), "### Plot") - q2 <- teal.code::eval_code( - q1, + teal.code::eval_code( + qenv, code = bquote( plot <- osprey::g_events_term_id( - term = ANL[[.(input$term)]], + term = ANL[[.(term_var_name)]], id = ANL$USUBJID, - arm = ANL[[.(input$arm_var)]], - arm_N = table(ADSL[[.(input$arm_var)]]), + arm = ANL[[.(arm_var_name)]], + arm_N = table(.(as.name(arm_dataset))[[.(arm_var_orig)]]), ref = .(input$arm_ref), trt = .(input$arm_trt), sort_by = .(input$sort), diff --git a/R/tm_g_events_term_id_picks.R b/R/tm_g_events_term_id_picks.R new file mode 100644 index 00000000..b7690129 --- /dev/null +++ b/R/tm_g_events_term_id_picks.R @@ -0,0 +1,407 @@ +#' @describeIn tm_g_events_term_id [teal.picks::picks()]-based encodings (`picks`). +#' @export +tm_g_events_term_id.picks <- function(label = "Common AE", # nolint: object_name_linter. + dataname = NULL, + term_var = teal.picks::picks( + teal.picks::datasets(), + teal.picks::variables( + choices = teal.picks::is_categorical(min.len = 2), + selected = 1L + ) + ), + arm_var = teal.picks::picks( + teal.picks::datasets(), + teal.picks::variables( + choices = teal.picks::is_categorical(min.len = 2), + selected = 1L + ) + ), + fontsize = c(5, 3, 7), + plot_height = c(600L, 200L, 2000L), + plot_width = NULL, + transformators = list()) { + checkmate::assert_string(label) + + checkmate::assert_class(term_var, "picks", .var.name = "term_var") + checkmate::assert_false( + teal.picks::is_pick_multiple(term_var$variables), + .var.name = "`term_var` must use variables(..., multiple = FALSE)" + ) + checkmate::assert_class(arm_var, "picks", .var.name = "arm_var") + checkmate::assert_false( + teal.picks::is_pick_multiple(arm_var$variables), + .var.name = "`arm_var` must use variables(..., multiple = FALSE)" + ) + + checkmate::assert( + checkmate::check_number(fontsize, finite = TRUE), + checkmate::assert( + combine = "and", + .var.name = "fontsize", + checkmate::check_numeric(fontsize, len = 3, any.missing = FALSE, finite = TRUE), + checkmate::check_numeric(fontsize[1], lower = fontsize[2], upper = fontsize[3]) + ) + ) + checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) + checkmate::assert_numeric( + plot_height[1], + lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height" + ) + checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) + checkmate::assert_numeric( + plot_width[1], + lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" + ) + + pick_slots <- list(term_var = term_var, arm_var = arm_var) + all_datanames <- unique( + unlist( + lapply( + pick_slots, + function(p) { + ch <- p$datasets$choices + if (checkmate::test_character(ch, min.len = 1L)) { + return(unique(as.character(ch))) + } + sel <- p$datasets$selected + unique(as.character(unlist(sel, recursive = FALSE, use.names = FALSE))) + } + ), + use.names = FALSE + ) + ) + all_datanames <- all_datanames[nzchar(all_datanames) & !is.na(all_datanames)] + + args <- as.list(environment()) + + module( + label = label, + ui = ui_g_events_term_id_picks, + server = srv_g_events_term_id_picks, + ui_args = args[names(args) %in% names(formals(ui_g_events_term_id_picks))], + server_args = args[names(args) %in% names(formals(srv_g_events_term_id_picks))], + transformators = transformators, + datanames = all_datanames + ) +} + +#' @examples +#' # Using the picks method +#' data <- teal_data() %>% +#' within({ +#' ADSL <- rADSL +#' ADAE <- rADAE +#' }) +#' +#' join_keys(data) <- default_cdisc_join_keys[names(data)] +#' +#' app <- init( +#' data = data, +#' modules = modules( +#' tm_g_events_term_id( +#' label = "Common AE", +#' term_var = teal.picks::picks( +#' teal.picks::datasets("ADAE"), +#' teal.picks::variables( +#' choices = teal.picks::is_categorical(min.len = 2), +#' selected = "AEDECOD" +#' ) +#' ), +#' arm_var = teal.picks::picks( +#' teal.picks::datasets("ADSL"), +#' teal.picks::variables( +#' choices = teal.picks::is_categorical(min.len = 2), +#' selected = "ACTARMCD" +#' ) +#' ), +#' plot_height = c(600, 200, 2000) +#' ) +#' ) +#' ) +#' if (interactive()) { +#' shinyApp(app$ui, app$server) +#' } + +#' @keywords internal +ui_g_events_term_id_picks <- function(id, + term_var, + arm_var, + fontsize) { + ns <- NS(id) + teal.widgets::standard_layout( + output = teal.widgets::white_small_well( + plot_decorate_output(id = ns(NULL)) + ), + encoding = tags$div( + tags$label("Encodings", class = "text-primary"), tags$br(), + tags$div( + tags$label("Term variable"), + teal.picks::picks_ui(id = ns("term_var"), picks = term_var) + ), + tags$div( + tags$label("Arm variable"), + teal.picks::picks_ui(id = ns("arm_var"), picks = arm_var) + ), + selectInput( + ns("arm_ref"), + "Control", + choices = NULL + ), + selectInput( + ns("arm_trt"), + "Treatment", + choices = NULL + ), + teal.widgets::optionalSelectInput( + ns("sort"), + "Sort By", + choices = c( + "Term" = "term", + "Risk Difference" = "riskdiff", + "Mean Risk" = "meanrisk" + ), + selected = NULL + ), + teal.widgets::panel_item( + "Confidence interval settings", + teal.widgets::optionalSelectInput( + ns("diff_ci_method"), + "Method for Difference of Proportions CI", + choices = ci_choices, + selected = ci_choices[1] + ), + teal.widgets::optionalSliderInput( + ns("conf_level"), + "Confidence Level", + min = 0.5, + max = 1, + value = 0.95 + ) + ), + teal.widgets::panel_item( + "Additional plot settings", + teal.widgets::optionalSelectInput( + ns("axis"), + "Axis Side", + choices = c("Left" = "left", "Right" = "right"), + selected = "left" + ), + sliderInput( + ns("raterange"), + "Overall Rate Range", + min = 0, + max = 1, + value = c(0.1, 1), + step = 0.01 + ), + sliderInput( + ns("diffrange"), + "Rate Difference Range", + min = -1, + max = 1, + value = c(-0.5, 0.5), + step = 0.01 + ), + checkboxInput( + ns("reverse"), + "Reverse Order", + value = FALSE + ) + ), + ui_g_decorate( + ns(NULL), + fontsize = fontsize, + titles = "Common AE Table", + footnotes = "" + ) + ) + ) +} + +#' @keywords internal +srv_g_events_term_id_picks <- function(id, + data, + term_var, + arm_var, + plot_height, + plot_width) { + checkmate::assert_class(data, "reactive") + checkmate::assert_class(isolate(data()), "teal_data") + + moduleServer(id, function(input, output, session) { + teal.logger::log_shiny_input_changes(input, namespace = "teal.osprey") + + anl_selectors <- teal.picks::picks_srv( + id = "", + picks = list(term_var = term_var, arm_var = arm_var), + data = data + ) + + data_with_card <- reactive({ + obj <- data() + teal.reporter::teal_card(obj) <- + c( + teal.reporter::teal_card(obj), + teal.reporter::teal_card("## Module's output(s)") + ) + obj + }) + + merged_anl <- teal.picks::merge_srv( + "merge_anl", + data = data_with_card, + selectors = anl_selectors, + output_name = "ANL", + join_fun = "dplyr::inner_join" + ) + + anl_q <- merged_anl$data + merge_vars <- merged_anl$variables + + observeEvent(anl_selectors$arm_var(), + { + arm_selector <- anl_selectors$arm_var() + req(arm_selector) + arm_var_name <- arm_selector$variables$selected + arm_dataset <- arm_selector$datasets$selected + req(arm_var_name, arm_dataset) + + arm_data <- data()[[arm_dataset]] + choices <- levels(arm_data[[arm_var_name]]) + + trt_index <- if (length(choices) == 1L) 1L else 2L + + updateSelectInput( + session, + "arm_ref", + selected = choices[1], + choices = choices + ) + updateSelectInput( + session, + "arm_trt", + selected = choices[trt_index], + choices = choices + ) + }, + ignoreNULL = TRUE + ) + + observeEvent(input$sort, + { + sort <- if (is.null(input$sort)) " " else input$sort + updateTextInput( + session, + "title", + value = sprintf( + "Common AE Table %s", + c( + "term" = "Sorted by Term", + "riskdiff" = "Sorted by Risk Difference", + "meanrisk" = "Sorted by Mean Risk", + " " = "" + )[sort] + ) + ) + }, + ignoreNULL = FALSE + ) + + observeEvent(list(input$diff_ci_method, input$conf_level), { + req(!is.null(input$diff_ci_method) && !is.null(input$conf_level)) + diff_ci_method <- input$diff_ci_method + conf_level <- input$conf_level + updateTextAreaInput( + session, + "foot", + value = sprintf( + "Note: %d%% CI is calculated using %s", + round(conf_level * 100), + name_ci(diff_ci_method) + ) + ) + }) + + decorate_output <- srv_g_decorate( + id = NULL, + plt = plot_r, + plot_height = plot_height, + plot_width = plot_width + ) + font_size <- decorate_output$font_size + pws <- decorate_output$pws + + output_q <- reactive({ + merged_vars <- merge_vars() + validate( + need( + length(merged_vars[["term_var"]]) > 0L, + "Please select a term variable" + ), + need( + length(merged_vars[["arm_var"]]) > 0L, + "Please select an arm variable" + ) + ) + + term_var_name <- merged_vars[["term_var"]][[1L]] + arm_var_name <- merged_vars[["arm_var"]][[1L]] + + arm_selector <- anl_selectors$arm_var() + arm_var_orig <- arm_selector$variables$selected + arm_dataset <- arm_selector$datasets$selected + + qenv <- anl_q() + ANL <- qenv[["ANL"]] + + validate( + need( + is.factor(ANL[[arm_var_name]]), + "Arm Variable must be a factor variable." + ), + need( + input$arm_trt %in% ANL[[arm_var_name]] && input$arm_ref %in% ANL[[arm_var_name]], + "Cannot generate plot. The dataset does not contain subjects from both the control and treatment arms." + ), + need( + !isTRUE(input$arm_trt == input$arm_ref), + "Control and Treatment must be different." + ) + ) + + teal::validate_has_data( + ANL, + min_nrow = 10, + msg = "Analysis data set must have at least 10 data points" + ) + + teal.reporter::teal_card(qenv) <- c(teal.reporter::teal_card(qenv), "### Plot") + + teal.code::eval_code( + qenv, + code = bquote( + plot <- osprey::g_events_term_id( + term = ANL[[.(term_var_name)]], + id = ANL$USUBJID, + arm = ANL[[.(arm_var_name)]], + arm_N = table(.(as.name(arm_dataset))[[.(arm_var_orig)]]), + ref = .(input$arm_ref), + trt = .(input$arm_trt), + sort_by = .(input$sort), + rate_range = .(input$raterange), + diff_range = .(input$diffrange), + reversed = .(input$reverse), + conf_level = .(input$conf_level), + diff_ci_method = .(input$diff_ci_method), + axis_side = .(input$axis), + fontsize = .(font_size()), + draw = TRUE + ) + ) + ) + }) + + plot_r <- reactive(output_q()[["plot"]]) + set_chunk_dims(pws, output_q) + }) +} diff --git a/R/tm_g_swimlane.R b/R/tm_g_swimlane.R index 0df80ca5..ee405ecf 100644 --- a/R/tm_g_swimlane.R +++ b/R/tm_g_swimlane.R @@ -2,31 +2,36 @@ #' #' @description #' -#' This is teal module that generates a `swimlane` plot (bar plot with markers) for `ADaM` data +#' This is a teal module that generates a `swimlane` plot (bar plot with markers) for `ADaM` data +#' using [teal.picks::picks()] encodings. #' #' @inheritParams teal.widgets::standard_layout #' @inheritParams teal::module #' @inheritParams argument_convention -#' @param dataname analysis data used for plotting, needs to be available in the list passed to the `data` -#' argument of [teal::init()]. If no markers are to be plotted in the module, `"ADSL"` should be -#' the input. If markers are to be plotted, data name for the marker data should be the input -#' @param bar_var [teal.transform::choices_selected] subject-level numeric variable from dataset -#' to plot as the bar length -#' @param bar_color_var [teal.transform::choices_selected] color by variable (subject-level) -#' @param sort_var `choices_selected` sort by variable (subject-level) -#' @param marker_pos_var [teal.transform::choices_selected] variable for marker position from marker data -#' (Note: make sure that marker position has the same relative start day as bar length variable `bar_var` -#' @param marker_shape_var [teal.transform::choices_selected] marker shape variable from marker data -#' @param marker_shape_opt aesthetic values to map shape values (named vector to map shape values to each name). -#' If not `NULL`, please make sure this contains all possible values for `marker_shape_var` values, -#' otherwise shape will be assigned by `ggplot` default -#' @param marker_color_var marker color variable from marker data -#' @param marker_color_opt aesthetic values to map color values (named vector to map color values to each name). -#' If not `NULL`, please make sure this contains all possible values for `marker_color_var` values, -#' otherwise color will be assigned by `ggplot` default -#' @param vref_line vertical reference lines -#' @param anno_txt_var character vector with subject-level variable names that are selected as annotation -#' @param x_label the label of the x axis +#' @param dataname (`character(1)`)\cr +#' Analysis data used for markers. Use `"ADSL"` when no markers are plotted. +#' @param bar_var (`picks`)\cr +#' Subject-level numeric variable for bar length (from `ADSL`). +#' @param bar_color_var (`picks` or `NULL`)\cr +#' Subject-level color variable from `ADSL`. +#' @param sort_var (`picks` or `NULL`)\cr +#' Subject-level sort variable from `ADSL`. +#' @param marker_pos_var (`picks` or `NULL`)\cr +#' Marker position variable from `dataname` (when not `"ADSL"`). +#' @param marker_shape_var (`picks` or `NULL`)\cr +#' Marker shape variable from `dataname`. +#' @param marker_shape_opt (`numeric`)\cr +#' Named vector mapping shape values to ggplot shapes. +#' @param marker_color_var (`picks` or `NULL`)\cr +#' Marker color variable from `dataname`. +#' @param marker_color_opt (`character`)\cr +#' Named vector mapping color values to colors. +#' @param anno_txt_var (`picks` or `NULL`)\cr +#' Subject-level annotation variables from `ADSL` (multiple selection allowed). +#' @param vref_line (`numeric`)\cr +#' Vertical reference lines. +#' @param x_label (`character`)\cr +#' Label of the x axis. #' #' @inherit argument_convention return #' @inheritSection teal::example_module Reporting @@ -35,77 +40,6 @@ #' #' @template author_qit3 #' -#' @examples -#' # Example using stream (ADaM) dataset -#' data <- teal_data() %>% -#' within({ -#' library(nestcolor) -#' library(dplyr) -#' ADSL <- rADSL %>% -#' mutate(TRTDURD = as.integer(TRTEDTM - TRTSDTM) + 1) %>% -#' filter(STRATA1 == "A" & ARMCD == "ARM A") -#' ADRS <- rADRS %>% -#' filter(PARAMCD == "LSTASDI" & DCSREAS == "Death") %>% -#' mutate(AVALC = DCSREAS, ADY = EOSDY) %>% -#' rbind(rADRS %>% filter(PARAMCD == "OVRINV" & AVALC != "NE")) %>% -#' arrange(USUBJID) -#' }) -#' -#' join_keys(data) <- default_cdisc_join_keys[names(data)] -#' -#' ADSL <- data[["ADSL"]] -#' ADRS <- data[["ADRS"]] -#' -#' app <- init( -#' data = data, -#' modules = modules( -#' tm_g_swimlane( -#' label = "Swimlane Plot", -#' dataname = "ADRS", -#' bar_var = choices_selected( -#' selected = "TRTDURD", -#' choices = c("TRTDURD", "EOSDY") -#' ), -#' bar_color_var = choices_selected( -#' selected = "EOSSTT", -#' choices = c("EOSSTT", "ARM", "ARMCD", "ACTARM", "ACTARMCD", "SEX") -#' ), -#' sort_var = choices_selected( -#' selected = "ACTARMCD", -#' choices = c("USUBJID", "SITEID", "ACTARMCD", "TRTDURD") -#' ), -#' marker_pos_var = choices_selected( -#' selected = "ADY", -#' choices = c("ADY") -#' ), -#' marker_shape_var = choices_selected( -#' selected = "AVALC", -#' c("AVALC", "AVISIT") -#' ), -#' marker_shape_opt = c("CR" = 16, "PR" = 17, "SD" = 18, "PD" = 15, "Death" = 8), -#' marker_color_var = choices_selected( -#' selected = "AVALC", -#' choices = c("AVALC", "AVISIT") -#' ), -#' marker_color_opt = c( -#' "CR" = "green", "PR" = "blue", "SD" = "goldenrod", -#' "PD" = "red", "Death" = "black" -#' ), -#' vref_line = c(30, 60), -#' anno_txt_var = choices_selected( -#' selected = c("ACTARM", "SEX"), -#' choices = c( -#' "ARM", "ARMCD", "ACTARM", "ACTARMCD", "AGEGR1", -#' "SEX", "RACE", "COUNTRY", "DCSREAS", "DCSREASP" -#' ) -#' ) -#' ) -#' ) -#' ) -#' if (interactive()) { -#' shinyApp(app$ui, app$server) -#' } -#' tm_g_swimlane <- function(label, dataname, bar_var, @@ -124,58 +58,69 @@ tm_g_swimlane <- function(label, post_output = NULL, x_label = "Time from First Treatment (Day)", transformators = list()) { - message("Initializing tm_g_swimlane") - args <- as.list(environment()) - checkmate::assert_string(label) checkmate::assert_string(dataname) - checkmate::assert_class(bar_var, classes = "choices_selected") - checkmate::assert_class(bar_color_var, classes = "choices_selected") - checkmate::assert_class(marker_pos_var, classes = "choices_selected") - checkmate::assert_class(marker_shape_var, classes = "choices_selected") - checkmate::assert_numeric(marker_shape_opt, min.len = 1, any.missing = FALSE) - checkmate::assert_class(marker_color_var, classes = "choices_selected") + .assert_picks_single_var(bar_var, "bar_var") + if (!is.null(bar_color_var)) .assert_picks_single_var(bar_color_var, "bar_color_var") + if (!is.null(sort_var)) .assert_picks_single_var(sort_var, "sort_var") + if (!is.null(marker_pos_var)) .assert_picks_single_var(marker_pos_var, "marker_pos_var") + if (!is.null(marker_shape_var)) .assert_picks_single_var(marker_shape_var, "marker_shape_var") + if (!is.null(marker_color_var)) .assert_picks_single_var(marker_color_var, "marker_color_var") + checkmate::assert_numeric(marker_shape_opt, min.len = 1, any.missing = FALSE, null.ok = TRUE) checkmate::assert_character(marker_color_opt, min.len = 1, any.missing = FALSE, null.ok = TRUE) - checkmate::assert_class(anno_txt_var, classes = "choices_selected") checkmate::assert_numeric(vref_line, min.len = 1, null.ok = TRUE, any.missing = FALSE) checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) - checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") + checkmate::assert_numeric( + plot_height[1], + lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height" + ) checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) checkmate::assert_numeric( plot_width[1], - lower = plot_width[2], - upper = plot_width[3], - null.ok = TRUE, - .var.name = "plot_width" + lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" ) checkmate::assert_string(x_label) + pick_slots <- Filter( + Negate(is.null), + list( + bar_var = bar_var, + bar_color_var = bar_color_var, + sort_var = sort_var, + marker_pos_var = marker_pos_var, + marker_shape_var = marker_shape_var, + marker_color_var = marker_color_var, + anno_txt_var = anno_txt_var + ) + ) + all_datanames <- unique(c("ADSL", dataname, .picks_all_datanames(pick_slots))) + + args <- as.list(environment()) module( label = label, ui = ui_g_swimlane, - ui_args = args, server = srv_g_swimlane, - server_args = list( - dataname = dataname, - marker_pos_var = marker_pos_var, - marker_shape_var = marker_shape_var, - marker_shape_opt = marker_shape_opt, - marker_color_var = marker_color_var, - marker_color_opt = marker_color_opt, - label = label, - plot_height = plot_height, - plot_width = plot_width, - x_label = x_label - ), + ui_args = args[names(args) %in% names(formals(ui_g_swimlane))], + server_args = args[names(args) %in% names(formals(srv_g_swimlane))], transformators = transformators, - datanames = c("ADSL", dataname) + datanames = all_datanames ) } - -ui_g_swimlane <- function(id, ...) { - a <- list(...) +#' @keywords internal +ui_g_swimlane <- function(id, + dataname, + bar_var, + bar_color_var, + sort_var, + marker_pos_var, + marker_shape_var, + marker_color_var, + anno_txt_var, + vref_line, + pre_output, + post_output) { ns <- NS(id) shiny::tagList( @@ -185,59 +130,51 @@ ui_g_swimlane <- function(id, ...) { ), encoding = tags$div( tags$label("Encodings", class = "text-primary"), - helpText("Analysis data:", tags$code(a$dataname)), + helpText("Analysis data:", tags$code(dataname)), left_bordered_div( - teal.widgets::optionalSelectInput( - ns("bar_var"), - "Bar Length", - choices = get_choices(a$bar_var$choices), - selected = a$bar_var$selected, - multiple = FALSE, - label_help = helpText("from ", tags$code("ADSL")) + tags$div( + tags$label("Bar length"), + teal.picks::picks_ui(ns("bar_var"), bar_var) ), - teal.widgets::optionalSelectInput( - ns("bar_color_var"), - "Bar Color", - choices = get_choices(a$bar_color_var$choices), - selected = a$bar_color_var$selected, - multiple = FALSE, - label_help = helpText("from ", tags$code("ADSL")) - ) - ), - teal.widgets::optionalSelectInput( - ns("sort_var"), - "Sort by", - choices = get_choices(a$sort_var$choices), - selected = a$sort_var$selected, - multiple = FALSE, - label_help = helpText("from ", tags$code("ADSL")) - ), - left_bordered_div( - if (a$dataname == "ADSL") { - NULL - } else if (is.null(a$marker_pos_var)) { - NULL - } else { - teal.widgets::optionalSelectInput( - ns("marker_pos_var"), - "Marker Position", - choices = get_choices(a$marker_pos_var$choices), - selected = a$marker_pos_var$selected, - multiple = FALSE, - label_help = helpText("from ", tags$code(a$dataname)) + if (!is.null(bar_color_var)) { + tags$div( + tags$label("Bar color"), + teal.picks::picks_ui(ns("bar_color_var"), bar_color_var) ) - }, - uiOutput(ns("marker_shape_sel")), - uiOutput(ns("marker_color_sel")) - ), - teal.widgets::optionalSelectInput( - ns("anno_txt_var"), - "Annotation Variables", - choices = get_choices(a$anno_txt_var$choices), - selected = a$anno_txt_var$selected, - multiple = TRUE, - label_help = helpText("from ", tags$code("ADSL")) + } ), + if (!is.null(sort_var)) { + tags$div( + tags$label("Sort by"), + teal.picks::picks_ui(ns("sort_var"), sort_var) + ) + }, + if (dataname != "ADSL" && !is.null(marker_pos_var)) { + left_bordered_div( + tags$div( + tags$label("Marker position"), + teal.picks::picks_ui(ns("marker_pos_var"), marker_pos_var) + ), + if (!is.null(marker_shape_var)) { + tags$div( + tags$label("Marker shape"), + teal.picks::picks_ui(ns("marker_shape_var"), marker_shape_var) + ) + }, + if (!is.null(marker_color_var)) { + tags$div( + tags$label("Marker color"), + teal.picks::picks_ui(ns("marker_color_var"), marker_color_var) + ) + } + ) + }, + if (!is.null(anno_txt_var)) { + tags$div( + tags$label("Annotation variables"), + teal.picks::picks_ui(ns("anno_txt_var"), anno_txt_var) + ) + }, textInput( ns("vref_line"), label = tags$div( @@ -245,38 +182,66 @@ ui_g_swimlane <- function(id, ...) { tags$br(), helpText("Enter numeric value(s) of reference lines, separated by comma (eg. 100, 200)") ), - value = paste(a$vref_line, collapse = ", ") + value = paste(vref_line, collapse = ", ") ) ), - pre_output = a$pre_output, - post_output = a$post_output + pre_output = pre_output, + post_output = post_output ) ) } +#' @keywords internal +.swimlane_picks_selected_var <- function(selector_state) { + if (is.null(selector_state) || is.null(selector_state$variables)) { + return(character()) + } + as.character(selector_state$variables$selected) +} + +#' @keywords internal srv_g_swimlane <- function(id, data, dataname, - marker_pos_var, - marker_shape_var, marker_shape_opt, - marker_color_var, marker_color_opt, - label, plot_height, plot_width, - x_label) { + x_label, + bar_var, + bar_color_var, + sort_var, + marker_pos_var, + marker_shape_var, + marker_color_var, + anno_txt_var) { checkmate::assert_class(data, "reactive") - checkmate::assert_class(shiny::isolate(data()), "teal_data") + checkmate::assert_class(isolate(data()), "teal_data") moduleServer(id, function(input, output, session) { teal.logger::log_shiny_input_changes(input, namespace = "teal.osprey") + + picks_inputs <- Filter( + Negate(is.null), + list( + bar_var = bar_var, + bar_color_var = bar_color_var, + sort_var = sort_var, + marker_pos_var = if (dataname != "ADSL") marker_pos_var else NULL, + marker_shape_var = if (dataname != "ADSL") marker_shape_var else NULL, + marker_color_var = if (dataname != "ADSL") marker_color_var else NULL, + anno_txt_var = anno_txt_var + ) + ) + + selectors <- teal.picks::picks_srv( + id = "", + picks = picks_inputs, + data = data + ) + iv <- reactive({ iv <- shinyvalidate::InputValidator$new() - iv$add_rule("bar_var", shinyvalidate::sv_required( - message = "Bar Length is required" - )) - # If reference lines are requested iv$add_rule("vref_line", ~ if (anyNA(suppressWarnings(as_numeric_from_comma_sep_str(.)))) { "Vertical Reference Line(s) are invalid" }) @@ -284,35 +249,6 @@ srv_g_swimlane <- function(id, iv }) - # if marker position is NULL, then hide options for marker shape and color - output$marker_shape_sel <- renderUI({ - if (dataname == "ADSL" || is.null(marker_shape_var) || is.null(input$marker_pos_var)) { - NULL - } else { - ns <- session$ns - teal.widgets::optionalSelectInput( - ns("marker_shape_var"), "Marker Shape", - choices = get_choices(marker_shape_var$choices), - selected = marker_shape_var$selected, multiple = FALSE, - label_help = helpText("from ", tags$code(dataname)) - ) - } - }) - output$marker_color_sel <- renderUI({ - if (dataname == "ADSL" || is.null(marker_color_var) || is.null(input$marker_pos_var)) { - NULL - } else { - ns <- session$ns - teal.widgets::optionalSelectInput( - ns("marker_color_var"), "Marker Color", - choices = get_choices(marker_color_var$choices), - selected = marker_color_var$selected, multiple = FALSE, - label_help = helpText("from ", tags$code(dataname)) - ) - } - }) - - # create plot output_q <- reactive({ obj <- data() teal.reporter::teal_card(obj) <- @@ -323,10 +259,48 @@ srv_g_swimlane <- function(id, teal::validate_inputs(iv()) + bar_var_name <- .swimlane_picks_selected_var(selectors$bar_var()) + validate( + need(length(bar_var_name) > 0L, "Please select a bar length variable.") + ) + + bar_color_var_name <- if (!is.null(bar_color_var)) { + .swimlane_picks_selected_var(selectors$bar_color_var()) + } else { + character() + } + sort_var_name <- if (!is.null(sort_var)) { + .swimlane_picks_selected_var(selectors$sort_var()) + } else { + character() + } + anno_txt_var_name <- if (!is.null(anno_txt_var)) { + .swimlane_picks_selected_var(selectors$anno_txt_var()) + } else { + character() + } + + marker_pos_var_name <- if (dataname != "ADSL" && !is.null(marker_pos_var)) { + .swimlane_picks_selected_var(selectors$marker_pos_var()) + } else { + character() + } + marker_shape_var_name <- if (dataname != "ADSL" && !is.null(marker_shape_var)) { + .swimlane_picks_selected_var(selectors$marker_shape_var()) + } else { + character() + } + marker_color_var_name <- if (dataname != "ADSL" && !is.null(marker_color_var)) { + .swimlane_picks_selected_var(selectors$marker_color_var()) + } else { + character() + } + validate(need("ADSL" %in% names(obj), "'ADSL' not included in data")) validate(need( (length(obj) == 1 && dataname == "ADSL") || - (length(obj) >= 2 && dataname != "ADSL"), paste( + (length(obj) >= 2 && dataname != "ADSL"), + paste( "Please either add just 'ADSL' as dataname when just ADSL is available.", "In case 2 datasets are available ADSL is not supposed to be the dataname." ) @@ -336,11 +310,11 @@ srv_g_swimlane <- function(id, anl_vars <- unique(c( "USUBJID", "STUDYID", - input$marker_pos_var, input$marker_shape_var, input$marker_color_var + marker_pos_var_name, marker_shape_var_name, marker_color_var_name )) adsl_vars <- unique(c( "USUBJID", "STUDYID", - input$bar_var, input$bar_color_var, input$sort_var, input$anno_txt_var + bar_var_name, bar_color_var_name, sort_var_name, anno_txt_var_name )) if (dataname == "ADSL") { @@ -350,30 +324,12 @@ srv_g_swimlane <- function(id, anl <- obj[[dataname]] teal::validate_has_data(anl, min_nrow = 3) teal::validate_has_variable(anl, anl_vars) - validate(need( - !any(c(marker_pos_var, marker_shape_var, marker_color_var) %in% adsl_vars), - "marker-related variables need to come from marker data" + length(marker_pos_var_name) > 0L, + "Please select a marker position variable." )) } - # VARIABLE GETTERS - # lookup bar variables - bar_var <- input$bar_var - bar_color_var <- input$bar_color_var - sort_var <- input$sort_var - anno_txt_var <- input$anno_txt_var - - # Check if marker inputs can be used - if (dataname == "ADSL") { - marker_pos_var <- NULL - marker_shape_var <- NULL - marker_color_var <- NULL - } else { - marker_pos_var <- input$marker_pos_var - marker_shape_var <- input$marker_shape_var - marker_color_var <- input$marker_color_var - } vref_line <- suppressWarnings(as_numeric_from_comma_sep_str(debounce(reactive(input$vref_line), 1500)())) q1 <- obj @@ -381,24 +337,22 @@ srv_g_swimlane <- function(id, q2 <- teal.code::eval_code( q1, code = bquote({ - bar_var <- .(bar_var) - bar_color_var <- .(bar_color_var) - sort_var <- .(sort_var) - marker_pos_var <- .(marker_pos_var) - marker_shape_var <- .(marker_shape_var) - marker_color_var <- .(marker_color_var) - anno_txt_var <- .(anno_txt_var) + bar_var <- .(bar_var_name) + bar_color_var <- .(bar_color_var_name) + sort_var <- .(sort_var_name) + marker_pos_var <- .(marker_pos_var_name) + marker_shape_var <- .(marker_shape_var_name) + marker_color_var <- .(marker_color_var_name) + anno_txt_var <- .(anno_txt_var_name) }) ) - # WRITE DATA SELECTION TO qenv q3 <- if (dataname == "ADSL") { teal.code::eval_code( q2, code = bquote({ ADSL_p <- ADSL - ADSL <- ADSL_p[, .(adsl_vars)] - # only take last part of USUBJID + ADSL <- ADSL_p[, .(adsl_vars), drop = FALSE] ADSL$USUBJID <- unlist(lapply(strsplit(ADSL$USUBJID, "-", fixed = TRUE), tail, 1)) }) ) @@ -409,14 +363,13 @@ srv_g_swimlane <- function(id, ADSL_p <- ADSL ANL_p <- .(as.name(dataname)) - ADSL <- ADSL_p[, .(adsl_vars)] + ADSL <- ADSL_p[, .(adsl_vars), drop = FALSE] ANL <- merge( x = ADSL, - y = ANL_p[, .(anl_vars)], + y = ANL_p[, .(anl_vars), drop = FALSE], all.x = FALSE, all.y = FALSE, by = c("USUBJID", "STUDYID") ) - # only take last part of USUBJID ADSL$USUBJID <- unlist(lapply(strsplit(ADSL$USUBJID, "-", fixed = TRUE), tail, 1)) ANL$USUBJID <- unlist(lapply(strsplit(ANL$USUBJID, "-", fixed = TRUE), tail, 1)) }) @@ -436,7 +389,7 @@ srv_g_swimlane <- function(id, marker_shape_opt = NULL, marker_color = NULL, marker_color_opt = NULL, - anno_txt = .(if (length(anno_txt_var) > 0) quote(ADSL[, anno_txt_var]) else NULL), + anno_txt = .(if (length(anno_txt_var) > 0) quote(ADSL[, anno_txt_var, drop = FALSE]) else NULL), xref_line = .(vref_line), xtick_at = ggplot2::waiver(), xlab = .(x_label), @@ -448,51 +401,33 @@ srv_g_swimlane <- function(id, plot <- osprey::g_swimlane( bar_id = ADSL[["USUBJID"]], bar_length = ADSL[[bar_var]], - sort_by = .(if (length(sort_var) > 0) { - quote(ADSL[[sort_var]]) - } else { - NULL - }), - col_by = .(if (length(bar_color_var) > 0) { - quote(ADSL[[bar_color_var]]) - } else { - NULL - }), + sort_by = .(if (length(sort_var) > 0) quote(ADSL[[sort_var]]) else NULL), + col_by = .(if (length(bar_color_var) > 0) quote(ADSL[[bar_color_var]]) else NULL), marker_id = ANL[["USUBJID"]], - marker_pos = .(if (length(marker_pos_var) > 0) { - quote(ANL[[marker_pos_var]]) - } else { - NULL - }), - marker_shape = .(if (length(marker_shape_var) > 0) { - quote(ANL[[marker_shape_var]]) - } else { - NULL - }), + marker_pos = .(if (length(marker_pos_var) > 0) quote(ANL[[marker_pos_var]]) else NULL), + marker_shape = .(if (length(marker_shape_var) > 0) quote(ANL[[marker_shape_var]]) else NULL), marker_shape_opt = .(if (length(marker_shape_var) == 0) { NULL - } else if (length(marker_shape_var) > 0 && all(unique(anl[[marker_shape_var]]) %in% names(marker_shape_opt))) { # nolint: line_length. + } else if ( + length(marker_shape_var) > 0 && + all(unique(ANL[[marker_shape_var]]) %in% names(marker_shape_opt)) + ) { bquote(.(marker_shape_opt)) } else { NULL }), - marker_color = .(if (length(marker_color_var) > 0) { - quote(ANL[[marker_color_var]]) - } else { - NULL - }), + marker_color = .(if (length(marker_color_var) > 0) quote(ANL[[marker_color_var]]) else NULL), marker_color_opt = .(if (length(marker_color_var) == 0) { NULL - } else if (length(marker_color_var) > 0 && all(unique(anl[[marker_color_var]]) %in% names(marker_color_opt))) { # nolint: line_length. + } else if ( + length(marker_color_var) > 0 && + all(unique(ANL[[marker_color_var]]) %in% names(marker_color_opt)) + ) { bquote(.(marker_color_opt)) } else { NULL }), - anno_txt = .(if (length(anno_txt_var) > 0) { - quote(ADSL[, anno_txt_var]) - } else { - NULL - }), + anno_txt = .(if (length(anno_txt_var) > 0) quote(ADSL[, anno_txt_var, drop = FALSE]) else NULL), xref_line = .(vref_line), xtick_at = ggplot2::waiver(), xlab = .(x_label), @@ -503,9 +438,9 @@ srv_g_swimlane <- function(id, teal.reporter::teal_card(q3) <- c(teal.reporter::teal_card(q3), "### Plot") - if (!is.null(input$sort_var)) { + if (length(sort_var_name) > 0L) { teal.reporter::teal_card(q3) <- c(teal.reporter::teal_card(q3), "### Selected Options") - teal.reporter::teal_card(q3) <- c(teal.reporter::teal_card(q3), paste("Sorted by:", input$sort_var)) + teal.reporter::teal_card(q3) <- c(teal.reporter::teal_card(q3), paste("Sorted by:", sort_var_name)) } teal.code::eval_code(q3, code = plot_call) @@ -513,7 +448,6 @@ srv_g_swimlane <- function(id, plot_r <- reactive(output_q()[["plot"]]) - # Insert the plot into a plot_with_settings module from teal.widgets pws <- teal.widgets::plot_with_settings_srv( id = "swimlaneplot", plot_r = plot_r, diff --git a/R/tm_g_waterfall.R b/R/tm_g_waterfall.R index e7f66066..cd07fcdd 100644 --- a/R/tm_g_waterfall.R +++ b/R/tm_g_waterfall.R @@ -2,42 +2,44 @@ #' #' @description #' -#' This is teal module that generates a waterfall plot for `ADaM` data +#' This is a teal module that generates a waterfall plot for `ADaM` data using +#' [teal.picks::picks()] encodings. #' #' @inheritParams teal.widgets::standard_layout #' @inheritParams teal::module #' @inheritParams argument_convention -#' @param dataname_tr tumor burden analysis data used in teal module to plot as bar height, needs to -#' be available in the list passed to the `data` argument of [teal::init()] -#' @param dataname_rs response analysis data used in teal module to label response parameters, needs to -#' be available in the list passed to the `data` argument of [teal::init()] -#' @param bar_paramcd `choices_selected` parameter in tumor burden data that will be plotted as -#' bar height -#' @param bar_var `choices_selected` numeric variable from dataset to plot the bar height, e.g., `PCHG` -#' @param bar_color_var `choices_selected` color by variable (subject level), `None` corresponds -#' to `NULL` -#' @param bar_color_opt aesthetic values to map color values (named vector to map color values to each name). -#' If not `NULL`, please make sure this contains all possible values for `bar_color_var` values, -#' otherwise color will be assigned by `ggplot` default, please note that `NULL` needs to be specified -#' in this case -#' @param sort_var `choices_selected` sort by variable (subject level), `None` corresponds -#' to `NULL` -#' @param add_label_var_sl `choices_selected` add label to bars (subject level), `None` -#' corresponds to `NULL` -#' @param add_label_paramcd_rs `choices_selected` add label to bars (response dataset), `None` -#' corresponds to `NULL`. At least one of `add_label_var_sl` and `add_label_paramcd_rs` needs -#' to be `NULL` -#' @param anno_txt_var_sl `choices_selected` subject level variables to be displayed in the annotation -#' table, default is `NULL` -#' @param anno_txt_paramcd_rs `choices_selected` analysis dataset variables to be displayed in the -#' annotation table, default is `NULL` -#' @param facet_var `choices_selected` facet by variable (subject level), `None` corresponds to -#' `NULL` -#' @param ytick_at bar height axis interval, default is 20 -#' @param href_line numeric vector to plot horizontal reference lines, default is `NULL` -#' @param gap_point_val singular numeric value for adding bar break when some bars are significantly higher -#' than others, default is `NULL` -#' @param show_value boolean of whether value of bar height is shown, default is `TRUE` +#' @param dataname_tr (`character(1)`)\cr +#' Tumor burden dataset name (e.g. `"ADTR"`). +#' @param dataname_rs (`character(1)`)\cr +#' Response dataset name (e.g. `"ADRS"`). +#' @param bar_paramcd (`picks`)\cr +#' `PARAMCD` selection for tumor burden data (`values` slot). +#' @param bar_var (`picks`)\cr +#' Numeric variable for bar height (e.g. `PCHG`). +#' @param bar_color_var (`picks` or `NULL`)\cr +#' Subject-level color variable from `ADSL`. +#' @param bar_color_opt (`character`)\cr +#' Named vector mapping color values to colors. +#' @param sort_var (`picks` or `NULL`)\cr +#' Subject-level sort variable from `ADSL`. +#' @param add_label_var_sl (`picks` or `NULL`)\cr +#' Subject-level bar label variable from `ADSL`. +#' @param add_label_paramcd_rs (`picks` or `NULL`)\cr +#' `PARAMCD` label from response data (`ADRS`). +#' @param anno_txt_var_sl (`picks` or `NULL`)\cr +#' Subject-level annotation variables from `ADSL`. +#' @param anno_txt_paramcd_rs (`picks` or `NULL`)\cr +#' `PARAMCD` annotation parameters from `ADRS`. +#' @param facet_var (`picks` or `NULL`)\cr +#' Subject-level facet variable from `ADSL`. +#' @param ytick_at (`numeric`)\cr +#' Bar height axis interval. +#' @param href_line (`character`)\cr +#' Comma-separated horizontal reference lines. +#' @param gap_point_val (`character`)\cr +#' Value for breaking high bars. +#' @param show_value (`logical`)\cr +#' Whether to show bar height values. #' #' @inherit argument_convention return #' @inheritSection teal::example_module Reporting @@ -47,56 +49,19 @@ #' @template author_qit3 #' @author houx14 \email{houx14@gene.com} #' -#' @examples -#' data <- teal_data() %>% -#' within({ -#' library(nestcolor) -#' ADSL <- rADSL -#' ADRS <- rADRS -#' ADTR <- rADTR -#' ADSL$SEX <- factor(ADSL$SEX, levels = unique(ADSL$SEX)) -#' }) -#' -#' join_keys(data) <- default_cdisc_join_keys[names(data)] -#' -#' app <- init( -#' data = data, -#' modules = modules( -#' tm_g_waterfall( -#' label = "Waterfall", -#' dataname_tr = "ADTR", -#' dataname_rs = "ADRS", -#' bar_paramcd = choices_selected(c("SLDINV"), "SLDINV"), -#' bar_var = choices_selected(c("PCHG", "AVAL"), "PCHG"), -#' bar_color_var = choices_selected(c("ARMCD", "SEX"), "ARMCD"), -#' bar_color_opt = NULL, -#' sort_var = choices_selected(c("ARMCD", "SEX"), NULL), -#' add_label_var_sl = choices_selected(c("SEX", "EOSDY"), NULL), -#' add_label_paramcd_rs = choices_selected(c("BESRSPI", "OBJRSPI"), NULL), -#' anno_txt_var_sl = choices_selected(c("SEX", "ARMCD", "BMK1", "BMK2"), NULL), -#' anno_txt_paramcd_rs = choices_selected(c("BESRSPI", "OBJRSPI"), NULL), -#' facet_var = choices_selected(c("SEX", "ARMCD", "STRATA1", "STRATA2"), NULL), -#' href_line = "-30, 20" -#' ) -#' ) -#' ) -#' if (interactive()) { -#' shinyApp(app$ui, app$server) -#' } -#' tm_g_waterfall <- function(label, dataname_tr = "ADTR", dataname_rs = "ADRS", bar_paramcd, bar_var, - bar_color_var, + bar_color_var = NULL, bar_color_opt = NULL, - sort_var, - add_label_var_sl, - add_label_paramcd_rs, - anno_txt_var_sl, - anno_txt_paramcd_rs, - facet_var, + sort_var = NULL, + add_label_var_sl = NULL, + add_label_paramcd_rs = NULL, + anno_txt_var_sl = NULL, + anno_txt_paramcd_rs = NULL, + facet_var = NULL, ytick_at = 20, href_line = NULL, gap_point_val = NULL, @@ -106,28 +71,39 @@ tm_g_waterfall <- function(label, pre_output = NULL, post_output = NULL, transformators = list()) { - message("Initializing tm_g_waterfall") checkmate::assert_string(label) checkmate::assert_string(dataname_tr) checkmate::assert_string(dataname_rs) - checkmate::assert_class(bar_paramcd, classes = "choices_selected") - checkmate::assert_class(bar_var, classes = "choices_selected") - checkmate::assert_class(bar_color_var, classes = "choices_selected") - checkmate::assert_class(sort_var, classes = "choices_selected") - checkmate::assert_class(anno_txt_var_sl, classes = "choices_selected") - checkmate::assert_class(anno_txt_paramcd_rs, classes = "choices_selected") - checkmate::assert_class(facet_var, classes = "choices_selected") - checkmate::assert_class(add_label_var_sl, classes = "choices_selected") - checkmate::assert_class(add_label_paramcd_rs, classes = "choices_selected") + checkmate::assert_class(bar_paramcd, "picks", .var.name = "bar_paramcd") + .assert_picks_single_var(bar_var, "bar_var") + if (!is.null(bar_color_var)) .assert_picks_single_var(bar_color_var, "bar_color_var") + if (!is.null(sort_var)) .assert_picks_single_var(sort_var, "sort_var") + if (!is.null(add_label_var_sl)) .assert_picks_single_var(add_label_var_sl, "add_label_var_sl") + if (!is.null(facet_var)) .assert_picks_single_var(facet_var, "facet_var") checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) - checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") + checkmate::assert_numeric( + plot_height[1], + lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height" + ) checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) checkmate::assert_numeric( plot_width[1], - lower = plot_width[2], - upper = plot_width[3], - null.ok = TRUE, - .var.name = "plot_width" + lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" + ) + + pick_slots <- Filter( + Negate(is.null), + list( + bar_paramcd = bar_paramcd, + bar_var = bar_var, + bar_color_var = bar_color_var, + sort_var = sort_var, + add_label_var_sl = add_label_var_sl, + add_label_paramcd_rs = add_label_paramcd_rs, + anno_txt_var_sl = anno_txt_var_sl, + anno_txt_paramcd_rs = anno_txt_paramcd_rs, + facet_var = facet_var + ) ) args <- as.list(environment()) @@ -135,26 +111,33 @@ tm_g_waterfall <- function(label, module( label = label, ui = ui_g_waterfall, - ui_args = args, server = srv_g_waterfall, - server_args = list( - dataname_tr = dataname_tr, - dataname_rs = dataname_rs, - bar_paramcd = bar_paramcd, - add_label_paramcd_rs = add_label_paramcd_rs, - anno_txt_paramcd_rs = anno_txt_paramcd_rs, - label = label, - bar_color_opt = bar_color_opt, - plot_height = plot_height, - plot_width = plot_width - ), + ui_args = args[names(args) %in% names(formals(ui_g_waterfall))], + server_args = args[names(args) %in% names(formals(srv_g_waterfall))], transformators = transformators, - datanames = c("ADSL", dataname_tr, dataname_rs) + datanames = unique(c("ADSL", dataname_tr, dataname_rs, .picks_all_datanames(pick_slots))) ) } -ui_g_waterfall <- function(id, ...) { - a <- list(...) +#' @keywords internal +ui_g_waterfall <- function(id, + dataname_tr, + dataname_rs, + bar_paramcd, + bar_var, + bar_color_var, + sort_var, + add_label_var_sl, + add_label_paramcd_rs, + anno_txt_var_sl, + anno_txt_paramcd_rs, + facet_var, + ytick_at, + href_line, + gap_point_val, + show_value, + pre_output, + post_output) { ns <- NS(id) teal.widgets::standard_layout( output = teal.widgets::white_small_well( @@ -162,73 +145,61 @@ ui_g_waterfall <- function(id, ...) { ), encoding = tags$div( tags$label("Encodings", class = "text-primary"), - helpText("Analysis Data: ", tags$code(a$dataname_tr), tags$code(a$dataname_rs)), - teal.widgets::optionalSelectInput( - ns("bar_paramcd"), - "Tumor Burden Parameter", - multiple = FALSE - ), - teal.widgets::optionalSelectInput( - ns("bar_var"), - "Bar Height", - choices = get_choices(a$bar_var$choices), - selected = a$bar_var$selected, - multiple = FALSE, - label_help = helpText("Tumor change variable from ", tags$code("ADTR")) - ), - teal.widgets::optionalSelectInput( - ns("bar_color_var"), - "Bar Color", - choices = get_choices(a$bar_color_var$choices), - selected = a$bar_color_var$selected, - multiple = FALSE - ), - teal.widgets::optionalSelectInput( - ns("sort_var"), - "Sort by", - choices = get_choices(a$sort_var$choices), - selected = a$sort_var$selected, - multiple = FALSE, - label_help = helpText("from ", tags$code("ADSL")) - ), - teal.widgets::optionalSelectInput( - ns("add_label_var_sl"), - "Add ADSL Label to Bars", - choices = get_choices(a$add_label_var_sl$choices), - selected = a$add_label_var_sl$selected, - multiple = FALSE - ), - teal.widgets::optionalSelectInput( - ns("add_label_paramcd_rs"), - "Add ADRS Label to Bars", - multiple = FALSE - ), - teal.widgets::optionalSelectInput( - ns("anno_txt_var_sl"), - "Annotation Variables", - choices = get_choices(a$anno_txt_var_sl$choices), - selected = a$anno_txt_var_sl$selected, - multiple = TRUE, - label_help = helpText("from ", tags$code("ADSL")) - ), - teal.widgets::optionalSelectInput( - ns("anno_txt_paramcd_rs"), - "Annotation Parameters", - multiple = TRUE, - label_help = helpText("from ", tags$code("ADRS")) + helpText("Analysis Data: ", tags$code(dataname_tr), tags$code(dataname_rs)), + tags$div( + tags$label("Tumor burden parameter"), + teal.picks::picks_ui(ns("bar_paramcd"), bar_paramcd) ), - teal.widgets::optionalSelectInput( - ns("facet_var"), - "Facet by", - choices = get_choices(a$facet_var$choices), - selected = NULL, - multiple = FALSE, - label_help = helpText("from ", tags$code("ADSL")) + tags$div( + tags$label("Bar height"), + teal.picks::picks_ui(ns("bar_var"), bar_var) ), + if (!is.null(bar_color_var)) { + tags$div( + tags$label("Bar color"), + teal.picks::picks_ui(ns("bar_color_var"), bar_color_var) + ) + }, + if (!is.null(sort_var)) { + tags$div( + tags$label("Sort by"), + teal.picks::picks_ui(ns("sort_var"), sort_var) + ) + }, + if (!is.null(add_label_var_sl)) { + tags$div( + tags$label("Add ADSL label to bars"), + teal.picks::picks_ui(ns("add_label_var_sl"), add_label_var_sl) + ) + }, + if (!is.null(add_label_paramcd_rs)) { + tags$div( + tags$label("Add ADRS label to bars"), + teal.picks::picks_ui(ns("add_label_paramcd_rs"), add_label_paramcd_rs) + ) + }, + if (!is.null(anno_txt_var_sl)) { + tags$div( + tags$label("Annotation variables (ADSL)"), + teal.picks::picks_ui(ns("anno_txt_var_sl"), anno_txt_var_sl) + ) + }, + if (!is.null(anno_txt_paramcd_rs)) { + tags$div( + tags$label("Annotation parameters (ADRS)"), + teal.picks::picks_ui(ns("anno_txt_paramcd_rs"), anno_txt_paramcd_rs) + ) + }, + if (!is.null(facet_var)) { + tags$div( + tags$label("Facet by"), + teal.picks::picks_ui(ns("facet_var"), facet_var) + ) + }, checkboxInput( ns("show_value"), "Add Bar Height Value", - value = a$show_value + value = show_value ), textInput( ns("href_line"), @@ -237,7 +208,7 @@ ui_g_waterfall <- function(id, ...) { tags$br(), helpText("Enter numeric value(s) of reference lines, separated by comma (eg. -10, 20)") ), - value = a$href_line + value = href_line ), textInput( ns("ytick_at"), @@ -246,7 +217,7 @@ ui_g_waterfall <- function(id, ...) { tags$br(), helpText("Enter a numeric value of Y axis interval") ), - value = a$ytick_at + value = ytick_at ), textInput( ns("gap_point_val"), @@ -255,105 +226,73 @@ ui_g_waterfall <- function(id, ...) { tags$br(), helpText("Enter a numeric value to break very high bars") ), - value = a$gap_point_val + value = gap_point_val ) ), - pre_output = a$pre_output, - post_output = a$post_output + pre_output = pre_output, + post_output = post_output ) } +#' @keywords internal +.waterfall_picks_selected_var <- function(selector_state) { + if (is.null(selector_state) || is.null(selector_state$variables)) { + return(character()) + } + as.character(selector_state$variables$selected) +} + +#' @keywords internal +.waterfall_picks_selected_values <- function(selector_state) { + if (is.null(selector_state) || is.null(selector_state$values)) { + return(character()) + } + as.character(selector_state$values$selected) +} + +#' @keywords internal srv_g_waterfall <- function(id, data, + dataname_tr, + dataname_rs, bar_paramcd, + bar_var, + bar_color_var, + sort_var, + add_label_var_sl, add_label_paramcd_rs, + anno_txt_var_sl, anno_txt_paramcd_rs, - dataname_tr, - dataname_rs, + facet_var, bar_color_opt, - label, plot_height, plot_width) { checkmate::assert_class(data, "reactive") - checkmate::assert_class(shiny::isolate(data()), "teal_data") + checkmate::assert_class(isolate(data()), "teal_data") moduleServer(id, function(input, output, session) { teal.logger::log_shiny_input_changes(input, namespace = "teal.osprey") - env <- as.list(isolate(data())) - resolved_bar_paramcd <- teal.transform::resolve_delayed(bar_paramcd, env) - resolved_add_label_paramcd_rs <- teal.transform::resolve_delayed(add_label_paramcd_rs, env) - resolved_anno_txt_paramcd_rs <- teal.transform::resolve_delayed(anno_txt_paramcd_rs, env) - - teal.widgets::updateOptionalSelectInput( - session = session, - inputId = "bar_paramcd", - choices = resolved_bar_paramcd$choices, - selected = resolved_bar_paramcd$selected - ) - teal.widgets::updateOptionalSelectInput( - session = session, - inputId = "add_label_paramcd_rs", - choices = resolved_add_label_paramcd_rs$choices, - selected = resolved_add_label_paramcd_rs$selected - ) - teal.widgets::updateOptionalSelectInput( - session = session, - inputId = "anno_txt_paramcd_rs", - choices = resolved_anno_txt_paramcd_rs$choices, - selected = resolved_anno_txt_paramcd_rs$selected + picks_inputs <- Filter( + Negate(is.null), + list( + bar_paramcd = bar_paramcd, + bar_var = bar_var, + bar_color_var = bar_color_var, + sort_var = sort_var, + add_label_var_sl = add_label_var_sl, + add_label_paramcd_rs = add_label_paramcd_rs, + anno_txt_var_sl = anno_txt_var_sl, + anno_txt_paramcd_rs = anno_txt_paramcd_rs, + facet_var = facet_var + ) ) - iv <- reactive({ - adsl <- data()[["ADSL"]] - adtr <- data()[[dataname_tr]] - adrs <- data()[[dataname_rs]] - - iv <- shinyvalidate::InputValidator$new() - iv$add_rule("bar_var", shinyvalidate::sv_required( - message = "Bar Height is required" - )) - iv$add_rule("bar_paramcd", shinyvalidate::sv_required( - message = "Tumor Burden Parameter is required" - )) - iv$add_rule("bar_paramcd", shinyvalidate::sv_in_set( - set = adtr$PARAMCD, - message_fmt = "All values of Tumor Burden Parameter must be elements of ADTR PARAMCD" - )) - iv$add_rule("add_label_paramcd_rs", shinyvalidate::sv_optional()) - iv$add_rule("add_label_paramcd_rs", shinyvalidate::sv_in_set( - set = adrs$PARAMCD, - message_fmt = "ADRS Label must be an element of ADRS PARAMCD" - )) - rule_excl <- function(value, other) { - if (length(value) > 0L && length(other) > 0L) { - "Only one \"Label to Bars\" is allowed" - } - } - iv$add_rule("add_label_paramcd_rs", rule_excl, other = input$add_label_var_sl) - iv$add_rule("add_label_var_sl", rule_excl, other = input$add_label_paramcd_rs) - iv$add_rule("anno_txt_paramcd_rs", shinyvalidate::sv_optional()) - iv$add_rule("anno_txt_paramcd_rs", shinyvalidate::sv_in_set( - set = adrs$PARAMCD, - message_fmt = "Annotation Parameters must be elements of ADRS PARAMCD" - )) - iv$add_rule("href_line", shinyvalidate::sv_optional()) - iv$add_rule("href_line", ~ if (anyNA(suppressWarnings(as_numeric_from_comma_sep_str(.)))) { - "Horizontal Reference Line(s) are invalid" - }) - iv$add_rule("ytick_at", shinyvalidate::sv_required( - message = "Y-axis Interval is required" - )) - iv$add_rule("ytick_at", ~ if (!checkmate::test_number(suppressWarnings(as.numeric(.)), lower = 1)) { - "Y-axis Interval must be a single positive number" - }) - iv$add_rule("gap_point_val", shinyvalidate::sv_optional()) - iv$add_rule("gap_point_val", ~ if (!checkmate::test_number(suppressWarnings(as.numeric(.)), lower = 1)) { - "Break High Bars must be a single positive number" - }) - iv$enable() - iv - }) + selectors <- teal.picks::picks_srv( + id = "", + picks = picks_inputs, + data = data + ) output_q <- reactive({ obj <- data() @@ -368,73 +307,130 @@ srv_g_waterfall <- function(id, adtr <- obj[[dataname_tr]] adrs <- obj[[dataname_rs]] - # validate data rows teal::validate_has_data(adsl, min_nrow = 2) teal::validate_has_data(adtr, min_nrow = 2) teal::validate_has_data(adrs, min_nrow = 2) - adsl_vars <- unique( - c( - "USUBJID", "STUDYID", - input$bar_color_var, input$sort_var, input$add_label_var_sl, input$anno_txt_var_sl, input$facet_var + bar_var_name <- .waterfall_picks_selected_var(selectors$bar_var()) + bar_paramcd_val <- .waterfall_picks_selected_values(selectors$bar_paramcd()) + + validate( + need(length(bar_var_name) > 0L, "Please select a bar height variable."), + need(length(bar_paramcd_val) > 0L, "Please select a tumor burden parameter.") + ) + + bar_color_var_name <- if (!is.null(bar_color_var)) { + .waterfall_picks_selected_var(selectors$bar_color_var()) + } else { + character() + } + sort_var_name <- if (!is.null(sort_var)) { + .waterfall_picks_selected_var(selectors$sort_var()) + } else { + character() + } + add_label_var_sl_name <- if (!is.null(add_label_var_sl)) { + .waterfall_picks_selected_var(selectors$add_label_var_sl()) + } else { + character() + } + add_label_paramcd_rs_val <- if (!is.null(add_label_paramcd_rs)) { + .waterfall_picks_selected_values(selectors$add_label_paramcd_rs()) + } else { + character() + } + anno_txt_var_sl_name <- if (!is.null(anno_txt_var_sl)) { + .waterfall_picks_selected_var(selectors$anno_txt_var_sl()) + } else { + character() + } + anno_txt_paramcd_rs_val <- if (!is.null(anno_txt_paramcd_rs)) { + .waterfall_picks_selected_values(selectors$anno_txt_paramcd_rs()) + } else { + character() + } + facet_var_name <- if (!is.null(facet_var)) { + .waterfall_picks_selected_var(selectors$facet_var()) + } else { + character() + } + + bar_paramcd_one <- bar_paramcd_val[[1L]] + validate( + need( + bar_paramcd_one %in% adtr$PARAMCD, + "Tumor burden parameter must be an element of ADTR PARAMCD." ) ) - adtr_vars <- unique(c("USUBJID", "STUDYID", "PARAMCD", input$bar_var)) + if (length(add_label_paramcd_rs_val) > 0L) { + validate(need( + all(add_label_paramcd_rs_val %in% adrs$PARAMCD), + "ADRS label must be an element of ADRS PARAMCD." + )) + } + if (length(add_label_var_sl_name) > 0L && length(add_label_paramcd_rs_val) > 0L) { + validate(need(FALSE, "Only one \"Label to Bars\" is allowed.")) + } + if (length(anno_txt_paramcd_rs_val) > 0L) { + validate(need( + all(anno_txt_paramcd_rs_val %in% adrs$PARAMCD), + "Annotation parameters must be elements of ADRS PARAMCD." + )) + } + + adsl_vars <- unique(c( + "USUBJID", "STUDYID", + bar_color_var_name, sort_var_name, add_label_var_sl_name, anno_txt_var_sl_name, facet_var_name + )) + adtr_vars <- unique(c("USUBJID", "STUDYID", "PARAMCD", bar_var_name)) adrs_vars <- unique(c("USUBJID", "STUDYID", "PARAMCD", "AVALC")) - adrs_paramcd <- unique(c(input$add_label_paramcd_rs, input$anno_txt_paramcd_rs)) + adrs_paramcd <- unique(c(add_label_paramcd_rs_val, anno_txt_paramcd_rs_val)) - # validate data input teal::validate_has_variable(adsl, adsl_vars) teal::validate_has_variable(adrs, adrs_vars) teal::validate_has_variable(adtr, adtr_vars) - teal::validate_inputs(iv()) - - # get variables - bar_var <- input$bar_var - bar_paramcd <- input$bar_paramcd - add_label_var_sl <- input$add_label_var_sl - add_label_paramcd_rs <- input$add_label_paramcd_rs - anno_txt_var_sl <- input$anno_txt_var_sl - anno_txt_paramcd_rs <- input$anno_txt_paramcd_rs - ytick_at <- input$ytick_at - href_line <- input$href_line + href_line <- suppressWarnings(as_numeric_from_comma_sep_str(input$href_line)) gap_point_val <- input$gap_point_val + ytick_at <- input$ytick_at show_value <- input$show_value - href_line <- suppressWarnings(as_numeric_from_comma_sep_str(href_line)) - if (gap_point_val == "") { + validate( + need( + !is.na(suppressWarnings(as.numeric(ytick_at))) && + checkmate::test_number(suppressWarnings(as.numeric(ytick_at)), lower = 1), + "Y-axis Interval must be a single positive number." + ) + ) + if (!is.null(gap_point_val) && nzchar(gap_point_val)) { + validate(need( + checkmate::test_number(suppressWarnings(as.numeric(gap_point_val)), lower = 1), + "Break High Bars must be a single positive number." + )) + } + if (!is.null(href_line) && anyNA(href_line)) { + validate(need(FALSE, "Horizontal Reference Line(s) are invalid.")) + } + + if (gap_point_val == "" || is.null(gap_point_val)) { gap_point_val <- NULL } else { gap_point_val <- as.numeric(gap_point_val) } ytick_at <- as.numeric(ytick_at) - bar_color_var <- if ( - !is.null(input$bar_color_var) && - input$bar_color_var != "None" && - input$bar_color_var != "" - ) { - input$bar_color_var - } else { - NULL - } - sort_var <- if (!is.null(input$sort_var) && input$sort_var != "None" && input$sort_var != "") { - input$sort_var - } else { - NULL - } - facet_var <- if (!is.null(input$facet_var) && input$facet_var != "None" && input$facet_var != "") { - input$facet_var - } else { - NULL - } + bar_color_var <- if (length(bar_color_var_name) > 0L) bar_color_var_name else NULL + sort_var <- if (length(sort_var_name) > 0L) sort_var_name else NULL + facet_var <- if (length(facet_var_name) > 0L) facet_var_name else NULL + add_label_var_sl <- if (length(add_label_var_sl_name) > 0L) add_label_var_sl_name else NULL + add_label_paramcd_rs <- if (length(add_label_paramcd_rs_val) > 0L) add_label_paramcd_rs_val else NULL + anno_txt_var_sl <- if (length(anno_txt_var_sl_name) > 0L) anno_txt_var_sl_name else NULL + anno_txt_paramcd_rs <- if (length(anno_txt_paramcd_rs_val) > 0L) anno_txt_paramcd_rs_val else NULL - # write variables to qenv q1 <- teal.code::eval_code( obj, code = bquote({ - bar_var <- .(bar_var) + bar_var <- .(bar_var_name) bar_color_var <- .(bar_color_var) sort_var <- .(sort_var) add_label_var_sl <- .(add_label_var_sl) @@ -448,7 +444,6 @@ srv_g_waterfall <- function(id, }) ) - # data processing q1 <- teal.code::eval_code( q1, code = bquote({ @@ -457,7 +452,7 @@ srv_g_waterfall <- function(id, adrs <- .(as.name(dataname_rs))[, .(adrs_vars)] bar_tr <- .(as.name(dataname_tr)) %>% - dplyr::filter(PARAMCD == .(bar_paramcd)) %>% + dplyr::filter(PARAMCD == .(bar_paramcd_one)) %>% dplyr::select(USUBJID, .(as.name(bar_var))) %>% dplyr::group_by(USUBJID) %>% dplyr::slice(which.min(.(as.name(bar_var)))) @@ -465,7 +460,7 @@ srv_g_waterfall <- function(id, }) ) - q1 <- if (is.null(adrs_paramcd)) { + q1 <- if (length(adrs_paramcd) == 0L) { teal.code::eval_code( q1, code = bquote({ @@ -496,14 +491,11 @@ srv_g_waterfall <- function(id, ) } - # write plotting code to qenv - anl <- q1[["anl"]] - teal.reporter::teal_card(q1) <- c( teal.reporter::teal_card(q1), "### Selected Options", - paste0("Tumor Burden Parameter: ", input$bar_paramcd, ".") + paste0("Tumor Burden Parameter: ", bar_paramcd_one, ".") ) if (!is.null(facet_var)) { @@ -521,22 +513,14 @@ srv_g_waterfall <- function(id, teal.reporter::teal_card(q1) <- c(teal.reporter::teal_card(q1), "### Plot") - q1 <- teal.code::eval_code( + teal.code::eval_code( q1, code = bquote({ plot <- osprey::g_waterfall( bar_id = anl[["USUBJID"]], bar_height = anl[[bar_var]], - sort_by = .(if (length(sort_var) > 0) { - quote(anl[[sort_var]]) - } else { - NULL - }), - col_by = .(if (length(bar_color_var) > 0) { - quote(anl[[bar_color_var]]) - } else { - NULL - }), + sort_by = .(if (length(sort_var) > 0) quote(anl[[sort_var]]) else NULL), + col_by = .(if (length(bar_color_var) > 0) quote(anl[[bar_color_var]]) else NULL), bar_color_opt = .(if (length(bar_color_var) == 0) { NULL } else if (length(bar_color_var) > 0 & all(unique(anl[[bar_color_var]]) %in% names(bar_color_opt))) { @@ -554,11 +538,7 @@ srv_g_waterfall <- function(id, quote(cbind(anl[anno_txt_var_sl], anl[anno_txt_paramcd_rs])) }), href_line = .(href_line), - facet_by = .(if (length(facet_var) > 0) { - quote(as.factor(anl[[facet_var]])) - } else { - NULL - }), + facet_by = .(if (length(facet_var) > 0) quote(as.factor(anl[[facet_var]])) else NULL), show_datavalue = .(show_value), add_label = .(if (length(add_label_var_sl) > 0 & length(add_label_paramcd_rs) == 0) { quote(anl[[add_label_var_sl]]) @@ -578,7 +558,6 @@ srv_g_waterfall <- function(id, plot_r <- reactive(output_q()[["plot"]]) - # Insert the plot into a plot_with_settings module from teal.widgets pws <- teal.widgets::plot_with_settings_srv( id = "waterfallplot", plot_r = plot_r, diff --git a/R/utils.R b/R/utils.R index 1dfcf628..d8f3d31b 100644 --- a/R/utils.R +++ b/R/utils.R @@ -70,7 +70,7 @@ ci_choices <- setNames( #' @param x ci method to retrieve its name name_ci <- function(x = ci_choices) { x <- match.arg(x) - return(paste0(names(x), " (", x, ")")) + paste0(names(x), " (", x, ")") } @@ -169,7 +169,7 @@ set_chunk_attrs <- function(teal_card, return(teal_card) } - for (ix in seq_len(length(teal_card))) { + for (ix in seq_along(teal_card)) { if (ix > n) { break } @@ -200,42 +200,3 @@ set_chunk_attrs <- function(teal_card, teal_card } - -#' Create a reactive that sets plot dimensions on a `teal_card` -#' -#' This is a convenience function that creates a reactive expression that -#' automatically sets the `dev.width` and `dev.height` attributes on the last -#' chunk outputs of a `teal_card` based on plot dimensions from a plot widget. -#' -#' @param pws (`plot_widget`) plot widget that provides dimensions via `dim()` method -#' @param q_r (`reactive`) reactive expression that returns a `teal_reporter` -#' @param inner_classes (`character`) classes within `chunk_output` that should be modified. -#' This can be used to only change `recordedplot`, `ggplot2` or other type of objects. -#' -#' @return A reactive expression that returns the `teal_card` with updated dimensions -#' -#' @keywords internal -set_chunk_dims <- function(pws, q_r, inner_classes = NULL) { - checkmate::assert_list(pws) - checkmate::assert_names(names(pws), must.include = "dim") - checkmate::assert_class(pws$dim, "reactive") - checkmate::assert_class(q_r, "reactive") - checkmate::assert_character(inner_classes, null.ok = TRUE) - - reactive({ - pws_dim <- stats::setNames(as.list(req(pws$dim())), c("width", "height")) - if (identical(pws_dim$width, "auto")) { # ignore non-numeric values (such as "auto") - pws_dim$width <- NULL - } - if (identical(pws_dim$height, "auto")) { # ignore non-numeric values (such as "auto") - pws_dim$height <- NULL - } - q <- req(q_r()) - teal.reporter::teal_card(q) <- set_chunk_attrs( - teal.reporter::teal_card(q), - list(dev.width = pws_dim$width, dev.height = pws_dim$height), - inner_classes = inner_classes - ) - q - }) -} diff --git a/R/utils_picks.R b/R/utils_picks.R new file mode 100644 index 00000000..73e73909 --- /dev/null +++ b/R/utils_picks.R @@ -0,0 +1,160 @@ +#' Create a reactive that sets plot dimensions on a `teal_card` +#' +#' This is a convenience function that creates a reactive expression that +#' automatically sets the `dev.width` and `dev.height` attributes on the last +#' chunk outputs of a `teal_card` based on plot dimensions from a plot widget. +#' +#' @return A reactive expression that returns the `teal_card` with updated dimensions +#' +#' Collect unique datanames from a list of picks objects (internal). +#' +#' @param pick_slots (`list`) named list of `picks` objects (NULL entries ignored). +#' +#' @keywords internal +#' +.picks_all_datanames <- function(pick_slots) { + pick_slots <- pick_slots[!vapply(pick_slots, is.null, logical(1))] + if (length(pick_slots) == 0L) { + return(character()) + } + all_datanames <- unique( + unlist( + lapply( + pick_slots, + function(p) { + ch <- p$datasets$choices + if (checkmate::test_character(ch, min.len = 1L)) { + return(unique(as.character(ch))) + } + sel <- p$datasets$selected + unique(as.character(unlist(sel, recursive = FALSE, use.names = FALSE))) + } + ), + use.names = FALSE + ) + ) + all_datanames[nzchar(all_datanames) & !is.na(all_datanames)] +} + +#' Assert a picks object uses single variable selection (internal). +#' +#' @param pick (`picks`) +#' @param arg_name (`character`) argument name for error messages. +#' +#' @keywords internal +.assert_picks_single_var <- function(pick, arg_name) { + checkmate::assert_class(pick, "picks", .var.name = arg_name) + checkmate::assert_false( + teal.picks::is_pick_multiple(pick$variables), + .var.name = sprintf("`%s` must use variables(..., multiple = FALSE)", arg_name) + ) +} + +#' @keywords internal +set_chunk_dims <- function(pws, q_r, inner_classes = NULL) { + checkmate::assert_list(pws) + checkmate::assert_names(names(pws), must.include = "dim") + checkmate::assert_class(pws$dim, "reactive") + checkmate::assert_class(q_r, "reactive") + checkmate::assert_character(inner_classes, null.ok = TRUE) + + reactive({ + pws_dim <- stats::setNames(as.list(req(pws$dim())), c("width", "height")) + if (identical(pws_dim$width, "auto")) { # ignore non-numeric values (such as "auto") + pws_dim$width <- NULL + } + if (identical(pws_dim$height, "auto")) { # ignore non-numeric values (such as "auto") + pws_dim$height <- NULL + } + q <- req(q_r()) + teal.reporter::teal_card(q) <- set_chunk_attrs( + teal.reporter::teal_card(q), + list(dev.width = pws_dim$width, dev.height = pws_dim$height), + inner_classes = inner_classes + ) + q + }) +} + +#' Coerce legacy `teal.transform` specs to [`teal.picks::variables()`] with deprecation +#' +#' If `x` is a legacy `choices_selected`, `filter_spec`, or `select_spec` object, it is converted +#' via [`teal.picks::as.picks()`]. Otherwise `x` must already inherit `"variables"`. +#' +#' @param x (`values`, `choices_selected` or `picks`) object. +#' @param arg_name optional (`character(1)`) argument name. +#' @param multiple optional (`logical(1)`) whether multiple values are allowed. +#' If `NULL` (default), it is not validated and inferred from the length of `selected` in the +#' `choices_selected` object. +#' @param null.ok (`logical(1)`) whether `NULL` is allowed. +#' +#' @keywords internal +#' @noRd +migrate_choices_selected_to_variables <- function(x, # nolint: object_length_linter + arg_name = checkmate::vname(x), + multiple = NULL, + null.ok = FALSE) { # nolint: object_name_linter. + # nolint: object_name_linter. + checkmate::assert_string(arg_name) + checkmate::assert_flag(multiple, null.ok = TRUE) + checkmate::assert_flag(null.ok) + if (inherits(x, "picks")) { + return(x) + } + + if (isTRUE(null.ok) && is.null(x)) { + return(x) + } + legacy <- c("choices_selected", "filter_spec", "select_spec") + if (inherits(x, legacy)) { + lifecycle::deprecate_warn( + when = "0.5.0", + what = I(paste0("`", arg_name, "`")), + details = paste( + "Pass `teal.picks::variables()` (or a full `teal.picks::picks()` chain).", + "Support for legacy `teal.transform::choices_selected()`, `filter_spec`, and `select_spec` is deprecated." + ) + ) + x <- teal.picks::as.picks(x, quiet = FALSE) + attr(x, "multiple") <- (!is.null(multiple) && multiple) || (is.null(multiple) && length(x$selected) > 1L) + } else { + if (!is.null(multiple) && !identical(attr(x, "multiple", exact = TRUE), multiple)) { + stop( + sprintf("`multiple` metadata does not match the requirement for %s.", arg_name), + sprintf(" Please set multiple = %s in the picks object.", multiple), + call. = FALSE + ) + } + } + checkmate::assert_class( + x, + "variables", + null.ok = null.ok, + .var.name = arg_name + ) + x +} + +#' Supports the creation of picks object that does not override a dataset if already exists +#' @param datasets ([`teal.picks::datasets()`] object) to use if `x` does not already have a dataset. +#' @param x (`pick` or `picks` object) to ensure has a dataset. +#' @return a `picks` object with a dataset, either from `x` or from `datasets`. +#' @keywords internal +#' @noRd +create_picks_helper <- function(datasets = NULL, x) { + if (inherits(x, "picks") && !is.null(x$datasets)) { + return(x) + } + checkmate::assert_class(datasets, "datasets", null.ok = FALSE) + checkmate::assert_multi_class(x, c("pick", "picks")) + + if (inherits(x, "picks")) { + picks_args <- list(datasets, x$variables, x$values) + do.call( + teal.picks::picks, + picks_args[vapply(picks_args, Negate(is.null), logical(1L))], + ) + } else if (inherits(x, "pick")) { + teal.picks::picks(datasets, x) + } +} diff --git a/inst/WORDLIST b/inst/WORDLIST index 21a72e78..3362c023 100644 --- a/inst/WORDLIST +++ b/inst/WORDLIST @@ -8,12 +8,15 @@ UI Xuefeng chot ci +datanames dichotomization funder +ggplot houx liaoc lil pre qit reportable +shinytest zhanc diff --git a/man/argument_convention.Rd b/man/argument_convention.Rd index a85d149d..e78a18e4 100644 --- a/man/argument_convention.Rd +++ b/man/argument_convention.Rd @@ -32,7 +32,7 @@ vector to indicate default value, minimum and maximum values.} vector to indicate default value, minimum and maximum values.} } \value{ -the \code{\link[teal:teal_modules]{teal::module()}} object. +the \code{\link[teal:module]{teal::module()}} object. } \description{ The documentation to this function lists all the arguments in teal modules diff --git a/man/dot-assert_picks_single_var.Rd b/man/dot-assert_picks_single_var.Rd new file mode 100644 index 00000000..e424df4c --- /dev/null +++ b/man/dot-assert_picks_single_var.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils_picks.R +\name{.assert_picks_single_var} +\alias{.assert_picks_single_var} +\title{Assert a picks object uses single variable selection (internal).} +\usage{ +.assert_picks_single_var(pick, arg_name) +} +\arguments{ +\item{pick}{(\code{picks})} + +\item{arg_name}{(\code{character}) argument name for error messages.} +} +\description{ +Assert a picks object uses single variable selection (internal). +} +\keyword{internal} diff --git a/man/set_chunk_dims.Rd b/man/dot-picks_all_datanames.Rd similarity index 53% rename from man/set_chunk_dims.Rd rename to man/dot-picks_all_datanames.Rd index aea85363..49fbc8a7 100644 --- a/man/set_chunk_dims.Rd +++ b/man/dot-picks_all_datanames.Rd @@ -1,21 +1,18 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/utils.R -\name{set_chunk_dims} -\alias{set_chunk_dims} +% Please edit documentation in R/utils_picks.R +\name{.picks_all_datanames} +\alias{.picks_all_datanames} \title{Create a reactive that sets plot dimensions on a \code{teal_card}} \usage{ -set_chunk_dims(pws, q_r, inner_classes = NULL) +.picks_all_datanames(pick_slots) } \arguments{ -\item{pws}{(\code{plot_widget}) plot widget that provides dimensions via \code{dim()} method} - -\item{q_r}{(\code{reactive}) reactive expression that returns a \code{teal_reporter}} - -\item{inner_classes}{(\code{character}) classes within \code{chunk_output} that should be modified. -This can be used to only change \code{recordedplot}, \code{ggplot2} or other type of objects.} +\item{pick_slots}{(\code{list}) named list of \code{picks} objects (NULL entries ignored).} } \value{ A reactive expression that returns the \code{teal_card} with updated dimensions + +Collect unique datanames from a list of picks objects (internal). } \description{ This is a convenience function that creates a reactive expression that diff --git a/man/plot_decorate_output.Rd b/man/plot_decorate_output.Rd index 67dd48ef..87b78b06 100644 --- a/man/plot_decorate_output.Rd +++ b/man/plot_decorate_output.Rd @@ -13,5 +13,5 @@ plot_decorate_output(id) An html element. } \description{ -Adds \code{\link[teal.widgets:plot_with_settings]{teal.widgets::plot_with_settings_ui()}} +Adds \code{\link[teal.widgets:plot_with_settings_ui]{plot_with_settings_ui()}} } diff --git a/man/teal.osprey-package.Rd b/man/teal.osprey-package.Rd index f7f0d8b9..a5b976d2 100644 --- a/man/teal.osprey-package.Rd +++ b/man/teal.osprey-package.Rd @@ -24,6 +24,7 @@ Useful links: Authors: \itemize{ + \item Nina Qi \email{qit3@gene.com} \item Dawid Kaledkowski \email{dawid.kaledkowski@roche.com} \item Chendi Liao \email{chendi.liao@roche.com} \item Liming Li \email{liming.li@roche.com} diff --git a/man/tm_g_ae_oview.Rd b/man/tm_g_ae_oview.Rd index 375f1212..fdb89eef 100644 --- a/man/tm_g_ae_oview.Rd +++ b/man/tm_g_ae_oview.Rd @@ -19,17 +19,18 @@ tm_g_ae_oview( \item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. For \code{modules()} defaults to \code{"root"}. See \code{Details}.} -\item{dataname}{(\code{character(1)})\cr -analysis data used in the teal module, needs to be -available in the list passed to the \code{data} argument of \code{\link[teal:init]{teal::init()}}.} +\item{dataname}{(\code{character(1)}) Name of the events dataset. Required when +using the default method with \link[teal.transform:choices_selected]{choices_selected}. +Ignored by the \code{.picks} method.} \item{arm_var}{(\code{choices_selected})\cr object with all available choices and the pre-selected option for variable names that can be used as \code{arm_var}. See \code{\link[teal.transform:choices_selected]{teal.transform::choices_selected()}} for details. Column \code{arm_var} in the \code{dataname} has to be a factor.} -\item{flag_var_anl}{(\code{\link[teal.transform:choices_selected]{teal.transform::choices_selected}}) -\code{choices_selected} object with variables used to count adverse event +\item{flag_var_anl}{Either a (\code{\link[teal.transform:choices_selected]{teal.transform::choices_selected}}) +\code{choices_selected} object or a (\verb{[teal.picks::variables()]}) +object with variables used to count adverse event sub-groups (e.g. Serious events, Related events, etc.)} \item{fontsize}{(\code{numeric(1)} or \code{numeric(3)})\cr @@ -47,7 +48,7 @@ vector to indicate default value, minimum and maximum values.} To learn more check \code{vignette("transform-input-data", package = "teal")}.} } \value{ -the \code{\link[teal:teal_modules]{teal::module()}} object. +the \code{\link[teal:module]{teal::module()}} object. } \description{ Display the \code{AE} overview plot as a shiny module @@ -95,27 +96,21 @@ data <- teal_data() \%>\% } ADAE <- .add_event_flags(ADAE) }) - join_keys(data) <- default_cdisc_join_keys[names(data)] - ADAE <- data[["ADAE"]] - app <- init( data = data, modules = modules( tm_g_ae_oview( label = "AE Overview", dataname = "ADAE", - arm_var = choices_selected( - selected = "ACTARM", - choices = c("ACTARM", "ACTARMCD") + arm_var = variables( + choices = dplyr::starts_with("ACTARM"), + selected = "ACTARMCD" ), - flag_var_anl = choices_selected( - selected = "AEREL1", - choices = variable_choices( - ADAE, - c("TMPFL_SER", "TMPFL_REL", "TMPFL_GR5", "AEREL1", "AEREL2") - ), + flag_var_anl = variables( + choices = c("TMPFL_SER", "TMPFL_REL", "TMPFL_GR5", "AEREL1", "AEREL2"), + selected = "AEREL1" ), plot_height = c(600, 200, 2000) ) @@ -124,5 +119,4 @@ app <- init( if (interactive()) { shinyApp(app$ui, app$server) } - } diff --git a/man/tm_g_ae_sub.Rd b/man/tm_g_ae_sub.Rd index e830c26b..6a1cd3ab 100644 --- a/man/tm_g_ae_sub.Rd +++ b/man/tm_g_ae_sub.Rd @@ -45,7 +45,7 @@ plot.} To learn more check \code{vignette("transform-input-data", package = "teal")}.} } \value{ -the \code{\link[teal:teal_modules]{teal::module()}} object. +the \code{\link[teal:module]{teal::module()}} object. } \description{ Display the \code{AE} by subgroups plot as a teal module diff --git a/man/tm_g_butterfly.Rd b/man/tm_g_butterfly.Rd index cc2f0673..80dcc3cc 100644 --- a/man/tm_g_butterfly.Rd +++ b/man/tm_g_butterfly.Rd @@ -70,7 +70,7 @@ into context. For example the \code{\link[shiny:helpText]{shiny::helpText()}} el To learn more check \code{vignette("transform-input-data", package = "teal")}.} } \value{ -the \code{\link[teal:teal_modules]{teal::module()}} object. +the \code{\link[teal:module]{teal::module()}} object. } \description{ Display butterfly plot as a shiny module diff --git a/man/tm_g_events_term_id.Rd b/man/tm_g_events_term_id.Rd index f7745d13..e3af6ce8 100644 --- a/man/tm_g_events_term_id.Rd +++ b/man/tm_g_events_term_id.Rd @@ -1,14 +1,30 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/tm_g_events_term_id.R +% Please edit documentation in R/tm_g_events_term_id.R, +% R/tm_g_events_term_id_picks.R \name{tm_g_events_term_id} \alias{tm_g_events_term_id} +\alias{tm_g_events_term_id.picks} \title{Events by Term Plot Teal Module} \usage{ tm_g_events_term_id( - label, - dataname, - term_var, - arm_var, + label = "Common AE", + term_var = teal.picks::picks(teal.picks::datasets(), teal.picks::variables(choices = + teal.picks::is_categorical(min.len = 2), selected = 1L)), + arm_var = teal.picks::picks(teal.picks::datasets(), teal.picks::variables(choices = + teal.picks::is_categorical(min.len = 2), selected = 1L)), + fontsize = c(5, 3, 7), + plot_height = c(600L, 200L, 2000L), + plot_width = NULL, + transformators = list() +) + +tm_g_events_term_id.picks( + label = "Common AE", + dataname = NULL, + term_var = teal.picks::picks(teal.picks::datasets(), teal.picks::variables(choices = + teal.picks::is_categorical(min.len = 2), selected = 1L)), + arm_var = teal.picks::picks(teal.picks::datasets(), teal.picks::variables(choices = + teal.picks::is_categorical(min.len = 2), selected = 1L)), fontsize = c(5, 3, 7), plot_height = c(600L, 200L, 2000L), plot_width = NULL, @@ -19,17 +35,12 @@ tm_g_events_term_id( \item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. For \code{modules()} defaults to \code{"root"}. See \code{Details}.} -\item{dataname}{(\code{character(1)})\cr -analysis data used in the teal module, needs to be -available in the list passed to the \code{data} argument of \code{\link[teal:init]{teal::init()}}.} +\item{term_var}{(\code{picks})\cr +\code{\link[teal.picks:picks]{teal.picks::picks()}} object for the event term variable (single selection).} -\item{term_var}{\link[teal.transform:choices_selected]{teal.transform::choices_selected} object with all available choices -and pre-selected option names that can be used to specify the term for events} - -\item{arm_var}{(\code{choices_selected})\cr -object with all available choices and the pre-selected option for variable -names that can be used as \code{arm_var}. See \code{\link[teal.transform:choices_selected]{teal.transform::choices_selected()}} for -details. Column \code{arm_var} in the \code{dataname} has to be a factor.} +\item{arm_var}{(\code{picks})\cr +\code{\link[teal.picks:picks]{teal.picks::picks()}} object for the treatment arm variable (single selection). +The arm variable must be a factor in the analysis data.} \item{fontsize}{(\code{numeric(1)} or \code{numeric(3)})\cr Defines initial possible range of font-size. \code{fontsize} is set for @@ -44,13 +55,22 @@ vector to indicate default value, minimum and maximum values.} \item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. To learn more check \code{vignette("transform-input-data", package = "teal")}.} + +\item{dataname}{(\code{character(1)})\cr +analysis data used in the teal module, needs to be +available in the list passed to the \code{data} argument of \code{\link[teal:init]{teal::init()}}.} } \value{ -the \code{\link[teal:teal_modules]{teal::module()}} object. +the \code{\link[teal:module]{teal::module()}} object. } \description{ -Display Events by Term plot as a shiny module +Display an events-by-term plot as a Shiny module using \code{\link[teal.picks:picks]{teal.picks::picks()}} encodings. } +\section{Functions}{ +\itemize{ +\item \code{tm_g_events_term_id.picks()}: \code{\link[teal.picks:picks]{teal.picks::picks()}}-based encodings (\code{picks}). + +}} \section{Reporting}{ @@ -81,17 +101,19 @@ app <- init( modules = modules( tm_g_events_term_id( label = "Common AE", - dataname = "ADAE", - term_var = choices_selected( - selected = "AEDECOD", - choices = c( - "AEDECOD", "AETERM", - "AEHLT", "AELLT", "AEBODSYS" + term_var = teal.picks::picks( + teal.picks::datasets("ADAE"), + teal.picks::variables( + choices = teal.picks::is_categorical(min.len = 2), + selected = "AEDECOD" ) ), - arm_var = choices_selected( - selected = "ACTARMCD", - choices = c("ACTARM", "ACTARMCD") + arm_var = teal.picks::picks( + teal.picks::datasets("ADSL"), + teal.picks::variables( + choices = teal.picks::is_categorical(min.len = 2), + selected = "ACTARMCD" + ) ), plot_height = c(600, 200, 2000) ) diff --git a/man/tm_g_heat_bygrade.Rd b/man/tm_g_heat_bygrade.Rd index 9aa0c127..6dd9e6ba 100644 --- a/man/tm_g_heat_bygrade.Rd +++ b/man/tm_g_heat_bygrade.Rd @@ -72,7 +72,7 @@ vector to indicate default value, minimum and maximum values.} To learn more check \code{vignette("transform-input-data", package = "teal")}.} } \value{ -the \code{\link[teal:teal_modules]{teal::module()}} object. +the \code{\link[teal:module]{teal::module()}} object. } \description{ Display the heatmap by grade as a shiny module diff --git a/man/tm_g_patient_profile.Rd b/man/tm_g_patient_profile.Rd index 48ceb14d..22f6e3d8 100644 --- a/man/tm_g_patient_profile.Rd +++ b/man/tm_g_patient_profile.Rd @@ -93,7 +93,7 @@ into context. For example the \code{\link[shiny:helpText]{shiny::helpText()}} el To learn more check \code{vignette("transform-input-data", package = "teal")}.} } \value{ -the \code{\link[teal:teal_modules]{teal::module()}} object. +the \code{\link[teal:module]{teal::module()}} object. } \description{ Display patient profile plot as a shiny module diff --git a/man/tm_g_spiderplot.Rd b/man/tm_g_spiderplot.Rd index fbda9e0a..3c98e64e 100644 --- a/man/tm_g_spiderplot.Rd +++ b/man/tm_g_spiderplot.Rd @@ -73,7 +73,7 @@ into context. For example the \code{\link[shiny:helpText]{shiny::helpText()}} el To learn more check \code{vignette("transform-input-data", package = "teal")}.} } \value{ -the \code{\link[teal:teal_modules]{teal::module()}} object. +the \code{\link[teal:module]{teal::module()}} object. } \description{ Display spider plot as a shiny module diff --git a/man/tm_g_swimlane.Rd b/man/tm_g_swimlane.Rd index fac41f64..08dd9b54 100644 --- a/man/tm_g_swimlane.Rd +++ b/man/tm_g_swimlane.Rd @@ -29,35 +29,38 @@ tm_g_swimlane( \item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. For \code{modules()} defaults to \code{"root"}. See \code{Details}.} -\item{dataname}{analysis data used for plotting, needs to be available in the list passed to the \code{data} -argument of \code{\link[teal:init]{teal::init()}}. If no markers are to be plotted in the module, \code{"ADSL"} should be -the input. If markers are to be plotted, data name for the marker data should be the input} +\item{dataname}{(\code{character(1)})\cr +Analysis data used for markers. Use \code{"ADSL"} when no markers are plotted.} -\item{bar_var}{\link[teal.transform:choices_selected]{teal.transform::choices_selected} subject-level numeric variable from dataset -to plot as the bar length} +\item{bar_var}{(\code{picks})\cr +Subject-level numeric variable for bar length (from \code{ADSL}).} -\item{bar_color_var}{\link[teal.transform:choices_selected]{teal.transform::choices_selected} color by variable (subject-level)} +\item{bar_color_var}{(\code{picks} or \code{NULL})\cr +Subject-level color variable from \code{ADSL}.} -\item{sort_var}{\code{choices_selected} sort by variable (subject-level)} +\item{sort_var}{(\code{picks} or \code{NULL})\cr +Subject-level sort variable from \code{ADSL}.} -\item{marker_pos_var}{\link[teal.transform:choices_selected]{teal.transform::choices_selected} variable for marker position from marker data -(Note: make sure that marker position has the same relative start day as bar length variable \code{bar_var}} +\item{marker_pos_var}{(\code{picks} or \code{NULL})\cr +Marker position variable from \code{dataname} (when not \code{"ADSL"}).} -\item{marker_shape_var}{\link[teal.transform:choices_selected]{teal.transform::choices_selected} marker shape variable from marker data} +\item{marker_shape_var}{(\code{picks} or \code{NULL})\cr +Marker shape variable from \code{dataname}.} -\item{marker_shape_opt}{aesthetic values to map shape values (named vector to map shape values to each name). -If not \code{NULL}, please make sure this contains all possible values for \code{marker_shape_var} values, -otherwise shape will be assigned by \code{ggplot} default} +\item{marker_shape_opt}{(\code{numeric})\cr +Named vector mapping shape values to ggplot shapes.} -\item{marker_color_var}{marker color variable from marker data} +\item{marker_color_var}{(\code{picks} or \code{NULL})\cr +Marker color variable from \code{dataname}.} -\item{marker_color_opt}{aesthetic values to map color values (named vector to map color values to each name). -If not \code{NULL}, please make sure this contains all possible values for \code{marker_color_var} values, -otherwise color will be assigned by \code{ggplot} default} +\item{marker_color_opt}{(\code{character})\cr +Named vector mapping color values to colors.} -\item{anno_txt_var}{character vector with subject-level variable names that are selected as annotation} +\item{anno_txt_var}{(\code{picks} or \code{NULL})\cr +Subject-level annotation variables from \code{ADSL} (multiple selection allowed).} -\item{vref_line}{vertical reference lines} +\item{vref_line}{(\code{numeric})\cr +Vertical reference lines.} \item{plot_height}{(\code{numeric(3)})\cr vector to indicate default value, minimum and maximum values.} @@ -71,16 +74,18 @@ with text placed before the output to put the output into context. For example a \item{post_output}{(\code{shiny.tag}) optional, with text placed after the output to put the output into context. For example the \code{\link[shiny:helpText]{shiny::helpText()}} elements are useful.} -\item{x_label}{the label of the x axis} +\item{x_label}{(\code{character})\cr +Label of the x axis.} \item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. To learn more check \code{vignette("transform-input-data", package = "teal")}.} } \value{ -the \code{\link[teal:teal_modules]{teal::module()}} object. +the \code{\link[teal:module]{teal::module()}} object. } \description{ -This is teal module that generates a \code{swimlane} plot (bar plot with markers) for \code{ADaM} data +This is a teal module that generates a \code{swimlane} plot (bar plot with markers) for \code{ADaM} data +using \code{\link[teal.picks:picks]{teal.picks::picks()}} encodings. } \section{Reporting}{ @@ -98,78 +103,6 @@ For more information on reporting in \code{teal}, see the vignettes: } -\examples{ -# Example using stream (ADaM) dataset -data <- teal_data() \%>\% - within({ - library(nestcolor) - library(dplyr) - ADSL <- rADSL \%>\% - mutate(TRTDURD = as.integer(TRTEDTM - TRTSDTM) + 1) \%>\% - filter(STRATA1 == "A" & ARMCD == "ARM A") - ADRS <- rADRS \%>\% - filter(PARAMCD == "LSTASDI" & DCSREAS == "Death") \%>\% - mutate(AVALC = DCSREAS, ADY = EOSDY) \%>\% - rbind(rADRS \%>\% filter(PARAMCD == "OVRINV" & AVALC != "NE")) \%>\% - arrange(USUBJID) - }) - -join_keys(data) <- default_cdisc_join_keys[names(data)] - -ADSL <- data[["ADSL"]] -ADRS <- data[["ADRS"]] - -app <- init( - data = data, - modules = modules( - tm_g_swimlane( - label = "Swimlane Plot", - dataname = "ADRS", - bar_var = choices_selected( - selected = "TRTDURD", - choices = c("TRTDURD", "EOSDY") - ), - bar_color_var = choices_selected( - selected = "EOSSTT", - choices = c("EOSSTT", "ARM", "ARMCD", "ACTARM", "ACTARMCD", "SEX") - ), - sort_var = choices_selected( - selected = "ACTARMCD", - choices = c("USUBJID", "SITEID", "ACTARMCD", "TRTDURD") - ), - marker_pos_var = choices_selected( - selected = "ADY", - choices = c("ADY") - ), - marker_shape_var = choices_selected( - selected = "AVALC", - c("AVALC", "AVISIT") - ), - marker_shape_opt = c("CR" = 16, "PR" = 17, "SD" = 18, "PD" = 15, "Death" = 8), - marker_color_var = choices_selected( - selected = "AVALC", - choices = c("AVALC", "AVISIT") - ), - marker_color_opt = c( - "CR" = "green", "PR" = "blue", "SD" = "goldenrod", - "PD" = "red", "Death" = "black" - ), - vref_line = c(30, 60), - anno_txt_var = choices_selected( - selected = c("ACTARM", "SEX"), - choices = c( - "ARM", "ARMCD", "ACTARM", "ACTARMCD", "AGEGR1", - "SEX", "RACE", "COUNTRY", "DCSREAS", "DCSREASP" - ) - ) - ) - ) -) -if (interactive()) { - shinyApp(app$ui, app$server) -} - -} \author{ Ting Qi (qit3) \email{qit3@gene.com} } diff --git a/man/tm_g_waterfall.Rd b/man/tm_g_waterfall.Rd index 799b57d3..f7915825 100644 --- a/man/tm_g_waterfall.Rd +++ b/man/tm_g_waterfall.Rd @@ -10,14 +10,14 @@ tm_g_waterfall( dataname_rs = "ADRS", bar_paramcd, bar_var, - bar_color_var, + bar_color_var = NULL, bar_color_opt = NULL, - sort_var, - add_label_var_sl, - add_label_paramcd_rs, - anno_txt_var_sl, - anno_txt_paramcd_rs, - facet_var, + sort_var = NULL, + add_label_var_sl = NULL, + add_label_paramcd_rs = NULL, + anno_txt_var_sl = NULL, + anno_txt_paramcd_rs = NULL, + facet_var = NULL, ytick_at = 20, href_line = NULL, gap_point_val = NULL, @@ -33,52 +33,53 @@ tm_g_waterfall( \item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. For \code{modules()} defaults to \code{"root"}. See \code{Details}.} -\item{dataname_tr}{tumor burden analysis data used in teal module to plot as bar height, needs to -be available in the list passed to the \code{data} argument of \code{\link[teal:init]{teal::init()}}} +\item{dataname_tr}{(\code{character(1)})\cr +Tumor burden dataset name (e.g. \code{"ADTR"}).} -\item{dataname_rs}{response analysis data used in teal module to label response parameters, needs to -be available in the list passed to the \code{data} argument of \code{\link[teal:init]{teal::init()}}} +\item{dataname_rs}{(\code{character(1)})\cr +Response dataset name (e.g. \code{"ADRS"}).} -\item{bar_paramcd}{\code{choices_selected} parameter in tumor burden data that will be plotted as -bar height} +\item{bar_paramcd}{(\code{picks})\cr +\code{PARAMCD} selection for tumor burden data (\code{values} slot).} -\item{bar_var}{\code{choices_selected} numeric variable from dataset to plot the bar height, e.g., \code{PCHG}} +\item{bar_var}{(\code{picks})\cr +Numeric variable for bar height (e.g. \code{PCHG}).} -\item{bar_color_var}{\code{choices_selected} color by variable (subject level), \code{None} corresponds -to \code{NULL}} +\item{bar_color_var}{(\code{picks} or \code{NULL})\cr +Subject-level color variable from \code{ADSL}.} -\item{bar_color_opt}{aesthetic values to map color values (named vector to map color values to each name). -If not \code{NULL}, please make sure this contains all possible values for \code{bar_color_var} values, -otherwise color will be assigned by \code{ggplot} default, please note that \code{NULL} needs to be specified -in this case} +\item{bar_color_opt}{(\code{character})\cr +Named vector mapping color values to colors.} -\item{sort_var}{\code{choices_selected} sort by variable (subject level), \code{None} corresponds -to \code{NULL}} +\item{sort_var}{(\code{picks} or \code{NULL})\cr +Subject-level sort variable from \code{ADSL}.} -\item{add_label_var_sl}{\code{choices_selected} add label to bars (subject level), \code{None} -corresponds to \code{NULL}} +\item{add_label_var_sl}{(\code{picks} or \code{NULL})\cr +Subject-level bar label variable from \code{ADSL}.} -\item{add_label_paramcd_rs}{\code{choices_selected} add label to bars (response dataset), \code{None} -corresponds to \code{NULL}. At least one of \code{add_label_var_sl} and \code{add_label_paramcd_rs} needs -to be \code{NULL}} +\item{add_label_paramcd_rs}{(\code{picks} or \code{NULL})\cr +\code{PARAMCD} label from response data (\code{ADRS}).} -\item{anno_txt_var_sl}{\code{choices_selected} subject level variables to be displayed in the annotation -table, default is \code{NULL}} +\item{anno_txt_var_sl}{(\code{picks} or \code{NULL})\cr +Subject-level annotation variables from \code{ADSL}.} -\item{anno_txt_paramcd_rs}{\code{choices_selected} analysis dataset variables to be displayed in the -annotation table, default is \code{NULL}} +\item{anno_txt_paramcd_rs}{(\code{picks} or \code{NULL})\cr +\code{PARAMCD} annotation parameters from \code{ADRS}.} -\item{facet_var}{\code{choices_selected} facet by variable (subject level), \code{None} corresponds to -\code{NULL}} +\item{facet_var}{(\code{picks} or \code{NULL})\cr +Subject-level facet variable from \code{ADSL}.} -\item{ytick_at}{bar height axis interval, default is 20} +\item{ytick_at}{(\code{numeric})\cr +Bar height axis interval.} -\item{href_line}{numeric vector to plot horizontal reference lines, default is \code{NULL}} +\item{href_line}{(\code{character})\cr +Comma-separated horizontal reference lines.} -\item{gap_point_val}{singular numeric value for adding bar break when some bars are significantly higher -than others, default is \code{NULL}} +\item{gap_point_val}{(\code{character})\cr +Value for breaking high bars.} -\item{show_value}{boolean of whether value of bar height is shown, default is \code{TRUE}} +\item{show_value}{(\code{logical})\cr +Whether to show bar height values.} \item{plot_height}{(\code{numeric(3)})\cr vector to indicate default value, minimum and maximum values.} @@ -96,10 +97,11 @@ into context. For example the \code{\link[shiny:helpText]{shiny::helpText()}} el To learn more check \code{vignette("transform-input-data", package = "teal")}.} } \value{ -the \code{\link[teal:teal_modules]{teal::module()}} object. +the \code{\link[teal:module]{teal::module()}} object. } \description{ -This is teal module that generates a waterfall plot for \code{ADaM} data +This is a teal module that generates a waterfall plot for \code{ADaM} data using +\code{\link[teal.picks:picks]{teal.picks::picks()}} encodings. } \section{Reporting}{ @@ -117,44 +119,6 @@ For more information on reporting in \code{teal}, see the vignettes: } -\examples{ -data <- teal_data() \%>\% - within({ - library(nestcolor) - ADSL <- rADSL - ADRS <- rADRS - ADTR <- rADTR - ADSL$SEX <- factor(ADSL$SEX, levels = unique(ADSL$SEX)) - }) - -join_keys(data) <- default_cdisc_join_keys[names(data)] - -app <- init( - data = data, - modules = modules( - tm_g_waterfall( - label = "Waterfall", - dataname_tr = "ADTR", - dataname_rs = "ADRS", - bar_paramcd = choices_selected(c("SLDINV"), "SLDINV"), - bar_var = choices_selected(c("PCHG", "AVAL"), "PCHG"), - bar_color_var = choices_selected(c("ARMCD", "SEX"), "ARMCD"), - bar_color_opt = NULL, - sort_var = choices_selected(c("ARMCD", "SEX"), NULL), - add_label_var_sl = choices_selected(c("SEX", "EOSDY"), NULL), - add_label_paramcd_rs = choices_selected(c("BESRSPI", "OBJRSPI"), NULL), - anno_txt_var_sl = choices_selected(c("SEX", "ARMCD", "BMK1", "BMK2"), NULL), - anno_txt_paramcd_rs = choices_selected(c("BESRSPI", "OBJRSPI"), NULL), - facet_var = choices_selected(c("SEX", "ARMCD", "STRATA1", "STRATA2"), NULL), - href_line = "-30, 20" - ) - ) -) -if (interactive()) { - shinyApp(app$ui, app$server) -} - -} \author{ Ting Qi (qit3) \email{qit3@gene.com} diff --git a/tests/testthat/helper-TealAppDriver.R b/tests/testthat/helper-TealAppDriver.R new file mode 100644 index 00000000..d2fa1454 --- /dev/null +++ b/tests/testthat/helper-TealAppDriver.R @@ -0,0 +1,242 @@ +# Setup timeout options for shinytest2 if none are set in options nor on environment variables +withr::local_options( + list( + shinytest2.timeout = getOption( + "shinytest2.timeout", + default = Sys.getenv("SHINYTEST2_TIMEOUT", unset = 30 * 1000) + ), + shinytest2.load_timeout = getOption( + "shinytest2.load_timeout", + default = Sys.getenv("SHINYTEST2_LOAD_TIMEOUT", unset = 60 * 1000) + ), + shinytest2.duration = getOption( + "shinytest2.duration", + default = Sys.getenv("SHINYTEST2_DURATION", unset = 0.5 * 1000) + ) + ), + .local_envir = testthat::test_env() +) + +# Initialization function to create a new TealAppDriver object +# +# By manipulating the server function as below, we can hint {shinytest2} to load +# this package and its "Depends". +# Related to https://github.com/rstudio/shinytest2/issues/381 +init_teal_app_driver <- function(...) { + testthat::with_mocked_bindings( + { + TealAppDriver <- getFromNamespace("TealAppDriver", "teal") # nolint: object_name_linter. + TealAppDriver$new(...) + }, + shinyApp = function(ui, server, ...) { + functionBody(server) <- bquote({ + # Hint to shinytest2 that this package should be available (via {globals}) + .hint_to_load_package <- tm_g_events_term_id + .(functionBody(server)) + }) + + shiny::shinyApp(ui, server, ...) + }, + # The relevant shinyApp call in `TealAppDriver` is being called without prefix, + # hence why the package bindings that is changed is in {teal} and not {shiny} + .package = "teal" + ) +} + +# Escape a string for use as a JavaScript double-quoted literal (ids, Shiny input names, values). +.teal_picks_js_id_literal <- function(id) { # nolint: object_length_linter. + id <- gsub("\\", "\\\\", id, fixed = TRUE) + id <- gsub("\"", "\\\"", id, fixed = TRUE) + id <- gsub("\r", "\\r", id, fixed = TRUE) + id <- gsub("\n", "\\n", id, fixed = TRUE) + paste0("\"", id, "\"") +} + +# JSON `[]`, a JSON string, or JSON string array for embedded JS (see `singleton_as_bare_string`). +# +# When `singleton_as_bare_string` is `TRUE` and `length(val) == 1L`, return a single JSON string +# token (e.g. `"foo"`). Otherwise return a JSON array (`[]`, `["a"]`, or `["a","b"]`). The +# always-array form is used where `const arr = ...` must remain an array (DOM sync script). +.teal_picks_js_json_collection_literal <- function(val, singleton_as_bare_string) { # nolint: object_length_linter. + val <- as.character(val) + if (length(val) == 0L) { + return("[]") + } + parts <- vapply(val, .teal_picks_js_id_literal, character(1)) + if (isTRUE(singleton_as_bare_string) && length(val) == 1L) { + return(parts[[1L]]) + } + paste0("[", paste(parts, collapse = ","), "]") +} + +# JavaScript array literal of quoted strings for picker values (may be empty). +.teal_picks_js_string_array_literal <- function(val) { # nolint: object_length_linter. + .teal_picks_js_json_collection_literal(val, singleton_as_bare_string = FALSE) +} + +# Scalar string or character vector for `AppDriver$set_inputs()` (empty multi-select: `character(0)`). +.teal_picks_shiny_selected_value_for_set_inputs <- function(val) { # nolint: object_length_linter. + val <- as.character(val) + if (length(val) == 0L) { + character(0) + } else if (length(val) == 1L) { + val[[1L]] + } else { + val + } +} + +# Sync native instead (true committed option(s)). +get_teal_picks_slot <- function(app_driver, pick_id, slot = "variables") { + checkmate::assert_string(pick_id) + checkmate::assert_string(slot) + selected_pick <- teal_picks_exports(app_driver, pick_id)[["picks_resolved"]] + selected_pick[[slot]]$selected +} + +# Read all exported values for a teal.picks module, filtered to those with the module's namespace prefix. +teal_picks_exports <- function(app_driver, pick_id) { + checkmate::assert_string(pick_id) + sel_id <- app_driver$namespaces()$module(pick_id) + exports <- app_driver$get_values(export = TRUE)$export + exports_filtered <- exports[grepl(sprintf("^%s", sel_id), names(exports))] + names(exports_filtered) <- sub(sprintf("^%s-", sel_id), "", names(exports_filtered)) + exports_filtered +} + +# Set a categorical teal.picks slot. `set_input` alone often does not refresh bootstrap-select +# or trigger teal.picks' commit observer reliably; sync the DOM widget then pulse +# `*_selected_open` via Shiny.setInputValue. +# Use value = NULL for an empty multi-select (character(0) is sent to Shiny). +# @param wait (`logical(1)`) if `TRUE` (default), call `wait_for_idle()` after committing the picker. +set_teal_picks_slot <- function(app_driver, pick_id, slot, value, wait = TRUE) { + checkmate::assert_string(pick_id) + checkmate::assert_string(slot) + checkmate::assert_flag(wait) + .teal_picks_click_summary_badge(app_driver, pick_id) + exports <- teal_picks_exports(app_driver, pick_id) + sel_id <- sprintf(exports$selected_id_fmt, slot) + open_id <- sprintf(exports$open_id_fmt, slot) + val <- if (is.null(value)) character(0L) else as.character(value) + .teal_picks_apply_select_value_in_browser(app_driver, sel_id, val) + .teal_picks_shiny_set_picker_and_commit(app_driver, sel_id, open_id, val) + if (isTRUE(wait)) { + app_driver$wait_for_idle() + } + .teal_picks_click_summary_badge(app_driver, pick_id) + invisible(app_driver) +} diff --git a/tests/testthat/helper-testing-depth.R b/tests/testthat/helper-testing-depth.R new file mode 100644 index 00000000..b5173ea9 --- /dev/null +++ b/tests/testthat/helper-testing-depth.R @@ -0,0 +1,49 @@ +#' Returns testing depth set by session option or by environmental variable. +#' +#' @details Looks for the session option `TESTING_DEPTH` first. +#' If not set, takes the system environmental variable `TESTING_DEPTH`. +#' If neither is set, then returns 3 by default. +#' If the value of `TESTING_DEPTH` is not a numeric of length 1, then returns 3. +#' +#' @return `numeric(1)` the testing depth. +#' +get_testing_depth <- function() { + default_depth <- 3 + depth <- getOption("TESTING_DEPTH", Sys.getenv("TESTING_DEPTH", default_depth)) + depth <- tryCatch( + as.numeric(depth), + error = function(error) default_depth, + warning = function(warning) default_depth + ) + if (length(depth) != 1 || is.na(depth)) depth <- default_depth + depth +} + +#' Skipping tests in the testthat pipeline under specific scope +#' @description This function should be used per each `testthat::test_that` call. +#' Each of the call should specify an appropriate depth value. +#' The depth value will set the appropriate scope so more/less time consuming tests could be recognized. +#' The environment variable `TESTING_DEPTH` is used for changing the scope of `testthat` pipeline. +#' `TESTING_DEPTH` interpretation for each possible value: +#' \itemize{ +#' \item{0}{no tests at all} +#' \item{1}{fast - small scope - executed on every commit} +#' \item{3}{medium - medium scope - daily integration pipeline} +#' \item{5}{slow - all tests - daily package tests} +#' } +#' @param depth `numeric` the depth of the testing evaluation, +#' has opposite interpretation to environment variable `TESTING_DEPTH`. +#' So e.g. `0` means run it always and `5` means a heavy test which should be run rarely. +#' If the `depth` argument is larger than `TESTING_DEPTH` then the test is skipped. +#' @importFrom testthat skip +#' @return `NULL` or invoke an error produced by `testthat::skip` +#' @note By default `TESTING_DEPTH` is equal to 3 if there is no environment variable for it. +#' By default `depth` argument lower or equal to 3 will not be skipped because by default `TESTING_DEPTH` +#' is equal to 3. To skip <= 3 depth tests then the environment variable has to be lower than 3 respectively. +skip_if_too_deep <- function(depth) { # nolint: object_name_linter. + checkmate::assert_numeric(depth, len = 1, lower = 0, upper = 5) + testing_depth <- get_testing_depth() # by default 3 if there are no env variable + if (testing_depth < depth) { + testthat::skip(paste("testing depth", testing_depth, "is below current testing specification", depth)) + } +} diff --git a/tests/testthat/test-shinytest2-tm_g_events_term_id.R b/tests/testthat/test-shinytest2-tm_g_events_term_id.R new file mode 100644 index 00000000..a9fdb1e3 --- /dev/null +++ b/tests/testthat/test-shinytest2-tm_g_events_term_id.R @@ -0,0 +1,124 @@ +create_tm_g_events_term_id_data <- function() { + data <- within(teal.data::teal_data(), { + ADSL <- teal.data::rADSL + ADAE <- teal.data::rADAE + }) + teal.data::join_keys(data) <- teal.data::default_cdisc_join_keys[names(data)] + data +} + +app_driver_tm_g_events_term_id <- function() { + data <- create_tm_g_events_term_id_data() + init_teal_app_driver( + teal::init( + data = data, + modules = tm_g_events_term_id( + label = "Common AE", + term_var = teal.picks::picks( + teal.picks::datasets("ADAE"), + teal.picks::variables( + choices = c("AEDECOD", "AETERM", "AEHLT"), + selected = "AEDECOD", + multiple = FALSE + ) + ), + arm_var = teal.picks::picks( + teal.picks::datasets("ADSL"), + teal.picks::variables( + choices = c("ACTARMCD", "ACTARM"), + selected = "ACTARMCD", + multiple = FALSE + ) + ) + ) + ) + ) +} + +testthat::test_that("e2e - tm_g_events_term_id initializes and renders a plot", { + testthat::skip_if_not_installed("shinytest2") + skip_if_too_deep(5) + app_driver <- app_driver_tm_g_events_term_id() + withr::defer(app_driver$stop()) + app_driver$wait_for_idle() + + app_driver$expect_no_shiny_error() + app_driver$expect_no_validation_error() + testthat::expect_match( + app_driver$get_active_module_plot_output("out"), + "data:image/png;base64," + ) + testthat::expect_false( + isTRUE(app_driver$get_active_module_input("arm_ref") == app_driver$get_active_module_input("arm_trt")) + ) +}) + +testthat::test_that( + "e2e - tm_g_events_term_id starts with expected label and encoding selections.", + { + testthat::skip_if_not_installed("shinytest2") + skip_if_too_deep(5) + app_driver <- app_driver_tm_g_events_term_id() + withr::defer(app_driver$stop()) + app_driver$wait_for_idle() + + testthat::expect_equal( + app_driver$get_text("a.nav-link.active"), + "Common AE" + ) + testthat::expect_equal(get_teal_picks_slot(app_driver, "term_var", "datasets"), "ADAE") + testthat::expect_equal( + .teal_picks_strip_ds_prefix_vec(get_teal_picks_slot(app_driver, "term_var", "variables")), + "AEDECOD" + ) + testthat::expect_equal(get_teal_picks_slot(app_driver, "arm_var", "datasets"), "ADSL") + testthat::expect_equal( + .teal_picks_strip_ds_prefix_vec(get_teal_picks_slot(app_driver, "arm_var", "variables")), + "ACTARMCD" + ) + } +) + +testthat::test_that( + "e2e - tm_g_events_term_id: changing term_var changes the plot and does not throw validation errors.", + { + testthat::skip_if_not_installed("shinytest2") + skip_if_too_deep(5) + app_driver <- app_driver_tm_g_events_term_id() + withr::defer(app_driver$stop()) + app_driver$wait_for_idle() + plot_before <- app_driver$get_active_module_plot_output("out") + set_teal_picks_slot(app_driver, "term_var", "variables", "AETERM") + testthat::expect_equal( + .teal_picks_strip_ds_prefix_vec(get_teal_picks_slot(app_driver, "term_var", "variables")), + "AETERM" + ) + testthat::expect_false(identical(plot_before, app_driver$get_active_module_plot_output("out"))) + app_driver$expect_no_validation_error() + } +) + +testthat::test_that("e2e - tm_g_events_term_id: deselection of term_var throws validation error.", { + testthat::skip_if_not_installed("shinytest2") + skip_if_too_deep(5) + app_driver <- app_driver_tm_g_events_term_id() + withr::defer(app_driver$stop()) + app_driver$wait_for_idle() + set_teal_picks_slot(app_driver, "term_var", "variables", character(0L)) + app_driver$expect_validation_error() +}) + +testthat::test_that("e2e - tm_g_events_term_id sort updates title", { + testthat::skip_if_not_installed("shinytest2") + skip_if_too_deep(5) + app_driver <- app_driver_tm_g_events_term_id() + withr::defer(app_driver$stop()) + app_driver$wait_for_idle() + + app_driver$set_active_module_input("sort", "riskdiff") + testthat::expect_identical( + app_driver$get_active_module_input("title"), + "Common AE Table Sorted by Risk Difference" + ) + app_driver$expect_no_validation_error() +}) diff --git a/tests/testthat/test-tm_g_ae_oview.R b/tests/testthat/test-tm_g_ae_oview.R new file mode 100644 index 00000000..4ef975a1 --- /dev/null +++ b/tests/testthat/test-tm_g_ae_oview.R @@ -0,0 +1,69 @@ +arm_var_cs <- teal.transform::choices_selected( + selected = "ACTARM", + choices = c("ACTARM", "ACTARMCD") +) + +flag_var_cs <- teal.transform::choices_selected( + selected = "TMPFL_SER", + choices = c("TMPFL_SER", "TMPFL_REL", "TMPFL_GR5") +) + +arm_var_picks <- teal.picks::variables( + choices = teal.picks::is_categorical(min.len = 2), + selected = 1L +) + +flag_var_picks <- teal.picks::variables( + choices = c("TMPFL_SER", "TMPFL_REL", "TMPFL_GR5"), + selected = "TMPFL_SER" +) + +testthat::describe("tm_g_ae_oview argument verification", { + it("fails when arm_var is neither picks or choices selected", { + testthat::expect_error( + tm_g_ae_oview( + label = "AE Overview", + dataname = "ADAE", + arm_var = list(), + flag_var_anl = flag_var_cs + ), + class = "error" + ) + }) + + it("fails when flag_var_anl is neiter picks or choices_selected", { + testthat::expect_error( + tm_g_ae_oview( + label = "AE Overview", + dataname = "ADAE", + arm_var = arm_var_cs, + flag_var_anl = list() + ), + class = "error" + ) + }) +}) + +testthat::describe("tm_g_ae_oview module creation", { + it("creates a teal module using choices_selected", { + mod <- tm_g_ae_oview( + label = "AE Overview", + dataname = "ADAE", + arm_var = arm_var_cs, + flag_var_anl = flag_var_cs, + plot_height = c(600, 200, 2000) + ) + testthat::expect_s3_class(mod, "teal_module") + }) + + it("creates a teal module using picks", { + mod <- tm_g_ae_oview( + label = "AE Overview", + dataname = "ADAE", + arm_var = arm_var_picks, + flag_var_anl = flag_var_picks, + plot_height = c(600, 200, 2000) + ) + testthat::expect_s3_class(mod, "teal_module") + }) +}) diff --git a/tests/testthat/test-tm_g_events_term_id.R b/tests/testthat/test-tm_g_events_term_id.R new file mode 100644 index 00000000..0d4376e8 --- /dev/null +++ b/tests/testthat/test-tm_g_events_term_id.R @@ -0,0 +1,53 @@ +testthat::test_that("tm_g_events_term_id builds a teal module with picks encodings", { + testthat::skip_if_not_installed("teal.picks") + + mod <- tm_g_events_term_id( + label = "Common AE", + term_var = teal.picks::picks( + teal.picks::datasets("ADAE"), + teal.picks::variables( + choices = "AEDECOD", + selected = "AEDECOD" + ) + ), + arm_var = teal.picks::picks( + teal.picks::datasets("ADSL"), + teal.picks::variables( + choices = "ACTARMCD", + selected = "ACTARMCD" + ) + ) + ) + testthat::expect_s3_class(mod, "teal_module") + testthat::expect_identical(mod$server, srv_g_events_term_id) + testthat::expect_equal(mod$datanames, c("ADAE", "ADSL")) +}) + +testthat::test_that("tm_g_events_term_id rejects multiple variable selection", { + testthat::skip_if_not_installed("teal.picks") + + term_var <- teal.picks::picks( + teal.picks::datasets("ADAE"), + teal.picks::variables( + choices = c("AEDECOD", "AETERM"), + selected = c("AEDECOD", "AETERM"), + multiple = TRUE + ) + ) + arm_var <- teal.picks::picks( + teal.picks::datasets("ADSL"), + teal.picks::variables( + choices = "ACTARMCD", + selected = "ACTARMCD" + ) + ) + + testthat::expect_error( + tm_g_events_term_id( + label = "Common AE", + term_var = term_var, + arm_var = arm_var + ), + "`term_var` must use variables\\(\\.\\.\\., multiple = FALSE\\)" + ) +}) diff --git a/tests/testthat/test-tm_g_swimlane_waterfall_picks.R b/tests/testthat/test-tm_g_swimlane_waterfall_picks.R new file mode 100644 index 00000000..2ae327c7 --- /dev/null +++ b/tests/testthat/test-tm_g_swimlane_waterfall_picks.R @@ -0,0 +1,64 @@ +testthat::test_that("tm_g_swimlane builds a teal module with picks encodings", { + testthat::skip_if_not_installed("teal.picks") + + mod <- tm_g_swimlane( + label = "Swimlane", + dataname = "ADRS", + bar_var = teal.picks::picks( + teal.picks::datasets("ADSL"), + teal.picks::variables(choices = "TRTDURD", selected = "TRTDURD") + ), + bar_color_var = teal.picks::picks( + teal.picks::datasets("ADSL"), + teal.picks::variables(choices = "EOSSTT", selected = "EOSSTT") + ), + marker_pos_var = teal.picks::picks( + teal.picks::datasets("ADRS"), + teal.picks::variables(choices = "ADY", selected = "ADY") + ), + marker_shape_var = teal.picks::picks( + teal.picks::datasets("ADRS"), + teal.picks::variables(choices = "AVALC", selected = "AVALC") + ), + marker_shape_opt = c(CR = 16), + marker_color_var = teal.picks::picks( + teal.picks::datasets("ADRS"), + teal.picks::variables(choices = "AVALC", selected = "AVALC") + ), + marker_color_opt = c(CR = "green"), + anno_txt_var = teal.picks::picks( + teal.picks::datasets("ADSL"), + teal.picks::variables( + choices = c("ACTARM", "SEX"), + selected = "ACTARM", + multiple = TRUE + ) + ) + ) + testthat::expect_s3_class(mod, "teal_module") + testthat::expect_identical(mod$server, srv_g_swimlane) +}) + +testthat::test_that("tm_g_waterfall builds a teal module with picks encodings", { + testthat::skip_if_not_installed("teal.picks") + + mod <- tm_g_waterfall( + label = "Waterfall", + bar_paramcd = teal.picks::picks( + teal.picks::datasets("ADTR"), + teal.picks::variables("PARAMCD", "PARAMCD"), + teal.picks::values(choices = "SLDINV", selected = "SLDINV") + ), + bar_var = teal.picks::picks( + teal.picks::datasets("ADTR"), + teal.picks::variables(choices = c("PCHG", "AVAL"), selected = "PCHG") + ), + bar_color_var = teal.picks::picks( + teal.picks::datasets("ADSL"), + teal.picks::variables(choices = c("ARMCD", "SEX"), selected = "ARMCD") + ) + ) + testthat::expect_s3_class(mod, "teal_module") + testthat::expect_identical(mod$server, srv_g_waterfall) + testthat::expect_equal(mod$datanames, c("ADSL", "ADTR", "ADRS")) +})