teal.osprey coverage - 0.14%

Files
Source

#' Shared Parameters
#'
#' @description Contains arguments that are shared between multiple functions
#'   in the package to avoid repetition using \code{inheritParams}.
#'
#' @param plot_height optional, (\code{numeric}) a vector of length three with \code{c(value, min, max)}. Specifies
#'   the height of the main plot.
#' @param plot_width optional, (\code{numeric}) a vector of length three with \code{c(value, min, max)}. Specifies
#'   the width of the main plot and renders a slider on the plot to interactively adjust the plot width.
#' @param label (\code{character}) module label in the teal app. Please note that this module is developed based on
#' `ADaM` data structure and `ADaM` variables.
#'
#' @name shared_params
#' @keywords internal
#'
NULL

#' Utility function for quick filter
#' `r lifecycle::badge("stable")`
#'
#'
#' @param filter_opt vector of string names of flag variable to filter (keep Y rows only)
#' @param ANL input dataset
#'
#' @return a filtered dataframe
#'
#' @export
#'
#' @template author_zhanc107
#'
quick_filter <- function(filter_opt, ANL) { # nolint
  for (i in seq_along(filter_opt)) {
    ANL <- ANL[ANL[, filter_opt[i]] == "Y", ] # nolint
  }
  return(ANL)
}

#' Automatically switch variable labels for standard `AE` variables in `AE` osprey functions
#' `r lifecycle::badge("stable")`
#'
#' @param x variable key
#'
#' @export
label_aevar <- function(x) {
  lifecycle::deprecate_soft(
    when = "0.1.15",
    what = "label_aevar()",
    details = "label_aevar is deprecated and will be unexported in the next release."
  )

  # Display full variable labels for standard AE variables
  ae_varlabel <- c(
    AEBODSYS = "MedDRA System Organ Class",
    AESOC = "MedDRA Primary System Organ Class",
    AEHLGT = "MedDRA High Level Group Term",
    AEHLT = "MedDRA High Level Term",
    AELLT = "MedDRA Lowest Level Term",
    AEDECOD = "MedDRA Preferred Term",
    AETERM = "Reported Adverse Event Term",
    AEMODIFY = "Modified Reported Term",
    AETOXGR = "NCI-CTCAE Grade",
    AEITOXGR = "Initial Toxicity Grade"
  )

  which_aevar <- match(x, names(ae_varlabel))
  out_label <- ifelse(is.na(which_aevar), x, ae_varlabel[which_aevar])
  return(out_label)
}

#' retrieve name of ci method
#' @param x ci method to retrieve its name
#' @keywords internal
#'
name_ci <- function(x) {
  names(ci_choices)[which(ci_choices == x)]
}

ci_choices <- setNames(
  c("wald", "waldcc", "ac", "scorecc", "score", "mn", "mee", "blj", "ha"),
  c(
    "Wald", "Corrected Wald", "Agresti-Caffo", "Newcombe",
    "Score", "Miettinen and Nurminen", "Mee",
    "Brown, Li's Jeffreys", "Hauck-Anderson"
  )
)

#' retrieve detailed name of ci method
#' @param x ci method to retrieve its name
name_ci <- function(x = ci_choices) {
  x <- match.arg(x)
  return(paste0(names(x), " (", x, ")"))
}


#' takes input_string, splits by ","  and returns a numeric vector
#' with NAs where the split-strings are not numeric.
#' e.g. as_numeric_from_comma_separated_string("4  ,hello,5,, 3")
#' is c(4, NA, 5, NA, 3).
#' If input argument is NULL or just whitespace then NULL is returned
#' @param input_string string to be split into numeric vector
#' @keywords internal
#'
as_numeric_from_comma_sep_str <- function(input_string) {
  if (!is.null(input_string) && trimws(input_string) != "") {
    ref_line <- unlist(strsplit(trimws(input_string), ","))
    ref_line <- as.numeric(ref_line)
  } else {
    ref_line <- NULL
  }
  return(ref_line)
}

#' Include `CSS` files from `/inst/css/` package directory to application header
#'
#' `system.file` should not be used to access files in other packages, it does
#' not work with `devtools`. Therefore, we redefine this method in each package
#' as needed. Thus, we do not export this method.
#'
#' @param pattern (`character`) pattern of files to be included
#'
#' @return HTML code that includes `CSS` files
#' @keywords internal
include_css_files <- function(pattern = "*") {
  css_files <- list.files(
    system.file("css", package = "teal.osprey", mustWork = TRUE),
    pattern = pattern, full.names = TRUE
  )
  if (length(css_files) == 0) {
    return(NULL)
  }
  return(shiny::singleton(shiny::tags$head(lapply(css_files, shiny::includeCSS))))
}

#' Butterfly plot Teal Module
#'
#' @description
#' `r lifecycle::badge("stable")`
#'
#' Display butterfly plot as a shiny module
#'
#' @inheritParams teal.widgets::standard_layout
#' @inheritParams argument_convention
#' @param filter_var (\code{choices_selected}) variable name of data filter, please see details regarding
#'   expected values, default is \code{NULL}. \code{choices}
#'   vector with \code{filter_var} choices, default is
#'   \code{NULL}
#' @param right_var (\code{choices_selected}) dichotomization variable for right side
#' @param left_var (\code{choices_selected}) dichotomization variable for left side
#' @param category_var (\code{choices_selected}) category (y axis) variable
#' @param color_by_var (\code{choices_selected}) variable defines color blocks within each bar
#' @param count_by_var (\code{choices_selected}) variable defines how x axis is calculated
#' @param facet_var (\code{choices_selected}) variable for row facets
#' @param sort_by_var (\code{choices_selected}) argument for order of class and term elements in table,
#'   default here is "count"
#' @param legend_on (\code{boolean}) value for whether legend is displayed
#'
#' @details \code{filter_var} option is designed to work in conjunction with
#'   filtering function provided by \code{teal} (encoding panel on the right
#'   hand side of the shiny app). It can be used as quick access to predefined
#'   subsets of the domain datasets (not subject-level dataset) to be used for
#'   analysis, denoted by an value of "Y". Each variable within the
#'   \code{filter_var_choices} is expected to contain values of either "Y" or
#'   "N". If multiple variables are selected as \code{filter_var}, only
#'   observations with "Y" value in each and every selected variables will be
#'   used for subsequent analysis. Flag variables (from `ADaM` datasets) can be
#'   used directly as filter.
#'
#' @inherit argument_convention return
#'
#' @export
#'
#' @template author_zhanc107
#' @template author_liaoc10
#'
#' @examples
#'
#' # Example using stream (ADaM) dataset
#' library(dplyr)
#' library(nestcolor)
#'
#' set.seed(23)
#' ADSL <- osprey::rADSL
#' ADAE <- osprey::rADAE
#' ADSL <- mutate(ADSL, DOSE = paste(sample(1:3, n(), replace = TRUE), "UG"))
#' ADAE <- mutate(
#'   ADAE,
#'   flag1 = ifelse(AETOXGR == 1, 1, 0),
#'   flag2 = ifelse(AETOXGR == 2, 1, 0),
#'   flag3 = ifelse(AETOXGR == 3, 1, 0),
#'   flag1_filt = rep("Y", n())
#' )
#'
#' app <- init(
#'   data = cdisc_data(
#'     cdisc_dataset("ADSL", ADSL,
#'       code = "ADSL <- osprey::rADSL
#'               set.seed(23)
#'               ADSL <- mutate(ADSL, DOSE = paste(sample(1:3, n(), replace = TRUE), 'UG'))"
#'     ),
#'     cdisc_dataset("ADAE", ADAE,
#'       code = "ADAE <- osprey::rADAE
#'               ADAE <- mutate(ADAE,
#'               flag1 = ifelse(AETOXGR == 1, 1, 0),
#'               flag2 = ifelse(AETOXGR == 2, 1, 0),
#'               flag3 = ifelse(AETOXGR == 3, 1, 0),
#'               flag1_filt = rep('Y', n()))"
#'     ),
#'     check = TRUE
#'   ),
#'   modules = modules(
#'     tm_g_butterfly(
#'       label = "Butterfly Plot",
#'       dataname = "ADAE",
#'       right_var = teal.transform::choices_selected(
#'         selected = "SEX",
#'         choices = c("SEX", "ARM", "RACE")
#'       ),
#'       left_var = teal.transform::choices_selected(
#'         selected = "RACE",
#'         choices = c("SEX", "ARM", "RACE")
#'       ),
#'       category_var = teal.transform::choices_selected(
#'         selected = "AEBODSYS",
#'         choices = c("AEDECOD", "AEBODSYS")
#'       ),
#'       color_by_var = teal.transform::choices_selected(
#'         selected = "AETOXGR",
#'         choices = c("AETOXGR", "None")
#'       ),
#'       count_by_var = teal.transform::choices_selected(
#'         selected = "# of patients",
#'         choices = c("# of patients", "# of AEs")
#'       ),
#'       facet_var = teal.transform::choices_selected(
#'         selected = NULL,
#'         choices = c("RACE", "SEX", "ARM")
#'       ),
#'       sort_by_var = teal.transform::choices_selected(
#'         selected = "count",
#'         choices = c("count", "alphabetical")
#'       ),
#'       legend_on = TRUE,
#'       plot_height = c(600, 200, 2000)
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
tm_g_butterfly <- function(label,
                           dataname,
                           filter_var = NULL,
                           right_var,
                           left_var,
                           category_var,
                           color_by_var,
                           count_by_var,
                           facet_var = NULL,
                           sort_by_var = teal.transform::choices_selected(
                             selected = "count", choices = c("count", "alphabetical")
                           ),
                           legend_on = TRUE,
                           plot_height = c(600L, 200L, 2000L),
                           plot_width = NULL,
                           pre_output = NULL,
                           post_output = NULL) {
  logger::log_info("Initializing tm_g_butterfly")
  checkmate::assert_string(label)
  checkmate::assert_string(dataname)
  checkmate::assert_class(filter_var, classes = "choices_selected", null.ok = TRUE)
  checkmate::assert_class(right_var, classes = "choices_selected")
  checkmate::assert_class(left_var, classes = "choices_selected")
  checkmate::assert_class(category_var, classes = "choices_selected")
  checkmate::assert_class(color_by_var, classes = "choices_selected")
  checkmate::assert_class(count_by_var, classes = "choices_selected")
  checkmate::assert_class(facet_var, classes = "choices_selected", null.ok = TRUE)
  checkmate::assert_class(sort_by_var, classes = "choices_selected")
  checkmate::assert_flag(legend_on)
  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"
  )

  args <- as.list(environment())

  module(
    label = label,
    datanames = 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,
    ui_args = args
  )
}

ui_g_butterfly <- function(id, ...) {
  ns <- NS(id)
  a <- list(...)

  teal.widgets::standard_layout(
    output = teal.widgets::white_small_well(
      teal.widgets::plot_with_settings_ui(id = ns("butterflyplot"))
    ),
    encoding = div(
      ### Reporter
      teal.reporter::simple_reporter_ui(ns("simple_reporter")),
      ###
      tags$label("Encodings", class = "text-primary"),
      helpText("Dataset is:", tags$code(a$dataname)),
      if (!is.null(a$filter_var)) {
        teal.widgets::optionalSelectInput(
          ns("filter_var"),
          label =
            "Preset Data Filters Observations with value of 'Y' for selected variable(s) will be used for analysis",
          choices = a$filter_var$choices,
          selected = a$filter_var$selected,
          multiple = TRUE
        )
      },
      teal.widgets::optionalSelectInput(
        ns("right_var"),
        "Right Dichotomization Variable",
        a$right_var$choices,
        a$right_var$selected,
        multiple = FALSE
      ),
      teal.widgets::optionalSelectInput(
        ns("right_val"),
        "Choose Up To 2:",
        multiple = TRUE,
        options = list(
          `max-options` = 2L,
          `max-options-text` = "no more than 2",
          `actions-box` = FALSE
        )
      ),
      teal.widgets::optionalSelectInput(
        ns("left_var"),
        "Left Dichotomization Variable",
        a$left_var$choices,
        a$left_var$selected,
        multiple = FALSE
      ),
      teal.widgets::optionalSelectInput(
        ns("left_val"),
        "Choose Up To 2:",
        multiple = TRUE,
        options = list(
          `max-options` = 2L,
          `max-options-text` = "no more than 2",
          `actions-box` = FALSE
        )
      ),
      teal.widgets::optionalSelectInput(
        ns("category_var"),
        "Category Variable",
        a$category_var$choices,
        a$category_var$selected,
        multiple = FALSE
      ),
      radioButtons(
        ns("color_by_var"),
        "Color Block By Variable",
        a$color_by_var$choices,
        a$color_by_var$selected
      ),
      radioButtons(
        ns("count_by_var"),
        "Count By Variable",
        a$count_by_var$choices,
        a$count_by_var$selected
      ),
      if (!is.null(a$facet_var)) {
        teal.widgets::optionalSelectInput(
          ns("facet_var"),
          "Facet By Variable",
          a$facet_var$choices,
          a$facet_var$selected,
          multiple = TRUE
        )
      },
      radioButtons(
        ns("sort_by_var"),
        "Sort By Variable",
        a$sort_by_var$choices,
        a$sort_by_var$selected
      ),
      checkboxInput(
        ns("legend_on"),
        "Add legend",
        value = a$legend_on
      )
    ),
    forms = tagList(
      teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
      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, 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")
  checkmate::assert_class(data, "tdata")

  moduleServer(id, function(input, output, session) {
    iv <- reactive({
      ADSL <- data[["ADSL"]]() # nolint
      ANL <- data[[dataname]]() # nolint

      iv <- shinyvalidate::InputValidator$new()
      iv$add_rule("category_var", shinyvalidate::sv_required(
        message = "Category Variable is required"
      ))
      iv$add_rule("right_var", shinyvalidate::sv_required(
        message = "Right Dichotomization Variable is required"
      ))
      iv$add_rule("left_var", shinyvalidate::sv_required(
        message = "Left Dichotomization Variable is required"
      ))
      iv$add_rule("right_var", ~ if (!is.factor(ANL[[.]])) {
        "Right Dichotomization Variable must be a factor variable, contact developer"
      })
      iv$add_rule("left_var", ~ if (!is.factor(ANL[[.]])) {
        "Left Dichotomization Variable must be a factor variable, contact developer"
      })
      iv$add_rule("right_val", shinyvalidate::sv_required(
        message = "At least one value of Right Dichotomization Variable must be selected"
      ))
      iv$add_rule("left_val", shinyvalidate::sv_required(
        message = "At least one value of Left Dichotomization Variable must be selected"
      ))
      iv$enable()
      iv
    })

    options <- reactiveValues(r = NULL, l = NULL)
    vars <- reactiveValues(r = NULL, l = NULL)

    # dynamic options for dichotomization variable
    observeEvent(input$right_var,
      handlerExpr = {
        right_var <- input$right_var
        right_val <- isolate(input$right_val)
        current_r_var <- isolate(vars$r)
        if (is.null(right_var)) {
          teal.widgets::updateOptionalSelectInput(
            session,
            "right_val",
            choices = character(0),
            selected = character(0)
          )
        } else {
          options$r <- if (right_var %in% names(data[["ADSL"]]())) {
            levels(data[["ADSL"]]()[[right_var]])
          } else {
            levels(data[[dataname]]()[[right_var]])
          }

          selected <- if (length(right_val) > 0) {
            left_over <- right_val[right_val %in% options$r]
            if (length(left_over) > 0 && !is.null(current_r_var) && current_r_var == right_var) {
              left_over
            } else {
              options$r[1]
            }
          } else {
            options$r[1]
          }
          teal.widgets::updateOptionalSelectInput(
            session, "right_val",
            choices = as.character(options$r), selected = selected, label = "Choose Up To 2:"
          )
        }
        vars$r <- right_var
      },
      ignoreNULL = FALSE
    )

    observeEvent(input$left_var,
      handlerExpr = {
        left_var <- input$left_var
        left_val <- isolate(input$left_val)
        current_l_var <- isolate(vars$l)
        if (is.null(left_var)) {
          teal.widgets::updateOptionalSelectInput(
            session, "left_val",
            choices = character(0), selected = character(0)
          )
        } else {
          options$l <- if (left_var %in% names(data[["ADSL"]]())) {
            levels(data[["ADSL"]]()[[left_var]])
          } else {
            levels(data[[dataname]]()[[left_var]])
          }

          selected <- if (length(left_val) > 0) {
            left_over <- left_val[left_val %in% options$l]
            if (length(left_over) > 0 && !is.null(current_l_var) && current_l_var == left_var) {
              left_over
            } else {
              options$l[1]
            }
          } else {
            options$l[1]
          }

          teal.widgets::updateOptionalSelectInput(
            session, "left_val",
            choices = as.character(options$l), selected = selected, label = "Choose Up To 2:"
          )
        }
        vars$l <- left_var
      },
      ignoreNULL = FALSE
    )

    output_q <- shiny::debounce(
      millis = 200,
      r = reactive({
        ADSL <- data[["ADSL"]]() # nolint
        ANL <- data[[dataname]]() # nolint

        teal::validate_has_data(ADSL, min_nrow = 0, msg = sprintf("%s Data is empty", "ADSL"))
        teal::validate_has_data(ANL, min_nrow = 0, msg = sprintf("%s Data is empty", dataname))

        teal::validate_inputs(iv())

        validate(
          need(
            all(input$right_val %in% ADSL[[input$right_var]]) &&
              all(input$left_val %in% ADSL[[input$left_var]]),
            "No observations for selected dichotomization values (filtered out?)"
          )
        )

        right_var <- isolate(input$right_var)
        left_var <- isolate(input$left_var)
        right_val <- input$right_val
        left_val <- input$left_val
        category_var <- input$category_var
        color_by_var <- input$color_by_var
        count_by_var <- input$count_by_var
        legend_on <- input$legend_on
        facet_var <- input$facet_var
        sort_by_var <- input$sort_by_var
        filter_var <- input$filter_var

        # if variable is not in ADSL, then take from domain VADs
        varlist <- c(category_var, color_by_var, facet_var, filter_var, right_var, left_var)
        varlist_from_adsl <- intersect(varlist, names(ADSL))
        varlist_from_anl <- intersect(varlist, setdiff(names(ANL), names(ADSL)))

        adsl_vars <- unique(c("USUBJID", "STUDYID", varlist_from_adsl)) # nolint
        anl_vars <- unique(c("USUBJID", "STUDYID", varlist_from_anl)) # nolint

        q1 <- teal.code::eval_code(
          teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)),
          code = bquote({
            ADSL <- ADSL[, .(adsl_vars)] %>% as.data.frame() # nolint
            ANL <- .(as.name(dataname))[, .(anl_vars)] %>% as.data.frame() # nolint
          })
        )

        if (!("NULL" %in% filter_var) && !is.null(filter_var)) {
          q1 <- teal.code::eval_code(
            q1,
            code = bquote(
              ANL <- quick_filter(.(filter_var), ANL) %>% # nolint
                droplevels() %>%
                as.data.frame()
            )
          )
        }

        q1 <- teal.code::eval_code(
          q1,
          code = bquote({
            ANL_f <- left_join(ADSL, ANL, by = c("USUBJID", "STUDYID")) %>% as.data.frame() # nolint
            ANL_f <- na.omit(ANL_f) # nolint
          })
        )

        if (!is.null(right_val) && !is.null(right_val)) {
          q1 <- teal.code::eval_code(
            q1,
            code = bquote({
              right <- ANL_f[, .(right_var)] %in% .(right_val)
              right_name <- paste(.(right_val), collapse = " - ")
              left <- ANL_f[, .(left_var)] %in% .(left_val)
              left_name <- paste(.(left_val), collapse = " - ")
            })
          )
        }

        if (!is.null(right_val) && !is.null(left_val)) {
          q1 <- teal.code::eval_code(
            q1,
            code = bquote(
              plot <- osprey::g_butterfly(
                category = ANL_f[, .(category_var)],
                right_flag = right,
                left_flag = left,
                group_names = c(right_name, left_name),
                block_count = .(count_by_var),
                block_color = .(if (color_by_var != "None") {
                  bquote(ANL_f[, .(color_by_var)])
                } else {
                  NULL
                }),
                id = ANL_f$USUBJID,
                facet_rows = .(if (!is.null(facet_var)) {
                  bquote(ANL_f[, .(facet_var)])
                } else {
                  NULL
                }),
                x_label = .(count_by_var),
                y_label = .(category_var),
                legend_label = .(color_by_var),
                sort_by = .(sort_by_var),
                show_legend = .(legend_on)
              )
            )
          )
        }

        teal.code::eval_code(q1, quote(plot))
      })
    )

    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",
      plot_r = plot_r,
      height = plot_height,
      width = plot_width
    )

    teal.widgets::verbatim_popup_srv(
      id = "warning",
      verbatim_content = reactive(teal.code::get_warnings(output_q())),
      title = "Warning",
      disabled = reactive(is.null(teal.code::get_warnings(output_q())))
    )

    teal.widgets::verbatim_popup_srv(
      id = "rcode",
      title = paste("R code for", label),
      verbatim_content = reactive(teal.code::get_code(output_q()))
    )

    ### REPORTER
    if (with_reporter) {
      card_fun <- function(comment) {
        card <- teal::TealReportCard$new()
        card$set_name("Butterfly")
        card$append_text("Butterfly Plot", "header2")
        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")
        }
        if (!is.null(input$filter_var)) {
          card$append_text(paste0("Preset Data Filters: ", paste(input$filter_var, collapse = ", "), "."))
        }
        if (!is.null(input$facet_var)) {
          card$append_text(paste0("Faceted by: ", paste(input$facet_var, collapse = ", "), "."))
        }
        if (!is.null(input$sort_by_var)) {
          card$append_text(paste0("Sorted by: ", paste(input$sort_by_var, collapse = ", "), "."))
        }
        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(teal.code::get_code(output_q()), collapse = "\n"))
        card
      }
      teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
    }
  })
}

#' Teal Module for `Swimlane` Plot
#'
#' @description
#' `r lifecycle::badge("stable")`
#'
#' This is teal module that generates a `swimlane` plot (bar plot with markers) for `ADaM` data
#'
#' @inheritParams teal.widgets::standard_layout
#' @inheritParams argument_convention
#' @param dataname analysis data used for plotting, needs to be available in the list passed to the \code{data}
#' argument of \code{\link[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 (\code{\link[teal.transform]{choices_selected}}) subject-level numeric variable from dataset
#' to plot as the bar length
#' @param bar_color_var (\code{\link[teal.transform]{choices_selected}}) color by variable (subject-level)
#' @param sort_var (\code{choices_selected}) sort by variable (subject-level)
#' @param marker_pos_var (\code{\link[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})
#' @param marker_shape_var (\code{\link[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 \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
#' @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 \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
#' @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
#'
#' @inherit argument_convention return
#'
#' @export
#'
#' @template author_qit3
#'
#' @examples
#'
#' # Example using stream (ADaM) dataset
#' library(dplyr)
#' library(nestcolor)
#'
#' ADSL <- osprey::rADSL %>%
#'   dplyr::mutate(TRTDURD = as.integer(TRTEDTM - TRTSDTM) + 1) %>%
#'   dplyr::filter(STRATA1 == "A" & ARMCD == "ARM A")
#' ADRS <- osprey::rADRS
#'
#' ADRS <- ADRS %>%
#'   dplyr::filter(PARAMCD == "LSTASDI" & DCSREAS == "Death") %>%
#'   mutate(AVALC = DCSREAS, ADY = EOSDY) %>%
#'   base::rbind(ADRS %>% dplyr::filter(PARAMCD == "OVRINV" & AVALC != "NE")) %>%
#'   arrange(USUBJID)
#'
#' app <- init(
#'   data = cdisc_data(
#'     cdisc_dataset("ADSL", ADSL, code = "ADSL <- osprey::rADSL %>%
#'       dplyr::mutate(TRTDURD = as.integer(TRTEDTM - TRTSDTM) + 1) %>%
#'       dplyr::filter(STRATA1 == 'A' & ARMCD == 'ARM A')"),
#'     cdisc_dataset("ADRS", ADRS,
#'       code = "ADRS <- rADRS
#'               ADRS <- ADRS %>% dplyr::filter(PARAMCD == 'LSTASDI' & DCSREAS == 'Death') %>%
#'                       mutate(AVALC = DCSREAS, ADY = EOSDY) %>%
#'               rbind(ADRS %>% dplyr::filter(PARAMCD == 'OVRINV' & AVALC != 'NE')) %>%
#'               arrange(USUBJID)"
#'     ),
#'     check = TRUE
#'   ),
#'   modules = modules(
#'     tm_g_swimlane(
#'       label = "Swimlane Plot",
#'       dataname = "ADRS",
#'       bar_var = teal.transform::choices_selected(
#'         selected = "TRTDURD",
#'         choices = c("TRTDURD", "EOSDY")
#'       ),
#'       bar_color_var = teal.transform::choices_selected(
#'         selected = "EOSSTT",
#'         choices = c("EOSSTT", "ARM", "ARMCD", "ACTARM", "ACTARMCD", "SEX")
#'       ),
#'       sort_var = teal.transform::choices_selected(
#'         selected = "ACTARMCD",
#'         choices = c("USUBJID", "SITEID", "ACTARMCD", "TRTDURD")
#'       ),
#'       marker_pos_var = teal.transform::choices_selected(
#'         selected = "ADY",
#'         choices = c("ADY")
#'       ),
#'       marker_shape_var = teal.transform::choices_selected(
#'         selected = "AVALC",
#'         c("AVALC", "AVISIT")
#'       ),
#'       marker_shape_opt = c("CR" = 16, "PR" = 17, "SD" = 18, "PD" = 15, "Death" = 8),
#'       marker_color_var = teal.transform::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 = teal.transform::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)") {
  logger::log_info("Initializing tm_g_swimlane")
  args <- as.list(environment())

  checkmate::assert_string(label)
  checkmate::assert_string(dataname)
  checkmate::assert_class(bar_var, classes = "choices_selected")
  checkmate::assert_class(bar_color_var, classes = "choices_selected")
  checkmate::assert_class(marker_pos_var, classes = "choices_selected")
  checkmate::assert_class(marker_shape_var, classes = "choices_selected")
  checkmate::assert_numeric(marker_shape_opt, min.len = 1, any.missing = FALSE)
  checkmate::assert_class(marker_color_var, classes = "choices_selected")
  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_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"
  )
  checkmate::assert_string(x_label)


  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
    ),
    datanames = c("ADSL", dataname)
  )
}


ui_g_swimlane <- function(id, ...) {
  a <- list(...)
  ns <- NS(id)

  shiny::tagList(
    include_css_files("custom"),
    teal.widgets::standard_layout(
      output = teal.widgets::white_small_well(
        teal.widgets::plot_with_settings_ui(id = ns("swimlaneplot"))
      ),
      encoding = div(
        ### Reporter
        teal.reporter::simple_reporter_ui(ns("simple_reporter")),
        ###
        tags$label("Encodings", class = "text-primary"),
        helpText("Analysis data:", code(a$dataname)),
        div(
          class = "pretty-left-border",
          teal.widgets::optionalSelectInput(
            ns("bar_var"),
            "Bar Length",
            choices = a$bar_var$choices,
            selected = a$bar_var$selected,
            multiple = FALSE,
            label_help = helpText("from ", code("ADSL"))
          ),
          teal.widgets::optionalSelectInput(
            ns("bar_color_var"),
            "Bar Color",
            choices = a$bar_color_var$choices,
            selected = a$bar_color_var$selected,
            multiple = FALSE,
            label_help = helpText("from ", code("ADSL"))
          )
        ),
        teal.widgets::optionalSelectInput(
          ns("sort_var"),
          "Sort by",
          choices = a$sort_var$choices,
          selected = a$sort_var$selected,
          multiple = FALSE,
          label_help = helpText("from ", code("ADSL"))
        ),
        div(
          class = "pretty-left-border",
          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 = a$marker_pos_var$choices,
              selected = a$marker_pos_var$selected,
              multiple = FALSE,
              label_help = helpText("from ", code(a$dataname))
            )
          },
          uiOutput(ns("marker_shape_sel")),
          uiOutput(ns("marker_color_sel"))
        ),
        teal.widgets::optionalSelectInput(
          ns("anno_txt_var"),
          "Annotation Variables",
          choices = a$anno_txt_var$choices,
          selected = a$anno_txt_var$selected,
          multiple = TRUE,
          label_help = helpText("from ", code("ADSL"))
        ),
        textInput(
          ns("vref_line"),
          label = div(
            "Vertical Reference Line(s)",
            tags$br(),
            helpText("Enter numeric value(s) of reference lines, separated by comma (eg. 100, 200)")
          ),
          value = paste(a$vref_line, collapse = ", ")
        )
      ),
      forms = tagList(
        teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
        teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
      ),
      pre_output = a$pre_output,
      post_output = a$post_output
    )
  )
}

srv_g_swimlane <- function(id,
                           data,
                           filter_panel_api,
                           reporter,
                           dataname,
                           marker_pos_var,
                           marker_shape_var,
                           marker_shape_opt,
                           marker_color_var,
                           marker_color_opt,
                           label,
                           plot_height,
                           plot_width,
                           x_label) {
  with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
  with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
  checkmate::assert_class(data, "tdata")

  moduleServer(id, function(input, output, session) {
    iv <- reactive({
      iv <- shinyvalidate::InputValidator$new()
      iv$add_rule("bar_var", shinyvalidate::sv_required(
        message = "Bar Length is required"
      ))
      # If reference lines are requested
      iv$add_rule("vref_line", ~ if (anyNA(suppressWarnings(as_numeric_from_comma_sep_str(.)))) {
        "Vertical Reference Line(s) are invalid"
      })
      iv$enable()
      iv
    })

    # if marker position is NULL, then hide options for marker shape and color
    output$marker_shape_sel <- renderUI({
      if (dataname == "ADSL" || is.null(marker_shape_var) || is.null(input$marker_pos_var)) {
        NULL
      } else {
        ns <- session$ns
        teal.widgets::optionalSelectInput(
          ns("marker_shape_var"), "Marker Shape",
          choices = marker_shape_var$choices,
          selected = marker_shape_var$selected, multiple = FALSE,
          label_help = helpText("from ", 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 = marker_color_var$choices,
          selected = marker_color_var$selected, multiple = FALSE,
          label_help = helpText("from ", code(dataname))
        )
      }
    })

    # create plot
    output_q <- reactive({
      teal::validate_inputs(iv())

      validate(need("ADSL" %in% names(data), "'ADSL' not included in data"))
      validate(need(
        (length(data) == 1 && dataname == "ADSL") ||
          (length(data) >= 2 && dataname != "ADSL"), paste(
          "Please either add just 'ADSL' as dataname when just ADSL is available.",
          "In case 2 datasets are available ADSL is not supposed to be the dataname."
        )
      ))

      ADSL <- data[["ADSL"]]() # nolint

      anl_vars <- unique(c(
        "USUBJID", "STUDYID",
        input$marker_pos_var, input$marker_shape_var, input$marker_color_var
      )) # nolint
      adsl_vars <- unique(c(
        "USUBJID", "STUDYID",
        input$bar_var, input$bar_color_var, input$sort_var, input$anno_txt_var
      ))

      if (dataname == "ADSL") {
        teal::validate_has_data(ADSL, min_nrow = 3)
        teal::validate_has_variable(ADSL, adsl_vars)
      } else {
        anl <- data[[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"
        ))
      }

      # 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 <- teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data))

      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)
        })
      )

      # WRITE DATA SELECTION TO qenv
      q3 <- if (dataname == "ADSL") {
        teal.code::eval_code(
          q2,
          code = bquote({
            ADSL_p <- ADSL # nolint
            ADSL <- ADSL_p[, .(adsl_vars)] # nolint
            # only take last part of USUBJID
            ADSL$USUBJID <- unlist(lapply(strsplit(ADSL$USUBJID, "-", fixed = TRUE), tail, 1)) # nolint
          })
        )
      } else {
        teal.code::eval_code(
          q2,
          code = bquote({
            ADSL_p <- ADSL # nolint
            ANL_p <- .(as.name(dataname)) # nolint

            ADSL <- ADSL_p[, .(adsl_vars)] # nolint
            ANL <- merge( # nolint
              x = ADSL,
              y = ANL_p[, .(anl_vars)],
              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)) # nolint
            ANL$USUBJID <- unlist(lapply(strsplit(ANL$USUBJID, "-", fixed = TRUE), tail, 1)) # nolint
          })
        )
      }

      plot_call <- if (dataname == "ADSL") {
        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),
            col_by = .(if (length(bar_color_var) > 0) quote(ADSL[[bar_color_var]]) else NULL),
            marker_id = NULL,
            marker_pos = NULL,
            marker_shape = NULL,
            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),
            xref_line = .(vref_line),
            xtick_at = waiver(),
            xlab = .(x_label),
            title = "Swimlane Plot"
          )
        )
      } else {
        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
            }),
            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_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)) == TRUE) {
              bquote(.(marker_shape_opt))
            } 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)) == TRUE) {
              bquote(.(marker_color_opt))
            } else {
              NULL
            }),
            anno_txt = .(if (length(anno_txt_var) > 0) {
              quote(ADSL[, anno_txt_var])
            } else {
              NULL
            }),
            xref_line = .(vref_line),
            xtick_at = waiver(),
            xlab = .(x_label),
            title = "Swimlane Plot"
          )
        )
      }

      q4 <- teal.code::eval_code(q3, code = plot_call)
      teal.code::eval_code(q4, 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",
      plot_r = plot_r,
      height = plot_height,
      width = plot_width
    )

    teal.widgets::verbatim_popup_srv(
      id = "warning",
      verbatim_content = reactive(teal.code::get_warnings(output_q())),
      title = "Warning",
      disabled = reactive(is.null(teal.code::get_warnings(output_q())))
    )

    teal.widgets::verbatim_popup_srv(
      id = "rcode",
      title = paste("R code for", label),
      verbatim_content = reactive(teal.code::get_code(output_q()))
    )

    ### REPORTER
    if (with_reporter) {
      card_fun <- function(comment) {
        card <- teal::TealReportCard$new()
        card$set_name("Swimlane")
        card$append_text("Swimlane Plot", "header2")
        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))
        }
        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(teal.code::get_code(output_q()), collapse = "\n"))
        card
      }
      teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
    }
  })
}

#' Spider plot Teal Module
#'
#' @description
#' `r lifecycle::badge("stable")`
#'
#' Display spider plot as a shiny module
#'
#' @inheritParams teal.widgets::standard_layout
#' @inheritParams argument_convention
#' @param x_var x-axis variables
#' @param y_var y-axis variables
#' @param marker_var variable dictates marker symbol
#' @param line_colorby_var variable dictates line color
#' @param vref_line vertical reference lines
#' @param href_line horizontal reference lines
#' @param anno_txt_var annotation text
#' @param legend_on boolean value for whether legend is displayed
#' @param xfacet_var variable for x facets
#' @param yfacet_var variable for y facets
#'
#' @inherit argument_convention return
#' @export
#'
#' @template author_zhanc107
#' @template author_liaoc10
#'
#' @examples
#'
#' # Example using stream (ADaM) dataset
#' library(dplyr)
#' library(nestcolor)
#'
#' ADSL <- osprey::rADSL
#' ADTR <- osprey::rADTR
#'
#' app <- teal::init(
#'   data = cdisc_data(
#'     cdisc_dataset("ADSL", ADSL, code = "ADSL <- osprey::rADSL"),
#'     cdisc_dataset("ADTR", ADTR,
#'       code = "ADTR <- osprey::rADTR",
#'       keys = c("STUDYID", "USUBJID", "PARAMCD", "AVISIT")
#'     ),
#'     check = TRUE
#'   ),
#'   modules = modules(
#'     tm_g_spiderplot(
#'       label = "Spider plot",
#'       dataname = "ADTR",
#'       paramcd = teal.transform::choices_selected(
#'         choices = "SLDINV",
#'         selected = "SLDINV"
#'       ),
#'       x_var = teal.transform::choices_selected(
#'         choices = "ADY",
#'         selected = "ADY"
#'       ),
#'       y_var = teal.transform::choices_selected(
#'         choices = c("PCHG", "CHG", "AVAL"),
#'         selected = "PCHG"
#'       ),
#'       marker_var = teal.transform::choices_selected(
#'         choices = c("SEX", "RACE", "USUBJID"),
#'         selected = "SEX"
#'       ),
#'       line_colorby_var = teal.transform::choices_selected(
#'         choices = c("SEX", "USUBJID", "RACE"),
#'         selected = "SEX"
#'       ),
#'       xfacet_var = teal.transform::choices_selected(
#'         choices = c("SEX", "ARM"),
#'         selected = "SEX"
#'       ),
#'       yfacet_var = teal.transform::choices_selected(
#'         choices = c("SEX", "ARM"),
#'         selected = "ARM"
#'       ),
#'       vref_line = "10, 37",
#'       href_line = "-20, 0"
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
tm_g_spiderplot <- function(label,
                            dataname,
                            paramcd,
                            x_var,
                            y_var,
                            marker_var,
                            line_colorby_var,
                            xfacet_var = NULL,
                            yfacet_var = NULL,
                            vref_line = NULL,
                            href_line = NULL,
                            anno_txt_var = TRUE,
                            legend_on = FALSE,
                            plot_height = c(600L, 200L, 2000L),
                            plot_width = NULL,
                            pre_output = NULL,
                            post_output = NULL) {
  logger::log_info("Initializing tm_g_spiderplot")
  checkmate::assert_class(paramcd, classes = "choices_selected")
  checkmate::assert_class(x_var, classes = "choices_selected")
  checkmate::assert_class(y_var, classes = "choices_selected")
  checkmate::assert_class(marker_var, classes = "choices_selected")
  checkmate::assert_class(line_colorby_var, classes = "choices_selected")
  checkmate::assert_class(xfacet_var, classes = "choices_selected")
  checkmate::assert_class(yfacet_var, classes = "choices_selected")
  checkmate::assert_string(vref_line)
  checkmate::assert_string(href_line)
  checkmate::assert_flag(anno_txt_var)
  checkmate::assert_flag(legend_on)
  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"
  )

  args <- as.list(environment())
  module(
    label = label,
    datanames = 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,
    ui_args = args
  )
}

