teal.osprey coverage - 0.15%

Files
Source

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

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


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

  shiny::tagList(
    teal.widgets::standard_layout(
      output = teal.widgets::white_small_well(
        teal.widgets::plot_with_settings_ui(id = ns("swimlaneplot"))
      ),
      encoding = tags$div(
        tags$label("Encodings", class = "text-primary"),
        helpText("Analysis data:", tags$code(a$dataname)),
        left_bordered_div(
          teal.widgets::optionalSelectInput(
            ns("bar_var"),
            "Bar Length",
            choices = get_choices(a$bar_var$choices),
            selected = a$bar_var$selected,
            multiple = FALSE,
            label_help = helpText("from ", tags$code("ADSL"))
          ),
          teal.widgets::optionalSelectInput(
            ns("bar_color_var"),
            "Bar Color",
            choices = get_choices(a$bar_color_var$choices),
            selected = a$bar_color_var$selected,
            multiple = FALSE,
            label_help = helpText("from ", tags$code("ADSL"))
          )
        ),
        teal.widgets::optionalSelectInput(
          ns("sort_var"),
          "Sort by",
          choices = get_choices(a$sort_var$choices),
          selected = a$sort_var$selected,
          multiple = FALSE,
          label_help = helpText("from ", tags$code("ADSL"))
        ),
        left_bordered_div(
          if (a$dataname == "ADSL") {
            NULL
          } else if (is.null(a$marker_pos_var)) {
            NULL
          } else {
            teal.widgets::optionalSelectInput(
              ns("marker_pos_var"),
              "Marker Position",
              choices = get_choices(a$marker_pos_var$choices),
              selected = a$marker_pos_var$selected,
              multiple = FALSE,
              label_help = helpText("from ", tags$code(a$dataname))
            )
          },
          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 = ", ")
        )
      ),
      pre_output = a$pre_output,
      post_output = a$post_output
    )
  )
}

srv_g_swimlane <- function(id,
                           data,
                           dataname,
                           marker_pos_var,
                           marker_shape_var,
                           marker_shape_opt,
                           marker_color_var,
                           marker_color_opt,
                           label,
                           plot_height,
                           plot_width,
                           x_label) {
  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({
      obj <- data()
      teal.reporter::teal_card(obj) <-
        c(
          teal.reporter::teal_card(obj),
          teal.reporter::teal_card("## Module's output(s)")
        )

      teal::validate_inputs(iv())

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

      ADSL <- obj[["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 <- obj[[dataname]]
        teal::validate_has_data(anl, min_nrow = 3)
        teal::validate_has_variable(anl, anl_vars)

        validate(need(
          !any(c(marker_pos_var, marker_shape_var, marker_color_var) %in% adsl_vars),
          "marker-related variables need to come from marker data"
        ))
      }

      # VARIABLE GETTERS
      # lookup bar variables
      bar_var <- input$bar_var
      bar_color_var <- input$bar_color_var
      sort_var <- input$sort_var
      anno_txt_var <- input$anno_txt_var

      # Check if marker inputs can be used
      if (dataname == "ADSL") {
        marker_pos_var <- NULL
        marker_shape_var <- NULL
        marker_color_var <- NULL
      } else {
        marker_pos_var <- input$marker_pos_var
        marker_shape_var <- input$marker_shape_var
        marker_color_var <- input$marker_color_var
      }
      vref_line <- suppressWarnings(as_numeric_from_comma_sep_str(debounce(reactive(input$vref_line), 1500)()))

      q1 <- obj

      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 = ggplot2::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 = ggplot2::waiver(),
            xlab = .(x_label),
            title = "Swimlane Plot"
          )
        )
      }

      teal.reporter::teal_card(q3) <- c(teal.reporter::teal_card(q3), "### Plot")

      if (!is.null(input$sort_var)) {
        teal.reporter::teal_card(q3) <- c(teal.reporter::teal_card(q3), "### Selected Options")
        teal.reporter::teal_card(q3) <- c(teal.reporter::teal_card(q3), paste("Sorted by:", input$sort_var))
      }

      teal.code::eval_code(q3, code = plot_call)
    })

    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
    )

    set_chunk_dims(pws, output_q)
  })
}

#' teal module for the `AE` by subgroups
#'
#' @description
#'
#' Display the `AE` by subgroups plot as a teal module
#'
#' @inheritParams teal.widgets::standard_layout
#' @inheritParams teal::module
#' @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
#' @inheritSection teal::example_module Reporting
#'
#' @export
#'
#' @examples
#' # Example using stream (ADaM) dataset
#' data <- teal_data() |>
#'   within({
#'     ADSL <- rADSL
#'     ADAE <- rADAE
#'   })
#'
#' join_keys(data) <- default_cdisc_join_keys[names(data)]
#'
#' app <- init(
#'   data = data,
#'   modules = modules(
#'     tm_g_ae_sub(
#'       label = "AE by Subgroup",
#'       dataname = "ADAE",
#'       arm_var = choices_selected(
#'         selected = "ACTARMCD",
#'         choices = c("ACTARM", "ACTARMCD")
#'       ),
#'       group_var = choices_selected(
#'         selected = c("SEX", "REGION1", "RACE"),
#'         choices = c("SEX", "REGION1", "RACE")
#'       ),
#'       plot_height = c(600, 200, 2000)
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
tm_g_ae_sub <- function(label,
                        dataname,
                        arm_var,
                        group_var,
                        plot_height = c(600L, 200L, 2000L),
                        plot_width = NULL,
                        fontsize = c(5, 3, 7),
                        transformators = list()) {
  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
    ),
    transformators = transformators,
    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(
      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 = ""
        )
      )
    )
  )
}

srv_g_ae_sub <- function(id,
                         data,
                         dataname,
                         label,
                         plot_height,
                         plot_width) {
  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({
        obj <- data()
        teal.reporter::teal_card(obj) <-
          c(
            teal.reporter::teal_card(obj),
            teal.reporter::teal_card("## Module's output(s)")
          )

        ANL <- obj[[dataname]]
        ADSL <- obj[["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)))
        }

        q1 <- teal.code::eval_code(obj, code = group_labels_call) %>%
          teal.code::eval_code(code = "")

        teal.reporter::teal_card(q1) <- c(teal.reporter::teal_card(q1), "### Plot")

        teal.code::eval_code(
          q1,
          code = as.expression(c(
            bquote(
              plot <- osprey::g_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
              )
            )
          ))
        )
      })
    )

    plot_r <- reactive(output_q()[["plot"]])
    set_chunk_dims(pws, output_q)
  })
}

#' Events by Term Plot Teal Module
#'
#' @description
#'
#' Display Events by Term plot as a shiny module
#'
#' @inheritParams teal.widgets::standard_layout
#' @inheritParams teal::module
#' @inheritParams argument_convention
#' @param term_var [teal.transform::choices_selected] object with all available choices
#' and pre-selected option names that can be used to specify the term for events
#'
#' @inherit argument_convention return
#' @inheritSection teal::example_module Reporting
#'
#' @export
#'
#' @author Liming Li (lil128) \email{liming.li@roche.com}
#' @author Molly He (hey59) \email{hey59@gene.com}
#'
#' @examples
#' data <- teal_data() |>
#'   within({
#'     ADSL <- rADSL
#'     ADAE <- rADAE
#'   })
#'
#' join_keys(data) <- default_cdisc_join_keys[names(data)]
#'
#' app <- init(
#'   data = data,
#'   modules = modules(
#'     tm_g_events_term_id(
#'       label = "Common AE",
#'       dataname = "ADAE",
#'       term_var = choices_selected(
#'         selected = "AEDECOD",
#'         choices = c(
#'           "AEDECOD", "AETERM",
#'           "AEHLT", "AELLT", "AEBODSYS"
#'         )
#'       ),
#'       arm_var = choices_selected(
#'         selected = "ACTARMCD",
#'         choices = c("ACTARM", "ACTARMCD")
#'       ),
#'       plot_height = c(600, 200, 2000)
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
tm_g_events_term_id <- function(label,
                                dataname,
                                term_var,
                                arm_var,
                                fontsize = c(5, 3, 7),
                                plot_height = c(600L, 200L, 2000L),
                                plot_width = NULL,
                                transformators = list()) {
  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,
    transformators = transformators,
    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(
      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 = ""
      )
    )
  )
}

srv_g_events_term_id <- function(id,
                                 data,
                                 dataname,
                                 label,
                                 plot_height,
                                 plot_width) {
  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({
      obj <- data()
      teal.reporter::teal_card(obj) <-
        c(
          teal.reporter::teal_card(obj),
          teal.reporter::teal_card("## Module's output(s)")
        )

      ANL <- obj[[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(
        obj,
        code = bquote(
          ANL <- merge(
            x = ADSL[, .(adsl_vars), drop = FALSE],
            y = .(as.name(dataname))[, .(anl_vars), drop = FALSE],
            all.x = FALSE,
            all.y = FALSE,
            by = c("USUBJID", "STUDYID")
          )
        )
      )

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

      teal.reporter::teal_card(q1) <- c(teal.reporter::teal_card(q1), "### Plot")

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

    plot_r <- reactive(output_q()[["plot"]])
    set_chunk_dims(pws, output_q)
  })
}

#' Butterfly plot Teal Module
#'
#' @description
#'
#' Display butterfly plot as a shiny module
#'
#' @inheritParams teal.widgets::standard_layout
#' @inheritParams teal::module
#' @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
#' @inheritSection teal::example_module Reporting
#'
#' @export
#'
#' @template author_zhanc107
#' @template author_liaoc10
#'
#' @examples
#' # Example using stream (ADaM) dataset
#' data <- teal_data() |>
#'   eval_code("set.seed(23) # @linksto ADSL") |>
#'   within({
#'     library(nestcolor)
#'     library(dplyr)
#'     ADSL <- rADSL
#'     ADAE <- rADAE
#'     ADSL <- mutate(ADSL, DOSE = paste(sample(1:3, n(), replace = TRUE), "UG"))
#'     ADAE <- mutate(
#'       ADAE,
#'       flag1 = ifelse(AETOXGR == 1, 1, 0),
#'       flag2 = ifelse(AETOXGR == 2, 1, 0),
#'       flag3 = ifelse(AETOXGR == 3, 1, 0),
#'       flag1_filt = rep("Y", n())
#'     )
#'   })
#'
#' join_keys(data) <- default_cdisc_join_keys[names(data)]
#'
#' app <- init(
#'   data = data,
#'   modules = modules(
#'     tm_g_butterfly(
#'       label = "Butterfly Plot",
#'       dataname = "ADAE",
#'       right_var = choices_selected(
#'         selected = "SEX",
#'         choices = c("SEX", "ARM", "RACE")
#'       ),
#'       left_var = choices_selected(
#'         selected = "RACE",
#'         choices = c("SEX", "ARM", "RACE")
#'       ),
#'       category_var = choices_selected(
#'         selected = "AEBODSYS",
#'         choices = c("AEDECOD", "AEBODSYS")
#'       ),
#'       color_by_var = choices_selected(
#'         selected = "AETOXGR",
#'         choices = c("AETOXGR", "None")
#'       ),
#'       count_by_var = choices_selected(
#'         selected = "# of patients",
#'         choices = c("# of patients", "# of AEs")
#'       ),
#'       facet_var = choices_selected(
#'         selected = NULL,
#'         choices = c("RACE", "SEX", "ARM")
#'       ),
#'       sort_by_var = choices_selected(
#'         selected = "count",
#'         choices = c("count", "alphabetical")
#'       ),
#'       legend_on = TRUE,
#'       plot_height = c(600, 200, 2000)
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
tm_g_butterfly <- function(label,
                           dataname,
                           filter_var = NULL,
                           right_var,
                           left_var,
                           category_var,
                           color_by_var,
                           count_by_var,
                           facet_var = NULL,
                           sort_by_var = teal.transform::choices_selected(
                             selected = "count", choices = c("count", "alphabetical")
                           ),
                           legend_on = TRUE,
                           plot_height = c(600L, 200L, 2000L),
                           plot_width = NULL,
                           pre_output = NULL,
                           post_output = NULL,
                           transformators = list()) {
  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,
    transformators = transformators
  )
}

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(
      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
      )
    ),
    pre_output = a$pre_output,
    post_output = a$post_output
  )
}

srv_g_butterfly <- function(id, data, dataname, label, plot_height, plot_width) {
  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({
        obj <- data()
        teal.reporter::teal_card(obj) <-
          c(
            teal.reporter::teal_card(obj),
            teal.reporter::teal_card("## Module's output(s)")
          )
        obj <- teal.code::eval_code(obj, "library(dplyr)")

        ADSL <- obj[["ADSL"]]
        ANL <- obj[[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(
          obj,
          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 = " - ")
            })
          )
        }

        teal.reporter::teal_card(q1) <- c(teal.reporter::teal_card(q1), "### Plot")

        if (!is.null(input$filter_var) || !is.null(input$facet_var) || !is.null(input$sort_by_var)) {
          teal.reporter::teal_card(q1) <- c(teal.reporter::teal_card(q1), "### Selected Options")
        }
        if (!is.null(input$filter_var)) {
          teal.reporter::teal_card(q1) <- c(
            teal.reporter::teal_card(q1),
            sprintf("Preset Data Filters: %s.", paste(input$filter_var, collapse = ", "))
          )
        }
        if (!is.null(input$facet_var)) {
          teal.reporter::teal_card(q1) <- c(
            teal.reporter::teal_card(q1),
            sprintf("Faceted by: %s.", paste(input$facet_var, collapse = ", "))
          )
        }
        if (!is.null(input$sort_by_var)) {
          teal.reporter::teal_card(q1) <- c(
            teal.reporter::teal_card(q1),
            sprintf("Sorted by: %s.", paste(input$sort_by_var, 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)
              )
            )
          )
        }

        q1
      })
    )

    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
    )

    set_chunk_dims(pws, output_q)
  })
}

