teal.goshawk coverage - 25.05%

Files
Source

#' Line plot
#'
#' This teal module renders the UI and calls the function that creates a line plot.
#'
#' @inheritParams teal.widgets::standard_layout
#' @param label menu item label of the module in the teal app.
#' @param dataname analysis data passed to the data argument of \code{\link[teal]{init}}. E.g. `ADaM` structured
#' laboratory data frame `ADLB`.
#' @param param_var name of variable containing biomarker codes e.g. `PARAMCD`.
#' @param param biomarker selected.
#' @param param_var_label single name of variable in analysis data that includes parameter labels.
#' @param xaxis_var single name of variable in analysis data that is used as x-axis in the plot for the
#' respective `goshawk` function.
#' @param xvar_level vector that can be used to define the factor level of `xvar`. Only use it when
#' `xvar` is character or factor.
#' @param filter_var data constraint variable.
#' @param filter_var_choices data constraint variable choices.
#' @param yaxis_var single name of variable in analysis data that is used as summary variable in the
#' respective `goshawk` function.
#' @param trt_group \code{\link[teal.transform]{choices_selected}} object with available choices and pre-selected option
#' for variable names representing treatment group e.g. `ARM`.
#' @param trt_group_level vector that can be used to define factor level of `trt_group`.
#' @param shape_choices Vector or \code{choices_selected} object with names of `ADSL` variables which
#' can be used to change shape
#' @param color_manual string vector representing customized colors
#' @param stat string of statistics
#' @param hline_arb numeric vector of at most 2 values identifying intercepts for arbitrary horizontal lines.
#' @param hline_arb_color a character vector of at most length of \code{hline_arb}.
#' naming the color for the arbitrary horizontal lines.
#' @param hline_arb_label a character vector of at most length of \code{hline_arb}.
#' naming the label for the arbitrary horizontal lines.
#' @param xtick numeric vector to define the tick values of x-axis when x variable is numeric.
#' Default value is waive().
#' @param xlabel vector with same length of `xtick` to define the label of x-axis tick values.
#' Default value is waive().
#' @param rotate_xlab `logical(1)` value indicating whether to rotate `x-axis` labels.
#' @param plot_height controls plot height.
#' @param plot_width optional, controls plot width.
#' @param plot_font_size control font size for title, `x-axis`, `y-axis` and legend font.
#' @param dodge controls the position dodge of error bar
#' @param count_threshold minimum count of observations (as listed in the output table) to plot
#' nodes on the graph
#' @param table_font_size controls the font size of values in the table
#' @param dot_size plot dot size.
#' @param plot_relative_height_value numeric value between 500 and 5000 for controlling the starting value
#' of the relative plot height slider
#' @author Wenyi Liu (luiw2) wenyi.liu@roche.com
#' @author Balazs Toth (tothb2) toth.balazs@gene.com
#'
#' @return \code{shiny} object
#'
#' @export
#'
#' @examplesIf require("nestcolor")
#' # Example using ADaM structure analysis dataset.
#' data <- teal_data()
#' data <- within(data, {
#'   library(dplyr)
#'   library(stringr)
#'   library(nestcolor)
#'
#'   # original ARM value = dose value
#'   arm_mapping <- list(
#'     "A: Drug X" = "150mg QD",
#'     "B: Placebo" = "Placebo",
#'     "C: Combination" = "Combination"
#'   )
#'
#'   ADSL <- rADSL
#'   ADLB <- rADLB
#'   var_labels <- lapply(ADLB, function(x) attributes(x)$label)
#'   ADLB <- ADLB %>%
#'     mutate(
#'       AVISITCD = case_when(
#'         AVISIT == "SCREENING" ~ "SCR",
#'         AVISIT == "BASELINE" ~ "BL",
#'         grepl("WEEK", AVISIT) ~ paste("W", str_extract(AVISIT, "(?<=(WEEK ))[0-9]+")),
#'         TRUE ~ as.character(NA)
#'       ),
#'       AVISITCDN = case_when(
#'         AVISITCD == "SCR" ~ -2,
#'         AVISITCD == "BL" ~ 0,
#'         grepl("W", AVISITCD) ~ as.numeric(gsub("[^0-9]*", "", AVISITCD)),
#'         TRUE ~ as.numeric(NA)
#'       ),
#'       AVISITCD = factor(AVISITCD) %>% reorder(AVISITCDN),
#'       TRTORD = case_when(
#'         ARMCD == "ARM C" ~ 1,
#'         ARMCD == "ARM B" ~ 2,
#'         ARMCD == "ARM A" ~ 3
#'       ),
#'       ARM = as.character(arm_mapping[match(ARM, names(arm_mapping))]),
#'       ARM = factor(ARM) %>% reorder(TRTORD),
#'       ACTARM = as.character(arm_mapping[match(ACTARM, names(arm_mapping))]),
#'       ACTARM = factor(ACTARM) %>% reorder(TRTORD)
#'     )
#'   attr(ADLB[["ARM"]], "label") <- var_labels[["ARM"]]
#'   attr(ADLB[["ACTARM"]], "label") <- var_labels[["ACTARM"]]
#' })
#'
#' datanames <- c("ADSL", "ADLB")
#' datanames(data) <- datanames
#' join_keys(data) <- default_cdisc_join_keys[datanames]
#'
#' app <- init(
#'   data = data,
#'   modules = modules(
#'     tm_g_gh_lineplot(
#'       label = "Line Plot",
#'       dataname = "ADLB",
#'       param_var = "PARAMCD",
#'       param = choices_selected(c("ALT", "CRP", "IGA"), "ALT"),
#'       shape_choices = c("SEX", "RACE"),
#'       xaxis_var = choices_selected("AVISITCD", "AVISITCD"),
#'       yaxis_var = choices_selected(c("AVAL", "BASE", "CHG", "PCHG"), "AVAL"),
#'       trt_group = choices_selected(c("ARM", "ACTARM"), "ARM"),
#'       hline_arb = c(20.5, 19.5),
#'       hline_arb_color = c("red", "green"),
#'       hline_arb_label = c("A", "B")
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
tm_g_gh_lineplot <- function(label,
                             dataname,
                             param_var,
                             param,
                             param_var_label = "PARAM",
                             xaxis_var,
                             yaxis_var,
                             xvar_level = NULL,
                             filter_var = yaxis_var,
                             filter_var_choices = filter_var,
                             trt_group,
                             trt_group_level = NULL,
                             shape_choices = NULL,
                             stat = "mean",
                             hline_arb = numeric(0),
                             hline_arb_color = "red",
                             hline_arb_label = "Horizontal line",
                             color_manual = c(
                               getOption("ggplot2.discrete.colour"),
                               c("#ff0000", "#008000", "#4ca3dd", "#8a2be2")
                             )[1:4],
                             xtick = ggplot2::waiver(),
                             xlabel = xtick,
                             rotate_xlab = FALSE,
                             plot_height = c(600, 200, 4000),
                             plot_width = NULL,
                             plot_font_size = c(12, 8, 20),
                             dodge = c(0.4, 0, 1),
                             pre_output = NULL,
                             post_output = NULL,
                             count_threshold = 0,
                             table_font_size = c(12, 4, 20),
                             dot_size = c(2, 1, 12),
                             plot_relative_height_value = 1000) {
  message("Initializing tm_g_gh_lineplot")
  # Validate string inputs
  checkmate::assert_string(label)
  checkmate::assert_string(dataname)
  checkmate::assert_string(param_var)
  checkmate::assert_string(param_var_label)
  checkmate::assert_string(stat)

  # Validate choices_selected class inputs
  checkmate::assert_class(param, "choices_selected")
  checkmate::assert_class(xaxis_var, "choices_selected")
  checkmate::assert_class(yaxis_var, "choices_selected")
  checkmate::assert_class(trt_group, "choices_selected")

  # Validate flag inputs
  checkmate::assert_flag(rotate_xlab)

  # Validate numeric vector inputs
  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_numeric(table_font_size, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
  checkmate::assert_numeric(dot_size, len = 3)
  checkmate::assert_numeric(
    table_font_size[1],
    lower = table_font_size[2], upper = table_font_size[3],
    null.ok = TRUE, .var.name = "table_font_size"
  )
  checkmate::assert_number(plot_relative_height_value, lower = 500, upper = 5000)
  checkmate::assert_number(count_threshold)

  # Validate color manual if provided
  checkmate::assert_character(color_manual, null.ok = TRUE)
  checkmate::assert_character(hline_arb_color)
  checkmate::assert_character(hline_arb_label)

  # Validate line arguments
  validate_line_arb_arg(hline_arb, hline_arb_color, hline_arb_label)

  args <- as.list(environment())

  module(
    label = label,
    server = srv_lineplot,
    server_args = list(
      dataname = dataname,
      param_var = param_var,
      color_manual = color_manual,
      xvar_level = xvar_level,
      trt_group_level = trt_group_level,
      shape_choices = shape_choices,
      param_var_label = param_var_label,
      xtick = xtick,
      xlabel = xlabel,
      plot_height = plot_height,
      plot_width = plot_width,
      module_args = args
    ),
    ui = ui_lineplot,
    ui_args = args,
    datanames = dataname
  )
}

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

  shiny::tagList(
    include_css_files("custom"),
    teal.widgets::standard_layout(
      output = teal.widgets::plot_with_settings_ui(id = ns("plot")),
      encoding = tags$div(
        ### Reporter
        teal.reporter::simple_reporter_ui(ns("simple_reporter")),
        ###
        templ_ui_dataname(a$dataname),
        uiOutput(ns("axis_selections")),
        uiOutput(ns("shape_ui")),
        radioButtons(ns("stat"), "Select a Statistic:", c("mean", "median"), a$stat),
        checkboxInput(ns("include_stat"), "Include Statistic Table", value = TRUE),
        tags$div(
          sliderInput(
            ns("relative_height"),
            tags$div(
              "Relative height of plot to table(s)",
              title =
                paste(
                  "The larger the value selected the greater the size of the plot relative\nto",
                  "the size of the tables. Note the units of this slider are arbitrary.\nTo",
                  "change the total size of the plot and table(s)\nuse",
                  "the plot resizing controls available at the top right of the plot."
                ),
              icon("circle-info")
            ),
            min = 500,
            max = 5000,
            step = 50,
            value = a$plot_relative_height_value,
            ticks = FALSE
          ),
        ),
        templ_ui_constraint(ns), # required by constr_anl_q
        ui_arbitrary_lines(id = ns("hline_arb"), a$hline_arb, a$hline_arb_label, a$hline_arb_color),
        teal.widgets::panel_group(
          teal.widgets::panel_item(
            title = "Plot Aesthetic Settings",
            toggle_slider_ui(
              ns("yrange_scale"),
              label = "Y-Axis Range Zoom"
            ),
            checkboxInput(ns("rotate_xlab"), "Rotate X-axis Label", a$rotate_xlab),
            numericInput(ns("count_threshold"), "Contributing Observations Threshold:", a$count_threshold)
          ),
          teal.widgets::panel_item(
            title = "Plot settings",
            teal.widgets::optionalSliderInputValMinMax(ns("dodge"), "Error Bar Position Dodge", a$dodge, ticks = FALSE),
            teal.widgets::panel_group(
              teal.widgets::panel_item(
                title = "Line Settings",
                uiOutput(ns("lines"))
              ),
              teal.widgets::panel_item(
                title = "Symbol settings",
                uiOutput(ns("symbols"))
              )
            ),
            teal.widgets::optionalSliderInputValMinMax(
              ns("plot_font_size"),
              "Font Size",
              a$plot_font_size,
              ticks = FALSE
            ),
            teal.widgets::optionalSliderInputValMinMax(
              ns("dot_size"),
              "Dot Size",
              a$dot_size,
              ticks = FALSE
            )
          ),
          teal.widgets::panel_item(
            title = "Table settings",
            teal.widgets::optionalSliderInputValMinMax(
              ns("table_font_size"),
              "Table Font Size",
              a$table_font_size,
              ticks = FALSE
            )
          )
        )
      ),
      forms = tagList(
        teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
      ),
      pre_output = a$pre_output,
      post_output = a$post_output
    )
  )
}

srv_lineplot <- function(id,
                         data,
                         reporter,
                         filter_panel_api,
                         dataname,
                         param_var,
                         trt_group,
                         color_manual,
                         xvar_level,
                         trt_group_level,
                         shape_choices,
                         param_var_label,
                         xtick,
                         xlabel,
                         plot_height,
                         plot_width,
                         module_args) {
  with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
  with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
  checkmate::assert_class(data, "reactive")
  checkmate::assert_class(shiny::isolate(data()), "teal_data")

  moduleServer(id, function(input, output, session) {
    teal.logger::log_shiny_input_changes(input, namespace = "teal.goshawk")
    ns <- session$ns

    output$axis_selections <- renderUI({
      env <- shiny::isolate(as.list(data()@env))
      resolved_x <- teal.transform::resolve_delayed(module_args$xaxis_var, env)
      resolved_y <- teal.transform::resolve_delayed(module_args$yaxis_var, env)
      resolved_param <- teal.transform::resolve_delayed(module_args$param, env)
      resolved_trt <- teal.transform::resolve_delayed(module_args$trt_group, env)
      templ_ui_params_vars(
        ns,
        # xparam and yparam are identical, so we only show the user one
        xparam_choices = resolved_param$choices,
        xparam_selected = resolved_param$selected,
        xparam_label = "Select a Biomarker",
        xchoices = resolved_x$choices,
        xselected = resolved_x$selected,
        ychoices = resolved_y$choices,
        yselected = resolved_y$selected,
        trt_choices = resolved_trt$choices,
        trt_selected = resolved_trt$selected
      )
    })

    output$shape_ui <- renderUI({
      if (!is.null(shape_choices)) {
        if (methods::is(shape_choices, "choices_selected")) {
          choices <- get_choices(shape_choices$choices)
          selected <- shape_choices$selected
        } else {
          choices <- shape_choices
          selected <- NULL
        }
        teal.widgets::optionalSelectInput(
          ns("shape"),
          "Select Line Splitting Variable",
          choices = choices, selected = selected
        )
      }
    })

    anl_q_output <- constr_anl_q(
      session = session,
      input = input,
      data = data,
      dataname = dataname,
      param_id = "xaxis_param",
      param_var = param_var,
      trt_group = input$trt_group,
      min_rows = 2
    )

    anl_q <- anl_q_output()$value

    keep_data_const_opts_updated(session, input, anl_q, "xaxis_param")

    horizontal_line <- srv_arbitrary_lines("hline_arb")

    iv_r <- reactive({
      iv <- shinyvalidate::InputValidator$new()
      iv$add_rule("xaxis_param", shinyvalidate::sv_required("Please select a biomarker"))
      iv$add_rule("trt_group", shinyvalidate::sv_required("Please select a treatment variable"))
      iv$add_rule("xaxis_var", shinyvalidate::sv_required("Please select an X-Axis variable"))
      iv$add_rule("yaxis_var", shinyvalidate::sv_required("Please select a Y-Axis variable"))

      iv$add_validator(horizontal_line()$iv_r())
      iv$add_validator(anl_q_output()$iv_r())
      iv$enable()
      iv
    })


    # update sliders for axes
    data_state <- reactive({
      varname <- input[["yaxis_var"]]
      validate(need(varname, "Please select variable"))

      ANL <- anl_q()$ANL # nolint
      validate_has_variable(ANL, varname, paste("variable", varname, "does not exist"))

      shape <- if (!(is.null(input$shape) || input$shape == "None")) {
        input$shape
      } else {
        NULL
      }

      # we don't need to additionally filter for paramvar here as in get_data_range_states because
      # xaxis_var and yaxis_var are always distinct
      sum_data <- ANL %>%
        dplyr::group_by_at(c(input$xaxis_var, input$trt_group, shape)) %>%
        dplyr::summarise(
          upper = if (input$stat == "mean") {
            mean(!!sym(varname), na.rm = TRUE) +
              1.96 * stats::sd(!!sym(varname), na.rm = TRUE) / sqrt(dplyr::n())
          } else {
            stats::quantile(!!sym(varname), 0.75, na.rm = TRUE)
          },
          lower = if (input$stat == "mean") {
            mean(!!sym(varname), na.rm = TRUE) -
              1.96 * stats::sd(!!sym(varname), na.rm = TRUE) / sqrt(dplyr::n())
          } else {
            stats::quantile(!!sym(varname), 0.25, na.rm = TRUE)
          }
        )

      minmax <- grDevices::extendrange(
        r = c(
          floor(min(sum_data$lower, na.rm = TRUE) * 10) / 10,
          ceiling(max(sum_data$upper, na.rm = TRUE) * 10) / 10
        ),
        f = 0.05
      )

      # we don't use get_data_range_states because this module computes the data ranges
      # not from the constrained ANL, but rather by first grouping and computing confidence
      # intervals
      list(
        range = c(min = minmax[[1]], max = minmax[[2]])
      )
    })
    yrange_slider <- toggle_slider_server("yrange_scale", data_state)

    line_color_defaults <- color_manual
    line_type_defaults <- c(
      "blank",
      "solid",
      "dashed",
      "dotted",
      "dotdash",
      "longdash",
      "twodash",
      "1F",
      "F1",
      "4C88C488",
      "12345678"
    )

    line_color_selected <- reactive({
      req(input$trt_group)
      anl_arm <- as.factor(isolate(anl_q())$ANL[[input$trt_group]])
      anl_arm_nlevels <- nlevels(anl_arm)
      anl_arm_levels <- levels(anl_arm)

      stats::setNames(
        vapply(
          seq_len(anl_arm_nlevels),
          function(idx) {
            x <- input[[paste0("line_color_", idx)]]
            anl_arm_level <- anl_arm_levels[[idx]]
            if (length(x)) {
              x
            } else if (anl_arm_level %in% names(line_color_defaults)) {
              line_color_defaults[[anl_arm_level]]
            } else if (idx <= length(line_color_defaults)) {
              line_color_defaults[[idx]]
            } else {
              "#000000"
            }
          },
          character(1)
        ),
        anl_arm_levels
      )
    })
    line_type_selected <- reactive({
      req(input$trt_group)
      anl_arm <- as.factor(isolate(anl_q())$ANL[[input$trt_group]])
      anl_arm_nlevels <- nlevels(anl_arm)
      anl_arm_levels <- levels(anl_arm)

      stats::setNames(
        vapply(
          seq_len(anl_arm_nlevels),
          function(idx) {
            x <- input[[paste0("line_type_", idx)]]
            if (is.null(x)) "solid" else x
          },
          character(1)
        ),
        anl_arm_levels
      )
    })

    output$lines <- renderUI({
      req(input$trt_group)
      anl_arm <- as.factor(anl_q()$ANL[[input$trt_group]])
      anl_arm_nlevels <- nlevels(anl_arm)
      anl_arm_levels <- levels(anl_arm)

      tagList(
        lapply(
          seq_len(anl_arm_nlevels),
          function(idx) {
            x <- anl_arm_levels[[idx]]
            color_input <- colourpicker::colourInput(
              ns(paste0("line_color_", idx)),
              "Color:",
              isolate(line_color_selected()[[idx]])
            )
            type_input <- selectInput(
              ns(paste0("line_type_", idx)),
              "Type:",
              choices = line_type_defaults,
              selected = isolate(line_type_selected()[[idx]])
            )
            tags$div(
              tags$label("Line configuration for:", tags$code(x)),
              tags$div(
                class = "flex",
                tags$div(
                  class = "flex-grow-1",
                  color_input
                ),
                tags$div(
                  class = "flex-grow-1",
                  type_input
                )
              )
            )
          }
        )
      )
    })

    symbol_type_start <- c(
      "circle",
      "square",
      "diamond",
      "triangle",
      "circle open",
      "square open",
      "diamond open",
      "triangle open",
      "triangle down open",
      "circle cross",
      "square cross",
      "circle plus",
      "square plus",
      "diamond plus",
      "square triangle",
      "plus",
      "cross",
      "asterisk"
    )
    symbol_type_defaults <- reactiveVal(symbol_type_start)

    # reset shapes when different splitting variable is selected
    observeEvent(
      eventExpr = input$shape,
      handlerExpr = symbol_type_defaults(symbol_type_start),
      ignoreNULL = TRUE
    )

    observe({
      req(input$shape)
      req(anl_q())
      anl_shape <- anl_q()$ANL[[input$shape]]
      anl_shape_nlevels <- nlevels(anl_shape)
      symbol_type_to_set <- symbol_type_defaults()[pmin(length(symbol_type_defaults()), seq_len(anl_shape_nlevels))]
      symbol_type_defaults(symbol_type_to_set)
    })

    symbol_type_selected <- reactive({
      req(anl_q())
      if (is.null(input$shape)) {
        return(NULL)
      }
      anl_shape <- isolate(anl_q()$ANL[[input$shape]])
      anl_shape_nlevels <- nlevels(anl_shape)
      anl_shape_levels <- levels(anl_shape)

      stats::setNames(
        vapply(
          seq_len(anl_shape_nlevels),
          function(idx) {
            x <- input[[paste0("symbol_type_", idx)]]
            if (is.null(x)) isolate(symbol_type_defaults())[[idx]] else x
          },
          character(1)
        ),
        anl_shape_levels
      )
    })

    output$symbols <- renderUI({
      req(symbol_type_defaults())
      validate(need(input$shape, "Please select line splitting variable first."))

      anl_shape <- isolate(anl_q()$ANL[[input$shape]])
      validate(need(is.factor(anl_shape), "Line splitting variable must be a factor."))

      anl_shape_nlevels <- nlevels(anl_shape)
      anl_shape_levels <- levels(anl_shape)
      symbol_def <- symbol_type_defaults()

      tagList(
        lapply(
          seq_len(anl_shape_nlevels),
          function(idx) {
            x <- anl_shape_levels[[idx]]
            x_color <- symbol_def[[idx]]
            selectInput(
              ns(paste0("symbol_type_", idx)),
              HTML(paste0("Symbol for: ", tags$code(x))),
              choices = symbol_type_start,
              selected = x_color
            )
          }
        )
      )
    })

    plot_q <- debounce(reactive({
      teal::validate_inputs(iv_r())
      req(anl_q(), line_color_selected(), line_type_selected())
      # nolint start
      ylim <- yrange_slider$value
      plot_font_size <- input$plot_font_size
      dot_size <- input$dot_size
      dodge <- input$dodge
      rotate_xlab <- input$rotate_xlab
      count_threshold <- `if`(is.na(as.numeric(input$count_threshold)), 0, as.numeric(input$count_threshold))
      table_font_size <- input$table_font_size

      median <- ifelse(input$stat == "median", TRUE, FALSE)
      relative_height <- input$relative_height
      trt_group <- input$trt_group
      color_selected <- line_color_selected()
      type_selected <- line_type_selected()
      symbol_selected <- symbol_type_selected()
      include_stat <- input$include_stat

      param <- input$xaxis_param
      xaxis <- input$xaxis_var
      yaxis <- input$yaxis_var
      # nolint end

      shape <- if (!(is.null(input$shape) || input$shape == "None")) {
        input$shape
      } else {
        NULL
      }

      validate(
        need(
          nrow(anl_q()$ANL[stats::complete.cases(anl_q()$ANL[, c(yaxis, xaxis)]), ]) >= 2,
          "Number of complete rows on x and y axis variables is less than 2"
        )
      )

      private_qenv <- anl_q()$qenv

      if (!methods::is(xtick, "waiver") && !is.null(xtick)) {
        private_qenv <- teal.code::eval_code(
          object = private_qenv,
          code = bquote({
            keep_index <- which(.(xtick) %in% ANL[[.(xaxis)]])
            xtick <- (.(xtick))[keep_index] # extra parentheses needed for edge case, e.g. 1:5[keep_index]
            xlabel <- (.(xlabel))[keep_index]
          })
        )
      } else if (methods::is(xtick, "waiver")) {
        private_qenv <- teal.code::eval_code(
          object = private_qenv,
          code = "
            xtick <- ggplot2::waiver()
            xlabel <- ggplot2::waiver()
          "
        )
      }

      hline_arb <- horizontal_line()$line_arb
      hline_arb_label <- horizontal_line()$line_arb_label
      hline_arb_color <- horizontal_line()$line_arb_color

      teal.code::eval_code(
        object = private_qenv,
        code = bquote({
          p <- goshawk::g_lineplot(
            data = ANL[stats::complete.cases(ANL[, c(.(yaxis), .(xaxis))]), ],
            biomarker_var = .(param_var),
            biomarker_var_label = .(param_var_label),
            biomarker = .(param),
            value_var = .(yaxis),
            ylim = .(ylim),
            trt_group = .(trt_group),
            trt_group_level = .(trt_group_level),
            shape = .(shape),
            shape_type = .(symbol_selected),
            time = .(xaxis),
            time_level = .(xvar_level),
            color_manual = .(color_selected),
            line_type = .(type_selected),
            median = .(median),
            hline_arb = .(hline_arb),
            hline_arb_label = .(hline_arb_label),
            hline_arb_color = .(hline_arb_color),
            xtick = .(if (!is.null(xtick)) quote(xtick) else xtick),
            xlabel = .(if (!is.null(xtick)) quote(xlabel) else xlabel),
            rotate_xlab = .(rotate_xlab),
            plot_height = .(relative_height), # in g_lineplot this is relative height of plot to table
            plot_font_size = .(plot_font_size),
            dot_size = .(dot_size),
            dodge = .(dodge),
            count_threshold = .(count_threshold),
            table_font_size = .(table_font_size),
            display_center_tbl = .(include_stat)
          )
          print(p)
        })
      )
    }), 800)

    plot_r <- reactive(plot_q()[["p"]])

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

    code <- reactive(teal.code::get_code(plot_q()))

    ### REPORTER
    if (with_reporter) {
      card_fun <- function(comment, label) {
        constraint_description <- paste(
          "\nSelect Line Splitting Variable:",
          if (!is.null(input$shape)) input$shape else "None",
          "\nContributing Observations Threshold:",
          input$count_threshold
        )
        card <- report_card_template_goshawk(
          title = "Line Plot",
          label = label,
          with_filter = with_filter,
          filter_panel_api = filter_panel_api,
          constraint_list = list(
            constraint_var = input$constraint_var,
            constraint_range_min = input$constraint_range_min,
            constraint_range_max = input$constraint_range_max
          ),
          constraint_description = constraint_description,
          style = "verbatim"
        )
        card$append_text("Plot", "header3")
        card$append_plot(plot_r(), dim = plot_data$dim())
        if (!comment == "") {
          card$append_text("Comment", "header3")
          card$append_text(comment)
        }
        card$append_src(code())
        card
      }
      teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
    }
    ###

    teal.widgets::verbatim_popup_srv(
      id = "rcode",
      verbatim_content = reactive(code()),
      title = "Show R Code for Line Plot"
    )
  })
}

#' Scatter Plot Teal Module For Biomarker Analysis
#'
#' @description Scatter Plot Teal Module For Biomarker Analysis
#'
#' @inheritParams teal.widgets::standard_layout
#' @param label menu item label of the module in the teal app.
#' @param dataname analysis data passed to the data argument of \code{\link[teal]{init}}. E.g. `ADaM` structured
#' laboratory data frame \code{ADLB}.
#' @param param_var name of variable containing biomarker codes e.g. \code{PARAMCD}.
#' @param xaxis_param biomarker selected for `x-axis`.
#' @param yaxis_param biomarker selected for `y-axis`.
#' @param xaxis_var name of variable containing biomarker results displayed on x-axis e.g. \code{BASE}.
#' @param yaxis_var name of variable containing biomarker results displayed on y-axis e.g. \code{AVAL}.
#' @param trt_group \code{\link[teal.transform]{choices_selected}} object with available choices and pre-selected option
#' for variable names representing treatment group e.g. `ARM`.
#' @param color_manual vector of colors applied to treatment values.
#' @param shape_manual vector of symbols applied to `LOQ` values.
#' @param facet_ncol numeric value indicating number of facets per row.
#' @param trt_facet facet by treatment group \code{trt_group}.
#' @param visit_facet visit facet toggle.
#' @param reg_line include regression line and annotations for slope and coefficient in visualization. Use with facet
#'   TRUE.
#' @param loq_legend `loq` legend toggle.
#' @param rotate_xlab 45 degree rotation of `x-axis` values.
#' @param hline_arb numeric vector of at most 2 values identifying intercepts for arbitrary horizontal lines.
#' @param hline_arb_color a character vector of at most length of \code{hline_arb}.
#' naming the color for the arbitrary horizontal lines.
#' @param hline_arb_label a character vector of at most length of \code{hline_arb}.
#' naming the label for the arbitrary horizontal lines.
#' @param hline_vars a character vector to name the columns that will define additional horizontal lines.
#' @param hline_vars_colors a character vector naming the colors for the additional horizontal lines.
#' @param hline_vars_labels a character vector naming the labels for the additional horizontal lines that will appear
#' @param vline_arb numeric vector of at most 2 values identifying intercepts for arbitrary horizontal lines.
#' @param vline_arb_color a character vector of at most length of \code{vline_arb}.
#' naming the color for the arbitrary horizontal lines.
#' @param vline_arb_label a character vector of at most length of \code{vline_arb}.
#' naming the label for the arbitrary horizontal lines.
#' @param vline_vars a character vector to name the columns that will define additional vertical lines.
#' @param vline_vars_colors a character vector naming the colors for the additional vertical lines.
#' @param vline_vars_labels a character vector naming the labels for the additional vertical lines that will appear
#' @param plot_height controls plot height.
#' @param plot_width optional, controls plot width.
#' @param font_size font size control for title, `x-axis` label, `y-axis` label and legend.
#' @param dot_size plot dot size.
#' @param reg_text_size font size control for regression line annotations.
#'
#' @export
#'
#' @author Nick Paszty (npaszty) paszty.nicholas@gene.com
#' @author Balazs Toth (tothb2)  toth.balazs@gene.com
#'
#' @examples
#' # Example using ADaM structure analysis dataset.
#' data <- teal_data()
#' data <- within(data, {
#'   library(dplyr)
#'   library(stringr)
#'
#'   # use non-exported function from goshawk
#'   h_identify_loq_values <- getFromNamespace("h_identify_loq_values", "goshawk")
#'
#'   # original ARM value = dose value
#'   arm_mapping <- list(
#'     "A: Drug X" = "150mg QD",
#'     "B: Placebo" = "Placebo",
#'     "C: Combination" = "Combination"
#'   )
#'   color_manual <- c("150mg QD" = "#000000", "Placebo" = "#3498DB", "Combination" = "#E74C3C")
#'   # assign LOQ flag symbols: circles for "N" and triangles for "Y", squares for "NA"
#'   shape_manual <- c("N" = 1, "Y" = 2, "NA" = 0)
#'
#'   set.seed(1)
#'   ADSL <- rADSL
#'   ADLB <- rADLB
#'   var_labels <- lapply(ADLB, function(x) attributes(x)$label)
#'   ADLB <- ADLB %>%
#'     mutate(AVISITCD = case_when(
#'       AVISIT == "SCREENING" ~ "SCR",
#'       AVISIT == "BASELINE" ~ "BL",
#'       grepl("WEEK", AVISIT) ~
#'         paste(
#'           "W",
#'           trimws(
#'             substr(
#'               AVISIT,
#'               start = 6,
#'               stop = str_locate(AVISIT, "DAY") - 1
#'             )
#'           )
#'         ),
#'       TRUE ~ NA_character_
#'     )) %>%
#'     mutate(AVISITCDN = case_when(
#'       AVISITCD == "SCR" ~ -2,
#'       AVISITCD == "BL" ~ 0,
#'       grepl("W", AVISITCD) ~ as.numeric(gsub("[^0-9]*", "", AVISITCD)),
#'       TRUE ~ NA_real_
#'     )) %>%
#'     # use ARMCD values to order treatment in visualization legend
#'     mutate(TRTORD = ifelse(grepl("C", ARMCD), 1,
#'       ifelse(grepl("B", ARMCD), 2,
#'         ifelse(grepl("A", ARMCD), 3, NA)
#'       )
#'     )) %>%
#'     mutate(ARM = as.character(arm_mapping[match(ARM, names(arm_mapping))])) %>%
#'     mutate(ARM = factor(ARM) %>%
#'       reorder(TRTORD)) %>%
#'     mutate(
#'       ANRHI = case_when(
#'         PARAMCD == "ALT" ~ 60,
#'         PARAMCD == "CRP" ~ 70,
#'         PARAMCD == "IGA" ~ 80,
#'         TRUE ~ NA_real_
#'       ),
#'       ANRLO = case_when(
#'         PARAMCD == "ALT" ~ 20,
#'         PARAMCD == "CRP" ~ 30,
#'         PARAMCD == "IGA" ~ 40,
#'         TRUE ~ NA_real_
#'       )
#'     ) %>%
#'     rowwise() %>%
#'     group_by(PARAMCD) %>%
#'     mutate(LBSTRESC = ifelse(
#'       USUBJID %in% sample(USUBJID, 1, replace = TRUE),
#'       paste("<", round(runif(1, min = 25, max = 30))), LBSTRESC
#'     )) %>%
#'     mutate(LBSTRESC = ifelse(
#'       USUBJID %in% sample(USUBJID, 1, replace = TRUE),
#'       paste(">", round(runif(1, min = 70, max = 75))), LBSTRESC
#'     )) %>%
#'     ungroup()
#'   attr(ADLB[["ARM"]], "label") <- var_labels[["ARM"]]
#'   attr(ADLB[["ANRHI"]], "label") <- "Analysis Normal Range Upper Limit"
#'   attr(ADLB[["ANRLO"]], "label") <- "Analysis Normal Range Lower Limit"
#'
#'   # add LLOQ and ULOQ variables
#'   ADLB_LOQS <- h_identify_loq_values(ADLB, "LOQFL")
#'   ADLB <- left_join(ADLB, ADLB_LOQS, by = "PARAM")
#' })
#'
#' datanames <- c("ADSL", "ADLB")
#' datanames(data) <- datanames
#'
#' join_keys(data) <- default_cdisc_join_keys[datanames]
#'
#' app <- init(
#'   data = data,
#'   modules = modules(
#'     tm_g_gh_correlationplot(
#'       label = "Correlation Plot",
#'       dataname = "ADLB",
#'       param_var = "PARAMCD",
#'       xaxis_param = choices_selected(c("ALT", "CRP", "IGA"), "ALT"),
#'       yaxis_param = choices_selected(c("ALT", "CRP", "IGA"), "CRP"),
#'       xaxis_var = choices_selected(c("AVAL", "BASE", "CHG", "PCHG"), "BASE"),
#'       yaxis_var = choices_selected(c("AVAL", "BASE", "CHG", "PCHG"), "AVAL"),
#'       trt_group = choices_selected(c("ARM", "ACTARM"), "ARM"),
#'       color_manual = c(
#'         "Drug X 100mg" = "#000000",
#'         "Placebo" = "#3498DB",
#'         "Combination 100mg" = "#E74C3C"
#'       ),
#'       shape_manual = c("N" = 1, "Y" = 2, "NA" = 0),
#'       plot_height = c(500, 200, 2000),
#'       facet_ncol = 2,
#'       visit_facet = TRUE,
#'       reg_line = FALSE,
#'       loq_legend = TRUE,
#'       font_size = c(12, 8, 20),
#'       dot_size = c(1, 1, 12),
#'       reg_text_size = c(3, 3, 10),
#'       hline_arb = c(40, 50),
#'       hline_arb_label = "arb hori label",
#'       hline_arb_color = c("red", "blue"),
#'       hline_vars = c("ANRHI", "ANRLO", "ULOQN", "LLOQN"),
#'       hline_vars_colors = c("green", "blue", "purple", "cyan"),
#'       hline_vars_labels = c("ANRHI Label", "ANRLO Label", "ULOQN Label", "LLOQN Label"),
#'       vline_vars = c("ANRHI", "ANRLO", "ULOQN", "LLOQN"),
#'       vline_vars_colors = c("yellow", "orange", "brown", "gold"),
#'       vline_vars_labels = c("ANRHI Label", "ANRLO Label", "ULOQN Label", "LLOQN Label"),
#'       vline_arb = c(50, 70),
#'       vline_arb_label = "arb vert A",
#'       vline_arb_color = c("green", "orange")
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
tm_g_gh_correlationplot <- function(label,
                                    dataname,
                                    param_var = "PARAMCD",
                                    xaxis_param = "ALT",
                                    xaxis_var = "BASE",
                                    yaxis_param = "CRP",
                                    yaxis_var = "AVAL",
                                    trt_group,
                                    color_manual = NULL,
                                    shape_manual = NULL,
                                    facet_ncol = 2,
                                    visit_facet = TRUE,
                                    trt_facet = FALSE,
                                    reg_line = FALSE,
                                    loq_legend = TRUE,
                                    rotate_xlab = FALSE,
                                    hline_arb = numeric(0),
                                    hline_arb_color = "red",
                                    hline_arb_label = "Horizontal line",
                                    hline_vars = character(0),
                                    hline_vars_colors = "green",
                                    hline_vars_labels = hline_vars,
                                    vline_arb = numeric(0),
                                    vline_arb_color = "red",
                                    vline_arb_label = "Vertical line",
                                    vline_vars = character(0),
                                    vline_vars_colors = "green",
                                    vline_vars_labels = vline_vars,
                                    plot_height = c(500, 200, 2000),
                                    plot_width = NULL,
                                    font_size = c(12, 8, 20),
                                    dot_size = c(1, 1, 12),
                                    reg_text_size = c(3, 3, 10),
                                    pre_output = NULL,
                                    post_output = NULL) {
  message("Initializing tm_g_gh_correlationplot")
  checkmate::assert_class(xaxis_param, "choices_selected")
  checkmate::assert_class(yaxis_param, "choices_selected")
  checkmate::assert_class(xaxis_var, "choices_selected")
  checkmate::assert_class(yaxis_var, "choices_selected")
  checkmate::assert_class(trt_group, "choices_selected")
  checkmate::assert_flag(trt_facet)
  validate_line_arb_arg(hline_arb, hline_arb_color, hline_arb_label)
  validate_line_arb_arg(vline_arb, vline_arb_color, vline_arb_label)
  validate_line_vars_arg(hline_vars, hline_vars_colors, hline_vars_labels)
  validate_line_vars_arg(vline_vars, vline_vars_colors, vline_vars_labels)
  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_numeric(font_size, len = 3)
  checkmate::assert_numeric(dot_size, len = 3)
  checkmate::assert_numeric(reg_text_size, len = 3)

  args <- as.list(environment())

  module(
    label = label,
    datanames = dataname,
    server = srv_g_correlationplot,
    server_args = list(
      dataname = dataname,
      param_var = param_var,
      trt_facet = trt_facet,
      color_manual = color_manual,
      shape_manual = shape_manual,
      plot_height = plot_height,
      plot_width = plot_width,
      hline_vars_colors = hline_vars_colors,
      hline_vars_labels = hline_vars_labels,
      vline_vars_colors = vline_vars_colors,
      vline_vars_labels = vline_vars_labels,
      module_args = args
    ),
    ui = ui_g_correlationplot,
    ui_args = args
  )
}

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

  teal.widgets::standard_layout(
    output = templ_ui_output_datatable(ns),
    encoding = tags$div(
      ### Reporter
      teal.reporter::simple_reporter_ui(ns("simple_reporter")),
      ###
      templ_ui_dataname(a$dataname),
      uiOutput(ns("axis_selections")),
      templ_ui_constraint(ns, "X-Axis Data Constraint"), # required by constr_anl_q
      if (length(a$hline_vars) > 0) {
        teal.widgets::optionalSelectInput(
          ns("hline_vars"),
          label = "Add Horizontal Range Line(s):",
          choices = a$hline_vars,
          selected = NULL,
          multiple = TRUE
        )
      },
      ui_arbitrary_lines(id = ns("hline_arb"), a$hline_arb, a$hline_arb_label, a$hline_arb_color),
      if (length(a$vline_vars) > 0) {
        teal.widgets::optionalSelectInput(
          ns("vline_vars"),
          label = "Add Vertical Range Line(s):",
          choices = a$vline_vars,
          selected = NULL,
          multiple = TRUE
        )
      },
      ui_arbitrary_lines(
        id = ns("vline_arb"),
        a$vline_arb,
        a$vline_arb_label,
        a$vline_arb_color,
        title = "Arbitrary Vertical Lines:"
      ),
      teal.widgets::panel_group(
        teal.widgets::panel_item(
          title = "Plot Aesthetic Settings",
          toggle_slider_ui(
            ns("xrange_scale"),
            label = "X-Axis Range Zoom"
          ),
          toggle_slider_ui(
            ns("yrange_scale"),
            label = "Y-Axis Range Zoom"
          ),
          numericInput(ns("facet_ncol"), "Number of Plots Per Row:", a$facet_ncol, min = 1),
          checkboxInput(ns("trt_facet"), "Treatment Variable Faceting", a$trt_facet),
          checkboxInput(ns("visit_facet"), "Visit Faceting", a$visit_facet),
          checkboxInput(ns("reg_line"), "Regression Line", a$reg_line),
          checkboxInput(ns("loq_legend"), "Display LoQ Legend", a$loq_legend),
          checkboxInput(ns("rotate_xlab"), "Rotate X-axis Label", a$rotate_xlab)
        ),
        teal.widgets::panel_item(
          title = "Plot settings",
          teal.widgets::optionalSliderInputValMinMax(ns("font_size"), "Font Size", a$font_size, ticks = FALSE),
          teal.widgets::optionalSliderInputValMinMax(ns("dot_size"), "Dot Size", a$dot_size, ticks = FALSE),
          teal.widgets::optionalSliderInputValMinMax(
            ns("reg_text_size"),
            "Regression Annotations Size",
            a$reg_text_size,
            ticks = FALSE
          )
        )
      )
    ),
    forms = tagList(
      teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
    ),
    pre_output = a$pre_output,
    post_output = a$post_output
  )
}

