From 77c8bbd0ec4e53b3d4e6ed88434eb05c1e188699 Mon Sep 17 00:00:00 2001 From: m7pr Date: Thu, 5 Mar 2026 11:30:18 +0100 Subject: [PATCH 01/12] picks version for tm_g_events_term_id --- DESCRIPTION | 7 +- NAMESPACE | 2 + R/tm_g_events_term_id.R | 51 +++- R/tm_g_events_term_id_picks.R | 423 ++++++++++++++++++++++++++++++++++ 4 files changed, 474 insertions(+), 9 deletions(-) create mode 100644 R/tm_g_events_term_id_picks.R diff --git a/DESCRIPTION b/DESCRIPTION index 27648b22..2bfa4f5d 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -37,6 +37,7 @@ Imports: teal.code (>= 0.7.0), teal.data (>= 0.8.0), teal.logger (>= 0.4.0), + teal.picks (>= 0.1.0), teal.reporter (>= 0.6.0), teal.widgets (>= 0.5.0), tern (>= 0.9.7), @@ -49,10 +50,12 @@ Suggests: testthat (>= 3.2.3), withr (>= 3.0.0) Remotes: - insightsengineering/osprey + insightsengineering/osprey, + insightsengineering/teal.picks@redesign_exptraction@main Config/Needs/verdepcheck: insightsengineering/osprey, rstudio/shiny, insightsengineering/teal, insightsengineering/teal.slice, - insightsengineering/teal.transform, mllg/checkmate, tidyverse/dplyr, + insightsengineering/teal.transform, insightsengineering/teal.picks, + mllg/checkmate, tidyverse/dplyr, insightsengineering/formatters, tidyverse/ggplot2, r-lib/lifecycle, daroczig/logger, rstudio/shinyvalidate, insightsengineering/teal.code, insightsengineering/teal.logger, insightsengineering/teal.reporter, diff --git a/NAMESPACE b/NAMESPACE index 9d07d672..049846ed 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,5 +1,7 @@ # Generated by roxygen2: do not edit by hand +S3method(tm_g_events_term_id,default) +S3method(tm_g_events_term_id,picks) export(label_aevar) export(plot_decorate_output) export(quick_filter) diff --git a/R/tm_g_events_term_id.R b/R/tm_g_events_term_id.R index 5a9cea52..a4025ba7 100644 --- a/R/tm_g_events_term_id.R +++ b/R/tm_g_events_term_id.R @@ -2,13 +2,23 @@ #' #' @description #' -#' Display Events by Term plot as a shiny module +#' Display Events by Term plot as a shiny module. +#' +#' This is an S3 generic that dispatches on the class of `term_var`: +#' - [choices_selected][teal.transform::choices_selected()] dispatches to the +#' default method. +#' - [picks][teal.picks::picks()] dispatches to the picks method. #' #' @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 A variable selection object. Either a +#' [teal.transform::choices_selected()] object (dispatches to the `.default` +#' method) or a [teal.picks::picks()] object (dispatches to the `.picks` +#' method). +#' @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 @@ -27,6 +37,7 @@ #' #' join_keys(data) <- default_cdisc_join_keys[names(data)] #' +#' # Using the default method (choices_selected) #' app <- init( #' data = data, #' modules = modules( @@ -52,16 +63,42 @@ #' 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", + 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()) { + UseMethod("tm_g_events_term_id", term_var) +} + +#' @rdname tm_g_events_term_id +#' @export +tm_g_events_term_id.default <- function(label = "Common AE", # nolint: object_name_linter. + dataname = NULL, + term_var, + arm_var, + 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_string(dataname) checkmate::assert_class(term_var, classes = "choices_selected") checkmate::assert_class(arm_var, classes = "choices_selected") checkmate::assert( 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..9d9a676d --- /dev/null +++ b/R/tm_g_events_term_id_picks.R @@ -0,0 +1,423 @@ +#' @rdname tm_g_events_term_id +#' +#' @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) +#' } +#' +#' @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()) { + message("Initializing tm_g_events_term_id.picks") + + # Start of assertions + checkmate::assert_string(label) + + checkmate::assert_class(term_var, "picks") + if (isTRUE(attr(term_var$variables, "multiple"))) { + warning( + "`term_var` accepts only a single variable selection. ", + "Forcing `teal.picks::variables(multiple)` to FALSE." + ) + attr(term_var$variables, "multiple") <- FALSE + } + + checkmate::assert_class(arm_var, "picks") + if (isTRUE(attr(arm_var$variables, "multiple"))) { + warning( + "`arm_var` accepts only a single variable selection. ", + "Forcing `teal.picks::variables(multiple)` to FALSE." + ) + attr(arm_var$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" + ) + # End of assertions + + 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 = .picks_datanames(list(term_var, arm_var)) + ) +} + +# UI function for the events_term_id.picks module +ui_g_events_term_id.picks <- function(id, # nolint: object_name_linter. + 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$div( + tags$strong("Term variable"), + teal.picks::picks_ui(id = ns("term_var"), picks = term_var) + ), + tags$div( + tags$strong("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 = "" + ) + ) + ) +} + +# Server function for the events_term_id.picks module +srv_g_events_term_id.picks <- function(id, # nolint: object_name_linter. + 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") + + # Initialize picks selectors + selectors <- teal.picks::picks_srv( + picks = list( + term_var = term_var, + arm_var = arm_var + ), + data = data + ) + + # Merge datasets based on picks selections + merged <- teal.picks::merge_srv( + "merge", + data = data, + selectors = selectors, + output_name = "ANL" + ) + + # Update arm_ref/arm_trt based on arm_var selection + observeEvent(selectors$arm_var(), { + arm_var_name <- selectors$arm_var()$variables$selected + 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 + } else { + trt_index <- 2 + } + + updateSelectInput( + session, + "arm_ref", + selected = choices[1], + choices = choices + ) + updateSelectInput( + session, + "arm_trt", + selected = choices[trt_index], + choices = choices + ) + }, ignoreNULL = TRUE) + + # Update title based on sort selection + 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) + + # Update footnotes based on CI settings + 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 + + # Main output reactive + output_q <- reactive({ + qenv <- merged$data() + + # Variable names in the merged ANL dataset (potentially renamed to avoid conflicts) + term_var_name <- merged$variables()$term_var + arm_var_name <- merged$variables()$arm_var + + # 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(term_var_name) > 0, + "A Term Variable needs to be selected." + ), + shiny::need( + length(arm_var_name) > 0, + "An Arm Variable needs to be selected." + ) + ) + + ANL <- qenv[["ANL"]] + + shiny::validate( + shiny::need( + is.factor(ANL[[arm_var_name]]), + "Arm Variable must be a factor variable." + ), + shiny::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." + ) + ) + + shiny::validate( + shiny::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), + teal.reporter::teal_card("## Module's output(s)") + ) + + 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) + }) +} + +#' Extract datanames from a list of picks objects +#' +#' @param x (`list`) list of picks objects (or NULLs) +#' @return `character` vector of unique datanames, or `"all"` if any picks +#' object uses dynamic dataset choices. +#' @keywords internal +.picks_datanames <- function(x) { + checkmate::assert_list(x, c("picks", "NULL")) + datanames_list <- lapply(x, function(x) { + if (is.character(x$datasets$choices)) { + x$datasets$choices + } else { + NULL + } + }) + + if (any(vapply(datanames_list, is.null, logical(1)))) { + "all" + } else { + unique(unlist(datanames_list)) + } +} From c326a149e63ccd01c2e23e9696b3288867092b18 Mon Sep 17 00:00:00 2001 From: m7pr Date: Wed, 27 May 2026 10:41:40 +0200 Subject: [PATCH 02/12] typo --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 2bfa4f5d..0f4fac89 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -51,7 +51,7 @@ Suggests: withr (>= 3.0.0) Remotes: insightsengineering/osprey, - insightsengineering/teal.picks@redesign_exptraction@main + insightsengineering/teal.picks@redesign_extraction@main Config/Needs/verdepcheck: insightsengineering/osprey, rstudio/shiny, insightsengineering/teal, insightsengineering/teal.slice, insightsengineering/teal.transform, insightsengineering/teal.picks, From 971416bd92f333c5c2ea82b22e7e134d9b104550 Mon Sep 17 00:00:00 2001 From: m7pr Date: Wed, 27 May 2026 13:11:14 +0200 Subject: [PATCH 03/12] add shinytest2 to description --- DESCRIPTION | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 0f4fac89..e654fb53 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -47,6 +47,7 @@ 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: @@ -61,7 +62,7 @@ Config/Needs/verdepcheck: insightsengineering/osprey, rstudio/shiny, 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 From 05a2b87412fb4a1aae21a7e19d93e5de477ca7b6 Mon Sep 17 00:00:00 2001 From: m7pr Date: Wed, 27 May 2026 13:11:22 +0200 Subject: [PATCH 04/12] qupdate NEWS --- NEWS.md | 3 +++ 1 file changed, 3 insertions(+) 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 From 6aa7f25fdcdca035896e61836e85fdd49d72fdc6 Mon Sep 17 00:00:00 2001 From: m7pr Date: Wed, 27 May 2026 13:11:37 +0200 Subject: [PATCH 05/12] add shinytest2 tests helpers --- tests/testthat/helper-TealAppDriver.R | 242 ++++++++++++++++++++++++++ tests/testthat/helper-testing-depth.R | 49 ++++++ 2 files changed, 291 insertions(+) create mode 100644 tests/testthat/helper-TealAppDriver.R create mode 100644 tests/testthat/helper-testing-depth.R 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)) + } +} From a9ff23307d54f10d0fa625c6f3d46cee81b63426 Mon Sep 17 00:00:00 2001 From: m7pr Date: Wed, 27 May 2026 13:11:51 +0200 Subject: [PATCH 06/12] update tm_g_enets_term_id --- R/tm_g_events_term_id.R | 54 ++-- R/tm_g_events_term_id_picks.R | 278 ++++++++---------- man/tm_g_events_term_id.Rd | 96 +++++- .../test-shinytest2-tm_g_events_term_id.R | 160 ++++++++++ tests/testthat/test-tm_g_events_term_id.R | 68 +++++ 5 files changed, 462 insertions(+), 194 deletions(-) create mode 100644 tests/testthat/test-shinytest2-tm_g_events_term_id.R create mode 100644 tests/testthat/test-tm_g_events_term_id.R diff --git a/R/tm_g_events_term_id.R b/R/tm_g_events_term_id.R index a4025ba7..e2c2f968 100644 --- a/R/tm_g_events_term_id.R +++ b/R/tm_g_events_term_id.R @@ -1,24 +1,26 @@ #' Events by Term Plot Teal Module #' -#' @description -#' -#' Display Events by Term plot as a shiny module. -#' -#' This is an S3 generic that dispatches on the class of `term_var`: -#' - [choices_selected][teal.transform::choices_selected()] dispatches to the -#' default method. -#' - [picks][teal.picks::picks()] dispatches to the picks method. +#' Display an events-by-term plot as a Shiny module. #' #' @inheritParams teal.widgets::standard_layout #' @inheritParams teal::module #' @inheritParams argument_convention -#' @param term_var A variable selection object. Either a -#' [teal.transform::choices_selected()] object (dispatches to the `.default` -#' method) or a [teal.picks::picks()] object (dispatches to the `.picks` -#' method). -#' @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. +#' @param term_var (`choices_selected` or `picks`)\cr +#' Variable selection for the event term. A [teal.transform::choices_selected()] +#' object dispatches to the default method; a [teal.picks::picks()] object +#' dispatches to the picks method. +#' @param arm_var (`choices_selected` or `picks`)\cr +#' Variable selection for the treatment arm. Must be a factor in the analysis +#' data. See `term_var` for supported selection types. +#' @param dataname (`character(1)`)\cr +#' Name of the events dataset. Required for the default method with +#' [teal.transform::choices_selected()]. Ignored by the picks method. +#' +#' @details +#' S3 dispatch uses the class of `term_var`: `tm_g_events_term_id.default()` for +#' [teal.transform::choices_selected()] and `tm_g_events_term_id.picks()` for +#' [teal.picks::picks()]. Do not mix `choices_selected` and `picks` encodings in +#' one call. #' #' @inherit argument_convention return #' @inheritSection teal::example_module Reporting @@ -37,7 +39,7 @@ #' #' join_keys(data) <- default_cdisc_join_keys[names(data)] #' -#' # Using the default method (choices_selected) +#' # Legacy `teal.transform::choices_selected()` encodings (default S3 method): #' app <- init( #' data = data, #' modules = modules( @@ -65,28 +67,17 @@ #' tm_g_events_term_id <- function(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 - ) - ), + term_var, + arm_var, fontsize = c(5, 3, 7), plot_height = c(600L, 200L, 2000L), plot_width = NULL, transformators = list()) { + checkmate::assert_string(label) UseMethod("tm_g_events_term_id", term_var) } -#' @rdname tm_g_events_term_id +#' @describeIn tm_g_events_term_id Legacy [teal.transform::choices_selected()] encodings. #' @export tm_g_events_term_id.default <- function(label = "Common AE", # nolint: object_name_linter. dataname = NULL, @@ -96,7 +87,6 @@ tm_g_events_term_id.default <- function(label = "Common AE", # nolint: object_na plot_height = c(600L, 200L, 2000L), plot_width = NULL, transformators = list()) { - message("Initializing tm_g_events_term_id") checkmate::assert_string(label) checkmate::assert_string(dataname) checkmate::assert_class(term_var, classes = "choices_selected") diff --git a/R/tm_g_events_term_id_picks.R b/R/tm_g_events_term_id_picks.R index 9d9a676d..c8fadf8a 100644 --- a/R/tm_g_events_term_id_picks.R +++ b/R/tm_g_events_term_id_picks.R @@ -1,42 +1,4 @@ -#' @rdname tm_g_events_term_id -#' -#' @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) -#' } -#' +#' @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, @@ -58,28 +20,18 @@ tm_g_events_term_id.picks <- function(label = "Common AE", # nolint: object_name plot_height = c(600L, 200L, 2000L), plot_width = NULL, transformators = list()) { - message("Initializing tm_g_events_term_id.picks") - - # Start of assertions checkmate::assert_string(label) - checkmate::assert_class(term_var, "picks") - if (isTRUE(attr(term_var$variables, "multiple"))) { - warning( - "`term_var` accepts only a single variable selection. ", - "Forcing `teal.picks::variables(multiple)` to FALSE." - ) - attr(term_var$variables, "multiple") <- FALSE - } - - checkmate::assert_class(arm_var, "picks") - if (isTRUE(attr(arm_var$variables, "multiple"))) { - warning( - "`arm_var` accepts only a single variable selection. ", - "Forcing `teal.picks::variables(multiple)` to FALSE." - ) - attr(arm_var$variables, "multiple") <- FALSE - } + 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), @@ -100,23 +52,78 @@ tm_g_events_term_id.picks <- function(label = "Common AE", # nolint: object_name plot_width[1], lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" ) - # End of assertions + + 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))], + 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 = .picks_datanames(list(term_var, arm_var)) + datanames = all_datanames ) } -# UI function for the events_term_id.picks module -ui_g_events_term_id.picks <- function(id, # nolint: object_name_linter. +#' @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) { @@ -126,13 +133,13 @@ ui_g_events_term_id.picks <- function(id, # nolint: object_name_linter. plot_decorate_output(id = ns(NULL)) ), encoding = tags$div( - tags$label("Encodings", class = "text-primary"), + tags$label("Encodings", class = "text-primary"), tags$br(), tags$div( - tags$strong("Term variable"), + tags$label("Term variable"), teal.picks::picks_ui(id = ns("term_var"), picks = term_var) ), tags$div( - tags$strong("Arm variable"), + tags$label("Arm variable"), teal.picks::picks_ui(id = ns("arm_var"), picks = arm_var) ), selectInput( @@ -211,8 +218,8 @@ ui_g_events_term_id.picks <- function(id, # nolint: object_name_linter. ) } -# Server function for the events_term_id.picks module -srv_g_events_term_id.picks <- function(id, # nolint: object_name_linter. +#' @keywords internal +srv_g_events_term_id_picks <- function(id, data, term_var, arm_var, @@ -224,37 +231,44 @@ srv_g_events_term_id.picks <- function(id, # nolint: object_name_linter. moduleServer(id, function(input, output, session) { teal.logger::log_shiny_input_changes(input, namespace = "teal.osprey") - # Initialize picks selectors - selectors <- teal.picks::picks_srv( - picks = list( - term_var = term_var, - arm_var = arm_var - ), + anl_selectors <- teal.picks::picks_srv( + id = "", + picks = list(term_var = term_var, arm_var = arm_var), data = data ) - # Merge datasets based on picks selections - merged <- teal.picks::merge_srv( - "merge", - data = data, - selectors = selectors, - output_name = "ANL" + 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" ) - # Update arm_ref/arm_trt based on arm_var selection - observeEvent(selectors$arm_var(), { - arm_var_name <- selectors$arm_var()$variables$selected - arm_dataset <- selectors$arm_var()$datasets$selected + 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]]) - if (length(choices) == 1) { - trt_index <- 1 - } else { - trt_index <- 2 - } + trt_index <- if (length(choices) == 1L) 1L else 2L updateSelectInput( session, @@ -270,7 +284,6 @@ srv_g_events_term_id.picks <- function(id, # nolint: object_name_linter. ) }, ignoreNULL = TRUE) - # Update title based on sort selection observeEvent(input$sort, { sort <- if (is.null(input$sort)) " " else input$sort updateTextInput( @@ -288,7 +301,6 @@ srv_g_events_term_id.picks <- function(id, # nolint: object_name_linter. ) }, ignoreNULL = FALSE) - # Update footnotes based on CI settings 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 @@ -313,44 +325,39 @@ srv_g_events_term_id.picks <- function(id, # nolint: object_name_linter. font_size <- decorate_output$font_size pws <- decorate_output$pws - # Main output reactive output_q <- reactive({ - qenv <- merged$data() - - # Variable names in the merged ANL dataset (potentially renamed to avoid conflicts) - term_var_name <- merged$variables()$term_var - arm_var_name <- merged$variables()$arm_var - - # 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(term_var_name) > 0, - "A Term Variable needs to be selected." + merged_vars <- merge_vars() + validate( + need( + length(merged_vars[["term_var"]]) > 0L, + "Please select a term variable" ), - shiny::need( - length(arm_var_name) > 0, - "An Arm Variable needs to be selected." + 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"]] - shiny::validate( - shiny::need( + validate( + need( is.factor(ANL[[arm_var_name]]), "Arm Variable must be a factor variable." ), - shiny::need( + 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." - ) - ) - - shiny::validate( - shiny::need( + ), + need( !isTRUE(input$arm_trt == input$arm_ref), "Control and Treatment must be different." ) @@ -362,12 +369,6 @@ srv_g_events_term_id.picks <- function(id, # nolint: object_name_linter. msg = "Analysis data set must have at least 10 data points" ) - teal.reporter::teal_card(qenv) <- - c( - teal.reporter::teal_card(qenv), - teal.reporter::teal_card("## Module's output(s)") - ) - teal.reporter::teal_card(qenv) <- c(teal.reporter::teal_card(qenv), "### Plot") teal.code::eval_code( @@ -398,26 +399,3 @@ srv_g_events_term_id.picks <- function(id, # nolint: object_name_linter. set_chunk_dims(pws, output_q) }) } - -#' Extract datanames from a list of picks objects -#' -#' @param x (`list`) list of picks objects (or NULLs) -#' @return `character` vector of unique datanames, or `"all"` if any picks -#' object uses dynamic dataset choices. -#' @keywords internal -.picks_datanames <- function(x) { - checkmate::assert_list(x, c("picks", "NULL")) - datanames_list <- lapply(x, function(x) { - if (is.character(x$datasets$choices)) { - x$datasets$choices - } else { - NULL - } - }) - - if (any(vapply(datanames_list, is.null, logical(1)))) { - "all" - } else { - unique(unlist(datanames_list)) - } -} diff --git a/man/tm_g_events_term_id.Rd b/man/tm_g_events_term_id.Rd index f7745d13..6539957a 100644 --- a/man/tm_g_events_term_id.Rd +++ b/man/tm_g_events_term_id.Rd @@ -1,12 +1,14 @@ % 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.default} +\alias{tm_g_events_term_id.picks} \title{Events by Term Plot Teal Module} \usage{ tm_g_events_term_id( - label, - dataname, + label = "Common AE", + dataname = NULL, term_var, arm_var, fontsize = c(5, 3, 7), @@ -14,22 +16,57 @@ tm_g_events_term_id( plot_width = NULL, transformators = list() ) + +\method{tm_g_events_term_id}{default}( + label = "Common AE", + dataname = NULL, + term_var, + arm_var, + fontsize = c(5, 3, 7), + plot_height = c(600L, 200L, 2000L), + plot_width = NULL, + transformators = list() +) + +\method{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, + transformators = list() +) } \arguments{ \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()}}.} +Name of the events dataset. Required for the default method with +\code{\link[teal.transform:choices_selected]{teal.transform::choices_selected()}}. Ignored by the picks method.} -\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{term_var}{(\code{choices_selected} or \code{picks})\cr +Variable selection for the event term. A \code{\link[teal.transform:choices_selected]{teal.transform::choices_selected()}} +object dispatches to the default method; a \code{\link[teal.picks:picks]{teal.picks::picks()}} object +dispatches to the 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{arm_var}{(\code{choices_selected} or \code{picks})\cr +Variable selection for the treatment arm. Must be a factor in the analysis +data. See \code{term_var} for supported selection types.} \item{fontsize}{(\code{numeric(1)} or \code{numeric(3)})\cr Defines initial possible range of font-size. \code{fontsize} is set for @@ -49,7 +86,13 @@ To learn more check \code{vignette("transform-input-data", package = "teal")}.} the \code{\link[teal:teal_modules]{teal::module()}} object. } \description{ -Display Events by Term plot as a shiny module +Display an events-by-term plot as a Shiny module. +} +\details{ +S3 dispatch uses the class of \code{term_var}: \code{tm_g_events_term_id.default()} for +\code{\link[teal.transform:choices_selected]{teal.transform::choices_selected()}} and \code{tm_g_events_term_id.picks()} for +\code{\link[teal.picks:picks]{teal.picks::picks()}}. Do not mix \code{choices_selected} and \code{picks} encodings in +one call. } \section{Reporting}{ @@ -76,6 +119,7 @@ data <- teal_data() \%>\% join_keys(data) <- default_cdisc_join_keys[names(data)] +# Legacy `teal.transform::choices_selected()` encodings (default S3 method): app <- init( data = data, modules = modules( @@ -101,6 +145,34 @@ if (interactive()) { shinyApp(app$ui, app$server) } +# Using the picks method +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) +} + } \author{ Liming Li (lil128) \email{liming.li@roche.com} 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..96c3e544 --- /dev/null +++ b/tests/testthat/test-shinytest2-tm_g_events_term_id.R @@ -0,0 +1,160 @@ +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_default <- 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 (default e2e)", + dataname = "ADAE", + term_var = teal.transform::choices_selected( + selected = "AEDECOD", + choices = c("AEDECOD", "AETERM", "AEHLT") + ), + arm_var = teal.transform::choices_selected( + selected = "ACTARMCD", + choices = c("ACTARMCD", "ACTARM") + ) + ) + ) + ) +} + +app_driver_tm_g_events_term_id_picks <- 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 (picks e2e)", + 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 default 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_default() + 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::test_that("e2e - tm_g_events_term_id picks initializes and sets different arms", { + testthat::skip_if_not_installed("shinytest2") + skip_if_too_deep(5) + app_driver <- app_driver_tm_g_events_term_id_picks() + 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 picks 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_picks() + withr::defer(app_driver$stop()) + app_driver$wait_for_idle() + + testthat::expect_equal( + app_driver$get_text("a.nav-link.active"), + "Common AE (picks e2e)" + ) + 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 picks: 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_picks() + 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 picks: 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_picks() + 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 picks sort updates title", { + testthat::skip_if_not_installed("shinytest2") + skip_if_too_deep(5) + app_driver <- app_driver_tm_g_events_term_id_picks() + 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_events_term_id.R b/tests/testthat/test-tm_g_events_term_id.R new file mode 100644 index 00000000..08e63b9d --- /dev/null +++ b/tests/testthat/test-tm_g_events_term_id.R @@ -0,0 +1,68 @@ +testthat::test_that("tm_g_events_term_id dispatches on term_var class", { + testthat::skip_if_not_installed("teal.picks") + + mod_default <- tm_g_events_term_id( + label = "Common AE", + dataname = "ADAE", + term_var = teal.transform::choices_selected( + selected = "AEDECOD", + choices = "AEDECOD" + ), + arm_var = teal.transform::choices_selected( + selected = "ACTARMCD", + choices = "ACTARMCD" + ) + ) + testthat::expect_s3_class(mod_default, "teal_module") + testthat::expect_identical(mod_default$server, srv_g_events_term_id) + + mod_picks <- 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_picks, "teal_module") + testthat::expect_identical(mod_picks$server, srv_g_events_term_id_picks) + testthat::expect_equal(mod_picks$datanames, c("ADAE", "ADSL")) +}) + +testthat::test_that("tm_g_events_term_id.picks 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\\)" + ) +}) From dc005cb604477d44a239cae2bb217647b65787d0 Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Wed, 27 May 2026 11:14:34 +0000 Subject: [PATCH 07/12] [skip style] [skip vbump] Restyle files --- R/tm_g_events_term_id_picks.R | 80 +++++++++++++++++++---------------- 1 file changed, 43 insertions(+), 37 deletions(-) diff --git a/R/tm_g_events_term_id_picks.R b/R/tm_g_events_term_id_picks.R index c8fadf8a..b7690129 100644 --- a/R/tm_g_events_term_id_picks.R +++ b/R/tm_g_events_term_id_picks.R @@ -258,48 +258,54 @@ srv_g_events_term_id_picks <- function(id, 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) + 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]]) + arm_data <- data()[[arm_dataset]] + choices <- levels(arm_data[[arm_var_name]]) - trt_index <- if (length(choices) == 1L) 1L else 2L + 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) + 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] + 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) + }, + ignoreNULL = FALSE + ) observeEvent(list(input$diff_ci_method, input$conf_level), { req(!is.null(input$diff_ci_method) && !is.null(input$conf_level)) From 1c9c1a9ca52595095251983b428ecb0141ba6911 Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Wed, 27 May 2026 11:18:49 +0000 Subject: [PATCH 08/12] [skip roxygen] [skip vbump] Roxygen Man Pages Auto Update --- DESCRIPTION | 2 +- man/argument_convention.Rd | 2 +- man/plot_decorate_output.Rd | 2 +- man/teal.osprey-package.Rd | 1 + man/tm_g_ae_oview.Rd | 2 +- man/tm_g_ae_sub.Rd | 2 +- man/tm_g_butterfly.Rd | 2 +- man/tm_g_events_term_id.Rd | 58 +++++++++---------------------------- man/tm_g_heat_bygrade.Rd | 2 +- man/tm_g_patient_profile.Rd | 2 +- man/tm_g_spiderplot.Rd | 2 +- man/tm_g_swimlane.Rd | 2 +- man/tm_g_waterfall.Rd | 2 +- 13 files changed, 26 insertions(+), 55 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index e654fb53..5974985e 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -69,4 +69,4 @@ 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/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/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..0aee4aa8 100644 --- a/man/tm_g_ae_oview.Rd +++ b/man/tm_g_ae_oview.Rd @@ -47,7 +47,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 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 6539957a..02baaecd 100644 --- a/man/tm_g_events_term_id.Rd +++ b/man/tm_g_events_term_id.Rd @@ -1,5 +1,6 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/tm_g_events_term_id.R, R/tm_g_events_term_id_picks.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.default} @@ -31,20 +32,10 @@ tm_g_events_term_id( \method{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 - ) - ), + 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, @@ -83,7 +74,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 an events-by-term plot as a Shiny module. @@ -94,6 +85,13 @@ S3 dispatch uses the class of \code{term_var}: \code{tm_g_events_term_id.default \code{\link[teal.picks:picks]{teal.picks::picks()}}. Do not mix \code{choices_selected} and \code{picks} encodings in one call. } +\section{Methods (by class)}{ +\itemize{ +\item \code{tm_g_events_term_id(default)}: Legacy \code{\link[teal.transform:choices_selected]{teal.transform::choices_selected()}} encodings. + +\item \code{tm_g_events_term_id(picks)}: \code{\link[teal.picks:picks]{teal.picks::picks()}}-based encodings (\code{picks}). + +}} \section{Reporting}{ @@ -145,34 +143,6 @@ if (interactive()) { shinyApp(app$ui, app$server) } -# Using the picks method -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) -} - } \author{ Liming Li (lil128) \email{liming.li@roche.com} 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..fcdb7324 100644 --- a/man/tm_g_swimlane.Rd +++ b/man/tm_g_swimlane.Rd @@ -77,7 +77,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{ This is teal module that generates a \code{swimlane} plot (bar plot with markers) for \code{ADaM} data diff --git a/man/tm_g_waterfall.Rd b/man/tm_g_waterfall.Rd index 799b57d3..6262c551 100644 --- a/man/tm_g_waterfall.Rd +++ b/man/tm_g_waterfall.Rd @@ -96,7 +96,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{ This is teal module that generates a waterfall plot for \code{ADaM} data From 3ca235fd39eb7dc0f49f0b9ab74a95a09ff575d1 Mon Sep 17 00:00:00 2001 From: m7pr Date: Wed, 27 May 2026 18:31:45 +0200 Subject: [PATCH 09/12] cleanup --- NAMESPACE | 2 - R/tm_g_events_term_id.R | 362 +++++----- R/tm_g_events_term_id_picks.R | 401 ----------- R/tm_g_swimlane.R | 554 +++++++-------- R/tm_g_waterfall.R | 651 +++++++++--------- R/utils.R | 43 ++ man/tm_g_events_term_id.Rd | 78 +-- .../test-shinytest2-tm_g_events_term_id.R | 62 +- tests/testthat/test-tm_g_events_term_id.R | 27 +- .../test-tm_g_swimlane_waterfall_picks.R | 64 ++ 10 files changed, 878 insertions(+), 1366 deletions(-) delete mode 100644 R/tm_g_events_term_id_picks.R create mode 100644 tests/testthat/test-tm_g_swimlane_waterfall_picks.R diff --git a/NAMESPACE b/NAMESPACE index 049846ed..9d07d672 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,7 +1,5 @@ # Generated by roxygen2: do not edit by hand -S3method(tm_g_events_term_id,default) -S3method(tm_g_events_term_id,picks) export(label_aevar) export(plot_decorate_output) export(quick_filter) diff --git a/R/tm_g_events_term_id.R b/R/tm_g_events_term_id.R index e2c2f968..23093c3f 100644 --- a/R/tm_g_events_term_id.R +++ b/R/tm_g_events_term_id.R @@ -1,26 +1,15 @@ #' Events by Term Plot Teal Module #' -#' Display an 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 (`choices_selected` or `picks`)\cr -#' Variable selection for the event term. A [teal.transform::choices_selected()] -#' object dispatches to the default method; a [teal.picks::picks()] object -#' dispatches to the picks method. -#' @param arm_var (`choices_selected` or `picks`)\cr -#' Variable selection for the treatment arm. Must be a factor in the analysis -#' data. See `term_var` for supported selection types. -#' @param dataname (`character(1)`)\cr -#' Name of the events dataset. Required for the default method with -#' [teal.transform::choices_selected()]. Ignored by the picks method. -#' -#' @details -#' S3 dispatch uses the class of `term_var`: `tm_g_events_term_id.default()` for -#' [teal.transform::choices_selected()] and `tm_g_events_term_id.picks()` for -#' [teal.picks::picks()]. Do not mix `choices_selected` and `picks` encodings in -#' one call. +#' @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 @@ -39,23 +28,24 @@ #' #' join_keys(data) <- default_cdisc_join_keys[names(data)] #' -#' # Legacy `teal.transform::choices_selected()` encodings (default S3 method): #' app <- init( #' data = data, #' 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) #' ) @@ -66,31 +56,37 @@ #' } #' tm_g_events_term_id <- function(label = "Common AE", - dataname = NULL, - term_var, - arm_var, + 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) - UseMethod("tm_g_events_term_id", term_var) -} -#' @describeIn tm_g_events_term_id Legacy [teal.transform::choices_selected()] encodings. -#' @export -tm_g_events_term_id.default <- function(label = "Common AE", # nolint: object_name_linter. - dataname = NULL, - term_var, - arm_var, - fontsize = c(5, 3, 7), - plot_height = c(600L, 200L, 2000L), - plot_width = NULL, - transformators = list()) { - checkmate::assert_string(label) - checkmate::assert_string(dataname) - 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( @@ -101,60 +97,61 @@ tm_g_events_term_id.default <- function(label = "Common AE", # nolint: object_na ) ) 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"), @@ -206,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 = "" ) @@ -221,39 +219,88 @@ 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 + + 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 }) - decorate_output <- srv_g_decorate( - id = NULL, plt = plot_r, plot_height = plot_height, plot_width = plot_width + merged_anl <- teal.picks::merge_srv( + "merge_anl", + data = data_with_card, + selectors = anl_selectors, + output_name = "ANL", + join_fun = "dplyr::inner_join" ) - font_size <- decorate_output$font_size - pws <- decorate_output$pws + + 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)) @@ -270,106 +317,69 @@ srv_g_events_term_id <- function(id, ) }) - 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(input$arm_var, - { - arm_var <- input$arm_var - ANL <- data()[[dataname]] - - choices <- levels(ANL[[arm_var]]) - - if (length(choices) == 1) { - trt_index <- 1 - } else { - trt_index <- 2 - } - - updateSelectInput( - session, - "arm_ref", - selected = choices[1], - choices = choices - ) - updateSelectInput( - session, - "arm_trt", - selected = choices[trt_index], - choices = choices - ) - }, - ignoreNULL = TRUE + 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({ - obj <- data() - teal.reporter::teal_card(obj) <- - c( - teal.reporter::teal_card(obj), - teal.reporter::teal_card("## Module's output(s)") + 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" ) + ) - ANL <- obj[[dataname]] - - teal::validate_inputs(iv()) + term_var_name <- merged_vars[["term_var"]][[1L]] + arm_var_name <- merged_vars[["arm_var"]][[1L]] - 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." - ) - ) + arm_selector <- anl_selectors$arm_var() + arm_var_orig <- arm_selector$variables$selected + arm_dataset <- arm_selector$datasets$selected - adsl_vars <- unique(c("USUBJID", "STUDYID", input$arm_var)) - anl_vars <- c("USUBJID", "STUDYID", input$term) + qenv <- anl_q() + ANL <- qenv[["ANL"]] - 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") - ) + 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 deleted file mode 100644 index c8fadf8a..00000000 --- a/R/tm_g_events_term_id_picks.R +++ /dev/null @@ -1,401 +0,0 @@ -#' @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..02689ea6 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,147 +40,87 @@ #' #' @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, - bar_color_var = NULL, - sort_var = NULL, - marker_pos_var = NULL, - marker_shape_var = NULL, - marker_shape_opt = NULL, - marker_color_var = NULL, - marker_color_opt = NULL, - anno_txt_var = NULL, - vref_line = NULL, - plot_height = c(1200L, 400L, 5000L), - plot_width = NULL, - pre_output = NULL, - post_output = NULL, - x_label = "Time from First Treatment (Day)", - transformators = list()) { - message("Initializing tm_g_swimlane") - args <- as.list(environment()) - + dataname, + bar_var, + bar_color_var = NULL, + sort_var = NULL, + marker_pos_var = NULL, + marker_shape_var = NULL, + marker_shape_opt = NULL, + marker_color_var = NULL, + marker_color_opt = NULL, + anno_txt_var = NULL, + vref_line = NULL, + plot_height = c(1200L, 400L, 5000L), + plot_width = NULL, + pre_output = NULL, + post_output = NULL, + x_label = "Time from First Treatment (Day)", + transformators = list()) { 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) { + data, + dataname, + marker_shape_opt, + marker_color_opt, + plot_height, + plot_width, + 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..9b6cb337 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,87 +49,61 @@ #' @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_opt = NULL, - sort_var, - add_label_var_sl, - add_label_paramcd_rs, - anno_txt_var_sl, - anno_txt_paramcd_rs, - facet_var, - ytick_at = 20, - href_line = NULL, - gap_point_val = NULL, - show_value = TRUE, - plot_height = c(1200L, 400L, 5000L), - plot_width = NULL, - pre_output = NULL, - post_output = NULL, - transformators = list()) { - message("Initializing tm_g_waterfall") + dataname_tr = "ADTR", + dataname_rs = "ADRS", + bar_paramcd, + bar_var, + bar_color_var = NULL, + bar_color_opt = NULL, + 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, + show_value = TRUE, + plot_height = c(1200L, 400L, 5000L), + plot_width = NULL, + pre_output = NULL, + post_output = NULL, + transformators = list()) { 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 + 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("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")) - ), - 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, - bar_paramcd, - add_label_paramcd_rs, - anno_txt_paramcd_rs, - dataname_tr, - dataname_rs, - bar_color_opt, - label, - plot_height, - plot_width) { + 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, + facet_var, + bar_color_opt, + 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..bb0622d8 100644 --- a/R/utils.R +++ b/R/utils.R @@ -214,6 +214,49 @@ set_chunk_attrs <- function(teal_card, #' #' @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) diff --git a/man/tm_g_events_term_id.Rd b/man/tm_g_events_term_id.Rd index 6539957a..8179ccdd 100644 --- a/man/tm_g_events_term_id.Rd +++ b/man/tm_g_events_term_id.Rd @@ -1,36 +1,11 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/tm_g_events_term_id.R, R/tm_g_events_term_id_picks.R +% Please edit documentation in R/tm_g_events_term_id.R \name{tm_g_events_term_id} \alias{tm_g_events_term_id} -\alias{tm_g_events_term_id.default} -\alias{tm_g_events_term_id.picks} \title{Events by Term Plot Teal Module} \usage{ tm_g_events_term_id( label = "Common AE", - dataname = NULL, - term_var, - arm_var, - fontsize = c(5, 3, 7), - plot_height = c(600L, 200L, 2000L), - plot_width = NULL, - transformators = list() -) - -\method{tm_g_events_term_id}{default}( - label = "Common AE", - dataname = NULL, - term_var, - arm_var, - fontsize = c(5, 3, 7), - plot_height = c(600L, 200L, 2000L), - plot_width = NULL, - transformators = list() -) - -\method{tm_g_events_term_id}{picks}( - label = "Common AE", - dataname = NULL, term_var = teal.picks::picks( teal.picks::datasets(), teal.picks::variables( @@ -55,18 +30,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 -Name of the events dataset. Required for the default method with -\code{\link[teal.transform:choices_selected]{teal.transform::choices_selected()}}. Ignored by the picks method.} +\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}{(\code{choices_selected} or \code{picks})\cr -Variable selection for the event term. A \code{\link[teal.transform:choices_selected]{teal.transform::choices_selected()}} -object dispatches to the default method; a \code{\link[teal.picks:picks]{teal.picks::picks()}} object -dispatches to the picks method.} - -\item{arm_var}{(\code{choices_selected} or \code{picks})\cr -Variable selection for the treatment arm. Must be a factor in the analysis -data. See \code{term_var} for supported selection types.} +\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 @@ -86,13 +55,7 @@ To learn more check \code{vignette("transform-input-data", package = "teal")}.} the \code{\link[teal:teal_modules]{teal::module()}} object. } \description{ -Display an events-by-term plot as a Shiny module. -} -\details{ -S3 dispatch uses the class of \code{term_var}: \code{tm_g_events_term_id.default()} for -\code{\link[teal.transform:choices_selected]{teal.transform::choices_selected()}} and \code{tm_g_events_term_id.picks()} for -\code{\link[teal.picks:picks]{teal.picks::picks()}}. Do not mix \code{choices_selected} and \code{picks} encodings in -one call. +Display an events-by-term plot as a Shiny module using \code{\link[teal.picks:picks]{teal.picks::picks()}} encodings. } \section{Reporting}{ @@ -119,33 +82,6 @@ data <- teal_data() \%>\% join_keys(data) <- default_cdisc_join_keys[names(data)] -# Legacy `teal.transform::choices_selected()` encodings (default S3 method): -app <- init( - data = data, - 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" - ) - ), - arm_var = choices_selected( - selected = "ACTARMCD", - choices = c("ACTARM", "ACTARMCD") - ), - plot_height = c(600, 200, 2000) - ) - ) -) -if (interactive()) { - shinyApp(app$ui, app$server) -} - -# Using the picks method app <- init( data = data, modules = modules( diff --git a/tests/testthat/test-shinytest2-tm_g_events_term_id.R b/tests/testthat/test-shinytest2-tm_g_events_term_id.R index 96c3e544..a9fdb1e3 100644 --- a/tests/testthat/test-shinytest2-tm_g_events_term_id.R +++ b/tests/testthat/test-shinytest2-tm_g_events_term_id.R @@ -7,34 +7,13 @@ create_tm_g_events_term_id_data <- function() { data } -app_driver_tm_g_events_term_id_default <- function() { +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 (default e2e)", - dataname = "ADAE", - term_var = teal.transform::choices_selected( - selected = "AEDECOD", - choices = c("AEDECOD", "AETERM", "AEHLT") - ), - arm_var = teal.transform::choices_selected( - selected = "ACTARMCD", - choices = c("ACTARMCD", "ACTARM") - ) - ) - ) - ) -} - -app_driver_tm_g_events_term_id_picks <- 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 (picks e2e)", + label = "Common AE", term_var = teal.picks::picks( teal.picks::datasets("ADAE"), teal.picks::variables( @@ -56,25 +35,10 @@ app_driver_tm_g_events_term_id_picks <- function() { ) } -testthat::test_that("e2e - tm_g_events_term_id default 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_default() - 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::test_that("e2e - tm_g_events_term_id picks initializes and sets different arms", { +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_picks() + app_driver <- app_driver_tm_g_events_term_id() withr::defer(app_driver$stop()) app_driver$wait_for_idle() @@ -90,17 +54,17 @@ testthat::test_that("e2e - tm_g_events_term_id picks initializes and sets differ }) testthat::test_that( - "e2e - tm_g_events_term_id picks starts with expected label and encoding selections.", + "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_picks() + 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 (picks e2e)" + "Common AE" ) testthat::expect_equal(get_teal_picks_slot(app_driver, "term_var", "datasets"), "ADAE") testthat::expect_equal( @@ -116,11 +80,11 @@ testthat::test_that( ) testthat::test_that( - "e2e - tm_g_events_term_id picks: changing term_var changes the plot and does not throw validation errors.", + "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_picks() + 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") @@ -134,20 +98,20 @@ testthat::test_that( } ) -testthat::test_that("e2e - tm_g_events_term_id picks: deselection of term_var throws 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_picks() + 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 picks sort updates title", { +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_picks() + app_driver <- app_driver_tm_g_events_term_id() withr::defer(app_driver$stop()) app_driver$wait_for_idle() diff --git a/tests/testthat/test-tm_g_events_term_id.R b/tests/testthat/test-tm_g_events_term_id.R index 08e63b9d..0d4376e8 100644 --- a/tests/testthat/test-tm_g_events_term_id.R +++ b/tests/testthat/test-tm_g_events_term_id.R @@ -1,22 +1,7 @@ -testthat::test_that("tm_g_events_term_id dispatches on term_var class", { +testthat::test_that("tm_g_events_term_id builds a teal module with picks encodings", { testthat::skip_if_not_installed("teal.picks") - mod_default <- tm_g_events_term_id( - label = "Common AE", - dataname = "ADAE", - term_var = teal.transform::choices_selected( - selected = "AEDECOD", - choices = "AEDECOD" - ), - arm_var = teal.transform::choices_selected( - selected = "ACTARMCD", - choices = "ACTARMCD" - ) - ) - testthat::expect_s3_class(mod_default, "teal_module") - testthat::expect_identical(mod_default$server, srv_g_events_term_id) - - mod_picks <- tm_g_events_term_id( + mod <- tm_g_events_term_id( label = "Common AE", term_var = teal.picks::picks( teal.picks::datasets("ADAE"), @@ -33,12 +18,12 @@ testthat::test_that("tm_g_events_term_id dispatches on term_var class", { ) ) ) - testthat::expect_s3_class(mod_picks, "teal_module") - testthat::expect_identical(mod_picks$server, srv_g_events_term_id_picks) - testthat::expect_equal(mod_picks$datanames, c("ADAE", "ADSL")) + 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.picks rejects multiple variable selection", { +testthat::test_that("tm_g_events_term_id rejects multiple variable selection", { testthat::skip_if_not_installed("teal.picks") term_var <- teal.picks::picks( 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")) +}) From 3dcfe482a1e8977c41e3a8c72752f8a8a1668bf9 Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Wed, 27 May 2026 16:34:54 +0000 Subject: [PATCH 10/12] [skip style] [skip vbump] Restyle files --- R/tm_g_events_term_id.R | 80 ++++++++++++++++-------------- R/tm_g_swimlane.R | 84 +++++++++++++++---------------- R/tm_g_waterfall.R | 106 ++++++++++++++++++++-------------------- 3 files changed, 138 insertions(+), 132 deletions(-) diff --git a/R/tm_g_events_term_id.R b/R/tm_g_events_term_id.R index 23093c3f..6d4db895 100644 --- a/R/tm_g_events_term_id.R +++ b/R/tm_g_events_term_id.R @@ -259,48 +259,54 @@ srv_g_events_term_id <- function(id, 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) + 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]]) + arm_data <- data()[[arm_dataset]] + choices <- levels(arm_data[[arm_var_name]]) - trt_index <- if (length(choices) == 1L) 1L else 2L + 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) + 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] + 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) + }, + ignoreNULL = FALSE + ) observeEvent(list(input$diff_ci_method, input$conf_level), { req(!is.null(input$diff_ci_method) && !is.null(input$conf_level)) diff --git a/R/tm_g_swimlane.R b/R/tm_g_swimlane.R index 02689ea6..ee405ecf 100644 --- a/R/tm_g_swimlane.R +++ b/R/tm_g_swimlane.R @@ -41,23 +41,23 @@ #' @template author_qit3 #' tm_g_swimlane <- function(label, - dataname, - bar_var, - bar_color_var = NULL, - sort_var = NULL, - marker_pos_var = NULL, - marker_shape_var = NULL, - marker_shape_opt = NULL, - marker_color_var = NULL, - marker_color_opt = NULL, - anno_txt_var = NULL, - vref_line = NULL, - plot_height = c(1200L, 400L, 5000L), - plot_width = NULL, - pre_output = NULL, - post_output = NULL, - x_label = "Time from First Treatment (Day)", - transformators = list()) { + dataname, + bar_var, + bar_color_var = NULL, + sort_var = NULL, + marker_pos_var = NULL, + marker_shape_var = NULL, + marker_shape_opt = NULL, + marker_color_var = NULL, + marker_color_opt = NULL, + anno_txt_var = NULL, + vref_line = NULL, + plot_height = c(1200L, 400L, 5000L), + plot_width = NULL, + pre_output = NULL, + post_output = NULL, + x_label = "Time from First Treatment (Day)", + transformators = list()) { checkmate::assert_string(label) checkmate::assert_string(dataname) .assert_picks_single_var(bar_var, "bar_var") @@ -110,17 +110,17 @@ tm_g_swimlane <- function(label, #' @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) { + 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( @@ -201,20 +201,20 @@ ui_g_swimlane <- function(id, #' @keywords internal srv_g_swimlane <- function(id, - data, - dataname, - marker_shape_opt, - marker_color_opt, - plot_height, - plot_width, - x_label, - bar_var, - bar_color_var, - sort_var, - marker_pos_var, - marker_shape_var, - marker_color_var, - anno_txt_var) { + data, + dataname, + marker_shape_opt, + marker_color_opt, + plot_height, + plot_width, + 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(isolate(data()), "teal_data") diff --git a/R/tm_g_waterfall.R b/R/tm_g_waterfall.R index 9b6cb337..cd07fcdd 100644 --- a/R/tm_g_waterfall.R +++ b/R/tm_g_waterfall.R @@ -50,27 +50,27 @@ #' @author houx14 \email{houx14@gene.com} #' tm_g_waterfall <- function(label, - dataname_tr = "ADTR", - dataname_rs = "ADRS", - bar_paramcd, - bar_var, - bar_color_var = NULL, - bar_color_opt = NULL, - 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, - show_value = TRUE, - plot_height = c(1200L, 400L, 5000L), - plot_width = NULL, - pre_output = NULL, - post_output = NULL, - transformators = list()) { + dataname_tr = "ADTR", + dataname_rs = "ADRS", + bar_paramcd, + bar_var, + bar_color_var = NULL, + bar_color_opt = NULL, + 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, + show_value = TRUE, + plot_height = c(1200L, 400L, 5000L), + plot_width = NULL, + pre_output = NULL, + post_output = NULL, + transformators = list()) { checkmate::assert_string(label) checkmate::assert_string(dataname_tr) checkmate::assert_string(dataname_rs) @@ -121,23 +121,23 @@ tm_g_waterfall <- function(label, #' @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) { + 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( @@ -252,21 +252,21 @@ ui_g_waterfall <- function(id, #' @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, - facet_var, - bar_color_opt, - plot_height, - plot_width) { + 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, + facet_var, + bar_color_opt, + plot_height, + plot_width) { checkmate::assert_class(data, "reactive") checkmate::assert_class(isolate(data()), "teal_data") From 80256d013d71a4fe4f831e7220b975ecac346584 Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Wed, 27 May 2026 16:38:57 +0000 Subject: [PATCH 11/12] [skip roxygen] [skip vbump] Roxygen Man Pages Auto Update --- man/dot-assert_picks_single_var.Rd | 17 +++ ...unk_dims.Rd => dot-picks_all_datanames.Rd} | 10 +- man/tm_g_events_term_id.Rd | 70 ++--------- man/tm_g_swimlane.Rd | 119 ++++-------------- man/tm_g_waterfall.Rd | 118 ++++++----------- 5 files changed, 103 insertions(+), 231 deletions(-) create mode 100644 man/dot-assert_picks_single_var.Rd rename man/{set_chunk_dims.Rd => dot-picks_all_datanames.Rd} (78%) diff --git a/man/dot-assert_picks_single_var.Rd b/man/dot-assert_picks_single_var.Rd new file mode 100644 index 00000000..fb1bcbb2 --- /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.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 78% rename from man/set_chunk_dims.Rd rename to man/dot-picks_all_datanames.Rd index aea85363..facc0ec4 100644 --- a/man/set_chunk_dims.Rd +++ b/man/dot-picks_all_datanames.Rd @@ -1,12 +1,14 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/utils.R -\name{set_chunk_dims} -\alias{set_chunk_dims} +\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{pick_slots}{(\code{list}) named list of \code{picks} objects (NULL entries ignored).} + \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}} @@ -16,6 +18,8 @@ This can be used to only change \code{recordedplot}, \code{ggplot2} or other typ } \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/tm_g_events_term_id.Rd b/man/tm_g_events_term_id.Rd index 107d636b..e3af6ce8 100644 --- a/man/tm_g_events_term_id.Rd +++ b/man/tm_g_events_term_id.Rd @@ -1,60 +1,30 @@ % Generated by roxygen2: do not edit by hand -<<<<<<< HEAD -% 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 ->>>>>>> 1c9c1a9ca52595095251983b428ecb0141ba6911 \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 = "Common AE", -<<<<<<< HEAD - 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 - ) - ), -======= - dataname = NULL, - term_var, - arm_var, - fontsize = c(5, 3, 7), - plot_height = c(600L, 200L, 2000L), - plot_width = NULL, - transformators = list() -) - -\method{tm_g_events_term_id}{default}( - label = "Common AE", - dataname = NULL, - term_var, - arm_var, + 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() ) -\method{tm_g_events_term_id}{picks}( +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)), ->>>>>>> 1c9c1a9ca52595095251983b428ecb0141ba6911 fontsize = c(5, 3, 7), plot_height = c(600L, 200L, 2000L), plot_width = NULL, @@ -85,6 +55,10 @@ 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:module]{teal::module()}} object. @@ -92,11 +66,9 @@ the \code{\link[teal:module]{teal::module()}} object. \description{ Display an events-by-term plot as a Shiny module using \code{\link[teal.picks:picks]{teal.picks::picks()}} encodings. } -\section{Methods (by class)}{ +\section{Functions}{ \itemize{ -\item \code{tm_g_events_term_id(default)}: Legacy \code{\link[teal.transform:choices_selected]{teal.transform::choices_selected()}} encodings. - -\item \code{tm_g_events_term_id(picks)}: \code{\link[teal.picks:picks]{teal.picks::picks()}}-based encodings (\code{picks}). +\item \code{tm_g_events_term_id.picks()}: \code{\link[teal.picks:picks]{teal.picks::picks()}}-based encodings (\code{picks}). }} \section{Reporting}{ @@ -124,16 +96,11 @@ data <- teal_data() \%>\% join_keys(data) <- default_cdisc_join_keys[names(data)] -<<<<<<< HEAD -======= -# Legacy `teal.transform::choices_selected()` encodings (default S3 method): ->>>>>>> 1c9c1a9ca52595095251983b428ecb0141ba6911 app <- init( data = data, modules = modules( tm_g_events_term_id( label = "Common AE", -<<<<<<< HEAD term_var = teal.picks::picks( teal.picks::datasets("ADAE"), teal.picks::variables( @@ -147,19 +114,6 @@ app <- init( choices = teal.picks::is_categorical(min.len = 2), selected = "ACTARMCD" ) -======= - dataname = "ADAE", - term_var = choices_selected( - selected = "AEDECOD", - choices = c( - "AEDECOD", "AETERM", - "AEHLT", "AELLT", "AEBODSYS" - ) - ), - arm_var = choices_selected( - selected = "ACTARMCD", - choices = c("ACTARM", "ACTARMCD") ->>>>>>> 1c9c1a9ca52595095251983b428ecb0141ba6911 ), plot_height = c(600, 200, 2000) ) diff --git a/man/tm_g_swimlane.Rd b/man/tm_g_swimlane.Rd index fcdb7324..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,7 +74,8 @@ 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")}.} @@ -80,7 +84,8 @@ To learn more check \code{vignette("transform-input-data", package = "teal")}.} 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 6262c551..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.} @@ -99,7 +100,8 @@ To learn more check \code{vignette("transform-input-data", package = "teal")}.} 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} From 726b039d77755c3aee24049b81cdf35352e7dccc Mon Sep 17 00:00:00 2001 From: Oriol Senan <35930244+osenan@users.noreply.github.com> Date: Tue, 23 Jun 2026 07:15:22 +0200 Subject: [PATCH 12/12] Add picks variable selection to ae_oview module (#331) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit # Pull Request This partially closes #330 I based my changes [in this PR](https://github.com/insightsengineering/teal.osprey/pull/329). Please compare both modules with this example app (requires to have teal.picks installed, osprey) ``` library("teal") library("teal.picks") devtools::load_all() data <- teal_data() %>% within({ library(dplyr) ADSL <- teal.data::rADSL ADAE <- teal.data::rADAE .add_event_flags <- function(dat) { dat <- dat %>% mutate( TMPFL_SER = AESER == "Y", TMPFL_REL = AEREL == "Y", TMPFL_GR5 = AETOXGR == "5", AEREL1 = (AEREL == "Y" & ACTARM == "A: Drug X"), AEREL2 = (AEREL == "Y" & ACTARM == "B: Placebo") ) labels <- c( "Serious AE", "Related AE", "Grade 5 AE", "AE related to A: Drug X", "AE related to B: Placebo" ) cols <- c("TMPFL_SER", "TMPFL_REL", "TMPFL_GR5", "AEREL1", "AEREL2") for (i in seq_along(labels)) { attr(dat[[cols[i]]], "label") <- labels[i] } dat } ADAE <- .add_event_flags(ADAE) }) join_keys(data) <- default_cdisc_join_keys[names(data)] app <- init( data = data, modules = modules( tm_g_ae_oview( label = "Common AE (picks)", flag_var_anl = teal.picks::picks( teal.picks::datasets("ADAE"), teal.picks::variables( choices = c("TMPFL_SER", "TMPFL_REL", "TMPFL_GR5", "AEREL1", "AEREL2"), selected = "TMPFL_SER" ) ), 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) ), # Default method (old) for comparison tm_g_ae_oview( label = "Common AE (default)", dataname = "ADAE", flag_var_anl = teal.transform::choices_selected( selected = "AEREL1", choices = teal.transform::variable_choices( data[["ADAE"]], c("TMPFL_SER", "TMPFL_REL", "TMPFL_GR5", "AEREL1", "AEREL2") ) ), arm_var = teal.transform::choices_selected( selected = "ACTARMCD", choices = c("ACTARM", "ACTARMCD") ), plot_height = c(600, 200, 2000) ) ) ) shinyApp(app$ui, app$server) ``` I refactored the `tm_g_ae_oview` module to create a generic, keep the default for `teal.transform` and add a method for picks variable selection. The module works as expected and setting the variables is better with picks. The issue reported in the similar PR on the plot dimensions is fixed if we set the plot dimensions in the module. The ui of the picks ui components is different and it breaks, in my opinion, the color pattern of the teal app. image image Here the teal.transform module image image I added simple tests for the module as well --------- Signed-off-by: Oriol Senan <35930244+osenan@users.noreply.github.com> Co-authored-by: osenan Co-authored-by: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Co-authored-by: André Veríssimo <211358+averissimo@users.noreply.github.com> --- .github/workflows/check.yaml | 1 + .lintr | 1 + DESCRIPTION | 8 +- NAMESPACE | 2 + R/teal.osprey.R | 2 +- R/tm_g_ae_oview.R | 303 +++++++++++++++++----------- R/utils.R | 86 +------- R/utils_picks.R | 160 +++++++++++++++ inst/WORDLIST | 3 + man/dot-assert_picks_single_var.Rd | 2 +- man/dot-picks_all_datanames.Rd | 9 +- man/tm_g_ae_oview.Rd | 30 ++- tests/testthat/test-tm_g_ae_oview.R | 69 +++++++ 13 files changed, 441 insertions(+), 235 deletions(-) create mode 100644 R/utils_picks.R create mode 100644 tests/testthat/test-tm_g_ae_oview.R 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 5974985e..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), @@ -37,7 +38,6 @@ Imports: teal.code (>= 0.7.0), teal.data (>= 0.8.0), teal.logger (>= 0.4.0), - teal.picks (>= 0.1.0), teal.reporter (>= 0.6.0), teal.widgets (>= 0.5.0), tern (>= 0.9.7), @@ -52,10 +52,10 @@ Suggests: withr (>= 3.0.0) Remotes: insightsengineering/osprey, - insightsengineering/teal.picks@redesign_extraction@main + insightsengineering/teal.picks Config/Needs/verdepcheck: insightsengineering/osprey, rstudio/shiny, - insightsengineering/teal, insightsengineering/teal.slice, - insightsengineering/teal.transform, insightsengineering/teal.picks, + 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, 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/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/utils.R b/R/utils.R index bb0622d8..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,85 +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 -#' -#' 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 - }) -} 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/dot-assert_picks_single_var.Rd b/man/dot-assert_picks_single_var.Rd index fb1bcbb2..e424df4c 100644 --- a/man/dot-assert_picks_single_var.Rd +++ b/man/dot-assert_picks_single_var.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/utils.R +% 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).} diff --git a/man/dot-picks_all_datanames.Rd b/man/dot-picks_all_datanames.Rd index facc0ec4..49fbc8a7 100644 --- a/man/dot-picks_all_datanames.Rd +++ b/man/dot-picks_all_datanames.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/utils.R +% 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}} @@ -8,13 +8,6 @@ } \arguments{ \item{pick_slots}{(\code{list}) named list of \code{picks} objects (NULL entries ignored).} - -\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.} } \value{ A reactive expression that returns the \code{teal_card} with updated dimensions diff --git a/man/tm_g_ae_oview.Rd b/man/tm_g_ae_oview.Rd index 0aee4aa8..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 @@ -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/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") + }) +})