teal.goshawk coverage - 0.00%

Files
Source

#' UI with a toggleable 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.
#' Both normal sliders (for a single number in a range) and dichotomous sliders (for a range
#' within the slider range) are supported. In the former case, the toggle button
#' will show one numeric input field, in the latter case two.
#'
#' Value is not checked to be within minmax range
#'
#' @md
#' @param id `character` module id
#' @param label `label` label for input field, e.g. slider or numeric inputs
#' @param min `numeric or integer` minimum value
#' @param max `numeric or integer` maximum value
#' @param value `numeric or integer` either of length 1 for normal slider or of
#'   length 2 for dichotomous slider.
#' @param slider_initially `logical` whether to show slider or numeric fields
#'   initially
#' @param step_slider `numeric or integer` step for slider
#' @param step_numeric `numeric or integer` step for numeric input fields
#' @param width `numeric` width of slider or of each numeric field
#' @param ... additional parameters to pass to `sliderInput`
#'
#' @return Shiny HTML UI
#' @keywords internal
#'
#' @examples
#' value <- c(20.3, 81.5) # dichotomous slider
#' # value <- c(50.1) # normal slider
#'
#' # use non-exported function from teal.goshawk
#' toggle_slider_ui <- getFromNamespace("toggle_slider_ui", "teal.goshawk")
#'
#' ui <- div(
#'   toggle_slider_ui(
#'     "toggle_slider", "Select value",
#'     min = 0.2, max = 100.1, value = value,
#'     slider_initially = FALSE, step_slider = 0.1, step_numeric = 0.001
#'   ),
#'   verbatimTextOutput("value")
#' )
#'
#' server <- function(input, output, session) {
#'   is_dichotomous_slider <- (length(value) == 2)
#'   range_value <- toggle_slider_server("toggle_slider",
#'     is_dichotomous_slider = is_dichotomous_slider
#'   )
#'   messages <- reactiveVal() # to keep history
#'   observeEvent(range_value$state(), {
#'     list_with_names_str <- function(x) paste(names(x), x, sep = ": ", collapse = ", ")
#'     messages(c(messages(), list_with_names_str(range_value$state())))
#'   })
#'   output$value <- renderText({
#'     paste(messages(), collapse = "\n")
#'   })
#' }
#'
#' if (interactive()) {
#'   shinyApp(ui, server)
#' }
toggle_slider_ui <- function(id,
                             label,
                             min,
                             max,
                             value,
                             slider_initially = TRUE,
                             step_slider = NULL,
                             step_numeric = step_slider,
                             width = NULL,
                             ...) {
  checkmate::assert_number(min)
  checkmate::assert_number(max)
  checkmate::assert_flag(slider_initially)
  checkmate::assert_number(step_slider, null.ok = TRUE)
  checkmate::assert_number(step_numeric, null.ok = TRUE)
  checkmate::assert_numeric(value, min.len = 1, max.len = 2)
  if (is.null(step_numeric)) {
    step_numeric <- NA # numericInput does not support NULL
  }

  show_or_not <- function(show) if (show) identity else shinyjs::hidden
  ns <- NS(id)
  tags$div(
    include_css_files("custom"),
    shinyjs::useShinyjs(),
    tags$div(
      class = "flex justify-between mb-1",
      tags$span(tags$strong(label)),
      actionButton(ns("toggle"), "Toggle", class = "btn-xs")
    ),
    show_or_not(slider_initially)(
      sliderInput(
        ns("slider"),
        label = NULL,
        min = min,
        max = max,
        value = value,
        step = step_slider,
        width = width,
        ...
      )
    ),
    show_or_not(!slider_initially)(tags$span(
      id = ns("numeric_view"),
      if (length(value) == 1) {
        numericInput(
          ns("value"),
          label = NULL,
          min = min,
          max = max,
          value = value[[1]],
          step = step_numeric,
          width = width
        )
      } else {
        tags$div(
          numericInput(
            ns("value_low"),
            "From:",
            min = min,
            max = max,
            value = value[[1]],
            step = step_numeric,
            width = width
          ),
          numericInput(
            ns("value_high"),
            "- to:",
            min = min,
            max = max,
            value = value[[2]],
            step = step_numeric,
            width = width
          )
        )
      }
    ))
  )
}

# is_dichotomous_slider `logical` whether it is a dichotomous slider or normal slider
toggle_slider_server <- function(id, is_dichotomous_slider = TRUE) {
  moduleServer(id, function(input, output, session) {
    checkmate::assert_flag(is_dichotomous_slider)
    # model view controller: cur_state is the model, the sliderInput and numericInputs are two views/controllers
    # additionally, the module returns the cur_state, so it can be controlled from that end as well
    cur_state <- reactiveVal(NULL) # model, can contain min, max, value etc.


    iv_r <- reactive({
      iv <- shinyvalidate::InputValidator$new()
      iv$condition(~ input$toggle %% 2 == 1)
      iv$add_rule("value_low", shinyvalidate::sv_required("A 'from' value is required - a default is used instead"))
      iv$add_rule("value_high", shinyvalidate::sv_required("A 'to' value is required - a default is used instead)"))
      iv$add_rule(
        "value_high",
        ~ if (!is.na(input$value_low) && (.) < input$value_low) {
          "'From' value should be lower than 'to' value - axis has been flipped"
        }
      )
      iv$add_rule(
        "value_low",
        ~ if (!is.na(input$value_high) && (.) > input$value_high) {
          "'To' value should be greater than 'from' value - axis has been flipped"
        }
      )
      iv$enable()
      iv
    })

    set_state <- function(new_state) {
      stopifnot(all(names(new_state) %in% c("min", "max", "step", "value")))
      iv_r()$is_valid()
      # when value does not fall into min, max range, it will automatically get truncated

      # only update provided components, do not discasrd others
      old_state <- cur_state()
      new_state <- c(new_state, old_state[!names(old_state) %in% names(new_state)])
      new_state <- new_state[sort(names(new_state))]
      if (!setequal(new_state, cur_state())) {
        cur_state(new_state)
      }
    }
    observeEvent(input$slider, {
      set_state(list(value = input$slider))
    })
    # two values for range (dichotomous slider)
    observeEvent(
      eventExpr = { # nolint
        input$value_low
        input$value_high
      },
      handlerExpr = { # nolint
        set_state(list(value = c(input$value_low, input$value_high)))
      }
    )
    # one value for value in range
    observeEvent(
      input$value,
      handlerExpr = { # nolint
        set_state(list(value = input$value))
      }
    )

    update_widgets <- function() {
      state_slider <- cur_state()
      req(length(state_slider) > 0) # update will otherwise not work
      state_low <- state_slider
      state_high <- state_slider
      if (!is.null(state_slider$value) && (length(state_slider$value) > 1)) {
        state_low$value <- state_low$value[[1]]
        state_high$value <- state_high$value[[2]]
      }
      if (input$toggle %% 2 == 0) {
        do.call(updateSliderInput, c(list(session, "slider"), state_slider))
      } else {
        if (length(state_slider$value) > 1) {
          do.call(updateNumericInput, c(list(session, "value_low"), state_low))
          do.call(updateNumericInput, c(list(session, "value_high"), state_high))
        } else {
          do.call(updateNumericInput, c(list(session, "value"), state_low))
        }
      }
    }
    observeEvent(input$toggle, {
      update_widgets()
      shinyjs::toggle("numeric_view")
      shinyjs::toggle("slider")
    })

    update_toggle_slider <- function(value = NULL, min = NULL, max = NULL, step = NULL) {
      if (!is.null(value) && is_dichotomous_slider) {
        stopifnot(length(value) == 2)
      }
      set_state(Filter(Negate(is.null), list(value = value, min = min, max = max, step = step)))
      update_widgets()
    }
    return(list(
      state = cur_state,
      update_state = update_toggle_slider
    ))
  })
}

#' 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,
      trt_group = trt_group,
      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),
        teal.widgets::optionalSelectInput(
          ns("trt_group"),
          label = "Select Treatment Variable",
          choices = get_choices(a$trt_group$choices),
          selected = a$trt_group$selected,
          multiple = FALSE
        ),
        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",
                min = -1000000,
                max = 1000000,
                value = c(-1000000, 1000000)
              ),
              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) {
    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)
      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
      )
    })

    # 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
    yrange_slider <- toggle_slider_server("yrange_scale")
    keep_range_slider_updated(session, input, yrange_slider$update_state, "yaxis_var", "xaxis_param", anl_q)
    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 <- reactive({
      teal::validate_inputs(iv_r())
      req(anl_q())
      # nolint start
      ylim <- yrange_slider$state()$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)
        })
      )
    })

    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
    )

    ### 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(teal.code::get_code(plot_q()))
        card
      }
      teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
    }
    ###

    output$brush_data <- DT::renderDataTable({
      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 <- df[order(df$PARAMCD, df[[trt_group]], df$USUBJID, df[[xvar]]), ]
      numeric_cols <- names(dplyr::select_if(df, is.numeric))

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

    teal.widgets::verbatim_popup_srv(
      id = "rcode",
      verbatim_content = reactive(teal.code::get_code(plot_q())),
      title = "Show R Code for Spaghetti 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
#'
#' @examples
#' # 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,
      trt_group = trt_group,
      facet_var = facet_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),
      teal.widgets::optionalSelectInput(
        ns("trt_group"),
        label = "Select Treatment Variable",
        choices = get_choices(a$trt_group$choices),
        selected = a$trt_group$selected,
        multiple = FALSE
      ),
      uiOutput(ns("axis_selections")),
      teal.widgets::optionalSelectInput(
        ns("facet_var"),
        label = "Facet by",
        choices = get_choices(a$facet_var$choices),
        selected = a$facet_var$selected,
        multiple = FALSE
      ),
      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",
            min = -1000000,
            max = 1000000,
            value = c(-1000000, 1000000)
          ),
          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,
                          facet_var,
                          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) {
    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)
      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
      )
    })
    # 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
    yrange_slider <- toggle_slider_server("yrange_scale")
    keep_range_slider_updated(
      session,
      input,
      update_slider_fcn = yrange_slider$update_state,
      id_var = "yaxis_var",
      id_param_var = "xaxis_param",
      reactive_ANL = anl_q
    )
    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 <- 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")
          )
        })
      )
    })

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

      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 = .(input$facet_var)
          )
        })
      )
    })

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

    ### 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(
          teal.code::get_code(
            teal.code::join(create_plot(), create_table())
          )
        )
        card
      }
      teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
    }
    ###

    # highlight plot area
    output$brush_data <- DT::renderDataTable({
      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)))

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

      numeric_cols <- names(dplyr::select_if(df, is.numeric))

      DT::datatable(df, 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())
    })

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

#' 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
#'
#' @examples
#' # 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,
      trt_group = trt_group,
      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),
        teal.widgets::optionalSelectInput(
          ns("trt_group"),
          label = "Select Treatment Variable",
          choices = get_choices(a$trt_group$choices),
          selected = a$trt_group$selected,
          multiple = FALSE
        ),
        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",
              min = -1000000,
              max = 1000000,
              value = c(-1000000, 1000000)
            ),
            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) {
    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)
      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
      )
    })

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

    yrange_slider <- toggle_slider_server("yrange_scale")

    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
    observe({
      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 keep_range_slider_updated 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 keep_range_slider_updated because this module computes the min, max
      # not from the constrained ANL, but rather by first grouping and computing confidence
      # intervals
      isolate(yrange_slider$update_state(
        min = minmax[[1]],
        max = minmax[[2]],
        value = minmax
      ))
    })

    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 <- reactive({
      teal::validate_inputs(iv_r())
      req(anl_q(), line_color_selected(), line_type_selected())
      # nolint start
      ylim <- yrange_slider$state()$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)
        })
      )
    })

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

    ### 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(teal.code::get_code(plot_q()))
        card
      }
      teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
    }
    ###

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

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