srv_g_correlationplot <- function(id,
                                  data,
                                  reporter,
                                  filter_panel_api,
                                  dataname,
                                  param_var,
                                  trt_group,
                                  trt_facet,
                                  color_manual,
                                  shape_manual,
                                  plot_height,
                                  plot_width,
                                  hline_vars_colors,
                                  hline_vars_labels,
                                  vline_vars_colors,
                                  vline_vars_labels,
                                  module_args) {
  with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
  with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
  checkmate::assert_class(data, "reactive")
  checkmate::assert_class(shiny::isolate(data()), "teal_data")

  moduleServer(id, function(input, output, session) {
    teal.logger::log_shiny_input_changes(input, namespace = "teal.goshawk")
    output$axis_selections <- renderUI({
      env <- shiny::isolate(as.list(data()@env))
      resolved_x_param <- teal.transform::resolve_delayed(module_args$xaxis_param, env)
      resolved_x_var <- teal.transform::resolve_delayed(module_args$xaxis_var, env)
      resolved_y_param <- teal.transform::resolve_delayed(module_args$yaxis_param, env)
      resolved_y_var <- teal.transform::resolve_delayed(module_args$yaxis_var, env)
      resolved_trt <- teal.transform::resolve_delayed(module_args$trt_group, env)
      templ_ui_params_vars(
        session$ns,
        xparam_choices = resolved_x_param$choices,
        xparam_selected = resolved_x_param$selected,
        xchoices = resolved_x_var$choices,
        xselected = resolved_x_var$selected,
        yparam_choices = resolved_y_param$choices,
        yparam_selected = resolved_y_param$selected,
        ychoices = resolved_y_var$choices,
        yselected = resolved_y_var$selected,
        trt_choices = resolved_trt$choices,
        trt_selected = resolved_trt$selected
      )
    })

    iv_r <- reactive({
      iv <- shinyvalidate::InputValidator$new()

      iv$add_rule("xaxis_param", shinyvalidate::sv_required("Please select an X-Axis biomarker"))
      iv$add_rule("yaxis_param", shinyvalidate::sv_required("Please select a Y-Axis biomarker"))
      iv$add_rule("trt_group", shinyvalidate::sv_required("Please select a treatment variable"))
      iv$add_rule("xaxis_var", shinyvalidate::sv_required("Please select an X-Axis variable"))
      iv$add_rule("yaxis_var", shinyvalidate::sv_required("Please select a Y-Axis variable"))
      iv$add_rule("facet_ncol", plots_per_row_validate_rules())

      iv$add_validator(anl_constraint_output()$iv_r())
      iv$add_validator(horizontal_line()$iv_r())
      iv$add_validator(vertical_line()$iv_r())
      iv$enable()
      iv
    })



    # filter selected biomarkers
    anl_param <- reactive({
      dataset_var <- dataname
      ANL <- data()[[dataname]] # nolint
      validate_has_data(ANL, 1)

      if (length(input$hline_vars) > 0) {
        validate(
          need(
            all(input$hline_vars %in% names(ANL)),
            "One or more selected horizontal line variable(s) is/are not names to any column in the data"
          ),
          need(
            all(input$vline_vars %in% names(ANL)),
            "One or more selected vertical line variable(s) is/are not names to any column in the data"
          )
        )
      }

      validate_has_variable(ANL, param_var)

      validate_in(
        input$xaxis_param, unique(ANL[[param_var]]),
        sprintf("X-Axis Biomarker %s is not available in data %s", input$xaxis_param, dataname)
      )

      validate_in(
        input$yaxis_param, unique(ANL[[param_var]]),
        sprintf("Y-Axis Biomarker %s is not available in data %s", input$yaxis_param, dataname)
      )

      validate_has_variable(
        ANL,
        "AVISITCD",
        sprintf("Variable AVISITCD is not available in data %s", dataname)
      )

      validate_has_variable(
        ANL,
        "BASE",
        sprintf("Variable BASE is not available in data %s", dataname)
      )

      validate_has_variable(
        ANL,
        "BASE2",
        sprintf("Variable BASE2 is not available in data %s", dataname)
      )

      validate_has_variable(
        ANL,
        "LOQFL",
        sprintf("Variable LOQFL is not available in data %s", dataname)
      )

      validate_has_variable(
        ANL,
        "PARAM",
        sprintf("Variable PARAM is not available in data %s", dataname)
      )

      validate_has_variable(
        ANL,
        "LBSTRESC",
        sprintf("Variable LBSTRESC is not available in data %s", dataname)
      )

      validate_has_variable(
        ANL,
        input$trt_group,
        sprintf("Variable %s is not available in data %s", input$trt_group, dataname)
      )

      validate_has_variable(
        ANL,
        "USUBJID",
        sprintf("Variable USUBJID is not available in data %s", dataname)
      )

      validate_has_variable(
        ANL,
        input$xaxis_var,
        sprintf("Variable %s is not available in data %s", input$xaxis_var, dataname)
      )

      validate_has_variable(
        ANL,
        input$yaxis_var,
        sprintf("Variable %s is not available in data %s", input$yaxis_var, dataname)
      )

      # analysis
      private_qenv <- data() %>%
        teal.code::eval_code(
          code = bquote({
            ANL <- .(as.name(dataset_var)) %>% # nolint
              dplyr::filter(.data[[.(param_var)]] %in% union(.(input$xaxis_param), .(input$yaxis_param))) %>%
              dplyr::select(
                .(c(
                  "USUBJID", input$trt_group, "AVISITCD", param_var, "PARAM", input$xaxis_var, input$yaxis_var, "AVALU",
                  "LOQFL", "LBSTRESC", unique(c(input$hline_vars, input$vline_vars))
                ))
              )
          })
        )
      validate_has_data(private_qenv[["ANL"]], 1)
      return(list(ANL = ANL, qenv = private_qenv))
    })

    # constraints
    observe({
      req(input$xaxis_param)

      constraint_var <- input$constraint_var
      req(constraint_var)

      # note that filtered is false thus we cannot use anl_param()$ANL
      ANL <- data()[[dataname]] # nolint
      validate_has_data(ANL, 1)

      validate_has_variable(ANL, param_var)
      validate_has_variable(ANL, "AVISITCD")
      validate_has_variable(ANL, "BASE")
      validate_has_variable(ANL, "BASE2")

      ANL <- ANL %>% dplyr::filter(.data[[param_var]] == input$xaxis_param) # nolint

      visit_freq <- unique(ANL$AVISITCD)

      # get min max values
      if ((constraint_var == "BASE2" && any(grepl("SCR", visit_freq))) ||
        (constraint_var == "BASE" && any(grepl("BL", visit_freq)))) { # nolint
        val <- stats::na.omit(switch(constraint_var,
          "BASE" = ANL$BASE[ANL$AVISITCD == "BL"],
          "BASE2" = ANL$BASE2[ANL$AVISITCD == "SCR"],
          stop(paste(constraint_var, "not allowed"))
        ))

        if (length(val) == 0 || all(is.na(val))) {
          shinyjs::show("all_na")
          shinyjs::hide("constraint_range")
          args <- list(
            min = list(label = "Min", min = 0, max = 0, value = 0),
            max = list(label = "Max", min = 0, max = 0, value = 0)
          )
          update_min_max(session, args)
        } else {
          rng <- range(val, na.rm = TRUE)

          minmax <- c(floor(rng[1] * 1000) / 1000, ceiling(rng[2] * 1000) / 1000)

          label_min <- sprintf("Min (%s)", minmax[1])
          label_max <- sprintf("Max (%s)", minmax[2])

          args <- list(
            min = list(label = label_min, min = minmax[1], max = minmax[2], value = minmax[1]),
            max = list(label = label_max, min = minmax[1], max = minmax[2], value = minmax[2])
          )

          update_min_max(session, args)
          shinyjs::show("constraint_range") # update before show
          shinyjs::hide("all_na")
        }
      } else if (constraint_var == "NONE") {
        shinyjs::hide("constraint_range") # hide before update
        shinyjs::hide("all_na")

        # force update (and thus refresh) on different constraint_var -> pass unique value for each constraint_var name
        args <- list(
          min = list(label = "Min", min = 0, max = 0, value = 0),
          max = list(label = "Max", min = 0, max = 0, value = 0)
        )

        update_min_max(session, args)
      } else {
        stop("invalid contraint_var", constraint_var)
      }
    })

    anl_constraint_output <- create_anl_constraint_reactive(anl_param, input, param_id = "xaxis_param", min_rows = 1)
    anl_constraint <- anl_constraint_output()$value

    # update sliders for axes taking constraints into account
    data_state_x <- reactive({
      get_data_range_states(
        varname = input$xaxis_var,
        paramname = input$xaxis_param,
        ANL = anl_constraint()$ANL
      )
    })
    xrange_slider <- toggle_slider_server("xrange_scale", data_state_x)
    data_state_y <- reactive({
      get_data_range_states(
        varname = input$yaxis_var,
        paramname = input$yaxis_param,
        ANL = anl_constraint()$ANL
      )
    })
    yrange_slider <- toggle_slider_server("yrange_scale", data_state_y)

    keep_data_const_opts_updated(session, input, anl_constraint, "xaxis_param")

    # selector names after transposition
    xvar <- reactive(paste0(input$xaxis_var, "_", input$xaxis_param))
    yvar <- reactive(paste0(input$yaxis_var, "_", input$yaxis_param))
    xloqfl <- reactive(paste0("LOQFL_", input$xaxis_param))
    yloqfl <- reactive(paste0("LOQFL_", input$yaxis_param))

    # transpose data to plot
    plot_data_transpose <- reactive({
      teal::validate_inputs(iv_r())

      req(anl_constraint())
      ANL <- anl_constraint()$ANL # nolint
      trt_group <- input$trt_group

      qenv <- anl_constraint()$qenv %>% teal.code::eval_code(
        code = bquote({
          ANL_x <- ANL %>% # nolint
            dplyr::filter(.data[[.(param_var)]] == .(input$xaxis_param) & !is.na(.data[[.(input$xaxis_var)]]))
        })
      )

      if (input$xaxis_var == "BASE") {
        qenv <- qenv %>% within({
          ANL_x <- ANL_x |> # nolint
            dplyr::group_by(.data[["USUBJID"]]) %>%
            dplyr::mutate(LOQFL = .data[["LOQFL"]][.data[["AVISITCD"]] == "BL"]) %>%
            dplyr::ungroup()
        })
      } else if (input$xaxis_var != "AVAL") {
        qenv <- qenv %>% within({
          ANL_x <- ANL_x |> # nolint
            dplyr::mutate(LOQFL = "N")
        })
      }

      qenv <- qenv %>% teal.code::eval_code(
        code = bquote({
          ANL_y <- ANL %>% # nolint
            dplyr::filter(.data[[.(param_var)]] == .(input$yaxis_param) & !is.na(.data[[.(input$yaxis_var)]]))
        })
      )

      if (input$yaxis_var == "BASE") {
        qenv <- qenv %>% within({
          ANL_y <- ANL_y |> # nolint
            dplyr::group_by(.data[["USUBJID"]]) %>%
            dplyr::mutate(LOQFL = .data[["LOQFL"]][.data[["AVISITCD"]] == "BL"]) %>%
            dplyr::ungroup()
        })
      } else if (input$yaxis_var != "AVAL") {
        qenv <- qenv %>% within({
          ANL_y <- ANL_y |> # nolint
            dplyr::mutate(LOQFL = "N")
        })
      }

      qenv <- qenv %>% teal.code::eval_code(
        code = bquote({
          ANL_TRANSPOSED <- dplyr::inner_join( # nolint
            ANL_x, ANL_y,
            by = c("USUBJID", "AVISITCD", .(trt_group)),
            suffix = .(sprintf("_%s", c(input$xaxis_param, input$yaxis_param)))
          )
          ANL_TRANSPOSED <- ANL_TRANSPOSED %>% # nolint
            dplyr::mutate(
              LOQFL_COMB = case_when(
                .data[[.(xloqfl())]] == "Y" | .data[[.(yloqfl())]] == "Y" ~ "Y",
                .data[[.(xloqfl())]] == "N" | .data[[.(yloqfl())]] == "N" ~ "N",
                TRUE ~ "NA"
              )
            )
        })
      )

      validate(need(nrow(qenv[["ANL_TRANSPOSED"]]) > 0, "Plot Data No Observations Left"))
      validate_has_variable(data = qenv[["ANL_TRANSPOSED"]], varname = c(xvar(), yvar(), xloqfl(), yloqfl()))

      qenv <- teal.code::eval_code(
        object = qenv,
        code =
          bquote(attr(ANL_TRANSPOSED[[.(trt_group)]], "label") <- attr(ANL[[.(trt_group)]], "label")) # nolint
      )
      return(list(ANL_TRANSPOSED = qenv[["ANL_TRANSPOSED"]], qenv = qenv))
    })

    plot_labels <- reactive({
      req(anl_constraint())
      ANL <- anl_constraint()$qenv[["ANL"]] # nolint

      xparam <- ANL$PARAM[ANL[[param_var]] == input$xaxis_param][1]
      yparam <- ANL$PARAM[ANL[[param_var]] == input$yaxis_param][1]

      # setup the x-axis label.  Combine the biomarker and the units (if available)
      if (is.null(ANL$AVALU) || all(ANL[["AVALU"]] == "")) {
        title_text <- paste(xparam, "and", yparam, "@ Visits")
        xaxis_lab <- paste(xparam, input$xaxis_var, "Values")
        yaxis_lab <- paste(yparam, input$yaxis_var, "Values")
      } else {
        xunit <- ANL$AVALU[ANL[[param_var]] == input$xaxis_param][1]
        yunit <- ANL$AVALU[ANL[[param_var]] == input$yaxis_param][1]

        title_text <- paste0(xparam, " (", xunit, ") and ", yparam, " (", yunit, ") @ Visits")
        xaxis_lab <- paste0(xparam, " (", xunit, ") ", input$xaxis_var, " Values")
        yaxis_lab <- paste0(yparam, " (", yunit, ") ", input$yaxis_var, " Values")
      }

      list(title_text = title_text, xaxis_lab = xaxis_lab, yaxis_lab = yaxis_lab)
    })

    horizontal_line <- srv_arbitrary_lines("hline_arb")
    vertical_line <- srv_arbitrary_lines("vline_arb")

    # plot
    plot_q <- debounce(reactive({
      req(plot_data_transpose())
      # nolint start
      xaxis_param <- input$xaxis_param
      xaxis_var <- input$xaxis_var
      yaxis_param <- input$yaxis_param
      yaxis_var <- input$yaxis_var
      xlim <- xrange_slider$value
      ylim <- yrange_slider$value
      font_size <- input$font_size
      dot_size <- input$dot_size
      reg_text_size <- input$reg_text_size
      hline_arb <- horizontal_line()$line_arb
      hline_arb_label <- horizontal_line()$line_arb_label
      hline_arb_color <- horizontal_line()$line_arb_color
      hline_vars <- if (length(input$hline_vars) == 0) {
        NULL
      } else {
        paste0(input$hline_vars, "_", yaxis_param)
      }
      vline_arb <- vertical_line()$line_arb
      vline_arb_label <- vertical_line()$line_arb_label
      vline_arb_color <- vertical_line()$line_arb_color
      vline_vars <- if (length(input$vline_vars) == 0) {
        NULL
      } else {
        paste0(input$vline_vars, "_", xaxis_param)
      }
      facet_ncol <- input$facet_ncol
      validate(need(
        is.na(facet_ncol) || (as.numeric(facet_ncol) > 0 && as.numeric(facet_ncol) %% 1 == 0),
        "Number of plots per row must be a positive integer"
      ))
      visit_facet <- input$visit_facet
      facet <- input$trt_facet
      reg_line <- input$reg_line
      loq_legend <- input$loq_legend
      rotate_xlab <- input$rotate_xlab
      # nolint end
      title_text <- plot_labels()$title_text
      xaxis_lab <- plot_labels()$xaxis_lab
      yaxis_lab <- plot_labels()$yaxis_lab
      validate(need(input$trt_group, "Please select a treatment variable"))
      trt_group <- input$trt_group

      teal.code::eval_code(
        object = plot_data_transpose()$qenv,
        code = bquote({
          # re-establish treatment variable label
          p <- goshawk::g_correlationplot(
            data = ANL_TRANSPOSED,
            param_var = .(param_var),
            xaxis_param = .(xaxis_param),
            xaxis_var = .(xaxis_var),
            xvar = .(xvar()),
            yaxis_param = .(yaxis_param),
            yaxis_var = .(yaxis_var),
            yvar = .(yvar()),
            trt_group = .(trt_group),
            xlim = .(xlim),
            ylim = .(ylim),
            title_text = .(title_text),
            xaxis_lab = .(xaxis_lab),
            yaxis_lab = .(yaxis_lab),
            color_manual = .(color_manual),
            shape_manual = .(shape_manual),
            facet_ncol = .(facet_ncol),
            visit_facet = .(visit_facet),
            facet = .(facet),
            facet_var = .(trt_group),
            reg_line = .(reg_line),
            font_size = .(font_size),
            dot_size = .(dot_size),
            reg_text_size = .(reg_text_size),
            loq_legend = .(loq_legend),
            rotate_xlab = .(rotate_xlab),
            hline_arb = .(hline_arb),
            hline_arb_label = .(hline_arb_label),
            hline_arb_color = .(hline_arb_color),
            hline_vars = .(hline_vars),
            hline_vars_colors = .(hline_vars_colors[seq_along(hline_vars)]),
            hline_vars_labels = .(paste(hline_vars_labels[seq_along(hline_vars)], "-", yaxis_param)),
            vline_arb = .(vline_arb),
            vline_arb_label = .(vline_arb_label),
            vline_arb_color = .(vline_arb_color),
            vline_vars = .(vline_vars),
            vline_vars_colors = .(vline_vars_colors[seq_along(vline_vars)]),
            vline_vars_labels = .(paste(vline_vars_labels[seq_along(vline_vars)], "-", xaxis_param))
          )
          print(p)
        })
      )
    }), 800)

    plot_r <- reactive(plot_q()[["p"]])

    plot_data <- teal.widgets::plot_with_settings_srv(
      id = "plot",
      plot_r = plot_r,
      height = plot_height,
      width = plot_width,
      brushing = TRUE
    )

    code <- reactive(teal.code::get_code(plot_q()))

    ### REPORTER
    if (with_reporter) {
      card_fun <- function(comment, label) {
        constraint_description <- paste(
          "\nTreatment Variable Faceting:",
          input$trt_facet,
          "\nRegression Line:",
          input$reg_line
        )
        card <- report_card_template_goshawk(
          title = "Correlation Plot",
          label = label,
          with_filter = with_filter,
          filter_panel_api = filter_panel_api,
          constraint_list = list(
            constraint_var = input$constraint_var,
            constraint_range_min = input$constraint_range_min,
            constraint_range_max = input$constraint_range_max
          ),
          constraint_description = constraint_description,
          style = "verbatim"
        )
        card$append_text("Plot", "header3")
        card$append_plot(plot_r(), dim = plot_data$dim())
        if (!comment == "") {
          card$append_text("Comment", "header3")
          card$append_text(comment)
        }
        card$append_src(code())
        card
      }
      teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
    }
    ###

    reactive_df <- debounce(reactive({
      req(iv_r()$is_valid())
      plot_brush <- plot_data$brush()

      ANL_TRANSPOSED <- isolate(plot_data_transpose()$ANL_TRANSPOSED) # nolint

      df <- teal.widgets::clean_brushedPoints(
        dplyr::select(
          ANL_TRANSPOSED, "USUBJID", dplyr::all_of(input$trt_group), "AVISITCD",
          dplyr::all_of(c(xvar(), yvar())), "LOQFL_COMB"
        ),
        plot_brush
      )
    }), 800)

    # highlight plot area
    output$brush_data <- DT::renderDataTable({
      numeric_cols <- names(dplyr::select_if(reactive_df(), is.numeric))

      DT::datatable(reactive_df(),
        rownames = FALSE, options = list(scrollX = TRUE)
      ) %>%
        DT::formatRound(numeric_cols, 4)
    })

    teal.widgets::verbatim_popup_srv(
      id = "rcode",
      verbatim_content = reactive(code()),
      title = "Show R Code for Correlation Plot"
    )
  })
}

#' Box Plot
#'
#' This teal module renders the UI and calls the functions that create a box plot and accompanying
#' summary table.
#'
#' @param label menu item label of the module in the teal app.
#' @param dataname analysis data passed to the data argument of \code{\link[teal]{init}}. E.g. `ADaM` structured
#'  laboratory data frame `ALB`.
#' @param param_var name of variable containing biomarker codes e.g. `PARAMCD`.
#' @param param list of biomarkers of interest.
#' @param yaxis_var name of variable containing biomarker results displayed on y-axis e.g. `AVAL`. When not provided,
#' it defaults to `choices_selected(c("AVAL", "CHG"), "AVAL")`.
#' @param xaxis_var variable to categorize the x-axis. When not provided, it defaults to
#' `choices_selected("AVISITCD", "AVISITCD")`.
#' @param facet_var variable to facet the plots by. When not provided, it defaults to
#' `choices_selected(c("ARM", "ACTARM"), "ARM")`.
#' @param trt_group  \code{\link[teal.transform]{choices_selected}} object with available choices and pre-selected
#'  option for variable names representing treatment group e.g. `ARM`.
#' @param color_manual vector of colors applied to treatment values.
#' @param shape_manual vector of symbols applied to `LOQ` values.
#' @param facet_ncol numeric value indicating number of facets per row.
#' @param loq_legend `loq` legend toggle.
#' @param rotate_xlab 45 degree rotation of `x-axis` values.
#' @param hline_arb numeric vector of at most 2 values identifying intercepts for arbitrary horizontal lines.
#' @param hline_arb_color a character vector of at most length of \code{hline_arb}.
#' naming the color for the arbitrary horizontal lines.
#' @param hline_arb_label a character vector of at most length of \code{hline_arb}.
#' naming the label for the arbitrary horizontal lines.
#' @param hline_vars a character vector to name the columns that will define additional horizontal lines.
#' @param hline_vars_colors a character vector naming the colors for the additional horizontal lines.
#' @param hline_vars_labels a character vector naming the labels for the additional horizontal lines that will appear
#'  in the legend.
#' @param plot_height controls plot height.
#' @param plot_width optional, controls plot width.
#' @param font_size font size control for title, `x-axis` label, `y-axis` label and legend.
#' @param dot_size plot dot size.
#' @param alpha numeric vector to define transparency of plotted points.
#'
#' @inheritParams teal.widgets::standard_layout
#'
#' @author Jeff Tomlinson (tomlinsj) jeffrey.tomlinson@roche.com
#' @author Balazs Toth (tothb2) toth.balazs@gene.com
#'
#' @return an \code{\link[teal]{module}} object
#'
#' @export
#'
#' @examplesIf require("nestcolor")
#' # Example using ADaM structure analysis dataset.
#' data <- teal_data()
#' data <- within(data, {
#'   library(dplyr)
#'   library(nestcolor)
#'   library(stringr)
#'
#'   # use non-exported function from goshawk
#'   h_identify_loq_values <- getFromNamespace("h_identify_loq_values", "goshawk")
#'
#'   # original ARM value = dose value
#'   arm_mapping <- list(
#'     "A: Drug X" = "150mg QD",
#'     "B: Placebo" = "Placebo",
#'     "C: Combination" = "Combination"
#'   )
#'   set.seed(1)
#'   ADSL <- rADSL
#'   ADLB <- rADLB
#'   var_labels <- lapply(ADLB, function(x) attributes(x)$label)
#'   ADLB <- ADLB %>%
#'     mutate(
#'       AVISITCD = case_when(
#'         AVISIT == "SCREENING" ~ "SCR",
#'         AVISIT == "BASELINE" ~ "BL",
#'         grepl("WEEK", AVISIT) ~ paste("W", str_extract(AVISIT, "(?<=(WEEK ))[0-9]+")),
#'         TRUE ~ as.character(NA)
#'       ),
#'       AVISITCDN = case_when(
#'         AVISITCD == "SCR" ~ -2,
#'         AVISITCD == "BL" ~ 0,
#'         grepl("W", AVISITCD) ~ as.numeric(gsub("[^0-9]*", "", AVISITCD)),
#'         TRUE ~ as.numeric(NA)
#'       ),
#'       AVISITCD = factor(AVISITCD) %>% reorder(AVISITCDN),
#'       TRTORD = case_when(
#'         ARMCD == "ARM C" ~ 1,
#'         ARMCD == "ARM B" ~ 2,
#'         ARMCD == "ARM A" ~ 3
#'       ),
#'       ARM = as.character(arm_mapping[match(ARM, names(arm_mapping))]),
#'       ARM = factor(ARM) %>% reorder(TRTORD),
#'       ACTARM = as.character(arm_mapping[match(ACTARM, names(arm_mapping))]),
#'       ACTARM = factor(ACTARM) %>% reorder(TRTORD),
#'       ANRLO = 50,
#'       ANRHI = 75
#'     ) %>%
#'     rowwise() %>%
#'     group_by(PARAMCD) %>%
#'     mutate(LBSTRESC = ifelse(
#'       USUBJID %in% sample(USUBJID, 1, replace = TRUE),
#'       paste("<", round(runif(1, min = 25, max = 30))), LBSTRESC
#'     )) %>%
#'     mutate(LBSTRESC = ifelse(
#'       USUBJID %in% sample(USUBJID, 1, replace = TRUE),
#'       paste(">", round(runif(1, min = 70, max = 75))), LBSTRESC
#'     )) %>%
#'     ungroup()
#'
#'   attr(ADLB[["ARM"]], "label") <- var_labels[["ARM"]]
#'   attr(ADLB[["ACTARM"]], "label") <- var_labels[["ACTARM"]]
#'   attr(ADLB[["ANRLO"]], "label") <- "Analysis Normal Range Lower Limit"
#'   attr(ADLB[["ANRHI"]], "label") <- "Analysis Normal Range Upper Limit"
#'
#'   # add LLOQ and ULOQ variables
#'   ALB_LOQS <- h_identify_loq_values(ADLB, "LOQFL")
#'   ADLB <- left_join(ADLB, ALB_LOQS, by = "PARAM")
#' })
#'
#' datanames <- c("ADSL", "ADLB")
#' datanames(data) <- datanames
#'
#' join_keys(data) <- default_cdisc_join_keys[datanames]
#'
#' app <- init(
#'   data = data,
#'   modules = modules(
#'     tm_g_gh_boxplot(
#'       label = "Box Plot",
#'       dataname = "ADLB",
#'       param_var = "PARAMCD",
#'       param = choices_selected(c("ALT", "CRP", "IGA"), "ALT"),
#'       yaxis_var = choices_selected(c("AVAL", "BASE", "CHG"), "AVAL"),
#'       xaxis_var = choices_selected(c("ACTARM", "ARM", "AVISITCD", "STUDYID"), "ARM"),
#'       facet_var = choices_selected(c("ACTARM", "ARM", "AVISITCD", "SEX"), "AVISITCD"),
#'       trt_group = choices_selected(c("ARM", "ACTARM"), "ARM"),
#'       loq_legend = TRUE,
#'       rotate_xlab = FALSE,
#'       hline_arb = c(60, 55),
#'       hline_arb_color = c("grey", "red"),
#'       hline_arb_label = c("default_hori_A", "default_hori_B"),
#'       hline_vars = c("ANRHI", "ANRLO", "ULOQN", "LLOQN"),
#'       hline_vars_colors = c("pink", "brown", "purple", "black"),
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
tm_g_gh_boxplot <- function(label,
                            dataname,
                            param_var,
                            param,
                            yaxis_var = teal.transform::choices_selected(c("AVAL", "CHG"), "AVAL"),
                            xaxis_var = teal.transform::choices_selected("AVISITCD", "AVISITCD"),
                            facet_var = teal.transform::choices_selected(c("ARM", "ACTARM"), "ARM"),
                            trt_group,
                            color_manual = NULL,
                            shape_manual = NULL,
                            facet_ncol = NULL,
                            loq_legend = TRUE,
                            rotate_xlab = FALSE,
                            hline_arb = numeric(0),
                            hline_arb_color = "red",
                            hline_arb_label = "Horizontal line",
                            hline_vars = character(0),
                            hline_vars_colors = "green",
                            hline_vars_labels = hline_vars,
                            plot_height = c(600, 200, 2000),
                            plot_width = NULL,
                            font_size = c(12, 8, 20),
                            dot_size = c(2, 1, 12),
                            alpha = c(0.8, 0.0, 1.0),
                            pre_output = NULL,
                            post_output = NULL) {
  message("Initializing tm_g_gh_boxplot")
  checkmate::assert_string(label)
  checkmate::assert_string(dataname)
  checkmate::assert_string(param_var)
  checkmate::assert_class(param, "choices_selected")
  checkmate::assert_class(yaxis_var, "choices_selected")
  checkmate::assert_class(xaxis_var, "choices_selected")
  checkmate::assert_class(facet_var, "choices_selected")
  checkmate::assert_class(trt_group, "choices_selected")
  checkmate::assert_int(facet_ncol, null.ok = TRUE)
  checkmate::assert_flag(loq_legend)
  checkmate::assert_flag(rotate_xlab)
  checkmate::assert_numeric(font_size, len = 3)
  checkmate::assert_numeric(dot_size, len = 3)
  checkmate::assert_numeric(alpha, len = 3)
  validate_line_arb_arg(hline_arb, hline_arb_color, hline_arb_label)
  validate_line_vars_arg(hline_vars, hline_vars_colors, hline_vars_labels)
  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 = dataname,
    server = srv_g_boxplot,
    server_args = list(
      dataname = dataname,
      param_var = param_var,
      color_manual = color_manual,
      shape_manual = shape_manual,
      plot_height = plot_height,
      plot_width = plot_width,
      hline_vars_colors = hline_vars_colors,
      hline_vars_labels = hline_vars_labels,
      module_args = args
    ),
    ui = ui_g_boxplot,
    ui_args = args
  )
}

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

  teal.widgets::standard_layout(
    output = tags$div(
      fluidRow(
        teal.widgets::plot_with_settings_ui(id = ns("boxplot"))
      ),
      fluidRow(column(
        width = 12,
        tags$br(), tags$hr(),
        tags$h4("Selected Data Points"),
        DT::dataTableOutput(ns("brush_data"))
      )),
      fluidRow(column(
        width = 12,
        tags$br(), tags$hr(),
        tags$h4("Descriptive Statistics"),
        DT::dataTableOutput(ns("table_ui"))
      ))
    ),
    encoding = tags$div(
      ### Reporter
      teal.reporter::simple_reporter_ui(ns("simple_reporter")),
      ###
      templ_ui_dataname(a$dataname),
      uiOutput(ns("axis_selections")),
      templ_ui_constraint(ns, label = "Data Constraint"), # required by constr_anl_q
      if (length(a$hline_vars) > 0) {
        teal.widgets::optionalSelectInput(
          ns("hline_vars"),
          label = "Add Horizontal Range Line(s):",
          choices = a$hline_vars,
          selected = NULL,
          multiple = TRUE
        )
      },
      ui_arbitrary_lines(id = ns("hline_arb"), a$hline_arb, a$hline_arb_label, a$hline_arb_color),
      teal.widgets::panel_group(
        teal.widgets::panel_item(
          title = "Plot Aesthetic Settings",
          toggle_slider_ui(
            ns("yrange_scale"),
            label = "Y-Axis Range Zoom"
          ),
          numericInput(ns("facet_ncol"), "Number of Plots Per Row:", a$facet_ncol, min = 1),
          checkboxInput(ns("loq_legend"), "Display LoQ Legend", a$loq_legend),
          checkboxInput(ns("rotate_xlab"), "Rotate X-axis Label", a$rotate_xlab)
        ),
        teal.widgets::panel_item(
          title = "Plot settings",
          teal.widgets::optionalSliderInputValMinMax(ns("font_size"), "Font Size", a$font_size, ticks = FALSE),
          teal.widgets::optionalSliderInputValMinMax(ns("dot_size"), "Dot Size", a$dot_size, ticks = FALSE),
          teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Dot Alpha", a$alpha, ticks = FALSE)
        )
      )
    ),
    forms = tagList(
      teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
    ),
    pre_output = a$pre_output,
    post_output = a$post_output
  )
}