ui_g_spider <- function(id, ...) {
  ns <- NS(id)
  a <- list(...)

  shiny::tagList(
    include_css_files("custom"),
    teal.widgets::standard_layout(
      output = teal.widgets::white_small_well(
        teal.widgets::plot_with_settings_ui(id = ns("spiderplot"))
      ),
      encoding = div(
        ### Reporter
        teal.reporter::simple_reporter_ui(ns("simple_reporter")),
        ###
        tags$label("Encodings", class = "text-primary"),
        helpText("Analysis data:", tags$code(a$dataname)),
        div(
          class = "pretty-left-border",
          teal.widgets::optionalSelectInput(
            ns("paramcd"),
            paste("Parameter - from", a$dataname),
            a$paramcd$choices,
            a$paramcd$selected,
            multiple = FALSE
          ),
          teal.widgets::optionalSelectInput(
            ns("x_var"),
            "X-axis Variable",
            a$x_var$choices,
            a$x_var$selected,
            multiple = FALSE
          ),
          teal.widgets::optionalSelectInput(
            ns("y_var"),
            "Y-axis Variable",
            a$y_var$choices,
            a$y_var$selected,
            multiple = FALSE
          ),
          teal.widgets::optionalSelectInput(
            ns("line_colorby_var"),
            "Color By Variable (Line)",
            a$line_colorby_var$choices,
            a$line_colorby_var$selected,
            multiple = FALSE
          ),
          teal.widgets::optionalSelectInput(
            ns("marker_var"),
            "Marker Symbol By Variable",
            a$marker_var$choices,
            a$marker_var$selected,
            multiple = FALSE
          ),
          teal.widgets::optionalSelectInput(
            ns("xfacet_var"),
            "X-facet By Variable",
            a$xfacet_var$choices,
            a$xfacet_var$selected,
            multiple = TRUE
          ),
          teal.widgets::optionalSelectInput(
            ns("yfacet_var"),
            "Y-facet By Variable",
            a$yfacet_var$choices,
            a$yfacet_var$selected,
            multiple = TRUE
          )
        ),
        checkboxInput(
          ns("anno_txt_var"),
          "Add subject ID label",
          value = a$anno_txt_var
        ),
        checkboxInput(
          ns("legend_on"),
          "Add legend",
          value = a$legend_on
        ),
        textInput(
          ns("vref_line"),
          label = div(
            "Vertical Reference Line(s)",
            tags$br(),
            helpText("Enter numeric value(s) of vertical reference lines, separated by comma (eg. -2, 1)")
          ),
          value = a$vref_line
        ),
        textInput(
          ns("href_line"),
          label = div(
            "Hortizontal Reference Line(s)",
            tags$br(),
            helpText("Enter numeric value(s) of horizontal reference lines, separated by comma (eg. -2, 1)")
          ),
          value = a$href_line
        )
      ),
      forms = tagList(
        teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
        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, 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")
  checkmate::assert_class(data, "tdata")

  moduleServer(id, function(input, output, session) {
    iv <- reactive({
      ADSL <- data[["ADSL"]]() # nolint
      ADTR <- data[[dataname]]() # nolint

      iv <- shinyvalidate::InputValidator$new()
      iv$add_rule("paramcd", shinyvalidate::sv_required(
        message = "Parameter is required"
      ))
      iv$add_rule("x_var", shinyvalidate::sv_required(
        message = "X Axis Variable is required"
      ))
      iv$add_rule("y_var", shinyvalidate::sv_required(
        message = "Y Axis Variable is required"
      ))
      iv$add_rule("line_colorby_var", shinyvalidate::sv_required(
        message = "Color Variable is required"
      ))
      iv$add_rule("marker_var", shinyvalidate::sv_required(
        message = "Marker Symbol Variable is required"
      ))
      fac_dupl <- function(value, other) {
        if (length(value) * length(other) > 0L && anyDuplicated(c(value, other))) {
          "X- and Y-facet Variables must not overlap"
        }
      }
      iv$add_rule("xfacet_var", fac_dupl, other = input$yfacet_var)
      iv$add_rule("yfacet_var", fac_dupl, other = input$xfacet_var)
      iv$add_rule("vref_line", ~ if (anyNA(suppressWarnings(as_numeric_from_comma_sep_str(.)))) {
        "Vertical Reference Line(s) are invalid"
      })
      iv$add_rule("href_line", ~ if (anyNA(suppressWarnings(as_numeric_from_comma_sep_str(.)))) {
        "Horizontal Reference Line(s) are invalid"
      })
      iv$enable()
    })

    vals <- reactiveValues(spiderplot = NULL) # nolint

    # render plot
    output_q <- reactive({
      # get datasets ---
      ADSL <- data[["ADSL"]]() # nolint
      ADTR <- data[[dataname]]() # nolint

      teal::validate_inputs(iv())

      teal::validate_has_data(ADSL, min_nrow = 1, msg = sprintf("%s data has zero rows", "ADSL"))
      teal::validate_has_data(ADTR, min_nrow = 1, msg = sprintf("%s data has zero rows", dataname))

      paramcd <- input$paramcd # nolint
      x_var <- input$x_var
      y_var <- input$y_var
      marker_var <- input$marker_var
      line_colorby_var <- input$line_colorby_var
      anno_txt_var <- input$anno_txt_var
      legend_on <- input$legend_on # nolint
      xfacet_var <- input$xfacet_var
      yfacet_var <- input$yfacet_var
      vref_line <- input$vref_line
      href_line <- input$href_line

      # reference lines preprocessing
      vref_line <- as_numeric_from_comma_sep_str(vref_line)
      href_line <- as_numeric_from_comma_sep_str(href_line)

      # define variables ---
      # if variable is not in ADSL, then take from domain VADs
      varlist <- c(xfacet_var, yfacet_var, marker_var, line_colorby_var)
      varlist_from_adsl <- varlist[varlist %in% names(ADSL)]
      varlist_from_anl <- varlist[!varlist %in% names(ADSL)]

      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 qenv ---

      # vars definition
      adtr_vars <- adtr_vars[adtr_vars != "None"]
      adtr_vars <- adtr_vars[!is.null(adtr_vars)]

      # merge
      q1 <- teal.code::eval_code(
        teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)),
        code = bquote({
          ADSL <- ADSL[, .(adsl_vars)] %>% as.data.frame() # nolint
          ADTR <- .(as.name(dataname))[, .(adtr_vars)] %>% as.data.frame() # nolint

          ANL <- merge(ADSL, ADTR, by = c("USUBJID", "STUDYID")) # nolint
          ANL <- ANL %>% # nolint
            group_by(USUBJID, PARAMCD) %>%
            arrange(ANL[, .(x_var)]) %>%
            as.data.frame()
        })
      )

      # format and filter
      q1 <- teal.code::eval_code(
        q1,
        code = bquote({
          ANL$USUBJID <- unlist(lapply(strsplit(ANL$USUBJID, "-", fixed = TRUE), tail, 1)) # nolint
          ANL_f <- ANL %>% # nolint
            filter(PARAMCD == .(paramcd)) %>%
            as.data.frame()
        })
      )

      # label
      q1 <- if (anno_txt_var) {
        teal.code::eval_code(
          q1,
          code = quote(lbl <- list(txt_ann = as.factor(ANL_f$USUBJID)))
        )
      } else {
        teal.code::eval_code(q1, code = quote(lbl <- NULL))
      }

      # plot code to qenv ---

      q1 <- teal.code::eval_code(
        q1,
        code = bquote({
          plot <- osprey::g_spiderplot(
            marker_x = ANL_f[, .(x_var)],
            marker_id = ANL_f$USUBJID,
            marker_y = ANL_f[, .(y_var)],
            line_colby = .(if (line_colorby_var != "None") {
              bquote(ANL_f[, .(line_colorby_var)])
            } else {
              NULL
            }),
            marker_shape = .(if (marker_var != "None") {
              bquote(ANL_f[, .(marker_var)])
            } else {
              NULL
            }),
            marker_size = 4,
            datalabel_txt = lbl,
            facet_rows = .(if (!is.null(yfacet_var)) {
              bquote(data.frame(ANL_f[, .(yfacet_var)]))
            } else {
              NULL
            }),
            facet_columns = .(if (!is.null(xfacet_var)) {
              bquote(data.frame(ANL_f[, .(xfacet_var)]))
            } else {
              NULL
            }),
            vref_line = .(vref_line),
            href_line = .(href_line),
            x_label = if (is.null(formatters::var_labels(ADTR[.(x_var)], fill = FALSE))) {
              .(x_var)
            } else {
              formatters::var_labels(ADTR[.(x_var)], fill = FALSE)
            },
            y_label = if (is.null(formatters::var_labels(ADTR[.(y_var)], fill = FALSE))) {
              .(y_var)
            } else {
              formatters::var_labels(ADTR[.(y_var)], fill = FALSE)
            },
            show_legend = .(legend_on)
          )

          plot
        })
      )
    })

    plot_r <- reactive(output_q()[["plot"]])

    pws <- teal.widgets::plot_with_settings_srv(
      id = "spiderplot",
      plot_r = plot_r,
      height = plot_height,
      width = plot_width
    )

    teal.widgets::verbatim_popup_srv(
      id = "warning",
      verbatim_content = reactive(teal.code::get_warnings(output_q())),
      title = "Warning",
      disabled = reactive(is.null(teal.code::get_warnings(output_q())))
    )

    teal.widgets::verbatim_popup_srv(
      id = "rcode",
      title = paste("R code for", label),
      verbatim_content = reactive(teal.code::get_code(output_q()))
    )

    ### REPORTER
    if (with_reporter) {
      card_fun <- function(comment) {
        card <- teal::TealReportCard$new()
        card$set_name("Spider Plot")
        card$append_text("Spider Plot", "header2")
        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")
        }
        if (!is.null(input$paramcd)) {
          card$append_text(paste0("Parameter - (from ", dataname, "): ", input$paramcd, "."))
        }
        if (!is.null(input$xfacet_var)) {
          card$append_text(paste0("Faceted horizontally by: ", paste(input$xfacet_var, collapse = ", "), "."))
        }
        if (!is.null(input$yfacet_var)) {
          card$append_text(paste0("Faceted vertically by: ", paste(input$yfacet_var, collapse = ", "), "."))
        }
        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(teal.code::get_code(output_q()), collapse = "\n"))
        card
      }
      teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
    }
  })
}

#' Teal module for the heatmap by grade
#'
#' @description
#' `r lifecycle::badge("stable")`
#'
#' Display the heatmap by grade as a shiny module
#'
#' @inheritParams teal.widgets::standard_layout
#' @inheritParams argument_convention
#' @param sl_dataname (\code{character}) subject level dataset name,
#' needs to be available in the list passed to the \code{data}
#' argument of \code{\link[teal]{init}}
#' @param ex_dataname (\code{character}) exposures dataset name,
#' needs to be available in the list passed to the \code{data}
#' argument of \code{\link[teal]{init}} \cr
#' @param ae_dataname (\code{character}) adverse events dataset name,
#' needs to be available in the list passed to the \code{data}
#' argument of \code{\link[teal]{init}} \cr
#' @param cm_dataname (\code{character}) concomitant medications dataset name,
#' needs to be available in the list passed to the \code{data}
#' argument of \code{\link[teal]{init}} \cr
#' specify to \code{NA} if no concomitant medications data is available
#' @param id_var (\code{choices_seleced}) unique subject ID variable
#' @param visit_var (\code{choices_seleced}) analysis visit variable
#' @param ongo_var (\code{choices_seleced}) study ongoing status variable,
#' This variable is a derived logical variable. Usually it can be derived from \code{EOSSTT}.
#' @param anno_var (\code{choices_seleced}) annotation variable
#' @param heat_var (\code{choices_seleced}) heatmap variable
#' @param conmed_var (\code{choices_seleced}) concomitant medications variable,
#' specify to \code{NA} if no concomitant medications data is available
#'
#' @inherit argument_convention return
#'
#' @export
#'
#' @examples
#' library(dplyr)
#' library(nestcolor)
#' ADSL <- osprey::rADSL %>% slice(1:30)
#' ADEX <- osprey::rADEX %>% filter(USUBJID %in% ADSL$USUBJID)
#' ADAE <- osprey::rADAE %>% filter(USUBJID %in% ADSL$USUBJID)
#' ADCM <- osprey::rADCM %>% filter(USUBJID %in% ADSL$USUBJID)
#'
#' # This preprocess is only to force legacy standard on ADCM
#' ADCM <- ADCM %>%
#'   select(-starts_with("ATC")) %>%
#'   unique()
#'
#' # function to derive AVISIT from ADEX
#' add_visit <- function(data_need_visit) {
#'   visit_dates <- ADEX %>%
#'     filter(PARAMCD == "DOSE") %>%
#'     distinct(USUBJID, AVISIT, ASTDTM) %>%
#'     group_by(USUBJID) %>%
#'     arrange(ASTDTM) %>%
#'     mutate(next_vis = lead(ASTDTM), is_last = ifelse(is.na(next_vis), TRUE, FALSE)) %>%
#'     rename(this_vis = ASTDTM)
#'   data_visit <- data_need_visit %>%
#'     select(USUBJID, ASTDTM) %>%
#'     left_join(visit_dates, by = "USUBJID") %>%
#'     filter(ASTDTM > this_vis & (ASTDTM < next_vis | is_last == TRUE)) %>%
#'     left_join(data_need_visit) %>%
#'     distinct()
#'   return(data_visit)
#' }
#' # derive AVISIT for ADAE and ADCM
#' ADAE <- add_visit(ADAE)
#' ADCM <- add_visit(ADCM)
#' # derive ongoing status variable for ADEX
#' ADEX <- ADEX %>%
#'   filter(PARCAT1 == "INDIVIDUAL") %>%
#'   mutate(ongo_status = (EOSSTT == "ONGOING"))
#'
#' app <- init(
#'   data = cdisc_data(
#'     cdisc_dataset("ADSL", ADSL),
#'     cdisc_dataset("ADEX", ADEX),
#'     cdisc_dataset("ADAE", ADAE),
#'     cdisc_dataset("ADCM", ADCM, keys = c("STUDYID", "USUBJID", "ASTDTM", "CMSEQ", "CMDECOD")),
#'     code = "
#'     ADSL <- osprey::rADSL %>% slice(1:30)
#'     ADEX <- osprey::rADEX %>% filter(USUBJID %in% ADSL$USUBJID)
#'     ADAE <- osprey::rADAE %>% filter(USUBJID %in% ADSL$USUBJID)
#'     ADCM <- osprey::rADCM %>% filter(USUBJID %in% ADSL$USUBJID)
#'     ADCM <- ADCM %>% select(-starts_with(\"ATC\")) %>% unique()
#'     ADEX  <- ADEX %>%
#'       filter(PARCAT1 == 'INDIVIDUAL') %>%
#'       mutate(ongo_status = (EOSSTT == 'ONGOING'))
#'     add_visit <- function(data_need_visit) {
#'       visit_dates <- ADEX %>%
#'         filter(PARAMCD == 'DOSE') %>%
#'         distinct(USUBJID, AVISIT, ASTDTM) %>%
#'         group_by(USUBJID) %>%
#'         arrange(ASTDTM) %>%
#'         mutate(next_vis = lead(ASTDTM), is_last = ifelse(is.na(next_vis), TRUE, FALSE)) %>%
#'         rename(this_vis = ASTDTM)
#'       data_visit <- data_need_visit %>%
#'         select(USUBJID, ASTDTM) %>%
#'         left_join(visit_dates, by = 'USUBJID') %>%
#'         filter(ASTDTM > this_vis & (ASTDTM < next_vis | is_last == TRUE)) %>%
#'         left_join(data_need_visit) %>% distinct()
#'       return(data_visit)
#'     }
#'     ADAE <- add_visit(ADAE)
#'     ADCM <- add_visit(ADCM)
#'     ",
#'     check = TRUE
#'   ),
#'   modules = modules(
#'     tm_g_heat_bygrade(
#'       label = "Heatmap by grade",
#'       sl_dataname = "ADSL",
#'       ex_dataname = "ADEX",
#'       ae_dataname = "ADAE",
#'       cm_dataname = "ADCM",
#'       id_var = teal.transform::choices_selected(
#'         selected = "USUBJID",
#'         choices = c("USUBJID", "SUBJID")
#'       ),
#'       visit_var = teal.transform::choices_selected(
#'         selected = "AVISIT",
#'         choices = c("AVISIT")
#'       ),
#'       ongo_var = teal.transform::choices_selected(
#'         selected = "ongo_status",
#'         choices = c("ongo_status")
#'       ),
#'       anno_var = teal.transform::choices_selected(
#'         selected = c("SEX", "COUNTRY"),
#'         choices = c("SEX", "COUNTRY", "USUBJID")
#'       ),
#'       heat_var = teal.transform::choices_selected(
#'         selected = "AETOXGR",
#'         choices = c("AETOXGR")
#'       ),
#'       conmed_var = teal.transform::choices_selected(
#'         selected = "CMDECOD",
#'         choices = c("CMDECOD")
#'       ),
#'       plot_height = c(600, 200, 2000)
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
tm_g_heat_bygrade <- function(label,
                              sl_dataname,
                              ex_dataname,
                              ae_dataname,
                              cm_dataname = NA,
                              id_var,
                              visit_var,
                              ongo_var,
                              anno_var,
                              heat_var,
                              conmed_var = NULL,
                              fontsize = c(5, 3, 7),
                              plot_height = c(600L, 200L, 2000L),
                              plot_width = NULL) {
  logger::log_info("Initializing tm_g_heat_bygrade")
  args <- as.list(environment())

  checkmate::assert_string(label)
  checkmate::assert_string(sl_dataname)
  checkmate::assert_string(ex_dataname)
  checkmate::assert_string(ae_dataname)
  checkmate::assert_string(cm_dataname, na.ok = TRUE)
  checkmate::assert_class(id_var, classes = "choices_selected")
  checkmate::assert_class(visit_var, classes = "choices_selected")
  checkmate::assert_class(ongo_var, classes = "choices_selected")
  checkmate::assert_class(anno_var, classes = "choices_selected")
  checkmate::assert_class(heat_var, classes = "choices_selected")
  checkmate::assert_class(conmed_var, classes = "choices_selected", null.ok = TRUE)
  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"
  )

  module(
    label = label,
    server = srv_g_heatmap_bygrade,
    server_args = list(
      label = label,
      sl_dataname = sl_dataname,
      ex_dataname = ex_dataname,
      ae_dataname = ae_dataname,
      cm_dataname = cm_dataname,
      plot_height = plot_height,
      plot_width = plot_width
    ),
    ui = ui_g_heatmap_bygrade,
    ui_args = args,
    datanames = "all"
  )
}

ui_g_heatmap_bygrade <- function(id, ...) {
  ns <- NS(id)
  args <- list(...)

  shiny::tagList(
    include_css_files("custom"),
    teal.widgets::standard_layout(
      output = teal.widgets::white_small_well(
        plot_decorate_output(id = ns(NULL))
      ),
      encoding = div(
        ### Reporter
        teal.reporter::simple_reporter_ui(ns("simple_reporter")),
        ###
        teal.widgets::optionalSelectInput(
          ns("id_var"),
          "ID Variable",
          choices = args$id_var$choices,
          selected = args$id_var$selected,
          multiple = FALSE
        ),
        teal.widgets::optionalSelectInput(
          ns("visit_var"),
          "Visit Variable",
          choices = args$visit_var$choices,
          selected = args$visit_var$selected,
          multiple = FALSE
        ),
        teal.widgets::optionalSelectInput(
          ns("ongo_var"),
          "Study Ongoing Status Variable",
          choices = args$ongo_var$choices,
          selected = args$ongo_var$selected,
          multiple = FALSE
        ),
        teal.widgets::optionalSelectInput(
          ns("anno_var"),
          "Annotation Variables",
          choices = args$anno_var$choices,
          selected = args$anno_var$selected,
          multiple = TRUE
        ),
        teal.widgets::optionalSelectInput(
          ns("heat_var"),
          "Heat Variable",
          choices = args$heat_var$choices,
          selected = args$heat_var$selected,
          multiple = FALSE
        ),
        helpText("Plot conmed"),
        div(
          class = "pretty-left-border",
          if (!is.na(args$cm_dataname)) {
            checkboxInput(
              ns("plot_cm"),
              "Yes",
              value = !is.na(args$cm_dataname)
            )
          }
        ),
        conditionalPanel(
          paste0("input['", ns("plot_cm"), "']"),
          teal.widgets::optionalSelectInput(
            ns("conmed_var"),
            "Conmed Variable",
            choices = args$conmed_var$choices,
            selected = args$conmed_var$selected,
            multiple = FALSE
          ),
          selectInput(
            ns("conmed_level"),
            "Conmed Levels",
            choices = args$conmed_var$choices,
            selected = args$conmed_var$selected,
            multiple = TRUE
          )
        ),
        ui_g_decorate(
          ns(NULL),
          fontsize = args$fontsize,
          titles = "Heatmap by Grade",
          footnotes = ""
        )
      ),
      forms = tagList(
        teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
        teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
      )
    )
  )
}

srv_g_heatmap_bygrade <- function(id,
                                  data,
                                  filter_panel_api,
                                  reporter,
                                  sl_dataname,
                                  ex_dataname,
                                  ae_dataname,
                                  cm_dataname,
                                  label,
                                  plot_height,
                                  plot_width) {
  with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
  with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
  checkmate::assert_class(data, "tdata")
  if (!is.na(sl_dataname)) checkmate::assert_names(sl_dataname, subset.of = names(data))
  if (!is.na(ex_dataname)) checkmate::assert_names(ex_dataname, subset.of = names(data))
  if (!is.na(ae_dataname)) checkmate::assert_names(ae_dataname, subset.of = names(data))
  if (!is.na(cm_dataname)) checkmate::assert_names(cm_dataname, subset.of = names(data))

  moduleServer(id, function(input, output, session) {
    iv <- reactive({
      ADSL <- data[[sl_dataname]]() # nolint
      ADEX <- data[[ex_dataname]]() # nolint
      ADAE <- data[[ae_dataname]]() # nolint
      if (isTRUE(input$plot_cm)) {
        ADCM <- data[[cm_dataname]]() # nolint
      }

      iv <- shinyvalidate::InputValidator$new()
      iv$add_rule("id_var", shinyvalidate::sv_required(
        message = "ID Variable is required"
      ))
      iv$add_rule("visit_var", shinyvalidate::sv_required(
        message = "Visit Variable is required"
      ))
      iv$add_rule("ongo_var", shinyvalidate::sv_required(
        message = "Study Ongoing Status Variable is required"
      ))
      iv$add_rule("ongo_var", shinyvalidate::sv_in_set(
        set = names(ADEX),
        message_fmt = sprintf("Study Ongoing Status must be a variable in %s", ex_dataname)
      ))
      iv$add_rule("ongo_var", ~ if (!is.logical(ADEX[[req(.)]])) {
        "Study Ongoing Status must be a logical variable"
      })
      iv$add_rule("anno_var", shinyvalidate::sv_required(
        message = "Annotation Variables is required"
      ))
      iv$add_rule("anno_var", ~ if (length(.) > 2L) {
        "No more than two Annotation Variables are allowed"
      })
      iv$add_rule("anno_var", shinyvalidate::sv_in_set(
        set = names(ADSL),
        message_fmt = sprintf("Study Ongoing Status must be a variable in %s", sl_dataname)
      ))
      iv$add_rule("anno_var", ~ if (isTRUE(input$id_var %in% .)) {
        sprintf("Deselect %s in Annotation Variables", input$id_var)
      })
      iv$add_rule("heat_var", shinyvalidate::sv_required(
        message = "Heat Variable is required"
      ))
      iv$enable()
      iv
    })
    iv_cm <- reactive({
      ADSL <- data[[sl_dataname]]() # nolint
      ADEX <- data[[ex_dataname]]() # nolint
      ADAE <- data[[ae_dataname]]() # nolint
      if (isTRUE(input$plot_cm)) {
        ADCM <- data[[cm_dataname]]() # nolint
      }

      iv_cm <- shinyvalidate::InputValidator$new()
      iv_cm$condition(~ isTRUE(input$plot_cm))
      iv_cm$add_rule("conmed_var", shinyvalidate::sv_required(
        message = "Conmed Variable is required"
      ))
      iv_cm$add_rule("conmed_var", shinyvalidate::sv_in_set(
        set = names(ADCM),
        message_fmt = sprintf("Conmed Variable must be a variable in %s", cm_dataname)
      ))
      iv_cm$add_rule("conmed_var", ~ if (!is.factor(ADCM[[.]])) {
        "Study Ongoing Status must be a factor variable"
      })
      iv_cm$add_rule("conmed_level", shinyvalidate::sv_required(
        "Select Conmed Levels"
      ))
      iv_cm$add_rule("conmed_level", ~ if (length(.) > 3L) {
        "No more than three Conmed Levels are allowed"
      })
      iv_cm$enable()
      iv_cm
    })

    decorate_output <- srv_g_decorate(
      id = NULL,
      plt = plot_r,
      plot_height = plot_height,
      plot_width = plot_width
    ) # nolint
    font_size <- decorate_output$font_size
    pws <- decorate_output$pws

    if (!is.na(cm_dataname)) {
      observeEvent(input$conmed_var, {
        ADCM <- data[[cm_dataname]]() # nolint
        choices <- levels(ADCM[[input$conmed_var]])

        updateSelectInput(
          session,
          "conmed_level",
          selected = choices[1:3],
          choices = choices
        )
      })
    }

    output_q <- shiny::debounce(
      millis = 200,
      r = reactive({
        ADSL <- data[[sl_dataname]]() # nolint
        ADEX <- data[[ex_dataname]]() # nolint
        ADAE <- data[[ae_dataname]]() # nolint

        teal::validate_has_data(ADSL, min_nrow = 1, msg = sprintf("%s contains no data", sl_dataname))
        teal::validate_inputs(iv(), iv_cm())
        if (isTRUE(input$plot_cm)) {
          shiny::validate(shiny::need(all(input$conmed_level %in% ADCM[[input$conmed_var]]), "Updating Conmed Levels"))
        }

        qenv <- teal.code::new_qenv(tdata2env(data), code = teal::get_code_tdata(data))
        if (isTRUE(input$plot_cm)) {
          ADCM <- data[[cm_dataname]]() # nolint
          qenv <- teal.code::eval_code(
            qenv,
            code = substitute(
              expr = {
                conmed_data <- ADCM %>%
                  filter(conmed_var_name %in% conmed_level)
                conmed_data[[conmed_var]] <-
                  factor(conmed_data[[conmed_var]], levels = unique(conmed_data[[conmed_var]]))
                formatters::var_labels(conmed_data)[conmed_var] <-
                  formatters::var_labels(ADCM, fill = FALSE)[conmed_var]
              },
              env = list(
                ADCM = as.name(cm_dataname),
                conmed_var = input$conmed_var,
                conmed_var_name = as.name(input$conmed_var),
                conmed_level = input$conmed_level
              )
            )
          )
        }

        qenv <- teal.code::eval_code(
          qenv,
          code = bquote(
            plot <- osprey::g_heat_bygrade(
              id_var = .(input$id_var),
              exp_data = .(as.name(ex_dataname)) %>% filter(PARCAT1 == "INDIVIDUAL"),
              visit_var = .(input$visit_var),
              ongo_var = .(input$ongo_var),
              anno_data = .(as.name(sl_dataname))[c(.(input$anno_var), .(input$id_var))],
              anno_var = .(input$anno_var),
              heat_data = .(as.name(ae_dataname)) %>%
                select(.(as.name(input$id_var)), .(as.name(input$visit_var)), .(as.name(input$heat_var))),
              heat_color_var = .(input$heat_var),
              conmed_data = .(if (isTRUE(input$plot_cm)) as.name("conmed_data")),
              conmed_var = .(if (isTRUE(input$plot_cm)) input$conmed_var),
            )
          )
        )
        teal.code::eval_code(qenv, quote(plot))
      })
    )

    plot_r <- reactive(output_q()[["plot"]])

    teal.widgets::verbatim_popup_srv(
      id = "warning",
      verbatim_content = reactive(teal.code::get_warnings(output_q())),
      title = "Warning",
      disabled = reactive(is.null(teal.code::get_warnings(output_q())))
    )

    teal.widgets::verbatim_popup_srv(
      id = "rcode",
      title = paste("R code for", label),
      verbatim_content = reactive(teal.code::get_code(output_q()))
    )

    ### REPORTER
    if (with_reporter) {
      card_fun <- function(comment) {
        card <- teal::TealReportCard$new()
        card$set_name("Heatmap by Grade")
        card$append_text("Heatmap by Grade", "header2")
        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(teal.code::get_code(output_q()), collapse = "\n"))
        card
      }
      teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
    }
  })
}

#' Patient Profile plot teal module
#'
#' @description
#' `r lifecycle::badge("stable")`
#'
#' Display patient profile plot as a shiny module
#'
#' @inheritParams teal.widgets::standard_layout
#' @inheritParams argument_convention
#' @param patient_id (\code{choices_seleced}) unique subject ID variable
#' @param sl_dataname (\code{character}) subject level dataset name,
#' needs to be available in the list passed to the \code{data}
#' argument of \code{\link[teal]{init}}
#' @param ex_dataname,ae_dataname,rs_dataname,cm_dataname,lb_dataname
#'        (\code{character(1)}) names of exposure, adverse events, response,
#'        concomitant medications, and labs datasets, respectively;
#'        must be available in the list passed to the \code{data}
#'        argument of \code{\link[teal]{init}}\cr
#'        set to NA (default) to omit from analysis
#' @param sl_start_date (\code{choices_selected}) study start date variable, usually set to
#'                      treatment start date or randomization date
#' @param ex_var (\code{choices_selected}) exposure variable to plot as each line \cr
#'               leave unspecified or set to \code{NULL} if exposure data is not available
#' @param ae_var (\code{choices_selected}) adverse event variable to plot as each line \cr
#'               leave unspecified or set to \code{NULL} if adverse events data is not available
#' @param ae_line_col_var (\code{choices_selected}) variable for coloring `AE` lines \cr
#'                        leave unspecified or set to \code{NULL} if adverse events data is not available
#' @param ae_line_col_opt aesthetic values to map color values
#'                        (named vector to map color values to each name).
#'                        If not \code{NULL}, please make sure this contains all possible
#'                        values for \code{ae_line_col_var} values. \cr
#'                        leave unspecified or set to \code{NULL} if adverse events data is not available
#' @param rs_var (\code{choices_selected}) response variable to plot as each line \cr
#'               leave unspecified or set to \code{NULL} if response data is not available
#' @param cm_var (\code{choices_selected}) concomitant medication variable
#'               to plot as each line \cr
#'               leave unspecified or set to \code{NULL} if concomitant medications data is not available
#' @param lb_var (\code{choices_selected}) lab variable to plot as each line \cr
#'               leave unspecified or set to \code{NULL} if labs data is not available
#' @param x_limit a single \code{character} string with two numbers
#'                separated by a comma indicating the x-axis limit,
#'                default is \code{"-28, 365"}
#'
#' @author Xuefeng Hou (houx14) \email{houx14@gene.com}
#' @author Tina Cho (chot) \email{tina.cho@roche.com}
#' @author Molly He (hey59) \email{hey59@gene.com}
#' @template author_qit3
#'
#' @inherit argument_convention return
#'
#' @details
#' As the patient profile module plots different domains in one plot, the study day (x-axis)
#' is derived for consistency based the start date of user's choice in the app (for example,
#' \code{ADSL.RANDDT} or \code{ADSL.TRTSDT}):
#' \itemize{
#' \item In \code{ADAE}, \code{ADEX}, and \code{ADCM}, it would be study day based on \code{ASTDT} and/or
#'     \code{AENDT} in reference to the start date
#' \item In \code{ADRS} and \code{ADLB}, it would be study day based on \code{ADT} in reference to
#'     the start date
#' }
#'
#' @export
#'
#' @examples
#' library(nestcolor)
#'
#' ADSL <- osprey::rADSL
#' ADAE <- osprey::rADAE %>%
#'   mutate(
#'     ASTDT = as.Date(ASTDTM),
#'     AENDT = as.Date(AENDTM)
#'   )
#' ADCM <- osprey::rADCM %>%
#'   mutate(
#'     ASTDT = as.Date(ASTDTM),
#'     AENDT = as.Date(AENDTM)
#'   )
#'
#' # The step below is to pre-process ADCM to legacy standard
#' ADCM <- ADCM %>%
#'   select(-starts_with("ATC")) %>%
#'   unique()
#'
#' ADRS <- osprey::rADRS %>%
#'   mutate(ADT = as.Date(ADTM))
#' ADEX <- osprey::rADEX %>%
#'   mutate(
#'     ASTDT = as.Date(ASTDTM),
#'     AENDT = as.Date(AENDTM)
#'   )
#' ADLB <- osprey::rADLB %>%
#'   mutate(
#'     ADT = as.Date(ADTM),
#'     LBSTRESN = as.numeric(LBSTRESC)
#'   )
#'
#' app <- init(
#'   data = cdisc_data(
#'     cdisc_dataset("ADSL", ADSL, code = "ADSL <- osprey::rADSL"),
#'     cdisc_dataset("ADRS", ADRS, code = "ADRS <- osprey::rADRS %>% mutate(ADT = as.Date(ADTM))"),
#'     cdisc_dataset("ADAE", ADAE,
#'       code = "ADAE <- osprey::rADAE %>%
#'               mutate(ASTDT = as.Date(ASTDTM),
#'                      AENDT = as.Date(AENDTM))"
#'     ),
#'     cdisc_dataset("ADCM", ADCM,
#'       code = "ADCM <- osprey::rADCM %>%
#'               mutate(ASTDT = as.Date(ASTDTM),
#'                      AENDT = as.Date(AENDTM))
#'               ADCM <- ADCM %>% select(-starts_with(\"ATC\")) %>% unique()",
#'       keys = c("STUDYID", "USUBJID", "ASTDTM", "CMSEQ", "CMDECOD")
#'     ),
#'     cdisc_dataset("ADLB", ADLB,
#'       code = "ADLB <- osprey::rADLB %>%
#'               mutate(ADT = as.Date(ADTM),
#'                      LBSTRESN = as.numeric(LBSTRESC))"
#'     ),
#'     cdisc_dataset("ADEX", ADEX,
#'       code = "ADEX <- osprey::rADEX %>%
#'               mutate(ASTDT = as.Date(ASTDTM),
#'                      AENDT = as.Date(AENDTM))"
#'     ),
#'     check = FALSE # set FALSE here to keep run time of example short, should be set to TRUE
#'   ),
#'   modules = modules(
#'     tm_g_patient_profile(
#'       label = "Patient Profile Plot",
#'       patient_id = teal.transform::choices_selected(
#'         choices = unique(ADSL$USUBJID),
#'         selected = unique(ADSL$USUBJID)[1]
#'       ),
#'       sl_dataname = "ADSL",
#'       ex_dataname = "ADEX",
#'       ae_dataname = "ADAE",
#'       rs_dataname = "ADRS",
#'       cm_dataname = "ADCM",
#'       lb_dataname = "ADLB",
#'       sl_start_date = teal.transform::choices_selected(
#'         selected = "TRTSDTM",
#'         choices = c("TRTSDTM", "RANDDT")
#'       ),
#'       ex_var = teal.transform::choices_selected(
#'         selected = "PARCAT2",
#'         choices = "PARCAT2"
#'       ),
#'       ae_var = teal.transform::choices_selected(
#'         selected = "AEDECOD",
#'         choices = c("AEDECOD", "AESOC")
#'       ),
#'       ae_line_col_var = teal.transform::choices_selected(
#'         selected = "AESER",
#'         choices = c("AESER", "AEREL")
#'       ),
#'       ae_line_col_opt = c("Y" = "red", "N" = "blue"),
#'       rs_var = teal.transform::choices_selected(
#'         selected = "PARAMCD",
#'         choices = "PARAMCD"
#'       ),
#'       cm_var = teal.transform::choices_selected(
#'         selected = "CMDECOD",
#'         choices = c("CMDECOD", "CMCAT")
#'       ),
#'       lb_var = teal.transform::choices_selected(
#'         selected = "LBTESTCD",
#'         choices = c("LBTESTCD", "LBCAT")
#'       ),
#'       x_limit = "-28, 750",
#'       plot_height = c(1200, 400, 5000)
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
tm_g_patient_profile <- function(label = "Patient Profile Plot",
                                 patient_id,
                                 sl_dataname,
                                 ex_dataname = NA,
                                 ae_dataname = NA,
                                 rs_dataname = NA,
                                 cm_dataname = NA,
                                 lb_dataname = NA,
                                 sl_start_date,
                                 ex_var = NULL,
                                 ae_var = NULL,
                                 ae_line_col_var = NULL,
                                 ae_line_col_opt = NULL,
                                 rs_var = NULL,
                                 cm_var = NULL,
                                 lb_var = NULL,
                                 x_limit = "-28, 365",
                                 plot_height = c(1200L, 400L, 5000L),
                                 plot_width = NULL,
                                 pre_output = NULL,
                                 post_output = NULL) {
  args <- as.list(environment())
  checkmate::assert_string(label)
  checkmate::assert_string(sl_dataname)
  checkmate::assert_string(ex_dataname, na.ok = TRUE)
  checkmate::assert_string(ae_dataname, na.ok = TRUE)
  checkmate::assert_string(rs_dataname, na.ok = TRUE)
  checkmate::assert_string(cm_dataname, na.ok = TRUE)
  checkmate::assert_string(lb_dataname, na.ok = TRUE)
  checkmate::assert_character(c(sl_dataname, ex_dataname, rs_dataname, cm_dataname, lb_dataname),
    any.missing = TRUE, all.missing = FALSE
  )
  checkmate::assert_class(sl_start_date, classes = "choices_selected")
  checkmate::assert_class(ex_var, classes = "choices_selected", null.ok = TRUE)
  checkmate::assert_class(ae_var, classes = "choices_selected", null.ok = TRUE)
  checkmate::assert_class(ae_line_col_var, classes = "choices_selected", null.ok = TRUE)
  checkmate::assert_class(rs_var, classes = "choices_selected", null.ok = TRUE)
  checkmate::assert_class(cm_var, classes = "choices_selected", null.ok = TRUE)
  checkmate::assert_class(lb_var, classes = "choices_selected", null.ok = TRUE)
  checkmate::assert_string(x_limit)
  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"
  )

  module(
    label = label,
    ui = ui_g_patient_profile,
    ui_args = args,
    server = srv_g_patient_profile,
    server_args = list(
      sl_dataname = sl_dataname,
      ex_dataname = ex_dataname,
      ae_dataname = ae_dataname,
      rs_dataname = rs_dataname,
      cm_dataname = cm_dataname,
      lb_dataname = lb_dataname,
      ae_line_col_opt = ae_line_col_opt,
      label = label,
      plot_height = plot_height,
      plot_width = plot_width
    ),
    datanames = "all"
  )
}

