teal.goshawk coverage - 28.67%

Files
Source

#' 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
#'
#' @inheritSection teal::example_module Reporting
#'
#' @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) # @linksto ADSL ADLB
#'   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 = bslib::page_fluid(
      tags$div(
        teal.widgets::plot_with_settings_ui(id = ns("boxplot"))
      ),
      tags$div(
        tags$br(), tags$hr(),
        tags$h4("Selected Data Points"),
        DT::dataTableOutput(ns("brush_data"))
      ),
      tags$div(
        tags$br(), tags$hr(),
        tags$h4("Descriptive Statistics"),
        DT::dataTableOutput(ns("table_ui"))
      )
    ),
    encoding = tags$div(
      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),
      bslib::accordion(
        bslib::accordion_panel(
          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)
        ),
        bslib::accordion_panel(
          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)
        )
      )
    ),
    pre_output = a$pre_output,
    post_output = a$post_output
  )
}


srv_g_boxplot <- function(id,
                          data,
                          dataname,
                          param_var,
                          trt_group,
                          color_manual,
                          shape_manual,
                          plot_height,
                          plot_width,
                          hline_vars_colors,
                          hline_vars_labels,
                          module_args) {
  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()[[".raw_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)
        )
      }

      obj <- anl_q()$qenv

      constraint_description <- c(
        paste("\nFacet By:", if (length(input$facet_var) != 0) input$facet_var else "None"),
        paste("\nSelect an X-axis Variable:", input$xaxis_var)
      )

      teal.reporter::teal_card(obj) <-
        c(
          teal.reporter::teal_card(obj),
          teal.reporter::teal_card("## Module's output(s)"),
          teal.reporter::teal_card(
            "### Selected Options",
            formatted_data_constraint(
              constraint_var = input$xaxis_param,
              constraint_range_min = input$constraint_range_min,
              constraint_range_max = input$constraint_range_max
            ),
            constraint_description
          ),
          teal.reporter::teal_card("### Plot")
        )

      obj %>% 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")
          )
          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())
    })

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

    set_chunk_dims(boxplot_data, create_plot)
  })
}

#' 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
#'
#' @inheritSection teal::example_module Reporting
#'
#'
#' @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) # @linksto ADSL ADLB
#'   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(
      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:"
      ),
      bslib::accordion(
        bslib::accordion_panel(
          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)
        ),
        bslib::accordion_panel(
          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
          )
        )
      )
    ),
    pre_output = a$pre_output,
    post_output = a$post_output
  )
}

srv_g_correlationplot <- function(id,
                                  data,
                                  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) {
  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()[[".raw_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

      obj <- plot_data_transpose()$qenv
      teal.reporter::teal_card(obj) <-
        c(
          teal.reporter::teal_card(obj),
          teal.reporter::teal_card("## Module's output(s)"),
          teal.reporter::teal_card("### Plot")
        )

      teal.code::eval_code(
        object = obj,
        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))
          )
          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
    )

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

    set_chunk_dims(plot_data, plot_q)
  })
}

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('library("dplyr")') %>% # nolint: quotes.
      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"))
    }
  })

  create_anl_constraint_reactive(anl_param, input, param_id = param_id, min_rows = min_rows)
}

# 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 = 'library("dplyr")' # nolint: quotes.
      )
      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))
}

#' 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.
#' @param dataname analysis data passed to the data argument of \code{\link[teal]{init}}. E.g. `ADaM` structured
#' @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}.
#'
#' @inheritParams teal.widgets::standard_layout
#' @inheritParams teal::module
#'
#'
#' @author Nick Paszty (npaszty) paszty.nicholas@gene.com
#' @author Balazs Toth (tothb2)  toth.balazs@gene.com
#' @inheritSection teal::example_module Reporting
#'
#' @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"
#'   )
#'   set.seed(1) # @linksto ADSL ADLB
#'   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 = bslib::page_fluid(
      tags$div(
        teal.widgets::plot_with_settings_ui(id = ns("plot"))
      ),
      tags$div(
        tags$br(), tags$hr(),
        tags$h4("Descriptive Statistics"),
        DT::dataTableOutput(ns("table_ui"))
      )
    ),
    encoding = tags$div(
      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),
      bslib::accordion(
        bslib::accordion_panel(
          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)
        ),
        bslib::accordion_panel(
          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
          )
        )
      )
    ),
    pre_output = a$pre_output,
    post_output = a$post_output
  )
}

