teal.osprey coverage - 0.14%

Files
Source

#' 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"))
#'   })
#'
#' datanames(data) <- c("ADSL", "ADEX", "ADAE", "ADCM")
#' join_keys(data) <- default_cdisc_join_keys[datanames(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)
    }
  })
}

#' 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
#'   })
#'
#' datanames(data) <- c("ADSL", "ADAE")
#' join_keys(data) <- default_cdisc_join_keys[datanames(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)
    }
  })
}

#' 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))
#'   })
#'
#' datanames(data) <- c("ADSL", "ADAE", "ADCM", "ADRS", "ADEX", "ADLB")
#' join_keys(data) <- default_cdisc_join_keys[datanames(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())@env))

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

#' 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))
#'   })
#'
#' datanames(data) <- c("ADSL", "ADTR", "ADRS")
#' join_keys(data) <- default_cdisc_join_keys[datanames(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())@env)
    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)
    }
  })
}

#' 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
#'   })
#'
#' datanames(data) <- c("ADSL", "ADTR")
#' join_keys(data) <- default_cdisc_join_keys[datanames(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())@env)
    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 `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)
#'   })
#'
#' datanames(data) <- c("ADSL", "ADAE")
#' join_keys(data) <- default_cdisc_join_keys[datanames(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)
    }
  })
}

#' 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())
#'     )
#'   })
#'
#' datanames(data) <- c("ADSL", "ADAE")
#' join_keys(data) <- default_cdisc_join_keys[datanames(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)
#'   })
#'
#' datanames(data) <- c("ADSL", "ADRS")
#' join_keys(data) <- default_cdisc_join_keys[datanames(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% teal.data::datanames(data()), "'ADSL' not included in data"))
      validate(need(
        (length(teal.data::datanames(data())) == 1 && dataname == "ADSL") ||
          (length(teal.data::datanames(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)
    }
  })
}

#' 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"))
}

#' 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
#'   })
#'
#' datanames(data) <- c("ADSL", "ADAE")
#' join_keys(data) <- default_cdisc_join_keys[datanames(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)
    }
  })
}

#' 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
  }
}

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

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

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

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

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

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

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

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		}

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

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		.onLoad <- function(libname, pkgname) {
2	!	teal.logger::register_logger(namespace = "teal.osprey")
3	!	teal.logger::register_handlers("teal.osprey")
4		}