ui_g_patient_profile <- function(id, ...) {
  a <- list(...)
  ns <- NS(id)
  checkboxes <- c(a$ex_dataname, a$ae_dataname, a$rs_dataname, a$lb_dataname, a$cm_dataname)

  shiny::tagList(
    include_css_files("custom"),
    teal.widgets::standard_layout(
      output = teal.widgets::white_small_well(
        teal.widgets::plot_with_settings_ui(id = ns("patientprofileplot"))
      ),
      encoding = div(
        ### Reporter
        teal.reporter::simple_reporter_ui(ns("simple_reporter")),
        ###
        tags$label("Encodings", class = "text-primary"),
        selectizeInput(
          ns("patient_id"),
          "Patient ID",
          choices = a$patient_id$choices,
          selected = a$patient_id$selected
        ),
        div(
          tagList(
            helpText("Select", tags$code("ADaM"), "Domains"),
            checkboxGroupInput(
              inputId = ns("select_ADaM"),
              label = NULL,
              choices = checkboxes[!is.na(checkboxes)],
              selected = checkboxes[!is.na(checkboxes)]
            )
          )
        ),
        teal.widgets::optionalSelectInput(
          ns("sl_start_date"),
          "Start date variable",
          choices = a$sl_start_date$choices,
          selected = a$sl_start_date$selected,
          multiple = FALSE,
          label_help = helpText(
            "from ", tags$code("ADSL")
          )
        ),
        conditionalPanel(
          condition = sprintf("input['select_ADaM'].includes('%s')", a$ex_dataname),
          ns = ns,
          selectInput(
            ns("ex_var"),
            "Exposure variable",
            choices = a$ex_var$choices,
            selected = a$ex_var$selected,
            multiple = FALSE
          )
        ),
        conditionalPanel(
          condition = sprintf("input['select_ADaM'].includes('%s')", a$ae_dataname),
          ns = ns,
          teal.widgets::optionalSelectInput(
            ns("ae_var"),
            "Adverse Event variable",
            choices = a$ae_var$choices,
            selected = a$ae_var$selected,
            multiple = FALSE
          ),
          teal.widgets::optionalSelectInput(
            ns("ae_line_var"),
            "Adverse Event line color variable",
            choices = a$ae_line_col_var$choices,
            selected = a$ae_line_col_var$selected,
            multiple = FALSE
          )
        ),
        conditionalPanel(
          condition = sprintf("input['select_ADaM'].includes('%s')", a$rs_dataname),
          ns = ns,
          teal.widgets::optionalSelectInput(
            ns("rs_var"),
            "Tumor response variable",
            choices = a$rs_var$choices,
            selected = a$rs_var$selected,
            multiple = FALSE
          )
        ),
        conditionalPanel(
          condition = sprintf("input['select_ADaM'].includes('%s')", a$cm_dataname),
          ns = ns,
          teal.widgets::optionalSelectInput(
            ns("cm_var"),
            "Concomitant medicine variable",
            choices = a$cm_var$choices,
            selected = a$cm_var$selected,
            multiple = FALSE
          )
        ),
        conditionalPanel(
          condition = sprintf("input['select_ADaM'].includes('%s')", a$lb_dataname),
          ns = ns,
          teal.widgets::optionalSelectInput(
            ns("lb_var"),
            "Lab variable",
            choices = a$lb_var$choices,
            selected = a$lb_var$selected,
            multiple = FALSE
          ),
          selectInput(
            ns("lb_var_show"),
            "Lab values",
            choices = a$lb_var$choices,
            selected = a$lb_var$selected,
            multiple = TRUE
          )
        ),
        textInput(
          ns("x_limit"),
          label = div(
            "Study Days Range",
            tags$br(),
            helpText("Enter TWO numeric values of study days range, separated by comma (eg. -28, 750)")
          ),
          value = a$x_limit
        )
      ),
      forms = tagList(
        teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
        teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
      ),
      pre_output = a$pre_output,
      post_output = a$post_output
    )
  )
}

srv_g_patient_profile <- function(id,
                                  data,
                                  filter_panel_api,
                                  reporter,
                                  sl_dataname,
                                  ex_dataname,
                                  ae_dataname,
                                  rs_dataname,
                                  lb_dataname,
                                  cm_dataname,
                                  label,
                                  ae_line_col_opt,
                                  plot_height,
                                  plot_width) {
  with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
  with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelApi")
  checkmate::assert_class(data, "tdata")
  if (!is.na(ex_dataname)) checkmate::assert_names(ex_dataname, subset.of = names(data))
  if (!is.na(ae_dataname)) checkmate::assert_names(ae_dataname, subset.of = names(data))
  if (!is.na(rs_dataname)) checkmate::assert_names(rs_dataname, subset.of = names(data))
  if (!is.na(lb_dataname)) checkmate::assert_names(lb_dataname, subset.of = names(data))
  if (!is.na(cm_dataname)) checkmate::assert_names(cm_dataname, subset.of = names(data))
  checkboxes <- c(ex_dataname, ae_dataname, rs_dataname, lb_dataname, cm_dataname)
  moduleServer(id, function(input, output, session) {
    select_plot <- reactive(
      vapply(checkboxes, function(x) x %in% input$select_ADaM, logical(1L))
    )

    if (!is.na(lb_dataname)) {
      observeEvent(input$lb_var, ignoreNULL = TRUE, {
        ADLB <- data[[lb_dataname]]() # nolint
        choices <- unique(ADLB[[input$lb_var]])
        choices_selected <- if (length(choices) > 5) choices[1:5] else choices

        updateSelectInput(
          session,
          "lb_var_show",
          selected = choices_selected,
          choices = choices
        )
      })
    }

    iv <- reactive({
      iv <- shinyvalidate::InputValidator$new()
      iv$add_rule("select_ADaM", shinyvalidate::sv_required(
        message = "At least one ADaM data set is required"
      ))
      iv$add_rule("sl_start_date", shinyvalidate::sv_required(
        message = "Date variable is required"
      ))
      if (isTRUE(select_plot()[ex_dataname])) {
        iv$add_rule("ex_var", shinyvalidate::sv_required(
          message = "Exposure variable is required"
        ))
      }
      if (isTRUE(select_plot()[ae_dataname])) {
        iv$add_rule("ae_var", shinyvalidate::sv_required(
          message = "Adverse Event variable is required"
        ))
        iv$add_rule("ae_line_var", shinyvalidate::sv_optional())
        iv$add_rule("ae_line_var", ~ if (length(levels(data[[ae_dataname]]()[[.]])) > length(ae_line_col_opt)) {
          "Not enough colors provided for Adverse Event line color, unselect"
        })
      }
      if (isTRUE(select_plot()[rs_dataname])) {
        iv$add_rule("rs_var", shinyvalidate::sv_required(
          message = "Tumor response variable is required"
        ))
      }
      if (isTRUE(select_plot()[cm_dataname])) {
        iv$add_rule("cm_var", shinyvalidate::sv_required(
          message = "Concomitant medicine variable is required"
        ))
      }
      if (isTRUE(select_plot()[lb_dataname])) {
        iv$add_rule("lb_var", shinyvalidate::sv_required(
          message = "Lab variable is required"
        ))
        iv$add_rule("lb_var_show", shinyvalidate::sv_required(
          message = "At least one Lab value is required"
        ))
        rule_diff <- function(value, other) {
          if (isTRUE(any(value == other))) {
            "Lab variable and Lab value must be different"
          }
        }
        iv$add_rule("lb_var", rule_diff, other = input$lb_var_show)
        iv$add_rule("lb_var_show", rule_diff, other = input$lb_var)
      }
      iv$add_rule("x_limit", shinyvalidate::sv_required(
        message = "Study Days Range is required"
      ))
      iv$add_rule("x_limit", ~ if (anyNA(suppressWarnings(as_numeric_from_comma_sep_str(.)))) {
        "Study Days Range is invalid"
      })
      iv$add_rule("x_limit", ~ if (length(suppressWarnings(as_numeric_from_comma_sep_str(.))) != 2L) {
        "Study Days Range must be two values"
      })
      iv$add_rule("x_limit", ~ if (!identical(order(suppressWarnings(as_numeric_from_comma_sep_str(.))), 1:2)) {
        "Study Days Range mut be: first lower, then upper limit"
      })
      iv$enable()
      iv
    })

    # render plot
    output_q <- shiny::debounce(
      millis = 200,
      r = reactive({
        teal::validate_inputs(iv())

        # get inputs ---
        patient_id <- input$patient_id # nolint
        sl_start_date <- input$sl_start_date # nolint
        ae_var <- input$ae_var
        ae_line_col_var <- input$ae_line_var
        rs_var <- input$rs_var
        cm_var <- input$cm_var
        ex_var <- input$ex_var
        lb_var <- input$lb_var
        x_limit <- input$x_limit
        lb_var_show <- input$lb_var_show

        adrs_vars <- unique(c(
          "USUBJID", "STUDYID", "PARAMCD",
          "PARAM", "AVALC", "AVAL", "ADY",
          "ADT", rs_var
        ))
        adae_vars <- unique(c(
          "USUBJID", "STUDYID", "ASTDT",
          "AENDT", "AESOC", "AEDECOD",
          "AESER", "AETOXGR", "AEREL",
          "ASTDY", "AENDY",
          ae_var, ae_line_col_var
        ))
        adcm_vars <- unique(c(
          "USUBJID", "STUDYID", "ASTDT",
          "AENDT", "ASTDT", "CMDECOD",
          "ASTDY", "AENDY", "CMCAT",
          cm_var
        ))
        adex_vars <- unique(c(
          "USUBJID", "STUDYID", "ASTDT",
          "AENDT", "PARCAT2", "AVAL",
          "AVALU", "PARAMCD", "PARCAT1",
          "PARCAT2", ex_var
        ))
        adlb_vars <- unique(c(
          "USUBJID", "STUDYID", "ANRIND", "LBSEQ",
          "PARAMCD", "BASETYPE", "ADT", "AVISITN",
          "LBSTRESN", "LBCAT", "LBTESTCD",
          lb_var
        ))

        # get ADSL dataset ---
        ADSL <- data[[sl_dataname]]() # nolint

        ADEX <- NULL # nolint
        if (isTRUE(select_plot()[ex_dataname])) {
          ADEX <- data[[ex_dataname]]() # nolint
          teal::validate_has_variable(ADEX, adex_vars)
        }
        ADAE <- NULL # nolint
        if (isTRUE(select_plot()[ae_dataname])) {
          ADAE <- data[[ae_dataname]]() # nolint
          teal::validate_has_variable(ADAE, adae_vars)
        }
        ADRS <- NULL # nolint
        if (isTRUE(select_plot()[rs_dataname])) {
          ADRS <- data[[rs_dataname]]() # nolint
          teal::validate_has_variable(ADRS, adrs_vars)
        }
        ADCM <- NULL # nolint
        if (isTRUE(select_plot()[cm_dataname])) {
          ADCM <- data[[cm_dataname]]() # nolint
          teal::validate_has_variable(ADCM, adcm_vars)
        }
        ADLB <- NULL # nolint
        if (isTRUE(select_plot()[lb_dataname])) {
          ADLB <- data[[lb_dataname]]() # nolint
          teal::validate_has_variable(ADLB, adlb_vars)
        }

        empty_rs <- FALSE
        empty_ae <- FALSE
        empty_cm <- FALSE
        empty_ex <- FALSE
        empty_lb <- FALSE

        q1 <- teal.code::eval_code(
          teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)),
          code = substitute(
            expr = {
              ADSL <- ADSL %>% # nolint
                filter(USUBJID == patient_id) %>%
                group_by(USUBJID) %>%
                mutate(
                  max_date = pmax(as.Date(LSTALVDT), as.Date(DTHDT), na.rm = TRUE),
                  max_day = as.numeric(difftime(as.Date(max_date), as.Date(sl_start_date), units = "days")) +
                    (as.Date(max_date) >= as.Date(sl_start_date))
                )
            },
            env = list(
              ADSL = as.name(sl_dataname),
              sl_start_date = as.name(sl_start_date),
              patient_id = patient_id
            )
          )
        )

        # ADSL with single subject
        validate(
          need(
            nrow(q1[["ADSL"]]) >= 1,
            paste(
              "Subject",
              patient_id,
              "not found in the dataset. Perhaps they have been filtered out by the filter panel?"
            )
          )
        )

        # name for ae_line_col
        q1 <- if (!is.null(ae_line_col_var) && is.data.frame(ADAE)) {
          teal.code::eval_code(
            q1,
            code = substitute(
              expr = ae_line_col_name <- formatters::var_labels(ADAE, fill = FALSE)[ae_line_col_var],
              env = list(ADAE = as.name(ae_dataname), ae_line_col_var = ae_line_col_var)
            )
          )
        } else {
          teal.code::eval_code(q1, code = quote(ae_line_col_name <- NULL))
        }

        q1 <- if (isTRUE(select_plot()[ae_dataname])) {
          if (all(ADAE$USUBJID %in% ADSL$USUBJID)) {
            qq <- teal.code::eval_code(
              q1,
              code = substitute(
                expr = {
                  # ADAE
                  ADAE <- ADAE[, adae_vars] # nolint

                  ADAE <- ADSL %>% # nolint
                    left_join(ADAE, by = c("STUDYID", "USUBJID")) %>% # nolint
                    as.data.frame() %>%
                    filter(!is.na(ASTDT), !is.na(AENDT)) %>%
                    mutate(
                      ASTDY = as.numeric(difftime(ASTDT, as.Date(sl_start_date), units = "days")) +
                        (ASTDT >= as.Date(sl_start_date)),
                      AENDY = as.numeric(difftime(AENDT, as.Date(sl_start_date), units = "days")) +
                        (AENDT >= as.Date(sl_start_date))
                    ) %>%
                    select(c(adae_vars, ASTDY, AENDY))
                  formatters::var_labels(ADAE)[ae_line_col_var] <- # nolint
                    formatters::var_labels(ADAE, fill = FALSE)[ae_line_col_var]
                },
                env = list(
                  ADSL = as.name(sl_dataname),
                  ADAE = as.name(ae_dataname),
                  sl_start_date = as.name(sl_start_date),
                  ae_line_col_var = ae_line_col_var,
                  adae_vars = adae_vars
                )
              )
            ) %>%
              teal.code::eval_code(
                code = substitute(
                  expr = ae <- list(
                    data = data.frame(ADAE),
                    var = as.vector(ADAE[, ae_var]),
                    line_col = line_col,
                    line_col_legend = line_col_legend,
                    line_col_opt = line_col_opt
                  ),
                  env = list(
                    ADAE = as.name(ae_dataname),
                    ae_var = ae_var,
                    line_col = if (!is.null(ae_line_col_var)) bquote(as.vector(ADAE[, .(ae_line_col_var)])) else NULL,
                    line_col_legend = ae_line_col_var,
                    line_col_opt = ae_line_col_opt
                  )
                )
              )
            ADAE <- qq[[ae_dataname]] # nolint
            if (is.null(ADAE) | nrow(ADAE) == 0) {
              empty_ae <- TRUE
            }
            qq
          } else {
            empty_ae <- TRUE
            teal.code::eval_code(q1, code = quote(ae <- NULL))
          }
        } else {
          teal.code::eval_code(q1, code = quote(ae <- NULL))
        }

        q1 <- if (isTRUE(select_plot()[rs_dataname])) {
          if (all(ADRS$USUBJID %in% ADSL$USUBJID)) {
            qq <- teal.code::eval_code(
              q1,
              code = substitute(
                expr = {
                  ADRS <- ADRS[, adrs_vars] # nolint
                  ADRS <- ADSL %>% # nolint
                    left_join(ADRS, by = c("STUDYID", "USUBJID")) %>% # nolint
                    as.data.frame() %>%
                    mutate(
                      ADY = as.numeric(difftime(ADT, as.Date(sl_start_date), units = "days")) +
                        (ADT >= as.Date(sl_start_date))
                    ) %>%
                    select(USUBJID, PARAMCD, PARAM, AVALC, AVAL, ADY, ADT) %>%
                    filter(is.na(ADY) == FALSE)
                  rs <- list(data = data.frame(ADRS), var = as.vector(ADRS[, rs_var]))
                },
                env = list(
                  ADRS = as.name(rs_dataname),
                  adrs_vars = adrs_vars,
                  sl_start_date = as.name(sl_start_date),
                  rs_var = rs_var
                )
              )
            )
            ADRS <- qq[[rs_dataname]] # nolint
            if (is.null(ADRS) || nrow(ADRS) == 0) {
              empty_rs <- TRUE
            }
            qq
          } else {
            empty_rs <- TRUE
            teal.code::eval_code(q1, expression = quote(rs <- NULL))
          }
        } else {
          teal.code::eval_code(q1, code = quote(rs <- NULL))
        }

        q1 <- if (isTRUE(select_plot()[cm_dataname])) {
          if (all(ADCM$USUBJID %in% ADSL$USUBJID)) {
            qq <- teal.code::eval_code(
              q1,
              code = substitute(
                expr = {
                  # ADCM
                  ADCM <- ADCM[, adcm_vars] # nolint
                  ADCM <- ADSL %>% # nolint
                    left_join(ADCM, by = c("STUDYID", "USUBJID")) %>% # nolint
                    as.data.frame() %>%
                    filter(!is.na(ASTDT), !is.na(AENDT)) %>%
                    mutate(
                      ASTDY = as.numeric(difftime(ASTDT, as.Date(sl_start_date), units = "days")) +
                        (ASTDT >= as.Date(sl_start_date)),
                      AENDY = as.numeric(difftime(AENDT, as.Date(sl_start_date), units = "days")) +
                        (AENDT >= as.Date(sl_start_date))
                    ) %>%
                    select(USUBJID, ASTDT, AENDT, ASTDY, AENDY, !!quo(cm_var))
                  if (length(unique(ADCM$USUBJID)) > 0) {
                    ADCM <- ADCM[which(ADCM$AENDY >= -28 | is.na(ADCM$AENDY) == TRUE # nolint
                    & is.na(ADCM$ASTDY) == FALSE), ]
                  }
                  cm <- list(data = data.frame(ADCM), var = as.vector(ADCM[, cm_var]))
                },
                env = list(
                  ADSL = as.name(sl_dataname),
                  ADCM = as.name(cm_dataname),
                  sl_start_date = as.name(sl_start_date),
                  adcm_vars = adcm_vars,
                  cm_var = cm_var
                )
              )
            )

            ADCM <- qq[[cm_dataname]] # nolint
            if (is.null(ADCM) | nrow(ADCM) == 0) {
              empty_cm <- TRUE
            }
            qq
          } else {
            empty_cm <- TRUE
            teal.code::eval_code(q1, code = quote(cm <- NULL))
          }
        } else {
          teal.code::eval_code(q1, code = quote(cm <- NULL))
        }

        q1 <- if (isTRUE(select_plot()[ex_dataname])) {
          if (all(ADEX$USUBJID %in% ADSL$USUBJID)) {
            qq <- teal.code::eval_code(
              q1,
              code = substitute(
                expr = {
                  # ADEX
                  ADEX <- ADEX[, adex_vars] # nolint
                  ADEX <- ADSL %>% # nolint
                    left_join(ADEX, by = c("STUDYID", "USUBJID")) %>% # nolint
                    as.data.frame() %>%
                    filter(PARCAT1 == "INDIVIDUAL" & PARAMCD == "DOSE" & !is.na(AVAL) & !is.na(ASTDT)) %>%
                    select(USUBJID, ASTDT, PARCAT2, AVAL, AVALU, PARAMCD, sl_start_date)

                  ADEX <- split(ADEX, ADEX$USUBJID) %>% # nolint
                    lapply(function(pinfo) {
                      pinfo %>%
                        arrange(PARCAT2, PARAMCD, ASTDT) %>%
                        ungroup() %>%
                        mutate(
                          diff = c(0, diff(AVAL, lag = 1)),
                          Modification = case_when(
                            diff < 0 ~ "Decrease",
                            diff > 0 ~ "Increase",
                            diff == 0 ~ "None"
                          ),
                          ASTDT_dur = as.numeric(difftime(as.Date(ASTDT), as.Date(sl_start_date), units = "days")) +
                            (as.Date(ASTDT) >= as.Date(sl_start_date))
                        )
                    }) %>%
                    Reduce(rbind, .) %>%
                    as.data.frame() %>%
                    select(-diff)
                  ex <- list(data = data.frame(ADEX), var = as.vector(ADEX[, ex_var]))
                },
                env = list(
                  ADSL = as.name(sl_dataname),
                  ADEX = as.name(ex_dataname),
                  adex_vars = adex_vars,
                  sl_start_date = as.name(sl_start_date),
                  ex_var = ex_var
                )
              )
            )
            ADEX <- qq[[ex_dataname]] # nolint
            if (is.null(ADEX) | nrow(ADEX) == 0) {
              empty_ex <- TRUE
            }
            qq
          } else {
            empty_ex <- TRUE
            teal.code::eval_code(q1, code = quote(ex <- NULL))
          }
        } else {
          teal.code::eval_code(q1, code = quote(ex <- NULL))
        }

        q1 <- if (isTRUE(select_plot()[lb_dataname])) {
          if (all(ADLB$USUBJID %in% ADSL$USUBJID)) {
            qq <- teal.code::eval_code(
              q1,
              code = substitute(
                expr = {
                  ADLB <- ADLB[, adlb_vars] # nolint
                  ADLB <- ADSL %>% # nolint
                    left_join(ADLB, by = c("STUDYID", "USUBJID")) %>%
                    as.data.frame() %>%
                    mutate(
                      ANRIND = factor(ANRIND, levels = c("HIGH", "LOW", "NORMAL"))
                    ) %>%
                    filter(!is.na(LBSTRESN) & !is.na(ANRIND) & .data[[lb_var]] %in% lb_var_show) %>%
                    as.data.frame() %>%
                    select(
                      USUBJID, STUDYID, LBSEQ, PARAMCD, BASETYPE, ADT, AVISITN, sl_start_date, LBTESTCD, ANRIND, lb_var
                    ) %>% # nolint
                    mutate(
                      ADY = as.numeric(difftime(ADT, as.Date(sl_start_date), units = "days")) +
                        (ADT >= as.Date(sl_start_date))
                    )
                  lb <- list(data = data.frame(ADLB), var = as.vector(ADLB[, lb_var]))
                },
                env = list(
                  ADLB = as.name(lb_dataname),
                  ADSL = as.name(sl_dataname),
                  adlb_vars = adlb_vars,
                  sl_start_date = as.name(sl_start_date),
                  lb_var = lb_var,
                  lb_var_show = lb_var_show
                )
              )
            )

            ADLB <- qq[[lb_dataname]] # nolint
            if (is.null(ADLB) | nrow(ADLB) == 0) {
              empty_lb <- TRUE
            }
            qq
          } else {
            empty_lb <- TRUE
            teal.code::eval_code(q1, code = quote(lb <- NULL))
          }
        } else {
          teal.code::eval_code(q1, code = quote(lb <- NULL))
        }

        # Check the subject has information in at least one selected domain
        empty_data_check <- structure(
          c(empty_ex, empty_ae, empty_rs, empty_lb, empty_cm),
          names = checkboxes
        )

        validate(need(
          any(!empty_data_check & select_plot()),
          "The subject does not have information in any selected domain."
        ))

        # Check the subject has information in all the selected domains
        if (any(empty_data_check & select_plot())) {
          showNotification(
            paste0(
              "This subject does not have information in the ",
              paste(checkboxes[empty_data_check & select_plot()], collapse = ", "),
              " domain."
            ),
            duration = 8,
            type = "warning"
          )
        }

        # Convert x_limit to numeric vector
        if (!is.null(x_limit) || x_limit != "") {
          q1 <- teal.code::eval_code(
            q1,
            code = bquote(x_limit <- as.numeric(unlist(strsplit(.(x_limit), ","))))
          )
          x_limit <- q1[["x_limit"]]
        }

        q1 <- teal.code::eval_code(
          q1,
          code = substitute(
            expr = {
              plot <- osprey::g_patient_profile(
                ex = ex,
                ae = ae,
                rs = rs,
                cm = cm,
                lb = lb,
                arrow_end_day = ADSL[["max_day"]],
                xlim = x_limit,
                xlab = "Study Day",
                title = paste("Patient Profile: ", patient_id)
              )
              plot
            },
            env = list(
              patient_id = patient_id,
              ADSL = as.name(sl_dataname)
            )
          )
        )
      })
    )

    plot_r <- reactive(output_q()[["plot"]])

    pws <- teal.widgets::plot_with_settings_srv(
      id = "patientprofileplot",
      plot_r = plot_r,
      height = plot_height,
      width = plot_width
    )

    teal.widgets::verbatim_popup_srv(
      id = "warning",
      verbatim_content = reactive(teal.code::get_warnings(output_q())),
      title = "Warning",
      disabled = reactive(is.null(teal.code::get_warnings(output_q())))
    )

    teal.widgets::verbatim_popup_srv(
      id = "rcode",
      title = paste("R code for", label),
      verbatim_content = reactive(teal.code::get_code(output_q()))
    )

    ### REPORTER
    if (with_reporter) {
      card_fun <- function(comment) {
        card <- teal::TealReportCard$new()
        card$set_name("Patient Profile")
        card$append_text("Patient Profile", "header2")
        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(teal.code::get_code(output_q()), collapse = "\n"))
        card
      }
      teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
    }
  })
}

#' teal module for the `AE` by subgroups
#'
#' @description
#' `r lifecycle::badge("stable")`
#'
#' Display the `AE` by subgroups plot as a teal module
#'
#' @inheritParams teal.widgets::standard_layout
#' @inheritParams argument_convention
#' @param group_var (`choices_selected`) subgroups variables. See [teal.transform::choices_selected()] for details.
#'
#' @author Liming Li (Lil128) \email{liming.li@roche.com}
#' @author Molly He (hey59) \email{hey59@gene.com}
#'
#' @inherit argument_convention return
#'
#' @export
#'
#' @examples
#' # Example using stream (ADaM) dataset
#' ADSL <- osprey::rADSL
#' ADAE <- osprey::rADAE
#'
#' app <- init(
#'   data = cdisc_data(
#'     cdisc_dataset("ADSL", ADSL, code = "ADSL <- osprey::rADSL"),
#'     cdisc_dataset("ADAE", ADAE, code = "ADAE <- osprey::rADAE"),
#'     check = TRUE
#'   ),
#'   modules = modules(
#'     tm_g_ae_sub(
#'       label = "AE by Subgroup",
#'       dataname = "ADAE",
#'       arm_var = teal.transform::choices_selected(
#'         selected = "ACTARMCD",
#'         choices = c("ACTARM", "ACTARMCD")
#'       ),
#'       group_var = teal.transform::choices_selected(
#'         selected = c("SEX", "REGION1", "RACE"),
#'         choices = c("SEX", "REGION1", "RACE")
#'       ),
#'       plot_height = c(600, 200, 2000)
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
tm_g_ae_sub <- function(label,
                        dataname,
                        arm_var,
                        group_var,
                        plot_height = c(600L, 200L, 2000L),
                        plot_width = NULL,
                        fontsize = c(5, 3, 7)) {
  logger::log_info("Initializing tm_g_ae_sub")
  checkmate::assert_class(arm_var, classes = "choices_selected")
  checkmate::assert_class(group_var, classes = "choices_selected")
  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"
  )

  module(
    label = label,
    server = srv_g_ae_sub,
    server_args = list(
      label = label,
      dataname = dataname,
      plot_height = plot_height,
      plot_width = plot_width
    ),
    ui = ui_g_ae_sub,
    ui_args = list(
      arm_var = arm_var,
      group_var = group_var,
      fontsize = fontsize
    ),
    datanames = c("ADSL", dataname)
  )
}

ui_g_ae_sub <- function(id, ...) {
  ns <- NS(id)
  args <- list(...)
  teal.widgets::standard_layout(
    output = teal.widgets::white_small_well(
      plot_decorate_output(id = ns(NULL))
    ),
    encoding = div(
      ### Reporter
      teal.reporter::simple_reporter_ui(ns("simple_reporter")),
      ###
      tags$label("Encodings", class = "text-primary"),
      helpText("Analysis data:", tags$code("ADAE")),
      teal.widgets::optionalSelectInput(
        ns("arm_var"),
        "Arm Variable",
        choices = args$arm_var$choices,
        selected = args$arm_var$selected
      ),
      selectInput(
        ns("arm_trt"),
        "Treatment",
        choices = args$arm_var$choices,
        selected = args$arm_var$selected
      ),
      selectInput(
        ns("arm_ref"),
        "Control",
        choices = args$arm_var$choices,
        selected = args$arm_var$selected
      ),
      checkboxInput(
        ns("arm_n"),
        "Show N in each arm",
        value = args$arm_n
      ),
      teal.widgets::optionalSelectInput(
        ns("groups"),
        "Group Variable",
        choices = args$group_var$choices,
        selected = args$group_var$selected,
        multiple = TRUE
      ),
      teal.widgets::panel_item(
        "Change group labels",
        uiOutput(ns("grouplabel_output"))
      ),
      teal.widgets::panel_item(
        "Additional plot settings",
        teal.widgets::optionalSelectInput(
          ns("ci"),
          "CI method",
          choices = ci_choices,
          selected = ci_choices[1]
        ),
        teal.widgets::optionalSliderInput(
          ns("conf_level"),
          "Significant Level",
          min = 0.5,
          max = 1,
          value = 0.95
        ),
        ui_g_decorate(
          ns(NULL),
          fontsize = args$fontsize,
          titles = "AE Table with Subgroups",
          footnotes = ""
        )
      )
    ),
    forms = tagList(
      teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
      teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
    )
  )
}

srv_g_ae_sub <- 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")
  checkmate::assert_class(data, "tdata")

  moduleServer(id, function(input, output, session) {
    iv <- reactive({
      ANL <- data[[dataname]]() # nolint
      ADSL <- data[["ADSL"]]() # nolint

      iv <- shinyvalidate::InputValidator$new()
      iv$add_rule("arm_var", shinyvalidate::sv_required(
        message = "Arm Variable is required"
      ))
      iv$add_rule("arm_var", ~ if (!is.factor(ANL[[.]])) {
        "Arm Var must be a factor variable, contact developer"
      })
      rule_diff <- function(value, other) {
        if (isTRUE(value == other)) "Control and Treatment must be different"
      }
      iv$add_rule("arm_trt", rule_diff, other = input$arm_ref)
      iv$add_rule("arm_ref", rule_diff, other = input$arm_trt)
      iv$add_rule("groups", shinyvalidate::sv_in_set(
        names(ANL),
        message_fmt = sprintf("Groups must be a variable in %s", dataname)
      ))
      iv$add_rule("groups", shinyvalidate::sv_in_set(
        names(ADSL),
        message_fmt = "Groups must be a variable in ADSL"
      ))
      iv$enable()
      iv
    })

    decorate_output <- srv_g_decorate(
      id = NULL,
      plt = plot_r,
      plot_height = plot_height,
      plot_width = plot_width
    )
    font_size <- decorate_output$font_size
    pws <- decorate_output$pws

    observeEvent(input$arm_var, ignoreNULL = TRUE, {
      arm_var <- input$arm_var
      ANL <- data[[dataname]]() # nolint

      anl_val <- ANL[[arm_var]]
      choices <- levels(anl_val)

      if (length(choices) == 1) {
        ref_index <- 1
      } else {
        ref_index <- 2
      }

      updateSelectInput(
        session,
        "arm_trt",
        selected = choices[1],
        choices = choices
      )
      updateSelectInput(
        session,
        "arm_ref",
        selected = choices[ref_index],
        choices = choices
      )
    })

    observeEvent(list(input$ci, input$conf_level, input$arm_trt, input$arm_ref), {
      diff_ci_method <- input$ci
      conf_level <- input$conf_level
      trt <- input$arm_trt
      ref <- input$arm_ref
      updateTextAreaInput(
        session,
        "foot",
        value = sprintf(
          "Note: %d%% CI is calculated using %s\nTRT: %s; CONT: %s",
          round(conf_level * 100),
          name_ci(diff_ci_method),
          trt,
          ref
        )
      )
    })

    observeEvent(input$groups, {
      ANL <- data[[dataname]]() # nolint
      output$grouplabel_output <- renderUI({
        grps <- input$groups
        lo <- lapply(seq_along(grps), function(index) {
          grp <- grps[index]
          choices <- levels(ANL[[grp]])
          sel <- teal.widgets::optionalSelectInput(
            session$ns(sprintf("groups__%s", index)),
            grp,
            choices,
            multiple = TRUE,
            selected = choices
          )
          textname <- sprintf("text_%s_out", index)
          txt <- uiOutput(session$ns(textname))
          observeEvent(
            eventExpr = input[[sprintf("groups__%s", index)]],
            handlerExpr = {
              output[[textname]] <- renderUI({
                if (!is.null(input[[sprintf("groups__%s", index)]])) {
                  l <- input[[sprintf("groups__%s", index)]]
                  l2 <- lapply(seq_along(l), function(i) {
                    nm <- sprintf("groups__%s__level__%s", index, i)
                    label <- sprintf("Label for %s, Level %s", grp, l[i])
                    textInput(session$ns(nm), label, l[i])
                  })
                  tagList(textInput(
                    session$ns(
                      sprintf("groups__%s__level__%s", index, "all")
                    ),
                    sprintf("Label for %s", grp), grp
                  ), l2)
                }
              })
            }
          )
          tagList(sel, txt)
        })
        ret <- tagList(lo)
        ret
      })
    })

    output_q <- shiny::debounce(
      millis = 200,
      r = reactive({
        ANL <- data[[dataname]]() # nolint
        ADSL <- data[["ADSL"]]() # nolint

        teal::validate_has_data(ANL, min_nrow = 10, msg = sprintf("%s has not enough data", dataname))

        teal::validate_inputs(iv())

        validate(need(
          input$arm_trt %in% ANL[[input$arm_var]] && input$arm_ref %in% ANL[[input$arm_var]],
          "Treatment or Control not found in Arm Variable. Perhaps they have been filtered out?"
        ))

        group_labels <- lapply(seq_along(input$groups), function(x) {
          items <- input[[sprintf("groups__%s", x)]]
          if (length(items) > 0) {
            l <- lapply(seq_along(items), function(y) {
              input[[sprintf("groups__%s__level__%s", x, y)]]
            })
            names(l) <- items
            l[["Total"]] <- input[[sprintf("groups__%s__level__%s", x, "all")]]
            l
          }
        })

        group_labels_call <- if (length(unlist(group_labels)) == 0) {
          quote(group_labels <- NULL)
        } else {
          bquote(group_labels <- setNames(.(group_labels), .(input$groups)))
        }

        q1 <- teal.code::eval_code(
          teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)),
          code = group_labels_call
        )
        q2 <- teal.code::eval_code(q1, code = "")
        teal.code::eval_code(
          q2,
          code = as.expression(c(
            bquote(
              plot <- osprey::g_ae_sub(
                id = .(as.name(dataname))$USUBJID,
                arm = as.factor(.(as.name(dataname))[[.(input$arm_var)]]),
                arm_sl = as.character(ADSL[[.(input$arm_var)]]),
                trt = .(input$arm_trt),
                ref = .(input$arm_ref),
                subgroups = .(as.name(dataname))[.(input$groups)],
                subgroups_sl = ADSL[.(input$groups)],
                subgroups_levels = group_labels,
                conf_level = .(input$conf_level),
                diff_ci_method = .(input$ci),
                fontsize = .(font_size()),
                arm_n = .(input$arm_n),
                draw = TRUE
              )
            ),
            quote(plot)
          ))
        )
      })
    )

    plot_r <- reactive(output_q()[["plot"]])

    teal.widgets::verbatim_popup_srv(
      id = "warning",
      verbatim_content = reactive(teal.code::get_warnings(output_q())),
      title = "Warning",
      disabled = reactive(is.null(teal.code::get_warnings(output_q())))
    )

    teal.widgets::verbatim_popup_srv(
      id = "rcode",
      verbatim_content = reactive(teal.code::get_code(output_q())),
      title = paste("R code for", label),
    )

    ### REPORTER
    if (with_reporter) {
      card_fun <- function(comment) {
        card <- teal::TealReportCard$new()
        card$set_name("AE Subgroups")
        card$append_text("AE Subgroups", "header2")
        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(teal.code::get_code(output_q()), collapse = "\n"))
        card
      }
      teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
    }
  })
}

