teal.osprey coverage - 0.14%

Files
Source

#' 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 (`choices_seleced`) unique subject ID variable
#' @param sl_dataname (`character`) subject level dataset name,
#' needs to be available in the list passed to the `data`
#' argument of [teal::init()]
#' @param ex_dataname,ae_dataname,rs_dataname,cm_dataname,lb_dataname
#'        (`character(1)`) names of exposure, adverse events, response,
#'        concomitant medications, and labs datasets, respectively;
#'        must be available in the list passed to the `data`
#'        argument of [teal::init()]\cr
#'        set to NA (default) to omit from analysis
#' @param sl_start_date `choices_selected` study start date variable, usually set to
#'                      treatment start date or randomization date
#' @param ex_var `choices_selected` exposure variable to plot as each line \cr
#'               leave unspecified or set to `NULL` if exposure data is not available
#' @param ae_var `choices_selected` adverse event variable to plot as each line \cr
#'               leave unspecified or set to `NULL` if adverse events data is not available
#' @param ae_line_col_var `choices_selected` variable for coloring `AE` lines \cr
#'                        leave unspecified or set to `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 `NULL`, please make sure this contains all possible
#'                        values for `ae_line_col_var` values. \cr
#'                        leave unspecified or set to `NULL` if adverse events data is not available
#' @param rs_var `choices_selected` response variable to plot as each line \cr
#'               leave unspecified or set to `NULL` if response data is not available
#' @param cm_var `choices_selected` concomitant medication variable
#'               to plot as each line \cr
#'               leave unspecified or set to `NULL` if concomitant medications data is not available
#' @param lb_var `choices_selected` lab variable to plot as each line \cr
#'               leave unspecified or set to `NULL` if labs data is not available
#' @param x_limit a single `character` string with two numbers
#'                separated by a comma indicating the x-axis limit,
#'                default is "-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,
#' `ADSL.RANDDT` or `ADSL.TRTSDT`):
#' - In `ADAE`, `ADEX`, and `ADCM`, it would be study day based on `ASTDT` and/or
#'     `AENDT` in reference to the start date
#' - In `ADRS` and `ADLB`, it would be study day based on `ADT` in reference to
#'     the start date
#'
#' @export
#'
#' @examples
#' data <- teal_data() |>
#'   within({
#'     ADSL <- rADSL
#'     ADAE <- rADAE %>% mutate(ASTDT = as.Date(ASTDTM), AENDT = as.Date(AENDTM))
#'     ADCM <- 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 <- rADRS %>% mutate(ADT = as.Date(ADTM))
#'     ADEX <- rADEX %>% mutate(ASTDT = as.Date(ASTDTM), AENDT = as.Date(AENDTM))
#'     ADLB <- rADLB %>% mutate(ADT = as.Date(ADTM), LBSTRESN = as.numeric(LBSTRESC))
#'   })
#'
#' join_keys(data) <- default_cdisc_join_keys[names(data)]
#'
#' ADSL <- data[["ADSL"]]
#'
#' app <- init(
#'   data = data,
#'   modules = modules(
#'     tm_g_patient_profile(
#'       label = "Patient Profile Plot",
#'       patient_id = 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 = choices_selected(
#'         selected = "TRTSDTM",
#'         choices = c("TRTSDTM", "RANDDT")
#'       ),
#'       ex_var = choices_selected(
#'         selected = "PARCAT2",
#'         choices = "PARCAT2"
#'       ),
#'       ae_var = choices_selected(
#'         selected = "AEDECOD",
#'         choices = c("AEDECOD", "AESOC")
#'       ),
#'       ae_line_col_var = choices_selected(
#'         selected = "AESER",
#'         choices = c("AESER", "AEREL")
#'       ),
#'       ae_line_col_opt = c("Y" = "red", "N" = "blue"),
#'       rs_var = choices_selected(
#'         selected = "PARAMCD",
#'         choices = "PARAMCD"
#'       ),
#'       cm_var = choices_selected(
#'         selected = "CMDECOD",
#'         choices = c("CMDECOD", "CMCAT")
#'       ),
#'       lb_var = 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(
      patient_id = patient_id,
      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 = tags$div(
        ### Reporter
        teal.reporter::simple_reporter_ui(ns("simple_reporter")),
        ###
        tags$label("Encodings", class = "text-primary"),
        selectizeInput(
          inputId = ns("patient_id"),
          label = "Patient ID",
          choices = NULL
        ),
        tags$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 = get_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 = get_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 = get_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 = get_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 = get_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 = get_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 = get_choices(a$lb_var$choices),
            selected = a$lb_var$selected,
            multiple = FALSE
          ),
          selectInput(
            ns("lb_var_show"),
            "Lab values",
            choices = get_choices(a$lb_var$choices),
            selected = a$lb_var$selected,
            multiple = TRUE
          )
        ),
        textInput(
          ns("x_limit"),
          label = tags$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("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,
                                  patient_id,
                                  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, "reactive")
  checkmate::assert_class(shiny::isolate(data()), "teal_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(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) {
    teal.logger::log_shiny_input_changes(input, namespace = "teal.osprey")
    select_plot <- reactive(
      vapply(checkboxes, function(x) x %in% input$select_ADaM, logical(1L))
    )

    resolved <- teal.transform::resolve_delayed(patient_id, as.list(isolate(data())))

    updateSelectizeInput(
      session = session,
      inputId = "patient_id",
      choices = resolved$choices,
      selected = resolved$selected
    )

    if (!is.na(lb_dataname)) {
      observeEvent(input$lb_var, ignoreNULL = TRUE, {
        ADLB <- data()[[lb_dataname]]
        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
        sl_start_date <- input$sl_start_date
        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]]

        ADEX <- NULL
        if (isTRUE(select_plot()[ex_dataname])) {
          ADEX <- data()[[ex_dataname]]
          teal::validate_has_variable(ADEX, adex_vars)
        }
        ADAE <- NULL
        if (isTRUE(select_plot()[ae_dataname])) {
          ADAE <- data()[[ae_dataname]]
          teal::validate_has_variable(ADAE, adae_vars)
        }
        ADRS <- NULL
        if (isTRUE(select_plot()[rs_dataname])) {
          ADRS <- data()[[rs_dataname]]
          teal::validate_has_variable(ADRS, adrs_vars)
        }
        ADCM <- NULL
        if (isTRUE(select_plot()[cm_dataname])) {
          ADCM <- data()[[cm_dataname]]
          teal::validate_has_variable(ADCM, adcm_vars)
        }
        ADLB <- NULL
        if (isTRUE(select_plot()[lb_dataname])) {
          ADLB <- data()[[lb_dataname]]
          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(
          data(),
          code = substitute(
            expr = {
              ADSL <- ADSL %>%
                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]

                  ADAE <- ADSL %>%
                    left_join(ADAE, by = c("STUDYID", "USUBJID")) %>%
                    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] <-
                    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]]
            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]
                  ADRS <- ADSL %>%
                    left_join(ADRS, by = c("STUDYID", "USUBJID")) %>%
                    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]]
            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]
                  ADCM <- ADSL %>%
                    left_join(ADCM, by = c("STUDYID", "USUBJID")) %>%
                    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 & 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]]
            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]
                  ADEX <- ADSL %>%
                    left_join(ADEX, by = c("STUDYID", "USUBJID")) %>%
                    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) %>%
                    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]]
            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]
                  ADLB <- ADSL %>%
                    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
                    ) %>%
                    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]]
            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 = "rcode",
      title = paste("R code for", label),
      verbatim_content = reactive(teal.code::get_code(output_q()))
    )

    ### REPORTER
    if (with_reporter) {
      card_fun <- function(comment, label) {
        card <- teal::report_card_template(
          title = "Patient Profile",
          label = label,
          with_filter = with_filter,
          filter_panel_api = filter_panel_api
        )
        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(teal.code::get_code(output_q()))
        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 [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
#' data <- teal_data() |>
#'   within({
#'     ADSL <- rADSL
#'     ADAE <- rADAE
#'   })
#'
#' join_keys(data) <- default_cdisc_join_keys[names(data)]
#'
#' app <- init(
#'   data = data,
#'   modules = modules(
#'     tm_g_events_term_id(
#'       label = "Common AE",
#'       dataname = "ADAE",
#'       term_var = choices_selected(
#'         selected = "AEDECOD",
#'         choices = c(
#'           "AEDECOD", "AETERM",
#'           "AEHLT", "AELLT", "AEBODSYS"
#'         )
#'       ),
#'       arm_var = choices_selected(
#'         selected = "ACTARMCD",
#'         choices = c("ACTARM", "ACTARMCD")
#'       ),
#'       plot_height = c(600, 200, 2000)
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
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) {
  message("Initializing tm_g_events_term_id")
  checkmate::assert_string(label)
  checkmate::assert_class(term_var, classes = "choices_selected")
  checkmate::assert_class(arm_var, classes = "choices_selected")
  checkmate::assert(
    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 = tags$div(
      ### Reporter
      teal.reporter::simple_reporter_ui(ns("simple_reporter")),
      ###
      teal.widgets::optionalSelectInput(
        ns("term"),
        "Term Variable",
        choices = get_choices(args$term_var$choices),
        selected = args$term_var$selected
      ),
      teal.widgets::optionalSelectInput(
        ns("arm_var"),
        "Arm Variable",
        choices = get_choices(args$arm_var$choices),
        selected = args$arm_var$selected
      ),
      selectInput(
        ns("arm_ref"),
        "Control",
        choices = get_choices(args$arm_var$choices),
        selected = args$arm_var$selected
      ),
      selectInput(
        ns("arm_trt"),
        "Treatment",
        choices = get_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("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, "reactive")
  checkmate::assert_class(shiny::isolate(data()), "teal_data")

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

    decorate_output <- srv_g_decorate(
      id = NULL, plt = plot_r, plot_height = plot_height, plot_width = plot_width
    )
    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]]

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

      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))
      anl_vars <- c("USUBJID", "STUDYID", input$term)

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

      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 = "rcode",
      title = paste("R code for", label),
      verbatim_content = reactive(teal.code::get_code(output_q()))
    )

    ### REPORTER
    if (with_reporter) {
      card_fun <- function(comment, label) {
        card <- teal::report_card_template(
          title = "Events by Term",
          label = label,
          with_filter = with_filter,
          filter_panel_api = filter_panel_api
        )
        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(teal.code::get_code(output_q()))
        card
      }
      teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
    }
  })
}