#' Spider plot Teal Module
#'
#' @description
#'
#' Display spider plot as a shiny module
#'
#' @inheritParams teal.widgets::standard_layout
#' @inheritParams teal::module
#' @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
#' @inheritSection teal::example_module Reporting
#' @export
#'
#' @template author_zhanc107
#' @template author_liaoc10
#'
#' @examples
#' # Example using stream (ADaM) dataset
#' data <- teal_data() |>
#'   within({
#'     library(nestcolor)
#'     ADSL <- rADSL
#'     ADTR <- rADTR
#'   })
#'
#' join_keys(data) <- default_cdisc_join_keys[names(data)]
#'
#' app <- init(
#'   data = data,
#'   modules = modules(
#'     tm_g_spiderplot(
#'       label = "Spider plot",
#'       dataname = "ADTR",
#'       paramcd = choices_selected(
#'         choices = "SLDINV",
#'         selected = "SLDINV"
#'       ),
#'       x_var = choices_selected(
#'         choices = "ADY",
#'         selected = "ADY"
#'       ),
#'       y_var = choices_selected(
#'         choices = c("PCHG", "CHG", "AVAL"),
#'         selected = "PCHG"
#'       ),
#'       marker_var = choices_selected(
#'         choices = c("SEX", "RACE", "USUBJID"),
#'         selected = "SEX"
#'       ),
#'       line_colorby_var = choices_selected(
#'         choices = c("SEX", "USUBJID", "RACE"),
#'         selected = "SEX"
#'       ),
#'       xfacet_var = choices_selected(
#'         choices = c("SEX", "ARM"),
#'         selected = "SEX"
#'       ),
#'       yfacet_var = choices_selected(
#'         choices = c("SEX", "ARM"),
#'         selected = "ARM"
#'       ),
#'       vref_line = "10, 37",
#'       href_line = "-20, 0"
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
tm_g_spiderplot <- function(label,
                            dataname,
                            paramcd,
                            x_var,
                            y_var,
                            marker_var,
                            line_colorby_var,
                            xfacet_var = NULL,
                            yfacet_var = NULL,
                            vref_line = NULL,
                            href_line = NULL,
                            anno_txt_var = TRUE,
                            legend_on = FALSE,
                            plot_height = c(600L, 200L, 2000L),
                            plot_width = NULL,
                            pre_output = NULL,
                            post_output = NULL,
                            transformators = list()) {
  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,
    transformators = transformators
  )
}

ui_g_spider <- function(id, ...) {
  ns <- NS(id)
  a <- list(...)
  shiny::tagList(
    teal.widgets::standard_layout(
      output = teal.widgets::white_small_well(
        teal.widgets::plot_with_settings_ui(id = ns("spiderplot"))
      ),
      encoding = tags$div(
        tags$label("Encodings", class = "text-primary"),
        helpText("Analysis data:", tags$code(a$dataname)),
        left_bordered_div(
          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)",
            bslib::tooltip(
              trigger = icon("circle-info"),
              tags$span(
                "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)",
            bslib::tooltip(
              trigger = icon("circle-info"),
              tags$span(
                "Enter numeric value(s) of horizontal reference lines, separated by comma (eg. -2, 1)"
              )
            )
          ),
          value = a$href_line
        )
      ),
      pre_output = a$pre_output,
      post_output = a$post_output
    )
  )
}

srv_g_spider <- function(id, data, dataname, paramcd, label, plot_height, plot_width) {
  checkmate::assert_class(data, "reactive")
  checkmate::assert_class(shiny::isolate(data()), "teal_data")

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

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

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

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

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

    vals <- reactiveValues(spiderplot = NULL)

    # render plot
    output_q <- reactive({
      obj <- data()
      teal.reporter::teal_card(obj) <-
        c(
          teal.reporter::teal_card(obj),
          teal.reporter::teal_card("## Module's output(s)")
        )
      obj <- teal.code::eval_code(obj, "library(dplyr)")

      # get datasets ---
      ADSL <- obj[["ADSL"]]
      ADTR <- obj[[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(
        obj,
        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 ---

      teal.reporter::teal_card(q1) <- c(teal.reporter::teal_card(q1), "### Plot")
      if (!is.null(input$paramcd) || !is.null(input$xfacet_var) || !is.null(input$yfacet_var)) {
        teal.reporter::teal_card(q1) <- c(teal.reporter::teal_card(q1), "### Selected Options")
      }
      if (!is.null(input$paramcd)) {
        teal.reporter::teal_card(q1) <-
          c(teal.reporter::teal_card(q1), paste0("Parameter - (from ", dataname, "): ", input$paramcd, "."))
      }
      if (!is.null(input$xfacet_var)) {
        teal.reporter::teal_card(q1) <- c(
          teal.reporter::teal_card(q1),
          sprintf("Faceted horizontally by: %s.", paste(input$xfacet_var, collapse = ", "))
        )
      }
      if (!is.null(input$yfacet_var)) {
        teal.reporter::teal_card(q1) <- c(
          teal.reporter::teal_card(q1),
          sprintf("Faceted vertically by: %s.", paste(input$yfacet_var, collapse = ", "))
        )
      }

      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_r <- reactive(output_q()[["plot"]])

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

    set_chunk_dims(pws, output_q)
  })
}

#' Patient Profile plot teal module
#'
#' @description
#'
#' Display patient profile plot as a shiny module
#'
#' @inheritParams teal.widgets::standard_layout
#' @inheritParams teal::module
#' @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
#' @inheritSection teal::example_module Reporting
#'
#' @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({
#'     library(nestcolor)
#'     library(dplyr)
#'     ADSL <- rADSL
#'     ADAE <- rADAE %>% mutate(ASTDT = as.Date(ASTDTM), AENDT = as.Date(AENDTM))
#'     ADCM <- rADCM %>% mutate(ASTDT = as.Date(ASTDTM), AENDT = as.Date(AENDTM))
#'     # The step below is to pre-process ADCM to legacy standard
#'     ADCM <- ADCM %>%
#'       select(-starts_with("ATC")) %>%
#'       unique()
#'     ADRS <- rADRS %>% mutate(ADT = as.Date(ADTM))
#'     ADEX <- rADEX %>% mutate(ASTDT = as.Date(ASTDTM), AENDT = as.Date(AENDTM))
#'     ADLB <- rADLB %>% mutate(ADT = as.Date(ADTM), LBSTRESN = as.numeric(LBSTRESC))
#'   })
#'
#' join_keys(data) <- default_cdisc_join_keys[names(data)]
#'
#' ADSL <- data[["ADSL"]]
#'
#' app <- init(
#'   data = data,
#'   modules = modules(
#'     tm_g_patient_profile(
#'       label = "Patient Profile Plot",
#'       patient_id = choices_selected(
#'         choices = unique(ADSL$USUBJID),
#'         selected = unique(ADSL$USUBJID)[1]
#'       ),
#'       sl_dataname = "ADSL",
#'       ex_dataname = "ADEX",
#'       ae_dataname = "ADAE",
#'       rs_dataname = "ADRS",
#'       cm_dataname = "ADCM",
#'       lb_dataname = "ADLB",
#'       sl_start_date = choices_selected(
#'         selected = "TRTSDTM",
#'         choices = c("TRTSDTM", "RANDDT")
#'       ),
#'       ex_var = choices_selected(
#'         selected = "PARCAT2",
#'         choices = "PARCAT2"
#'       ),
#'       ae_var = choices_selected(
#'         selected = "AEDECOD",
#'         choices = c("AEDECOD", "AESOC")
#'       ),
#'       ae_line_col_var = choices_selected(
#'         selected = "AESER",
#'         choices = c("AESER", "AEREL")
#'       ),
#'       ae_line_col_opt = c("Y" = "red", "N" = "blue"),
#'       rs_var = choices_selected(
#'         selected = "PARAMCD",
#'         choices = "PARAMCD"
#'       ),
#'       cm_var = choices_selected(
#'         selected = "CMDECOD",
#'         choices = c("CMDECOD", "CMCAT")
#'       ),
#'       lb_var = choices_selected(
#'         selected = "LBTESTCD",
#'         choices = c("LBTESTCD", "LBCAT")
#'       ),
#'       x_limit = "-28, 750",
#'       plot_height = c(1200, 400, 5000)
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
tm_g_patient_profile <- function(label = "Patient Profile Plot",
                                 patient_id,
                                 sl_dataname,
                                 ex_dataname = NA,
                                 ae_dataname = NA,
                                 rs_dataname = NA,
                                 cm_dataname = NA,
                                 lb_dataname = NA,
                                 sl_start_date,
                                 ex_var = NULL,
                                 ae_var = NULL,
                                 ae_line_col_var = NULL,
                                 ae_line_col_opt = NULL,
                                 rs_var = NULL,
                                 cm_var = NULL,
                                 lb_var = NULL,
                                 x_limit = "-28, 365",
                                 plot_height = c(1200L, 400L, 5000L),
                                 plot_width = NULL,
                                 pre_output = NULL,
                                 post_output = NULL,
                                 transformators = list()) {
  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
    ),
    transformators = transformators,
    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(
    teal.widgets::standard_layout(
      output = teal.widgets::white_small_well(
        teal.widgets::plot_with_settings_ui(id = ns("patientprofileplot"))
      ),
      encoding = tags$div(
        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
        )
      ),
      pre_output = a$pre_output,
      post_output = a$post_output
    )
  )
}

srv_g_patient_profile <- function(id,
                                  data,
                                  patient_id,
                                  sl_dataname,
                                  ex_dataname,
                                  ae_dataname,
                                  rs_dataname,
                                  lb_dataname,
                                  cm_dataname,
                                  label,
                                  ae_line_col_opt,
                                  plot_height,
                                  plot_width) {
  checkmate::assert_class(data, "reactive")
  checkmate::assert_class(shiny::isolate(data()), "teal_data")
  if (!is.na(ex_dataname)) checkmate::assert_names(ex_dataname, subset.of = names(data))
  if (!is.na(ae_dataname)) checkmate::assert_names(ae_dataname, subset.of = names(data))
  if (!is.na(rs_dataname)) checkmate::assert_names(rs_dataname, subset.of = names(data))
  if (!is.na(lb_dataname)) checkmate::assert_names(lb_dataname, subset.of = names(data))
  if (!is.na(cm_dataname)) checkmate::assert_names(cm_dataname, subset.of = names(data))
  checkboxes <- c(ex_dataname, ae_dataname, rs_dataname, lb_dataname, cm_dataname)
  moduleServer(id, function(input, output, session) {
    teal.logger::log_shiny_input_changes(input, namespace = "teal.osprey")
    select_plot <- reactive(
      vapply(checkboxes, function(x) x %in% input$select_ADaM, logical(1L))
    )

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

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

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

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

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

    # render plot
    output_q <- shiny::debounce(
      millis = 200,
      r = reactive({
        obj <- data()
        teal.reporter::teal_card(obj) <-
          c(
            teal.reporter::teal_card(obj),
            teal.reporter::teal_card("## Module's output(s)")
          )
        obj <- teal.code::eval_code(obj, "library(dplyr)")

        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 <- obj[[sl_dataname]]

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

        teal.reporter::teal_card(q1) <- c(teal.reporter::teal_card(q1), "### Plot")

        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
    )

    set_chunk_dims(pws, output_q)
  })
}

#' Teal Module for Waterfall Plot
#'
#' @description
#'
#' This is teal module that generates a waterfall plot for `ADaM` data
#'
#' @inheritParams teal.widgets::standard_layout
#' @inheritParams teal::module
#' @inheritParams argument_convention
#' @param dataname_tr tumor burden analysis data used in teal module to plot as bar height, needs to
#' be available in the list passed to the `data` argument of [teal::init()]
#' @param dataname_rs response analysis data used in teal module to label response parameters, needs to
#' be available in the list passed to the `data` argument of [teal::init()]
#' @param bar_paramcd `choices_selected` parameter in tumor burden data that will be plotted as
#' bar height
#' @param bar_var `choices_selected` numeric variable from dataset to plot the bar height, e.g., `PCHG`
#' @param bar_color_var `choices_selected` color by variable (subject level), `None` corresponds
#' to `NULL`
#' @param bar_color_opt aesthetic values to map color values (named vector to map color values to each name).
#' If not `NULL`, please make sure this contains all possible values for `bar_color_var` values,
#' otherwise color will be assigned by `ggplot` default, please note that `NULL` needs to be specified
#' in this case
#' @param sort_var `choices_selected` sort by variable (subject level), `None` corresponds
#' to `NULL`
#' @param add_label_var_sl `choices_selected` add label to bars (subject level), `None`
#' corresponds to `NULL`
#' @param add_label_paramcd_rs `choices_selected` add label to bars (response dataset), `None`
#' corresponds to `NULL`. At least one of `add_label_var_sl` and `add_label_paramcd_rs` needs
#' to be `NULL`
#' @param anno_txt_var_sl `choices_selected` subject level variables to be displayed in the annotation
#' table, default is `NULL`
#' @param anno_txt_paramcd_rs `choices_selected` analysis dataset variables to be displayed in the
#' annotation table, default is `NULL`
#' @param facet_var `choices_selected` facet by variable (subject level), `None` corresponds to
#' `NULL`
#' @param ytick_at bar height axis interval, default is 20
#' @param href_line numeric vector to plot horizontal reference lines, default is `NULL`
#' @param gap_point_val singular numeric value for adding bar break when some bars are significantly higher
#' than others, default is `NULL`
#' @param show_value boolean of whether value of bar height is shown, default is `TRUE`
#'
#' @inherit argument_convention return
#' @inheritSection teal::example_module Reporting
#'
#' @export
#'
#' @template author_qit3
#' @author houx14 \email{houx14@gene.com}
#'
#' @examples
#' data <- teal_data() |>
#'   within({
#'     library(nestcolor)
#'     ADSL <- rADSL
#'     ADRS <- rADRS
#'     ADTR <- rADTR
#'     ADSL$SEX <- factor(ADSL$SEX, levels = unique(ADSL$SEX))
#'   })
#'
#' join_keys(data) <- default_cdisc_join_keys[names(data)]
#'
#' app <- init(
#'   data = data,
#'   modules = modules(
#'     tm_g_waterfall(
#'       label = "Waterfall",
#'       dataname_tr = "ADTR",
#'       dataname_rs = "ADRS",
#'       bar_paramcd = choices_selected(c("SLDINV"), "SLDINV"),
#'       bar_var = choices_selected(c("PCHG", "AVAL"), "PCHG"),
#'       bar_color_var = choices_selected(c("ARMCD", "SEX"), "ARMCD"),
#'       bar_color_opt = NULL,
#'       sort_var = choices_selected(c("ARMCD", "SEX"), NULL),
#'       add_label_var_sl = choices_selected(c("SEX", "EOSDY"), NULL),
#'       add_label_paramcd_rs = choices_selected(c("BESRSPI", "OBJRSPI"), NULL),
#'       anno_txt_var_sl = choices_selected(c("SEX", "ARMCD", "BMK1", "BMK2"), NULL),
#'       anno_txt_paramcd_rs = choices_selected(c("BESRSPI", "OBJRSPI"), NULL),
#'       facet_var = choices_selected(c("SEX", "ARMCD", "STRATA1", "STRATA2"), NULL),
#'       href_line = "-30, 20"
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
tm_g_waterfall <- function(label,
                           dataname_tr = "ADTR",
                           dataname_rs = "ADRS",
                           bar_paramcd,
                           bar_var,
                           bar_color_var,
                           bar_color_opt = NULL,
                           sort_var,
                           add_label_var_sl,
                           add_label_paramcd_rs,
                           anno_txt_var_sl,
                           anno_txt_paramcd_rs,
                           facet_var,
                           ytick_at = 20,
                           href_line = NULL,
                           gap_point_val = NULL,
                           show_value = TRUE,
                           plot_height = c(1200L, 400L, 5000L),
                           plot_width = NULL,
                           pre_output = NULL,
                           post_output = NULL,
                           transformators = list()) {
  message("Initializing tm_g_waterfall")
  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
    ),
    transformators = transformators,
    datanames = c("ADSL", dataname_tr, dataname_rs)
  )
}

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(
      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
      )
    ),
    pre_output = a$pre_output,
    post_output = a$post_output
  )
}

