teal.goshawk coverage - 25.03%

Files
Source

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

#' 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
#' @inheritParams teal::module
#' @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"]]
#' })
#'
#' join_keys(data) <- default_cdisc_join_keys[names(data)]
#'
#'
#' 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,
                                transformators = list()) {
  lifecycle::deprecate_soft(
    when = "0.1.15",
    what = "tm_g_gh_scatterplot()",
    details = "You should use teal.goshawk::tm_g_gh_correlationplot instead of teal.goshawk::tm_g_gh_scatterplot"
  )

  message("Initializing tm_g_gh_scatterplot")
  checkmate::assert_class(param, "choices_selected")
  checkmate::assert_class(xaxis_var, "choices_selected")
  checkmate::assert_class(yaxis_var, "choices_selected")
  checkmate::assert_class(trt_group, "choices_selected")
  checkmate::assert_flag(trt_facet)
  checkmate::assert_flag(reg_line)
  checkmate::assert_flag(rotate_xlab)
  checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
  checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")
  checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
  checkmate::assert_numeric(
    plot_width[1],
    lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"
  )

  args <- as.list(environment())

  module(
    label = label,
    datanames = dataname,
    server = srv_g_scatterplot,
    server_args = list(
      dataname = dataname,
      param_var = param_var,
      trt_facet = trt_facet,
      color_manual = color_manual,
      shape_manual = shape_manual,
      plot_height = plot_height,
      plot_width = plot_width,
      module_args = args
    ),
    ui = ui_g_scatterplot,
    ui_args = args,
    transformators = transformators
  )
}

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

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

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

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

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

    anl_q <- anl_q_output()$value

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