#' Events by Term Plot Teal Module
#'
#' @description
#' `r lifecycle::badge("stable")`
#'
#' Display Events by Term plot as a shiny module
#'
#' @inheritParams teal.widgets::standard_layout
#' @inheritParams argument_convention
#' @param term_var \code{\link[teal.transform]{choices_selected}} object with all available choices
#' and pre-selected option names that can be used to specify the term for events
#'
#' @inherit argument_convention return
#'
#' @export
#'
#' @author Liming Li (lil128) \email{liming.li@roche.com}
#' @author Molly He (hey59) \email{hey59@gene.com}
#'
#' @examples
#' library(nestcolor)
#'
#' ADSL <- osprey::rADSL
#' ADAE <- osprey::rADAE
#'
#' app <- init(
#'   data = cdisc_data(
#'     cdisc_dataset("ADSL", ADSL, code = "ADSL <- osprey::rADSL"),
#'     cdisc_dataset("ADAE", ADAE, code = "ADAE <- osprey::rADAE"),
#'     check = TRUE
#'   ),
#'   modules = modules(
#'     tm_g_events_term_id(
#'       label = "Common AE",
#'       dataname = "ADAE",
#'       term_var = teal.transform::choices_selected(
#'         selected = "AEDECOD",
#'         choices = c(
#'           "AEDECOD", "AETERM",
#'           "AEHLT", "AELLT", "AEBODSYS"
#'         )
#'       ),
#'       arm_var = teal.transform::choices_selected(
#'         selected = "ACTARMCD",
#'         choices = c("ACTARM", "ACTARMCD")
#'       ),
#'       plot_height = c(600, 200, 2000)
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
tm_g_events_term_id <- function(label,
                                dataname,
                                term_var,
                                arm_var,
                                fontsize = c(5, 3, 7),
                                plot_height = c(600L, 200L, 2000L),
                                plot_width = NULL) {
  logger::log_info("Initializing tm_g_events_term_id")
  checkmate::assert_string(label)
  checkmate::assert_class(term_var, classes = "choices_selected")
  checkmate::assert_class(arm_var, classes = "choices_selected")
  checkmate::assert(
    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"
  )

  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,
    datanames = c("ADSL", dataname)
  )
}

ui_g_events_term_id <- function(id, ...) {
  ns <- NS(id)
  args <- list(...)
  teal.widgets::standard_layout(
    output = teal.widgets::white_small_well(
      plot_decorate_output(id = ns(NULL))
    ),
    encoding = div(
      ### Reporter
      teal.reporter::simple_reporter_ui(ns("simple_reporter")),
      ###
      teal.widgets::optionalSelectInput(
        ns("term"),
        "Term Variable",
        choices = args$term_var$choices,
        selected = args$term_var$selected
      ),
      teal.widgets::optionalSelectInput(
        ns("arm_var"),
        "Arm Variable",
        choices = args$arm_var$choices,
        selected = args$arm_var$selected
      ),
      selectInput(
        ns("arm_ref"),
        "Control",
        choices = args$arm_var$choices,
        selected = args$arm_var$selected
      ),
      selectInput(
        ns("arm_trt"),
        "Treatment",
        choices = args$arm_var$choices,
        selected = args$arm_var$selected
      ),
      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 = args$fontsize,
        titles = "Common AE Table",
        footnotes = ""
      )
    ),
    forms = tagList(
      teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
      teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
    )
  )
}

srv_g_events_term_id <- 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")
  checkmate::assert_class(data, "tdata")

  moduleServer(id, function(input, output, session) {
    iv <- reactive({
      iv <- shinyvalidate::InputValidator$new()
      iv$add_rule("term", shinyvalidate::sv_required(
        message = "Term Variable is required"
      ))
      iv$add_rule("arm_var", shinyvalidate::sv_required(
        message = "Arm Variable is required"
      ))
      rule_diff <- function(value, other) {
        if (isTRUE(value == other)) "Control and Treatment must be different"
      }
      iv$add_rule("arm_trt", rule_diff, other = input$arm_ref)
      iv$add_rule("arm_ref", rule_diff, other = input$arm_trt)
      iv$enable()
      iv
    })

    decorate_output <- srv_g_decorate(
      id = NULL, plt = plot_r, plot_height = plot_height, plot_width = plot_width
    )
    font_size <- decorate_output$font_size
    pws <- decorate_output$pws

    observeEvent(list(input$diff_ci_method, input$conf_level), {
      req(!is.null(input$diff_ci_method) && !is.null(input$conf_level))
      diff_ci_method <- input$diff_ci_method
      conf_level <- input$conf_level
      updateTextAreaInput(
        session,
        "foot",
        value = sprintf(
          "Note: %d%% CI is calculated using %s",
          round(conf_level * 100),
          name_ci(diff_ci_method)
        )
      )
    })


    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]]() # nolint

        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
    )

    output_q <- reactive({
      ANL <- data[[dataname]]() # nolint

      teal::validate_inputs(iv())

      shiny::validate(
        shiny::need(is.factor(ANL[[input$arm_var]]), "Arm Var must be a factor variable. Contact developer."),
        shiny::need(
          input$arm_trt %in% ANL[[req(input$arm_var)]] && input$arm_ref %in% ANL[[req(input$arm_var)]],
          "Cannot generate plot. The dataset does not contain subjects from both the control and treatment arms."
        )
      )

      adsl_vars <- unique(c("USUBJID", "STUDYID", input$arm_var)) # nolint
      anl_vars <- c("USUBJID", "STUDYID", input$term) # nolint

      q1 <- teal.code::eval_code(
        teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)),
        code = bquote(
          ANL <- merge( # nolint
            x = ADSL[, .(adsl_vars), drop = FALSE],
            y = .(as.name(dataname))[, .(anl_vars), drop = FALSE],
            all.x = FALSE,
            all.y = FALSE,
            by = c("USUBJID", "STUDYID")
          )
        )
      )

      teal::validate_has_data(q1[["ANL"]],
        min_nrow = 10,
        msg = "Analysis data set must have at least 10 data points"
      )

      q2 <- teal.code::eval_code(
        q1,
        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),
            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
          )
        )
      )

      teal.code::eval_code(q2, quote(plot))
    })

    plot_r <- reactive(output_q()[["plot"]])

    teal.widgets::verbatim_popup_srv(
      id = "warning",
      verbatim_content = reactive(teal.code::get_warnings(output_q())),
      title = "Warning",
      disabled = reactive(is.null(teal.code::get_warnings(output_q())))
    )

    teal.widgets::verbatim_popup_srv(
      id = "rcode",
      title = paste("R code for", label),
      verbatim_content = reactive(teal.code::get_code(output_q()))
    )

    ### REPORTER
    if (with_reporter) {
      card_fun <- function(comment) {
        card <- teal::TealReportCard$new()
        card$set_name("Events by Term")
        card$append_text("Events by Term", "header2")
        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(teal.code::get_code(output_q()), collapse = "\n"))
        card
      }
      teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
    }
  })
}

#' Teal module for the `AE` overview
#'
#' @description
#' `r lifecycle::badge("stable")`
#'
#' Display the `AE` overview plot as a shiny module
#'
#' @inheritParams teal.widgets::standard_layout
#' @inheritParams argument_convention
#' @param flag_var_anl ([`teal.transform::choices_selected`])
#'   `choices_selected` object with variables used to count adverse event
#'   sub-groups (e.g. Serious events, Related events, etc.)
#'
#' @inherit argument_convention return
#'
#' @export
#'
#' @examples
#' library(nestcolor)
#'
#' ADSL <- osprey::rADSL
#' ADAE <- osprey::rADAE
#'
#' # Add additional dummy causality flags.
#' add_event_flags <- function(dat) {
#'   dat <- dat %>%
#'     dplyr::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 <- ADAE %>% add_event_flags()
#'
#' app <- init(
#'   data = cdisc_data(
#'     cdisc_dataset("ADSL", ADSL, code = "ADSL <- osprey::rADSL"),
#'     cdisc_dataset("ADAE", ADAE,
#'       code =
#'         "ADAE <- osprey::rADAE
#'            add_event_flags <- function(dat) {
#'              dat <- dat %>%
#'                dplyr::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
#'            }
#'            # Generating user-defined event flags.
#'            ADAE <- ADAE %>% add_event_flags()"
#'     ),
#'     check = TRUE
#'   ),
#'   modules = modules(
#'     tm_g_ae_oview(
#'       label = "AE Overview",
#'       dataname = "ADAE",
#'       arm_var = teal.transform::choices_selected(
#'         selected = "ACTARM",
#'         choices = c("ACTARM", "ACTARMCD")
#'       ),
#'       flag_var_anl = teal.transform::choices_selected(
#'         selected = "AEREL1",
#'         choices = teal.transform::variable_choices(
#'           ADAE,
#'           c("TMPFL_SER", "TMPFL_REL", "TMPFL_GR5", "AEREL1", "AEREL2")
#'         ),
#'       ),
#'       plot_height = c(600, 200, 2000)
#'     )
#'   )
#' )
#' 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) {
  logger::log_info("Initializing tm_g_ae_oview")
  checkmate::assert_class(arm_var, classes = "choices_selected")
  checkmate::assert_class(flag_var_anl, classes = "choices_selected")
  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"
  )

  args <- as.list(environment())

  module(
    label = label,
    server = srv_g_ae_oview,
    server_args = list(
      label = label,
      dataname = dataname,
      plot_height = plot_height,
      plot_width = plot_width
    ),
    ui = ui_g_ae_oview,
    ui_args = args,
    datanames = c("ADSL", dataname)
  )
}

ui_g_ae_oview <- function(id, ...) {
  ns <- NS(id)
  args <- list(...)
  teal.widgets::standard_layout(
    output = teal.widgets::white_small_well(
      plot_decorate_output(id = ns(NULL))
    ),
    encoding = div(
      ### Reporter
      teal.reporter::simple_reporter_ui(ns("simple_reporter")),
      ###
      teal.widgets::optionalSelectInput(
        ns("arm_var"),
        "Arm Variable",
        choices = args$arm_var$choices,
        selected = args$arm_var$selected,
        multiple = FALSE
      ),
      selectInput(
        ns("arm_ref"),
        "Control",
        choices = args$arm_var$choices,
        selected = args$arm_var$selected
      ),
      selectInput(
        ns("arm_trt"),
        "Treatment",
        choices = args$arm_var$choices,
        selected = args$arm_var$selected
      ),
      selectInput(
        ns("flag_var_anl"),
        "Flags",
        choices = args$flag_var_anl$choices,
        selected = args$flag_var_anl$selected,
        multiple = TRUE
      ),
      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],
          multiple = FALSE
        ),
        teal.widgets::optionalSliderInput(
          ns("conf_level"),
          "Confidence Level",
          min = 0.5,
          max = 1,
          value = 0.95
        )
      ),
      teal.widgets::optionalSelectInput(
        ns("axis"),
        "Axis Side",
        choices = c("Left" = "left", "Right" = "right"),
        selected = "left",
        multiple = FALSE
      ),
      ui_g_decorate(
        ns(NULL),
        fontsize = args$fontsize,
        titles = "AE Overview",
        footnotes = ""
      )
    ),
    forms = tagList(
      teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
      teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
    )
  )
}

srv_g_ae_oview <- 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")
  checkmate::assert_class(data, "tdata")

  moduleServer(id, function(input, output, session) {
    iv <- reactive({
      ANL <- data[[dataname]]() # nolint

      iv <- shinyvalidate::InputValidator$new()
      iv$add_rule("arm_var", shinyvalidate::sv_required(
        message = "Arm Variable is required"
      ))
      iv$add_rule("arm_var", ~ if (!is.factor(ANL[[.]])) {
        "Arm Var must be a factor variable"
      })
      iv$add_rule("arm_var", ~ if (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
    })

    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

    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)
        )
      )
    })

    observeEvent(input$arm_var, ignoreNULL = TRUE, {
      ANL <- data[[dataname]]() # nolint
      arm_var <- input$arm_var
      arm_val <- ANL[[arm_var]]
      choices <- levels(arm_val)

      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
      )
    })

    output_q <- shiny::debounce(
      millis = 200,
      r = reactive({
        ANL <- data[[dataname]]() # nolint

        teal::validate_has_data(ANL, min_nrow = 10, msg = sprintf("%s has not enough data", dataname))

        teal::validate_inputs(iv())

        validate(need(
          input$arm_trt %in% ANL[[input$arm_var]] && input$arm_ref %in% ANL[[input$arm_var]],
          "Treatment or Control not found in Arm Variable. Perhaps they have been filtered out?"
        ))

        q1 <- teal.code::eval_code(
          teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)),
          code = as.expression(c(
            bquote(anl_labels <- formatters::var_labels(.(as.name(dataname)), fill = FALSE)),
            bquote(flags <- .(as.name(dataname)) %>%
              select(all_of(.(input$flag_var_anl))) %>%
              rename_at(vars(.(input$flag_var_anl)), function(x) paste0(x, ": ", anl_labels[x])))
          ))
        )

        teal.code::eval_code(
          q1,
          code = as.expression(c(
            bquote(
              plot <- osprey::g_events_term_id(
                term = flags,
                id = .(as.name(dataname))[["USUBJID"]],
                arm = .(as.name(dataname))[[.(input$arm_var)]],
                arm_N = table(ADSL[[.(input$arm_var)]]),
                ref = .(input$arm_ref),
                trt = .(input$arm_trt),
                diff_ci_method = .(input$diff_ci_method),
                conf_level = .(input$conf_level),
                axis_side = .(input$axis),
                fontsize = .(font_size()),
                draw = TRUE
              )
            ),
            quote(plot)
          ))
        )
      })
    )

    plot_r <- reactive(output_q()[["plot"]])

    teal.widgets::verbatim_popup_srv(
      id = "warning",
      verbatim_content = reactive(teal.code::get_warnings(output_q())),
      title = "Warning",
      disabled = reactive(is.null(teal.code::get_warnings(output_q())))
    )

    teal.widgets::verbatim_popup_srv(
      id = "rcode",
      verbatim_content = reactive(teal.code::get_code(output_q())),
      title = paste("R code for", label)
    )
    ### REPORTER
    if (with_reporter) {
      card_fun <- function(comment) {
        card <- teal::TealReportCard$new()
        card$set_name("AE Overview")
        card$append_text("AE Overview", "header2")
        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(teal.code::get_code(output_q()), collapse = "\n"))
        card
      }
      teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
    }
  })
}

#' Helper UI function to decorate plot output UI
#'
#' @description
#' `r lifecycle::badge("stable")`
#'
#' This is used in \code{\link{tm_g_ae_oview}} and \code{\link{tm_g_events_term_id}}.
#'
#' @param id (\code{character}) id of this module. set to `NULL` if you want to make it identical
#' to the module who called it.
#' @param titles (\code{character}) default titles
#' @param footnotes (\code{character}) default footnotes
#' @inheritParams argument_convention
#' @export
ui_g_decorate <- function(id,
                          titles = "Titles",
                          footnotes = "footnotes",
                          fontsize = c(5, 4, 11)) {
  ns <- NS(id)
  tagList(
    teal.widgets::optionalSliderInputValMinMax(
      ns("fontsize"),
      "Font Size",
      value_min_max = fontsize,
      step = 0.1
    ),
    textInput(ns("title"), "Title", value = titles),
    textAreaInput(ns("foot"), "Footnote", value = footnotes, resize = "none")
  )
}

#' Helper server function to decorate plot output
#'
#' @description
#' `r lifecycle::badge("stable")`
#'
#' This is used in \code{\link{tm_g_ae_oview}} and \code{\link{tm_g_events_term_id}}.
#'
#' @inheritParams shared_params
#' @param id (\code{character}) id of the module
#' @param plot_id (\code{character}) id for plot output
#' @param plt (\code{reactive}) a reactive object of graph object
#'
#' @export
srv_g_decorate <- function(id,
                           plot_id = "out",
                           plt = reactive(NULL),
                           plot_height,
                           plot_width) {
  moduleServer(id, function(input, output, session) {
    plot_g <- reactive({
      g <- tern::decorate_grob(
        plt(),
        titles = input$title,
        footnotes = input$foot,
        gp_titles = grid::gpar(
          fontsize = input$fontsize * ggplot2::.pt,
          col = "black",
          fontface = "bold"
        ),
        gp_footnotes = grid::gpar(fontsize = input$fontsize * ggplot2::.pt, col = "black")
      )
    })

    plot_r <- function() {
      grid::grid.newpage()
      grid::grid.draw(plot_g())
      plot_g()
    }

    class(plot_r) <- c(class(plot_r), "reactive")

    pws <- teal.widgets::plot_with_settings_srv(
      id = plot_id,
      plot_r = plot_r,
      height = plot_height,
      width = plot_width
    )

    return(
      list(
        font_size = reactive(input$fontsize),
        pws = pws
      )
    )
  })
}

#' Helper function to plot decorated output UI
#'
#' @description
#' `r lifecycle::badge("stable")`
#'
#' @param id (\code{character}) id of this element
#'
#' @export
plot_decorate_output <- function(id) {
  ns <- NS(id)
  teal.widgets::plot_with_settings_ui(id = ns("out"))
}

#' Teal Module for Waterfall Plot
#'
#' @description
#' `r lifecycle::badge("stable")`
#'
#' This is teal module that generates a waterfall plot for `ADaM` data
#'
#' @inheritParams teal.widgets::standard_layout
#' @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 \code{data} argument of \code{\link[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 \code{data} argument of \code{\link[teal]{init}}
#' @param bar_paramcd (\code{choices_selected}) parameter in tumor burden data that will be plotted as
#' bar height
#' @param bar_var (\code{choices_selected}) numeric variable from dataset to plot the bar height, e.g., `PCHG`
#' @param bar_color_var (\code{choices_selected}) color by variable (subject level), \code{None} corresponds
#' to \code{NULL}
#' @param 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
#' @param sort_var (\code{choices_selected}) sort by variable (subject level), \code{None} corresponds
#' to \code{NULL}
#' @param add_label_var_sl (\code{choices_selected}) add label to bars (subject level), \code{None}
#' corresponds to \code{NULL}
#' @param 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}
#' @param anno_txt_var_sl (\code{choices_selected}) subject level variables to be displayed in the annotation
#' table, default is \code{NULL}
#' @param anno_txt_paramcd_rs (\code{choices_selected}) analysis dataset variables to be displayed in the
#' annotation table, default is \code{NULL}
#' @param facet_var (\code{choices_selected}) facet by variable (subject level), \code{None} corresponds to
#' \code{NULL}
#' @param ytick_at bar height axis interval, default is \code{20}
#' @param href_line numeric vector to plot horizontal reference lines, default is \code{NULL}
#' @param gap_point_val singular numeric value for adding bar break when some bars are significantly higher
#' than others, default is \code{NULL}
#' @param show_value boolean of whether value of bar height is shown, default is \code{TRUE}
#'
#' @inherit argument_convention return
#'
#' @export
#'
#' @template author_qit3
#' @author houx14 \email{houx14@gene.com}
#'
#' @examples
#' library(nestcolor)
#' ADSL <- osprey::rADSL
#' ADRS <- osprey::rADRS
#' ADTR <- osprey::rADTR
#'
#' ADSL$SEX <- factor(ADSL$SEX, levels = unique(ADSL$SEX))
#'
#' app <- teal::init(
#'   data = cdisc_data(
#'     cdisc_dataset("ADSL", ADSL,
#'       code = "ADSL <- rADSL
#'               ADSL$SEX <- factor(ADSL$SEX, levels = unique(ADSL$SEX))"
#'     ),
#'     cdisc_dataset("ADRS", ADRS, code = "ADRS <- rADRS"),
#'     cdisc_dataset("ADTR", ADTR,
#'       code = " ADTR <- rADTR",
#'       c("STUDYID", "USUBJID", "PARAMCD", "AVISIT")
#'     ),
#'     check = TRUE
#'   ),
#'   modules = modules(
#'     tm_g_waterfall(
#'       label = "Waterfall",
#'       dataname_tr = "ADTR",
#'       dataname_rs = "ADRS",
#'       bar_paramcd = teal.transform::choices_selected(c("SLDINV"), "SLDINV"),
#'       bar_var = teal.transform::choices_selected(c("PCHG", "AVAL"), "PCHG"),
#'       bar_color_var = teal.transform::choices_selected(c("ARMCD", "SEX"), "ARMCD"),
#'       bar_color_opt = NULL,
#'       sort_var = teal.transform::choices_selected(c("ARMCD", "SEX"), NULL),
#'       add_label_var_sl = teal.transform::choices_selected(c("SEX", "EOSDY"), NULL),
#'       add_label_paramcd_rs = teal.transform::choices_selected(c("BESRSPI", "OBJRSPI"), NULL),
#'       anno_txt_var_sl = teal.transform::choices_selected(c("SEX", "ARMCD", "BMK1", "BMK2"), NULL),
#'       anno_txt_paramcd_rs = teal.transform::choices_selected(c("BESRSPI", "OBJRSPI"), NULL),
#'       facet_var = teal.transform::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) {
  logger::log_info("Initializing tm_g_waterfall")
  checkmate::assert_string(label)
  checkmate::assert_string(dataname_tr)
  checkmate::assert_string(dataname_rs)
  checkmate::assert_class(bar_paramcd, classes = "choices_selected")
  checkmate::assert_class(bar_var, classes = "choices_selected")
  checkmate::assert_class(bar_color_var, classes = "choices_selected")
  checkmate::assert_class(sort_var, classes = "choices_selected")
  checkmate::assert_class(anno_txt_var_sl, classes = "choices_selected")
  checkmate::assert_class(anno_txt_paramcd_rs, classes = "choices_selected")
  checkmate::assert_class(facet_var, classes = "choices_selected")
  checkmate::assert_class(add_label_var_sl, classes = "choices_selected")
  checkmate::assert_class(add_label_paramcd_rs, classes = "choices_selected")
  checkmate::assert_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"
  )

  args <- as.list(environment())

  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,
      label = label,
      bar_color_opt = bar_color_opt,
      plot_height = plot_height,
      plot_width = plot_width
    ),
    datanames = "all"
  )
}

ui_g_waterfall <- function(id, ...) {
  a <- list(...)
  ns <- NS(id)

  teal.widgets::standard_layout(
    output = teal.widgets::white_small_well(
      teal.widgets::plot_with_settings_ui(id = ns("waterfallplot"))
    ),
    encoding = div(
      ### Reporter
      teal.reporter::simple_reporter_ui(ns("simple_reporter")),
      ###
      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",
        choices = a$bar_paramcd$choices,
        selected = a$bar_paramcd$selected,
        multiple = FALSE
      ),
      teal.widgets::optionalSelectInput(
        ns("bar_var"),
        "Bar Height",
        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 = a$bar_color_var$choices,
        selected = a$bar_color_var$selected,
        multiple = FALSE
      ),
      teal.widgets::optionalSelectInput(
        ns("sort_var"),
        "Sort by",
        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 = a$add_label_var_sl$choices,
        selected = a$add_label_var_sl$selected,
        multiple = FALSE
      ),
      teal.widgets::optionalSelectInput(
        ns("add_label_paramcd_rs"),
        "Add ADRS Label to Bars",
        choices = a$add_label_paramcd_rs$choices,
        selected = a$add_label_paramcd_rs$selected,
        multiple = FALSE
      ),
      teal.widgets::optionalSelectInput(
        ns("anno_txt_var_sl"),
        "Annotation Variables",
        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",
        choices = a$anno_txt_paramcd_rs$choices,
        selected = a$anno_txt_paramcd_rs$selected,
        multiple = TRUE,
        label_help = helpText("from ", tags$code("ADRS"))
      ),
      teal.widgets::optionalSelectInput(
        ns("facet_var"),
        "Facet by",
        choices = a$facet_var$choices,
        selected = NULL,
        multiple = FALSE,
        label_help = helpText("from ", tags$code("ADSL"))
      ),
      checkboxInput(
        ns("show_value"),
        "Add Bar Height Value",
        value = a$show_value
      ),
      textInput(
        ns("href_line"),
        label = div(
          "Horizontal Reference Line(s)",
          tags$br(),
          helpText("Enter numeric value(s) of reference lines, separated by comma (eg. -10, 20)")
        ),
        value = a$href_line
      ),
      textInput(
        ns("ytick_at"),
        label = div(
          "Y-axis Interval",
          tags$br(),
          helpText("Enter a numeric value of Y axis interval")
        ),
        value = a$ytick_at
      ),
      textInput(
        ns("gap_point_val"),
        label = div(
          "Break High Bars",
          tags$br(),
          helpText("Enter a numeric value to break very high bars")
        ),
        value = a$gap_point_val
      )
    ),
    forms = tagList(
      teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
      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,
                            data,
                            filter_panel_api,
                            reporter,
                            dataname_tr,
                            dataname_rs,
                            bar_color_opt,
                            label,
                            plot_height,
                            plot_width) {
  with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
  with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
  checkmate::assert_class(data, "tdata")

  moduleServer(id, function(input, output, session) {
    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
    })

    output_q <- reactive({
      adsl <- data[["ADSL"]]()
      adtr <- data[[dataname_tr]]()
      adrs <- data[[dataname_rs]]()

      # validate data rows
      teal::validate_has_data(adsl, min_nrow = 2)
      teal::validate_has_data(adtr, min_nrow = 2)
      teal::validate_has_data(adrs, min_nrow = 2)

      adsl_vars <- unique(
        c(
          "USUBJID", "STUDYID",
          input$bar_color_var, input$sort_var, input$add_label_var_sl, input$anno_txt_var_sl, input$facet_var
        )
      )
      adtr_vars <- unique(c("USUBJID", "STUDYID", "PARAMCD", input$bar_var))
      adrs_vars <- unique(c("USUBJID", "STUDYID", "PARAMCD", "AVALC"))
      adrs_paramcd <- unique(c(input$add_label_paramcd_rs, input$anno_txt_paramcd_rs))

      # validate data input
      teal::validate_has_variable(adsl, adsl_vars)
      teal::validate_has_variable(adrs, adrs_vars)
      teal::validate_has_variable(adtr, adtr_vars)

      teal::validate_inputs(iv())

      # get variables
      bar_var <- input$bar_var
      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
      gap_point_val <- input$gap_point_val
      show_value <- input$show_value # nolint
      href_line <- suppressWarnings(as_numeric_from_comma_sep_str(href_line))

      if (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
      }

      # write variables to qenv
      q1 <- teal.code::eval_code(
        teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)),
        code = bquote({
          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)
          href_line <- .(href_line)
          gap_point_val <- .(gap_point_val)
          show_value <- .(show_value)
        })
      )

      # data processing
      q1 <- teal.code::eval_code(
        q1,
        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) %>%
            dplyr::slice(which.min(.(as.name(bar_var))))
          bar_data <- adsl %>% dplyr::inner_join(bar_tr, "USUBJID")
        })
      )

      q1 <- if (is.null(adrs_paramcd)) {
        teal.code::eval_code(
          q1,
          code = bquote({
            anl <- bar_data
            anl$USUBJID <- unlist(lapply(strsplit(anl$USUBJID, "-", fixed = TRUE), tail, 1)) # nolint
          })
        )
      } else {
        qq1 <- teal.code::eval_code(
          q1,
          code = bquote(
            rs_sub <- .(as.name(dataname_rs)) %>%
              dplyr::filter(PARAMCD %in% .(adrs_paramcd))
          )
        )

        teal::validate_one_row_per_id(qq1[["rs_sub"]], key = c("STUDYID", "USUBJID", "PARAMCD"))

        teal.code::eval_code(
          qq1,
          code = bquote({
            rs_label <- rs_sub %>%
              dplyr::select(USUBJID, PARAMCD, AVALC) %>%
              tidyr::pivot_wider(names_from = PARAMCD, values_from = AVALC)
            anl <- bar_data %>% dplyr::left_join(rs_label, by = c("USUBJID"))
            anl$USUBJID <- unlist(lapply(strsplit(anl$USUBJID, "-", fixed = TRUE), tail, 1)) # nolint
          })
        )
      }

      # write plotting code to qenv
      anl <- q1[["anl"]] # nolint

      q1 <- 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
            }),
            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))) {
              bar_color_opt
            } else {
              NULL
            }),
            anno_txt = .(if (length(anno_txt_var_sl) == 0 & length(anno_txt_paramcd_rs) == 0) {
              NULL
            } else if (length(anno_txt_var_sl) >= 1 & length(anno_txt_paramcd_rs) == 0) {
              quote(data.frame(anl[anno_txt_var_sl]))
            } else if (length(anno_txt_paramcd_rs) >= 1 & length(anno_txt_var_sl) == 0) {
              quote(data.frame(anl[anno_txt_paramcd_rs]))
            } else {
              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
            }),
            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]])
            } else if (length(add_label_paramcd_rs) > 0 & length(add_label_var_sl) == 0) {
              quote(anl[[add_label_paramcd_rs]])
            } else {
              NULL
            }),
            gap_point = .(gap_point_val),
            ytick_at = .(ytick_at),
            y_label = "Tumor Burden Change from Baseline",
            title = "Waterfall Plot"
          )
          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 = "waterfallplot",
      plot_r = plot_r,
      height = plot_height,
      width = plot_width
    )

    teal.widgets::verbatim_popup_srv(
      id = "warning",
      verbatim_content = reactive(teal.code::get_warnings(output_q())),
      title = "Warning",
      disabled = reactive(is.null(teal.code::get_warnings(output_q())))
    )

    # Show R Code
    teal.widgets::verbatim_popup_srv(
      id = "rcode",
      title = paste("R code for", label),
      verbatim_content = reactive(teal.code::get_code(output_q()))
    )

    ### REPORTER
    if (with_reporter) {
      card_fun <- function(comment) {
        card <- teal::TealReportCard$new()
        card$set_name("Waterfall")
        card$append_text("Waterfall Plot", "header2")
        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)) {
          card$append_text(paste0("Sorted by: ", input$sort_var, "."))
        }
        if (!is.null(input$facet_var)) {
          card$append_text(paste0("Faceted by: ", paste(input$facet_var, collapse = ", "), "."))
        }
        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(teal.code::get_code(output_q()), collapse = "\n"))
        card
      }
      teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
    }
  })
}

1		#' Shared Parameters
2		#'
3		#' @description Contains arguments that are shared between multiple functions
4		#' in the package to avoid repetition using \code{inheritParams}.
5		#'
6		#' @param plot_height optional, (\code{numeric}) a vector of length three with \code{c(value, min, max)}. Specifies
7		#' the height of the main plot.
8		#' @param plot_width optional, (\code{numeric}) a vector of length three with \code{c(value, min, max)}. Specifies
9		#' the width of the main plot and renders a slider on the plot to interactively adjust the plot width.
10		#' @param label (\code{character}) module label in the teal app. Please note that this module is developed based on
11		#' `ADaM` data structure and `ADaM` variables.
12		#'
13		#' @name shared_params
14		#' @keywords internal
15		#'
16		NULL
17
18		#' Utility function for quick filter
19		#' `r lifecycle::badge("stable")`
20		#'
21		#'
22		#' @param filter_opt vector of string names of flag variable to filter (keep Y rows only)
23		#' @param ANL input dataset
24		#'
25		#' @return a filtered dataframe
26		#'
27		#' @export
28		#'
29		#' @template author_zhanc107
30		#'
31		quick_filter <- function(filter_opt, ANL) { # nolint
32	!	for (i in seq_along(filter_opt)) {
33	!	ANL <- ANL[ANL[, filter_opt[i]] == "Y", ] # nolint
34		}
35	!	return(ANL)
36		}
37
38		#' Automatically switch variable labels for standard `AE` variables in `AE` osprey functions
39		#' `r lifecycle::badge("stable")`
40		#'
41		#' @param x variable key
42		#'
43		#' @export
44		label_aevar <- function(x) {
45	!	lifecycle::deprecate_soft(
46	!	when = "0.1.15",
47	!	what = "label_aevar()",
48	!	details = "label_aevar is deprecated and will be unexported in the next release."
49		)
50
51		# Display full variable labels for standard AE variables
52	!	ae_varlabel <- c(
53	!	AEBODSYS = "MedDRA System Organ Class",
54	!	AESOC = "MedDRA Primary System Organ Class",
55	!	AEHLGT = "MedDRA High Level Group Term",
56	!	AEHLT = "MedDRA High Level Term",
57	!	AELLT = "MedDRA Lowest Level Term",
58	!	AEDECOD = "MedDRA Preferred Term",
59	!	AETERM = "Reported Adverse Event Term",
60	!	AEMODIFY = "Modified Reported Term",
61	!	AETOXGR = "NCI-CTCAE Grade",
62	!	AEITOXGR = "Initial Toxicity Grade"
63		)
64
65	!	which_aevar <- match(x, names(ae_varlabel))
66	!	out_label <- ifelse(is.na(which_aevar), x, ae_varlabel[which_aevar])
67	!	return(out_label)
68		}
69
70		#' retrieve name of ci method
71		#' @param x ci method to retrieve its name
72		#' @keywords internal
73		#'
74		name_ci <- function(x) {
75		names(ci_choices)[which(ci_choices == x)]
76		}
77
78		ci_choices <- setNames(
79		c("wald", "waldcc", "ac", "scorecc", "score", "mn", "mee", "blj", "ha"),
80		c(
81		"Wald", "Corrected Wald", "Agresti-Caffo", "Newcombe",
82		"Score", "Miettinen and Nurminen", "Mee",
83		"Brown, Li's Jeffreys", "Hauck-Anderson"
84		)
85		)
86
87		#' retrieve detailed name of ci method
88		#' @param x ci method to retrieve its name
89		name_ci <- function(x = ci_choices) {
90	!	x <- match.arg(x)
91	!	return(paste0(names(x), " (", x, ")"))
92		}
93
94
95		#' takes input_string, splits by "," and returns a numeric vector
96		#' with NAs where the split-strings are not numeric.
97		#' e.g. as_numeric_from_comma_separated_string("4 ,hello,5,, 3")
98		#' is c(4, NA, 5, NA, 3).
99		#' If input argument is NULL or just whitespace then NULL is returned
100		#' @param input_string string to be split into numeric vector
101		#' @keywords internal
102		#'
103		as_numeric_from_comma_sep_str <- function(input_string) {
104	10x	if (!is.null(input_string) && trimws(input_string) != "") {
105	7x	ref_line <- unlist(strsplit(trimws(input_string), ","))
106	7x	ref_line <- as.numeric(ref_line)
107		} else {
108	3x	ref_line <- NULL
109		}
110	10x	return(ref_line)
111		}
112
113		#' Include `CSS` files from `/inst/css/` package directory to application header
114		#'
115		#' `system.file` should not be used to access files in other packages, it does
116		#' not work with `devtools`. Therefore, we redefine this method in each package
117		#' as needed. Thus, we do not export this method.
118		#'
119		#' @param pattern (`character`) pattern of files to be included
120		#'
121		#' @return HTML code that includes `CSS` files
122		#' @keywords internal
123		include_css_files <- function(pattern = "*") {
124	!	css_files <- list.files(
125	!	system.file("css", package = "teal.osprey", mustWork = TRUE),
126	!	pattern = pattern, full.names = TRUE
127		)
128	!	if (length(css_files) == 0) {
129	!	return(NULL)
130		}
131	!	return(shiny::singleton(shiny::tags$head(lapply(css_files, shiny::includeCSS))))
132		}