#' 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 `data` argument of [teal::init()]
#' @param dataname_rs response analysis data used in teal module to label response parameters, needs to
#' be available in the list passed to the `data` argument of [teal::init()]
#' @param bar_paramcd `choices_selected` parameter in tumor burden data that will be plotted as
#' bar height
#' @param bar_var `choices_selected` numeric variable from dataset to plot the bar height, e.g., `PCHG`
#' @param bar_color_var `choices_selected` color by variable (subject level), `None` corresponds
#' to `NULL`
#' @param bar_color_opt aesthetic values to map color values (named vector to map color values to each name).
#' If not `NULL`, please make sure this contains all possible values for `bar_color_var` values,
#' otherwise color will be assigned by `ggplot` default, please note that `NULL` needs to be specified
#' in this case
#' @param sort_var `choices_selected` sort by variable (subject level), `None` corresponds
#' to `NULL`
#' @param add_label_var_sl `choices_selected` add label to bars (subject level), `None`
#' corresponds to `NULL`
#' @param add_label_paramcd_rs `choices_selected` add label to bars (response dataset), `None`
#' corresponds to `NULL`. At least one of `add_label_var_sl` and `add_label_paramcd_rs` needs
#' to be `NULL`
#' @param anno_txt_var_sl `choices_selected` subject level variables to be displayed in the annotation
#' table, default is `NULL`
#' @param anno_txt_paramcd_rs `choices_selected` analysis dataset variables to be displayed in the
#' annotation table, default is `NULL`
#' @param facet_var `choices_selected` facet by variable (subject level), `None` corresponds to
#' `NULL`
#' @param ytick_at bar height axis interval, default is 20
#' @param href_line numeric vector to plot horizontal reference lines, default is `NULL`
#' @param gap_point_val singular numeric value for adding bar break when some bars are significantly higher
#' than others, default is `NULL`
#' @param show_value boolean of whether value of bar height is shown, default is `TRUE`
#'
#' @inherit argument_convention return
#'
#' @export
#'
#' @template author_qit3
#' @author houx14 \email{houx14@gene.com}
#'
#' @examples
#' data <- teal_data() |>
#'   within({
#'     ADSL <- rADSL
#'     ADRS <- rADRS
#'     ADTR <- rADTR
#'     ADSL$SEX <- factor(ADSL$SEX, levels = unique(ADSL$SEX))
#'   })
#'
#' join_keys(data) <- default_cdisc_join_keys[names(data)]
#'
#' app <- init(
#'   data = data,
#'   modules = modules(
#'     tm_g_waterfall(
#'       label = "Waterfall",
#'       dataname_tr = "ADTR",
#'       dataname_rs = "ADRS",
#'       bar_paramcd = choices_selected(c("SLDINV"), "SLDINV"),
#'       bar_var = choices_selected(c("PCHG", "AVAL"), "PCHG"),
#'       bar_color_var = choices_selected(c("ARMCD", "SEX"), "ARMCD"),
#'       bar_color_opt = NULL,
#'       sort_var = choices_selected(c("ARMCD", "SEX"), NULL),
#'       add_label_var_sl = choices_selected(c("SEX", "EOSDY"), NULL),
#'       add_label_paramcd_rs = choices_selected(c("BESRSPI", "OBJRSPI"), NULL),
#'       anno_txt_var_sl = choices_selected(c("SEX", "ARMCD", "BMK1", "BMK2"), NULL),
#'       anno_txt_paramcd_rs = choices_selected(c("BESRSPI", "OBJRSPI"), NULL),
#'       facet_var = choices_selected(c("SEX", "ARMCD", "STRATA1", "STRATA2"), NULL),
#'       href_line = "-30, 20"
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
tm_g_waterfall <- function(label,
                           dataname_tr = "ADTR",
                           dataname_rs = "ADRS",
                           bar_paramcd,
                           bar_var,
                           bar_color_var,
                           bar_color_opt = NULL,
                           sort_var,
                           add_label_var_sl,
                           add_label_paramcd_rs,
                           anno_txt_var_sl,
                           anno_txt_paramcd_rs,
                           facet_var,
                           ytick_at = 20,
                           href_line = NULL,
                           gap_point_val = NULL,
                           show_value = TRUE,
                           plot_height = c(1200L, 400L, 5000L),
                           plot_width = NULL,
                           pre_output = NULL,
                           post_output = NULL) {
  message("Initializing tm_g_waterfall")
  checkmate::assert_string(label)
  checkmate::assert_string(dataname_tr)
  checkmate::assert_string(dataname_rs)
  checkmate::assert_class(bar_paramcd, classes = "choices_selected")
  checkmate::assert_class(bar_var, classes = "choices_selected")
  checkmate::assert_class(bar_color_var, classes = "choices_selected")
  checkmate::assert_class(sort_var, classes = "choices_selected")
  checkmate::assert_class(anno_txt_var_sl, classes = "choices_selected")
  checkmate::assert_class(anno_txt_paramcd_rs, classes = "choices_selected")
  checkmate::assert_class(facet_var, classes = "choices_selected")
  checkmate::assert_class(add_label_var_sl, classes = "choices_selected")
  checkmate::assert_class(add_label_paramcd_rs, classes = "choices_selected")
  checkmate::assert_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,
      bar_paramcd = bar_paramcd,
      add_label_paramcd_rs = add_label_paramcd_rs,
      anno_txt_paramcd_rs = anno_txt_paramcd_rs,
      label = label,
      bar_color_opt = bar_color_opt,
      plot_height = plot_height,
      plot_width = plot_width
    ),
    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 = tags$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",
        multiple = FALSE
      ),
      teal.widgets::optionalSelectInput(
        ns("bar_var"),
        "Bar Height",
        choices = get_choices(a$bar_var$choices),
        selected = a$bar_var$selected,
        multiple = FALSE,
        label_help = helpText("Tumor change variable from ", tags$code("ADTR"))
      ),
      teal.widgets::optionalSelectInput(
        ns("bar_color_var"),
        "Bar Color",
        choices = get_choices(a$bar_color_var$choices),
        selected = a$bar_color_var$selected,
        multiple = FALSE
      ),
      teal.widgets::optionalSelectInput(
        ns("sort_var"),
        "Sort by",
        choices = get_choices(a$sort_var$choices),
        selected = a$sort_var$selected,
        multiple = FALSE,
        label_help = helpText("from ", tags$code("ADSL"))
      ),
      teal.widgets::optionalSelectInput(
        ns("add_label_var_sl"),
        "Add ADSL Label to Bars",
        choices = get_choices(a$add_label_var_sl$choices),
        selected = a$add_label_var_sl$selected,
        multiple = FALSE
      ),
      teal.widgets::optionalSelectInput(
        ns("add_label_paramcd_rs"),
        "Add ADRS Label to Bars",
        multiple = FALSE
      ),
      teal.widgets::optionalSelectInput(
        ns("anno_txt_var_sl"),
        "Annotation Variables",
        choices = get_choices(a$anno_txt_var_sl$choices),
        selected = a$anno_txt_var_sl$selected,
        multiple = TRUE,
        label_help = helpText("from ", tags$code("ADSL"))
      ),
      teal.widgets::optionalSelectInput(
        ns("anno_txt_paramcd_rs"),
        "Annotation Parameters",
        multiple = TRUE,
        label_help = helpText("from ", tags$code("ADRS"))
      ),
      teal.widgets::optionalSelectInput(
        ns("facet_var"),
        "Facet by",
        choices = get_choices(a$facet_var$choices),
        selected = NULL,
        multiple = FALSE,
        label_help = helpText("from ", tags$code("ADSL"))
      ),
      checkboxInput(
        ns("show_value"),
        "Add Bar Height Value",
        value = a$show_value
      ),
      textInput(
        ns("href_line"),
        label = tags$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 = tags$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 = tags$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("rcode"), "Show R code")
    ),
    pre_output = a$pre_output,
    post_output = a$post_output
  )
}