srv_g_boxplot <- function(id,
                          data,
                          reporter,
                          filter_panel_api,
                          dataname,
                          param_var,
                          trt_group,
                          color_manual,
                          shape_manual,
                          plot_height,
                          plot_width,
                          hline_vars_colors,
                          hline_vars_labels,
                          module_args) {
  with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
  with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
  checkmate::assert_class(data, "reactive")
  checkmate::assert_class(shiny::isolate(data()), "teal_data")

  moduleServer(id, function(input, output, session) {
    teal.logger::log_shiny_input_changes(input, namespace = "teal.goshawk")
    output$axis_selections <- renderUI({
      env <- shiny::isolate(as.list(data()@env))
      resolved_x <- teal.transform::resolve_delayed(module_args$xaxis_var, env)
      resolved_y <- teal.transform::resolve_delayed(module_args$yaxis_var, env)
      resolved_param <- teal.transform::resolve_delayed(module_args$param, env)
      resolved_facet_var <- teal.transform::resolve_delayed(module_args$facet_var, env)
      resolved_trt <- teal.transform::resolve_delayed(module_args$trt_group, env)

      templ_ui_params_vars(
        session$ns,
        xparam_choices = resolved_param$choices,
        xparam_selected = resolved_param$selected,
        xparam_label = module_args$"Select a Biomarker",
        xchoices = resolved_x$choices,
        xselected = resolved_x$selected,
        ychoices = resolved_y$choices,
        yselected = resolved_y$selected,
        facet_choices = resolved_facet_var$choices,
        facet_selected = resolved_facet_var$selected,
        trt_choices = resolved_trt$choices,
        trt_selected = resolved_trt$selected
      )
    })
    # reused in all modules
    anl_q_output <- constr_anl_q(
      session, input, data, dataname,
      param_id = "xaxis_param", param_var = param_var, trt_group = input$trt_group, min_rows = 2
    )

    anl_q <- anl_q_output()$value

    # update sliders for axes taking constraints into account
    data_state <- reactive({
      get_data_range_states(
        varname = input$yaxis_var,
        paramname = input$xaxis_param,
        ANL = anl_q()$ANL
      )
    })
    yrange_slider_state <- toggle_slider_server("yrange_scale", data_state)
    keep_data_const_opts_updated(session, input, anl_q, "xaxis_param")

    horizontal_line <- srv_arbitrary_lines("hline_arb")

    trt_group <- reactive({
      input$trt_group
    })

    iv_r <- reactive({
      iv <- shinyvalidate::InputValidator$new()

      iv$add_rule("xaxis_param", shinyvalidate::sv_required("Please select a biomarker"))
      iv$add_rule("trt_group", shinyvalidate::sv_required("Please select a treatment variable"))
      iv$add_rule("xaxis_var", shinyvalidate::sv_required("Please select an X-Axis variable"))
      iv$add_rule("xaxis_var", ~ if ((.) %in% c("ACTARM", "ARM") && isTRUE((.) != trt_group())) {
        sprintf("You can not choose %s as x-axis variable for treatment variable %s.", (.), trt_group())
      })
      iv$add_rule("yaxis_var", shinyvalidate::sv_required("Please select a Y-Axis variable"))

      iv$add_rule("facet_var", shinyvalidate::sv_optional())
      iv$add_rule("facet_var", ~ if ((.) %in% c("ACTARM", "ARM") && isTRUE((.) != trt_group())) {
        sprintf("You can not choose %s as faceting variable for treatment variable %s.", (.), trt_group())
      })

      iv_facet <- shinyvalidate::InputValidator$new()
      iv_facet$condition(~ !is.null(input$facet_var))
      iv_facet$add_rule("facet_ncol", plots_per_row_validate_rules(required = FALSE))
      iv$add_validator(iv_facet)

      iv$add_validator(horizontal_line()$iv_r())
      iv$add_validator(anl_q_output()$iv_r())
      iv$enable()
      iv
    })

    create_plot <- debounce(reactive({
      teal::validate_inputs(iv_r())

      req(anl_q())
      # nolint start
      param <- input$xaxis_param
      yaxis <- input$yaxis_var
      xaxis <- input$xaxis_var
      facet_var <- `if`(is.null(input$facet_var), "None", input$facet_var)
      ylim <- yrange_slider_state$value
      facet_ncol <- input$facet_ncol

      alpha <- input$alpha
      font_size <- input$font_size
      dot_size <- input$dot_size
      loq_legend <- input$loq_legend
      rotate_xlab <- input$rotate_xlab

      hline_arb <- horizontal_line()$line_arb
      hline_arb_label <- horizontal_line()$line_arb_label
      hline_arb_color <- horizontal_line()$line_arb_color

      hline_vars <- input$hline_vars
      trt_group <- input$trt_group
      # nolint end

      validate_has_variable(
        anl_q()$ANL,
        yaxis,
        sprintf("Variable %s is not available in data %s", yaxis, dataname)
      )
      validate_has_variable(
        anl_q()$ANL,
        xaxis,
        sprintf("Variable %s is not available in data %s", xaxis, dataname)
      )

      if (!facet_var == "None") {
        validate_has_variable(
          anl_q()$ANL,
          facet_var,
          sprintf("Variable %s is not available in data %s", facet_var, dataname)
        )
      }

      anl_q()$qenv %>% teal.code::eval_code(
        code = bquote({
          p <- goshawk::g_boxplot(
            data = ANL,
            biomarker = .(param),
            xaxis_var = .(xaxis),
            yaxis_var = .(yaxis),
            hline_arb = .(hline_arb),
            hline_arb_label = .(hline_arb_label),
            hline_arb_color = .(hline_arb_color),
            hline_vars = .(hline_vars),
            hline_vars_colors = .(hline_vars_colors[seq_along(hline_vars)]),
            hline_vars_labels = .(hline_vars_labels[seq_along(hline_vars)]),
            facet_ncol = .(facet_ncol),
            loq_legend = .(loq_legend),
            rotate_xlab = .(rotate_xlab),
            trt_group = .(trt_group),
            ylim = .(ylim),
            color_manual = .(color_manual),
            shape_manual = .(shape_manual),
            facet_var = .(facet_var),
            alpha = .(alpha),
            dot_size = .(dot_size),
            font_size = .(font_size),
            unit = .("AVALU")
          )
          print(p)
        })
      )
    }), 800)

    create_table <- debounce(reactive({
      req(iv_r()$is_valid())
      req(anl_q())
      param <- input$xaxis_param
      xaxis_var <- input$yaxis_var # nolint
      font_size <- input$font_size
      trt_group <- input$trt_group
      facet_var <- input$facet_var

      anl_q()$qenv %>% teal.code::eval_code(
        code = bquote({
          tbl <- goshawk::t_summarytable(
            data = ANL,
            trt_group = .(trt_group),
            param_var = .(param_var),
            param = .(param),
            xaxis_var = .(xaxis_var),
            facet_var = .(facet_var)
          )
          tbl
        })
      )
    }), 800)

    plot_r <- reactive({
      create_plot()[["p"]]
    })

    boxplot_data <- teal.widgets::plot_with_settings_srv(
      id = "boxplot",
      plot_r = plot_r,
      height = plot_height,
      width = plot_width,
      brushing = TRUE
    )

    output$table_ui <- DT::renderDataTable({
      req(create_table())
      tbl <- create_table()[["tbl"]]

      numeric_cols <- setdiff(names(dplyr::select_if(tbl, is.numeric)), "n")

      DT::datatable(tbl,
        rownames = FALSE, options = list(scrollX = TRUE)
      ) %>%
        DT::formatRound(numeric_cols, 4)
    })

    joined_qenvs <- reactive({
      req(create_plot(), create_table())
      teal.code::join(create_plot(), create_table())
    })

    code <- reactive(teal.code::get_code(joined_qenvs()))

    ### REPORTER
    if (with_reporter) {
      card_fun <- function(comment, label) {
        constraint_description <- paste(
          "\nFacet By:",
          if (length(input$facet_var) != 0) input$facet_var else "None",
          "\nSelect an X-axis Variable:",
          input$xaxis_var
        )
        card <- report_card_template_goshawk(
          title = "Box Plot",
          label = label,
          with_filter = with_filter,
          filter_panel_api = filter_panel_api,
          constraint_list = list(
            constraint_var = input$constraint_var,
            constraint_range_min = input$constraint_range_min,
            constraint_range_max = input$constraint_range_max
          ),
          constraint_description = constraint_description,
          style = "verbatim"
        )
        card$append_text("Plot", "header3")
        card$append_plot(plot_r(), dim = boxplot_data$dim())
        if (!comment == "") {
          card$append_text("Comment", "header3")
          card$append_text(comment)
        }
        card$append_src(code())
        card
      }
      teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
    }
    ###

    # highlight plot area
    reactive_df <- debounce(reactive({
      boxplot_brush <- boxplot_data$brush()

      ANL <- isolate(anl_q()$ANL) %>% droplevels() # nolint
      validate_has_data(ANL, 2)

      xvar <- isolate(input$xaxis_var)
      yvar <- isolate(input$yaxis_var)
      facetv <- isolate(input$facet_var)
      trt_group <- isolate(input$trt_group)

      req(all(c(xvar, yvar, facetv, trt_group) %in% names(ANL)))

      teal.widgets::clean_brushedPoints(
        dplyr::select(
          ANL, "USUBJID", dplyr::all_of(c(trt_group, facetv)),
          "AVISITCD", "PARAMCD", dplyr::all_of(c(xvar, yvar)), "LOQFL"
        ),
        boxplot_brush
      )
    }), 800)

    output$brush_data <- DT::renderDataTable({
      numeric_cols <- names(dplyr::select_if(reactive_df(), is.numeric))

      DT::datatable(reactive_df(),
        rownames = FALSE, options = list(scrollX = TRUE)
      ) %>%
        DT::formatRound(numeric_cols, 4)
    })

    teal.widgets::verbatim_popup_srv(
      id = "rcode",
      verbatim_content = reactive(code()),
      title = "Show R Code for Boxplot"
    )
  })
}

#' Scatter Plot Teal Module For Biomarker Analysis
#'
#' @description
#' `r lifecycle::badge("deprecated")`
#'
#'  `tm_g_gh_scatterplot` is deprecated. Please use [tm_g_gh_correlationplot]
#'   instead.
#'
#' @inheritParams teal.widgets::standard_layout
#' @param label menu item label of the module in the teal app.
#' @param dataname analysis data passed to the data argument of \code{\link[teal]{init}}. E.g. `ADaM` structured
#' laboratory data frame \code{ADLB}.
#' @param param_var name of variable containing biomarker codes e.g. \code{PARAMCD}.
#' @param param biomarker selected.
#' @param xaxis_var name of variable containing biomarker results displayed on `x-axis` e.g. \code{BASE}.
#' @param yaxis_var name of variable containing biomarker results displayed on `y-axis` e.g. \code{AVAL}.
#' @param trt_group \code{\link[teal.transform]{choices_selected}} object with available choices and pre-selected option
#' for variable names representing treatment group e.g. `ARM`.
#' @param color_manual vector of colors applied to treatment values.
#' @param shape_manual vector of symbols applied to `LOQ` values.
#' @param facet_ncol numeric value indicating number of facets per row.
#' @param trt_facet facet by treatment group \code{trt_group}.
#' @param reg_line include regression line and annotations for slope and coefficient in visualization. Use with facet
#'   TRUE.
#' @param rotate_xlab 45 degree rotation of `x-axis` values.
#' @param hline y-axis value to position of horizontal line.
#' @param vline x-axis value to position a vertical line.
#' @param plot_height controls plot height.
#' @param plot_width optional, controls plot width.
#' @param font_size font size control for title, `x-axis` label, `y-axis` label and legend.
#' @param dot_size plot dot size.
#' @param reg_text_size font size control for regression line annotations.
#'
#'
#' @export
#'
#' @author Nick Paszty (npaszty) paszty.nicholas@gene.com
#' @author Balazs Toth (tothb2)  toth.balazs@gene.com
#'
#' @examples
#' # Example using ADaM structure analysis dataset.
#' data <- teal_data()
#' data <- within(data, {
#'   library(dplyr)
#'   library(stringr)
#'
#'   # original ARM value = dose value
#'   arm_mapping <- list(
#'     "A: Drug X" = "150mg QD",
#'     "B: Placebo" = "Placebo",
#'     "C: Combination" = "Combination"
#'   )
#'
#'   ADSL <- rADSL
#'   ADLB <- rADLB
#'   var_labels <- lapply(ADLB, function(x) attributes(x)$label)
#'   ADLB <- ADLB %>%
#'     mutate(
#'       AVISITCD = case_when(
#'         AVISIT == "SCREENING" ~ "SCR",
#'         AVISIT == "BASELINE" ~ "BL",
#'         grepl("WEEK", AVISIT) ~ paste("W", str_extract(AVISIT, "(?<=(WEEK ))[0-9]+")),
#'         TRUE ~ as.character(NA)
#'       ),
#'       AVISITCDN = case_when(
#'         AVISITCD == "SCR" ~ -2,
#'         AVISITCD == "BL" ~ 0,
#'         grepl("W", AVISITCD) ~ as.numeric(gsub("[^0-9]*", "", AVISITCD)),
#'         TRUE ~ as.numeric(NA)
#'       ),
#'       AVISITCD = factor(AVISITCD) %>% reorder(AVISITCDN),
#'       TRTORD = case_when(
#'         ARMCD == "ARM C" ~ 1,
#'         ARMCD == "ARM B" ~ 2,
#'         ARMCD == "ARM A" ~ 3
#'       ),
#'       ARM = as.character(arm_mapping[match(ARM, names(arm_mapping))]),
#'       ARM = factor(ARM) %>% reorder(TRTORD),
#'       ACTARM = as.character(arm_mapping[match(ACTARM, names(arm_mapping))]),
#'       ACTARM = factor(ACTARM) %>% reorder(TRTORD)
#'     )
#'   attr(ADLB[["ARM"]], "label") <- var_labels[["ARM"]]
#'   attr(ADLB[["ACTARM"]], "label") <- var_labels[["ACTARM"]]
#' })
#'
#' datanames <- c("ADSL", "ADLB")
#' datanames(data) <- datanames
#' join_keys(data) <- default_cdisc_join_keys[datanames]
#'
#'
#' app <- init(
#'   data = data,
#'   modules = modules(
#'     tm_g_gh_scatterplot(
#'       label = "Scatter Plot",
#'       dataname = "ADLB",
#'       param_var = "PARAMCD",
#'       param = choices_selected(c("ALT", "CRP", "IGA"), "ALT"),
#'       xaxis_var = choices_selected(c("AVAL", "BASE", "CHG", "PCHG"), "BASE"),
#'       yaxis_var = choices_selected(c("AVAL", "BASE", "CHG", "PCHG"), "AVAL"),
#'       trt_group = choices_selected(c("ARM", "ACTARM"), "ARM"),
#'       color_manual = c(
#'         "150mg QD" = "#000000",
#'         "Placebo" = "#3498DB",
#'         "Combination" = "#E74C3C"
#'       ),
#'       shape_manual = c("N" = 1, "Y" = 2, "NA" = 0),
#'       plot_height = c(500, 200, 2000),
#'       facet_ncol = 2,
#'       trt_facet = FALSE,
#'       reg_line = FALSE,
#'       font_size = c(12, 8, 20),
#'       dot_size = c(1, 1, 12),
#'       reg_text_size = c(3, 3, 10)
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
tm_g_gh_scatterplot <- function(label,
                                dataname,
                                param_var,
                                param,
                                xaxis_var,
                                yaxis_var,
                                trt_group,
                                color_manual = NULL,
                                shape_manual = NULL,
                                facet_ncol = 2,
                                trt_facet = FALSE,
                                reg_line = FALSE,
                                rotate_xlab = FALSE,
                                hline = NULL,
                                vline = NULL,
                                plot_height = c(500, 200, 2000),
                                plot_width = NULL,
                                font_size = c(12, 8, 20),
                                dot_size = c(1, 1, 12),
                                reg_text_size = c(3, 3, 10),
                                pre_output = NULL,
                                post_output = NULL) {
  lifecycle::deprecate_soft(
    when = "0.1.15",
    what = "tm_g_gh_scatterplot()",
    details = "You should use teal.goshawk::tm_g_gh_correlationplot instead of teal.goshawk::tm_g_gh_scatterplot"
  )

  message("Initializing tm_g_gh_scatterplot")
  checkmate::assert_class(param, "choices_selected")
  checkmate::assert_class(xaxis_var, "choices_selected")
  checkmate::assert_class(yaxis_var, "choices_selected")
  checkmate::assert_class(trt_group, "choices_selected")
  checkmate::assert_flag(trt_facet)
  checkmate::assert_flag(reg_line)
  checkmate::assert_flag(rotate_xlab)
  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 = dataname,
    server = srv_g_scatterplot,
    server_args = list(
      dataname = dataname,
      param_var = param_var,
      trt_facet = trt_facet,
      color_manual = color_manual,
      shape_manual = shape_manual,
      plot_height = plot_height,
      plot_width = plot_width,
      module_args = args
    ),
    ui = ui_g_scatterplot,
    ui_args = args
  )
}

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

  teal.widgets::standard_layout(
    output = templ_ui_output_datatable(ns),
    encoding = tags$div(
      ### Reporter
      teal.reporter::simple_reporter_ui(ns("simple_reporter")),
      ###
      templ_ui_dataname(a$dataname),
      uiOutput(ns("axis_selections")),
      templ_ui_constraint(ns), # required by constr_anl_q
      teal.widgets::panel_group(
        teal.widgets::panel_item(
          title = "Plot Aesthetic Settings",
          toggle_slider_ui(
            ns("xrange_scale"),
            label = "X-Axis Range Zoom"
          ),
          toggle_slider_ui(
            ns("yrange_scale"),
            label = "Y-Axis Range Zoom"
          ),
          numericInput(ns("facet_ncol"), "Number of Plots Per Row:", a$facet_ncol, min = 1),
          checkboxInput(ns("trt_facet"), "Treatment Variable Faceting", a$trt_facet),
          checkboxInput(ns("reg_line"), "Regression Line", a$reg_line),
          checkboxInput(ns("rotate_xlab"), "Rotate X-axis Label", a$rotate_xlab),
          numericInput(ns("hline"), "Add a horizontal line:", a$hline),
          numericInput(ns("vline"), "Add a vertical line:", a$vline)
        ),
        teal.widgets::panel_item(
          title = "Plot settings",
          teal.widgets::optionalSliderInputValMinMax(ns("font_size"), "Font Size", a$font_size, ticks = FALSE),
          teal.widgets::optionalSliderInputValMinMax(ns("dot_size"), "Dot Size", a$dot_size, ticks = FALSE),
          teal.widgets::optionalSliderInputValMinMax(
            ns("reg_text_size"),
            "Regression Annotations Size",
            a$reg_text_size,
            ticks = FALSE
          )
        )
      )
    ),
    forms = tagList(
      teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
    ),
    pre_output = a$pre_output,
    post_output = a$post_output
  )
}

srv_g_scatterplot <- function(id,
                              data,
                              reporter,
                              filter_panel_api,
                              dataname,
                              param_var,
                              trt_group,
                              trt_facet,
                              color_manual,
                              shape_manual,
                              plot_height,
                              plot_width,
                              module_args) {
  with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
  with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
  checkmate::assert_class(data, "reactive")
  checkmate::assert_class(shiny::isolate(data()), "teal_data")

  moduleServer(id, function(input, output, session) {
    teal.logger::log_shiny_input_changes(input, namespace = "teal.goshawk")
    output$axis_selections <- renderUI({
      env <- shiny::isolate(as.list(data()@env))
      resolved_x <- teal.transform::resolve_delayed(module_args$xaxis_var, env)
      resolved_y <- teal.transform::resolve_delayed(module_args$yaxis_var, env)
      resolved_param <- teal.transform::resolve_delayed(module_args$param, env)
      resolved_trt <- teal.transform::resolve_delayed(module_args$trt_group, env)
      templ_ui_params_vars(
        session$ns,
        # xparam and yparam are identical, so we only show the user one
        xparam_choices = resolved_param$choices,
        xparam_selected = resolved_param$selected,
        xparam_label = "Select a Biomarker",
        xchoices = resolved_x$choices,
        xselected = resolved_x$selected,
        ychoices = resolved_y$choices,
        yselected = resolved_y$selected,
        trt_choices = resolved_trt$choices,
        trt_selected = resolved_trt$selected
      )
    })

    # reused in all modules
    anl_q_output <- constr_anl_q(
      session, input, data, dataname,
      param_id = "xaxis_param", param_var = param_var, trt_group = input$trt_group, min_rows = 1
    )

    anl_q <- anl_q_output()$value

    # update sliders for axes taking constraints into account
    data_state_x <- reactive({
      get_data_range_states(
        varname = input$xaxis_var,
        paramname = input$xaxis_param,
        ANL = anl_q()$ANL
      )
    })
    xrange_slider <- toggle_slider_server("xrange_scale", data_state_x)
    data_state_y <- reactive({
      get_data_range_states(
        varname = input$yaxis_var,
        paramname = input$xaxis_param,
        ANL = anl_q()$ANL
      )
    })
    yrange_slider <- toggle_slider_server("yrange_scale", data_state_y)

    keep_data_const_opts_updated(session, input, anl_q, "xaxis_param")

    # plot
    plot_q <- debounce(reactive({
      req(anl_q())
      # nolint start
      xlim <- xrange_slider$value
      ylim <- yrange_slider$value
      facet_ncol <- input$facet_ncol
      validate(need(
        is.na(facet_ncol) || (as.numeric(facet_ncol) > 0 && as.numeric(facet_ncol) %% 1 == 0),
        "Number of plots per row must be a positive integer"
      ))
      reg_line <- input$reg_line
      font_size <- input$font_size
      dot_size <- input$dot_size
      reg_text_size <- input$reg_text_size
      rotate_xlab <- input$rotate_xlab
      hline <- input$hline
      vline <- input$vline
      trt_group <- input$trt_group
      facet <- input$trt_facet
      validate(need(trt_group, "Please select a treatment variable"))

      # Below inputs should trigger plot via updates of other reactive objects (i.e. anl_q()) and some inputs
      validate(need(input$xaxis_var, "Please select an X-Axis Variable"))
      validate(need(input$yaxis_var, "Please select a Y-Axis Variable"))
      param <- input$xaxis_param
      xaxis <- input$xaxis_var
      yaxis <- input$yaxis_var

      # nolint end
      teal.code::eval_code(
        object = anl_q()$qenv,
        code = bquote({
          # re-establish treatment variable label
          p <- goshawk::g_scatterplot(
            data = ANL,
            param_var = .(param_var),
            param = .(param),
            xaxis_var = .(xaxis),
            yaxis_var = .(yaxis),
            trt_group = .(trt_group),
            xlim = .(xlim),
            ylim = .(ylim),
            color_manual = .(color_manual),
            shape_manual = .(shape_manual),
            facet_ncol = .(facet_ncol),
            facet = .(facet),
            facet_var = .(trt_group),
            reg_line = .(reg_line),
            font_size = .(font_size),
            dot_size = .(dot_size),
            reg_text_size = .(reg_text_size),
            rotate_xlab = .(rotate_xlab),
            hline = .(`if`(is.na(hline), NULL, as.numeric(hline))),
            vline = .(`if`(is.na(vline), NULL, as.numeric(vline)))
          )
          print(p)
        })
      )
    }), 800)

    plot_r <- reactive(plot_q()[["p"]])

    plot_data <- teal.widgets::plot_with_settings_srv(
      id = "plot",
      plot_r = plot_r,
      height = plot_height,
      width = plot_width,
      brushing = TRUE
    )

    code <- reactive(teal.code::get_code(plot_q()))

    ### REPORTER
    if (with_reporter) {
      card_fun <- function(comment, label) {
        constraint_description <- paste(
          "\nTreatment Variable Faceting:",
          input$trt_facet,
          "\nRegression Line:",
          input$reg_line
        )
        card <- report_card_template_goshawk(
          title = "Scatter Plot",
          label = label,
          with_filter = with_filter,
          filter_panel_api = filter_panel_api,
          constraint_list = list(
            constraint_var = input$constraint_var,
            constraint_range_min = input$constraint_range_min,
            constraint_range_max = input$constraint_range_max
          ),
          constraint_description = constraint_description,
          style = "verbatim"
        )
        card$append_text("Scatter Plot", "header3")
        card$append_plot(plot_r(), dim = plot_data$dim())
        if (!comment == "") {
          card$append_text("Comment", "header3")
          card$append_text(comment)
        }
        card$append_src(code())
        card
      }
      teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
    }
    ###

    reactive_df <- debounce(reactive({
      plot_brush <- plot_data$brush()

      ANL <- isolate(anl_q()$ANL) # nolint
      validate_has_data(ANL, 1)

      xvar <- isolate(input$xaxis_var)
      yvar <- isolate(input$yaxis_var)
      trt_group <- isolate(input$trt_group)

      req(all(c(xvar, yvar) %in% names(ANL)))

      teal.widgets::clean_brushedPoints(
        dplyr::select(
          ANL, "USUBJID", dplyr::all_of(trt_group), "AVISITCD", "PARAMCD",
          dplyr::all_of(c(xvar, yvar)), "LOQFL"
        ),
        plot_brush
      )
    }), 800)

    # highlight plot area
    output$brush_data <- DT::renderDataTable({
      numeric_cols <- names(dplyr::select_if(reactive_df(), is.numeric))

      DT::datatable(reactive_df(),
        rownames = FALSE, options = list(scrollX = TRUE)
      ) %>%
        DT::formatRound(numeric_cols, 4)
    })

    teal.widgets::verbatim_popup_srv(
      id = "rcode",
      verbatim_content = reactive(code()),
      title = "Show R Code for Scatterplot"
    )
  })
}

templ_ui_constraint <- function(ns, label = "Data Constraint") {
  tags$div(
    id = ns("constraint_var_whole"), # give an id to hide it
    radioButtons(ns("constraint_var"), label, choices = "NONE"),
    shinyjs::hidden(tags$div(
      id = ns("constraint_range"),
      tags$div(
        class = "inline-block;",
        numericInput(ns("constraint_range_min"), label = "Min", value = 0, min = 0, max = 0)
      ),
      tags$div(
        class = "inline-block;",
        numericInput(ns("constraint_range_max"), label = "Min", value = 0, min = 0, max = 0)
      )
    )),
    shinyjs::hidden(tags$div(
      id = ns("all_na"),
      helpText("All values are missing (NA)")
    ))
  )
}

keep_data_const_opts_updated <- function(session, input, data, id_param_var) {
  # use reactiveVal so that it only updates when options actually changed and not just data
  choices <- reactiveVal()
  observeEvent(data(), {
    paramname <- input[[id_param_var]]
    req(length(paramname) == 1)

    data_filtered <- data()$ANL %>% dplyr::filter(.data$PARAMCD == paramname)
    choices(c("None" = "NONE", "Screening" = "BASE2", "Baseline" = "BASE")[
      c(TRUE, !all(is.na(data_filtered[["BASE2"]])), !all(is.na(data_filtered[["BASE"]])))
    ])
  })
  observeEvent(choices(), {
    updateRadioButtons(session, "constraint_var", choices = choices())
    # hide when only one option "NONE"
    if (length(choices()) == 1) {
      shinyjs::hide("constraint_var_whole")
    } else {
      shinyjs::show("constraint_var_whole")
    }
  })
}




# param_id: input id that contains values of PARAMCD to filter for
# param_var: currently only "PARAMCD" is supported
constr_anl_q <- function(session, input, data, dataname, param_id, param_var, trt_group, min_rows) {
  checkmate::assert_class(data, "reactive")
  checkmate::assert_class(shiny::isolate(data()), "teal_data")
  dataset_var <- dataname
  if (!identical(param_var, "PARAMCD")) {
    # why is there a variable param_id which is provided to this function and always equal to "param"?
    stop("param_var must be 'PARAMCD'. Otherwise, we cannot currently guarantee the correctness of the code.")
  }

  anl_param <- reactive({
    param_var_value <- input[[param_id]] # value to filter PARAMCD for
    validate(need(param_var_value, "Please select a biomarker"))
    checkmate::assert_string(param_var_value)

    ANL <- data()[[dataname]] # nolint
    validate_has_data(ANL, min_rows)

    validate_has_variable(ANL, param_var)
    validate_has_variable(ANL, "AVISITCD")
    validate_has_variable(ANL, "BASE")
    validate_has_variable(ANL, "BASE2")
    validate_has_variable(ANL, trt_group)

    # analysis
    private_qenv <- data() %>%
      teal.code::eval_code(
        substitute(ANL <- dataname, list(dataname = as.name(dataname))) # nolint
      ) %>%
      teal.code::eval_code(
        code = bquote({
          ANL <- .(as.name(dataset_var)) %>% # nolint
            dplyr::filter(.(as.name(param_var)) == .(param_var_value))
        })
      )
    validate_has_data(private_qenv[["ANL"]], min_rows)
    list(ANL = ANL, qenv = private_qenv)
  })

  observe({
    param_var_value <- input[[param_id]]
    validate(need(param_var_value, "Please select a biomarker"))

    constraint_var <- input[["constraint_var"]]
    validate(need(constraint_var, "select a constraint variable"))

    ANL <- data()[[dataname]] # nolint
    validate_has_data(ANL, min_rows)

    validate_has_variable(ANL, param_var)
    validate_has_variable(ANL, "AVISITCD")
    validate_has_variable(ANL, "BASE")
    validate_has_variable(ANL, "BASE2")

    ANL <- ANL %>% dplyr::filter(!!sym(param_var) == param_var_value) # nolint

    visit_freq <- unique(ANL$AVISITCD)

    # get min max values
    if ((constraint_var == "BASE2" && any(grepl("SCR", visit_freq))) ||
      (constraint_var == "BASE" && any(grepl("BL", visit_freq)))) { # nolint
      val <- stats::na.omit(switch(constraint_var,
        "BASE" = ANL$BASE[ANL$AVISITCD == "BL"],
        "BASE2" = ANL$BASE2[ANL$AVISITCD == "SCR"],
        stop(paste(constraint_var, "not allowed"))
      ))

      if (length(val) == 0 || all(is.na(val))) {
        shinyjs::show("all_na")
        shinyjs::hide("constraint_range")
        args <- list(
          min = list(label = "Min", min = 0, max = 0, value = 0),
          max = list(label = "Max", min = 0, max = 0, value = 0)
        )
        update_min_max(session, args)
      } else {
        rng <- range(val, na.rm = TRUE)

        minmax <- c(floor(rng[1] * 1000) / 1000, ceiling(rng[2] * 1000) / 1000)

        label_min <- sprintf("Min (%s)", minmax[1])
        label_max <- sprintf("Max (%s)", minmax[2])

        args <- list(
          min = list(label = label_min, min = minmax[1], max = minmax[2], value = minmax[1]),
          max = list(label = label_max, min = minmax[1], max = minmax[2], value = minmax[2])
        )

        update_min_max(session, args)
        shinyjs::show("constraint_range") # update before show
        shinyjs::hide("all_na")
      }
    } else if (constraint_var == "NONE") {
      shinyjs::hide("constraint_range") # hide before update
      shinyjs::hide("all_na")

      # force update (and thus refresh) on different constraint_var -> pass unique value for each constraint_var name
      args <- list(
        min = list(label = "Min", min = 0, max = 0, value = 0),
        max = list(label = "Max", min = 0, max = 0, value = 0)
      )

      update_min_max(session, args)
    } else {
      validate(need(FALSE, "This is an invalid data contraint for the filtered data"))
    }
  })

  anl_constraint <- create_anl_constraint_reactive(anl_param, input, param_id = param_id, min_rows = min_rows)

  return(anl_constraint)
}