srv_g_density_distribution_plot <- function(id, # nolint
                                            data,
                                            dataname,
                                            param_var,
                                            param,
                                            trt_group,
                                            color_manual,
                                            color_comb,
                                            plot_height,
                                            plot_width,
                                            module_args) {
  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()[[".raw_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


      obj <- anl_q()$qenv
      teal.reporter::teal_card(obj) <-
        c(
          teal.reporter::teal_card(obj),
          teal.reporter::teal_card("## Module's output(s)"),
          teal.reporter::teal_card("### Plot")
        )

      teal.code::eval_code(
        object = obj,
        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)
          )
          p
        })
      )
    }), 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,
    )

    create_plot_dims <- set_chunk_dims(plot_data, create_plot)

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

      obj <- create_plot_dims()
      teal.reporter::teal_card(obj) <- c(teal.reporter::teal_card(obj), "### Descriptive Statistics")
      teal.code::eval_code(
        object = obj,
        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)

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

    create_table
  })
}

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

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

#' 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
#' @inheritSection teal::example_module Reporting
#'
#' @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"
#'   )
#'   set.seed(1) # @linksto ADSL ADLB
#'   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(
    teal.widgets::standard_layout(
      output = teal.widgets::plot_with_settings_ui(id = ns("plot")),
      encoding = tags$div(
        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)",
              bslib::tooltip(
                trigger = icon("circle-info"),
                tags$span(
                  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."
                  )
                )
              )
            ),
            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),
        bslib::accordion(
          bslib::accordion_panel(
            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)
          ),
          bslib::accordion_panel(
            title = "Plot settings",
            teal.widgets::optionalSliderInputValMinMax(ns("dodge"), "Error Bar Position Dodge", a$dodge, ticks = FALSE),
            bslib::accordion(
              bslib::accordion_panel(
                title = "Line Settings",
                uiOutput(ns("lines"))
              ),
              bslib::accordion_panel(
                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
            )
          ),
          bslib::accordion_panel(
            title = "Table settings",
            teal.widgets::optionalSliderInputValMinMax(
              ns("table_font_size"),
              "Table Font Size",
              a$table_font_size,
              ticks = FALSE
            )
          )
        )
      ),
      pre_output = a$pre_output,
      post_output = a$post_output
    )
  )
}

srv_lineplot <- function(id,
                         data,
                         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) {
  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()[[".raw_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(
                color_input,
                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

      obj <- private_qenv
      teal.reporter::teal_card(obj) <-
        c(
          teal.reporter::teal_card(obj),
          teal.reporter::teal_card("## Module's output(s)"),
          teal.reporter::teal_card("### Plot")
        )

      teal.code::eval_code(
        object = obj,
        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)
          )
          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,
    )

    set_chunk_dims(plot_data, plot_q)
  })
}

#' 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
#'
#' @inheritSection teal::example_module Reporting
#'
#' @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) # @linksto ADSL ADLB
#'   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(...)

  tags$div(
    teal.widgets::standard_layout(
      output = templ_ui_output_datatable(ns),
      encoding = tags$div(
        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),
        bslib::accordion(
          bslib::accordion_panel(
            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
            )
          )
        )
      ),
      pre_output = a$pre_output,
      post_output = a$post_output
    )
  )
}


srv_g_spaghettiplot <- function(id,
                                data,
                                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) {
  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()[[".raw_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())
        )
      }

      obj <- private_qenv
      teal.reporter::teal_card(obj) <-
        c(
          teal.reporter::teal_card(obj),
          teal.reporter::teal_card("## Module's output(s)"),
          teal.reporter::teal_card("### Plot")
        )
      teal.code::eval_code(
        object = obj,
        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)])
          )
          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
    )


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

    set_chunk_dims(plot_data, plot_q)
  })
}

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

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

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

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

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

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

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

  teal_card
}

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

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