#' 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_group = trt_group,
      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),
      teal.widgets::optionalSelectInput(
        ns("trt_group"),
        label = "Select Treatment Variable",
        choices = get_choices(a$trt_group$choices),
        selected = a$trt_group$selected,
        multiple = FALSE
      ),
      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",
            min = -1000000, max = 1000000, value = c(-1000000, 1000000)
          ),
          toggle_slider_ui(
            ns("yrange_scale"),
            label = "Y-Axis Range Zoom",
            min = -1000000, max = 1000000, value = c(-1000000, 1000000)
          ),
          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) {
    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)
      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
      )
    })

    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,
                  "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
    xrange_slider <- toggle_slider_server("xrange_scale")
    yrange_slider <- toggle_slider_server("yrange_scale")
    keep_range_slider_updated(session, input, xrange_slider$update_state, "xaxis_var", "xaxis_param", anl_constraint)
    keep_range_slider_updated(session, input, yrange_slider$update_state, "yaxis_var", "yaxis_param", anl_constraint)
    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 <- 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$state()$value
      ylim <- yrange_slider$state()$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)
        })
      )
    })

    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
    )


    ### 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(teal.code::get_code(plot_q()))
        card
      }
      teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
    }
    ###

    # highlight plot area
    output$brush_data <- DT::renderDataTable({
      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
      )

      numeric_cols <- names(dplyr::select_if(df, is.numeric))

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

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

#' 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_group = trt_group,
      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),
      teal.widgets::optionalSelectInput(
        ns("trt_group"),
        label = "Select Treatment Variable",
        choices = get_choices(a$trt_group$choices),
        selected = a$trt_group$selected,
        multiple = FALSE
      ),
      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",
            min = -1000000,
            max = 1000000,
            value = c(-1000000, 1000000)
          ),
          toggle_slider_ui(ns("yrange_scale"),
            label = "Y-Axis Range Zoom",
            min = -1000000,
            max = 1000000,
            value = c(-1000000, 1000000)
          ),
          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) {
    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)
      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
      )
    })

    # 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
    xrange_slider <- toggle_slider_server("xrange_scale")
    yrange_slider <- toggle_slider_server("yrange_scale")
    keep_range_slider_updated(session, input, xrange_slider$update_state, "xaxis_var", "xaxis_param", anl_q)
    keep_range_slider_updated(session, input, yrange_slider$update_state, "yaxis_var", "xaxis_param", anl_q)
    keep_data_const_opts_updated(session, input, anl_q, "xaxis_param")

    # plot
    plot_q <- reactive({
      req(anl_q())
      # nolint start
      xlim <- xrange_slider$state()$value
      ylim <- yrange_slider$state()$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)
        })
      )
    })

    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
    )

    ### 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(teal.code::get_code(plot_q()))
        card
      }
      teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
    }
    ###

    # highlight plot area
    output$brush_data <- DT::renderDataTable({
      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), "AVISITCD", "PARAMCD",
          dplyr::all_of(c(xvar, yvar)), "LOQFL"
        ),
        plot_brush
      )

      numeric_cols <- names(dplyr::select_if(df, is.numeric))

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

    teal.widgets::verbatim_popup_srv(
      id = "rcode",
      verbatim_content = reactive(teal.code::get_code(plot_q())),
      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,
      trt_group = trt_group,
      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),
      teal.widgets::optionalSelectInput(
        ns("trt_group"),
        label = "Select Treatment Variable",
        choices = get_choices(a$trt_group$choices),
        selected = a$trt_group$selected,
        multiple = FALSE
      ),
      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",
            min = -1000000,
            max = 1000000,
            value = c(-1000000, 1000000)
          ),
          toggle_slider_ui(
            ns("yrange_scale"),
            label = "Y-Axis Range Zoom",
            min = -1000000,
            max = 1000000,
            value = c(-1000000, 1000000)
          ),
          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) {
    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)
      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
      )
    })

    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
    xrange_slider <- toggle_slider_server("xrange_scale")
    yrange_slider <- toggle_slider_server("yrange_scale")
    keep_range_slider_updated(session, input, xrange_slider$update_state, "xaxis_var", "xaxis_param", anl_q)
    keep_range_slider_updated(
      session,
      input,
      yrange_slider$update_state,
      "xaxis_var",
      "xaxis_param",
      anl_q,
      is_density = TRUE
    )
    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 <- reactive({
      teal::validate_inputs(iv_r())
      req(anl_q())

      # nolint start
      param <- input$xaxis_param
      xaxis_var <- input$xaxis_var
      xlim <- xrange_slider$state()$value
      ylim <- yrange_slider$state()$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)
          )
        })
      )
    })

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

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

    teal.widgets::verbatim_popup_srv(
      id = "rcode",
      verbatim_content = reactive(
        teal.code::get_code(joined_qenvs())
      ),
      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(
          teal.code::get_code(
            teal.code::join(create_plot(), create_table())
          )
        )
        card
      }
      teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
    }
    ###
  })
}

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

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

keep_range_slider_updated <- function(session,
                                      input,
                                      update_slider_fcn,
                                      id_var,
                                      id_param_var,
                                      reactive_ANL, # nolint
                                      is_density = FALSE) {
  stopifnot(is.function(update_slider_fcn))

  observe({
    varname <- input[[id_var]]
    validate(need(varname, "Please select variable"))
    paramname <- input[[id_param_var]]
    validate(need(paramname, "Please select variable"))
    req(length(paramname) == 1)

    # we need id_param_var (e.g. ALT) to filter down because the y-axis may have a different
    # param var and the range of id_var (e.g. BASE) values may be larger due to this
    # therefore, we need to filter
    ANL <- reactive_ANL()$ANL %>% dplyr::filter(.data$PARAMCD == paramname) # nolint
    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)
    step <- NULL

    if (isTRUE(is_density)) {
      minmax <- c(0, round(max(stats::density(stats::na.omit(ANL[[varname]]))$y) * 1.5, 5))
      step <- round(max(stats::density(stats::na.omit(ANL[[varname]]))$y) / 100, 5)
    }

    isolate(update_slider_fcn(
      min = minmax[[1]],
      max = minmax[[2]],
      value = minmax,
      step = step
    ))
  })
}