# returns a reactive that applies the `x-axis data constraint`
# More precisely, all patients are filtered out that do not have the range of
# `param_id.constraint_var` in the specified range
# constraint var means that `param_id.constraint_var` is constrained to the filtered range (or NA),
# e.g. `ALT.BASE2` (i.e. `PARAMCD = ALT & range_filter_on(BASE2)`)
create_anl_constraint_reactive <- function(anl_param, input, param_id, min_rows) {
  iv_r <- reactive({
    iv <- shinyvalidate::InputValidator$new()
    iv$condition(~ isTRUE(input$constraint_var != "NONE"))
    iv$add_rule("constraint_range_min", shinyvalidate::sv_required("A contraint minimum value is required"))
    iv$add_rule("constraint_range_max", shinyvalidate::sv_required("A contraint maximum value is required"))
    iv$add_rule(
      "constraint_range_min",
      ~ if (!is.na(input$constraint_range_max) && (.) > input$constraint_range_max) {
        "constraint min needs to be less than max"
      }
    )
    iv$add_rule(
      "constraint_range_max",
      ~ if (!is.na(input$constraint_range_min) && (.) < input$constraint_range_min) {
        "constraint min needs to be less than max"
      }
    )
    iv
  })


  return_val <- reactive({
    private_qenv <- anl_param()$qenv

    # it is assumed that constraint_var is triggering constraint_range which then trigger this clause
    constraint_var <- isolate(input[["constraint_var"]])
    constraint_range_min <- input[["constraint_range_min"]]
    constraint_range_max <- input[["constraint_range_max"]]
    param <- input[[param_id]]
    req(param)

    # filter constraint
    if (constraint_var != "NONE") {
      private_qenv <- teal.code::eval_code(
        object = private_qenv,
        code = bquote({
          # the below includes patients who have at least one non-NA BASE value
          # ideally, a patient should either have all NA values or none at all
          # this could be achieved through preprocessing; otherwise, this is easily overseen
          filtered_usubjids <- ANL %>% # nolint
            dplyr::filter(
              PARAMCD == .(param),
              (.(constraint_range_min) <= .data[[.(constraint_var)]]) &
                (.data[[.(constraint_var)]] <= .(constraint_range_max))
            ) %>%
            dplyr::pull(USUBJID)
          # include patients with all NA values for constraint_var
          filtered_usubjids <- c(
            filtered_usubjids,
            ANL %>%
              dplyr::filter(PARAMCD == .(param)) %>%
              dplyr::group_by(USUBJID) %>%
              dplyr::summarize(all_na = all(is.na(.data[[.(constraint_var)]]))) %>%
              dplyr::filter(all_na) %>%
              dplyr::pull(USUBJID)
          )
          ANL <- ANL %>% dplyr::filter(USUBJID %in% filtered_usubjids) # nolint
        })
      )
      validate_has_data(private_qenv[["ANL"]], min_rows)
    }
    list(ANL = private_qenv[["ANL"]], qenv = private_qenv)
  })

  reactive(
    list(
      value = return_val,
      iv_r = iv_r
    )
  )
}

# for outputting the constraint in the report
formatted_data_constraint <- function(constraint_var, constraint_range_min, constraint_range_max) {
  constraint_var_label <- switch(constraint_var,
    "BASE2" = "Screening",
    "BASE" = "Baseline",
    "None"
  )
  msg <- paste("Data Constraint:", constraint_var_label)
  if (constraint_var_label != "None") {
    msg <- paste(msg, "from", constraint_range_min, "to", constraint_range_max)
  }
  msg
}

update_min_max <- function(session, args) {
  do.call("updateNumericInput", c(list(session = session, inputId = "constraint_range_min"), args$min))
  do.call("updateNumericInput", c(list(session = session, inputId = "constraint_range_max"), args$max))
}

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

plots_per_row_validate_rules <- function(required = TRUE) {
  msg <- "Number of plots per row must be a positive integer"
  shinyvalidate::compose_rules(
    if (required) {
      shinyvalidate::sv_required(msg)
    } else {
      shinyvalidate::sv_optional()
    },
    shinyvalidate::sv_integer(msg),
    shinyvalidate::sv_gt(0, message_fmt = msg)
  )
}

#' Template Function for `TealReportCard` Creation and Customization in `teal.goshawk`
#'
#' This function generates a report card with a title,
#' an optional description, and the option to append the filter state list.
#' Additionally, it display selected constraint options.
#'
#' @inheritParams teal::report_card_template
#' @param constraint_list (`list`) a list containing constraint variables, including:
#'   - constraint_var (`character(1)`) the constraint variable name.
#'   - constraint_range_min (`numeric(1)`) the minimum constraint range value.
#'   - constraint_range_max (`numeric(1)`) the maximum constraint range value.
#' @param constraint_description (`character(1)`)  description of the constraints.
#' @param style (`character(1)`)  style of the constraint text block.
#'   options: `default`, `verbatim` (default is `default`).
#'
#' @return (`TealReportCard`) populated with a title, description, and filter state
#'
#' @keywords internal
report_card_template_goshawk <- function(title,
                                         label,
                                         with_filter,
                                         filter_panel_api,
                                         constraint_list,
                                         constraint_description = NULL,
                                         style = "default") {
  checkmate::assert_subset(names(constraint_list), c("constraint_var", "constraint_range_min", "constraint_range_max"))
  checkmate::assert_string(constraint_description, null.ok = TRUE)
  checkmate::assert_choice(style, c("default", "verbatim"))

  card <- teal::report_card_template(
    title = title,
    label = label,
    with_filter = with_filter,
    filter_panel_api = filter_panel_api
  )

  card$append_text("Selected Options", "header3")
  card$append_text(
    paste(
      formatted_data_constraint(
        constraint_list$constraint_var,
        constraint_list$constraint_range_min,
        constraint_list$constraint_range_max
      ),
      constraint_description
    ),
    style = style
  )
  card
}

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

#' Density Distribution Plot
#'
#' This teal module renders the UI and calls the functions that create a density distribution plot
#' and an accompanying summary table.
#'
#' @param label menu item label of the module in the teal app.
#' @param trt_group \code{\link[teal.transform]{choices_selected}} object with available choices and pre-selected option
#' for variable names representing treatment group e.g. `ARM`.
#' @param color_manual vector of colors applied to treatment values.
#' @param color_comb name or hex value for combined treatment color.
#' @param plot_height controls plot height.
#' @param plot_width optional, controls plot width.
#' @param font_size font size control for title, `x-axis` label, `y-axis` label and legend.
#' @param line_size plot line thickness.
#' @param hline_arb numeric vector of at most 2 values identifying intercepts for arbitrary horizontal lines.
#' @param hline_arb_color a character vector of at most length of \code{hline_arb}.
#' naming the color for the arbitrary horizontal lines.
#' @param hline_arb_label a character vector of at most length of \code{hline_arb}.
#' naming the label for the arbitrary horizontal lines.
#' @param facet_ncol numeric value indicating number of facets per row.
#' @param comb_line display combined treatment line toggle.
#' @param rotate_xlab 45 degree rotation of `x-axis` values.
#'
#' @inheritParams teal.widgets::standard_layout
#' @inheritParams tm_g_gh_scatterplot
#'
#'
#' @author Nick Paszty (npaszty) paszty.nicholas@gene.com
#' @author Balazs Toth (tothb2)  toth.balazs@gene.com
#'
#' @details None
#'
#' @export
#'
#' @examples
#' # Example using ADaM structure analysis dataset.
#' data <- teal_data()
#' data <- within(data, {
#'   library(dplyr)
#'   library(stringr)
#'
#'   # original ARM value = dose value
#'   arm_mapping <- list(
#'     "A: Drug X" = "150mg QD",
#'     "B: Placebo" = "Placebo",
#'     "C: Combination" = "Combination"
#'   )
#'   ADSL <- rADSL
#'   ADLB <- rADLB
#'   var_labels <- lapply(ADLB, function(x) attributes(x)$label)
#'   ADLB <- ADLB %>%
#'     mutate(
#'       AVISITCD = case_when(
#'         AVISIT == "SCREENING" ~ "SCR",
#'         AVISIT == "BASELINE" ~ "BL",
#'         grepl("WEEK", AVISIT) ~ paste("W", str_extract(AVISIT, "(?<=(WEEK ))[0-9]+")),
#'         TRUE ~ as.character(NA)
#'       ),
#'       AVISITCDN = case_when(
#'         AVISITCD == "SCR" ~ -2,
#'         AVISITCD == "BL" ~ 0,
#'         grepl("W", AVISITCD) ~ as.numeric(gsub("[^0-9]*", "", AVISITCD)),
#'         TRUE ~ as.numeric(NA)
#'       ),
#'       AVISITCD = factor(AVISITCD) %>% reorder(AVISITCDN),
#'       TRTORD = case_when(
#'         ARMCD == "ARM C" ~ 1,
#'         ARMCD == "ARM B" ~ 2,
#'         ARMCD == "ARM A" ~ 3
#'       ),
#'       ARM = as.character(arm_mapping[match(ARM, names(arm_mapping))]),
#'       ARM = factor(ARM) %>% reorder(TRTORD),
#'       ACTARM = as.character(arm_mapping[match(ACTARM, names(arm_mapping))]),
#'       ACTARM = factor(ACTARM) %>% reorder(TRTORD)
#'     )
#'
#'   attr(ADLB[["ARM"]], "label") <- var_labels[["ARM"]]
#'   attr(ADLB[["ACTARM"]], "label") <- var_labels[["ACTARM"]]
#' })
#'
#' datanames <- c("ADSL", "ADLB")
#' datanames(data) <- datanames
#' join_keys(data) <- default_cdisc_join_keys[datanames]
#'
#' app <- init(
#'   data = data,
#'   modules = modules(
#'     tm_g_gh_density_distribution_plot(
#'       label = "Density Distribution Plot",
#'       dataname = "ADLB",
#'       param_var = "PARAMCD",
#'       param = choices_selected(c("ALT", "CRP", "IGA"), "ALT"),
#'       xaxis_var = choices_selected(c("AVAL", "BASE", "CHG", "PCHG"), "AVAL"),
#'       trt_group = choices_selected(c("ARM", "ACTARM"), "ARM"),
#'       color_manual = c(
#'         "150mg QD" = "#000000",
#'         "Placebo" = "#3498DB",
#'         "Combination" = "#E74C3C"
#'       ),
#'       color_comb = "#39ff14",
#'       comb_line = TRUE,
#'       plot_height = c(500, 200, 2000),
#'       font_size = c(12, 8, 20),
#'       line_size = c(1, .25, 3),
#'       hline_arb = c(.02, .05),
#'       hline_arb_color = c("red", "black"),
#'       hline_arb_label = c("Horizontal Line A", "Horizontal Line B")
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
tm_g_gh_density_distribution_plot <- function(label, # nolint
                                              dataname,
                                              param_var,
                                              param,
                                              xaxis_var,
                                              trt_group,
                                              color_manual = NULL,
                                              color_comb = NULL,
                                              plot_height = c(500, 200, 2000),
                                              plot_width = NULL,
                                              font_size = c(12, 8, 20),
                                              line_size = c(1, .25, 3),
                                              hline_arb = numeric(0),
                                              hline_arb_color = "red",
                                              hline_arb_label = "Horizontal line",
                                              facet_ncol = 2L,
                                              comb_line = TRUE,
                                              rotate_xlab = FALSE,
                                              pre_output = NULL,
                                              post_output = NULL) {
  message("Initializing tm_g_gh_density_distribution_plot")
  checkmate::assert_string(label)
  checkmate::assert_string(dataname)
  checkmate::assert_string(param_var)
  checkmate::assert_class(param, "choices_selected")
  checkmate::assert_class(xaxis_var, "choices_selected")
  checkmate::assert_class(trt_group, "choices_selected")
  checkmate::assert_numeric(font_size, len = 3)
  checkmate::assert_numeric(line_size, len = 3)
  checkmate::assert_int(facet_ncol)
  checkmate::assert_flag(comb_line)
  checkmate::assert_flag(rotate_xlab)
  validate_line_arb_arg(hline_arb, hline_arb_color, hline_arb_label)
  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 = dataname,
    server = srv_g_density_distribution_plot,
    server_args = list(
      dataname = dataname,
      param_var = param_var,
      param = param,
      color_manual = color_manual,
      color_comb = color_comb,
      plot_height = plot_height,
      plot_width = plot_width,
      module_args = args
    ),
    ui = ui_g_density_distribution_plot,
    ui_args = args
  )
}

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

  teal.widgets::standard_layout(
    output = tags$div(
      fluidRow(
        teal.widgets::plot_with_settings_ui(id = ns("plot"))
      ),
      fluidRow(column(
        width = 12,
        tags$br(), tags$hr(),
        tags$h4("Descriptive Statistics"),
        DT::dataTableOutput(ns("table_ui"))
      ))
    ),
    encoding = tags$div(
      ### Reporter
      teal.reporter::simple_reporter_ui(ns("simple_reporter")),
      ###
      templ_ui_dataname(a$dataname),
      uiOutput(ns("axis_selections")),
      templ_ui_constraint(ns, label = "Data Constraint"),
      ui_arbitrary_lines(id = ns("hline_arb"), a$hline_arb, a$hline_arb_label, a$hline_arb_color),
      teal.widgets::panel_group(
        teal.widgets::panel_item(
          title = "Plot Aesthetic Settings",
          toggle_slider_ui(
            ns("xrange_scale"),
            label = "X-Axis Range Zoom"
          ),
          toggle_slider_ui(
            ns("yrange_scale"),
            label = "Y-Axis Range Zoom"
          ),
          numericInput(ns("facet_ncol"), "Number of Plots Per Row:", a$facet_ncol, min = 1),
          checkboxInput(ns("comb_line"), "Display Combined line", a$comb_line),
          checkboxInput(ns("rug_plot"), "Include rug plot", value = FALSE),
          checkboxInput(ns("rotate_xlab"), "Rotate X-axis Label", a$rotate_xlab)
        ),
        teal.widgets::panel_item(
          title = "Plot settings",
          teal.widgets::optionalSliderInputValMinMax(ns("font_size"), "Font Size", a$font_size, ticks = FALSE),
          teal.widgets::optionalSliderInputValMinMax(
            ns("line_size"),
            "Line Size",
            value_min_max = a$line_size,
            step = .25,
            ticks = FALSE
          )
        )
      )
    ),
    forms = tagList(
      teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
    ),
    pre_output = a$pre_output,
    post_output = a$post_output
  )
}

srv_g_density_distribution_plot <- function(id, # nolint
                                            data,
                                            reporter,
                                            filter_panel_api,
                                            dataname,
                                            param_var,
                                            param,
                                            trt_group,
                                            color_manual,
                                            color_comb,
                                            plot_height,
                                            plot_width,
                                            module_args) {
  with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
  with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
  checkmate::assert_class(data, "reactive")
  checkmate::assert_class(shiny::isolate(data()), "teal_data")

  moduleServer(id, function(input, output, session) {
    teal.logger::log_shiny_input_changes(input, namespace = "teal.goshawk")
    output$axis_selections <- renderUI({
      env <- shiny::isolate(as.list(data()@env))
      resolved_x <- teal.transform::resolve_delayed(module_args$xaxis_var, env)
      resolved_param <- teal.transform::resolve_delayed(module_args$param, env)
      resolved_trt <- teal.transform::resolve_delayed(module_args$trt_group, env)

      templ_ui_params_vars(
        session$ns,
        xparam_choices = resolved_param$choices,
        xparam_selected = resolved_param$selected,
        xparam_label = "Select a Biomarker",
        xchoices = resolved_x$choices,
        xselected = resolved_x$selected,
        trt_choices = resolved_trt$choices,
        trt_selected = resolved_trt$selected
      )
    })

    anl_q_output <- constr_anl_q(
      session, input, data, dataname,
      param_id = "xaxis_param", param_var = param_var, trt_group = input$trt_group, min_rows = 2
    )

    anl_q <- anl_q_output()$value

    # update sliders for axes taking constraints into account
    data_state_x <- reactive({
      get_data_range_states(
        varname = input$xaxis_var,
        paramname = input$xaxis_param,
        ANL = anl_q()$ANL
      )
    })
    xrange_slider <- toggle_slider_server("xrange_scale", data_state_x)
    data_state_y <- reactive({
      get_data_range_states(
        varname = input$xaxis_var,
        paramname = input$xaxis_param,
        ANL = anl_q()$ANL,
        trt_group = "trt_group"
      )
    })
    yrange_slider <- toggle_slider_server("yrange_scale", data_state_y)

    keep_data_const_opts_updated(session, input, anl_q, "xaxis_param")

    horizontal_line <- srv_arbitrary_lines("hline_arb")

    iv_r <- reactive({
      iv <- shinyvalidate::InputValidator$new()

      iv$add_rule("xaxis_param", shinyvalidate::sv_required("Please select a biomarker"))
      iv$add_rule("trt_group", shinyvalidate::sv_required("Please select a treatment variable"))
      iv$add_rule("xaxis_var", shinyvalidate::sv_required("Please select an X-Axis variable"))
      iv$add_rule("facet_ncol", plots_per_row_validate_rules())

      iv$add_validator(horizontal_line()$iv_r())
      iv$add_validator(anl_q_output()$iv_r())
      iv$enable()
      iv
    })


    create_plot <- debounce(reactive({
      teal::validate_inputs(iv_r())
      req(anl_q())

      # nolint start
      param <- input$xaxis_param
      xaxis_var <- input$xaxis_var
      xlim <- xrange_slider$value
      ylim <- yrange_slider$value
      font_size <- input$font_size
      line_size <- input$line_size
      hline_arb <- horizontal_line()$line_arb
      hline_arb_label <- horizontal_line()$line_arb_label
      hline_arb_color <- horizontal_line()$line_arb_color
      facet_ncol <- input$facet_ncol

      comb_line <- input$comb_line
      rug_plot <- input$rug_plot
      rotate_xlab <- input$rotate_xlab
      trt_group <- input$trt_group
      # nolint end


      teal.code::eval_code(
        object = anl_q()$qenv,
        code = bquote({
          p <- goshawk::g_density_distribution_plot(
            data = ANL,
            param_var = .(param_var),
            param = .(param),
            xaxis_var = .(xaxis_var),
            trt_group = .(trt_group),
            xlim = .(xlim),
            ylim = .(ylim),
            color_manual = .(color_manual),
            color_comb = .(color_comb),
            font_size = .(font_size),
            line_size = .(line_size),
            facet_ncol = .(facet_ncol),
            comb_line = .(comb_line),
            hline_arb = .(hline_arb),
            hline_arb_label = .(hline_arb_label),
            hline_arb_color = .(hline_arb_color),
            rug_plot = .(rug_plot)
          )
          print(p)
        })
      )
    }), 800)

    create_table <- debounce(reactive({
      req(iv_r()$is_valid())
      req(anl_q())
      param <- input$xaxis_param
      xaxis_var <- input$xaxis_var
      font_size <- input$font_size
      trt_group <- input$trt_group

      teal.code::eval_code(
        object = anl_q()$qenv,
        code = bquote({
          tbl <- goshawk::t_summarytable(
            data = ANL,
            trt_group = .(trt_group),
            param_var = .(param_var),
            param = .(param),
            xaxis_var = .(xaxis_var),
            font_size = .(font_size)
          )
          tbl
        })
      )
    }), 800)

    plot_r <- reactive({
      create_plot()[["p"]]
    })

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

    output$table_ui <- DT::renderDataTable({
      req(create_table())
      tbl <- create_table()[["tbl"]]
      numeric_cols <- names(dplyr::select_if(tbl, is.numeric))

      DT::datatable(tbl,
        rownames = FALSE, options = list(scrollX = TRUE)
      ) %>%
        DT::formatRound(numeric_cols, 2)
    })

    joined_qenvs <- reactive({
      req(create_plot(), create_table())
      teal.code::join(create_plot(), create_table())
    })

    code <- reactive(teal.code::get_code(joined_qenvs()))

    teal.widgets::verbatim_popup_srv(
      id = "rcode",
      verbatim_content = reactive(code()),
      title = "Show R Code for Density Distribution Plot"
    )

    ### REPORTER
    if (with_reporter) {
      card_fun <- function(comment, label) {
        card <- report_card_template_goshawk(
          title = "Density Distribution Plot",
          label = label,
          with_filter = with_filter,
          filter_panel_api = filter_panel_api,
          constraint_list = list(
            constraint_var = input$constraint_var,
            constraint_range_min = input$constraint_range_min,
            constraint_range_max = input$constraint_range_max
          )
        )
        card$append_text("Plot", "header3")
        card$append_plot(plot_r(), dim = plot_data$dim())
        card$append_text("Descriptive Statistics", "header3")
        card$append_table(
          create_table()[["tbl"]] %>% dplyr::mutate_if(is.numeric, round, 2)
        )
        if (!comment == "") {
          card$append_text("Comment", "header3")
          card$append_text(comment)
        }
        card$append_src(code())
        card
      }
      teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
    }
    ###
  })
}

#' Spaghetti Plot
#'
#' This teal module renders the UI and calls the function
#' that creates a spaghetti plot.
#'
#' @param label menu item label of the module in the teal app.
#' @param dataname analysis data passed to the data argument of \code{\link[teal]{init}}.
#' E.g. `ADaM` structured laboratory data frame `ADLB`.
#' @param param_var name of variable containing biomarker codes e.g. `PARAMCD`.
#' @param param biomarker selected.
#' @param param_var_label single name of variable in analysis data
#' that includes parameter labels.
#' @param idvar name of unique subject id variable.
#' @param xaxis_var single name of variable in analysis data
#' that is used as x-axis in the plot for the respective goshawk function.
#' @param xaxis_var_level vector that can be used to define the factor level of `xaxis_var`.
#' Only use it when `xaxis_var` is character or factor.
#' @param filter_var data constraint variable.
#' @param yaxis_var single name of variable in analysis data that is used as
#' summary variable in the respective `goshawk` function.
#' @param trt_group \code{\link[teal.transform]{choices_selected}} object with available choices and pre-selected option
#' for variable names representing treatment group e.g. `ARM`.
#' @param trt_group_level vector that can be used to define factor
#' level of `trt_group`.
#' @param man_color string vector representing customized colors
#' @param color_comb name or hex value for combined treatment color.
#' @param xtick numeric vector to define the tick values of `x-axis`
#' when x variable is numeric. Default value is `waive()`.
#' @param xlabel vector with same length of `xtick` to define the
#' label of `x-axis` tick values. Default value is `waive()`.
#' @param rotate_xlab `logical(1)` value indicating whether to rotate `x-axis` labels
#' @param facet_ncol numeric value indicating number of facets per row.
#' @param free_x `logical(1)` should scales be `"fixed"` (`FALSE`) of `"free"` (`TRUE`) for `x-axis` in
#' \code{\link[ggplot2]{facet_wrap}} \code{scales} parameter.
#' @param plot_height controls plot height.
#' @param plot_width optional, controls plot width.
#' @param font_size control font size for title, `x-axis`, `y-axis` and legend font.
#' @param dot_size plot dot size.
#' @param group_stats control group mean or median overlay.
#' @param hline_arb numeric vector of at most 2 values identifying intercepts for arbitrary horizontal lines.
#' @param hline_arb_color a character vector of at most length of \code{hline_arb}.
#' naming the color for the arbitrary horizontal lines.
#' @param hline_arb_label a character vector of at most length of \code{hline_arb}.
#' naming the label for the arbitrary horizontal lines.
#' @param hline_vars a character vector to name the columns that will define additional horizontal lines.
#' @param hline_vars_colors a character vector naming the colors for the additional horizontal lines.
#' @param hline_vars_labels a character vector naming the labels for the additional horizontal lines that will appear
#'  in the legend.
#' @inheritParams teal.widgets::standard_layout
#'
#' @author Wenyi Liu (luiw2) wenyi.liu@roche.com
#' @author Balazs Toth (tothb2) toth.balazs@gene.com
#'
#' @return \code{shiny} object
#'
#' @export
#'
#' @examples
#' # Example using ADaM structure analysis dataset.
#' data <- teal_data()
#' data <- within(data, {
#'   library(dplyr)
#'   library(stringr)
#'
#'   # use non-exported function from goshawk
#'   h_identify_loq_values <- getFromNamespace("h_identify_loq_values", "goshawk")
#'
#'   # original ARM value = dose value
#'   arm_mapping <- list(
#'     "A: Drug X" = "150mg QD",
#'     "B: Placebo" = "Placebo",
#'     "C: Combination" = "Combination"
#'   )
#'   set.seed(1)
#'   ADSL <- rADSL
#'   ADLB <- rADLB
#'   var_labels <- lapply(ADLB, function(x) attributes(x)$label)
#'   ADLB <- ADLB %>%
#'     mutate(
#'       AVISITCD = case_when(
#'         AVISIT == "SCREENING" ~ "SCR",
#'         AVISIT == "BASELINE" ~ "BL",
#'         grepl("WEEK", AVISIT) ~ paste("W", str_extract(AVISIT, "(?<=(WEEK ))[0-9]+")),
#'         TRUE ~ as.character(NA)
#'       ),
#'       AVISITCDN = case_when(
#'         AVISITCD == "SCR" ~ -2,
#'         AVISITCD == "BL" ~ 0,
#'         grepl("W", AVISITCD) ~ as.numeric(gsub("[^0-9]*", "", AVISITCD)),
#'         TRUE ~ as.numeric(NA)
#'       ),
#'       AVISITCD = factor(AVISITCD) %>% reorder(AVISITCDN),
#'       TRTORD = case_when(
#'         ARMCD == "ARM C" ~ 1,
#'         ARMCD == "ARM B" ~ 2,
#'         ARMCD == "ARM A" ~ 3
#'       ),
#'       ARM = as.character(arm_mapping[match(ARM, names(arm_mapping))]),
#'       ARM = factor(ARM) %>% reorder(TRTORD),
#'       ACTARM = as.character(arm_mapping[match(ACTARM, names(arm_mapping))]),
#'       ACTARM = factor(ACTARM) %>% reorder(TRTORD),
#'       ANRLO = 30,
#'       ANRHI = 75
#'     ) %>%
#'     rowwise() %>%
#'     group_by(PARAMCD) %>%
#'     mutate(LBSTRESC = ifelse(USUBJID %in% sample(USUBJID, 1, replace = TRUE),
#'       paste("<", round(runif(1, min = 25, max = 30))), LBSTRESC
#'     )) %>%
#'     mutate(LBSTRESC = ifelse(USUBJID %in% sample(USUBJID, 1, replace = TRUE),
#'       paste(">", round(runif(1, min = 70, max = 75))), LBSTRESC
#'     )) %>%
#'     ungroup()
#'   attr(ADLB[["ARM"]], "label") <- var_labels[["ARM"]]
#'   attr(ADLB[["ACTARM"]], "label") <- var_labels[["ACTARM"]]
#'   attr(ADLB[["ANRLO"]], "label") <- "Analysis Normal Range Lower Limit"
#'   attr(ADLB[["ANRHI"]], "label") <- "Analysis Normal Range Upper Limit"
#'
#'   # add LLOQ and ULOQ variables
#'   ALB_LOQS <- h_identify_loq_values(ADLB, "LOQFL")
#'   ADLB <- left_join(ADLB, ALB_LOQS, by = "PARAM")
#' })
#'
#' datanames <- c("ADSL", "ADLB")
#' datanames(data) <- datanames
#' join_keys(data) <- default_cdisc_join_keys[datanames]
#'
#' app <- init(
#'   data = data,
#'   modules = modules(
#'     tm_g_gh_spaghettiplot(
#'       label = "Spaghetti Plot",
#'       dataname = "ADLB",
#'       param_var = "PARAMCD",
#'       param = choices_selected(c("ALT", "CRP", "IGA"), "ALT"),
#'       idvar = "USUBJID",
#'       xaxis_var = choices_selected(c("Analysis Visit Code" = "AVISITCD"), "AVISITCD"),
#'       yaxis_var = choices_selected(c("AVAL", "CHG", "PCHG"), "AVAL"),
#'       filter_var = choices_selected(
#'         c("None" = "NONE", "Screening" = "BASE2", "Baseline" = "BASE"),
#'         "NONE"
#'       ),
#'       trt_group = choices_selected(c("ARM", "ACTARM"), "ARM"),
#'       color_comb = "#39ff14",
#'       man_color = c(
#'         "Combination" = "#000000",
#'         "Placebo" = "#fce300",
#'         "150mg QD" = "#5a2f5f"
#'       ),
#'       hline_arb = c(60, 50),
#'       hline_arb_color = c("grey", "red"),
#'       hline_arb_label = c("default A", "default B"),
#'       hline_vars = c("ANRHI", "ANRLO", "ULOQN", "LLOQN"),
#'       hline_vars_colors = c("pink", "brown", "purple", "black"),
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
tm_g_gh_spaghettiplot <- function(label,
                                  dataname,
                                  param_var,
                                  param,
                                  param_var_label = "PARAM",
                                  idvar,
                                  xaxis_var,
                                  yaxis_var,
                                  xaxis_var_level = NULL,
                                  filter_var = yaxis_var,
                                  trt_group,
                                  trt_group_level = NULL,
                                  group_stats = "NONE",
                                  man_color = NULL,
                                  color_comb = NULL,
                                  xtick = ggplot2::waiver(),
                                  xlabel = xtick,
                                  rotate_xlab = FALSE,
                                  facet_ncol = 2,
                                  free_x = FALSE,
                                  plot_height = c(600, 200, 2000),
                                  plot_width = NULL,
                                  font_size = c(12, 8, 20),
                                  dot_size = c(2, 1, 12),
                                  hline_arb = numeric(0),
                                  hline_arb_color = "red",
                                  hline_arb_label = "Horizontal line",
                                  hline_vars = character(0),
                                  hline_vars_colors = "green",
                                  hline_vars_labels = hline_vars,
                                  pre_output = NULL,
                                  post_output = NULL) {
  message("Initializing tm_g_gh_spaghettiplot")

  # Validate string inputs
  checkmate::assert_string(label)
  checkmate::assert_string(dataname)
  checkmate::assert_string(param_var)
  checkmate::assert_string(param_var_label)
  checkmate::assert_string(idvar)
  checkmate::assert_string(group_stats)

  # Validate choices_selected class inputs
  checkmate::assert_class(param, "choices_selected")
  checkmate::assert_class(xaxis_var, "choices_selected")
  checkmate::assert_class(yaxis_var, "choices_selected")
  checkmate::assert_class(trt_group, "choices_selected")

  # Validate flag inputs
  checkmate::assert_flag(rotate_xlab)
  checkmate::assert_flag(free_x)

  # Validate numeric vector inputs
  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_numeric(font_size, len = 3, any.missing = FALSE, finite = TRUE)
  checkmate::assert_numeric(dot_size, len = 3, any.missing = FALSE, finite = TRUE)

  # Validate color manual if provided
  checkmate::assert_character(man_color, null.ok = TRUE)
  checkmate::assert_character(color_comb, null.ok = TRUE)
  checkmate::assert_character(hline_arb_color)
  checkmate::assert_character(hline_arb_label)

  # Validate facet columns
  checkmate::assert_int(facet_ncol, lower = 1)

  # Validate line arguments
  validate_line_arb_arg(hline_arb, hline_arb_color, hline_arb_label)
  validate_line_vars_arg(hline_vars, hline_vars_colors, hline_vars_labels)

  args <- as.list(environment())

  module(
    label = label,
    server = srv_g_spaghettiplot,
    server_args = list(
      dataname = dataname,
      idvar = idvar,
      param_var = param_var,
      xaxis_var_level = xaxis_var_level,
      trt_group_level = trt_group_level,
      man_color = man_color,
      color_comb = color_comb,
      param_var_label = param_var_label,
      xtick = xtick,
      xlabel = xlabel,
      plot_height = plot_height,
      plot_width = plot_width,
      hline_vars_colors = hline_vars_colors,
      hline_vars_labels = hline_vars_labels,
      module_args = args
    ),
    ui = g_ui_spaghettiplot,
    ui_args = args,
    datanames = dataname
  )
}

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

  shiny::tagList(
    include_css_files("custom"),
    teal.widgets::standard_layout(
      output = templ_ui_output_datatable(ns),
      encoding = tags$div(
        ### Reporter
        teal.reporter::simple_reporter_ui(ns("simple_reporter")),
        ###
        templ_ui_dataname(a$dataname),
        uiOutput(ns("axis_selections")),
        radioButtons(
          ns("group_stats"),
          "Group Statistics",
          c("None" = "NONE", "Mean" = "MEAN", "Median" = "MEDIAN"),
          inline = TRUE
        ),
        templ_ui_constraint(ns), # required by constr_anl_q
        if (length(a$hline_vars) > 0) {
          teal.widgets::optionalSelectInput(
            ns("hline_vars"),
            label = "Add Horizontal Range Line(s):",
            choices = a$hline_vars,
            selected = NULL,
            multiple = TRUE
          )
        },
        ui_arbitrary_lines(id = ns("hline_arb"), a$hline_arb, a$hline_arb_label, a$hline_arb_color),
        teal.widgets::panel_group(
          teal.widgets::panel_item(
            title = "Plot Aesthetic Settings",
            tags$div(
              toggle_slider_ui(
                ns("yrange_scale"),
                label = "Y-Axis Range Zoom"
              ),
              tags$div(
                class = "flex flex-wrap items-center",
                tags$div(
                  class = "mr-1",
                  tags$span(tags$strong("Number of Plots Per Row:"))
                ),
                tags$div(
                  class = "w-65px",
                  numericInput(ns("facet_ncol"), "", a$facet_ncol, min = 1)
                )
              )
            ),
            checkboxInput(ns("free_x"), "Free X-Axis Scales", a$free_x),
            checkboxInput(ns("rotate_xlab"), "Rotate X-Axis Label", a$rotate_xlab),
            teal.widgets::optionalSliderInputValMinMax(ns("font_size"), "Font Size", a$font_size, ticks = FALSE),
            teal.widgets::optionalSliderInputValMinMax(ns("dot_size"), "Dot Size", a$dot_size, ticks = FALSE),
            teal.widgets::optionalSliderInputValMinMax(
              ns("alpha"),
              "Line Alpha",
              a$alpha,
              value_min_max = c(0.8, 0.0, 1.0), step = 0.1, ticks = FALSE
            )
          )
        )
      ),
      forms = tagList(
        teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
      ),
      pre_output = a$pre_output,
      post_output = a$post_output
    )
  )
}