srv_g_waterfall <- function(id,
                            data,
                            filter_panel_api,
                            reporter,
                            bar_paramcd,
                            add_label_paramcd_rs,
                            anno_txt_paramcd_rs,
                            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, "reactive")
  checkmate::assert_class(shiny::isolate(data()), "teal_data")

  moduleServer(id, function(input, output, session) {
    teal.logger::log_shiny_input_changes(input, namespace = "teal.osprey")

    env <- as.list(isolate(data()))
    resolved_bar_paramcd <- teal.transform::resolve_delayed(bar_paramcd, env)
    resolved_add_label_paramcd_rs <- teal.transform::resolve_delayed(add_label_paramcd_rs, env)
    resolved_anno_txt_paramcd_rs <- teal.transform::resolve_delayed(anno_txt_paramcd_rs, env)

    teal.widgets::updateOptionalSelectInput(
      session = session,
      inputId = "bar_paramcd",
      choices = resolved_bar_paramcd$choices,
      selected = resolved_bar_paramcd$selected
    )
    teal.widgets::updateOptionalSelectInput(
      session = session,
      inputId = "add_label_paramcd_rs",
      choices = resolved_add_label_paramcd_rs$choices,
      selected = resolved_add_label_paramcd_rs$selected
    )
    teal.widgets::updateOptionalSelectInput(
      session = session,
      inputId = "anno_txt_paramcd_rs",
      choices = resolved_anno_txt_paramcd_rs$choices,
      selected = resolved_anno_txt_paramcd_rs$selected
    )

    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
      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(
        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)]
          adrs <- .(as.name(dataname_rs))[, .(adrs_vars)]

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

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

      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
    )

    # 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, label) {
        card <- teal::report_card_template(
          title = "Waterfall Plot",
          label = label,
          with_filter = with_filter,
          filter_panel_api = filter_panel_api
        )
        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(teal.code::get_code(output_q()))
        card
      }
      teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
    }
  })
}