1		#' Butterfly plot Teal Module
2		#'
3		#' @description
4		#' `r lifecycle::badge("stable")`
5		#'
6		#' Display butterfly plot as a shiny module
7		#'
8		#' @inheritParams teal.widgets::standard_layout
9		#' @inheritParams argument_convention
10		#' @param filter_var (\code{choices_selected}) variable name of data filter, please see details regarding
11		#' expected values, default is \code{NULL}. \code{choices}
12		#' vector with \code{filter_var} choices, default is
13		#' \code{NULL}
14		#' @param right_var (\code{choices_selected}) dichotomization variable for right side
15		#' @param left_var (\code{choices_selected}) dichotomization variable for left side
16		#' @param category_var (\code{choices_selected}) category (y axis) variable
17		#' @param color_by_var (\code{choices_selected}) variable defines color blocks within each bar
18		#' @param count_by_var (\code{choices_selected}) variable defines how x axis is calculated
19		#' @param facet_var (\code{choices_selected}) variable for row facets
20		#' @param sort_by_var (\code{choices_selected}) argument for order of class and term elements in table,
21		#' default here is "count"
22		#' @param legend_on (\code{boolean}) value for whether legend is displayed
23		#'
24		#' @details \code{filter_var} option is designed to work in conjunction with
25		#' filtering function provided by \code{teal} (encoding panel on the right
26		#' hand side of the shiny app). It can be used as quick access to predefined
27		#' subsets of the domain datasets (not subject-level dataset) to be used for
28		#' analysis, denoted by an value of "Y". Each variable within the
29		#' \code{filter_var_choices} is expected to contain values of either "Y" or
30		#' "N". If multiple variables are selected as \code{filter_var}, only
31		#' observations with "Y" value in each and every selected variables will be
32		#' used for subsequent analysis. Flag variables (from `ADaM` datasets) can be
33		#' used directly as filter.
34		#'
35		#' @inherit argument_convention return
36		#'
37		#' @export
38		#'
39		#' @template author_zhanc107
40		#' @template author_liaoc10
41		#'
42		#' @examples
43		#'
44		#' # Example using stream (ADaM) dataset
45		#' library(dplyr)
46		#' library(nestcolor)
47		#'
48		#' set.seed(23)
49		#' ADSL <- osprey::rADSL
50		#' ADAE <- osprey::rADAE
51		#' ADSL <- mutate(ADSL, DOSE = paste(sample(1:3, n(), replace = TRUE), "UG"))
52		#' ADAE <- mutate(
53		#' ADAE,
54		#' flag1 = ifelse(AETOXGR == 1, 1, 0),
55		#' flag2 = ifelse(AETOXGR == 2, 1, 0),
56		#' flag3 = ifelse(AETOXGR == 3, 1, 0),
57		#' flag1_filt = rep("Y", n())
58		#' )
59		#'
60		#' app <- init(
61		#' data = cdisc_data(
62		#' cdisc_dataset("ADSL", ADSL,
63		#' code = "ADSL <- osprey::rADSL
64		#' set.seed(23)
65		#' ADSL <- mutate(ADSL, DOSE = paste(sample(1:3, n(), replace = TRUE), 'UG'))"
66		#' ),
67		#' cdisc_dataset("ADAE", ADAE,
68		#' code = "ADAE <- osprey::rADAE
69		#' ADAE <- mutate(ADAE,
70		#' flag1 = ifelse(AETOXGR == 1, 1, 0),
71		#' flag2 = ifelse(AETOXGR == 2, 1, 0),
72		#' flag3 = ifelse(AETOXGR == 3, 1, 0),
73		#' flag1_filt = rep('Y', n()))"
74		#' ),
75		#' check = TRUE
76		#' ),
77		#' modules = modules(
78		#' tm_g_butterfly(
79		#' label = "Butterfly Plot",
80		#' dataname = "ADAE",
81		#' right_var = teal.transform::choices_selected(
82		#' selected = "SEX",
83		#' choices = c("SEX", "ARM", "RACE")
84		#' ),
85		#' left_var = teal.transform::choices_selected(
86		#' selected = "RACE",
87		#' choices = c("SEX", "ARM", "RACE")
88		#' ),
89		#' category_var = teal.transform::choices_selected(
90		#' selected = "AEBODSYS",
91		#' choices = c("AEDECOD", "AEBODSYS")
92		#' ),
93		#' color_by_var = teal.transform::choices_selected(
94		#' selected = "AETOXGR",
95		#' choices = c("AETOXGR", "None")
96		#' ),
97		#' count_by_var = teal.transform::choices_selected(
98		#' selected = "# of patients",
99		#' choices = c("# of patients", "# of AEs")
100		#' ),
101		#' facet_var = teal.transform::choices_selected(
102		#' selected = NULL,
103		#' choices = c("RACE", "SEX", "ARM")
104		#' ),
105		#' sort_by_var = teal.transform::choices_selected(
106		#' selected = "count",
107		#' choices = c("count", "alphabetical")
108		#' ),
109		#' legend_on = TRUE,
110		#' plot_height = c(600, 200, 2000)
111		#' )
112		#' )
113		#' )
114		#' if (interactive()) {
115		#' shinyApp(app$ui, app$server)
116		#' }
117		#'
118		tm_g_butterfly <- function(label,
119		dataname,
120		filter_var = NULL,
121		right_var,
122		left_var,
123		category_var,
124		color_by_var,
125		count_by_var,
126		facet_var = NULL,
127		sort_by_var = teal.transform::choices_selected(
128		selected = "count", choices = c("count", "alphabetical")
129		),
130		legend_on = TRUE,
131		plot_height = c(600L, 200L, 2000L),
132		plot_width = NULL,
133		pre_output = NULL,
134		post_output = NULL) {
135	!	logger::log_info("Initializing tm_g_butterfly")
136	!	checkmate::assert_string(label)
137	!	checkmate::assert_string(dataname)
138	!	checkmate::assert_class(filter_var, classes = "choices_selected", null.ok = TRUE)
139	!	checkmate::assert_class(right_var, classes = "choices_selected")
140	!	checkmate::assert_class(left_var, classes = "choices_selected")
141	!	checkmate::assert_class(category_var, classes = "choices_selected")
142	!	checkmate::assert_class(color_by_var, classes = "choices_selected")
143	!	checkmate::assert_class(count_by_var, classes = "choices_selected")
144	!	checkmate::assert_class(facet_var, classes = "choices_selected", null.ok = TRUE)
145	!	checkmate::assert_class(sort_by_var, classes = "choices_selected")
146	!	checkmate::assert_flag(legend_on)
147	!	checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
148	!	checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")
149	!	checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
150	!	checkmate::assert_numeric(
151	!	plot_width[1],
152	!	lower = plot_width[2],
153	!	upper = plot_width[3],
154	!	null.ok = TRUE,
155	!	.var.name = "plot_width"
156		)
157
158	!	args <- as.list(environment())
159
160	!	module(
161	!	label = label,
162	!	datanames = c("ADSL", dataname),
163	!	server = srv_g_butterfly,
164	!	server_args = list(dataname = dataname, label = label, plot_height = plot_height, plot_width = plot_width),
165	!	ui = ui_g_butterfly,
166	!	ui_args = args
167		)
168		}
169
170		ui_g_butterfly <- function(id, ...) {
171	!	ns <- NS(id)
172	!	a <- list(...)
173
174	!	teal.widgets::standard_layout(
175	!	output = teal.widgets::white_small_well(
176	!	teal.widgets::plot_with_settings_ui(id = ns("butterflyplot"))
177		),
178	!	encoding = div(
179		### Reporter
180	!	teal.reporter::simple_reporter_ui(ns("simple_reporter")),
181		###
182	!	tags$label("Encodings", class = "text-primary"),
183	!	helpText("Dataset is:", tags$code(a$dataname)),
184	!	if (!is.null(a$filter_var)) {
185	!	teal.widgets::optionalSelectInput(
186	!	ns("filter_var"),
187	!	label =
188	!	"Preset Data Filters Observations with value of 'Y' for selected variable(s) will be used for analysis",
189	!	choices = a$filter_var$choices,
190	!	selected = a$filter_var$selected,
191	!	multiple = TRUE
192		)
193		},
194	!	teal.widgets::optionalSelectInput(
195	!	ns("right_var"),
196	!	"Right Dichotomization Variable",
197	!	a$right_var$choices,
198	!	a$right_var$selected,
199	!	multiple = FALSE
200		),
201	!	teal.widgets::optionalSelectInput(
202	!	ns("right_val"),
203	!	"Choose Up To 2:",
204	!	multiple = TRUE,
205	!	options = list(
206	!	`max-options` = 2L,
207	!	`max-options-text` = "no more than 2",
208	!	`actions-box` = FALSE
209		)
210		),
211	!	teal.widgets::optionalSelectInput(
212	!	ns("left_var"),
213	!	"Left Dichotomization Variable",
214	!	a$left_var$choices,
215	!	a$left_var$selected,
216	!	multiple = FALSE
217		),
218	!	teal.widgets::optionalSelectInput(
219	!	ns("left_val"),
220	!	"Choose Up To 2:",
221	!	multiple = TRUE,
222	!	options = list(
223	!	`max-options` = 2L,
224	!	`max-options-text` = "no more than 2",
225	!	`actions-box` = FALSE
226		)
227		),
228	!	teal.widgets::optionalSelectInput(
229	!	ns("category_var"),
230	!	"Category Variable",
231	!	a$category_var$choices,
232	!	a$category_var$selected,
233	!	multiple = FALSE
234		),
235	!	radioButtons(
236	!	ns("color_by_var"),
237	!	"Color Block By Variable",
238	!	a$color_by_var$choices,
239	!	a$color_by_var$selected
240		),
241	!	radioButtons(
242	!	ns("count_by_var"),
243	!	"Count By Variable",
244	!	a$count_by_var$choices,
245	!	a$count_by_var$selected
246		),
247	!	if (!is.null(a$facet_var)) {
248	!	teal.widgets::optionalSelectInput(
249	!	ns("facet_var"),
250	!	"Facet By Variable",
251	!	a$facet_var$choices,
252	!	a$facet_var$selected,
253	!	multiple = TRUE
254		)
255		},
256	!	radioButtons(
257	!	ns("sort_by_var"),
258	!	"Sort By Variable",
259	!	a$sort_by_var$choices,
260	!	a$sort_by_var$selected
261		),
262	!	checkboxInput(
263	!	ns("legend_on"),
264	!	"Add legend",
265	!	value = a$legend_on
266		)
267		),
268	!	forms = tagList(
269	!	teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
270	!	teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
271		),
272	!	pre_output = a$pre_output,
273	!	post_output = a$post_output
274		)
275		}
276
277		srv_g_butterfly <- function(id, data, filter_panel_api, reporter, dataname, label, plot_height, plot_width) {
278	!	with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
279	!	with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
280	!	checkmate::assert_class(data, "tdata")
281
282	!	moduleServer(id, function(input, output, session) {
283	!	iv <- reactive({
284	!	ADSL <- data[["ADSL"]]() # nolint
285	!	ANL <- data[[dataname]]() # nolint
286
287	!	iv <- shinyvalidate::InputValidator$new()
288	!	iv$add_rule("category_var", shinyvalidate::sv_required(
289	!	message = "Category Variable is required"
290		))
291	!	iv$add_rule("right_var", shinyvalidate::sv_required(
292	!	message = "Right Dichotomization Variable is required"
293		))
294	!	iv$add_rule("left_var", shinyvalidate::sv_required(
295	!	message = "Left Dichotomization Variable is required"
296		))
297	!	iv$add_rule("right_var", ~ if (!is.factor(ANL[[.]])) {
298	!	"Right Dichotomization Variable must be a factor variable, contact developer"
299		})
300	!	iv$add_rule("left_var", ~ if (!is.factor(ANL[[.]])) {
301	!	"Left Dichotomization Variable must be a factor variable, contact developer"
302		})
303	!	iv$add_rule("right_val", shinyvalidate::sv_required(
304	!	message = "At least one value of Right Dichotomization Variable must be selected"
305		))
306	!	iv$add_rule("left_val", shinyvalidate::sv_required(
307	!	message = "At least one value of Left Dichotomization Variable must be selected"
308		))
309	!	iv$enable()
310	!	iv
311		})
312
313	!	options <- reactiveValues(r = NULL, l = NULL)
314	!	vars <- reactiveValues(r = NULL, l = NULL)
315
316		# dynamic options for dichotomization variable
317	!	observeEvent(input$right_var,
318	!	handlerExpr = {
319	!	right_var <- input$right_var
320	!	right_val <- isolate(input$right_val)
321	!	current_r_var <- isolate(vars$r)
322	!	if (is.null(right_var)) {
323	!	teal.widgets::updateOptionalSelectInput(
324	!	session,
325	!	"right_val",
326	!	choices = character(0),
327	!	selected = character(0)
328		)
329		} else {
330	!	options$r <- if (right_var %in% names(data[["ADSL"]]())) {
331	!	levels(data[["ADSL"]]()[[right_var]])
332		} else {
333	!	levels(data[[dataname]]()[[right_var]])
334		}
335
336	!	selected <- if (length(right_val) > 0) {
337	!	left_over <- right_val[right_val %in% options$r]
338	!	if (length(left_over) > 0 && !is.null(current_r_var) && current_r_var == right_var) {
339	!	left_over
340		} else {
341	!	options$r[1]
342		}
343		} else {
344	!	options$r[1]
345		}
346	!	teal.widgets::updateOptionalSelectInput(
347	!	session, "right_val",
348	!	choices = as.character(options$r), selected = selected, label = "Choose Up To 2:"
349		)
350		}
351	!	vars$r <- right_var
352		},
353	!	ignoreNULL = FALSE
354		)
355
356	!	observeEvent(input$left_var,
357	!	handlerExpr = {
358	!	left_var <- input$left_var
359	!	left_val <- isolate(input$left_val)
360	!	current_l_var <- isolate(vars$l)
361	!	if (is.null(left_var)) {
362	!	teal.widgets::updateOptionalSelectInput(
363	!	session, "left_val",
364	!	choices = character(0), selected = character(0)
365		)
366		} else {
367	!	options$l <- if (left_var %in% names(data[["ADSL"]]())) {
368	!	levels(data[["ADSL"]]()[[left_var]])
369		} else {
370	!	levels(data[[dataname]]()[[left_var]])
371		}
372
373	!	selected <- if (length(left_val) > 0) {
374	!	left_over <- left_val[left_val %in% options$l]
375	!	if (length(left_over) > 0 && !is.null(current_l_var) && current_l_var == left_var) {
376	!	left_over
377		} else {
378	!	options$l[1]
379		}
380		} else {
381	!	options$l[1]
382		}
383
384	!	teal.widgets::updateOptionalSelectInput(
385	!	session, "left_val",
386	!	choices = as.character(options$l), selected = selected, label = "Choose Up To 2:"
387		)
388		}
389	!	vars$l <- left_var
390		},
391	!	ignoreNULL = FALSE
392		)
393
394	!	output_q <- shiny::debounce(
395	!	millis = 200,
396	!	r = reactive({
397	!	ADSL <- data[["ADSL"]]() # nolint
398	!	ANL <- data[[dataname]]() # nolint
399
400	!	teal::validate_has_data(ADSL, min_nrow = 0, msg = sprintf("%s Data is empty", "ADSL"))
401	!	teal::validate_has_data(ANL, min_nrow = 0, msg = sprintf("%s Data is empty", dataname))
402
403	!	teal::validate_inputs(iv())
404
405	!	validate(
406	!	need(
407	!	all(input$right_val %in% ADSL[[input$right_var]]) &&
408	!	all(input$left_val %in% ADSL[[input$left_var]]),
409	!	"No observations for selected dichotomization values (filtered out?)"
410		)
411		)
412
413	!	right_var <- isolate(input$right_var)
414	!	left_var <- isolate(input$left_var)
415	!	right_val <- input$right_val
416	!	left_val <- input$left_val
417	!	category_var <- input$category_var
418	!	color_by_var <- input$color_by_var
419	!	count_by_var <- input$count_by_var
420	!	legend_on <- input$legend_on
421	!	facet_var <- input$facet_var
422	!	sort_by_var <- input$sort_by_var
423	!	filter_var <- input$filter_var
424
425		# if variable is not in ADSL, then take from domain VADs
426	!	varlist <- c(category_var, color_by_var, facet_var, filter_var, right_var, left_var)
427	!	varlist_from_adsl <- intersect(varlist, names(ADSL))
428	!	varlist_from_anl <- intersect(varlist, setdiff(names(ANL), names(ADSL)))
429
430	!	adsl_vars <- unique(c("USUBJID", "STUDYID", varlist_from_adsl)) # nolint
431	!	anl_vars <- unique(c("USUBJID", "STUDYID", varlist_from_anl)) # nolint
432
433	!	q1 <- teal.code::eval_code(
434	!	teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)),
435	!	code = bquote({
436	!	ADSL <- ADSL[, .(adsl_vars)] %>% as.data.frame() # nolint
437	!	ANL <- .(as.name(dataname))[, .(anl_vars)] %>% as.data.frame() # nolint
438		})
439		)
440
441	!	if (!("NULL" %in% filter_var) && !is.null(filter_var)) {
442	!	q1 <- teal.code::eval_code(
443	!	q1,
444	!	code = bquote(
445	!	ANL <- quick_filter(.(filter_var), ANL) %>% # nolint
446	!	droplevels() %>%
447	!	as.data.frame()
448		)
449		)
450		}
451
452	!	q1 <- teal.code::eval_code(
453	!	q1,
454	!	code = bquote({
455	!	ANL_f <- left_join(ADSL, ANL, by = c("USUBJID", "STUDYID")) %>% as.data.frame() # nolint
456	!	ANL_f <- na.omit(ANL_f) # nolint
457		})
458		)
459
460	!	if (!is.null(right_val) && !is.null(right_val)) {
461	!	q1 <- teal.code::eval_code(
462	!	q1,
463	!	code = bquote({
464	!	right <- ANL_f[, .(right_var)] %in% .(right_val)
465	!	right_name <- paste(.(right_val), collapse = " - ")
466	!	left <- ANL_f[, .(left_var)] %in% .(left_val)
467	!	left_name <- paste(.(left_val), collapse = " - ")
468		})
469		)
470		}
471
472	!	if (!is.null(right_val) && !is.null(left_val)) {
473	!	q1 <- teal.code::eval_code(
474	!	q1,
475	!	code = bquote(
476	!	plot <- osprey::g_butterfly(
477	!	category = ANL_f[, .(category_var)],
478	!	right_flag = right,
479	!	left_flag = left,
480	!	group_names = c(right_name, left_name),
481	!	block_count = .(count_by_var),
482	!	block_color = .(if (color_by_var != "None") {
483	!	bquote(ANL_f[, .(color_by_var)])
484		} else {
485	!	NULL
486		}),
487	!	id = ANL_f$USUBJID,
488	!	facet_rows = .(if (!is.null(facet_var)) {
489	!	bquote(ANL_f[, .(facet_var)])
490		} else {
491	!	NULL
492		}),
493	!	x_label = .(count_by_var),
494	!	y_label = .(category_var),
495	!	legend_label = .(color_by_var),
496	!	sort_by = .(sort_by_var),
497	!	show_legend = .(legend_on)
498		)
499		)
500		)
501		}
502
503	!	teal.code::eval_code(q1, quote(plot))
504		})
505		)
506
507	!	plot_r <- reactive(output_q()[["plot"]])
508
509		# Insert the plot into a plot_with_settings module from teal.widgets
510	!	pws <- teal.widgets::plot_with_settings_srv(
511	!	id = "butterflyplot",
512	!	plot_r = plot_r,
513	!	height = plot_height,
514	!	width = plot_width
515		)
516
517	!	teal.widgets::verbatim_popup_srv(
518	!	id = "warning",
519	!	verbatim_content = reactive(teal.code::get_warnings(output_q())),
520	!	title = "Warning",
521	!	disabled = reactive(is.null(teal.code::get_warnings(output_q())))
522		)
523
524	!	teal.widgets::verbatim_popup_srv(
525	!	id = "rcode",
526	!	title = paste("R code for", label),
527	!	verbatim_content = reactive(teal.code::get_code(output_q()))
528		)
529
530		### REPORTER
531	!	if (with_reporter) {
532	!	card_fun <- function(comment) {
533	!	card <- teal::TealReportCard$new()
534	!	card$set_name("Butterfly")
535	!	card$append_text("Butterfly Plot", "header2")
536	!	if (with_filter) card$append_fs(filter_panel_api$get_filter_state())
537	!	if (!is.null(input$filter_var) \|\| !is.null(input$facet_var) \|\| !is.null(input$sort_by_var)) {
538	!	card$append_text("Selected Options", "header3")
539		}
540	!	if (!is.null(input$filter_var)) {
541	!	card$append_text(paste0("Preset Data Filters: ", paste(input$filter_var, collapse = ", "), "."))
542		}
543	!	if (!is.null(input$facet_var)) {
544	!	card$append_text(paste0("Faceted by: ", paste(input$facet_var, collapse = ", "), "."))
545		}
546	!	if (!is.null(input$sort_by_var)) {
547	!	card$append_text(paste0("Sorted by: ", paste(input$sort_by_var, collapse = ", "), "."))
548		}
549	!	card$append_text("Plot", "header3")
550	!	card$append_plot(plot_r(), dim = pws$dim())
551	!	if (!comment == "") {
552	!	card$append_text("Comment", "header3")
553	!	card$append_text(comment)
554		}
555	!	card$append_src(paste(teal.code::get_code(output_q()), collapse = "\n"))
556	!	card
557		}
558	!	teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
559		}
560		})
561		}

1		#' Teal Module for `Swimlane` Plot
2		#'
3		#' @description
4		#' `r lifecycle::badge("stable")`
5		#'
6		#' This is teal module that generates a `swimlane` plot (bar plot with markers) for `ADaM` data
7		#'
8		#' @inheritParams teal.widgets::standard_layout
9		#' @inheritParams argument_convention
10		#' @param dataname analysis data used for plotting, needs to be available in the list passed to the \code{data}
11		#' argument of \code{\link[teal]{init}}. If no markers are to be plotted in the module, `"ADSL"` should be
12		#' the input. If markers are to be plotted, data name for the marker data should be the input
13		#' @param bar_var (\code{\link[teal.transform]{choices_selected}}) subject-level numeric variable from dataset
14		#' to plot as the bar length
15		#' @param bar_color_var (\code{\link[teal.transform]{choices_selected}}) color by variable (subject-level)
16		#' @param sort_var (\code{choices_selected}) sort by variable (subject-level)
17		#' @param marker_pos_var (\code{\link[teal.transform]{choices_selected}}) variable for marker position from marker data
18		#' (Note: make sure that marker position has the same relative start day as bar length variable \code{bar_var})
19		#' @param marker_shape_var (\code{\link[teal.transform]{choices_selected}}) marker shape variable from marker data
20		#' @param marker_shape_opt aesthetic values to map shape values (named vector to map shape values to each name).
21		#' If not \code{NULL}, please make sure this contains all possible values for \code{marker_shape_var} values,
22		#' otherwise shape will be assigned by \code{ggplot} default
23		#' @param marker_color_var marker color variable from marker data
24		#' @param marker_color_opt aesthetic values to map color values (named vector to map color values to each name).
25		#' If not \code{NULL}, please make sure this contains all possible values for \code{marker_color_var} values,
26		#' otherwise color will be assigned by \code{ggplot} default
27		#' @param vref_line vertical reference lines
28		#' @param anno_txt_var character vector with subject-level variable names that are selected as annotation
29		#' @param x_label the label of the x axis
30		#'
31		#' @inherit argument_convention return
32		#'
33		#' @export
34		#'
35		#' @template author_qit3
36		#'
37		#' @examples
38		#'
39		#' # Example using stream (ADaM) dataset
40		#' library(dplyr)
41		#' library(nestcolor)
42		#'
43		#' ADSL <- osprey::rADSL %>%
44		#' dplyr::mutate(TRTDURD = as.integer(TRTEDTM - TRTSDTM) + 1) %>%
45		#' dplyr::filter(STRATA1 == "A" & ARMCD == "ARM A")
46		#' ADRS <- osprey::rADRS
47		#'
48		#' ADRS <- ADRS %>%
49		#' dplyr::filter(PARAMCD == "LSTASDI" & DCSREAS == "Death") %>%
50		#' mutate(AVALC = DCSREAS, ADY = EOSDY) %>%
51		#' base::rbind(ADRS %>% dplyr::filter(PARAMCD == "OVRINV" & AVALC != "NE")) %>%
52		#' arrange(USUBJID)
53		#'
54		#' app <- init(
55		#' data = cdisc_data(
56		#' cdisc_dataset("ADSL", ADSL, code = "ADSL <- osprey::rADSL %>%
57		#' dplyr::mutate(TRTDURD = as.integer(TRTEDTM - TRTSDTM) + 1) %>%
58		#' dplyr::filter(STRATA1 == 'A' & ARMCD == 'ARM A')"),
59		#' cdisc_dataset("ADRS", ADRS,
60		#' code = "ADRS <- rADRS
61		#' ADRS <- ADRS %>% dplyr::filter(PARAMCD == 'LSTASDI' & DCSREAS == 'Death') %>%
62		#' mutate(AVALC = DCSREAS, ADY = EOSDY) %>%
63		#' rbind(ADRS %>% dplyr::filter(PARAMCD == 'OVRINV' & AVALC != 'NE')) %>%
64		#' arrange(USUBJID)"
65		#' ),
66		#' check = TRUE
67		#' ),
68		#' modules = modules(
69		#' tm_g_swimlane(
70		#' label = "Swimlane Plot",
71		#' dataname = "ADRS",
72		#' bar_var = teal.transform::choices_selected(
73		#' selected = "TRTDURD",
74		#' choices = c("TRTDURD", "EOSDY")
75		#' ),
76		#' bar_color_var = teal.transform::choices_selected(
77		#' selected = "EOSSTT",
78		#' choices = c("EOSSTT", "ARM", "ARMCD", "ACTARM", "ACTARMCD", "SEX")
79		#' ),
80		#' sort_var = teal.transform::choices_selected(
81		#' selected = "ACTARMCD",
82		#' choices = c("USUBJID", "SITEID", "ACTARMCD", "TRTDURD")
83		#' ),
84		#' marker_pos_var = teal.transform::choices_selected(
85		#' selected = "ADY",
86		#' choices = c("ADY")
87		#' ),
88		#' marker_shape_var = teal.transform::choices_selected(
89		#' selected = "AVALC",
90		#' c("AVALC", "AVISIT")
91		#' ),
92		#' marker_shape_opt = c("CR" = 16, "PR" = 17, "SD" = 18, "PD" = 15, "Death" = 8),
93		#' marker_color_var = teal.transform::choices_selected(
94		#' selected = "AVALC",
95		#' choices = c("AVALC", "AVISIT")
96		#' ),
97		#' marker_color_opt = c(
98		#' "CR" = "green", "PR" = "blue", "SD" = "goldenrod",
99		#' "PD" = "red", "Death" = "black"
100		#' ),
101		#' vref_line = c(30, 60),
102		#' anno_txt_var = teal.transform::choices_selected(
103		#' selected = c("ACTARM", "SEX"),
104		#' choices = c(
105		#' "ARM", "ARMCD", "ACTARM", "ACTARMCD", "AGEGR1",
106		#' "SEX", "RACE", "COUNTRY", "DCSREAS", "DCSREASP"
107		#' )
108		#' )
109		#' )
110		#' )
111		#' )
112		#' if (interactive()) {
113		#' shinyApp(app$ui, app$server)
114		#' }
115		#'
116		tm_g_swimlane <- function(label,
117		dataname,
118		bar_var,
119		bar_color_var = NULL,
120		sort_var = NULL,
121		marker_pos_var = NULL,
122		marker_shape_var = NULL,
123		marker_shape_opt = NULL,
124		marker_color_var = NULL,
125		marker_color_opt = NULL,
126		anno_txt_var = NULL,
127		vref_line = NULL,
128		plot_height = c(1200L, 400L, 5000L),
129		plot_width = NULL,
130		pre_output = NULL,
131		post_output = NULL,
132		x_label = "Time from First Treatment (Day)") {
133	!	logger::log_info("Initializing tm_g_swimlane")
134	!	args <- as.list(environment())
135
136	!	checkmate::assert_string(label)
137	!	checkmate::assert_string(dataname)
138	!	checkmate::assert_class(bar_var, classes = "choices_selected")
139	!	checkmate::assert_class(bar_color_var, classes = "choices_selected")
140	!	checkmate::assert_class(marker_pos_var, classes = "choices_selected")
141	!	checkmate::assert_class(marker_shape_var, classes = "choices_selected")
142	!	checkmate::assert_numeric(marker_shape_opt, min.len = 1, any.missing = FALSE)
143	!	checkmate::assert_class(marker_color_var, classes = "choices_selected")
144	!	checkmate::assert_character(marker_color_opt, min.len = 1, any.missing = FALSE, null.ok = TRUE)
145	!	checkmate::assert_class(anno_txt_var, classes = "choices_selected")
146	!	checkmate::assert_numeric(vref_line, min.len = 1, null.ok = TRUE, any.missing = FALSE)
147	!	checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
148	!	checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")
149	!	checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
150	!	checkmate::assert_numeric(
151	!	plot_width[1],
152	!	lower = plot_width[2],
153	!	upper = plot_width[3],
154	!	null.ok = TRUE,
155	!	.var.name = "plot_width"
156		)
157	!	checkmate::assert_string(x_label)
158
159
160	!	module(
161	!	label = label,
162	!	ui = ui_g_swimlane,
163	!	ui_args = args,
164	!	server = srv_g_swimlane,
165	!	server_args = list(
166	!	dataname = dataname,
167	!	marker_pos_var = marker_pos_var,
168	!	marker_shape_var = marker_shape_var,
169	!	marker_shape_opt = marker_shape_opt,
170	!	marker_color_var = marker_color_var,
171	!	marker_color_opt = marker_color_opt,
172	!	label = label,
173	!	plot_height = plot_height,
174	!	plot_width = plot_width,
175	!	x_label = x_label
176		),
177	!	datanames = c("ADSL", dataname)
178		)
179		}
180
181
182		ui_g_swimlane <- function(id, ...) {
183	!	a <- list(...)
184	!	ns <- NS(id)
185
186	!	shiny::tagList(
187	!	include_css_files("custom"),
188	!	teal.widgets::standard_layout(
189	!	output = teal.widgets::white_small_well(
190	!	teal.widgets::plot_with_settings_ui(id = ns("swimlaneplot"))
191		),
192	!	encoding = div(
193		### Reporter
194	!	teal.reporter::simple_reporter_ui(ns("simple_reporter")),
195		###
196	!	tags$label("Encodings", class = "text-primary"),
197	!	helpText("Analysis data:", code(a$dataname)),
198	!	div(
199	!	class = "pretty-left-border",
200	!	teal.widgets::optionalSelectInput(
201	!	ns("bar_var"),
202	!	"Bar Length",
203	!	choices = a$bar_var$choices,
204	!	selected = a$bar_var$selected,
205	!	multiple = FALSE,
206	!	label_help = helpText("from ", code("ADSL"))
207		),
208	!	teal.widgets::optionalSelectInput(
209	!	ns("bar_color_var"),
210	!	"Bar Color",
211	!	choices = a$bar_color_var$choices,
212	!	selected = a$bar_color_var$selected,
213	!	multiple = FALSE,
214	!	label_help = helpText("from ", code("ADSL"))
215		)
216		),
217	!	teal.widgets::optionalSelectInput(
218	!	ns("sort_var"),
219	!	"Sort by",
220	!	choices = a$sort_var$choices,
221	!	selected = a$sort_var$selected,
222	!	multiple = FALSE,
223	!	label_help = helpText("from ", code("ADSL"))
224		),
225	!	div(
226	!	class = "pretty-left-border",
227	!	if (a$dataname == "ADSL") {
228	!	NULL
229	!	} else if (is.null(a$marker_pos_var)) {
230	!	NULL
231		} else {
232	!	teal.widgets::optionalSelectInput(
233	!	ns("marker_pos_var"),
234	!	"Marker Position",
235	!	choices = a$marker_pos_var$choices,
236	!	selected = a$marker_pos_var$selected,
237	!	multiple = FALSE,
238	!	label_help = helpText("from ", code(a$dataname))
239		)
240		},
241	!	uiOutput(ns("marker_shape_sel")),
242	!	uiOutput(ns("marker_color_sel"))
243		),
244	!	teal.widgets::optionalSelectInput(
245	!	ns("anno_txt_var"),
246	!	"Annotation Variables",
247	!	choices = a$anno_txt_var$choices,
248	!	selected = a$anno_txt_var$selected,
249	!	multiple = TRUE,
250	!	label_help = helpText("from ", code("ADSL"))
251		),
252	!	textInput(
253	!	ns("vref_line"),
254	!	label = div(
255	!	"Vertical Reference Line(s)",
256	!	tags$br(),
257	!	helpText("Enter numeric value(s) of reference lines, separated by comma (eg. 100, 200)")
258		),
259	!	value = paste(a$vref_line, collapse = ", ")
260		)
261		),
262	!	forms = tagList(
263	!	teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
264	!	teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
265		),
266	!	pre_output = a$pre_output,
267	!	post_output = a$post_output
268		)
269		)
270		}
271
272		srv_g_swimlane <- function(id,
273		data,
274		filter_panel_api,
275		reporter,
276		dataname,
277		marker_pos_var,
278		marker_shape_var,
279		marker_shape_opt,
280		marker_color_var,
281		marker_color_opt,
282		label,
283		plot_height,
284		plot_width,
285		x_label) {
286	!	with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
287	!	with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
288	!	checkmate::assert_class(data, "tdata")
289
290	!	moduleServer(id, function(input, output, session) {
291	!	iv <- reactive({
292	!	iv <- shinyvalidate::InputValidator$new()
293	!	iv$add_rule("bar_var", shinyvalidate::sv_required(
294	!	message = "Bar Length is required"
295		))
296		# If reference lines are requested
297	!	iv$add_rule("vref_line", ~ if (anyNA(suppressWarnings(as_numeric_from_comma_sep_str(.)))) {
298	!	"Vertical Reference Line(s) are invalid"
299		})
300	!	iv$enable()
301	!	iv
302		})
303
304		# if marker position is NULL, then hide options for marker shape and color
305	!	output$marker_shape_sel <- renderUI({
306	!	if (dataname == "ADSL" \|\| is.null(marker_shape_var) \|\| is.null(input$marker_pos_var)) {
307	!	NULL
308		} else {
309	!	ns <- session$ns
310	!	teal.widgets::optionalSelectInput(
311	!	ns("marker_shape_var"), "Marker Shape",
312	!	choices = marker_shape_var$choices,
313	!	selected = marker_shape_var$selected, multiple = FALSE,
314	!	label_help = helpText("from ", code(dataname))
315		)
316		}
317		})
318	!	output$marker_color_sel <- renderUI({
319	!	if (dataname == "ADSL" \|\| is.null(marker_color_var) \|\| is.null(input$marker_pos_var)) {
320	!	NULL
321		} else {
322	!	ns <- session$ns
323	!	teal.widgets::optionalSelectInput(
324	!	ns("marker_color_var"), "Marker Color",
325	!	choices = marker_color_var$choices,
326	!	selected = marker_color_var$selected, multiple = FALSE,
327	!	label_help = helpText("from ", code(dataname))
328		)
329		}
330		})
331
332		# create plot
333	!	output_q <- reactive({
334	!	teal::validate_inputs(iv())
335
336	!	validate(need("ADSL" %in% names(data), "'ADSL' not included in data"))
337	!	validate(need(
338	!	(length(data) == 1 && dataname == "ADSL") \|\|
339	!	(length(data) >= 2 && dataname != "ADSL"), paste(
340	!	"Please either add just 'ADSL' as dataname when just ADSL is available.",
341	!	"In case 2 datasets are available ADSL is not supposed to be the dataname."
342		)
343		))
344
345	!	ADSL <- data[["ADSL"]]() # nolint
346
347	!	anl_vars <- unique(c(
348	!	"USUBJID", "STUDYID",
349	!	input$marker_pos_var, input$marker_shape_var, input$marker_color_var
350	!	)) # nolint
351	!	adsl_vars <- unique(c(
352	!	"USUBJID", "STUDYID",
353	!	input$bar_var, input$bar_color_var, input$sort_var, input$anno_txt_var
354		))
355
356	!	if (dataname == "ADSL") {
357	!	teal::validate_has_data(ADSL, min_nrow = 3)
358	!	teal::validate_has_variable(ADSL, adsl_vars)
359		} else {
360	!	anl <- data[[dataname]]()
361	!	teal::validate_has_data(anl, min_nrow = 3)
362	!	teal::validate_has_variable(anl, anl_vars)
363
364	!	validate(need(
365	!	!any(c(marker_pos_var, marker_shape_var, marker_color_var) %in% adsl_vars),
366	!	"marker-related variables need to come from marker data"
367		))
368		}
369
370		# VARIABLE GETTERS
371		# lookup bar variables
372	!	bar_var <- input$bar_var
373	!	bar_color_var <- input$bar_color_var
374	!	sort_var <- input$sort_var
375	!	anno_txt_var <- input$anno_txt_var
376
377		# Check if marker inputs can be used
378	!	if (dataname == "ADSL") {
379	!	marker_pos_var <- NULL
380	!	marker_shape_var <- NULL
381	!	marker_color_var <- NULL
382		} else {
383	!	marker_pos_var <- input$marker_pos_var
384	!	marker_shape_var <- input$marker_shape_var
385	!	marker_color_var <- input$marker_color_var
386		}
387	!	vref_line <- suppressWarnings(as_numeric_from_comma_sep_str(debounce(reactive(input$vref_line), 1500)()))
388
389	!	q1 <- teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data))
390
391	!	q2 <- teal.code::eval_code(
392	!	q1,
393	!	code = bquote({
394	!	bar_var <- .(bar_var)
395	!	bar_color_var <- .(bar_color_var)
396	!	sort_var <- .(sort_var)
397	!	marker_pos_var <- .(marker_pos_var)
398	!	marker_shape_var <- .(marker_shape_var)
399	!	marker_color_var <- .(marker_color_var)
400	!	anno_txt_var <- .(anno_txt_var)
401		})
402		)
403
404		# WRITE DATA SELECTION TO qenv
405	!	q3 <- if (dataname == "ADSL") {
406	!	teal.code::eval_code(
407	!	q2,
408	!	code = bquote({
409	!	ADSL_p <- ADSL # nolint
410	!	ADSL <- ADSL_p[, .(adsl_vars)] # nolint
411		# only take last part of USUBJID
412	!	ADSL$USUBJID <- unlist(lapply(strsplit(ADSL$USUBJID, "-", fixed = TRUE), tail, 1)) # nolint
413		})
414		)
415		} else {
416	!	teal.code::eval_code(
417	!	q2,
418	!	code = bquote({
419	!	ADSL_p <- ADSL # nolint
420	!	ANL_p <- .(as.name(dataname)) # nolint
421
422	!	ADSL <- ADSL_p[, .(adsl_vars)] # nolint
423	!	ANL <- merge( # nolint
424	!	x = ADSL,
425	!	y = ANL_p[, .(anl_vars)],
426	!	all.x = FALSE, all.y = FALSE,
427	!	by = c("USUBJID", "STUDYID")
428		)
429		# only take last part of USUBJID
430	!	ADSL$USUBJID <- unlist(lapply(strsplit(ADSL$USUBJID, "-", fixed = TRUE), tail, 1)) # nolint
431	!	ANL$USUBJID <- unlist(lapply(strsplit(ANL$USUBJID, "-", fixed = TRUE), tail, 1)) # nolint
432		})
433		)
434		}
435
436	!	plot_call <- if (dataname == "ADSL") {
437	!	bquote(
438	!	plot <- osprey::g_swimlane(
439	!	bar_id = ADSL[["USUBJID"]],
440	!	bar_length = ADSL[[bar_var]],
441	!	sort_by = .(if (length(sort_var) > 0) quote(ADSL[[sort_var]]) else NULL),
442	!	col_by = .(if (length(bar_color_var) > 0) quote(ADSL[[bar_color_var]]) else NULL),
443	!	marker_id = NULL,
444	!	marker_pos = NULL,
445	!	marker_shape = NULL,
446	!	marker_shape_opt = NULL,
447	!	marker_color = NULL,
448	!	marker_color_opt = NULL,
449	!	anno_txt = .(if (length(anno_txt_var) > 0) quote(ADSL[, anno_txt_var]) else NULL),
450	!	xref_line = .(vref_line),
451	!	xtick_at = waiver(),
452	!	xlab = .(x_label),
453	!	title = "Swimlane Plot"
454		)
455		)
456		} else {
457	!	bquote(
458	!	plot <- osprey::g_swimlane(
459	!	bar_id = ADSL[["USUBJID"]],
460	!	bar_length = ADSL[[bar_var]],
461	!	sort_by = .(if (length(sort_var) > 0) {
462	!	quote(ADSL[[sort_var]])
463		} else {
464	!	NULL
465		}),
466	!	col_by = .(if (length(bar_color_var) > 0) {
467	!	quote(ADSL[[bar_color_var]])
468		} else {
469	!	NULL
470		}),
471	!	marker_id = ANL[["USUBJID"]],
472	!	marker_pos = .(if (length(marker_pos_var) > 0) {
473	!	quote(ANL[[marker_pos_var]])
474		} else {
475	!	NULL
476		}),
477	!	marker_shape = .(if (length(marker_shape_var) > 0) {
478	!	quote(ANL[[marker_shape_var]])
479		} else {
480	!	NULL
481		}),
482	!	marker_shape_opt = .(if (length(marker_shape_var) == 0) {
483	!	NULL
484	!	} else if (length(marker_shape_var) > 0 &
485	!	all(unique(anl[[marker_shape_var]]) %in% names(marker_shape_opt)) == TRUE) {
486	!	bquote(.(marker_shape_opt))
487		} else {
488	!	NULL
489		}),
490	!	marker_color = .(if (length(marker_color_var) > 0) {
491	!	quote(ANL[[marker_color_var]])
492		} else {
493	!	NULL
494		}),
495	!	marker_color_opt = .(if (length(marker_color_var) == 0) {
496	!	NULL
497	!	} else if (length(marker_color_var) > 0 &
498	!	all(unique(anl[[marker_color_var]]) %in% names(marker_color_opt)) == TRUE) {
499	!	bquote(.(marker_color_opt))
500		} else {
501	!	NULL
502		}),
503	!	anno_txt = .(if (length(anno_txt_var) > 0) {
504	!	quote(ADSL[, anno_txt_var])
505		} else {
506	!	NULL
507		}),
508	!	xref_line = .(vref_line),
509	!	xtick_at = waiver(),
510	!	xlab = .(x_label),
511	!	title = "Swimlane Plot"
512		)
513		)
514		}
515
516	!	q4 <- teal.code::eval_code(q3, code = plot_call)
517	!	teal.code::eval_code(q4, quote(plot))
518		})
519
520	!	plot_r <- reactive(output_q()[["plot"]])
521
522		# Insert the plot into a plot_with_settings module from teal.widgets
523	!	pws <- teal.widgets::plot_with_settings_srv(
524	!	id = "swimlaneplot",
525	!	plot_r = plot_r,
526	!	height = plot_height,
527	!	width = plot_width
528		)
529
530	!	teal.widgets::verbatim_popup_srv(
531	!	id = "warning",
532	!	verbatim_content = reactive(teal.code::get_warnings(output_q())),
533	!	title = "Warning",
534	!	disabled = reactive(is.null(teal.code::get_warnings(output_q())))
535		)
536
537	!	teal.widgets::verbatim_popup_srv(
538	!	id = "rcode",
539	!	title = paste("R code for", label),
540	!	verbatim_content = reactive(teal.code::get_code(output_q()))
541		)
542
543		### REPORTER
544	!	if (with_reporter) {
545	!	card_fun <- function(comment) {
546	!	card <- teal::TealReportCard$new()
547	!	card$set_name("Swimlane")
548	!	card$append_text("Swimlane Plot", "header2")
549	!	if (with_filter) card$append_fs(filter_panel_api$get_filter_state())
550	!	if (!is.null(input$sort_var)) {
551	!	card$append_text("Selected Options", "header3")
552	!	card$append_text(paste("Sorted by:", input$sort_var))
553		}
554	!	card$append_text("Plot", "header3")
555	!	card$append_plot(plot_r(), dim = pws$dim())
556	!	if (!comment == "") {
557	!	card$append_text("Comment", "header3")
558	!	card$append_text(comment)
559		}
560	!	card$append_src(paste(teal.code::get_code(output_q()), collapse = "\n"))
561	!	card
562		}
563	!	teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
564		}
565		})
566		}