srv_g_spaghettiplot <- function(id,
                                data,
                                reporter,
                                filter_panel_api,
                                dataname,
                                idvar,
                                param_var,
                                trt_group,
                                man_color,
                                color_comb,
                                xaxis_var_level,
                                trt_group_level,
                                param_var_label,
                                xtick,
                                xlabel,
                                plot_height,
                                plot_width,
                                hline_vars_colors,
                                hline_vars_labels,
                                module_args) {
  with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
  with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
  checkmate::assert_class(data, "reactive")
  checkmate::assert_class(shiny::isolate(data()), "teal_data")

  moduleServer(id, function(input, output, session) {
    teal.logger::log_shiny_input_changes(input, namespace = "teal.goshawk")
    output$axis_selections <- renderUI({
      env <- shiny::isolate(as.list(data()@env))
      resolved_x <- teal.transform::resolve_delayed(module_args$xaxis_var, env)
      resolved_y <- teal.transform::resolve_delayed(module_args$yaxis_var, env)
      resolved_param <- teal.transform::resolve_delayed(module_args$param, env)
      resolved_trt <- teal.transform::resolve_delayed(module_args$trt_group, env)
      templ_ui_params_vars(
        session$ns,
        # xparam and yparam are identical, so we only show the user one
        xparam_choices = resolved_param$choices,
        xparam_selected = resolved_param$selected,
        xparam_label = "Select a Biomarker",
        xchoices = resolved_x$choices,
        xselected = resolved_x$selected,
        ychoices = resolved_y$choices,
        yselected = resolved_y$selected,
        trt_choices = resolved_trt$choices,
        trt_selected = resolved_trt$selected
      )
    })

    # reused in all modules
    anl_q_output <- constr_anl_q(
      session, input, data, dataname,
      param_id = "xaxis_param", param_var = param_var, trt_group = input$trt_group, min_rows = 1
    )

    anl_q <- anl_q_output()$value

    # update sliders for axes taking constraints into account
    data_state <- reactive({
      get_data_range_states(
        varname = input$yaxis_var,
        paramname = input$xaxis_param,
        ANL = anl_q()$ANL
      )
    })
    yrange_slider <- toggle_slider_server("yrange_scale", data_state)
    keep_data_const_opts_updated(session, input, anl_q, "xaxis_param")

    horizontal_line <- srv_arbitrary_lines("hline_arb")

    iv_r <- reactive({
      iv <- shinyvalidate::InputValidator$new()

      iv$add_rule("xaxis_param", shinyvalidate::sv_required("Please select a biomarker"))
      iv$add_rule("trt_group", shinyvalidate::sv_required("Please select a treatment variable"))
      iv$add_rule("xaxis_var", shinyvalidate::sv_required("Please select an X-Axis variable"))
      iv$add_rule("yaxis_var", shinyvalidate::sv_required("Please select a Y-Axis variable"))
      iv$add_rule("facet_ncol", plots_per_row_validate_rules())

      iv$add_validator(horizontal_line()$iv_r())
      iv$add_validator(anl_q_output()$iv_r())
      iv$enable()
      iv
    })


    plot_q <- debounce(reactive({
      teal::validate_inputs(iv_r())
      req(anl_q())
      # nolint start
      ylim <- yrange_slider$value
      facet_ncol <- input$facet_ncol
      facet_scales <- ifelse(input$free_x, "free_x", "fixed")

      rotate_xlab <- input$rotate_xlab
      hline_arb <- horizontal_line()$line_arb
      hline_arb_label <- horizontal_line()$line_arb_label
      hline_arb_color <- horizontal_line()$line_arb_color
      group_stats <- input$group_stats
      font_size <- input$font_size
      dot_size <- input$dot_size
      alpha <- input$alpha
      validate(need(input$trt_group, "Please select a treatment variable"))
      trt_group <- input$trt_group

      # Below inputs should trigger plot via updates of other reactive objects (i.e. anl_q()) and some inputs
      param <- input$xaxis_param
      xaxis_var <- input$xaxis_var
      yaxis_var <- input$yaxis_var
      hline_vars <- input$hline_vars
      # nolint end

      private_qenv <- anl_q()$qenv

      # this code is needed to make sure the waiver attribute
      # of ggplot2::waiver is correctly passed to goshawk's spaghettiplot
      if (!methods::is(xtick, "waiver")) {
        private_qenv <- teal.code::eval_code(
          object = private_qenv,
          code = bquote(xtick <- .(xtick))
        )
      } else {
        private_qenv <- teal.code::eval_code(
          object = private_qenv,
          code = quote(xtick <- ggplot2::waiver())
        )
      }

      if (!methods::is(xlabel, "waiver")) {
        private_qenv <- teal.code::eval_code(
          object = private_qenv,
          code = bquote(xlabel <- .(xlabel))
        )
      } else {
        private_qenv <- teal.code::eval_code(
          object = private_qenv,
          code = quote(xlabel <- ggplot2::waiver())
        )
      }

      teal.code::eval_code(
        object = private_qenv,
        code = bquote({
          p <- goshawk::g_spaghettiplot(
            data = ANL,
            subj_id = .(idvar),
            biomarker_var = .(param_var),
            biomarker_var_label = .(param_var_label),
            biomarker = .(param),
            value_var = .(yaxis_var),
            trt_group = .(trt_group),
            trt_group_level = .(trt_group_level),
            time = .(xaxis_var),
            time_level = .(xaxis_var_level),
            color_manual = .(man_color),
            color_comb = .(color_comb),
            ylim = .(ylim),
            facet_ncol = .(facet_ncol),
            facet_scales = .(facet_scales),
            hline_arb = .(hline_arb),
            hline_arb_label = .(hline_arb_label),
            hline_arb_color = .(hline_arb_color),
            xtick = xtick,
            xlabel = xlabel,
            rotate_xlab = .(rotate_xlab),
            font_size = .(font_size),
            dot_size = .(dot_size),
            alpha = .(alpha),
            group_stats = .(group_stats),
            hline_vars = .(hline_vars),
            hline_vars_colors = .(hline_vars_colors[seq_along(hline_vars)]),
            hline_vars_labels = .(hline_vars_labels[seq_along(hline_vars)])
          )
          print(p)
        })
      )
    }), 800)

    plot_r <- reactive({
      plot_q()[["p"]]
    })

    plot_data <- teal.widgets::plot_with_settings_srv(
      id = "plot",
      plot_r = plot_r,
      height = plot_height,
      width = plot_width,
      brushing = TRUE
    )

    code <- reactive(teal.code::get_code(plot_q()))

    ### REPORTER
    if (with_reporter) {
      card_fun <- function(comment, label) {
        card <- report_card_template_goshawk(
          title = "Spaghetti Plot",
          label = label,
          with_filter = with_filter,
          filter_panel_api = filter_panel_api,
          constraint_list = list(
            constraint_var = input$constraint_var,
            constraint_range_min = input$constraint_range_min,
            constraint_range_max = input$constraint_range_max
          )
        )
        card$append_text("Spaghetti Plot", "header3")
        card$append_plot(plot_r(), dim = plot_data$dim())
        if (!comment == "") {
          card$append_text("Comment", "header3")
          card$append_text(comment)
        }
        card$append_src(code())
        card
      }
      teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
    }
    ###

    reactive_df <- debounce(reactive({
      plot_brush <- plot_data$brush()

      ANL <- isolate(anl_q()$ANL) # nolint
      validate_has_data(ANL, 1)

      xvar <- isolate(input$xaxis_var)
      yvar <- isolate(input$yaxis_var)
      trt_group <- isolate(input$trt_group)

      req(all(c(xvar, yvar) %in% names(ANL)))

      df <- teal.widgets::clean_brushedPoints(
        dplyr::select(
          ANL, "USUBJID", dplyr::all_of(trt_group), "PARAMCD",
          dplyr::all_of(c(xvar, yvar)), "LOQFL"
        ),
        plot_brush
      )
      df[order(df$PARAMCD, df[[trt_group]], df$USUBJID, df[[xvar]]), ]
    }), 800)

    output$brush_data <- DT::renderDataTable({
      numeric_cols <- names(dplyr::select_if(reactive_df(), is.numeric))

      DT::datatable(reactive_df(),
        rownames = FALSE, options = list(scrollX = TRUE)
      ) %>%
        DT::formatRound(numeric_cols, 4)
    })

    teal.widgets::verbatim_popup_srv(
      id = "rcode",
      verbatim_content = reactive(code()),
      title = "Show R Code for Spaghetti Plot"
    )
  })
}

#' UI with a toggleable dichotomous slider to change between slider and numeric input fields
#'
#' This is useful when a slider should be shown, but it is sometimes hard to configure sliders,
#' so one can toggle to one or two numeric input fields to set slider instead.
#' The toggle button will show two numeric input field for selecting the from and to range.
#'
#' @md
#' @param id `character` module id
#' @param label `label` label for input field, e.g. slider or numeric inputs
#' @param ... additional parameters to pass to `sliderInput`
#'
#' @name toggle_slider
#' @keywords internal
#' @return `NULL`.
NULL


#' @rdname toggle_slider
toggle_slider_ui <- function(id, label) {
  ns <- NS(id)
  tags$div(
    tags$div(
      style = "display: flex; justify-content: space-between;",
      tags$span(tags$strong(label)),
      tags$div(actionButton(ns("toggle"), "Toggle", class = "btn-xs"))
    ),
    uiOutput(ns("inputs"))
  )
}

#' @keywords internal
#' @rdname toggle_slider
toggle_slider_server <- function(id, data_state, ...) {
  moduleServer(id, function(input, output, session) {
    state <- reactiveValues(
      min = NULL,
      max = NULL,
      value = NULL
    )
    slider_shown <- reactive(input$toggle %% 2 == 0)

    observeEvent(data_state()$range, {
      state$min <- data_state()$range[1]
      state$max <- data_state()$range[2]
      state$value <- data_state()$range
    })

    output$inputs <- renderUI({
      req(state$value)
      if (slider_shown()) {
        tags$div(
          class = "teal-goshawk toggle-slider-container",
          sliderInput(
            inputId = session$ns("slider"),
            label = NULL,
            min = min(data_state()$range[1], state$min),
            max = max(data_state()$range[2], state$max),
            value = state$value,
            step = data_state()$step,
            ticks = TRUE,
            ...
          ),
          tags$script(HTML(sprintf(
            '
              $(".teal-goshawk.toggle-slider-container #%s").ready(function () {
                var tickLabel = document.querySelector(
                  ".teal-goshawk.toggle-slider-container .irs-grid-text.js-grid-text-9"
                );
                var tick = document.querySelector(
                  ".teal-goshawk.toggle-slider-container .irs-grid-pol:nth-last-child(6)"
                );
                if (tickLabel) {
                  if (parseFloat(tickLabel.style.left) > 95) {
                    tickLabel.style.opacity = "0";
                    tick.style.opacity = "0";
                  }
                } else {
                  console.log("Toggle slider element not found.");
                }
              });
            ',
            session$ns("slider")
          )))
        )
      } else {
        tags$div(
          class = "teal-goshawk toggle-slider-container",
          numericInput(
            inputId = session$ns("value_low"),
            label = "From:",
            value = state$value[1]
          ),
          numericInput(
            inputId = session$ns("value_high"),
            label = "to:",
            value = state$value[2]
          )
        )
      }
    })

    d_slider <- debounce(reactive(input$slider), 500)

    observeEvent(d_slider(), {
      if (!setequal(state$value, d_slider())) {
        state$value <- d_slider()
      }
    })

    d_value_low <- debounce(reactive(input$value_low), 500)
    d_value_high <- debounce(reactive(input$value_high), 500)

    observeEvent(c(d_value_low(), d_value_high()), ignoreInit = TRUE, {
      values <- c(input$value_low, input$value_high)
      if (!setequal(state$value, values)) {
        state$value <- values
        state$min <- values[1]
        state$max <- values[2]
      }
    })

    return(state)
  })
}

#' @keywords internal
#' @rdname toggle_slider
get_data_range_states <- function(varname, paramname, ANL, trt_group = NULL, step = NULL) { # nolint object_name_linter
  validate(need(varname, "Please select variable"))
  validate(need(paramname, "Please select variable"))
  req(length(paramname) == 1)
  step <- NULL

  ANL <- ANL %>% dplyr::filter(.data$PARAMCD == paramname) # nolint object_name_linter
  validate_has_variable(ANL, varname, paste("variable", varname, "does not exist"))

  var <- stats::na.omit(ANL[[varname]])
  minmax <- if (length(var)) c(floor(min(var)), ceiling(max(var))) else c(0, 0)
  if (!is.null(trt_group)) {
    ANL_split <- ANL %>% split(f = factor(paste0(ANL[["AVISITCD"]], ANL[[trt_group]]))) # nolint
    density_maxes <- lapply(ANL_split, function(x) {
      max(stats::density(stats::na.omit(x[[varname]]))$y)
    })
    dmax <- max(unlist(density_maxes))
    minmax <- c(0, round(dmax * 1.2, 5))
    step <- round(dmax / 100, 5)
  }
  list(
    range = c(min = minmax[[1]], max = minmax[[2]]),
    step = step
  )
}

#' UI module to arbitrary lines
#'
#' UI module to input either horizontal or vertical lines to a plot via comma separated values
#'
#' @param id (`character(1)`)\cr
#'  defining namespace of the `shiny` module.
#' @param line_arb (`numeric`)\cr
#'  default values for the `textInput` defining values of arbitrary lines
#' @param line_arb_color (`character`)\cr
#'  default values for the `textInput` defining colors of arbitrary lines
#' @param line_arb_label (`character`)\cr
#'  default values for the `textInput` defining labels of arbitrary lines
#' @param title (`character(1)`)\cr
#'  title of the arbitrary lines input. The default is "Arbitrary Horizontal Lines".
#' @return (`shiny.tag`) an input to define values, colors and labels for arbitrary
#' straight lines.
#' @keywords internal
ui_arbitrary_lines <- function(id, line_arb, line_arb_label, line_arb_color, title = "Arbitrary Horizontal Lines:") {
  ns <- NS(id)
  tags$div(
    tags$b(title),
    textInput(
      ns("line_arb"),
      tags$div(
        class = "teal-tooltip",
        tagList(
          "Value:",
          icon("circle-info"),
          tags$span(
            class = "tooltiptext",
            "For multiple lines, supply a comma separated list of values."
          )
        )
      ),
      value = paste(line_arb, collapse = ", ")
    ),
    textInput(ns("line_arb_label"), label = "Label:", value = paste(line_arb_label, collapse = ", ")),
    textInput(ns("line_arb_color"), label = "Color:", value = paste(line_arb_color, collapse = ", "))
  )
}
#' Server module to arbitrary lines
#'
#' Server to validate and transform the comma separated values into vectors of values
#' to be passed into goshawk functions.
#' @inheritParams shiny::moduleServer
#' @return (`reactive`) returning a `list` containing `line_arb`, `line_arb_color`,
#'  `line_arb_label` which are validated and could be passed to `goshawk` plot functions.
#' @keywords internal
srv_arbitrary_lines <- function(id) {
  moduleServer(id, function(input, output, session) {

    comma_sep_to_values <- function(values, wrapper_fun = trimws) {
      vals <- strsplit(values, "\\s{0,},\\s{0,}")[[1]]
      suppressWarnings(wrapper_fun(vals))
    }

    iv_r <- reactive({
      iv <- shinyvalidate::InputValidator$new()
      iv$add_rule("line_arb", shinyvalidate::sv_optional())
      iv$add_rule(
        "line_arb",
        ~ if (any(is.na(comma_sep_to_values(., as.numeric)))) {
          "Arbitrary lines values should be a comma separated list of numbers"
        }
      )

      iv_color <- shinyvalidate::InputValidator$new()
      iv_color$condition(~ length(line_arb()) != 0)

      iv_color$add_rule("line_arb_color", shinyvalidate::sv_optional())
      iv_color$add_rule(
        "line_arb_color",
        ~ if (!length(comma_sep_to_values(.)) %in% c(1, length(line_arb()))) {
          sprintf(
            "Line input error: number of colors should be equal to 1, the number of lines (%d) or left blank for 'red'",
            length(line_arb())
          )
        }
      )
      iv_color$add_rule("line_arb_color", ~ if (!check_color(comma_sep_to_values(.))) {
        "The line colors entered cannot be converted to colors in R, please check your spelling"
      })
      iv$add_validator(iv_color)


      iv_label <- shinyvalidate::InputValidator$new()
      iv_label$condition(~ length(line_arb()) != 0)

      iv_label$add_rule("line_arb_label", shinyvalidate::sv_optional())
      iv_label$add_rule(
        "line_arb_label",
        ~ if (!length(comma_sep_to_values(.)) %in% c(1, length(line_arb()))) {
          sprintf(
            "Line input error: number of labels should be equal to 1, the number of lines (%d) or left blank",
            length(line_arb())
          )
        }
      )
      iv$add_validator(iv_label)
      iv
    })

    line_arb <- reactive({
      req(!is.null(input$line_arb))
      comma_sep_to_values(input$line_arb, as.numeric)
    })

    line_arb_label <- reactive({
      if (length(line_arb()) == 0) {
        return(character(0))
      }
      val <- comma_sep_to_values(input$line_arb_label)
      if (length(val) == 0) {
        val <- ""
      }
      val
    })

    line_arb_color <- reactive({
      if (length(line_arb()) == 0) {
        return(character(0))
      }
      val <- comma_sep_to_values(input$line_arb_color)
      if (length(val) == 0 || all(val == "")) {
        val <- "red"
      }
      val
    })

    return(
      reactive(
        list(
          iv_r = iv_r,
          line_arb = line_arb(),
          line_arb_color = line_arb_color(),
          line_arb_label = line_arb_label()
        )
      )
    )
  })
}

check_color <- function(col) {
  tryCatch(
    is.matrix(grDevices::col2rgb(col)),
    error = function(e) FALSE
  )
}

# to check the arbitrary line arguments
validate_line_arb_arg <- function(line_arb, line_arb_color, line_arb_label) {
  checkmate::assert_numeric(line_arb)
  if (length(line_arb) > 0) {
    checkmate::assert(
      checkmate::check_string(line_arb_color),
      checkmate::check_character(line_arb_color, len = length(line_arb))
    )
    checkmate::assert(
      checkmate::check_string(line_arb_label),
      checkmate::check_character(line_arb_label, len = length(line_arb))
    )
  }
}

# to check the variable line arguments
validate_line_vars_arg <- function(line_vars, line_vars_colors, line_vars_labels) {
  checkmate::assert_character(line_vars)
  if (length(line_vars) > 0) {
    checkmate::assert(
      checkmate::check_string(line_vars_colors),
      checkmate::check_character(line_vars_colors, len = length(line_vars))
    )
    checkmate::assert(
      checkmate::check_string(line_vars_labels),
      checkmate::check_character(line_vars_labels, len = length(line_vars))
    )
  }
}

templ_ui_output_datatable <- function(ns) {
  tags$div(
    teal.widgets::plot_with_settings_ui(id = ns("plot")),
    tags$br(), tags$hr(),
    tags$h4("Selected Data Points"),
    DT::dataTableOutput(ns("brush_data"))
  )
}

templ_ui_dataname <- function(dataname) {
  tags$label(dataname, "Data Settings", class = "text-primary")
}

# UI to create params (biomarker, value of PARAMCD) and vars (column, e.g. AVAL column) select fields for x and y
templ_ui_params_vars <- function(ns,
                                 # x
                                 xparam_choices = NULL,
                                 xparam_selected = NULL,
                                 xparam_label = NULL, # biomarker, e.g. ALT
                                 xchoices = NULL,
                                 xselected = NULL,
                                 xvar_label = NULL, # variable, e.g. AVAL
                                 # y
                                 yparam_choices = NULL,
                                 yparam_selected = NULL,
                                 yparam_label = NULL, # biomarker, e.g. ALT
                                 ychoices = NULL,
                                 yselected = NULL,
                                 yvar_label = NULL, # variable, e.g. AVAL
                                 # facet_var
                                 facet_choices = NULL,
                                 facet_selected = NULL,
                                 # trt_group
                                 trt_choices = NULL,
                                 trt_selected = NULL,

                                 multiple = FALSE) {
  if (is.null(xparam_choices) && !is.null(xchoices) && !is.null(yparam_choices)) {
    # otherwise, xchoices will appear first without any biomarker to select and this looks odd in the UI
    stop(
      "You have to specify xparam choices rather than yparamchoices
      if both xvar and yvar should be values for the same biomarker."
    )
  }
  tagList(
    if (!is.null(trt_choices)) {
      teal.widgets::optionalSelectInput(
        ns("trt_group"),
        label = "Select Treatment Variable",
        choices = trt_choices,
        selected = trt_selected,
        multiple = FALSE
      )
    },
    if (!is.null(xparam_choices)) {
      teal.widgets::optionalSelectInput(
        ns("xaxis_param"),
        `if`(is.null(xparam_label), "Select an X-Axis Biomarker", xparam_label),
        xparam_choices,
        `if`(is.null(xparam_selected), xparam_choices[1], xparam_selected),
        multiple = FALSE
      )
    },
    if (!is.null(xchoices)) {
      teal.widgets::optionalSelectInput(
        ns("xaxis_var"),
        `if`(is.null(xvar_label), "Select an X-Axis Variable", xvar_label),
        xchoices, xselected,
        multiple = multiple
      )
    },
    if (!is.null(yparam_choices)) {
      teal.widgets::optionalSelectInput(
        ns("yaxis_param"),
        `if`(is.null(yparam_label), "Select an Y-Axis Biomarker", yparam_label),
        yparam_choices,
        `if`(is.null(yparam_selected), yparam_choices[1], yparam_selected),
        multiple = FALSE
      )
    },
    if (!is.null(ychoices)) {
      teal.widgets::optionalSelectInput(
        ns("yaxis_var"),
        `if`(is.null(yvar_label), "Select a Y-Axis Variable", yvar_label),
        ychoices, yselected,
        multiple = multiple
      )
    },
    if (!is.null(facet_choices)) {
      teal.widgets::optionalSelectInput(
        ns("facet_var"),
        label = "Facet by",
        choices = facet_choices,
        selected = facet_selected,
        multiple = FALSE
      )
    }
  )
}

#' helper for writing arm mapping and ordering code.
#'
#' Provides lines of code for left hand side of arm mapping. user must provide right hand side
#'
#' @details SPA configure study specific pre-processing for deploying `goshawk`. writing the code for `ARM` mapping and
#' ordering is tedious. this function helps to get that started by providing the left hand side of the
#' mapping and ordering syntax. call the function and then copy and paste the resulting code from the console
#' into the app.R file.
#'
#' @param df_armvar the dataframe and column name containing treatment code. e.g. `ADSL$ARMCD`
#' @param code controls whether mapping or ordering code is written to console. Valid values: `"M"` and `"O"`.
#'
#' @export
#'
#' @examples
#' ADSL <- rADSL
#'
#' # get treatment mapping code
#' maptrt(df_armvar = ADSL$ARMCD, code = "M")
#'
#' # get treatment ordering code
#' maptrt(df_armvar = ADSL$ARMCD, code = "O")
maptrt <- function(df_armvar, code = c("M", "O")) {
  code <- match.arg(code)

  # get arm variable
  trtvar <- strsplit(deparse(substitute(df_armvar)), "[$]")[[1]][2]

  dftrt <- data.frame(unique(df_armvar)) %>%
    dplyr::mutate(trt_mapping = paste0("\"", unique(df_armvar), "\"", " = \"\",")) %>%
    dplyr::mutate(trt_ordering = paste0(eval(trtvar), " == \"", unique(df_armvar), "\"", " ~  ,"))

  if (toupper(code) == "M") {
    print(unname(dftrt["trt_mapping"]), row.names = FALSE)
  } else if (toupper(code) == "O") {
    print(unname(dftrt["trt_ordering"]), row.names = FALSE)
  }
}

1		#' UI with a toggleable dichotomous slider to change between slider and numeric input fields
2		#'
3		#' This is useful when a slider should be shown, but it is sometimes hard to configure sliders,
4		#' so one can toggle to one or two numeric input fields to set slider instead.
5		#' The toggle button will show two numeric input field for selecting the from and to range.
6		#'
7		#' @md
8		#' @param id `character` module id
9		#' @param label `label` label for input field, e.g. slider or numeric inputs
10		#' @param ... additional parameters to pass to `sliderInput`
11		#'
12		#' @name toggle_slider
13		#' @keywords internal
14		#' @return `NULL`.
15		NULL
16
17
18		#' @rdname toggle_slider
19		toggle_slider_ui <- function(id, label) {
20	1x	ns <- NS(id)
21	1x	tags$div(
22	1x	tags$div(
23	1x	style = "display: flex; justify-content: space-between;",
24	1x	tags$span(tags$strong(label)),
25	1x	tags$div(actionButton(ns("toggle"), "Toggle", class = "btn-xs"))
26		),
27	1x	uiOutput(ns("inputs"))
28		)
29		}
30
31		#' @keywords internal
32		#' @rdname toggle_slider
33		toggle_slider_server <- function(id, data_state, ...) {
34	1x	moduleServer(id, function(input, output, session) {
35	1x	state <- reactiveValues(
36	1x	min = NULL,
37	1x	max = NULL,
38	1x	value = NULL
39		)
40	1x	slider_shown <- reactive(input$toggle %% 2 == 0)
41
42	1x	observeEvent(data_state()$range, {
43	2x	state$min <- data_state()$range[1]
44	2x	state$max <- data_state()$range[2]
45	2x	state$value <- data_state()$range
46		})
47
48	1x	output$inputs <- renderUI({
49	20x	req(state$value)
50	20x	if (slider_shown()) {
51	7x	tags$div(
52	7x	class = "teal-goshawk toggle-slider-container",
53	7x	sliderInput(
54	7x	inputId = session$ns("slider"),
55	7x	label = NULL,
56	7x	min = min(data_state()$range[1], state$min),
57	7x	max = max(data_state()$range[2], state$max),
58	7x	value = state$value,
59	7x	step = data_state()$step,
60	7x	ticks = TRUE,
61		...
62		),
63	7x	tags$script(HTML(sprintf(
64		'
65	7x	$(".teal-goshawk.toggle-slider-container #%s").ready(function () {
66	7x	var tickLabel = document.querySelector(
67	7x	".teal-goshawk.toggle-slider-container .irs-grid-text.js-grid-text-9"
68		);
69	7x	var tick = document.querySelector(
70	7x	".teal-goshawk.toggle-slider-container .irs-grid-pol:nth-last-child(6)"
71		);
72	7x	if (tickLabel) {
73	7x	if (parseFloat(tickLabel.style.left) > 95) {
74	7x	tickLabel.style.opacity = "0";
75	7x	tick.style.opacity = "0";
76		}
77		} else {
78	7x	console.log("Toggle slider element not found.");
79		}
80		});
81		',
82	7x	session$ns("slider")
83		)))
84		)
85		} else {
86	13x	tags$div(
87	13x	class = "teal-goshawk toggle-slider-container",
88	13x	numericInput(
89	13x	inputId = session$ns("value_low"),
90	13x	label = "From:",
91	13x	value = state$value[1]
92		),
93	13x	numericInput(
94	13x	inputId = session$ns("value_high"),
95	13x	label = "to:",
96	13x	value = state$value[2]
97		)
98		)
99		}
100		})
101
102	1x	d_slider <- debounce(reactive(input$slider), 500)
103
104	1x	observeEvent(d_slider(), {
105	6x	if (!setequal(state$value, d_slider())) {
106	1x	state$value <- d_slider()
107		}
108		})
109
110	1x	d_value_low <- debounce(reactive(input$value_low), 500)
111	1x	d_value_high <- debounce(reactive(input$value_high), 500)
112
113	1x	observeEvent(c(d_value_low(), d_value_high()), ignoreInit = TRUE, {
114	12x	values <- c(input$value_low, input$value_high)
115	12x	if (!setequal(state$value, values)) {
116	6x	state$value <- values
117	6x	state$min <- values[1]
118	6x	state$max <- values[2]
119		}
120		})
121
122	1x	return(state)
123		})
124		}
125
126		#' @keywords internal
127		#' @rdname toggle_slider
128		get_data_range_states <- function(varname, paramname, ANL, trt_group = NULL, step = NULL) { # nolint object_name_linter
129	3x	validate(need(varname, "Please select variable"))
130	2x	validate(need(paramname, "Please select variable"))
131	2x	req(length(paramname) == 1)
132	2x	step <- NULL
133
134	2x	ANL <- ANL %>% dplyr::filter(.data$PARAMCD == paramname) # nolint object_name_linter
135	2x	validate_has_variable(ANL, varname, paste("variable", varname, "does not exist"))
136
137	2x	var <- stats::na.omit(ANL[[varname]])
138	2x	minmax <- if (length(var)) c(floor(min(var)), ceiling(max(var))) else c(0, 0)
139	2x	if (!is.null(trt_group)) {
140	!	ANL_split <- ANL %>% split(f = factor(paste0(ANL[["AVISITCD"]], ANL[[trt_group]]))) # nolint
141	!	density_maxes <- lapply(ANL_split, function(x) {
142	!	max(stats::density(stats::na.omit(x[[varname]]))$y)
143		})
144	!	dmax <- max(unlist(density_maxes))
145	!	minmax <- c(0, round(dmax * 1.2, 5))
146	!	step <- round(dmax / 100, 5)
147		}
148	2x	list(
149	2x	range = c(min = minmax[[1]], max = minmax[[2]]),
150	2x	step = step
151		)
152		}

1		#' UI module to arbitrary lines
2		#'
3		#' UI module to input either horizontal or vertical lines to a plot via comma separated values
4		#'
5		#' @param id (`character(1)`)\cr
6		#' defining namespace of the `shiny` module.
7		#' @param line_arb (`numeric`)\cr
8		#' default values for the `textInput` defining values of arbitrary lines
9		#' @param line_arb_color (`character`)\cr
10		#' default values for the `textInput` defining colors of arbitrary lines
11		#' @param line_arb_label (`character`)\cr
12		#' default values for the `textInput` defining labels of arbitrary lines
13		#' @param title (`character(1)`)\cr
14		#' title of the arbitrary lines input. The default is "Arbitrary Horizontal Lines".
15		#' @return (`shiny.tag`) an input to define values, colors and labels for arbitrary
16		#' straight lines.
17		#' @keywords internal
18		ui_arbitrary_lines <- function(id, line_arb, line_arb_label, line_arb_color, title = "Arbitrary Horizontal Lines:") {
19	1x	ns <- NS(id)
20	1x	tags$div(
21	1x	tags$b(title),
22	1x	textInput(
23	1x	ns("line_arb"),
24	1x	tags$div(
25	1x	class = "teal-tooltip",
26	1x	tagList(
27	1x	"Value:",
28	1x	icon("circle-info"),
29	1x	tags$span(
30	1x	class = "tooltiptext",
31	1x	"For multiple lines, supply a comma separated list of values."
32		)
33		)
34		),
35	1x	value = paste(line_arb, collapse = ", ")
36		),
37	1x	textInput(ns("line_arb_label"), label = "Label:", value = paste(line_arb_label, collapse = ", ")),
38	1x	textInput(ns("line_arb_color"), label = "Color:", value = paste(line_arb_color, collapse = ", "))
39		)
40		}
41		#' Server module to arbitrary lines
42		#'
43		#' Server to validate and transform the comma separated values into vectors of values
44		#' to be passed into goshawk functions.
45		#' @inheritParams shiny::moduleServer
46		#' @return (`reactive`) returning a `list` containing `line_arb`, `line_arb_color`,
47		#' `line_arb_label` which are validated and could be passed to `goshawk` plot functions.
48		#' @keywords internal
49		srv_arbitrary_lines <- function(id) {
50	1x	moduleServer(id, function(input, output, session) {
51
52	1x	comma_sep_to_values <- function(values, wrapper_fun = trimws) {
53	75x	vals <- strsplit(values, "\\s{0,},\\s{0,}")[[1]]
54	75x	suppressWarnings(wrapper_fun(vals))
55		}
56
57	1x	iv_r <- reactive({
58	1x	iv <- shinyvalidate::InputValidator$new()
59	1x	iv$add_rule("line_arb", shinyvalidate::sv_optional())
60	1x	iv$add_rule(
61	1x	"line_arb",
62	1x	~ if (any(is.na(comma_sep_to_values(., as.numeric)))) {
63	!	"Arbitrary lines values should be a comma separated list of numbers"
64		}
65		)
66
67	1x	iv_color <- shinyvalidate::InputValidator$new()
68	1x	iv_color$condition(~ length(line_arb()) != 0)
69
70	1x	iv_color$add_rule("line_arb_color", shinyvalidate::sv_optional())
71	1x	iv_color$add_rule(
72	1x	"line_arb_color",
73	1x	~ if (!length(comma_sep_to_values(.)) %in% c(1, length(line_arb()))) {
74	!	sprintf(
75	!	"Line input error: number of colors should be equal to 1, the number of lines (%d) or left blank for 'red'",
76	!	length(line_arb())
77		)
78		}
79		)
80	1x	iv_color$add_rule("line_arb_color", ~ if (!check_color(comma_sep_to_values(.))) {
81	!	"The line colors entered cannot be converted to colors in R, please check your spelling"
82		})
83	1x	iv$add_validator(iv_color)
84
85
86	1x	iv_label <- shinyvalidate::InputValidator$new()
87	1x	iv_label$condition(~ length(line_arb()) != 0)
88
89	1x	iv_label$add_rule("line_arb_label", shinyvalidate::sv_optional())
90	1x	iv_label$add_rule(
91	1x	"line_arb_label",
92	1x	~ if (!length(comma_sep_to_values(.)) %in% c(1, length(line_arb()))) {
93	!	sprintf(
94	!	"Line input error: number of labels should be equal to 1, the number of lines (%d) or left blank",
95	!	length(line_arb())
96		)
97		}
98		)
99	1x	iv$add_validator(iv_label)
100	1x	iv
101		})
102
103	1x	line_arb <- reactive({
104	1x	req(!is.null(input$line_arb))
105	1x	comma_sep_to_values(input$line_arb, as.numeric)
106		})
107
108	1x	line_arb_label <- reactive({
109	1x	if (length(line_arb()) == 0) {
110	!	return(character(0))
111		}
112	1x	val <- comma_sep_to_values(input$line_arb_label)
113	1x	if (length(val) == 0) {
114	!	val <- ""
115		}
116	1x	val
117		})
118
119	1x	line_arb_color <- reactive({
120	1x	if (length(line_arb()) == 0) {
121	!	return(character(0))
122		}
123	1x	val <- comma_sep_to_values(input$line_arb_color)
124	1x	if (length(val) == 0 \|\| all(val == "")) {
125	!	val <- "red"
126		}
127	1x	val
128		})
129
130	1x	return(
131	1x	reactive(
132	1x	list(
133	1x	iv_r = iv_r,
134	1x	line_arb = line_arb(),
135	1x	line_arb_color = line_arb_color(),
136	1x	line_arb_label = line_arb_label()
137		)
138		)
139		)
140		})
141		}
142
143		check_color <- function(col) {
144	18x	tryCatch(
145	18x	is.matrix(grDevices::col2rgb(col)),
146	18x	error = function(e) FALSE
147		)
148		}
149
150		# to check the arbitrary line arguments
151		validate_line_arb_arg <- function(line_arb, line_arb_color, line_arb_label) {
152	1x	checkmate::assert_numeric(line_arb)
153	1x	if (length(line_arb) > 0) {
154	1x	checkmate::assert(
155	1x	checkmate::check_string(line_arb_color),
156	1x	checkmate::check_character(line_arb_color, len = length(line_arb))
157		)
158	1x	checkmate::assert(
159	1x	checkmate::check_string(line_arb_label),
160	1x	checkmate::check_character(line_arb_label, len = length(line_arb))
161		)
162		}
163		}
164
165		# to check the variable line arguments
166		validate_line_vars_arg <- function(line_vars, line_vars_colors, line_vars_labels) {
167	1x	checkmate::assert_character(line_vars)
168	1x	if (length(line_vars) > 0) {
169	1x	checkmate::assert(
170	1x	checkmate::check_string(line_vars_colors),
171	1x	checkmate::check_character(line_vars_colors, len = length(line_vars))
172		)
173	1x	checkmate::assert(
174	1x	checkmate::check_string(line_vars_labels),
175	1x	checkmate::check_character(line_vars_labels, len = length(line_vars))
176		)
177		}
178		}