srv_g_waterfall <- function(id,
                            data,
                            bar_paramcd,
                            add_label_paramcd_rs,
                            anno_txt_paramcd_rs,
                            dataname_tr,
                            dataname_rs,
                            bar_color_opt,
                            label,
                            plot_height,
                            plot_width) {
  checkmate::assert_class(data, "reactive")
  checkmate::assert_class(shiny::isolate(data()), "teal_data")

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

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

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

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

      iv <- shinyvalidate::InputValidator$new()
      iv$add_rule("bar_var", shinyvalidate::sv_required(
        message = "Bar Height is required"
      ))
      iv$add_rule("bar_paramcd", shinyvalidate::sv_required(
        message = "Tumor Burden Parameter is required"
      ))
      iv$add_rule("bar_paramcd", shinyvalidate::sv_in_set(
        set = adtr$PARAMCD,
        message_fmt = "All values of Tumor Burden Parameter must be elements of ADTR PARAMCD"
      ))
      iv$add_rule("add_label_paramcd_rs", shinyvalidate::sv_optional())
      iv$add_rule("add_label_paramcd_rs", shinyvalidate::sv_in_set(
        set = adrs$PARAMCD,
        message_fmt = "ADRS Label must be an element of ADRS PARAMCD"
      ))
      rule_excl <- function(value, other) {
        if (length(value) > 0L && length(other) > 0L) {
          "Only one \"Label to Bars\" is allowed"
        }
      }
      iv$add_rule("add_label_paramcd_rs", rule_excl, other = input$add_label_var_sl)
      iv$add_rule("add_label_var_sl", rule_excl, other = input$add_label_paramcd_rs)
      iv$add_rule("anno_txt_paramcd_rs", shinyvalidate::sv_optional())
      iv$add_rule("anno_txt_paramcd_rs", shinyvalidate::sv_in_set(
        set = adrs$PARAMCD,
        message_fmt = "Annotation Parameters must be elements of ADRS PARAMCD"
      ))
      iv$add_rule("href_line", shinyvalidate::sv_optional())
      iv$add_rule("href_line", ~ if (anyNA(suppressWarnings(as_numeric_from_comma_sep_str(.)))) {
        "Horizontal Reference Line(s) are invalid"
      })
      iv$add_rule("ytick_at", shinyvalidate::sv_required(
        message = "Y-axis Interval is required"
      ))
      iv$add_rule("ytick_at", ~ if (!checkmate::test_number(suppressWarnings(as.numeric(.)), lower = 1)) {
        "Y-axis Interval must be a single positive number"
      })
      iv$add_rule("gap_point_val", shinyvalidate::sv_optional())
      iv$add_rule("gap_point_val", ~ if (!checkmate::test_number(suppressWarnings(as.numeric(.)), lower = 1)) {
        "Break High Bars must be a single positive number"
      })
      iv$enable()
      iv
    })

    output_q <- reactive({
      obj <- data()
      teal.reporter::teal_card(obj) <-
        c(
          teal.reporter::teal_card(obj),
          teal.reporter::teal_card("## Module's output(s)")
        )
      obj <- teal.code::eval_code(obj, "library(dplyr)")

      adsl <- obj[["ADSL"]]
      adtr <- obj[[dataname_tr]]
      adrs <- obj[[dataname_rs]]

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

      adsl_vars <- unique(
        c(
          "USUBJID", "STUDYID",
          input$bar_color_var, input$sort_var, input$add_label_var_sl, input$anno_txt_var_sl, input$facet_var
        )
      )
      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(
        obj,
        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"]]

      teal.reporter::teal_card(q1) <-
        c(
          teal.reporter::teal_card(q1),
          "### Selected Options",
          paste0("Tumor Burden Parameter: ", input$bar_paramcd, ".")
        )

      if (!is.null(facet_var)) {
        teal.reporter::teal_card(q1) <- c(
          teal.reporter::teal_card(q1),
          paste0("Faceted by: ", paste(facet_var, collapse = ", "), ".")
        )
      }
      if (!is.null(sort_var)) {
        teal.reporter::teal_card(q1) <- c(
          teal.reporter::teal_card(q1),
          paste0("Sorted by: ", paste(sort_var, collapse = ", "), ".")
        )
      }

      teal.reporter::teal_card(q1) <- c(teal.reporter::teal_card(q1), "### Plot")

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

    set_chunk_dims(pws, output_q)
  })
}

#' Teal module for the `AE` overview
#'
#' @description
#'
#' Display the `AE` overview plot as a shiny module
#'
#' @inheritParams teal.widgets::standard_layout
#' @inheritParams teal::module
#' @inheritParams argument_convention
#' @param flag_var_anl ([`teal.transform::choices_selected`])
#'   `choices_selected` object with variables used to count adverse event
#'   sub-groups (e.g. Serious events, Related events, etc.)
#'
#' @inherit argument_convention return
#' @inheritSection teal::example_module Reporting
#'
#' @export
#'
#' @examples
#' data <- teal_data() |>
#'   within({
#'     library(dplyr)
#'     ADSL <- rADSL
#'     ADAE <- rADAE
#'     .add_event_flags <- function(dat) {
#'       dat <- dat |>
#'         mutate(
#'           TMPFL_SER = AESER == "Y",
#'           TMPFL_REL = AEREL == "Y",
#'           TMPFL_GR5 = AETOXGR == "5",
#'           AEREL1 = (AEREL == "Y" & ACTARM == "A: Drug X"),
#'           AEREL2 = (AEREL == "Y" & ACTARM == "B: Placebo")
#'         )
#'       labels <- c(
#'         "Serious AE", "Related AE", "Grade 5 AE",
#'         "AE related to A: Drug X", "AE related to B: Placebo"
#'       )
#'       cols <- c("TMPFL_SER", "TMPFL_REL", "TMPFL_GR5", "AEREL1", "AEREL2")
#'       for (i in seq_along(labels)) {
#'         attr(dat[[cols[i]]], "label") <- labels[i]
#'       }
#'       dat
#'     }
#'     ADAE <- .add_event_flags(ADAE)
#'   })
#'
#' join_keys(data) <- default_cdisc_join_keys[names(data)]
#'
#' ADAE <- data[["ADAE"]]
#'
#' app <- init(
#'   data = data,
#'   modules = modules(
#'     tm_g_ae_oview(
#'       label = "AE Overview",
#'       dataname = "ADAE",
#'       arm_var = choices_selected(
#'         selected = "ACTARM",
#'         choices = c("ACTARM", "ACTARMCD")
#'       ),
#'       flag_var_anl = choices_selected(
#'         selected = "AEREL1",
#'         choices = variable_choices(
#'           ADAE,
#'           c("TMPFL_SER", "TMPFL_REL", "TMPFL_GR5", "AEREL1", "AEREL2")
#'         ),
#'       ),
#'       plot_height = c(600, 200, 2000)
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
tm_g_ae_oview <- function(label,
                          dataname,
                          arm_var,
                          flag_var_anl,
                          fontsize = c(5, 3, 7),
                          plot_height = c(600L, 200L, 2000L),
                          plot_width = NULL,
                          transformators = list()) {
  message("Initializing tm_g_ae_oview")
  checkmate::assert_class(arm_var, classes = "choices_selected")
  checkmate::assert_class(flag_var_anl, classes = "choices_selected")
  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,
    transformators = transformators,
    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(
      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 = ""
      )
    )
  )
}

srv_g_ae_oview <- function(id,
                           data,
                           dataname,
                           label,
                           plot_height,
                           plot_width) {
  checkmate::assert_class(data, "reactive")
  checkmate::assert_class(isolate(data()), "teal_data")

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

      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({
        obj <- data()
        teal.reporter::teal_card(obj) <-
          c(
            teal.reporter::teal_card(obj),
            teal.reporter::teal_card("## Module's output(s)")
          )
        obj <- teal.code::eval_code(obj, "library(dplyr)")

        ANL <- obj[[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 <- obj %>%
          teal.code::eval_code(
            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.reporter::teal_card(q1) <- c(teal.reporter::teal_card(q1), "### Plot")

        teal.code::eval_code(
          q1,
          code = as.expression(c(
            bquote(
              plot <- osprey::g_events_term_id(
                term = flags,
                id = .(as.name(dataname))[["USUBJID"]],
                arm = .(as.name(dataname))[[.(input$arm_var)]],
                arm_N = table(ADSL[[.(input$arm_var)]]),
                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
              )
            )
          ))
        )
      })
    )

    plot_r <- reactive(output_q()[["plot"]])
    set_chunk_dims(pws, output_q)
  })
}

#' 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
#'
#'
#' @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", ]
  }
  ANL
}

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

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

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

#' @keywords internal
#' @noRd
left_bordered_div <- function(...) {
  tags$div(
    style = "
      border-left: 3px solid #e3e3e3;
      padding-left: 0.6em;
      border-radius: 5px;
      margin-left: -0.6em;
      margin-bottom: 0.5em;
    ",
    ...
  )
}

#' Set the attributes of the last chunk outputs
#'
#' This function modifies the attributes of the last `n` elements of a `teal_card`
#' that are `chunk_output` objects. It can be used to set attributes like `dev.width`
#' and `dev.height` for plot outputs.
#'
#' @param teal_card (`teal_card`) the teal_card object to modify
#' @param attributes (`list`) named list of attributes to set
#' @param n (`integer(1)`) number of the last element of `teal_card` to modify.
#' it will only change `chunk_output` objects.
#' @param inner_classes (`character`) classes within `chunk_output` that should be modified.
#' This can be used to only change `recordedplot`, `ggplot2` or other type of objects.
#' @param quiet (`logical`) whether to suppress warnings
#' @keywords internal
set_chunk_attrs <- function(teal_card,
                            attributes,
                            n = 1,
                            inner_classes = NULL,
                            quiet = FALSE) {
  checkmate::assert_class(teal_card, "teal_card")
  checkmate::assert_list(attributes, names = "unique")
  checkmate::assert_int(n, lower = 1)
  checkmate::assert_character(inner_classes, null.ok = TRUE)
  checkmate::assert_flag(quiet)

  if (!inherits(teal_card[[length(teal_card)]], "chunk_output")) {
    if (!quiet) {
      warning("The last element of the `teal_card` is not a `chunk_output` object. No attributes were modified.")
    }
    return(teal_card)
  }

  for (ix in seq_len(length(teal_card))) {
    if (ix > n) {
      break
    }
    current_ix <- length(teal_card) + 1 - ix
    if (!inherits(teal_card[[current_ix]], "chunk_output")) {
      if (!quiet) {
        warning(
          "The ", ix,
          " to last element of the `teal_card` is not a `chunk_output` object. Skipping any further modifications."
        )
      }
      return(teal_card)
    }

    if (
      length(inner_classes) > 0 &&
        length(teal_card[[current_ix]]) >= 1 &&
        !checkmate::test_multi_class(teal_card[[current_ix]][[1]], inner_classes)
    ) {
      next
    }

    attributes(teal_card[[current_ix]]) <- utils::modifyList(
      attributes(teal_card[[current_ix]]),
      attributes
    )
  }

  teal_card
}

#' Create a reactive that sets plot dimensions on a `teal_card`
#'
#' This is a convenience function that creates a reactive expression that
#' automatically sets the `dev.width` and `dev.height` attributes on the last
#' chunk outputs of a `teal_card` based on plot dimensions from a plot widget.
#'
#' @param pws (`plot_widget`) plot widget that provides dimensions via `dim()` method
#' @param q_r (`reactive`) reactive expression that returns a `teal_reporter`
#' @param inner_classes (`character`) classes within `chunk_output` that should be modified.
#' This can be used to only change `recordedplot`, `ggplot2` or other type of objects.
#'
#' @return A reactive expression that returns the `teal_card` with updated dimensions
#'
#' @keywords internal
set_chunk_dims <- function(pws, q_r, inner_classes = NULL) {
  checkmate::assert_list(pws)
  checkmate::assert_names(names(pws), must.include = "dim")
  checkmate::assert_class(pws$dim, "reactive")
  checkmate::assert_class(q_r, "reactive")
  checkmate::assert_character(inner_classes, null.ok = TRUE)

  reactive({
    pws_dim <- stats::setNames(as.list(req(pws$dim())), c("width", "height"))
    if (identical(pws_dim$width, "auto")) { # ignore non-numeric values (such as "auto")
      pws_dim$width <- NULL
    }
    if (identical(pws_dim$height, "auto")) { # ignore non-numeric values (such as "auto")
      pws_dim$height <- NULL
    }
    q <- req(q_r())
    teal.reporter::teal_card(q) <- set_chunk_attrs(
      teal.reporter::teal_card(q),
      list(dev.width = pws_dim$width, dev.height = pws_dim$height),
      inner_classes = inner_classes
    )
    q
  })
}

