From fff2ede2edb48b571e3c2142c6bf8e6b70643694 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dawid=20Ka=C5=82=C4=99dkowski?= <6959016+gogonzo@users.noreply.github.com> Date: Thu, 8 Sep 2022 18:13:19 +0200 Subject: [PATCH] 26 new chunks@main (#172) * Update file paths (#171) Co-authored-by: cicdguy <26552821+cicdguy@users.noreply.github.com> * [skip actions] Bump version to 0.1.14.9013.1 * tm_g_ae_oview * implement quosures and data * fixes * [skip actions] Restyle files * Apply suggestions from code review * fix linting * with filter * Apply suggestions from code review Co-authored-by: Mahmoud Hallal <86970066+mhallal1@users.noreply.github.com> * Update NEWS.md * fix tm_g_ae_oview report card * @main: * remove print statements * fix red error from empty data * fix butterfly validation * Apply suggestions from code review Fix docs grammar Co-authored-by: Mahmoud Hallal <86970066+mhallal1@users.noreply.github.com> Co-authored-by: Nikolas Burkoff * [skip actions] Roxygen Man Pages Auto Update * empty Co-authored-by: Insights Engineering Bot <68416928+insights-engineering-bot@users.noreply.github.com> Co-authored-by: cicdguy <26552821+cicdguy@users.noreply.github.com> Co-authored-by: cicdguy Co-authored-by: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Co-authored-by: Nikolas Burkoff Co-authored-by: Mahmoud Hallal <86970066+mhallal1@users.noreply.github.com> Co-authored-by: Maciej Nasinski Co-authored-by: 27856297+dependabot-preview[bot]@users.noreply.github.com <27856297+dependabot-preview[bot]@users.noreply.github.com> --- .github/workflows/check.yaml | 1 - NEWS.md | 4 +- R/argument_convention.R | 2 +- R/tm_g_ae_oview.R | 148 ++++++++----------- R/tm_g_ae_sub.R | 153 +++++++------------- R/tm_g_butterfly.R | 148 +++++++++---------- R/tm_g_events_term_id.R | 108 ++++++-------- R/tm_g_heat_bygrade.R | 95 +++++------- R/tm_g_patient_profile.R | 272 +++++++++++++++++------------------ R/tm_g_spiderplot.R | 108 ++++++-------- R/tm_g_swimlane.R | 113 +++++++-------- R/tm_g_waterfall.R | 135 ++++++++--------- man/argument_convention.Rd | 2 +- man/tm_g_ae_oview.Rd | 2 +- man/tm_g_ae_sub.Rd | 2 +- man/tm_g_events_term_id.Rd | 2 +- 16 files changed, 549 insertions(+), 746 deletions(-) diff --git a/.github/workflows/check.yaml b/.github/workflows/check.yaml index 00745c3c..ec90c833 100644 --- a/.github/workflows/check.yaml +++ b/.github/workflows/check.yaml @@ -25,7 +25,6 @@ jobs: secrets: REPO_GITHUB_TOKEN: ${{ secrets.REPO_GITHUB_TOKEN }} coverage: - if: github.event_name == 'pull_request' name: Coverage 📔 uses: insightsengineering/r.pkg.template/.github/workflows/test-coverage.yaml@main secrets: diff --git a/NEWS.md b/NEWS.md index 28bcda37..b3710d15 100644 --- a/NEWS.md +++ b/NEWS.md @@ -2,7 +2,9 @@ ### Breaking changes * Soft deprecate function `label_aevar()`. - +* Replaced `chunks` with simpler `Quosure` class. +* Replaced `datasets` argument containing `FilteredData` with the new arguments `data` (list of reactive datasets) and `filter_panel_api` (`FilterPanelAPI`). +* Updated `arm_var` to point to the factor column in `ANL`. It can't be a character column anymore. ### Enhancements * Added `teal.reporter` to all modules. diff --git a/R/argument_convention.R b/R/argument_convention.R index 62ade90f..d41b0177 100644 --- a/R/argument_convention.R +++ b/R/argument_convention.R @@ -19,7 +19,7 @@ #' @param arm_var (`choices_selected`)\cr #' object with all available choices and the pre-selected option for variable #' names that can be used as `arm_var`. See [teal.transform::choices_selected()] for -#' details. +#' details. Column `arm_var` in the `dataname` has to be a factor. #' #' @param paramcd (`character(1)` or `choices_selected`)\cr #' variable value designating the studied parameter. diff --git a/R/tm_g_ae_oview.R b/R/tm_g_ae_oview.R index e3666b83..12e9d170 100644 --- a/R/tm_g_ae_oview.R +++ b/R/tm_g_ae_oview.R @@ -136,7 +136,7 @@ tm_g_ae_oview <- function(label, ), ui = ui_g_ae_oview, ui_args = args, - filters = dataname + filters = c("ADSL", dataname) ) } @@ -208,22 +208,23 @@ ui_g_ae_oview <- function(id, ...) { footnotes = "" ) ), - forms = get_rcode_ui(ns("rcode")) + forms = teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") ) } srv_g_ae_oview <- function(id, - datasets, + data, + filter_panel_api, reporter, dataname, label, plot_height, plot_width) { with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") + with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") moduleServer(id, function(input, output, session) { - teal.code::init_chunks() - decorate_output <- srv_g_decorate(id = NULL, plt = plt, plot_height = plot_height, plot_width = plot_width) + decorate_output <- srv_g_decorate(id = NULL, plt = plot_r, plot_height = plot_height, plot_width = plot_width) font_size <- decorate_output$font_size pws <- decorate_output$pws @@ -241,15 +242,12 @@ srv_g_ae_oview <- function(id, ) }) - observeEvent(input$arm_var, { - ANL <- datasets$get_data(dataname, filtered = FALSE) # nolint - - req(!is.null(input$arm_var)) + observeEvent(input$arm_var, ignoreNULL = TRUE, { + ANL <- data[[dataname]]() # nolint arm_var <- input$arm_var + arm_val <- ANL[[arm_var]] + choices <- levels(arm_val) - choices <- unique(ANL[[arm_var]]) - - validate(need(length(choices) > 0, "Please include multiple treatment")) if (length(choices) == 1) { trt_index <- 1 } else { @@ -270,8 +268,13 @@ srv_g_ae_oview <- function(id, ) }) - plt <- reactive({ + output_q <- reactive({ + ANL <- data[[dataname]]() # nolint validate(need(input$arm_var, "Please select an arm variable.")) + validate(need( + is.factor(ANL[[input$arm_var]]), + "Selected arm variable needs to be a factor." + )) validate(need(input$flag_var_anl, "Please select at least one flag.")) validate(need( input$arm_trt != input$arm_ref, @@ -281,83 +284,61 @@ srv_g_ae_oview <- function(id, sep = "\n" ) )) - - ANL_UNFILTERED <- datasets$get_data(dataname, filtered = FALSE) # nolint - ADSL <- datasets$get_data("ADSL", filtered = TRUE) # nolint - ANL <- datasets$get_data(dataname, filtered = TRUE) # nolint - - anl_name <- dataname - assign(anl_name, ANL) - - teal.code::chunks_reset(envir = environment()) - validate(need(nlevels(ANL[[input$arm_var]]) > 1, "Arm needs to have at least 2 levels")) validate_has_data(ANL, min_nrow = 10) - if (all(c(input$arm_trt, input$arm_ref) %in% ANL_UNFILTERED[[input$arm_var]])) { - validate( - need( - input$arm_ref %in% ANL[[input$arm_var]], - paste0("Selected Control ", input$arm_var, ", ", input$arm_ref, ", is not in the data (filtered out?)") - ), - need( - input$arm_trt %in% ANL[[input$arm_var]], - paste0("Selected Treatment ", input$arm_var, ", ", input$arm_trt, ", is not in the data (filtered out?)") - ) + validate( + need( + input$arm_ref %in% ANL[[input$arm_var]], + paste0("Selected Control ", input$arm_var, ", ", input$arm_ref, ", is not in the data (filtered out?)") + ), + need( + input$arm_trt %in% ANL[[input$arm_var]], + paste0("Selected Treatment ", input$arm_var, ", ", input$arm_trt, ", is not in the data (filtered out?)") ) - } + ) validate(need(all(c(input$arm_trt, input$arm_ref) %in% unique(ANL[[input$arm_var]])), "Plot loading")) - teal.code::chunks_push( - id = "variables call", - expression = bquote({ - id <- .(as.name(anl_name))[["USUBJID"]] - arm <- .(as.name(anl_name))[[.(input$arm_var)]] - arm_N <- table(ADSL[[.(input$arm_var)]]) # nolint - trt <- .(input$arm_trt) - ref <- .(input$arm_ref) - anl_labels <- formatters::var_labels(.(as.name(anl_name)), fill = FALSE) - flags <- .(as.name(anl_name)) %>% + q1 <- teal.code::eval_code( + teal.code::new_quosure(data), + name = "variables call", + code = as.expression(c( + bquote(anl_labels <- formatters::var_labels(.(as.name(dataname)), fill = FALSE)), + bquote(flags <- .(as.name(dataname)) %>% select(all_of(.(input$flag_var_anl))) %>% - rename_at(vars(.(input$flag_var_anl)), function(x) paste0(x, ": ", anl_labels[x])) - }) + rename_at(vars(.(input$flag_var_anl)), function(x) paste0(x, ": ", anl_labels[x]))) + )) ) - teal.code::chunks_push_new_line() - - teal.code::chunks_safe_eval() - - teal.code::chunks_push( - id = "g_events_term_id call", - expression = bquote({ - osprey::g_events_term_id( - term = flags, - id = id, - arm = arm, - arm_N = arm_N, - ref = .(input$arm_ref), - trt = .(input$arm_trt), - diff_ci_method = .(input$diff_ci_method), - conf_level = .(input$conf_level), - axis_side = .(input$axis), - fontsize = .(font_size()), - draw = TRUE - ) - }) + teal.code::eval_code( + q1, + name = "g_events_term_id call", + code = as.expression(c( + bquote( + plot <- osprey::g_events_term_id( + term = flags, + id = .(as.name(dataname))[["USUBJID"]], + arm = .(as.name(dataname))[[.(input$arm_var)]], + arm_N = table(ADSL[[.(input$arm_var)]]), + ref = .(input$arm_ref), + trt = .(input$arm_trt), + diff_ci_method = .(input$diff_ci_method), + conf_level = .(input$conf_level), + axis_side = .(input$axis), + fontsize = .(font_size()), + draw = TRUE + ) + ), + quote(plot) + )) ) - - teal.code::chunks_safe_eval() }) - get_rcode_srv( + plot_r <- reactive(output_q()[["plot"]]) + + teal.widgets::verbatim_popup_srv( id = "rcode", - datasets = datasets, - modal_title = paste("R code for", label), - datanames = unique(c( - dataname, - vapply(X = dataname, FUN.VALUE = character(1), function(x) { - if (inherits(datasets, "CDISCFilteredData")) datasets$get_parentname(x) - }) - )) + verbatim_content = reactive(teal.code::get_code(output_q())), + title = paste("R code for", label) ) ### REPORTER @@ -366,19 +347,14 @@ srv_g_ae_oview <- function(id, card <- teal.reporter::TealReportCard$new() card$set_name("AE Overview") card$append_text("AE Overview", "header2") - card$append_fs(datasets$get_filter_state()) + if (with_filter) card$append_fs(filter_panel_api$get_filter_state()) card$append_text("Plot", "header3") - card$append_plot(plt(), dim = pws$dim()) + card$append_plot(plot_r(), dim = pws$dim()) if (!comment == "") { card$append_text("Comment", "header3") card$append_text(comment) } - card$append_src(paste(get_rcode( - chunks = teal.code::get_chunks_object(parent_idx = 2L), - datasets = datasets, - title = "", - description = "" - ), collapse = "\n")) + card$append_src(paste(teal.code::get_code(output_q()), collapse = "\n")) card } teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun) diff --git a/R/tm_g_ae_sub.R b/R/tm_g_ae_sub.R index acb8abca..3892f3f4 100644 --- a/R/tm_g_ae_sub.R +++ b/R/tm_g_ae_sub.R @@ -87,7 +87,7 @@ tm_g_ae_sub <- function(label, group_var = group_var, fontsize = fontsize ), - filters = dataname + filters = c("ADSL", dataname) ) } @@ -161,40 +161,38 @@ ui_g_ae_sub <- function(id, ...) { ) ) ), - forms = get_rcode_ui(ns("rcode")) + forms = teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") ) } srv_g_ae_sub <- function(id, - datasets, + data, + filter_panel_api, reporter, dataname, label, plot_height, plot_width) { with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") + with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") moduleServer(id, function(input, output, session) { - teal.code::init_chunks() decorate_output <- srv_g_decorate( id = NULL, - plt = plt, + plt = plot_r, plot_height = plot_height, plot_width = plot_width ) font_size <- decorate_output$font_size pws <- decorate_output$pws - observeEvent(input$arm_var, { - req(!is.null(input$arm_var)) + observeEvent(input$arm_var, ignoreNULL = TRUE, { arm_var <- input$arm_var - ANL <- datasets$get_data(dataname, filtered = TRUE) # nolint + ANL <- data[[dataname]]() # nolint - choices <- unique(ANL[[arm_var]]) + anl_val <- ANL[[arm_var]] + choices <- levels(anl_val) - validate(need( - length(choices) > 0, "Please include multiple treatment" - )) if (length(choices) == 1) { ref_index <- 1 } else { @@ -234,7 +232,7 @@ srv_g_ae_sub <- function(id, }) observeEvent(input$groups, { - ANL <- datasets$get_data(dataname, filtered = TRUE) # nolint + ANL <- data[[dataname]]() # nolint output$grouplabel_output <- renderUI({ grps <- input$groups lo <- lapply(seq_along(grps), function(index) { @@ -277,17 +275,14 @@ srv_g_ae_sub <- function(id, }) }) - plt <- reactive({ + output_q <- reactive({ + ANL <- data[[dataname]]() # nolint + ADSL <- data[["ADSL"]]() # nolint + validate_has_data(ANL, min_nrow = 10) validate(need(input$arm_var, "Please select an arm variable.")) - ANL <- datasets$get_data(dataname, filtered = TRUE) # nolint - ADSL <- datasets$get_data("ADSL", filtered = TRUE) # nolint - - anl_name <- dataname - assign(anl_name, ANL) - validate(need( - is.factor(ADSL[[input$arm_var]]), - "Selected arm variable needs to be a factor." + is.factor(ANL[[input$arm_var]]), + "Selected arm variable needs to be a factor. Contact the app developer." )) validate( need( @@ -297,12 +292,11 @@ srv_g_ae_sub <- function(id, ) validate( need( - all(c(input$arm_trt, input$arm_ref) %in% unique(ANL[[input$arm_var]])), + all(c(input$arm_trt, input$arm_ref) %in% levels(ANL[[input$arm_var]])), "The dataset does not contain subjects with AE events from both the control and treatment arms." ), need( - all(input$groups %in% names(ANL)) & - all(input$groups %in% names(ADSL)), + all(input$groups %in% names(ANL)) & all(input$groups %in% names(ADSL)), "Check all selected subgroups are columns in ADAE and ADSL." ), need( @@ -311,25 +305,6 @@ srv_g_ae_sub <- function(id, ) ) - teal.code::chunks_reset(envir = environment()) - - teal.code::chunks_push( - id = "variables call", - expression = bquote({ - id <- .(as.name(anl_name))$USUBJID - arm <- as.factor(.(as.name(anl_name))[[.(input$arm_var)]]) - arm_sl <- as.character(ADSL[[.(input$arm_var)]]) - grps <- .(input$groups) - subgroups <- .(as.name(anl_name))[grps] - subgroups_sl <- ADSL[grps] - trt <- .(input$arm_trt) - ref <- .(input$arm_ref) - }) - ) - teal.code::chunks_push_new_line() - - teal.code::chunks_safe_eval() - group_labels <- lapply(seq_along(input$groups), function(x) { items <- input[[sprintf("groups__%s", x)]] if (length(items) > 0) { @@ -342,59 +317,46 @@ srv_g_ae_sub <- function(id, } }) - if (length(unlist(group_labels)) == 0) { - teal.code::chunks_push( - id = "group_labels call", - expression = bquote({ - group_labels <- NULL - }) - ) + group_labels_call <- if (length(unlist(group_labels)) == 0) { + quote(group_labels <- NULL) } else { - teal.code::chunks_push( - id = "group_labels call", - expression = bquote({ - group_labels <- .(group_labels) - names(group_labels) <- .(input$groups) - }) - ) + bquote(group_labels <- setNames(.(group_labels), .(input$groups))) } - teal.code::chunks_push_new_line() - teal.code::chunks_safe_eval() - teal.code::chunks_push( - id = "g_ae_sub call", - expression = bquote({ - osprey::g_ae_sub( - id = id, - arm = arm, - arm_sl = arm_sl, - trt = trt, - ref = ref, - subgroups = subgroups, - subgroups_sl = subgroups_sl, - subgroups_levels = group_labels, - conf_level = .(input$conf_level), - diff_ci_method = .(input$ci), - fontsize = .(font_size()), - arm_n = .(input$arm_n), - draw = TRUE - ) - }) + q1 <- teal.code::eval_code(teal.code::new_quosure(data), code = group_labels_call, name = "group_labels call") + q2 <- teal.code::eval_code(q1, code = "") + teal.code::eval_code( + q2, + name = "g_ae_sub call", + code = as.expression(c( + bquote( + plot <- osprey::g_ae_sub( + id = .(as.name(dataname))$USUBJID, + arm = as.factor(.(as.name(dataname))[[.(input$arm_var)]]), + arm_sl = as.character(ADSL[[.(input$arm_var)]]), + trt = .(input$arm_trt), + ref = .(input$arm_ref), + subgroups = .(as.name(dataname))[.(input$groups)], + subgroups_sl = ADSL[.(input$groups)], + subgroups_levels = group_labels, + conf_level = .(input$conf_level), + diff_ci_method = .(input$ci), + fontsize = .(font_size()), + arm_n = .(input$arm_n), + draw = TRUE + ) + ), + quote(plot) + )) ) - - teal.code::chunks_safe_eval() }) - get_rcode_srv( + plot_r <- reactive(output_q()[["plot"]]) + + teal.widgets::verbatim_popup_srv( id = "rcode", - datasets = datasets, - modal_title = paste("R code for", label), - datanames = unique(c( - dataname, - vapply(X = dataname, FUN.VALUE = character(1), function(x) { - if (inherits(datasets, "CDISCFilteredData")) datasets$get_parentname(x) - }) - )) + verbatim_content = reactive(teal.code::get_code(output_q())), + title = paste("R code for", label), ) ### REPORTER @@ -403,19 +365,14 @@ srv_g_ae_sub <- function(id, card <- teal.reporter::TealReportCard$new() card$set_name("AE Subgroups") card$append_text("AE Subgroups", "header2") - card$append_fs(datasets$get_filter_state()) + if (with_filter) card$append_fs(filter_panel_api$get_filter_state()) card$append_text("Plot", "header3") - card$append_plot(plt(), dim = pws$dim()) + card$append_plot(plot_r(), dim = pws$dim()) if (!comment == "") { card$append_text("Comment", "header3") card$append_text(comment) } - card$append_src(paste(get_rcode( - chunks = teal.code::get_chunks_object(parent_idx = 2L), - datasets = datasets, - title = "", - description = "" - ), collapse = "\n")) + card$append_src(paste(teal.code::get_code(output_q()), collapse = "\n")) card } teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun) diff --git a/R/tm_g_butterfly.R b/R/tm_g_butterfly.R index cc1524bc..a3265458 100644 --- a/R/tm_g_butterfly.R +++ b/R/tm_g_butterfly.R @@ -146,7 +146,7 @@ tm_g_butterfly <- function(label, module( label = label, - filters = dataname, + filters = c("ADSL", dataname), server = srv_g_butterfly, server_args = list(dataname = dataname, label = label, plot_height = plot_height, plot_width = plot_width), ui = ui_g_butterfly, @@ -252,31 +252,20 @@ ui_g_butterfly <- function(id, ...) { value = a$legend_on ) ), - forms = get_rcode_ui(ns("rcode")), + forms = teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code"), pre_output = a$pre_output, post_output = a$post_output ) } -srv_g_butterfly <- function(id, datasets, reporter, dataname, label, plot_height, plot_width) { +srv_g_butterfly <- function(id, data, filter_panel_api, reporter, dataname, label, plot_height, plot_width) { with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") + with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") moduleServer(id, function(input, output, session) { - teal.code::init_chunks() - options <- reactiveValues(r = NULL, l = NULL) vars <- reactiveValues(r = NULL, l = NULL) - reactive_data <- reactive({ - ADSL <- datasets$get_data("ADSL", filtered = FALSE) # nolint - ANL <- datasets$get_data(dataname, filtered = FALSE) # nolint - - ADSL_df <- ADSL %>% as.data.frame() # nolint - ANL_df <- ANL %>% as.data.frame() # nolint - - list(ADSL_df = ADSL_df, ANL_df = ANL_df) - }) - # dynamic options for dichotomization variable observeEvent(input$right_var, handlerExpr = { @@ -291,11 +280,10 @@ srv_g_butterfly <- function(id, datasets, reporter, dataname, label, plot_height selected = character(0) ) } else { - data <- reactive_data() - options$r <- if (right_var %in% names(data$ADSL_df)) { - sort(unique(data$ADSL_df[, right_var])) + options$r <- if (right_var %in% names(data[["ADSL"]]())) { + levels(data[["ADSL"]]()[[right_var]]) } else { - sort(unique(data$ANL_df[, right_var])) + levels(data[[dataname]]()[[right_var]]) } selected <- if (length(right_val) > 0) { @@ -329,11 +317,10 @@ srv_g_butterfly <- function(id, datasets, reporter, dataname, label, plot_height choices = character(0), selected = character(0) ) } else { - data <- reactive_data() - options$l <- if (left_var %in% names(data$ADSL_df)) { - sort(unique(data$ADSL_df[, left_var])) + options$l <- if (left_var %in% names(data[["ADSL"]]())) { + levels(data[["ADSL"]]()[[left_var]]) } else { - sort(unique(data$ANL_df[, left_var])) + levels(data[[dataname]]()[[left_var]]) } selected <- if (length(left_val) > 0) { @@ -357,13 +344,9 @@ srv_g_butterfly <- function(id, datasets, reporter, dataname, label, plot_height ignoreNULL = FALSE ) - - - plot_r <- reactive({ - validate(need(input$category_var, "Please select a category variable.")) - - ADSL <- datasets$get_data("ADSL", filtered = TRUE) # nolint - ANL <- datasets$get_data(dataname, filtered = TRUE) # nolint + output_q <- reactive({ + ADSL <- data[["ADSL"]]() # nolint + ANL <- data[[dataname]]() # nolint right_var <- isolate(input$right_var) left_var <- isolate(input$left_var) @@ -378,21 +361,29 @@ srv_g_butterfly <- function(id, datasets, reporter, dataname, label, plot_height filter_var <- input$filter_var validate( + need(category_var, "Please select a category variable."), need(nrow(ADSL) > 0, "ADSL Data has no rows"), - need(nrow(ANL) > 0, "ADAE Data has no rows") - ) - validate( + need(nrow(ANL) > 0, "ADAE Data has no rows"), need(right_var, "'Right Dichotomization Variable' not selected"), need(left_var, "'Left Dichotomization Variable' not selected") ) + validate( need(length(right_val) > 0, "No values of 'Right Dichotomization Variable' are checked"), - need(length(left_val) > 0, "No values of 'Left Dichotomization Variable' are checked") + need(length(left_val) > 0, "No values of 'Left Dichotomization Variable' are checked"), + need( + is.factor(ANL[[right_var]]), + "Selected 'Right Dichotomization Variable' variable needs to be a factor. Contact an app developer." + ), + need( + is.factor(ANL[[left_var]]), + "Selected 'Right Dichotomization Variable' variable needs to be a factor. Contact an app developer." + ), + need( + any(c(ADSL[[right_var]] %in% right_val, ADSL[[left_var]] %in% left_val)), + "ADSL Data contains no rows with either of the selected left or right dichotomization values (filtered out?)" + ) ) - validate(need( - any(c(ADSL[[right_var]] %in% right_val, ADSL[[left_var]] %in% left_val)), - "ADSL Data contains no rows with either of the selected left or right dichotomization values (filtered out?)" - )) # if variable is not in ADSL, then take from domain VADs varlist <- c(category_var, color_by_var, facet_var, filter_var, right_var, left_var) @@ -402,47 +393,45 @@ srv_g_butterfly <- function(id, datasets, reporter, dataname, label, plot_height adsl_vars <- unique(c("USUBJID", "STUDYID", varlist_from_adsl)) # nolint anl_vars <- unique(c("USUBJID", "STUDYID", varlist_from_anl)) # nolint - anl_name <- dataname - assign(anl_name, ANL) # so that we can refer to the 'correct' data name - - teal.code::chunks_reset(envir = environment()) - - teal.code::chunks_push( - id = "datasets call", - expression = bquote({ + q1 <- teal.code::eval_code( + teal.code::new_quosure(data), + name = "datasets call", + code = bquote({ ADSL <- ADSL[, .(adsl_vars)] %>% as.data.frame() # nolint - ANL <- .(as.name(anl_name))[, .(anl_vars)] %>% as.data.frame() # nolint + ANL <- .(as.name(dataname))[, .(anl_vars)] %>% as.data.frame() # nolint }) ) - teal.code::chunks_push_new_line() + q2 <- teal.code::eval_code(q1, "") if (!("NULL" %in% filter_var) && !is.null(filter_var)) { - teal.code::chunks_push( - id = "data filter call", - expression = bquote( + q2 <- teal.code::eval_code( + q2, + name = "data filter call", + code = bquote( ANL <- quick_filter(.(filter_var), ANL) %>% # nolint droplevels() %>% as.data.frame() ) ) } - teal.code::chunks_push_new_line() + q3 <- teal.code::eval_code(q2, "") - teal.code::chunks_push( - id = "ANL_f call", - expression = bquote({ + q4 <- teal.code::eval_code( + q3, + name = "ANL_f call", + code = bquote({ ANL_f <- left_join(ADSL, ANL, by = c("USUBJID", "STUDYID")) %>% as.data.frame() # nolint ANL_f <- na.omit(ANL_f) # nolint }) ) - teal.code::chunks_push_new_line() - teal.code::chunks_push_new_line() + q5 <- teal.code::eval_code(q4, "\n") if (!is.null(right_val) && !is.null(right_val)) { - teal.code::chunks_push( - id = "right/left call", - expression = bquote({ + q5 <- teal.code::eval_code( + q5, + name = "right/left call", + code = bquote({ right <- ANL_f[, .(right_var)] %in% .(right_val) right_name <- paste(.(right_val), collapse = " - ") left <- ANL_f[, .(left_var)] %in% .(left_val) @@ -451,14 +440,14 @@ srv_g_butterfly <- function(id, datasets, reporter, dataname, label, plot_height ) } - teal.code::chunks_push_new_line() - teal.code::chunks_safe_eval() + q6 <- teal.code::eval_code(q5, "") if (!is.null(right_val) && !is.null(left_val)) { - teal.code::chunks_push( - id = "g_butterfly call", - expression = bquote({ - osprey::g_butterfly( + q6 <- teal.code::eval_code( + q6, + name = "g_butterfly call", + code = bquote( + plot <- osprey::g_butterfly( category = ANL_f[, .(category_var)], right_flag = right, left_flag = left, @@ -481,13 +470,15 @@ srv_g_butterfly <- function(id, datasets, reporter, dataname, label, plot_height sort_by = .(sort_by_var), show_legend = .(legend_on) ) - }) + ) ) } - teal.code::chunks_safe_eval() + teal.code::eval_code(q6, quote(plot)) }) + 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 = "butterflyplot", @@ -496,16 +487,10 @@ srv_g_butterfly <- function(id, datasets, reporter, dataname, label, plot_height width = plot_width ) - get_rcode_srv( + teal.widgets::verbatim_popup_srv( id = "rcode", - datasets = datasets, - modal_title = paste("R code for", label), - datanames = unique(c( - dataname, - vapply(X = dataname, FUN.VALUE = character(1), function(x) { - if (inherits(datasets, "CDISCFilteredData")) datasets$get_parentname(x) - }) - )) + title = paste("R code for", label), + verbatim_content = reactive(teal.code::get_code(output_q())) ) ### REPORTER @@ -514,7 +499,7 @@ srv_g_butterfly <- function(id, datasets, reporter, dataname, label, plot_height card <- teal.reporter::TealReportCard$new() card$set_name("Butterfly") card$append_text("Butterfly Plot", "header2") - card$append_fs(datasets$get_filter_state()) + if (with_filter) card$append_fs(filter_panel_api$get_filter_state()) if (!is.null(input$filter_var) || !is.null(input$facet_var) || !is.null(input$sort_by_var)) { card$append_text("Selected Options", "header3") } @@ -533,12 +518,7 @@ srv_g_butterfly <- function(id, datasets, reporter, dataname, label, plot_height card$append_text("Comment", "header3") card$append_text(comment) } - card$append_src(paste(get_rcode( - chunks = teal.code::get_chunks_object(parent_idx = 2L), - datasets = datasets, - title = "", - description = "" - ), collapse = "\n")) + card$append_src(paste(teal.code::get_code(output_q()), collapse = "\n")) card } teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun) diff --git a/R/tm_g_events_term_id.R b/R/tm_g_events_term_id.R index fd62c279..3024326e 100644 --- a/R/tm_g_events_term_id.R +++ b/R/tm_g_events_term_id.R @@ -89,7 +89,7 @@ tm_g_events_term_id <- function(label, server_args = list(label = label, dataname = dataname, plot_height = plot_height, plot_width = plot_width), ui = ui_g_events_term_id, ui_args = args, - filters = dataname + filters = c("ADSL", dataname) ) } @@ -190,26 +190,28 @@ ui_g_events_term_id <- function(id, ...) { footnotes = "" ) ), - forms = get_rcode_ui(ns("rcode")) + forms = teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") ) } srv_g_events_term_id <- function(id, - datasets, + data, + filter_panel_api, reporter, dataname, label, plot_height, plot_width) { with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") + with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") moduleServer(id, function(input, output, session) { - decorate_output <- srv_g_decorate(id = NULL, plt = plt, plot_height = plot_height, plot_width = plot_width) # nolint + decorate_output <- srv_g_decorate( + id = NULL, plt = plot_r, plot_height = plot_height, plot_width = plot_width + ) font_size <- decorate_output$font_size pws <- decorate_output$pws - teal.code::init_chunks() - 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 @@ -247,9 +249,10 @@ srv_g_events_term_id <- function(id, ) observeEvent(input$arm_var, + ignoreNULL = TRUE, handlerExpr = { arm_var <- input$arm_var - ANL <- datasets$get_data(dataname, filtered = TRUE) # nolint + ANL <- data[[dataname]]() # nolint choices <- levels(ANL[[arm_var]]) @@ -272,16 +275,22 @@ srv_g_events_term_id <- function(id, selected = choices[trt_index], choices = choices ) - }, - ignoreNULL = TRUE + } ) - plt <- reactive({ + output_q <- reactive({ + ANL <- data[[dataname]]() # nolint + validate( need(input$term, "'Term Variable' field is missing"), need(input$arm_var, "'Arm Variable' field is missing") ) + validate(need( + is.factor(ANL[[input$arm_var]]), + "Selected arm variable needs to be a factor. Contact an app developer." + )) + validate(need( input$arm_trt != input$arm_ref, paste("Treatment arm and control arm cannot be the same.", @@ -290,57 +299,39 @@ srv_g_events_term_id <- function(id, ) )) - ADSL <- datasets$get_data("ADSL", filtered = TRUE) # nolint - ANL <- datasets$get_data(dataname, filtered = TRUE) # nolint - formatters::var_labels(ANL) <- formatters::var_labels( - datasets$get_data(dataname, filtered = FALSE), - fill = FALSE - ) - - anl_name <- dataname - assign(anl_name, ANL) - validate(need( all(c(input$arm_trt, input$arm_ref) %in% unique(ANL[[input$arm_var]])), "Cannot generate plot. The dataset does not contain subjects from both the control and treatment arms." )) - teal.code::chunks_reset(envir = environment()) - adsl_vars <- unique(c("USUBJID", "STUDYID", input$arm_var)) # nolint anl_vars <- c("USUBJID", "STUDYID", input$term) # nolint - teal.code::chunks_push( - id = "ANL call", - expression = bquote({ + q1 <- teal.code::eval_code( + teal.code::new_quosure(data), + name = "ANL call", + code = bquote( ANL <- merge( # nolint x = ADSL[, .(adsl_vars), drop = FALSE], - y = .(as.name(anl_name))[, .(anl_vars), drop = FALSE], + y = .(as.name(dataname))[, .(anl_vars), drop = FALSE], all.x = FALSE, all.y = FALSE, by = c("USUBJID", "STUDYID") ) - }) + ) ) - teal.code::chunks_safe_eval() - validate(need(nrow(teal.code::chunks_get_var("ANL")) > 10, "need at least 10 data points")) + validate(need(nrow(q1[["ANL"]]) > 10, "ANL needs at least 10 data points")) - teal.code::chunks_push( - id = "Variables and g_events_term_id call", - expression = bquote({ - term <- ANL[[.(input$term)]] - id <- ANL$USUBJID - arm <- ANL[[.(input$arm_var)]] - arm_N <- table(ADSL[[.(input$arm_var)]]) # nolint - ref <- .(input$arm_ref) - trt <- .(input$arm_trt) - - osprey::g_events_term_id( - term = term, - id = id, - arm = arm, - arm_N = arm_N, + q2 <- teal.code::eval_code( + q1, + name = "Variables and g_events_term_id call", + code = bquote( + plot <- osprey::g_events_term_id( + term = ANL[[.(input$term)]], + id = ANL$USUBJID, + arm = ANL[[.(input$arm_var)]], + arm_N = table(ADSL[[.(input$arm_var)]]), ref = .(input$arm_ref), trt = .(input$arm_trt), sort_by = .(input$sort), @@ -353,22 +344,18 @@ srv_g_events_term_id <- function(id, fontsize = .(font_size()), draw = TRUE ) - }) + ) ) - teal.code::chunks_safe_eval() + teal.code::eval_code(q2, quote(plot)) }) - get_rcode_srv( + plot_r <- reactive(output_q()[["plot"]]) + + teal.widgets::verbatim_popup_srv( id = "rcode", - datasets = datasets, - modal_title = paste("R code for", label), - datanames = unique(c( - dataname, - vapply(X = dataname, FUN.VALUE = character(1), function(x) { - if (inherits(datasets, "CDISCFilteredData")) datasets$get_parentname(x) - }) - )) + title = paste("R code for", label), + verbatim_content = reactive(teal.code::get_code(output_q())) ) ### REPORTER @@ -377,19 +364,14 @@ srv_g_events_term_id <- function(id, card <- teal.reporter::TealReportCard$new() card$set_name("Events by Term") card$append_text("Events by Term", "header2") - card$append_fs(datasets$get_filter_state()) + if (with_filter) card$append_fs(filter_panel_api$get_filter_state()) card$append_text("Plot", "header3") - card$append_plot(plt(), dim = pws$dim()) + card$append_plot(plot_r(), dim = pws$dim()) if (!comment == "") { card$append_text("Comment", "header3") card$append_text(comment) } - card$append_src(paste(get_rcode( - chunks = teal.code::get_chunks_object(parent_idx = 2L), - datasets = datasets, - title = "", - description = "" - ), collapse = "\n")) + card$append_src(paste(teal.code::get_code(output_q()), collapse = "\n")) card } teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun) diff --git a/R/tm_g_heat_bygrade.R b/R/tm_g_heat_bygrade.R index 459f40ef..0e9c6481 100644 --- a/R/tm_g_heat_bygrade.R +++ b/R/tm_g_heat_bygrade.R @@ -286,13 +286,14 @@ ui_g_heatmap_bygrade <- function(id, ...) { footnotes = "" ) ), - forms = get_rcode_ui(ns("rcode")) + forms = teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") ) ) } srv_g_heatmap_bygrade <- function(id, - datasets, + data, + filter_panel_api, reporter, sl_dataname, ex_dataname, @@ -302,10 +303,10 @@ srv_g_heatmap_bygrade <- function(id, plot_height, plot_width) { with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") + with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") moduleServer(id, function(input, output, session) { - teal.code::init_chunks() - decorate_output <- srv_g_decorate(id = NULL, plt = plt, plot_height = plot_height, plot_width = plot_width) # nolint + decorate_output <- srv_g_decorate(id = NULL, plt = plot_r, plot_height = plot_height, plot_width = plot_width) # nolint font_size <- decorate_output$font_size pws <- decorate_output$pws @@ -322,9 +323,7 @@ srv_g_heatmap_bygrade <- function(id, }) observeEvent(input$plot_cm, { - ADCM <- datasets$get_data(cm_dataname, filtered = TRUE) # nolint - ADCM_label <- formatters::var_labels(datasets$get_data(cm_dataname, filtered = FALSE), fill = FALSE) # nolint - formatters::var_labels(ADCM) <- ADCM_label + ADCM <- data[[cm_dataname]]() # nolint choices <- levels(ADCM[[input$conmed_var]]) updateSelectInput( @@ -335,27 +334,18 @@ srv_g_heatmap_bygrade <- function(id, ) }) - plt <- reactive({ + output_q <- reactive({ validate(need(input$id_var, "Please select a ID variable.")) validate(need(input$visit_var, "Please select a visit variable.")) validate(need(input$ongo_var, "Please select a Study Ongoing Status variable.")) validate(need(input$heat_var, "Please select a heat variable.")) validate(need(length(input$anno_var) <= 2, "Please include no more than 2 annotation variables")) - ADSL <- datasets$get_data(sl_dataname, filtered = TRUE) # nolint - ADEX <- datasets$get_data(ex_dataname, filtered = TRUE) # nolint - ADAE <- datasets$get_data(ae_dataname, filtered = TRUE) # nolint - - # assign labels back to the data - formatters::var_labels(ADSL) <- - formatters::var_labels(datasets$get_data(sl_dataname, filtered = FALSE), fill = FALSE) - formatters::var_labels(ADEX) <- - formatters::var_labels(datasets$get_data(ex_dataname, filtered = FALSE), fill = FALSE) - formatters::var_labels(ADAE) <- - formatters::var_labels(datasets$get_data(ae_dataname, filtered = FALSE), fill = FALSE) + ADSL <- data[[sl_dataname]]() # nolint + ADEX <- data[[ex_dataname]]() # nolint + ADAE <- data[[ae_dataname]]() # nolint validate(need(nrow(ADSL) > 0, "Please select at least one subject")) - validate(need( input$ongo_var %in% names(ADEX), paste("Study Ongoing Status must be a variable in", ex_dataname, sep = " ") @@ -377,28 +367,29 @@ srv_g_heatmap_bygrade <- function(id, )) if (input$plot_cm) { - ADCM <- datasets$get_data(cm_dataname, filtered = TRUE) # nolint - ADCM_label <- formatters::var_labels(datasets$get_data(cm_dataname, filtered = FALSE), fill = FALSE) # nolint - formatters::var_labels(ADCM) <- ADCM_label + ADCM <- data[[cm_dataname]]() # nolint validate( need( input$conmed_var %in% names(ADCM), paste("Please select a Conmed Variable in", cm_dataname, sep = " ") ) ) + validate(need( + is.factor(ADCM[[input$conmed_var]]), + "Conmed Variable should be a factor" + )) validate(need( all(input$conmed_level %in% levels(ADCM[[input$conmed_var]])), "Updating Conmed Levels" )) } - teal.code::chunks_reset(envir = environment()) - - if (input$plot_cm) { + q1 <- if (input$plot_cm) { validate(need(!is.na(input$conmed_var), "Please select a conmed variable.")) - teal.code::chunks_push( - id = "conmed_data call", - expression = bquote({ + teal.code::eval_code( + teal.code::new_quosure(data), + name = "conmed_data call", + code = bquote({ conmed_data <- ADCM %>% filter(!!sym(.(input$conmed_var)) %in% .(input$conmed_level)) conmed_var <- .(input$conmed_var) @@ -409,28 +400,24 @@ srv_g_heatmap_bygrade <- function(id, }) ) } else { - teal.code::chunks_push( - id = "conmed_data call", - expression = bquote({ - conmed_data <- conmed_var <- NULL - }) + teal.code::eval_code( + teal.code::new_quosure(data), + name = "conmed_data call", + code = quote(conmed_data <- conmed_var <- NULL) ) } - teal.code::chunks_safe_eval() validate( need(length(input$conmed_level) <= 3, "Please select no more than 3 conmed levels") ) - teal.code::chunks_push( - id = "g_heat_bygrade call", - expression = bquote({ - exp_data <- ADEX %>% - filter(PARCAT1 == "INDIVIDUAL") - - osprey::g_heat_bygrade( + q2 <- teal.code::eval_code( + q1, + name = "g_heat_bygrade call", + code = bquote({ + plot <- osprey::g_heat_bygrade( id_var = .(input$id_var), - exp_data = exp_data, + exp_data = ADEX %>% filter(PARCAT1 == "INDIVIDUAL"), visit_var = .(input$visit_var), ongo_var = .(input$ongo_var), anno_data = ADSL[c(.(input$anno_var), .(input$id_var))], @@ -442,16 +429,15 @@ srv_g_heatmap_bygrade <- function(id, ) }) ) - - teal.code::chunks_safe_eval() + teal.code::eval_code(q2, quote(plot)) }) + plot_r <- reactive(output_q()[["plot"]]) - get_rcode_srv( + teal.widgets::verbatim_popup_srv( id = "rcode", - datasets = datasets, - modal_title = paste("R code for", label), - datanames = datasets$datanames() + title = paste("R code for", label), + verbatim_content = reactive(teal.code::get_code(output_q())) ) ### REPORTER @@ -460,19 +446,14 @@ srv_g_heatmap_bygrade <- function(id, card <- teal.reporter::TealReportCard$new() card$set_name("Heatmap by Grade") card$append_text("Heatmap by Grade", "header2") - card$append_fs(datasets$get_filter_state()) + if (with_filter) card$append_fs(filter_panel_api$get_filter_state()) card$append_text("Plot", "header3") - card$append_plot(plt(), dim = pws$dim()) + card$append_plot(plot_r(), dim = pws$dim()) if (!comment == "") { card$append_text("Comment", "header3") card$append_text(comment) } - card$append_src(paste(get_rcode( - chunks = teal.code::get_chunks_object(parent_idx = 2L), - datasets = datasets, - title = "", - description = "" - ), collapse = "\n")) + card$append_src(paste(teal.code::get_code(output_q()), collapse = "\n")) card } teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun) diff --git a/R/tm_g_patient_profile.R b/R/tm_g_patient_profile.R index d575acf0..f41cae13 100644 --- a/R/tm_g_patient_profile.R +++ b/R/tm_g_patient_profile.R @@ -392,7 +392,7 @@ ui_g_patient_profile <- function(id, ...) { value = a$x_limit ) ), - forms = get_rcode_ui(ns("rcode")), + forms = teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code"), pre_output = a$pre_output, post_output = a$post_output ) @@ -400,7 +400,8 @@ ui_g_patient_profile <- function(id, ...) { } srv_g_patient_profile <- function(id, - datasets, + data, + filter_panel_api, reporter, sl_dataname, ex_dataname, @@ -413,11 +414,9 @@ srv_g_patient_profile <- function(id, plot_height, plot_width) { with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") + with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelApi") moduleServer(id, function(input, output, session) { - # initialize chunks - teal.code::init_chunks() - # only show the check box when domain data is available observeEvent(ae_dataname, { if (!is.na(ae_dataname)) { @@ -481,7 +480,7 @@ srv_g_patient_profile <- function(id, observeEvent(input$select_lb, { req(input$select_lb == TRUE && !is.null(input$lb_var)) - ADLB <- datasets$get_data(lb_dataname, filtered = TRUE) # nolint + ADLB <- data[[lb_dataname]]() # nolint choices <- unique(ADLB[[input$lb_var]]) choices_selected <- if (length(choices) > 5) choices[1:5] else choices @@ -494,7 +493,7 @@ srv_g_patient_profile <- function(id, }) # render plot - plot_r <- reactive({ + output_q <- reactive({ # get inputs --- patient_id <- input$patient_id # nolint sl_start_date <- input$sl_start_date # nolint @@ -546,13 +545,13 @@ srv_g_patient_profile <- function(id, )) # get ADSL dataset --- - ADSL <- datasets$get_data(sl_dataname, filtered = TRUE) # nolint + ADSL <- data[[sl_dataname]]() # nolint if (!is.null(input$select_ex)) { if (input$select_ex == FALSE | is.na(ex_dataname)) { ADEX <- NULL # nolint } else { - ADEX <- datasets$get_data(ex_dataname, filtered = TRUE) # nolint + ADEX <- data[[ex_dataname]]() # nolint validate_has_variable(ADEX, adex_vars) } } else { @@ -563,11 +562,7 @@ srv_g_patient_profile <- function(id, if (input$select_ae == FALSE | is.na(ae_dataname)) { ADAE <- NULL # nolint } else { - ADAE <- datasets$get_data(ae_dataname, filtered = TRUE) # nolint - formatters::var_labels(ADAE) <- formatters::var_labels( - datasets$get_data(ae_dataname, filtered = FALSE), - fill = FALSE - ) + ADAE <- data[[ae_dataname]]() # nolint validate_has_variable(ADAE, adae_vars) } } else { @@ -579,7 +574,7 @@ srv_g_patient_profile <- function(id, if (input$select_rs == FALSE | is.na(rs_dataname)) { ADRS <- NULL # nolint } else { - ADRS <- datasets$get_data(rs_dataname, filtered = TRUE) # nolint + ADRS <- data[[rs_dataname]]() # nolint validate_has_variable(ADRS, adrs_vars) } } else { @@ -590,7 +585,7 @@ srv_g_patient_profile <- function(id, if (input$select_cm == FALSE | is.na(cm_dataname)) { ADCMD <- NULL # nolint } else { - ADCM <- datasets$get_data(cm_dataname, filtered = TRUE) # nolint + ADCM <- data[[cm_dataname]]() # nolint validate_has_variable(ADCM, adcm_vars) } } else { @@ -601,7 +596,7 @@ srv_g_patient_profile <- function(id, if (input$select_lb == FALSE | is.na(lb_dataname)) { ADLB <- NULL # nolint } else { - ADLB <- datasets$get_data(lb_dataname, filtered = TRUE) # nolint + ADLB <- data[[lb_dataname]]() # nolint validate_has_variable(ADLB, adlb_vars) } } else { @@ -646,21 +641,14 @@ srv_g_patient_profile <- function(id, empty_ex <- FALSE empty_lb <- FALSE - # restart chunks & include current environment --- - teal.code::chunks_reset(envir = environment()) - - teal.code::chunks_push( - id = "ADSL call", - expression = bquote({ - ADSL <- ADSL %>% # nolint - group_by(.data$USUBJID) - ADSL$max_date <- pmax( - as.Date(ADSL$LSTALVDT), - as.Date(ADSL$DTHDT), - na.rm = TRUE - ) + q1 <- teal.code::eval_code( + teal.code::new_quosure(data), + name = "ADSL call", + code = bquote({ ADSL <- ADSL %>% # nolint + group_by(.data$USUBJID) %>% mutate( + max_date = pmax(as.Date(LSTALVDT), as.Date(DTHDT), na.rm = TRUE), max_day = as.numeric( as.Date(.data$max_date) - as.Date( eval(parse(text = .(sl_start_date), keep.source = FALSE)) @@ -672,15 +660,12 @@ srv_g_patient_profile <- function(id, }) ) - teal.code::chunks_push_new_line() - teal.code::chunks_safe_eval() + q2 <- teal.code::eval_code(q1, "") # ADSL with single subject - ADSL <- teal.code::chunks_get_var("ADSL") # nolint - validate( need( - nrow(ADSL) >= 1, + nrow(q1[["ADSL"]]) >= 1, paste( "Subject", patient_id, @@ -690,24 +675,26 @@ srv_g_patient_profile <- function(id, ) # name for ae_line_col - if (!is.null(ae_line_col_var) && is.data.frame(ADAE)) { - teal.code::chunks_push( - id = "ae_line_col_name call", - expression = + q3 <- if (!is.null(ae_line_col_var) && is.data.frame(ADAE)) { + teal.code::eval_code( + q2, + name = "ae_line_col_name call", + code = bquote(ae_line_col_name <- formatters::var_labels(ADAE, fill = FALSE)[.(ae_line_col_var)]) ) } else { - teal.code::chunks_push(id = "ae_line_col_name call", expression = quote(ae_line_col_name <- NULL)) + teal.code::eval_code(q2, name = "ae_line_col_name call", code = quote(ae_line_col_name <- NULL)) } - if (select_plot["ae"]) { + q4 <- if (select_plot["ae"]) { validate( need(!is.null(input$ae_var), "Please select an adverse event variable.") ) - if (ADSL$USUBJID %in% ADAE$USUBJID) { - teal.code::chunks_push( - id = "ADAE call", - expression = bquote({ + if (all(ADAE$USUBJID %in% ADSL$USUBJID)) { + qq <- teal.code::eval_code( + q3, + name = "ADAE call", + code = bquote({ # ADAE ADAE <- ADAE[, .(adae_vars)] # nolint @@ -745,62 +732,61 @@ srv_g_patient_profile <- function(id, as.character(eval(parse(text = .(sl_start_date), keep.source = FALSE))), 1, 10 )))) %>% select(c(.(adae_vars), ASTDY, AENDY)) - formatters::var_labels(ADAE)[.(ae_line_col_var)] <- + formatters::var_labels(ADAE)[.(ae_line_col_var)] <- # nolint formatters::var_labels(ADAE, fill = FALSE)[.(ae_line_col_var)] }) - ) - teal.code::chunks_safe_eval() - - teal.code::chunks_push( - id = "ae call", - expression = call( - "<-", - as.name("ae"), - call( - "list", - data = bquote(data.frame(ADAE)), - var = bquote(as.vector(ADAE[, .(ae_var)])), - line_col = if (!is.null(ae_line_col_var)) { - bquote(as.vector(ADAE[, .(ae_line_col_var)])) - } else { - NULL - }, - line_col_legend = if (!is.null(ae_line_col_var)) { - quote(ae_line_col_name) - } else { - NULL - }, - line_col_opt = if (is.null(ae_line_col_var)) { - NULL - } else { - bquote(.(ae_line_col_opt)) - } + ) %>% + teal.code::eval_code( + name = "ae call", + code = call( + "<-", + as.name("ae"), + call( + "list", + data = bquote(data.frame(ADAE)), + var = bquote(as.vector(ADAE[, .(ae_var)])), + line_col = if (!is.null(ae_line_col_var)) { + bquote(as.vector(ADAE[, .(ae_line_col_var)])) + } else { + NULL + }, + line_col_legend = if (!is.null(ae_line_col_var)) { + quote(ae_line_col_name) + } else { + NULL + }, + line_col_opt = if (is.null(ae_line_col_var)) { + NULL + } else { + bquote(.(ae_line_col_opt)) + } + ) ) ) - ) - ADAE <- teal.code::chunks_get_var("ADAE") # nolint + ADAE <- qq[["ADAE"]] # nolint if (is.null(ADAE) | nrow(ADAE) == 0) { empty_ae <- TRUE } + qq } else { empty_ae <- TRUE - teal.code::chunks_push(id = "ae call", expression = bquote(ae <- NULL)) + teal.code::eval_code(q3, name = "ae call", code = bquote(ae <- NULL)) } } else { - teal.code::chunks_push(id = "ae call", expression = bquote(ae <- NULL)) + teal.code::eval_code(q3, name = "ae call", code = bquote(ae <- NULL)) } - teal.code::chunks_push_new_line() - teal.code::chunks_safe_eval() + q5 <- teal.code::eval_code(q4, "") - if (select_plot["rs"]) { + q6 <- if (select_plot["rs"]) { validate( need(!is.null(rs_var), "Please select a tumor response variable.") ) - if (ADSL$USUBJID %in% ADRS$USUBJID) { - teal.code::chunks_push( - id = "ADRS and rs call", - expression = bquote({ + if (all(ADRS$USUBJID %in% ADSL$USUBJID)) { + qq <- teal.code::eval_code( + q5, + name = "ADRS and rs call", + code = bquote({ ADRS <- ADRS[, .(adrs_vars)] # nolint ADRS <- ADSL %>% # nolint left_join(ADRS, by = c("STUDYID", "USUBJID")) %>% # nolint @@ -825,29 +811,30 @@ srv_g_patient_profile <- function(id, rs <- list(data = data.frame(ADRS), var = as.vector(ADRS[, .(rs_var)])) }) ) - teal.code::chunks_safe_eval() - ADRS <- teal.code::chunks_get_var("ADRS") # nolint + ADRS <- qq[["ADRS"]] # nolint if (is.null(ADRS) || nrow(ADRS) == 0) { empty_rs <- TRUE } + qq } else { empty_rs <- TRUE - teal.code::chunks_push(id = "rs call", expression = bquote(rs <- NULL)) + teal.code::eval_code(q5, id = "rs call", expression = bquote(rs <- NULL)) } } else { - teal.code::chunks_push(id = "rs call", expression = bquote(rs <- NULL)) + teal.code::eval_code(q5, name = "rs call", code = bquote(rs <- NULL)) } - teal.code::chunks_push_new_line() + q7 <- teal.code::eval_code(q6, "") - if (select_plot["cm"]) { + q8 <- if (select_plot["cm"]) { validate( need(!is.null(cm_var), "Please select a concomitant medication variable.") ) - if (ADSL$USUBJID %in% ADCM$USUBJID) { - teal.code::chunks_push( - id = "ADCM and cm call", - expression = bquote({ + if (all(ADCM$USUBJID %in% ADSL$USUBJID)) { + qq <- teal.code::eval_code( + q7, + name = "ADCM and cm call", + code = bquote({ # ADCM ADCM <- ADCM[, .(adcm_vars)] # nolint ADCM <- ADSL %>% # nolint @@ -879,29 +866,31 @@ srv_g_patient_profile <- function(id, cm <- list(data = data.frame(ADCM), var = as.vector(ADCM[, .(cm_var)])) }) ) - teal.code::chunks_safe_eval() - ADCM <- teal.code::chunks_get_var("ADCM") # nolint + + ADCM <- qq[["ADCM"]] # nolint if (is.null(ADCM) | nrow(ADCM) == 0) { empty_cm <- TRUE } + qq } else { empty_cm <- TRUE - teal.code::chunks_push(id = "cm call", expression = bquote(cm <- NULL)) + teal.code::eval_code(q7, name = "cm call", code = quote(cm <- NULL)) } } else { - teal.code::chunks_push(id = "cm call", expression = bquote(cm <- NULL)) + teal.code::eval_code(q7, name = "cm call", code = bquote(cm <- NULL)) } - teal.code::chunks_push_new_line() + q9 <- teal.code::eval_code(q8, "") - if (select_plot["ex"]) { + q10 <- if (select_plot["ex"]) { validate( need(!is.null(ex_var), "Please select an exposure variable.") ) - if (ADSL$USUBJID %in% ADEX$USUBJID) { - teal.code::chunks_push( - id = "ADEX and ex call", - expression = bquote({ + if (all(ADEX$USUBJID %in% ADSL$USUBJID)) { + qq <- teal.code::eval_code( + q9, + name = "ADEX and ex call", + code = bquote({ # ADEX ADEX <- ADEX[, .(adex_vars)] # nolint ADEX <- ADSL %>% # nolint @@ -939,30 +928,31 @@ srv_g_patient_profile <- function(id, ex <- list(data = data.frame(ADEX), var = as.vector(ADEX[, .(ex_var)])) }) ) - teal.code::chunks_safe_eval() - ADEX <- teal.code::chunks_get_var("ADEX") # nolint + ADEX <- qq[["ADEX"]] # nolint if (is.null(ADEX) | nrow(ADEX) == 0) { empty_ex <- TRUE } + qq } else { empty_ex <- TRUE - teal.code::chunks_push(id = "ex call", expression = bquote(ex <- NULL)) + teal.code::eval_code(q9, name = "ex call", code = quote(ex <- NULL)) } } else { - teal.code::chunks_push(id = "ex call", expression = bquote(ex <- NULL)) + teal.code::eval_code(q9, name = "ex call", code = quote(ex <- NULL)) } - teal.code::chunks_push_new_line() + q11 <- teal.code::eval_code(q10, "") - if (select_plot["lb"]) { + q12 <- if (select_plot["lb"]) { validate( need(!is.null(lb_var), "Please select a lab variable.") ) - if (ADSL$USUBJID %in% ADLB$USUBJID) { - req(lb_var_show != lb_var) - teal.code::chunks_push( - id = "ADLB and lb call", - expression = bquote({ + if (all(ADLB$USUBJID %in% ADSL$USUBJID)) { + validate(need(lb_var_show != lb_var, "Lab variable and lab values must differ")) + qq <- teal.code::eval_code( + q11, + name = "ADLB and lb call", + code = bquote({ ADLB <- ADLB[, .(adlb_vars)] # nolint ADLB <- ADSL %>% # nolint left_join(ADLB, by = c("STUDYID", "USUBJID")) %>% @@ -994,21 +984,22 @@ srv_g_patient_profile <- function(id, lb <- list(data = data.frame(ADLB), var = as.vector(ADLB[, .(lb_var)])) }) ) - teal.code::chunks_safe_eval() - ADLB <- teal.code::chunks_get_var("ADLB") # nolint + + ADLB <- qq[["ADLB"]] # nolint if (is.null(ADLB) | nrow(ADLB) == 0) { empty_lb <- TRUE } + qq } else { empty_lb <- TRUE - teal.code::chunks_push(id = "lb call", expression = bquote(lb <- NULL)) + teal.code::eval_code(q11, name = "lb call", code = quote(lb <- NULL)) } } else { - teal.code::chunks_push(id = "lb call", expression = bquote(lb <- NULL)) + teal.code::eval_code(q11, name = "lb call", code = bquote(lb <- NULL)) } - teal.code::chunks_push_new_line() + q13 <- teal.code::eval_code(q12, "") # Check that at least 1 dataset is selected @@ -1039,12 +1030,12 @@ srv_g_patient_profile <- function(id, # Convert x_limit to numeric vector if (!is.null(x_limit) || x_limit != "") { - teal.code::chunks_push( - id = "x_limit call", - expression = bquote(x_limit <- as.numeric(unlist(strsplit(.(x_limit), ",")))) + q12 <- teal.code::eval_code( + q12, + name = "x_limit call", + code = bquote(x_limit <- as.numeric(unlist(strsplit(.(x_limit), ",")))) ) - teal.code::chunks_safe_eval() - x_limit <- teal.code::chunks_get_var("x_limit") + x_limit <- q12[["x_limit"]] } validate(need( @@ -1056,12 +1047,13 @@ srv_g_patient_profile <- function(id, "The lower limit for study days range should come first." )) - teal.code::chunks_push_new_line() + q13 <- teal.code::eval_code(q12, "") - teal.code::chunks_push( - id = "g_patient_profile call", - expression = bquote({ - osprey::g_patient_profile( + q14 <- teal.code::eval_code( + q13, + name = "g_patient_profile call", + code = bquote({ + plot <- osprey::g_patient_profile( ex = ex, ae = ae, rs = rs, @@ -1072,11 +1064,13 @@ srv_g_patient_profile <- function(id, xlab = "Study Day", title = paste("Patient Profile: ", .(patient_id)) ) + plot }) ) - teal.code::chunks_safe_eval() }) + plot_r <- reactive(output_q()[["plot"]]) + pws <- teal.widgets::plot_with_settings_srv( id = "patientprofileplot", plot_r = plot_r, @@ -1084,11 +1078,10 @@ srv_g_patient_profile <- function(id, width = plot_width ) - get_rcode_srv( + teal.widgets::verbatim_popup_srv( id = "rcode", - datasets = datasets, - modal_title = paste("R code for", label), - datanames = datasets$datanames() + title = paste("R code for", label), + verbatim_content = reactive(teal.code::get_code(output_q())) ) ### REPORTER @@ -1097,19 +1090,14 @@ srv_g_patient_profile <- function(id, card <- teal.reporter::TealReportCard$new() card$set_name("Patient Profile") card$append_text("Patient Profile", "header2") - card$append_fs(datasets$get_filter_state()) + if (with_filter) card$append_fs(filter_panel_api$get_filter_state()) card$append_text("Plot", "header3") card$append_plot(plot_r(), dim = pws$dim()) if (!comment == "") { card$append_text("Comment", "header3") card$append_text(comment) } - card$append_src(paste(get_rcode( - chunks = teal.code::get_chunks_object(parent_idx = 2L), - datasets = datasets, - title = "", - description = "" - ), collapse = "\n")) + card$append_src(paste(teal.code::get_code(output_q()), collapse = "\n")) card } teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun) diff --git a/R/tm_g_spiderplot.R b/R/tm_g_spiderplot.R index 3e4f4916..daeb7f28 100644 --- a/R/tm_g_spiderplot.R +++ b/R/tm_g_spiderplot.R @@ -104,7 +104,7 @@ tm_g_spiderplot <- function(label, args <- as.list(environment()) module( label = label, - filters = dataname, + filters = c("ADSL", dataname), server = srv_g_spider, server_args = list(dataname = dataname, label = label, plot_height = plot_height, plot_width = plot_width), ui = ui_g_spider, @@ -209,40 +209,25 @@ ui_g_spider <- function(id, ...) { value = a$href_line ) ), - forms = get_rcode_ui(ns("rcode")), + forms = teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code"), pre_output = a$pre_output, post_output = a$post_output ) ) } -srv_g_spider <- function(id, datasets, reporter, dataname, label, plot_height, plot_width) { +srv_g_spider <- function(id, data, filter_panel_api, reporter, dataname, label, plot_height, plot_width) { with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") + with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") moduleServer(id, function(input, output, session) { vals <- reactiveValues(spiderplot = NULL) # nolint - # initialize chunks - teal.code::init_chunks() - # render plot - plot_r <- reactive({ - + output_q <- reactive({ # get datasets --- - - ADSL <- datasets$get_data("ADSL", filtered = TRUE) # nolint - ADTR <- datasets$get_data(dataname, filtered = TRUE) # nolint - - adtr_name <- dataname - assign(adtr_name, ADTR) # so that we can refer to the 'correct' data name - - - # restart chunks & include current environment --- - - teal.code::chunks_reset(envir = environment()) - - - # get inputs --- + ADSL <- data[["ADSL"]]() # nolint + ADTR <- data[[dataname]]() # nolint paramcd <- input$paramcd # nolint x_var <- input$x_var @@ -274,18 +259,19 @@ srv_g_spider <- function(id, datasets, reporter, dataname, label, plot_height, p adsl_vars <- unique(c("USUBJID", "STUDYID", varlist_from_adsl)) # nolint adtr_vars <- unique(c("USUBJID", "STUDYID", "PARAMCD", x_var, y_var, varlist_from_anl)) - # preprocessing of datasets to chunks --- + # preprocessing of datasets to quosure --- # vars definition adtr_vars <- adtr_vars[adtr_vars != "None"] adtr_vars <- adtr_vars[!is.null(adtr_vars)] # merge - teal.code::chunks_push( - id = "ANL call", - expression = bquote({ + q1 <- teal.code::eval_code( + teal.code::new_quosure(data), + name = "ANL call", + code = bquote({ ADSL <- ADSL[, .(adsl_vars)] %>% as.data.frame() # nolint - ADTR <- .(as.name(adtr_name))[, .(adtr_vars)] %>% as.data.frame() # nolint + ADTR <- .(as.name(dataname))[, .(adtr_vars)] %>% as.data.frame() # nolint ANL <- merge(ADSL, ADTR, by = c("USUBJID", "STUDYID")) # nolint ANL <- ANL %>% # nolint @@ -295,12 +281,13 @@ srv_g_spider <- function(id, datasets, reporter, dataname, label, plot_height, p }) ) - teal.code::chunks_push_new_line() + q2 <- teal.code::eval_code(q1, "") # format and filter - teal.code::chunks_push( - id = "ANL_f call", - expression = bquote({ + q3 <- teal.code::eval_code( + q2, + name = "ANL_f call", + code = bquote({ ANL$USUBJID <- unlist(lapply(strsplit(ANL$USUBJID, "-", fixed = TRUE), tail, 1)) # nolint ANL_f <- ANL %>% # nolint filter(PARAMCD == .(paramcd)) %>% @@ -308,10 +295,7 @@ srv_g_spider <- function(id, datasets, reporter, dataname, label, plot_height, p }) ) - teal.code::chunks_push_new_line() - - # check - teal.code::chunks_safe_eval() + q4 <- teal.code::eval_code(q3, "") # reference lines preprocessing - vertical vref_line <- as_numeric_from_comma_sep_str(vref_line) @@ -328,26 +312,25 @@ srv_g_spider <- function(id, datasets, reporter, dataname, label, plot_height, p )) # label - if (anno_txt_var) { - teal.code::chunks_push( - id = "lbl call", - expression = quote(lbl <- list(txt_ann = as.factor(ANL_f$USUBJID))) + q5 <- if (anno_txt_var) { + teal.code::eval_code( + q4, + name = "lbl call", + code = quote(lbl <- list(txt_ann = as.factor(ANL_f$USUBJID))) ) } else { - teal.code::chunks_push(id = "lbl call", expression = quote(lbl <- NULL)) + teal.code::eval_code(q4, name = "lbl call", code = quote(lbl <- NULL)) } - teal.code::chunks_push_new_line() + q6 <- teal.code::eval_code(q5, "") - # check - teal.code::chunks_safe_eval() + # plot code to quosure --- - # plot code to chunks --- - - teal.code::chunks_push( - id = "g_spiderplot call", - expression = bquote({ - osprey::g_spiderplot( + q7 <- teal.code::eval_code( + q6, + name = "g_spiderplot call", + code = bquote({ + plot <- osprey::g_spiderplot( marker_x = ANL_f[, .(x_var)], marker_id = ANL_f$USUBJID, marker_y = ANL_f[, .(y_var)], @@ -387,12 +370,14 @@ srv_g_spider <- function(id, datasets, reporter, dataname, label, plot_height, p }, show_legend = .(legend_on) ) + + plot }) ) - - teal.code::chunks_safe_eval() }) + plot_r <- reactive(output_q()[["plot"]]) + pws <- teal.widgets::plot_with_settings_srv( id = "spiderplot", plot_r = plot_r, @@ -400,16 +385,10 @@ srv_g_spider <- function(id, datasets, reporter, dataname, label, plot_height, p width = plot_width ) - get_rcode_srv( + teal.widgets::verbatim_popup_srv( id = "rcode", - datasets = datasets, - modal_title = paste("R code for", label), - datanames = unique(c( - dataname, - vapply(X = dataname, FUN.VALUE = character(1), function(x) { - if (inherits(datasets, "CDISCFilteredData")) datasets$get_parentname(x) - }) - )) + title = paste("R code for", label), + verbatim_content = reactive(teal.code::get_code(output_q())) ) ### REPORTER @@ -418,7 +397,7 @@ srv_g_spider <- function(id, datasets, reporter, dataname, label, plot_height, p card <- teal.reporter::TealReportCard$new() card$set_name("Spider Plot") card$append_text("Spider Plot", "header2") - card$append_fs(datasets$get_filter_state()) + if (with_filter) card$append_fs(filter_panel_api$get_filter_state()) if (!is.null(input$paramcd) || !is.null(input$xfacet_var) || !is.null(input$yfacet_var)) { card$append_text("Selected Options", "header3") } @@ -437,12 +416,7 @@ srv_g_spider <- function(id, datasets, reporter, dataname, label, plot_height, p card$append_text("Comment", "header3") card$append_text(comment) } - card$append_src(paste(get_rcode( - chunks = teal.code::get_chunks_object(parent_idx = 2L), - datasets = datasets, - title = "", - description = "" - ), collapse = "\n")) + card$append_src(paste(teal.code::get_code(output_q()), collapse = "\n")) card } teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun) diff --git a/R/tm_g_swimlane.R b/R/tm_g_swimlane.R index 9d2508b7..63424216 100644 --- a/R/tm_g_swimlane.R +++ b/R/tm_g_swimlane.R @@ -158,7 +158,7 @@ tm_g_swimlane <- function(label, plot_width = plot_width, x_label = x_label ), - filters = dataname + filters = c("ADSL", dataname) ) } @@ -243,7 +243,7 @@ ui_g_swimlane <- function(id, ...) { value = paste(a$vref_line, collapse = ", ") ) ), - forms = get_rcode_ui(ns("rcode")), + forms = teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code"), pre_output = a$pre_output, post_output = a$post_output ) @@ -251,7 +251,8 @@ ui_g_swimlane <- function(id, ...) { } srv_g_swimlane <- function(id, - datasets, + data, + filter_panel_api, reporter, dataname, marker_pos_var, @@ -264,11 +265,9 @@ srv_g_swimlane <- function(id, plot_width, x_label) { with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") + with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") moduleServer(id, function(input, output, session) { - # use teal.code code chunks - teal.code::init_chunks() - # 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)) { @@ -298,26 +297,20 @@ srv_g_swimlane <- function(id, }) # create plot - plot_r <- reactive({ + output_q <- reactive({ # DATA GETTERS - validate(need("ADSL" %in% datasets$datanames(), "ADSL needs to be defined in datasets")) + validate(need("ADSL" %in% names(data), "'ADSL' not included in data")) validate(need( - (length(datasets$datanames()) == 1 && dataname == "ADSL") || - (length(datasets$datanames()) >= 2 && dataname != "ADSL"), + (length(data) == 1 && dataname == "ADSL") || + (length(data) >= 2 && dataname != "ADSL"), "Please either add just 'ADSL' as dataname when just ADSL is available In case 2 datasets are available ADSL is not supposed to be the dataname." )) validate(need(input$bar_var, "Please select a variable to map to the bar length.")) - ADSL <- datasets$get_data("ADSL", filtered = TRUE) # nolint - if (dataname != "ADSL") { - ANL <- datasets$get_data(dataname, filtered = TRUE) # nolint - anl_name <- dataname - assign(anl_name, ANL) - } + ADSL <- data[["ADSL"]]() # nolint - # Restart the chunks for showing code - teal.code::chunks_reset(envir = environment()) + q1 <- teal.code::new_quosure(data) # VARIABLE GETTERS # lookup bar variables @@ -350,12 +343,13 @@ srv_g_swimlane <- function(id, validate_has_data(ADSL, min_nrow = 3) validate_has_variable(ADSL, c("USUBJID", "STUDYID", bar_var, bar_color_var, sort_var, anno_txt_var)) } else { + anl <- data[[dataname]]() validate_has_data(ADSL, min_nrow = 3) validate_has_variable(ADSL, c("USUBJID", "STUDYID", bar_var, bar_color_var, sort_var, anno_txt_var)) - validate_has_data(ANL, min_nrow = 3) + validate_has_data(anl, min_nrow = 3) validate_has_variable( - ANL, + anl, unique(c("USUBJID", "STUDYID", marker_pos_var, marker_shape_var, marker_color_var)) ) } @@ -372,11 +366,12 @@ srv_g_swimlane <- function(id, )) } - # WRITE VARIABLES TO CHUNKS + # WRITE VARIABLES TO QUOSURE - teal.code::chunks_push( - id = "variables call", - expression = bquote({ + q2 <- teal.code::eval_code( + q1, + name = "variables call", + code = bquote({ bar_var <- .(bar_var) bar_color_var <- .(bar_color_var) sort_var <- .(sort_var) @@ -386,14 +381,14 @@ srv_g_swimlane <- function(id, anno_txt_var <- .(anno_txt_var) }) ) - teal.code::chunks_push_new_line() - - # WRITE DATA SELECTION TO CHUNKS - - if (dataname == "ADSL") { - teal.code::chunks_push( - id = "ADSL call", - expression = bquote({ + q3 <- teal.code::eval_code(q2, "") + + # WRITE DATA SELECTION TO QUOSURE + q4 <- if (dataname == "ADSL") { + teal.code::eval_code( + q3, + name = "ADSL call", + code = bquote({ ADSL_p <- ADSL # nolint ADSL <- ADSL_p[, .(adsl_vars)] # nolint # only take last part of USUBJID @@ -401,12 +396,12 @@ srv_g_swimlane <- function(id, }) ) } else { - anl_name <- dataname - teal.code::chunks_push( - id = "ADSL and ANL call", - expression = bquote({ + teal.code::eval_code( + q3, + name = "ADSL and ANL call", + code = bquote({ ADSL_p <- ADSL # nolint - ANL_p <- .(as.name(anl_name)) # nolint + ANL_p <- .(as.name(dataname)) # nolint ADSL <- ADSL_p[, .(adsl_vars)] # nolint ANL <- merge( # nolint @@ -421,14 +416,11 @@ srv_g_swimlane <- function(id, }) ) } - teal.code::chunks_push_new_line() # empty line for pretty code - teal.code::chunks_safe_eval() - + q5 <- teal.code::eval_code(q4, "") # empty line for pretty code - anl <- teal.code::chunks_get_var("ANL") plot_call <- if (dataname == "ADSL") { - bquote({ - osprey::g_swimlane( + bquote( + 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), @@ -445,10 +437,10 @@ srv_g_swimlane <- function(id, xlab = .(x_label), title = "Swimlane Plot" ) - }) + ) } else { - bquote({ - osprey::g_swimlane( + bquote( + plot <- osprey::g_swimlane( bar_id = ADSL[["USUBJID"]], bar_length = ADSL[[bar_var]], sort_by = .(if (length(sort_var) > 0) { @@ -503,13 +495,15 @@ srv_g_swimlane <- function(id, xlab = .(x_label), title = "Swimlane Plot" ) - }) + ) } - teal.code::chunks_push(id = "plot call", expression = plot_call) - teal.code::chunks_safe_eval() + q6 <- teal.code::eval_code(q5, name = "plot call", code = plot_call) + teal.code::eval_code(q6, quote(plot)) }) + 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", @@ -518,16 +512,10 @@ srv_g_swimlane <- function(id, width = plot_width ) - get_rcode_srv( + teal.widgets::verbatim_popup_srv( id = "rcode", - datasets = datasets, - modal_title = paste("R code for", label), - datanames = unique(c( - dataname, - vapply(X = dataname, FUN.VALUE = character(1), function(x) { - if (inherits(datasets, "CDISCFilteredData")) datasets$get_parentname(x) - }) - )) + title = paste("R code for", label), + verbatim_content = reactive(teal.code::get_code(output_q())) ) ### REPORTER @@ -536,7 +524,7 @@ srv_g_swimlane <- function(id, card <- teal.reporter::TealReportCard$new() card$set_name("Swimlane") card$append_text("Swimlane Plot", "header2") - card$append_fs(datasets$get_filter_state()) + if (with_filter) card$append_fs(filter_panel_api$get_filter_state()) if (!is.null(input$sort_var)) { card$append_text("Selected Options", "header3") card$append_text(paste("Sorted by:", input$sort_var)) @@ -547,12 +535,7 @@ srv_g_swimlane <- function(id, card$append_text("Comment", "header3") card$append_text(comment) } - card$append_src(paste(get_rcode( - chunks = teal.code::get_chunks_object(parent_idx = 2L), - datasets = datasets, - title = "", - description = "" - ), collapse = "\n")) + card$append_src(paste(teal.code::get_code(output_q()), collapse = "\n")) card } teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun) diff --git a/R/tm_g_waterfall.R b/R/tm_g_waterfall.R index 48e6b21f..b0b99cd9 100644 --- a/R/tm_g_waterfall.R +++ b/R/tm_g_waterfall.R @@ -265,14 +265,15 @@ ui_g_waterfall <- function(id, ...) { value = a$gap_point_val ) ), - forms = get_rcode_ui(ns("rcode")), + forms = teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code"), pre_output = a$pre_output, post_output = a$post_output ) } srv_g_waterfall <- function(id, - datasets, + data, + filter_panel_api, reporter, dataname_tr, dataname_rs, @@ -281,15 +282,13 @@ srv_g_waterfall <- function(id, plot_height, plot_width) { with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") + with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") moduleServer(id, function(input, output, session) { - # use teal.code code chunks - teal.code::init_chunks() - - plot_r <- reactive({ - adsl <- datasets$get_data("ADSL", filtered = TRUE) - adtr <- datasets$get_data(dataname_tr, filtered = TRUE) - adrs <- datasets$get_data(dataname_rs, filtered = TRUE) + output_q <- reactive({ + adsl <- data[["ADSL"]]() + adtr <- data[[dataname_tr]]() + adrs <- data[[dataname_rs]]() bar_var <- input$bar_var bar_paramcd <- input$bar_paramcd @@ -377,27 +376,16 @@ srv_g_waterfall <- function(id, adrs_vars <- unique(c("USUBJID", "STUDYID", "PARAMCD", "AVALC")) adrs_paramcd <- unique(c(add_label_paramcd_rs, anno_txt_paramcd_rs)) - # write data selection to chunks - adsl_name <- "ADSL" - adtr_name <- dataname_tr - adrs_name <- dataname_rs - - assign(adsl_name, adsl) - assign(adtr_name, adtr) - assign(adrs_name, adrs) - # validate data input validate_has_variable(adsl, adsl_vars) validate_has_variable(adrs, adrs_vars) validate_has_variable(adtr, adtr_vars) - # restart the chunks for showing code - teal.code::chunks_reset(envir = environment()) - - # write variables to chunks - teal.code::chunks_push( - id = "variables call", - expression = bquote({ + # write variables to quosure + q1 <- teal.code::eval_code( + teal.code::new_quosure(data), + name = "variables call", + code = bquote({ bar_var <- .(bar_var) bar_color_var <- .(bar_color_var) sort_var <- .(sort_var) @@ -411,17 +399,18 @@ srv_g_waterfall <- function(id, show_value <- .(show_value) }) ) - teal.code::chunks_push_new_line() + q2 <- teal.code::eval_code(q1, "") # data processing - teal.code::chunks_push( - id = "bar_data call", - expression = bquote({ - adsl <- .(as.name(adsl_name))[, .(adsl_vars)] - adtr <- .(as.name(adtr_name))[, .(adtr_vars)] # nolint - adrs <- .(as.name(adrs_name))[, .(adrs_vars)] # nolint - - bar_tr <- .(as.name(adtr_name)) %>% + q3 <- teal.code::eval_code( + q2, + name = "bar_data call", + code = bquote({ + adsl <- ADSL[, .(adsl_vars)] + adtr <- .(as.name(dataname_tr))[, .(adtr_vars)] # nolint + adrs <- .(as.name(dataname_rs))[, .(adrs_vars)] # nolint + + bar_tr <- .(as.name(dataname_tr)) %>% dplyr::filter(PARAMCD == .(bar_paramcd)) %>% dplyr::select(USUBJID, .(as.name(bar_var))) %>% dplyr::group_by(USUBJID) %>% @@ -429,35 +418,34 @@ srv_g_waterfall <- function(id, bar_data <- adsl %>% dplyr::inner_join(bar_tr, "USUBJID") }) ) - teal.code::chunks_push_new_line() - teal.code::chunks_safe_eval() - bar_data <- teal.code::chunks_get_var("bar_data") # nolint + q4 <- teal.code::eval_code(q3, "") - if (is.null(adrs_paramcd)) { - teal.code::chunks_push( - id = "anl call", - expression = bquote({ + q5 <- if (is.null(adrs_paramcd)) { + teal.code::eval_code( + q4, + name = "anl call", + code = bquote({ anl <- bar_data anl$USUBJID <- unlist(lapply(strsplit(anl$USUBJID, "-", fixed = TRUE), tail, 1)) # nolint }) ) } else { - teal.code::chunks_push( - id = "rs_sub call", - expression = bquote({ - rs_sub <- .(as.name(adrs_name)) %>% + qq1 <- teal.code::eval_code( + q4, + name = "rs_sub call", + code = bquote( + rs_sub <- .(as.name(dataname_rs)) %>% dplyr::filter(PARAMCD %in% .(adrs_paramcd)) - }) + ) ) - teal.code::chunks_push_new_line() - teal.code::chunks_safe_eval() + qq2 <- teal.code::eval_code(qq1, "") - rs_sub <- teal.code::chunks_get_var("rs_sub") - validate_one_row_per_id(rs_sub, key = c("STUDYID", "USUBJID", "PARAMCD")) + validate_one_row_per_id(qq2[["rs_sub"]], key = c("STUDYID", "USUBJID", "PARAMCD")) - teal.code::chunks_push( - id = "anl call", - expression = bquote({ + teal.code::eval_code( + qq2, + name = "anl call", + code = bquote({ rs_label <- rs_sub %>% dplyr::select(USUBJID, PARAMCD, AVALC) %>% tidyr::pivot_wider(names_from = PARAMCD, values_from = AVALC) @@ -466,18 +454,16 @@ srv_g_waterfall <- function(id, }) ) } - teal.code::chunks_push_new_line() - - teal.code::chunks_safe_eval() - + q6 <- teal.code::eval_code(q5, "") - # write plotting code to chunks - anl <- teal.code::chunks_get_var("anl") # nolint + # write plotting code to quosure + anl <- q6[["anl"]] # nolint - teal.code::chunks_push( - id = "g_waterfall call", - expression = bquote({ - osprey::g_waterfall( + q7 <- teal.code::eval_code( + q6, + name = "g_waterfall call", + code = bquote({ + plot <- osprey::g_waterfall( bar_id = anl[["USUBJID"]], bar_height = anl[[bar_var]], sort_by = .(if (length(sort_var) > 0) { @@ -492,7 +478,7 @@ srv_g_waterfall <- function(id, }), 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)) == T) { + } else if (length(bar_color_var) > 0 & all(unique(anl[[bar_color_var]]) %in% names(bar_color_opt))) { bar_color_opt } else { NULL @@ -525,12 +511,13 @@ srv_g_waterfall <- function(id, y_label = "Tumor Burden Change from Baseline", title = "Waterfall Plot" ) + plot }) ) - - teal.code::chunks_safe_eval() }) + 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", @@ -540,11 +527,10 @@ srv_g_waterfall <- function(id, ) # Show R Code - get_rcode_srv( + teal.widgets::verbatim_popup_srv( id = "rcode", - datasets = datasets, - modal_title = paste("R code for", label), - datanames = datasets$datanames() + title = paste("R code for", label), + verbatim_content = reactive(teal.code::get_code(output_q())) ) ### REPORTER @@ -553,7 +539,7 @@ srv_g_waterfall <- function(id, card <- teal.reporter::TealReportCard$new() card$set_name("Waterfall") card$append_text("Waterfall Plot", "header2") - card$append_fs(datasets$get_filter_state()) + if (with_filter) card$append_fs(filter_panel_api$get_filter_state()) card$append_text("Selected Options", "header3") card$append_text(paste0("Tumor Burden Parameter: ", input$bar_paramcd, ".")) if (!is.null(input$sort_var)) { @@ -568,12 +554,7 @@ srv_g_waterfall <- function(id, card$append_text("Comment", "header3") card$append_text(comment) } - card$append_src(paste(get_rcode( - chunks = teal.code::get_chunks_object(parent_idx = 2L), - datasets = datasets, - title = "", - description = "" - ), collapse = "\n")) + card$append_src(paste(teal.code::get_code(output_q()), collapse = "\n")) card } teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun) diff --git a/man/argument_convention.Rd b/man/argument_convention.Rd index 2c44efa1..e78a18e4 100644 --- a/man/argument_convention.Rd +++ b/man/argument_convention.Rd @@ -14,7 +14,7 @@ available in the list passed to the \code{data} argument of \code{\link[teal:ini \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.} +details. Column \code{arm_var} in the \code{dataname} has to be a factor.} \item{paramcd}{(\code{character(1)} or \code{choices_selected})\cr variable value designating the studied parameter. diff --git a/man/tm_g_ae_oview.Rd b/man/tm_g_ae_oview.Rd index 65ad9295..dde59aa4 100644 --- a/man/tm_g_ae_oview.Rd +++ b/man/tm_g_ae_oview.Rd @@ -25,7 +25,7 @@ available in the list passed to the \code{data} argument of \code{\link[teal:ini \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.} +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 diff --git a/man/tm_g_ae_sub.Rd b/man/tm_g_ae_sub.Rd index 04a65f27..b2d7d28f 100644 --- a/man/tm_g_ae_sub.Rd +++ b/man/tm_g_ae_sub.Rd @@ -25,7 +25,7 @@ available in the list passed to the \code{data} argument of \code{\link[teal:ini \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.} +details. Column \code{arm_var} in the \code{dataname} has to be a factor.} \item{group_var}{(\code{choices_selected}) subgroups variables. See \code{\link[teal.transform:choices_selected]{teal.transform::choices_selected()}} for details.} diff --git a/man/tm_g_events_term_id.Rd b/man/tm_g_events_term_id.Rd index 14c367c9..b8703390 100644 --- a/man/tm_g_events_term_id.Rd +++ b/man/tm_g_events_term_id.Rd @@ -28,7 +28,7 @@ and pre-selected option names that can be used to specify the term for events} \item{arm_var}{(\code{choices_selected})\cr object with all available choices and the pre-selected option for variable names that can be used as \code{arm_var}. See \code{\link[teal.transform:choices_selected]{teal.transform::choices_selected()}} for -details.} +details. Column \code{arm_var} in the \code{dataname} has to be a factor.} \item{fontsize}{(\code{numeric(1)} or \code{numeric(3)})\cr Defines initial possible range of font-size. \code{fontsize} is set for