#' 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 (`choices_selected`) variable name of data filter, please see details regarding
#'   expected values, default is`NULL`.`choices`
#'   vector with `filter_var` choices, default is
#'   `NULL`
#' @param right_var (`choices_selected`) dichotomization variable for right side
#' @param left_var (`choices_selected`) dichotomization variable for left side
#' @param category_var (`choices_selected`) category (y axis) variable
#' @param color_by_var (`choices_selected`) variable defines color blocks within each bar
#' @param count_by_var (`choices_selected`) variable defines how x axis is calculated
#' @param facet_var (`choices_selected`) variable for row facets
#' @param sort_by_var (`choices_selected`) argument for order of class and term elements in table,
#'   default here is "count"
#' @param legend_on (`boolean`) value for whether legend is displayed
#'
#' @details `filter_var` option is designed to work in conjunction with
#'   filtering function provided by `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
#'   `filter_var_choices` is expected to contain values of either "Y" or
#'   "N". If multiple variables are selected as `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
#' data <- teal_data() |>
#'   within({
#'     library(dplyr)
#'     set.seed(23)
#'     ADSL <- rADSL
#'     ADAE <- 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())
#'     )
#'   })
#'
#' join_keys(data) <- default_cdisc_join_keys[names(data)]
#'
#' app <- init(
#'   data = data,
#'   modules = modules(
#'     tm_g_butterfly(
#'       label = "Butterfly Plot",
#'       dataname = "ADAE",
#'       right_var = choices_selected(
#'         selected = "SEX",
#'         choices = c("SEX", "ARM", "RACE")
#'       ),
#'       left_var = choices_selected(
#'         selected = "RACE",
#'         choices = c("SEX", "ARM", "RACE")
#'       ),
#'       category_var = choices_selected(
#'         selected = "AEBODSYS",
#'         choices = c("AEDECOD", "AEBODSYS")
#'       ),
#'       color_by_var = choices_selected(
#'         selected = "AETOXGR",
#'         choices = c("AETOXGR", "None")
#'       ),
#'       count_by_var = choices_selected(
#'         selected = "# of patients",
#'         choices = c("# of patients", "# of AEs")
#'       ),
#'       facet_var = choices_selected(
#'         selected = NULL,
#'         choices = c("RACE", "SEX", "ARM")
#'       ),
#'       sort_by_var = 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) {
  message("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 = tags$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 = get_choices(a$filter_var$choices),
          selected = a$filter_var$selected,
          multiple = TRUE
        )
      },
      teal.widgets::optionalSelectInput(
        ns("right_var"),
        "Right Dichotomization Variable",
        get_choices(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",
        get_choices(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",
        get_choices(a$category_var$choices),
        a$category_var$selected,
        multiple = FALSE
      ),
      radioButtons(
        ns("color_by_var"),
        "Color Block By Variable",
        get_choices(a$color_by_var$choices),
        a$color_by_var$selected
      ),
      radioButtons(
        ns("count_by_var"),
        "Count By Variable",
        get_choices(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",
          get_choices(a$facet_var$choices),
          a$facet_var$selected,
          multiple = TRUE
        )
      },
      radioButtons(
        ns("sort_by_var"),
        "Sort By Variable",
        get_choices(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("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, "reactive")
  checkmate::assert_class(shiny::isolate(data()), "teal_data")

  moduleServer(id, function(input, output, session) {
    teal.logger::log_shiny_input_changes(input, namespace = "teal.osprey")
    iv <- reactive({
      ADSL <- data()[["ADSL"]]
      ANL <- data()[[dataname]]

      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"]]
        ANL <- data()[[dataname]]

        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))
        anl_vars <- unique(c("USUBJID", "STUDYID", varlist_from_anl))

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

        if (!("NULL" %in% filter_var) && !is.null(filter_var)) {
          q1 <- teal.code::eval_code(
            q1,
            code = bquote(
              ANL <- quick_filter(.(filter_var), ANL) %>%
                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()
            ANL_f <- na.omit(ANL_f)
          })
        )

        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 = "rcode",
      title = paste("R code for", label),
      verbatim_content = reactive(teal.code::get_code(output_q()))
    )

    ### REPORTER
    if (with_reporter) {
      card_fun <- function(comment, label) {
        card <- teal::report_card_template(
          title = "Butterfly Plot",
          label = label,
          with_filter = with_filter,
          filter_panel_api = filter_panel_api
        )
        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(teal.code::get_code(output_q()))
        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 `data`
#' argument of [teal::init()]. If no markers are to be plotted in the module, `"ADSL"` should be
#' the input. If markers are to be plotted, data name for the marker data should be the input
#' @param bar_var [teal.transform::choices_selected] subject-level numeric variable from dataset
#' to plot as the bar length
#' @param bar_color_var [teal.transform::choices_selected] color by variable (subject-level)
#' @param sort_var `choices_selected` sort by variable (subject-level)
#' @param marker_pos_var [teal.transform::choices_selected] variable for marker position from marker data
#' (Note: make sure that marker position has the same relative start day as bar length variable `bar_var`
#' @param marker_shape_var [teal.transform::choices_selected] marker shape variable from marker data
#' @param marker_shape_opt aesthetic values to map shape values (named vector to map shape values to each name).
#' If not `NULL`, please make sure this contains all possible values for `marker_shape_var` values,
#' otherwise shape will be assigned by `ggplot` default
#' @param marker_color_var marker color variable from marker data
#' @param marker_color_opt aesthetic values to map color values (named vector to map color values to each name).
#' If not `NULL`, please make sure this contains all possible values for `marker_color_var` values,
#' otherwise color will be assigned by `ggplot` default
#' @param vref_line vertical reference lines
#' @param anno_txt_var character vector with subject-level variable names that are selected as annotation
#' @param x_label the label of the x axis
#'
#' @inherit argument_convention return
#'
#' @export
#'
#' @template author_qit3
#'
#' @examples
#' # Example using stream (ADaM) dataset
#' data <- teal_data() |>
#'   within({
#'     library(dplyr)
#'     ADSL <- rADSL %>%
#'       mutate(TRTDURD = as.integer(TRTEDTM - TRTSDTM) + 1) %>%
#'       filter(STRATA1 == "A" & ARMCD == "ARM A")
#'     ADRS <- rADRS %>%
#'       filter(PARAMCD == "LSTASDI" & DCSREAS == "Death") %>%
#'       mutate(AVALC = DCSREAS, ADY = EOSDY) %>%
#'       rbind(rADRS %>% filter(PARAMCD == "OVRINV" & AVALC != "NE")) %>%
#'       arrange(USUBJID)
#'   })
#'
#' join_keys(data) <- default_cdisc_join_keys[names(data)]
#'
#' ADSL <- data[["ADSL"]]
#' ADRS <- data[["ADRS"]]
#'
#' app <- init(
#'   data = data,
#'   modules = modules(
#'     tm_g_swimlane(
#'       label = "Swimlane Plot",
#'       dataname = "ADRS",
#'       bar_var = choices_selected(
#'         selected = "TRTDURD",
#'         choices = c("TRTDURD", "EOSDY")
#'       ),
#'       bar_color_var = choices_selected(
#'         selected = "EOSSTT",
#'         choices = c("EOSSTT", "ARM", "ARMCD", "ACTARM", "ACTARMCD", "SEX")
#'       ),
#'       sort_var = choices_selected(
#'         selected = "ACTARMCD",
#'         choices = c("USUBJID", "SITEID", "ACTARMCD", "TRTDURD")
#'       ),
#'       marker_pos_var = choices_selected(
#'         selected = "ADY",
#'         choices = c("ADY")
#'       ),
#'       marker_shape_var = choices_selected(
#'         selected = "AVALC",
#'         c("AVALC", "AVISIT")
#'       ),
#'       marker_shape_opt = c("CR" = 16, "PR" = 17, "SD" = 18, "PD" = 15, "Death" = 8),
#'       marker_color_var = choices_selected(
#'         selected = "AVALC",
#'         choices = c("AVALC", "AVISIT")
#'       ),
#'       marker_color_opt = c(
#'         "CR" = "green", "PR" = "blue", "SD" = "goldenrod",
#'         "PD" = "red", "Death" = "black"
#'       ),
#'       vref_line = c(30, 60),
#'       anno_txt_var = choices_selected(
#'         selected = c("ACTARM", "SEX"),
#'         choices = c(
#'           "ARM", "ARMCD", "ACTARM", "ACTARMCD", "AGEGR1",
#'           "SEX", "RACE", "COUNTRY", "DCSREAS", "DCSREASP"
#'         )
#'       )
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
tm_g_swimlane <- function(label,
                          dataname,
                          bar_var,
                          bar_color_var = NULL,
                          sort_var = NULL,
                          marker_pos_var = NULL,
                          marker_shape_var = NULL,
                          marker_shape_opt = NULL,
                          marker_color_var = NULL,
                          marker_color_opt = NULL,
                          anno_txt_var = NULL,
                          vref_line = NULL,
                          plot_height = c(1200L, 400L, 5000L),
                          plot_width = NULL,
                          pre_output = NULL,
                          post_output = NULL,
                          x_label = "Time from First Treatment (Day)") {
  message("Initializing tm_g_swimlane")
  args <- as.list(environment())

  checkmate::assert_string(label)
  checkmate::assert_string(dataname)
  checkmate::assert_class(bar_var, classes = "choices_selected")
  checkmate::assert_class(bar_color_var, classes = "choices_selected")
  checkmate::assert_class(marker_pos_var, classes = "choices_selected")
  checkmate::assert_class(marker_shape_var, classes = "choices_selected")
  checkmate::assert_numeric(marker_shape_opt, min.len = 1, any.missing = FALSE)
  checkmate::assert_class(marker_color_var, classes = "choices_selected")
  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 = tags$div(
        ### Reporter
        teal.reporter::simple_reporter_ui(ns("simple_reporter")),
        ###
        tags$label("Encodings", class = "text-primary"),
        helpText("Analysis data:", tags$code(a$dataname)),
        tags$div(
          class = "pretty-left-border",
          teal.widgets::optionalSelectInput(
            ns("bar_var"),
            "Bar Length",
            choices = get_choices(a$bar_var$choices),
            selected = a$bar_var$selected,
            multiple = FALSE,
            label_help = helpText("from ", tags$code("ADSL"))
          ),
          teal.widgets::optionalSelectInput(
            ns("bar_color_var"),
            "Bar Color",
            choices = get_choices(a$bar_color_var$choices),
            selected = a$bar_color_var$selected,
            multiple = FALSE,
            label_help = helpText("from ", tags$code("ADSL"))
          )
        ),
        teal.widgets::optionalSelectInput(
          ns("sort_var"),
          "Sort by",
          choices = get_choices(a$sort_var$choices),
          selected = a$sort_var$selected,
          multiple = FALSE,
          label_help = helpText("from ", tags$code("ADSL"))
        ),
        tags$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 = get_choices(a$marker_pos_var$choices),
              selected = a$marker_pos_var$selected,
              multiple = FALSE,
              label_help = helpText("from ", tags$code(a$dataname))
            )
          },
          uiOutput(ns("marker_shape_sel")),
          uiOutput(ns("marker_color_sel"))
        ),
        teal.widgets::optionalSelectInput(
          ns("anno_txt_var"),
          "Annotation Variables",
          choices = get_choices(a$anno_txt_var$choices),
          selected = a$anno_txt_var$selected,
          multiple = TRUE,
          label_help = helpText("from ", tags$code("ADSL"))
        ),
        textInput(
          ns("vref_line"),
          label = tags$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("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, "reactive")
  checkmate::assert_class(shiny::isolate(data()), "teal_data")

  moduleServer(id, function(input, output, session) {
    teal.logger::log_shiny_input_changes(input, namespace = "teal.osprey")
    iv <- reactive({
      iv <- shinyvalidate::InputValidator$new()
      iv$add_rule("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 = get_choices(marker_shape_var$choices),
          selected = marker_shape_var$selected, multiple = FALSE,
          label_help = helpText("from ", tags$code(dataname))
        )
      }
    })
    output$marker_color_sel <- renderUI({
      if (dataname == "ADSL" || is.null(marker_color_var) || is.null(input$marker_pos_var)) {
        NULL
      } else {
        ns <- session$ns
        teal.widgets::optionalSelectInput(
          ns("marker_color_var"), "Marker Color",
          choices = get_choices(marker_color_var$choices),
          selected = marker_color_var$selected, multiple = FALSE,
          label_help = helpText("from ", tags$code(dataname))
        )
      }
    })

    # create plot
    output_q <- reactive({
      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"]]

      anl_vars <- unique(c(
        "USUBJID", "STUDYID",
        input$marker_pos_var, input$marker_shape_var, input$marker_color_var
      ))
      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 <- 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
            ADSL <- ADSL_p[, .(adsl_vars)]
            # only take last part of USUBJID
            ADSL$USUBJID <- unlist(lapply(strsplit(ADSL$USUBJID, "-", fixed = TRUE), tail, 1))
          })
        )
      } else {
        teal.code::eval_code(
          q2,
          code = bquote({
            ADSL_p <- ADSL
            ANL_p <- .(as.name(dataname))

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

      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))) { # nolint: line_length.
              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))) { # nolint: line_length.
              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 = "rcode",
      title = paste("R code for", label),
      verbatim_content = reactive(teal.code::get_code(output_q()))
    )

    ### REPORTER
    if (with_reporter) {
      card_fun <- function(comment, label) {
        card <- teal::report_card_template(
          title = "Swimlane Plot",
          label = label,
          with_filter = with_filter,
          filter_panel_api = filter_panel_api
        )
        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(teal.code::get_code(output_q()))
        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
#' data <- teal_data() |>
#'   within({
#'     ADSL <- rADSL
#'     ADAE <- rADAE
#'   })
#'
#' join_keys(data) <- default_cdisc_join_keys[names(data)]
#'
#' app <- init(
#'   data = data,
#'   modules = modules(
#'     tm_g_ae_sub(
#'       label = "AE by Subgroup",
#'       dataname = "ADAE",
#'       arm_var = choices_selected(
#'         selected = "ACTARMCD",
#'         choices = c("ACTARM", "ACTARMCD")
#'       ),
#'       group_var = 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)) {
  message("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 = tags$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 = get_choices(args$arm_var$choices),
        selected = args$arm_var$selected
      ),
      selectInput(
        ns("arm_trt"),
        "Treatment",
        choices = get_choices(args$arm_var$choices),
        selected = args$arm_var$selected
      ),
      selectInput(
        ns("arm_ref"),
        "Control",
        choices = get_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 = get_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("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, "reactive")
  checkmate::assert_class(shiny::isolate(data()), "teal_data")

  moduleServer(id, function(input, output, session) {
    teal.logger::log_shiny_input_changes(input, namespace = "teal.osprey")
    iv <- reactive({
      ANL <- data()[[dataname]]
      ADSL <- data()[["ADSL"]]

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

      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]]
      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]]
        ADSL <- data()[["ADSL"]]

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

        teal.code::eval_code(data(), code = group_labels_call) %>%
          teal.code::eval_code(code = "") %>%
          teal.code::eval_code(
            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 = "rcode",
      verbatim_content = reactive(teal.code::get_code(output_q())),
      title = paste("R code for", label),
    )

    ### REPORTER
    if (with_reporter) {
      card_fun <- function(comment, label) {
        card <- teal::report_card_template(
          title = "AE Subgroups",
          label = label,
          with_filter = with_filter,
          filter_panel_api = filter_panel_api
        )
        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(teal.code::get_code(output_q()))
        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
#' data <- teal_data() |>
#'   within({
#'     ADSL <- rADSL
#'     ADAE <- rADAE
#'     .add_event_flags <- function(dat) {
#'       dat <- dat |>
#'         mutate(
#'           TMPFL_SER = AESER == "Y",
#'           TMPFL_REL = AEREL == "Y",
#'           TMPFL_GR5 = AETOXGR == "5",
#'           AEREL1 = (AEREL == "Y" & ACTARM == "A: Drug X"),
#'           AEREL2 = (AEREL == "Y" & ACTARM == "B: Placebo")
#'         )
#'       labels <- c(
#'         "Serious AE", "Related AE", "Grade 5 AE",
#'         "AE related to A: Drug X", "AE related to B: Placebo"
#'       )
#'       cols <- c("TMPFL_SER", "TMPFL_REL", "TMPFL_GR5", "AEREL1", "AEREL2")
#'       for (i in seq_along(labels)) {
#'         attr(dat[[cols[i]]], "label") <- labels[i]
#'       }
#'       dat
#'     }
#'     ADAE <- .add_event_flags(ADAE)
#'   })
#'
#' join_keys(data) <- default_cdisc_join_keys[names(data)]
#'
#' ADAE <- data[["ADAE"]]
#'
#' app <- init(
#'   data = data,
#'   modules = modules(
#'     tm_g_ae_oview(
#'       label = "AE Overview",
#'       dataname = "ADAE",
#'       arm_var = choices_selected(
#'         selected = "ACTARM",
#'         choices = c("ACTARM", "ACTARMCD")
#'       ),
#'       flag_var_anl = choices_selected(
#'         selected = "AEREL1",
#'         choices = 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) {
  message("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 = tags$div(
      ### Reporter
      teal.reporter::simple_reporter_ui(ns("simple_reporter")),
      ###
      teal.widgets::optionalSelectInput(
        ns("arm_var"),
        "Arm Variable",
        choices = get_choices(args$arm_var$choices),
        selected = args$arm_var$selected,
        multiple = FALSE
      ),
      selectInput(
        ns("arm_ref"),
        "Control",
        choices = get_choices(args$arm_var$choices),
        selected = args$arm_var$selected
      ),
      selectInput(
        ns("arm_trt"),
        "Treatment",
        choices = get_choices(args$arm_var$choices),
        selected = args$arm_var$selected
      ),
      selectInput(
        ns("flag_var_anl"),
        "Flags",
        choices = get_choices(args$flag_var_anl$choices),
        selected = args$flag_var_anl$selected,
        multiple = TRUE
      ),
      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("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, "reactive")
  checkmate::assert_class(isolate(data()), "teal_data")

  moduleServer(id, function(input, output, session) {
    teal.logger::log_shiny_input_changes(input, namespace = "teal.osprey")
    iv <- reactive({
      ANL <- data()[[dataname]]

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

        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(
          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 = "rcode",
      verbatim_content = reactive(teal.code::get_code(output_q())),
      title = paste("R code for", label)
    )
    ### REPORTER
    if (with_reporter) {
      card_fun <- function(comment, label) {
        card <- teal::report_card_template(
          title = "AE Overview",
          label = label,
          with_filter = with_filter,
          filter_panel_api = filter_panel_api
        )
        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(teal.code::get_code(output_q()))
        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
#' data <- teal_data() |>
#'   within({
#'     ADSL <- rADSL
#'     ADTR <- rADTR
#'   })
#'
#' join_keys(data) <- default_cdisc_join_keys[names(data)]
#'
#' app <- init(
#'   data = data,
#'   modules = modules(
#'     tm_g_spiderplot(
#'       label = "Spider plot",
#'       dataname = "ADTR",
#'       paramcd = choices_selected(
#'         choices = "SLDINV",
#'         selected = "SLDINV"
#'       ),
#'       x_var = choices_selected(
#'         choices = "ADY",
#'         selected = "ADY"
#'       ),
#'       y_var = choices_selected(
#'         choices = c("PCHG", "CHG", "AVAL"),
#'         selected = "PCHG"
#'       ),
#'       marker_var = choices_selected(
#'         choices = c("SEX", "RACE", "USUBJID"),
#'         selected = "SEX"
#'       ),
#'       line_colorby_var = choices_selected(
#'         choices = c("SEX", "USUBJID", "RACE"),
#'         selected = "SEX"
#'       ),
#'       xfacet_var = choices_selected(
#'         choices = c("SEX", "ARM"),
#'         selected = "SEX"
#'       ),
#'       yfacet_var = 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) {
  message("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,
      paramcd = paramcd,
      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 = tags$div(
        ### Reporter
        teal.reporter::simple_reporter_ui(ns("simple_reporter")),
        ###
        tags$label("Encodings", class = "text-primary"),
        helpText("Analysis data:", tags$code(a$dataname)),
        tags$div(
          class = "pretty-left-border",
          teal.widgets::optionalSelectInput(
            ns("paramcd"),
            paste("Parameter - from", a$dataname),
            multiple = FALSE
          ),
          teal.widgets::optionalSelectInput(
            ns("x_var"),
            "X-axis Variable",
            get_choices(a$x_var$choices),
            a$x_var$selected,
            multiple = FALSE
          ),
          teal.widgets::optionalSelectInput(
            ns("y_var"),
            "Y-axis Variable",
            get_choices(a$y_var$choices),
            a$y_var$selected,
            multiple = FALSE
          ),
          teal.widgets::optionalSelectInput(
            ns("line_colorby_var"),
            "Color By Variable (Line)",
            get_choices(a$line_colorby_var$choices),
            a$line_colorby_var$selected,
            multiple = FALSE
          ),
          teal.widgets::optionalSelectInput(
            ns("marker_var"),
            "Marker Symbol By Variable",
            get_choices(a$marker_var$choices),
            a$marker_var$selected,
            multiple = FALSE
          ),
          teal.widgets::optionalSelectInput(
            ns("xfacet_var"),
            "X-facet By Variable",
            get_choices(a$xfacet_var$choices),
            a$xfacet_var$selected,
            multiple = TRUE
          ),
          teal.widgets::optionalSelectInput(
            ns("yfacet_var"),
            "Y-facet By Variable",
            get_choices(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 = tags$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 = tags$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("rcode"), "Show R code")
      ),
      pre_output = a$pre_output,
      post_output = a$post_output
    )
  )
}

srv_g_spider <- function(id, data, filter_panel_api, paramcd, 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, "reactive")
  checkmate::assert_class(shiny::isolate(data()), "teal_data")

  moduleServer(id, function(input, output, session) {
    teal.logger::log_shiny_input_changes(input, namespace = "teal.osprey")

    env <- as.list(isolate(data()))
    resolved_paramcd <- teal.transform::resolve_delayed(paramcd, env)

    teal.widgets::updateOptionalSelectInput(
      session = session,
      inputId = "paramcd",
      choices = resolved_paramcd$choices,
      selected = resolved_paramcd$selected
    )

    iv <- reactive({
      ADSL <- data()[["ADSL"]]
      ADTR <- data()[[dataname]]

      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)

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

      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
      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
      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))
      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(
        data(),
        code = bquote({
          ADSL <- ADSL[, .(adsl_vars)] %>% as.data.frame()
          ADTR <- .(as.name(dataname))[, .(adtr_vars)] %>% as.data.frame()

          ANL <- merge(ADSL, ADTR, by = c("USUBJID", "STUDYID"))
          ANL <- ANL %>%
            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))
          ANL_f <- ANL %>%
            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 = "rcode",
      title = paste("R code for", label),
      verbatim_content = reactive(teal.code::get_code(output_q()))
    )

    ### REPORTER
    if (with_reporter) {
      card_fun <- function(comment, label) {
        card <- teal::report_card_template(
          title = "Spider Plot",
          label = label,
          with_filter = with_filter,
          filter_panel_api = filter_panel_api
        )
        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(teal.code::get_code(output_q()))
        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 (`character`) subject level dataset name,
#' needs to be available in the list passed to the `data`
#' argument of [teal::init()]
#' @param ex_dataname (`character`) exposures dataset name,
#' needs to be available in the list passed to the `data`
#' argument of [teal::init()] \cr
#' @param ae_dataname (`character`) adverse events dataset name,
#' needs to be available in the list passed to the `data`
#' argument of [teal::init()] \cr
#' @param cm_dataname (`character`) concomitant medications dataset name,
#' needs to be available in the list passed to the `data`
#' argument of [teal::init()] \cr
#' specify to `NA` if no concomitant medications data is available
#' @param id_var (`choices_seleced`) unique subject ID variable
#' @param visit_var (`choices_seleced`) analysis visit variable
#' @param ongo_var (`choices_seleced`) study ongoing status variable.
#' This variable is a derived logical variable. Usually it can be derived from `EOSSTT`.
#' @param anno_var (`choices_seleced`) annotation variable
#' @param heat_var (`choices_seleced`) heatmap variable
#' @param conmed_var (`choices_seleced`) concomitant medications variable,
#' specify to `NA` if no concomitant medications data is available
#'
#' @inherit argument_convention return
#'
#' @export
#'
#' @examples
#' data <- teal_data() |>
#'   within({
#'     library(dplyr)
#'     ADSL <- rADSL %>% slice(1:30)
#'     ADEX <- rADEX %>% filter(USUBJID %in% ADSL$USUBJID)
#'     ADAE <- rADAE %>% filter(USUBJID %in% ADSL$USUBJID)
#'     ADCM <- 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"))
#'   })
#'
#' join_keys(data) <- default_cdisc_join_keys[names(data)]
#'
#' ADCM <- data[["ADCM"]]
#'
#' app <- init(
#'   data = data,
#'   modules = modules(
#'     tm_g_heat_bygrade(
#'       label = "Heatmap by grade",
#'       sl_dataname = "ADSL",
#'       ex_dataname = "ADEX",
#'       ae_dataname = "ADAE",
#'       cm_dataname = "ADCM",
#'       id_var = choices_selected(
#'         selected = "USUBJID",
#'         choices = c("USUBJID", "SUBJID")
#'       ),
#'       visit_var = choices_selected(
#'         selected = "AVISIT",
#'         choices = c("AVISIT")
#'       ),
#'       ongo_var = choices_selected(
#'         selected = "ongo_status",
#'         choices = c("ongo_status")
#'       ),
#'       anno_var = choices_selected(
#'         selected = c("SEX", "COUNTRY"),
#'         choices = c("SEX", "COUNTRY", "USUBJID")
#'       ),
#'       heat_var = choices_selected(
#'         selected = "AETOXGR",
#'         choices = c("AETOXGR")
#'       ),
#'       conmed_var = 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) {
  message("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 = tags$div(
        ### Reporter
        teal.reporter::simple_reporter_ui(ns("simple_reporter")),
        ###
        teal.widgets::optionalSelectInput(
          ns("id_var"),
          "ID Variable",
          choices = get_choices(args$id_var$choices),
          selected = args$id_var$selected,
          multiple = FALSE
        ),
        teal.widgets::optionalSelectInput(
          ns("visit_var"),
          "Visit Variable",
          choices = get_choices(args$visit_var$choices),
          selected = args$visit_var$selected,
          multiple = FALSE
        ),
        teal.widgets::optionalSelectInput(
          ns("ongo_var"),
          "Study Ongoing Status Variable",
          choices = get_choices(args$ongo_var$choices),
          selected = args$ongo_var$selected,
          multiple = FALSE
        ),
        teal.widgets::optionalSelectInput(
          ns("anno_var"),
          "Annotation Variables",
          choices = get_choices(args$anno_var$choices),
          selected = args$anno_var$selected,
          multiple = TRUE
        ),
        teal.widgets::optionalSelectInput(
          ns("heat_var"),
          "Heat Variable",
          choices = get_choices(args$heat_var$choices),
          selected = args$heat_var$selected,
          multiple = FALSE
        ),
        helpText("Plot conmed"),
        tags$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 = get_choices(args$conmed_var$choices),
            selected = args$conmed_var$selected,
            multiple = FALSE
          ),
          selectInput(
            ns("conmed_level"),
            "Conmed Levels",
            choices = get_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("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, "reactive")
  checkmate::assert_class(shiny::isolate(data()), "teal_data")
  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) {
    teal.logger::log_shiny_input_changes(input, namespace = "teal.osprey")
    iv <- reactive({
      ADSL <- data()[[sl_dataname]]
      ADEX <- data()[[ex_dataname]]
      ADAE <- data()[[ae_dataname]]
      if (isTRUE(input$plot_cm)) {
        ADCM <- data()[[cm_dataname]]
      }

      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]]
      ADEX <- data()[[ex_dataname]]
      ADAE <- data()[[ae_dataname]]
      if (isTRUE(input$plot_cm)) {
        ADCM <- data()[[cm_dataname]]
      }

      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
    )
    font_size <- decorate_output$font_size
    pws <- decorate_output$pws

    if (!is.na(cm_dataname)) {
      observeEvent(input$conmed_var, {
        ADCM <- data()[[cm_dataname]]
        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]]
        ADEX <- data()[[ex_dataname]]
        ADAE <- data()[[ae_dataname]]
        ADCM <- data()[[cm_dataname]]

        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 <- data()

        if (isTRUE(input$plot_cm)) {
          ADCM <- qenv[[cm_dataname]]
          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 = "rcode",
      title = paste("R code for", label),
      verbatim_content = reactive(teal.code::get_code(output_q()))
    )

    ### REPORTER
    if (with_reporter) {
      card_fun <- function(comment, label) {
        card <- teal::report_card_template(
          title = "Heatmap by Grade",
          label = label,
          with_filter = with_filter,
          filter_panel_api = filter_panel_api
        )
        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(teal.code::get_code(output_q()))
        card
      }
      teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
    }
  })
}

#' Shared Parameters
#'
#' @description Contains arguments that are shared between multiple functions
#'   in the package to avoid repetition using `inheritParams`.
#'
#' @param plot_height (`numeric`) optional vector of length three with `c(value, min, max)`. Specifies
#'   the height of the main plot.
#' @param plot_width (`numeric`) optional vector of length three with `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 (`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) {
  for (i in seq_along(filter_opt)) {
    ANL <- ANL[ANL[, filter_opt[i]] == "Y", ]
  }
  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))))
}

#' Get Choices
#'
#' This function returns choices based on the class of the input.
#' If the input is of class `delayed_data`, it returns the `subset` of the input.
#' If `subset` is NULL and the input contains `var_label` and `var_choices`,
#' it throws an error prompting to resolve delayed inputs.
#' Otherwise, it returns the input as is.
#'
#' @param choices An object that contains choices.
#' @return A vector of choices.
#' @keywords internal
get_choices <- function(choices) {
  if (inherits(choices, "delayed_data")) {
    if (is.null(choices$subset)) {
      if (!is.null(choices$var_label) && !is.null(choices$var_choices)) {
        stop(
          "Resolve delayed inputs by evaluating the code within the provided datasets.
          Check ?teal.transform::resolve_delayed for more information."
        )
      } else {
        stop("Subset is NULL and necessary fields are missing.")
      }
    } else {
      choices$subset
    }
  } else {
    choices
  }
}

#' Helper UI function to decorate plot output UI
#'
#' @description
#' `r lifecycle::badge("stable")`
#'
#' This is used in [tm_g_ae_oview()] and [tm_g_events_term_id()].
#'
#' @param id (`character`) id of this module. set to `NULL` if you want to make it identical
#' to the module who called it.
#' @param titles (`character`) default titles
#' @param footnotes (`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 [tm_g_ae_oview()] and [tm_g_events_term_id()].
#'
#' @inheritParams shared_params
#' @param id (`character`) id of the module
#' @param plot_id (`character`) id for plot output
#' @param plt (`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) {
    teal.logger::log_shiny_input_changes(input, namespace = "teal.osprey")
    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 (`character`) id of this element
#'
#' @export
plot_decorate_output <- function(id) {
  ns <- NS(id)
  teal.widgets::plot_with_settings_ui(id = ns("out"))
}

1		.onLoad <- function(libname, pkgname) {
2		# Fixes R CMD check note on "All declared Imports should be used."
3		# teal.data is necessary to access S3 method names.teal_data
4	!	teal.data::teal_data
5
6	!	teal.logger::register_logger(namespace = "teal.osprey")
7	!	teal.logger::register_handlers("teal.osprey")
8		}

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 [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		#' data <- teal_data() \|>
22		#' within({
23		#' ADSL <- rADSL
24		#' ADAE <- rADAE
25		#' })
26		#'
27		#' join_keys(data) <- default_cdisc_join_keys[names(data)]
28		#'
29		#' app <- init(
30		#' data = data,
31		#' modules = modules(
32		#' tm_g_events_term_id(
33		#' label = "Common AE",
34		#' dataname = "ADAE",
35		#' term_var = choices_selected(
36		#' selected = "AEDECOD",
37		#' choices = c(
38		#' "AEDECOD", "AETERM",
39		#' "AEHLT", "AELLT", "AEBODSYS"
40		#' )
41		#' ),
42		#' arm_var = choices_selected(
43		#' selected = "ACTARMCD",
44		#' choices = c("ACTARM", "ACTARMCD")
45		#' ),
46		#' plot_height = c(600, 200, 2000)
47		#' )
48		#' )
49		#' )
50		#' if (interactive()) {
51		#' shinyApp(app$ui, app$server)
52		#' }
53		#'
54		tm_g_events_term_id <- function(label,
55		dataname,
56		term_var,
57		arm_var,
58		fontsize = c(5, 3, 7),
59		plot_height = c(600L, 200L, 2000L),
60		plot_width = NULL) {
61	!	message("Initializing tm_g_events_term_id")
62	!	checkmate::assert_string(label)
63	!	checkmate::assert_class(term_var, classes = "choices_selected")
64	!	checkmate::assert_class(arm_var, classes = "choices_selected")
65	!	checkmate::assert(
66	!	checkmate::check_number(fontsize, finite = TRUE),
67	!	checkmate::assert(
68	!	combine = "and",
69	!	.var.name = "fontsize",
70	!	checkmate::check_numeric(fontsize, len = 3, any.missing = FALSE, finite = TRUE),
71	!	checkmate::check_numeric(fontsize[1], lower = fontsize[2], upper = fontsize[3])
72		)
73		)
74	!	checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
75	!	checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")
76	!	checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
77	!	checkmate::assert_numeric(
78	!	plot_width[1],
79	!	lower = plot_width[2],
80	!	upper = plot_width[3],
81	!	null.ok = TRUE,
82	!	.var.name = "plot_width"
83		)
84
85	!	args <- as.list(environment())
86
87	!	module(
88	!	label = label,
89	!	server = srv_g_events_term_id,
90	!	server_args = list(label = label, dataname = dataname, plot_height = plot_height, plot_width = plot_width),
91	!	ui = ui_g_events_term_id,
92	!	ui_args = args,
93	!	datanames = c("ADSL", dataname)
94		)
95		}
96
97		ui_g_events_term_id <- function(id, ...) {
98	!	ns <- NS(id)
99	!	args <- list(...)
100	!	teal.widgets::standard_layout(
101	!	output = teal.widgets::white_small_well(
102	!	plot_decorate_output(id = ns(NULL))
103		),
104	!	encoding = tags$div(
105		### Reporter
106	!	teal.reporter::simple_reporter_ui(ns("simple_reporter")),
107		###
108	!	teal.widgets::optionalSelectInput(
109	!	ns("term"),
110	!	"Term Variable",
111	!	choices = get_choices(args$term_var$choices),
112	!	selected = args$term_var$selected
113		),
114	!	teal.widgets::optionalSelectInput(
115	!	ns("arm_var"),
116	!	"Arm Variable",
117	!	choices = get_choices(args$arm_var$choices),
118	!	selected = args$arm_var$selected
119		),
120	!	selectInput(
121	!	ns("arm_ref"),
122	!	"Control",
123	!	choices = get_choices(args$arm_var$choices),
124	!	selected = args$arm_var$selected
125		),
126	!	selectInput(
127	!	ns("arm_trt"),
128	!	"Treatment",
129	!	choices = get_choices(args$arm_var$choices),
130	!	selected = args$arm_var$selected
131		),
132	!	teal.widgets::optionalSelectInput(
133	!	ns("sort"),
134	!	"Sort By",
135	!	choices = c(
136	!	"Term" = "term",
137	!	"Risk Difference" = "riskdiff",
138	!	"Mean Risk" = "meanrisk"
139		),
140	!	selected = NULL
141		),
142	!	teal.widgets::panel_item(
143	!	"Confidence interval settings",
144	!	teal.widgets::optionalSelectInput(
145	!	ns("diff_ci_method"),
146	!	"Method for Difference of Proportions CI",
147	!	choices = ci_choices,
148	!	selected = ci_choices[1]
149		),
150	!	teal.widgets::optionalSliderInput(
151	!	ns("conf_level"),
152	!	"Confidence Level",
153	!	min = 0.5,
154	!	max = 1,
155	!	value = 0.95
156		)
157		),
158	!	teal.widgets::panel_item(
159	!	"Additional plot settings",
160	!	teal.widgets::optionalSelectInput(
161	!	ns("axis"),
162	!	"Axis Side",
163	!	choices = c("Left" = "left", "Right" = "right"),
164	!	selected = "left"
165		),
166	!	sliderInput(
167	!	ns("raterange"),
168	!	"Overall Rate Range",
169	!	min = 0,
170	!	max = 1,
171	!	value = c(0.1, 1),
172	!	step = 0.01
173		),
174	!	sliderInput(
175	!	ns("diffrange"),
176	!	"Rate Difference Range",
177	!	min = -1,
178	!	max = 1,
179	!	value = c(-0.5, 0.5),
180	!	step = 0.01
181		),
182	!	checkboxInput(ns("reverse"),
183	!	"Reverse Order",
184	!	value = FALSE
185		)
186		),
187	!	ui_g_decorate(
188	!	ns(NULL),
189	!	fontsize = args$fontsize,
190	!	titles = "Common AE Table",
191	!	footnotes = ""
192		)
193		),
194	!	forms = tagList(
195	!	teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
196		)
197		)
198		}
199
200		srv_g_events_term_id <- function(id,
201		data,
202		filter_panel_api,
203		reporter,
204		dataname,
205		label,
206		plot_height,
207		plot_width) {
208	!	with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
209	!	with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
210	!	checkmate::assert_class(data, "reactive")
211	!	checkmate::assert_class(shiny::isolate(data()), "teal_data")
212
213	!	moduleServer(id, function(input, output, session) {
214	!	teal.logger::log_shiny_input_changes(input, namespace = "teal.osprey")
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]]
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]]
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))
317	!	anl_vars <- c("USUBJID", "STUDYID", input$term)
318
319	!	q1 <- teal.code::eval_code(
320	!	data(),
321	!	code = bquote(
322	!	ANL <- merge(
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 = "rcode",
367	!	title = paste("R code for", label),
368	!	verbatim_content = reactive(teal.code::get_code(output_q()))
369		)
370
371		### REPORTER
372	!	if (with_reporter) {
373	!	card_fun <- function(comment, label) {
374	!	card <- teal::report_card_template(
375	!	title = "Events by Term",
376	!	label = label,
377	!	with_filter = with_filter,
378	!	filter_panel_api = filter_panel_api
379		)
380	!	card$append_text("Plot", "header3")
381	!	card$append_plot(plot_r(), dim = pws$dim())
382	!	if (!comment == "") {
383	!	card$append_text("Comment", "header3")
384	!	card$append_text(comment)
385		}
386	!	card$append_src(teal.code::get_code(output_q()))
387	!	card
388		}
389	!	teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
390		}
391		})
392		}

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

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

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

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

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

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

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

1		#' Shared Parameters
2		#'
3		#' @description Contains arguments that are shared between multiple functions
4		#' in the package to avoid repetition using `inheritParams`.
5		#'
6		#' @param plot_height (`numeric`) optional vector of length three with `c(value, min, max)`. Specifies
7		#' the height of the main plot.
8		#' @param plot_width (`numeric`) optional vector of length three with `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 (`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) {
32	!	for (i in seq_along(filter_opt)) {
33	!	ANL <- ANL[ANL[, filter_opt[i]] == "Y", ]
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		}
133
134		#' Get Choices
135		#'
136		#' This function returns choices based on the class of the input.
137		#' If the input is of class `delayed_data`, it returns the `subset` of the input.
138		#' If `subset` is NULL and the input contains `var_label` and `var_choices`,
139		#' it throws an error prompting to resolve delayed inputs.
140		#' Otherwise, it returns the input as is.
141		#'
142		#' @param choices An object that contains choices.
143		#' @return A vector of choices.
144		#' @keywords internal
145		get_choices <- function(choices) {
146	!	if (inherits(choices, "delayed_data")) {
147	!	if (is.null(choices$subset)) {
148	!	if (!is.null(choices$var_label) && !is.null(choices$var_choices)) {
149	!	stop(
150	!	"Resolve delayed inputs by evaluating the code within the provided datasets.
151	!	Check ?teal.transform::resolve_delayed for more information."
152		)
153		} else {
154	!	stop("Subset is NULL and necessary fields are missing.")
155		}
156		} else {
157	!	choices$subset
158		}
159		} else {
160	!	choices
161		}
162		}

1		#' Helper UI function to decorate plot output UI
2		#'
3		#' @description
4		#' `r lifecycle::badge("stable")`
5		#'
6		#' This is used in [tm_g_ae_oview()] and [tm_g_events_term_id()].
7		#'
8		#' @param id (`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 (`character`) default titles
11		#' @param footnotes (`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 [tm_g_ae_oview()] and [tm_g_events_term_id()].
37		#'
38		#' @inheritParams shared_params
39		#' @param id (`character`) id of the module
40		#' @param plot_id (`character`) id for plot output
41		#' @param plt (`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	!	teal.logger::log_shiny_input_changes(input, namespace = "teal.osprey")
51	!	plot_g <- reactive({
52	!	g <- tern::decorate_grob(
53	!	plt(),
54	!	titles = input$title,
55	!	footnotes = input$foot,
56	!	gp_titles = grid::gpar(
57	!	fontsize = input$fontsize * ggplot2::.pt,
58	!	col = "black",
59	!	fontface = "bold"
60		),
61	!	gp_footnotes = grid::gpar(fontsize = input$fontsize * ggplot2::.pt, col = "black")
62		)
63		})
64
65	!	plot_r <- function() {
66	!	grid::grid.newpage()
67	!	grid::grid.draw(plot_g())
68	!	plot_g()
69		}
70
71	!	class(plot_r) <- c(class(plot_r), "reactive")
72
73	!	pws <- teal.widgets::plot_with_settings_srv(
74	!	id = plot_id,
75	!	plot_r = plot_r,
76	!	height = plot_height,
77	!	width = plot_width
78		)
79
80	!	return(
81	!	list(
82	!	font_size = reactive(input$fontsize),
83	!	pws = pws
84		)
85		)
86		})
87		}
88
89		#' Helper function to plot decorated output UI
90		#'
91		#' @description
92		#' `r lifecycle::badge("stable")`
93		#'
94		#' @param id (`character`) id of this element
95		#'
96		#' @export
97		plot_decorate_output <- function(id) {
98	!	ns <- NS(id)
99	!	teal.widgets::plot_with_settings_ui(id = ns("out"))
100		}