#' 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
#' @inheritParams teal::module
#'
#' @author Jeff Tomlinson (tomlinsj) jeffrey.tomlinson@roche.com
#' @author Balazs Toth (tothb2) toth.balazs@gene.com
#'
#' @return an \code{\link[teal]{module}} object
#'
#' @export
#'
#' @examplesIf require("nestcolor")
#' # Example using ADaM structure analysis dataset.
#' data <- teal_data()
#' data <- within(data, {
#'   library(dplyr)
#'   library(nestcolor)
#'   library(stringr)
#'
#'   # use non-exported function from goshawk
#'   .h_identify_loq_values <- getFromNamespace("h_identify_loq_values", "goshawk")
#'
#'   # original ARM value = dose value
#'   .arm_mapping <- list(
#'     "A: Drug X" = "150mg QD",
#'     "B: Placebo" = "Placebo",
#'     "C: Combination" = "Combination"
#'   )
#'   set.seed(1)
#'   ADSL <- rADSL
#'   ADLB <- rADLB
#'   .var_labels <- lapply(ADLB, function(x) attributes(x)$label)
#'   ADLB <- ADLB %>%
#'     mutate(
#'       AVISITCD = case_when(
#'         AVISIT == "SCREENING" ~ "SCR",
#'         AVISIT == "BASELINE" ~ "BL",
#'         grepl("WEEK", AVISIT) ~ paste("W", str_extract(AVISIT, "(?<=(WEEK ))[0-9]+")),
#'         TRUE ~ as.character(NA)
#'       ),
#'       AVISITCDN = case_when(
#'         AVISITCD == "SCR" ~ -2,
#'         AVISITCD == "BL" ~ 0,
#'         grepl("W", AVISITCD) ~ as.numeric(gsub("[^0-9]*", "", AVISITCD)),
#'         TRUE ~ as.numeric(NA)
#'       ),
#'       AVISITCD = factor(AVISITCD) %>% reorder(AVISITCDN),
#'       TRTORD = case_when(
#'         ARMCD == "ARM C" ~ 1,
#'         ARMCD == "ARM B" ~ 2,
#'         ARMCD == "ARM A" ~ 3
#'       ),
#'       ARM = as.character(.arm_mapping[match(ARM, names(.arm_mapping))]),
#'       ARM = factor(ARM) %>% reorder(TRTORD),
#'       ACTARM = as.character(.arm_mapping[match(ACTARM, names(.arm_mapping))]),
#'       ACTARM = factor(ACTARM) %>% reorder(TRTORD),
#'       ANRLO = 50,
#'       ANRHI = 75
#'     ) %>%
#'     rowwise() %>%
#'     group_by(PARAMCD) %>%
#'     mutate(LBSTRESC = ifelse(
#'       USUBJID %in% sample(USUBJID, 1, replace = TRUE),
#'       paste("<", round(runif(1, min = 25, max = 30))), LBSTRESC
#'     )) %>%
#'     mutate(LBSTRESC = ifelse(
#'       USUBJID %in% sample(USUBJID, 1, replace = TRUE),
#'       paste(">", round(runif(1, min = 70, max = 75))), LBSTRESC
#'     )) %>%
#'     ungroup()
#'
#'   attr(ADLB[["ARM"]], "label") <- .var_labels[["ARM"]]
#'   attr(ADLB[["ACTARM"]], "label") <- .var_labels[["ACTARM"]]
#'   attr(ADLB[["ANRLO"]], "label") <- "Analysis Normal Range Lower Limit"
#'   attr(ADLB[["ANRHI"]], "label") <- "Analysis Normal Range Upper Limit"
#'
#'   # add LLOQ and ULOQ variables
#'   ALB_LOQS <- .h_identify_loq_values(ADLB, "LOQFL")
#'   ADLB <- left_join(ADLB, ALB_LOQS, by = "PARAM")
#' })
#'
#' join_keys(data) <- default_cdisc_join_keys[names(data)]
#'
#' 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,
                            transformators = list()) {
  message("Initializing tm_g_gh_boxplot")
  checkmate::assert_string(label)
  checkmate::assert_string(dataname)
  checkmate::assert_string(param_var)
  checkmate::assert_class(param, "choices_selected")
  checkmate::assert_class(yaxis_var, "choices_selected")
  checkmate::assert_class(xaxis_var, "choices_selected")
  checkmate::assert_class(facet_var, "choices_selected")
  checkmate::assert_class(trt_group, "choices_selected")
  checkmate::assert_int(facet_ncol, null.ok = TRUE)
  checkmate::assert_flag(loq_legend)
  checkmate::assert_flag(rotate_xlab)
  checkmate::assert_numeric(font_size, len = 3)
  checkmate::assert_numeric(dot_size, len = 3)
  checkmate::assert_numeric(alpha, len = 3)
  validate_line_arb_arg(hline_arb, hline_arb_color, hline_arb_label)
  validate_line_vars_arg(hline_vars, hline_vars_colors, hline_vars_labels)
  checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
  checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")
  checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
  checkmate::assert_numeric(
    plot_width[1],
    lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"
  )

  args <- as.list(environment())

  module(
    label = label,
    datanames = dataname,
    server = srv_g_boxplot,
    server_args = list(
      dataname = dataname,
      param_var = param_var,
      color_manual = color_manual,
      shape_manual = shape_manual,
      plot_height = plot_height,
      plot_width = plot_width,
      hline_vars_colors = hline_vars_colors,
      hline_vars_labels = hline_vars_labels,
      module_args = args
    ),
    ui = ui_g_boxplot,
    ui_args = args,
    transformators = transformators
  )
}

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

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


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

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

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

    anl_q <- anl_q_output()$value

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

    horizontal_line <- srv_arbitrary_lines("hline_arb")

    trt_group <- reactive({
      input$trt_group
    })

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    joined_qenvs <- reactive({
      req(create_plot(), create_table())
      c(create_plot(), create_table())
    })

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

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

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

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

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

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

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

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

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

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