1		#' Box Plot
2		#'
3		#' This teal module renders the UI and calls the functions that create a box plot and accompanying
4		#' summary table.
5		#'
6		#' @param label menu item label of the module in the teal app.
7		#' @param dataname analysis data passed to the data argument of \code{\link[teal]{init}}. E.g. `ADaM` structured
8		#' laboratory data frame `ALB`.
9		#' @param param_var name of variable containing biomarker codes e.g. `PARAMCD`.
10		#' @param param list of biomarkers of interest.
11		#' @param yaxis_var name of variable containing biomarker results displayed on y-axis e.g. `AVAL`. When not provided,
12		#' it defaults to `choices_selected(c("AVAL", "CHG"), "AVAL")`.
13		#' @param xaxis_var variable to categorize the x-axis. When not provided, it defaults to
14		#' `choices_selected("AVISITCD", "AVISITCD")`.
15		#' @param facet_var variable to facet the plots by. When not provided, it defaults to
16		#' `choices_selected(c("ARM", "ACTARM"), "ARM")`.
17		#' @param trt_group \code{\link[teal.transform]{choices_selected}} object with available choices and pre-selected
18		#' option for variable names representing treatment group e.g. `ARM`.
19		#' @param color_manual vector of colors applied to treatment values.
20		#' @param shape_manual vector of symbols applied to `LOQ` values.
21		#' @param facet_ncol numeric value indicating number of facets per row.
22		#' @param loq_legend `loq` legend toggle.
23		#' @param rotate_xlab 45 degree rotation of `x-axis` values.
24		#' @param hline_arb numeric vector of at most 2 values identifying intercepts for arbitrary horizontal lines.
25		#' @param hline_arb_color a character vector of at most length of \code{hline_arb}.
26		#' naming the color for the arbitrary horizontal lines.
27		#' @param hline_arb_label a character vector of at most length of \code{hline_arb}.
28		#' naming the label for the arbitrary horizontal lines.
29		#' @param hline_vars a character vector to name the columns that will define additional horizontal lines.
30		#' @param hline_vars_colors a character vector naming the colors for the additional horizontal lines.
31		#' @param hline_vars_labels a character vector naming the labels for the additional horizontal lines that will appear
32		#' in the legend.
33		#' @param plot_height controls plot height.
34		#' @param plot_width optional, controls plot width.
35		#' @param font_size font size control for title, `x-axis` label, `y-axis` label and legend.
36		#' @param dot_size plot dot size.
37		#' @param alpha numeric vector to define transparency of plotted points.
38		#'
39		#' @inheritParams teal.widgets::standard_layout
40		#'
41		#' @author Jeff Tomlinson (tomlinsj) jeffrey.tomlinson@roche.com
42		#' @author Balazs Toth (tothb2) toth.balazs@gene.com
43		#'
44		#' @return an \code{\link[teal]{module}} object
45		#'
46		#' @export
47		#'
48		#' @examplesIf require("nestcolor")
49		#' # Example using ADaM structure analysis dataset.
50		#' data <- teal_data()
51		#' data <- within(data, {
52		#' library(dplyr)
53		#' library(nestcolor)
54		#' library(stringr)
55		#'
56		#' # use non-exported function from goshawk
57		#' h_identify_loq_values <- getFromNamespace("h_identify_loq_values", "goshawk")
58		#'
59		#' # original ARM value = dose value
60		#' arm_mapping <- list(
61		#' "A: Drug X" = "150mg QD",
62		#' "B: Placebo" = "Placebo",
63		#' "C: Combination" = "Combination"
64		#' )
65		#' set.seed(1)
66		#' ADSL <- rADSL
67		#' ADLB <- rADLB
68		#' var_labels <- lapply(ADLB, function(x) attributes(x)$label)
69		#' ADLB <- ADLB %>%
70		#' mutate(
71		#' AVISITCD = case_when(
72		#' AVISIT == "SCREENING" ~ "SCR",
73		#' AVISIT == "BASELINE" ~ "BL",
74		#' grepl("WEEK", AVISIT) ~ paste("W", str_extract(AVISIT, "(?<=(WEEK ))[0-9]+")),
75		#' TRUE ~ as.character(NA)
76		#' ),
77		#' AVISITCDN = case_when(
78		#' AVISITCD == "SCR" ~ -2,
79		#' AVISITCD == "BL" ~ 0,
80		#' grepl("W", AVISITCD) ~ as.numeric(gsub("[^0-9]*", "", AVISITCD)),
81		#' TRUE ~ as.numeric(NA)
82		#' ),
83		#' AVISITCD = factor(AVISITCD) %>% reorder(AVISITCDN),
84		#' TRTORD = case_when(
85		#' ARMCD == "ARM C" ~ 1,
86		#' ARMCD == "ARM B" ~ 2,
87		#' ARMCD == "ARM A" ~ 3
88		#' ),
89		#' ARM = as.character(arm_mapping[match(ARM, names(arm_mapping))]),
90		#' ARM = factor(ARM) %>% reorder(TRTORD),
91		#' ACTARM = as.character(arm_mapping[match(ACTARM, names(arm_mapping))]),
92		#' ACTARM = factor(ACTARM) %>% reorder(TRTORD),
93		#' ANRLO = 50,
94		#' ANRHI = 75
95		#' ) %>%
96		#' rowwise() %>%
97		#' group_by(PARAMCD) %>%
98		#' mutate(LBSTRESC = ifelse(
99		#' USUBJID %in% sample(USUBJID, 1, replace = TRUE),
100		#' paste("<", round(runif(1, min = 25, max = 30))), LBSTRESC
101		#' )) %>%
102		#' mutate(LBSTRESC = ifelse(
103		#' USUBJID %in% sample(USUBJID, 1, replace = TRUE),
104		#' paste(">", round(runif(1, min = 70, max = 75))), LBSTRESC
105		#' )) %>%
106		#' ungroup()
107		#'
108		#' attr(ADLB[["ARM"]], "label") <- var_labels[["ARM"]]
109		#' attr(ADLB[["ACTARM"]], "label") <- var_labels[["ACTARM"]]
110		#' attr(ADLB[["ANRLO"]], "label") <- "Analysis Normal Range Lower Limit"
111		#' attr(ADLB[["ANRHI"]], "label") <- "Analysis Normal Range Upper Limit"
112		#'
113		#' # add LLOQ and ULOQ variables
114		#' ALB_LOQS <- h_identify_loq_values(ADLB, "LOQFL")
115		#' ADLB <- left_join(ADLB, ALB_LOQS, by = "PARAM")
116		#' })
117		#'
118		#' datanames <- c("ADSL", "ADLB")
119		#' datanames(data) <- datanames
120		#'
121		#' join_keys(data) <- default_cdisc_join_keys[datanames]
122		#'
123		#' app <- init(
124		#' data = data,
125		#' modules = modules(
126		#' tm_g_gh_boxplot(
127		#' label = "Box Plot",
128		#' dataname = "ADLB",
129		#' param_var = "PARAMCD",
130		#' param = choices_selected(c("ALT", "CRP", "IGA"), "ALT"),
131		#' yaxis_var = choices_selected(c("AVAL", "BASE", "CHG"), "AVAL"),
132		#' xaxis_var = choices_selected(c("ACTARM", "ARM", "AVISITCD", "STUDYID"), "ARM"),
133		#' facet_var = choices_selected(c("ACTARM", "ARM", "AVISITCD", "SEX"), "AVISITCD"),
134		#' trt_group = choices_selected(c("ARM", "ACTARM"), "ARM"),
135		#' loq_legend = TRUE,
136		#' rotate_xlab = FALSE,
137		#' hline_arb = c(60, 55),
138		#' hline_arb_color = c("grey", "red"),
139		#' hline_arb_label = c("default_hori_A", "default_hori_B"),
140		#' hline_vars = c("ANRHI", "ANRLO", "ULOQN", "LLOQN"),
141		#' hline_vars_colors = c("pink", "brown", "purple", "black"),
142		#' )
143		#' )
144		#' )
145		#' if (interactive()) {
146		#' shinyApp(app$ui, app$server)
147		#' }
148		#'
149		tm_g_gh_boxplot <- function(label,
150		dataname,
151		param_var,
152		param,
153		yaxis_var = teal.transform::choices_selected(c("AVAL", "CHG"), "AVAL"),
154		xaxis_var = teal.transform::choices_selected("AVISITCD", "AVISITCD"),
155		facet_var = teal.transform::choices_selected(c("ARM", "ACTARM"), "ARM"),
156		trt_group,
157		color_manual = NULL,
158		shape_manual = NULL,
159		facet_ncol = NULL,
160		loq_legend = TRUE,
161		rotate_xlab = FALSE,
162		hline_arb = numeric(0),
163		hline_arb_color = "red",
164		hline_arb_label = "Horizontal line",
165		hline_vars = character(0),
166		hline_vars_colors = "green",
167		hline_vars_labels = hline_vars,
168		plot_height = c(600, 200, 2000),
169		plot_width = NULL,
170		font_size = c(12, 8, 20),
171		dot_size = c(2, 1, 12),
172		alpha = c(0.8, 0.0, 1.0),
173		pre_output = NULL,
174		post_output = NULL) {
175	1x	message("Initializing tm_g_gh_boxplot")
176	1x	checkmate::assert_string(label)
177	1x	checkmate::assert_string(dataname)
178	1x	checkmate::assert_string(param_var)
179	1x	checkmate::assert_class(param, "choices_selected")
180	1x	checkmate::assert_class(yaxis_var, "choices_selected")
181	1x	checkmate::assert_class(xaxis_var, "choices_selected")
182	1x	checkmate::assert_class(facet_var, "choices_selected")
183	1x	checkmate::assert_class(trt_group, "choices_selected")
184	1x	checkmate::assert_int(facet_ncol, null.ok = TRUE)
185	1x	checkmate::assert_flag(loq_legend)
186	1x	checkmate::assert_flag(rotate_xlab)
187	1x	checkmate::assert_numeric(font_size, len = 3)
188	1x	checkmate::assert_numeric(dot_size, len = 3)
189	1x	checkmate::assert_numeric(alpha, len = 3)
190	1x	validate_line_arb_arg(hline_arb, hline_arb_color, hline_arb_label)
191	1x	validate_line_vars_arg(hline_vars, hline_vars_colors, hline_vars_labels)
192	1x	checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
193	1x	checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")
194	1x	checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
195	1x	checkmate::assert_numeric(
196	1x	plot_width[1],
197	1x	lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"
198		)
199
200	1x	args <- as.list(environment())
201
202	1x	module(
203	1x	label = label,
204	1x	datanames = dataname,
205	1x	server = srv_g_boxplot,
206	1x	server_args = list(
207	1x	dataname = dataname,
208	1x	param_var = param_var,
209	1x	color_manual = color_manual,
210	1x	shape_manual = shape_manual,
211	1x	plot_height = plot_height,
212	1x	plot_width = plot_width,
213	1x	hline_vars_colors = hline_vars_colors,
214	1x	hline_vars_labels = hline_vars_labels,
215	1x	module_args = args
216		),
217	1x	ui = ui_g_boxplot,
218	1x	ui_args = args
219		)
220		}
221
222		ui_g_boxplot <- function(id, ...) {
223	1x	ns <- NS(id)
224	1x	a <- list(...)
225
226	1x	teal.widgets::standard_layout(
227	1x	output = tags$div(
228	1x	fluidRow(
229	1x	teal.widgets::plot_with_settings_ui(id = ns("boxplot"))
230		),
231	1x	fluidRow(column(
232	1x	width = 12,
233	1x	tags$br(), tags$hr(),
234	1x	tags$h4("Selected Data Points"),
235	1x	DT::dataTableOutput(ns("brush_data"))
236		)),
237	1x	fluidRow(column(
238	1x	width = 12,
239	1x	tags$br(), tags$hr(),
240	1x	tags$h4("Descriptive Statistics"),
241	1x	DT::dataTableOutput(ns("table_ui"))
242		))
243		),
244	1x	encoding = tags$div(
245		### Reporter
246	1x	teal.reporter::simple_reporter_ui(ns("simple_reporter")),
247		###
248	1x	templ_ui_dataname(a$dataname),
249	1x	uiOutput(ns("axis_selections")),
250	1x	templ_ui_constraint(ns, label = "Data Constraint"), # required by constr_anl_q
251	1x	if (length(a$hline_vars) > 0) {
252	1x	teal.widgets::optionalSelectInput(
253	1x	ns("hline_vars"),
254	1x	label = "Add Horizontal Range Line(s):",
255	1x	choices = a$hline_vars,
256	1x	selected = NULL,
257	1x	multiple = TRUE
258		)
259		},
260	1x	ui_arbitrary_lines(id = ns("hline_arb"), a$hline_arb, a$hline_arb_label, a$hline_arb_color),
261	1x	teal.widgets::panel_group(
262	1x	teal.widgets::panel_item(
263	1x	title = "Plot Aesthetic Settings",
264	1x	toggle_slider_ui(
265	1x	ns("yrange_scale"),
266	1x	label = "Y-Axis Range Zoom"
267		),
268	1x	numericInput(ns("facet_ncol"), "Number of Plots Per Row:", a$facet_ncol, min = 1),
269	1x	checkboxInput(ns("loq_legend"), "Display LoQ Legend", a$loq_legend),
270	1x	checkboxInput(ns("rotate_xlab"), "Rotate X-axis Label", a$rotate_xlab)
271		),
272	1x	teal.widgets::panel_item(
273	1x	title = "Plot settings",
274	1x	teal.widgets::optionalSliderInputValMinMax(ns("font_size"), "Font Size", a$font_size, ticks = FALSE),
275	1x	teal.widgets::optionalSliderInputValMinMax(ns("dot_size"), "Dot Size", a$dot_size, ticks = FALSE),
276	1x	teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Dot Alpha", a$alpha, ticks = FALSE)
277		)
278		)
279		),
280	1x	forms = tagList(
281	1x	teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
282		),
283	1x	pre_output = a$pre_output,
284	1x	post_output = a$post_output
285		)
286		}
287
288
289		srv_g_boxplot <- function(id,
290		data,
291		reporter,
292		filter_panel_api,
293		dataname,
294		param_var,
295		trt_group,
296		color_manual,
297		shape_manual,
298		plot_height,
299		plot_width,
300		hline_vars_colors,
301		hline_vars_labels,
302		module_args) {
303	1x	with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
304	1x	with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
305	1x	checkmate::assert_class(data, "reactive")
306	1x	checkmate::assert_class(shiny::isolate(data()), "teal_data")
307
308	1x	moduleServer(id, function(input, output, session) {
309	1x	teal.logger::log_shiny_input_changes(input, namespace = "teal.goshawk")
310	1x	output$axis_selections <- renderUI({
311	1x	env <- shiny::isolate(as.list(data()@env))
312	1x	resolved_x <- teal.transform::resolve_delayed(module_args$xaxis_var, env)
313	1x	resolved_y <- teal.transform::resolve_delayed(module_args$yaxis_var, env)
314	1x	resolved_param <- teal.transform::resolve_delayed(module_args$param, env)
315	1x	resolved_facet_var <- teal.transform::resolve_delayed(module_args$facet_var, env)
316	1x	resolved_trt <- teal.transform::resolve_delayed(module_args$trt_group, env)
317
318	1x	templ_ui_params_vars(
319	1x	session$ns,
320	1x	xparam_choices = resolved_param$choices,
321	1x	xparam_selected = resolved_param$selected,
322	1x	xparam_label = module_args$"Select a Biomarker",
323	1x	xchoices = resolved_x$choices,
324	1x	xselected = resolved_x$selected,
325	1x	ychoices = resolved_y$choices,
326	1x	yselected = resolved_y$selected,
327	1x	facet_choices = resolved_facet_var$choices,
328	1x	facet_selected = resolved_facet_var$selected,
329	1x	trt_choices = resolved_trt$choices,
330	1x	trt_selected = resolved_trt$selected
331		)
332		})
333		# reused in all modules
334	1x	anl_q_output <- constr_anl_q(
335	1x	session, input, data, dataname,
336	1x	param_id = "xaxis_param", param_var = param_var, trt_group = input$trt_group, min_rows = 2
337		)
338
339	1x	anl_q <- anl_q_output()$value
340
341		# update sliders for axes taking constraints into account
342	1x	data_state <- reactive({
343	3x	get_data_range_states(
344	3x	varname = input$yaxis_var,
345	3x	paramname = input$xaxis_param,
346	3x	ANL = anl_q()$ANL
347		)
348		})
349	1x	yrange_slider_state <- toggle_slider_server("yrange_scale", data_state)
350	1x	keep_data_const_opts_updated(session, input, anl_q, "xaxis_param")
351
352	1x	horizontal_line <- srv_arbitrary_lines("hline_arb")
353
354	1x	trt_group <- reactive({
355	1x	input$trt_group
356		})
357
358	1x	iv_r <- reactive({
359	1x	iv <- shinyvalidate::InputValidator$new()
360
361	1x	iv$add_rule("xaxis_param", shinyvalidate::sv_required("Please select a biomarker"))
362	1x	iv$add_rule("trt_group", shinyvalidate::sv_required("Please select a treatment variable"))
363	1x	iv$add_rule("xaxis_var", shinyvalidate::sv_required("Please select an X-Axis variable"))
364	1x	iv$add_rule("xaxis_var", ~ if ((.) %in% c("ACTARM", "ARM") && isTRUE((.) != trt_group())) {
365	!	sprintf("You can not choose %s as x-axis variable for treatment variable %s.", (.), trt_group())
366		})
367	1x	iv$add_rule("yaxis_var", shinyvalidate::sv_required("Please select a Y-Axis variable"))
368
369	1x	iv$add_rule("facet_var", shinyvalidate::sv_optional())
370	1x	iv$add_rule("facet_var", ~ if ((.) %in% c("ACTARM", "ARM") && isTRUE((.) != trt_group())) {
371	!	sprintf("You can not choose %s as faceting variable for treatment variable %s.", (.), trt_group())
372		})
373
374	1x	iv_facet <- shinyvalidate::InputValidator$new()
375	1x	iv_facet$condition(~ !is.null(input$facet_var))
376	1x	iv_facet$add_rule("facet_ncol", plots_per_row_validate_rules(required = FALSE))
377	1x	iv$add_validator(iv_facet)
378
379	1x	iv$add_validator(horizontal_line()$iv_r())
380	1x	iv$add_validator(anl_q_output()$iv_r())
381	1x	iv$enable()
382	1x	iv
383		})
384
385	1x	create_plot <- debounce(reactive({
386	12x	teal::validate_inputs(iv_r())
387
388	11x	req(anl_q())
389		# nolint start
390	11x	param <- input$xaxis_param
391	11x	yaxis <- input$yaxis_var
392	11x	xaxis <- input$xaxis_var
393	11x	facet_var <- `if`(is.null(input$facet_var), "None", input$facet_var)
394	11x	ylim <- yrange_slider_state$value
395	11x	facet_ncol <- input$facet_ncol
396
397	11x	alpha <- input$alpha
398	11x	font_size <- input$font_size
399	11x	dot_size <- input$dot_size
400	11x	loq_legend <- input$loq_legend
401	11x	rotate_xlab <- input$rotate_xlab
402
403	11x	hline_arb <- horizontal_line()$line_arb
404	11x	hline_arb_label <- horizontal_line()$line_arb_label
405	11x	hline_arb_color <- horizontal_line()$line_arb_color
406
407	11x	hline_vars <- input$hline_vars
408	11x	trt_group <- input$trt_group
409		# nolint end
410
411	11x	validate_has_variable(
412	11x	anl_q()$ANL,
413	11x	yaxis,
414	11x	sprintf("Variable %s is not available in data %s", yaxis, dataname)
415		)
416	11x	validate_has_variable(
417	11x	anl_q()$ANL,
418	11x	xaxis,
419	11x	sprintf("Variable %s is not available in data %s", xaxis, dataname)
420		)
421
422	11x	if (!facet_var == "None") {
423	11x	validate_has_variable(
424	11x	anl_q()$ANL,
425	11x	facet_var,
426	11x	sprintf("Variable %s is not available in data %s", facet_var, dataname)
427		)
428		}
429
430	11x	anl_q()$qenv %>% teal.code::eval_code(
431	11x	code = bquote({
432	11x	p <- goshawk::g_boxplot(
433	11x	data = ANL,
434	11x	biomarker = .(param),
435	11x	xaxis_var = .(xaxis),
436	11x	yaxis_var = .(yaxis),
437	11x	hline_arb = .(hline_arb),
438	11x	hline_arb_label = .(hline_arb_label),
439	11x	hline_arb_color = .(hline_arb_color),
440	11x	hline_vars = .(hline_vars),
441	11x	hline_vars_colors = .(hline_vars_colors[seq_along(hline_vars)]),
442	11x	hline_vars_labels = .(hline_vars_labels[seq_along(hline_vars)]),
443	11x	facet_ncol = .(facet_ncol),
444	11x	loq_legend = .(loq_legend),
445	11x	rotate_xlab = .(rotate_xlab),
446	11x	trt_group = .(trt_group),
447	11x	ylim = .(ylim),
448	11x	color_manual = .(color_manual),
449	11x	shape_manual = .(shape_manual),
450	11x	facet_var = .(facet_var),
451	11x	alpha = .(alpha),
452	11x	dot_size = .(dot_size),
453	11x	font_size = .(font_size),
454	11x	unit = .("AVALU")
455		)
456	10x	print(p)
457		})
458		)
459	1x	}), 800)
460
461	1x	create_table <- debounce(reactive({
462	3x	req(iv_r()$is_valid())
463	2x	req(anl_q())
464	2x	param <- input$xaxis_param
465	2x	xaxis_var <- input$yaxis_var # nolint
466	2x	font_size <- input$font_size
467	2x	trt_group <- input$trt_group
468	2x	facet_var <- input$facet_var
469
470	2x	anl_q()$qenv %>% teal.code::eval_code(
471	2x	code = bquote({
472	2x	tbl <- goshawk::t_summarytable(
473	2x	data = ANL,
474	2x	trt_group = .(trt_group),
475	2x	param_var = .(param_var),
476	2x	param = .(param),
477	2x	xaxis_var = .(xaxis_var),
478	2x	facet_var = .(facet_var)
479		)
480	2x	tbl
481		})
482		)
483	1x	}), 800)
484
485	1x	plot_r <- reactive({
486	10x	create_plot()[["p"]]
487		})
488
489	1x	boxplot_data <- teal.widgets::plot_with_settings_srv(
490	1x	id = "boxplot",
491	1x	plot_r = plot_r,
492	1x	height = plot_height,
493	1x	width = plot_width,
494	1x	brushing = TRUE
495		)
496
497	1x	output$table_ui <- DT::renderDataTable({
498	3x	req(create_table())
499	2x	tbl <- create_table()[["tbl"]]
500
501	2x	numeric_cols <- setdiff(names(dplyr::select_if(tbl, is.numeric)), "n")
502
503	2x	DT::datatable(tbl,
504	2x	rownames = FALSE, options = list(scrollX = TRUE)
505		) %>%
506	2x	DT::formatRound(numeric_cols, 4)
507		})
508
509	1x	joined_qenvs <- reactive({
510	!	req(create_plot(), create_table())
511	!	teal.code::join(create_plot(), create_table())
512		})
513
514	1x	code <- reactive(teal.code::get_code(joined_qenvs()))
515
516		### REPORTER
517	1x	if (with_reporter) {
518	1x	card_fun <- function(comment, label) {
519	!	constraint_description <- paste(
520	!	"\nFacet By:",
521	!	if (length(input$facet_var) != 0) input$facet_var else "None",
522	!	"\nSelect an X-axis Variable:",
523	!	input$xaxis_var
524		)
525	!	card <- report_card_template_goshawk(
526	!	title = "Box Plot",
527	!	label = label,
528	!	with_filter = with_filter,
529	!	filter_panel_api = filter_panel_api,
530	!	constraint_list = list(
531	!	constraint_var = input$constraint_var,
532	!	constraint_range_min = input$constraint_range_min,
533	!	constraint_range_max = input$constraint_range_max
534		),
535	!	constraint_description = constraint_description,
536	!	style = "verbatim"
537		)
538	!	card$append_text("Plot", "header3")
539	!	card$append_plot(plot_r(), dim = boxplot_data$dim())
540	!	if (!comment == "") {
541	!	card$append_text("Comment", "header3")
542	!	card$append_text(comment)
543		}
544	!	card$append_src(code())
545	!	card
546		}
547	1x	teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
548		}
549		###
550
551		# highlight plot area
552	1x	reactive_df <- debounce(reactive({
553	2x	boxplot_brush <- boxplot_data$brush()
554
555	2x	ANL <- isolate(anl_q()$ANL) %>% droplevels() # nolint
556	1x	validate_has_data(ANL, 2)
557
558	1x	xvar <- isolate(input$xaxis_var)
559	1x	yvar <- isolate(input$yaxis_var)
560	1x	facetv <- isolate(input$facet_var)
561	1x	trt_group <- isolate(input$trt_group)
562
563	1x	req(all(c(xvar, yvar, facetv, trt_group) %in% names(ANL)))
564
565	1x	teal.widgets::clean_brushedPoints(
566	1x	dplyr::select(
567	1x	ANL, "USUBJID", dplyr::all_of(c(trt_group, facetv)),
568	1x	"AVISITCD", "PARAMCD", dplyr::all_of(c(xvar, yvar)), "LOQFL"
569		),
570	1x	boxplot_brush
571		)
572	1x	}), 800)
573
574	1x	output$brush_data <- DT::renderDataTable({
575	2x	numeric_cols <- names(dplyr::select_if(reactive_df(), is.numeric))
576
577	1x	DT::datatable(reactive_df(),
578	1x	rownames = FALSE, options = list(scrollX = TRUE)
579		) %>%
580	1x	DT::formatRound(numeric_cols, 4)
581		})
582
583	1x	teal.widgets::verbatim_popup_srv(
584	1x	id = "rcode",
585	1x	verbatim_content = reactive(code()),
586	1x	title = "Show R Code for Boxplot"
587		)
588		})
589		}

1		#' Scatter Plot Teal Module For Biomarker Analysis
2		#'
3		#' @description
4		#' `r lifecycle::badge("deprecated")`
5		#'
6		#' `tm_g_gh_scatterplot` is deprecated. Please use [tm_g_gh_correlationplot]
7		#' instead.
8		#'
9		#' @inheritParams teal.widgets::standard_layout
10		#' @param label menu item label of the module in the teal app.
11		#' @param dataname analysis data passed to the data argument of \code{\link[teal]{init}}. E.g. `ADaM` structured
12		#' laboratory data frame \code{ADLB}.
13		#' @param param_var name of variable containing biomarker codes e.g. \code{PARAMCD}.
14		#' @param param biomarker selected.
15		#' @param xaxis_var name of variable containing biomarker results displayed on `x-axis` e.g. \code{BASE}.
16		#' @param yaxis_var name of variable containing biomarker results displayed on `y-axis` e.g. \code{AVAL}.
17		#' @param trt_group \code{\link[teal.transform]{choices_selected}} object with available choices and pre-selected option
18		#' for variable names representing treatment group e.g. `ARM`.
19		#' @param color_manual vector of colors applied to treatment values.
20		#' @param shape_manual vector of symbols applied to `LOQ` values.
21		#' @param facet_ncol numeric value indicating number of facets per row.
22		#' @param trt_facet facet by treatment group \code{trt_group}.
23		#' @param reg_line include regression line and annotations for slope and coefficient in visualization. Use with facet
24		#' TRUE.
25		#' @param rotate_xlab 45 degree rotation of `x-axis` values.
26		#' @param hline y-axis value to position of horizontal line.
27		#' @param vline x-axis value to position a vertical line.
28		#' @param plot_height controls plot height.
29		#' @param plot_width optional, controls plot width.
30		#' @param font_size font size control for title, `x-axis` label, `y-axis` label and legend.
31		#' @param dot_size plot dot size.
32		#' @param reg_text_size font size control for regression line annotations.
33		#'
34		#'
35		#' @export
36		#'
37		#' @author Nick Paszty (npaszty) paszty.nicholas@gene.com
38		#' @author Balazs Toth (tothb2) toth.balazs@gene.com
39		#'
40		#' @examples
41		#' # Example using ADaM structure analysis dataset.
42		#' data <- teal_data()
43		#' data <- within(data, {
44		#' library(dplyr)
45		#' library(stringr)
46		#'
47		#' # original ARM value = dose value
48		#' arm_mapping <- list(
49		#' "A: Drug X" = "150mg QD",
50		#' "B: Placebo" = "Placebo",
51		#' "C: Combination" = "Combination"
52		#' )
53		#'
54		#' ADSL <- rADSL
55		#' ADLB <- rADLB
56		#' var_labels <- lapply(ADLB, function(x) attributes(x)$label)
57		#' ADLB <- ADLB %>%
58		#' mutate(
59		#' AVISITCD = case_when(
60		#' AVISIT == "SCREENING" ~ "SCR",
61		#' AVISIT == "BASELINE" ~ "BL",
62		#' grepl("WEEK", AVISIT) ~ paste("W", str_extract(AVISIT, "(?<=(WEEK ))[0-9]+")),
63		#' TRUE ~ as.character(NA)
64		#' ),
65		#' AVISITCDN = case_when(
66		#' AVISITCD == "SCR" ~ -2,
67		#' AVISITCD == "BL" ~ 0,
68		#' grepl("W", AVISITCD) ~ as.numeric(gsub("[^0-9]*", "", AVISITCD)),
69		#' TRUE ~ as.numeric(NA)
70		#' ),
71		#' AVISITCD = factor(AVISITCD) %>% reorder(AVISITCDN),
72		#' TRTORD = case_when(
73		#' ARMCD == "ARM C" ~ 1,
74		#' ARMCD == "ARM B" ~ 2,
75		#' ARMCD == "ARM A" ~ 3
76		#' ),
77		#' ARM = as.character(arm_mapping[match(ARM, names(arm_mapping))]),
78		#' ARM = factor(ARM) %>% reorder(TRTORD),
79		#' ACTARM = as.character(arm_mapping[match(ACTARM, names(arm_mapping))]),
80		#' ACTARM = factor(ACTARM) %>% reorder(TRTORD)
81		#' )
82		#' attr(ADLB[["ARM"]], "label") <- var_labels[["ARM"]]
83		#' attr(ADLB[["ACTARM"]], "label") <- var_labels[["ACTARM"]]
84		#' })
85		#'
86		#' datanames <- c("ADSL", "ADLB")
87		#' datanames(data) <- datanames
88		#' join_keys(data) <- default_cdisc_join_keys[datanames]
89		#'
90		#'
91		#' app <- init(
92		#' data = data,
93		#' modules = modules(
94		#' tm_g_gh_scatterplot(
95		#' label = "Scatter Plot",
96		#' dataname = "ADLB",
97		#' param_var = "PARAMCD",
98		#' param = choices_selected(c("ALT", "CRP", "IGA"), "ALT"),
99		#' xaxis_var = choices_selected(c("AVAL", "BASE", "CHG", "PCHG"), "BASE"),
100		#' yaxis_var = choices_selected(c("AVAL", "BASE", "CHG", "PCHG"), "AVAL"),
101		#' trt_group = choices_selected(c("ARM", "ACTARM"), "ARM"),
102		#' color_manual = c(
103		#' "150mg QD" = "#000000",
104		#' "Placebo" = "#3498DB",
105		#' "Combination" = "#E74C3C"
106		#' ),
107		#' shape_manual = c("N" = 1, "Y" = 2, "NA" = 0),
108		#' plot_height = c(500, 200, 2000),
109		#' facet_ncol = 2,
110		#' trt_facet = FALSE,
111		#' reg_line = FALSE,
112		#' font_size = c(12, 8, 20),
113		#' dot_size = c(1, 1, 12),
114		#' reg_text_size = c(3, 3, 10)
115		#' )
116		#' )
117		#' )
118		#' if (interactive()) {
119		#' shinyApp(app$ui, app$server)
120		#' }
121		#'
122		tm_g_gh_scatterplot <- function(label,
123		dataname,
124		param_var,
125		param,
126		xaxis_var,
127		yaxis_var,
128		trt_group,
129		color_manual = NULL,
130		shape_manual = NULL,
131		facet_ncol = 2,
132		trt_facet = FALSE,
133		reg_line = FALSE,
134		rotate_xlab = FALSE,
135		hline = NULL,
136		vline = NULL,
137		plot_height = c(500, 200, 2000),
138		plot_width = NULL,
139		font_size = c(12, 8, 20),
140		dot_size = c(1, 1, 12),
141		reg_text_size = c(3, 3, 10),
142		pre_output = NULL,
143		post_output = NULL) {
144	!	lifecycle::deprecate_soft(
145	!	when = "0.1.15",
146	!	what = "tm_g_gh_scatterplot()",
147	!	details = "You should use teal.goshawk::tm_g_gh_correlationplot instead of teal.goshawk::tm_g_gh_scatterplot"
148		)
149
150	!	message("Initializing tm_g_gh_scatterplot")
151	!	checkmate::assert_class(param, "choices_selected")
152	!	checkmate::assert_class(xaxis_var, "choices_selected")
153	!	checkmate::assert_class(yaxis_var, "choices_selected")
154	!	checkmate::assert_class(trt_group, "choices_selected")
155	!	checkmate::assert_flag(trt_facet)
156	!	checkmate::assert_flag(reg_line)
157	!	checkmate::assert_flag(rotate_xlab)
158	!	checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
159	!	checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")
160	!	checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
161	!	checkmate::assert_numeric(
162	!	plot_width[1],
163	!	lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"
164		)
165
166	!	args <- as.list(environment())
167
168	!	module(
169	!	label = label,
170	!	datanames = dataname,
171	!	server = srv_g_scatterplot,
172	!	server_args = list(
173	!	dataname = dataname,
174	!	param_var = param_var,
175	!	trt_facet = trt_facet,
176	!	color_manual = color_manual,
177	!	shape_manual = shape_manual,
178	!	plot_height = plot_height,
179	!	plot_width = plot_width,
180	!	module_args = args
181		),
182	!	ui = ui_g_scatterplot,
183	!	ui_args = args
184		)
185		}
186
187		ui_g_scatterplot <- function(id, ...) {
188	!	ns <- NS(id)
189	!	a <- list(...)
190
191	!	teal.widgets::standard_layout(
192	!	output = templ_ui_output_datatable(ns),
193	!	encoding = tags$div(
194		### Reporter
195	!	teal.reporter::simple_reporter_ui(ns("simple_reporter")),
196		###
197	!	templ_ui_dataname(a$dataname),
198	!	uiOutput(ns("axis_selections")),
199	!	templ_ui_constraint(ns), # required by constr_anl_q
200	!	teal.widgets::panel_group(
201	!	teal.widgets::panel_item(
202	!	title = "Plot Aesthetic Settings",
203	!	toggle_slider_ui(
204	!	ns("xrange_scale"),
205	!	label = "X-Axis Range Zoom"
206		),
207	!	toggle_slider_ui(
208	!	ns("yrange_scale"),
209	!	label = "Y-Axis Range Zoom"
210		),
211	!	numericInput(ns("facet_ncol"), "Number of Plots Per Row:", a$facet_ncol, min = 1),
212	!	checkboxInput(ns("trt_facet"), "Treatment Variable Faceting", a$trt_facet),
213	!	checkboxInput(ns("reg_line"), "Regression Line", a$reg_line),
214	!	checkboxInput(ns("rotate_xlab"), "Rotate X-axis Label", a$rotate_xlab),
215	!	numericInput(ns("hline"), "Add a horizontal line:", a$hline),
216	!	numericInput(ns("vline"), "Add a vertical line:", a$vline)
217		),
218	!	teal.widgets::panel_item(
219	!	title = "Plot settings",
220	!	teal.widgets::optionalSliderInputValMinMax(ns("font_size"), "Font Size", a$font_size, ticks = FALSE),
221	!	teal.widgets::optionalSliderInputValMinMax(ns("dot_size"), "Dot Size", a$dot_size, ticks = FALSE),
222	!	teal.widgets::optionalSliderInputValMinMax(
223	!	ns("reg_text_size"),
224	!	"Regression Annotations Size",
225	!	a$reg_text_size,
226	!	ticks = FALSE
227		)
228		)
229		)
230		),
231	!	forms = tagList(
232	!	teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
233		),
234	!	pre_output = a$pre_output,
235	!	post_output = a$post_output
236		)
237		}
238
239		srv_g_scatterplot <- function(id,
240		data,
241		reporter,
242		filter_panel_api,
243		dataname,
244		param_var,
245		trt_group,
246		trt_facet,
247		color_manual,
248		shape_manual,
249		plot_height,
250		plot_width,
251		module_args) {
252	!	with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
253	!	with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
254	!	checkmate::assert_class(data, "reactive")
255	!	checkmate::assert_class(shiny::isolate(data()), "teal_data")
256
257	!	moduleServer(id, function(input, output, session) {
258	!	teal.logger::log_shiny_input_changes(input, namespace = "teal.goshawk")
259	!	output$axis_selections <- renderUI({
260	!	env <- shiny::isolate(as.list(data()@env))
261	!	resolved_x <- teal.transform::resolve_delayed(module_args$xaxis_var, env)
262	!	resolved_y <- teal.transform::resolve_delayed(module_args$yaxis_var, env)
263	!	resolved_param <- teal.transform::resolve_delayed(module_args$param, env)
264	!	resolved_trt <- teal.transform::resolve_delayed(module_args$trt_group, env)
265	!	templ_ui_params_vars(
266	!	session$ns,
267		# xparam and yparam are identical, so we only show the user one
268	!	xparam_choices = resolved_param$choices,
269	!	xparam_selected = resolved_param$selected,
270	!	xparam_label = "Select a Biomarker",
271	!	xchoices = resolved_x$choices,
272	!	xselected = resolved_x$selected,
273	!	ychoices = resolved_y$choices,
274	!	yselected = resolved_y$selected,
275	!	trt_choices = resolved_trt$choices,
276	!	trt_selected = resolved_trt$selected
277		)
278		})
279
280		# reused in all modules
281	!	anl_q_output <- constr_anl_q(
282	!	session, input, data, dataname,
283	!	param_id = "xaxis_param", param_var = param_var, trt_group = input$trt_group, min_rows = 1
284		)
285
286	!	anl_q <- anl_q_output()$value
287
288		# update sliders for axes taking constraints into account
289	!	data_state_x <- reactive({
290	!	get_data_range_states(
291	!	varname = input$xaxis_var,
292	!	paramname = input$xaxis_param,
293	!	ANL = anl_q()$ANL
294		)
295		})
296	!	xrange_slider <- toggle_slider_server("xrange_scale", data_state_x)
297	!	data_state_y <- reactive({
298	!	get_data_range_states(
299	!	varname = input$yaxis_var,
300	!	paramname = input$xaxis_param,
301	!	ANL = anl_q()$ANL
302		)
303		})
304	!	yrange_slider <- toggle_slider_server("yrange_scale", data_state_y)
305
306	!	keep_data_const_opts_updated(session, input, anl_q, "xaxis_param")
307
308		# plot
309	!	plot_q <- debounce(reactive({
310	!	req(anl_q())
311		# nolint start
312	!	xlim <- xrange_slider$value
313	!	ylim <- yrange_slider$value
314	!	facet_ncol <- input$facet_ncol
315	!	validate(need(
316	!	is.na(facet_ncol) \|\| (as.numeric(facet_ncol) > 0 && as.numeric(facet_ncol) %% 1 == 0),
317	!	"Number of plots per row must be a positive integer"
318		))
319	!	reg_line <- input$reg_line
320	!	font_size <- input$font_size
321	!	dot_size <- input$dot_size
322	!	reg_text_size <- input$reg_text_size
323	!	rotate_xlab <- input$rotate_xlab
324	!	hline <- input$hline
325	!	vline <- input$vline
326	!	trt_group <- input$trt_group
327	!	facet <- input$trt_facet
328	!	validate(need(trt_group, "Please select a treatment variable"))
329
330		# Below inputs should trigger plot via updates of other reactive objects (i.e. anl_q()) and some inputs
331	!	validate(need(input$xaxis_var, "Please select an X-Axis Variable"))
332	!	validate(need(input$yaxis_var, "Please select a Y-Axis Variable"))
333	!	param <- input$xaxis_param
334	!	xaxis <- input$xaxis_var
335	!	yaxis <- input$yaxis_var
336
337		# nolint end
338	!	teal.code::eval_code(
339	!	object = anl_q()$qenv,
340	!	code = bquote({
341		# re-establish treatment variable label
342	!	p <- goshawk::g_scatterplot(
343	!	data = ANL,
344	!	param_var = .(param_var),
345	!	param = .(param),
346	!	xaxis_var = .(xaxis),
347	!	yaxis_var = .(yaxis),
348	!	trt_group = .(trt_group),
349	!	xlim = .(xlim),
350	!	ylim = .(ylim),
351	!	color_manual = .(color_manual),
352	!	shape_manual = .(shape_manual),
353	!	facet_ncol = .(facet_ncol),
354	!	facet = .(facet),
355	!	facet_var = .(trt_group),
356	!	reg_line = .(reg_line),
357	!	font_size = .(font_size),
358	!	dot_size = .(dot_size),
359	!	reg_text_size = .(reg_text_size),
360	!	rotate_xlab = .(rotate_xlab),
361	!	hline = .(`if`(is.na(hline), NULL, as.numeric(hline))),
362	!	vline = .(`if`(is.na(vline), NULL, as.numeric(vline)))
363		)
364	!	print(p)
365		})
366		)
367	!	}), 800)
368
369	!	plot_r <- reactive(plot_q()[["p"]])
370
371	!	plot_data <- teal.widgets::plot_with_settings_srv(
372	!	id = "plot",
373	!	plot_r = plot_r,
374	!	height = plot_height,
375	!	width = plot_width,
376	!	brushing = TRUE
377		)
378
379	!	code <- reactive(teal.code::get_code(plot_q()))
380
381		### REPORTER
382	!	if (with_reporter) {
383	!	card_fun <- function(comment, label) {
384	!	constraint_description <- paste(
385	!	"\nTreatment Variable Faceting:",
386	!	input$trt_facet,
387	!	"\nRegression Line:",
388	!	input$reg_line
389		)
390	!	card <- report_card_template_goshawk(
391	!	title = "Scatter Plot",
392	!	label = label,
393	!	with_filter = with_filter,
394	!	filter_panel_api = filter_panel_api,
395	!	constraint_list = list(
396	!	constraint_var = input$constraint_var,
397	!	constraint_range_min = input$constraint_range_min,
398	!	constraint_range_max = input$constraint_range_max
399		),
400	!	constraint_description = constraint_description,
401	!	style = "verbatim"
402		)
403	!	card$append_text("Scatter Plot", "header3")
404	!	card$append_plot(plot_r(), dim = plot_data$dim())
405	!	if (!comment == "") {
406	!	card$append_text("Comment", "header3")
407	!	card$append_text(comment)
408		}
409	!	card$append_src(code())
410	!	card
411		}
412	!	teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
413		}
414		###
415
416	!	reactive_df <- debounce(reactive({
417	!	plot_brush <- plot_data$brush()
418
419	!	ANL <- isolate(anl_q()$ANL) # nolint
420	!	validate_has_data(ANL, 1)
421
422	!	xvar <- isolate(input$xaxis_var)
423	!	yvar <- isolate(input$yaxis_var)
424	!	trt_group <- isolate(input$trt_group)
425
426	!	req(all(c(xvar, yvar) %in% names(ANL)))
427
428	!	teal.widgets::clean_brushedPoints(
429	!	dplyr::select(
430	!	ANL, "USUBJID", dplyr::all_of(trt_group), "AVISITCD", "PARAMCD",
431	!	dplyr::all_of(c(xvar, yvar)), "LOQFL"
432		),
433	!	plot_brush
434		)
435	!	}), 800)
436
437		# highlight plot area
438	!	output$brush_data <- DT::renderDataTable({
439	!	numeric_cols <- names(dplyr::select_if(reactive_df(), is.numeric))
440
441	!	DT::datatable(reactive_df(),
442	!	rownames = FALSE, options = list(scrollX = TRUE)
443		) %>%
444	!	DT::formatRound(numeric_cols, 4)
445		})
446
447	!	teal.widgets::verbatim_popup_srv(
448	!	id = "rcode",
449	!	verbatim_content = reactive(code()),
450	!	title = "Show R Code for Scatterplot"
451		)
452		})
453		}