#' Teal module for the heatmap by grade
#'
#' @description
#'
#' Display the heatmap by grade as a shiny module
#'
#' @inheritParams teal.widgets::standard_layout
#' @inheritParams teal::module
#' @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
#' @inheritSection teal::example_module Reporting
#'
#' @export
#'
#' @examples
#' data <- teal_data() |>
#'   within({
#'     library(dplyr)
#'     library(nestcolor)
#'     ADSL <- rADSL %>% slice(1:30)
#'     ADEX <- rADEX %>% filter(USUBJID %in% ADSL$USUBJID)
#'     ADAE <- rADAE %>% filter(USUBJID %in% ADSL$USUBJID)
#'     ADCM <- rADCM %>% filter(USUBJID %in% ADSL$USUBJID)
#'     # This preprocess is only to force legacy standard on ADCM
#'     ADCM <- ADCM %>%
#'       select(-starts_with("ATC")) %>%
#'       unique()
#'     # function to derive AVISIT from ADEX
#'     .add_visit <- function(data_need_visit) {
#'       visit_dates <- ADEX %>%
#'         filter(PARAMCD == "DOSE") %>%
#'         distinct(USUBJID, AVISIT, ASTDTM) %>%
#'         group_by(USUBJID) %>%
#'         arrange(ASTDTM) %>%
#'         mutate(next_vis = lead(ASTDTM), is_last = ifelse(is.na(next_vis), TRUE, FALSE)) %>%
#'         rename(this_vis = ASTDTM)
#'       data_visit <- data_need_visit %>%
#'         select(USUBJID, ASTDTM) %>%
#'         left_join(visit_dates, by = "USUBJID") %>%
#'         filter(ASTDTM > this_vis & (ASTDTM < next_vis | is_last == TRUE)) %>%
#'         left_join(data_need_visit) %>%
#'         distinct()
#'       return(data_visit)
#'     }
#'     # derive AVISIT for ADAE and ADCM
#'     ADAE <- .add_visit(ADAE)
#'     ADCM <- .add_visit(ADCM)
#'     # derive ongoing status variable for ADEX
#'     ADEX <- ADEX %>%
#'       filter(PARCAT1 == "INDIVIDUAL") %>%
#'       mutate(ongo_status = (EOSSTT == "ONGOING"))
#'   })
#'
#' join_keys(data) <- default_cdisc_join_keys[names(data)]
#'
#' ADCM <- data[["ADCM"]]
#'
#' app <- init(
#'   data = data,
#'   modules = modules(
#'     tm_g_heat_bygrade(
#'       label = "Heatmap by grade",
#'       sl_dataname = "ADSL",
#'       ex_dataname = "ADEX",
#'       ae_dataname = "ADAE",
#'       cm_dataname = "ADCM",
#'       id_var = choices_selected(
#'         selected = "USUBJID",
#'         choices = c("USUBJID", "SUBJID")
#'       ),
#'       visit_var = choices_selected(
#'         selected = "AVISIT",
#'         choices = c("AVISIT")
#'       ),
#'       ongo_var = choices_selected(
#'         selected = "ongo_status",
#'         choices = c("ongo_status")
#'       ),
#'       anno_var = choices_selected(
#'         selected = c("SEX", "COUNTRY"),
#'         choices = c("SEX", "COUNTRY", "USUBJID")
#'       ),
#'       heat_var = choices_selected(
#'         selected = "AETOXGR",
#'         choices = c("AETOXGR")
#'       ),
#'       conmed_var = choices_selected(
#'         selected = "CMDECOD",
#'         choices = c("CMDECOD")
#'       ),
#'       plot_height = c(600, 200, 2000)
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
tm_g_heat_bygrade <- function(label,
                              sl_dataname,
                              ex_dataname,
                              ae_dataname,
                              cm_dataname = NA,
                              id_var,
                              visit_var,
                              ongo_var,
                              anno_var,
                              heat_var,
                              conmed_var = NULL,
                              fontsize = c(5, 3, 7),
                              plot_height = c(600L, 200L, 2000L),
                              plot_width = NULL,
                              transformators = list()) {
  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,
    transformators = transformators,
    datanames = "all"
  )
}

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

  shiny::tagList(
    teal.widgets::standard_layout(
      output = teal.widgets::white_small_well(
        plot_decorate_output(id = ns(NULL))
      ),
      encoding = tags$div(
        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"),
        left_bordered_div(
          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 = ""
        )
      )
    )
  )
}