1		#' Spider plot Teal Module
2		#'
3		#' @description
4		#' `r lifecycle::badge("stable")`
5		#'
6		#' Display spider plot as a shiny module
7		#'
8		#' @inheritParams teal.widgets::standard_layout
9		#' @inheritParams argument_convention
10		#' @param x_var x-axis variables
11		#' @param y_var y-axis variables
12		#' @param marker_var variable dictates marker symbol
13		#' @param line_colorby_var variable dictates line color
14		#' @param vref_line vertical reference lines
15		#' @param href_line horizontal reference lines
16		#' @param anno_txt_var annotation text
17		#' @param legend_on boolean value for whether legend is displayed
18		#' @param xfacet_var variable for x facets
19		#' @param yfacet_var variable for y facets
20		#'
21		#' @inherit argument_convention return
22		#' @export
23		#'
24		#' @template author_zhanc107
25		#' @template author_liaoc10
26		#'
27		#' @examples
28		#'
29		#' # Example using stream (ADaM) dataset
30		#' library(dplyr)
31		#' library(nestcolor)
32		#'
33		#' ADSL <- osprey::rADSL
34		#' ADTR <- osprey::rADTR
35		#'
36		#' app <- teal::init(
37		#' data = cdisc_data(
38		#' cdisc_dataset("ADSL", ADSL, code = "ADSL <- osprey::rADSL"),
39		#' cdisc_dataset("ADTR", ADTR,
40		#' code = "ADTR <- osprey::rADTR",
41		#' keys = c("STUDYID", "USUBJID", "PARAMCD", "AVISIT")
42		#' ),
43		#' check = TRUE
44		#' ),
45		#' modules = modules(
46		#' tm_g_spiderplot(
47		#' label = "Spider plot",
48		#' dataname = "ADTR",
49		#' paramcd = teal.transform::choices_selected(
50		#' choices = "SLDINV",
51		#' selected = "SLDINV"
52		#' ),
53		#' x_var = teal.transform::choices_selected(
54		#' choices = "ADY",
55		#' selected = "ADY"
56		#' ),
57		#' y_var = teal.transform::choices_selected(
58		#' choices = c("PCHG", "CHG", "AVAL"),
59		#' selected = "PCHG"
60		#' ),
61		#' marker_var = teal.transform::choices_selected(
62		#' choices = c("SEX", "RACE", "USUBJID"),
63		#' selected = "SEX"
64		#' ),
65		#' line_colorby_var = teal.transform::choices_selected(
66		#' choices = c("SEX", "USUBJID", "RACE"),
67		#' selected = "SEX"
68		#' ),
69		#' xfacet_var = teal.transform::choices_selected(
70		#' choices = c("SEX", "ARM"),
71		#' selected = "SEX"
72		#' ),
73		#' yfacet_var = teal.transform::choices_selected(
74		#' choices = c("SEX", "ARM"),
75		#' selected = "ARM"
76		#' ),
77		#' vref_line = "10, 37",
78		#' href_line = "-20, 0"
79		#' )
80		#' )
81		#' )
82		#' if (interactive()) {
83		#' shinyApp(app$ui, app$server)
84		#' }
85		#'
86		tm_g_spiderplot <- function(label,
87		dataname,
88		paramcd,
89		x_var,
90		y_var,
91		marker_var,
92		line_colorby_var,
93		xfacet_var = NULL,
94		yfacet_var = NULL,
95		vref_line = NULL,
96		href_line = NULL,
97		anno_txt_var = TRUE,
98		legend_on = FALSE,
99		plot_height = c(600L, 200L, 2000L),
100		plot_width = NULL,
101		pre_output = NULL,
102		post_output = NULL) {
103	!	logger::log_info("Initializing tm_g_spiderplot")
104	!	checkmate::assert_class(paramcd, classes = "choices_selected")
105	!	checkmate::assert_class(x_var, classes = "choices_selected")
106	!	checkmate::assert_class(y_var, classes = "choices_selected")
107	!	checkmate::assert_class(marker_var, classes = "choices_selected")
108	!	checkmate::assert_class(line_colorby_var, classes = "choices_selected")
109	!	checkmate::assert_class(xfacet_var, classes = "choices_selected")
110	!	checkmate::assert_class(yfacet_var, classes = "choices_selected")
111	!	checkmate::assert_string(vref_line)
112	!	checkmate::assert_string(href_line)
113	!	checkmate::assert_flag(anno_txt_var)
114	!	checkmate::assert_flag(legend_on)
115	!	checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
116	!	checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")
117	!	checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
118	!	checkmate::assert_numeric(
119	!	plot_width[1],
120	!	lower = plot_width[2],
121	!	upper = plot_width[3],
122	!	null.ok = TRUE,
123	!	.var.name = "plot_width"
124		)
125
126	!	args <- as.list(environment())
127	!	module(
128	!	label = label,
129	!	datanames = c("ADSL", dataname),
130	!	server = srv_g_spider,
131	!	server_args = list(dataname = dataname, label = label, plot_height = plot_height, plot_width = plot_width),
132	!	ui = ui_g_spider,
133	!	ui_args = args
134		)
135		}
136
137		ui_g_spider <- function(id, ...) {
138	!	ns <- NS(id)
139	!	a <- list(...)
140
141	!	shiny::tagList(
142	!	include_css_files("custom"),
143	!	teal.widgets::standard_layout(
144	!	output = teal.widgets::white_small_well(
145	!	teal.widgets::plot_with_settings_ui(id = ns("spiderplot"))
146		),
147	!	encoding = div(
148		### Reporter
149	!	teal.reporter::simple_reporter_ui(ns("simple_reporter")),
150		###
151	!	tags$label("Encodings", class = "text-primary"),
152	!	helpText("Analysis data:", tags$code(a$dataname)),
153	!	div(
154	!	class = "pretty-left-border",
155	!	teal.widgets::optionalSelectInput(
156	!	ns("paramcd"),
157	!	paste("Parameter - from", a$dataname),
158	!	a$paramcd$choices,
159	!	a$paramcd$selected,
160	!	multiple = FALSE
161		),
162	!	teal.widgets::optionalSelectInput(
163	!	ns("x_var"),
164	!	"X-axis Variable",
165	!	a$x_var$choices,
166	!	a$x_var$selected,
167	!	multiple = FALSE
168		),
169	!	teal.widgets::optionalSelectInput(
170	!	ns("y_var"),
171	!	"Y-axis Variable",
172	!	a$y_var$choices,
173	!	a$y_var$selected,
174	!	multiple = FALSE
175		),
176	!	teal.widgets::optionalSelectInput(
177	!	ns("line_colorby_var"),
178	!	"Color By Variable (Line)",
179	!	a$line_colorby_var$choices,
180	!	a$line_colorby_var$selected,
181	!	multiple = FALSE
182		),
183	!	teal.widgets::optionalSelectInput(
184	!	ns("marker_var"),
185	!	"Marker Symbol By Variable",
186	!	a$marker_var$choices,
187	!	a$marker_var$selected,
188	!	multiple = FALSE
189		),
190	!	teal.widgets::optionalSelectInput(
191	!	ns("xfacet_var"),
192	!	"X-facet By Variable",
193	!	a$xfacet_var$choices,
194	!	a$xfacet_var$selected,
195	!	multiple = TRUE
196		),
197	!	teal.widgets::optionalSelectInput(
198	!	ns("yfacet_var"),
199	!	"Y-facet By Variable",
200	!	a$yfacet_var$choices,
201	!	a$yfacet_var$selected,
202	!	multiple = TRUE
203		)
204		),
205	!	checkboxInput(
206	!	ns("anno_txt_var"),
207	!	"Add subject ID label",
208	!	value = a$anno_txt_var
209		),
210	!	checkboxInput(
211	!	ns("legend_on"),
212	!	"Add legend",
213	!	value = a$legend_on
214		),
215	!	textInput(
216	!	ns("vref_line"),
217	!	label = div(
218	!	"Vertical Reference Line(s)",
219	!	tags$br(),
220	!	helpText("Enter numeric value(s) of vertical reference lines, separated by comma (eg. -2, 1)")
221		),
222	!	value = a$vref_line
223		),
224	!	textInput(
225	!	ns("href_line"),
226	!	label = div(
227	!	"Hortizontal Reference Line(s)",
228	!	tags$br(),
229	!	helpText("Enter numeric value(s) of horizontal reference lines, separated by comma (eg. -2, 1)")
230		),
231	!	value = a$href_line
232		)
233		),
234	!	forms = tagList(
235	!	teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
236	!	teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
237		),
238	!	pre_output = a$pre_output,
239	!	post_output = a$post_output
240		)
241		)
242		}
243
244		srv_g_spider <- function(id, data, filter_panel_api, reporter, dataname, label, plot_height, plot_width) {
245	!	with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
246	!	with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
247	!	checkmate::assert_class(data, "tdata")
248
249	!	moduleServer(id, function(input, output, session) {
250	!	iv <- reactive({
251	!	ADSL <- data[["ADSL"]]() # nolint
252	!	ADTR <- data[[dataname]]() # nolint
253
254	!	iv <- shinyvalidate::InputValidator$new()
255	!	iv$add_rule("paramcd", shinyvalidate::sv_required(
256	!	message = "Parameter is required"
257		))
258	!	iv$add_rule("x_var", shinyvalidate::sv_required(
259	!	message = "X Axis Variable is required"
260		))
261	!	iv$add_rule("y_var", shinyvalidate::sv_required(
262	!	message = "Y Axis Variable is required"
263		))
264	!	iv$add_rule("line_colorby_var", shinyvalidate::sv_required(
265	!	message = "Color Variable is required"
266		))
267	!	iv$add_rule("marker_var", shinyvalidate::sv_required(
268	!	message = "Marker Symbol Variable is required"
269		))
270	!	fac_dupl <- function(value, other) {
271	!	if (length(value) * length(other) > 0L && anyDuplicated(c(value, other))) {
272	!	"X- and Y-facet Variables must not overlap"
273		}
274		}
275	!	iv$add_rule("xfacet_var", fac_dupl, other = input$yfacet_var)
276	!	iv$add_rule("yfacet_var", fac_dupl, other = input$xfacet_var)
277	!	iv$add_rule("vref_line", ~ if (anyNA(suppressWarnings(as_numeric_from_comma_sep_str(.)))) {
278	!	"Vertical Reference Line(s) are invalid"
279		})
280	!	iv$add_rule("href_line", ~ if (anyNA(suppressWarnings(as_numeric_from_comma_sep_str(.)))) {
281	!	"Horizontal Reference Line(s) are invalid"
282		})
283	!	iv$enable()
284		})
285
286	!	vals <- reactiveValues(spiderplot = NULL) # nolint
287
288		# render plot
289	!	output_q <- reactive({
290		# get datasets ---
291	!	ADSL <- data[["ADSL"]]() # nolint
292	!	ADTR <- data[[dataname]]() # nolint
293
294	!	teal::validate_inputs(iv())
295
296	!	teal::validate_has_data(ADSL, min_nrow = 1, msg = sprintf("%s data has zero rows", "ADSL"))
297	!	teal::validate_has_data(ADTR, min_nrow = 1, msg = sprintf("%s data has zero rows", dataname))
298
299	!	paramcd <- input$paramcd # nolint
300	!	x_var <- input$x_var
301	!	y_var <- input$y_var
302	!	marker_var <- input$marker_var
303	!	line_colorby_var <- input$line_colorby_var
304	!	anno_txt_var <- input$anno_txt_var
305	!	legend_on <- input$legend_on # nolint
306	!	xfacet_var <- input$xfacet_var
307	!	yfacet_var <- input$yfacet_var
308	!	vref_line <- input$vref_line
309	!	href_line <- input$href_line
310
311		# reference lines preprocessing
312	!	vref_line <- as_numeric_from_comma_sep_str(vref_line)
313	!	href_line <- as_numeric_from_comma_sep_str(href_line)
314
315		# define variables ---
316		# if variable is not in ADSL, then take from domain VADs
317	!	varlist <- c(xfacet_var, yfacet_var, marker_var, line_colorby_var)
318	!	varlist_from_adsl <- varlist[varlist %in% names(ADSL)]
319	!	varlist_from_anl <- varlist[!varlist %in% names(ADSL)]
320
321	!	adsl_vars <- unique(c("USUBJID", "STUDYID", varlist_from_adsl)) # nolint
322	!	adtr_vars <- unique(c("USUBJID", "STUDYID", "PARAMCD", x_var, y_var, varlist_from_anl))
323
324		# preprocessing of datasets to qenv ---
325
326		# vars definition
327	!	adtr_vars <- adtr_vars[adtr_vars != "None"]
328	!	adtr_vars <- adtr_vars[!is.null(adtr_vars)]
329
330		# merge
331	!	q1 <- teal.code::eval_code(
332	!	teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)),
333	!	code = bquote({
334	!	ADSL <- ADSL[, .(adsl_vars)] %>% as.data.frame() # nolint
335	!	ADTR <- .(as.name(dataname))[, .(adtr_vars)] %>% as.data.frame() # nolint
336
337	!	ANL <- merge(ADSL, ADTR, by = c("USUBJID", "STUDYID")) # nolint
338	!	ANL <- ANL %>% # nolint
339	!	group_by(USUBJID, PARAMCD) %>%
340	!	arrange(ANL[, .(x_var)]) %>%
341	!	as.data.frame()
342		})
343		)
344
345		# format and filter
346	!	q1 <- teal.code::eval_code(
347	!	q1,
348	!	code = bquote({
349	!	ANL$USUBJID <- unlist(lapply(strsplit(ANL$USUBJID, "-", fixed = TRUE), tail, 1)) # nolint
350	!	ANL_f <- ANL %>% # nolint
351	!	filter(PARAMCD == .(paramcd)) %>%
352	!	as.data.frame()
353		})
354		)
355
356		# label
357	!	q1 <- if (anno_txt_var) {
358	!	teal.code::eval_code(
359	!	q1,
360	!	code = quote(lbl <- list(txt_ann = as.factor(ANL_f$USUBJID)))
361		)
362		} else {
363	!	teal.code::eval_code(q1, code = quote(lbl <- NULL))
364		}
365
366		# plot code to qenv ---
367
368	!	q1 <- teal.code::eval_code(
369	!	q1,
370	!	code = bquote({
371	!	plot <- osprey::g_spiderplot(
372	!	marker_x = ANL_f[, .(x_var)],
373	!	marker_id = ANL_f$USUBJID,
374	!	marker_y = ANL_f[, .(y_var)],
375	!	line_colby = .(if (line_colorby_var != "None") {
376	!	bquote(ANL_f[, .(line_colorby_var)])
377		} else {
378	!	NULL
379		}),
380	!	marker_shape = .(if (marker_var != "None") {
381	!	bquote(ANL_f[, .(marker_var)])
382		} else {
383	!	NULL
384		}),
385	!	marker_size = 4,
386	!	datalabel_txt = lbl,
387	!	facet_rows = .(if (!is.null(yfacet_var)) {
388	!	bquote(data.frame(ANL_f[, .(yfacet_var)]))
389		} else {
390	!	NULL
391		}),
392	!	facet_columns = .(if (!is.null(xfacet_var)) {
393	!	bquote(data.frame(ANL_f[, .(xfacet_var)]))
394		} else {
395	!	NULL
396		}),
397	!	vref_line = .(vref_line),
398	!	href_line = .(href_line),
399	!	x_label = if (is.null(formatters::var_labels(ADTR[.(x_var)], fill = FALSE))) {
400	!	.(x_var)
401		} else {
402	!	formatters::var_labels(ADTR[.(x_var)], fill = FALSE)
403		},
404	!	y_label = if (is.null(formatters::var_labels(ADTR[.(y_var)], fill = FALSE))) {
405	!	.(y_var)
406		} else {
407	!	formatters::var_labels(ADTR[.(y_var)], fill = FALSE)
408		},
409	!	show_legend = .(legend_on)
410		)
411
412	!	plot
413		})
414		)
415		})
416
417	!	plot_r <- reactive(output_q()[["plot"]])
418
419	!	pws <- teal.widgets::plot_with_settings_srv(
420	!	id = "spiderplot",
421	!	plot_r = plot_r,
422	!	height = plot_height,
423	!	width = plot_width
424		)
425
426	!	teal.widgets::verbatim_popup_srv(
427	!	id = "warning",
428	!	verbatim_content = reactive(teal.code::get_warnings(output_q())),
429	!	title = "Warning",
430	!	disabled = reactive(is.null(teal.code::get_warnings(output_q())))
431		)
432
433	!	teal.widgets::verbatim_popup_srv(
434	!	id = "rcode",
435	!	title = paste("R code for", label),
436	!	verbatim_content = reactive(teal.code::get_code(output_q()))
437		)
438
439		### REPORTER
440	!	if (with_reporter) {
441	!	card_fun <- function(comment) {
442	!	card <- teal::TealReportCard$new()
443	!	card$set_name("Spider Plot")
444	!	card$append_text("Spider Plot", "header2")
445	!	if (with_filter) card$append_fs(filter_panel_api$get_filter_state())
446	!	if (!is.null(input$paramcd) \|\| !is.null(input$xfacet_var) \|\| !is.null(input$yfacet_var)) {
447	!	card$append_text("Selected Options", "header3")
448		}
449	!	if (!is.null(input$paramcd)) {
450	!	card$append_text(paste0("Parameter - (from ", dataname, "): ", input$paramcd, "."))
451		}
452	!	if (!is.null(input$xfacet_var)) {
453	!	card$append_text(paste0("Faceted horizontally by: ", paste(input$xfacet_var, collapse = ", "), "."))
454		}
455	!	if (!is.null(input$yfacet_var)) {
456	!	card$append_text(paste0("Faceted vertically by: ", paste(input$yfacet_var, collapse = ", "), "."))
457		}
458	!	card$append_text("Plot", "header3")
459	!	card$append_plot(plot_r(), dim = pws$dim())
460	!	if (!comment == "") {
461	!	card$append_text("Comment", "header3")
462	!	card$append_text(comment)
463		}
464	!	card$append_src(paste(teal.code::get_code(output_q()), collapse = "\n"))
465	!	card
466		}
467	!	teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
468		}
469		})
470		}

1		#' Teal module for the heatmap by grade
2		#'
3		#' @description
4		#' `r lifecycle::badge("stable")`
5		#'
6		#' Display the heatmap by grade as a shiny module
7		#'
8		#' @inheritParams teal.widgets::standard_layout
9		#' @inheritParams argument_convention
10		#' @param sl_dataname (\code{character}) subject level dataset name,
11		#' needs to be available in the list passed to the \code{data}
12		#' argument of \code{\link[teal]{init}}
13		#' @param ex_dataname (\code{character}) exposures dataset name,
14		#' needs to be available in the list passed to the \code{data}
15		#' argument of \code{\link[teal]{init}} \cr
16		#' @param ae_dataname (\code{character}) adverse events dataset name,
17		#' needs to be available in the list passed to the \code{data}
18		#' argument of \code{\link[teal]{init}} \cr
19		#' @param cm_dataname (\code{character}) concomitant medications dataset name,
20		#' needs to be available in the list passed to the \code{data}
21		#' argument of \code{\link[teal]{init}} \cr
22		#' specify to \code{NA} if no concomitant medications data is available
23		#' @param id_var (\code{choices_seleced}) unique subject ID variable
24		#' @param visit_var (\code{choices_seleced}) analysis visit variable
25		#' @param ongo_var (\code{choices_seleced}) study ongoing status variable,
26		#' This variable is a derived logical variable. Usually it can be derived from \code{EOSSTT}.
27		#' @param anno_var (\code{choices_seleced}) annotation variable
28		#' @param heat_var (\code{choices_seleced}) heatmap variable
29		#' @param conmed_var (\code{choices_seleced}) concomitant medications variable,
30		#' specify to \code{NA} if no concomitant medications data is available
31		#'
32		#' @inherit argument_convention return
33		#'
34		#' @export
35		#'
36		#' @examples
37		#' library(dplyr)
38		#' library(nestcolor)
39		#' ADSL <- osprey::rADSL %>% slice(1:30)
40		#' ADEX <- osprey::rADEX %>% filter(USUBJID %in% ADSL$USUBJID)
41		#' ADAE <- osprey::rADAE %>% filter(USUBJID %in% ADSL$USUBJID)
42		#' ADCM <- osprey::rADCM %>% filter(USUBJID %in% ADSL$USUBJID)
43		#'
44		#' # This preprocess is only to force legacy standard on ADCM
45		#' ADCM <- ADCM %>%
46		#' select(-starts_with("ATC")) %>%
47		#' unique()
48		#'
49		#' # function to derive AVISIT from ADEX
50		#' add_visit <- function(data_need_visit) {
51		#' visit_dates <- ADEX %>%
52		#' filter(PARAMCD == "DOSE") %>%
53		#' distinct(USUBJID, AVISIT, ASTDTM) %>%
54		#' group_by(USUBJID) %>%
55		#' arrange(ASTDTM) %>%
56		#' mutate(next_vis = lead(ASTDTM), is_last = ifelse(is.na(next_vis), TRUE, FALSE)) %>%
57		#' rename(this_vis = ASTDTM)
58		#' data_visit <- data_need_visit %>%
59		#' select(USUBJID, ASTDTM) %>%
60		#' left_join(visit_dates, by = "USUBJID") %>%
61		#' filter(ASTDTM > this_vis & (ASTDTM < next_vis \| is_last == TRUE)) %>%
62		#' left_join(data_need_visit) %>%
63		#' distinct()
64		#' return(data_visit)
65		#' }
66		#' # derive AVISIT for ADAE and ADCM
67		#' ADAE <- add_visit(ADAE)
68		#' ADCM <- add_visit(ADCM)
69		#' # derive ongoing status variable for ADEX
70		#' ADEX <- ADEX %>%
71		#' filter(PARCAT1 == "INDIVIDUAL") %>%
72		#' mutate(ongo_status = (EOSSTT == "ONGOING"))
73		#'
74		#' app <- init(
75		#' data = cdisc_data(
76		#' cdisc_dataset("ADSL", ADSL),
77		#' cdisc_dataset("ADEX", ADEX),
78		#' cdisc_dataset("ADAE", ADAE),
79		#' cdisc_dataset("ADCM", ADCM, keys = c("STUDYID", "USUBJID", "ASTDTM", "CMSEQ", "CMDECOD")),
80		#' code = "
81		#' ADSL <- osprey::rADSL %>% slice(1:30)
82		#' ADEX <- osprey::rADEX %>% filter(USUBJID %in% ADSL$USUBJID)
83		#' ADAE <- osprey::rADAE %>% filter(USUBJID %in% ADSL$USUBJID)
84		#' ADCM <- osprey::rADCM %>% filter(USUBJID %in% ADSL$USUBJID)
85		#' ADCM <- ADCM %>% select(-starts_with(\"ATC\")) %>% unique()
86		#' ADEX <- ADEX %>%
87		#' filter(PARCAT1 == 'INDIVIDUAL') %>%
88		#' mutate(ongo_status = (EOSSTT == 'ONGOING'))
89		#' add_visit <- function(data_need_visit) {
90		#' visit_dates <- ADEX %>%
91		#' filter(PARAMCD == 'DOSE') %>%
92		#' distinct(USUBJID, AVISIT, ASTDTM) %>%
93		#' group_by(USUBJID) %>%
94		#' arrange(ASTDTM) %>%
95		#' mutate(next_vis = lead(ASTDTM), is_last = ifelse(is.na(next_vis), TRUE, FALSE)) %>%
96		#' rename(this_vis = ASTDTM)
97		#' data_visit <- data_need_visit %>%
98		#' select(USUBJID, ASTDTM) %>%
99		#' left_join(visit_dates, by = 'USUBJID') %>%
100		#' filter(ASTDTM > this_vis & (ASTDTM < next_vis \| is_last == TRUE)) %>%
101		#' left_join(data_need_visit) %>% distinct()
102		#' return(data_visit)
103		#' }
104		#' ADAE <- add_visit(ADAE)
105		#' ADCM <- add_visit(ADCM)
106		#' ",
107		#' check = TRUE
108		#' ),
109		#' modules = modules(
110		#' tm_g_heat_bygrade(
111		#' label = "Heatmap by grade",
112		#' sl_dataname = "ADSL",
113		#' ex_dataname = "ADEX",
114		#' ae_dataname = "ADAE",
115		#' cm_dataname = "ADCM",
116		#' id_var = teal.transform::choices_selected(
117		#' selected = "USUBJID",
118		#' choices = c("USUBJID", "SUBJID")
119		#' ),
120		#' visit_var = teal.transform::choices_selected(
121		#' selected = "AVISIT",
122		#' choices = c("AVISIT")
123		#' ),
124		#' ongo_var = teal.transform::choices_selected(
125		#' selected = "ongo_status",
126		#' choices = c("ongo_status")
127		#' ),
128		#' anno_var = teal.transform::choices_selected(
129		#' selected = c("SEX", "COUNTRY"),
130		#' choices = c("SEX", "COUNTRY", "USUBJID")
131		#' ),
132		#' heat_var = teal.transform::choices_selected(
133		#' selected = "AETOXGR",
134		#' choices = c("AETOXGR")
135		#' ),
136		#' conmed_var = teal.transform::choices_selected(
137		#' selected = "CMDECOD",
138		#' choices = c("CMDECOD")
139		#' ),
140		#' plot_height = c(600, 200, 2000)
141		#' )
142		#' )
143		#' )
144		#' if (interactive()) {
145		#' shinyApp(app$ui, app$server)
146		#' }
147		tm_g_heat_bygrade <- function(label,
148		sl_dataname,
149		ex_dataname,
150		ae_dataname,
151		cm_dataname = NA,
152		id_var,
153		visit_var,
154		ongo_var,
155		anno_var,
156		heat_var,
157		conmed_var = NULL,
158		fontsize = c(5, 3, 7),
159		plot_height = c(600L, 200L, 2000L),
160		plot_width = NULL) {
161	!	logger::log_info("Initializing tm_g_heat_bygrade")
162	!	args <- as.list(environment())
163
164	!	checkmate::assert_string(label)
165	!	checkmate::assert_string(sl_dataname)
166	!	checkmate::assert_string(ex_dataname)
167	!	checkmate::assert_string(ae_dataname)
168	!	checkmate::assert_string(cm_dataname, na.ok = TRUE)
169	!	checkmate::assert_class(id_var, classes = "choices_selected")
170	!	checkmate::assert_class(visit_var, classes = "choices_selected")
171	!	checkmate::assert_class(ongo_var, classes = "choices_selected")
172	!	checkmate::assert_class(anno_var, classes = "choices_selected")
173	!	checkmate::assert_class(heat_var, classes = "choices_selected")
174	!	checkmate::assert_class(conmed_var, classes = "choices_selected", null.ok = TRUE)
175	!	checkmate::assert(
176	!	checkmate::check_number(fontsize, finite = TRUE),
177	!	checkmate::assert(
178	!	combine = "and",
179	!	.var.name = "fontsize",
180	!	checkmate::check_numeric(fontsize, len = 3, any.missing = FALSE, finite = TRUE),
181	!	checkmate::check_numeric(fontsize[1], lower = fontsize[2], upper = fontsize[3])
182		)
183		)
184	!	checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
185	!	checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")
186	!	checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
187	!	checkmate::assert_numeric(
188	!	plot_width[1],
189	!	lower = plot_width[2],
190	!	upper = plot_width[3],
191	!	null.ok = TRUE,
192	!	.var.name = "plot_width"
193		)
194
195	!	module(
196	!	label = label,
197	!	server = srv_g_heatmap_bygrade,
198	!	server_args = list(
199	!	label = label,
200	!	sl_dataname = sl_dataname,
201	!	ex_dataname = ex_dataname,
202	!	ae_dataname = ae_dataname,
203	!	cm_dataname = cm_dataname,
204	!	plot_height = plot_height,
205	!	plot_width = plot_width
206		),
207	!	ui = ui_g_heatmap_bygrade,
208	!	ui_args = args,
209	!	datanames = "all"
210		)
211		}
212
213		ui_g_heatmap_bygrade <- function(id, ...) {
214	!	ns <- NS(id)
215	!	args <- list(...)
216
217	!	shiny::tagList(
218	!	include_css_files("custom"),
219	!	teal.widgets::standard_layout(
220	!	output = teal.widgets::white_small_well(
221	!	plot_decorate_output(id = ns(NULL))
222		),
223	!	encoding = div(
224		### Reporter
225	!	teal.reporter::simple_reporter_ui(ns("simple_reporter")),
226		###
227	!	teal.widgets::optionalSelectInput(
228	!	ns("id_var"),
229	!	"ID Variable",
230	!	choices = args$id_var$choices,
231	!	selected = args$id_var$selected,
232	!	multiple = FALSE
233		),
234	!	teal.widgets::optionalSelectInput(
235	!	ns("visit_var"),
236	!	"Visit Variable",
237	!	choices = args$visit_var$choices,
238	!	selected = args$visit_var$selected,
239	!	multiple = FALSE
240		),
241	!	teal.widgets::optionalSelectInput(
242	!	ns("ongo_var"),
243	!	"Study Ongoing Status Variable",
244	!	choices = args$ongo_var$choices,
245	!	selected = args$ongo_var$selected,
246	!	multiple = FALSE
247		),
248	!	teal.widgets::optionalSelectInput(
249	!	ns("anno_var"),
250	!	"Annotation Variables",
251	!	choices = args$anno_var$choices,
252	!	selected = args$anno_var$selected,
253	!	multiple = TRUE
254		),
255	!	teal.widgets::optionalSelectInput(
256	!	ns("heat_var"),
257	!	"Heat Variable",
258	!	choices = args$heat_var$choices,
259	!	selected = args$heat_var$selected,
260	!	multiple = FALSE
261		),
262	!	helpText("Plot conmed"),
263	!	div(
264	!	class = "pretty-left-border",
265	!	if (!is.na(args$cm_dataname)) {
266	!	checkboxInput(
267	!	ns("plot_cm"),
268	!	"Yes",
269	!	value = !is.na(args$cm_dataname)
270		)
271		}
272		),
273	!	conditionalPanel(
274	!	paste0("input['", ns("plot_cm"), "']"),
275	!	teal.widgets::optionalSelectInput(
276	!	ns("conmed_var"),
277	!	"Conmed Variable",
278	!	choices = args$conmed_var$choices,
279	!	selected = args$conmed_var$selected,
280	!	multiple = FALSE
281		),
282	!	selectInput(
283	!	ns("conmed_level"),
284	!	"Conmed Levels",
285	!	choices = args$conmed_var$choices,
286	!	selected = args$conmed_var$selected,
287	!	multiple = TRUE
288		)
289		),
290	!	ui_g_decorate(
291	!	ns(NULL),
292	!	fontsize = args$fontsize,
293	!	titles = "Heatmap by Grade",
294	!	footnotes = ""
295		)
296		),
297	!	forms = tagList(
298	!	teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
299	!	teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
300		)
301		)
302		)
303		}
304
305		srv_g_heatmap_bygrade <- function(id,
306		data,
307		filter_panel_api,
308		reporter,
309		sl_dataname,
310		ex_dataname,
311		ae_dataname,
312		cm_dataname,
313		label,
314		plot_height,
315		plot_width) {
316	!	with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
317	!	with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
318	!	checkmate::assert_class(data, "tdata")
319	!	if (!is.na(sl_dataname)) checkmate::assert_names(sl_dataname, subset.of = names(data))
320	!	if (!is.na(ex_dataname)) checkmate::assert_names(ex_dataname, subset.of = names(data))
321	!	if (!is.na(ae_dataname)) checkmate::assert_names(ae_dataname, subset.of = names(data))
322	!	if (!is.na(cm_dataname)) checkmate::assert_names(cm_dataname, subset.of = names(data))
323
324	!	moduleServer(id, function(input, output, session) {
325	!	iv <- reactive({
326	!	ADSL <- data[[sl_dataname]]() # nolint
327	!	ADEX <- data[[ex_dataname]]() # nolint
328	!	ADAE <- data[[ae_dataname]]() # nolint
329	!	if (isTRUE(input$plot_cm)) {
330	!	ADCM <- data[[cm_dataname]]() # nolint
331		}
332
333	!	iv <- shinyvalidate::InputValidator$new()
334	!	iv$add_rule("id_var", shinyvalidate::sv_required(
335	!	message = "ID Variable is required"
336		))
337	!	iv$add_rule("visit_var", shinyvalidate::sv_required(
338	!	message = "Visit Variable is required"
339		))
340	!	iv$add_rule("ongo_var", shinyvalidate::sv_required(
341	!	message = "Study Ongoing Status Variable is required"
342		))
343	!	iv$add_rule("ongo_var", shinyvalidate::sv_in_set(
344	!	set = names(ADEX),
345	!	message_fmt = sprintf("Study Ongoing Status must be a variable in %s", ex_dataname)
346		))
347	!	iv$add_rule("ongo_var", ~ if (!is.logical(ADEX[[req(.)]])) {
348	!	"Study Ongoing Status must be a logical variable"
349		})
350	!	iv$add_rule("anno_var", shinyvalidate::sv_required(
351	!	message = "Annotation Variables is required"
352		))
353	!	iv$add_rule("anno_var", ~ if (length(.) > 2L) {
354	!	"No more than two Annotation Variables are allowed"
355		})
356	!	iv$add_rule("anno_var", shinyvalidate::sv_in_set(
357	!	set = names(ADSL),
358	!	message_fmt = sprintf("Study Ongoing Status must be a variable in %s", sl_dataname)
359		))
360	!	iv$add_rule("anno_var", ~ if (isTRUE(input$id_var %in% .)) {
361	!	sprintf("Deselect %s in Annotation Variables", input$id_var)
362		})
363	!	iv$add_rule("heat_var", shinyvalidate::sv_required(
364	!	message = "Heat Variable is required"
365		))
366	!	iv$enable()
367	!	iv
368		})
369	!	iv_cm <- reactive({
370	!	ADSL <- data[[sl_dataname]]() # nolint
371	!	ADEX <- data[[ex_dataname]]() # nolint
372	!	ADAE <- data[[ae_dataname]]() # nolint
373	!	if (isTRUE(input$plot_cm)) {
374	!	ADCM <- data[[cm_dataname]]() # nolint
375		}
376
377	!	iv_cm <- shinyvalidate::InputValidator$new()
378	!	iv_cm$condition(~ isTRUE(input$plot_cm))
379	!	iv_cm$add_rule("conmed_var", shinyvalidate::sv_required(
380	!	message = "Conmed Variable is required"
381		))
382	!	iv_cm$add_rule("conmed_var", shinyvalidate::sv_in_set(
383	!	set = names(ADCM),
384	!	message_fmt = sprintf("Conmed Variable must be a variable in %s", cm_dataname)
385		))
386	!	iv_cm$add_rule("conmed_var", ~ if (!is.factor(ADCM[[.]])) {
387	!	"Study Ongoing Status must be a factor variable"
388		})
389	!	iv_cm$add_rule("conmed_level", shinyvalidate::sv_required(
390	!	"Select Conmed Levels"
391		))
392	!	iv_cm$add_rule("conmed_level", ~ if (length(.) > 3L) {
393	!	"No more than three Conmed Levels are allowed"
394		})
395	!	iv_cm$enable()
396	!	iv_cm
397		})
398
399	!	decorate_output <- srv_g_decorate(
400	!	id = NULL,
401	!	plt = plot_r,
402	!	plot_height = plot_height,
403	!	plot_width = plot_width
404	!	) # nolint
405	!	font_size <- decorate_output$font_size
406	!	pws <- decorate_output$pws
407
408	!	if (!is.na(cm_dataname)) {
409	!	observeEvent(input$conmed_var, {
410	!	ADCM <- data[[cm_dataname]]() # nolint
411	!	choices <- levels(ADCM[[input$conmed_var]])
412
413	!	updateSelectInput(
414	!	session,
415	!	"conmed_level",
416	!	selected = choices[1:3],
417	!	choices = choices
418		)
419		})
420		}
421
422	!	output_q <- shiny::debounce(
423	!	millis = 200,
424	!	r = reactive({
425	!	ADSL <- data[[sl_dataname]]() # nolint
426	!	ADEX <- data[[ex_dataname]]() # nolint
427	!	ADAE <- data[[ae_dataname]]() # nolint
428
429	!	teal::validate_has_data(ADSL, min_nrow = 1, msg = sprintf("%s contains no data", sl_dataname))
430	!	teal::validate_inputs(iv(), iv_cm())
431	!	if (isTRUE(input$plot_cm)) {
432	!	shiny::validate(shiny::need(all(input$conmed_level %in% ADCM[[input$conmed_var]]), "Updating Conmed Levels"))
433		}
434
435	!	qenv <- teal.code::new_qenv(tdata2env(data), code = teal::get_code_tdata(data))
436	!	if (isTRUE(input$plot_cm)) {
437	!	ADCM <- data[[cm_dataname]]() # nolint
438	!	qenv <- teal.code::eval_code(
439	!	qenv,
440	!	code = substitute(
441	!	expr = {
442	!	conmed_data <- ADCM %>%
443	!	filter(conmed_var_name %in% conmed_level)
444	!	conmed_data[[conmed_var]] <-
445	!	factor(conmed_data[[conmed_var]], levels = unique(conmed_data[[conmed_var]]))
446	!	formatters::var_labels(conmed_data)[conmed_var] <-
447	!	formatters::var_labels(ADCM, fill = FALSE)[conmed_var]
448		},
449	!	env = list(
450	!	ADCM = as.name(cm_dataname),
451	!	conmed_var = input$conmed_var,
452	!	conmed_var_name = as.name(input$conmed_var),
453	!	conmed_level = input$conmed_level
454		)
455		)
456		)
457		}
458
459	!	qenv <- teal.code::eval_code(
460	!	qenv,
461	!	code = bquote(
462	!	plot <- osprey::g_heat_bygrade(
463	!	id_var = .(input$id_var),
464	!	exp_data = .(as.name(ex_dataname)) %>% filter(PARCAT1 == "INDIVIDUAL"),
465	!	visit_var = .(input$visit_var),
466	!	ongo_var = .(input$ongo_var),
467	!	anno_data = .(as.name(sl_dataname))[c(.(input$anno_var), .(input$id_var))],
468	!	anno_var = .(input$anno_var),
469	!	heat_data = .(as.name(ae_dataname)) %>%
470	!	select(.(as.name(input$id_var)), .(as.name(input$visit_var)), .(as.name(input$heat_var))),
471	!	heat_color_var = .(input$heat_var),
472	!	conmed_data = .(if (isTRUE(input$plot_cm)) as.name("conmed_data")),
473	!	conmed_var = .(if (isTRUE(input$plot_cm)) input$conmed_var),
474		)
475		)
476		)
477	!	teal.code::eval_code(qenv, quote(plot))
478		})
479		)
480
481	!	plot_r <- reactive(output_q()[["plot"]])
482
483	!	teal.widgets::verbatim_popup_srv(
484	!	id = "warning",
485	!	verbatim_content = reactive(teal.code::get_warnings(output_q())),
486	!	title = "Warning",
487	!	disabled = reactive(is.null(teal.code::get_warnings(output_q())))
488		)
489
490	!	teal.widgets::verbatim_popup_srv(
491	!	id = "rcode",
492	!	title = paste("R code for", label),
493	!	verbatim_content = reactive(teal.code::get_code(output_q()))
494		)
495
496		### REPORTER
497	!	if (with_reporter) {
498	!	card_fun <- function(comment) {
499	!	card <- teal::TealReportCard$new()
500	!	card$set_name("Heatmap by Grade")
501	!	card$append_text("Heatmap by Grade", "header2")
502	!	if (with_filter) card$append_fs(filter_panel_api$get_filter_state())
503	!	card$append_text("Plot", "header3")
504	!	card$append_plot(plot_r(), dim = pws$dim())
505	!	if (!comment == "") {
506	!	card$append_text("Comment", "header3")
507	!	card$append_text(comment)
508		}
509	!	card$append_src(paste(teal.code::get_code(output_q()), collapse = "\n"))
510	!	card
511		}
512	!	teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
513		}
514		})
515		}