1		templ_ui_constraint <- function(ns, label = "Data Constraint") {
2	1x	tags$div(
3	1x	id = ns("constraint_var_whole"), # give an id to hide it
4	1x	radioButtons(ns("constraint_var"), label, choices = "NONE"),
5	1x	shinyjs::hidden(tags$div(
6	1x	id = ns("constraint_range"),
7	1x	tags$div(
8	1x	class = "inline-block;",
9	1x	numericInput(ns("constraint_range_min"), label = "Min", value = 0, min = 0, max = 0)
10		),
11	1x	tags$div(
12	1x	class = "inline-block;",
13	1x	numericInput(ns("constraint_range_max"), label = "Min", value = 0, min = 0, max = 0)
14		)
15		)),
16	1x	shinyjs::hidden(tags$div(
17	1x	id = ns("all_na"),
18	1x	helpText("All values are missing (NA)")
19		))
20		)
21		}
22
23		keep_data_const_opts_updated <- function(session, input, data, id_param_var) {
24		# use reactiveVal so that it only updates when options actually changed and not just data
25	1x	choices <- reactiveVal()
26	1x	observeEvent(data(), {
27	2x	paramname <- input[[id_param_var]]
28	2x	req(length(paramname) == 1)
29
30	2x	data_filtered <- data()$ANL %>% dplyr::filter(.data$PARAMCD == paramname)
31	2x	choices(c("None" = "NONE", "Screening" = "BASE2", "Baseline" = "BASE")[
32	2x	c(TRUE, !all(is.na(data_filtered[["BASE2"]])), !all(is.na(data_filtered[["BASE"]])))
33		])
34		})
35	1x	observeEvent(choices(), {
36	1x	updateRadioButtons(session, "constraint_var", choices = choices())
37		# hide when only one option "NONE"
38	1x	if (length(choices()) == 1) {
39	!	shinyjs::hide("constraint_var_whole")
40		} else {
41	1x	shinyjs::show("constraint_var_whole")
42		}
43		})
44		}
45
46
47
48
49		# param_id: input id that contains values of PARAMCD to filter for
50		# param_var: currently only "PARAMCD" is supported
51		constr_anl_q <- function(session, input, data, dataname, param_id, param_var, trt_group, min_rows) {
52	1x	checkmate::assert_class(data, "reactive")
53	1x	checkmate::assert_class(shiny::isolate(data()), "teal_data")
54	1x	dataset_var <- dataname
55	1x	if (!identical(param_var, "PARAMCD")) {
56		# why is there a variable param_id which is provided to this function and always equal to "param"?
57	!	stop("param_var must be 'PARAMCD'. Otherwise, we cannot currently guarantee the correctness of the code.")
58		}
59
60	1x	anl_param <- reactive({
61	3x	param_var_value <- input[[param_id]] # value to filter PARAMCD for
62	3x	validate(need(param_var_value, "Please select a biomarker"))
63	2x	checkmate::assert_string(param_var_value)
64
65	2x	ANL <- data()[[dataname]] # nolint
66	2x	validate_has_data(ANL, min_rows)
67
68	2x	validate_has_variable(ANL, param_var)
69	2x	validate_has_variable(ANL, "AVISITCD")
70	2x	validate_has_variable(ANL, "BASE")
71	2x	validate_has_variable(ANL, "BASE2")
72	2x	validate_has_variable(ANL, trt_group)
73
74		# analysis
75	2x	private_qenv <- data() %>%
76	2x	teal.code::eval_code(
77	2x	substitute(ANL <- dataname, list(dataname = as.name(dataname))) # nolint
78		) %>%
79	2x	teal.code::eval_code(
80	2x	code = bquote({
81	2x	ANL <- .(as.name(dataset_var)) %>% # nolint
82	2x	dplyr::filter(.(as.name(param_var)) == .(param_var_value))
83		})
84		)
85	2x	validate_has_data(private_qenv[["ANL"]], min_rows)
86	2x	list(ANL = ANL, qenv = private_qenv)
87		})
88
89	1x	observe({
90	3x	param_var_value <- input[[param_id]]
91	3x	validate(need(param_var_value, "Please select a biomarker"))
92
93	2x	constraint_var <- input[["constraint_var"]]
94	2x	validate(need(constraint_var, "select a constraint variable"))
95
96	2x	ANL <- data()[[dataname]] # nolint
97	2x	validate_has_data(ANL, min_rows)
98
99	2x	validate_has_variable(ANL, param_var)
100	2x	validate_has_variable(ANL, "AVISITCD")
101	2x	validate_has_variable(ANL, "BASE")
102	2x	validate_has_variable(ANL, "BASE2")
103
104	2x	ANL <- ANL %>% dplyr::filter(!!sym(param_var) == param_var_value) # nolint
105
106	2x	visit_freq <- unique(ANL$AVISITCD)
107
108		# get min max values
109	2x	if ((constraint_var == "BASE2" && any(grepl("SCR", visit_freq))) \|\|
110	2x	(constraint_var == "BASE" && any(grepl("BL", visit_freq)))) { # nolint
111	!	val <- stats::na.omit(switch(constraint_var,
112	!	"BASE" = ANL$BASE[ANL$AVISITCD == "BL"],
113	!	"BASE2" = ANL$BASE2[ANL$AVISITCD == "SCR"],
114	!	stop(paste(constraint_var, "not allowed"))
115		))
116
117	!	if (length(val) == 0 \|\| all(is.na(val))) {
118	!	shinyjs::show("all_na")
119	!	shinyjs::hide("constraint_range")
120	!	args <- list(
121	!	min = list(label = "Min", min = 0, max = 0, value = 0),
122	!	max = list(label = "Max", min = 0, max = 0, value = 0)
123		)
124	!	update_min_max(session, args)
125		} else {
126	!	rng <- range(val, na.rm = TRUE)
127
128	!	minmax <- c(floor(rng[1] * 1000) / 1000, ceiling(rng[2] * 1000) / 1000)
129
130	!	label_min <- sprintf("Min (%s)", minmax[1])
131	!	label_max <- sprintf("Max (%s)", minmax[2])
132
133	!	args <- list(
134	!	min = list(label = label_min, min = minmax[1], max = minmax[2], value = minmax[1]),
135	!	max = list(label = label_max, min = minmax[1], max = minmax[2], value = minmax[2])
136		)
137
138	!	update_min_max(session, args)
139	!	shinyjs::show("constraint_range") # update before show
140	!	shinyjs::hide("all_na")
141		}
142	2x	} else if (constraint_var == "NONE") {
143	2x	shinyjs::hide("constraint_range") # hide before update
144	2x	shinyjs::hide("all_na")
145
146		# force update (and thus refresh) on different constraint_var -> pass unique value for each constraint_var name
147	2x	args <- list(
148	2x	min = list(label = "Min", min = 0, max = 0, value = 0),
149	2x	max = list(label = "Max", min = 0, max = 0, value = 0)
150		)
151
152	2x	update_min_max(session, args)
153		} else {
154	!	validate(need(FALSE, "This is an invalid data contraint for the filtered data"))
155		}
156		})
157
158	1x	anl_constraint <- create_anl_constraint_reactive(anl_param, input, param_id = param_id, min_rows = min_rows)
159
160	1x	return(anl_constraint)
161		}
162
163		# returns a reactive that applies the `x-axis data constraint`
164		# More precisely, all patients are filtered out that do not have the range of
165		# `param_id.constraint_var` in the specified range
166		# constraint var means that `param_id.constraint_var` is constrained to the filtered range (or NA),
167		# e.g. `ALT.BASE2` (i.e. `PARAMCD = ALT & range_filter_on(BASE2)`)
168		create_anl_constraint_reactive <- function(anl_param, input, param_id, min_rows) {
169	1x	iv_r <- reactive({
170	1x	iv <- shinyvalidate::InputValidator$new()
171	1x	iv$condition(~ isTRUE(input$constraint_var != "NONE"))
172	1x	iv$add_rule("constraint_range_min", shinyvalidate::sv_required("A contraint minimum value is required"))
173	1x	iv$add_rule("constraint_range_max", shinyvalidate::sv_required("A contraint maximum value is required"))
174	1x	iv$add_rule(
175	1x	"constraint_range_min",
176	1x	~ if (!is.na(input$constraint_range_max) && (.) > input$constraint_range_max) {
177	!	"constraint min needs to be less than max"
178		}
179		)
180	1x	iv$add_rule(
181	1x	"constraint_range_max",
182	1x	~ if (!is.na(input$constraint_range_min) && (.) < input$constraint_range_min) {
183	!	"constraint min needs to be less than max"
184		}
185		)
186	1x	iv
187		})
188
189
190	1x	return_val <- reactive({
191	3x	private_qenv <- anl_param()$qenv
192
193		# it is assumed that constraint_var is triggering constraint_range which then trigger this clause
194	2x	constraint_var <- isolate(input[["constraint_var"]])
195	2x	constraint_range_min <- input[["constraint_range_min"]]
196	2x	constraint_range_max <- input[["constraint_range_max"]]
197	2x	param <- input[[param_id]]
198	2x	req(param)
199
200		# filter constraint
201	2x	if (constraint_var != "NONE") {
202	!	private_qenv <- teal.code::eval_code(
203	!	object = private_qenv,
204	!	code = bquote({
205		# the below includes patients who have at least one non-NA BASE value
206		# ideally, a patient should either have all NA values or none at all
207		# this could be achieved through preprocessing; otherwise, this is easily overseen
208	!	filtered_usubjids <- ANL %>% # nolint
209	!	dplyr::filter(
210	!	PARAMCD == .(param),
211	!	(.(constraint_range_min) <= .data[[.(constraint_var)]]) &
212	!	(.data[[.(constraint_var)]] <= .(constraint_range_max))
213		) %>%
214	!	dplyr::pull(USUBJID)
215		# include patients with all NA values for constraint_var
216	!	filtered_usubjids <- c(
217	!	filtered_usubjids,
218	!	ANL %>%
219	!	dplyr::filter(PARAMCD == .(param)) %>%
220	!	dplyr::group_by(USUBJID) %>%
221	!	dplyr::summarize(all_na = all(is.na(.data[[.(constraint_var)]]))) %>%
222	!	dplyr::filter(all_na) %>%
223	!	dplyr::pull(USUBJID)
224		)
225	!	ANL <- ANL %>% dplyr::filter(USUBJID %in% filtered_usubjids) # nolint
226		})
227		)
228	!	validate_has_data(private_qenv[["ANL"]], min_rows)
229		}
230	2x	list(ANL = private_qenv[["ANL"]], qenv = private_qenv)
231		})
232
233	1x	reactive(
234	1x	list(
235	1x	value = return_val,
236	1x	iv_r = iv_r
237		)
238		)
239		}
240
241		# for outputting the constraint in the report
242		formatted_data_constraint <- function(constraint_var, constraint_range_min, constraint_range_max) {
243	!	constraint_var_label <- switch(constraint_var,
244	!	"BASE2" = "Screening",
245	!	"BASE" = "Baseline",
246	!	"None"
247		)
248	!	msg <- paste("Data Constraint:", constraint_var_label)
249	!	if (constraint_var_label != "None") {
250	!	msg <- paste(msg, "from", constraint_range_min, "to", constraint_range_max)
251		}
252	!	msg
253		}
254
255		update_min_max <- function(session, args) {
256	2x	do.call("updateNumericInput", c(list(session = session, inputId = "constraint_range_min"), args$min))
257	2x	do.call("updateNumericInput", c(list(session = session, inputId = "constraint_range_max"), args$max))
258		}

1		#' Include `CSS` files from `/inst/css/` package directory to application header
2		#'
3		#' `system.file` should not be used to access files in other packages, it does
4		#' not work with `devtools`. Therefore, we redefine this method in each package
5		#' as needed. Thus, we do not export this method.
6		#'
7		#' @param pattern (`character`) pattern of files to be included
8		#'
9		#' @return HTML code that includes `CSS` files
10		#' @keywords internal
11		include_css_files <- function(pattern = "*") {
12	!	css_files <- list.files(
13	!	system.file("css", package = "teal.goshawk", mustWork = TRUE),
14	!	pattern = pattern, full.names = TRUE
15		)
16	!	if (length(css_files) == 0) {
17	!	return(NULL)
18		}
19	!	return(shiny::singleton(shiny::tags$head(lapply(css_files, shiny::includeCSS))))
20		}
21
22		plots_per_row_validate_rules <- function(required = TRUE) {
23	1x	msg <- "Number of plots per row must be a positive integer"
24	1x	shinyvalidate::compose_rules(
25	1x	if (required) {
26	!	shinyvalidate::sv_required(msg)
27		} else {
28	1x	shinyvalidate::sv_optional()
29		},
30	1x	shinyvalidate::sv_integer(msg),
31	1x	shinyvalidate::sv_gt(0, message_fmt = msg)
32		)
33		}
34
35		#' Template Function for `TealReportCard` Creation and Customization in `teal.goshawk`
36		#'
37		#' This function generates a report card with a title,
38		#' an optional description, and the option to append the filter state list.
39		#' Additionally, it display selected constraint options.
40		#'
41		#' @inheritParams teal::report_card_template
42		#' @param constraint_list (`list`) a list containing constraint variables, including:
43		#' - constraint_var (`character(1)`) the constraint variable name.
44		#' - constraint_range_min (`numeric(1)`) the minimum constraint range value.
45		#' - constraint_range_max (`numeric(1)`) the maximum constraint range value.
46		#' @param constraint_description (`character(1)`) description of the constraints.
47		#' @param style (`character(1)`) style of the constraint text block.
48		#' options: `default`, `verbatim` (default is `default`).
49		#'
50		#' @return (`TealReportCard`) populated with a title, description, and filter state
51		#'
52		#' @keywords internal
53		report_card_template_goshawk <- function(title,
54		label,
55		with_filter,
56		filter_panel_api,
57		constraint_list,
58		constraint_description = NULL,
59		style = "default") {
60	!	checkmate::assert_subset(names(constraint_list), c("constraint_var", "constraint_range_min", "constraint_range_max"))
61	!	checkmate::assert_string(constraint_description, null.ok = TRUE)
62	!	checkmate::assert_choice(style, c("default", "verbatim"))
63
64	!	card <- teal::report_card_template(
65	!	title = title,
66	!	label = label,
67	!	with_filter = with_filter,
68	!	filter_panel_api = filter_panel_api
69		)
70
71	!	card$append_text("Selected Options", "header3")
72	!	card$append_text(
73	!	paste(
74	!	formatted_data_constraint(
75	!	constraint_list$constraint_var,
76	!	constraint_list$constraint_range_min,
77	!	constraint_list$constraint_range_max
78		),
79	!	constraint_description
80		),
81	!	style = style
82		)
83	!	card
84		}
85
86		#' Get Choices
87		#'
88		#' This function returns choices based on the class of the input.
89		#' If the input is of class `delayed_data`, it returns the `subset` of the input.
90		#' If `subset` is NULL and the input contains `var_label` and `var_choices`,
91		#' it throws an error prompting to resolve delayed inputs.
92		#' Otherwise, it returns the input as is.
93		#'
94		#' @param choices An object that contains choices.
95		#' @return A vector of choices.
96		#' @keywords internal
97		get_choices <- function(choices) {
98	!	if (inherits(choices, "delayed_data")) {
99	!	if (is.null(choices$subset)) {
100	!	if (!is.null(choices$var_label) && !is.null(choices$var_choices)) {
101	!	stop(
102	!	"Resolve delayed inputs by evaluating the code within the provided datasets.
103	!	Check ?teal.transform::resolve_delayed for more information."
104		)
105		} else {
106	!	stop("Subset is NULL and necessary fields are missing.")
107		}
108		} else {
109	!	choices$subset
110		}
111		} else {
112	!	choices
113		}
114		}

1		#' Density Distribution Plot
2		#'
3		#' This teal module renders the UI and calls the functions that create a density distribution plot
4		#' and an accompanying summary table.
5		#'
6		#' @param label menu item label of the module in the teal app.
7		#' @param trt_group \code{\link[teal.transform]{choices_selected}} object with available choices and pre-selected option
8		#' for variable names representing treatment group e.g. `ARM`.
9		#' @param color_manual vector of colors applied to treatment values.
10		#' @param color_comb name or hex value for combined treatment color.
11		#' @param plot_height controls plot height.
12		#' @param plot_width optional, controls plot width.
13		#' @param font_size font size control for title, `x-axis` label, `y-axis` label and legend.
14		#' @param line_size plot line thickness.
15		#' @param hline_arb numeric vector of at most 2 values identifying intercepts for arbitrary horizontal lines.
16		#' @param hline_arb_color a character vector of at most length of \code{hline_arb}.
17		#' naming the color for the arbitrary horizontal lines.
18		#' @param hline_arb_label a character vector of at most length of \code{hline_arb}.
19		#' naming the label for the arbitrary horizontal lines.
20		#' @param facet_ncol numeric value indicating number of facets per row.
21		#' @param comb_line display combined treatment line toggle.
22		#' @param rotate_xlab 45 degree rotation of `x-axis` values.
23		#'
24		#' @inheritParams teal.widgets::standard_layout
25		#' @inheritParams tm_g_gh_scatterplot
26		#'
27		#'
28		#' @author Nick Paszty (npaszty) paszty.nicholas@gene.com
29		#' @author Balazs Toth (tothb2) toth.balazs@gene.com
30		#'
31		#' @details None
32		#'
33		#' @export
34		#'
35		#' @examples
36		#' # Example using ADaM structure analysis dataset.
37		#' data <- teal_data()
38		#' data <- within(data, {
39		#' library(dplyr)
40		#' library(stringr)
41		#'
42		#' # original ARM value = dose value
43		#' arm_mapping <- list(
44		#' "A: Drug X" = "150mg QD",
45		#' "B: Placebo" = "Placebo",
46		#' "C: Combination" = "Combination"
47		#' )
48		#' ADSL <- rADSL
49		#' ADLB <- rADLB
50		#' var_labels <- lapply(ADLB, function(x) attributes(x)$label)
51		#' ADLB <- ADLB %>%
52		#' mutate(
53		#' AVISITCD = case_when(
54		#' AVISIT == "SCREENING" ~ "SCR",
55		#' AVISIT == "BASELINE" ~ "BL",
56		#' grepl("WEEK", AVISIT) ~ paste("W", str_extract(AVISIT, "(?<=(WEEK ))[0-9]+")),
57		#' TRUE ~ as.character(NA)
58		#' ),
59		#' AVISITCDN = case_when(
60		#' AVISITCD == "SCR" ~ -2,
61		#' AVISITCD == "BL" ~ 0,
62		#' grepl("W", AVISITCD) ~ as.numeric(gsub("[^0-9]*", "", AVISITCD)),
63		#' TRUE ~ as.numeric(NA)
64		#' ),
65		#' AVISITCD = factor(AVISITCD) %>% reorder(AVISITCDN),
66		#' TRTORD = case_when(
67		#' ARMCD == "ARM C" ~ 1,
68		#' ARMCD == "ARM B" ~ 2,
69		#' ARMCD == "ARM A" ~ 3
70		#' ),
71		#' ARM = as.character(arm_mapping[match(ARM, names(arm_mapping))]),
72		#' ARM = factor(ARM) %>% reorder(TRTORD),
73		#' ACTARM = as.character(arm_mapping[match(ACTARM, names(arm_mapping))]),
74		#' ACTARM = factor(ACTARM) %>% reorder(TRTORD)
75		#' )
76		#'
77		#' attr(ADLB[["ARM"]], "label") <- var_labels[["ARM"]]
78		#' attr(ADLB[["ACTARM"]], "label") <- var_labels[["ACTARM"]]
79		#' })
80		#'
81		#' datanames <- c("ADSL", "ADLB")
82		#' datanames(data) <- datanames
83		#' join_keys(data) <- default_cdisc_join_keys[datanames]
84		#'
85		#' app <- init(
86		#' data = data,
87		#' modules = modules(
88		#' tm_g_gh_density_distribution_plot(
89		#' label = "Density Distribution Plot",
90		#' dataname = "ADLB",
91		#' param_var = "PARAMCD",
92		#' param = choices_selected(c("ALT", "CRP", "IGA"), "ALT"),
93		#' xaxis_var = choices_selected(c("AVAL", "BASE", "CHG", "PCHG"), "AVAL"),
94		#' trt_group = choices_selected(c("ARM", "ACTARM"), "ARM"),
95		#' color_manual = c(
96		#' "150mg QD" = "#000000",
97		#' "Placebo" = "#3498DB",
98		#' "Combination" = "#E74C3C"
99		#' ),
100		#' color_comb = "#39ff14",
101		#' comb_line = TRUE,
102		#' plot_height = c(500, 200, 2000),
103		#' font_size = c(12, 8, 20),
104		#' line_size = c(1, .25, 3),
105		#' hline_arb = c(.02, .05),
106		#' hline_arb_color = c("red", "black"),
107		#' hline_arb_label = c("Horizontal Line A", "Horizontal Line B")
108		#' )
109		#' )
110		#' )
111		#' if (interactive()) {
112		#' shinyApp(app$ui, app$server)
113		#' }
114		#'
115		tm_g_gh_density_distribution_plot <- function(label, # nolint
116		dataname,
117		param_var,
118		param,
119		xaxis_var,
120		trt_group,
121		color_manual = NULL,
122		color_comb = NULL,
123		plot_height = c(500, 200, 2000),
124		plot_width = NULL,
125		font_size = c(12, 8, 20),
126		line_size = c(1, .25, 3),
127		hline_arb = numeric(0),
128		hline_arb_color = "red",
129		hline_arb_label = "Horizontal line",
130		facet_ncol = 2L,
131		comb_line = TRUE,
132		rotate_xlab = FALSE,
133		pre_output = NULL,
134		post_output = NULL) {
135	!	message("Initializing tm_g_gh_density_distribution_plot")
136	!	checkmate::assert_string(label)
137	!	checkmate::assert_string(dataname)
138	!	checkmate::assert_string(param_var)
139	!	checkmate::assert_class(param, "choices_selected")
140	!	checkmate::assert_class(xaxis_var, "choices_selected")
141	!	checkmate::assert_class(trt_group, "choices_selected")
142	!	checkmate::assert_numeric(font_size, len = 3)
143	!	checkmate::assert_numeric(line_size, len = 3)
144	!	checkmate::assert_int(facet_ncol)
145	!	checkmate::assert_flag(comb_line)
146	!	checkmate::assert_flag(rotate_xlab)
147	!	validate_line_arb_arg(hline_arb, hline_arb_color, hline_arb_label)
148	!	checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
149	!	checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")
150	!	checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
151	!	checkmate::assert_numeric(
152	!	plot_width[1],
153	!	lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"
154		)
155
156	!	args <- as.list(environment())
157
158	!	module(
159	!	label = label,
160	!	datanames = dataname,
161	!	server = srv_g_density_distribution_plot,
162	!	server_args = list(
163	!	dataname = dataname,
164	!	param_var = param_var,
165	!	param = param,
166	!	color_manual = color_manual,
167	!	color_comb = color_comb,
168	!	plot_height = plot_height,
169	!	plot_width = plot_width,
170	!	module_args = args
171		),
172	!	ui = ui_g_density_distribution_plot,
173	!	ui_args = args
174		)
175		}
176
177		ui_g_density_distribution_plot <- function(id, ...) {
178	!	ns <- NS(id)
179	!	a <- list(...)
180
181	!	teal.widgets::standard_layout(
182	!	output = tags$div(
183	!	fluidRow(
184	!	teal.widgets::plot_with_settings_ui(id = ns("plot"))
185		),
186	!	fluidRow(column(
187	!	width = 12,
188	!	tags$br(), tags$hr(),
189	!	tags$h4("Descriptive Statistics"),
190	!	DT::dataTableOutput(ns("table_ui"))
191		))
192		),
193	!	encoding = tags$div(
194		### Reporter
195	!	teal.reporter::simple_reporter_ui(ns("simple_reporter")),
196		###
197	!	templ_ui_dataname(a$dataname),
198	!	uiOutput(ns("axis_selections")),
199	!	templ_ui_constraint(ns, label = "Data Constraint"),
200	!	ui_arbitrary_lines(id = ns("hline_arb"), a$hline_arb, a$hline_arb_label, a$hline_arb_color),
201	!	teal.widgets::panel_group(
202	!	teal.widgets::panel_item(
203	!	title = "Plot Aesthetic Settings",
204	!	toggle_slider_ui(
205	!	ns("xrange_scale"),
206	!	label = "X-Axis Range Zoom"
207		),
208	!	toggle_slider_ui(
209	!	ns("yrange_scale"),
210	!	label = "Y-Axis Range Zoom"
211		),
212	!	numericInput(ns("facet_ncol"), "Number of Plots Per Row:", a$facet_ncol, min = 1),
213	!	checkboxInput(ns("comb_line"), "Display Combined line", a$comb_line),
214	!	checkboxInput(ns("rug_plot"), "Include rug plot", value = FALSE),
215	!	checkboxInput(ns("rotate_xlab"), "Rotate X-axis Label", a$rotate_xlab)
216		),
217	!	teal.widgets::panel_item(
218	!	title = "Plot settings",
219	!	teal.widgets::optionalSliderInputValMinMax(ns("font_size"), "Font Size", a$font_size, ticks = FALSE),
220	!	teal.widgets::optionalSliderInputValMinMax(
221	!	ns("line_size"),
222	!	"Line Size",
223	!	value_min_max = a$line_size,
224	!	step = .25,
225	!	ticks = FALSE
226		)
227		)
228		)
229		),
230	!	forms = tagList(
231	!	teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
232		),
233	!	pre_output = a$pre_output,
234	!	post_output = a$post_output
235		)
236		}
237
238		srv_g_density_distribution_plot <- function(id, # nolint
239		data,
240		reporter,
241		filter_panel_api,
242		dataname,
243		param_var,
244		param,
245		trt_group,
246		color_manual,
247		color_comb,
248		plot_height,
249		plot_width,
250		module_args) {
251	!	with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
252	!	with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
253	!	checkmate::assert_class(data, "reactive")
254	!	checkmate::assert_class(shiny::isolate(data()), "teal_data")
255
256	!	moduleServer(id, function(input, output, session) {
257	!	teal.logger::log_shiny_input_changes(input, namespace = "teal.goshawk")
258	!	output$axis_selections <- renderUI({
259	!	env <- shiny::isolate(as.list(data()@env))
260	!	resolved_x <- teal.transform::resolve_delayed(module_args$xaxis_var, env)
261	!	resolved_param <- teal.transform::resolve_delayed(module_args$param, env)
262	!	resolved_trt <- teal.transform::resolve_delayed(module_args$trt_group, env)
263
264	!	templ_ui_params_vars(
265	!	session$ns,
266	!	xparam_choices = resolved_param$choices,
267	!	xparam_selected = resolved_param$selected,
268	!	xparam_label = "Select a Biomarker",
269	!	xchoices = resolved_x$choices,
270	!	xselected = resolved_x$selected,
271	!	trt_choices = resolved_trt$choices,
272	!	trt_selected = resolved_trt$selected
273		)
274		})
275
276	!	anl_q_output <- constr_anl_q(
277	!	session, input, data, dataname,
278	!	param_id = "xaxis_param", param_var = param_var, trt_group = input$trt_group, min_rows = 2
279		)
280
281	!	anl_q <- anl_q_output()$value
282
283		# update sliders for axes taking constraints into account
284	!	data_state_x <- reactive({
285	!	get_data_range_states(
286	!	varname = input$xaxis_var,
287	!	paramname = input$xaxis_param,
288	!	ANL = anl_q()$ANL
289		)
290		})
291	!	xrange_slider <- toggle_slider_server("xrange_scale", data_state_x)
292	!	data_state_y <- reactive({
293	!	get_data_range_states(
294	!	varname = input$xaxis_var,
295	!	paramname = input$xaxis_param,
296	!	ANL = anl_q()$ANL,
297	!	trt_group = "trt_group"
298		)
299		})
300	!	yrange_slider <- toggle_slider_server("yrange_scale", data_state_y)
301
302	!	keep_data_const_opts_updated(session, input, anl_q, "xaxis_param")
303
304	!	horizontal_line <- srv_arbitrary_lines("hline_arb")
305
306	!	iv_r <- reactive({
307	!	iv <- shinyvalidate::InputValidator$new()
308
309	!	iv$add_rule("xaxis_param", shinyvalidate::sv_required("Please select a biomarker"))
310	!	iv$add_rule("trt_group", shinyvalidate::sv_required("Please select a treatment variable"))
311	!	iv$add_rule("xaxis_var", shinyvalidate::sv_required("Please select an X-Axis variable"))
312	!	iv$add_rule("facet_ncol", plots_per_row_validate_rules())
313
314	!	iv$add_validator(horizontal_line()$iv_r())
315	!	iv$add_validator(anl_q_output()$iv_r())
316	!	iv$enable()
317	!	iv
318		})
319
320
321	!	create_plot <- debounce(reactive({
322	!	teal::validate_inputs(iv_r())
323	!	req(anl_q())
324
325		# nolint start
326	!	param <- input$xaxis_param
327	!	xaxis_var <- input$xaxis_var
328	!	xlim <- xrange_slider$value
329	!	ylim <- yrange_slider$value
330	!	font_size <- input$font_size
331	!	line_size <- input$line_size
332	!	hline_arb <- horizontal_line()$line_arb
333	!	hline_arb_label <- horizontal_line()$line_arb_label
334	!	hline_arb_color <- horizontal_line()$line_arb_color
335	!	facet_ncol <- input$facet_ncol
336
337	!	comb_line <- input$comb_line
338	!	rug_plot <- input$rug_plot
339	!	rotate_xlab <- input$rotate_xlab
340	!	trt_group <- input$trt_group
341		# nolint end
342
343
344	!	teal.code::eval_code(
345	!	object = anl_q()$qenv,
346	!	code = bquote({
347	!	p <- goshawk::g_density_distribution_plot(
348	!	data = ANL,
349	!	param_var = .(param_var),
350	!	param = .(param),
351	!	xaxis_var = .(xaxis_var),
352	!	trt_group = .(trt_group),
353	!	xlim = .(xlim),
354	!	ylim = .(ylim),
355	!	color_manual = .(color_manual),
356	!	color_comb = .(color_comb),
357	!	font_size = .(font_size),
358	!	line_size = .(line_size),
359	!	facet_ncol = .(facet_ncol),
360	!	comb_line = .(comb_line),
361	!	hline_arb = .(hline_arb),
362	!	hline_arb_label = .(hline_arb_label),
363	!	hline_arb_color = .(hline_arb_color),
364	!	rug_plot = .(rug_plot)
365		)
366	!	print(p)
367		})
368		)
369	!	}), 800)
370
371	!	create_table <- debounce(reactive({
372	!	req(iv_r()$is_valid())
373	!	req(anl_q())
374	!	param <- input$xaxis_param
375	!	xaxis_var <- input$xaxis_var
376	!	font_size <- input$font_size
377	!	trt_group <- input$trt_group
378
379	!	teal.code::eval_code(
380	!	object = anl_q()$qenv,
381	!	code = bquote({
382	!	tbl <- goshawk::t_summarytable(
383	!	data = ANL,
384	!	trt_group = .(trt_group),
385	!	param_var = .(param_var),
386	!	param = .(param),
387	!	xaxis_var = .(xaxis_var),
388	!	font_size = .(font_size)
389		)
390	!	tbl
391		})
392		)
393	!	}), 800)
394
395	!	plot_r <- reactive({
396	!	create_plot()[["p"]]
397		})
398
399	!	plot_data <- teal.widgets::plot_with_settings_srv(
400	!	id = "plot",
401	!	plot_r = plot_r,
402	!	height = plot_height,
403	!	width = plot_width,
404		)
405
406	!	output$table_ui <- DT::renderDataTable({
407	!	req(create_table())
408	!	tbl <- create_table()[["tbl"]]
409	!	numeric_cols <- names(dplyr::select_if(tbl, is.numeric))
410
411	!	DT::datatable(tbl,
412	!	rownames = FALSE, options = list(scrollX = TRUE)
413		) %>%
414	!	DT::formatRound(numeric_cols, 2)
415		})
416
417	!	joined_qenvs <- reactive({
418	!	req(create_plot(), create_table())
419	!	teal.code::join(create_plot(), create_table())
420		})
421
422	!	code <- reactive(teal.code::get_code(joined_qenvs()))
423
424	!	teal.widgets::verbatim_popup_srv(
425	!	id = "rcode",
426	!	verbatim_content = reactive(code()),
427	!	title = "Show R Code for Density Distribution Plot"
428		)
429
430		### REPORTER
431	!	if (with_reporter) {
432	!	card_fun <- function(comment, label) {
433	!	card <- report_card_template_goshawk(
434	!	title = "Density Distribution Plot",
435	!	label = label,
436	!	with_filter = with_filter,
437	!	filter_panel_api = filter_panel_api,
438	!	constraint_list = list(
439	!	constraint_var = input$constraint_var,
440	!	constraint_range_min = input$constraint_range_min,
441	!	constraint_range_max = input$constraint_range_max
442		)
443		)
444	!	card$append_text("Plot", "header3")
445	!	card$append_plot(plot_r(), dim = plot_data$dim())
446	!	card$append_text("Descriptive Statistics", "header3")
447	!	card$append_table(
448	!	create_table()[["tbl"]] %>% dplyr::mutate_if(is.numeric, round, 2)
449		)
450	!	if (!comment == "") {
451	!	card$append_text("Comment", "header3")
452	!	card$append_text(comment)
453		}
454	!	card$append_src(code())
455	!	card
456		}
457	!	teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
458		}
459		###
460		})
461		}