1		#' UI with a toggleable 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		#' Both normal sliders (for a single number in a range) and dichotomous sliders (for a range
6		#' within the slider range) are supported. In the former case, the toggle button
7		#' will show one numeric input field, in the latter case two.
8		#'
9		#' Value is not checked to be within minmax range
10		#'
11		#' @md
12		#' @param id `character` module id
13		#' @param label `label` label for input field, e.g. slider or numeric inputs
14		#' @param min `numeric or integer` minimum value
15		#' @param max `numeric or integer` maximum value
16		#' @param value `numeric or integer` either of length 1 for normal slider or of
17		#' length 2 for dichotomous slider.
18		#' @param slider_initially `logical` whether to show slider or numeric fields
19		#' initially
20		#' @param step_slider `numeric or integer` step for slider
21		#' @param step_numeric `numeric or integer` step for numeric input fields
22		#' @param width `numeric` width of slider or of each numeric field
23		#' @param ... additional parameters to pass to `sliderInput`
24		#'
25		#' @return Shiny HTML UI
26		#' @keywords internal
27		#'
28		#' @examples
29		#' value <- c(20.3, 81.5) # dichotomous slider
30		#' # value <- c(50.1) # normal slider
31		#'
32		#' # use non-exported function from teal.goshawk
33		#' toggle_slider_ui <- getFromNamespace("toggle_slider_ui", "teal.goshawk")
34		#'
35		#' ui <- div(
36		#' toggle_slider_ui(
37		#' "toggle_slider", "Select value",
38		#' min = 0.2, max = 100.1, value = value,
39		#' slider_initially = FALSE, step_slider = 0.1, step_numeric = 0.001
40		#' ),
41		#' verbatimTextOutput("value")
42		#' )
43		#'
44		#' server <- function(input, output, session) {
45		#' is_dichotomous_slider <- (length(value) == 2)
46		#' range_value <- toggle_slider_server("toggle_slider",
47		#' is_dichotomous_slider = is_dichotomous_slider
48		#' )
49		#' messages <- reactiveVal() # to keep history
50		#' observeEvent(range_value$state(), {
51		#' list_with_names_str <- function(x) paste(names(x), x, sep = ": ", collapse = ", ")
52		#' messages(c(messages(), list_with_names_str(range_value$state())))
53		#' })
54		#' output$value <- renderText({
55		#' paste(messages(), collapse = "\n")
56		#' })
57		#' }
58		#'
59		#' if (interactive()) {
60		#' shinyApp(ui, server)
61		#' }
62		toggle_slider_ui <- function(id,
63		label,
64		min,
65		max,
66		value,
67		slider_initially = TRUE,
68		step_slider = NULL,
69		step_numeric = step_slider,
70		width = NULL,
71		...) {
72	!	checkmate::assert_number(min)
73	!	checkmate::assert_number(max)
74	!	checkmate::assert_flag(slider_initially)
75	!	checkmate::assert_number(step_slider, null.ok = TRUE)
76	!	checkmate::assert_number(step_numeric, null.ok = TRUE)
77	!	checkmate::assert_numeric(value, min.len = 1, max.len = 2)
78	!	if (is.null(step_numeric)) {
79	!	step_numeric <- NA # numericInput does not support NULL
80		}
81
82	!	show_or_not <- function(show) if (show) identity else shinyjs::hidden
83	!	ns <- NS(id)
84	!	tags$div(
85	!	include_css_files("custom"),
86	!	shinyjs::useShinyjs(),
87	!	tags$div(
88	!	class = "flex justify-between mb-1",
89	!	tags$span(tags$strong(label)),
90	!	actionButton(ns("toggle"), "Toggle", class = "btn-xs")
91		),
92	!	show_or_not(slider_initially)(
93	!	sliderInput(
94	!	ns("slider"),
95	!	label = NULL,
96	!	min = min,
97	!	max = max,
98	!	value = value,
99	!	step = step_slider,
100	!	width = width,
101		...
102		)
103		),
104	!	show_or_not(!slider_initially)(tags$span(
105	!	id = ns("numeric_view"),
106	!	if (length(value) == 1) {
107	!	numericInput(
108	!	ns("value"),
109	!	label = NULL,
110	!	min = min,
111	!	max = max,
112	!	value = value[[1]],
113	!	step = step_numeric,
114	!	width = width
115		)
116		} else {
117	!	tags$div(
118	!	numericInput(
119	!	ns("value_low"),
120	!	"From:",
121	!	min = min,
122	!	max = max,
123	!	value = value[[1]],
124	!	step = step_numeric,
125	!	width = width
126		),
127	!	numericInput(
128	!	ns("value_high"),
129	!	"- to:",
130	!	min = min,
131	!	max = max,
132	!	value = value[[2]],
133	!	step = step_numeric,
134	!	width = width
135		)
136		)
137		}
138		))
139		)
140		}
141
142		# is_dichotomous_slider `logical` whether it is a dichotomous slider or normal slider
143		toggle_slider_server <- function(id, is_dichotomous_slider = TRUE) {
144	!	moduleServer(id, function(input, output, session) {
145	!	checkmate::assert_flag(is_dichotomous_slider)
146		# model view controller: cur_state is the model, the sliderInput and numericInputs are two views/controllers
147		# additionally, the module returns the cur_state, so it can be controlled from that end as well
148	!	cur_state <- reactiveVal(NULL) # model, can contain min, max, value etc.
149
150
151	!	iv_r <- reactive({
152	!	iv <- shinyvalidate::InputValidator$new()
153	!	iv$condition(~ input$toggle %% 2 == 1)
154	!	iv$add_rule("value_low", shinyvalidate::sv_required("A 'from' value is required - a default is used instead"))
155	!	iv$add_rule("value_high", shinyvalidate::sv_required("A 'to' value is required - a default is used instead)"))
156	!	iv$add_rule(
157	!	"value_high",
158	!	~ if (!is.na(input$value_low) && (.) < input$value_low) {
159	!	"'From' value should be lower than 'to' value - axis has been flipped"
160		}
161		)
162	!	iv$add_rule(
163	!	"value_low",
164	!	~ if (!is.na(input$value_high) && (.) > input$value_high) {
165	!	"'To' value should be greater than 'from' value - axis has been flipped"
166		}
167		)
168	!	iv$enable()
169	!	iv
170		})
171
172	!	set_state <- function(new_state) {
173	!	stopifnot(all(names(new_state) %in% c("min", "max", "step", "value")))
174	!	iv_r()$is_valid()
175		# when value does not fall into min, max range, it will automatically get truncated
176
177		# only update provided components, do not discasrd others
178	!	old_state <- cur_state()
179	!	new_state <- c(new_state, old_state[!names(old_state) %in% names(new_state)])
180	!	new_state <- new_state[sort(names(new_state))]
181	!	if (!setequal(new_state, cur_state())) {
182	!	cur_state(new_state)
183		}
184		}
185	!	observeEvent(input$slider, {
186	!	set_state(list(value = input$slider))
187		})
188		# two values for range (dichotomous slider)
189	!	observeEvent(
190	!	eventExpr = { # nolint
191	!	input$value_low
192	!	input$value_high
193		},
194	!	handlerExpr = { # nolint
195	!	set_state(list(value = c(input$value_low, input$value_high)))
196		}
197		)
198		# one value for value in range
199	!	observeEvent(
200	!	input$value,
201	!	handlerExpr = { # nolint
202	!	set_state(list(value = input$value))
203		}
204		)
205
206	!	update_widgets <- function() {
207	!	state_slider <- cur_state()
208	!	req(length(state_slider) > 0) # update will otherwise not work
209	!	state_low <- state_slider
210	!	state_high <- state_slider
211	!	if (!is.null(state_slider$value) && (length(state_slider$value) > 1)) {
212	!	state_low$value <- state_low$value[[1]]
213	!	state_high$value <- state_high$value[[2]]
214		}
215	!	if (input$toggle %% 2 == 0) {
216	!	do.call(updateSliderInput, c(list(session, "slider"), state_slider))
217		} else {
218	!	if (length(state_slider$value) > 1) {
219	!	do.call(updateNumericInput, c(list(session, "value_low"), state_low))
220	!	do.call(updateNumericInput, c(list(session, "value_high"), state_high))
221		} else {
222	!	do.call(updateNumericInput, c(list(session, "value"), state_low))
223		}
224		}
225		}
226	!	observeEvent(input$toggle, {
227	!	update_widgets()
228	!	shinyjs::toggle("numeric_view")
229	!	shinyjs::toggle("slider")
230		})
231
232	!	update_toggle_slider <- function(value = NULL, min = NULL, max = NULL, step = NULL) {
233	!	if (!is.null(value) && is_dichotomous_slider) {
234	!	stopifnot(length(value) == 2)
235		}
236	!	set_state(Filter(Negate(is.null), list(value = value, min = min, max = max, step = step)))
237	!	update_widgets()
238		}
239	!	return(list(
240	!	state = cur_state,
241	!	update_state = update_toggle_slider
242		))
243		})
244		}

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	!	trt_group = trt_group,
249	!	xaxis_var_level = xaxis_var_level,
250	!	trt_group_level = trt_group_level,
251	!	man_color = man_color,
252	!	color_comb = color_comb,
253	!	param_var_label = param_var_label,
254	!	xtick = xtick,
255	!	xlabel = xlabel,
256	!	plot_height = plot_height,
257	!	plot_width = plot_width,
258	!	hline_vars_colors = hline_vars_colors,
259	!	hline_vars_labels = hline_vars_labels,
260	!	module_args = args
261		),
262	!	ui = g_ui_spaghettiplot,
263	!	ui_args = args,
264	!	datanames = dataname
265		)
266		}
267
268		g_ui_spaghettiplot <- function(id, ...) {
269	!	ns <- NS(id)
270	!	a <- list(...)
271
272	!	shiny::tagList(
273	!	include_css_files("custom"),
274	!	teal.widgets::standard_layout(
275	!	output = templ_ui_output_datatable(ns),
276	!	encoding = tags$div(
277		### Reporter
278	!	teal.reporter::simple_reporter_ui(ns("simple_reporter")),
279		###
280	!	templ_ui_dataname(a$dataname),
281	!	teal.widgets::optionalSelectInput(
282	!	ns("trt_group"),
283	!	label = "Select Treatment Variable",
284	!	choices = get_choices(a$trt_group$choices),
285	!	selected = a$trt_group$selected,
286	!	multiple = FALSE
287		),
288	!	uiOutput(ns("axis_selections")),
289	!	radioButtons(
290	!	ns("group_stats"),
291	!	"Group Statistics",
292	!	c("None" = "NONE", "Mean" = "MEAN", "Median" = "MEDIAN"),
293	!	inline = TRUE
294		),
295	!	templ_ui_constraint(ns), # required by constr_anl_q
296	!	if (length(a$hline_vars) > 0) {
297	!	teal.widgets::optionalSelectInput(
298	!	ns("hline_vars"),
299	!	label = "Add Horizontal Range Line(s):",
300	!	choices = a$hline_vars,
301	!	selected = NULL,
302	!	multiple = TRUE
303		)
304		},
305	!	ui_arbitrary_lines(id = ns("hline_arb"), a$hline_arb, a$hline_arb_label, a$hline_arb_color),
306	!	teal.widgets::panel_group(
307	!	teal.widgets::panel_item(
308	!	title = "Plot Aesthetic Settings",
309	!	tags$div(
310	!	toggle_slider_ui(
311	!	ns("yrange_scale"),
312	!	label = "Y-Axis Range Zoom",
313	!	min = -1000000,
314	!	max = 1000000,
315	!	value = c(-1000000, 1000000)
316		),
317	!	tags$div(
318	!	class = "flex flex-wrap items-center",
319	!	tags$div(
320	!	class = "mr-1",
321	!	tags$span(tags$strong("Number of Plots Per Row:"))
322		),
323	!	tags$div(
324	!	class = "w-65px",
325	!	numericInput(ns("facet_ncol"), "", a$facet_ncol, min = 1)
326		)
327		)
328		),
329	!	checkboxInput(ns("free_x"), "Free X-Axis Scales", a$free_x),
330	!	checkboxInput(ns("rotate_xlab"), "Rotate X-Axis Label", a$rotate_xlab),
331	!	teal.widgets::optionalSliderInputValMinMax(ns("font_size"), "Font Size", a$font_size, ticks = FALSE),
332	!	teal.widgets::optionalSliderInputValMinMax(ns("dot_size"), "Dot Size", a$dot_size, ticks = FALSE),
333	!	teal.widgets::optionalSliderInputValMinMax(
334	!	ns("alpha"),
335	!	"Line Alpha",
336	!	a$alpha,
337	!	value_min_max = c(0.8, 0.0, 1.0), step = 0.1, ticks = FALSE
338		)
339		)
340		)
341		),
342	!	forms = tagList(
343	!	teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
344		),
345	!	pre_output = a$pre_output,
346	!	post_output = a$post_output
347		)
348		)
349		}
350
351
352
353		srv_g_spaghettiplot <- function(id,
354		data,
355		reporter,
356		filter_panel_api,
357		dataname,
358		idvar,
359		param_var,
360		trt_group,
361		man_color,
362		color_comb,
363		xaxis_var_level,
364		trt_group_level,
365		param_var_label,
366		xtick,
367		xlabel,
368		plot_height,
369		plot_width,
370		hline_vars_colors,
371		hline_vars_labels,
372		module_args) {
373	!	with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
374	!	with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
375	!	checkmate::assert_class(data, "reactive")
376	!	checkmate::assert_class(shiny::isolate(data()), "teal_data")
377
378	!	moduleServer(id, function(input, output, session) {
379	!	output$axis_selections <- renderUI({
380	!	env <- shiny::isolate(as.list(data()@env))
381	!	resolved_x <- teal.transform::resolve_delayed(module_args$xaxis_var, env)
382	!	resolved_y <- teal.transform::resolve_delayed(module_args$yaxis_var, env)
383	!	resolved_param <- teal.transform::resolve_delayed(module_args$param, env)
384	!	templ_ui_params_vars(
385	!	session$ns,
386		# xparam and yparam are identical, so we only show the user one
387	!	xparam_choices = resolved_param$choices,
388	!	xparam_selected = resolved_param$selected,
389	!	xparam_label = "Select a Biomarker",
390	!	xchoices = resolved_x$choices,
391	!	xselected = resolved_x$selected,
392	!	ychoices = resolved_y$choices,
393	!	yselected = resolved_y$selected
394		)
395		})
396
397		# reused in all modules
398	!	anl_q_output <- constr_anl_q(
399	!	session, input, data, dataname,
400	!	param_id = "xaxis_param", param_var = param_var, trt_group = input$trt_group, min_rows = 1
401		)
402
403	!	anl_q <- anl_q_output()$value
404
405		# update sliders for axes taking constraints into account
406	!	yrange_slider <- toggle_slider_server("yrange_scale")
407	!	keep_range_slider_updated(session, input, yrange_slider$update_state, "yaxis_var", "xaxis_param", anl_q)
408	!	keep_data_const_opts_updated(session, input, anl_q, "xaxis_param")
409
410	!	horizontal_line <- srv_arbitrary_lines("hline_arb")
411
412	!	iv_r <- reactive({
413	!	iv <- shinyvalidate::InputValidator$new()
414
415	!	iv$add_rule("xaxis_param", shinyvalidate::sv_required("Please select a biomarker"))
416	!	iv$add_rule("trt_group", shinyvalidate::sv_required("Please select a treatment variable"))
417	!	iv$add_rule("xaxis_var", shinyvalidate::sv_required("Please select an X-Axis variable"))
418	!	iv$add_rule("yaxis_var", shinyvalidate::sv_required("Please select a Y-Axis variable"))
419	!	iv$add_rule("facet_ncol", plots_per_row_validate_rules())
420
421	!	iv$add_validator(horizontal_line()$iv_r())
422	!	iv$add_validator(anl_q_output()$iv_r())
423	!	iv$enable()
424	!	iv
425		})
426
427
428	!	plot_q <- reactive({
429	!	teal::validate_inputs(iv_r())
430	!	req(anl_q())
431		# nolint start
432	!	ylim <- yrange_slider$state()$value
433	!	facet_ncol <- input$facet_ncol
434	!	facet_scales <- ifelse(input$free_x, "free_x", "fixed")
435
436	!	rotate_xlab <- input$rotate_xlab
437	!	hline_arb <- horizontal_line()$line_arb
438	!	hline_arb_label <- horizontal_line()$line_arb_label
439	!	hline_arb_color <- horizontal_line()$line_arb_color
440	!	group_stats <- input$group_stats
441	!	font_size <- input$font_size
442	!	dot_size <- input$dot_size
443	!	alpha <- input$alpha
444	!	validate(need(input$trt_group, "Please select a treatment variable"))
445	!	trt_group <- input$trt_group
446
447		# Below inputs should trigger plot via updates of other reactive objects (i.e. anl_q()) and some inputs
448	!	param <- input$xaxis_param
449	!	xaxis_var <- input$xaxis_var
450	!	yaxis_var <- input$yaxis_var
451	!	hline_vars <- input$hline_vars
452		# nolint end
453
454	!	private_qenv <- anl_q()$qenv
455
456		# this code is needed to make sure the waiver attribute
457		# of ggplot2::waiver is correctly passed to goshawk's spaghettiplot
458	!	if (!methods::is(xtick, "waiver")) {
459	!	private_qenv <- teal.code::eval_code(
460	!	object = private_qenv,
461	!	code = bquote(xtick <- .(xtick))
462		)
463		} else {
464	!	private_qenv <- teal.code::eval_code(
465	!	object = private_qenv,
466	!	code = quote(xtick <- ggplot2::waiver())
467		)
468		}
469
470	!	if (!methods::is(xlabel, "waiver")) {
471	!	private_qenv <- teal.code::eval_code(
472	!	object = private_qenv,
473	!	code = bquote(xlabel <- .(xlabel))
474		)
475		} else {
476	!	private_qenv <- teal.code::eval_code(
477	!	object = private_qenv,
478	!	code = quote(xlabel <- ggplot2::waiver())
479		)
480		}
481
482	!	teal.code::eval_code(
483	!	object = private_qenv,
484	!	code = bquote({
485	!	p <- goshawk::g_spaghettiplot(
486	!	data = ANL,
487	!	subj_id = .(idvar),
488	!	biomarker_var = .(param_var),
489	!	biomarker_var_label = .(param_var_label),
490	!	biomarker = .(param),
491	!	value_var = .(yaxis_var),
492	!	trt_group = .(trt_group),
493	!	trt_group_level = .(trt_group_level),
494	!	time = .(xaxis_var),
495	!	time_level = .(xaxis_var_level),
496	!	color_manual = .(man_color),
497	!	color_comb = .(color_comb),
498	!	ylim = .(ylim),
499	!	facet_ncol = .(facet_ncol),
500	!	facet_scales = .(facet_scales),
501	!	hline_arb = .(hline_arb),
502	!	hline_arb_label = .(hline_arb_label),
503	!	hline_arb_color = .(hline_arb_color),
504	!	xtick = xtick,
505	!	xlabel = xlabel,
506	!	rotate_xlab = .(rotate_xlab),
507	!	font_size = .(font_size),
508	!	dot_size = .(dot_size),
509	!	alpha = .(alpha),
510	!	group_stats = .(group_stats),
511	!	hline_vars = .(hline_vars),
512	!	hline_vars_colors = .(hline_vars_colors[seq_along(hline_vars)]),
513	!	hline_vars_labels = .(hline_vars_labels[seq_along(hline_vars)])
514		)
515	!	print(p)
516		})
517		)
518		})
519
520	!	plot_r <- reactive({
521	!	plot_q()[["p"]]
522		})
523
524	!	plot_data <- teal.widgets::plot_with_settings_srv(
525	!	id = "plot",
526	!	plot_r = plot_r,
527	!	height = plot_height,
528	!	width = plot_width,
529	!	brushing = TRUE
530		)
531
532		### REPORTER
533	!	if (with_reporter) {
534	!	card_fun <- function(comment, label) {
535	!	card <- report_card_template_goshawk(
536	!	title = "Spaghetti Plot",
537	!	label = label,
538	!	with_filter = with_filter,
539	!	filter_panel_api = filter_panel_api,
540	!	constraint_list = list(
541	!	constraint_var = input$constraint_var,
542	!	constraint_range_min = input$constraint_range_min,
543	!	constraint_range_max = input$constraint_range_max
544		)
545		)
546	!	card$append_text("Spaghetti Plot", "header3")
547	!	card$append_plot(plot_r(), dim = plot_data$dim())
548	!	if (!comment == "") {
549	!	card$append_text("Comment", "header3")
550	!	card$append_text(comment)
551		}
552	!	card$append_src(teal.code::get_code(plot_q()))
553	!	card
554		}
555	!	teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
556		}
557		###
558
559	!	output$brush_data <- DT::renderDataTable({
560	!	plot_brush <- plot_data$brush()
561
562	!	ANL <- isolate(anl_q()$ANL) # nolint
563	!	validate_has_data(ANL, 1)
564
565	!	xvar <- isolate(input$xaxis_var)
566	!	yvar <- isolate(input$yaxis_var)
567	!	trt_group <- isolate(input$trt_group)
568
569	!	req(all(c(xvar, yvar) %in% names(ANL)))
570
571	!	df <- teal.widgets::clean_brushedPoints(
572	!	dplyr::select(
573	!	ANL, "USUBJID", dplyr::all_of(trt_group), "PARAMCD",
574	!	dplyr::all_of(c(xvar, yvar)), "LOQFL"
575		),
576	!	plot_brush
577		)
578	!	df <- df[order(df$PARAMCD, df[[trt_group]], df$USUBJID, df[[xvar]]), ]
579	!	numeric_cols <- names(dplyr::select_if(df, is.numeric))
580
581	!	DT::datatable(df, rownames = FALSE, options = list(scrollX = TRUE)) %>%
582	!	DT::formatRound(numeric_cols, 4)
583		})
584
585	!	teal.widgets::verbatim_popup_srv(
586	!	id = "rcode",
587	!	verbatim_content = reactive(teal.code::get_code(plot_q())),
588	!	title = "Show R Code for Spaghetti Plot"
589		)
590		})
591		}

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		#' @examples
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	!	message("Initializing tm_g_gh_boxplot")
176	!	checkmate::assert_string(label)
177	!	checkmate::assert_string(dataname)
178	!	checkmate::assert_string(param_var)
179	!	checkmate::assert_class(param, "choices_selected")
180	!	checkmate::assert_class(yaxis_var, "choices_selected")
181	!	checkmate::assert_class(xaxis_var, "choices_selected")
182	!	checkmate::assert_class(facet_var, "choices_selected")
183	!	checkmate::assert_class(trt_group, "choices_selected")
184	!	checkmate::assert_int(facet_ncol, null.ok = TRUE)
185	!	checkmate::assert_flag(loq_legend)
186	!	checkmate::assert_flag(rotate_xlab)
187	!	checkmate::assert_numeric(font_size, len = 3)
188	!	checkmate::assert_numeric(dot_size, len = 3)
189	!	checkmate::assert_numeric(alpha, len = 3)
190	!	validate_line_arb_arg(hline_arb, hline_arb_color, hline_arb_label)
191	!	validate_line_vars_arg(hline_vars, hline_vars_colors, hline_vars_labels)
192	!	checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
193	!	checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")
194	!	checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
195	!	checkmate::assert_numeric(
196	!	plot_width[1],
197	!	lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"
198		)
199
200	!	args <- as.list(environment())
201
202	!	module(
203	!	label = label,
204	!	datanames = dataname,
205	!	server = srv_g_boxplot,
206	!	server_args = list(
207	!	dataname = dataname,
208	!	param_var = param_var,
209	!	trt_group = trt_group,
210	!	facet_var = facet_var,
211	!	color_manual = color_manual,
212	!	shape_manual = shape_manual,
213	!	plot_height = plot_height,
214	!	plot_width = plot_width,
215	!	hline_vars_colors = hline_vars_colors,
216	!	hline_vars_labels = hline_vars_labels,
217	!	module_args = args
218		),
219	!	ui = ui_g_boxplot,
220	!	ui_args = args
221		)
222		}
223
224		ui_g_boxplot <- function(id, ...) {
225	!	ns <- NS(id)
226	!	a <- list(...)
227
228	!	teal.widgets::standard_layout(
229	!	output = tags$div(
230	!	fluidRow(
231	!	teal.widgets::plot_with_settings_ui(id = ns("boxplot"))
232		),
233	!	fluidRow(column(
234	!	width = 12,
235	!	tags$br(), tags$hr(),
236	!	tags$h4("Selected Data Points"),
237	!	DT::dataTableOutput(ns("brush_data"))
238		)),
239	!	fluidRow(column(
240	!	width = 12,
241	!	tags$br(), tags$hr(),
242	!	tags$h4("Descriptive Statistics"),
243	!	DT::dataTableOutput(ns("table_ui"))
244		))
245		),
246	!	encoding = tags$div(
247		### Reporter
248	!	teal.reporter::simple_reporter_ui(ns("simple_reporter")),
249		###
250	!	templ_ui_dataname(a$dataname),
251	!	teal.widgets::optionalSelectInput(
252	!	ns("trt_group"),
253	!	label = "Select Treatment Variable",
254	!	choices = get_choices(a$trt_group$choices),
255	!	selected = a$trt_group$selected,
256	!	multiple = FALSE
257		),
258	!	uiOutput(ns("axis_selections")),
259	!	teal.widgets::optionalSelectInput(
260	!	ns("facet_var"),
261	!	label = "Facet by",
262	!	choices = get_choices(a$facet_var$choices),
263	!	selected = a$facet_var$selected,
264	!	multiple = FALSE
265		),
266	!	templ_ui_constraint(ns, label = "Data Constraint"), # required by constr_anl_q
267	!	if (length(a$hline_vars) > 0) {
268	!	teal.widgets::optionalSelectInput(
269	!	ns("hline_vars"),
270	!	label = "Add Horizontal Range Line(s):",
271	!	choices = a$hline_vars,
272	!	selected = NULL,
273	!	multiple = TRUE
274		)
275		},
276	!	ui_arbitrary_lines(id = ns("hline_arb"), a$hline_arb, a$hline_arb_label, a$hline_arb_color),
277	!	teal.widgets::panel_group(
278	!	teal.widgets::panel_item(
279	!	title = "Plot Aesthetic Settings",
280	!	toggle_slider_ui(
281	!	ns("yrange_scale"),
282	!	label = "Y-Axis Range Zoom",
283	!	min = -1000000,
284	!	max = 1000000,
285	!	value = c(-1000000, 1000000)
286		),
287	!	numericInput(ns("facet_ncol"), "Number of Plots Per Row:", a$facet_ncol, min = 1),
288	!	checkboxInput(ns("loq_legend"), "Display LoQ Legend", a$loq_legend),
289	!	checkboxInput(ns("rotate_xlab"), "Rotate X-axis Label", a$rotate_xlab)
290		),
291	!	teal.widgets::panel_item(
292	!	title = "Plot settings",
293	!	teal.widgets::optionalSliderInputValMinMax(ns("font_size"), "Font Size", a$font_size, ticks = FALSE),
294	!	teal.widgets::optionalSliderInputValMinMax(ns("dot_size"), "Dot Size", a$dot_size, ticks = FALSE),
295	!	teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Dot Alpha", a$alpha, ticks = FALSE)
296		)
297		)
298		),
299	!	forms = tagList(
300	!	teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
301		),
302	!	pre_output = a$pre_output,
303	!	post_output = a$post_output
304		)
305		}
306
307
308		srv_g_boxplot <- function(id,
309		data,
310		reporter,
311		filter_panel_api,
312		dataname,
313		param_var,
314		trt_group,
315		facet_var,
316		color_manual,
317		shape_manual,
318		plot_height,
319		plot_width,
320		hline_vars_colors,
321		hline_vars_labels,
322		module_args) {
323	!	with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
324	!	with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
325	!	checkmate::assert_class(data, "reactive")
326	!	checkmate::assert_class(shiny::isolate(data()), "teal_data")
327
328	!	moduleServer(id, function(input, output, session) {
329	!	output$axis_selections <- renderUI({
330	!	env <- shiny::isolate(as.list(data()@env))
331	!	resolved_x <- teal.transform::resolve_delayed(module_args$xaxis_var, env)
332	!	resolved_y <- teal.transform::resolve_delayed(module_args$yaxis_var, env)
333	!	resolved_param <- teal.transform::resolve_delayed(module_args$param, env)
334	!	templ_ui_params_vars(
335	!	session$ns,
336	!	xparam_choices = resolved_param$choices,
337	!	xparam_selected = resolved_param$selected,
338	!	xparam_label = module_args$"Select a Biomarker",
339	!	xchoices = resolved_x$choices,
340	!	xselected = resolved_x$selected,
341	!	ychoices = resolved_y$choices,
342	!	yselected = resolved_y$selected
343		)
344		})
345		# reused in all modules
346	!	anl_q_output <- constr_anl_q(
347	!	session, input, data, dataname,
348	!	param_id = "xaxis_param", param_var = param_var, trt_group = input$trt_group, min_rows = 2
349		)
350
351	!	anl_q <- anl_q_output()$value
352
353		# update sliders for axes taking constraints into account
354	!	yrange_slider <- toggle_slider_server("yrange_scale")
355	!	keep_range_slider_updated(
356	!	session,
357	!	input,
358	!	update_slider_fcn = yrange_slider$update_state,
359	!	id_var = "yaxis_var",
360	!	id_param_var = "xaxis_param",
361	!	reactive_ANL = anl_q
362		)
363	!	keep_data_const_opts_updated(session, input, anl_q, "xaxis_param")
364
365	!	horizontal_line <- srv_arbitrary_lines("hline_arb")
366
367	!	trt_group <- reactive({
368	!	input$trt_group
369		})
370
371	!	iv_r <- reactive({
372	!	iv <- shinyvalidate::InputValidator$new()
373
374	!	iv$add_rule("xaxis_param", shinyvalidate::sv_required("Please select a biomarker"))
375	!	iv$add_rule("trt_group", shinyvalidate::sv_required("Please select a treatment variable"))
376	!	iv$add_rule("xaxis_var", shinyvalidate::sv_required("Please select an X-Axis variable"))
377	!	iv$add_rule("xaxis_var", ~ if ((.) %in% c("ACTARM", "ARM") && isTRUE((.) != trt_group())) {
378	!	sprintf("You can not choose %s as x-axis variable for treatment variable %s.", (.), trt_group())
379		})
380	!	iv$add_rule("yaxis_var", shinyvalidate::sv_required("Please select a Y-Axis variable"))
381
382	!	iv$add_rule("facet_var", shinyvalidate::sv_optional())
383	!	iv$add_rule("facet_var", ~ if ((.) %in% c("ACTARM", "ARM") && isTRUE((.) != trt_group())) {
384	!	sprintf("You can not choose %s as faceting variable for treatment variable %s.", (.), trt_group())
385		})
386
387	!	iv_facet <- shinyvalidate::InputValidator$new()
388	!	iv_facet$condition(~ !is.null(input$facet_var))
389	!	iv_facet$add_rule("facet_ncol", plots_per_row_validate_rules(required = FALSE))
390	!	iv$add_validator(iv_facet)
391
392	!	iv$add_validator(horizontal_line()$iv_r())
393	!	iv$add_validator(anl_q_output()$iv_r())
394	!	iv$enable()
395	!	iv
396		})
397
398	!	create_plot <- reactive({
399	!	teal::validate_inputs(iv_r())
400
401	!	req(anl_q())
402		# nolint start
403	!	param <- input$xaxis_param
404	!	yaxis <- input$yaxis_var
405	!	xaxis <- input$xaxis_var
406	!	facet_var <- `if`(is.null(input$facet_var), "None", input$facet_var)
407	!	ylim <- yrange_slider$state()$value
408	!	facet_ncol <- input$facet_ncol
409
410	!	alpha <- input$alpha
411	!	font_size <- input$font_size
412	!	dot_size <- input$dot_size
413	!	loq_legend <- input$loq_legend
414	!	rotate_xlab <- input$rotate_xlab
415
416	!	hline_arb <- horizontal_line()$line_arb
417	!	hline_arb_label <- horizontal_line()$line_arb_label
418	!	hline_arb_color <- horizontal_line()$line_arb_color
419
420	!	hline_vars <- input$hline_vars
421	!	trt_group <- input$trt_group
422		# nolint end
423
424	!	validate_has_variable(
425	!	anl_q()$ANL,
426	!	yaxis,
427	!	sprintf("Variable %s is not available in data %s", yaxis, dataname)
428		)
429	!	validate_has_variable(
430	!	anl_q()$ANL,
431	!	xaxis,
432	!	sprintf("Variable %s is not available in data %s", xaxis, dataname)
433		)
434
435	!	if (!facet_var == "None") {
436	!	validate_has_variable(
437	!	anl_q()$ANL,
438	!	facet_var,
439	!	sprintf("Variable %s is not available in data %s", facet_var, dataname)
440		)
441		}
442
443	!	anl_q()$qenv %>% teal.code::eval_code(
444	!	code = bquote({
445	!	p <- goshawk::g_boxplot(
446	!	data = ANL,
447	!	biomarker = .(param),
448	!	xaxis_var = .(xaxis),
449	!	yaxis_var = .(yaxis),
450	!	hline_arb = .(hline_arb),
451	!	hline_arb_label = .(hline_arb_label),
452	!	hline_arb_color = .(hline_arb_color),
453	!	hline_vars = .(hline_vars),
454	!	hline_vars_colors = .(hline_vars_colors[seq_along(hline_vars)]),
455	!	hline_vars_labels = .(hline_vars_labels[seq_along(hline_vars)]),
456	!	facet_ncol = .(facet_ncol),
457	!	loq_legend = .(loq_legend),
458	!	rotate_xlab = .(rotate_xlab),
459	!	trt_group = .(trt_group),
460	!	ylim = .(ylim),
461	!	color_manual = .(color_manual),
462	!	shape_manual = .(shape_manual),
463	!	facet_var = .(facet_var),
464	!	alpha = .(alpha),
465	!	dot_size = .(dot_size),
466	!	font_size = .(font_size),
467	!	unit = .("AVALU")
468		)
469		})
470		)
471		})
472
473	!	create_table <- reactive({
474	!	req(iv_r()$is_valid())
475	!	req(anl_q())
476	!	param <- input$xaxis_param
477	!	xaxis_var <- input$yaxis_var # nolint
478	!	font_size <- input$font_size
479	!	trt_group <- input$trt_group
480
481	!	anl_q()$qenv %>% teal.code::eval_code(
482	!	code = bquote({
483	!	tbl <- goshawk::t_summarytable(
484	!	data = ANL,
485	!	trt_group = .(trt_group),
486	!	param_var = .(param_var),
487	!	param = .(param),
488	!	xaxis_var = .(xaxis_var),
489	!	facet_var = .(input$facet_var)
490		)
491		})
492		)
493		})
494
495	!	plot_r <- reactive({
496	!	create_plot()[["p"]]
497		})
498
499	!	boxplot_data <- teal.widgets::plot_with_settings_srv(
500	!	id = "boxplot",
501	!	plot_r = plot_r,
502	!	height = plot_height,
503	!	width = plot_width,
504	!	brushing = TRUE
505		)
506
507	!	output$table_ui <- DT::renderDataTable({
508	!	req(create_table())
509	!	tbl <- create_table()[["tbl"]]
510
511	!	numeric_cols <- setdiff(names(dplyr::select_if(tbl, is.numeric)), "n")
512
513	!	DT::datatable(tbl, rownames = FALSE, options = list(scrollX = TRUE)) %>%
514	!	DT::formatRound(numeric_cols, 4)
515		})
516
517		### REPORTER
518	!	if (with_reporter) {
519	!	card_fun <- function(comment, label) {
520	!	constraint_description <- paste(
521	!	"\nFacet By:",
522	!	if (length(input$facet_var) != 0) input$facet_var else "None",
523	!	"\nSelect an X-axis Variable:",
524	!	input$xaxis_var
525		)
526	!	card <- report_card_template_goshawk(
527	!	title = "Box Plot",
528	!	label = label,
529	!	with_filter = with_filter,
530	!	filter_panel_api = filter_panel_api,
531	!	constraint_list = list(
532	!	constraint_var = input$constraint_var,
533	!	constraint_range_min = input$constraint_range_min,
534	!	constraint_range_max = input$constraint_range_max
535		),
536	!	constraint_description = constraint_description,
537	!	style = "verbatim"
538		)
539	!	card$append_text("Plot", "header3")
540	!	card$append_plot(plot_r(), dim = boxplot_data$dim())
541	!	if (!comment == "") {
542	!	card$append_text("Comment", "header3")
543	!	card$append_text(comment)
544		}
545	!	card$append_src(
546	!	teal.code::get_code(
547	!	teal.code::join(create_plot(), create_table())
548		)
549		)
550	!	card
551		}
552	!	teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
553		}
554		###
555
556		# highlight plot area
557	!	output$brush_data <- DT::renderDataTable({
558	!	boxplot_brush <- boxplot_data$brush()
559
560	!	ANL <- isolate(anl_q()$ANL) %>% droplevels() # nolint
561	!	validate_has_data(ANL, 2)
562
563	!	xvar <- isolate(input$xaxis_var)
564	!	yvar <- isolate(input$yaxis_var)
565	!	facetv <- isolate(input$facet_var)
566	!	trt_group <- isolate(input$trt_group)
567
568	!	req(all(c(xvar, yvar, facetv, trt_group) %in% names(ANL)))
569
570	!	df <- teal.widgets::clean_brushedPoints(
571	!	dplyr::select(
572	!	ANL, "USUBJID", dplyr::all_of(c(trt_group, facetv)),
573	!	"AVISITCD", "PARAMCD", dplyr::all_of(c(xvar, yvar)), "LOQFL"
574		),
575	!	boxplot_brush
576		)
577
578	!	numeric_cols <- names(dplyr::select_if(df, is.numeric))
579
580	!	DT::datatable(df, rownames = FALSE, options = list(scrollX = TRUE)) %>%
581	!	DT::formatRound(numeric_cols, 4)
582		})
583
584	!	joined_qenvs <- reactive({
585	!	req(create_plot(), create_table())
586	!	teal.code::join(create_plot(), create_table())
587		})
588
589	!	teal.widgets::verbatim_popup_srv(
590	!	id = "rcode",
591	!	verbatim_content = reactive(teal.code::get_code(joined_qenvs())),
592	!	title = "Show R Code for Boxplot"
593		)
594		})
595		}

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	!	ns <- NS(id)
20	!	tags$div(
21	!	tags$b(title),
22	!	textInput(
23	!	ns("line_arb"),
24	!	tags$div(
25	!	class = "teal-tooltip",
26	!	tagList(
27	!	"Value:",
28	!	icon("circle-info"),
29	!	tags$span(
30	!	class = "tooltiptext",
31	!	"For multiple lines, supply a comma separated list of values."
32		)
33		)
34		),
35	!	value = paste(line_arb, collapse = ", ")
36		),
37	!	textInput(ns("line_arb_label"), label = "Label:", value = paste(line_arb_label, collapse = ", ")),
38	!	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	!	moduleServer(id, function(input, output, session) {
51
52	!	comma_sep_to_values <- function(values, wrapper_fun = trimws) {
53	!	vals <- strsplit(values, "\\s{0,},\\s{0,}")[[1]]
54	!	suppressWarnings(wrapper_fun(vals))
55		}
56
57	!	iv_r <- reactive({
58	!	iv <- shinyvalidate::InputValidator$new()
59	!	iv$add_rule("line_arb", shinyvalidate::sv_optional())
60	!	iv$add_rule(
61	!	"line_arb",
62	!	~ 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	!	iv_color <- shinyvalidate::InputValidator$new()
68	!	iv_color$condition(~ length(line_arb()) != 0)
69
70	!	iv_color$add_rule("line_arb_color", shinyvalidate::sv_optional())
71	!	iv_color$add_rule(
72	!	"line_arb_color",
73	!	~ 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	!	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	!	iv$add_validator(iv_color)
84
85
86	!	iv_label <- shinyvalidate::InputValidator$new()
87	!	iv_label$condition(~ length(line_arb()) != 0)
88
89	!	iv_label$add_rule("line_arb_label", shinyvalidate::sv_optional())
90	!	iv_label$add_rule(
91	!	"line_arb_label",
92	!	~ 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	!	iv$add_validator(iv_label)
100	!	iv
101		})
102
103	!	line_arb <- reactive({
104	!	req(!is.null(input$line_arb))
105	!	comma_sep_to_values(input$line_arb, as.numeric)
106		})
107
108	!	line_arb_label <- reactive({
109	!	if (length(line_arb()) == 0) {
110	!	return(character(0))
111		}
112	!	val <- comma_sep_to_values(input$line_arb_label)
113	!	if (length(val) == 0) {
114	!	val <- ""
115		}
116	!	val
117		})
118
119	!	line_arb_color <- reactive({
120	!	if (length(line_arb()) == 0) {
121	!	return(character(0))
122		}
123	!	val <- comma_sep_to_values(input$line_arb_color)
124	!	if (length(val) == 0 \|\| all(val == "")) {
125	!	val <- "red"
126		}
127	!	val
128		})
129
130	!	return(
131	!	reactive(
132	!	list(
133	!	iv_r = iv_r,
134	!	line_arb = line_arb(),
135	!	line_arb_color = line_arb_color(),
136	!	line_arb_label = line_arb_label()
137		)
138		)
139		)
140		})
141		}
142
143		check_color <- function(col) {
144	!	tryCatch(
145	!	is.matrix(grDevices::col2rgb(col)),
146	!	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	!	checkmate::assert_numeric(line_arb)
153	!	if (length(line_arb) > 0) {
154	!	checkmate::assert(
155	!	checkmate::check_string(line_arb_color),
156	!	checkmate::check_character(line_arb_color, len = length(line_arb))
157		)
158	!	checkmate::assert(
159	!	checkmate::check_string(line_arb_label),
160	!	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	!	checkmate::assert_character(line_vars)
168	!	if (length(line_vars) > 0) {
169	!	checkmate::assert(
170	!	checkmate::check_string(line_vars_colors),
171	!	checkmate::check_character(line_vars_colors, len = length(line_vars))
172		)
173	!	checkmate::assert(
174	!	checkmate::check_string(line_vars_labels),
175	!	checkmate::check_character(line_vars_labels, len = length(line_vars))
176		)
177		}
178		}

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_group = trt_group,
176	!	trt_facet = trt_facet,
177	!	color_manual = color_manual,
178	!	shape_manual = shape_manual,
179	!	plot_height = plot_height,
180	!	plot_width = plot_width,
181	!	module_args = args
182		),
183	!	ui = ui_g_scatterplot,
184	!	ui_args = args
185		)
186		}
187
188		ui_g_scatterplot <- function(id, ...) {
189	!	ns <- NS(id)
190	!	a <- list(...)
191
192	!	teal.widgets::standard_layout(
193	!	output = templ_ui_output_datatable(ns),
194	!	encoding = tags$div(
195		### Reporter
196	!	teal.reporter::simple_reporter_ui(ns("simple_reporter")),
197		###
198	!	templ_ui_dataname(a$dataname),
199	!	teal.widgets::optionalSelectInput(
200	!	ns("trt_group"),
201	!	label = "Select Treatment Variable",
202	!	choices = get_choices(a$trt_group$choices),
203	!	selected = a$trt_group$selected,
204	!	multiple = FALSE
205		),
206	!	uiOutput(ns("axis_selections")),
207	!	templ_ui_constraint(ns), # required by constr_anl_q
208	!	teal.widgets::panel_group(
209	!	teal.widgets::panel_item(
210	!	title = "Plot Aesthetic Settings",
211	!	toggle_slider_ui(ns("xrange_scale"),
212	!	label = "X-Axis Range Zoom",
213	!	min = -1000000,
214	!	max = 1000000,
215	!	value = c(-1000000, 1000000)
216		),
217	!	toggle_slider_ui(ns("yrange_scale"),
218	!	label = "Y-Axis Range Zoom",
219	!	min = -1000000,
220	!	max = 1000000,
221	!	value = c(-1000000, 1000000)
222		),
223	!	numericInput(ns("facet_ncol"), "Number of Plots Per Row:", a$facet_ncol, min = 1),
224	!	checkboxInput(ns("trt_facet"), "Treatment Variable Faceting", a$trt_facet),
225	!	checkboxInput(ns("reg_line"), "Regression Line", a$reg_line),
226	!	checkboxInput(ns("rotate_xlab"), "Rotate X-axis Label", a$rotate_xlab),
227	!	numericInput(ns("hline"), "Add a horizontal line:", a$hline),
228	!	numericInput(ns("vline"), "Add a vertical line:", a$vline)
229		),
230	!	teal.widgets::panel_item(
231	!	title = "Plot settings",
232	!	teal.widgets::optionalSliderInputValMinMax(ns("font_size"), "Font Size", a$font_size, ticks = FALSE),
233	!	teal.widgets::optionalSliderInputValMinMax(ns("dot_size"), "Dot Size", a$dot_size, ticks = FALSE),
234	!	teal.widgets::optionalSliderInputValMinMax(
235	!	ns("reg_text_size"),
236	!	"Regression Annotations Size",
237	!	a$reg_text_size,
238	!	ticks = FALSE
239		)
240		)
241		)
242		),
243	!	forms = tagList(
244	!	teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
245		),
246	!	pre_output = a$pre_output,
247	!	post_output = a$post_output
248		)
249		}
250
251		srv_g_scatterplot <- function(id,
252		data,
253		reporter,
254		filter_panel_api,
255		dataname,
256		param_var,
257		trt_group,
258		trt_facet,
259		color_manual,
260		shape_manual,
261		plot_height,
262		plot_width,
263		module_args) {
264	!	with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
265	!	with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
266	!	checkmate::assert_class(data, "reactive")
267	!	checkmate::assert_class(shiny::isolate(data()), "teal_data")
268
269	!	moduleServer(id, function(input, output, session) {
270	!	output$axis_selections <- renderUI({
271	!	env <- shiny::isolate(as.list(data()@env))
272	!	resolved_x <- teal.transform::resolve_delayed(module_args$xaxis_var, env)
273	!	resolved_y <- teal.transform::resolve_delayed(module_args$yaxis_var, env)
274	!	resolved_param <- teal.transform::resolve_delayed(module_args$param, env)
275	!	templ_ui_params_vars(
276	!	session$ns,
277		# xparam and yparam are identical, so we only show the user one
278	!	xparam_choices = resolved_param$choices,
279	!	xparam_selected = resolved_param$selected,
280	!	xparam_label = "Select a Biomarker",
281	!	xchoices = resolved_x$choices,
282	!	xselected = resolved_x$selected,
283	!	ychoices = resolved_y$choices,
284	!	yselected = resolved_y$selected
285		)
286		})
287
288		# reused in all modules
289	!	anl_q_output <- constr_anl_q(
290	!	session, input, data, dataname,
291	!	param_id = "xaxis_param", param_var = param_var, trt_group = input$trt_group, min_rows = 1
292		)
293
294	!	anl_q <- anl_q_output()$value
295
296		# update sliders for axes taking constraints into account
297	!	xrange_slider <- toggle_slider_server("xrange_scale")
298	!	yrange_slider <- toggle_slider_server("yrange_scale")
299	!	keep_range_slider_updated(session, input, xrange_slider$update_state, "xaxis_var", "xaxis_param", anl_q)
300	!	keep_range_slider_updated(session, input, yrange_slider$update_state, "yaxis_var", "xaxis_param", anl_q)
301	!	keep_data_const_opts_updated(session, input, anl_q, "xaxis_param")
302
303		# plot
304	!	plot_q <- reactive({
305	!	req(anl_q())
306		# nolint start
307	!	xlim <- xrange_slider$state()$value
308	!	ylim <- yrange_slider$state()$value
309	!	facet_ncol <- input$facet_ncol
310	!	validate(need(
311	!	is.na(facet_ncol) \|\| (as.numeric(facet_ncol) > 0 && as.numeric(facet_ncol) %% 1 == 0),
312	!	"Number of plots per row must be a positive integer"
313		))
314	!	reg_line <- input$reg_line
315	!	font_size <- input$font_size
316	!	dot_size <- input$dot_size
317	!	reg_text_size <- input$reg_text_size
318	!	rotate_xlab <- input$rotate_xlab
319	!	hline <- input$hline
320	!	vline <- input$vline
321	!	trt_group <- input$trt_group
322	!	facet <- input$trt_facet
323	!	validate(need(trt_group, "Please select a treatment variable"))
324
325		# Below inputs should trigger plot via updates of other reactive objects (i.e. anl_q()) and some inputs
326	!	validate(need(input$xaxis_var, "Please select an X-Axis Variable"))
327	!	validate(need(input$yaxis_var, "Please select a Y-Axis Variable"))
328	!	param <- input$xaxis_param
329	!	xaxis <- input$xaxis_var
330	!	yaxis <- input$yaxis_var
331
332		# nolint end
333	!	teal.code::eval_code(
334	!	object = anl_q()$qenv,
335	!	code = bquote({
336		# re-establish treatment variable label
337	!	p <- goshawk::g_scatterplot(
338	!	data = ANL,
339	!	param_var = .(param_var),
340	!	param = .(param),
341	!	xaxis_var = .(xaxis),
342	!	yaxis_var = .(yaxis),
343	!	trt_group = .(trt_group),
344	!	xlim = .(xlim),
345	!	ylim = .(ylim),
346	!	color_manual = .(color_manual),
347	!	shape_manual = .(shape_manual),
348	!	facet_ncol = .(facet_ncol),
349	!	facet = .(facet),
350	!	facet_var = .(trt_group),
351	!	reg_line = .(reg_line),
352	!	font_size = .(font_size),
353	!	dot_size = .(dot_size),
354	!	reg_text_size = .(reg_text_size),
355	!	rotate_xlab = .(rotate_xlab),
356	!	hline = .(`if`(is.na(hline), NULL, as.numeric(hline))),
357	!	vline = .(`if`(is.na(vline), NULL, as.numeric(vline)))
358		)
359	!	print(p)
360		})
361		)
362		})
363
364	!	plot_r <- reactive(plot_q()[["p"]])
365
366	!	plot_data <- teal.widgets::plot_with_settings_srv(
367	!	id = "plot",
368	!	plot_r = plot_r,
369	!	height = plot_height,
370	!	width = plot_width,
371	!	brushing = TRUE
372		)
373
374		### REPORTER
375	!	if (with_reporter) {
376	!	card_fun <- function(comment, label) {
377	!	constraint_description <- paste(
378	!	"\nTreatment Variable Faceting:",
379	!	input$trt_facet,
380	!	"\nRegression Line:",
381	!	input$reg_line
382		)
383	!	card <- report_card_template_goshawk(
384	!	title = "Scatter Plot",
385	!	label = label,
386	!	with_filter = with_filter,
387	!	filter_panel_api = filter_panel_api,
388	!	constraint_list = list(
389	!	constraint_var = input$constraint_var,
390	!	constraint_range_min = input$constraint_range_min,
391	!	constraint_range_max = input$constraint_range_max
392		),
393	!	constraint_description = constraint_description,
394	!	style = "verbatim"
395		)
396	!	card$append_text("Scatter Plot", "header3")
397	!	card$append_plot(plot_r(), dim = plot_data$dim())
398	!	if (!comment == "") {
399	!	card$append_text("Comment", "header3")
400	!	card$append_text(comment)
401		}
402	!	card$append_src(teal.code::get_code(plot_q()))
403	!	card
404		}
405	!	teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
406		}
407		###
408
409		# highlight plot area
410	!	output$brush_data <- DT::renderDataTable({
411	!	plot_brush <- plot_data$brush()
412
413	!	ANL <- isolate(anl_q()$ANL) # nolint
414	!	validate_has_data(ANL, 1)
415
416	!	xvar <- isolate(input$xaxis_var)
417	!	yvar <- isolate(input$yaxis_var)
418	!	trt_group <- isolate(input$trt_group)
419
420	!	req(all(c(xvar, yvar) %in% names(ANL)))
421
422	!	df <- teal.widgets::clean_brushedPoints(
423	!	dplyr::select(
424	!	ANL, "USUBJID", dplyr::all_of(trt_group), "AVISITCD", "PARAMCD",
425	!	dplyr::all_of(c(xvar, yvar)), "LOQFL"
426		),
427	!	plot_brush
428		)
429
430	!	numeric_cols <- names(dplyr::select_if(df, is.numeric))
431
432	!	DT::datatable(df, rownames = FALSE, options = list(scrollX = TRUE)) %>%
433	!	DT::formatRound(numeric_cols, 4)
434		})
435
436	!	teal.widgets::verbatim_popup_srv(
437	!	id = "rcode",
438	!	verbatim_content = reactive(teal.code::get_code(plot_q())),
439	!	title = "Show R Code for Scatterplot"
440		)
441		})
442		}

1		templ_ui_constraint <- function(ns, label = "Data Constraint") {
2	!	tags$div(
3	!	id = ns("constraint_var_whole"), # give an id to hide it
4	!	radioButtons(ns("constraint_var"), label, choices = "NONE"),
5	!	shinyjs::hidden(tags$div(
6	!	id = ns("constraint_range"),
7	!	tags$div(
8	!	class = "inline-block;",
9	!	numericInput(ns("constraint_range_min"), label = "Min", value = 0, min = 0, max = 0)
10		),
11	!	tags$div(
12	!	class = "inline-block;",
13	!	numericInput(ns("constraint_range_max"), label = "Min", value = 0, min = 0, max = 0)
14		)
15		)),
16	!	shinyjs::hidden(tags$div(
17	!	id = ns("all_na"),
18	!	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	!	choices <- reactiveVal()
26	!	observeEvent(data(), {
27	!	paramname <- input[[id_param_var]]
28	!	req(length(paramname) == 1)
29
30	!	data_filtered <- data()$ANL %>% dplyr::filter(.data$PARAMCD == paramname)
31	!	choices(c("None" = "NONE", "Screening" = "BASE2", "Baseline" = "BASE")[
32	!	c(TRUE, !all(is.na(data_filtered[["BASE2"]])), !all(is.na(data_filtered[["BASE"]])))
33		])
34		})
35	!	observeEvent(choices(), {
36	!	updateRadioButtons(session, "constraint_var", choices = choices())
37		# hide when only one option "NONE"
38	!	if (length(choices()) == 1) {
39	!	shinyjs::hide("constraint_var_whole")
40		} else {
41	!	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	!	checkmate::assert_class(data, "reactive")
53	!	checkmate::assert_class(shiny::isolate(data()), "teal_data")
54	!	dataset_var <- dataname
55	!	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	!	anl_param <- reactive({
61	!	param_var_value <- input[[param_id]] # value to filter PARAMCD for
62	!	validate(need(param_var_value, "Please select a biomarker"))
63	!	checkmate::assert_string(param_var_value)
64
65	!	ANL <- data()[[dataname]] # nolint
66	!	validate_has_data(ANL, min_rows)
67
68	!	validate_has_variable(ANL, param_var)
69	!	validate_has_variable(ANL, "AVISITCD")
70	!	validate_has_variable(ANL, "BASE")
71	!	validate_has_variable(ANL, "BASE2")
72	!	validate_has_variable(ANL, trt_group)
73
74		# analysis
75	!	private_qenv <- data() %>%
76	!	teal.code::eval_code(
77	!	substitute(ANL <- dataname, list(dataname = as.name(dataname))) # nolint
78		) %>%
79	!	teal.code::eval_code(
80	!	code = bquote({
81	!	ANL <- .(as.name(dataset_var)) %>% # nolint
82	!	dplyr::filter(.(as.name(param_var)) == .(param_var_value))
83		})
84		)
85	!	validate_has_data(private_qenv[["ANL"]], min_rows)
86	!	list(ANL = ANL, qenv = private_qenv)
87		})
88
89	!	observe({
90	!	param_var_value <- input[[param_id]]
91	!	validate(need(param_var_value, "Please select a biomarker"))
92
93	!	constraint_var <- input[["constraint_var"]]
94	!	validate(need(constraint_var, "select a constraint variable"))
95
96	!	ANL <- data()[[dataname]] # nolint
97	!	validate_has_data(ANL, min_rows)
98
99	!	validate_has_variable(ANL, param_var)
100	!	validate_has_variable(ANL, "AVISITCD")
101	!	validate_has_variable(ANL, "BASE")
102	!	validate_has_variable(ANL, "BASE2")
103
104	!	ANL <- ANL %>% dplyr::filter(!!sym(param_var) == param_var_value) # nolint
105
106	!	visit_freq <- unique(ANL$AVISITCD)
107
108		# get min max values
109	!	if ((constraint_var == "BASE2" && any(grepl("SCR", visit_freq))) \|\|
110	!	(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	!	} else if (constraint_var == "NONE") {
143	!	shinyjs::hide("constraint_range") # hide before update
144	!	shinyjs::hide("all_na")
145
146		# force update (and thus refresh) on different constraint_var -> pass unique value for each constraint_var name
147	!	args <- list(
148	!	min = list(label = "Min", min = 0, max = 0, value = 0),
149	!	max = list(label = "Max", min = 0, max = 0, value = 0)
150		)
151
152	!	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	!	anl_constraint <- create_anl_constraint_reactive(anl_param, input, param_id = param_id, min_rows = min_rows)
159
160	!	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	!	iv_r <- reactive({
170	!	iv <- shinyvalidate::InputValidator$new()
171	!	iv$condition(~ isTRUE(input$constraint_var != "NONE"))
172	!	iv$add_rule("constraint_range_min", shinyvalidate::sv_required("A contraint minimum value is required"))
173	!	iv$add_rule("constraint_range_max", shinyvalidate::sv_required("A contraint maximum value is required"))
174	!	iv$add_rule(
175	!	"constraint_range_min",
176	!	~ if (!is.na(input$constraint_range_max) && (.) > input$constraint_range_max) {
177	!	"constraint min needs to be less than max"
178		}
179		)
180	!	iv$add_rule(
181	!	"constraint_range_max",
182	!	~ if (!is.na(input$constraint_range_min) && (.) < input$constraint_range_min) {
183	!	"constraint min needs to be less than max"
184		}
185		)
186	!	iv
187		})
188
189
190	!	return_val <- reactive({
191	!	private_qenv <- anl_param()$qenv
192
193		# it is assumed that constraint_var is triggering constraint_range which then trigger this clause
194	!	constraint_var <- isolate(input[["constraint_var"]])
195	!	constraint_range_min <- input[["constraint_range_min"]]
196	!	constraint_range_max <- input[["constraint_range_max"]]
197	!	param <- input[[param_id]]
198	!	req(param)
199
200		# filter constraint
201	!	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	!	list(ANL = private_qenv[["ANL"]], qenv = private_qenv)
231		})
232
233	!	reactive(
234	!	list(
235	!	value = return_val,
236	!	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	!	do.call("updateNumericInput", c(list(session = session, inputId = "constraint_range_min"), args$min))
257	!	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	!	msg <- "Number of plots per row must be a positive integer"
24	!	shinyvalidate::compose_rules(
25	!	if (required) {
26	!	shinyvalidate::sv_required(msg)
27		} else {
28	!	shinyvalidate::sv_optional()
29		},
30	!	shinyvalidate::sv_integer(msg),
31	!	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	!	trt_group = trt_group,
167	!	color_manual = color_manual,
168	!	color_comb = color_comb,
169	!	plot_height = plot_height,
170	!	plot_width = plot_width,
171	!	module_args = args
172		),
173	!	ui = ui_g_density_distribution_plot,
174	!	ui_args = args
175		)
176		}
177
178		ui_g_density_distribution_plot <- function(id, ...) {
179	!	ns <- NS(id)
180	!	a <- list(...)
181
182	!	teal.widgets::standard_layout(
183	!	output = tags$div(
184	!	fluidRow(
185	!	teal.widgets::plot_with_settings_ui(id = ns("plot"))
186		),
187	!	fluidRow(column(
188	!	width = 12,
189	!	tags$br(), tags$hr(),
190	!	tags$h4("Descriptive Statistics"),
191	!	DT::dataTableOutput(ns("table_ui"))
192		))
193		),
194	!	encoding = tags$div(
195		### Reporter
196	!	teal.reporter::simple_reporter_ui(ns("simple_reporter")),
197		###
198	!	templ_ui_dataname(a$dataname),
199	!	teal.widgets::optionalSelectInput(
200	!	ns("trt_group"),
201	!	label = "Select Treatment Variable",
202	!	choices = get_choices(a$trt_group$choices),
203	!	selected = a$trt_group$selected,
204	!	multiple = FALSE
205		),
206	!	uiOutput(ns("axis_selections")),
207	!	templ_ui_constraint(ns, label = "Data Constraint"),
208	!	ui_arbitrary_lines(id = ns("hline_arb"), a$hline_arb, a$hline_arb_label, a$hline_arb_color),
209	!	teal.widgets::panel_group(
210	!	teal.widgets::panel_item(
211	!	title = "Plot Aesthetic Settings",
212	!	toggle_slider_ui(
213	!	ns("xrange_scale"),
214	!	label = "X-Axis Range Zoom",
215	!	min = -1000000,
216	!	max = 1000000,
217	!	value = c(-1000000, 1000000)
218		),
219	!	toggle_slider_ui(
220	!	ns("yrange_scale"),
221	!	label = "Y-Axis Range Zoom",
222	!	min = -1000000,
223	!	max = 1000000,
224	!	value = c(-1000000, 1000000)
225		),
226	!	numericInput(ns("facet_ncol"), "Number of Plots Per Row:", a$facet_ncol, min = 1),
227	!	checkboxInput(ns("comb_line"), "Display Combined line", a$comb_line),
228	!	checkboxInput(ns("rug_plot"), "Include rug plot", value = FALSE),
229	!	checkboxInput(ns("rotate_xlab"), "Rotate X-axis Label", a$rotate_xlab)
230		),
231	!	teal.widgets::panel_item(
232	!	title = "Plot settings",
233	!	teal.widgets::optionalSliderInputValMinMax(ns("font_size"), "Font Size", a$font_size, ticks = FALSE),
234	!	teal.widgets::optionalSliderInputValMinMax(
235	!	ns("line_size"),
236	!	"Line Size",
237	!	value_min_max = a$line_size,
238	!	step = .25,
239	!	ticks = FALSE
240		)
241		)
242		)
243		),
244	!	forms = tagList(
245	!	teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
246		),
247	!	pre_output = a$pre_output,
248	!	post_output = a$post_output
249		)
250		}
251
252		srv_g_density_distribution_plot <- function(id, # nolint
253		data,
254		reporter,
255		filter_panel_api,
256		dataname,
257		param_var,
258		param,
259		trt_group,
260		color_manual,
261		color_comb,
262		plot_height,
263		plot_width,
264		module_args) {
265	!	with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
266	!	with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
267	!	checkmate::assert_class(data, "reactive")
268	!	checkmate::assert_class(shiny::isolate(data()), "teal_data")
269
270	!	moduleServer(id, function(input, output, session) {
271	!	output$axis_selections <- renderUI({
272	!	env <- shiny::isolate(as.list(data()@env))
273	!	resolved_x <- teal.transform::resolve_delayed(module_args$xaxis_var, env)
274	!	resolved_param <- teal.transform::resolve_delayed(module_args$param, env)
275	!	templ_ui_params_vars(
276	!	session$ns,
277	!	xparam_choices = resolved_param$choices,
278	!	xparam_selected = resolved_param$selected,
279	!	xparam_label = "Select a Biomarker",
280	!	xchoices = resolved_x$choices,
281	!	xselected = resolved_x$selected
282		)
283		})
284
285	!	anl_q_output <- constr_anl_q(
286	!	session, input, data, dataname,
287	!	param_id = "xaxis_param", param_var = param_var, trt_group = input$trt_group, min_rows = 2
288		)
289
290	!	anl_q <- anl_q_output()$value
291
292		# update sliders for axes taking constraints into account
293	!	xrange_slider <- toggle_slider_server("xrange_scale")
294	!	yrange_slider <- toggle_slider_server("yrange_scale")
295	!	keep_range_slider_updated(session, input, xrange_slider$update_state, "xaxis_var", "xaxis_param", anl_q)
296	!	keep_range_slider_updated(
297	!	session,
298	!	input,
299	!	yrange_slider$update_state,
300	!	"xaxis_var",
301	!	"xaxis_param",
302	!	anl_q,
303	!	is_density = TRUE
304		)
305	!	keep_data_const_opts_updated(session, input, anl_q, "xaxis_param")
306
307	!	horizontal_line <- srv_arbitrary_lines("hline_arb")
308
309	!	iv_r <- reactive({
310	!	iv <- shinyvalidate::InputValidator$new()
311
312	!	iv$add_rule("xaxis_param", shinyvalidate::sv_required("Please select a biomarker"))
313	!	iv$add_rule("trt_group", shinyvalidate::sv_required("Please select a treatment variable"))
314	!	iv$add_rule("xaxis_var", shinyvalidate::sv_required("Please select an X-Axis variable"))
315	!	iv$add_rule("facet_ncol", plots_per_row_validate_rules())
316
317	!	iv$add_validator(horizontal_line()$iv_r())
318	!	iv$add_validator(anl_q_output()$iv_r())
319	!	iv$enable()
320	!	iv
321		})
322
323
324	!	create_plot <- reactive({
325	!	teal::validate_inputs(iv_r())
326	!	req(anl_q())
327
328		# nolint start
329	!	param <- input$xaxis_param
330	!	xaxis_var <- input$xaxis_var
331	!	xlim <- xrange_slider$state()$value
332	!	ylim <- yrange_slider$state()$value
333	!	font_size <- input$font_size
334	!	line_size <- input$line_size
335	!	hline_arb <- horizontal_line()$line_arb
336	!	hline_arb_label <- horizontal_line()$line_arb_label
337	!	hline_arb_color <- horizontal_line()$line_arb_color
338	!	facet_ncol <- input$facet_ncol
339
340	!	comb_line <- input$comb_line
341	!	rug_plot <- input$rug_plot
342	!	rotate_xlab <- input$rotate_xlab
343	!	trt_group <- input$trt_group
344		# nolint end
345
346
347	!	teal.code::eval_code(
348	!	object = anl_q()$qenv,
349	!	code = bquote({
350	!	p <- goshawk::g_density_distribution_plot(
351	!	data = ANL,
352	!	param_var = .(param_var),
353	!	param = .(param),
354	!	xaxis_var = .(xaxis_var),
355	!	trt_group = .(trt_group),
356	!	xlim = .(xlim),
357	!	ylim = .(ylim),
358	!	color_manual = .(color_manual),
359	!	color_comb = .(color_comb),
360	!	font_size = .(font_size),
361	!	line_size = .(line_size),
362	!	facet_ncol = .(facet_ncol),
363	!	comb_line = .(comb_line),
364	!	hline_arb = .(hline_arb),
365	!	hline_arb_label = .(hline_arb_label),
366	!	hline_arb_color = .(hline_arb_color),
367	!	rug_plot = .(rug_plot)
368		)
369		})
370		)
371		})
372
373	!	create_table <- reactive({
374	!	req(iv_r()$is_valid())
375	!	req(anl_q())
376	!	param <- input$xaxis_param
377	!	xaxis_var <- input$xaxis_var
378	!	font_size <- input$font_size
379	!	trt_group <- input$trt_group
380
381	!	teal.code::eval_code(
382	!	object = anl_q()$qenv,
383	!	code = bquote(
384	!	tbl <- goshawk::t_summarytable(
385	!	data = ANL,
386	!	trt_group = .(trt_group),
387	!	param_var = .(param_var),
388	!	param = .(param),
389	!	xaxis_var = .(xaxis_var),
390	!	font_size = .(font_size)
391		)
392		)
393		)
394		})
395
396	!	plot_r <- reactive({
397	!	create_plot()[["p"]]
398		})
399
400	!	plot_data <- teal.widgets::plot_with_settings_srv(
401	!	id = "plot",
402	!	plot_r = plot_r,
403	!	height = plot_height,
404	!	width = plot_width,
405		)
406
407	!	output$table_ui <- DT::renderDataTable({
408	!	req(create_table())
409	!	tbl <- create_table()[["tbl"]]
410	!	numeric_cols <- names(dplyr::select_if(tbl, is.numeric))
411
412	!	DT::datatable(tbl, rownames = FALSE, options = list(scrollX = TRUE)) %>%
413	!	DT::formatRound(numeric_cols, 2)
414		})
415
416	!	joined_qenvs <- reactive({
417	!	req(create_plot(), create_table())
418	!	teal.code::join(create_plot(), create_table())
419		})
420
421	!	teal.widgets::verbatim_popup_srv(
422	!	id = "rcode",
423	!	verbatim_content = reactive(
424	!	teal.code::get_code(joined_qenvs())
425		),
426	!	title = "Show R Code for Density Distribution Plot"
427		)
428
429		### REPORTER
430	!	if (with_reporter) {
431	!	card_fun <- function(comment, label) {
432	!	card <- report_card_template_goshawk(
433	!	title = "Density Distribution Plot",
434	!	label = label,
435	!	with_filter = with_filter,
436	!	filter_panel_api = filter_panel_api,
437	!	constraint_list = list(
438	!	constraint_var = input$constraint_var,
439	!	constraint_range_min = input$constraint_range_min,
440	!	constraint_range_max = input$constraint_range_max
441		)
442		)
443	!	card$append_text("Plot", "header3")
444	!	card$append_plot(plot_r(), dim = plot_data$dim())
445	!	card$append_text("Descriptive Statistics", "header3")
446	!	card$append_table(
447	!	create_table()[["tbl"]] %>% dplyr::mutate_if(is.numeric, round, 2)
448		)
449	!	if (!comment == "") {
450	!	card$append_text("Comment", "header3")
451	!	card$append_text(comment)
452		}
453	!	card$append_src(
454	!	teal.code::get_code(
455	!	teal.code::join(create_plot(), create_table())
456		)
457		)
458	!	card
459		}
460	!	teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
461		}
462		###
463		})
464		}

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	!	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		multiple = FALSE) {
31	!	if (is.null(xparam_choices) && !is.null(xchoices) && !is.null(yparam_choices)) {
32		# otherwise, xchoices will appear first without any biomarker to select and this looks odd in the UI
33	!	stop(
34	!	"You have to specify xparam choices rather than yparamchoices
35	!	if both xvar and yvar should be values for the same biomarker."
36		)
37		}
38	!	tagList(
39	!	if (!is.null(xparam_choices)) {
40	!	teal.widgets::optionalSelectInput(
41	!	ns("xaxis_param"),
42	!	`if`(is.null(xparam_label), "Select an X-Axis Biomarker", xparam_label),
43	!	xparam_choices,
44	!	`if`(is.null(xparam_selected), xparam_choices[1], xparam_selected),
45	!	multiple = FALSE
46		)
47		},
48	!	if (!is.null(xchoices)) {
49	!	teal.widgets::optionalSelectInput(
50	!	ns("xaxis_var"),
51	!	`if`(is.null(xvar_label), "Select an X-Axis Variable", xvar_label),
52	!	xchoices, xselected,
53	!	multiple = multiple
54		)
55		},
56	!	if (!is.null(yparam_choices)) {
57	!	teal.widgets::optionalSelectInput(
58	!	ns("yaxis_param"),
59	!	`if`(is.null(yparam_label), "Select an Y-Axis Biomarker", yparam_label),
60	!	yparam_choices,
61	!	`if`(is.null(yparam_selected), yparam_choices[1], yparam_selected),
62	!	multiple = FALSE
63		)
64		},
65	!	if (!is.null(ychoices)) {
66	!	teal.widgets::optionalSelectInput(
67	!	ns("yaxis_var"),
68	!	`if`(is.null(yvar_label), "Select a Y-Axis Variable", yvar_label),
69	!	ychoices, yselected,
70	!	multiple = multiple
71		)
72		}
73		)
74		}

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		}

1		keep_range_slider_updated <- function(session,
2		input,
3		update_slider_fcn,
4		id_var,
5		id_param_var,
6		reactive_ANL, # nolint
7		is_density = FALSE) {
8	!	stopifnot(is.function(update_slider_fcn))
9
10	!	observe({
11	!	varname <- input[[id_var]]
12	!	validate(need(varname, "Please select variable"))
13	!	paramname <- input[[id_param_var]]
14	!	validate(need(paramname, "Please select variable"))
15	!	req(length(paramname) == 1)
16
17		# we need id_param_var (e.g. ALT) to filter down because the y-axis may have a different
18		# param var and the range of id_var (e.g. BASE) values may be larger due to this
19		# therefore, we need to filter
20	!	ANL <- reactive_ANL()$ANL %>% dplyr::filter(.data$PARAMCD == paramname) # nolint
21	!	validate_has_variable(ANL, varname, paste("variable", varname, "does not exist"))
22
23	!	var <- stats::na.omit(ANL[[varname]])
24	!	minmax <- if (length(var)) c(floor(min(var)), ceiling(max(var))) else c(0, 0)
25	!	step <- NULL
26
27	!	if (isTRUE(is_density)) {
28	!	minmax <- c(0, round(max(stats::density(stats::na.omit(ANL[[varname]]))$y) * 1.5, 5))
29	!	step <- round(max(stats::density(stats::na.omit(ANL[[varname]]))$y) / 100, 5)
30		}
31
32	!	isolate(update_slider_fcn(
33	!	min = minmax[[1]],
34	!	max = minmax[[2]],
35	!	value = minmax,
36	!	step = step
37		))
38		})
39		}