1		#' teal module for the `AE` by subgroups
2		#'
3		#' @description
4		#' `r lifecycle::badge("stable")`
5		#'
6		#' Display the `AE` by subgroups plot as a teal module
7		#'
8		#' @inheritParams teal.widgets::standard_layout
9		#' @inheritParams argument_convention
10		#' @param group_var (`choices_selected`) subgroups variables. See [teal.transform::choices_selected()] for details.
11		#'
12		#' @author Liming Li (Lil128) \email{liming.li@roche.com}
13		#' @author Molly He (hey59) \email{hey59@gene.com}
14		#'
15		#' @inherit argument_convention return
16		#'
17		#' @export
18		#'
19		#' @examples
20		#' # Example using stream (ADaM) dataset
21		#' ADSL <- osprey::rADSL
22		#' ADAE <- osprey::rADAE
23		#'
24		#' app <- init(
25		#' data = cdisc_data(
26		#' cdisc_dataset("ADSL", ADSL, code = "ADSL <- osprey::rADSL"),
27		#' cdisc_dataset("ADAE", ADAE, code = "ADAE <- osprey::rADAE"),
28		#' check = TRUE
29		#' ),
30		#' modules = modules(
31		#' tm_g_ae_sub(
32		#' label = "AE by Subgroup",
33		#' dataname = "ADAE",
34		#' arm_var = teal.transform::choices_selected(
35		#' selected = "ACTARMCD",
36		#' choices = c("ACTARM", "ACTARMCD")
37		#' ),
38		#' group_var = teal.transform::choices_selected(
39		#' selected = c("SEX", "REGION1", "RACE"),
40		#' choices = c("SEX", "REGION1", "RACE")
41		#' ),
42		#' plot_height = c(600, 200, 2000)
43		#' )
44		#' )
45		#' )
46		#' if (interactive()) {
47		#' shinyApp(app$ui, app$server)
48		#' }
49		tm_g_ae_sub <- function(label,
50		dataname,
51		arm_var,
52		group_var,
53		plot_height = c(600L, 200L, 2000L),
54		plot_width = NULL,
55		fontsize = c(5, 3, 7)) {
56	!	logger::log_info("Initializing tm_g_ae_sub")
57	!	checkmate::assert_class(arm_var, classes = "choices_selected")
58	!	checkmate::assert_class(group_var, classes = "choices_selected")
59	!	checkmate::assert(
60	!	checkmate::check_number(fontsize, finite = TRUE),
61	!	checkmate::assert(
62	!	combine = "and",
63	!	.var.name = "fontsize",
64	!	checkmate::check_numeric(fontsize, len = 3, any.missing = FALSE, finite = TRUE),
65	!	checkmate::check_numeric(fontsize[1], lower = fontsize[2], upper = fontsize[3])
66		)
67		)
68	!	checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
69	!	checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")
70	!	checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
71	!	checkmate::assert_numeric(
72	!	plot_width[1],
73	!	lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"
74		)
75
76	!	module(
77	!	label = label,
78	!	server = srv_g_ae_sub,
79	!	server_args = list(
80	!	label = label,
81	!	dataname = dataname,
82	!	plot_height = plot_height,
83	!	plot_width = plot_width
84		),
85	!	ui = ui_g_ae_sub,
86	!	ui_args = list(
87	!	arm_var = arm_var,
88	!	group_var = group_var,
89	!	fontsize = fontsize
90		),
91	!	datanames = c("ADSL", dataname)
92		)
93		}
94
95		ui_g_ae_sub <- function(id, ...) {
96	!	ns <- NS(id)
97	!	args <- list(...)
98	!	teal.widgets::standard_layout(
99	!	output = teal.widgets::white_small_well(
100	!	plot_decorate_output(id = ns(NULL))
101		),
102	!	encoding = div(
103		### Reporter
104	!	teal.reporter::simple_reporter_ui(ns("simple_reporter")),
105		###
106	!	tags$label("Encodings", class = "text-primary"),
107	!	helpText("Analysis data:", tags$code("ADAE")),
108	!	teal.widgets::optionalSelectInput(
109	!	ns("arm_var"),
110	!	"Arm Variable",
111	!	choices = args$arm_var$choices,
112	!	selected = args$arm_var$selected
113		),
114	!	selectInput(
115	!	ns("arm_trt"),
116	!	"Treatment",
117	!	choices = args$arm_var$choices,
118	!	selected = args$arm_var$selected
119		),
120	!	selectInput(
121	!	ns("arm_ref"),
122	!	"Control",
123	!	choices = args$arm_var$choices,
124	!	selected = args$arm_var$selected
125		),
126	!	checkboxInput(
127	!	ns("arm_n"),
128	!	"Show N in each arm",
129	!	value = args$arm_n
130		),
131	!	teal.widgets::optionalSelectInput(
132	!	ns("groups"),
133	!	"Group Variable",
134	!	choices = args$group_var$choices,
135	!	selected = args$group_var$selected,
136	!	multiple = TRUE
137		),
138	!	teal.widgets::panel_item(
139	!	"Change group labels",
140	!	uiOutput(ns("grouplabel_output"))
141		),
142	!	teal.widgets::panel_item(
143	!	"Additional plot settings",
144	!	teal.widgets::optionalSelectInput(
145	!	ns("ci"),
146	!	"CI method",
147	!	choices = ci_choices,
148	!	selected = ci_choices[1]
149		),
150	!	teal.widgets::optionalSliderInput(
151	!	ns("conf_level"),
152	!	"Significant Level",
153	!	min = 0.5,
154	!	max = 1,
155	!	value = 0.95
156		),
157	!	ui_g_decorate(
158	!	ns(NULL),
159	!	fontsize = args$fontsize,
160	!	titles = "AE Table with Subgroups",
161	!	footnotes = ""
162		)
163		)
164		),
165	!	forms = tagList(
166	!	teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
167	!	teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
168		)
169		)
170		}
171
172		srv_g_ae_sub <- function(id,
173		data,
174		filter_panel_api,
175		reporter,
176		dataname,
177		label,
178		plot_height,
179		plot_width) {
180	!	with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
181	!	with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
182	!	checkmate::assert_class(data, "tdata")
183
184	!	moduleServer(id, function(input, output, session) {
185	!	iv <- reactive({
186	!	ANL <- data[[dataname]]() # nolint
187	!	ADSL <- data[["ADSL"]]() # nolint
188
189	!	iv <- shinyvalidate::InputValidator$new()
190	!	iv$add_rule("arm_var", shinyvalidate::sv_required(
191	!	message = "Arm Variable is required"
192		))
193	!	iv$add_rule("arm_var", ~ if (!is.factor(ANL[[.]])) {
194	!	"Arm Var must be a factor variable, contact developer"
195		})
196	!	rule_diff <- function(value, other) {
197	!	if (isTRUE(value == other)) "Control and Treatment must be different"
198		}
199	!	iv$add_rule("arm_trt", rule_diff, other = input$arm_ref)
200	!	iv$add_rule("arm_ref", rule_diff, other = input$arm_trt)
201	!	iv$add_rule("groups", shinyvalidate::sv_in_set(
202	!	names(ANL),
203	!	message_fmt = sprintf("Groups must be a variable in %s", dataname)
204		))
205	!	iv$add_rule("groups", shinyvalidate::sv_in_set(
206	!	names(ADSL),
207	!	message_fmt = "Groups must be a variable in ADSL"
208		))
209	!	iv$enable()
210	!	iv
211		})
212
213	!	decorate_output <- srv_g_decorate(
214	!	id = NULL,
215	!	plt = plot_r,
216	!	plot_height = plot_height,
217	!	plot_width = plot_width
218		)
219	!	font_size <- decorate_output$font_size
220	!	pws <- decorate_output$pws
221
222	!	observeEvent(input$arm_var, ignoreNULL = TRUE, {
223	!	arm_var <- input$arm_var
224	!	ANL <- data[[dataname]]() # nolint
225
226	!	anl_val <- ANL[[arm_var]]
227	!	choices <- levels(anl_val)
228
229	!	if (length(choices) == 1) {
230	!	ref_index <- 1
231		} else {
232	!	ref_index <- 2
233		}
234
235	!	updateSelectInput(
236	!	session,
237	!	"arm_trt",
238	!	selected = choices[1],
239	!	choices = choices
240		)
241	!	updateSelectInput(
242	!	session,
243	!	"arm_ref",
244	!	selected = choices[ref_index],
245	!	choices = choices
246		)
247		})
248
249	!	observeEvent(list(input$ci, input$conf_level, input$arm_trt, input$arm_ref), {
250	!	diff_ci_method <- input$ci
251	!	conf_level <- input$conf_level
252	!	trt <- input$arm_trt
253	!	ref <- input$arm_ref
254	!	updateTextAreaInput(
255	!	session,
256	!	"foot",
257	!	value = sprintf(
258	!	"Note: %d%% CI is calculated using %s\nTRT: %s; CONT: %s",
259	!	round(conf_level * 100),
260	!	name_ci(diff_ci_method),
261	!	trt,
262	!	ref
263		)
264		)
265		})
266
267	!	observeEvent(input$groups, {
268	!	ANL <- data[[dataname]]() # nolint
269	!	output$grouplabel_output <- renderUI({
270	!	grps <- input$groups
271	!	lo <- lapply(seq_along(grps), function(index) {
272	!	grp <- grps[index]
273	!	choices <- levels(ANL[[grp]])
274	!	sel <- teal.widgets::optionalSelectInput(
275	!	session$ns(sprintf("groups__%s", index)),
276	!	grp,
277	!	choices,
278	!	multiple = TRUE,
279	!	selected = choices
280		)
281	!	textname <- sprintf("text_%s_out", index)
282	!	txt <- uiOutput(session$ns(textname))
283	!	observeEvent(
284	!	eventExpr = input[[sprintf("groups__%s", index)]],
285	!	handlerExpr = {
286	!	output[[textname]] <- renderUI({
287	!	if (!is.null(input[[sprintf("groups__%s", index)]])) {
288	!	l <- input[[sprintf("groups__%s", index)]]
289	!	l2 <- lapply(seq_along(l), function(i) {
290	!	nm <- sprintf("groups__%s__level__%s", index, i)
291	!	label <- sprintf("Label for %s, Level %s", grp, l[i])
292	!	textInput(session$ns(nm), label, l[i])
293		})
294	!	tagList(textInput(
295	!	session$ns(
296	!	sprintf("groups__%s__level__%s", index, "all")
297		),
298	!	sprintf("Label for %s", grp), grp
299	!	), l2)
300		}
301		})
302		}
303		)
304	!	tagList(sel, txt)
305		})
306	!	ret <- tagList(lo)
307	!	ret
308		})
309		})
310
311	!	output_q <- shiny::debounce(
312	!	millis = 200,
313	!	r = reactive({
314	!	ANL <- data[[dataname]]() # nolint
315	!	ADSL <- data[["ADSL"]]() # nolint
316
317	!	teal::validate_has_data(ANL, min_nrow = 10, msg = sprintf("%s has not enough data", dataname))
318
319	!	teal::validate_inputs(iv())
320
321	!	validate(need(
322	!	input$arm_trt %in% ANL[[input$arm_var]] && input$arm_ref %in% ANL[[input$arm_var]],
323	!	"Treatment or Control not found in Arm Variable. Perhaps they have been filtered out?"
324		))
325
326	!	group_labels <- lapply(seq_along(input$groups), function(x) {
327	!	items <- input[[sprintf("groups__%s", x)]]
328	!	if (length(items) > 0) {
329	!	l <- lapply(seq_along(items), function(y) {
330	!	input[[sprintf("groups__%s__level__%s", x, y)]]
331		})
332	!	names(l) <- items
333	!	l[["Total"]] <- input[[sprintf("groups__%s__level__%s", x, "all")]]
334	!	l
335		}
336		})
337
338	!	group_labels_call <- if (length(unlist(group_labels)) == 0) {
339	!	quote(group_labels <- NULL)
340		} else {
341	!	bquote(group_labels <- setNames(.(group_labels), .(input$groups)))
342		}
343
344	!	q1 <- teal.code::eval_code(
345	!	teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)),
346	!	code = group_labels_call
347		)
348	!	q2 <- teal.code::eval_code(q1, code = "")
349	!	teal.code::eval_code(
350	!	q2,
351	!	code = as.expression(c(
352	!	bquote(
353	!	plot <- osprey::g_ae_sub(
354	!	id = .(as.name(dataname))$USUBJID,
355	!	arm = as.factor(.(as.name(dataname))[[.(input$arm_var)]]),
356	!	arm_sl = as.character(ADSL[[.(input$arm_var)]]),
357	!	trt = .(input$arm_trt),
358	!	ref = .(input$arm_ref),
359	!	subgroups = .(as.name(dataname))[.(input$groups)],
360	!	subgroups_sl = ADSL[.(input$groups)],
361	!	subgroups_levels = group_labels,
362	!	conf_level = .(input$conf_level),
363	!	diff_ci_method = .(input$ci),
364	!	fontsize = .(font_size()),
365	!	arm_n = .(input$arm_n),
366	!	draw = TRUE
367		)
368		),
369	!	quote(plot)
370		))
371		)
372		})
373		)
374
375	!	plot_r <- reactive(output_q()[["plot"]])
376
377	!	teal.widgets::verbatim_popup_srv(
378	!	id = "warning",
379	!	verbatim_content = reactive(teal.code::get_warnings(output_q())),
380	!	title = "Warning",
381	!	disabled = reactive(is.null(teal.code::get_warnings(output_q())))
382		)
383
384	!	teal.widgets::verbatim_popup_srv(
385	!	id = "rcode",
386	!	verbatim_content = reactive(teal.code::get_code(output_q())),
387	!	title = paste("R code for", label),
388		)
389
390		### REPORTER
391	!	if (with_reporter) {
392	!	card_fun <- function(comment) {
393	!	card <- teal::TealReportCard$new()
394	!	card$set_name("AE Subgroups")
395	!	card$append_text("AE Subgroups", "header2")
396	!	if (with_filter) card$append_fs(filter_panel_api$get_filter_state())
397	!	card$append_text("Plot", "header3")
398	!	card$append_plot(plot_r(), dim = pws$dim())
399	!	if (!comment == "") {
400	!	card$append_text("Comment", "header3")
401	!	card$append_text(comment)
402		}
403	!	card$append_src(paste(teal.code::get_code(output_q()), collapse = "\n"))
404	!	card
405		}
406	!	teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
407		}
408		})
409		}

1		#' Events by Term Plot Teal Module
2		#'
3		#' @description
4		#' `r lifecycle::badge("stable")`
5		#'
6		#' Display Events by Term plot as a shiny module
7		#'
8		#' @inheritParams teal.widgets::standard_layout
9		#' @inheritParams argument_convention
10		#' @param term_var \code{\link[teal.transform]{choices_selected}} object with all available choices
11		#' and pre-selected option names that can be used to specify the term for events
12		#'
13		#' @inherit argument_convention return
14		#'
15		#' @export
16		#'
17		#' @author Liming Li (lil128) \email{liming.li@roche.com}
18		#' @author Molly He (hey59) \email{hey59@gene.com}
19		#'
20		#' @examples
21		#' library(nestcolor)
22		#'
23		#' ADSL <- osprey::rADSL
24		#' ADAE <- osprey::rADAE
25		#'
26		#' app <- init(
27		#' data = cdisc_data(
28		#' cdisc_dataset("ADSL", ADSL, code = "ADSL <- osprey::rADSL"),
29		#' cdisc_dataset("ADAE", ADAE, code = "ADAE <- osprey::rADAE"),
30		#' check = TRUE
31		#' ),
32		#' modules = modules(
33		#' tm_g_events_term_id(
34		#' label = "Common AE",
35		#' dataname = "ADAE",
36		#' term_var = teal.transform::choices_selected(
37		#' selected = "AEDECOD",
38		#' choices = c(
39		#' "AEDECOD", "AETERM",
40		#' "AEHLT", "AELLT", "AEBODSYS"
41		#' )
42		#' ),
43		#' arm_var = teal.transform::choices_selected(
44		#' selected = "ACTARMCD",
45		#' choices = c("ACTARM", "ACTARMCD")
46		#' ),
47		#' plot_height = c(600, 200, 2000)
48		#' )
49		#' )
50		#' )
51		#' if (interactive()) {
52		#' shinyApp(app$ui, app$server)
53		#' }
54		#'
55		tm_g_events_term_id <- function(label,
56		dataname,
57		term_var,
58		arm_var,
59		fontsize = c(5, 3, 7),
60		plot_height = c(600L, 200L, 2000L),
61		plot_width = NULL) {
62	!	logger::log_info("Initializing tm_g_events_term_id")
63	!	checkmate::assert_string(label)
64	!	checkmate::assert_class(term_var, classes = "choices_selected")
65	!	checkmate::assert_class(arm_var, classes = "choices_selected")
66	!	checkmate::assert(
67	!	checkmate::check_number(fontsize, finite = TRUE),
68	!	checkmate::assert(
69	!	combine = "and",
70	!	.var.name = "fontsize",
71	!	checkmate::check_numeric(fontsize, len = 3, any.missing = FALSE, finite = TRUE),
72	!	checkmate::check_numeric(fontsize[1], lower = fontsize[2], upper = fontsize[3])
73		)
74		)
75	!	checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
76	!	checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")
77	!	checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
78	!	checkmate::assert_numeric(
79	!	plot_width[1],
80	!	lower = plot_width[2],
81	!	upper = plot_width[3],
82	!	null.ok = TRUE,
83	!	.var.name = "plot_width"
84		)
85
86	!	args <- as.list(environment())
87
88	!	module(
89	!	label = label,
90	!	server = srv_g_events_term_id,
91	!	server_args = list(label = label, dataname = dataname, plot_height = plot_height, plot_width = plot_width),
92	!	ui = ui_g_events_term_id,
93	!	ui_args = args,
94	!	datanames = c("ADSL", dataname)
95		)
96		}
97
98		ui_g_events_term_id <- function(id, ...) {
99	!	ns <- NS(id)
100	!	args <- list(...)
101	!	teal.widgets::standard_layout(
102	!	output = teal.widgets::white_small_well(
103	!	plot_decorate_output(id = ns(NULL))
104		),
105	!	encoding = div(
106		### Reporter
107	!	teal.reporter::simple_reporter_ui(ns("simple_reporter")),
108		###
109	!	teal.widgets::optionalSelectInput(
110	!	ns("term"),
111	!	"Term Variable",
112	!	choices = args$term_var$choices,
113	!	selected = args$term_var$selected
114		),
115	!	teal.widgets::optionalSelectInput(
116	!	ns("arm_var"),
117	!	"Arm Variable",
118	!	choices = args$arm_var$choices,
119	!	selected = args$arm_var$selected
120		),
121	!	selectInput(
122	!	ns("arm_ref"),
123	!	"Control",
124	!	choices = args$arm_var$choices,
125	!	selected = args$arm_var$selected
126		),
127	!	selectInput(
128	!	ns("arm_trt"),
129	!	"Treatment",
130	!	choices = args$arm_var$choices,
131	!	selected = args$arm_var$selected
132		),
133	!	teal.widgets::optionalSelectInput(
134	!	ns("sort"),
135	!	"Sort By",
136	!	choices = c(
137	!	"Term" = "term",
138	!	"Risk Difference" = "riskdiff",
139	!	"Mean Risk" = "meanrisk"
140		),
141	!	selected = NULL
142		),
143	!	teal.widgets::panel_item(
144	!	"Confidence interval settings",
145	!	teal.widgets::optionalSelectInput(
146	!	ns("diff_ci_method"),
147	!	"Method for Difference of Proportions CI",
148	!	choices = ci_choices,
149	!	selected = ci_choices[1]
150		),
151	!	teal.widgets::optionalSliderInput(
152	!	ns("conf_level"),
153	!	"Confidence Level",
154	!	min = 0.5,
155	!	max = 1,
156	!	value = 0.95
157		)
158		),
159	!	teal.widgets::panel_item(
160	!	"Additional plot settings",
161	!	teal.widgets::optionalSelectInput(
162	!	ns("axis"),
163	!	"Axis Side",
164	!	choices = c("Left" = "left", "Right" = "right"),
165	!	selected = "left"
166		),
167	!	sliderInput(
168	!	ns("raterange"),
169	!	"Overall Rate Range",
170	!	min = 0,
171	!	max = 1,
172	!	value = c(0.1, 1),
173	!	step = 0.01
174		),
175	!	sliderInput(
176	!	ns("diffrange"),
177	!	"Rate Difference Range",
178	!	min = -1,
179	!	max = 1,
180	!	value = c(-0.5, 0.5),
181	!	step = 0.01
182		),
183	!	checkboxInput(ns("reverse"),
184	!	"Reverse Order",
185	!	value = FALSE
186		)
187		),
188	!	ui_g_decorate(
189	!	ns(NULL),
190	!	fontsize = args$fontsize,
191	!	titles = "Common AE Table",
192	!	footnotes = ""
193		)
194		),
195	!	forms = tagList(
196	!	teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
197	!	teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
198		)
199		)
200		}
201
202		srv_g_events_term_id <- function(id,
203		data,
204		filter_panel_api,
205		reporter,
206		dataname,
207		label,
208		plot_height,
209		plot_width) {
210	!	with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
211	!	with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
212	!	checkmate::assert_class(data, "tdata")
213
214	!	moduleServer(id, function(input, output, session) {
215	!	iv <- reactive({
216	!	iv <- shinyvalidate::InputValidator$new()
217	!	iv$add_rule("term", shinyvalidate::sv_required(
218	!	message = "Term Variable is required"
219		))
220	!	iv$add_rule("arm_var", shinyvalidate::sv_required(
221	!	message = "Arm Variable is required"
222		))
223	!	rule_diff <- function(value, other) {
224	!	if (isTRUE(value == other)) "Control and Treatment must be different"
225		}
226	!	iv$add_rule("arm_trt", rule_diff, other = input$arm_ref)
227	!	iv$add_rule("arm_ref", rule_diff, other = input$arm_trt)
228	!	iv$enable()
229	!	iv
230		})
231
232	!	decorate_output <- srv_g_decorate(
233	!	id = NULL, plt = plot_r, plot_height = plot_height, plot_width = plot_width
234		)
235	!	font_size <- decorate_output$font_size
236	!	pws <- decorate_output$pws
237
238	!	observeEvent(list(input$diff_ci_method, input$conf_level), {
239	!	req(!is.null(input$diff_ci_method) && !is.null(input$conf_level))
240	!	diff_ci_method <- input$diff_ci_method
241	!	conf_level <- input$conf_level
242	!	updateTextAreaInput(
243	!	session,
244	!	"foot",
245	!	value = sprintf(
246	!	"Note: %d%% CI is calculated using %s",
247	!	round(conf_level * 100),
248	!	name_ci(diff_ci_method)
249		)
250		)
251		})
252
253
254	!	observeEvent(input$sort,
255		{
256	!	sort <- if (is.null(input$sort)) " " else input$sort
257	!	updateTextInput(
258	!	session,
259	!	"title",
260	!	value = sprintf(
261	!	"Common AE Table %s",
262	!	c(
263	!	"term" = "Sorted by Term",
264	!	"riskdiff" = "Sorted by Risk Difference",
265	!	"meanrisk" = "Sorted by Mean Risk",
266		" " = ""
267	!	)[sort]
268		)
269		)
270		},
271	!	ignoreNULL = FALSE
272		)
273
274	!	observeEvent(input$arm_var,
275		{
276	!	arm_var <- input$arm_var
277	!	ANL <- data[[dataname]]() # nolint
278
279	!	choices <- levels(ANL[[arm_var]])
280
281	!	if (length(choices) == 1) {
282	!	trt_index <- 1
283		} else {
284	!	trt_index <- 2
285		}
286
287	!	updateSelectInput(
288	!	session,
289	!	"arm_ref",
290	!	selected = choices[1],
291	!	choices = choices
292		)
293	!	updateSelectInput(
294	!	session,
295	!	"arm_trt",
296	!	selected = choices[trt_index],
297	!	choices = choices
298		)
299		},
300	!	ignoreNULL = TRUE
301		)
302
303	!	output_q <- reactive({
304	!	ANL <- data[[dataname]]() # nolint
305
306	!	teal::validate_inputs(iv())
307
308	!	shiny::validate(
309	!	shiny::need(is.factor(ANL[[input$arm_var]]), "Arm Var must be a factor variable. Contact developer."),
310	!	shiny::need(
311	!	input$arm_trt %in% ANL[[req(input$arm_var)]] && input$arm_ref %in% ANL[[req(input$arm_var)]],
312	!	"Cannot generate plot. The dataset does not contain subjects from both the control and treatment arms."
313		)
314		)
315
316	!	adsl_vars <- unique(c("USUBJID", "STUDYID", input$arm_var)) # nolint
317	!	anl_vars <- c("USUBJID", "STUDYID", input$term) # nolint
318
319	!	q1 <- teal.code::eval_code(
320	!	teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)),
321	!	code = bquote(
322	!	ANL <- merge( # nolint
323	!	x = ADSL[, .(adsl_vars), drop = FALSE],
324	!	y = .(as.name(dataname))[, .(anl_vars), drop = FALSE],
325	!	all.x = FALSE,
326	!	all.y = FALSE,
327	!	by = c("USUBJID", "STUDYID")
328		)
329		)
330		)
331
332	!	teal::validate_has_data(q1[["ANL"]],
333	!	min_nrow = 10,
334	!	msg = "Analysis data set must have at least 10 data points"
335		)
336
337	!	q2 <- teal.code::eval_code(
338	!	q1,
339	!	code = bquote(
340	!	plot <- osprey::g_events_term_id(
341	!	term = ANL[[.(input$term)]],
342	!	id = ANL$USUBJID,
343	!	arm = ANL[[.(input$arm_var)]],
344	!	arm_N = table(ADSL[[.(input$arm_var)]]),
345	!	ref = .(input$arm_ref),
346	!	trt = .(input$arm_trt),
347	!	sort_by = .(input$sort),
348	!	rate_range = .(input$raterange),
349	!	diff_range = .(input$diffrange),
350	!	reversed = .(input$reverse),
351	!	conf_level = .(input$conf_level),
352	!	diff_ci_method = .(input$diff_ci_method),
353	!	axis_side = .(input$axis),
354	!	fontsize = .(font_size()),
355	!	draw = TRUE
356		)
357		)
358		)
359
360	!	teal.code::eval_code(q2, quote(plot))
361		})
362
363	!	plot_r <- reactive(output_q()[["plot"]])
364
365	!	teal.widgets::verbatim_popup_srv(
366	!	id = "warning",
367	!	verbatim_content = reactive(teal.code::get_warnings(output_q())),
368	!	title = "Warning",
369	!	disabled = reactive(is.null(teal.code::get_warnings(output_q())))
370		)
371
372	!	teal.widgets::verbatim_popup_srv(
373	!	id = "rcode",
374	!	title = paste("R code for", label),
375	!	verbatim_content = reactive(teal.code::get_code(output_q()))
376		)
377
378		### REPORTER
379	!	if (with_reporter) {
380	!	card_fun <- function(comment) {
381	!	card <- teal::TealReportCard$new()
382	!	card$set_name("Events by Term")
383	!	card$append_text("Events by Term", "header2")
384	!	if (with_filter) card$append_fs(filter_panel_api$get_filter_state())
385	!	card$append_text("Plot", "header3")
386	!	card$append_plot(plot_r(), dim = pws$dim())
387	!	if (!comment == "") {
388	!	card$append_text("Comment", "header3")
389	!	card$append_text(comment)
390		}
391	!	card$append_src(paste(teal.code::get_code(output_q()), collapse = "\n"))
392	!	card
393		}
394	!	teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
395		}
396		})
397		}