1		#' Spaghetti Plot
2		#'
3		#' This teal module renders the UI and calls the function
4		#' that creates a spaghetti plot.
5		#'
6		#' @param label menu item label of the module in the teal app.
7		#' @param dataname analysis data passed to the data argument of \code{\link[teal]{init}}.
8		#' E.g. `ADaM` structured laboratory data frame `ADLB`.
9		#' @param param_var name of variable containing biomarker codes e.g. `PARAMCD`.
10		#' @param param biomarker selected.
11		#' @param param_var_label single name of variable in analysis data
12		#' that includes parameter labels.
13		#' @param idvar name of unique subject id variable.
14		#' @param xaxis_var single name of variable in analysis data
15		#' that is used as x-axis in the plot for the respective goshawk function.
16		#' @param xaxis_var_level vector that can be used to define the factor level of `xaxis_var`.
17		#' Only use it when `xaxis_var` is character or factor.
18		#' @param filter_var data constraint variable.
19		#' @param yaxis_var single name of variable in analysis data that is used as
20		#' summary variable in the respective `goshawk` function.
21		#' @param trt_group \code{\link[teal.transform]{choices_selected}} object with available choices and pre-selected option
22		#' for variable names representing treatment group e.g. `ARM`.
23		#' @param trt_group_level vector that can be used to define factor
24		#' level of `trt_group`.
25		#' @param man_color string vector representing customized colors
26		#' @param color_comb name or hex value for combined treatment color.
27		#' @param xtick numeric vector to define the tick values of `x-axis`
28		#' when x variable is numeric. Default value is `waive()`.
29		#' @param xlabel vector with same length of `xtick` to define the
30		#' label of `x-axis` tick values. Default value is `waive()`.
31		#' @param rotate_xlab `logical(1)` value indicating whether to rotate `x-axis` labels
32		#' @param facet_ncol numeric value indicating number of facets per row.
33		#' @param free_x `logical(1)` should scales be `"fixed"` (`FALSE`) of `"free"` (`TRUE`) for `x-axis` in
34		#' \code{\link[ggplot2]{facet_wrap}} \code{scales} parameter.
35		#' @param plot_height controls plot height.
36		#' @param plot_width optional, controls plot width.
37		#' @param font_size control font size for title, `x-axis`, `y-axis` and legend font.
38		#' @param dot_size plot dot size.
39		#' @param group_stats control group mean or median overlay.
40		#' @param hline_arb numeric vector of at most 2 values identifying intercepts for arbitrary horizontal lines.
41		#' @param hline_arb_color a character vector of at most length of \code{hline_arb}.
42		#' naming the color for the arbitrary horizontal lines.
43		#' @param hline_arb_label a character vector of at most length of \code{hline_arb}.
44		#' naming the label for the arbitrary horizontal lines.
45		#' @param hline_vars a character vector to name the columns that will define additional horizontal lines.
46		#' @param hline_vars_colors a character vector naming the colors for the additional horizontal lines.
47		#' @param hline_vars_labels a character vector naming the labels for the additional horizontal lines that will appear
48		#' in the legend.
49		#' @inheritParams teal.widgets::standard_layout
50		#'
51		#' @author Wenyi Liu (luiw2) wenyi.liu@roche.com
52		#' @author Balazs Toth (tothb2) toth.balazs@gene.com
53		#'
54		#' @return \code{shiny} object
55		#'
56		#' @export
57		#'
58		#' @examples
59		#' # Example using ADaM structure analysis dataset.
60		#' data <- teal_data()
61		#' data <- within(data, {
62		#' library(dplyr)
63		#' library(stringr)
64		#'
65		#' # use non-exported function from goshawk
66		#' h_identify_loq_values <- getFromNamespace("h_identify_loq_values", "goshawk")
67		#'
68		#' # original ARM value = dose value
69		#' arm_mapping <- list(
70		#' "A: Drug X" = "150mg QD",
71		#' "B: Placebo" = "Placebo",
72		#' "C: Combination" = "Combination"
73		#' )
74		#' set.seed(1)
75		#' ADSL <- rADSL
76		#' ADLB <- rADLB
77		#' var_labels <- lapply(ADLB, function(x) attributes(x)$label)
78		#' ADLB <- ADLB %>%
79		#' mutate(
80		#' AVISITCD = case_when(
81		#' AVISIT == "SCREENING" ~ "SCR",
82		#' AVISIT == "BASELINE" ~ "BL",
83		#' grepl("WEEK", AVISIT) ~ paste("W", str_extract(AVISIT, "(?<=(WEEK ))[0-9]+")),
84		#' TRUE ~ as.character(NA)
85		#' ),
86		#' AVISITCDN = case_when(
87		#' AVISITCD == "SCR" ~ -2,
88		#' AVISITCD == "BL" ~ 0,
89		#' grepl("W", AVISITCD) ~ as.numeric(gsub("[^0-9]*", "", AVISITCD)),
90		#' TRUE ~ as.numeric(NA)
91		#' ),
92		#' AVISITCD = factor(AVISITCD) %>% reorder(AVISITCDN),
93		#' TRTORD = case_when(
94		#' ARMCD == "ARM C" ~ 1,
95		#' ARMCD == "ARM B" ~ 2,
96		#' ARMCD == "ARM A" ~ 3
97		#' ),
98		#' ARM = as.character(arm_mapping[match(ARM, names(arm_mapping))]),
99		#' ARM = factor(ARM) %>% reorder(TRTORD),
100		#' ACTARM = as.character(arm_mapping[match(ACTARM, names(arm_mapping))]),
101		#' ACTARM = factor(ACTARM) %>% reorder(TRTORD),
102		#' ANRLO = 30,
103		#' ANRHI = 75
104		#' ) %>%
105		#' rowwise() %>%
106		#' group_by(PARAMCD) %>%
107		#' mutate(LBSTRESC = ifelse(USUBJID %in% sample(USUBJID, 1, replace = TRUE),
108		#' paste("<", round(runif(1, min = 25, max = 30))), LBSTRESC
109		#' )) %>%
110		#' mutate(LBSTRESC = ifelse(USUBJID %in% sample(USUBJID, 1, replace = TRUE),
111		#' paste(">", round(runif(1, min = 70, max = 75))), LBSTRESC
112		#' )) %>%
113		#' ungroup()
114		#' attr(ADLB[["ARM"]], "label") <- var_labels[["ARM"]]
115		#' attr(ADLB[["ACTARM"]], "label") <- var_labels[["ACTARM"]]
116		#' attr(ADLB[["ANRLO"]], "label") <- "Analysis Normal Range Lower Limit"
117		#' attr(ADLB[["ANRHI"]], "label") <- "Analysis Normal Range Upper Limit"
118		#'
119		#' # add LLOQ and ULOQ variables
120		#' ALB_LOQS <- h_identify_loq_values(ADLB, "LOQFL")
121		#' ADLB <- left_join(ADLB, ALB_LOQS, by = "PARAM")
122		#' })
123		#'
124		#' datanames <- c("ADSL", "ADLB")
125		#' datanames(data) <- datanames
126		#' join_keys(data) <- default_cdisc_join_keys[datanames]
127		#'
128		#' app <- init(
129		#' data = data,
130		#' modules = modules(
131		#' tm_g_gh_spaghettiplot(
132		#' label = "Spaghetti Plot",
133		#' dataname = "ADLB",
134		#' param_var = "PARAMCD",
135		#' param = choices_selected(c("ALT", "CRP", "IGA"), "ALT"),
136		#' idvar = "USUBJID",
137		#' xaxis_var = choices_selected(c("Analysis Visit Code" = "AVISITCD"), "AVISITCD"),
138		#' yaxis_var = choices_selected(c("AVAL", "CHG", "PCHG"), "AVAL"),
139		#' filter_var = choices_selected(
140		#' c("None" = "NONE", "Screening" = "BASE2", "Baseline" = "BASE"),
141		#' "NONE"
142		#' ),
143		#' trt_group = choices_selected(c("ARM", "ACTARM"), "ARM"),
144		#' color_comb = "#39ff14",
145		#' man_color = c(
146		#' "Combination" = "#000000",
147		#' "Placebo" = "#fce300",
148		#' "150mg QD" = "#5a2f5f"
149		#' ),
150		#' hline_arb = c(60, 50),
151		#' hline_arb_color = c("grey", "red"),
152		#' hline_arb_label = c("default A", "default B"),
153		#' hline_vars = c("ANRHI", "ANRLO", "ULOQN", "LLOQN"),
154		#' hline_vars_colors = c("pink", "brown", "purple", "black"),
155		#' )
156		#' )
157		#' )
158		#' if (interactive()) {
159		#' shinyApp(app$ui, app$server)
160		#' }
161		#'
162		tm_g_gh_spaghettiplot <- function(label,
163		dataname,
164		param_var,
165		param,
166		param_var_label = "PARAM",
167		idvar,
168		xaxis_var,
169		yaxis_var,
170		xaxis_var_level = NULL,
171		filter_var = yaxis_var,
172		trt_group,
173		trt_group_level = NULL,
174		group_stats = "NONE",
175		man_color = NULL,
176		color_comb = NULL,
177		xtick = ggplot2::waiver(),
178		xlabel = xtick,
179		rotate_xlab = FALSE,
180		facet_ncol = 2,
181		free_x = FALSE,
182		plot_height = c(600, 200, 2000),
183		plot_width = NULL,
184		font_size = c(12, 8, 20),
185		dot_size = c(2, 1, 12),
186		hline_arb = numeric(0),
187		hline_arb_color = "red",
188		hline_arb_label = "Horizontal line",
189		hline_vars = character(0),
190		hline_vars_colors = "green",
191		hline_vars_labels = hline_vars,
192		pre_output = NULL,
193		post_output = NULL) {
194	!	message("Initializing tm_g_gh_spaghettiplot")
195
196		# Validate string inputs
197	!	checkmate::assert_string(label)
198	!	checkmate::assert_string(dataname)
199	!	checkmate::assert_string(param_var)
200	!	checkmate::assert_string(param_var_label)
201	!	checkmate::assert_string(idvar)
202	!	checkmate::assert_string(group_stats)
203
204		# Validate choices_selected class inputs
205	!	checkmate::assert_class(param, "choices_selected")
206	!	checkmate::assert_class(xaxis_var, "choices_selected")
207	!	checkmate::assert_class(yaxis_var, "choices_selected")
208	!	checkmate::assert_class(trt_group, "choices_selected")
209
210		# Validate flag inputs
211	!	checkmate::assert_flag(rotate_xlab)
212	!	checkmate::assert_flag(free_x)
213
214		# Validate numeric vector inputs
215	!	checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
216	!	checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")
217	!	checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
218	!	checkmate::assert_numeric(
219	!	plot_width[1],
220	!	lower = plot_width[2], upper = plot_width[3],
221	!	null.ok = TRUE, .var.name = "plot_width"
222		)
223	!	checkmate::assert_numeric(font_size, len = 3, any.missing = FALSE, finite = TRUE)
224	!	checkmate::assert_numeric(dot_size, len = 3, any.missing = FALSE, finite = TRUE)
225
226		# Validate color manual if provided
227	!	checkmate::assert_character(man_color, null.ok = TRUE)
228	!	checkmate::assert_character(color_comb, null.ok = TRUE)
229	!	checkmate::assert_character(hline_arb_color)
230	!	checkmate::assert_character(hline_arb_label)
231
232		# Validate facet columns
233	!	checkmate::assert_int(facet_ncol, lower = 1)
234
235		# Validate line arguments
236	!	validate_line_arb_arg(hline_arb, hline_arb_color, hline_arb_label)
237	!	validate_line_vars_arg(hline_vars, hline_vars_colors, hline_vars_labels)
238
239	!	args <- as.list(environment())
240
241	!	module(
242	!	label = label,
243	!	server = srv_g_spaghettiplot,
244	!	server_args = list(
245	!	dataname = dataname,
246	!	idvar = idvar,
247	!	param_var = param_var,
248	!	xaxis_var_level = xaxis_var_level,
249	!	trt_group_level = trt_group_level,
250	!	man_color = man_color,
251	!	color_comb = color_comb,
252	!	param_var_label = param_var_label,
253	!	xtick = xtick,
254	!	xlabel = xlabel,
255	!	plot_height = plot_height,
256	!	plot_width = plot_width,
257	!	hline_vars_colors = hline_vars_colors,
258	!	hline_vars_labels = hline_vars_labels,
259	!	module_args = args
260		),
261	!	ui = g_ui_spaghettiplot,
262	!	ui_args = args,
263	!	datanames = dataname
264		)
265		}
266
267		g_ui_spaghettiplot <- function(id, ...) {
268	!	ns <- NS(id)
269	!	a <- list(...)
270
271	!	shiny::tagList(
272	!	include_css_files("custom"),
273	!	teal.widgets::standard_layout(
274	!	output = templ_ui_output_datatable(ns),
275	!	encoding = tags$div(
276		### Reporter
277	!	teal.reporter::simple_reporter_ui(ns("simple_reporter")),
278		###
279	!	templ_ui_dataname(a$dataname),
280	!	uiOutput(ns("axis_selections")),
281	!	radioButtons(
282	!	ns("group_stats"),
283	!	"Group Statistics",
284	!	c("None" = "NONE", "Mean" = "MEAN", "Median" = "MEDIAN"),
285	!	inline = TRUE
286		),
287	!	templ_ui_constraint(ns), # required by constr_anl_q
288	!	if (length(a$hline_vars) > 0) {
289	!	teal.widgets::optionalSelectInput(
290	!	ns("hline_vars"),
291	!	label = "Add Horizontal Range Line(s):",
292	!	choices = a$hline_vars,
293	!	selected = NULL,
294	!	multiple = TRUE
295		)
296		},
297	!	ui_arbitrary_lines(id = ns("hline_arb"), a$hline_arb, a$hline_arb_label, a$hline_arb_color),
298	!	teal.widgets::panel_group(
299	!	teal.widgets::panel_item(
300	!	title = "Plot Aesthetic Settings",
301	!	tags$div(
302	!	toggle_slider_ui(
303	!	ns("yrange_scale"),
304	!	label = "Y-Axis Range Zoom"
305		),
306	!	tags$div(
307	!	class = "flex flex-wrap items-center",
308	!	tags$div(
309	!	class = "mr-1",
310	!	tags$span(tags$strong("Number of Plots Per Row:"))
311		),
312	!	tags$div(
313	!	class = "w-65px",
314	!	numericInput(ns("facet_ncol"), "", a$facet_ncol, min = 1)
315		)
316		)
317		),
318	!	checkboxInput(ns("free_x"), "Free X-Axis Scales", a$free_x),
319	!	checkboxInput(ns("rotate_xlab"), "Rotate X-Axis Label", a$rotate_xlab),
320	!	teal.widgets::optionalSliderInputValMinMax(ns("font_size"), "Font Size", a$font_size, ticks = FALSE),
321	!	teal.widgets::optionalSliderInputValMinMax(ns("dot_size"), "Dot Size", a$dot_size, ticks = FALSE),
322	!	teal.widgets::optionalSliderInputValMinMax(
323	!	ns("alpha"),
324	!	"Line Alpha",
325	!	a$alpha,
326	!	value_min_max = c(0.8, 0.0, 1.0), step = 0.1, ticks = FALSE
327		)
328		)
329		)
330		),
331	!	forms = tagList(
332	!	teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
333		),
334	!	pre_output = a$pre_output,
335	!	post_output = a$post_output
336		)
337		)
338		}
339
340
341
342		srv_g_spaghettiplot <- function(id,
343		data,
344		reporter,
345		filter_panel_api,
346		dataname,
347		idvar,
348		param_var,
349		trt_group,
350		man_color,
351		color_comb,
352		xaxis_var_level,
353		trt_group_level,
354		param_var_label,
355		xtick,
356		xlabel,
357		plot_height,
358		plot_width,
359		hline_vars_colors,
360		hline_vars_labels,
361		module_args) {
362	!	with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
363	!	with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
364	!	checkmate::assert_class(data, "reactive")
365	!	checkmate::assert_class(shiny::isolate(data()), "teal_data")
366
367	!	moduleServer(id, function(input, output, session) {
368	!	teal.logger::log_shiny_input_changes(input, namespace = "teal.goshawk")
369	!	output$axis_selections <- renderUI({
370	!	env <- shiny::isolate(as.list(data()@env))
371	!	resolved_x <- teal.transform::resolve_delayed(module_args$xaxis_var, env)
372	!	resolved_y <- teal.transform::resolve_delayed(module_args$yaxis_var, env)
373	!	resolved_param <- teal.transform::resolve_delayed(module_args$param, env)
374	!	resolved_trt <- teal.transform::resolve_delayed(module_args$trt_group, env)
375	!	templ_ui_params_vars(
376	!	session$ns,
377		# xparam and yparam are identical, so we only show the user one
378	!	xparam_choices = resolved_param$choices,
379	!	xparam_selected = resolved_param$selected,
380	!	xparam_label = "Select a Biomarker",
381	!	xchoices = resolved_x$choices,
382	!	xselected = resolved_x$selected,
383	!	ychoices = resolved_y$choices,
384	!	yselected = resolved_y$selected,
385	!	trt_choices = resolved_trt$choices,
386	!	trt_selected = resolved_trt$selected
387		)
388		})
389
390		# reused in all modules
391	!	anl_q_output <- constr_anl_q(
392	!	session, input, data, dataname,
393	!	param_id = "xaxis_param", param_var = param_var, trt_group = input$trt_group, min_rows = 1
394		)
395
396	!	anl_q <- anl_q_output()$value
397
398		# update sliders for axes taking constraints into account
399	!	data_state <- reactive({
400	!	get_data_range_states(
401	!	varname = input$yaxis_var,
402	!	paramname = input$xaxis_param,
403	!	ANL = anl_q()$ANL
404		)
405		})
406	!	yrange_slider <- toggle_slider_server("yrange_scale", data_state)
407	!	keep_data_const_opts_updated(session, input, anl_q, "xaxis_param")
408
409	!	horizontal_line <- srv_arbitrary_lines("hline_arb")
410
411	!	iv_r <- reactive({
412	!	iv <- shinyvalidate::InputValidator$new()
413
414	!	iv$add_rule("xaxis_param", shinyvalidate::sv_required("Please select a biomarker"))
415	!	iv$add_rule("trt_group", shinyvalidate::sv_required("Please select a treatment variable"))
416	!	iv$add_rule("xaxis_var", shinyvalidate::sv_required("Please select an X-Axis variable"))
417	!	iv$add_rule("yaxis_var", shinyvalidate::sv_required("Please select a Y-Axis variable"))
418	!	iv$add_rule("facet_ncol", plots_per_row_validate_rules())
419
420	!	iv$add_validator(horizontal_line()$iv_r())
421	!	iv$add_validator(anl_q_output()$iv_r())
422	!	iv$enable()
423	!	iv
424		})
425
426
427	!	plot_q <- debounce(reactive({
428	!	teal::validate_inputs(iv_r())
429	!	req(anl_q())
430		# nolint start
431	!	ylim <- yrange_slider$value
432	!	facet_ncol <- input$facet_ncol
433	!	facet_scales <- ifelse(input$free_x, "free_x", "fixed")
434
435	!	rotate_xlab <- input$rotate_xlab
436	!	hline_arb <- horizontal_line()$line_arb
437	!	hline_arb_label <- horizontal_line()$line_arb_label
438	!	hline_arb_color <- horizontal_line()$line_arb_color
439	!	group_stats <- input$group_stats
440	!	font_size <- input$font_size
441	!	dot_size <- input$dot_size
442	!	alpha <- input$alpha
443	!	validate(need(input$trt_group, "Please select a treatment variable"))
444	!	trt_group <- input$trt_group
445
446		# Below inputs should trigger plot via updates of other reactive objects (i.e. anl_q()) and some inputs
447	!	param <- input$xaxis_param
448	!	xaxis_var <- input$xaxis_var
449	!	yaxis_var <- input$yaxis_var
450	!	hline_vars <- input$hline_vars
451		# nolint end
452
453	!	private_qenv <- anl_q()$qenv
454
455		# this code is needed to make sure the waiver attribute
456		# of ggplot2::waiver is correctly passed to goshawk's spaghettiplot
457	!	if (!methods::is(xtick, "waiver")) {
458	!	private_qenv <- teal.code::eval_code(
459	!	object = private_qenv,
460	!	code = bquote(xtick <- .(xtick))
461		)
462		} else {
463	!	private_qenv <- teal.code::eval_code(
464	!	object = private_qenv,
465	!	code = quote(xtick <- ggplot2::waiver())
466		)
467		}
468
469	!	if (!methods::is(xlabel, "waiver")) {
470	!	private_qenv <- teal.code::eval_code(
471	!	object = private_qenv,
472	!	code = bquote(xlabel <- .(xlabel))
473		)
474		} else {
475	!	private_qenv <- teal.code::eval_code(
476	!	object = private_qenv,
477	!	code = quote(xlabel <- ggplot2::waiver())
478		)
479		}
480
481	!	teal.code::eval_code(
482	!	object = private_qenv,
483	!	code = bquote({
484	!	p <- goshawk::g_spaghettiplot(
485	!	data = ANL,
486	!	subj_id = .(idvar),
487	!	biomarker_var = .(param_var),
488	!	biomarker_var_label = .(param_var_label),
489	!	biomarker = .(param),
490	!	value_var = .(yaxis_var),
491	!	trt_group = .(trt_group),
492	!	trt_group_level = .(trt_group_level),
493	!	time = .(xaxis_var),
494	!	time_level = .(xaxis_var_level),
495	!	color_manual = .(man_color),
496	!	color_comb = .(color_comb),
497	!	ylim = .(ylim),
498	!	facet_ncol = .(facet_ncol),
499	!	facet_scales = .(facet_scales),
500	!	hline_arb = .(hline_arb),
501	!	hline_arb_label = .(hline_arb_label),
502	!	hline_arb_color = .(hline_arb_color),
503	!	xtick = xtick,
504	!	xlabel = xlabel,
505	!	rotate_xlab = .(rotate_xlab),
506	!	font_size = .(font_size),
507	!	dot_size = .(dot_size),
508	!	alpha = .(alpha),
509	!	group_stats = .(group_stats),
510	!	hline_vars = .(hline_vars),
511	!	hline_vars_colors = .(hline_vars_colors[seq_along(hline_vars)]),
512	!	hline_vars_labels = .(hline_vars_labels[seq_along(hline_vars)])
513		)
514	!	print(p)
515		})
516		)
517	!	}), 800)
518
519	!	plot_r <- reactive({
520	!	plot_q()[["p"]]
521		})
522
523	!	plot_data <- teal.widgets::plot_with_settings_srv(
524	!	id = "plot",
525	!	plot_r = plot_r,
526	!	height = plot_height,
527	!	width = plot_width,
528	!	brushing = TRUE
529		)
530
531	!	code <- reactive(teal.code::get_code(plot_q()))
532
533		### REPORTER
534	!	if (with_reporter) {
535	!	card_fun <- function(comment, label) {
536	!	card <- report_card_template_goshawk(
537	!	title = "Spaghetti Plot",
538	!	label = label,
539	!	with_filter = with_filter,
540	!	filter_panel_api = filter_panel_api,
541	!	constraint_list = list(
542	!	constraint_var = input$constraint_var,
543	!	constraint_range_min = input$constraint_range_min,
544	!	constraint_range_max = input$constraint_range_max
545		)
546		)
547	!	card$append_text("Spaghetti Plot", "header3")
548	!	card$append_plot(plot_r(), dim = plot_data$dim())
549	!	if (!comment == "") {
550	!	card$append_text("Comment", "header3")
551	!	card$append_text(comment)
552		}
553	!	card$append_src(code())
554	!	card
555		}
556	!	teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
557		}
558		###
559
560	!	reactive_df <- debounce(reactive({
561	!	plot_brush <- plot_data$brush()
562
563	!	ANL <- isolate(anl_q()$ANL) # nolint
564	!	validate_has_data(ANL, 1)
565
566	!	xvar <- isolate(input$xaxis_var)
567	!	yvar <- isolate(input$yaxis_var)
568	!	trt_group <- isolate(input$trt_group)
569
570	!	req(all(c(xvar, yvar) %in% names(ANL)))
571
572	!	df <- teal.widgets::clean_brushedPoints(
573	!	dplyr::select(
574	!	ANL, "USUBJID", dplyr::all_of(trt_group), "PARAMCD",
575	!	dplyr::all_of(c(xvar, yvar)), "LOQFL"
576		),
577	!	plot_brush
578		)
579	!	df[order(df$PARAMCD, df[[trt_group]], df$USUBJID, df[[xvar]]), ]
580	!	}), 800)
581
582	!	output$brush_data <- DT::renderDataTable({
583	!	numeric_cols <- names(dplyr::select_if(reactive_df(), is.numeric))
584
585	!	DT::datatable(reactive_df(),
586	!	rownames = FALSE, options = list(scrollX = TRUE)
587		) %>%
588	!	DT::formatRound(numeric_cols, 4)
589		})
590
591	!	teal.widgets::verbatim_popup_srv(
592	!	id = "rcode",
593	!	verbatim_content = reactive(code()),
594	!	title = "Show R Code for Spaghetti Plot"
595		)
596		})
597		}

1		templ_ui_output_datatable <- function(ns) {
2	!	tags$div(
3	!	teal.widgets::plot_with_settings_ui(id = ns("plot")),
4	!	tags$br(), tags$hr(),
5	!	tags$h4("Selected Data Points"),
6	!	DT::dataTableOutput(ns("brush_data"))
7		)
8		}
9
10		templ_ui_dataname <- function(dataname) {
11	1x	tags$label(dataname, "Data Settings", class = "text-primary")
12		}
13
14		# UI to create params (biomarker, value of PARAMCD) and vars (column, e.g. AVAL column) select fields for x and y
15		templ_ui_params_vars <- function(ns,
16		# x
17		xparam_choices = NULL,
18		xparam_selected = NULL,
19		xparam_label = NULL, # biomarker, e.g. ALT
20		xchoices = NULL,
21		xselected = NULL,
22		xvar_label = NULL, # variable, e.g. AVAL
23		# y
24		yparam_choices = NULL,
25		yparam_selected = NULL,
26		yparam_label = NULL, # biomarker, e.g. ALT
27		ychoices = NULL,
28		yselected = NULL,
29		yvar_label = NULL, # variable, e.g. AVAL
30		# facet_var
31		facet_choices = NULL,
32		facet_selected = NULL,
33		# trt_group
34		trt_choices = NULL,
35		trt_selected = NULL,
36
37		multiple = FALSE) {
38	1x	if (is.null(xparam_choices) && !is.null(xchoices) && !is.null(yparam_choices)) {
39		# otherwise, xchoices will appear first without any biomarker to select and this looks odd in the UI
40	!	stop(
41	!	"You have to specify xparam choices rather than yparamchoices
42	!	if both xvar and yvar should be values for the same biomarker."
43		)
44		}
45	1x	tagList(
46	1x	if (!is.null(trt_choices)) {
47	1x	teal.widgets::optionalSelectInput(
48	1x	ns("trt_group"),
49	1x	label = "Select Treatment Variable",
50	1x	choices = trt_choices,
51	1x	selected = trt_selected,
52	1x	multiple = FALSE
53		)
54		},
55	1x	if (!is.null(xparam_choices)) {
56	1x	teal.widgets::optionalSelectInput(
57	1x	ns("xaxis_param"),
58	1x	`if`(is.null(xparam_label), "Select an X-Axis Biomarker", xparam_label),
59	1x	xparam_choices,
60	1x	`if`(is.null(xparam_selected), xparam_choices[1], xparam_selected),
61	1x	multiple = FALSE
62		)
63		},
64	1x	if (!is.null(xchoices)) {
65	1x	teal.widgets::optionalSelectInput(
66	1x	ns("xaxis_var"),
67	1x	`if`(is.null(xvar_label), "Select an X-Axis Variable", xvar_label),
68	1x	xchoices, xselected,
69	1x	multiple = multiple
70		)
71		},
72	1x	if (!is.null(yparam_choices)) {
73	!	teal.widgets::optionalSelectInput(
74	!	ns("yaxis_param"),
75	!	`if`(is.null(yparam_label), "Select an Y-Axis Biomarker", yparam_label),
76	!	yparam_choices,
77	!	`if`(is.null(yparam_selected), yparam_choices[1], yparam_selected),
78	!	multiple = FALSE
79		)
80		},
81	1x	if (!is.null(ychoices)) {
82	1x	teal.widgets::optionalSelectInput(
83	1x	ns("yaxis_var"),
84	1x	`if`(is.null(yvar_label), "Select a Y-Axis Variable", yvar_label),
85	1x	ychoices, yselected,
86	1x	multiple = multiple
87		)
88		},
89	1x	if (!is.null(facet_choices)) {
90	1x	teal.widgets::optionalSelectInput(
91	1x	ns("facet_var"),
92	1x	label = "Facet by",
93	1x	choices = facet_choices,
94	1x	selected = facet_selected,
95	1x	multiple = FALSE
96		)
97		}
98		)
99		}

1		#' helper for writing arm mapping and ordering code.
2		#'
3		#' Provides lines of code for left hand side of arm mapping. user must provide right hand side
4		#'
5		#' @details SPA configure study specific pre-processing for deploying `goshawk`. writing the code for `ARM` mapping and
6		#' ordering is tedious. this function helps to get that started by providing the left hand side of the
7		#' mapping and ordering syntax. call the function and then copy and paste the resulting code from the console
8		#' into the app.R file.
9		#'
10		#' @param df_armvar the dataframe and column name containing treatment code. e.g. `ADSL$ARMCD`
11		#' @param code controls whether mapping or ordering code is written to console. Valid values: `"M"` and `"O"`.
12		#'
13		#' @export
14		#'
15		#' @examples
16		#' ADSL <- rADSL
17		#'
18		#' # get treatment mapping code
19		#' maptrt(df_armvar = ADSL$ARMCD, code = "M")
20		#'
21		#' # get treatment ordering code
22		#' maptrt(df_armvar = ADSL$ARMCD, code = "O")
23		maptrt <- function(df_armvar, code = c("M", "O")) {
24	!	code <- match.arg(code)
25
26		# get arm variable
27	!	trtvar <- strsplit(deparse(substitute(df_armvar)), "[$]")[[1]][2]
28
29	!	dftrt <- data.frame(unique(df_armvar)) %>%
30	!	dplyr::mutate(trt_mapping = paste0("\"", unique(df_armvar), "\"", " = \"\",")) %>%
31	!	dplyr::mutate(trt_ordering = paste0(eval(trtvar), " == \"", unique(df_armvar), "\"", " ~ ,"))
32
33	!	if (toupper(code) == "M") {
34	!	print(unname(dftrt["trt_mapping"]), row.names = FALSE)
35	!	} else if (toupper(code) == "O") {
36	!	print(unname(dftrt["trt_ordering"]), row.names = FALSE)
37		}
38		}

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