#' Scatter Plot Teal Module For Biomarker Analysis
#'
#' @description Scatter Plot Teal Module For Biomarker Analysis
#'
#' @inheritParams teal.widgets::standard_layout
#' @inheritParams teal::module
#' @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")
#' })
#'
#' join_keys(data) <- default_cdisc_join_keys[names(data)]
#'
#' 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,
                                    transformators = list()) {
  message("Initializing tm_g_gh_correlationplot")
  checkmate::assert_class(xaxis_param, "choices_selected")
  checkmate::assert_class(yaxis_param, "choices_selected")
  checkmate::assert_class(xaxis_var, "choices_selected")
  checkmate::assert_class(yaxis_var, "choices_selected")
  checkmate::assert_class(trt_group, "choices_selected")
  checkmate::assert_flag(trt_facet)
  validate_line_arb_arg(hline_arb, hline_arb_color, hline_arb_label)
  validate_line_arb_arg(vline_arb, vline_arb_color, vline_arb_label)
  validate_line_vars_arg(hline_vars, hline_vars_colors, hline_vars_labels)
  validate_line_vars_arg(vline_vars, vline_vars_colors, vline_vars_labels)
  checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
  checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")
  checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
  checkmate::assert_numeric(
    plot_width[1],
    lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"
  )
  checkmate::assert_numeric(font_size, len = 3)
  checkmate::assert_numeric(dot_size, len = 3)
  checkmate::assert_numeric(reg_text_size, len = 3)

  args <- as.list(environment())

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

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

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

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

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

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

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

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



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

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

      validate_has_variable(ANL, param_var)

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

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

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

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

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

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

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

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

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

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

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

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

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

    # constraints
    observe({
      req(input$xaxis_param)

      constraint_var <- input$constraint_var
      req(constraint_var)

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

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

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

      visit_freq <- unique(ANL$AVISITCD)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

#' 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
#' @inheritParams teal::module
#'
#'
#' @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"]]
#' })
#'
#' join_keys(data) <- default_cdisc_join_keys[names(data)]
#'
#' 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,
                                              transformators = list()) {
  message("Initializing tm_g_gh_density_distribution_plot")
  checkmate::assert_string(label)
  checkmate::assert_string(dataname)
  checkmate::assert_string(param_var)
  checkmate::assert_class(param, "choices_selected")
  checkmate::assert_class(xaxis_var, "choices_selected")
  checkmate::assert_class(trt_group, "choices_selected")
  checkmate::assert_numeric(font_size, len = 3)
  checkmate::assert_numeric(line_size, len = 3)
  checkmate::assert_int(facet_ncol)
  checkmate::assert_flag(comb_line)
  checkmate::assert_flag(rotate_xlab)
  validate_line_arb_arg(hline_arb, hline_arb_color, hline_arb_label)
  checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
  checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")
  checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
  checkmate::assert_numeric(
    plot_width[1],
    lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"
  )

  args <- as.list(environment())

  module(
    label = label,
    datanames = dataname,
    server = srv_g_density_distribution_plot,
    server_args = list(
      dataname = dataname,
      param_var = param_var,
      param = param,
      color_manual = color_manual,
      color_comb = color_comb,
      plot_height = plot_height,
      plot_width = plot_width,
      module_args = args
    ),
    ui = ui_g_density_distribution_plot,
    ui_args = args,
    transformators = transformators
  )
}

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

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

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

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

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

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

    anl_q <- anl_q_output()$value

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

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

    horizontal_line <- srv_arbitrary_lines("hline_arb")

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

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

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


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

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

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


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

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

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

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

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

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

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

    joined_qenvs <- reactive({
      req(create_plot(), create_table())
      c(create_plot(), create_table())
    })

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

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

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

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

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

  # Validate flag inputs
  checkmate::assert_flag(rotate_xlab)

  # Validate numeric vector inputs
  checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
  checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")
  checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
  checkmate::assert_numeric(
    plot_width[1],
    lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"
  )
  checkmate::assert_numeric(table_font_size, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
  checkmate::assert_numeric(dot_size, len = 3)
  checkmate::assert_numeric(
    table_font_size[1],
    lower = table_font_size[2], upper = table_font_size[3],
    null.ok = TRUE, .var.name = "table_font_size"
  )
  checkmate::assert_number(plot_relative_height_value, lower = 500, upper = 5000)
  checkmate::assert_number(count_threshold)

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

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

  args <- as.list(environment())

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

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

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

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

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

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

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

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

    anl_q <- anl_q_output()$value

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

    horizontal_line <- srv_arbitrary_lines("hline_arb")

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

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


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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

      private_qenv <- anl_q()$qenv

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

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

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

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

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

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

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

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

#' 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::module
#' @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")
#' })
#'
#' join_keys(data) <- default_cdisc_join_keys[names(data)]
#'
#' 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,
                                  transformators = list()) {
  message("Initializing tm_g_gh_spaghettiplot")

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

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

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

  # Validate numeric vector inputs
  checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
  checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")
  checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
  checkmate::assert_numeric(
    plot_width[1],
    lower = plot_width[2], upper = plot_width[3],
    null.ok = TRUE, .var.name = "plot_width"
  )
  checkmate::assert_numeric(font_size, len = 3, any.missing = FALSE, finite = TRUE)
  checkmate::assert_numeric(dot_size, len = 3, any.missing = FALSE, finite = TRUE)

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

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

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

  args <- as.list(environment())

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

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

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



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

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

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

    anl_q <- anl_q_output()$value

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

    horizontal_line <- srv_arbitrary_lines("hline_arb")

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

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

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


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

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

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

      private_qenv <- anl_q()$qenv

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


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

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

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

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

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

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

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

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

    return(state)
  })
}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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::module
50		#' @inheritParams teal.widgets::standard_layout
51		#'
52		#' @author Wenyi Liu (luiw2) wenyi.liu@roche.com
53		#' @author Balazs Toth (tothb2) toth.balazs@gene.com
54		#'
55		#' @return \code{shiny} object
56		#'
57		#' @export
58		#'
59		#' @examples
60		#' # Example using ADaM structure analysis dataset.
61		#' data <- teal_data()
62		#' data <- within(data, {
63		#' library(dplyr)
64		#' library(stringr)
65		#'
66		#' # use non-exported function from goshawk
67		#' .h_identify_loq_values <- getFromNamespace("h_identify_loq_values", "goshawk")
68		#'
69		#' # original ARM value = dose value
70		#' .arm_mapping <- list(
71		#' "A: Drug X" = "150mg QD",
72		#' "B: Placebo" = "Placebo",
73		#' "C: Combination" = "Combination"
74		#' )
75		#' set.seed(1)
76		#' ADSL <- rADSL
77		#' ADLB <- rADLB
78		#' .var_labels <- lapply(ADLB, function(x) attributes(x)$label)
79		#' ADLB <- ADLB %>%
80		#' mutate(
81		#' AVISITCD = case_when(
82		#' AVISIT == "SCREENING" ~ "SCR",
83		#' AVISIT == "BASELINE" ~ "BL",
84		#' grepl("WEEK", AVISIT) ~ paste("W", str_extract(AVISIT, "(?<=(WEEK ))[0-9]+")),
85		#' TRUE ~ as.character(NA)
86		#' ),
87		#' AVISITCDN = case_when(
88		#' AVISITCD == "SCR" ~ -2,
89		#' AVISITCD == "BL" ~ 0,
90		#' grepl("W", AVISITCD) ~ as.numeric(gsub("[^0-9]*", "", AVISITCD)),
91		#' TRUE ~ as.numeric(NA)
92		#' ),
93		#' AVISITCD = factor(AVISITCD) %>% reorder(AVISITCDN),
94		#' TRTORD = case_when(
95		#' ARMCD == "ARM C" ~ 1,
96		#' ARMCD == "ARM B" ~ 2,
97		#' ARMCD == "ARM A" ~ 3
98		#' ),
99		#' ARM = as.character(.arm_mapping[match(ARM, names(.arm_mapping))]),
100		#' ARM = factor(ARM) %>% reorder(TRTORD),
101		#' ACTARM = as.character(.arm_mapping[match(ACTARM, names(.arm_mapping))]),
102		#' ACTARM = factor(ACTARM) %>% reorder(TRTORD),
103		#' ANRLO = 30,
104		#' ANRHI = 75
105		#' ) %>%
106		#' rowwise() %>%
107		#' group_by(PARAMCD) %>%
108		#' mutate(LBSTRESC = ifelse(USUBJID %in% sample(USUBJID, 1, replace = TRUE),
109		#' paste("<", round(runif(1, min = 25, max = 30))), LBSTRESC
110		#' )) %>%
111		#' mutate(LBSTRESC = ifelse(USUBJID %in% sample(USUBJID, 1, replace = TRUE),
112		#' paste(">", round(runif(1, min = 70, max = 75))), LBSTRESC
113		#' )) %>%
114		#' ungroup()
115		#' attr(ADLB[["ARM"]], "label") <- .var_labels[["ARM"]]
116		#' attr(ADLB[["ACTARM"]], "label") <- .var_labels[["ACTARM"]]
117		#' attr(ADLB[["ANRLO"]], "label") <- "Analysis Normal Range Lower Limit"
118		#' attr(ADLB[["ANRHI"]], "label") <- "Analysis Normal Range Upper Limit"
119		#'
120		#' # add LLOQ and ULOQ variables
121		#' ALB_LOQS <- .h_identify_loq_values(ADLB, "LOQFL")
122		#' ADLB <- left_join(ADLB, ALB_LOQS, by = "PARAM")
123		#' })
124		#'
125		#' join_keys(data) <- default_cdisc_join_keys[names(data)]
126		#'
127		#' app <- init(
128		#' data = data,
129		#' modules = modules(
130		#' tm_g_gh_spaghettiplot(
131		#' label = "Spaghetti Plot",
132		#' dataname = "ADLB",
133		#' param_var = "PARAMCD",
134		#' param = choices_selected(c("ALT", "CRP", "IGA"), "ALT"),
135		#' idvar = "USUBJID",
136		#' xaxis_var = choices_selected(c("Analysis Visit Code" = "AVISITCD"), "AVISITCD"),
137		#' yaxis_var = choices_selected(c("AVAL", "CHG", "PCHG"), "AVAL"),
138		#' filter_var = choices_selected(
139		#' c("None" = "NONE", "Screening" = "BASE2", "Baseline" = "BASE"),
140		#' "NONE"
141		#' ),
142		#' trt_group = choices_selected(c("ARM", "ACTARM"), "ARM"),
143		#' color_comb = "#39ff14",
144		#' man_color = c(
145		#' "Combination" = "#000000",
146		#' "Placebo" = "#fce300",
147		#' "150mg QD" = "#5a2f5f"
148		#' ),
149		#' hline_arb = c(60, 50),
150		#' hline_arb_color = c("grey", "red"),
151		#' hline_arb_label = c("default A", "default B"),
152		#' hline_vars = c("ANRHI", "ANRLO", "ULOQN", "LLOQN"),
153		#' hline_vars_colors = c("pink", "brown", "purple", "black"),
154		#' )
155		#' )
156		#' )
157		#' if (interactive()) {
158		#' shinyApp(app$ui, app$server)
159		#' }
160		#'
161		tm_g_gh_spaghettiplot <- function(label,
162		dataname,
163		param_var,
164		param,
165		param_var_label = "PARAM",
166		idvar,
167		xaxis_var,
168		yaxis_var,
169		xaxis_var_level = NULL,
170		filter_var = yaxis_var,
171		trt_group,
172		trt_group_level = NULL,
173		group_stats = "NONE",
174		man_color = NULL,
175		color_comb = NULL,
176		xtick = ggplot2::waiver(),
177		xlabel = xtick,
178		rotate_xlab = FALSE,
179		facet_ncol = 2,
180		free_x = FALSE,
181		plot_height = c(600, 200, 2000),
182		plot_width = NULL,
183		font_size = c(12, 8, 20),
184		dot_size = c(2, 1, 12),
185		hline_arb = numeric(0),
186		hline_arb_color = "red",
187		hline_arb_label = "Horizontal line",
188		hline_vars = character(0),
189		hline_vars_colors = "green",
190		hline_vars_labels = hline_vars,
191		pre_output = NULL,
192		post_output = NULL,
193		transformators = list()) {
194	!	message("Initializing tm_g_gh_spaghettiplot")
195
196		# Validate string inputs
197	!	checkmate::assert_string(label)
198	!	checkmate::assert_string(dataname)
199	!	checkmate::assert_string(param_var)
200	!	checkmate::assert_string(param_var_label)
201	!	checkmate::assert_string(idvar)
202	!	checkmate::assert_string(group_stats)
203
204		# Validate choices_selected class inputs
205	!	checkmate::assert_class(param, "choices_selected")
206	!	checkmate::assert_class(xaxis_var, "choices_selected")
207	!	checkmate::assert_class(yaxis_var, "choices_selected")
208	!	checkmate::assert_class(trt_group, "choices_selected")
209
210		# Validate flag inputs
211	!	checkmate::assert_flag(rotate_xlab)
212	!	checkmate::assert_flag(free_x)
213
214		# Validate numeric vector inputs
215	!	checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
216	!	checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")
217	!	checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
218	!	checkmate::assert_numeric(
219	!	plot_width[1],
220	!	lower = plot_width[2], upper = plot_width[3],
221	!	null.ok = TRUE, .var.name = "plot_width"
222		)
223	!	checkmate::assert_numeric(font_size, len = 3, any.missing = FALSE, finite = TRUE)
224	!	checkmate::assert_numeric(dot_size, len = 3, any.missing = FALSE, finite = TRUE)
225
226		# Validate color manual if provided
227	!	checkmate::assert_character(man_color, null.ok = TRUE)
228	!	checkmate::assert_character(color_comb, null.ok = TRUE)
229	!	checkmate::assert_character(hline_arb_color)
230	!	checkmate::assert_character(hline_arb_label)
231
232		# Validate facet columns
233	!	checkmate::assert_int(facet_ncol, lower = 1)
234
235		# Validate line arguments
236	!	validate_line_arb_arg(hline_arb, hline_arb_color, hline_arb_label)
237	!	validate_line_vars_arg(hline_vars, hline_vars_colors, hline_vars_labels)
238
239	!	args <- as.list(environment())
240
241	!	module(
242	!	label = label,
243	!	server = srv_g_spaghettiplot,
244	!	server_args = list(
245	!	dataname = dataname,
246	!	idvar = idvar,
247	!	param_var = param_var,
248	!	xaxis_var_level = xaxis_var_level,
249	!	trt_group_level = trt_group_level,
250	!	man_color = man_color,
251	!	color_comb = color_comb,
252	!	param_var_label = param_var_label,
253	!	xtick = xtick,
254	!	xlabel = xlabel,
255	!	plot_height = plot_height,
256	!	plot_width = plot_width,
257	!	hline_vars_colors = hline_vars_colors,
258	!	hline_vars_labels = hline_vars_labels,
259	!	module_args = args
260		),
261	!	ui = g_ui_spaghettiplot,
262	!	ui_args = args,
263	!	transformators = transformators,
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	!	uiOutput(ns("axis_selections")),
282	!	radioButtons(
283	!	ns("group_stats"),
284	!	"Group Statistics",
285	!	c("None" = "NONE", "Mean" = "MEAN", "Median" = "MEDIAN"),
286	!	inline = TRUE
287		),
288	!	templ_ui_constraint(ns), # required by constr_anl_q
289	!	if (length(a$hline_vars) > 0) {
290	!	teal.widgets::optionalSelectInput(
291	!	ns("hline_vars"),
292	!	label = "Add Horizontal Range Line(s):",
293	!	choices = a$hline_vars,
294	!	selected = NULL,
295	!	multiple = TRUE
296		)
297		},
298	!	ui_arbitrary_lines(id = ns("hline_arb"), a$hline_arb, a$hline_arb_label, a$hline_arb_color),
299	!	teal.widgets::panel_group(
300	!	teal.widgets::panel_item(
301	!	title = "Plot Aesthetic Settings",
302	!	tags$div(
303	!	toggle_slider_ui(
304	!	ns("yrange_scale"),
305	!	label = "Y-Axis Range Zoom"
306		),
307	!	tags$div(
308	!	class = "flex flex-wrap items-center",
309	!	tags$div(
310	!	class = "mr-1",
311	!	tags$span(tags$strong("Number of Plots Per Row:"))
312		),
313	!	tags$div(
314	!	class = "w-65px",
315	!	numericInput(ns("facet_ncol"), "", a$facet_ncol, min = 1)
316		)
317		)
318		),
319	!	checkboxInput(ns("free_x"), "Free X-Axis Scales", a$free_x),
320	!	checkboxInput(ns("rotate_xlab"), "Rotate X-Axis Label", a$rotate_xlab),
321	!	teal.widgets::optionalSliderInputValMinMax(ns("font_size"), "Font Size", a$font_size, ticks = FALSE),
322	!	teal.widgets::optionalSliderInputValMinMax(ns("dot_size"), "Dot Size", a$dot_size, ticks = FALSE),
323	!	teal.widgets::optionalSliderInputValMinMax(
324	!	ns("alpha"),
325	!	"Line Alpha",
326	!	a$alpha,
327	!	value_min_max = c(0.8, 0.0, 1.0), step = 0.1, ticks = FALSE
328		)
329		)
330		)
331		),
332	!	forms = tagList(
333	!	teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
334		),
335	!	pre_output = a$pre_output,
336	!	post_output = a$post_output
337		)
338		)
339		}
340
341
342
343		srv_g_spaghettiplot <- function(id,
344		data,
345		reporter,
346		filter_panel_api,
347		dataname,
348		idvar,
349		param_var,
350		trt_group,
351		man_color,
352		color_comb,
353		xaxis_var_level,
354		trt_group_level,
355		param_var_label,
356		xtick,
357		xlabel,
358		plot_height,
359		plot_width,
360		hline_vars_colors,
361		hline_vars_labels,
362		module_args) {
363	!	with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
364	!	with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
365	!	checkmate::assert_class(data, "reactive")
366	!	checkmate::assert_class(shiny::isolate(data()), "teal_data")
367
368	!	moduleServer(id, function(input, output, session) {
369	!	teal.logger::log_shiny_input_changes(input, namespace = "teal.goshawk")
370	!	output$axis_selections <- renderUI({
371	!	env <- shiny::isolate(as.list(data()))
372	!	resolved_x <- teal.transform::resolve_delayed(module_args$xaxis_var, env)
373	!	resolved_y <- teal.transform::resolve_delayed(module_args$yaxis_var, env)
374	!	resolved_param <- teal.transform::resolve_delayed(module_args$param, env)
375	!	resolved_trt <- teal.transform::resolve_delayed(module_args$trt_group, env)
376	!	templ_ui_params_vars(
377	!	session$ns,
378		# xparam and yparam are identical, so we only show the user one
379	!	xparam_choices = resolved_param$choices,
380	!	xparam_selected = resolved_param$selected,
381	!	xparam_label = "Select a Biomarker",
382	!	xchoices = resolved_x$choices,
383	!	xselected = resolved_x$selected,
384	!	ychoices = resolved_y$choices,
385	!	yselected = resolved_y$selected,
386	!	trt_choices = resolved_trt$choices,
387	!	trt_selected = resolved_trt$selected
388		)
389		})
390
391		# reused in all modules
392	!	anl_q_output <- constr_anl_q(
393	!	session, input, data, dataname,
394	!	param_id = "xaxis_param", param_var = param_var, trt_group = input$trt_group, min_rows = 1
395		)
396
397	!	anl_q <- anl_q_output()$value
398
399		# update sliders for axes taking constraints into account
400	!	data_state <- reactive({
401	!	get_data_range_states(
402	!	varname = input$yaxis_var,
403	!	paramname = input$xaxis_param,
404	!	ANL = anl_q()$ANL
405		)
406		})
407	!	yrange_slider <- toggle_slider_server("yrange_scale", data_state)
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 <- debounce(reactive({
429	!	teal::validate_inputs(iv_r())
430	!	req(anl_q())
431		# nolint start
432	!	ylim <- yrange_slider$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	!	}), 800)
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	!	code <- reactive(teal.code::get_code(plot_q()))
533
534		### REPORTER
535	!	if (with_reporter) {
536	!	card_fun <- function(comment, label) {
537	!	card <- report_card_template_goshawk(
538	!	title = "Spaghetti Plot",
539	!	label = label,
540	!	with_filter = with_filter,
541	!	filter_panel_api = filter_panel_api,
542	!	constraint_list = list(
543	!	constraint_var = input$constraint_var,
544	!	constraint_range_min = input$constraint_range_min,
545	!	constraint_range_max = input$constraint_range_max
546		)
547		)
548	!	card$append_text("Spaghetti Plot", "header3")
549	!	card$append_plot(plot_r(), dim = plot_data$dim())
550	!	if (!comment == "") {
551	!	card$append_text("Comment", "header3")
552	!	card$append_text(comment)
553		}
554	!	card$append_src(code())
555	!	card
556		}
557	!	teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
558		}
559		###
560
561	!	reactive_df <- debounce(reactive({
562	!	plot_brush <- plot_data$brush()
563
564	!	ANL <- isolate(anl_q()$ANL) # nolint
565	!	validate_has_data(ANL, 1)
566
567	!	xvar <- isolate(input$xaxis_var)
568	!	yvar <- isolate(input$yaxis_var)
569	!	trt_group <- isolate(input$trt_group)
570
571	!	req(all(c(xvar, yvar) %in% names(ANL)))
572
573	!	df <- teal.widgets::clean_brushedPoints(
574	!	dplyr::select(
575	!	ANL, "USUBJID", dplyr::all_of(trt_group), "PARAMCD",
576	!	dplyr::all_of(c(xvar, yvar)), "LOQFL"
577		),
578	!	plot_brush
579		)
580	!	df[order(df$PARAMCD, df[[trt_group]], df$USUBJID, df[[xvar]]), ]
581	!	}), 800)
582
583	!	output$brush_data <- DT::renderDataTable({
584	!	numeric_cols <- names(dplyr::select_if(reactive_df(), is.numeric))
585
586	!	DT::datatable(reactive_df(),
587	!	rownames = FALSE, options = list(scrollX = TRUE)
588		) %>%
589	!	DT::formatRound(numeric_cols, 4)
590		})
591
592	!	teal.widgets::verbatim_popup_srv(
593	!	id = "rcode",
594	!	verbatim_content = reactive(code()),
595	!	title = "Show R Code for Spaghetti Plot"
596		)
597		})
598		}

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

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

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

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		}