1		#' Teal module for the `AE` overview
2		#'
3		#' @description
4		#' `r lifecycle::badge("stable")`
5		#'
6		#' Display the `AE` overview plot as a shiny module
7		#'
8		#' @inheritParams teal.widgets::standard_layout
9		#' @inheritParams argument_convention
10		#' @param flag_var_anl ([`teal.transform::choices_selected`])
11		#' `choices_selected` object with variables used to count adverse event
12		#' sub-groups (e.g. Serious events, Related events, etc.)
13		#'
14		#' @inherit argument_convention return
15		#'
16		#' @export
17		#'
18		#' @examples
19		#' library(nestcolor)
20		#'
21		#' ADSL <- osprey::rADSL
22		#' ADAE <- osprey::rADAE
23		#'
24		#' # Add additional dummy causality flags.
25		#' add_event_flags <- function(dat) {
26		#' dat <- dat %>%
27		#' dplyr::mutate(
28		#' TMPFL_SER = AESER == "Y",
29		#' TMPFL_REL = AEREL == "Y",
30		#' TMPFL_GR5 = AETOXGR == "5",
31		#' AEREL1 = (AEREL == "Y" & ACTARM == "A: Drug X"),
32		#' AEREL2 = (AEREL == "Y" & ACTARM == "B: Placebo")
33		#' )
34		#' labels <- c(
35		#' "Serious AE", "Related AE", "Grade 5 AE",
36		#' "AE related to A: Drug X", "AE related to B: Placebo"
37		#' )
38		#' cols <- c("TMPFL_SER", "TMPFL_REL", "TMPFL_GR5", "AEREL1", "AEREL2")
39		#' for (i in seq_along(labels)) {
40		#' attr(dat[[cols[i]]], "label") <- labels[i]
41		#' }
42		#' dat
43		#' }
44		#' ADAE <- ADAE %>% add_event_flags()
45		#'
46		#' app <- init(
47		#' data = cdisc_data(
48		#' cdisc_dataset("ADSL", ADSL, code = "ADSL <- osprey::rADSL"),
49		#' cdisc_dataset("ADAE", ADAE,
50		#' code =
51		#' "ADAE <- osprey::rADAE
52		#' add_event_flags <- function(dat) {
53		#' dat <- dat %>%
54		#' dplyr::mutate(
55		#' TMPFL_SER = AESER == 'Y',
56		#' TMPFL_REL = AEREL == 'Y',
57		#' TMPFL_GR5 = AETOXGR == '5',
58		#' AEREL1 = (AEREL == 'Y' & ACTARM == 'A: Drug X'),
59		#' AEREL2 = (AEREL == 'Y' & ACTARM == 'B: Placebo')
60		#' )
61		#' labels <- c(
62		#' 'Serious AE',
63		#' 'Related AE',
64		#' 'Grade 5 AE',
65		#' 'AE related to A: Drug X',
66		#' 'AE related to B: Placebo'
67		#' )
68		#' cols <- c('TMPFL_SER', 'TMPFL_REL', 'TMPFL_GR5', 'AEREL1', 'AEREL2')
69		#' for (i in seq_along(labels)) {
70		#' attr(dat[[cols[i]]], 'label') <- labels[i]
71		#' }
72		#' dat
73		#' }
74		#' # Generating user-defined event flags.
75		#' ADAE <- ADAE %>% add_event_flags()"
76		#' ),
77		#' check = TRUE
78		#' ),
79		#' modules = modules(
80		#' tm_g_ae_oview(
81		#' label = "AE Overview",
82		#' dataname = "ADAE",
83		#' arm_var = teal.transform::choices_selected(
84		#' selected = "ACTARM",
85		#' choices = c("ACTARM", "ACTARMCD")
86		#' ),
87		#' flag_var_anl = teal.transform::choices_selected(
88		#' selected = "AEREL1",
89		#' choices = teal.transform::variable_choices(
90		#' ADAE,
91		#' c("TMPFL_SER", "TMPFL_REL", "TMPFL_GR5", "AEREL1", "AEREL2")
92		#' ),
93		#' ),
94		#' plot_height = c(600, 200, 2000)
95		#' )
96		#' )
97		#' )
98		#' if (interactive()) {
99		#' shinyApp(app$ui, app$server)
100		#' }
101		tm_g_ae_oview <- function(label,
102		dataname,
103		arm_var,
104		flag_var_anl,
105		fontsize = c(5, 3, 7),
106		plot_height = c(600L, 200L, 2000L),
107		plot_width = NULL) {
108	!	logger::log_info("Initializing tm_g_ae_oview")
109	!	checkmate::assert_class(arm_var, classes = "choices_selected")
110	!	checkmate::assert_class(flag_var_anl, classes = "choices_selected")
111	!	checkmate::assert(
112	!	checkmate::check_number(fontsize, finite = TRUE),
113	!	checkmate::assert(
114	!	combine = "and",
115	!	.var.name = "fontsize",
116	!	checkmate::check_numeric(fontsize, len = 3, any.missing = FALSE, finite = TRUE),
117	!	checkmate::check_numeric(fontsize[1], lower = fontsize[2], upper = fontsize[3])
118		)
119		)
120	!	checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
121	!	checkmate::assert_numeric(plot_height[1],
122	!	lower = plot_height[2], upper = plot_height[3],
123	!	.var.name = "plot_height"
124		)
125	!	checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
126	!	checkmate::assert_numeric(
127	!	plot_width[1],
128	!	lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"
129		)
130
131	!	args <- as.list(environment())
132
133	!	module(
134	!	label = label,
135	!	server = srv_g_ae_oview,
136	!	server_args = list(
137	!	label = label,
138	!	dataname = dataname,
139	!	plot_height = plot_height,
140	!	plot_width = plot_width
141		),
142	!	ui = ui_g_ae_oview,
143	!	ui_args = args,
144	!	datanames = c("ADSL", dataname)
145		)
146		}
147
148		ui_g_ae_oview <- function(id, ...) {
149	!	ns <- NS(id)
150	!	args <- list(...)
151	!	teal.widgets::standard_layout(
152	!	output = teal.widgets::white_small_well(
153	!	plot_decorate_output(id = ns(NULL))
154		),
155	!	encoding = div(
156		### Reporter
157	!	teal.reporter::simple_reporter_ui(ns("simple_reporter")),
158		###
159	!	teal.widgets::optionalSelectInput(
160	!	ns("arm_var"),
161	!	"Arm Variable",
162	!	choices = args$arm_var$choices,
163	!	selected = args$arm_var$selected,
164	!	multiple = FALSE
165		),
166	!	selectInput(
167	!	ns("arm_ref"),
168	!	"Control",
169	!	choices = args$arm_var$choices,
170	!	selected = args$arm_var$selected
171		),
172	!	selectInput(
173	!	ns("arm_trt"),
174	!	"Treatment",
175	!	choices = args$arm_var$choices,
176	!	selected = args$arm_var$selected
177		),
178	!	selectInput(
179	!	ns("flag_var_anl"),
180	!	"Flags",
181	!	choices = args$flag_var_anl$choices,
182	!	selected = args$flag_var_anl$selected,
183	!	multiple = TRUE
184		),
185	!	teal.widgets::panel_item(
186	!	"Confidence interval settings",
187	!	teal.widgets::optionalSelectInput(
188	!	ns("diff_ci_method"),
189	!	"Method for Difference of Proportions CI",
190	!	choices = ci_choices,
191	!	selected = ci_choices[1],
192	!	multiple = FALSE
193		),
194	!	teal.widgets::optionalSliderInput(
195	!	ns("conf_level"),
196	!	"Confidence Level",
197	!	min = 0.5,
198	!	max = 1,
199	!	value = 0.95
200		)
201		),
202	!	teal.widgets::optionalSelectInput(
203	!	ns("axis"),
204	!	"Axis Side",
205	!	choices = c("Left" = "left", "Right" = "right"),
206	!	selected = "left",
207	!	multiple = FALSE
208		),
209	!	ui_g_decorate(
210	!	ns(NULL),
211	!	fontsize = args$fontsize,
212	!	titles = "AE Overview",
213	!	footnotes = ""
214		)
215		),
216	!	forms = tagList(
217	!	teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
218	!	teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
219		)
220		)
221		}
222
223		srv_g_ae_oview <- function(id,
224		data,
225		filter_panel_api,
226		reporter,
227		dataname,
228		label,
229		plot_height,
230		plot_width) {
231	!	with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
232	!	with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
233	!	checkmate::assert_class(data, "tdata")
234
235	!	moduleServer(id, function(input, output, session) {
236	!	iv <- reactive({
237	!	ANL <- data[[dataname]]() # nolint
238
239	!	iv <- shinyvalidate::InputValidator$new()
240	!	iv$add_rule("arm_var", shinyvalidate::sv_required(
241	!	message = "Arm Variable is required"
242		))
243	!	iv$add_rule("arm_var", ~ if (!is.factor(ANL[[.]])) {
244	!	"Arm Var must be a factor variable"
245		})
246	!	iv$add_rule("arm_var", ~ if (nlevels(ANL[[.]]) < 2L) {
247	!	"Selected Arm Var must have at least two levels"
248		})
249	!	iv$add_rule("flag_var_anl", shinyvalidate::sv_required(
250	!	message = "At least one Flag is required"
251		))
252	!	rule_diff <- function(value, other) {
253	!	if (isTRUE(value == other)) "Control and Treatment must be different"
254		}
255	!	iv$add_rule("arm_trt", rule_diff, other = input$arm_ref)
256	!	iv$add_rule("arm_ref", rule_diff, other = input$arm_trt)
257	!	iv$enable()
258	!	iv
259		})
260
261	!	decorate_output <- srv_g_decorate(
262	!	id = NULL, plt = plot_r,
263	!	plot_height = plot_height, plot_width = plot_width
264		)
265	!	font_size <- decorate_output$font_size
266	!	pws <- decorate_output$pws
267
268	!	observeEvent(list(input$diff_ci_method, input$conf_level), {
269	!	req(!is.null(input$diff_ci_method) && !is.null(input$conf_level))
270	!	diff_ci_method <- input$diff_ci_method
271	!	conf_level <- input$conf_level
272	!	updateTextAreaInput(session,
273	!	"foot",
274	!	value = sprintf(
275	!	"Note: %d%% CI is calculated using %s",
276	!	round(conf_level * 100),
277	!	name_ci(diff_ci_method)
278		)
279		)
280		})
281
282	!	observeEvent(input$arm_var, ignoreNULL = TRUE, {
283	!	ANL <- data[[dataname]]() # nolint
284	!	arm_var <- input$arm_var
285	!	arm_val <- ANL[[arm_var]]
286	!	choices <- levels(arm_val)
287
288	!	if (length(choices) == 1) {
289	!	trt_index <- 1
290		} else {
291	!	trt_index <- 2
292		}
293
294	!	updateSelectInput(
295	!	session,
296	!	"arm_ref",
297	!	selected = choices[1],
298	!	choices = choices
299		)
300	!	updateSelectInput(
301	!	session,
302	!	"arm_trt",
303	!	selected = choices[trt_index],
304	!	choices = choices
305		)
306		})
307
308	!	output_q <- shiny::debounce(
309	!	millis = 200,
310	!	r = reactive({
311	!	ANL <- data[[dataname]]() # nolint
312
313	!	teal::validate_has_data(ANL, min_nrow = 10, msg = sprintf("%s has not enough data", dataname))
314
315	!	teal::validate_inputs(iv())
316
317	!	validate(need(
318	!	input$arm_trt %in% ANL[[input$arm_var]] && input$arm_ref %in% ANL[[input$arm_var]],
319	!	"Treatment or Control not found in Arm Variable. Perhaps they have been filtered out?"
320		))
321
322	!	q1 <- teal.code::eval_code(
323	!	teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)),
324	!	code = as.expression(c(
325	!	bquote(anl_labels <- formatters::var_labels(.(as.name(dataname)), fill = FALSE)),
326	!	bquote(flags <- .(as.name(dataname)) %>%
327	!	select(all_of(.(input$flag_var_anl))) %>%
328	!	rename_at(vars(.(input$flag_var_anl)), function(x) paste0(x, ": ", anl_labels[x])))
329		))
330		)
331
332	!	teal.code::eval_code(
333	!	q1,
334	!	code = as.expression(c(
335	!	bquote(
336	!	plot <- osprey::g_events_term_id(
337	!	term = flags,
338	!	id = .(as.name(dataname))[["USUBJID"]],
339	!	arm = .(as.name(dataname))[[.(input$arm_var)]],
340	!	arm_N = table(ADSL[[.(input$arm_var)]]),
341	!	ref = .(input$arm_ref),
342	!	trt = .(input$arm_trt),
343	!	diff_ci_method = .(input$diff_ci_method),
344	!	conf_level = .(input$conf_level),
345	!	axis_side = .(input$axis),
346	!	fontsize = .(font_size()),
347	!	draw = TRUE
348		)
349		),
350	!	quote(plot)
351		))
352		)
353		})
354		)
355
356	!	plot_r <- reactive(output_q()[["plot"]])
357
358	!	teal.widgets::verbatim_popup_srv(
359	!	id = "warning",
360	!	verbatim_content = reactive(teal.code::get_warnings(output_q())),
361	!	title = "Warning",
362	!	disabled = reactive(is.null(teal.code::get_warnings(output_q())))
363		)
364
365	!	teal.widgets::verbatim_popup_srv(
366	!	id = "rcode",
367	!	verbatim_content = reactive(teal.code::get_code(output_q())),
368	!	title = paste("R code for", label)
369		)
370		### REPORTER
371	!	if (with_reporter) {
372	!	card_fun <- function(comment) {
373	!	card <- teal::TealReportCard$new()
374	!	card$set_name("AE Overview")
375	!	card$append_text("AE Overview", "header2")
376	!	if (with_filter) card$append_fs(filter_panel_api$get_filter_state())
377	!	card$append_text("Plot", "header3")
378	!	card$append_plot(plot_r(), dim = pws$dim())
379	!	if (!comment == "") {
380	!	card$append_text("Comment", "header3")
381	!	card$append_text(comment)
382		}
383	!	card$append_src(paste(teal.code::get_code(output_q()), collapse = "\n"))
384	!	card
385		}
386	!	teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
387		}
388		})
389		}

1		#' Helper UI function to decorate plot output UI
2		#'
3		#' @description
4		#' `r lifecycle::badge("stable")`
5		#'
6		#' This is used in \code{\link{tm_g_ae_oview}} and \code{\link{tm_g_events_term_id}}.
7		#'
8		#' @param id (\code{character}) id of this module. set to `NULL` if you want to make it identical
9		#' to the module who called it.
10		#' @param titles (\code{character}) default titles
11		#' @param footnotes (\code{character}) default footnotes
12		#' @inheritParams argument_convention
13		#' @export
14		ui_g_decorate <- function(id,
15		titles = "Titles",
16		footnotes = "footnotes",
17		fontsize = c(5, 4, 11)) {
18	!	ns <- NS(id)
19	!	tagList(
20	!	teal.widgets::optionalSliderInputValMinMax(
21	!	ns("fontsize"),
22	!	"Font Size",
23	!	value_min_max = fontsize,
24	!	step = 0.1
25		),
26	!	textInput(ns("title"), "Title", value = titles),
27	!	textAreaInput(ns("foot"), "Footnote", value = footnotes, resize = "none")
28		)
29		}
30
31		#' Helper server function to decorate plot output
32		#'
33		#' @description
34		#' `r lifecycle::badge("stable")`
35		#'
36		#' This is used in \code{\link{tm_g_ae_oview}} and \code{\link{tm_g_events_term_id}}.
37		#'
38		#' @inheritParams shared_params
39		#' @param id (\code{character}) id of the module
40		#' @param plot_id (\code{character}) id for plot output
41		#' @param plt (\code{reactive}) a reactive object of graph object
42		#'
43		#' @export
44		srv_g_decorate <- function(id,
45		plot_id = "out",
46		plt = reactive(NULL),
47		plot_height,
48		plot_width) {
49	!	moduleServer(id, function(input, output, session) {
50	!	plot_g <- reactive({
51	!	g <- tern::decorate_grob(
52	!	plt(),
53	!	titles = input$title,
54	!	footnotes = input$foot,
55	!	gp_titles = grid::gpar(
56	!	fontsize = input$fontsize * ggplot2::.pt,
57	!	col = "black",
58	!	fontface = "bold"
59		),
60	!	gp_footnotes = grid::gpar(fontsize = input$fontsize * ggplot2::.pt, col = "black")
61		)
62		})
63
64	!	plot_r <- function() {
65	!	grid::grid.newpage()
66	!	grid::grid.draw(plot_g())
67	!	plot_g()
68		}
69
70	!	class(plot_r) <- c(class(plot_r), "reactive")
71
72	!	pws <- teal.widgets::plot_with_settings_srv(
73	!	id = plot_id,
74	!	plot_r = plot_r,
75	!	height = plot_height,
76	!	width = plot_width
77		)
78
79	!	return(
80	!	list(
81	!	font_size = reactive(input$fontsize),
82	!	pws = pws
83		)
84		)
85		})
86		}
87
88		#' Helper function to plot decorated output UI
89		#'
90		#' @description
91		#' `r lifecycle::badge("stable")`
92		#'
93		#' @param id (\code{character}) id of this element
94		#'
95		#' @export
96		plot_decorate_output <- function(id) {
97	!	ns <- NS(id)
98	!	teal.widgets::plot_with_settings_ui(id = ns("out"))
99		}

1		#' Teal Module for Waterfall Plot
2		#'
3		#' @description
4		#' `r lifecycle::badge("stable")`
5		#'
6		#' This is teal module that generates a waterfall plot for `ADaM` data
7		#'
8		#' @inheritParams teal.widgets::standard_layout
9		#' @inheritParams argument_convention
10		#' @param dataname_tr tumor burden analysis data used in teal module to plot as bar height, needs to
11		#' be available in the list passed to the \code{data} argument of \code{\link[teal]{init}}
12		#' @param dataname_rs response analysis data used in teal module to label response parameters, needs to
13		#' be available in the list passed to the \code{data} argument of \code{\link[teal]{init}}
14		#' @param bar_paramcd (\code{choices_selected}) parameter in tumor burden data that will be plotted as
15		#' bar height
16		#' @param bar_var (\code{choices_selected}) numeric variable from dataset to plot the bar height, e.g., `PCHG`
17		#' @param bar_color_var (\code{choices_selected}) color by variable (subject level), \code{None} corresponds
18		#' to \code{NULL}
19		#' @param bar_color_opt aesthetic values to map color values (named vector to map color values to each name).
20		#' If not \code{NULL}, please make sure this contains all possible values for \code{bar_color_var} values,
21		#' otherwise color will be assigned by \code{ggplot} default, please note that \code{NULL} needs to be specified
22		#' in this case
23		#' @param sort_var (\code{choices_selected}) sort by variable (subject level), \code{None} corresponds
24		#' to \code{NULL}
25		#' @param add_label_var_sl (\code{choices_selected}) add label to bars (subject level), \code{None}
26		#' corresponds to \code{NULL}
27		#' @param add_label_paramcd_rs (\code{choices_selected}) add label to bars (response dataset), \code{None}
28		#' corresponds to \code{NULL}. At least one of \code{add_label_var_sl} and \code{add_label_paramcd_rs} needs
29		#' to be \code{NULL}
30		#' @param anno_txt_var_sl (\code{choices_selected}) subject level variables to be displayed in the annotation
31		#' table, default is \code{NULL}
32		#' @param anno_txt_paramcd_rs (\code{choices_selected}) analysis dataset variables to be displayed in the
33		#' annotation table, default is \code{NULL}
34		#' @param facet_var (\code{choices_selected}) facet by variable (subject level), \code{None} corresponds to
35		#' \code{NULL}
36		#' @param ytick_at bar height axis interval, default is \code{20}
37		#' @param href_line numeric vector to plot horizontal reference lines, default is \code{NULL}
38		#' @param gap_point_val singular numeric value for adding bar break when some bars are significantly higher
39		#' than others, default is \code{NULL}
40		#' @param show_value boolean of whether value of bar height is shown, default is \code{TRUE}
41		#'
42		#' @inherit argument_convention return
43		#'
44		#' @export
45		#'
46		#' @template author_qit3
47		#' @author houx14 \email{houx14@gene.com}
48		#'
49		#' @examples
50		#' library(nestcolor)
51		#' ADSL <- osprey::rADSL
52		#' ADRS <- osprey::rADRS
53		#' ADTR <- osprey::rADTR
54		#'
55		#' ADSL$SEX <- factor(ADSL$SEX, levels = unique(ADSL$SEX))
56		#'
57		#' app <- teal::init(
58		#' data = cdisc_data(
59		#' cdisc_dataset("ADSL", ADSL,
60		#' code = "ADSL <- rADSL
61		#' ADSL$SEX <- factor(ADSL$SEX, levels = unique(ADSL$SEX))"
62		#' ),
63		#' cdisc_dataset("ADRS", ADRS, code = "ADRS <- rADRS"),
64		#' cdisc_dataset("ADTR", ADTR,
65		#' code = " ADTR <- rADTR",
66		#' c("STUDYID", "USUBJID", "PARAMCD", "AVISIT")
67		#' ),
68		#' check = TRUE
69		#' ),
70		#' modules = modules(
71		#' tm_g_waterfall(
72		#' label = "Waterfall",
73		#' dataname_tr = "ADTR",
74		#' dataname_rs = "ADRS",
75		#' bar_paramcd = teal.transform::choices_selected(c("SLDINV"), "SLDINV"),
76		#' bar_var = teal.transform::choices_selected(c("PCHG", "AVAL"), "PCHG"),
77		#' bar_color_var = teal.transform::choices_selected(c("ARMCD", "SEX"), "ARMCD"),
78		#' bar_color_opt = NULL,
79		#' sort_var = teal.transform::choices_selected(c("ARMCD", "SEX"), NULL),
80		#' add_label_var_sl = teal.transform::choices_selected(c("SEX", "EOSDY"), NULL),
81		#' add_label_paramcd_rs = teal.transform::choices_selected(c("BESRSPI", "OBJRSPI"), NULL),
82		#' anno_txt_var_sl = teal.transform::choices_selected(c("SEX", "ARMCD", "BMK1", "BMK2"), NULL),
83		#' anno_txt_paramcd_rs = teal.transform::choices_selected(c("BESRSPI", "OBJRSPI"), NULL),
84		#' facet_var = teal.transform::choices_selected(c("SEX", "ARMCD", "STRATA1", "STRATA2"), NULL),
85		#' href_line = "-30, 20"
86		#' )
87		#' )
88		#' )
89		#' if (interactive()) {
90		#' shinyApp(app$ui, app$server)
91		#' }
92		tm_g_waterfall <- function(label,
93		dataname_tr = "ADTR",
94		dataname_rs = "ADRS",
95		bar_paramcd,
96		bar_var,
97		bar_color_var,
98		bar_color_opt = NULL,
99		sort_var,
100		add_label_var_sl,
101		add_label_paramcd_rs,
102		anno_txt_var_sl,
103		anno_txt_paramcd_rs,
104		facet_var,
105		ytick_at = 20,
106		href_line = NULL,
107		gap_point_val = NULL,
108		show_value = TRUE,
109		plot_height = c(1200L, 400L, 5000L),
110		plot_width = NULL,
111		pre_output = NULL,
112		post_output = NULL) {
113	!	logger::log_info("Initializing tm_g_waterfall")
114	!	checkmate::assert_string(label)
115	!	checkmate::assert_string(dataname_tr)
116	!	checkmate::assert_string(dataname_rs)
117	!	checkmate::assert_class(bar_paramcd, classes = "choices_selected")
118	!	checkmate::assert_class(bar_var, classes = "choices_selected")
119	!	checkmate::assert_class(bar_color_var, classes = "choices_selected")
120	!	checkmate::assert_class(sort_var, classes = "choices_selected")
121	!	checkmate::assert_class(anno_txt_var_sl, classes = "choices_selected")
122	!	checkmate::assert_class(anno_txt_paramcd_rs, classes = "choices_selected")
123	!	checkmate::assert_class(facet_var, classes = "choices_selected")
124	!	checkmate::assert_class(add_label_var_sl, classes = "choices_selected")
125	!	checkmate::assert_class(add_label_paramcd_rs, classes = "choices_selected")
126	!	checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
127	!	checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")
128	!	checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
129	!	checkmate::assert_numeric(
130	!	plot_width[1],
131	!	lower = plot_width[2],
132	!	upper = plot_width[3],
133	!	null.ok = TRUE,
134	!	.var.name = "plot_width"
135		)
136
137	!	args <- as.list(environment())
138
139	!	module(
140	!	label = label,
141	!	ui = ui_g_waterfall,
142	!	ui_args = args,
143	!	server = srv_g_waterfall,
144	!	server_args = list(
145	!	dataname_tr = dataname_tr,
146	!	dataname_rs = dataname_rs,
147	!	label = label,
148	!	bar_color_opt = bar_color_opt,
149	!	plot_height = plot_height,
150	!	plot_width = plot_width
151		),
152	!	datanames = "all"
153		)
154		}
155
156		ui_g_waterfall <- function(id, ...) {
157	!	a <- list(...)
158	!	ns <- NS(id)
159
160	!	teal.widgets::standard_layout(
161	!	output = teal.widgets::white_small_well(
162	!	teal.widgets::plot_with_settings_ui(id = ns("waterfallplot"))
163		),
164	!	encoding = div(
165		### Reporter
166	!	teal.reporter::simple_reporter_ui(ns("simple_reporter")),
167		###
168	!	tags$label("Encodings", class = "text-primary"),
169	!	helpText("Analysis Data: ", tags$code(a$dataname_tr), tags$code(a$dataname_rs)),
170	!	teal.widgets::optionalSelectInput(
171	!	ns("bar_paramcd"),
172	!	"Tumor Burden Parameter",
173	!	choices = a$bar_paramcd$choices,
174	!	selected = a$bar_paramcd$selected,
175	!	multiple = FALSE
176		),
177	!	teal.widgets::optionalSelectInput(
178	!	ns("bar_var"),
179	!	"Bar Height",
180	!	choices = a$bar_var$choices,
181	!	selected = a$bar_var$selected,
182	!	multiple = FALSE,
183	!	label_help = helpText("Tumor change variable from ", tags$code("ADTR"))
184		),
185	!	teal.widgets::optionalSelectInput(
186	!	ns("bar_color_var"),
187	!	"Bar Color",
188	!	choices = a$bar_color_var$choices,
189	!	selected = a$bar_color_var$selected,
190	!	multiple = FALSE
191		),
192	!	teal.widgets::optionalSelectInput(
193	!	ns("sort_var"),
194	!	"Sort by",
195	!	choices = a$sort_var$choices,
196	!	selected = a$sort_var$selected,
197	!	multiple = FALSE,
198	!	label_help = helpText("from ", tags$code("ADSL"))
199		),
200	!	teal.widgets::optionalSelectInput(
201	!	ns("add_label_var_sl"),
202	!	"Add ADSL Label to Bars",
203	!	choices = a$add_label_var_sl$choices,
204	!	selected = a$add_label_var_sl$selected,
205	!	multiple = FALSE
206		),
207	!	teal.widgets::optionalSelectInput(
208	!	ns("add_label_paramcd_rs"),
209	!	"Add ADRS Label to Bars",
210	!	choices = a$add_label_paramcd_rs$choices,
211	!	selected = a$add_label_paramcd_rs$selected,
212	!	multiple = FALSE
213		),
214	!	teal.widgets::optionalSelectInput(
215	!	ns("anno_txt_var_sl"),
216	!	"Annotation Variables",
217	!	choices = a$anno_txt_var_sl$choices,
218	!	selected = a$anno_txt_var_sl$selected,
219	!	multiple = TRUE,
220	!	label_help = helpText("from ", tags$code("ADSL"))
221		),
222	!	teal.widgets::optionalSelectInput(
223	!	ns("anno_txt_paramcd_rs"),
224	!	"Annotation Parameters",
225	!	choices = a$anno_txt_paramcd_rs$choices,
226	!	selected = a$anno_txt_paramcd_rs$selected,
227	!	multiple = TRUE,
228	!	label_help = helpText("from ", tags$code("ADRS"))
229		),
230	!	teal.widgets::optionalSelectInput(
231	!	ns("facet_var"),
232	!	"Facet by",
233	!	choices = a$facet_var$choices,
234	!	selected = NULL,
235	!	multiple = FALSE,
236	!	label_help = helpText("from ", tags$code("ADSL"))
237		),
238	!	checkboxInput(
239	!	ns("show_value"),
240	!	"Add Bar Height Value",
241	!	value = a$show_value
242		),
243	!	textInput(
244	!	ns("href_line"),
245	!	label = div(
246	!	"Horizontal Reference Line(s)",
247	!	tags$br(),
248	!	helpText("Enter numeric value(s) of reference lines, separated by comma (eg. -10, 20)")
249		),
250	!	value = a$href_line
251		),
252	!	textInput(
253	!	ns("ytick_at"),
254	!	label = div(
255	!	"Y-axis Interval",
256	!	tags$br(),
257	!	helpText("Enter a numeric value of Y axis interval")
258		),
259	!	value = a$ytick_at
260		),
261	!	textInput(
262	!	ns("gap_point_val"),
263	!	label = div(
264	!	"Break High Bars",
265	!	tags$br(),
266	!	helpText("Enter a numeric value to break very high bars")
267		),
268	!	value = a$gap_point_val
269		)
270		),
271	!	forms = tagList(
272	!	teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
273	!	teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
274		),
275	!	pre_output = a$pre_output,
276	!	post_output = a$post_output
277		)
278		}
279
280		srv_g_waterfall <- function(id,
281		data,
282		filter_panel_api,
283		reporter,
284		dataname_tr,
285		dataname_rs,
286		bar_color_opt,
287		label,
288		plot_height,
289		plot_width) {
290	!	with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
291	!	with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
292	!	checkmate::assert_class(data, "tdata")
293
294	!	moduleServer(id, function(input, output, session) {
295	!	iv <- reactive({
296	!	adsl <- data[["ADSL"]]()
297	!	adtr <- data[[dataname_tr]]()
298	!	adrs <- data[[dataname_rs]]()
299
300	!	iv <- shinyvalidate::InputValidator$new()
301	!	iv$add_rule("bar_var", shinyvalidate::sv_required(
302	!	message = "Bar Height is required"
303		))
304	!	iv$add_rule("bar_paramcd", shinyvalidate::sv_required(
305	!	message = "Tumor Burden Parameter is required"
306		))
307	!	iv$add_rule("bar_paramcd", shinyvalidate::sv_in_set(
308	!	set = adtr$PARAMCD,
309	!	message_fmt = "All values of Tumor Burden Parameter must be elements of ADTR PARAMCD"
310		))
311	!	iv$add_rule("add_label_paramcd_rs", shinyvalidate::sv_optional())
312	!	iv$add_rule("add_label_paramcd_rs", shinyvalidate::sv_in_set(
313	!	set = adrs$PARAMCD,
314	!	message_fmt = "ADRS Label must be an element of ADRS PARAMCD"
315		))
316	!	rule_excl <- function(value, other) {
317	!	if (length(value) > 0L && length(other) > 0L) {
318	!	"Only one \"Label to Bars\" is allowed"
319		}
320		}
321	!	iv$add_rule("add_label_paramcd_rs", rule_excl, other = input$add_label_var_sl)
322	!	iv$add_rule("add_label_var_sl", rule_excl, other = input$add_label_paramcd_rs)
323	!	iv$add_rule("anno_txt_paramcd_rs", shinyvalidate::sv_optional())
324	!	iv$add_rule("anno_txt_paramcd_rs", shinyvalidate::sv_in_set(
325	!	set = adrs$PARAMCD,
326	!	message_fmt = "Annotation Parameters must be elements of ADRS PARAMCD"
327		))
328	!	iv$add_rule("href_line", shinyvalidate::sv_optional())
329	!	iv$add_rule("href_line", ~ if (anyNA(suppressWarnings(as_numeric_from_comma_sep_str(.)))) {
330	!	"Horizontal Reference Line(s) are invalid"
331		})
332	!	iv$add_rule("ytick_at", shinyvalidate::sv_required(
333	!	message = "Y-axis Interval is required"
334		))
335	!	iv$add_rule("ytick_at", ~ if (!checkmate::test_number(suppressWarnings(as.numeric(.)), lower = 1)) {
336	!	"Y-axis Interval must be a single positive number"
337		})
338	!	iv$add_rule("gap_point_val", shinyvalidate::sv_optional())
339	!	iv$add_rule("gap_point_val", ~ if (!checkmate::test_number(suppressWarnings(as.numeric(.)), lower = 1)) {
340	!	"Break High Bars must be a single positive number"
341		})
342	!	iv$enable()
343	!	iv
344		})
345
346	!	output_q <- reactive({
347	!	adsl <- data[["ADSL"]]()
348	!	adtr <- data[[dataname_tr]]()
349	!	adrs <- data[[dataname_rs]]()
350
351		# validate data rows
352	!	teal::validate_has_data(adsl, min_nrow = 2)
353	!	teal::validate_has_data(adtr, min_nrow = 2)
354	!	teal::validate_has_data(adrs, min_nrow = 2)
355
356	!	adsl_vars <- unique(
357	!	c(
358	!	"USUBJID", "STUDYID",
359	!	input$bar_color_var, input$sort_var, input$add_label_var_sl, input$anno_txt_var_sl, input$facet_var
360		)
361		)
362	!	adtr_vars <- unique(c("USUBJID", "STUDYID", "PARAMCD", input$bar_var))
363	!	adrs_vars <- unique(c("USUBJID", "STUDYID", "PARAMCD", "AVALC"))
364	!	adrs_paramcd <- unique(c(input$add_label_paramcd_rs, input$anno_txt_paramcd_rs))
365
366		# validate data input
367	!	teal::validate_has_variable(adsl, adsl_vars)
368	!	teal::validate_has_variable(adrs, adrs_vars)
369	!	teal::validate_has_variable(adtr, adtr_vars)
370
371	!	teal::validate_inputs(iv())
372
373		# get variables
374	!	bar_var <- input$bar_var
375	!	bar_paramcd <- input$bar_paramcd
376	!	add_label_var_sl <- input$add_label_var_sl
377	!	add_label_paramcd_rs <- input$add_label_paramcd_rs
378	!	anno_txt_var_sl <- input$anno_txt_var_sl
379	!	anno_txt_paramcd_rs <- input$anno_txt_paramcd_rs
380	!	ytick_at <- input$ytick_at
381	!	href_line <- input$href_line
382	!	gap_point_val <- input$gap_point_val
383	!	show_value <- input$show_value # nolint
384	!	href_line <- suppressWarnings(as_numeric_from_comma_sep_str(href_line))
385
386	!	if (gap_point_val == "") {
387	!	gap_point_val <- NULL
388		} else {
389	!	gap_point_val <- as.numeric(gap_point_val)
390		}
391	!	ytick_at <- as.numeric(ytick_at)
392
393	!	bar_color_var <- if (!is.null(input$bar_color_var) &&
394	!	input$bar_color_var != "None" &&
395	!	input$bar_color_var != "") {
396	!	input$bar_color_var
397		} else {
398	!	NULL
399		}
400	!	sort_var <- if (!is.null(input$sort_var) && input$sort_var != "None" && input$sort_var != "") {
401	!	input$sort_var
402		} else {
403	!	NULL
404		}
405	!	facet_var <- if (!is.null(input$facet_var) && input$facet_var != "None" && input$facet_var != "") {
406	!	input$facet_var
407		} else {
408	!	NULL
409		}
410
411		# write variables to qenv
412	!	q1 <- teal.code::eval_code(
413	!	teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)),
414	!	code = bquote({
415	!	bar_var <- .(bar_var)
416	!	bar_color_var <- .(bar_color_var)
417	!	sort_var <- .(sort_var)
418	!	add_label_var_sl <- .(add_label_var_sl)
419	!	add_label_paramcd_rs <- .(add_label_paramcd_rs)
420	!	anno_txt_var_sl <- .(anno_txt_var_sl)
421	!	anno_txt_paramcd_rs <- .(anno_txt_paramcd_rs)
422	!	facet_var <- .(facet_var)
423	!	href_line <- .(href_line)
424	!	gap_point_val <- .(gap_point_val)
425	!	show_value <- .(show_value)
426		})
427		)
428
429		# data processing
430	!	q1 <- teal.code::eval_code(
431	!	q1,
432	!	code = bquote({
433	!	adsl <- ADSL[, .(adsl_vars)]
434	!	adtr <- .(as.name(dataname_tr))[, .(adtr_vars)] # nolint
435	!	adrs <- .(as.name(dataname_rs))[, .(adrs_vars)] # nolint
436
437	!	bar_tr <- .(as.name(dataname_tr)) %>%
438	!	dplyr::filter(PARAMCD == .(bar_paramcd)) %>%
439	!	dplyr::select(USUBJID, .(as.name(bar_var))) %>%
440	!	dplyr::group_by(USUBJID) %>%
441	!	dplyr::slice(which.min(.(as.name(bar_var))))
442	!	bar_data <- adsl %>% dplyr::inner_join(bar_tr, "USUBJID")
443		})
444		)
445
446	!	q1 <- if (is.null(adrs_paramcd)) {
447	!	teal.code::eval_code(
448	!	q1,
449	!	code = bquote({
450	!	anl <- bar_data
451	!	anl$USUBJID <- unlist(lapply(strsplit(anl$USUBJID, "-", fixed = TRUE), tail, 1)) # nolint
452		})
453		)
454		} else {
455	!	qq1 <- teal.code::eval_code(
456	!	q1,
457	!	code = bquote(
458	!	rs_sub <- .(as.name(dataname_rs)) %>%
459	!	dplyr::filter(PARAMCD %in% .(adrs_paramcd))
460		)
461		)
462
463	!	teal::validate_one_row_per_id(qq1[["rs_sub"]], key = c("STUDYID", "USUBJID", "PARAMCD"))
464
465	!	teal.code::eval_code(
466	!	qq1,
467	!	code = bquote({
468	!	rs_label <- rs_sub %>%
469	!	dplyr::select(USUBJID, PARAMCD, AVALC) %>%
470	!	tidyr::pivot_wider(names_from = PARAMCD, values_from = AVALC)
471	!	anl <- bar_data %>% dplyr::left_join(rs_label, by = c("USUBJID"))
472	!	anl$USUBJID <- unlist(lapply(strsplit(anl$USUBJID, "-", fixed = TRUE), tail, 1)) # nolint
473		})
474		)
475		}
476
477		# write plotting code to qenv
478	!	anl <- q1[["anl"]] # nolint
479
480	!	q1 <- teal.code::eval_code(
481	!	q1,
482	!	code = bquote({
483	!	plot <- osprey::g_waterfall(
484	!	bar_id = anl[["USUBJID"]],
485	!	bar_height = anl[[bar_var]],
486	!	sort_by = .(if (length(sort_var) > 0) {
487	!	quote(anl[[sort_var]])
488		} else {
489	!	NULL
490		}),
491	!	col_by = .(if (length(bar_color_var) > 0) {
492	!	quote(anl[[bar_color_var]])
493		} else {
494	!	NULL
495		}),
496	!	bar_color_opt = .(if (length(bar_color_var) == 0) {
497	!	NULL
498	!	} else if (length(bar_color_var) > 0 & all(unique(anl[[bar_color_var]]) %in% names(bar_color_opt))) {
499	!	bar_color_opt
500		} else {
501	!	NULL
502		}),
503	!	anno_txt = .(if (length(anno_txt_var_sl) == 0 & length(anno_txt_paramcd_rs) == 0) {
504	!	NULL
505	!	} else if (length(anno_txt_var_sl) >= 1 & length(anno_txt_paramcd_rs) == 0) {
506	!	quote(data.frame(anl[anno_txt_var_sl]))
507	!	} else if (length(anno_txt_paramcd_rs) >= 1 & length(anno_txt_var_sl) == 0) {
508	!	quote(data.frame(anl[anno_txt_paramcd_rs]))
509		} else {
510	!	quote(cbind(anl[anno_txt_var_sl], anl[anno_txt_paramcd_rs]))
511		}),
512	!	href_line = .(href_line),
513	!	facet_by = .(if (length(facet_var) > 0) {
514	!	quote(as.factor(anl[[facet_var]]))
515		} else {
516	!	NULL
517		}),
518	!	show_datavalue = .(show_value),
519	!	add_label = .(if (length(add_label_var_sl) > 0 & length(add_label_paramcd_rs) == 0) {
520	!	quote(anl[[add_label_var_sl]])
521	!	} else if (length(add_label_paramcd_rs) > 0 & length(add_label_var_sl) == 0) {
522	!	quote(anl[[add_label_paramcd_rs]])
523		} else {
524	!	NULL
525		}),
526	!	gap_point = .(gap_point_val),
527	!	ytick_at = .(ytick_at),
528	!	y_label = "Tumor Burden Change from Baseline",
529	!	title = "Waterfall Plot"
530		)
531	!	plot
532		})
533		)
534		})
535
536	!	plot_r <- reactive(output_q()[["plot"]])
537
538		# Insert the plot into a plot_with_settings module from teal.widgets
539	!	pws <- teal.widgets::plot_with_settings_srv(
540	!	id = "waterfallplot",
541	!	plot_r = plot_r,
542	!	height = plot_height,
543	!	width = plot_width
544		)
545
546	!	teal.widgets::verbatim_popup_srv(
547	!	id = "warning",
548	!	verbatim_content = reactive(teal.code::get_warnings(output_q())),
549	!	title = "Warning",
550	!	disabled = reactive(is.null(teal.code::get_warnings(output_q())))
551		)
552
553		# Show R Code
554	!	teal.widgets::verbatim_popup_srv(
555	!	id = "rcode",
556	!	title = paste("R code for", label),
557	!	verbatim_content = reactive(teal.code::get_code(output_q()))
558		)
559
560		### REPORTER
561	!	if (with_reporter) {
562	!	card_fun <- function(comment) {
563	!	card <- teal::TealReportCard$new()
564	!	card$set_name("Waterfall")
565	!	card$append_text("Waterfall Plot", "header2")
566	!	if (with_filter) card$append_fs(filter_panel_api$get_filter_state())
567	!	card$append_text("Selected Options", "header3")
568	!	card$append_text(paste0("Tumor Burden Parameter: ", input$bar_paramcd, "."))
569	!	if (!is.null(input$sort_var)) {
570	!	card$append_text(paste0("Sorted by: ", input$sort_var, "."))
571		}
572	!	if (!is.null(input$facet_var)) {
573	!	card$append_text(paste0("Faceted by: ", paste(input$facet_var, collapse = ", "), "."))
574		}
575	!	card$append_text("Plot", "header3")
576	!	card$append_plot(plot_r(), dim = pws$dim())
577	!	if (!comment == "") {
578	!	card$append_text("Comment", "header3")
579	!	card$append_text(comment)
580		}
581	!	card$append_src(paste(teal.code::get_code(output_q()), collapse = "\n"))
582	!	card
583		}
584	!	teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
585		}
586		})
587		}

1		.onLoad <- function(libname, pkgname) { # nolint
2	!	teal.logger::register_logger(namespace = "teal.osprey")
3		}