teal.goshawk coverage - 0.00%

Files
Source

#' 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 group_stats control group mean or median overlay.
#' @param hline_arb numeric vector of at most 2 values identifying intercepts for arbitrary horizontal lines.
#' @param hline_arb_color a character vector of at most length of \code{hline_arb}.
#' naming the color for the arbitrary horizontal lines.
#' @param hline_arb_label a character vector of at most length of \code{hline_arb}.
#' naming the label for the arbitrary horizontal lines.
#' @param hline_vars a character vector to name the columns that will define additional horizontal lines.
#' @param hline_vars_colors a character vector naming the colors for the additional horizontal lines.
#' @param hline_vars_labels a character vector naming the labels for the additional horizontal lines that will appear
#'  in the legend.
#' @inheritParams teal.widgets::standard_layout
#'
#' @author Wenyi Liu (luiw2) wenyi.liu@roche.com
#' @author Balazs Toth (tothb2) toth.balazs@gene.com
#'
#' @return \code{shiny} object
#'
#' @export
#'
#' @examples
#'
#' # Example using ADaM structure analysis dataset.
#'
#' library(dplyr)
#'
#' # original ARM value = dose value
#' arm_mapping <- list(
#'   "A: Drug X" = "150mg QD",
#'   "B: Placebo" = "Placebo",
#'   "C: Combination" = "Combination"
#' )
#' set.seed(1)
#' ADSL <- goshawk::rADSL
#' ADLB <- goshawk::rADLB
#' var_labels <- lapply(ADLB, function(x) attributes(x)$label)
#' ADLB <- ADLB %>%
#'   dplyr::mutate(
#'     AVISITCD = dplyr::case_when(
#'       AVISIT == "SCREENING" ~ "SCR",
#'       AVISIT == "BASELINE" ~ "BL",
#'       grepl("WEEK", AVISIT) ~ paste("W", stringr::str_extract(AVISIT, "(?<=(WEEK ))[0-9]+")),
#'       TRUE ~ as.character(NA)
#'     ),
#'     AVISITCDN = dplyr::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 = dplyr::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
#'   ) %>%
#'   dplyr::rowwise() %>%
#'   dplyr::group_by(PARAMCD) %>%
#'   dplyr::mutate(LBSTRESC = ifelse(USUBJID %in% sample(USUBJID, 1, replace = TRUE),
#'     paste("<", round(runif(1, min = 25, max = 30))), LBSTRESC
#'   )) %>%
#'   dplyr::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 <- goshawk:::h_identify_loq_values(ADLB)
#' ADLB <- dplyr::left_join(ADLB, ALB_LOQS, by = "PARAM")
#'
#' app <- teal::init(
#'   data = teal.data::cdisc_data(
#'     teal.data::cdisc_dataset("ADSL", ADSL, code = "ADSL <- goshawk::rADSL"),
#'     teal.data::cdisc_dataset(
#'       "ADLB",
#'       ADLB,
#'       code = "set.seed(1)
#'               ADLB <- goshawk::rADLB
#'               var_labels <- lapply(ADLB, function(x) attributes(x)$label)
#'               ADLB <- ADLB %>%
#'                 dplyr::mutate(AVISITCD = dplyr::case_when(
#'                     AVISIT == 'SCREENING' ~ 'SCR',
#'                     AVISIT == 'BASELINE' ~ 'BL',
#'                     grepl('WEEK', AVISIT) ~
#'                       paste('W', stringr::str_extract(AVISIT, '(?<=(WEEK ))[0-9]+')),
#'                     TRUE ~ as.character(NA)),
#'                   AVISITCDN = dplyr::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 = dplyr::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) %>%
#'                   dplyr::rowwise() %>%
#'                   dplyr::group_by(PARAMCD) %>%
#'                   dplyr::mutate(LBSTRESC = ifelse(USUBJID %in% sample(USUBJID, 1, replace = TRUE),
#'                   paste('<', round(runif(1, min = 25, max = 30))), LBSTRESC)) %>%
#'                   dplyr::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'
#'                ALB_LOQS <- goshawk:::h_identify_loq_values(ADLB)
#'                ADLB <- left_join(ADLB, ALB_LOQS, by = 'PARAM')",
#'       vars = list(arm_mapping = arm_mapping)
#'     ),
#'     check = FALSE
#'   ),
#'   modules = teal::modules(
#'     teal.goshawk::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),
                                  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) {
  logger::log_info("Initializing tm_g_gh_spaghettiplot")
  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_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"
  )
  checkmate::assert_flag(free_x)

  args <- as.list(environment())

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

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

  shiny::tagList(
    include_css_files("custom"),
    teal.widgets::standard_layout(
      output = templ_ui_output_datatable(ns),
      encoding = div(
        ### Reporter
        teal.reporter::simple_reporter_ui(ns("simple_reporter")),
        ###
        templ_ui_dataname(a$dataname),
        teal.widgets::optionalSelectInput(
          ns("trt_group"),
          label = "Select Treatment Variable",
          choices = a$trt_group$choices,
          selected = a$trt_group$selected,
          multiple = FALSE
        ),
        templ_ui_params_vars(
          ns,
          # xparam and yparam are identical, so we only show the user one
          xparam_choices = a$param$choices, xparam_selected = a$param$selected, xparam_label = "Select a Biomarker",
          xchoices = a$xaxis_var$choices, xselected = a$xaxis_var$selected,
          ychoices = a$yaxis_var$choices, yselected = a$yaxis_var$selected
        ),
        radioButtons(
          ns("group_stats"),
          "Group Statistics",
          c("None" = "NONE", "Mean" = "MEAN", "Median" = "MEDIAN"),
          inline = TRUE
        ),
        templ_ui_constraint(ns), # required by constr_anl_q
        if (length(a$hline_vars) > 0) {
          teal.widgets::optionalSelectInput(
            ns("hline_vars"),
            label = "Add Horizontal Range Line(s):",
            choices = a$hline_vars,
            selected = NULL,
            multiple = TRUE
          )
        },
        ui_arbitrary_lines(id = ns("hline_arb"), a$hline_arb, a$hline_arb_label, a$hline_arb_color),
        teal.widgets::panel_group(
          teal.widgets::panel_item(
            title = "Plot Aesthetic Settings",
            div(
              toggle_slider_ui(
                ns("yrange_scale"),
                label = "Y-Axis Range Zoom",
                min = -1000000,
                max = 1000000,
                value = c(-1000000, 1000000)
              ),
              tags$div(
                class = "flex flex-wrap items-center",
                tags$div(
                  class = "mr-1",
                  tags$span(tags$strong("Number of Plots Per Row:"))
                ),
                tags$div(
                  class = "w-65px",
                  numericInput(ns("facet_ncol"), "", a$facet_ncol, min = 1)
                )
              )
            ),
            checkboxInput(ns("free_x"), "Free X-Axis Scales", a$free_x),
            checkboxInput(ns("rotate_xlab"), "Rotate X-Axis Label", a$rotate_xlab),
            teal.widgets::optionalSliderInputValMinMax(ns("font_size"), "Font Size", a$font_size, ticks = FALSE),
            teal.widgets::optionalSliderInputValMinMax(
              ns("alpha"),
              "Line Alpha",
              a$alpha,
              value_min_max = c(0.8, 0.0, 1.0), step = 0.1, ticks = FALSE
            )
          )
        )
      ),
      forms = tagList(
        teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
        teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
      ),
      pre_output = a$pre_output,
      post_output = a$post_output
    )
  )
}



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

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

    anl_q <- anl_q_output()$value

    # update sliders for axes taking constraints into account
    yrange_slider <- toggle_slider_server("yrange_scale")
    keep_range_slider_updated(session, input, yrange_slider$update_state, "yaxis_var", "xaxis_param", anl_q)
    keep_data_const_opts_updated(session, input, anl_q, "xaxis_param")

    horizontal_line <- srv_arbitrary_lines("hline_arb")

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

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

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


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

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

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

      private_qenv <- anl_q()$qenv

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

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

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

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

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

    ### REPORTER
    if (with_reporter) {
      card_fun <- function(comment) {
        card <- teal::TealReportCard$new()
        card$set_name("Spaghetti Plot")
        card$append_text("Spaghetti Plot", "header2")
        if (with_filter) card$append_fs(filter_panel_api$get_filter_state())
        card$append_text("Selected Options", "header3")
        card$append_text(
          formatted_data_constraint(input$constraint_var, input$constraint_range_min, input$constraint_range_max)
        )
        card$append_text("Spaghetti Plot", "header3")
        card$append_plot(plot_r(), dim = plot_data$dim())
        if (!comment == "") {
          card$append_text("Comment", "header3")
          card$append_text(comment)
        }
        card$append_src(paste(teal.code::get_code(plot_q()), collapse = "\n"))
        card
      }
      teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
    }
    ###

    output$brush_data <- DT::renderDataTable({
      plot_brush <- plot_data$brush()

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

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

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

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

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

    teal.widgets::verbatim_popup_srv(
      id = "warning",
      verbatim_content = reactive(teal.code::get_warnings(plot_q())),
      title = "Warning",
      disabled = reactive(is.null(teal.code::get_warnings(plot_q())))
    )

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

templ_ui_constraint <- function(ns, label = "Data Constraint") {
  div(
    id = ns("constraint_var_whole"), # give an id to hide it
    radioButtons(ns("constraint_var"), label, choices = "NONE"),
    shinyjs::hidden(div(
      id = ns("constraint_range"),
      div(
        class = "inline-block;",
        numericInput(ns("constraint_range_min"), label = "Min", value = 0, min = 0, max = 0)
      ),
      div(
        class = "inline-block;",
        numericInput(ns("constraint_range_max"), label = "Min", value = 0, min = 0, max = 0)
      )
    )),
    shinyjs::hidden(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) {
  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 <- teal.code::new_qenv(tdata2env(data), code = teal::get_code_tdata(data)) %>%
      teal.code::eval_code(
        substitute(ANL <- dataname, list(dataname = as.name(dataname))) # nolint
      ) %>%
      teal.code::eval_code(
        code = bquote({
          ANL <- .(as.name(dataset_var)) %>% # nolint
            dplyr::filter(.(as.name(param_var)) == .(param_var_value))
        })
      )
    validate_has_data(private_qenv[["ANL"]], min_rows)
    list(ANL = ANL, qenv = private_qenv)
  })

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

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


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

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

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

    visit_freq <- unique(ANL$AVISITCD)

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

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

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

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

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

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

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

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

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

  return(anl_constraint)
}

# returns a reactive that applies the `x-axis data constraint`
# More precisely, all patients are filtered out that do not have the range of
# `param_id.constraint_var` in the specified range
# constraint var means that `param_id.constraint_var` is constrained to the filtered range (or NA),
# e.g. `ALT.BASE2` (i.e. `PARAMCD = ALT & range_filter_on(BASE2)`)
create_anl_constraint_reactive <- function(anl_param, input, param_id, min_rows) {

  iv_r <- reactive({
    iv <- shinyvalidate::InputValidator$new()
    iv$condition(~ isTRUE(input$constraint_var != "NONE"))
    iv$add_rule("constraint_range_min", shinyvalidate::sv_required("A contraint minimum value is required"))
    iv$add_rule("constraint_range_max", shinyvalidate::sv_required("A contraint maximum value is required"))
    iv$add_rule(
      "constraint_range_min",
      ~ if (!is.na(input$constraint_range_max) && (.) > input$constraint_range_max)
        "constraint min needs to be less than max"
    )
    iv$add_rule(
      "constraint_range_max",
      ~ if (!is.na(input$constraint_range_min) && (.) < input$constraint_range_min)
        "constraint min needs to be less than max"
    )
    iv
  })


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

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

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

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

# for outputting the constaint 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))
}

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

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

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

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

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

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

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

    anl_q <- anl_q_output()$value

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

    yrange_slider <- toggle_slider_server("yrange_scale")

    horizontal_line <- srv_arbitrary_lines("hline_arb")

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

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


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

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

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

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

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

      # we don't use keep_range_slider_updated because this module computes the min, max
      # not from the constrained ANL, but rather by first grouping and computing confidence
      # intervals
      isolate(yrange_slider$update_state(
        min = minmax[[1]],
        max = minmax[[2]],
        value = minmax
      ))
    })

    line_color_defaults <- reactiveVal(color_manual)

    line_type_defaults <- reactiveVal("solid")

    observeEvent(input$trt_group, {
      req(anl_q())
      req(input$trt_group)
      anl_arm <- anl_q()$ANL[[input$trt_group]]
      anl_arm_nlevels <- nlevels(anl_arm)

      if (is.null(names(line_color_defaults()))) {
        # if color_manual did not specify arms (i.e. didn't have names) then order
        # of the vector does not need to match order of level(anl_arm)
        line_color_to_set <- line_color_defaults()[seq_len(anl_arm_nlevels)]
      } else {
        # if color_manual did specify arms then we need to make sure the order of
        # line_color_to_set matches the order of level(anl_arm) and if any arms are invalid
        # or missing then we fill with a random colour
        line_color_to_set <- stats::setNames(line_color_defaults()[levels(anl_arm)], nm = levels(anl_arm))
      }
      line_color_to_set[is.na(line_color_to_set)] <- grDevices::rainbow(anl_arm_nlevels)[is.na(line_color_to_set)]
      line_color_defaults(line_color_to_set)

      line_type_to_set <- if (length(line_type_defaults()) <= anl_arm_nlevels) {
        c(line_type_defaults(), rep(line_type_defaults(), anl_arm_nlevels - length(line_type_defaults())))
      } else {
        line_type_defaults()[seq_len(anl_arm_nlevels)]
      }

      line_type_defaults(line_type_to_set)
    })

    line_color_selected <- reactive({
      req(anl_q())
      if (is.null(input$trt_group)) {
        return(NULL)
      }
      anl_arm <- 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)]]
            if (is.null(x)) isolate(line_color_defaults())[[idx]] else x
          },
          character(1)
        ),
        anl_arm_levels
      )
    })

    line_type_selected <- reactive({
      req(anl_q())
      if (is.null(input$trt_group)) {
        return(NULL)
      }
      anl_arm <- 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)) isolate(line_type_defaults())[[idx]] else x
          },
          character(1)
        ),
        anl_arm_levels
      )
    })

    output$lines <- renderUI({
      req(anl_q())
      req(input$trt_group)
      anl_arm <- isolate(anl_q()$ANL[[input$trt_group]])
      anl_arm_nlevels <- nlevels(anl_arm)
      anl_arm_levels <- levels(anl_arm)
      color_def <- line_color_defaults()
      type_def <- line_type_defaults()
      tagList(
        lapply(
          seq_len(anl_arm_nlevels),
          function(idx) {
            x <- anl_arm_levels[[idx]]
            x_color <- color_def[[idx]]
            color_input <- colourpicker::colourInput(
              ns(paste0("line_color_", idx)),
              "Color:",
              x_color
            )
            x_type <- type_def[[idx]]
            type_input <- selectInput(
              ns(paste0("line_type_", idx)),
              "Type:",
              choices = c(
                "blank",
                "solid",
                "dashed",
                "dotted",
                "dotdash",
                "longdash",
                "twodash",
                "1F",
                "F1",
                "4C88C488",
                "12345678"
              ),
              selected = x_type
            )
            div(
              tags$label("Line configuration for:", tags$code(x)),
              div(
                class = "flex",
                div(
                  class = "flex-grow-1",
                  color_input
                ),
                div(
                  class = "flex-grow-1",
                  type_input
                )
              )
            )
          }
        )
      )
    })


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

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

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

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

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

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

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

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

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

    plot_q <- reactive({
      teal::validate_inputs(iv_r())
      req(anl_q(), line_color_selected(), line_type_selected())
      # nolint start

      ylim <- yrange_slider$state()$value
      plot_font_size <- input$plot_font_size
      dodge <- input$dodge
      rotate_xlab <- input$rotate_xlab
      count_threshold <- `if`(is.na(as.numeric(input$count_threshold)), 0, as.numeric(input$count_threshold))
      table_font_size <- input$table_font_size

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

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

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

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

      private_qenv <- anl_q()$qenv

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

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

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

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

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

    ### REPORTER
    if (with_reporter) {
      card_fun <- function(comment) {
        card <- teal::TealReportCard$new()
        card$set_name("Line Plot")
        card$append_text("Line Plot", "header2")
        if (with_filter) card$append_fs(filter_panel_api$get_filter_state())
        card$append_text("Selected Options", "header3")
        card$append_text(
          paste(
            formatted_data_constraint(input$constraint_var, input$constraint_range_min, input$constraint_range_max),
            "\nSelect Line Splitting Variable:",
            if (!is.null(input$shape)) input$shape else "None",
            "\nContributing Observations Threshold:",
            input$count_threshold
          ),
          style = "verbatim"
        )
        card$append_text("Plot", "header3")
        card$append_plot(plot_r(), dim = plot_data$dim())
        if (!comment == "") {
          card$append_text("Comment", "header3")
          card$append_text(comment)
        }
        card$append_src(paste(teal.code::get_code(plot_q()), collapse = "\n"))
        card
      }
      teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
    }
    ###

    teal.widgets::verbatim_popup_srv(
      id = "warning",
      verbatim_content = reactive(teal.code::get_warnings(plot_q())),
      title = "Warning",
      disabled = reactive(is.null(teal.code::get_warnings(plot_q())))
    )

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

#' Scatter Plot Teal Module For Biomarker Analysis
#'
#' @description Scatter Plot Teal Module For Biomarker Analysis
#'
#' @inheritParams teal.widgets::standard_layout
#' @param label menu item label of the module in the teal app.
#' @param dataname analysis data passed to the data argument of \code{\link[teal]{init}}. E.g. `ADaM` structured
#' laboratory data frame \code{ADLB}.
#' @param param_var name of variable containing biomarker codes e.g. \code{PARAMCD}.
#' @param xaxis_param biomarker selected for `x-axis`.
#' @param yaxis_param biomarker selected for `y-axis`.
#' @param xaxis_var name of variable containing biomarker results displayed on x-axis e.g. \code{BASE}.
#' @param yaxis_var name of variable containing biomarker results displayed on y-axis e.g. \code{AVAL}.
#' @param trt_group \code{\link[teal.transform]{choices_selected}} object with available choices and pre-selected option
#' for variable names representing treatment group e.g. `ARM`.
#' @param color_manual vector of colors applied to treatment values.
#' @param shape_manual vector of symbols applied to `LOQ` values.
#' @param facet_ncol numeric value indicating number of facets per row.
#' @param trt_facet facet by treatment group \code{trt_group}.
#' @param visit_facet visit facet toggle.
#' @param reg_line include regression line and annotations for slope and coefficient in visualization. Use with facet
#'   TRUE.
#' @param loq_legend `loq` legend toggle.
#' @param rotate_xlab 45 degree rotation of `x-axis` values.
#' @param hline_arb numeric vector of at most 2 values identifying intercepts for arbitrary horizontal lines.
#' @param hline_arb_color a character vector of at most length of \code{hline_arb}.
#' naming the color for the arbitrary horizontal lines.
#' @param hline_arb_label a character vector of at most length of \code{hline_arb}.
#' naming the label for the arbitrary horizontal lines.
#' @param hline_vars a character vector to name the columns that will define additional horizontal lines.
#' @param hline_vars_colors a character vector naming the colors for the additional horizontal lines.
#' @param hline_vars_labels a character vector naming the labels for the additional horizontal lines that will appear
#' @param vline_arb numeric vector of at most 2 values identifying intercepts for arbitrary horizontal lines.
#' @param vline_arb_color a character vector of at most length of \code{vline_arb}.
#' naming the color for the arbitrary horizontal lines.
#' @param vline_arb_label a character vector of at most length of \code{vline_arb}.
#' naming the label for the arbitrary horizontal lines.
#' @param vline_vars a character vector to name the columns that will define additional vertical lines.
#' @param vline_vars_colors a character vector naming the colors for the additional vertical lines.
#' @param vline_vars_labels a character vector naming the labels for the additional vertical lines that will appear
#' @param plot_height controls plot height.
#' @param plot_width optional, controls plot width.
#' @param font_size font size control for title, `x-axis` label, `y-axis` label and legend.
#' @param dot_size plot dot size.
#' @param reg_text_size font size control for regression line annotations.
#'
#' @export
#'
#' @author Nick Paszty (npaszty) paszty.nicholas@gene.com
#' @author Balazs Toth (tothb2)  toth.balazs@gene.com
#'
#' @examples
#'
#' # Example using ADaM structure analysis dataset.
#'
#' # original ARM value = dose value
#' arm_mapping <- list(
#'   "A: Drug X" = "150mg QD",
#'   "B: Placebo" = "Placebo",
#'   "C: Combination" = "Combination"
#' )
#' color_manual <- c("150mg QD" = "#000000", "Placebo" = "#3498DB", "Combination" = "#E74C3C")
#' # assign LOQ flag symbols: circles for "N" and triangles for "Y", squares for "NA"
#' shape_manual <- c("N" = 1, "Y" = 2, "NA" = 0)
#'
#' set.seed(1)
#' ADSL <- goshawk::rADSL
#' ADLB <- goshawk::rADLB
#' var_labels <- lapply(ADLB, function(x) attributes(x)$label)
#' ADLB <- ADLB %>%
#'   dplyr::mutate(AVISITCD = dplyr::case_when(
#'     AVISIT == "SCREENING" ~ "SCR",
#'     AVISIT == "BASELINE" ~ "BL",
#'     grepl("WEEK", AVISIT) ~
#'       paste(
#'         "W",
#'         trimws(
#'           substr(
#'             AVISIT,
#'             start = 6,
#'             stop = stringr::str_locate(AVISIT, "DAY") - 1
#'           )
#'         )
#'       ),
#'     TRUE ~ NA_character_
#'   )) %>%
#'   dplyr::mutate(AVISITCDN = dplyr::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
#'   dplyr::mutate(TRTORD = ifelse(grepl("C", ARMCD), 1,
#'     ifelse(grepl("B", ARMCD), 2,
#'       ifelse(grepl("A", ARMCD), 3, NA)
#'     )
#'   )) %>%
#'   dplyr::mutate(ARM = as.character(arm_mapping[match(ARM, names(arm_mapping))])) %>%
#'   dplyr::mutate(ARM = factor(ARM) %>%
#'     reorder(TRTORD)) %>%
#'   dplyr::mutate(
#'     ANRHI = dplyr::case_when(
#'       PARAMCD == "ALT" ~ 60,
#'       PARAMCD == "CRP" ~ 70,
#'       PARAMCD == "IGA" ~ 80,
#'       TRUE ~ NA_real_
#'     ),
#'     ANRLO = dplyr::case_when(
#'       PARAMCD == "ALT" ~ 20,
#'       PARAMCD == "CRP" ~ 30,
#'       PARAMCD == "IGA" ~ 40,
#'       TRUE ~ NA_real_
#'     )
#'   ) %>%
#'   dplyr::rowwise() %>%
#'   dplyr::group_by(PARAMCD) %>%
#'   dplyr::mutate(LBSTRESC = ifelse(
#'     USUBJID %in% sample(USUBJID, 1, replace = TRUE),
#'     paste("<", round(runif(1, min = 25, max = 30))), LBSTRESC
#'   )) %>%
#'   dplyr::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 <- goshawk:::h_identify_loq_values(ADLB)
#' ADLB <- dplyr::left_join(ADLB, ADLB_LOQS, by = "PARAM")
#'
#' app <- teal::init(
#'   data = teal.data::cdisc_data(
#'     teal.data::cdisc_dataset("ADSL", ADSL, code = "ADSL <- goshawk::rADSL"),
#'     teal.data::cdisc_dataset(
#'       "ADLB",
#'       ADLB,
#'       code = "set.seed(1)
#'               ADLB <- goshawk::rADLB
#'               var_labels <- lapply(ADLB, function(x) attributes(x)$label)
#'               ADLB <- ADLB %>%
#'                 dplyr::mutate(AVISITCD = dplyr::case_when(
#'                   AVISIT == 'SCREENING' ~ 'SCR',
#'                   AVISIT == 'BASELINE' ~ 'BL',
#'                   grepl('WEEK', AVISIT) ~
#'                     paste(
#'                       'W',
#'                       trimws(
#'                         substr(
#'                           AVISIT,
#'                           start = 6,
#'                           stop = stringr::str_locate(AVISIT, 'DAY') - 1
#'                         )
#'                       )
#'                     ),
#'                   TRUE ~ NA_character_)) %>%
#'                 dplyr::mutate(AVISITCDN = dplyr::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
#'                 dplyr::mutate(TRTORD = ifelse(grepl('C', ARMCD), 1,
#'                                        ifelse(grepl('B', ARMCD), 2,
#'                                               ifelse(grepl('A', ARMCD), 3, NA)))) %>%
#'                 dplyr::mutate(ARM = as.character(arm_mapping[match(ARM, names(arm_mapping))])) %>%
#'                 dplyr::mutate(ARM = factor(ARM) %>%
#'                          reorder(TRTORD)) %>%
#'                 dplyr::mutate(
#'                   ANRHI = dplyr::case_when(
#'                     PARAMCD == 'ALT' ~ 60,
#'                     PARAMCD == 'CRP' ~ 70,
#'                     PARAMCD == 'IGA' ~ 80,
#'                     TRUE ~ NA_real_
#'                   ),
#'                   ANRLO = dplyr::case_when(
#'                     PARAMCD == 'ALT' ~ 20,
#'                     PARAMCD == 'CRP' ~ 30,
#'                     PARAMCD == 'IGA' ~ 40,
#'                     TRUE ~ NA_real_
#'                   )) %>%
#'                 dplyr::rowwise() %>%
#'                 dplyr::group_by(PARAMCD) %>%
#'                 dplyr::mutate(LBSTRESC = ifelse(
#'                   USUBJID %in% sample(USUBJID, 1, replace = TRUE),
#'                   paste('<', round(runif(1, min = 25, max = 30))), LBSTRESC)) %>%
#'                 dplyr::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 <- goshawk:::h_identify_loq_values(ADLB)
#'               ADLB <- left_join(ADLB, ADLB_LOQS, by = 'PARAM')",
#'       vars = list(arm_mapping = arm_mapping)
#'     ),
#'     check = TRUE
#'   ),
#'   modules = teal::modules(
#'     teal.goshawk::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_label = 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) {
  logger::log_info("Initializing tm_g_gh_correlationplot")
  checkmate::assert_class(xaxis_param, "choices_selected")
  checkmate::assert_class(yaxis_param, "choices_selected")
  checkmate::assert_class(xaxis_var, "choices_selected")
  checkmate::assert_class(yaxis_var, "choices_selected")
  checkmate::assert_class(trt_group, "choices_selected")
  checkmate::assert_flag(trt_facet)
  validate_line_arb_arg(hline_arb, hline_arb_color, hline_arb_label)
  validate_line_arb_arg(vline_arb, vline_arb_color, vline_arb_label)
  validate_line_vars_arg(hline_vars, hline_vars_colors, hline_vars_labels)
  validate_line_vars_arg(vline_vars, vline_vars_colors, vline_vars_labels)
  checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
  checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")
  checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
  checkmate::assert_numeric(
    plot_width[1],
    lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"
  )
  checkmate::assert_numeric(font_size, len = 3)
  checkmate::assert_numeric(dot_size, len = 3)
  checkmate::assert_numeric(reg_text_size, len = 3)

  args <- as.list(environment())

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

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

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

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

  moduleServer(id, function(input, output, session) {
    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 <- teal.code::new_qenv(tdata2env(data), code = get_code_tdata(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)))
          })
        )
      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)))) {
        val <- stats::na.omit(switch(constraint_var,
          "BASE" = ANL$BASE[ANL$AVISITCD == "BL"],
          "BASE2" = ANL$BASE2[ANL$AVISITCD == "SCR"],
          stop(paste(constraint_var, "not allowed"))
        ))

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

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

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

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

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

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

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

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

    # update sliders for axes taking constraints into account
    xrange_slider <- toggle_slider_server("xrange_scale")
    yrange_slider <- toggle_slider_server("yrange_scale")
    keep_range_slider_updated(session, input, xrange_slider$update_state, "xaxis_var", "xaxis_param", anl_constraint)
    keep_range_slider_updated(session, input, yrange_slider$update_state, "yaxis_var", "yaxis_param", anl_constraint)
    keep_data_const_opts_updated(session, input, anl_constraint, "xaxis_param")

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

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

      req(anl_constraint())
      ANL <- anl_constraint()$ANL # nolint
      trt_group <- input$trt_group
      line_vars <- unique(c(input$hline_vars, input$vline_vars))

      private_q <- anl_constraint()$qenv %>% teal.code::eval_code(
        code = bquote({
          ANL_TRANSPOSED1 <- ANL %>% # nolint
            dplyr::select(
              .data[["USUBJID"]],
              .data[[.(trt_group)]],
              .data[["AVISITCD"]],
              .data[[.(param_var)]],
              .data[[.(input$xaxis_var)]],
              .data[[.(input$yaxis_var)]],
              .(`if`(length(line_vars) == 0, NULL, line_vars))
            ) %>%
            tidyr::pivot_longer(
              c(
                .data[[.(input$xaxis_var)]],
                .data[[.(input$yaxis_var)]],
                .(`if`(length(line_vars) == 0, NULL, line_vars))
              ),
              names_to = "ANLVARS",
              values_to = "ANLVALS"
            ) %>%
            tidyr::unite(
              "ANL.PARAM",
              "ANLVARS",
              .(param_var),
              sep = ".",
              remove = TRUE
            ) %>%
            tidyr::pivot_wider(names_from = "ANL.PARAM", values_from = "ANLVALS") %>%
            dplyr::filter(!is.na(.data[[.(xvar())]]) & !is.na(.data[[.(yvar())]]))

          ANL_TRANSPOSED2 <- ANL %>% # nolint
            dplyr::select(
              .data[["USUBJID"]],
              .data[[.(trt_group)]],
              .data[["AVISITCD"]],
              .data[[.(param_var)]],
              .data[["LOQFL"]],
              .data[["PARAM"]],
              .data[["LBSTRESC"]]
            ) %>%
            tidyr::pivot_longer(
              c(
                .data[["LOQFL"]],
                .data[["PARAM"]],
                .data[["LBSTRESC"]]
              ),
              names_to = "ANLVARS",
              values_to = "ANLVALS"
            ) %>%
            tidyr::unite(
              "ANL.PARAM",
              "ANLVARS",
              .(param_var),
              sep = "_",
              remove = TRUE
            ) %>%
            tidyr::pivot_wider(names_from = "ANL.PARAM", values_from = "ANLVALS") %>%
            dplyr::mutate(LOQFL_COMB = dplyr::case_when(
              .data[[.(xloqfl())]] == "Y" | .data[[.(yloqfl())]] == "Y" ~ "Y",
              .data[[.(xloqfl())]] == "N" & .data[[.(yloqfl())]] == "N" ~ "N",
              .data[[.(xloqfl())]] == "N" & .data[[.(yloqfl())]] == "NA" ~ "N",
              .data[[.(xloqfl())]] == "NA" & .data[[.(yloqfl())]] == "N" ~ "N",
              .data[[.(xloqfl())]] == "NA" & .data[[.(yloqfl())]] == "NA" ~ "NA",
              TRUE ~ as.character(NA)
            ))

          ANL_TRANSPOSED <- merge(ANL_TRANSPOSED1, ANL_TRANSPOSED2) # nolint
        })
      )

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

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

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

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

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

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

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

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

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

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

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

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


    ### REPORTER
    if (with_reporter) {
      card_fun <- function(comment) {
        card <- teal::TealReportCard$new()
        card$set_name("Correlation Plot")
        card$append_text("Correlation Plot", "header2")
        if (with_filter) card$append_fs(filter_panel_api$get_filter_state())
        card$append_text("Selected Options", "header3")
        card$append_text(
          paste(
            formatted_data_constraint(input$constraint_var, input$constraint_range_min, input$constraint_range_max),
            "\nTreatment Variable Faceting:",
            input$trt_facet,
            "\nRegression Line:",
            input$reg_line
          ),
          style = "verbatim"
        )
        card$append_text("Plot", "header3")
        card$append_plot(plot_r(), dim = plot_data$dim())
        if (!comment == "") {
          card$append_text("Comment", "header3")
          card$append_text(comment)
        }
        card$append_src(paste(teal.code::get_code(plot_q()), collapse = "\n"))
        card
      }
      teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
    }
    ###

    # highlight plot area
    output$brush_data <- DT::renderDataTable({
      req(iv_r()$is_valid())
      plot_brush <- plot_data$brush()

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

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

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

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

    teal.widgets::verbatim_popup_srv(
      id = "warning",
      verbatim_content = reactive(teal.code::get_warnings(plot_q())),
      title = "Warning",
      disabled = reactive(is.null(teal.code::get_warnings(plot_q())))
    )

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

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

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

    # we need id_param_var (e.g. ALT) to filter down because the y-axis may have a different
    # param var and the range of id_var (e.g. BASE) values may be larger due to this
    # therefore, we need to filter
    ANL <- reactive_ANL()$ANL %>% dplyr::filter(.data$PARAMCD == paramname) # nolint
    validate_has_variable(ANL, varname, paste("variable", varname, "does not exist"))

    var <- stats::na.omit(ANL[[varname]])
    minmax <- if (length(var)) c(floor(min(var)), ceiling(max(var))) else c(0, 0)
    step <- NULL

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

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

#' Density Distribution Plot
#'
#' This teal module renders the UI and calls the functions that create a density distribution plot
#' and an accompanying summary table.
#'
#' @param label menu item label of the module in the teal app.
#' @param trt_group \code{\link[teal.transform]{choices_selected}} object with available choices and pre-selected option
#' for variable names representing treatment group e.g. `ARM`.
#' @param color_manual vector of colors applied to treatment values.
#' @param color_comb name or hex value for combined treatment color.
#' @param plot_height controls plot height.
#' @param plot_width optional, controls plot width.
#' @param font_size font size control for title, `x-axis` label, `y-axis` label and legend.
#' @param line_size plot line thickness.
#' @param hline_arb numeric vector of at most 2 values identifying intercepts for arbitrary horizontal lines.
#' @param hline_arb_color a character vector of at most length of \code{hline_arb}.
#' naming the color for the arbitrary horizontal lines.
#' @param hline_arb_label a character vector of at most length of \code{hline_arb}.
#' naming the label for the arbitrary horizontal lines.
#' @param facet_ncol numeric value indicating number of facets per row.
#' @param comb_line display combined treatment line toggle.
#' @param rotate_xlab 45 degree rotation of `x-axis` values.
#'
#' @inheritParams teal.widgets::standard_layout
#' @inheritParams tm_g_gh_scatterplot
#'
#'
#' @author Nick Paszty (npaszty) paszty.nicholas@gene.com
#' @author Balazs Toth (tothb2)  toth.balazs@gene.com
#'
#' @details None
#'
#' @export
#'
#' @examples
#'
#' # Example using ADaM structure analysis dataset.
#'
#' library(dplyr)
#'
#' # original ARM value = dose value
#' arm_mapping <- list(
#'   "A: Drug X" = "150mg QD",
#'   "B: Placebo" = "Placebo",
#'   "C: Combination" = "Combination"
#' )
#' ADSL <- goshawk::rADSL
#' ADLB <- goshawk::rADLB
#' var_labels <- lapply(ADLB, function(x) attributes(x)$label)
#' ADLB <- ADLB %>%
#'   dplyr::mutate(
#'     AVISITCD = dplyr::case_when(
#'       AVISIT == "SCREENING" ~ "SCR",
#'       AVISIT == "BASELINE" ~ "BL",
#'       grepl("WEEK", AVISIT) ~ paste("W", stringr::str_extract(AVISIT, "(?<=(WEEK ))[0-9]+")),
#'       TRUE ~ as.character(NA)
#'     ),
#'     AVISITCDN = dplyr::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 = dplyr::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"]]
#'
#' app <- teal::init(
#'   data = teal.data::cdisc_data(
#'     teal.data::cdisc_dataset("ADSL", ADSL, code = "ADSL <- goshawk::rADSL"),
#'     teal.data::cdisc_dataset(
#'       "ADLB",
#'       ADLB,
#'       code = "ADLB <- goshawk::rADLB
#'               var_labels <- lapply(ADLB, function(x) attributes(x)$label)
#'               ADLB <- ADLB %>%
#'                 dplyr::mutate(AVISITCD = dplyr::case_when(
#'                     AVISIT == 'SCREENING' ~ 'SCR',
#'                     AVISIT == 'BASELINE' ~ 'BL',
#'                     grepl('WEEK', AVISIT) ~
#'                       paste('W', stringr::str_extract(AVISIT, '(?<=(WEEK ))[0-9]+')),
#'                     TRUE ~ as.character(NA)),
#'                   AVISITCDN = dplyr::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 = dplyr::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']]",
#'       vars = list(arm_mapping = arm_mapping)
#'     ),
#'     check = TRUE
#'   ),
#'   modules = teal::modules(
#'     teal.goshawk::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) {
  logger::log_info("Initializing tm_g_gh_density_distribution_plot")
  checkmate::assert_string(label)
  checkmate::assert_string(dataname)
  checkmate::assert_string(param_var)
  checkmate::assert_class(param, "choices_selected")
  checkmate::assert_class(xaxis_var, "choices_selected")
  checkmate::assert_class(trt_group, "choices_selected")
  checkmate::assert_numeric(font_size, len = 3)
  checkmate::assert_numeric(line_size, len = 3)
  checkmate::assert_int(facet_ncol)
  checkmate::assert_flag(comb_line)
  checkmate::assert_flag(rotate_xlab)
  validate_line_arb_arg(hline_arb, hline_arb_color, hline_arb_label)
  checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
  checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")
  checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
  checkmate::assert_numeric(
    plot_width[1],
    lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"
  )

  args <- as.list(environment())

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

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

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

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

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

    anl_q <- anl_q_output()$value

    # update sliders for axes taking constraints into account
    xrange_slider <- toggle_slider_server("xrange_scale")
    yrange_slider <- toggle_slider_server("yrange_scale")
    keep_range_slider_updated(session, input, xrange_slider$update_state, "xaxis_var", "xaxis_param", anl_q)
    keep_range_slider_updated(
      session,
      input,
      yrange_slider$update_state,
      "xaxis_var",
      "xaxis_param",
      anl_q,
      is_density = TRUE
    )
    keep_data_const_opts_updated(session, input, anl_q, "xaxis_param")

    horizontal_line <- srv_arbitrary_lines("hline_arb")

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

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

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


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

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

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


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

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

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

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

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

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

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

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

    teal.widgets::verbatim_popup_srv(
      id = "warning",
      verbatim_content = reactive(teal.code::get_warnings(joined_qenvs())),
      title = "Warning",
      disabled = reactive(is.null(teal.code::get_warnings(joined_qenvs())))
    )

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

    ### REPORTER
    if (with_reporter) {
      card_fun <- function(comment) {
        card <- teal::TealReportCard$new()
        card$set_name("Density Distribution Plot")
        card$append_text("Density Distribution Plot", "header2")
        if (with_filter) card$append_fs(filter_panel_api$get_filter_state())
        card$append_text("Selected Options", "header3")
        card$append_text(
          formatted_data_constraint(input$constraint_var, input$constraint_range_min, input$constraint_range_max)
        )
        card$append_text("Plot", "header3")
        card$append_plot(plot_r(), dim = plot_data$dim())
        card$append_text("Descriptive Statistics", "header3")
        card$append_table(
          create_table()[["tbl"]] %>% dplyr::mutate_if(is.numeric, round, 2)
        )
        if (!comment == "") {
          card$append_text("Comment", "header3")
          card$append_text(comment)
        }
        card$append_src(
          paste(
            teal.code::get_code(
              teal.code::join(create_plot(), create_table())
            ),
            collapse = "\n"
          )
        )
        card
      }
      teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
    }
    ###
  })
}

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

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

  args <- as.list(environment())

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

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

  teal.widgets::standard_layout(
    output = templ_ui_output_datatable(ns),
    encoding = div(
      ### Reporter
      teal.reporter::simple_reporter_ui(ns("simple_reporter")),
      ###
      templ_ui_dataname(a$dataname),
      teal.widgets::optionalSelectInput(
        ns("trt_group"),
        label = "Select Treatment Variable",
        choices = a$trt_group$choices,
        selected = a$trt_group$selected,
        multiple = FALSE
      ),
      templ_ui_params_vars(
        ns,
        # xparam and yparam are identical, so we only show the user one
        xparam_choices = a$param$choices, xparam_selected = a$param$selected, xparam_label = "Select a Biomarker",
        xchoices = a$xaxis_var$choices, xselected = a$xaxis_var$selected,
        ychoices = a$yaxis_var$choices, yselected = a$yaxis_var$selected
      ),
      templ_ui_constraint(ns), # required by constr_anl_q
      teal.widgets::panel_group(
        teal.widgets::panel_item(
          title = "Plot Aesthetic Settings",
          toggle_slider_ui(ns("xrange_scale"),
            label = "X-Axis Range Zoom",
            min = -1000000,
            max = 1000000,
            value = c(-1000000, 1000000)
          ),
          toggle_slider_ui(ns("yrange_scale"),
            label = "Y-Axis Range Zoom",
            min = -1000000,
            max = 1000000,
            value = c(-1000000, 1000000)
          ),
          numericInput(ns("facet_ncol"), "Number of Plots Per Row:", a$facet_ncol, min = 1),
          checkboxInput(ns("trt_facet"), "Treatment Variable Faceting", a$trt_facet),
          checkboxInput(ns("reg_line"), "Regression Line", a$reg_line),
          checkboxInput(ns("rotate_xlab"), "Rotate X-axis Label", a$rotate_xlab),
          numericInput(ns("hline"), "Add a horizontal line:", a$hline),
          numericInput(ns("vline"), "Add a vertical line:", a$vline)
        ),
        teal.widgets::panel_item(
          title = "Plot settings",
          teal.widgets::optionalSliderInputValMinMax(ns("font_size"), "Font Size", a$font_size, ticks = FALSE),
          teal.widgets::optionalSliderInputValMinMax(ns("dot_size"), "Dot Size", a$dot_size, ticks = FALSE),
          teal.widgets::optionalSliderInputValMinMax(
            ns("reg_text_size"),
            "Regression Annotations Size",
            a$reg_text_size,
            ticks = FALSE
          )
        )
      )
    ),
    forms = tagList(
      teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
      teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
    ),
    pre_output = a$pre_output,
    post_output = a$post_output
  )
}

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

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

    anl_q <- anl_q_output()$value

    # update sliders for axes taking constraints into account
    xrange_slider <- toggle_slider_server("xrange_scale")
    yrange_slider <- toggle_slider_server("yrange_scale")
    keep_range_slider_updated(session, input, xrange_slider$update_state, "xaxis_var", "xaxis_param", anl_q)
    keep_range_slider_updated(session, input, yrange_slider$update_state, "yaxis_var", "xaxis_param", anl_q)
    keep_data_const_opts_updated(session, input, anl_q, "xaxis_param")

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

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

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

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

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

    ### REPORTER
    if (with_reporter) {
      card_fun <- function(comment) {
        card <- teal::TealReportCard$new()
        card$set_name("Scatter Plot")
        card$append_text("Scatter Plot", "header2")
        if (with_filter) card$append_fs(filter_panel_api$get_filter_state())
        card$append_text("Selected Options", "header3")
        card$append_text(
          paste(
            formatted_data_constraint(input$constraint_var, input$constraint_range_min, input$constraint_range_max),
            "\nTreatment Variable Faceting:",
            input$trt_facet,
            "\nRegression Line:",
            input$reg_line
          ),
          style = "verbatim"
        )
        card$append_text("Scatter Plot", "header3")
        card$append_plot(plot_r(), dim = plot_data$dim())
        if (!comment == "") {
          card$append_text("Comment", "header3")
          card$append_text(comment)
        }
        card$append_src(paste(teal.code::get_code(plot_q()), collapse = "\n"))
        card
      }
      teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
    }
    ###

    # highlight plot area
    output$brush_data <- DT::renderDataTable({
      plot_brush <- plot_data$brush()

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

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

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

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

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

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

    teal.widgets::verbatim_popup_srv(
      id = "warning",
      verbatim_content = reactive(teal.code::get_warnings(plot_q())),
      title = "Warning",
      disabled = reactive(is.null(teal.code::get_warnings(plot_q())))
    )

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

#' UI with a toggleable slider to change between slider and numeric input fields
#'
#' This is useful when a slider should be shown, but it is sometimes hard to configure sliders,
#' so one can toggle to one or two numeric input fields to set slider instead.
#' Both normal sliders (for a single number in a range) and dichotomous sliders (for a range
#' within the slider range) are supported. In the former case, the toggle button
#' will show one numeric input field, in the latter case two.
#'
#' Value is not checked to be within minmax range
#'
#' @md
#' @param id `character` module id
#' @param label `label` label for input field, e.g. slider or numeric inputs
#' @param min `numeric or integer` minimum value
#' @param max `numeric or integer` maximum value
#' @param value `numeric or integer` either of length 1 for normal slider or of
#'   length 2 for dichotomous slider.
#' @param slider_initially `logical` whether to show slider or numeric fields
#'   initially
#' @param step_slider `numeric or integer` step for slider
#' @param step_numeric `numeric or integer` step for numeric input fields
#' @param width `numeric` width of slider or of each numeric field
#' @param ... additional parameters to pass to `sliderInput`
#'
#' @return Shiny HTML UI
#' @keywords internal
#'
#' @examples
#' value <- c(20.3, 81.5) # dichotomous slider
#' # value <- c(50.1) # normal slider
#' app <- shinyApp(
#'   ui = div(
#'     teal.goshawk:::toggle_slider_ui(
#'       "toggle_slider", "Select value",
#'       min = 0.2, max = 100.1, value = value,
#'       slider_initially = FALSE, step_slider = 0.1, step_numeric = 0.001
#'     ),
#'     verbatimTextOutput("value")
#'   ),
#'   server = function(input, output, session) {
#'     is_dichotomous_slider <- (length(value) == 2)
#'     range_value <- toggle_slider_server("toggle_slider",
#'       is_dichotomous_slider = is_dichotomous_slider
#'     )
#'     messages <- reactiveVal() # to keep history
#'     observeEvent(range_value$state(), {
#'       list_with_names_str <- function(x) paste(names(x), x, sep = ": ", collapse = ", ")
#'       messages(c(messages(), list_with_names_str(range_value$state())))
#'     })
#'     output$value <- renderText({
#'       paste(messages(), collapse = "\n")
#'     })
#'
#'     # for stress-testing example, update slider settings
#'     # bug with invalidateLater not working inside `observeEvent`
#'     # observe({
#'     #   invalidateLater(1000, session)
#'     #   a <- sample(0:100, 1) # for range
#'     #   b <- sample(0:100, 1)
#'     #   isolate(do.call(
#'     #     range_value$update_state,
#'     #     list(
#'     #       value = sort(sample(0:100, if (is_dichotomous_slider) 2 else 1)),
#'     #       min = min(a, b), max = max(a, b),
#'     #       step = sample(1:20, 1) / 10
#'     #     )[sample(1:4, sample(4, 1))] # select up to four fields from the list
#'     #   ))
#'     # })
#'   }
#' )
#' shinyApp(app$ui, app$server) %>% invisible()
toggle_slider_ui <- function(id,
                             label,
                             min,
                             max,
                             value,
                             slider_initially = TRUE,
                             step_slider = NULL,
                             step_numeric = step_slider,
                             width = NULL,
                             ...) {
  checkmate::assert_number(min)
  checkmate::assert_number(max)
  checkmate::assert_flag(slider_initially)
  checkmate::assert_number(step_slider, null.ok = TRUE)
  checkmate::assert_number(step_numeric, null.ok = TRUE)
  checkmate::assert_numeric(value, min.len = 1, max.len = 2)
  if (is.null(step_numeric)) {
    step_numeric <- NA # numericInput does not support NULL
  }

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

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


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

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

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

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

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

#' 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)
  div(
    tags$b(title),
    textInput(
      ns("line_arb"),
      div(
        class = "teal-tooltip",
        tagList(
          "Value:",
          icon("circle-info"),
          span(
            class = "tooltiptext",
            "For multiple lines, supply a comma separated list of values."
          )
        )
      ),
      value = paste(line_arb, collapse = ", ")
    ),
    textInput(ns("line_arb_label"), label = "Label:", value = paste(line_arb_label, collapse = ", ")),
    textInput(ns("line_arb_color"), label = "Color:", value = paste(line_arb_color, collapse = ", "))
  )
}
#' Server module to arbitrary lines
#'
#' Server to validate and transform the comma separated values into vectors of values
#' to be passed into goshawk functions.
#' @inheritParams shiny::moduleServer
#' @return (`reactive`) returning a `list` containing `line_arb`, `line_arb_color`,
#'  `line_arb_label` which are validated and could be passed to `goshawk` plot functions.
#' @keywords internal
srv_arbitrary_lines <- function(id) {
  moduleServer(id, function(input, output, session) {

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

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

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

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


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

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

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

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

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

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

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

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

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

#' Box Plot
#'
#' This teal module renders the UI and calls the functions that create a box plot and accompanying
#' summary table.
#'
#' @param label menu item label of the module in the teal app.
#' @param dataname analysis data passed to the data argument of \code{\link[teal]{init}}. E.g. `ADaM` structured
#'  laboratory data frame `ALB`.
#' @param param_var name of variable containing biomarker codes e.g. `PARAMCD`.
#' @param param list of biomarkers of interest.
#' @param yaxis_var name of variable containing biomarker results displayed on y-axis e.g. `AVAL`. When not provided,
#' it defaults to `choices_selected(c("AVAL", "CHG"), "AVAL")`.
#' @param xaxis_var variable to categorize the x-axis. When not provided, it defaults to
#' `choices_selected("AVISITCD", "AVISITCD")`.
#' @param facet_var variable to facet the plots by. When not provided, it defaults to
#' `choices_selected(c("ARM", "ACTARM"), "ARM")`.
#' @param trt_group  \code{\link[teal.transform]{choices_selected}} object with available choices and pre-selected
#'  option for variable names representing treatment group e.g. `ARM`.
#' @param color_manual vector of colors applied to treatment values.
#' @param shape_manual vector of symbols applied to `LOQ` values.
#' @param facet_ncol numeric value indicating number of facets per row.
#' @param loq_legend `loq` legend toggle.
#' @param rotate_xlab 45 degree rotation of `x-axis` values.
#' @param hline_arb numeric vector of at most 2 values identifying intercepts for arbitrary horizontal lines.
#' @param hline_arb_color a character vector of at most length of \code{hline_arb}.
#' naming the color for the arbitrary horizontal lines.
#' @param hline_arb_label a character vector of at most length of \code{hline_arb}.
#' naming the label for the arbitrary horizontal lines.
#' @param hline_vars a character vector to name the columns that will define additional horizontal lines.
#' @param hline_vars_colors a character vector naming the colors for the additional horizontal lines.
#' @param hline_vars_labels a character vector naming the labels for the additional horizontal lines that will appear
#'  in the legend.
#' @param plot_height controls plot height.
#' @param plot_width optional, controls plot width.
#' @param font_size font size control for title, `x-axis` label, `y-axis` label and legend.
#' @param dot_size plot dot size.
#' @param alpha numeric vector to define transparency of plotted points.
#'
#' @inheritParams teal.widgets::standard_layout
#'
#' @author Jeff Tomlinson (tomlinsj) jeffrey.tomlinson@roche.com
#' @author Balazs Toth (tothb2) toth.balazs@gene.com
#'
#' @return an \code{\link[teal]{module}} object
#'
#' @export
#'
#' @examples
#'
#' # Example using ADaM structure analysis dataset.
#'
#' library(dplyr)
#' library(nestcolor)
#'
#' # original ARM value = dose value
#' arm_mapping <- list(
#'   "A: Drug X" = "150mg QD",
#'   "B: Placebo" = "Placebo",
#'   "C: Combination" = "Combination"
#' )
#'
#' set.seed(1)
#' ADSL <- goshawk::rADSL
#' ADLB <- goshawk::rADLB
#' var_labels <- lapply(ADLB, function(x) attributes(x)$label)
#' ADLB <- ADLB %>%
#'   dplyr::mutate(
#'     AVISITCD = dplyr::case_when(
#'       AVISIT == "SCREENING" ~ "SCR",
#'       AVISIT == "BASELINE" ~ "BL",
#'       grepl("WEEK", AVISIT) ~ paste("W", stringr::str_extract(AVISIT, "(?<=(WEEK ))[0-9]+")),
#'       TRUE ~ as.character(NA)
#'     ),
#'     AVISITCDN = dplyr::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 = dplyr::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
#'   ) %>%
#'   dplyr::rowwise() %>%
#'   dplyr::group_by(PARAMCD) %>%
#'   dplyr::mutate(LBSTRESC = ifelse(
#'     USUBJID %in% sample(USUBJID, 1, replace = TRUE),
#'     paste("<", round(runif(1, min = 25, max = 30))), LBSTRESC
#'   )) %>%
#'   dplyr::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 <- goshawk:::h_identify_loq_values(ADLB)
#' ADLB <- dplyr::left_join(ADLB, ALB_LOQS, by = "PARAM")
#'
#' app <- teal::init(
#'   data = teal.data::cdisc_data(
#'     adsl <- teal.data::cdisc_dataset("ADSL", ADSL, code = "ADSL <- goshawk::rADSL"),
#'     teal.data::cdisc_dataset(
#'       "ADLB",
#'       ADLB,
#'       code = "
#'         set.seed(1)
#'         ADLB <- goshawk::rADLB
#'         var_labels <- lapply(ADLB, function(x) attributes(x)$label)
#'         ADLB <- ADLB %>%
#'           dplyr::mutate(AVISITCD = dplyr::case_when(
#'             AVISIT == 'SCREENING' ~ 'SCR',
#'             AVISIT == 'BASELINE' ~ 'BL',
#'             grepl('WEEK', AVISIT) ~ paste('W', stringr::str_extract(AVISIT, '(?<=(WEEK ))[0-9]+')),
#'             TRUE ~ as.character(NA)),
#'             AVISITCDN = dplyr::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 = dplyr::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) %>%
#'           dplyr::rowwise() %>%
#'           dplyr::group_by(PARAMCD) %>%
#'           dplyr::mutate(LBSTRESC = ifelse(
#'             USUBJID %in% sample(USUBJID, 1, replace = TRUE),
#'             paste('<', round(runif(1, min = 25, max = 30))), LBSTRESC)) %>%
#'           dplyr::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 <- goshawk:::h_identify_loq_values(ADLB)
#'         ADLB <- left_join(ADLB, ALB_LOQS, by = 'PARAM')",
#'       vars = list(ADSL = adsl, arm_mapping = arm_mapping)
#'     ),
#'     check = FALSE # to shorten the example check = FALSE, in real scenarios use check = TRUE
#'   ),
#'   modules = teal::modules(
#'     teal.goshawk::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) {
  logger::log_info("Initializing tm_g_gh_boxplot")
  checkmate::assert_string(label)
  checkmate::assert_string(dataname)
  checkmate::assert_string(param_var)
  checkmate::assert_class(param, "choices_selected")
  checkmate::assert_class(yaxis_var, "choices_selected")
  checkmate::assert_class(xaxis_var, "choices_selected")
  checkmate::assert_class(facet_var, "choices_selected")
  checkmate::assert_class(trt_group, "choices_selected")
  checkmate::assert_int(facet_ncol, null.ok = TRUE)
  checkmate::assert_flag(loq_legend)
  checkmate::assert_flag(rotate_xlab)
  checkmate::assert_numeric(font_size, len = 3)
  checkmate::assert_numeric(dot_size, len = 3)
  checkmate::assert_numeric(alpha, len = 3)
  validate_line_arb_arg(hline_arb, hline_arb_color, hline_arb_label)
  validate_line_vars_arg(hline_vars, hline_vars_colors, hline_vars_labels)
  checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
  checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")
  checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
  checkmate::assert_numeric(
    plot_width[1],
    lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"
  )

  args <- as.list(environment())

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

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

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


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

  moduleServer(id, function(input, output, session) {
    # reused in all modules
    anl_q_output <- constr_anl_q(
      session, input, data, dataname,
      param_id = "xaxis_param", param_var = param_var, trt_group = input$trt_group, min_rows = 2
    )

    anl_q <- anl_q_output()$value

    # update sliders for axes taking constraints into account
    yrange_slider <- toggle_slider_server("yrange_scale")
    keep_range_slider_updated(
      session,
      input,
      update_slider_fcn = yrange_slider$update_state,
      id_var = "yaxis_var",
      id_param_var = "xaxis_param",
      reactive_ANL = anl_q
    )
    keep_data_const_opts_updated(session, input, anl_q, "xaxis_param")

    horizontal_line <- srv_arbitrary_lines("hline_arb")

    trt_group <- reactive({
      input$trt_group
    })

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    ### REPORTER
    if (with_reporter) {
      card_fun <- function(comment) {
        card <- teal::TealReportCard$new()
        card$set_name("Box Plot")
        card$append_text("Box Plot", "header2")
        if (with_filter) card$append_fs(filter_panel_api$get_filter_state())
        card$append_text("Selected Options", "header3")
        card$append_text(
          paste(
            formatted_data_constraint(input$constraint_var, input$constraint_range_min, input$constraint_range_max),
            "\nFacet By:",
            if (length(input$facet_var) != 0) input$facet_var else "None",
            "\nSelect an X-axis Variable:",
            input$xaxis_var
          ),
          style = "verbatim"
        )
        card$append_text("Plot", "header3")
        card$append_plot(plot_r(), dim = boxplot_data$dim())
        if (!comment == "") {
          card$append_text("Comment", "header3")
          card$append_text(comment)
        }
        card$append_src(
          paste(
            teal.code::get_code(
              teal.code::join(create_plot(), create_table())
            ),
            collapse = "\n"
          )
        )
        card
      }
      teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
    }
    ###

    # highlight plot area
    output$brush_data <- DT::renderDataTable({
      boxplot_brush <- boxplot_data$brush()

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

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

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

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

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

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

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

    teal.widgets::verbatim_popup_srv(
      id = "warning",
      verbatim_content = reactive(teal.code::get_warnings(joined_qenvs())),
      title = "Warning",
      disabled = reactive(is.null(teal.code::get_warnings(joined_qenvs())))
    )

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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		#'
17		#' ADSL <- goshawk::rADSL
18		#'
19		#' # get treatment mapping code
20		#' maptrt(df_armvar = ADSL$ARMCD, code = "M")
21		#'
22		#' # get treatment ordering code
23		#' maptrt(df_armvar = ADSL$ARMCD, code = "O")
24		maptrt <- function(df_armvar, code = c("M", "O")) {
25	!	code <- match.arg(code)
26
27		# get arm variable
28	!	trtvar <- strsplit(deparse(substitute(df_armvar)), "[$]")[[1]][2]
29
30	!	dftrt <- data.frame(unique(df_armvar)) %>%
31	!	dplyr::mutate(trt_mapping = paste0("\"", unique(df_armvar), "\"", " = \"\",")) %>%
32	!	dplyr::mutate(trt_ordering = paste0(eval(trtvar), " == \"", unique(df_armvar), "\"", " ~ ,"))
33
34	!	if (toupper(code) == "M") {
35	!	print(unname(dftrt["trt_mapping"]), row.names = FALSE)
36	!	} else if (toupper(code) == "O") {
37	!	print(unname(dftrt["trt_ordering"]), row.names = FALSE)
38		}
39		}

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

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

1		#' Include `CSS` files from `/inst/css/` package directory to application header
2		#'
3		#' `system.file` should not be used to access files in other packages, it does
4		#' not work with `devtools`. Therefore, we redefine this method in each package
5		#' as needed. Thus, we do not export this method.
6		#'
7		#' @param pattern (`character`) pattern of files to be included
8		#'
9		#' @return HTML code that includes `CSS` files
10		#' @keywords internal
11		include_css_files <- function(pattern = "*") {
12	!	css_files <- list.files(
13	!	system.file("css", package = "teal.goshawk", mustWork = TRUE),
14	!	pattern = pattern, full.names = TRUE
15		)
16	!	if (length(css_files) == 0) {
17	!	return(NULL)
18		}
19	!	return(shiny::singleton(shiny::tags$head(lapply(css_files, shiny::includeCSS))))
20		}
21
22		plots_per_row_validate_rules <- function(required = TRUE) {
23	!	msg <- "Number of plots per row must be a positive integer"
24	!	shinyvalidate::compose_rules(
25	!	if (required) {
26	!	shinyvalidate::sv_required(msg)
27		} else {
28	!	shinyvalidate::sv_optional()
29		},
30	!	shinyvalidate::sv_integer(msg),
31	!	shinyvalidate::sv_gt(0, message_fmt = msg)
32		)
33		}