srv_g_heatmap_bygrade <- function(id,
                                  data,
                                  sl_dataname,
                                  ex_dataname,
                                  ae_dataname,
                                  cm_dataname,
                                  label,
                                  plot_height,
                                  plot_width) {
  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({
        obj <- data()
        teal.reporter::teal_card(obj) <-
          c(
            teal.reporter::teal_card(obj),
            teal.reporter::teal_card("## Module's output(s)")
          )
        obj <- teal.code::eval_code(obj, "library(dplyr)")

        ADSL <- obj[[sl_dataname]]
        ADEX <- obj[[ex_dataname]]
        ADAE <- obj[[ae_dataname]]
        ADCM <- obj[[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 <- obj

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

        teal.reporter::teal_card(qenv) <- c(teal.reporter::teal_card(qenv), "### Plot")

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

    plot_r <- reactive(output_q()[["plot"]])
    set_chunk_dims(pws, output_q)
  })
}

#' Helper UI function to decorate plot output UI
#'
#' @description
#'
#' 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
#'
#' 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
    )

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

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

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

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

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

1		#' Events by Term Plot Teal Module
2		#'
3		#' @description
4		#'
5		#' Display Events by Term plot as a shiny module
6		#'
7		#' @inheritParams teal.widgets::standard_layout
8		#' @inheritParams teal::module
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		#' @inheritSection teal::example_module Reporting
15		#'
16		#' @export
17		#'
18		#' @author Liming Li (lil128) \email{liming.li@roche.com}
19		#' @author Molly He (hey59) \email{hey59@gene.com}
20		#'
21		#' @examples
22		#' data <- teal_data() \|>
23		#' within({
24		#' ADSL <- rADSL
25		#' ADAE <- rADAE
26		#' })
27		#'
28		#' join_keys(data) <- default_cdisc_join_keys[names(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		transformators = list()) {
63	!	message("Initializing tm_g_events_term_id")
64	!	checkmate::assert_string(label)
65	!	checkmate::assert_class(term_var, classes = "choices_selected")
66	!	checkmate::assert_class(arm_var, classes = "choices_selected")
67	!	checkmate::assert(
68	!	checkmate::check_number(fontsize, finite = TRUE),
69	!	checkmate::assert(
70	!	combine = "and",
71	!	.var.name = "fontsize",
72	!	checkmate::check_numeric(fontsize, len = 3, any.missing = FALSE, finite = TRUE),
73	!	checkmate::check_numeric(fontsize[1], lower = fontsize[2], upper = fontsize[3])
74		)
75		)
76	!	checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
77	!	checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")
78	!	checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
79	!	checkmate::assert_numeric(
80	!	plot_width[1],
81	!	lower = plot_width[2],
82	!	upper = plot_width[3],
83	!	null.ok = TRUE,
84	!	.var.name = "plot_width"
85		)
86
87	!	args <- as.list(environment())
88
89	!	module(
90	!	label = label,
91	!	server = srv_g_events_term_id,
92	!	server_args = list(label = label, dataname = dataname, plot_height = plot_height, plot_width = plot_width),
93	!	ui = ui_g_events_term_id,
94	!	ui_args = args,
95	!	transformators = transformators,
96	!	datanames = c("ADSL", dataname)
97		)
98		}
99
100		ui_g_events_term_id <- function(id, ...) {
101	!	ns <- NS(id)
102	!	args <- list(...)
103	!	teal.widgets::standard_layout(
104	!	output = teal.widgets::white_small_well(
105	!	plot_decorate_output(id = ns(NULL))
106		),
107	!	encoding = tags$div(
108	!	teal.widgets::optionalSelectInput(
109	!	ns("term"),
110	!	"Term Variable",
111	!	choices = get_choices(args$term_var$choices),
112	!	selected = args$term_var$selected
113		),
114	!	teal.widgets::optionalSelectInput(
115	!	ns("arm_var"),
116	!	"Arm Variable",
117	!	choices = get_choices(args$arm_var$choices),
118	!	selected = args$arm_var$selected
119		),
120	!	selectInput(
121	!	ns("arm_ref"),
122	!	"Control",
123	!	choices = get_choices(args$arm_var$choices),
124	!	selected = args$arm_var$selected
125		),
126	!	selectInput(
127	!	ns("arm_trt"),
128	!	"Treatment",
129	!	choices = get_choices(args$arm_var$choices),
130	!	selected = args$arm_var$selected
131		),
132	!	teal.widgets::optionalSelectInput(
133	!	ns("sort"),
134	!	"Sort By",
135	!	choices = c(
136	!	"Term" = "term",
137	!	"Risk Difference" = "riskdiff",
138	!	"Mean Risk" = "meanrisk"
139		),
140	!	selected = NULL
141		),
142	!	teal.widgets::panel_item(
143	!	"Confidence interval settings",
144	!	teal.widgets::optionalSelectInput(
145	!	ns("diff_ci_method"),
146	!	"Method for Difference of Proportions CI",
147	!	choices = ci_choices,
148	!	selected = ci_choices[1]
149		),
150	!	teal.widgets::optionalSliderInput(
151	!	ns("conf_level"),
152	!	"Confidence Level",
153	!	min = 0.5,
154	!	max = 1,
155	!	value = 0.95
156		)
157		),
158	!	teal.widgets::panel_item(
159	!	"Additional plot settings",
160	!	teal.widgets::optionalSelectInput(
161	!	ns("axis"),
162	!	"Axis Side",
163	!	choices = c("Left" = "left", "Right" = "right"),
164	!	selected = "left"
165		),
166	!	sliderInput(
167	!	ns("raterange"),
168	!	"Overall Rate Range",
169	!	min = 0,
170	!	max = 1,
171	!	value = c(0.1, 1),
172	!	step = 0.01
173		),
174	!	sliderInput(
175	!	ns("diffrange"),
176	!	"Rate Difference Range",
177	!	min = -1,
178	!	max = 1,
179	!	value = c(-0.5, 0.5),
180	!	step = 0.01
181		),
182	!	checkboxInput(ns("reverse"),
183	!	"Reverse Order",
184	!	value = FALSE
185		)
186		),
187	!	ui_g_decorate(
188	!	ns(NULL),
189	!	fontsize = args$fontsize,
190	!	titles = "Common AE Table",
191	!	footnotes = ""
192		)
193		)
194		)
195		}
196
197		srv_g_events_term_id <- function(id,
198		data,
199		dataname,
200		label,
201		plot_height,
202		plot_width) {
203	!	checkmate::assert_class(data, "reactive")
204	!	checkmate::assert_class(shiny::isolate(data()), "teal_data")
205
206	!	moduleServer(id, function(input, output, session) {
207	!	teal.logger::log_shiny_input_changes(input, namespace = "teal.osprey")
208	!	iv <- reactive({
209	!	iv <- shinyvalidate::InputValidator$new()
210	!	iv$add_rule("term", shinyvalidate::sv_required(
211	!	message = "Term Variable is required"
212		))
213	!	iv$add_rule("arm_var", shinyvalidate::sv_required(
214	!	message = "Arm Variable is required"
215		))
216	!	rule_diff <- function(value, other) {
217	!	if (isTRUE(value == other)) "Control and Treatment must be different"
218		}
219	!	iv$add_rule("arm_trt", rule_diff, other = input$arm_ref)
220	!	iv$add_rule("arm_ref", rule_diff, other = input$arm_trt)
221	!	iv$enable()
222	!	iv
223		})
224
225	!	decorate_output <- srv_g_decorate(
226	!	id = NULL, plt = plot_r, plot_height = plot_height, plot_width = plot_width
227		)
228	!	font_size <- decorate_output$font_size
229	!	pws <- decorate_output$pws
230
231	!	observeEvent(list(input$diff_ci_method, input$conf_level), {
232	!	req(!is.null(input$diff_ci_method) && !is.null(input$conf_level))
233	!	diff_ci_method <- input$diff_ci_method
234	!	conf_level <- input$conf_level
235	!	updateTextAreaInput(
236	!	session,
237	!	"foot",
238	!	value = sprintf(
239	!	"Note: %d%% CI is calculated using %s",
240	!	round(conf_level * 100),
241	!	name_ci(diff_ci_method)
242		)
243		)
244		})
245
246	!	observeEvent(input$sort,
247		{
248	!	sort <- if (is.null(input$sort)) " " else input$sort
249	!	updateTextInput(
250	!	session,
251	!	"title",
252	!	value = sprintf(
253	!	"Common AE Table %s",
254	!	c(
255	!	"term" = "Sorted by Term",
256	!	"riskdiff" = "Sorted by Risk Difference",
257	!	"meanrisk" = "Sorted by Mean Risk",
258		" " = ""
259	!	)[sort]
260		)
261		)
262		},
263	!	ignoreNULL = FALSE
264		)
265
266	!	observeEvent(input$arm_var,
267		{
268	!	arm_var <- input$arm_var
269	!	ANL <- data()[[dataname]]
270
271	!	choices <- levels(ANL[[arm_var]])
272
273	!	if (length(choices) == 1) {
274	!	trt_index <- 1
275		} else {
276	!	trt_index <- 2
277		}
278
279	!	updateSelectInput(
280	!	session,
281	!	"arm_ref",
282	!	selected = choices[1],
283	!	choices = choices
284		)
285	!	updateSelectInput(
286	!	session,
287	!	"arm_trt",
288	!	selected = choices[trt_index],
289	!	choices = choices
290		)
291		},
292	!	ignoreNULL = TRUE
293		)
294
295	!	output_q <- reactive({
296	!	obj <- data()
297	!	teal.reporter::teal_card(obj) <-
298	!	c(
299	!	teal.reporter::teal_card(obj),
300	!	teal.reporter::teal_card("## Module's output(s)")
301		)
302
303	!	ANL <- obj[[dataname]]
304
305	!	teal::validate_inputs(iv())
306
307	!	shiny::validate(
308	!	shiny::need(is.factor(ANL[[input$arm_var]]), "Arm Var must be a factor variable. Contact developer."),
309	!	shiny::need(
310	!	input$arm_trt %in% ANL[[req(input$arm_var)]] && input$arm_ref %in% ANL[[req(input$arm_var)]],
311	!	"Cannot generate plot. The dataset does not contain subjects from both the control and treatment arms."
312		)
313		)
314
315	!	adsl_vars <- unique(c("USUBJID", "STUDYID", input$arm_var))
316	!	anl_vars <- c("USUBJID", "STUDYID", input$term)
317
318	!	q1 <- teal.code::eval_code(
319	!	obj,
320	!	code = bquote(
321	!	ANL <- merge(
322	!	x = ADSL[, .(adsl_vars), drop = FALSE],
323	!	y = .(as.name(dataname))[, .(anl_vars), drop = FALSE],
324	!	all.x = FALSE,
325	!	all.y = FALSE,
326	!	by = c("USUBJID", "STUDYID")
327		)
328		)
329		)
330
331	!	teal::validate_has_data(q1[["ANL"]],
332	!	min_nrow = 10,
333	!	msg = "Analysis data set must have at least 10 data points"
334		)
335
336	!	teal.reporter::teal_card(q1) <- c(teal.reporter::teal_card(q1), "### Plot")
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
362	!	plot_r <- reactive(output_q()[["plot"]])
363	!	set_chunk_dims(pws, output_q)
364		})
365		}

1		#' Butterfly plot Teal Module
2		#'
3		#' @description
4		#'
5		#' Display butterfly plot as a shiny module
6		#'
7		#' @inheritParams teal.widgets::standard_layout
8		#' @inheritParams teal::module
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		#' @inheritSection teal::example_module Reporting
37		#'
38		#' @export
39		#'
40		#' @template author_zhanc107
41		#' @template author_liaoc10
42		#'
43		#' @examples
44		#' # Example using stream (ADaM) dataset
45		#' data <- teal_data() \|>
46		#' eval_code("set.seed(23) # @linksto ADSL") \|>
47		#' within({
48		#' library(nestcolor)
49		#' library(dplyr)
50		#' ADSL <- rADSL
51		#' ADAE <- rADAE
52		#' ADSL <- mutate(ADSL, DOSE = paste(sample(1:3, n(), replace = TRUE), "UG"))
53		#' ADAE <- mutate(
54		#' ADAE,
55		#' flag1 = ifelse(AETOXGR == 1, 1, 0),
56		#' flag2 = ifelse(AETOXGR == 2, 1, 0),
57		#' flag3 = ifelse(AETOXGR == 3, 1, 0),
58		#' flag1_filt = rep("Y", n())
59		#' )
60		#' })
61		#'
62		#' join_keys(data) <- default_cdisc_join_keys[names(data)]
63		#'
64		#' app <- init(
65		#' data = data,
66		#' modules = modules(
67		#' tm_g_butterfly(
68		#' label = "Butterfly Plot",
69		#' dataname = "ADAE",
70		#' right_var = choices_selected(
71		#' selected = "SEX",
72		#' choices = c("SEX", "ARM", "RACE")
73		#' ),
74		#' left_var = choices_selected(
75		#' selected = "RACE",
76		#' choices = c("SEX", "ARM", "RACE")
77		#' ),
78		#' category_var = choices_selected(
79		#' selected = "AEBODSYS",
80		#' choices = c("AEDECOD", "AEBODSYS")
81		#' ),
82		#' color_by_var = choices_selected(
83		#' selected = "AETOXGR",
84		#' choices = c("AETOXGR", "None")
85		#' ),
86		#' count_by_var = choices_selected(
87		#' selected = "# of patients",
88		#' choices = c("# of patients", "# of AEs")
89		#' ),
90		#' facet_var = choices_selected(
91		#' selected = NULL,
92		#' choices = c("RACE", "SEX", "ARM")
93		#' ),
94		#' sort_by_var = choices_selected(
95		#' selected = "count",
96		#' choices = c("count", "alphabetical")
97		#' ),
98		#' legend_on = TRUE,
99		#' plot_height = c(600, 200, 2000)
100		#' )
101		#' )
102		#' )
103		#' if (interactive()) {
104		#' shinyApp(app$ui, app$server)
105		#' }
106		#'
107		tm_g_butterfly <- function(label,
108		dataname,
109		filter_var = NULL,
110		right_var,
111		left_var,
112		category_var,
113		color_by_var,
114		count_by_var,
115		facet_var = NULL,
116		sort_by_var = teal.transform::choices_selected(
117		selected = "count", choices = c("count", "alphabetical")
118		),
119		legend_on = TRUE,
120		plot_height = c(600L, 200L, 2000L),
121		plot_width = NULL,
122		pre_output = NULL,
123		post_output = NULL,
124		transformators = list()) {
125	!	message("Initializing tm_g_butterfly")
126	!	checkmate::assert_string(label)
127	!	checkmate::assert_string(dataname)
128	!	checkmate::assert_class(filter_var, classes = "choices_selected", null.ok = TRUE)
129	!	checkmate::assert_class(right_var, classes = "choices_selected")
130	!	checkmate::assert_class(left_var, classes = "choices_selected")
131	!	checkmate::assert_class(category_var, classes = "choices_selected")
132	!	checkmate::assert_class(color_by_var, classes = "choices_selected")
133	!	checkmate::assert_class(count_by_var, classes = "choices_selected")
134	!	checkmate::assert_class(facet_var, classes = "choices_selected", null.ok = TRUE)
135	!	checkmate::assert_class(sort_by_var, classes = "choices_selected")
136	!	checkmate::assert_flag(legend_on)
137	!	checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
138	!	checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")
139	!	checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
140	!	checkmate::assert_numeric(
141	!	plot_width[1],
142	!	lower = plot_width[2],
143	!	upper = plot_width[3],
144	!	null.ok = TRUE,
145	!	.var.name = "plot_width"
146		)
147
148	!	args <- as.list(environment())
149
150	!	module(
151	!	label = label,
152	!	datanames = c("ADSL", dataname),
153	!	server = srv_g_butterfly,
154	!	server_args = list(dataname = dataname, label = label, plot_height = plot_height, plot_width = plot_width),
155	!	ui = ui_g_butterfly,
156	!	ui_args = args,
157	!	transformators = transformators
158		)
159		}
160
161		ui_g_butterfly <- function(id, ...) {
162	!	ns <- NS(id)
163	!	a <- list(...)
164
165	!	teal.widgets::standard_layout(
166	!	output = teal.widgets::white_small_well(
167	!	teal.widgets::plot_with_settings_ui(id = ns("butterflyplot"))
168		),
169	!	encoding = tags$div(
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	!	pre_output = a$pre_output,
257	!	post_output = a$post_output
258		)
259		}
260
261		srv_g_butterfly <- function(id, data, dataname, label, plot_height, plot_width) {
262	!	checkmate::assert_class(data, "reactive")
263	!	checkmate::assert_class(shiny::isolate(data()), "teal_data")
264
265	!	moduleServer(id, function(input, output, session) {
266	!	teal.logger::log_shiny_input_changes(input, namespace = "teal.osprey")
267	!	iv <- reactive({
268	!	ADSL <- data()[["ADSL"]]
269	!	ANL <- data()[[dataname]]
270
271	!	iv <- shinyvalidate::InputValidator$new()
272	!	iv$add_rule("category_var", shinyvalidate::sv_required(
273	!	message = "Category Variable is required"
274		))
275	!	iv$add_rule("right_var", shinyvalidate::sv_required(
276	!	message = "Right Dichotomization Variable is required"
277		))
278	!	iv$add_rule("left_var", shinyvalidate::sv_required(
279	!	message = "Left Dichotomization Variable is required"
280		))
281	!	iv$add_rule("right_var", ~ if (!is.factor(ANL[[.]])) {
282	!	"Right Dichotomization Variable must be a factor variable, contact developer"
283		})
284	!	iv$add_rule("left_var", ~ if (!is.factor(ANL[[.]])) {
285	!	"Left Dichotomization Variable must be a factor variable, contact developer"
286		})
287	!	iv$add_rule("right_val", shinyvalidate::sv_required(
288	!	message = "At least one value of Right Dichotomization Variable must be selected"
289		))
290	!	iv$add_rule("left_val", shinyvalidate::sv_required(
291	!	message = "At least one value of Left Dichotomization Variable must be selected"
292		))
293	!	iv$enable()
294	!	iv
295		})
296
297	!	options <- reactiveValues(r = NULL, l = NULL)
298	!	vars <- reactiveValues(r = NULL, l = NULL)
299
300		# dynamic options for dichotomization variable
301	!	observeEvent(input$right_var,
302	!	handlerExpr = {
303	!	right_var <- input$right_var
304	!	right_val <- isolate(input$right_val)
305	!	current_r_var <- isolate(vars$r)
306	!	if (is.null(right_var)) {
307	!	teal.widgets::updateOptionalSelectInput(
308	!	session,
309	!	"right_val",
310	!	choices = character(0),
311	!	selected = character(0)
312		)
313		} else {
314	!	options$r <- if (right_var %in% names(data()[["ADSL"]])) {
315	!	levels(data()[["ADSL"]][[right_var]])
316		} else {
317	!	levels(data()[[dataname]][[right_var]])
318		}
319
320	!	selected <- if (length(right_val) > 0) {
321	!	left_over <- right_val[right_val %in% options$r]
322	!	if (length(left_over) > 0 && !is.null(current_r_var) && current_r_var == right_var) {
323	!	left_over
324		} else {
325	!	options$r[1]
326		}
327		} else {
328	!	options$r[1]
329		}
330	!	teal.widgets::updateOptionalSelectInput(
331	!	session, "right_val",
332	!	choices = as.character(options$r), selected = selected, label = "Choose Up To 2:"
333		)
334		}
335	!	vars$r <- right_var
336		},
337	!	ignoreNULL = FALSE
338		)
339
340	!	observeEvent(input$left_var,
341	!	handlerExpr = {
342	!	left_var <- input$left_var
343	!	left_val <- isolate(input$left_val)
344	!	current_l_var <- isolate(vars$l)
345	!	if (is.null(left_var)) {
346	!	teal.widgets::updateOptionalSelectInput(
347	!	session, "left_val",
348	!	choices = character(0), selected = character(0)
349		)
350		} else {
351	!	options$l <- if (left_var %in% names(data()[["ADSL"]])) {
352	!	levels(data()[["ADSL"]][[left_var]])
353		} else {
354	!	levels(data()[[dataname]][[left_var]])
355		}
356
357	!	selected <- if (length(left_val) > 0) {
358	!	left_over <- left_val[left_val %in% options$l]
359	!	if (length(left_over) > 0 && !is.null(current_l_var) && current_l_var == left_var) {
360	!	left_over
361		} else {
362	!	options$l[1]
363		}
364		} else {
365	!	options$l[1]
366		}
367
368	!	teal.widgets::updateOptionalSelectInput(
369	!	session, "left_val",
370	!	choices = as.character(options$l), selected = selected, label = "Choose Up To 2:"
371		)
372		}
373	!	vars$l <- left_var
374		},
375	!	ignoreNULL = FALSE
376		)
377
378	!	output_q <- shiny::debounce(
379	!	millis = 200,
380	!	r = reactive({
381	!	obj <- data()
382	!	teal.reporter::teal_card(obj) <-
383	!	c(
384	!	teal.reporter::teal_card(obj),
385	!	teal.reporter::teal_card("## Module's output(s)")
386		)
387	!	obj <- teal.code::eval_code(obj, "library(dplyr)")
388
389	!	ADSL <- obj[["ADSL"]]
390	!	ANL <- obj[[dataname]]
391
392	!	teal::validate_has_data(ADSL, min_nrow = 0, msg = sprintf("%s Data is empty", "ADSL"))
393	!	teal::validate_has_data(ANL, min_nrow = 0, msg = sprintf("%s Data is empty", dataname))
394
395	!	teal::validate_inputs(iv())
396
397	!	validate(
398	!	need(
399	!	all(input$right_val %in% ADSL[[input$right_var]]) &&
400	!	all(input$left_val %in% ADSL[[input$left_var]]),
401	!	"No observations for selected dichotomization values (filtered out?)"
402		)
403		)
404
405	!	right_var <- isolate(input$right_var)
406	!	left_var <- isolate(input$left_var)
407	!	right_val <- input$right_val
408	!	left_val <- input$left_val
409	!	category_var <- input$category_var
410	!	color_by_var <- input$color_by_var
411	!	count_by_var <- input$count_by_var
412	!	legend_on <- input$legend_on
413	!	facet_var <- input$facet_var
414	!	sort_by_var <- input$sort_by_var
415	!	filter_var <- input$filter_var
416
417		# if variable is not in ADSL, then take from domain VADs
418	!	varlist <- c(category_var, color_by_var, facet_var, filter_var, right_var, left_var)
419	!	varlist_from_adsl <- intersect(varlist, names(ADSL))
420	!	varlist_from_anl <- intersect(varlist, setdiff(names(ANL), names(ADSL)))
421
422	!	adsl_vars <- unique(c("USUBJID", "STUDYID", varlist_from_adsl))
423	!	anl_vars <- unique(c("USUBJID", "STUDYID", varlist_from_anl))
424
425	!	q1 <- teal.code::eval_code(
426	!	obj,
427	!	code = bquote({
428	!	ADSL <- ADSL[, .(adsl_vars)] %>% as.data.frame()
429	!	ANL <- .(as.name(dataname))[, .(anl_vars)] %>% as.data.frame()
430		})
431		)
432
433	!	if (!("NULL" %in% filter_var) && !is.null(filter_var)) {
434	!	q1 <- teal.code::eval_code(
435	!	q1,
436	!	code = bquote(
437	!	ANL <- quick_filter(.(filter_var), ANL) %>%
438	!	droplevels() %>%
439	!	as.data.frame()
440		)
441		)
442		}
443
444	!	q1 <- teal.code::eval_code(
445	!	q1,
446	!	code = bquote({
447	!	ANL_f <- left_join(ADSL, ANL, by = c("USUBJID", "STUDYID")) %>% as.data.frame()
448	!	ANL_f <- na.omit(ANL_f)
449		})
450		)
451
452	!	if (!is.null(right_val) && !is.null(right_val)) {
453	!	q1 <- teal.code::eval_code(
454	!	q1,
455	!	code = bquote({
456	!	right <- ANL_f[, .(right_var)] %in% .(right_val)
457	!	right_name <- paste(.(right_val), collapse = " - ")
458	!	left <- ANL_f[, .(left_var)] %in% .(left_val)
459	!	left_name <- paste(.(left_val), collapse = " - ")
460		})
461		)
462		}
463
464	!	teal.reporter::teal_card(q1) <- c(teal.reporter::teal_card(q1), "### Plot")
465
466	!	if (!is.null(input$filter_var) \|\| !is.null(input$facet_var) \|\| !is.null(input$sort_by_var)) {
467	!	teal.reporter::teal_card(q1) <- c(teal.reporter::teal_card(q1), "### Selected Options")
468		}
469	!	if (!is.null(input$filter_var)) {
470	!	teal.reporter::teal_card(q1) <- c(
471	!	teal.reporter::teal_card(q1),
472	!	sprintf("Preset Data Filters: %s.", paste(input$filter_var, collapse = ", "))
473		)
474		}
475	!	if (!is.null(input$facet_var)) {
476	!	teal.reporter::teal_card(q1) <- c(
477	!	teal.reporter::teal_card(q1),
478	!	sprintf("Faceted by: %s.", paste(input$facet_var, collapse = ", "))
479		)
480		}
481	!	if (!is.null(input$sort_by_var)) {
482	!	teal.reporter::teal_card(q1) <- c(
483	!	teal.reporter::teal_card(q1),
484	!	sprintf("Sorted by: %s.", paste(input$sort_by_var, collapse = ", "))
485		)
486		}
487
488	!	if (!is.null(right_val) && !is.null(left_val)) {
489	!	q1 <- teal.code::eval_code(
490	!	q1,
491	!	code = bquote(
492	!	plot <- osprey::g_butterfly(
493	!	category = ANL_f[, .(category_var)],
494	!	right_flag = right,
495	!	left_flag = left,
496	!	group_names = c(right_name, left_name),
497	!	block_count = .(count_by_var),
498	!	block_color = .(if (color_by_var != "None") {
499	!	bquote(ANL_f[, .(color_by_var)])
500		} else {
501	!	NULL
502		}),
503	!	id = ANL_f$USUBJID,
504	!	facet_rows = .(if (!is.null(facet_var)) {
505	!	bquote(ANL_f[, .(facet_var)])
506		} else {
507	!	NULL
508		}),
509	!	x_label = .(count_by_var),
510	!	y_label = .(category_var),
511	!	legend_label = .(color_by_var),
512	!	sort_by = .(sort_by_var),
513	!	show_legend = .(legend_on)
514		)
515		)
516		)
517		}
518
519	!	q1
520		})
521		)
522
523	!	plot_r <- reactive(output_q()[["plot"]])
524
525		# Insert the plot into a plot_with_settings module from teal.widgets
526	!	pws <- teal.widgets::plot_with_settings_srv(
527	!	id = "butterflyplot",
528	!	plot_r = plot_r,
529	!	height = plot_height,
530	!	width = plot_width
531		)
532
533	!	set_chunk_dims(pws, output_q)
534		})
535		}

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

1		#' Teal Module for Waterfall Plot
2		#'
3		#' @description
4		#'
5		#' This is teal module that generates a waterfall plot for `ADaM` data
6		#'
7		#' @inheritParams teal.widgets::standard_layout
8		#' @inheritParams teal::module
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		#' @inheritSection teal::example_module Reporting
44		#'
45		#' @export
46		#'
47		#' @template author_qit3
48		#' @author houx14 \email{houx14@gene.com}
49		#'
50		#' @examples
51		#' data <- teal_data() \|>
52		#' within({
53		#' library(nestcolor)
54		#' ADSL <- rADSL
55		#' ADRS <- rADRS
56		#' ADTR <- rADTR
57		#' ADSL$SEX <- factor(ADSL$SEX, levels = unique(ADSL$SEX))
58		#' })
59		#'
60		#' join_keys(data) <- default_cdisc_join_keys[names(data)]
61		#'
62		#' app <- init(
63		#' data = data,
64		#' modules = modules(
65		#' tm_g_waterfall(
66		#' label = "Waterfall",
67		#' dataname_tr = "ADTR",
68		#' dataname_rs = "ADRS",
69		#' bar_paramcd = choices_selected(c("SLDINV"), "SLDINV"),
70		#' bar_var = choices_selected(c("PCHG", "AVAL"), "PCHG"),
71		#' bar_color_var = choices_selected(c("ARMCD", "SEX"), "ARMCD"),
72		#' bar_color_opt = NULL,
73		#' sort_var = choices_selected(c("ARMCD", "SEX"), NULL),
74		#' add_label_var_sl = choices_selected(c("SEX", "EOSDY"), NULL),
75		#' add_label_paramcd_rs = choices_selected(c("BESRSPI", "OBJRSPI"), NULL),
76		#' anno_txt_var_sl = choices_selected(c("SEX", "ARMCD", "BMK1", "BMK2"), NULL),
77		#' anno_txt_paramcd_rs = choices_selected(c("BESRSPI", "OBJRSPI"), NULL),
78		#' facet_var = choices_selected(c("SEX", "ARMCD", "STRATA1", "STRATA2"), NULL),
79		#' href_line = "-30, 20"
80		#' )
81		#' )
82		#' )
83		#' if (interactive()) {
84		#' shinyApp(app$ui, app$server)
85		#' }
86		#'
87		tm_g_waterfall <- function(label,
88		dataname_tr = "ADTR",
89		dataname_rs = "ADRS",
90		bar_paramcd,
91		bar_var,
92		bar_color_var,
93		bar_color_opt = NULL,
94		sort_var,
95		add_label_var_sl,
96		add_label_paramcd_rs,
97		anno_txt_var_sl,
98		anno_txt_paramcd_rs,
99		facet_var,
100		ytick_at = 20,
101		href_line = NULL,
102		gap_point_val = NULL,
103		show_value = TRUE,
104		plot_height = c(1200L, 400L, 5000L),
105		plot_width = NULL,
106		pre_output = NULL,
107		post_output = NULL,
108		transformators = list()) {
109	!	message("Initializing tm_g_waterfall")
110	!	checkmate::assert_string(label)
111	!	checkmate::assert_string(dataname_tr)
112	!	checkmate::assert_string(dataname_rs)
113	!	checkmate::assert_class(bar_paramcd, classes = "choices_selected")
114	!	checkmate::assert_class(bar_var, classes = "choices_selected")
115	!	checkmate::assert_class(bar_color_var, classes = "choices_selected")
116	!	checkmate::assert_class(sort_var, classes = "choices_selected")
117	!	checkmate::assert_class(anno_txt_var_sl, classes = "choices_selected")
118	!	checkmate::assert_class(anno_txt_paramcd_rs, classes = "choices_selected")
119	!	checkmate::assert_class(facet_var, classes = "choices_selected")
120	!	checkmate::assert_class(add_label_var_sl, classes = "choices_selected")
121	!	checkmate::assert_class(add_label_paramcd_rs, classes = "choices_selected")
122	!	checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
123	!	checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")
124	!	checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
125	!	checkmate::assert_numeric(
126	!	plot_width[1],
127	!	lower = plot_width[2],
128	!	upper = plot_width[3],
129	!	null.ok = TRUE,
130	!	.var.name = "plot_width"
131		)
132
133	!	args <- as.list(environment())
134
135	!	module(
136	!	label = label,
137	!	ui = ui_g_waterfall,
138	!	ui_args = args,
139	!	server = srv_g_waterfall,
140	!	server_args = list(
141	!	dataname_tr = dataname_tr,
142	!	dataname_rs = dataname_rs,
143	!	bar_paramcd = bar_paramcd,
144	!	add_label_paramcd_rs = add_label_paramcd_rs,
145	!	anno_txt_paramcd_rs = anno_txt_paramcd_rs,
146	!	label = label,
147	!	bar_color_opt = bar_color_opt,
148	!	plot_height = plot_height,
149	!	plot_width = plot_width
150		),
151	!	transformators = transformators,
152	!	datanames = c("ADSL", dataname_tr, dataname_rs)
153		)
154		}
155
156		ui_g_waterfall <- function(id, ...) {
157	!	a <- list(...)
158	!	ns <- NS(id)
159	!	teal.widgets::standard_layout(
160	!	output = teal.widgets::white_small_well(
161	!	teal.widgets::plot_with_settings_ui(id = ns("waterfallplot"))
162		),
163	!	encoding = tags$div(
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	!	pre_output = a$pre_output,
262	!	post_output = a$post_output
263		)
264		}
265
266		srv_g_waterfall <- function(id,
267		data,
268		bar_paramcd,
269		add_label_paramcd_rs,
270		anno_txt_paramcd_rs,
271		dataname_tr,
272		dataname_rs,
273		bar_color_opt,
274		label,
275		plot_height,
276		plot_width) {
277	!	checkmate::assert_class(data, "reactive")
278	!	checkmate::assert_class(shiny::isolate(data()), "teal_data")
279
280	!	moduleServer(id, function(input, output, session) {
281	!	teal.logger::log_shiny_input_changes(input, namespace = "teal.osprey")
282
283	!	env <- as.list(isolate(data()))
284	!	resolved_bar_paramcd <- teal.transform::resolve_delayed(bar_paramcd, env)
285	!	resolved_add_label_paramcd_rs <- teal.transform::resolve_delayed(add_label_paramcd_rs, env)
286	!	resolved_anno_txt_paramcd_rs <- teal.transform::resolve_delayed(anno_txt_paramcd_rs, env)
287
288	!	teal.widgets::updateOptionalSelectInput(
289	!	session = session,
290	!	inputId = "bar_paramcd",
291	!	choices = resolved_bar_paramcd$choices,
292	!	selected = resolved_bar_paramcd$selected
293		)
294	!	teal.widgets::updateOptionalSelectInput(
295	!	session = session,
296	!	inputId = "add_label_paramcd_rs",
297	!	choices = resolved_add_label_paramcd_rs$choices,
298	!	selected = resolved_add_label_paramcd_rs$selected
299		)
300	!	teal.widgets::updateOptionalSelectInput(
301	!	session = session,
302	!	inputId = "anno_txt_paramcd_rs",
303	!	choices = resolved_anno_txt_paramcd_rs$choices,
304	!	selected = resolved_anno_txt_paramcd_rs$selected
305		)
306
307	!	iv <- reactive({
308	!	adsl <- data()[["ADSL"]]
309	!	adtr <- data()[[dataname_tr]]
310	!	adrs <- data()[[dataname_rs]]
311
312	!	iv <- shinyvalidate::InputValidator$new()
313	!	iv$add_rule("bar_var", shinyvalidate::sv_required(
314	!	message = "Bar Height is required"
315		))
316	!	iv$add_rule("bar_paramcd", shinyvalidate::sv_required(
317	!	message = "Tumor Burden Parameter is required"
318		))
319	!	iv$add_rule("bar_paramcd", shinyvalidate::sv_in_set(
320	!	set = adtr$PARAMCD,
321	!	message_fmt = "All values of Tumor Burden Parameter must be elements of ADTR PARAMCD"
322		))
323	!	iv$add_rule("add_label_paramcd_rs", shinyvalidate::sv_optional())
324	!	iv$add_rule("add_label_paramcd_rs", shinyvalidate::sv_in_set(
325	!	set = adrs$PARAMCD,
326	!	message_fmt = "ADRS Label must be an element of ADRS PARAMCD"
327		))
328	!	rule_excl <- function(value, other) {
329	!	if (length(value) > 0L && length(other) > 0L) {
330	!	"Only one \"Label to Bars\" is allowed"
331		}
332		}
333	!	iv$add_rule("add_label_paramcd_rs", rule_excl, other = input$add_label_var_sl)
334	!	iv$add_rule("add_label_var_sl", rule_excl, other = input$add_label_paramcd_rs)
335	!	iv$add_rule("anno_txt_paramcd_rs", shinyvalidate::sv_optional())
336	!	iv$add_rule("anno_txt_paramcd_rs", shinyvalidate::sv_in_set(
337	!	set = adrs$PARAMCD,
338	!	message_fmt = "Annotation Parameters must be elements of ADRS PARAMCD"
339		))
340	!	iv$add_rule("href_line", shinyvalidate::sv_optional())
341	!	iv$add_rule("href_line", ~ if (anyNA(suppressWarnings(as_numeric_from_comma_sep_str(.)))) {
342	!	"Horizontal Reference Line(s) are invalid"
343		})
344	!	iv$add_rule("ytick_at", shinyvalidate::sv_required(
345	!	message = "Y-axis Interval is required"
346		))
347	!	iv$add_rule("ytick_at", ~ if (!checkmate::test_number(suppressWarnings(as.numeric(.)), lower = 1)) {
348	!	"Y-axis Interval must be a single positive number"
349		})
350	!	iv$add_rule("gap_point_val", shinyvalidate::sv_optional())
351	!	iv$add_rule("gap_point_val", ~ if (!checkmate::test_number(suppressWarnings(as.numeric(.)), lower = 1)) {
352	!	"Break High Bars must be a single positive number"
353		})
354	!	iv$enable()
355	!	iv
356		})
357
358	!	output_q <- reactive({
359	!	obj <- data()
360	!	teal.reporter::teal_card(obj) <-
361	!	c(
362	!	teal.reporter::teal_card(obj),
363	!	teal.reporter::teal_card("## Module's output(s)")
364		)
365	!	obj <- teal.code::eval_code(obj, "library(dplyr)")
366
367	!	adsl <- obj[["ADSL"]]
368	!	adtr <- obj[[dataname_tr]]
369	!	adrs <- obj[[dataname_rs]]
370
371		# validate data rows
372	!	teal::validate_has_data(adsl, min_nrow = 2)
373	!	teal::validate_has_data(adtr, min_nrow = 2)
374	!	teal::validate_has_data(adrs, min_nrow = 2)
375
376	!	adsl_vars <- unique(
377	!	c(
378	!	"USUBJID", "STUDYID",
379	!	input$bar_color_var, input$sort_var, input$add_label_var_sl, input$anno_txt_var_sl, input$facet_var
380		)
381		)
382	!	adtr_vars <- unique(c("USUBJID", "STUDYID", "PARAMCD", input$bar_var))
383	!	adrs_vars <- unique(c("USUBJID", "STUDYID", "PARAMCD", "AVALC"))
384	!	adrs_paramcd <- unique(c(input$add_label_paramcd_rs, input$anno_txt_paramcd_rs))
385
386		# validate data input
387	!	teal::validate_has_variable(adsl, adsl_vars)
388	!	teal::validate_has_variable(adrs, adrs_vars)
389	!	teal::validate_has_variable(adtr, adtr_vars)
390
391	!	teal::validate_inputs(iv())
392
393		# get variables
394	!	bar_var <- input$bar_var
395	!	bar_paramcd <- input$bar_paramcd
396	!	add_label_var_sl <- input$add_label_var_sl
397	!	add_label_paramcd_rs <- input$add_label_paramcd_rs
398	!	anno_txt_var_sl <- input$anno_txt_var_sl
399	!	anno_txt_paramcd_rs <- input$anno_txt_paramcd_rs
400	!	ytick_at <- input$ytick_at
401	!	href_line <- input$href_line
402	!	gap_point_val <- input$gap_point_val
403	!	show_value <- input$show_value
404	!	href_line <- suppressWarnings(as_numeric_from_comma_sep_str(href_line))
405
406	!	if (gap_point_val == "") {
407	!	gap_point_val <- NULL
408		} else {
409	!	gap_point_val <- as.numeric(gap_point_val)
410		}
411	!	ytick_at <- as.numeric(ytick_at)
412
413	!	bar_color_var <- if (
414	!	!is.null(input$bar_color_var) &&
415	!	input$bar_color_var != "None" &&
416	!	input$bar_color_var != ""
417		) {
418	!	input$bar_color_var
419		} else {
420	!	NULL
421		}
422	!	sort_var <- if (!is.null(input$sort_var) && input$sort_var != "None" && input$sort_var != "") {
423	!	input$sort_var
424		} else {
425	!	NULL
426		}
427	!	facet_var <- if (!is.null(input$facet_var) && input$facet_var != "None" && input$facet_var != "") {
428	!	input$facet_var
429		} else {
430	!	NULL
431		}
432
433		# write variables to qenv
434	!	q1 <- teal.code::eval_code(
435	!	obj,
436	!	code = bquote({
437	!	bar_var <- .(bar_var)
438	!	bar_color_var <- .(bar_color_var)
439	!	sort_var <- .(sort_var)
440	!	add_label_var_sl <- .(add_label_var_sl)
441	!	add_label_paramcd_rs <- .(add_label_paramcd_rs)
442	!	anno_txt_var_sl <- .(anno_txt_var_sl)
443	!	anno_txt_paramcd_rs <- .(anno_txt_paramcd_rs)
444	!	facet_var <- .(facet_var)
445	!	href_line <- .(href_line)
446	!	gap_point_val <- .(gap_point_val)
447	!	show_value <- .(show_value)
448		})
449		)
450
451		# data processing
452	!	q1 <- teal.code::eval_code(
453	!	q1,
454	!	code = bquote({
455	!	adsl <- ADSL[, .(adsl_vars)]
456	!	adtr <- .(as.name(dataname_tr))[, .(adtr_vars)]
457	!	adrs <- .(as.name(dataname_rs))[, .(adrs_vars)]
458
459	!	bar_tr <- .(as.name(dataname_tr)) %>%
460	!	dplyr::filter(PARAMCD == .(bar_paramcd)) %>%
461	!	dplyr::select(USUBJID, .(as.name(bar_var))) %>%
462	!	dplyr::group_by(USUBJID) %>%
463	!	dplyr::slice(which.min(.(as.name(bar_var))))
464	!	bar_data <- adsl %>% dplyr::inner_join(bar_tr, "USUBJID")
465		})
466		)
467
468	!	q1 <- if (is.null(adrs_paramcd)) {
469	!	teal.code::eval_code(
470	!	q1,
471	!	code = bquote({
472	!	anl <- bar_data
473	!	anl$USUBJID <- unlist(lapply(strsplit(anl$USUBJID, "-", fixed = TRUE), tail, 1))
474		})
475		)
476		} else {
477	!	qq1 <- teal.code::eval_code(
478	!	q1,
479	!	code = bquote(
480	!	rs_sub <- .(as.name(dataname_rs)) %>%
481	!	dplyr::filter(PARAMCD %in% .(adrs_paramcd))
482		)
483		)
484
485	!	teal::validate_one_row_per_id(qq1[["rs_sub"]], key = c("STUDYID", "USUBJID", "PARAMCD"))
486
487	!	teal.code::eval_code(
488	!	qq1,
489	!	code = bquote({
490	!	rs_label <- rs_sub %>%
491	!	dplyr::select(USUBJID, PARAMCD, AVALC) %>%
492	!	tidyr::pivot_wider(names_from = PARAMCD, values_from = AVALC)
493	!	anl <- bar_data %>% dplyr::left_join(rs_label, by = c("USUBJID"))
494	!	anl$USUBJID <- unlist(lapply(strsplit(anl$USUBJID, "-", fixed = TRUE), tail, 1))
495		})
496		)
497		}
498
499		# write plotting code to qenv
500	!	anl <- q1[["anl"]]
501
502	!	teal.reporter::teal_card(q1) <-
503	!	c(
504	!	teal.reporter::teal_card(q1),
505	!	"### Selected Options",
506	!	paste0("Tumor Burden Parameter: ", input$bar_paramcd, ".")
507		)
508
509	!	if (!is.null(facet_var)) {
510	!	teal.reporter::teal_card(q1) <- c(
511	!	teal.reporter::teal_card(q1),
512	!	paste0("Faceted by: ", paste(facet_var, collapse = ", "), ".")
513		)
514		}
515	!	if (!is.null(sort_var)) {
516	!	teal.reporter::teal_card(q1) <- c(
517	!	teal.reporter::teal_card(q1),
518	!	paste0("Sorted by: ", paste(sort_var, collapse = ", "), ".")
519		)
520		}
521
522	!	teal.reporter::teal_card(q1) <- c(teal.reporter::teal_card(q1), "### Plot")
523
524	!	q1 <- teal.code::eval_code(
525	!	q1,
526	!	code = bquote({
527	!	plot <- osprey::g_waterfall(
528	!	bar_id = anl[["USUBJID"]],
529	!	bar_height = anl[[bar_var]],
530	!	sort_by = .(if (length(sort_var) > 0) {
531	!	quote(anl[[sort_var]])
532		} else {
533	!	NULL
534		}),
535	!	col_by = .(if (length(bar_color_var) > 0) {
536	!	quote(anl[[bar_color_var]])
537		} else {
538	!	NULL
539		}),
540	!	bar_color_opt = .(if (length(bar_color_var) == 0) {
541	!	NULL
542	!	} else if (length(bar_color_var) > 0 & all(unique(anl[[bar_color_var]]) %in% names(bar_color_opt))) {
543	!	bar_color_opt
544		} else {
545	!	NULL
546		}),
547	!	anno_txt = .(if (length(anno_txt_var_sl) == 0 & length(anno_txt_paramcd_rs) == 0) {
548	!	NULL
549	!	} else if (length(anno_txt_var_sl) >= 1 & length(anno_txt_paramcd_rs) == 0) {
550	!	quote(data.frame(anl[anno_txt_var_sl]))
551	!	} else if (length(anno_txt_paramcd_rs) >= 1 & length(anno_txt_var_sl) == 0) {
552	!	quote(data.frame(anl[anno_txt_paramcd_rs]))
553		} else {
554	!	quote(cbind(anl[anno_txt_var_sl], anl[anno_txt_paramcd_rs]))
555		}),
556	!	href_line = .(href_line),
557	!	facet_by = .(if (length(facet_var) > 0) {
558	!	quote(as.factor(anl[[facet_var]]))
559		} else {
560	!	NULL
561		}),
562	!	show_datavalue = .(show_value),
563	!	add_label = .(if (length(add_label_var_sl) > 0 & length(add_label_paramcd_rs) == 0) {
564	!	quote(anl[[add_label_var_sl]])
565	!	} else if (length(add_label_paramcd_rs) > 0 & length(add_label_var_sl) == 0) {
566	!	quote(anl[[add_label_paramcd_rs]])
567		} else {
568	!	NULL
569		}),
570	!	gap_point = .(gap_point_val),
571	!	ytick_at = .(ytick_at),
572	!	y_label = "Tumor Burden Change from Baseline",
573	!	title = "Waterfall Plot"
574		)
575		})
576		)
577		})
578
579	!	plot_r <- reactive(output_q()[["plot"]])
580
581		# Insert the plot into a plot_with_settings module from teal.widgets
582	!	pws <- teal.widgets::plot_with_settings_srv(
583	!	id = "waterfallplot",
584	!	plot_r = plot_r,
585	!	height = plot_height,
586	!	width = plot_width
587		)
588
589	!	set_chunk_dims(pws, output_q)
590		})
591		}

1		#' Teal module for the `AE` overview
2		#'
3		#' @description
4		#'
5		#' Display the `AE` overview plot as a shiny module
6		#'
7		#' @inheritParams teal.widgets::standard_layout
8		#' @inheritParams teal::module
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		#' @inheritSection teal::example_module Reporting
16		#'
17		#' @export
18		#'
19		#' @examples
20		#' data <- teal_data() \|>
21		#' within({
22		#' library(dplyr)
23		#' ADSL <- rADSL
24		#' ADAE <- rADAE
25		#' .add_event_flags <- function(dat) {
26		#' dat <- dat \|>
27		#' mutate(
28		#' TMPFL_SER = AESER == "Y",
29		#' TMPFL_REL = AEREL == "Y",
30		#' TMPFL_GR5 = AETOXGR == "5",
31		#' AEREL1 = (AEREL == "Y" & ACTARM == "A: Drug X"),
32		#' AEREL2 = (AEREL == "Y" & ACTARM == "B: Placebo")
33		#' )
34		#' labels <- c(
35		#' "Serious AE", "Related AE", "Grade 5 AE",
36		#' "AE related to A: Drug X", "AE related to B: Placebo"
37		#' )
38		#' cols <- c("TMPFL_SER", "TMPFL_REL", "TMPFL_GR5", "AEREL1", "AEREL2")
39		#' for (i in seq_along(labels)) {
40		#' attr(dat[[cols[i]]], "label") <- labels[i]
41		#' }
42		#' dat
43		#' }
44		#' ADAE <- .add_event_flags(ADAE)
45		#' })
46		#'
47		#' join_keys(data) <- default_cdisc_join_keys[names(data)]
48		#'
49		#' ADAE <- data[["ADAE"]]
50		#'
51		#' app <- init(
52		#' data = data,
53		#' modules = modules(
54		#' tm_g_ae_oview(
55		#' label = "AE Overview",
56		#' dataname = "ADAE",
57		#' arm_var = choices_selected(
58		#' selected = "ACTARM",
59		#' choices = c("ACTARM", "ACTARMCD")
60		#' ),
61		#' flag_var_anl = choices_selected(
62		#' selected = "AEREL1",
63		#' choices = variable_choices(
64		#' ADAE,
65		#' c("TMPFL_SER", "TMPFL_REL", "TMPFL_GR5", "AEREL1", "AEREL2")
66		#' ),
67		#' ),
68		#' plot_height = c(600, 200, 2000)
69		#' )
70		#' )
71		#' )
72		#' if (interactive()) {
73		#' shinyApp(app$ui, app$server)
74		#' }
75		#'
76		tm_g_ae_oview <- function(label,
77		dataname,
78		arm_var,
79		flag_var_anl,
80		fontsize = c(5, 3, 7),
81		plot_height = c(600L, 200L, 2000L),
82		plot_width = NULL,
83		transformators = list()) {
84	!	message("Initializing tm_g_ae_oview")
85	!	checkmate::assert_class(arm_var, classes = "choices_selected")
86	!	checkmate::assert_class(flag_var_anl, classes = "choices_selected")
87	!	checkmate::assert(
88	!	checkmate::check_number(fontsize, finite = TRUE),
89	!	checkmate::assert(
90	!	combine = "and",
91	!	.var.name = "fontsize",
92	!	checkmate::check_numeric(fontsize, len = 3, any.missing = FALSE, finite = TRUE),
93	!	checkmate::check_numeric(fontsize[1], lower = fontsize[2], upper = fontsize[3])
94		)
95		)
96	!	checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
97	!	checkmate::assert_numeric(plot_height[1],
98	!	lower = plot_height[2], upper = plot_height[3],
99	!	.var.name = "plot_height"
100		)
101	!	checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
102	!	checkmate::assert_numeric(
103	!	plot_width[1],
104	!	lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"
105		)
106
107	!	args <- as.list(environment())
108
109	!	module(
110	!	label = label,
111	!	server = srv_g_ae_oview,
112	!	server_args = list(
113	!	label = label,
114	!	dataname = dataname,
115	!	plot_height = plot_height,
116	!	plot_width = plot_width
117		),
118	!	ui = ui_g_ae_oview,
119	!	ui_args = args,
120	!	transformators = transformators,
121	!	datanames = c("ADSL", dataname)
122		)
123		}
124
125		ui_g_ae_oview <- function(id, ...) {
126	!	ns <- NS(id)
127	!	args <- list(...)
128	!	teal.widgets::standard_layout(
129	!	output = teal.widgets::white_small_well(
130	!	plot_decorate_output(id = ns(NULL))
131		),
132	!	encoding = tags$div(
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		)
191		}
192
193		srv_g_ae_oview <- function(id,
194		data,
195		dataname,
196		label,
197		plot_height,
198		plot_width) {
199	!	checkmate::assert_class(data, "reactive")
200	!	checkmate::assert_class(isolate(data()), "teal_data")
201
202	!	moduleServer(id, function(input, output, session) {
203	!	teal.logger::log_shiny_input_changes(input, namespace = "teal.osprey")
204	!	iv <- reactive({
205	!	ANL <- data()[[dataname]]
206
207	!	iv <- shinyvalidate::InputValidator$new()
208	!	iv$add_rule("arm_var", shinyvalidate::sv_required(
209	!	message = "Arm Variable is required"
210		))
211	!	iv$add_rule("arm_var", ~ if (!is.factor(ANL[[.]])) {
212	!	"Arm Var must be a factor variable"
213		})
214	!	iv$add_rule("arm_var", ~ if (nlevels(ANL[[.]]) < 2L) {
215	!	"Selected Arm Var must have at least two levels"
216		})
217	!	iv$add_rule("flag_var_anl", shinyvalidate::sv_required(
218	!	message = "At least one Flag is required"
219		))
220	!	rule_diff <- function(value, other) {
221	!	if (isTRUE(value == other)) "Control and Treatment must be different"
222		}
223	!	iv$add_rule("arm_trt", rule_diff, other = input$arm_ref)
224	!	iv$add_rule("arm_ref", rule_diff, other = input$arm_trt)
225	!	iv$enable()
226	!	iv
227		})
228
229	!	decorate_output <- srv_g_decorate(
230	!	id = NULL, plt = plot_r,
231	!	plot_height = plot_height, plot_width = plot_width
232		)
233	!	font_size <- decorate_output$font_size
234	!	pws <- decorate_output$pws
235
236	!	observeEvent(list(input$diff_ci_method, input$conf_level), {
237	!	req(!is.null(input$diff_ci_method) && !is.null(input$conf_level))
238	!	diff_ci_method <- input$diff_ci_method
239	!	conf_level <- input$conf_level
240	!	updateTextAreaInput(session,
241	!	"foot",
242	!	value = sprintf(
243	!	"Note: %d%% CI is calculated using %s",
244	!	round(conf_level * 100),
245	!	name_ci(diff_ci_method)
246		)
247		)
248		})
249
250	!	observeEvent(input$arm_var, ignoreNULL = TRUE, {
251	!	ANL <- data()[[dataname]]
252	!	arm_var <- input$arm_var
253	!	arm_val <- ANL[[arm_var]]
254	!	choices <- levels(arm_val)
255
256	!	if (length(choices) == 1) {
257	!	trt_index <- 1
258		} else {
259	!	trt_index <- 2
260		}
261
262	!	updateSelectInput(
263	!	session,
264	!	"arm_ref",
265	!	selected = choices[1],
266	!	choices = choices
267		)
268	!	updateSelectInput(
269	!	session,
270	!	"arm_trt",
271	!	selected = choices[trt_index],
272	!	choices = choices
273		)
274		})
275
276	!	output_q <- shiny::debounce(
277	!	millis = 200,
278	!	r = reactive({
279	!	obj <- data()
280	!	teal.reporter::teal_card(obj) <-
281	!	c(
282	!	teal.reporter::teal_card(obj),
283	!	teal.reporter::teal_card("## Module's output(s)")
284		)
285	!	obj <- teal.code::eval_code(obj, "library(dplyr)")
286
287	!	ANL <- obj[[dataname]]
288
289	!	teal::validate_has_data(ANL, min_nrow = 10, msg = sprintf("%s has not enough data", dataname))
290
291	!	teal::validate_inputs(iv())
292
293	!	validate(need(
294	!	input$arm_trt %in% ANL[[input$arm_var]] && input$arm_ref %in% ANL[[input$arm_var]],
295	!	"Treatment or Control not found in Arm Variable. Perhaps they have been filtered out?"
296		))
297
298	!	q1 <- obj %>%
299	!	teal.code::eval_code(
300	!	code = as.expression(c(
301	!	bquote(anl_labels <- formatters::var_labels(.(as.name(dataname)), fill = FALSE)),
302	!	bquote(
303	!	flags <- .(as.name(dataname)) %>%
304	!	select(all_of(.(input$flag_var_anl))) %>%
305	!	rename_at(vars(.(input$flag_var_anl)), function(x) paste0(x, ": ", anl_labels[x]))
306		)
307		))
308		)
309
310	!	teal.reporter::teal_card(q1) <- c(teal.reporter::teal_card(q1), "### Plot")
311
312	!	teal.code::eval_code(
313	!	q1,
314	!	code = as.expression(c(
315	!	bquote(
316	!	plot <- osprey::g_events_term_id(
317	!	term = flags,
318	!	id = .(as.name(dataname))[["USUBJID"]],
319	!	arm = .(as.name(dataname))[[.(input$arm_var)]],
320	!	arm_N = table(ADSL[[.(input$arm_var)]]),
321	!	ref = .(input$arm_ref),
322	!	trt = .(input$arm_trt),
323	!	diff_ci_method = .(input$diff_ci_method),
324	!	conf_level = .(input$conf_level),
325	!	axis_side = .(input$axis),
326	!	fontsize = .(font_size()),
327	!	draw = TRUE
328		)
329		)
330		))
331		)
332		})
333		)
334
335	!	plot_r <- reactive(output_q()[["plot"]])
336	!	set_chunk_dims(pws, output_q)
337		})
338		}

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		#'
20		#'
21		#' @param filter_opt vector of string names of flag variable to filter (keep Y rows only)
22		#' @param ANL input dataset
23		#'
24		#' @return a filtered dataframe
25		#'
26		#' @export
27		#'
28		#' @template author_zhanc107
29		#'
30		quick_filter <- function(filter_opt, ANL) {
31	!	for (i in seq_along(filter_opt)) {
32	!	ANL <- ANL[ANL[, filter_opt[i]] == "Y", ]
33		}
34	!	ANL
35		}
36
37		#' Automatically switch variable labels for standard `AE` variables in `AE` osprey functions
38		#' `r lifecycle::badge("deprecated")`
39		#' `label_aevar` is deprecated and will be unexported in the next release.
40		#'
41		#' @param x variable key
42		#'
43		#' @export
44		label_aevar <- function(x) {
45	!	lifecycle::deprecate_stop(
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
52		#' retrieve name of ci method
53		#' @param x ci method to retrieve its name
54		#' @keywords internal
55		#'
56		name_ci <- function(x) {
57		names(ci_choices)[which(ci_choices == x)]
58		}
59
60		ci_choices <- setNames(
61		c("wald", "waldcc", "ac", "scorecc", "score", "mn", "mee", "blj", "ha"),
62		c(
63		"Wald", "Corrected Wald", "Agresti-Caffo", "Newcombe",
64		"Score", "Miettinen and Nurminen", "Mee",
65		"Brown, Li's Jeffreys", "Hauck-Anderson"
66		)
67		)
68
69		#' retrieve detailed name of ci method
70		#' @param x ci method to retrieve its name
71		name_ci <- function(x = ci_choices) {
72	!	x <- match.arg(x)
73	!	return(paste0(names(x), " (", x, ")"))
74		}
75
76
77		#' takes input_string, splits by "," and returns a numeric vector
78		#' with NAs where the split-strings are not numeric.
79		#' e.g. as_numeric_from_comma_separated_string("4 ,hello,5,, 3")
80		#' is c(4, NA, 5, NA, 3).
81		#' If input argument is NULL or just whitespace then NULL is returned
82		#' @param input_string string to be split into numeric vector
83		#' @keywords internal
84		#'
85		as_numeric_from_comma_sep_str <- function(input_string) {
86	10x	if (!is.null(input_string) && trimws(input_string) != "") {
87	7x	ref_line <- unlist(strsplit(trimws(input_string), ","))
88	7x	ref_line <- as.numeric(ref_line)
89		} else {
90	3x	ref_line <- NULL
91		}
92	10x	ref_line
93		}
94
95		#' Get Choices
96		#'
97		#' This function returns choices based on the class of the input.
98		#' If the input is of class `delayed_data`, it returns the `subset` of the input.
99		#' If `subset` is NULL and the input contains `var_label` and `var_choices`,
100		#' it throws an error prompting to resolve delayed inputs.
101		#' Otherwise, it returns the input as is.
102		#'
103		#' @param choices An object that contains choices.
104		#' @return A vector of choices.
105		#' @keywords internal
106		get_choices <- function(choices) {
107	!	if (inherits(choices, "delayed_data")) {
108	!	if (is.null(choices$subset)) {
109	!	if (!is.null(choices$var_label) && !is.null(choices$var_choices)) {
110	!	stop(
111	!	"Resolve delayed inputs by evaluating the code within the provided datasets.
112	!	Check ?teal.transform::resolve_delayed for more information."
113		)
114		} else {
115	!	stop("Subset is NULL and necessary fields are missing.")
116		}
117		} else {
118	!	choices$subset
119		}
120		} else {
121	!	choices
122		}
123		}
124
125		#' @keywords internal
126		#' @noRd
127		left_bordered_div <- function(...) {
128	!	tags$div(
129	!	style = "
130	!	border-left: 3px solid #e3e3e3;
131	!	padding-left: 0.6em;
132	!	border-radius: 5px;
133	!	margin-left: -0.6em;
134	!	margin-bottom: 0.5em;
135		",
136		...
137		)
138		}
139
140		#' Set the attributes of the last chunk outputs
141		#'
142		#' This function modifies the attributes of the last `n` elements of a `teal_card`
143		#' that are `chunk_output` objects. It can be used to set attributes like `dev.width`
144		#' and `dev.height` for plot outputs.
145		#'
146		#' @param teal_card (`teal_card`) the teal_card object to modify
147		#' @param attributes (`list`) named list of attributes to set
148		#' @param n (`integer(1)`) number of the last element of `teal_card` to modify.
149		#' it will only change `chunk_output` objects.
150		#' @param inner_classes (`character`) classes within `chunk_output` that should be modified.
151		#' This can be used to only change `recordedplot`, `ggplot2` or other type of objects.
152		#' @param quiet (`logical`) whether to suppress warnings
153		#' @keywords internal
154		set_chunk_attrs <- function(teal_card,
155		attributes,
156		n = 1,
157		inner_classes = NULL,
158		quiet = FALSE) {
159	!	checkmate::assert_class(teal_card, "teal_card")
160	!	checkmate::assert_list(attributes, names = "unique")
161	!	checkmate::assert_int(n, lower = 1)
162	!	checkmate::assert_character(inner_classes, null.ok = TRUE)
163	!	checkmate::assert_flag(quiet)
164
165	!	if (!inherits(teal_card[[length(teal_card)]], "chunk_output")) {
166	!	if (!quiet) {
167	!	warning("The last element of the `teal_card` is not a `chunk_output` object. No attributes were modified.")
168		}
169	!	return(teal_card)
170		}
171
172	!	for (ix in seq_len(length(teal_card))) {
173	!	if (ix > n) {
174	!	break
175		}
176	!	current_ix <- length(teal_card) + 1 - ix
177	!	if (!inherits(teal_card[[current_ix]], "chunk_output")) {
178	!	if (!quiet) {
179	!	warning(
180	!	"The ", ix,
181	!	" to last element of the `teal_card` is not a `chunk_output` object. Skipping any further modifications."
182		)
183		}
184	!	return(teal_card)
185		}
186
187		if (
188	!	length(inner_classes) > 0 &&
189	!	length(teal_card[[current_ix]]) >= 1 &&
190	!	!checkmate::test_multi_class(teal_card[[current_ix]][[1]], inner_classes)
191		) {
192	!	next
193		}
194
195	!	attributes(teal_card[[current_ix]]) <- utils::modifyList(
196	!	attributes(teal_card[[current_ix]]),
197	!	attributes
198		)
199		}
200
201	!	teal_card
202		}
203
204		#' Create a reactive that sets plot dimensions on a `teal_card`
205		#'
206		#' This is a convenience function that creates a reactive expression that
207		#' automatically sets the `dev.width` and `dev.height` attributes on the last
208		#' chunk outputs of a `teal_card` based on plot dimensions from a plot widget.
209		#'
210		#' @param pws (`plot_widget`) plot widget that provides dimensions via `dim()` method
211		#' @param q_r (`reactive`) reactive expression that returns a `teal_reporter`
212		#' @param inner_classes (`character`) classes within `chunk_output` that should be modified.
213		#' This can be used to only change `recordedplot`, `ggplot2` or other type of objects.
214		#'
215		#' @return A reactive expression that returns the `teal_card` with updated dimensions
216		#'
217		#' @keywords internal
218		set_chunk_dims <- function(pws, q_r, inner_classes = NULL) {
219	!	checkmate::assert_list(pws)
220	!	checkmate::assert_names(names(pws), must.include = "dim")
221	!	checkmate::assert_class(pws$dim, "reactive")
222	!	checkmate::assert_class(q_r, "reactive")
223	!	checkmate::assert_character(inner_classes, null.ok = TRUE)
224
225	!	reactive({
226	!	pws_dim <- stats::setNames(as.list(req(pws$dim())), c("width", "height"))
227	!	if (identical(pws_dim$width, "auto")) { # ignore non-numeric values (such as "auto")
228	!	pws_dim$width <- NULL
229		}
230	!	if (identical(pws_dim$height, "auto")) { # ignore non-numeric values (such as "auto")
231	!	pws_dim$height <- NULL
232		}
233	!	q <- req(q_r())
234	!	teal.reporter::teal_card(q) <- set_chunk_attrs(
235	!	teal.reporter::teal_card(q),
236	!	list(dev.width = pws_dim$width, dev.height = pws_dim$height),
237	!	inner_classes = inner_classes
238		)
239	!	q
240		})
241		}

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

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