#' 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,
      bslib::tooltip(
        trigger = icon("circle-info"),
        tags$span(
          "For multiple lines, supply a comma separated list of values."
        )
      )
    ),
    textInput(
      ns("line_arb"),
      "Value:",
      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
    })

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

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

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

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

templ_ui_output_datatable <- function(ns) {
  bslib::page_fluid(
    teal.widgets::plot_with_settings_ui(id = ns("plot")),
    tags$br(), tags$hr(),
    tags$h4("Selected Data Points"),
    tags$div(
      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
      )
    }
  )
}

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	6x	ns <- NS(id)
21	6x	tags$div(
22	6x	tags$div(
23	6x	style = "display: flex; justify-content: space-between;",
24	6x	tags$span(tags$strong(label)),
25	6x	tags$div(actionButton(ns("toggle"), "Toggle", class = "btn-xs"))
26		),
27	6x	uiOutput(ns("inputs"))
28		)
29		}
30
31		#' @keywords internal
32		#' @rdname toggle_slider
33		toggle_slider_server <- function(id, data_state, ...) {
34	6x	moduleServer(id, function(input, output, session) {
35	6x	state <- reactiveValues(
36	6x	min = NULL,
37	6x	max = NULL,
38	6x	value = NULL
39		)
40	6x	slider_shown <- reactive(input$toggle %% 2 == 0)
41
42	6x	observeEvent(data_state()$range, {
43	7x	state$min <- data_state()$range[1]
44	7x	state$max <- data_state()$range[2]
45	7x	state$value <- data_state()$range
46		})
47
48	6x	output$inputs <- renderUI({
49	28x	req(state$value)
50	22x	if (slider_shown()) {
51	11x	tags$div(
52	11x	class = "teal-goshawk toggle-slider-container",
53	11x	sliderInput(
54	11x	inputId = session$ns("slider"),
55	11x	label = NULL,
56	11x	min = min(data_state()$range[1], state$min),
57	11x	max = max(data_state()$range[2], state$max),
58	11x	value = state$value,
59	11x	step = data_state()$step,
60	11x	ticks = TRUE,
61		...
62		),
63	11x	tags$script(HTML(sprintf(
64		'
65	11x	$(".teal-goshawk.toggle-slider-container #%s").ready(function () {
66	11x	var tickLabel = document.querySelector(
67	11x	".teal-goshawk.toggle-slider-container .irs-grid-text.js-grid-text-9"
68		);
69	11x	var tick = document.querySelector(
70	11x	".teal-goshawk.toggle-slider-container .irs-grid-pol:nth-last-child(6)"
71		);
72	11x	if (tickLabel) {
73	11x	if (parseFloat(tickLabel.style.left) > 95) {
74	11x	tickLabel.style.opacity = "0";
75	11x	tick.style.opacity = "0";
76		}
77		} else {
78	11x	console.log("Toggle slider element not found.");
79		}
80		});
81		',
82	11x	session$ns("slider")
83		)))
84		)
85		} else {
86	11x	tags$div(
87	11x	class = "teal-goshawk toggle-slider-container",
88	11x	numericInput(
89	11x	inputId = session$ns("value_low"),
90	11x	label = "From:",
91	11x	value = state$value[1]
92		),
93	11x	numericInput(
94	11x	inputId = session$ns("value_high"),
95	11x	label = "to:",
96	11x	value = state$value[2]
97		)
98		)
99		}
100		})
101
102	6x	d_slider <- debounce(reactive(input$slider), 500)
103
104	6x	observeEvent(d_slider(), {
105	11x	if (!setequal(state$value, d_slider())) {
106	1x	state$value <- d_slider()
107		}
108		})
109
110	6x	d_value_low <- debounce(reactive(input$value_low), 500)
111	6x	d_value_high <- debounce(reactive(input$value_high), 500)
112
113	6x	observeEvent(c(d_value_low(), d_value_high()), ignoreInit = TRUE, {
114	16x	values <- c(input$value_low, input$value_high)
115	16x	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	6x	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	13x	validate(need(varname, "Please select variable"))
130	7x	validate(need(paramname, "Please select variable"))
131	7x	req(length(paramname) == 1)
132	7x	step <- NULL
133
134	7x	ANL <- ANL %>% dplyr::filter(.data$PARAMCD == paramname) # nolint object_name_linter
135	7x	validate_has_variable(ANL, varname, paste("variable", varname, "does not exist"))
136
137	7x	var <- stats::na.omit(ANL[[varname]])
138	7x	minmax <- if (length(var)) c(floor(min(var)), ceiling(max(var))) else c(0, 0)
139	7x	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	7x	list(
149	7x	range = c(min = minmax[[1]], max = minmax[[2]]),
150	7x	step = step
151		)
152		}

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

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

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

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

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

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

1		plots_per_row_validate_rules <- function(required = TRUE) {
2	6x	msg <- "Number of plots per row must be a positive integer"
3	6x	shinyvalidate::compose_rules(
4	6x	if (required) {
5	!	shinyvalidate::sv_required(msg)
6		} else {
7	6x	shinyvalidate::sv_optional()
8		},
9	6x	shinyvalidate::sv_integer(msg),
10	6x	shinyvalidate::sv_gt(0, message_fmt = msg)
11		)
12		}
13
14		#' Template Function for `TealReportCard` Creation and Customization in `teal.goshawk`
15		#'
16		#' This function generates a report card with a title,
17		#' an optional description, and the option to append the filter state list.
18		#' Additionally, it display selected constraint options.
19		#'
20		#' @inheritParams teal::report_card_template
21		#' @param constraint_list (`list`) a list containing constraint variables, including:
22		#' - constraint_var (`character(1)`) the constraint variable name.
23		#' - constraint_range_min (`numeric(1)`) the minimum constraint range value.
24		#' - constraint_range_max (`numeric(1)`) the maximum constraint range value.
25		#' @param constraint_description (`character(1)`) description of the constraints.
26		#' @param style (`character(1)`) style of the constraint text block.
27		#' options: `default`, `verbatim` (default is `default`).
28		#'
29		#' @return (`TealReportCard`) populated with a title, description, and filter state
30		#'
31		#' @keywords internal
32		report_card_template_goshawk <- function(title,
33		label,
34		with_filter,
35		filter_panel_api,
36		constraint_list,
37		constraint_description = NULL,
38		style = "default") {
39	!	checkmate::assert_subset(names(constraint_list), c("constraint_var", "constraint_range_min", "constraint_range_max"))
40	!	checkmate::assert_string(constraint_description, null.ok = TRUE)
41	!	checkmate::assert_choice(style, c("default", "verbatim"))
42
43	!	card <- teal::report_card_template(
44	!	title = title,
45	!	label = label,
46	!	with_filter = with_filter,
47	!	filter_panel_api = filter_panel_api
48		)
49
50	!	card$append_text("Selected Options", "header3")
51	!	card$append_text(
52	!	paste(
53	!	formatted_data_constraint(
54	!	constraint_list$constraint_var,
55	!	constraint_list$constraint_range_min,
56	!	constraint_list$constraint_range_max
57		),
58	!	constraint_description
59		),
60	!	style = style
61		)
62	!	card
63		}
64
65		#' Get Choices
66		#'
67		#' This function returns choices based on the class of the input.
68		#' If the input is of class `delayed_data`, it returns the `subset` of the input.
69		#' If `subset` is NULL and the input contains `var_label` and `var_choices`,
70		#' it throws an error prompting to resolve delayed inputs.
71		#' Otherwise, it returns the input as is.
72		#'
73		#' @param choices An object that contains choices.
74		#' @return A vector of choices.
75		#' @keywords internal
76		get_choices <- function(choices) {
77	!	if (inherits(choices, "delayed_data")) {
78	!	if (is.null(choices$subset)) {
79	!	if (!is.null(choices$var_label) && !is.null(choices$var_choices)) {
80	!	stop(
81	!	"Resolve delayed inputs by evaluating the code within the provided datasets.
82	!	Check ?teal.transform::resolve_delayed for more information."
83		)
84		} else {
85	!	stop("Subset is NULL and necessary fields are missing.")
86		}
87		} else {
88	!	choices$subset
89		}
90		} else {
91	!	choices
92		}
93		}
94
95		#' Set the attributes of the last chunk outputs
96		#' @param teal_card (`teal_card`) object to modify.
97		#' @param attributes (`list`) of attributes to set on the last chunk outputs.
98		#' @param n (`integer(1)`) number of the last element of `teal_card` to modify.
99		#' it will only change `chunk_output` objects.
100		#' @param inner_classes (`character`) classes within `chunk_output` that should be modified.
101		#' This can be used to only change `recordedplot`, `ggplot2` or other type of objects.
102		#' @keywords internal
103		set_chunk_attrs <- function(teal_card,
104		attributes,
105		n = 1,
106		inner_classes = NULL,
107		quiet = FALSE) {
108	!	checkmate::assert_class(teal_card, "teal_card")
109	!	checkmate::assert_list(attributes, names = "unique")
110	!	checkmate::assert_int(n, lower = 1)
111	!	checkmate::assert_character(inner_classes, null.ok = TRUE)
112	!	checkmate::assert_flag(quiet)
113
114	!	if (!inherits(teal_card[[length(teal_card)]], "chunk_output")) {
115	!	if (!quiet) {
116	!	warning("The last element of the `teal_card` is not a `chunk_output` object. No attributes were modified.")
117		}
118	!	return(teal_card)
119		}
120
121	!	for (ix in seq_len(length(teal_card))) {
122	!	if (ix > n) {
123	!	break
124		}
125	!	current_ix <- length(teal_card) + 1 - ix
126	!	if (!inherits(teal_card[[current_ix]], "chunk_output")) {
127	!	if (!quiet) {
128	!	warning(
129	!	"The ", ix,
130	!	" to last element of the `teal_card` is not a `chunk_output` object. Skipping any further modifications."
131		)
132		}
133	!	return(teal_card)
134		}
135
136		if (
137	!	length(inner_classes) > 0 &&
138	!	length(teal_card[[current_ix]]) >= 1 &&
139	!	!checkmate::test_multi_class(teal_card[[current_ix]][[1]], inner_classes)
140		) {
141	!	next
142		}
143
144	!	attributes(teal_card[[current_ix]]) <- utils::modifyList(
145	!	attributes(teal_card[[current_ix]]),
146	!	attributes
147		)
148		}
149
150	!	teal_card
151		}
152
153		#' Create a reactive that sets plot dimensions on a `teal_card`
154		#'
155		#' This is a convenience function that creates a reactive expression that
156		#' automatically sets the `dev.width` and `dev.height` attributes on the last
157		#' chunk outputs of a `teal_card` based on plot dimensions from a plot widget.
158		#'
159		#' @param pws (`plot_widget`) plot widget that provides dimensions via `dim()` method
160		#' @param q_r (`reactive`) reactive expression that returns a `teal_reporter`
161		#' @param inner_classes (`character`) classes within `chunk_output` that should be modified.
162		#' This can be used to only change `recordedplot`, `ggplot2` or other type of objects.
163		#'
164		#' @return A reactive expression that returns the `teal_card` with updated dimensions
165		#'
166		#' @keywords internal
167		set_chunk_dims <- function(pws, q_r, inner_classes = NULL) {
168	6x	checkmate::assert_list(pws)
169	6x	checkmate::assert_names(names(pws), must.include = "dim")
170	6x	checkmate::assert_class(pws$dim, "reactive")
171	6x	checkmate::assert_class(q_r, "reactive")
172	6x	checkmate::assert_character(inner_classes, null.ok = TRUE)
173
174	6x	reactive({
175	20x	pws_dim <- stats::setNames(as.list(req(pws$dim())), c("width", "height"))
176	20x	if (identical(pws_dim$width, "auto")) { # ignore non-numeric values (such as "auto")
177	20x	pws_dim$width <- NULL
178		}
179	20x	if (identical(pws_dim$height, "auto")) { # ignore non-numeric values (such as "auto")
180	!	pws_dim$height <- NULL
181		}
182	20x	q <- req(q_r())
183	!	teal.reporter::teal_card(q) <- set_chunk_attrs(
184	!	teal.reporter::teal_card(q),
185	!	list(dev.width = pws_dim$width, dev.height = pws_dim$height),
186	!	inner_classes = inner_classes
187		)
188	!	q
189		})
190		}

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

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