Movatterモバイル変換

teal.modules.general coverage - 4.84%

#' `teal` module: Cross-table
#'
#' Generates a simple cross-table of two variables from a dataset with custom
#' options for showing percentages and sub-totals.
#'
#' @inheritParams teal::module
#' @inheritParams shared_params
#' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`)
#' Object with all available choices with pre-selected option for variable X - row values.
#' In case of `data_extract_spec` use `select_spec(..., ordered = TRUE)` if table elements should be
#' rendered according to selection order.
#' @param y (`data_extract_spec` or `list` of multiple `data_extract_spec`)
#' Object with all available choices with pre-selected option for variable Y - column values.
#'
#' `data_extract_spec` must not allow multiple selection in this case.
#' @param show_percentage (`logical(1)`)
#' Indicates whether to show percentages (relevant only when `x` is a `factor`).
#' Defaults to `TRUE`.
#' @param show_total (`logical(1)`)
#' Indicates whether to show total column.
#' Defaults to `TRUE`.
#' @param remove_zero_columns (`logical(1)`)
#' Indicates whether to remove columns that contain only zeros from the output table.
#' Defaults to `FALSE`.
#'
#' @note For more examples, please see the vignette "Using cross table" via
#' `vignette("using-cross-table", package = "teal.modules.general")`.
#'
#' @inherit shared_params return
#'
#' @section Table Settings:
#' The module provides several table settings that can be adjusted:
#' \itemize{
#'   \item \code{Show column percentage}: Shows column percentages when enabled
#'   \item \code{Show total column}: Shows a total column when enabled
#'   \item \code{Remove zero-only columns}: Removes columns that contain only zeros from the output table
#' }
#'
#' @section Decorating Module:
#'
#' This module generates the following objects, which can be modified in place using decorators:
#' - `table` (`ElementaryTable` - output of `rtables::build_table`)
#'
#' A Decorator is applied to the specific output using a named list of `teal_transform_module` objects.
#' The name of this list corresponds to the name of the output to which the decorator is applied.
#' See code snippet below:
#'
#' ```
#' tm_t_crosstable(
#'    ..., # arguments for module
#'    decorators = list(
#'      table = teal_transform_module(...) # applied to the `table` output
#'    )
#' )
#' ```
#' For additional details and examples of decorators, refer to the vignette
#' `vignette("decorate-module-output", package = "teal.modules.general")`.
#'
#' To learn more please refer to the vignette
#' `vignette("transform-module-output", package = "teal")` or the [`teal::teal_transform_module()`] documentation.
#'
#' @inheritSection teal::example_module Reporting
#'
#' @examplesShinylive
#' library(teal.modules.general)
#' interactive <- function() TRUE
#' {{ next_example }}
#' @examples
#' # general data example
#' data <- teal_data()
#' data <- within(data, {
#'   mtcars <- mtcars
#'   for (v in c("cyl", "vs", "am", "gear")) {
#'     mtcars[[v]] <- as.factor(mtcars[[v]])
#'   }
#'   mtcars[["primary_key"]] <- seq_len(nrow(mtcars))
#' })
#' join_keys(data) <- join_keys(join_key("mtcars", "mtcars", "primary_key"))
#'
#' app <- init(
#'   data = data,
#'   modules = modules(
#'     tm_t_crosstable(
#'       label = "Cross Table",
#'       x = data_extract_spec(
#'         dataname = "mtcars",
#'         select = select_spec(
#'           label = "Select variable:",
#'           choices = variable_choices(data[["mtcars"]], c("cyl", "vs", "am", "gear")),
#'           selected = c("cyl", "gear"),
#'           multiple = TRUE,
#'           ordered = TRUE,
#'           fixed = FALSE
#'         )
#'       ),
#'       y = data_extract_spec(
#'         dataname = "mtcars",
#'         select = select_spec(
#'           label = "Select variable:",
#'           choices = variable_choices(data[["mtcars"]], c("cyl", "vs", "am", "gear")),
#'           selected = "vs",
#'           multiple = FALSE,
#'           fixed = FALSE
#'         )
#'       )
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
#' @examplesShinylive
#' library(teal.modules.general)
#' interactive <- function() TRUE
#' {{ next_example }}
#' @examples
#' # CDISC data example
#' data <- teal_data()
#' data <- within(data, {
#'   ADSL <- teal.data::rADSL
#' })
#' join_keys(data) <- default_cdisc_join_keys[names(data)]
#'
#' app <- init(
#'   data = data,
#'   modules = modules(
#'     tm_t_crosstable(
#'       label = "Cross Table",
#'       x = data_extract_spec(
#'         dataname = "ADSL",
#'         select = select_spec(
#'           label = "Select variable:",
#'           choices = variable_choices(data[["ADSL"]], subset = function(data) {
#'             idx <- !vapply(data, inherits, logical(1), c("Date", "POSIXct", "POSIXlt"))
#'             return(names(data)[idx])
#'           }),
#'           selected = "COUNTRY",
#'           multiple = TRUE,
#'           ordered = TRUE,
#'           fixed = FALSE
#'         )
#'       ),
#'       y = data_extract_spec(
#'         dataname = "ADSL",
#'         select = select_spec(
#'           label = "Select variable:",
#'           choices = variable_choices(data[["ADSL"]], subset = function(data) {
#'             idx <- vapply(data, is.factor, logical(1))
#'             return(names(data)[idx])
#'           }),
#'           selected = "SEX",
#'           multiple = FALSE,
#'           fixed = FALSE
#'         )
#'       )
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
#' @export
#'
tm_t_crosstable <- function(label = "Cross Table",
                            x,
                            y,
                            show_percentage = TRUE,
                            show_total = TRUE,
                            remove_zero_columns = FALSE,
                            pre_output = NULL,
                            post_output = NULL,
                            basic_table_args = teal.widgets::basic_table_args(),
                            transformators = list(),
                            decorators = list()) {
  message("Initializing tm_t_crosstable")

  # Normalize the parameters
  if (inherits(x, "data_extract_spec")) x <- list(x)
  if (inherits(y, "data_extract_spec")) y <- list(y)

  # Start of assertions
  checkmate::assert_string(label)
  checkmate::assert_list(x, types = "data_extract_spec")

  checkmate::assert_list(y, types = "data_extract_spec")
  assert_single_selection(y)

  checkmate::assert_flag(show_percentage)
  checkmate::assert_flag(show_total)
  checkmate::assert_flag(remove_zero_columns)
  checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
  checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
  checkmate::assert_class(basic_table_args, classes = "basic_table_args")

  assert_decorators(decorators, "table")
  # End of assertions

  # Make UI args
  ui_args <- as.list(environment())

  server_args <- list(
    label = label,
    x = x,
    y = y,
    remove_zero_columns = remove_zero_columns,
    basic_table_args = basic_table_args,
    decorators = decorators
  )

  ans <- module(
    label = label,
    server = srv_t_crosstable,
    ui = ui_t_crosstable,
    ui_args = ui_args,
    server_args = server_args,
    transformators = transformators,
    datanames = teal.transform::get_extract_datanames(list(x = x, y = y))
  )
  attr(ans, "teal_bookmarkable") <- TRUE
  ans
}

# UI function for the cross-table module
ui_t_crosstable <- function(id, x, y, show_percentage, show_total, remove_zero_columns, pre_output, post_output, ...) {
  args <- list(...)
  ns <- NS(id)
  is_single_dataset <- teal.transform::is_single_dataset(x, y)

  join_default_options <- c(
    "Full Join" = "dplyr::full_join",
    "Inner Join" = "dplyr::inner_join",
    "Left Join" = "dplyr::left_join",
    "Right Join" = "dplyr::right_join"
  )

  teal.widgets::standard_layout(
    output = teal.widgets::white_small_well(
      textOutput(ns("title")),
      teal.widgets::table_with_settings_ui(ns("table"))
    ),
    encoding = tags$div(
      tags$label("Encodings", class = "text-primary"),
      teal.transform::datanames_input(list(x, y)),
      teal.transform::data_extract_ui(ns("x"), label = "Row values", x, is_single_dataset = is_single_dataset),
      teal.transform::data_extract_ui(ns("y"), label = "Column values", y, is_single_dataset = is_single_dataset),
      teal.widgets::optionalSelectInput(
        ns("join_fun"),
        label = "Row to Column type of join",
        choices = join_default_options,
        selected = join_default_options[1],
        multiple = FALSE
      ),
      tags$hr(),
      bslib::accordion(
        open = TRUE,
        bslib::accordion_panel(
          title = "Table settings",
          checkboxInput(ns("show_percentage"), "Show column percentage", value = show_percentage),
          checkboxInput(ns("show_total"), "Show total column", value = show_total),
          checkboxInput(ns("remove_zero_columns"), "Remove zero-only columns", value = remove_zero_columns)
        )
      ),
      ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "table"))
    ),
    pre_output = pre_output,
    post_output = post_output
  )
}

# Server function for the cross-table module
srv_t_crosstable <- function(id, data, label, x, y, remove_zero_columns, basic_table_args, decorators) {
  checkmate::assert_class(data, "reactive")
  checkmate::assert_class(isolate(data()), "teal_data")
  moduleServer(id, function(input, output, session) {
    teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")

    selector_list <- teal.transform::data_extract_multiple_srv(
      data_extract = list(x = x, y = y),
      datasets = data,
      select_validation_rule = list(
        x = shinyvalidate::sv_required("Please define column for row variable."),
        y = shinyvalidate::sv_required("Please define column for column variable.")
      )
    )

    iv_r <- reactive({
      iv <- shinyvalidate::InputValidator$new()
      iv$add_rule("join_fun", function(value) {
        if (!identical(selector_list()$x()$dataname, selector_list()$y()$dataname)) {
          if (!shinyvalidate::input_provided(value)) {
            "Please select a joining function."
          }
        }
      })
      teal.transform::compose_and_enable_validators(iv, selector_list)
    })

    observeEvent(
      eventExpr = {
        req(!is.null(selector_list()$x()) && !is.null(selector_list()$y()))
        list(selector_list()$x(), selector_list()$y())
      },
      handlerExpr = {
        if (identical(selector_list()$x()$dataname, selector_list()$y()$dataname)) {
          shinyjs::hide("join_fun")
        } else {
          shinyjs::show("join_fun")
        }
      }
    )

    merge_function <- reactive({
      if (is.null(input$join_fun)) {
        "dplyr::full_join"
      } else {
        input$join_fun
      }
    })

    anl_merged_input <- teal.transform::merge_expression_srv(
      datasets = data,
      selector_list = selector_list,
      merge_function = merge_function
    )
    qenv <- reactive({
      obj <- data()
      teal.reporter::teal_card(obj) <-
        c(
          teal.reporter::teal_card(obj),
          teal.reporter::teal_card("## Module's output(s)")
        )
      teal.code::eval_code(obj, "library(rtables);library(tern);library(dplyr)")
    })
    anl_merged_q <- reactive({
      req(anl_merged_input())
      qenv() %>%
        teal.code::eval_code(as.expression(anl_merged_input()$expr))
    })

    merged <- list(
      anl_input_r = anl_merged_input,
      anl_q_r = anl_merged_q
    )

    output_q <- reactive({
      teal::validate_inputs(iv_r())
      ANL <- merged$anl_q_r()[["ANL"]]

      # As this is a summary
      x_name <- as.vector(merged$anl_input_r()$columns_source$x)
      y_name <- as.vector(merged$anl_input_r()$columns_source$y)

      teal::validate_has_data(ANL, 3)
      teal::validate_has_data(ANL[, c(x_name, y_name)], 3, complete = TRUE, allow_inf = FALSE)

      is_allowed_class <- function(x) is.numeric(x) || is.factor(x) || is.character(x) || is.logical(x)
      validate(need(
        all(vapply(ANL[x_name], is_allowed_class, logical(1))),
        "Selected row variable has an unsupported data type."
      ))
      validate(need(
        is_allowed_class(ANL[[y_name]]),
        "Selected column variable has an unsupported data type."
      ))

      show_percentage <- input$show_percentage
      show_total <- input$show_total
      remove_zero_columns <- input$remove_zero_columns

      plot_title <- paste(
        "Cross-Table of",
        paste0(varname_w_label(x_name, ANL), collapse = ", "),
        "(rows)", "vs.",
        varname_w_label(y_name, ANL),
        "(columns)"
      )

      labels_vec <- vapply(
        x_name,
        varname_w_label,
        character(1),
        ANL
      )

      obj <- merged$anl_q_r()
      teal.reporter::teal_card(obj) <- c(teal.reporter::teal_card(obj), "### Table")
      obj <- teal.code::eval_code(
        obj,
        substitute(
          expr = {
            title <- plot_title
          },
          env = list(plot_title = plot_title)
        )
      ) %>%
        teal.code::eval_code(
          substitute(
            expr = {
              table <- basic_tables %>%
                split_call %>% # styler: off
                rtables::add_colcounts() %>%
                tern::analyze_vars(
                  vars = x_name,
                  var_labels = labels_vec,
                  na.rm = FALSE,
                  denom = "N_col",
                  .stats = c("mean_sd", "median", "range", count_value)
                )
            },
            env = list(
              basic_tables = teal.widgets::parse_basic_table_args(
                basic_table_args = teal.widgets::resolve_basic_table_args(basic_table_args)
              ),
              split_call = if (show_total) {
                substitute(
                  expr = rtables::split_cols_by(
                    y_name,
                    split_fun = rtables::add_overall_level(label = "Total", first = FALSE)
                  ),
                  env = list(y_name = y_name)
                )
              } else {
                substitute(rtables::split_cols_by(y_name), env = list(y_name = y_name))
              },
              x_name = x_name,
              labels_vec = labels_vec,
              count_value = ifelse(show_percentage, "count_fraction", "count")
            )
          )
        ) %>%
        teal.code::eval_code(
          expression(ANL <- tern::df_explicit_na(ANL))
        )

      if (remove_zero_columns) {
        obj <- obj %>%
          teal.code::eval_code(
            substitute(
              expr = {
                ANL[[y_name]] <- droplevels(ANL[[y_name]])
                table <- rtables::build_table(lyt = table, df = ANL[order(ANL[[y_name]]), ])
              },
              env = list(y_name = y_name)
            )
          )
      } else {
        obj <- obj %>%
          teal.code::eval_code(
            substitute(
              expr = {
                table <- rtables::build_table(lyt = table, df = ANL[order(ANL[[y_name]]), ])
              },
              env = list(y_name = y_name)
            )
          )
      }
      obj
    })

    decorated_output_q <- srv_decorate_teal_data(
      id = "decorator",
      data = output_q,
      decorators = select_decorators(decorators, "table"),
      expr = quote(table)
    )

    output$title <- renderText(req(decorated_output_q())[["title"]])

    table_r <- reactive({
      req(iv_r()$is_valid())
      req(decorated_output_q())[["table"]]
    })

    teal.widgets::table_with_settings_srv(
      id = "table",
      table_r = table_r
    )

    decorated_output_q
  })
}

#' `teal` module: Distribution analysis
#'
#' Module is designed to explore the distribution of a single variable within a given dataset.
#' It offers several tools, such as histograms, Q-Q plots, and various statistical tests to
#' visually and statistically analyze the variable's distribution.
#'
#' @inheritParams teal::module
#' @inheritParams teal.widgets::standard_layout
#' @inheritParams shared_params
#'
#' @param dist_var (`data_extract_spec` or `list` of multiple `data_extract_spec`)
#' Variable(s) for which the distribution will be analyzed.
#' @param strata_var (`data_extract_spec` or `list` of multiple `data_extract_spec`)
#' Categorical variable used to split the distribution analysis.
#' @param group_var (`data_extract_spec` or `list` of multiple `data_extract_spec`)
#' Variable used for faceting plot into multiple panels.
#' @param freq (`logical`) optional, whether to display frequency (`TRUE`) or density (`FALSE`).
#' Defaults to density (`FALSE`).
#' @param bins (`integer(1)` or `integer(3)`) optional,  specifies the number of bins for the histogram.
#' - When the length of `bins` is one: The histogram bins will have a fixed size based on the `bins` provided.
#' - When the length of `bins` is three: The histogram bins are dynamically adjusted based on vector of `value`, `min`,
#' and `max`.
#' Defaults to `c(30L, 1L, 100L)`.
#'
#' @param ggplot2_args `r roxygen_ggplot2_args_param("Histogram", "QQplot")`
#'
#' @inherit shared_params return
#'
#' @section Decorating Module:
#'
#' This module generates the following objects, which can be modified in place using decorators::
#' - `histogram_plot` (`ggplot`)
#' - `qq_plot` (`ggplot`)
#'
#' A Decorator is applied to the specific output using a named list of `teal_transform_module` objects.
#' The name of this list corresponds to the name of the output to which the decorator is applied.
#' See code snippet below:
#'
#' ```
#' tm_g_distribution(
#'    ..., # arguments for module
#'    decorators = list(
#'      histogram_plot = teal_transform_module(...), # applied only to `histogram_plot` output
#'      qq_plot = teal_transform_module(...) # applied only to `qq_plot` output
#'    )
#' )
#' ```
#'
#' For additional details and examples of decorators, refer to the vignette
#' `vignette("decorate-module-output", package = "teal.modules.general")`.
#'
#' To learn more please refer to the vignette
#' `vignette("transform-module-output", package = "teal")` or the [`teal::teal_transform_module()`] documentation.
#'
#' @inheritSection teal::example_module Reporting
#'
#' @examplesShinylive
#' library(teal.modules.general)
#' interactive <- function() TRUE
#' {{ next_example }}
# nolint start: line_length_linter.
#' @examples
# nolint end: line_length_linter.
#' # general data example
#' data <- teal_data()
#' data <- within(data, {
#'   iris <- iris
#' })
#'
#' app <- init(
#'   data = data,
#'   modules = list(
#'     tm_g_distribution(
#'       dist_var = data_extract_spec(
#'         dataname = "iris",
#'         select = select_spec(variable_choices("iris"), "Petal.Length")
#'       )
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
#' @examplesShinylive
#' library(teal.modules.general)
#' interactive <- function() TRUE
#' {{ next_example }}
# nolint start: line_length_linter.
#' @examples
# nolint end: line_length_linter.
#' # CDISC data example
#' data <- teal_data()
#' data <- within(data, {
#'   ADSL <- teal.data::rADSL
#' })
#' join_keys(data) <- default_cdisc_join_keys[names(data)]
#'
#'
#' app <- init(
#'   data = data,
#'   modules = modules(
#'     tm_g_distribution(
#'       dist_var = data_extract_spec(
#'         dataname = "ADSL",
#'         select = select_spec(
#'           choices = variable_choices("ADSL", c("AGE", "BMRKR1")),
#'           selected = "BMRKR1",
#'           multiple = FALSE,
#'           fixed = FALSE
#'         )
#'       ),
#'       strata_var = data_extract_spec(
#'         dataname = "ADSL",
#'         filter = filter_spec(
#'           vars = choices_selected(
#'             variable_choices("ADSL", c("ARM", "COUNTRY", "SEX")),
#'             selected = NULL
#'           ),
#'           multiple = TRUE
#'         )
#'       ),
#'       group_var = data_extract_spec(
#'         dataname = "ADSL",
#'         filter = filter_spec(
#'           vars = choices_selected(
#'             variable_choices("ADSL", c("ARM", "COUNTRY", "SEX")),
#'             selected = "ARM"
#'           ),
#'           multiple = TRUE
#'         )
#'       )
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
#' @export
#'
tm_g_distribution <- function(label = "Distribution Module",
                              dist_var,
                              strata_var = NULL,
                              group_var = NULL,
                              freq = FALSE,
                              ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
                              ggplot2_args = teal.widgets::ggplot2_args(),
                              bins = c(30L, 1L, 100L),
                              plot_height = c(600, 200, 2000),
                              plot_width = NULL,
                              pre_output = NULL,
                              post_output = NULL,
                              transformators = list(),
                              decorators = list()) {
  message("Initializing tm_g_distribution")

  # Normalize the parameters
  if (inherits(dist_var, "data_extract_spec")) dist_var <- list(dist_var)
  if (inherits(strata_var, "data_extract_spec")) strata_var <- list(strata_var)
  if (inherits(group_var, "data_extract_spec")) group_var <- list(group_var)
  if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)

  # Start of assertions
  checkmate::assert_string(label)

  checkmate::assert_list(dist_var, "data_extract_spec")
  checkmate::assert_false(dist_var[[1L]]$select$multiple)

  checkmate::assert_list(strata_var, types = "data_extract_spec", null.ok = TRUE)
  checkmate::assert_list(group_var, types = "data_extract_spec", null.ok = TRUE)
  checkmate::assert_flag(freq)
  ggtheme <- match.arg(ggtheme)

  plot_choices <- c("Histogram", "QQplot")
  checkmate::assert_list(ggplot2_args, types = "ggplot2_args")
  checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))

  if (length(bins) == 1) {
    checkmate::assert_numeric(bins, any.missing = FALSE, lower = 1)
  } else {
    checkmate::assert_numeric(bins, len = 3, any.missing = FALSE, lower = 1)
    checkmate::assert_numeric(bins[1], lower = bins[2], upper = bins[3], .var.name = "bins")
  }

  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_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
  checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)

  assert_decorators(decorators, names = c("histogram_plot", "qq_plot"))

  # End of assertions

  # Make UI args
  args <- as.list(environment())

  data_extract_list <- list(
    dist_var = dist_var,
    strata_var = strata_var,
    group_var = group_var
  )

  ans <- module(
    label = label,
    server = srv_distribution,
    server_args = c(
      data_extract_list,
      list(
        plot_height = plot_height,
        plot_width = plot_width,
        ggplot2_args = ggplot2_args,
        decorators = decorators
      )
    ),
    ui = ui_distribution,
    ui_args = args,
    transformators = transformators,
    datanames = teal.transform::get_extract_datanames(data_extract_list)
  )
  attr(ans, "teal_bookmarkable") <- TRUE
  ans
}

# UI function for the distribution module
ui_distribution <- function(id, ...) {
  args <- list(...)
  ns <- NS(id)
  is_single_dataset_value <- teal.transform::is_single_dataset(args$dist_var, args$strata_var, args$group_var)

  teal.widgets::standard_layout(
    output = teal.widgets::white_small_well(
      tabsetPanel(
        id = ns("tabs"),
        tabPanel("Histogram", teal.widgets::plot_with_settings_ui(id = ns("hist_plot"))),
        tabPanel("QQplot", teal.widgets::plot_with_settings_ui(id = ns("qq_plot")))
      ),
      tags$h3("Statistics Table"),
      DT::dataTableOutput(ns("summary_table")),
      tags$h3("Tests"),
      conditionalPanel(
        sprintf("input['%s'].length === 0", ns("dist_tests")),
        div(
          id = ns("please_select_a_test"),
          "Please select a test"
        )
      ),
      conditionalPanel(
        sprintf("input['%s'].length > 0", ns("dist_tests")),
        DT::dataTableOutput(ns("t_stats"))
      )
    ),
    encoding = tags$div(
      tags$label("Encodings", class = "text-primary"),
      teal.transform::datanames_input(args[c("dist_var", "strata_var")]),
      teal.transform::data_extract_ui(
        id = ns("dist_i"),
        label = "Variable",
        data_extract_spec = args$dist_var,
        is_single_dataset = is_single_dataset_value
      ),
      if (!is.null(args$group_var)) {
        tagList(
          teal.transform::data_extract_ui(
            id = ns("group_i"),
            label = "Group by",
            data_extract_spec = args$group_var,
            is_single_dataset = is_single_dataset_value
          ),
          uiOutput(ns("scales_types_ui"))
        )
      },
      if (!is.null(args$strata_var)) {
        teal.transform::data_extract_ui(
          id = ns("strata_i"),
          label = "Stratify by",
          data_extract_spec = args$strata_var,
          is_single_dataset = is_single_dataset_value
        )
      },
      bslib::accordion(
        conditionalPanel(
          condition = paste0("input['", ns("tabs"), "'] == 'Histogram'"),
          bslib::accordion_panel(
            "Histogram",
            teal.widgets::optionalSliderInputValMinMax(ns("bins"), "Bins", args$bins, ticks = FALSE, step = 1),
            shinyWidgets::prettyRadioButtons(
              ns("main_type"),
              label = "Plot Type:",
              choices = c("Density", "Frequency"),
              selected = if (!args$freq) "Density" else "Frequency",
              bigger = FALSE,
              inline = TRUE
            ),
            checkboxInput(ns("add_dens"), label = "Overlay Density", value = TRUE),
            ui_decorate_teal_data(
              ns("d_density"),
              decorators = select_decorators(args$decorators, "histogram_plot")
            )
          )
        ),
        conditionalPanel(
          condition = paste0("input['", ns("tabs"), "'] == 'QQplot'"),
          bslib::accordion_panel(
            "QQ Plot",
            checkboxInput(ns("qq_line"), label = "Add diagonal line(s)", TRUE),
            ui_decorate_teal_data(
              ns("d_qq"),
              decorators = select_decorators(args$decorators, "qq_plot")
            ),
            collapsed = FALSE
          )
        ),
        conditionalPanel(
          condition = paste0("input['", ns("main_type"), "'] == 'Density'"),
          bslib::accordion_panel(
            "Theoretical Distribution",
            teal.widgets::optionalSelectInput(
              ns("t_dist"),
              tags$div(
                tagList(
                  "Distribution:",
                  bslib::tooltip(
                    icon("circle-info"),
                    tags$span(
                      "Default parameters are optimized with MASS::fitdistr function."
                    )
                  )
                )
              ),
              choices = c("normal", "lognormal", "gamma", "unif"),
              selected = NULL,
              multiple = FALSE
            ),
            numericInput(ns("dist_param1"), label = "param1", value = NULL),
            numericInput(ns("dist_param2"), label = "param2", value = NULL),
            tags$span(actionButton(ns("params_reset"), "Default params")),
            collapsed = FALSE
          )
        ),
        bslib::accordion_panel(
          title = "Tests",
          teal.widgets::optionalSelectInput(
            ns("dist_tests"),
            "Tests:",
            choices = c(
              "Shapiro-Wilk",
              if (!is.null(args$strata_var)) "t-test (two-samples, not paired)",
              if (!is.null(args$strata_var)) "one-way ANOVA",
              if (!is.null(args$strata_var)) "Fligner-Killeen",
              if (!is.null(args$strata_var)) "F-test",
              "Kolmogorov-Smirnov (one-sample)",
              "Anderson-Darling (one-sample)",
              "Cramer-von Mises (one-sample)",
              if (!is.null(args$strata_var)) "Kolmogorov-Smirnov (two-samples)"
            ),
            selected = NULL
          )
        ),
        bslib::accordion_panel(
          title = "Statistics Table",
          sliderInput(ns("roundn"), "Round to n digits", min = 0, max = 10, value = 2)
        ),
        bslib::accordion_panel(
          title = "Plot settings",
          selectInput(
            inputId = ns("ggtheme"),
            label = "Theme (by ggplot):",
            choices = ggplot_themes,
            selected = args$ggtheme,
            multiple = FALSE
          )
        )
      )
    ),
    pre_output = args$pre_output,
    post_output = args$post_output
  )
}

# Server function for the distribution module
srv_distribution <- function(id,
                             data,
                             dist_var,
                             strata_var,
                             group_var,
                             plot_height,
                             plot_width,
                             ggplot2_args,
                             decorators) {
  checkmate::assert_class(data, "reactive")
  checkmate::assert_class(isolate(data()), "teal_data")
  moduleServer(id, function(input, output, session) {
    teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")

    setBookmarkExclude("params_reset")

    ns <- session$ns

    rule_req <- function(value) {
      if (isTRUE(input$dist_tests %in% c(
        "Fligner-Killeen",
        "t-test (two-samples, not paired)",
        "F-test",
        "Kolmogorov-Smirnov (two-samples)",
        "one-way ANOVA"
      ))) {
        if (!shinyvalidate::input_provided(value)) {
          "Please select stratify variable."
        }
      }
    }
    rule_dupl <- function(...) {
      if (identical(input$dist_tests, "Fligner-Killeen")) {
        strata <- selector_list()$strata_i()$select
        group <- selector_list()$group_i()$select
        if (isTRUE(strata == group)) {
          "Please select different variables for strata and group."
        }
      }
    }

    selector_list <- teal.transform::data_extract_multiple_srv(
      data_extract = list(
        dist_i = dist_var,
        strata_i = strata_var,
        group_i = group_var
      ),
      data,
      select_validation_rule = list(
        dist_i = shinyvalidate::sv_required("Please select a variable")
      ),
      filter_validation_rule = list(
        strata_i = shinyvalidate::compose_rules(
          rule_req,
          rule_dupl
        ),
        group_i = rule_dupl
      )
    )

    iv_r <- reactive({
      iv <- shinyvalidate::InputValidator$new()
      teal.transform::compose_and_enable_validators(iv, selector_list, validator_names = "dist_i")
    })

    iv_r_dist <- reactive({
      iv <- shinyvalidate::InputValidator$new()
      teal.transform::compose_and_enable_validators(
        iv, selector_list,
        validator_names = c("strata_i", "group_i")
      )
    })
    rule_dist_1 <- function(value) {
      if (!is.null(input$t_dist)) {
        switch(input$t_dist,
          "normal" = if (!shinyvalidate::input_provided(value)) "mean is required",
          "lognormal" = if (!shinyvalidate::input_provided(value)) "meanlog is required",
          "gamma" = {
            if (!shinyvalidate::input_provided(value)) "shape is required" else if (value <= 0) "shape must be positive"
          },
          "unif" = NULL
        )
      }
    }
    rule_dist_2 <- function(value) {
      if (!is.null(input$t_dist)) {
        switch(input$t_dist,
          "normal" = {
            if (!shinyvalidate::input_provided(value)) {
              "sd is required"
            } else if (value < 0) {
              "sd must be non-negative"
            }
          },
          "lognormal" = {
            if (!shinyvalidate::input_provided(value)) {
              "sdlog is required"
            } else if (value < 0) {
              "sdlog must be non-negative"
            }
          },
          "gamma" = {
            if (!shinyvalidate::input_provided(value)) {
              "rate is required"
            } else if (value <= 0) {
              "rate must be positive"
            }
          },
          "unif" = NULL
        )
      }
    }

    rule_dist <- function(value) {
      if (isTRUE(input$tabs == "QQplot") ||
        isTRUE(input$dist_tests %in% c(
          "Kolmogorov-Smirnov (one-sample)",
          "Anderson-Darling (one-sample)",
          "Cramer-von Mises (one-sample)"
        ))) {
        if (!shinyvalidate::input_provided(value)) {
          "Please select the theoretical distribution."
        }
      }
    }

    iv_dist <- shinyvalidate::InputValidator$new()
    iv_dist$add_rule("t_dist", rule_dist)
    iv_dist$add_rule("dist_param1", rule_dist_1)
    iv_dist$add_rule("dist_param2", rule_dist_2)
    iv_dist$enable()

    anl_merged_input <- teal.transform::merge_expression_srv(
      selector_list = selector_list,
      datasets = data
    )

    qenv <- reactive(
      teal.code::eval_code(data(), "library(ggplot2);library(dplyr)")
    )

    anl_merged_q <- reactive({
      req(anl_merged_input())
      qenv() %>%
        teal.code::eval_code(as.expression(anl_merged_input()$expr))
    })

    merged <- list(
      anl_input_r = anl_merged_input,
      anl_q_r = anl_merged_q
    )

    output$scales_types_ui <- renderUI({
      if ("group_i" %in% names(selector_list()) && length(selector_list()$group_i()$filters[[1]]$selected) > 0) {
        shinyWidgets::prettyRadioButtons(
          ns("scales_type"),
          label = "Scales:",
          choices = c("Fixed", "Free"),
          selected = "Fixed",
          bigger = FALSE,
          inline = TRUE
        )
      }
    })

    observeEvent(
      eventExpr = list(
        input$t_dist,
        input$params_reset,
        selector_list()$dist_i()$select
      ),
      handlerExpr = {
        params <-
          if (length(input$t_dist) != 0) {
            get_dist_params <- function(x, dist) {
              if (dist == "unif") {
                return(stats::setNames(range(x, na.rm = TRUE), c("min", "max")))
              }
              tryCatch(
                MASS::fitdistr(x, densfun = dist)$estimate,
                error = function(e) c(param1 = NA_real_, param2 = NA_real_)
              )
            }

            ANL <- merged$anl_q_r()[["ANL"]]
            round(get_dist_params(as.numeric(stats::na.omit(ANL[[merge_vars()$dist_var]])), input$t_dist), 2)
          } else {
            c("param1" = NA_real_, "param2" = NA_real_)
          }

        params_vals <- unname(params)
        map_distr_nams <- list(
          normal = c("mean", "sd"),
          lognormal = c("meanlog", "sdlog"),
          gamma = c("shape", "rate"),
          unif = c("min", "max")
        )

        if (!is.null(input$t_dist) && input$t_dist %in% names(map_distr_nams)) {
          params_names <- map_distr_nams[[input$t_dist]]
        } else {
          params_names <- names(params)
        }

        updateNumericInput(
          inputId = "dist_param1",
          label = params_names[1],
          value = restoreInput(ns("dist_param1"), params_vals[1])
        )
        updateNumericInput(
          inputId = "dist_param2",
          label = params_names[2],
          value = restoreInput(ns("dist_param1"), params_vals[2])
        )
      },
      ignoreInit = TRUE
    )

    observeEvent(input$params_reset, {
      updateActionButton(inputId = "params_reset", label = "Reset params")
    })

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

      dist_var <- as.vector(merged$anl_input_r()$columns_source$dist_i)
      s_var <- as.vector(merged$anl_input_r()$columns_source$strata_i)
      g_var <- as.vector(merged$anl_input_r()$columns_source$group_i)

      dist_var_name <- if (length(dist_var)) as.name(dist_var) else NULL
      s_var_name <- if (length(s_var)) as.name(s_var) else NULL
      g_var_name <- if (length(g_var)) as.name(g_var) else NULL

      list(
        dist_var = dist_var,
        s_var = s_var,
        g_var = g_var,
        dist_var_name = dist_var_name,
        s_var_name = s_var_name,
        g_var_name = g_var_name
      )
    })

    # common qenv
    common_q <- reactive({
      # Create a private stack for this function only.

      obj <- merged$anl_q_r()
      teal.reporter::teal_card(obj) <-
        c(
          teal.reporter::teal_card(obj),
          teal.reporter::teal_card("## Module's output(s)")
        )

      ANL <- obj[["ANL"]]
      dist_var <- merge_vars()$dist_var
      s_var <- merge_vars()$s_var
      g_var <- merge_vars()$g_var

      dist_var_name <- merge_vars()$dist_var_name
      s_var_name <- merge_vars()$s_var_name
      g_var_name <- merge_vars()$g_var_name

      roundn <- input$roundn
      dist_param1 <- input$dist_param1
      dist_param2 <- input$dist_param2
      # isolated as dist_param1/dist_param2 already triggered the reactivity
      t_dist <- isolate(input$t_dist)

      qenv <- obj

      if (length(g_var) > 0) {
        validate(
          need(
            inherits(ANL[[g_var]], c("integer", "factor", "character")),
            "Group by variable must be `factor`, `character`, or `integer`"
          )
        )
        qenv <- teal.code::eval_code(qenv, "library(forcats)")
        qenv <- teal.code::eval_code(
          qenv,
          substitute(
            expr = ANL[[g_var]] <- forcats::fct_na_value_to_level(as.factor(ANL[[g_var]]), "NA"),
            env = list(g_var = g_var)
          )
        )
      }

      if (length(s_var) > 0) {
        validate(
          need(
            inherits(ANL[[s_var]], c("integer", "factor", "character")),
            "Stratify by variable must be `factor`, `character`, or `integer`"
          )
        )

        qenv <- teal.code::eval_code(qenv, "library(forcats)")
        qenv <- teal.code::eval_code(
          qenv,
          substitute(
            expr = ANL[[s_var]] <- forcats::fct_na_value_to_level(as.factor(ANL[[s_var]]), "NA"),
            env = list(s_var = s_var)
          )
        )
      }

      validate(need(is.numeric(ANL[[dist_var]]), "Please select a numeric variable."))
      teal::validate_has_data(ANL, 1, complete = TRUE)

      if (length(t_dist) != 0) {
        map_distr_nams <- list(
          normal = c("mean", "sd"),
          lognormal = c("meanlog", "sdlog"),
          gamma = c("shape", "rate"),
          unif = c("min", "max")
        )
        params_names_raw <- map_distr_nams[[t_dist]]

        qenv <- teal.code::eval_code(
          qenv,
          substitute(
            expr = {
              params <- as.list(c(dist_param1, dist_param2))
              names(params) <- params_names_raw
            },
            env = list(
              dist_param1 = dist_param1,
              dist_param2 = dist_param2,
              params_names_raw = params_names_raw
            )
          )
        )
      }

      if (length(s_var) == 0 && length(g_var) == 0) {
        teal.code::eval_code(
          qenv,
          substitute(
            expr = {
              summary_table_data <- ANL %>%
                dplyr::summarise(
                  min = round(min(dist_var_name, na.rm = TRUE), roundn),
                  median = round(stats::median(dist_var_name, na.rm = TRUE), roundn),
                  mean = round(mean(dist_var_name, na.rm = TRUE), roundn),
                  max = round(max(dist_var_name, na.rm = TRUE), roundn),
                  sd = round(stats::sd(dist_var_name, na.rm = TRUE), roundn),
                  count = dplyr::n()
                )
            },
            env = list(
              dist_var_name = as.name(dist_var),
              roundn = roundn
            )
          )
        )
      } else {
        teal.code::eval_code(
          qenv,
          substitute(
            expr = {
              strata_vars <- strata_vars_raw
              summary_table_data <- ANL %>%
                dplyr::group_by_at(dplyr::vars(dplyr::any_of(strata_vars))) %>%
                dplyr::summarise(
                  min = round(min(dist_var_name, na.rm = TRUE), roundn),
                  median = round(stats::median(dist_var_name, na.rm = TRUE), roundn),
                  mean = round(mean(dist_var_name, na.rm = TRUE), roundn),
                  max = round(max(dist_var_name, na.rm = TRUE), roundn),
                  sd = round(stats::sd(dist_var_name, na.rm = TRUE), roundn),
                  count = dplyr::n()
                )
            },
            env = list(
              dist_var_name = dist_var_name,
              strata_vars_raw = c(g_var, s_var),
              roundn = roundn
            )
          )
        )
      }
    })

    # distplot qenv ----
    dist_q <- eventReactive(
      eventExpr = {
        common_q()
        input$scales_type
        input$main_type
        input$bins
        input$add_dens
        is.null(input$ggtheme)
      },
      valueExpr = {
        dist_var <- merge_vars()$dist_var
        s_var <- merge_vars()$s_var
        g_var <- merge_vars()$g_var
        dist_var_name <- merge_vars()$dist_var_name
        s_var_name <- merge_vars()$s_var_name
        g_var_name <- merge_vars()$g_var_name
        t_dist <- input$t_dist
        dist_param1 <- input$dist_param1
        dist_param2 <- input$dist_param2

        scales_type <- input$scales_type

        ndensity <- 512
        main_type_var <- input$main_type
        bins_var <- input$bins
        add_dens_var <- input$add_dens
        ggtheme <- input$ggtheme

        teal::validate_inputs(iv_dist)

        qenv <- common_q()

        m_type <- if (main_type_var == "Density") "density" else "count"

        plot_call <- if (length(s_var) == 0 && length(g_var) == 0) {
          substitute(
            expr = ggplot2::ggplot(ANL, ggplot2::aes(dist_var_name)) +
              ggplot2::geom_histogram(
                position = "identity", ggplot2::aes(y = ggplot2::after_stat(m_type)), bins = bins_var, alpha = 0.3
              ),
            env = list(
              m_type = as.name(m_type), bins_var = bins_var, dist_var_name = as.name(dist_var)
            )
          )
        } else if (length(s_var) != 0 && length(g_var) == 0) {
          substitute(
            expr = ggplot2::ggplot(ANL, ggplot2::aes(dist_var_name, col = s_var_name)) +
              ggplot2::geom_histogram(
                position = "identity", ggplot2::aes(y = ggplot2::after_stat(m_type), fill = s_var),
                bins = bins_var, alpha = 0.3
              ),
            env = list(
              m_type = as.name(m_type),
              bins_var = bins_var,
              dist_var_name = dist_var_name,
              s_var = as.name(s_var),
              s_var_name = s_var_name
            )
          )
        } else if (length(s_var) == 0 && length(g_var) != 0) {
          req(scales_type)
          substitute(
            expr = ggplot2::ggplot(ANL[ANL[[g_var]] != "NA", ], ggplot2::aes(dist_var_name)) +
              ggplot2::geom_histogram(
                position = "identity", ggplot2::aes(y = ggplot2::after_stat(m_type)), bins = bins_var, alpha = 0.3
              ) +
              ggplot2::facet_wrap(~g_var_name, ncol = 1, scales = scales_raw),
            env = list(
              m_type = as.name(m_type),
              bins_var = bins_var,
              dist_var_name = dist_var_name,
              g_var = g_var,
              g_var_name = g_var_name,
              scales_raw = tolower(scales_type)
            )
          )
        } else {
          req(scales_type)
          substitute(
            expr = ggplot2::ggplot(ANL[ANL[[g_var]] != "NA", ], ggplot2::aes(dist_var_name, col = s_var_name)) +
              ggplot2::geom_histogram(
                position = "identity",
                ggplot2::aes(y = ggplot2::after_stat(m_type), fill = s_var), bins = bins_var, alpha = 0.3
              ) +
              ggplot2::facet_wrap(~g_var_name, ncol = 1, scales = scales_raw),
            env = list(
              m_type = as.name(m_type),
              bins_var = bins_var,
              dist_var_name = dist_var_name,
              g_var = g_var,
              s_var = as.name(s_var),
              g_var_name = g_var_name,
              s_var_name = s_var_name,
              scales_raw = tolower(scales_type)
            )
          )
        }

        if (add_dens_var) {
          plot_call <- substitute(
            expr = plot_call +
              ggplot2::stat_density(
                ggplot2::aes(y = ggplot2::after_stat(const * m_type2)),
                geom = "line",
                position = "identity",
                alpha = 0.5,
                size = 2,
                n = ndensity
              ),
            env = list(
              plot_call = plot_call,
              const = if (main_type_var == "Density") {
                1
              } else {
                diff(range(qenv[["ANL"]][[dist_var]], na.rm = TRUE)) / bins_var
              },
              m_type2 = if (main_type_var == "Density") as.name("density") else as.name("count"),
              ndensity = ndensity
            )
          )
        }

        if (length(t_dist) != 0 && main_type_var == "Density" && length(g_var) == 0 && length(s_var) == 0) {
          qenv <- teal.code::eval_code(qenv, "library(ggpp)")
          qenv <- teal.code::eval_code(
            qenv,
            substitute(
              df_params <- as.data.frame(append(params, list(name = t_dist))),
              env = list(t_dist = t_dist)
            )
          )
          datas <- quote(data.frame(x = 0.7, y = 1, tb = I(list(df_params = df_params))))
          label <- quote(tb)

          plot_call <- substitute(
            expr = plot_call + ggpp::geom_table_npc(
              data = data,
              ggplot2::aes(npcx = x, npcy = y, label = label),
              hjust = 0, vjust = 1, size = 4
            ),
            env = list(plot_call = plot_call, data = datas, label = label)
          )
        }

        if (
          length(s_var) == 0 &&
            length(g_var) == 0 &&
            main_type_var == "Density" &&
            length(t_dist) != 0 &&
            main_type_var == "Density"
        ) {
          map_dist <- stats::setNames(
            c("dnorm", "dlnorm", "dgamma", "dunif"),
            c("normal", "lognormal", "gamma", "unif")
          )
          plot_call <- substitute(
            expr = plot_call + stat_function(
              data = data.frame(x = range(ANL[[dist_var]]), color = mapped_dist),
              ggplot2::aes(x, color = color),
              fun = mapped_dist_name,
              n = ndensity,
              size = 2,
              args = params
            ) +
              ggplot2::scale_color_manual(values = stats::setNames("blue", mapped_dist), aesthetics = "color"),
            env = list(
              plot_call = plot_call,
              dist_var = dist_var,
              ndensity = ndensity,
              mapped_dist = unname(map_dist[t_dist]),
              mapped_dist_name = as.name(unname(map_dist[t_dist]))
            )
          )
        }

        all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(
          user_plot = ggplot2_args[["Histogram"]],
          user_default = ggplot2_args$default
        )

        parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(
          all_ggplot2_args,
          ggtheme = ggtheme
        )

        teal.reporter::teal_card(qenv) <- c(teal.reporter::teal_card(qenv), "### Histogram Plot")
        teal.code::eval_code(
          qenv,
          substitute(
            expr = histogram_plot <- plot_call,
            env = list(plot_call = Reduce(function(x, y) call("+", x, y), c(plot_call, parsed_ggplot2_args)))
          )
        )
      }
    )

    # qqplot qenv ----
    qq_q <- eventReactive(
      eventExpr = {
        common_q()
        input$scales_type
        input$qq_line
        is.null(input$ggtheme)
        input$tabs
      },
      valueExpr = {
        dist_var <- merge_vars()$dist_var
        s_var <- merge_vars()$s_var
        g_var <- merge_vars()$g_var
        dist_var_name <- merge_vars()$dist_var_name
        s_var_name <- merge_vars()$s_var_name
        g_var_name <- merge_vars()$g_var_name
        dist_param1 <- input$dist_param1
        dist_param2 <- input$dist_param2

        scales_type <- input$scales_type
        ggtheme <- input$ggtheme

        teal::validate_inputs(iv_r_dist(), iv_dist)
        t_dist <- req(input$t_dist) # Not validated when tab is not selected
        qenv <- common_q()

        plot_call <- if (length(s_var) == 0 && length(g_var) == 0) {
          substitute(
            expr = ggplot2::ggplot(ANL, ggplot2::aes_string(sample = dist_var)),
            env = list(dist_var = dist_var)
          )
        } else if (length(s_var) != 0 && length(g_var) == 0) {
          substitute(
            expr = ggplot2::ggplot(ANL, ggplot2::aes_string(sample = dist_var, color = s_var)),
            env = list(dist_var = dist_var, s_var = s_var)
          )
        } else if (length(s_var) == 0 && length(g_var) != 0) {
          substitute(
            expr = ggplot2::ggplot(ANL[ANL[[g_var]] != "NA", ], ggplot2::aes_string(sample = dist_var)) +
              ggplot2::facet_wrap(~g_var_name, ncol = 1, scales = scales_raw),
            env = list(
              dist_var = dist_var,
              g_var = g_var,
              g_var_name = g_var_name,
              scales_raw = tolower(scales_type)
            )
          )
        } else {
          substitute(
            expr = ggplot2::ggplot(ANL[ANL[[g_var]] != "NA", ], ggplot2::aes_string(sample = dist_var, color = s_var)) +
              ggplot2::facet_wrap(~g_var_name, ncol = 1, scales = scales_raw),
            env = list(
              dist_var = dist_var,
              g_var = g_var,
              s_var = s_var,
              g_var_name = g_var_name,
              scales_raw = tolower(scales_type)
            )
          )
        }

        map_dist <- stats::setNames(
          c("qnorm", "qlnorm", "qgamma", "qunif"),
          c("normal", "lognormal", "gamma", "unif")
        )

        plot_call <- substitute(
          expr = plot_call +
            ggplot2::stat_qq(distribution = mapped_dist, dparams = params),
          env = list(plot_call = plot_call, mapped_dist = as.name(unname(map_dist[t_dist])))
        )

        if (length(t_dist) != 0 && length(g_var) == 0 && length(s_var) == 0) {
          qenv <- teal.code::eval_code(qenv, "library(ggpp)")
          qenv <- teal.code::eval_code(
            qenv,
            substitute(
              df_params <- as.data.frame(append(params, list(name = t_dist))),
              env = list(t_dist = t_dist)
            )
          )
          datas <- quote(data.frame(x = 0.7, y = 1, tb = I(list(df_params = df_params))))
          label <- quote(tb)

          plot_call <- substitute(
            expr = plot_call +
              ggpp::geom_table_npc(
                data = data,
                ggplot2::aes(npcx = x, npcy = y, label = label),
                hjust = 0,
                vjust = 1,
                size = 4
              ),
            env = list(
              plot_call = plot_call,
              data = datas,
              label = label
            )
          )
        }

        if (isTRUE(input$qq_line)) {
          plot_call <- substitute(
            expr = plot_call +
              ggplot2::stat_qq_line(distribution = mapped_dist, dparams = params),
            env = list(plot_call = plot_call, mapped_dist = as.name(unname(map_dist[t_dist])))
          )
        }

        all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(
          user_plot = ggplot2_args[["QQplot"]],
          user_default = ggplot2_args$default,
          module_plot = teal.widgets::ggplot2_args(labs = list(x = "theoretical", y = "sample"))
        )

        parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(
          all_ggplot2_args,
          ggtheme = ggtheme
        )

        teal.reporter::teal_card(qenv) <- c(teal.reporter::teal_card(qenv), "### QQ Plot")
        teal.code::eval_code(
          qenv,
          substitute(
            expr = qq_plot <- plot_call,
            env = list(plot_call = Reduce(function(x, y) call("+", x, y), c(plot_call, parsed_ggplot2_args)))
          )
        )
      }
    )

    # test qenv ----
    test_q <- eventReactive(
      ignoreNULL = FALSE,
      eventExpr = {
        common_q()
        input$dist_param1
        input$dist_param2
        input$dist_tests
      },
      valueExpr = {
        # Create a private stack for this function only.
        ANL <- common_q()[["ANL"]]

        dist_var <- merge_vars()$dist_var
        s_var <- merge_vars()$s_var
        g_var <- merge_vars()$g_var

        dist_var_name <- merge_vars()$dist_var_name
        s_var_name <- merge_vars()$s_var_name
        g_var_name <- merge_vars()$g_var_name

        dist_param1 <- input$dist_param1
        dist_param2 <- input$dist_param2
        dist_tests <- input$dist_tests
        t_dist <- input$t_dist

        req(dist_tests)

        teal::validate_inputs(iv_dist)

        if (length(s_var) > 0 || length(g_var) > 0) {
          counts <- ANL %>%
            dplyr::group_by_at(dplyr::vars(dplyr::any_of(c(s_var, g_var)))) %>%
            dplyr::summarise(n = dplyr::n())

          validate(need(all(counts$n > 5), "Please select strata*group with at least 5 observation each."))
        }


        if (dist_tests %in% c(
          "t-test (two-samples, not paired)",
          "F-test",
          "Kolmogorov-Smirnov (two-samples)"
        )) {
          if (length(g_var) == 0 && length(s_var) > 0) {
            validate(need(
              length(unique(ANL[[s_var]])) == 2,
              "Please select stratify variable with 2 levels."
            ))
          }
          if (length(g_var) > 0 && length(s_var) > 0) {
            validate(need(
              all(stats::na.omit(as.vector(
                tapply(ANL[[s_var]], list(ANL[[g_var]]), function(x) length(unique(x))) == 2
              ))),
              "Please select stratify variable with 2 levels, per each group."
            ))
          }
        }

        map_dist <- stats::setNames(
          c("pnorm", "plnorm", "pgamma", "punif"),
          c("normal", "lognormal", "gamma", "unif")
        )
        sks_args <- list(
          test = quote(stats::ks.test),
          args = bquote(append(list(.[[.(dist_var)]], .(map_dist[t_dist])), params)),
          groups = c(g_var, s_var)
        )
        ssw_args <- list(
          test = quote(stats::shapiro.test),
          args = bquote(list(.[[.(dist_var)]])),
          groups = c(g_var, s_var)
        )
        mfil_args <- list(
          test = quote(stats::fligner.test),
          args = bquote(list(.[[.(dist_var)]], .[[.(s_var)]])),
          groups = c(g_var)
        )
        sad_args <- list(
          test = quote(goftest::ad.test),
          args = bquote(append(list(.[[.(dist_var)]], .(map_dist[t_dist])), params)),
          groups = c(g_var, s_var)
        )
        scvm_args <- list(
          test = quote(goftest::cvm.test),
          args = bquote(append(list(.[[.(dist_var)]], .(map_dist[t_dist])), params)),
          groups = c(g_var, s_var)
        )
        manov_args <- list(
          test = quote(stats::aov),
          args = bquote(list(stats::formula(.(dist_var_name) ~ .(s_var_name)), .)),
          groups = c(g_var)
        )
        mt_args <- list(
          test = quote(stats::t.test),
          args = bquote(unname(split(.[[.(dist_var)]], .[[.(s_var)]], drop = TRUE))),
          groups = c(g_var)
        )
        mv_args <- list(
          test = quote(stats::var.test),
          args = bquote(unname(split(.[[.(dist_var)]], .[[.(s_var)]], drop = TRUE))),
          groups = c(g_var)
        )
        mks_args <- list(
          test = quote(stats::ks.test),
          args = bquote(unname(split(.[[.(dist_var)]], .[[.(s_var)]], drop = TRUE))),
          groups = c(g_var)
        )

        tests_base <- switch(dist_tests,
          "Kolmogorov-Smirnov (one-sample)" = sks_args,
          "Shapiro-Wilk" = ssw_args,
          "Fligner-Killeen" = mfil_args,
          "one-way ANOVA" = manov_args,
          "t-test (two-samples, not paired)" = mt_args,
          "F-test" = mv_args,
          "Kolmogorov-Smirnov (two-samples)" = mks_args,
          "Anderson-Darling (one-sample)" = sad_args,
          "Cramer-von Mises (one-sample)" = scvm_args
        )

        env <- list(
          t_test = t_dist,
          dist_var = dist_var,
          g_var = g_var,
          s_var = s_var,
          args = tests_base$args,
          groups = tests_base$groups,
          test = tests_base$test,
          dist_var_name = dist_var_name,
          g_var_name = g_var_name,
          s_var_name = s_var_name
        )

        qenv <- common_q()

        if (length(s_var) == 0 && length(g_var) == 0) {
          qenv <- teal.code::eval_code(qenv, "library(generics)")
          qenv <- teal.code::eval_code(
            qenv,
            substitute(
              expr = {
                test_table_data <- ANL %>%
                  dplyr::select(dist_var) %>%
                  with(., generics::glance(do.call(test, args))) %>%
                  dplyr::mutate_if(is.numeric, round, 3)
              },
              env = env
            )
          )
        } else {
          qenv <- teal.code::eval_code(qenv, "library(tidyr)")
          qenv <- teal.code::eval_code(
            qenv,
            substitute(
              expr = {
                test_table_data <- ANL %>%
                  dplyr::select(dist_var, s_var, g_var) %>%
                  dplyr::group_by_at(dplyr::vars(dplyr::any_of(groups))) %>%
                  dplyr::do(tests = generics::glance(do.call(test, args))) %>%
                  tidyr::unnest(tests) %>%
                  dplyr::mutate_if(is.numeric, round, 3)
              },
              env = env
            )
          )
        }
      }
    )

    # outputs ----
    output_dist_q <- reactive(c(common_q(), req(dist_q())))
    output_qq_q <- reactive(c(common_q(), req(qq_q())))

    output_summary_q <- reactive({
      # Summary table listing has to be created separately to allow for qenv join
      q_common <- common_q()
      teal.reporter::teal_card(q_common) <- c(
        teal.reporter::teal_card(q_common),
        "### Statistics table"
      )
      if (iv_r()$is_valid()) {
        within(q_common, {
          summary_table <- rtables::df_to_tt(summary_table_data)
        })
      } else {
        within(
          q_common,
          summary_table <- rtables::rtable(header = rtables::rheader(colnames(summary_table_data)))
        )
      }
    })

    output_test_q <- reactive({
      # wrapped in if since could lead into validate error - we do want to continue
      test_q_out <- try(test_q(), silent = TRUE)
      q_common <- common_q()
      teal.reporter::teal_card(q_common) <- c(
        teal.reporter::teal_card(q_common),
        "### Distribution Tests table"
      )
      if (inherits(test_q_out, c("try-error", "error"))) {
        within(
          q_common,
          test_table <- rtables::rtable(header = rtables::rheader("No data available in table"), rtables::rrow())
        )
      } else {
        within(c(q_common, test_q_out), {
          test_table <- rtables::df_to_tt(test_table_data)
        })
      }
    })

    decorated_output_dist_q <- srv_decorate_teal_data(
      "d_density",
      data = output_dist_q,
      decorators = select_decorators(decorators, "histogram_plot"),
      expr = quote(histogram_plot)
    )

    decorated_output_qq_q <- srv_decorate_teal_data(
      "d_qq",
      data = output_qq_q,
      decorators = select_decorators(decorators, "qq_plot"),
      expr = quote(qq_plot)
    )

    decorated_output_summary_q <- srv_decorate_teal_data(
      "d_summary",
      data = output_summary_q,
      decorators = select_decorators(decorators, "summary_table"),
      expr = quote(summary_table)
    )

    decorated_output_test_q <- srv_decorate_teal_data(
      "d_test",
      data = output_test_q,
      decorators = select_decorators(decorators, "test_table"),
      expr = quote(test_table)
    )

    dist_r <- reactive(req(decorated_output_dist_q())[["histogram_plot"]])
    qq_r <- reactive(req(decorated_output_qq_q())[["qq_plot"]])

    summary_r <- reactive({
      q <- req(output_summary_q())

      DT::datatable(
        q[["summary_table_data"]],
        options = list(
          autoWidth = TRUE,
          columnDefs = list(list(width = "200px", targets = "_all"))
        ),
        rownames = FALSE
      )
    })

    output$summary_table <- DT::renderDataTable(summary_r())

    tests_r <- reactive({
      q <- req(decorated_output_test_q())
      DT::datatable(q[["test_table_data"]])
    })

    pws1 <- teal.widgets::plot_with_settings_srv(
      id = "hist_plot",
      plot_r = dist_r,
      height = plot_height,
      width = plot_width,
      brushing = FALSE
    )

    pws2 <- teal.widgets::plot_with_settings_srv(
      id = "qq_plot",
      plot_r = qq_r,
      height = plot_height,
      width = plot_width,
      brushing = FALSE
    )

    decorated_output_dist_dims_q <- set_chunk_dims(pws1, decorated_output_dist_q)

    decorated_output_qq_dims_q <- set_chunk_dims(pws2, decorated_output_qq_q)

    decorated_output_q <- reactive({
      tab <- req(input$tabs) # tab is NULL upon app launch, hence will crash without this statement
      test_q_out <- decorated_output_test_q()

      out_q <- switch(tab,
        Histogram = decorated_output_dist_dims_q(),
        QQplot = decorated_output_qq_dims_q()
      )
      withCallingHandlers(
        c(out_q, output_summary_q(), test_q_out),
        warning = function(w) {
          if (grepl("Restoring original content and adding only", conditionMessage(w))) {
            invokeRestart("muffleWarning")
          }
        }
      )
    })

    output$t_stats <- DT::renderDataTable(tests_r())

    decorated_output_q
  })
}

#' `teal` module: Response plot
#'
#' Generates a response plot for a given `response` and `x` variables.
#' This module allows users customize and add annotations to the plot depending
#' on the module's arguments.
#' It supports showing the counts grouped by other variable facets (by row / column),
#' swapping the coordinates, show count annotations and displaying the response plot
#' as frequency or density.
#'
#' @inheritParams teal::module
#' @inheritParams shared_params
#' @param response (`data_extract_spec` or `list` of multiple `data_extract_spec`)
#' Which variable to use as the response.
#' You can define one fixed column by setting `fixed = TRUE` inside the `select_spec`.
#'
#' The `data_extract_spec` must not allow multiple selection in this case.
#' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`)
#' Specifies which variable to use on the X-axis of the response plot.
#' Allow the user to select multiple columns from the `data` allowed in teal.
#'
#' The `data_extract_spec` must not allow multiple selection in this case.
#' @param row_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`)
#' optional specification of the data variable(s) to use for faceting rows.
#' @param col_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`)
#' optional specification of the data variable(s) to use for faceting columns.
#' @param coord_flip (`logical(1)`)
#' Indicates whether to flip coordinates between `x` and `response`.
#' The default value is `FALSE` and it will show the `x` variable on the x-axis
#' and the `response` variable on the y-axis.
#' @param count_labels (`logical(1)`)
#' Indicates whether to show count labels.
#' Defaults to `TRUE`.
#' @param freq (`logical(1)`)
#' Indicates whether to display frequency (`TRUE`) or density (`FALSE`).
#' Defaults to density (`FALSE`).
#'
#' @inherit shared_params return
#'
#' @note For more examples, please see the vignette "Using response plot" via
#' `vignette("using-response-plot", package = "teal.modules.general")`.
#'
#' @section Decorating Module:
#'
#' This module generates the following objects, which can be modified in place using decorators:
#' - `plot` (`ggplot`)
#'
#' A Decorator is applied to the specific output using a named list of `teal_transform_module` objects.
#' The name of this list corresponds to the name of the output to which the decorator is applied.
#' See code snippet below:
#'
#' ```
#' tm_g_response(
#'    ..., # arguments for module
#'    decorators = list(
#'      plot = teal_transform_module(...) # applied to the `plot` output
#'    )
#' )
#' ```
#'
#' For additional details and examples of decorators, refer to the vignette
#' `vignette("decorate-module-output", package = "teal.modules.general")`.
#'
#' To learn more please refer to the vignette
#' `vignette("transform-module-output", package = "teal")` or the [`teal::teal_transform_module()`] documentation.
#'
#' @inheritSection teal::example_module Reporting
#'
#' @examplesShinylive
#' library(teal.modules.general)
#' interactive <- function() TRUE
#' {{ next_example }}
#' @examples
#' # general data example
#' data <- teal_data()
#' data <- within(data, {
#'   require(nestcolor)
#'   mtcars <- mtcars
#'   for (v in c("cyl", "vs", "am", "gear")) {
#'     mtcars[[v]] <- as.factor(mtcars[[v]])
#'   }
#' })
#'
#' app <- init(
#'   data = data,
#'   modules = modules(
#'     tm_g_response(
#'       label = "Response Plots",
#'       response = data_extract_spec(
#'         dataname = "mtcars",
#'         select = select_spec(
#'           label = "Select variable:",
#'           choices = variable_choices(data[["mtcars"]], c("cyl", "gear")),
#'           selected = "cyl",
#'           multiple = FALSE,
#'           fixed = FALSE
#'         )
#'       ),
#'       x = data_extract_spec(
#'         dataname = "mtcars",
#'         select = select_spec(
#'           label = "Select variable:",
#'           choices = variable_choices(data[["mtcars"]], c("vs", "am")),
#'           selected = "vs",
#'           multiple = FALSE,
#'           fixed = FALSE
#'         )
#'       )
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
#' @examplesShinylive
#' library(teal.modules.general)
#' interactive <- function() TRUE
#' {{ next_example }}
#' @examples
#' # CDISC data example
#' data <- teal_data()
#' data <- within(data, {
#'   require(nestcolor)
#'   ADSL <- teal.data::rADSL
#' })
#' join_keys(data) <- default_cdisc_join_keys[names(data)]
#'
#' app <- init(
#'   data = data,
#'   modules = modules(
#'     tm_g_response(
#'       label = "Response Plots",
#'       response = data_extract_spec(
#'         dataname = "ADSL",
#'         select = select_spec(
#'           label = "Select variable:",
#'           choices = variable_choices(data[["ADSL"]], c("BMRKR2", "COUNTRY")),
#'           selected = "BMRKR2",
#'           multiple = FALSE,
#'           fixed = FALSE
#'         )
#'       ),
#'       x = data_extract_spec(
#'         dataname = "ADSL",
#'         select = select_spec(
#'           label = "Select variable:",
#'           choices = variable_choices(data[["ADSL"]], c("SEX", "RACE")),
#'           selected = "RACE",
#'           multiple = FALSE,
#'           fixed = FALSE
#'         )
#'       )
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
#' @export
#'
tm_g_response <- function(label = "Response Plot",
                          response,
                          x,
                          row_facet = NULL,
                          col_facet = NULL,
                          coord_flip = FALSE,
                          count_labels = TRUE,
                          rotate_xaxis_labels = FALSE,
                          freq = FALSE,
                          plot_height = c(600, 400, 5000),
                          plot_width = NULL,
                          ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
                          ggplot2_args = teal.widgets::ggplot2_args(),
                          pre_output = NULL,
                          post_output = NULL,
                          transformators = list(),
                          decorators = list()) {
  message("Initializing tm_g_response")

  # Normalize the parameters
  if (inherits(response, "data_extract_spec")) response <- list(response)
  if (inherits(x, "data_extract_spec")) x <- list(x)
  if (inherits(row_facet, "data_extract_spec")) row_facet <- list(row_facet)
  if (inherits(col_facet, "data_extract_spec")) col_facet <- list(col_facet)

  # Start of assertions
  checkmate::assert_string(label)

  checkmate::assert_list(response, types = "data_extract_spec")
  if (!all(vapply(response, function(x) !("" %in% x$select$choices), logical(1)))) {
    stop("'response' should not allow empty values")
  }
  assert_single_selection(response)

  checkmate::assert_list(x, types = "data_extract_spec")
  if (!all(vapply(x, function(x) !("" %in% x$select$choices), logical(1)))) {
    stop("'x' should not allow empty values")
  }
  assert_single_selection(x)

  checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE)
  checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE)
  checkmate::assert_flag(coord_flip)
  checkmate::assert_flag(count_labels)
  checkmate::assert_flag(rotate_xaxis_labels)
  checkmate::assert_flag(freq)

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

  ggtheme <- match.arg(ggtheme)
  checkmate::assert_class(ggplot2_args, "ggplot2_args")

  checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
  checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)

  assert_decorators(decorators, "plot")
  # End of assertions

  # Make UI args
  args <- as.list(environment())

  data_extract_list <- list(
    response = response,
    x = x,
    row_facet = row_facet,
    col_facet = col_facet
  )

  ans <- module(
    label = label,
    server = srv_g_response,
    ui = ui_g_response,
    ui_args = args,
    server_args = c(
      data_extract_list,
      list(
        plot_height = plot_height,
        plot_width = plot_width,
        ggplot2_args = ggplot2_args,
        decorators = decorators
      )
    ),
    transformators = transformators,
    datanames = teal.transform::get_extract_datanames(data_extract_list)
  )
  attr(ans, "teal_bookmarkable") <- TRUE
  ans
}

# UI function for the response module
ui_g_response <- function(id, ...) {
  ns <- NS(id)
  args <- list(...)
  is_single_dataset_value <- teal.transform::is_single_dataset(args$response, args$x, args$row_facet, args$col_facet)

  teal.widgets::standard_layout(
    output = teal.widgets::white_small_well(
      teal.widgets::plot_with_settings_ui(id = ns("myplot"))
    ),
    encoding = tags$div(
      tags$label("Encodings", class = "text-primary"),
      teal.transform::datanames_input(args[c("response", "x", "row_facet", "col_facet")]),
      teal.transform::data_extract_ui(
        id = ns("response"),
        label = "Response variable",
        data_extract_spec = args$response,
        is_single_dataset = is_single_dataset_value
      ),
      teal.transform::data_extract_ui(
        id = ns("x"),
        label = "X variable",
        data_extract_spec = args$x,
        is_single_dataset = is_single_dataset_value
      ),
      if (!is.null(args$row_facet)) {
        teal.transform::data_extract_ui(
          id = ns("row_facet"),
          label = "Row facetting",
          data_extract_spec = args$row_facet,
          is_single_dataset = is_single_dataset_value
        )
      },
      if (!is.null(args$col_facet)) {
        teal.transform::data_extract_ui(
          id = ns("col_facet"),
          label = "Column facetting",
          data_extract_spec = args$col_facet,
          is_single_dataset = is_single_dataset_value
        )
      },
      shinyWidgets::radioGroupButtons(
        inputId = ns("freq"),
        label = NULL,
        choices = c("frequency", "density"),
        selected = ifelse(args$freq, "frequency", "density"),
        justified = TRUE
      ),
      ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "plot")),
      bslib::accordion(
        open = TRUE,
        bslib::accordion_panel(
          title = "Plot settings",
          checkboxInput(ns("count_labels"), "Add count labels", value = args$count_labels),
          checkboxInput(ns("coord_flip"), "Swap axes", value = args$coord_flip),
          checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels),
          selectInput(
            inputId = ns("ggtheme"),
            label = "Theme (by ggplot):",
            choices = ggplot_themes,
            selected = args$ggtheme,
            multiple = FALSE
          )
        )
      )
    ),
    pre_output = args$pre_output,
    post_output = args$post_output
  )
}

# Server function for the response module
srv_g_response <- function(id,
                           data,
                           response,
                           x,
                           row_facet,
                           col_facet,
                           plot_height,
                           plot_width,
                           ggplot2_args,
                           decorators) {
  checkmate::assert_class(data, "reactive")
  checkmate::assert_class(isolate(data()), "teal_data")
  moduleServer(id, function(input, output, session) {
    teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")

    data_extract <- list(response = response, x = x, row_facet = row_facet, col_facet = col_facet)

    rule_diff <- function(other) {
      function(value) {
        if (other %in% names(selector_list())) {
          othervalue <- selector_list()[[other]]()[["select"]]
          if (!is.null(othervalue)) {
            if (identical(value, othervalue)) {
              "Row and column facetting variables must be different."
            }
          }
        }
      }
    }

    selector_list <- teal.transform::data_extract_multiple_srv(
      data_extract = data_extract,
      datasets = data,
      select_validation_rule = list(
        response = shinyvalidate::sv_required("Please define a column for the response variable"),
        x = shinyvalidate::sv_required("Please define a column for X variable"),
        row_facet = shinyvalidate::compose_rules(
          shinyvalidate::sv_optional(),
          ~ if (length(.) > 1) "There must be 1 or no row facetting variable.",
          rule_diff("col_facet")
        ),
        col_facet = shinyvalidate::compose_rules(
          shinyvalidate::sv_optional(),
          ~ if (length(.) > 1) "There must be 1 or no column facetting variable.",
          rule_diff("row_facet")
        )
      )
    )

    iv_r <- reactive({
      iv <- shinyvalidate::InputValidator$new()
      iv$add_rule("ggtheme", shinyvalidate::sv_required("Please select a theme"))
      teal.transform::compose_and_enable_validators(iv, selector_list)
    })

    anl_merged_input <- teal.transform::merge_expression_srv(
      selector_list = selector_list,
      datasets = data
    )

    qenv <- reactive(
      teal.code::eval_code(data(), "library(ggplot2);library(dplyr)")
    )

    anl_merged_q <- reactive({
      req(anl_merged_input())
      qenv() %>%
        teal.code::eval_code(as.expression(anl_merged_input()$expr))
    })

    merged <- list(
      anl_input_r = anl_merged_input,
      anl_q_r = anl_merged_q
    )

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

      qenv <- merged$anl_q_r()
      teal.reporter::teal_card(qenv) <-
        c(
          teal.reporter::teal_card(qenv),
          teal.reporter::teal_card("## Module's output(s)")
        )
      ANL <- qenv[["ANL"]]
      resp_var <- as.vector(merged$anl_input_r()$columns_source$response)
      x <- as.vector(merged$anl_input_r()$columns_source$x)

      validate(need(is.factor(ANL[[resp_var]]), "Please select a factor variable as the response."))
      validate(need(is.factor(ANL[[x]]), "Please select a factor variable as the X-Variable."))
      teal::validate_has_data(ANL, 10)
      teal::validate_has_data(ANL[, c(resp_var, x)], 10, complete = TRUE, allow_inf = FALSE)

      row_facet_name <- if (length(merged$anl_input_r()$columns_source$row_facet) == 0) {
        character(0)
      } else {
        as.vector(merged$anl_input_r()$columns_source$row_facet)
      }
      col_facet_name <- if (length(merged$anl_input_r()$columns_source$col_facet) == 0) {
        character(0)
      } else {
        as.vector(merged$anl_input_r()$columns_source$col_facet)
      }

      freq <- input$freq == "frequency"
      swap_axes <- input$coord_flip
      counts <- input$count_labels
      rotate_xaxis_labels <- input$rotate_xaxis_labels
      ggtheme <- input$ggtheme

      arg_position <- if (freq) "stack" else "fill"

      rowf <- if (length(row_facet_name) != 0) as.name(row_facet_name)
      colf <- if (length(col_facet_name) != 0) as.name(col_facet_name)
      resp_cl <- as.name(resp_var)
      x_cl <- as.name(x)

      if (swap_axes) {
        qenv <- teal.code::eval_code(
          qenv,
          substitute(
            expr = ANL[[x]] <- with(ANL, forcats::fct_rev(x_cl)),
            env = list(x = x, x_cl = x_cl)
          )
        )
      }

      qenv <- teal.code::eval_code(
        qenv,
        substitute(
          expr = ANL[[resp_var]] <- factor(ANL[[resp_var]]),
          env = list(resp_var = resp_var)
        )
      ) %>%
        # rowf and colf will be a NULL if not set by a user
        teal.code::eval_code(
          substitute(
            expr = ANL2 <- ANL %>%
              dplyr::group_by_at(dplyr::vars(x_cl, resp_cl, rowf, colf)) %>%
              dplyr::summarise(ns = dplyr::n()) %>%
              dplyr::group_by_at(dplyr::vars(x_cl, rowf, colf)) %>%
              dplyr::mutate(sums = sum(ns), percent = round(ns / sums * 100, 1)),
            env = list(x_cl = x_cl, resp_cl = resp_cl, rowf = rowf, colf = colf)
          )
        ) %>%
        teal.code::eval_code(
          substitute(
            expr = ANL3 <- ANL %>%
              dplyr::group_by_at(dplyr::vars(x_cl, rowf, colf)) %>%
              dplyr::summarise(ns = dplyr::n()),
            env = list(x_cl = x_cl, rowf = rowf, colf = colf)
          )
        )

      plot_call <- substitute(
        expr = ggplot2::ggplot(ANL2, ggplot2::aes(x = x_cl, y = ns)) +
          ggplot2::geom_bar(ggplot2::aes(fill = resp_cl), stat = "identity", position = arg_position),
        env = list(
          x_cl = x_cl,
          resp_cl = resp_cl,
          arg_position = arg_position
        )
      )

      if (!freq) {
        plot_call <- substitute(
          plot_call + ggplot2::expand_limits(y = c(0, 1.1)),
          env = list(plot_call = plot_call)
        )
      }

      if (counts) {
        plot_call <- substitute(
          expr = plot_call +
            ggplot2::geom_text(
              data = ANL2,
              ggplot2::aes(label = ns, x = x_cl, y = ns, group = resp_cl),
              col = "white",
              vjust = "middle",
              hjust = "middle",
              position = position_anl2_value
            ) +
            ggplot2::geom_text(
              data = ANL3, ggplot2::aes(label = ns, x = x_cl, y = anl3_y),
              hjust = hjust_value,
              vjust = vjust_value,
              position = position_anl3_value
            ),
          env = list(
            plot_call = plot_call,
            x_cl = x_cl,
            resp_cl = resp_cl,
            hjust_value = if (swap_axes) "left" else "middle",
            vjust_value = if (swap_axes) "middle" else -1,
            position_anl2_value = if (!freq) quote(position_fill(0.5)) else quote(position_stack(0.5)), # nolint: line_length_linter.
            anl3_y = if (!freq) 1.1 else as.name("ns"),
            position_anl3_value = if (!freq) "fill" else "stack"
          )
        )
      }

      if (swap_axes) {
        plot_call <- substitute(plot_call + coord_flip(), env = list(plot_call = plot_call))
      }

      facet_cl <- facet_ggplot_call(row_facet_name, col_facet_name)

      if (!is.null(facet_cl)) {
        plot_call <- substitute(expr = plot_call + facet_cl, env = list(plot_call = plot_call, facet_cl = facet_cl))
      }

      dev_ggplot2_args <- teal.widgets::ggplot2_args(
        labs = list(
          x = varname_w_label(x, ANL),
          y = varname_w_label(resp_var, ANL, prefix = "Proportion of "),
          fill = varname_w_label(resp_var, ANL)
        ),
        theme = list(legend.position = "bottom")
      )

      if (rotate_xaxis_labels) {
        dev_ggplot2_args$theme[["axis.text.x"]] <- quote(ggplot2::element_text(angle = 45, hjust = 1))
      }

      all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(
        user_plot = ggplot2_args,
        module_plot = dev_ggplot2_args
      )

      parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(
        all_ggplot2_args,
        ggtheme = ggtheme
      )

      plot_call <- substitute(expr = {
        plot <- plot_call + labs + ggthemes + themes
      }, env = list(
        plot_call = plot_call,
        labs = parsed_ggplot2_args$labs,
        themes = parsed_ggplot2_args$theme,
        ggthemes = parsed_ggplot2_args$ggtheme
      ))

      teal.reporter::teal_card(qenv) <- c(teal.reporter::teal_card(qenv), "### Plot")
      teal.code::eval_code(qenv, plot_call)
    })

    decorated_output_plot_q <- srv_decorate_teal_data(
      id = "decorator",
      data = output_q,
      decorators = select_decorators(decorators, "plot"),
      expr = quote(plot)
    )

    plot_r <- reactive(req(decorated_output_plot_q())[["plot"]])

    # Insert the plot into a plot_with_settings module from teal.widgets
    pws <- teal.widgets::plot_with_settings_srv(
      id = "myplot",
      plot_r = plot_r,
      height = plot_height,
      width = plot_width
    )

    set_chunk_dims(pws, decorated_output_plot_q)
  })
}

#' `teal` module: Univariate and bivariate visualizations
#'
#' Module enables the creation of univariate and bivariate plots,
#' facilitating the exploration of data distributions and relationships between two variables.
#'
#' This is a general module to visualize 1 & 2 dimensional data.
#'
#' @note
#' For more examples, please see the vignette "Using bivariate plot" via
#' `vignette("using-bivariate-plot", package = "teal.modules.general")`.
#'
#' @inheritParams teal::module
#' @inheritParams shared_params
#' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`)
#' Variable names selected to plot along the x-axis by default.
#' Can be numeric, factor or character.
#' No empty selections are allowed.
#' @param y (`data_extract_spec` or `list` of multiple `data_extract_spec`)
#' Variable names selected to plot along the y-axis by default.
#' Can be numeric, factor or character.
#' @param use_density (`logical`) optional, indicates whether to plot density (`TRUE`) or frequency (`FALSE`).
#' Defaults to frequency (`FALSE`).
#' @param row_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,
#' specification of the data variable(s) to use for faceting rows.
#' @param col_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,
#' specification of the data variable(s) to use for faceting columns.
#' @param facet (`logical`) optional, specifies whether the facet encodings `ui` elements are toggled
#' on and shown to the user by default. Defaults to `TRUE` if either `row_facet` or `column_facet`
#' are supplied.
#' @param color_settings (`logical`) Whether coloring, filling and size should be applied
#' and `UI` tool offered to the user.
#' @param color (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,
#' specification of the data variable(s) selected for the outline color inside the coloring settings.
#' It will be applied when `color_settings` is set to `TRUE`.
#' @param fill (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,
#' specification of the data variable(s) selected for the fill color inside the coloring settings.
#' It will be applied when `color_settings` is set to `TRUE`.
#' @param size (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,
#' specification of the data variable(s) selected for the size of `geom_point` plots inside the coloring settings.
#' It will be applied when `color_settings` is set to `TRUE`.
#' @param free_x_scales (`logical`) optional, whether X scaling shall be changeable.
#' Does not allow scaling to be changed by default (`FALSE`).
#' @param free_y_scales (`logical`) optional, whether Y scaling shall be changeable.
#' Does not allow scaling to be changed by default (`FALSE`).
#' @param swap_axes (`logical`) optional, whether to swap X and Y axes. Defaults to `FALSE`.
#'
#' @inherit shared_params return
#'
#' @section Decorating Module:
#'
#' This module generates the following objects, which can be modified in place using decorators:
#' - `plot` (`ggplot`)
#'
#' A Decorator is applied to the specific output using a named list of `teal_transform_module` objects.
#' The name of this list corresponds to the name of the output to which the decorator is applied.
#' See code snippet below:
#'
#' ```
#' tm_g_bivariate(
#'    ..., # arguments for module
#'    decorators = list(
#'      plot = teal_transform_module(...) # applied to the `plot` output
#'    )
#' )
#' ```
#'
#' For additional details and examples of decorators, refer to the vignette
#' `vignette("decorate-module-output", package = "teal.modules.general")`.
#'
#' To learn more please refer to the vignette
#' `vignette("transform-module-output", package = "teal")` or the [`teal::teal_transform_module()`] documentation.
#'
#' @inheritSection teal::example_module Reporting
#'
#' @examplesShinylive
#' library(teal.modules.general)
#' interactive <- function() TRUE
#' {{ next_example }}
#' @examples
#' # general data example
#' data <- teal_data()
#' data <- within(data, {
#'   require(nestcolor)
#'   CO2 <- data.frame(CO2)
#' })
#'
#' app <- init(
#'   data = data,
#'   modules = tm_g_bivariate(
#'     x = data_extract_spec(
#'       dataname = "CO2",
#'       select = select_spec(
#'         label = "Select variable:",
#'         choices = variable_choices(data[["CO2"]]),
#'         selected = "conc",
#'         fixed = FALSE
#'       )
#'     ),
#'     y = data_extract_spec(
#'       dataname = "CO2",
#'       select = select_spec(
#'         label = "Select variable:",
#'         choices = variable_choices(data[["CO2"]]),
#'         selected = "uptake",
#'         multiple = FALSE,
#'         fixed = FALSE
#'       )
#'     ),
#'     row_facet = data_extract_spec(
#'       dataname = "CO2",
#'       select = select_spec(
#'         label = "Select variable:",
#'         choices = variable_choices(data[["CO2"]]),
#'         selected = "Type",
#'         fixed = FALSE
#'       )
#'     ),
#'     col_facet = data_extract_spec(
#'       dataname = "CO2",
#'       select = select_spec(
#'         label = "Select variable:",
#'         choices = variable_choices(data[["CO2"]]),
#'         selected = "Treatment",
#'         fixed = FALSE
#'       )
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
#' @examplesShinylive
#' library(teal.modules.general)
#' interactive <- function() TRUE
#' {{ next_example }}
#' @examples
#' # CDISC data example
#' data <- teal_data()
#' data <- within(data, {
#'   require(nestcolor)
#'   ADSL <- teal.data::rADSL
#' })
#' join_keys(data) <- default_cdisc_join_keys[names(data)]
#'
#' app <- init(
#'   data = data,
#'   modules = tm_g_bivariate(
#'     x = data_extract_spec(
#'       dataname = "ADSL",
#'       select = select_spec(
#'         label = "Select variable:",
#'         choices = variable_choices(data[["ADSL"]]),
#'         selected = "AGE",
#'         fixed = FALSE
#'       )
#'     ),
#'     y = data_extract_spec(
#'       dataname = "ADSL",
#'       select = select_spec(
#'         label = "Select variable:",
#'         choices = variable_choices(data[["ADSL"]]),
#'         selected = "SEX",
#'         multiple = FALSE,
#'         fixed = FALSE
#'       )
#'     ),
#'     row_facet = data_extract_spec(
#'       dataname = "ADSL",
#'       select = select_spec(
#'         label = "Select variable:",
#'         choices = variable_choices(data[["ADSL"]]),
#'         selected = "ARM",
#'         fixed = FALSE
#'       )
#'     ),
#'     col_facet = data_extract_spec(
#'       dataname = "ADSL",
#'       select = select_spec(
#'         label = "Select variable:",
#'         choices = variable_choices(data[["ADSL"]]),
#'         selected = "COUNTRY",
#'         fixed = FALSE
#'       )
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
#' @export
#'
tm_g_bivariate <- function(label = "Bivariate Plots",
                           x,
                           y,
                           row_facet = NULL,
                           col_facet = NULL,
                           facet = !is.null(row_facet) || !is.null(col_facet),
                           color = NULL,
                           fill = NULL,
                           size = NULL,
                           use_density = FALSE,
                           color_settings = FALSE,
                           free_x_scales = FALSE,
                           free_y_scales = FALSE,
                           plot_height = c(600, 200, 2000),
                           plot_width = NULL,
                           rotate_xaxis_labels = FALSE,
                           swap_axes = FALSE,
                           ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
                           ggplot2_args = teal.widgets::ggplot2_args(),
                           pre_output = NULL,
                           post_output = NULL,
                           transformators = list(),
                           decorators = list()) {
  message("Initializing tm_g_bivariate")

  # Normalize the parameters
  if (inherits(x, "data_extract_spec")) x <- list(x)
  if (inherits(y, "data_extract_spec")) y <- list(y)
  if (inherits(row_facet, "data_extract_spec")) row_facet <- list(row_facet)
  if (inherits(col_facet, "data_extract_spec")) col_facet <- list(col_facet)
  if (inherits(color, "data_extract_spec")) color <- list(color)
  if (inherits(fill, "data_extract_spec")) fill <- list(fill)
  if (inherits(size, "data_extract_spec")) size <- list(size)

  # Start of assertions
  checkmate::assert_string(label)

  checkmate::assert_list(x, types = "data_extract_spec")
  assert_single_selection(x)

  checkmate::assert_list(y, types = "data_extract_spec")
  assert_single_selection(y)

  checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE)
  assert_single_selection(row_facet)

  checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE)
  assert_single_selection(col_facet)

  checkmate::assert_flag(facet)

  checkmate::assert_list(color, types = "data_extract_spec", null.ok = TRUE)
  assert_single_selection(color)

  checkmate::assert_list(fill, types = "data_extract_spec", null.ok = TRUE)
  assert_single_selection(fill)

  checkmate::assert_list(size, types = "data_extract_spec", null.ok = TRUE)
  assert_single_selection(size)

  checkmate::assert_flag(use_density)

  # Determines color, fill & size if they are not explicitly set
  checkmate::assert_flag(color_settings)
  if (color_settings) {
    if (is.null(color)) {
      color <- x
      color[[1]]$select <- teal.transform::select_spec(choices = color[[1]]$select$choices, selected = NULL)
    }
    if (is.null(fill)) {
      fill <- x
      fill[[1]]$select <- teal.transform::select_spec(choices = fill[[1]]$select$choices, selected = NULL)
    }
    if (is.null(size)) {
      size <- x
      size[[1]]$select <- teal.transform::select_spec(choices = size[[1]]$select$choices, selected = NULL)
    }
  } else {
    if (!is.null(c(color, fill, size))) {
      stop("'color_settings' argument needs to be set to TRUE if 'color', 'fill', and/or 'size' is/are supplied.")
    }
  }

  checkmate::assert_flag(free_x_scales)
  checkmate::assert_flag(free_y_scales)

  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(rotate_xaxis_labels)
  checkmate::assert_flag(swap_axes)

  ggtheme <- match.arg(ggtheme)
  checkmate::assert_class(ggplot2_args, "ggplot2_args")

  checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
  checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)

  assert_decorators(decorators, "plot")
  # End of assertions

  # Make UI args
  args <- as.list(environment())

  data_extract_list <- list(
    x = x,
    y = y,
    row_facet = row_facet,
    col_facet = col_facet,
    color_settings = color_settings,
    color = color,
    fill = fill,
    size = size
  )

  ans <- module(
    label = label,
    server = srv_g_bivariate,
    ui = ui_g_bivariate,
    ui_args = args,
    server_args = c(
      data_extract_list,
      list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args, decorators = decorators)
    ),
    transformators = transformators,
    datanames = teal.transform::get_extract_datanames(data_extract_list)
  )
  attr(ans, "teal_bookmarkable") <- TRUE
  ans
}

# UI function for the bivariate module
ui_g_bivariate <- function(id, ...) {
  args <- list(...)
  is_single_dataset_value <- teal.transform::is_single_dataset(
    args$x, args$y, args$row_facet, args$col_facet, args$color, args$fill, args$size
  )

  ns <- NS(id)
  teal.widgets::standard_layout(
    output = teal.widgets::white_small_well(
      tags$div(teal.widgets::plot_with_settings_ui(id = ns("myplot")))
    ),
    encoding = tags$div(
      tags$label("Encodings", class = "text-primary"),
      teal.transform::datanames_input(args[c("x", "y", "row_facet", "col_facet", "color", "fill", "size")]),
      teal.transform::data_extract_ui(
        id = ns("x"),
        label = "X variable",
        data_extract_spec = args$x,
        is_single_dataset = is_single_dataset_value
      ),
      teal.transform::data_extract_ui(
        id = ns("y"),
        label = "Y variable",
        data_extract_spec = args$y,
        is_single_dataset = is_single_dataset_value
      ),
      conditionalPanel(
        condition =
          "$(\"button[data-id*='-x-dataset'][data-id$='-select']\").text() == '- Nothing selected - ' ||
          $(\"button[data-id*='-y-dataset'][data-id$='-select']\").text() == '- Nothing selected - ' ",
        shinyWidgets::radioGroupButtons(
          inputId = ns("use_density"),
          label = NULL,
          choices = c("frequency", "density"),
          selected = ifelse(args$use_density, "density", "frequency"),
          justified = TRUE
        )
      ),
      ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "plot")),
      if (!is.null(args$row_facet) || !is.null(args$col_facet)) {
        tags$div(
          class = "data-extract-box",
          tags$br(),
          bslib::input_switch(
            id = ns("facetting"),
            label = "Facetting",
            value = args$facet
          ),
          conditionalPanel(
            condition = paste0("input['", ns("facetting"), "']"),
            tags$div(
              if (!is.null(args$row_facet)) {
                teal.transform::data_extract_ui(
                  id = ns("row_facet"),
                  label = "Row facetting variable",
                  data_extract_spec = args$row_facet,
                  is_single_dataset = is_single_dataset_value
                )
              },
              if (!is.null(args$col_facet)) {
                teal.transform::data_extract_ui(
                  id = ns("col_facet"),
                  label = "Column facetting variable",
                  data_extract_spec = args$col_facet,
                  is_single_dataset = is_single_dataset_value
                )
              },
              checkboxInput(ns("free_x_scales"), "free x scales", value = args$free_x_scales),
              checkboxInput(ns("free_y_scales"), "free y scales", value = args$free_y_scales)
            )
          )
        )
      },
      if (args$color_settings) {
        # Put a grey border around the coloring settings
        tags$div(
          class = "data-extract-box",
          tags$label("Color settings"),
          bslib::input_switch(
            id = ns("coloring"),
            label = "Color settings",
            value = TRUE
          ),
          conditionalPanel(
            condition = paste0("input['", ns("coloring"), "']"),
            tags$div(
              teal.transform::data_extract_ui(
                id = ns("color"),
                label = "Outline color by variable",
                data_extract_spec = args$color,
                is_single_dataset = is_single_dataset_value
              ),
              teal.transform::data_extract_ui(
                id = ns("fill"),
                label = "Fill color by variable",
                data_extract_spec = args$fill,
                is_single_dataset = is_single_dataset_value
              ),
              tags$div(
                id = ns("size_settings"),
                teal.transform::data_extract_ui(
                  id = ns("size"),
                  label = "Size of points by variable (only if x and y are numeric)",
                  data_extract_spec = args$size,
                  is_single_dataset = is_single_dataset_value
                )
              )
            )
          )
        )
      },
      bslib::accordion(
        open = TRUE,
        bslib::accordion_panel(
          title = "Plot settings",
          checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels),
          checkboxInput(ns("swap_axes"), "Swap axes", value = args$swap_axes),
          selectInput(
            inputId = ns("ggtheme"),
            label = "Theme (by ggplot):",
            choices = ggplot_themes,
            selected = args$ggtheme,
            multiple = FALSE
          ),
          sliderInput(
            ns("alpha"), "Opacity Scatterplot:",
            min = 0, max = 1,
            step = .05, value = .5, ticks = FALSE
          ),
          sliderInput(
            ns("fixed_size"), "Scatterplot point size:",
            min = 1, max = 8,
            step = 1, value = 2, ticks = FALSE
          ),
          checkboxInput(ns("add_lines"), "Add lines"),
        )
      )
    ),
    pre_output = args$pre_output,
    post_output = args$post_output
  )
}

# Server function for the bivariate module
srv_g_bivariate <- function(id,
                            data,
                            x,
                            y,
                            row_facet,
                            col_facet,
                            color_settings = FALSE,
                            color,
                            fill,
                            size,
                            plot_height,
                            plot_width,
                            ggplot2_args,
                            decorators) {
  checkmate::assert_class(data, "reactive")
  checkmate::assert_class(isolate(data()), "teal_data")
  moduleServer(id, function(input, output, session) {
    teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")

    ns <- session$ns

    data_extract <- list(
      x = x, y = y, row_facet = row_facet, col_facet = col_facet,
      color = color, fill = fill, size = size
    )

    rule_var <- function(other) {
      function(value) {
        othervalue <- selector_list()[[other]]()$select
        if (length(value) == 0L && length(othervalue) == 0L) {
          "Please select at least one of x-variable or y-variable"
        }
      }
    }
    rule_diff <- function(other) {
      function(value) {
        othervalue <- selector_list()[[other]]()[["select"]]
        if (!is.null(othervalue)) {
          if (identical(value, othervalue)) {
            "Row and column facetting variables must be different."
          }
        }
      }
    }

    selector_list <- teal.transform::data_extract_multiple_srv(
      data_extract = data_extract,
      datasets = data,
      select_validation_rule = list(
        x = rule_var("y"),
        y = rule_var("x"),
        row_facet = shinyvalidate::compose_rules(
          shinyvalidate::sv_optional(),
          rule_diff("col_facet")
        ),
        col_facet = shinyvalidate::compose_rules(
          shinyvalidate::sv_optional(),
          rule_diff("row_facet")
        )
      )
    )

    iv_r <- reactive({
      iv_facet <- shinyvalidate::InputValidator$new()
      iv_child <- teal.transform::compose_and_enable_validators(iv_facet, selector_list,
        validator_names = c("row_facet", "col_facet")
      )
      iv_child$condition(~ isTRUE(input$facetting))

      iv <- shinyvalidate::InputValidator$new()
      iv$add_validator(iv_child)
      teal.transform::compose_and_enable_validators(iv, selector_list, validator_names = c("x", "y"))
    })

    anl_merged_input <- teal.transform::merge_expression_srv(
      selector_list = selector_list,
      datasets = data
    )

    anl_merged_q <- reactive({
      obj <- data()
      teal.reporter::teal_card(obj) <-
        c(
          teal.reporter::teal_card(obj),
          teal.reporter::teal_card("## Module's output(s)")
        )
      obj |>
        teal.code::eval_code("library(ggplot2);library(dplyr)") |>
        teal.code::eval_code(as.expression(anl_merged_input()$expr))
    })

    merged <- list(
      anl_input_r = anl_merged_input,
      anl_q_r = anl_merged_q
    )

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

      ANL <- merged$anl_q_r()[["ANL"]]
      teal::validate_has_data(ANL, 3)

      x_col_vec <- as.vector(merged$anl_input_r()$columns_source$x)
      x_name <- `if`(is.null(x_col_vec), character(0), x_col_vec)
      y_col_vec <- as.vector(merged$anl_input_r()$columns_source$y)
      y_name <- `if`(is.null(y_col_vec), character(0), y_col_vec)

      row_facet_name <- as.vector(merged$anl_input_r()$columns_source$row_facet)
      col_facet_name <- as.vector(merged$anl_input_r()$columns_source$col_facet)
      color_name <- if ("color" %in% names(merged$anl_input_r()$columns_source)) {
        as.vector(merged$anl_input_r()$columns_source$color)
      } else {
        character(0)
      }
      fill_name <- if ("fill" %in% names(merged$anl_input_r()$columns_source)) {
        as.vector(merged$anl_input_r()$columns_source$fill)
      } else {
        character(0)
      }
      size_name <- if ("size" %in% names(merged$anl_input_r()$columns_source)) {
        as.vector(merged$anl_input_r()$columns_source$size)
      } else {
        character(0)
      }

      use_density <- input$use_density == "density"
      free_x_scales <- input$free_x_scales
      free_y_scales <- input$free_y_scales
      ggtheme <- input$ggtheme
      rotate_xaxis_labels <- input$rotate_xaxis_labels
      swap_axes <- input$swap_axes

      is_scatterplot <- all(vapply(ANL[c(x_name, y_name)], is.numeric, logical(1))) &&
        length(x_name) > 0 && length(y_name) > 0

      if (is_scatterplot) {
        shinyjs::show("alpha")
        alpha <- input$alpha
        shinyjs::show("add_lines")

        if (color_settings && input$coloring) {
          shinyjs::hide("fixed_size")
          shinyjs::show("size_settings")
          size <- NULL
        } else {
          shinyjs::show("fixed_size")
          size <- input$fixed_size
        }
      } else {
        shinyjs::hide("add_lines")
        updateCheckboxInput(session, "add_lines", value = restoreInput(ns("add_lines"), FALSE))
        shinyjs::hide("alpha")
        shinyjs::hide("fixed_size")
        shinyjs::hide("size_settings")
        alpha <- 1
        size <- NULL
      }

      teal::validate_has_data(ANL[, c(x_name, y_name), drop = FALSE], 3, complete = TRUE, allow_inf = FALSE)

      cl <- bivariate_plot_call(
        data_name = "ANL",
        x = x_name,
        y = y_name,
        x_class = ifelse(!identical(x_name, character(0)), class(ANL[[x_name]]), "NULL"),
        y_class = ifelse(!identical(y_name, character(0)), class(ANL[[y_name]]), "NULL"),
        x_label = varname_w_label(x_name, ANL),
        y_label = varname_w_label(y_name, ANL),
        freq = !use_density,
        theme = ggtheme,
        rotate_xaxis_labels = rotate_xaxis_labels,
        swap_axes = swap_axes,
        alpha = alpha,
        size = size,
        ggplot2_args = ggplot2_args
      )

      facetting <- (isTRUE(input$facetting) && (!is.null(row_facet_name) || !is.null(col_facet_name)))

      if (facetting) {
        facet_cl <- facet_ggplot_call(row_facet_name, col_facet_name, free_x_scales, free_y_scales)

        if (!is.null(facet_cl)) {
          cl <- call("+", cl, facet_cl)
        }
      }

      if (input$add_lines) {
        cl <- call("+", cl, quote(geom_line(size = 1)))
      }

      coloring_cl <- NULL
      if (color_settings) {
        if (input$coloring) {
          coloring_cl <- coloring_ggplot_call(
            colour = color_name,
            fill = fill_name,
            size = size_name,
            is_point = any(grepl("geom_point", cl %>% deparse()))
          )
          legend_lbls <- substitute(
            expr = labs(color = color_name, fill = fill_name, size = size_name),
            env = list(
              color_name = varname_w_label(color_name, ANL),
              fill_name = varname_w_label(fill_name, ANL),
              size_name = varname_w_label(size_name, ANL)
            )
          )
        }
        if (!is.null(coloring_cl)) {
          cl <- call("+", call("+", cl, coloring_cl), legend_lbls)
        }
      }

      obj <- merged$anl_q_r()
      teal.reporter::teal_card(obj) <- c(teal.reporter::teal_card(obj), "### Plot")
      teal.code::eval_code(obj, substitute(expr = plot <- cl, env = list(cl = cl)))
    })

    decorated_output_q_facets <- srv_decorate_teal_data(
      "decorator",
      data = output_q,
      decorators = select_decorators(decorators, "plot"),
      expr = reactive({
        ANL <- merged$anl_q_r()[["ANL"]]
        row_facet_name <- as.vector(merged$anl_input_r()$columns_source$row_facet)
        col_facet_name <- as.vector(merged$anl_input_r()$columns_source$col_facet)

        # Add labels to facets
        nulled_row_facet_name <- varname_w_label(row_facet_name, ANL)
        nulled_col_facet_name <- varname_w_label(col_facet_name, ANL)
        facetting <- (isTRUE(input$facetting) && (!is.null(row_facet_name) || !is.null(col_facet_name)))
        without_facet <- (is.null(nulled_row_facet_name) && is.null(nulled_col_facet_name)) || !facetting

        print_call <- if (without_facet) {
          quote(plot)
        } else {
          substitute(
            expr = {
              teal.modules.general::add_facet_labels(
                plot,
                xfacet_label = nulled_col_facet_name,
                yfacet_label = nulled_row_facet_name
              )
            },
            env = list(nulled_col_facet_name = nulled_col_facet_name, nulled_row_facet_name = nulled_row_facet_name)
          )
        }
        print_call
      })
    )

    plot_r <- reactive({
      req(decorated_output_q_facets())[["plot"]]
    })

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

    set_chunk_dims(pws, decorated_output_q_facets)
  })
}

# Get Substituted ggplot call
bivariate_plot_call <- function(data_name,
                                x = character(0),
                                y = character(0),
                                x_class = "NULL",
                                y_class = "NULL",
                                x_label = NULL,
                                y_label = NULL,
                                freq = TRUE,
                                theme = "gray",
                                rotate_xaxis_labels = FALSE,
                                swap_axes = FALSE,
                                alpha = double(0),
                                size = 2,
                                ggplot2_args = teal.widgets::ggplot2_args()) {
  supported_types <- c("NULL", "numeric", "integer", "factor", "character", "logical", "ordered")
  validate(need(x_class %in% supported_types, paste0("Data type '", x_class, "' is not supported.")))
  validate(need(y_class %in% supported_types, paste0("Data type '", y_class, "' is not supported.")))


  if (identical(x, character(0))) {
    x <- x_label <- "-"
  } else {
    x <- if (is.call(x)) x else as.name(x)
  }
  if (identical(y, character(0))) {
    y <- y_label <- "-"
  } else {
    y <- if (is.call(y)) y else as.name(y)
  }

  bivariate_ggplot_call(
    x_class = x_class,
    y_class = y_class,
    freq = freq,
    theme = theme,
    rotate_xaxis_labels = rotate_xaxis_labels,
    swap_axes = swap_axes,
    alpha = alpha,
    size = size,
    ggplot2_args = ggplot2_args,
    x = x,
    y = y,
    xlab = x_label,
    ylab = y_label,
    data_name = data_name
  )
}

# Create ggplot part of plot call
# Due to the type of the x and y variable the plot type is chosen
bivariate_ggplot_call <- function(x_class,
                                  y_class,
                                  freq = TRUE,
                                  theme = "gray",
                                  rotate_xaxis_labels = FALSE,
                                  swap_axes = FALSE,
                                  size = double(0),
                                  alpha = double(0),
                                  x = NULL,
                                  y = NULL,
                                  xlab = "-",
                                  ylab = "-",
                                  data_name = "ANL",
                                  ggplot2_args = teal.widgets::ggplot2_args()) {
  x_class <- switch(x_class,
    "character" = ,
    "ordered" = ,
    "logical" = ,
    "factor" = "factor",
    "integer" = ,
    "numeric" = "numeric",
    "NULL" = "NULL",
    stop("unsupported x_class: ", x_class)
  )
  y_class <- switch(y_class,
    "character" = ,
    "ordered" = ,
    "logical" = ,
    "factor" = "factor",
    "integer" = ,
    "numeric" = "numeric",
    "NULL" = "NULL",
    stop("unsupported y_class: ", y_class)
  )

  if (all(c(x_class, y_class) == "NULL")) {
    stop("either x or y is required")
  }

  reduce_plot_call <- function(...) {
    args <- Filter(Negate(is.null), list(...))
    Reduce(function(x, y) call("+", x, y), args)
  }

  plot_call <- substitute(ggplot2::ggplot(data_name), env = list(data_name = as.name(data_name)))

  # Single data plots
  if (x_class == "numeric" && y_class == "NULL") {
    plot_call <- reduce_plot_call(plot_call, substitute(ggplot2::aes(x = xval), env = list(xval = x)))

    if (freq) {
      plot_call <- reduce_plot_call(
        plot_call,
        quote(ggplot2::geom_histogram(bins = 30)),
        quote(ggplot2::ylab("Frequency"))
      )
    } else {
      plot_call <- reduce_plot_call(
        plot_call,
        quote(ggplot2::geom_histogram(bins = 30, ggplot2::aes(y = ggplot2::after_stat(density)))),
        quote(ggplot2::geom_density(ggplot2::aes(y = ggplot2::after_stat(density)))),
        quote(ggplot2::ylab("Density"))
      )
    }
  } else if (x_class == "NULL" && y_class == "numeric") {
    plot_call <- reduce_plot_call(plot_call, substitute(ggplot2::aes(x = yval), env = list(yval = y)))

    if (freq) {
      plot_call <- reduce_plot_call(
        plot_call,
        quote(ggplot2::geom_histogram(bins = 30)),
        quote(ggplot2::ylab("Frequency"))
      )
    } else {
      plot_call <- reduce_plot_call(
        plot_call,
        quote(ggplot2::geom_histogram(bins = 30, ggplot2::aes(y = ggplot2::after_stat(density)))),
        quote(ggplot2::geom_density(ggplot2::aes(y = ggplot2::after_stat(density)))),
        quote(ggplot2::ylab("Density"))
      )
    }
  } else if (x_class == "factor" && y_class == "NULL") {
    plot_call <- reduce_plot_call(plot_call, substitute(ggplot2::aes(x = xval), env = list(xval = x)))

    if (freq) {
      plot_call <- reduce_plot_call(
        plot_call,
        quote(ggplot2::geom_bar()),
        quote(ggplot2::ylab("Frequency"))
      )
    } else {
      plot_call <- reduce_plot_call(
        plot_call,
        quote(ggplot2::geom_bar(ggplot2::aes(y = ggplot2::after_stat(prop), group = 1))),
        quote(ggplot2::ylab("Fraction"))
      )
    }
  } else if (x_class == "NULL" && y_class == "factor") {
    plot_call <- reduce_plot_call(plot_call, substitute(ggplot2::aes(x = yval), env = list(yval = y)))

    if (freq) {
      plot_call <- reduce_plot_call(
        plot_call,
        quote(ggplot2::geom_bar()),
        quote(ggplot2::ylab("Frequency"))
      )
    } else {
      plot_call <- reduce_plot_call(
        plot_call,
        quote(ggplot2::geom_bar(ggplot2::aes(y = ggplot2::after_stat(prop), group = 1))),
        quote(ggplot2::ylab("Fraction"))
      )
    }
    # Numeric Plots
  } else if (x_class == "numeric" && y_class == "numeric") {
    plot_call <- reduce_plot_call(
      plot_call,
      substitute(ggplot2::aes(x = xval, y = yval), env = list(xval = x, yval = y)),
      # pch = 21 for consistent coloring behaviour b/w all geoms (outline and fill properties)
      `if`(
        !is.null(size),
        substitute(
          ggplot2::geom_point(alpha = alphaval, size = sizeval, pch = 21),
          env = list(alphaval = alpha, sizeval = size)
        ),
        substitute(
          ggplot2::geom_point(alpha = alphaval, pch = 21),
          env = list(alphaval = alpha)
        )
      )
    )
  } else if ((x_class == "numeric" && y_class == "factor") || (x_class == "factor" && y_class == "numeric")) {
    plot_call <- reduce_plot_call(
      plot_call,
      substitute(ggplot2::aes(x = xval, y = yval), env = list(xval = x, yval = y)),
      quote(ggplot2::geom_boxplot())
    )
    # Factor and character plots
  } else if (x_class == "factor" && y_class == "factor") {
    plot_call <- reduce_plot_call(
      plot_call,
      substitute(
        teal.modules.general::geom_mosaic(ggplot2::aes(x = xval, fill = yval)),
        env = list(xval = x, yval = y)
      )
    )
  } else {
    stop("x y type combination not allowed")
  }

  labs_base <- if (x_class == "NULL") {
    list(x = substitute(ylab, list(ylab = ylab)))
  } else if (y_class == "NULL") {
    list(x = substitute(xlab, list(xlab = xlab)))
  } else {
    list(
      x = substitute(xlab, list(xlab = xlab)),
      y = substitute(ylab, list(ylab = ylab))
    )
  }

  dev_ggplot2_args <- teal.widgets::ggplot2_args(labs = labs_base)

  if (rotate_xaxis_labels) {
    dev_ggplot2_args$theme <- list(axis.text.x = quote(ggplot2::element_text(angle = 45, hjust = 1)))
  }

  all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(
    user_plot = ggplot2_args,
    module_plot = dev_ggplot2_args
  )

  parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(all_ggplot2_args, ggtheme = theme)

  plot_call <- reduce_plot_call(
    plot_call,
    parsed_ggplot2_args$labs,
    parsed_ggplot2_args$ggtheme,
    parsed_ggplot2_args$theme
  )

  if (swap_axes) {
    plot_call <- reduce_plot_call(plot_call, quote(coord_flip()))
  }

  plot_call
}

# Create facet call
facet_ggplot_call <- function(row_facet = character(0),
                              col_facet = character(0),
                              free_x_scales = FALSE,
                              free_y_scales = FALSE) {
  scales <- if (free_x_scales && free_y_scales) {
    "free"
  } else if (free_x_scales) {
    "free_x"
  } else if (free_y_scales) {
    "free_y"
  } else {
    "fixed"
  }

  if (identical(row_facet, character(0)) && identical(col_facet, character(0))) {
    NULL
  } else if (!identical(row_facet, character(0)) && !identical(col_facet, character(0))) {
    call(
      "facet_grid",
      rows = call_fun_dots("vars", row_facet),
      cols = call_fun_dots("vars", col_facet),
      scales = scales
    )
  } else if (identical(row_facet, character(0)) && !identical(col_facet, character(0))) {
    call("facet_grid", cols = call_fun_dots("vars", col_facet), scales = scales)
  } else if (!identical(row_facet, character(0)) && identical(col_facet, character(0))) {
    call("facet_grid", rows = call_fun_dots("vars", row_facet), scales = scales)
  }
}

coloring_ggplot_call <- function(colour,
                                 fill,
                                 size,
                                 is_point = FALSE) {
  if (
    !identical(colour, character(0)) &&
      !identical(fill, character(0)) &&
      is_point &&
      !identical(size, character(0))
  ) {
    substitute(
      expr = ggplot2::aes(colour = colour_name, fill = fill_name, size = size_name),
      env = list(colour_name = as.name(colour), fill_name = as.name(fill), size_name = as.name(size))
    )
  } else if (
    identical(colour, character(0)) &&
      !identical(fill, character(0)) &&
      is_point &&
      identical(size, character(0))
  ) {
    substitute(expr = ggplot2::aes(fill = fill_name), env = list(fill_name = as.name(fill)))
  } else if (
    !identical(colour, character(0)) &&
      !identical(fill, character(0)) &&
      (!is_point || identical(size, character(0)))
  ) {
    substitute(
      expr = ggplot2::aes(colour = colour_name, fill = fill_name),
      env = list(colour_name = as.name(colour), fill_name = as.name(fill))
    )
  } else if (
    !identical(colour, character(0)) &&
      identical(fill, character(0)) &&
      (!is_point || identical(size, character(0)))
  ) {
    substitute(expr = ggplot2::aes(colour = colour_name), env = list(colour_name = as.name(colour)))
  } else if (
    identical(colour, character(0)) &&
      !identical(fill, character(0)) &&
      (!is_point || identical(size, character(0)))
  ) {
    substitute(expr = ggplot2::aes(fill = fill_name), env = list(fill_name = as.name(fill)))
  } else if (
    identical(colour, character(0)) &&
      identical(fill, character(0)) &&
      is_point &&
      !identical(size, character(0))
  ) {
    substitute(expr = ggplot2::aes(size = size_name), env = list(size_name = as.name(size)))
  } else if (
    !identical(colour, character(0)) &&
      identical(fill, character(0)) &&
      is_point &&
      !identical(size, character(0))
  ) {
    substitute(
      expr = ggplot2::aes(colour = colour_name, size = size_name),
      env = list(colour_name = as.name(colour), size_name = as.name(size))
    )
  } else if (
    identical(colour, character(0)) &&
      !identical(fill, character(0)) &&
      is_point &&
      !identical(size, character(0))
  ) {
    substitute(
      expr = ggplot2::aes(colour = colour_name, fill = fill_name, size = size_name),
      env = list(colour_name = as.name(fill), fill_name = as.name(fill), size_name = as.name(size))
    )
  } else {
    NULL
  }
}

#' `teal` module: Stack plots of variables and show association with reference variable
#'
#' Module provides functionality for visualizing the distribution of variables and
#' their association with a reference variable.
#' It supports configuring the appearance of the plots, including themes and whether to show associations.
#'
#'
#' @note For more examples, please see the vignette "Using association plot" via
#' `vignette("using-association-plot", package = "teal.modules.general")`.
#'
#' @inheritParams teal::module
#' @inheritParams shared_params
#' @param ref (`data_extract_spec` or `list` of multiple `data_extract_spec`)
#' Reference variable, must accepts a `data_extract_spec` with `select_spec(multiple = FALSE)`
#' to ensure single selection option.
#' @param vars (`data_extract_spec` or `list` of multiple `data_extract_spec`)
#' Variables to be associated with the reference variable.
#' @param show_association (`logical`) optional, whether show association of `vars`
#' with reference variable. Defaults to `TRUE`.
#' @param distribution_theme,association_theme (`character`) optional, `ggplot2` themes to be used by default.
#' Default to `"gray"`.
#'
#' @param ggplot2_args `r roxygen_ggplot2_args_param("Bivariate1", "Bivariate2")`
#'
#' @inherit shared_params return
#'
#' @section Decorating Module:
#'
#' This module generates the following objects, which can be modified in place using decorators:
#' - `plot` (`grob` created with [ggplot2::ggplotGrob()])
#'
#' A Decorator is applied to the specific output using a named list of `teal_transform_module` objects.
#' The name of this list corresponds to the name of the output to which the decorator is applied.
#' See code snippet below:
#'
#' ```
#' tm_g_association(
#'    ..., # arguments for module
#'    decorators = list(
#'      plot = teal_transform_module(...) # applied to the `plot` output
#'    )
#' )
#' ```
#'
#' For additional details and examples of decorators, refer to the vignette
#' `vignette("decorate-module-output", package = "teal.modules.general")`.
#'
#' To learn more please refer to the vignette
#' `vignette("transform-module-output", package = "teal")` or the [`teal::teal_transform_module()`] documentation.
#'
#' @inheritSection teal::example_module Reporting
#'
#' @examplesShinylive
#' library(teal.modules.general)
#' interactive <- function() TRUE
#' {{ next_example }}
#' @examples
#' # general data example
#' data <- teal_data()
#' data <- within(data, {
#'   require(nestcolor)
#'   CO2 <- CO2
#'   factors <- names(Filter(isTRUE, vapply(CO2, is.factor, logical(1L))))
#'   CO2[factors] <- lapply(CO2[factors], as.character)
#' })
#'
#' app <- init(
#'   data = data,
#'   modules = modules(
#'     tm_g_association(
#'       ref = data_extract_spec(
#'         dataname = "CO2",
#'         select = select_spec(
#'           label = "Select variable:",
#'           choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")),
#'           selected = "Plant",
#'           fixed = FALSE
#'         )
#'       ),
#'       vars = data_extract_spec(
#'         dataname = "CO2",
#'         select = select_spec(
#'           label = "Select variables:",
#'           choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")),
#'           selected = "Treatment",
#'           multiple = TRUE,
#'           fixed = FALSE
#'         )
#'       )
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
#' @examplesShinylive
#' library(teal.modules.general)
#' interactive <- function() TRUE
#' {{ next_example }}
#' @examples
#' # CDISC data example
#' data <- teal_data()
#' data <- within(data, {
#'   require(nestcolor)
#'   ADSL <- teal.data::rADSL
#' })
#' join_keys(data) <- default_cdisc_join_keys[names(data)]
#'
#' app <- init(
#'   data = data,
#'   modules = modules(
#'     tm_g_association(
#'       ref = data_extract_spec(
#'         dataname = "ADSL",
#'         select = select_spec(
#'           label = "Select variable:",
#'           choices = variable_choices(
#'             data[["ADSL"]],
#'             c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2")
#'           ),
#'           selected = "RACE",
#'           fixed = FALSE
#'         )
#'       ),
#'       vars = data_extract_spec(
#'         dataname = "ADSL",
#'         select = select_spec(
#'           label = "Select variables:",
#'           choices = variable_choices(
#'             data[["ADSL"]],
#'             c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2")
#'           ),
#'           selected = "BMRKR2",
#'           multiple = TRUE,
#'           fixed = FALSE
#'         )
#'       )
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
#' @export
#'
tm_g_association <- function(label = "Association",
                             ref,
                             vars,
                             show_association = TRUE,
                             plot_height = c(600, 400, 5000),
                             plot_width = NULL,
                             distribution_theme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), # nolint line_length_linter.
                             association_theme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), # nolint line_length_linter.
                             pre_output = NULL,
                             post_output = NULL,
                             ggplot2_args = teal.widgets::ggplot2_args(),
                             transformators = list(),
                             decorators = list()) {
  message("Initializing tm_g_association")

  # Normalize the parameters
  if (inherits(ref, "data_extract_spec")) ref <- list(ref)
  if (inherits(vars, "data_extract_spec")) vars <- list(vars)
  if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)

  # Start of assertions
  checkmate::assert_string(label)

  checkmate::assert_list(ref, types = "data_extract_spec")
  if (!all(vapply(ref, function(x) !x$select$multiple, logical(1)))) {
    stop("'ref' should not allow multiple selection")
  }

  checkmate::assert_list(vars, types = "data_extract_spec")
  checkmate::assert_flag(show_association)

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

  distribution_theme <- match.arg(distribution_theme)
  association_theme <- match.arg(association_theme)

  checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
  checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)

  plot_choices <- c("Bivariate1", "Bivariate2")
  checkmate::assert_list(ggplot2_args, types = "ggplot2_args")
  checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))

  assert_decorators(decorators, "plot")
  # End of assertions

  # Make UI args
  args <- as.list(environment())

  data_extract_list <- list(
    ref = ref,
    vars = vars
  )

  ans <- module(
    label = label,
    server = srv_tm_g_association,
    ui = ui_tm_g_association,
    ui_args = args,
    server_args = c(
      data_extract_list,
      list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args, decorators = decorators)
    ),
    transformators = transformators,
    datanames = teal.transform::get_extract_datanames(data_extract_list)
  )
  attr(ans, "teal_bookmarkable") <- TRUE
  ans
}

# UI function for the association module
ui_tm_g_association <- function(id, ...) {
  ns <- NS(id)
  args <- list(...)
  is_single_dataset_value <- teal.transform::is_single_dataset(args$ref, args$vars)

  teal.widgets::standard_layout(
    output = teal.widgets::white_small_well(
      textOutput(ns("title")),
      tags$br(),
      teal.widgets::plot_with_settings_ui(id = ns("myplot"))
    ),
    encoding = tags$div(
      tags$label("Encodings", class = "text-primary"),
      teal.transform::datanames_input(args[c("ref", "vars")]),
      teal.transform::data_extract_ui(
        id = ns("ref"),
        label = "Reference variable",
        data_extract_spec = args$ref,
        is_single_dataset = is_single_dataset_value
      ),
      teal.transform::data_extract_ui(
        id = ns("vars"),
        label = "Associated variables",
        data_extract_spec = args$vars,
        is_single_dataset = is_single_dataset_value
      ),
      checkboxInput(
        ns("association"),
        "Association with reference variable",
        value = args$show_association
      ),
      checkboxInput(
        ns("show_dist"),
        "Scaled frequencies",
        value = FALSE
      ),
      checkboxInput(
        ns("log_transformation"),
        "Log transformed",
        value = FALSE
      ),
      ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "plot")),
      bslib::accordion(
        open = TRUE,
        bslib::accordion_panel(
          title = "Plot settings",
          teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Scatterplot opacity:", c(0.5, 0, 1), ticks = FALSE),
          teal.widgets::optionalSliderInputValMinMax(ns("size"), "Scatterplot points size:", c(2, 1, 8), ticks = FALSE),
          checkboxInput(ns("swap_axes"), "Swap axes", value = FALSE),
          checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = FALSE),
          selectInput(
            inputId = ns("distribution_theme"),
            label = "Distribution theme (by ggplot):",
            choices = ggplot_themes,
            selected = args$distribution_theme,
            multiple = FALSE
          ),
          selectInput(
            inputId = ns("association_theme"),
            label = "Association theme (by ggplot):",
            choices = ggplot_themes,
            selected = args$association_theme,
            multiple = FALSE
          )
        )
      )
    ),
    pre_output = args$pre_output,
    post_output = args$post_output
  )
}

# Server function for the association module
srv_tm_g_association <- function(id,
                                 data,
                                 ref,
                                 vars,
                                 plot_height,
                                 plot_width,
                                 ggplot2_args,
                                 decorators) {
  checkmate::assert_class(data, "reactive")
  checkmate::assert_class(isolate(data()), "teal_data")

  moduleServer(id, function(input, output, session) {
    teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")

    selector_list <- teal.transform::data_extract_multiple_srv(
      data_extract = list(ref = ref, vars = vars),
      datasets = data,
      select_validation_rule = list(
        ref = shinyvalidate::compose_rules(
          shinyvalidate::sv_required("A reference variable needs to be selected."),
          ~ if ((.) %in% selector_list()$vars()$select) {
            "Associated variables and reference variable cannot overlap"
          }
        ),
        vars = shinyvalidate::compose_rules(
          shinyvalidate::sv_required("An associated variable needs to be selected."),
          ~ if (length(selector_list()$ref()$select) != 0 && selector_list()$ref()$select %in% (.)) {
            "Associated variables and reference variable cannot overlap"
          }
        )
      )
    )

    iv_r <- reactive({
      iv <- shinyvalidate::InputValidator$new()
      teal.transform::compose_and_enable_validators(iv, selector_list)
    })

    anl_merged_input <- teal.transform::merge_expression_srv(
      datasets = data,
      selector_list = selector_list
    )

    qenv <- reactive({
      obj <- data()
      teal.reporter::teal_card(obj) <-
        c(
          teal.reporter::teal_card(obj),
          teal.reporter::teal_card("## Module's output(s)")
        )
      teal.code::eval_code(obj, "library(ggplot2);library(dplyr)")
    })
    anl_merged_q <- reactive({
      req(anl_merged_input())
      qenv() %>% teal.code::eval_code(as.expression(anl_merged_input()$expr))
    })

    merged <- list(
      anl_input_r = anl_merged_input,
      anl_q_r = anl_merged_q
    )

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

      ANL <- merged$anl_q_r()[["ANL"]]
      teal::validate_has_data(ANL, 3)

      vars_names <- merged$anl_input_r()$columns_source$vars

      ref_name <- as.vector(merged$anl_input_r()$columns_source$ref)
      association <- input$association
      show_dist <- input$show_dist
      log_transformation <- input$log_transformation
      rotate_xaxis_labels <- input$rotate_xaxis_labels
      swap_axes <- input$swap_axes
      distribution_theme <- input$distribution_theme
      association_theme <- input$association_theme

      is_scatterplot <- is.numeric(ANL[[ref_name]]) && any(vapply(ANL[vars_names], is.numeric, logical(1)))
      if (is_scatterplot) {
        shinyjs::show("alpha")
        shinyjs::show("size")
        alpha <- input$alpha
        size <- input$size
      } else {
        shinyjs::hide("alpha")
        shinyjs::hide("size")
        alpha <- 0.5
        size <- 2
      }

      teal::validate_has_data(ANL[, c(ref_name, vars_names)], 3, complete = TRUE, allow_inf = FALSE)

      # reference
      ref_class <- class(ANL[[ref_name]])[1]
      if (is.numeric(ANL[[ref_name]]) && log_transformation) {
        # works for both integers and doubles
        ref_cl_name <- call("log", as.name(ref_name))
        ref_cl_lbl <- varname_w_label(ref_name, ANL, prefix = "Log of ")
      } else {
        # silently ignore when non-numeric even if `log` is selected because some
        # variables may be numeric and others not
        ref_cl_name <- as.name(ref_name)
        ref_cl_lbl <- varname_w_label(ref_name, ANL)
      }

      user_ggplot2_args <- teal.widgets::resolve_ggplot2_args(
        user_plot = ggplot2_args[["Bivariate1"]],
        user_default = ggplot2_args$default
      )

      ref_call <- bivariate_plot_call(
        data_name = "ANL",
        x = ref_cl_name,
        x_class = ref_class,
        x_label = ref_cl_lbl,
        freq = !show_dist,
        theme = distribution_theme,
        rotate_xaxis_labels = rotate_xaxis_labels,
        swap_axes = FALSE,
        size = size,
        alpha = alpha,
        ggplot2_args = user_ggplot2_args
      )

      # association
      ref_class_cov <- ifelse(association, ref_class, "NULL")

      var_calls <- lapply(vars_names, function(var_i) {
        var_class <- class(ANL[[var_i]])[1]
        if (is.numeric(ANL[[var_i]]) && log_transformation) {
          # works for both integers and doubles
          var_cl_name <- call("log", as.name(var_i))
          var_cl_lbl <- varname_w_label(var_i, ANL, prefix = "Log of ")
        } else {
          # silently ignore when non-numeric even if `log` is selected because some
          # variables may be numeric and others not
          var_cl_name <- as.name(var_i)
          var_cl_lbl <- varname_w_label(var_i, ANL)
        }

        user_ggplot2_args <- teal.widgets::resolve_ggplot2_args(
          user_plot = ggplot2_args[["Bivariate2"]],
          user_default = ggplot2_args$default
        )

        bivariate_plot_call(
          data_name = "ANL",
          x = ref_cl_name,
          y = var_cl_name,
          x_class = ref_class_cov,
          y_class = var_class,
          x_label = ref_cl_lbl,
          y_label = var_cl_lbl,
          theme = association_theme,
          freq = !show_dist,
          rotate_xaxis_labels = rotate_xaxis_labels,
          swap_axes = swap_axes,
          alpha = alpha,
          size = size,
          ggplot2_args = user_ggplot2_args
        )
      })

      # helper function to format variable name
      format_varnames <- function(x) {
        if (is.numeric(ANL[[x]]) && log_transformation) {
          varname_w_label(x, ANL, prefix = "Log of ")
        } else {
          varname_w_label(x, ANL)
        }
      }
      new_title <-
        if (association) {
          switch(as.character(length(vars_names)),
            "0" = sprintf("Value distribution for %s", ref_cl_lbl),
            "1" = sprintf(
              "Association between %s and %s",
              ref_cl_lbl,
              format_varnames(vars_names)
            ),
            sprintf(
              "Associations between %s and: %s",
              ref_cl_lbl,
              paste(lapply(vars_names, format_varnames), collapse = ", ")
            )
          )
        } else {
          switch(as.character(length(vars_names)),
            "0" = sprintf("Value distribution for %s", ref_cl_lbl),
            sprintf(
              "Value distributions for %s and %s",
              ref_cl_lbl,
              paste(lapply(vars_names, format_varnames), collapse = ", ")
            )
          )
        }
      obj <- merged$anl_q_r()
      teal.reporter::teal_card(obj) <- c(teal.reporter::teal_card(obj), "### Plot")
      teal.code::eval_code(
        obj,
        substitute(
          expr = title <- new_title,
          env = list(new_title = new_title)
        )
      ) %>%
        teal.code::eval_code(
          substitute(
            expr = {
              plots <- plot_calls
              plot <- gridExtra::arrangeGrob(grobs = plots, ncol = 1)
            },
            env = list(
              plot_calls = do.call(
                "call",
                c(list("list", ref_call), unname(var_calls)),
                quote = TRUE
              )
            )
          )
        )
    })

    decorated_output_grob_q <- srv_decorate_teal_data(
      id = "decorator",
      data = output_q,
      decorators = select_decorators(decorators, "plot"),
      expr = quote({
        grid::grid.newpage()
        grid::grid.draw(plot)
      })
    )

    plot_r <- reactive({
      req(iv_r()$is_valid())
      req(decorated_output_grob_q())[["plot"]]
    })

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

    output$title <- renderText(output_q()[["title"]])

    set_chunk_dims(pws, decorated_output_grob_q)
  })
}

#' `teal` module: Missing data analysis
#'
#' This module analyzes missing data in `data.frame`s to help users explore missing observations and
#' gain insights into the completeness of their data.
#' It is useful for clinical data analysis within the context of `CDISC` standards and
#' adaptable for general data analysis purposes.
#'
#' @inheritParams teal::module
#' @inheritParams shared_params
#' @param parent_dataname (`character(1)`) Specifies the parent dataset name. Default is `ADSL` for `CDISC` data.
#' If provided and exists, enables additional analysis "by subject". For non-`CDISC` data, this parameter can be
#' ignored.
# nolint start: line_length.
#' @param ggtheme (`character`) optional, specifies the default `ggplot2` theme for plots. Defaults to `classic`.
#' @param ggplot2_args `r roxygen_ggplot2_args_param("Summary Obs", "Summary Patients", "Combinations Main", "Combinations Hist", "By Subject")`
# nolint end: line_length.
#'
#' @inherit shared_params return
#'
#' @section Decorating Module:
#'
#' This module generates the following objects, which can be modified in place using decorators:
#' - `summary_plot` (`ggplot`)
#' - `combination_plot` (`grob` created with [ggplot2::ggplotGrob()])
#' - `by_variable_plot` (`ggplot`)
#' - `by_subject_plot` (`ggplot`)
#'
#' A Decorator is applied to the specific output using a named list of `teal_transform_module` objects.
#' The name of this list corresponds to the name of the output to which the decorator is applied.
#' See code snippet below:
#'
#' ```
#' tm_missing_data(
#'    ..., # arguments for module
#'    decorators = list(
#'      summary_plot = teal_transform_module(...), # applied only to `summary_plot` output
#'      combination_plot = teal_transform_module(...), # applied only to `combination_plot` output
#'      by_variable_plot = teal_transform_module(...) # applied only to `by_variable_plot` output
#'      by_subject_plot = teal_transform_module(...) # applied only to `by_subject_plot` output
#'    )
#' )
#' ```
#'
#' For additional details and examples of decorators, refer to the vignette
#' `vignette("decorate-module-output", package = "teal.modules.general")`.
#'
#' To learn more please refer to the vignette
#' `vignette("transform-module-output", package = "teal")` or the [`teal::teal_transform_module()`] documentation.
#'
#' @inheritSection teal::example_module Reporting
#'
#' @examplesShinylive
#' library(teal.modules.general)
#' interactive <- function() TRUE
#' {{ next_example }}
#' @examples
#' # general example data
#' data <- teal_data()
#' data <- within(data, {
#'   require(nestcolor)
#'
#'   add_nas <- function(x) {
#'     x[sample(seq_along(x), floor(length(x) * runif(1, .05, .17)))] <- NA
#'     x
#'   }
#'
#'   iris <- iris
#'   mtcars <- mtcars
#'
#'   iris[] <- lapply(iris, add_nas)
#'   mtcars[] <- lapply(mtcars, add_nas)
#'   mtcars[["cyl"]] <- as.factor(mtcars[["cyl"]])
#'   mtcars[["gear"]] <- as.factor(mtcars[["gear"]])
#' })
#'
#' app <- init(
#'   data = data,
#'   modules = modules(
#'     tm_missing_data(parent_dataname = "mtcars")
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
#' @examplesShinylive
#' library(teal.modules.general)
#' interactive <- function() TRUE
#' {{ next_example }}
#' @examples
#' # CDISC example data
#' data <- teal_data()
#' data <- within(data, {
#'   require(nestcolor)
#'   ADSL <- teal.data::rADSL
#'   ADRS <- rADRS
#' })
#' join_keys(data) <- default_cdisc_join_keys[names(data)]
#'
#' app <- init(
#'   data = data,
#'   modules = modules(
#'     tm_missing_data()
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
#' @export
#'
tm_missing_data <- function(label = "Missing data",
                            plot_height = c(600, 400, 5000),
                            plot_width = NULL,
                            datanames = "all",
                            parent_dataname = "ADSL",
                            ggtheme = c("classic", "gray", "bw", "linedraw", "light", "dark", "minimal", "void"),
                            ggplot2_args = list(
                              "Combinations Hist" = teal.widgets::ggplot2_args(labs = list(caption = NULL)),
                              "Combinations Main" = teal.widgets::ggplot2_args(labs = list(title = NULL))
                            ),
                            pre_output = NULL,
                            post_output = NULL,
                            transformators = list(),
                            decorators = list()) {
  message("Initializing tm_missing_data")

  # Normalize the parameters
  if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)

  # Start of assertions
  checkmate::assert_string(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"
  )

  checkmate::assert_character(datanames, min.len = 0, min.chars = 1, null.ok = TRUE)
  checkmate::assert_character(parent_dataname, min.len = 0, max.len = 1)
  ggtheme <- match.arg(ggtheme)

  plot_choices <- c("Summary Obs", "Summary Patients", "Combinations Main", "Combinations Hist", "By Subject")
  checkmate::assert_list(ggplot2_args, types = "ggplot2_args")
  checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))

  checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
  checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)

  assert_decorators(decorators, names = c("summary_plot", "combination_plot", "by_subject_plot"))
  # End of assertions

  datanames_module <- if (identical(datanames, "all") || is.null(datanames)) {
    datanames
  } else {
    union(datanames, parent_dataname)
  }

  ans <- module(
    label,
    server = srv_page_missing_data,
    datanames = datanames_module,
    server_args = list(
      datanames = if (is.null(datanames)) "all" else datanames,
      parent_dataname = parent_dataname,
      plot_height = plot_height,
      plot_width = plot_width,
      ggplot2_args = ggplot2_args,
      ggtheme = ggtheme,
      decorators = decorators
    ),
    ui = ui_page_missing_data,
    transformators = transformators,
    ui_args = list(pre_output = pre_output, post_output = post_output)
  )
  attr(ans, "teal_bookmarkable") <- TRUE
  ans
}

# UI function for the missing data module (all datasets)
ui_page_missing_data <- function(id, pre_output = NULL, post_output = NULL) {
  ns <- NS(id)
  tagList(
    teal.widgets::standard_layout(
      output = teal.widgets::white_small_well(
        uiOutput(ns("dataset_tabs"))
      ),
      encoding = tags$div(
        uiOutput(ns("dataset_encodings"))
      ),
      pre_output = pre_output,
      post_output = post_output
    )
  )
}

# Server function for the missing data module (all datasets)
srv_page_missing_data <- function(id, data, datanames, parent_dataname,
                                  plot_height, plot_width, ggplot2_args, ggtheme, decorators) {
  moduleServer(id, function(input, output, session) {
    teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")

    datanames <- Filter(function(name) {
      is.data.frame(isolate(data())[[name]])
    }, if (identical(datanames, "all")) names(isolate(data())) else datanames)

    if_subject_plot <- length(parent_dataname) > 0 && parent_dataname %in% datanames

    ns <- session$ns

    output$dataset_tabs <- renderUI({
      do.call(
        tabsetPanel,
        c(
          id = ns("dataname_tab"),
          lapply(
            datanames,
            function(x) {
              tabPanel(
                title = x,
                ui_missing_data(id = ns(x), by_subject_plot = if_subject_plot)
              )
            }
          )
        )
      )
    })

    output$dataset_encodings <- renderUI({
      req(ggtheme, datanames, is.logical(if_subject_plot))
      tagList(
        lapply(
          datanames,
          function(x) {
            conditionalPanel(
              is_tab_active_js(ns("dataname_tab"), x),
              encoding_missing_data(
                id = ns(x),
                summary_per_patient = if_subject_plot,
                ggtheme = ggtheme,
                datanames = datanames,
                decorators = decorators
              )
            )
          }
        )
      )
    })

    result <- sapply(
      datanames,
      function(x) {
        srv_missing_data(
          id = x,
          data = data,
          dataname = x,
          parent_dataname = parent_dataname,
          plot_height = plot_height,
          plot_width = plot_width,
          ggplot2_args = ggplot2_args,
          decorators = decorators
        )
      },
      USE.NAMES = TRUE,
      simplify = FALSE
    )

    reactive({
      if (is.null(input$dataname_tab)) {
        teal.data::teal_data()
      } else {
        result[[input$dataname_tab]]()
      }
    })
  })
}

# UI function for the missing data module (single dataset)
ui_missing_data <- function(id, by_subject_plot = FALSE) {
  ns <- NS(id)

  tab_list <- list(
    tabPanel(
      "Summary",
      teal.widgets::plot_with_settings_ui(id = ns("summary_plot")),
      helpText(
        tags$p(paste(
          'The "Summary" graph shows the number of missing values per variable (both absolute and percentage),',
          "sorted by magnitude."
        )),
        tags$p(
          'The "summary per patients" graph is showing how many subjects have at least one missing observation',
          "for each variable. It will be most useful for panel datasets."
        )
      )
    ),
    tabPanel(
      "Combinations",
      teal.widgets::plot_with_settings_ui(id = ns("combination_plot")),
      helpText(
        tags$p(paste(
          'The "Combinations" graph is used to explore the relationship between the missing data within',
          "different columns of the dataset.",
          "It shows the different patterns of missingness in the rows of the data.",
          'For example, suppose that 70 rows of the data have exactly columns "A" and "B" missing.',
          "In this case there would be a bar of height 70 in the top graph and",
          'the column below this in the second graph would have rows "A" and "B" cells shaded red.'
        )),
        tags$p(paste(
          "Due to the large number of missing data patterns possible, only those with a large set of observations",
          'are shown in the graph and the "Combination cut-off" slider can be used to adjust the number shown.'
        ))
      )
    ),
    tabPanel(
      "By Variable Levels",
      teal.widgets::plot_with_settings_ui(id = ns("by_variable_plot"))
    )
  )
  if (isTRUE(by_subject_plot)) {
    tab_list <- append(
      tab_list,
      list(tabPanel(
        "Grouped by Subject",
        teal.widgets::plot_with_settings_ui(id = ns("by_subject_plot")),
        helpText(
          tags$p(paste(
            "This graph shows the missingness with respect to subjects rather than individual rows of the",
            "dataset. Each row represents one dataset variable and each column a single subject. Only subjects",
            "with at least one record in this dataset are shown. For a given subject, if they have any missing",
            "values of a specific variable then the appropriate cell in the graph is marked as missing."
          ))
        )
      ))
    )
  }

  do.call(
    tabsetPanel,
    c(
      id = ns("summary_type"),
      tab_list
    )
  )
}

# UI encoding for the missing data module (all datasets)
encoding_missing_data <- function(id, summary_per_patient = FALSE, ggtheme, datanames, decorators) {
  ns <- NS(id)

  tagList(
    tags$label("Encodings", class = "text-primary"),
    helpText(
      paste0("Dataset", `if`(length(datanames) > 1, "s", ""), ":"),
      tags$code(paste(datanames, collapse = ", "))
    ),
    uiOutput(ns("variables")),
    actionButton(
      ns("filter_na"),
      tags$span("Select only vars with missings", style = "white-space: normal;"),
      width = "100%",
      style = "margin-bottom: 1rem;"
    ),
    conditionalPanel(
      is_tab_active_js(ns("summary_type"), "Summary"),
      bslib::input_switch(
        id = ns("any_na"),
        label = tags$div(
          HTML("Add <b>anyna</b> variable"),
          bslib::tooltip(
            icon("circle-info"),
            tags$span(
              "Describes the number of observations with at least one missing value in any variable."
            )
          )
        ),
        value = FALSE
      ),
      if (summary_per_patient) {
        bslib::input_switch(
          id = ns("if_patients_plot"),
          label = tags$div(
            "Add summary per patients",
            bslib::tooltip(
              icon("circle-info"),
              tags$span(
                paste(
                  "Displays the number of missing values per observation,",
                  "where the x-axis is sorted by observation appearance in the table."
                )
              )
            )
          ),
          value = FALSE
        )
      },
      ui_decorate_teal_data(ns("dec_summary_plot"), decorators = select_decorators(decorators, "summary_plot"))
    ),
    conditionalPanel(
      is_tab_active_js(ns("summary_type"), "Combinations"),
      uiOutput(ns("cutoff")),
      ui_decorate_teal_data(ns("dec_combination_plot"), decorators = select_decorators(decorators, "combination_plot"))
    ),
    conditionalPanel(
      is_tab_active_js(ns("summary_type"), "Grouped by Subject"),
      ui_decorate_teal_data(ns("dec_by_subject_plot"), decorators = select_decorators(decorators, "by_subject_plot"))
    ),
    conditionalPanel(
      is_tab_active_js(ns("summary_type"), "By Variable Levels"),
      uiOutput(ns("group_by_var_ui")),
      uiOutput(ns("group_by_vals_ui")),
      radioButtons(
        ns("count_type"),
        label = "Display missing as",
        choices = c("counts", "proportions"),
        selected = "counts",
        inline = TRUE
      )
    ),
    bslib::accordion(
      bslib::accordion_panel(
        title = "Plot settings",
        selectInput(
          inputId = ns("ggtheme"),
          label = "Theme (by ggplot):",
          choices = ggplot_themes,
          selected = ggtheme,
          multiple = FALSE
        )
      )
    )
  )
}

# Server function for the missing data (single dataset)
srv_missing_data <- function(id,
                             data,
                             dataname,
                             parent_dataname,
                             plot_height,
                             plot_width,
                             ggplot2_args,
                             decorators) {
  checkmate::assert_class(data, "reactive")
  checkmate::assert_class(isolate(data()), "teal_data")
  moduleServer(id, function(input, output, session) {
    ns <- session$ns

    prev_group_by_var <- reactiveVal("")
    data_r <- reactive(data()[[dataname]])
    data_keys <- reactive(unlist(teal.data::join_keys(data())[[dataname]]))

    iv_r <- reactive({
      iv <- shinyvalidate::InputValidator$new()
      iv$add_rule(
        "variables_select",
        shinyvalidate::sv_required("At least one reference variable needs to be selected.")
      )
      iv$add_rule(
        "variables_select",
        ~ if (length(setdiff((.), data_keys())) < 1) "Please also select non-key columns."
      )
      iv_summary_table <- shinyvalidate::InputValidator$new()
      iv_summary_table$condition(~ isTRUE(input$summary_type == "By Variable Levels"))
      iv_summary_table$add_rule("count_type", shinyvalidate::sv_required("Please select type of counts"))
      iv_summary_table$add_rule(
        "group_by_vals",
        ~ if (length(input$group_by_var) >= 1L && length(.) == 0L) "Please select filter values"
      )
      iv_summary_table$add_rule(
        "group_by_var",
        ~ if (length(.) == 0L) "Please select group-by variable"
      )
      iv_summary_table$add_rule(
        "group_by_var",
        ~ if (length(.) > 0 && length(input$variables_select) == 1 && (.) == input$variables_select) {
          "If only one reference variable is selected it must not be the grouping variable."
        }
      )
      iv_summary_table$add_rule(
        "variables_select",
        ~ if (length(input$group_by_var) > 0 && length(.) == 1 && (.) == input$group_by_var) {
          "If only one reference variable is selected it must not be the grouping variable."
        }
      )
      iv$add_validator(iv_summary_table)
      iv$enable()
      iv
    })

    data_parent_keys <- reactive({
      req(data(), parent_dataname)
      if (length(parent_dataname) > 0 && parent_dataname %in% names(data())) {
        keys <- teal.data::join_keys(data())[[dataname]]
        if (parent_dataname %in% names(keys)) {
          keys[[parent_dataname]]
        } else {
          keys[[dataname]]
        }
      } else {
        NULL
      }
    })

    common_code_q <- reactive({
      teal::validate_inputs(iv_r())
      req(data(), data_r(), input$summary_type)
      group_var <- input$group_by_var
      anl <- data_r()
      obj <- data()
      teal.reporter::teal_card(obj) <- c(
        teal.reporter::teal_card(obj),
        teal.reporter::teal_card("## Module's output(s)")
      )

      qenv <- teal.code::eval_code(obj, {
        "library(dplyr);library(ggplot2);library(tidyr);library(gridExtra)"
      })

      qenv <- if (!is.null(selected_vars()) && length(selected_vars()) != ncol(anl)) {
        teal.code::eval_code(
          qenv,
          substitute(
            expr = ANL <- anl_name[, selected_vars, drop = FALSE],
            env = list(anl_name = as.name(dataname), selected_vars = selected_vars())
          )
        )
      } else {
        teal.code::eval_code(
          qenv,
          substitute(expr = ANL <- anl_name, env = list(anl_name = as.name(dataname)))
        )
      }

      if (input$summary_type == "By Variable Levels" && !is.null(group_var) && !(group_var %in% selected_vars())) {
        qenv <- teal.code::eval_code(
          qenv,
          substitute(
            expr = ANL[[group_var]] <- anl_name[[group_var]],
            env = list(group_var = group_var, anl_name = as.name(dataname))
          )
        )
      }

      new_col_name <- "**anyna**"

      qenv <- teal.code::eval_code(
        qenv,
        substitute(
          expr =
            create_cols_labels <- function(cols, just_label = FALSE) {
              column_labels <- column_labels_value
              column_labels[is.na(column_labels) | length(column_labels) == 0] <- ""
              if (just_label) {
                labels <- column_labels[cols]
              } else {
                labels <- ifelse(cols == new_col_name | cols == "", cols, paste0(column_labels[cols], " [", cols, "]"))
              }
              labels
            },
          env = list(
            new_col_name = new_col_name,
            column_labels_value = c(teal.data::col_labels(data_r())[selected_vars()],
              new_col_name = new_col_name
            )
          )
        )
      )
      qenv
    })

    selected_vars <- reactive({
      req(input$variables_select)
      keys <- data_keys()
      vars <- unique(c(keys, input$variables_select))
      vars
    })

    vars_summary <- reactive({
      req(data_r())
      na_count <- data_r() %>%
        sapply(function(x) mean(is.na(x)), USE.NAMES = TRUE) %>%
        sort(decreasing = TRUE)

      tibble::tibble(
        key = names(na_count),
        value = unname(na_count),
        label = cut(na_count, breaks = seq(from = 0, to = 1, by = 0.1), include.lowest = TRUE)
      )
    })

    # Keep encoding panel up-to-date
    output$variables <- renderUI({
      req(vars_summary(), data_r())
      choices <- split(x = vars_summary()$key, f = vars_summary()$label, drop = TRUE) %>% rev()
      selected <- choices <- unname(unlist(choices))

      teal.widgets::optionalSelectInput(
        ns("variables_select"),
        label = "Select variables",
        label_help = HTML(paste0("Dataset: ", tags$code(dataname))),
        choices = teal.transform::variable_choices(data_r(), choices),
        selected = selected,
        multiple = TRUE
      )
    })

    observeEvent(input$filter_na, {
      req(vars_summary(), data_r())
      choices <- vars_summary() %>%
        dplyr::select(!!as.name("key")) %>%
        getElement(name = 1)

      selected <- vars_summary() %>%
        dplyr::filter(!!as.name("value") > 0) %>%
        dplyr::select(!!as.name("key")) %>%
        getElement(name = 1)

      teal.widgets::updateOptionalSelectInput(
        session = session,
        inputId = "variables_select",
        choices = teal.transform::variable_choices(data_r()),
        selected = restoreInput(ns("variables_select"), selected)
      )
    })

    output$group_by_var_ui <- renderUI({
      req(data_r())
      all_choices <- teal.transform::variable_choices(data_r())
      cat_choices <- all_choices[!sapply(data_r(), function(x) is.numeric(x) || inherits(x, "POSIXct"))]
      validate(
        need(cat_choices, "Dataset does not have any non-numeric or non-datetime variables to use to group data with")
      )
      teal.widgets::optionalSelectInput(
        ns("group_by_var"),
        label = "Group by variable",
        choices = cat_choices,
        selected = `if`(
          is.null(isolate(input$group_by_var)),
          cat_choices[1],
          isolate(input$group_by_var)
        ),
        multiple = FALSE,
        label_help = paste0("Dataset: ", dataname)
      )
    })

    output$group_by_vals_ui <- renderUI({
      req(input$group_by_var, data_r())

      choices <- teal.transform::value_choices(data_r(), input$group_by_var, input$group_by_var)
      prev_choices <- isolate(input$group_by_vals)

      # determine selected value based on filtered data
      # display those previously selected values that are still available
      selected <- if (!is.null(prev_choices) && any(prev_choices %in% choices)) {
        prev_choices[match(choices[choices %in% prev_choices], prev_choices)]
      } else if (
        !is.null(prev_choices) &&
          !any(prev_choices %in% choices) &&
          isolate(prev_group_by_var()) == input$group_by_var
      ) {
        # if not any previously selected value is available and the grouping variable is the same,
        # then display NULL
        NULL
      } else {
        # if new grouping variable (i.e. not any previously selected value is available),
        # then display all choices
        choices
      }

      prev_group_by_var(input$group_by_var) # set current group_by_var
      validate(need(length(choices) < 100, "Please select group-by variable with fewer than 100 unique values"))
      teal.widgets::optionalSelectInput(
        ns("group_by_vals"),
        label = "Filter levels",
        choices = choices,
        selected = selected,
        multiple = TRUE,
        label_help = paste0("Dataset: ", dataname)
      )
    })

    combination_cutoff_q <- reactive({
      qenv <- req(common_code_q())
      teal.reporter::teal_card(qenv) <- c(teal.reporter::teal_card(qenv), "### Combination Plot")
      teal.code::eval_code(
        qenv,
        quote(
          combination_cutoff <- ANL %>%
            dplyr::mutate_all(is.na) %>%
            dplyr::group_by_all() %>%
            dplyr::tally() %>%
            dplyr::ungroup()
        )
      )
    })

    output$cutoff <- renderUI({
      req(combination_cutoff_q())
      x <- combination_cutoff_q()[["combination_cutoff"]]$n

      # select 10-th from the top
      n <- length(x)
      idx <- max(1, n - 10)
      prev_value <- isolate(input$combination_cutoff)
      value <- if (is.null(prev_value) || prev_value > max(x) || prev_value < min(x)) {
        sort(x, partial = idx)[idx]
      } else {
        prev_value
      }

      teal.widgets::optionalSliderInputValMinMax(
        ns("combination_cutoff"),
        "Combination cut-off",
        c(value, range(x))
      )
    })

    # Prepare qenvs for output objects

    summary_plot_q <- reactive({
      req(input$summary_type == "Summary") # needed to trigger update on tab change
      teal::validate_has_data(req(data_r()), 1)
      req(input$ggtheme)
      qenv <- req(common_code_q())
      if (input$any_na) {
        new_col_name <- "**anyna**"
        qenv <- teal.code::eval_code(
          qenv,
          substitute(
            expr = ANL[[new_col_name]] <- ifelse(rowSums(is.na(ANL)) > 0, NA, FALSE),
            env = list(new_col_name = new_col_name)
          )
        )
      }

      qenv <- teal.code::eval_code(
        qenv,
        substitute(
          expr = analysis_vars <- setdiff(colnames(ANL), data_keys),
          env = list(data_keys = data_keys())
        )
      )

      teal.reporter::teal_card(qenv) <- c(teal.reporter::teal_card(qenv), "### Summary Plot")

      qenv <- teal.code::eval_code(
        qenv,
        substitute(
          expr = summary_plot_obs <- data_frame_call[, analysis_vars] %>%
            dplyr::summarise_all(list(function(x) sum(is.na(x)))) %>%
            tidyr::pivot_longer(dplyr::everything(), names_to = "col", values_to = "n_na") %>%
            dplyr::mutate(n_not_na = nrow(ANL) - n_na) %>%
            tidyr::pivot_longer(-col, names_to = "isna", values_to = "n") %>%
            dplyr::mutate(isna = isna == "n_na", n_pct = n / nrow(ANL) * 100),
          env = list(data_frame_call = if (!inherits(data_r(), "tbl_df")) {
            quote(tibble::as_tibble(ANL))
          } else {
            quote(ANL)
          })
        )
      ) %>%
        # x axis ordering according to number of missing values and alphabet
        teal.code::eval_code(
          quote(
            expr = x_levels <- dplyr::filter(summary_plot_obs, isna) %>%
              dplyr::arrange(n_pct, dplyr::desc(col)) %>%
              dplyr::pull(col) %>%
              create_cols_labels()
          )
        )

      # always set "**anyna**" level as the last one
      if (input$any_na) {
        qenv <- teal.code::eval_code(
          qenv,
          quote(x_levels <- c(setdiff(x_levels, "**anyna**"), "**anyna**"))
        )
      }

      dev_ggplot2_args <- teal.widgets::ggplot2_args(
        labs = list(x = "Variable", y = "Missing observations"),
        theme = list(legend.position = "bottom", axis.text.x = quote(ggplot2::element_text(angle = 45, hjust = 1)))
      )

      all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(
        user_plot = ggplot2_args[["Summary Obs"]],
        user_default = ggplot2_args$default,
        module_plot = dev_ggplot2_args
      )

      parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(
        all_ggplot2_args,
        ggtheme = input$ggtheme
      )

      qenv <- teal.code::eval_code(
        qenv,
        substitute(
          summary_plot_top <- summary_plot_obs %>%
            ggplot2::ggplot() +
            ggplot2::aes(
              x = factor(create_cols_labels(col), levels = x_levels),
              y = n_pct,
              fill = isna
            ) +
            ggplot2::geom_bar(position = "fill", stat = "identity") +
            ggplot2::scale_fill_manual(
              name = "",
              values = c("grey90", c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]),
              labels = c("Present", "Missing")
            ) +
            ggplot2::scale_y_continuous(
              labels = scales::percent_format(),
              breaks = seq(0, 1, by = 0.1),
              expand = c(0, 0)
            ) +
            ggplot2::geom_text(
              ggplot2::aes(label = ifelse(isna == TRUE, sprintf("%d [%.02f%%]", n, n_pct), ""), y = 1),
              hjust = 1,
              color = "black"
            ) +
            labs +
            ggthemes +
            themes +
            ggplot2::coord_flip(),
          env = list(
            labs = parsed_ggplot2_args$labs,
            themes = parsed_ggplot2_args$theme,
            ggthemes = parsed_ggplot2_args$ggtheme
          )
        )
      )

      if (isTRUE(input$if_patients_plot)) {
        qenv <- teal.code::eval_code(
          qenv,
          substitute(
            expr = parent_keys <- keys,
            env = list(keys = data_parent_keys())
          )
        ) %>%
          teal.code::eval_code(quote(ndistinct_subjects <- dplyr::n_distinct(ANL[, parent_keys]))) %>%
          teal.code::eval_code(
            quote(
              summary_plot_patients <- ANL[, c(parent_keys, analysis_vars)] %>%
                dplyr::group_by_at(parent_keys) %>%
                dplyr::summarise_all(anyNA) %>%
                tidyr::pivot_longer(cols = !dplyr::all_of(parent_keys), names_to = "col", values_to = "anyna") %>%
                dplyr::group_by_at(c("col")) %>%
                dplyr::summarise(count_na = sum(anyna)) %>%
                dplyr::mutate(count_not_na = ndistinct_subjects - count_na) %>%
                tidyr::pivot_longer(-c(col), names_to = "isna", values_to = "n") %>%
                dplyr::mutate(isna = isna == "count_na", n_pct = n / ndistinct_subjects * 100) %>%
                dplyr::arrange_at(c("isna", "n"), .funs = dplyr::desc)
            )
          )

        dev_ggplot2_args <- teal.widgets::ggplot2_args(
          labs = list(x = "", y = "Missing patients"),
          theme = list(
            legend.position = "bottom",
            axis.text.x = quote(ggplot2::element_text(angle = 45, hjust = 1)),
            axis.text.y = quote(ggplot2::element_blank())
          )
        )

        all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(
          user_plot = ggplot2_args[["Summary Patients"]],
          user_default = ggplot2_args$default,
          module_plot = dev_ggplot2_args
        )

        parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(
          all_ggplot2_args,
          ggtheme = input$ggtheme
        )

        qenv <- teal.code::eval_code(
          qenv,
          substitute(
            summary_plot_bottom <- summary_plot_patients %>%
              ggplot2::ggplot() +
              ggplot2::aes_(
                x = ~ factor(create_cols_labels(col), levels = x_levels),
                y = ~n_pct,
                fill = ~isna
              ) +
              ggplot2::geom_bar(alpha = 1, stat = "identity", position = "fill") +
              ggplot2::scale_y_continuous(
                labels = scales::percent_format(),
                breaks = seq(0, 1, by = 0.1),
                expand = c(0, 0)
              ) +
              ggplot2::scale_fill_manual(
                name = "",
                values = c("grey90", c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]),
                labels = c("Present", "Missing")
              ) +
              ggplot2::geom_text(
                ggplot2::aes(label = ifelse(isna == TRUE, sprintf("%d [%.02f%%]", n, n_pct), ""), y = 1),
                hjust = 1,
                color = "black"
              ) +
              labs +
              ggthemes +
              themes +
              ggplot2::coord_flip(),
            env = list(
              labs = parsed_ggplot2_args$labs,
              themes = parsed_ggplot2_args$theme,
              ggthemes = parsed_ggplot2_args$ggtheme
            )
          )
        )
      }

      qenv <- if (isTRUE(input$if_patients_plot)) {
        within(qenv, {
          summary_plot <- gridExtra::grid.arrange(summary_plot_top, summary_plot_bottom, ncol = 2)
        })
      } else {
        within(qenv, {
          summary_plot <- summary_plot_top
        })
      }
      qenv
    })

    combination_plot_q <- reactive({
      req(
        input$summary_type == "Combinations", input$combination_cutoff,
        combination_cutoff_q(), input$ggtheme
      )
      teal::validate_has_data(req(data_r()), 1)

      qenv <- teal.code::eval_code(
        combination_cutoff_q(),
        substitute(
          expr = data_combination_plot_cutoff <- combination_cutoff %>%
            dplyr::filter(n >= combination_cutoff_value) %>%
            dplyr::mutate(id = rank(-n, ties.method = "first")) %>%
            tidyr::pivot_longer(-c(n, id), names_to = "key", values_to = "value") %>%
            dplyr::arrange(n),
          env = list(combination_cutoff_value = input$combination_cutoff)
        )
      )

      # find keys in dataset not selected in the UI and remove them from dataset
      keys_not_selected <- setdiff(data_keys(), input$variables_select)
      if (length(keys_not_selected) > 0) {
        qenv <- teal.code::eval_code(
          qenv,
          substitute(
            expr = data_combination_plot_cutoff <- data_combination_plot_cutoff %>%
              dplyr::filter(!key %in% keys_not_selected),
            env = list(keys_not_selected = keys_not_selected)
          )
        )
      }

      qenv <- teal.code::eval_code(
        qenv,
        quote(
          labels <- data_combination_plot_cutoff %>%
            dplyr::filter(key == key[[1]]) %>%
            getElement(name = 1)
        )
      )

      dev_ggplot2_args1 <- teal.widgets::ggplot2_args(
        labs = list(x = "", y = ""),
        theme = list(
          legend.position = "bottom",
          axis.text.x = quote(ggplot2::element_blank())
        )
      )

      all_ggplot2_args1 <- teal.widgets::resolve_ggplot2_args(
        user_plot = ggplot2_args[["Combinations Hist"]],
        user_default = ggplot2_args$default,
        module_plot = dev_ggplot2_args1
      )

      parsed_ggplot2_args1 <- teal.widgets::parse_ggplot2_args(
        all_ggplot2_args1,
        ggtheme = "void"
      )

      dev_ggplot2_args2 <- teal.widgets::ggplot2_args(
        labs = list(x = "", y = ""),
        theme = list(
          legend.position = "bottom",
          axis.text.x = quote(ggplot2::element_blank()),
          axis.ticks = quote(ggplot2::element_blank()),
          panel.grid.major = quote(ggplot2::element_blank())
        )
      )

      all_ggplot2_args2 <- teal.widgets::resolve_ggplot2_args(
        user_plot = ggplot2_args[["Combinations Main"]],
        user_default = ggplot2_args$default,
        module_plot = dev_ggplot2_args2
      )

      parsed_ggplot2_args2 <- teal.widgets::parse_ggplot2_args(
        all_ggplot2_args2,
        ggtheme = input$ggtheme
      )

      qenv <- teal.code::eval_code(
        qenv,
        substitute(
          expr = {
            combination_plot_top <- data_combination_plot_cutoff %>%
              dplyr::select(id, n) %>%
              dplyr::distinct() %>%
              ggplot2::ggplot(ggplot2::aes(x = id, y = n)) +
              ggplot2::geom_bar(stat = "identity", fill = c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]) +
              ggplot2::geom_text(
                ggplot2::aes(label = n),
                position = ggplot2::position_dodge(width = 0.9),
                vjust = -0.25
              ) +
              ggplot2::ylim(c(0, max(data_combination_plot_cutoff$n) * 1.5)) +
              labs1 +
              ggthemes1 +
              themes1

            graph_number_rows <- length(unique(data_combination_plot_cutoff$id))
            graph_number_cols <- nrow(data_combination_plot_cutoff) / graph_number_rows

            combination_plot_bottom <- data_combination_plot_cutoff %>% ggplot2::ggplot() +
              ggplot2::aes(x = create_cols_labels(key), y = id - 0.5, fill = value) +
              ggplot2::geom_tile(alpha = 0.85, height = 0.95) +
              ggplot2::scale_fill_manual(
                name = "",
                values = c("grey90", c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]),
                labels = c("Present", "Missing")
              ) +
              ggplot2::geom_hline(yintercept = seq_len(1 + graph_number_rows) - 1) +
              ggplot2::geom_vline(xintercept = seq_len(1 + graph_number_cols) - 0.5, linetype = "dotted") +
              ggplot2::coord_flip() +
              labs2 +
              ggthemes2 +
              themes2
          },
          env = list(
            labs1 = parsed_ggplot2_args1$labs,
            themes1 = parsed_ggplot2_args1$theme,
            ggthemes1 = parsed_ggplot2_args1$ggtheme,
            labs2 = parsed_ggplot2_args2$labs,
            themes2 = parsed_ggplot2_args2$theme,
            ggthemes2 = parsed_ggplot2_args2$ggtheme
          )
        )
      )

      within(qenv, {
        g1 <- ggplot2::ggplotGrob(combination_plot_top)
        g2 <- ggplot2::ggplotGrob(combination_plot_bottom)

        combination_plot <- gridExtra::gtable_rbind(g1, g2, size = "last")
        combination_plot$heights[7] <- grid::unit(0.2, "null") # rescale to get the bar chart smaller
      })
    })

    by_variable_plot_q <- reactive({
      req(
        input$summary_type == "By Variable Levels", # needed to trigger update on tab change
        common_code_q()
      )
      teal::validate_has_data(req(data_r()), 1)

      # extract the ANL dataset for use in further validation
      anl <- common_code_q()[["ANL"]]

      req(input$group_by_var)
      group_var <- input$group_by_var
      validate(
        need(
          length(unique(anl[[group_var]])) < 100,
          "Please select group-by variable with fewer than 100 unique values"
        )
      )
      group_vals <- input$group_by_vals
      variables_select <- input$variables_select
      vars <- unique(variables_select, group_var)
      count_type <- input$count_type

      if (!is.null(selected_vars()) && length(selected_vars()) != ncol(anl)) {
        variables <- selected_vars()
      } else {
        variables <- colnames(anl)
      }

      summ_fn <- if (input$count_type == "counts") {
        function(x) sum(is.na(x))
      } else {
        function(x) round(sum(is.na(x)) / length(x), 4)
      }

      qenv <- req(common_code_q())
      teal.reporter::teal_card(qenv) <- c(teal.reporter::teal_card(qenv), "### Summary Table")


      common_code_libraries_q <- teal.code::eval_code(
        qenv,
        "library(forcats);library(glue)"
      )
      qenv <- teal.code::eval_code(
        common_code_libraries_q,
        substitute(
          expr = {
            summary_data <- ANL %>%
              dplyr::mutate(group_var_name := forcats::fct_na_value_to_level(as.factor(group_var_name), "NA")) %>%
              dplyr::group_by_at(group_var) %>%
              dplyr::filter(group_var_name %in% group_vals)

            count_data <- dplyr::summarise(summary_data, n = dplyr::n())

            summary_data <- dplyr::summarise_all(summary_data, summ_fn) %>%
              dplyr::mutate(group_var_name := paste0(group_var, ":", group_var_name, "(N=", count_data$n, ")")) %>%
              tidyr::pivot_longer(!dplyr::all_of(group_var), names_to = "Variable", values_to = "out") %>%
              tidyr::pivot_wider(names_from = group_var, values_from = "out") %>%
              dplyr::mutate(`Variable label` = create_cols_labels(Variable, just_label = TRUE), .after = Variable)
          },
          env = list(
            group_var = group_var, group_var_name = as.name(group_var), group_vals = group_vals, summ_fn = summ_fn
          )
        )
      )

      dev_ggplot2_args <- teal.widgets::ggplot2_args(
        labs = list(
          fill = if (input$count_type == "counts") "Missing counts" else "Missing percentage",
          y = NULL
        )
      )

      all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(
        user_plot = ggplot2_args[["By Variable Levels"]],
        user_default = ggplot2_args$default,
        module_plot = dev_ggplot2_args
      )

      parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(
        all_ggplot2_args,
        ggtheme = input$ggtheme
      )

      # convert to ggplot
      labels <- lapply(qenv$ANL, attr, which = "label")
      if (!any(lengths(labels))) {
        ANL_q <- within(qenv, # nolint object_name_linter
          {
            keep_columns <- intersect(c(keys, group_var), colnames(ANL))
            ANL <- ANL %>%
              filter(group_var_name %in% group_vals) %>%
              pivot_longer(-keep_columns, values_transform = is.na) %>%
              summarise(
                .by = c(group_var_name, name),
                value = sum(value), perc = value / n()
              )
          },
          keys = join_keys(qenv) |> unlist() |> unique(),
          group_var_name = as.name(group_var),
          group_var = group_var,
          group_vals = req(group_vals)
        )
        tile <- within(ANL_q,
          {
            by_variable_plot <- ggplot2::ggplot(ANL, ggplot2::aes(group_var_name, name)) +
              ggplot2::geom_tile(ggplot2::aes(fill = column), color = "gray90") +
              ggplot2::geom_text(ggplot2::aes(label = text_label),
                data = ~ dplyr::filter(.x, perc > 0),
              ) +
              ggplot2::scale_x_discrete(expand = ggplot2::expansion()) +
              ggplot2::scale_fill_gradient(high = "#ff2951ff", low = "grey90", labels = labels) +
              labs +
              ggthemes
          },
          group_var_name = as.name(group_var),
          column = if (input$count_type == "counts") {
            as.name("value")
          } else {
            as.name("perc")
          },
          text_label = if (input$count_type == "counts") as.name("value") else quote(scales::percent(perc)),
          labs = parsed_ggplot2_args$labs,
          labels = if (input$count_type == "counts") quote(ggplot2::waiver()) else quote(scales::label_percent()),
          ggthemes = parsed_ggplot2_args$ggtheme
        )
      } else {
        ANL_q <- within(qenv, # nolint object_name_linter
          {
            keep_columns <- intersect(c(keys, group_var), colnames(ANL))
            labels <- vapply(ANL, attr, which = "label", FUN.VALUE = character(1L))
            ANL <- ANL %>%
              dplyr::filter(group_var_name %in% group_vals) %>%
              tidyr::pivot_longer(-keep_columns, values_transform = is.na) %>%
              dplyr::group_by(group_var_name, name) %>%
              dplyr::summarise(value = sum(value), perc = value / n()) %>%
              dplyr::mutate(label = labels[name])
          },
          keys = join_keys(qenv) |> unlist() |> unique(),
          group_var_name = as.name(group_var),
          group_var = group_var,
          group_vals = req(group_vals)
        )

        tile <- within(ANL_q,
          {
            by_variable_plot <- ggplot2::ggplot(ANL, ggplot2::aes(group_var_name, label)) +
              ggplot2::geom_tile(ggplot2::aes(fill = column), color = "gray90") +
              ggplot2::geom_text(ggplot2::aes(label = text_label),
                data = ~ dplyr::filter(.x, perc > 0)
              ) +
              ggplot2::scale_x_discrete(expand = ggplot2::expansion()) +
              ggplot2::scale_fill_gradient(high = "#ff2951ff", low = "grey90", labels = labels) +
              labs +
              ggthemes
          },
          text_label = if (input$count_type == "counts") as.name("value") else quote(scales::percent(perc)),
          group_var_name = as.name(group_var),
          column = if (input$count_type == "counts") {
            as.name("value")
          } else {
            as.name("perc")
          },
          labs = parsed_ggplot2_args$labs,
          labels = if (input$count_type == "counts") quote(ggplot2::waiver()) else quote(scales::label_percent()),
          ggthemes = parsed_ggplot2_args$ggtheme
        )
      }
      tile
    })

    by_subject_plot_q <- reactive({
      # needed to trigger update on tab change
      req(
        input$summary_type == "Grouped by Subject", common_code_q(),
        input$ggtheme
      )

      teal::validate_has_data(req(data_r()), 1)

      dev_ggplot2_args <- teal.widgets::ggplot2_args(
        labs = list(x = NULL, y = NULL),
        theme = list(legend.position = "bottom", axis.text.x = NULL)
      )

      all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(
        user_plot = ggplot2_args[["By Subject"]],
        user_default = ggplot2_args$default,
        module_plot = dev_ggplot2_args
      )

      parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(
        all_ggplot2_args,
        ggtheme = input$ggtheme
      )

      # Unlikely that `rlang` is not available, new hashing may be expensive
      hashing_function <- if (requireNamespace("rlang", quietly = TRUE)) {
        quote(rlang::hash)
      } else {
        function(x) paste(as.integer(x), collapse = "")
      }

      qenv <- req(common_code_q())
      teal.reporter::teal_card(qenv) <- c(teal.reporter::teal_card(qenv), "### By Subject Plot")

      qenv <- teal.code::eval_code(
        qenv,
        substitute(
          expr = parent_keys <- keys,
          env = list(keys = data_parent_keys())
        )
      ) %>%
        teal.code::eval_code(
          substitute(
            expr = analysis_vars <- setdiff(colnames(ANL), data_keys),
            env = list(data_keys = data_keys())
          )
        ) %>%
        teal.code::eval_code(
          substitute(
            expr = {
              summary_plot_patients <- ANL[, c(parent_keys, analysis_vars)] %>%
                dplyr::group_by_at(parent_keys) %>%
                dplyr::mutate(id = dplyr::cur_group_id()) %>%
                dplyr::ungroup() %>%
                dplyr::group_by_at(c(parent_keys, "id")) %>%
                dplyr::summarise_all(anyNA) %>%
                dplyr::ungroup()

              # order subjects by decreasing number of missing and then by
              # missingness pattern (defined using sha1)
              order_subjects <- summary_plot_patients %>%
                dplyr::select(-"id", -dplyr::all_of(parent_keys)) %>%
                dplyr::transmute(
                  id = dplyr::row_number(),
                  number_NA = apply(., 1, sum),
                  sha = apply(., 1, hashing_function)
                ) %>%
                dplyr::arrange(dplyr::desc(number_NA), sha) %>%
                getElement(name = "id")

              # order columns by decreasing percent of missing values
              ordered_columns <- summary_plot_patients %>%
                dplyr::select(-"id", -dplyr::all_of(parent_keys)) %>%
                dplyr::summarise(
                  column = create_cols_labels(colnames(.)),
                  na_count = apply(., MARGIN = 2, FUN = sum),
                  na_percent = na_count / nrow(.) * 100
                ) %>%
                dplyr::arrange(na_percent, dplyr::desc(column))

              summary_plot_patients <- summary_plot_patients %>%
                tidyr::gather("col", "isna", -"id", -dplyr::all_of(parent_keys)) %>%
                dplyr::mutate(col = create_cols_labels(col))
            },
            env = list(hashing_function = hashing_function)
          )
        )

      qenv <- teal.code::eval_code(
        qenv,
        substitute(
          expr = {
            by_subject_plot <- ggplot2::ggplot(summary_plot_patients, ggplot2::aes(
              x = factor(id, levels = order_subjects),
              y = factor(col, levels = ordered_columns[["column"]]),
              fill = isna
            )) +
              ggplot2::geom_raster() +
              ggplot2::annotate(
                "text",
                x = length(order_subjects),
                y = seq_len(nrow(ordered_columns)),
                hjust = 1,
                label = sprintf("%d [%.02f%%]", ordered_columns[["na_count"]], ordered_columns[["na_percent"]])
              ) +
              ggplot2::scale_fill_manual(
                name = "",
                values = c("grey90", c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]),
                labels = c("Present", "Missing (at least one)")
              ) +
              labs +
              ggthemes +
              themes
          },
          env = list(
            labs = parsed_ggplot2_args$labs,
            themes = parsed_ggplot2_args$theme,
            ggthemes = parsed_ggplot2_args$ggtheme
          )
        )
      )
    })

    # Decorated outputs

    # Summary_plot_q
    decorated_summary_plot_q <- srv_decorate_teal_data(
      id = "dec_summary_plot",
      data = summary_plot_q,
      decorators = select_decorators(decorators, "summary_plot"),
      expr = quote({
        summary_plot
      })
    )

    decorated_combination_plot_q <- srv_decorate_teal_data(
      id = "dec_combination_plot",
      data = combination_plot_q,
      decorators = select_decorators(decorators, "combination_plot"),
      expr = quote({
        grid::grid.newpage()
        grid::grid.draw(combination_plot)
      })
    )

    decorated_by_variable_plot_q <- srv_decorate_teal_data(
      id = "dec_by_variable_plot",
      data = by_variable_plot_q,
      decorators = select_decorators(decorators, "by_variable_plot"),
      expr = quote(by_variable_plot)
    )

    decorated_by_subject_plot_q <- srv_decorate_teal_data(
      id = "dec_by_subject_plot",
      data = by_subject_plot_q,
      decorators = select_decorators(decorators, "by_subject_plot"),
      expr = quote(by_subject_plot)
    )

    # Plots & tables reactives

    summary_plot_r <- reactive({
      req(decorated_summary_plot_q())[["summary_plot"]]
    })

    combination_plot_r <- reactive({
      req(decorated_combination_plot_q())[["combination_plot"]]
    })

    by_variable_plot_r <- reactive({
      req(decorated_by_variable_plot_q())[["by_variable_plot"]]
    })

    by_subject_plot_r <- reactive({
      req(decorated_by_subject_plot_q()[["by_subject_plot"]])
    })

    # Generate output
    pws1 <- teal.widgets::plot_with_settings_srv(
      id = "summary_plot",
      plot_r = summary_plot_r,
      height = plot_height,
      width = plot_width
    )

    pws2 <- teal.widgets::plot_with_settings_srv(
      id = "combination_plot",
      plot_r = combination_plot_r,
      height = plot_height,
      width = plot_width
    )

    pws3 <- teal.widgets::plot_with_settings_srv(
      id = "by_variable_plot",
      plot_r = by_variable_plot_r,
      height = plot_height,
      width = plot_width
    )

    pws4 <- teal.widgets::plot_with_settings_srv(
      id = "by_subject_plot",
      plot_r = by_subject_plot_r,
      height = plot_height,
      width = plot_width
    )

    decorated_summary_plot_dims_q <- set_chunk_dims(pws1, decorated_summary_plot_q)

    decorated_combination_plot_dims_q <- # nolint: object_length_linter.
      set_chunk_dims(pws2, decorated_combination_plot_q)

    decorated_by_variable_plot_dims_q <- # nolint: object_length_linter.
      set_chunk_dims(pws3, decorated_by_variable_plot_q)

    decorated_by_subject_plot_dims_q <- # nolint: object_length_linter.
      set_chunk_dims(pws4, decorated_by_subject_plot_q)

    decorated_final_q <- reactive({
      sum_type <- req(input$summary_type)
      if (sum_type == "Summary") {
        decorated_summary_plot_dims_q()
      } else if (sum_type == "Combinations") {
        decorated_combination_plot_dims_q()
      } else if (sum_type == "By Variable Levels") {
        decorated_by_variable_plot_dims_q()
      } else if (sum_type == "Grouped by Subject") {
        decorated_by_subject_plot_dims_q()
      }
    })

    decorated_final_q
  })
}

#' `teal` module: R Markdown render
#'
#' @description
#' `r lifecycle::badge("experimental")`
#'
#' Module to render R Markdown files using the data provided in the
#' `teal_data` object.
#'
#' The R Markdown file should be designed to accept variables available
#' in the data names of the module.
#'
#' @details
#' For example, if the `teal_data` object contains datasets named `mtcars`
#'  and `iris`, the R Markdown file can use these as variables as they
#' will be available in the R Markdown environment.
#'
#' The libraries used in the R Markdown file must be available in the
#' deployed shiny app environment.
#'
#' When developing the R Markdown file, the working data can be simulated
#' on a code chunk, which in turn can look for the presence of `.raw_data`
#' object to determine if it is being run inside the `teal` module or not.
#'
#' Example R markdown file:
#'
#' ``````md
#' ---
#' title: "R Markdown Report"
#' output: html_document
#' ---
#'
#' ```{r eval=!exists(".raw_data")}
#' mtcars <- datasets::mtcars
#' iris <- datasets::iris
#' ```
#'
#' ```{r}
#' summary(mtcars) |> print()
#' summary(iris) |> print()
#' ```
#' ``````
#'
#' @inheritParams teal::module
#' @inheritParams shared_params
#'
#' @param rmd_content (`character`) Content of the R Markdown file to be rendered.
#' This can be the value of `readLines("path/to/file.Rmd")`.
#' @param allow_download (`logical`) whether to allow downloading of the R Markdown file.
#' Defaults to `TRUE`.
#' @param extra_transform (`list`) of [teal::teal_transform_module()] that will be added in the module's UI.
#' This can be used to create interactive inputs that modify the parameters in R Markdown rendering.
#'
#' @inherit shared_params return
#'
#' @inheritSection teal::example_module Reporting
#'
#' @examplesShinylive
#' library(teal.modules.general)
#' interactive <- function() TRUE
#' {{ next_example }}
#' @examples
#'
#' # general data example
#' data <- teal_data()
#' data <- within(data, {
#'   CO2 <- CO2
#' })
#'
#' app <- init(
#'   data = data,
#'   modules = modules(
#'     tm_rmarkdown(
#'       label = "RMarkdown Module",
#'       rmd_content = c(
#'         "---",
#'         "title: \"R Markdown Report\"",
#'         "output: html_document",
#'         "---",
#'         "",
#'         "```{r}",
#'         "summary(CO2) |> print()",
#'         "```"
#'       )
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
#' @examples
#' nrow_transform <- teal_transform_module(
#'   label = "N Rows selector",
#'   ui = function(id) {
#'     ns <- NS(id)
#'     tags$div(
#'       numericInput(ns("n_rows"), "Show n rows", value = 40, min = 0, max = 200, step = 5)
#'     )
#'   },
#'   server = function(id, data) {
#'     moduleServer(id, function(input, output, session) {
#'       reactive({
#'         req(data())
#'         within(data(),
#'           {
#'             n_rows <- n_rows_value
#'           },
#'           n_rows_value = input$n_rows
#'         )
#'       })
#'     })
#'   }
#' )
#'
#' app <- init(
#'   data = data,
#'   modules = modules(
#'     tm_rmarkdown(
#'       label = "RMarkdown Module",
#'       rmd_content = readLines(
#'         system.file(
#'           file.path("sample_files", "co2_example.Rmd"),
#'           package = "teal.modules.general"
#'         )
#'       ),
#'       allow_download = FALSE,
#'       extra_transform = list(nrow_transform)
#'     )
#'   )
#' )
#'
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#' @export
tm_rmarkdown <- function(label = "RMarkdown Module",
                         rmd_content,
                         datanames = "all",
                         allow_download = TRUE,
                         pre_output = NULL,
                         post_output = NULL,
                         transformators = list(),
                         extra_transform = list()) {
  message("Initializing tm_rmarkdown")

  # Start of assertions

  checkmate::assert_string(label)
  checkmate::assert_character(rmd_content)
  checkmate::assert_flag(allow_download)

  checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
  checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)

  # End of assertions

  # Make UI args
  args <- as.list(environment())

  ans <- module(
    label = label,
    server = srv_rmarkdown,
    server_args = list(rmd_content = rmd_content, allow_download = allow_download, extra_transform = extra_transform),
    ui = ui_rmarkdown,
    ui_args = args,
    transformators = transformators,
    datanames = datanames
  )
  disable_src(ans)
}

# UI function for the rmarkdown module
ui_rmarkdown <- function(id, rmd_content, allow_download, extra_transform, ...) {
  args <- list(...)
  ns <- NS(id)

  teal.widgets::standard_layout(
    output = teal.widgets::white_small_well(
      tags$div(
        tags$h4("Rendered report from Rmd"),
        if (allow_download) {
          downloadButton(
            ns("download_rmd"),
            sprintf("Download R Markdown file"),
            class = "btn-primary btn-sm"
          )
        },
        ui_transform_teal_data(ns("extra_transform"), transformators = extra_transform)
      ),
      tags$hr(),
      uiOutput(ns("rmd_output"))
    ),
    encoding = NULL,
    pre_output = args$pre_output,
    post_output = args$post_output
  )
}

# Server function for the rmarkdown module
srv_rmarkdown <- function(id, data, rmd_content, allow_download, extra_transform) {
  checkmate::assert_class(data, "reactive")
  checkmate::assert_class(isolate(data()), "teal_data")
  moduleServer(id, function(input, output, session) {
    pre_decorated_q_r <- reactive({
      data_q <- req(data())
      teal.reporter::teal_card(data_q) <- c(
        teal.reporter::teal_card(data_q),
        teal.reporter::teal_card("## Module's output(s)")
      )
      data_q
    })

    q_r <- data_with_output_decorated <- teal::srv_transform_teal_data(
      "extra_transform",
      data = pre_decorated_q_r,
      transformators = extra_transform
    )

    if (allow_download) {
      output$download_rmd <- downloadHandler(
        filename = function() sprintf("from_teal_module-%s.Rmd", format(Sys.time(), "%Y%m%d_%H%M")),
        content = function(file) {
          # find the end of the YAML header or start of the file
          # and insert the contents of teal.code::get_code(q_r())
          yaml_end <- which(rmd_content == "---")[2]
          insert_pos <- if (!is.na(yaml_end)) yaml_end else 0
          note_lines <- c(
            "",
            "### Pre-processing data",
            "",
            "The following code chunk was automatically added by the teal markdown module.",
            "It shows how to generate the data used in this report.",
            "",
            "```{r}",
            teal.code::get_code(q_r()),
            "```",
            ""
          )
          rmd_content <- append(rmd_content, note_lines, after = insert_pos)
          writeLines(rmd_content, con = file)
        },
        contentType = "text/plain"
      )
    }

    clean_up_r <- shiny::reactiveVal(list())
    # Can only clean on sessionEnded as temporary files are needed for the reporter
    # during session
    onSessionEnded(function() {
      logger::log_debug("srv_rmarkdown: cleaning up temporary folders.")
      lapply(shiny::isolate(clean_up_r()), function(f) f())
    }, session)

    rendered_path_r <- reactive({
      datasets <- rlang::env_clone(
        as.environment(req(q_r())),
        parent = new.env() # Ensuring a clean parent environment that can load libraries
      ) # Clone to use unlocked environment
      temp_dir <- tempfile(pattern = "rmd_")
      dir.create(temp_dir, showWarnings = FALSE, recursive = TRUE)
      temp_rmd <- tempfile(pattern = "rmarkdown_module-", tmpdir = temp_dir, fileext = ".Rmd")
      # Schedule cleanup of temp files when reactive is re-executed
      shiny::isolate({
        old_clean_up <- clean_up_r()
        clean_up_r(c(old_clean_up, function() unlink(temp_dir, recursive = TRUE)))
      })
      writeLines(rmd_content, con = temp_rmd)

      tryCatch(
        {
          rmarkdown::render(
            temp_rmd,
            output_format = rmarkdown::md_document(
              variant = "markdown",
              standalone = TRUE,
              dev = "png"
            ),
            envir = datasets,
            quiet = TRUE,
            runtime = "static"
          )
        },
        error = function(e) {
          warning("Error rendering RMD file: ", e$message) # verbose error in logs
          e
        }
      )
    })

    rendered_html_r <- reactive({
      output_path <- req(rendered_path_r())
      validate(
        need(inherits(output_path, "character"), "Error rendering RMD file. Please contact the app developer.")
      )
      shiny::includeMarkdown(output_path)
    })

    output$rmd_output <- renderUI(rendered_html_r())

    result <- reactive({
      out_data <- q_r()
      report_doc <- .markdown_internal(rendered_path_r(), rendered_html_r())
      teal.reporter::teal_card(out_data) <- c(
        teal.reporter::teal_card(out_data), report_doc
      )
      out_data
    })
    result
  })
}

#' Create internal markdown object for use in reporter
#'
#' Creates an object of class `markdown_internal` that contains the
#' content of a markdown file.
#'
#' This package registers S3 methods for `toHTML` and `to_rmd` for this class to
#' facilitate rendering in `teal.reporter`.
#'
#' @param markdown_file (`character(1)`) path to markdown file.
#' @param rendered_html (`shiny.tag`) rendered HTML content.
#'
#' @return `markdown_internal` object
#'
#' @keywords internal
.markdown_internal <- function(markdown_file, rendered_html) {
  base_file <- basename(markdown_file)

  # Create new custom structure with contents and images in base64 as attribute
  structure(
    readLines(markdown_file),
    class = c("markdown_internal", "character"),
    parent_path = dirname(markdown_file),
    old_base_path = sprintf("%s_files/", tools::file_path_sans_ext(base_file)),
    cached_html = rendered_html
  )
}

#' @describeIn dot-markdown_internal Custom [tools::toHTML()] method for markdown_internal class that
#' uses a cached rendering of the module.
#' @inheritParams tools::toHTML
#' @param ... Arguments that will be passed to the next method.
#' @exportS3Method tools::toHTML
toHTML.markdown_internal <- function(x, ...) {
  cached_html <- attr(x, "cached_html", exact = TRUE)
  if (!is.null(cached_html)) {
    return(cached_html)
  }
  NextMethod(unclass(x), ...)
}

#' @describeIn dot-markdown_internal Custom [teal.reporter::to_rmd()] method for `markdown_internal`
#' object will be used to render the report.
#' @inheritParams teal.reporter::to_rmd
#' @param figures_dir (`character(1)`) directory where the R markdown auxiliary files will be saved.
#' @exportS3Method teal.reporter::to_rmd
to_rmd.markdown_internal <- function(block, figures_dir = "figures", ...) {
  old_base_path <- attr(block, "old_base_path", exact = TRUE)
  parent_path <- attr(block, "parent_path", exact = TRUE)
  new_base_path <- file.path(figures_dir, old_base_path)

  # Copy figures from old path to new location
  dir.create(figures_dir, showWarnings = FALSE, recursive = TRUE)
  file.copy(file.path(parent_path, old_base_path), figures_dir, recursive = TRUE)

  # Change the image paths in the markdown content
  block <- gsub(pattern = old_base_path, replacement = new_base_path, x = block, fixed = TRUE)
  NextMethod(unclass(block), ...)
}

#' `teal` module: Scatterplot and regression analysis
#'
#' Module for visualizing regression analysis, including scatterplots and
#' various regression diagnostics plots.
#' It allows users to explore the relationship between a set of regressors and a response variable,
#' visualize residuals, and identify outliers.
#'
#' @note For more examples, please see the vignette "Using regression plots" via
#' `vignette("using-regression-plots", package = "teal.modules.general")`.
#'
#' @inheritParams teal::module
#' @inheritParams shared_params
#' @param regressor (`data_extract_spec` or `list` of multiple `data_extract_spec`)
#' Regressor variables from an incoming dataset with filtering and selecting.
#' @param response (`data_extract_spec` or `list` of multiple `data_extract_spec`)
#' Response variables from an incoming dataset with filtering and selecting.
#' @param default_outlier_label (`character`) optional, default column selected to label outliers.
#' @param default_plot_type (`numeric`) optional, defaults to "Response vs Regressor".
#' 1. Response vs Regressor
#' 2. Residuals vs Fitted
#' 3. Normal Q-Q
#' 4. Scale-Location
#' 5. Cook's distance
#' 6. Residuals vs Leverage
#' 7. Cook's dist vs Leverage
#' @param label_segment_threshold (`numeric(1)` or `numeric(3)`)
#' Minimum distance between label and point on the plot that triggers the creation of
#' a line segment between the two.
#' This may happen when the label cannot be placed next to the point as it overlaps another
#' label or point.
#' The value is used as the `min.segment.length` parameter to the [ggrepel::geom_text_repel()] function.
#'
#' It can take the following forms:
#' - `numeric(1)`: Fixed value used for the minimum distance and the slider is not presented in the UI.
#' - `numeric(3)`: A slider is presented in the UI (under "Plot settings") to adjust the minimum distance dynamically.
#'
#'     It takes the form of `c(value, min, max)` and it is passed to the `value_min_max`
#'     argument in `teal.widgets::optionalSliderInputValMinMax`.
#'
# nolint start: line_length.
#' @param ggplot2_args `r roxygen_ggplot2_args_param("Response vs Regressor", "Residuals vs Fitted", "Scale-Location", "Cook's distance", "Residuals vs Leverage", "Cook's dist vs Leverage")`
# nolint end: line_length.
#'
#' @inherit shared_params return
#'
#' @section Decorating Module:
#'
#' This module generates the following objects, which can be modified in place using decorators:
#' - `plot` (`ggplot`)
#'
#' A Decorator is applied to the specific output using a named list of `teal_transform_module` objects.
#' The name of this list corresponds to the name of the output to which the decorator is applied.
#' See code snippet below:
#'
#' ```
#' tm_a_regression(
#'    ..., # arguments for module
#'    decorators = list(
#'      plot = teal_transform_module(...) # applied to the `plot` output
#'    )
#' )
#' ```
#'
#' For additional details and examples of decorators, refer to the vignette
#' `vignette("decorate-module-output", package = "teal.modules.general")`.
#'
#' To learn more please refer to the vignette
#' `vignette("transform-module-output", package = "teal")` or the [`teal::teal_transform_module()`] documentation.
#'
#' @inheritSection teal::example_module Reporting
#'
#' @examplesShinylive
#' library(teal.modules.general)
#' interactive <- function() TRUE
#' {{ next_example }}
#' @examples
#'
#' # general data example
#' data <- teal_data()
#' data <- within(data, {
#'   require(nestcolor)
#'   CO2 <- CO2
#' })
#'
#' app <- init(
#'   data = data,
#'   modules = modules(
#'     tm_a_regression(
#'       label = "Regression",
#'       response = data_extract_spec(
#'         dataname = "CO2",
#'         select = select_spec(
#'           label = "Select variable:",
#'           choices = "uptake",
#'           selected = "uptake",
#'           multiple = FALSE,
#'           fixed = TRUE
#'         )
#'       ),
#'       regressor = data_extract_spec(
#'         dataname = "CO2",
#'         select = select_spec(
#'           label = "Select variables:",
#'           choices = variable_choices(data[["CO2"]], c("conc", "Treatment")),
#'           selected = "conc",
#'           multiple = TRUE,
#'           fixed = FALSE
#'         )
#'       )
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
#' @examplesShinylive
#' library(teal.modules.general)
#' interactive <- function() TRUE
#' {{ next_example }}
#' @examples
#' # CDISC data example
#' data <- teal_data()
#' data <- within(data, {
#'   require(nestcolor)
#'   ADSL <- teal.data::rADSL
#' })
#' join_keys(data) <- default_cdisc_join_keys[names(data)]
#'
#' app <- init(
#'   data = data,
#'   modules = modules(
#'     tm_a_regression(
#'       label = "Regression",
#'       response = data_extract_spec(
#'         dataname = "ADSL",
#'         select = select_spec(
#'           label = "Select variable:",
#'           choices = "BMRKR1",
#'           selected = "BMRKR1",
#'           multiple = FALSE,
#'           fixed = TRUE
#'         )
#'       ),
#'       regressor = data_extract_spec(
#'         dataname = "ADSL",
#'         select = select_spec(
#'           label = "Select variables:",
#'           choices = variable_choices(data[["ADSL"]], c("AGE", "SEX", "RACE")),
#'           selected = "AGE",
#'           multiple = TRUE,
#'           fixed = FALSE
#'         )
#'       )
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
#' @export
#'
tm_a_regression <- function(label = "Regression Analysis",
                            regressor,
                            response,
                            plot_height = c(600, 200, 2000),
                            plot_width = NULL,
                            alpha = c(1, 0, 1),
                            size = c(2, 1, 8),
                            ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
                            ggplot2_args = teal.widgets::ggplot2_args(),
                            pre_output = NULL,
                            post_output = NULL,
                            default_plot_type = 1,
                            default_outlier_label = "USUBJID",
                            label_segment_threshold = c(0.5, 0, 10),
                            transformators = list(),
                            decorators = list()) {
  message("Initializing tm_a_regression")

  # Normalize the parameters
  if (inherits(regressor, "data_extract_spec")) regressor <- list(regressor)
  if (inherits(response, "data_extract_spec")) response <- list(response)
  if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)

  # Start of assertions
  checkmate::assert_string(label)
  checkmate::assert_list(regressor, types = "data_extract_spec")

  checkmate::assert_list(response, types = "data_extract_spec")
  assert_single_selection(response)

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

  if (length(alpha) == 1) {
    checkmate::assert_numeric(alpha, any.missing = FALSE, finite = TRUE)
  } else {
    checkmate::assert_numeric(alpha, len = 3, any.missing = FALSE, finite = TRUE)
    checkmate::assert_numeric(alpha[1], lower = alpha[2], upper = alpha[3], .var.name = "alpha")
  }

  if (length(size) == 1) {
    checkmate::assert_numeric(size, any.missing = FALSE, finite = TRUE)
  } else {
    checkmate::assert_numeric(size, len = 3, any.missing = FALSE, finite = TRUE)
    checkmate::assert_numeric(size[1], lower = size[2], upper = size[3], .var.name = "size")
  }

  ggtheme <- match.arg(ggtheme)

  plot_choices <- c(
    "Response vs Regressor", "Residuals vs Fitted", "Normal Q-Q", "Scale-Location",
    "Cook's distance", "Residuals vs Leverage", "Cook's dist vs Leverage"
  )
  checkmate::assert_list(ggplot2_args, types = "ggplot2_args")
  checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))

  checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
  checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
  checkmate::assert_choice(default_plot_type, seq.int(1L, length(plot_choices)))
  checkmate::assert_string(default_outlier_label)
  checkmate::assert_list(decorators, "teal_transform_module")

  if (length(label_segment_threshold) == 1) {
    checkmate::assert_numeric(label_segment_threshold, any.missing = FALSE, finite = TRUE)
  } else {
    checkmate::assert_numeric(label_segment_threshold, len = 3, any.missing = FALSE, finite = TRUE)
    checkmate::assert_numeric(
      label_segment_threshold[1],
      lower = label_segment_threshold[2],
      upper = label_segment_threshold[3],
      .var.name = "label_segment_threshold"
    )
  }
  assert_decorators(decorators, "plot")
  # End of assertions

  # Make UI args
  args <- as.list(environment())
  args[["plot_choices"]] <- plot_choices
  data_extract_list <- list(
    regressor = regressor,
    response = response
  )

  ans <- module(
    label = label,
    server = srv_a_regression,
    ui = ui_a_regression,
    ui_args = args,
    server_args = c(
      data_extract_list,
      list(
        plot_height = plot_height,
        plot_width = plot_width,
        default_outlier_label = default_outlier_label,
        ggplot2_args = ggplot2_args,
        decorators = decorators
      )
    ),
    transformators = transformators,
    datanames = teal.transform::get_extract_datanames(data_extract_list)
  )
  attr(ans, "teal_bookmarkable") <- FALSE
  ans
}

# UI function for the regression module
ui_a_regression <- function(id, ...) {
  ns <- NS(id)
  args <- list(...)
  is_single_dataset_value <- teal.transform::is_single_dataset(args$regressor, args$response)
  teal.widgets::standard_layout(
    output = teal.widgets::white_small_well(tags$div(
      teal.widgets::plot_with_settings_ui(id = ns("myplot")),
      tags$div(verbatimTextOutput(ns("text")))
    )),
    encoding = tags$div(
      tags$label("Encodings", class = "text-primary"), tags$br(),
      teal.transform::datanames_input(args[c("response", "regressor")]),
      teal.transform::data_extract_ui(
        id = ns("response"),
        label = "Response variable",
        data_extract_spec = args$response,
        is_single_dataset = is_single_dataset_value
      ),
      teal.transform::data_extract_ui(
        id = ns("regressor"),
        label = "Regressor variables",
        data_extract_spec = args$regressor,
        is_single_dataset = is_single_dataset_value
      ),
      radioButtons(
        ns("plot_type"),
        label = "Plot type:",
        choices = args$plot_choices,
        selected = args$plot_choices[args$default_plot_type]
      ),
      checkboxInput(ns("show_outlier"), label = "Display outlier labels", value = TRUE),
      conditionalPanel(
        condition = "input['show_outlier']",
        ns = ns,
        teal.widgets::optionalSliderInput(
          ns("outlier"),
          tags$div(
            tagList(
              "Outlier definition:",
              bslib::tooltip(
                icon("fas fa-circle-info"),
                paste(
                  "Use the slider to choose the cut-off value to define outliers.",
                  "Points with a Cook's distance greater than",
                  "the value on the slider times the mean of the Cook's distance of the dataset will have labels."
                )
              )
            )
          ),
          min = 1, max = 10, value = 9, ticks = FALSE, step = .1
        ),
        teal.widgets::optionalSelectInput(
          ns("label_var"),
          multiple = FALSE,
          label = "Outlier label"
        )
      ),
      ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "plot")),
      bslib::accordion(
        open = TRUE,
        bslib::accordion_panel(
          title = "Plot settings",
          teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", args$alpha, ticks = FALSE),
          teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", args$size, ticks = FALSE),
          teal.widgets::optionalSliderInputValMinMax(
            inputId = ns("label_min_segment"),
            label = tags$div(
              tagList(
                "Label min. segment:",
                bslib::tooltip(
                  icon("circle-info"),
                  tags$span(
                    paste(
                      "Use the slider to choose the cut-off value to define minimum distance between label and point",
                      "that generates a line segment.",
                      "It's only valid when 'Display outlier labels' is checked."
                    )
                  )
                )
              )
            ),
            value_min_max = args$label_segment_threshold,
            # Extra parameters to sliderInput
            ticks = FALSE,
            step = .1,
            round = FALSE
          ),
          selectInput(
            inputId = ns("ggtheme"),
            label = "Theme (by ggplot):",
            choices = ggplot_themes,
            selected = args$ggtheme,
            multiple = FALSE
          )
        )
      )
    ),
    pre_output = args$pre_output,
    post_output = args$post_output
  )
}

# Server function for the regression module
srv_a_regression <- function(id,
                             data,
                             response,
                             regressor,
                             plot_height,
                             plot_width,
                             ggplot2_args,
                             default_outlier_label,
                             decorators) {
  checkmate::assert_class(data, "reactive")
  checkmate::assert_class(isolate(data()), "teal_data")
  moduleServer(id, function(input, output, session) {
    teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")

    ns <- session$ns

    rule_rvr1 <- function(value) {
      if (isTRUE(input$plot_type == "Response vs Regressor")) {
        if (length(value) > 1L) {
          "This plot can only have one regressor."
        }
      }
    }
    rule_rvr2 <- function(other) {
      function(value) {
        if (isTRUE(input$plot_type == "Response vs Regressor")) {
          otherval <- selector_list()[[other]]()$select
          if (isTRUE(value == otherval)) {
            "Response and Regressor must be different."
          }
        }
      }
    }

    selector_list <- teal.transform::data_extract_multiple_srv(
      data_extract = list(response = response, regressor = regressor),
      datasets = data,
      select_validation_rule = list(
        regressor = shinyvalidate::compose_rules(
          shinyvalidate::sv_required("At least one regressor should be selected."),
          rule_rvr1,
          rule_rvr2("response")
        ),
        response = shinyvalidate::compose_rules(
          shinyvalidate::sv_required("At least one response should be selected."),
          rule_rvr2("regressor")
        )
      )
    )

    iv_r <- reactive({
      iv <- shinyvalidate::InputValidator$new()
      teal.transform::compose_and_enable_validators(iv, selector_list)
    })

    iv_out <- shinyvalidate::InputValidator$new()
    iv_out$condition(~ isTRUE(input$show_outlier))
    iv_out$add_rule("label_var", shinyvalidate::sv_required("Please provide an `Outlier label` variable"))
    iv_out$enable()

    anl_merged_input <- teal.transform::merge_expression_srv(
      selector_list = selector_list,
      datasets = data
    )

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

      list(
        response = as.vector(anl_merged_input()$columns_source$response),
        regressor = as.vector(anl_merged_input()$columns_source$regressor)
      )
    })

    qenv <- reactive({
      obj <- data()
      teal.reporter::teal_card(obj) <-
        c(
          teal.reporter::teal_card(obj),
          teal.reporter::teal_card("## Module's output(s)")
        )
      teal.code::eval_code(obj, "library(ggplot2);library(dplyr)")
    })

    anl_merged_q <- reactive({
      req(anl_merged_input())
      qenv() %>%
        teal.code::eval_code(as.expression(anl_merged_input()$expr))
    })

    # sets qenv object and populates it with data merge call and fit expression
    fit_r <- reactive({
      ANL <- anl_merged_q()[["ANL"]]
      teal::validate_has_data(ANL, 10)

      validate(need(is.numeric(ANL[regression_var()$response][[1]]), "Response variable should be numeric."))

      teal::validate_has_data(
        ANL[, c(regression_var()$response, regression_var()$regressor)], 10,
        complete = TRUE, allow_inf = FALSE
      )

      form <- stats::as.formula(
        paste(
          regression_var()$response,
          paste(
            regression_var()$regressor,
            collapse = " + "
          ),
          sep = " ~ "
        )
      )

      if (input$show_outlier) {
        opts <- teal.transform::variable_choices(ANL)
        selected <- if (!is.null(isolate(input$label_var)) && isolate(input$label_var) %in% as.character(opts)) {
          isolate(input$label_var)
        } else {
          if (length(opts[as.character(opts) == default_outlier_label]) == 0) {
            opts[[1]]
          } else {
            opts[as.character(opts) == default_outlier_label]
          }
        }
        teal.widgets::updateOptionalSelectInput(
          session = session,
          inputId = "label_var",
          choices = opts,
          selected = restoreInput(ns("label_var"), selected)
        )

        data <- ggplot2::fortify(stats::lm(form, data = ANL))
        cooksd <- data$.cooksd[!is.nan(data$.cooksd)]
        max_outlier <- max(ceiling(max(cooksd) / mean(cooksd)), 2)
        cur_outlier <- isolate(input$outlier)
        updateSliderInput(
          session = session,
          inputId = "outlier",
          min = 1,
          max = max_outlier,
          value = restoreInput(ns("outlier"), if (cur_outlier < max_outlier) cur_outlier else max_outlier * .9)
        )
      }

      anl_fit <- anl_merged_q() %>%
        teal.code::eval_code(substitute(fit <- stats::lm(form, data = ANL), env = list(form = form))) %>%
        teal.code::eval_code(quote({
          for (regressor in names(fit$contrasts)) {
            alts <- paste0(levels(ANL[[regressor]]), collapse = "|")
            names(fit$coefficients) <- gsub(
              paste0("^(", regressor, ")(", alts, ")$"), paste0("\\1", ": ", "\\2"), names(fit$coefficients)
            )
          }
        })) %>%
        teal.code::eval_code(quote({
          fit_summary <- summary(fit)
          fit_summary
        }))
      teal.reporter::teal_card(anl_fit) <- c(teal.reporter::teal_card(anl_fit), "### Plot")
      anl_fit
    })

    label_col <- reactive({
      teal::validate_inputs(iv_out)

      substitute(
        expr = dplyr::if_else(
          data$.cooksd > outliers * mean(data$.cooksd, na.rm = TRUE),
          as.character(stats::na.omit(ANL)[[label_var]]),
          ""
        ) %>%
          dplyr::if_else(is.na(.), "cooksd == NaN", .),
        env = list(outliers = input$outlier, label_var = input$label_var)
      )
    })

    label_min_segment <- reactive({
      input$label_min_segment
    })

    outlier_label <- reactive({
      substitute(
        expr = ggrepel::geom_text_repel(
          label = label_col,
          color = "red",
          hjust = 0,
          vjust = 1,
          max.overlaps = Inf,
          min.segment.length = label_min_segment,
          segment.alpha = 0.5,
          seed = 123
        ),
        env = list(label_col = label_col(), label_min_segment = label_min_segment())
      )
    })

    output_plot_base <- reactive({
      base_fit <- fit_r()
      teal.code::eval_code(
        base_fit,
        quote({
          class(fit$residuals) <- NULL

          data <- ggplot2::fortify(fit)

          smooth <- function(x, y) {
            as.data.frame(stats::lowess(x, y, f = 2 / 3, iter = 3))
          }

          smoothy_aes <- ggplot2::aes_string(x = "x", y = "y")

          reg_form <- deparse(fit$call[[2]])
        })
      )
    })

    output_plot_0 <- reactive({
      fit <- fit_r()[["fit"]]
      ANL <- anl_merged_q()[["ANL"]]

      stopifnot(ncol(fit$model) == 2)

      if (!is.factor(ANL[[regression_var()$regressor]])) {
        shinyjs::show("size")
        shinyjs::show("alpha")
        plot <- substitute(
          expr = ggplot2::ggplot(fit$model[, 2:1], ggplot2::aes_string(regressor, response)) +
            ggplot2::geom_point(size = size, alpha = alpha) +
            ggplot2::stat_smooth(method = "lm", formula = y ~ x, se = FALSE),
          env = list(
            regressor = regression_var()$regressor,
            response = regression_var()$response,
            size = input$size,
            alpha = input$alpha
          )
        )
        if (input$show_outlier) {
          plot <- substitute(
            expr = plot + outlier_label,
            env = list(plot = plot, outlier_label = outlier_label())
          )
        }
      } else {
        shinyjs::hide("size")
        shinyjs::hide("alpha")
        plot <- substitute(
          expr = ggplot2::ggplot(fit$model[, 2:1], ggplot2::aes_string(regressor, response)) +
            ggplot2::geom_boxplot(),
          env = list(regressor = regression_var()$regressor, response = regression_var()$response)
        )
        if (input$show_outlier) {
          plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label()))
        }
      }

      parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(
        teal.widgets::resolve_ggplot2_args(
          user_plot = ggplot2_args[["Response vs Regressor"]],
          user_default = ggplot2_args$default,
          module_plot = teal.widgets::ggplot2_args(
            labs = list(
              title = "Response vs Regressor",
              x = varname_w_label(regression_var()$regressor, ANL),
              y = varname_w_label(regression_var()$response, ANL)
            ),
            theme = list()
          )
        ),
        ggtheme = input$ggtheme
      )

      teal.code::eval_code(
        fit_r(),
        substitute(
          expr = {
            class(fit$residuals) <- NULL
            data <- ggplot2::fortify(fit)
            plot <- graph
          },
          env = list(
            graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
          )
        )
      )
    })

    output_plot_1 <- reactive({
      plot_base <- output_plot_base()
      shinyjs::show("size")
      shinyjs::show("alpha")
      plot <- substitute(
        expr = ggplot2::ggplot(data = data, ggplot2::aes(.fitted, .resid)) +
          ggplot2::geom_point(size = size, alpha = alpha) +
          ggplot2::geom_hline(yintercept = 0, linetype = "dashed", size = 1) +
          ggplot2::geom_line(data = smoothy, mapping = smoothy_aes),
        env = list(size = input$size, alpha = input$alpha)
      )
      if (input$show_outlier) {
        plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label()))
      }

      parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(
        teal.widgets::resolve_ggplot2_args(
          user_plot = ggplot2_args[["Residuals vs Fitted"]],
          user_default = ggplot2_args$default,
          module_plot = teal.widgets::ggplot2_args(
            labs = list(
              x = quote(paste0("Fitted values\nlm(", reg_form, ")")),
              y = "Residuals",
              title = "Residuals vs Fitted"
            )
          )
        ),
        ggtheme = input$ggtheme
      )

      teal.code::eval_code(
        plot_base,
        substitute(
          expr = {
            smoothy <- smooth(data$.fitted, data$.resid)
            plot <- graph
          },
          env = list(
            graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
          )
        )
      )
    })

    output_plot_2 <- reactive({
      shinyjs::show("size")
      shinyjs::show("alpha")
      plot_base <- output_plot_base()
      plot <- substitute(
        expr = ggplot2::ggplot(data = data, ggplot2::aes(sample = .stdresid)) +
          ggplot2::stat_qq(size = size, alpha = alpha) +
          ggplot2::geom_abline(linetype = "dashed"),
        env = list(size = input$size, alpha = input$alpha)
      )
      if (input$show_outlier) {
        plot <- substitute(
          expr = plot +
            ggplot2::stat_qq(
              geom = ggrepel::GeomTextRepel,
              label = label_col %>%
                data.frame(label = .) %>%
                dplyr::filter(label != "cooksd == NaN") %>%
                unlist(),
              color = "red",
              hjust = 0,
              vjust = 0,
              max.overlaps = Inf,
              min.segment.length = label_min_segment,
              segment.alpha = .5,
              seed = 123
            ),
          env = list(plot = plot, label_col = label_col(), label_min_segment = label_min_segment())
        )
      }

      parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(
        teal.widgets::resolve_ggplot2_args(
          user_plot = ggplot2_args[["Normal Q-Q"]],
          user_default = ggplot2_args$default,
          module_plot = teal.widgets::ggplot2_args(
            labs = list(
              x = quote(paste0("Theoretical Quantiles\nlm(", reg_form, ")")),
              y = "Standardized residuals",
              title = "Normal Q-Q"
            )
          )
        ),
        ggtheme = input$ggtheme
      )

      teal.code::eval_code(
        plot_base,
        substitute(
          expr = {
            plot <- graph
          },
          env = list(
            graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
          )
        )
      )
    })

    output_plot_3 <- reactive({
      shinyjs::show("size")
      shinyjs::show("alpha")
      plot_base <- output_plot_base()
      plot <- substitute(
        expr = ggplot2::ggplot(data = data, ggplot2::aes(.fitted, sqrt(abs(.stdresid)))) +
          ggplot2::geom_point(size = size, alpha = alpha) +
          ggplot2::geom_line(data = smoothy, mapping = smoothy_aes),
        env = list(size = input$size, alpha = input$alpha)
      )
      if (input$show_outlier) {
        plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label()))
      }

      parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(
        teal.widgets::resolve_ggplot2_args(
          user_plot = ggplot2_args[["Scale-Location"]],
          user_default = ggplot2_args$default,
          module_plot = teal.widgets::ggplot2_args(
            labs = list(
              x = quote(paste0("Fitted values\nlm(", reg_form, ")")),
              y = quote(expression(sqrt(abs(`Standardized residuals`)))),
              title = "Scale-Location"
            )
          )
        ),
        ggtheme = input$ggtheme
      )

      teal.code::eval_code(
        plot_base,
        substitute(
          expr = {
            smoothy <- smooth(data$.fitted, sqrt(abs(data$.stdresid)))
            plot <- graph
          },
          env = list(
            graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
          )
        )
      )
    })

    output_plot_4 <- reactive({
      shinyjs::hide("size")
      shinyjs::show("alpha")
      plot_base <- output_plot_base()
      plot <- substitute(
        expr = ggplot2::ggplot(data = data, ggplot2::aes(seq_along(.cooksd), .cooksd)) +
          ggplot2::geom_col(alpha = alpha),
        env = list(alpha = input$alpha)
      )
      if (input$show_outlier) {
        plot <- substitute(
          expr = plot +
            ggplot2::geom_hline(
              yintercept = c(
                outlier * mean(data$.cooksd, na.rm = TRUE),
                mean(data$.cooksd, na.rm = TRUE)
              ),
              color = "red",
              linetype = "dashed"
            ) +
            ggplot2::annotate(
              geom = "text",
              x = 0,
              y = mean(data$.cooksd, na.rm = TRUE),
              label = paste("mu", "=", round(mean(data$.cooksd, na.rm = TRUE), 4)),
              vjust = -1,
              hjust = 0,
              color = "red",
              angle = 90
            ) +
            outlier_label,
          env = list(plot = plot, outlier = input$outlier, outlier_label = outlier_label())
        )
      }

      parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(
        teal.widgets::resolve_ggplot2_args(
          user_plot = ggplot2_args[["Cook's distance"]],
          user_default = ggplot2_args$default,
          module_plot = teal.widgets::ggplot2_args(
            labs = list(
              x = quote(paste0("Obs. number\nlm(", reg_form, ")")),
              y = "Cook's distance",
              title = "Cook's distance"
            )
          )
        ),
        ggtheme = input$ggtheme
      )

      teal.code::eval_code(
        plot_base,
        substitute(
          expr = {
            plot <- graph
          },
          env = list(
            graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
          )
        )
      )
    })

    output_plot_5 <- reactive({
      shinyjs::show("size")
      shinyjs::show("alpha")
      plot_base <- output_plot_base()
      plot <- substitute(
        expr = ggplot2::ggplot(data = data, ggplot2::aes(.hat, .stdresid)) +
          ggplot2::geom_vline(
            size = 1,
            colour = "black",
            linetype = "dashed",
            xintercept = 0
          ) +
          ggplot2::geom_hline(
            size = 1,
            colour = "black",
            linetype = "dashed",
            yintercept = 0
          ) +
          ggplot2::geom_point(size = size, alpha = alpha) +
          ggplot2::geom_line(data = smoothy, mapping = smoothy_aes),
        env = list(size = input$size, alpha = input$alpha)
      )
      if (input$show_outlier) {
        plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label()))
      }

      parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(
        teal.widgets::resolve_ggplot2_args(
          user_plot = ggplot2_args[["Residuals vs Leverage"]],
          user_default = ggplot2_args$default,
          module_plot = teal.widgets::ggplot2_args(
            labs = list(
              x = quote(paste0("Standardized residuals\nlm(", reg_form, ")")),
              y = "Leverage",
              title = "Residuals vs Leverage"
            )
          )
        ),
        ggtheme = input$ggtheme
      )

      teal.code::eval_code(
        plot_base,
        substitute(
          expr = {
            smoothy <- smooth(data$.hat, data$.stdresid)
            plot <- graph
          },
          env = list(
            graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
          )
        )
      )
    })

    output_plot_6 <- reactive({
      shinyjs::show("size")
      shinyjs::show("alpha")
      plot_base <- output_plot_base()
      plot <- substitute(
        expr = ggplot2::ggplot(data = data, ggplot2::aes(.hat, .cooksd)) +
          ggplot2::geom_vline(xintercept = 0, colour = NA) +
          ggplot2::geom_abline(
            slope = seq(0, 3, by = 0.5),
            colour = "black",
            linetype = "dashed",
            size = 1
          ) +
          ggplot2::geom_line(data = smoothy, mapping = smoothy_aes) +
          ggplot2::geom_point(size = size, alpha = alpha),
        env = list(size = input$size, alpha = input$alpha)
      )
      if (input$show_outlier) {
        plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label()))
      }

      parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(
        teal.widgets::resolve_ggplot2_args(
          user_plot = ggplot2_args[["Cook's dist vs Leverage"]],
          user_default = ggplot2_args$default,
          module_plot = teal.widgets::ggplot2_args(
            labs = list(
              x = quote(paste0("Leverage\nlm(", reg_form, ")")),
              y = "Cooks's distance",
              title = "Cook's dist vs Leverage"
            )
          )
        ),
        ggtheme = input$ggtheme
      )

      teal.code::eval_code(
        plot_base,
        substitute(
          expr = {
            smoothy <- smooth(data$.hat, data$.cooksd)
            plot <- graph
          },
          env = list(
            graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
          )
        )
      )
    })

    output_q <- reactive({
      teal::validate_inputs(iv_r())
      switch(input$plot_type,
        "Response vs Regressor" = output_plot_0(),
        "Residuals vs Fitted" = output_plot_1(),
        "Normal Q-Q" = output_plot_2(),
        "Scale-Location" = output_plot_3(),
        "Cook's distance" = output_plot_4(),
        "Residuals vs Leverage" = output_plot_5(),
        "Cook's dist vs Leverage" = output_plot_6()
      )
    })

    decorated_output_q <- srv_decorate_teal_data(
      "decorator",
      data = output_q,
      decorators = select_decorators(decorators, "plot"),
      expr = quote(plot)
    )

    fitted <- reactive({
      req(decorated_output_q())
      decorated_output_q()[["fit"]]
    })
    plot_r <- reactive({
      req(decorated_output_q())
      decorated_output_q()[["plot"]]
    })

    # Insert the plot into a plot_with_settings module from teal.widgets
    pws <- teal.widgets::plot_with_settings_srv(
      id = "myplot",
      plot_r = plot_r,
      height = plot_height,
      width = plot_width
    )

    output$text <- renderText({
      req(iv_r()$is_valid())
      req(iv_out$is_valid())
      paste(utils::capture.output(summary(fitted()))[-1], collapse = "\n")
    })

    set_chunk_dims(pws, decorated_output_q)
  })
}

# minimal implementation of ggplot2 mosaic after ggmosaic was archived in CRAN
#
# This was heavily inspired by github.com/haleyjeppson/ggmosaic package but
# simplified to only support 2 categorical variables

#' Mosaic Rectangles Layer for ggplot2
#'
#' Adds a mosaic-style rectangles layer to a ggplot, visualizing the
#' joint distribution of categorical variables.
#' Each rectangle's size reflects the proportion of observations for
#' combinations of `x` and `fill`.
#'
#' @param mapping Set of aesthetic mappings created by `aes()`. Must specify `x` and `fill`.
#' @param data The data to be displayed in this layer.
#' @param stat The statistical transformation to use on the data. Defaults to `"rects"`.
#' @param position Position adjustment. Defaults to `"identity"`.
#' @param ... Other arguments passed to `layer()`.
#' @param na.rm Logical. Should missing values be removed?
#' @param show.legend Logical. Should this layer be included in the legends?
#' @param inherit.aes Logical. If `FALSE`, overrides default aesthetics.
#'
#' @return A ggplot2 layer that adds mosaic rectangles to the plot.
#'
#' @examples
#' df <- data.frame(RACE = c("Black", "White", "Black", "Asian"), SEX = c("M", "M", "F", "F"))
#' library(ggplot2)
#' ggplot(df) +
#'   geom_mosaic(aes(x = RACE, fill = SEX))
#' @export
geom_mosaic <- function(mapping = NULL, data = NULL,
                        stat = "mosaic", position = "identity",
                        ...,
                        na.rm = FALSE, # nolint: object_name_linter.
                        show.legend = TRUE, # nolint: object_name_linter.
                        inherit.aes = TRUE) { # nolint: object_name_linter.

  aes_x <- mapping$x
  if (!is.null(aes_x)) {
    aes_x <- list(rlang::quo_get_expr(mapping$x))
    var_x <- paste0("x__", as.character(aes_x))
    mapping[[var_x]] <- mapping$x
  }

  aes_fill <- mapping$fill
  if (!is.null(aes_fill)) {
    aes_fill <- rlang::quo_text(mapping$fill)
  }

  mapping$x <- structure(1L)

  layer <- ggplot2::layer(
    geom = GeomMosaic,
    stat = "mosaic",
    data = data,
    mapping = mapping,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    check.aes = FALSE,
    params = list(na.rm = na.rm, ...)
  )
  list(layer, .scale_x_mosaic())
}

#' @keywords internal
GeomMosaic <- ggplot2::ggproto( # nolint: object_name_linter.
  "GeomMosaic", ggplot2::GeomRect,
  default_aes = ggplot2::aes(
    colour = NA, linewidth = 0.5, linetype = 1, alpha = 1, fill = "grey30"
  ),
  draw_panel = function(data, panel_params, coord) {
    if (all(is.na(data$colour))) data$colour <- scales::alpha(data$fill, data$alpha)
    ggplot2::GeomRect$draw_panel(data, panel_params, coord)
  },
  required_aes = c("xmin", "xmax", "ymin", "ymax")
)

#' @keywords internal
StatMosaic <- ggplot2::ggproto( # nolint: object_name_linter.
  "StatMosaic", ggplot2::Stat,
  required_aes = c("x", "fill"),
  compute_group = function(data, scales) data,
  compute_panel = function(data, scales) {
    data$x <- data[, grepl("x__", colnames(data))]
    result <- .calculate_coordinates(data)

    results_non_zero <- result[result$.n != 0, ]
    breaks <- unique(with(results_non_zero, (xmin + xmax) / 2))
    labels <- unique(results_non_zero$x)
    result$x <- list(list2env(list(breaks = breaks[breaks != 0], labels = labels[breaks != 0])))

    result$group <- 1
    result$PANEL <- unique(data$PANEL)
    result
  }
)

#' Determining scales for mosaics
#'
#' @param breaks,labels,minor_breaks One of:
#' - `NULL` for no breaks / labels.
#' - [ggplot2::waiver()] for the default breaks / labels computed by the scale.
#' - A numeric / character vector giving the positions of the breaks / labels.
#' - A function.
#' See [ggplot2::scale_x_continuous()] for more details.
#' @param na.value The value to be used for `NA` values.
#' @param position For position scales, The position of the axis.
#' left or right for y axes, top or bottom for x axes.
#' @param ... other arguments passed to `continuous_scale()`.
#' @keywords internal
.scale_x_mosaic <- function(breaks = unique,
                            minor_breaks = NULL,
                            labels = unique,
                            na.value = NA_real_, # nolint: object_name_linter.
                            position = "bottom",
                            ...) {
  ggplot2::continuous_scale(
    aesthetics = c(
      "x", "xmin", "xmax", "xend", "xintercept", "xmin_final", "xmax_final",
      "xlower", "xmiddle", "xupper"
    ),
    palette = identity,
    breaks = breaks,
    minor_breaks = minor_breaks,
    labels = labels,
    na.value = na.value,
    position = position,
    super = ScaleContinuousMosaic, ,
    guide = ggplot2::waiver(),
    ...
  )
}

#' @keywords internal
ScaleContinuousMosaic <- ggplot2::ggproto( # nolint: object_name_linter.
  "ScaleContinuousMosaic", ggplot2::ScaleContinuousPosition,
  train = function(self, x) {
    if (length(x) == 0) {
      return()
    }
    if (is.list(x)) {
      scale_x <- x[[1]]
      # re-assign the scale values now that we have the information - but only if necessary
      if (is.function(self$breaks)) self$breaks <- scale_x$breaks
      if (is.function(self$labels)) self$labels <- as.vector(scale_x$labels)
      return(NULL)
    }
    if (is_discrete(x)) {
      self$range$train(x = c(0, 1))
      return(NULL)
    }
    self$range$train(x, call = self$call)
  },
  map = function(self, x, limits = self$get_limits()) {
    if (is_discrete(x)) {
      return(x)
    }
    if (is.list(x)) {
      return(0)
    } # need a number
    scaled <- as.numeric(self$oob(x, limits))
    ifelse(!is.na(scaled), scaled, self$na.value)
  },
  dimension = function(self, expand = c(0, 0)) c(-0.05, 1.05)
)

#' @noRd
is_discrete <- function(x) is.factor(x) || is.character(x) || is.logical(x)

#' @describeIn geom_mosaic
#' Computes the coordinates for rectangles in a mosaic plot based
#' on combinations of `x` and `fill` variables.
#' For each unique `x` and `fill`, calculates the proportional
#' widths and heights, stacking rectangles within each `x` group.
#'
#' ### Value
#'
#' A data frame with columns: `x`, `fill`, `xmin`, `xmax`, `ymin`, `ymax`,
#' representing the position and size of each rectangle.
#'
#' @keywords internal
.calculate_coordinates <- function(data) {
  # Example: compute rectangles from x and y
  result <- data |>
    # Count combinations of X and Y
    dplyr::count(.data$x, .data$fill, .drop = FALSE) |>
    # Compute total for each X group
    dplyr::mutate(
      .by = .data$x,
      x_total = sum(.data$n),
      prop = .data$n / .data$x_total,
      prop = dplyr::if_else(is.nan(.data$prop), 0, .data$prop)
    ) |>
    dplyr::arrange(dplyr::desc(.data$x_total), .data$x, .data$fill) |>
    # Compute total sample size to turn counts into widths
    dplyr::mutate(
      N_total = dplyr::n(),
      x_width = .data$x_total / .data$N_total
    ) |>
    # Convert counts to x widths
    dplyr::mutate(
      .by = .data$x,
      x_width_last = dplyr::if_else(dplyr::row_number() == dplyr::n(), .data$x_width, 0)
    ) |>
    # Compute x-min/x-max for each group
    dplyr::mutate(
      xmin = cumsum(dplyr::lag(.data$x_width_last, default = 0)),
      xmax = .data$xmin + .data$x_width
    ) |>
    # Compute y-min/y-max for stacked proportions
    dplyr::mutate(
      .by = .data$x,
      ymin = c(0, utils::head(cumsum(.data$prop), -1)),
      ymax = cumsum(.data$prop)
    ) |>
    dplyr::mutate(
      xmin = .data$xmin / max(.data$xmax),
      xmax = .data$xmax / max(.data$xmax),
      xmin = dplyr::if_else(.data$n == 0, 0, .data$xmin + 0.005),
      xmax = dplyr::if_else(.data$n == 0, 0, .data$xmax - 0.005),
      ymin = dplyr::if_else(.data$n == 0, 0, .data$ymin + 0.005),
      ymax = dplyr::if_else(.data$n == 0, 0, .data$ymax - 0.005)
    ) |>
    dplyr::select(.data$x, .data$fill, .data$xmin, .data$xmax, .data$ymin, .data$ymax, .n = .data$n)
  result
}

#' `teal` module: Front page
#'
#' Creates a simple front page for `teal` applications, displaying
#' introductory text, tables, additional `html` or `shiny` tags, and footnotes.
#'
#' @inheritParams teal::module
#' @param header_text (`character` vector) text to be shown at the top of the module, for each
#' element, if named the name is shown first in bold as a header followed by the value. The first
#' element's header is displayed larger than the others.
#' @param tables (`named list` of `data.frame`s) tables to be shown in the module.
#' @param additional_tags (`shiny.tag.list` or `html`) additional `shiny` tags or `html` to be included after the table,
#' for example to include an image, `tagList(tags$img(src = "image.png"))` or to include further `html`,
#' `HTML("html text here")`.
#' @param footnotes (`character` vector) of text to be shown at the bottom of the module, for each
#' element, if named the name is shown first in bold, followed by the value.
#' @param show_metadata (`logical`) `r lifecycle::badge("deprecated")` indicating
#' whether the metadata of the datasets be available on the module.
#' Metadata shown automatically when `datanames` set.
#' @inheritParams tm_variable_browser
#'
#' @inherit shared_params return
#'
#' @examplesShinylive
#' library(teal.modules.general)
#' interactive <- function() TRUE
#' {{ next_example }}
#' @examples
#' data <- teal_data()
#' data <- within(data, {
#'   require(nestcolor)
#'   ADSL <- teal.data::rADSL
#'   attr(ADSL, "metadata") <- list("Author" = "NEST team", "data_source" = "synthetic data")
#' })
#' join_keys(data) <- default_cdisc_join_keys[names(data)]
#'
#' table_1 <- data.frame(Info = c("A", "B"), Text = c("A", "B"))
#' table_2 <- data.frame(`Column 1` = c("C", "D"), `Column 2` = c(5.5, 6.6), `Column 3` = c("A", "B"))
#' table_3 <- data.frame(Info = c("E", "F"), Text = c("G", "H"))
#'
#' table_input <- list(
#'   "Table 1" = table_1,
#'   "Table 2" = table_2,
#'   "Table 3" = table_3
#' )
#'
#' app <- init(
#'   data = data,
#'   modules = modules(
#'     tm_front_page(
#'       header_text = c(
#'         "Important information" = "It can go here.",
#'         "Other information" = "Can go here."
#'       ),
#'       tables = table_input,
#'       additional_tags = HTML("Additional HTML or shiny tags go here <br>"),
#'       footnotes = c("X" = "is the first footnote", "Y is the second footnote")
#'     )
#'   )
#' ) |>
#'   modify_header(tags$h1("Sample Application")) |>
#'   modify_footer(tags$p("Application footer"))
#'
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
#' @export
#'
tm_front_page <- function(label = "Front page",
                          header_text = character(0),
                          tables = list(),
                          additional_tags = tagList(),
                          footnotes = character(0),
                          show_metadata = deprecated(),
                          datanames = if (missing(show_metadata)) NULL else "all",
                          transformators = list()) {
  message("Initializing tm_front_page")

  # Start of assertions
  checkmate::assert_string(label)
  checkmate::assert_character(header_text, min.len = 0, any.missing = FALSE)
  checkmate::assert_list(tables, types = "data.frame", names = "named", any.missing = FALSE)
  checkmate::assert_multi_class(additional_tags, classes = c("shiny.tag.list", "html"))
  checkmate::assert_character(footnotes, min.len = 0, any.missing = FALSE)
  if (!missing(show_metadata)) {
    lifecycle::deprecate_stop(
      when = "0.4.0",
      what = "tm_front_page(show_metadata)",
      with = "tm_front_page(datanames)",
      details = c(
        "With `datanames` you can select which datasets are displayed.",
        i = "Use `tm_front_page(datanames = 'all')` to keep the previous behavior and avoid this warning."
      )
    )
  }
  checkmate::assert_character(datanames, min.len = 0, min.chars = 1, null.ok = TRUE)

  # End of assertions

  # Make UI args
  args <- as.list(environment())

  ans <- module(
    label = label,
    server = srv_front_page,
    ui = ui_front_page,
    ui_args = args,
    server_args = list(tables = tables),
    datanames = datanames, ,
    transformators = transformators
  )
  attr(ans, "teal_bookmarkable") <- TRUE
  ans
}

# UI function for the front page module
ui_front_page <- function(id, ...) {
  args <- list(...)
  ns <- NS(id)

  tagList(
    tags$div(
      id = "front_page_content",
      style = "margin-left: 2rem;",
      tags$div(
        id = "front_page_headers",
        get_header_tags(args$header_text)
      ),
      tags$div(
        id = "front_page_tables",
        style = "margin-left: 2rem;",
        get_table_tags(args$tables, ns)
      ),
      tags$div(
        id = "front_page_custom_html",
        style = "margin-left: 2rem;",
        args$additional_tags
      ),
      if (length(args$datanames) > 0L) {
        tags$div(
          id = "front_page_metabutton",
          style = "margin: 1rem;",
          actionButton(ns("metadata_button"), "Show metadata")
        )
      },
      tags$footer(
        class = "small",
        get_footer_tags(args$footnotes)
      )
    )
  )
}

# Server function for the front page module
srv_front_page <- function(id, data, tables) {
  checkmate::assert_class(data, "reactive")
  checkmate::assert_class(isolate(data()), "teal_data")
  moduleServer(id, function(input, output, session) {
    teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")

    ns <- session$ns

    setBookmarkExclude("metadata_button")

    lapply(seq_along(tables), function(idx) {
      output[[paste0("table_", idx)]] <- renderTable(
        tables[[idx]],
        bordered = TRUE,
        caption = names(tables)[idx],
        caption.placement = "top"
      )
    })
    if (length(isolate(names(data()))) > 0L) {
      observeEvent(
        input$metadata_button, showModal(
          modalDialog(
            title = "Metadata",
            dataTableOutput(ns("metadata_table")),
            size = "l",
            easyClose = TRUE
          )
        )
      )

      metadata_data_frame <- reactive({
        datanames <- names(data())
        convert_metadata_to_dataframe(
          lapply(datanames, function(dataname) attr(data()[[dataname]], "metadata")),
          datanames
        )
      })

      output$metadata_table <- DT::renderDT({
        validate(need(nrow(metadata_data_frame()) > 0, "The data has no associated metadata"))
        metadata_data_frame()
      })
    }
  })
}

## utils functions

get_header_tags <- function(header_text) {
  if (length(header_text) == 0) {
    return(list())
  }

  get_single_header_tags <- function(header_text, p_text, header_tag = tags$h4) {
    tagList(
      tags$div(
        if (!is.null(header_text) && nchar(header_text) > 0) header_tag(header_text),
        tags$p(p_text)
      )
    )
  }

  header_tags <- get_single_header_tags(names(header_text[1]), header_text[1], header_tag = tags$h3)
  c(header_tags, mapply(get_single_header_tags, utils::tail(names(header_text), -1), utils::tail(header_text, -1)))
}

get_table_tags <- function(tables, ns) {
  if (length(tables) == 0) {
    return(list())
  }
  table_tags <- c(lapply(seq_along(tables), function(idx) {
    list(
      tableOutput(ns(paste0("table_", idx)))
    )
  }))
  table_tags
}

get_footer_tags <- function(footnotes) {
  if (length(footnotes) == 0) {
    return(list())
  }
  bold_texts <- if (is.null(names(footnotes))) rep("", length(footnotes)) else names(footnotes)
  footnote_tags <- mapply(function(bold_text, value) {
    list(
      tags$div(
        tags$b(bold_text),
        value,
        tags$br()
      )
    )
  }, bold_text = bold_texts, value = footnotes)
}

# take a list of metadata, one item per dataset (raw_metadata each element from datasets$get_metadata())
# and the corresponding datanames and output a data.frame with columns {Dataset, Name, Value}.
# which are, the Dataset the metadata came from, the metadata's name and value
convert_metadata_to_dataframe <- function(raw_metadata, datanames) {
  output <- mapply(function(metadata, dataname) {
    if (is.null(metadata)) {
      return(data.frame(Dataset = character(0), Name = character(0), Value = character(0)))
    }
    data.frame(
      Dataset = dataname,
      Name = names(metadata),
      Value = unname(unlist(lapply(metadata, as.character)))
    )
  }, raw_metadata, datanames, SIMPLIFY = FALSE)
  do.call(rbind, output)
}

#' `teal` module: Variable browser
#'
#' Module provides provides a detailed summary and visualization of variable distributions
#' for `data.frame` objects, with interactive features to customize analysis.
#'
#' Numeric columns with fewer than 30 distinct values can be treated as either discrete
#' or continuous with a checkbox allowing users to switch how they are treated(if < 6 unique values
#' then the default is discrete, otherwise it is continuous).
#'
#' @inheritParams teal::module
#' @inheritParams shared_params
#' @param parent_dataname (`character(1)`) string specifying a parent dataset.
#' If it exists in `datanames` then an extra checkbox will be shown to
#' allow users to not show variables in other datasets which exist in this `dataname`.
#' This is typically used to remove `ADSL` columns in `CDISC` data.
#' In non `CDISC` data this can be ignored. Defaults to `"ADSL"`.
#' @param datasets_selected (`character`) `r lifecycle::badge("deprecated")` vector of datasets to show, please
#' use the `datanames` argument.
#'
#' @inherit shared_params return
#'
#' @examplesShinylive
#' library(teal.modules.general)
#' interactive <- function() TRUE
#' {{ next_example }}
# nolint start: line_length_linter.
#' @examples
# nolint end: line_length_linter.
#' # general data example
#' data <- teal_data()
#' data <- within(data, {
#'   iris <- iris
#'   mtcars <- mtcars
#'   women <- women
#'   faithful <- faithful
#'   CO2 <- CO2
#' })
#'
#' app <- init(
#'   data = data,
#'   modules = modules(
#'     tm_variable_browser(
#'       label = "Variable browser"
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
#' @examplesShinylive
#' library(teal.modules.general)
#' interactive <- function() TRUE
#' {{ next_example }}
# nolint start: line_length_linter.
#' @examples
# nolint end: line_length_linter.
#' # CDISC example data
#' library(sparkline)
#' data <- teal_data()
#' data <- within(data, {
#'   ADSL <- teal.data::rADSL
#'   ADTTE <- teal.data::rADTTE
#' })
#' join_keys(data) <- default_cdisc_join_keys[names(data)]
#'
#' app <- init(
#'   data = data,
#'   modules = modules(
#'     tm_variable_browser(
#'       label = "Variable browser"
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
#' @export
#'
tm_variable_browser <- function(label = "Variable Browser",
                                datasets_selected = deprecated(),
                                datanames = if (missing(datasets_selected)) "all" else datasets_selected,
                                parent_dataname = "ADSL",
                                pre_output = NULL,
                                post_output = NULL,
                                ggplot2_args = teal.widgets::ggplot2_args(),
                                transformators = list()) {
  message("Initializing tm_variable_browser")

  # Start of assertions
  checkmate::assert_string(label)
  if (!missing(datasets_selected)) {
    lifecycle::deprecate_stop(
      when = "0.4.0",
      what = "tm_variable_browser(datasets_selected)",
      with = "tm_variable_browser(datanames)",
      details = c(
        "If both `datasets_selected` and `datanames` are set `datasets_selected` will be silently ignored.",
        i = 'Use `tm_variable_browser(datanames = "all")` to keep the previous behavior and avoid this warning.'
      )
    )
  }
  checkmate::assert_character(datanames, min.len = 0, min.chars = 1, null.ok = TRUE)
  checkmate::assert_character(parent_dataname, min.len = 0, max.len = 1)
  checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
  checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
  checkmate::assert_class(ggplot2_args, "ggplot2_args")
  # End of assertions

  datanames_module <- if (identical(datanames, "all") || is.null(datanames)) {
    datanames
  } else {
    union(datanames, parent_dataname)
  }

  ans <- module(
    label,
    server = srv_variable_browser,
    ui = ui_variable_browser,
    datanames = datanames_module,
    server_args = list(
      datanames = if (is.null(datanames)) "all" else datanames,
      parent_dataname = parent_dataname,
      ggplot2_args = ggplot2_args
    ),
    ui_args = list(
      pre_output = pre_output,
      post_output = post_output
    ),
    transformators = transformators
  )
  # `shiny` inputs are stored properly but the majority of the module is state of `datatable` which is not stored.
  attr(ans, "teal_bookmarkable") <- NULL
  ans
}

# UI function for the variable browser module
ui_variable_browser <- function(id,
                                pre_output = NULL,
                                post_output = NULL) {
  ns <- NS(id)

  tags$div(
    shinyjs::useShinyjs(),
    teal.widgets::standard_layout(
      output = tags$div(
        htmlwidgets::getDependency("sparkline"), # needed for sparklines to work
        bslib::layout_column_wrap(
          width = 0.5,
          teal.widgets::white_small_well(
            uiOutput(ns("ui_variable_browser")),
            shinyjs::hidden({
              checkboxInput(ns("show_parent_vars"), "Show parent dataset variables", value = FALSE)
            })
          ),
          teal.widgets::white_small_well(
            uiOutput(ns("ui_histogram_display")),
            uiOutput(ns("ui_numeric_display")),
            teal.widgets::plot_with_settings_ui(ns("variable_plot")),
            tags$br(),
            bslib::accordion(
              open = FALSE,
              bslib::accordion_panel(
                title = "Plot settings",
                selectInput(
                  inputId = ns("ggplot_theme"), label = "ggplot2 theme",
                  choices = ggplot_themes,
                  selected = "grey"
                ),
                bslib::layout_columns(
                  col_widths = c(6, 6),
                  sliderInput(
                    inputId = ns("font_size"), label = "font size",
                    min = 5L, max = 30L, value = 15L, step = 1L, ticks = FALSE
                  ),
                  sliderInput(
                    inputId = ns("label_rotation"), label = "rotate x labels",
                    min = 0L, max = 90L, value = 45L, step = 1, ticks = FALSE
                  )
                )
              )
            ),
            tags$br(),
            teal.widgets::get_dt_rows(ns("variable_summary_table"), ns("variable_summary_table_rows")),
            DT::dataTableOutput(ns("variable_summary_table"))
          )
        )
      ),
      pre_output = pre_output,
      post_output = post_output
    )
  )
}

# Server function for the variable browser module
srv_variable_browser <- function(id,
                                 data,
                                 datanames, parent_dataname, ggplot2_args) {
  checkmate::assert_class(data, "reactive")
  checkmate::assert_class(isolate(data()), "teal_data")
  moduleServer(id, function(input, output, session) {
    teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")

    # if there are < this number of unique records then a numeric
    # variable can be treated as a factor and all factors with < this groups
    # have their values plotted
    .unique_records_for_factor <- 30
    # if there are < this number of unique records then a numeric
    # variable is by default treated as a factor
    .unique_records_default_as_factor <- 6 # nolint: object_length.

    varname_numeric_as_factor <- reactiveValues()

    datanames <- Filter(function(name) {
      is.data.frame(isolate(data())[[name]])
    }, if (identical(datanames, "all")) names(isolate(data())) else datanames)

    output$ui_variable_browser <- renderUI({
      ns <- session$ns
      do.call(
        tabsetPanel,
        c(
          id = ns("tabset_panel"),
          do.call(
            tagList,
            lapply(datanames, function(dataname) {
              tabPanel(
                dataname,
                tags$div(
                  style = "margin-top: 1rem;",
                  textOutput(ns(paste0("dataset_summary_", dataname)))
                ),
                tags$div(
                  style = "margin-top: 1rem;",
                  teal.widgets::get_dt_rows(
                    ns(paste0("variable_browser_", dataname)),
                    ns(paste0("variable_browser_", dataname, "_rows"))
                  ),
                  DT::dataTableOutput(ns(paste0("variable_browser_", dataname)), width = "100%")
                )
              )
            })
          )
        )
      )
    })

    # conditionally display checkbox
    shinyjs::toggle(
      id = "show_parent_vars",
      condition = length(parent_dataname) > 0 && parent_dataname %in% datanames
    )

    columns_names <- new.env()

    # plot_var$data holds the name of the currently selected dataset
    # plot_var$variable[[<dataset_name>]] holds the name of the currently selected
    # variable for dataset <dataset_name>
    plot_var <- reactiveValues(data = NULL, variable = list())

    establish_updating_selection(datanames, input, plot_var, columns_names)

    # validations
    validation_checks <- validate_input(req(input), req(plot_var), data)

    # data_for_analysis is a list with two elements: a column from a dataset and the column label
    plotted_data <- reactive({
      req(input, plot_var, data())
      validation_checks()
      get_plotted_data(input, plot_var, data)
    })

    treat_numeric_as_factor <- reactive({
      if (is_num_var_short(.unique_records_for_factor, input, plotted_data)) {
        input$numeric_as_factor
      } else {
        FALSE
      }
    })

    render_tabset_panel_content(
      input = input,
      output = output,
      data = data,
      datanames = datanames,
      parent_dataname = parent_dataname,
      columns_names = columns_names,
      plot_var = plot_var
    )
    # add used-defined text size to ggplot arguments passed from caller frame
    all_ggplot2_args <- reactive({
      user_text <- teal.widgets::ggplot2_args(
        theme = list(
          "text" = ggplot2::element_text(size = input[["font_size"]]),
          "axis.text.x" = ggplot2::element_text(angle = input[["label_rotation"]], hjust = 1)
        )
      )
      user_theme <- utils::getFromNamespace(sprintf("theme_%s", input[["ggplot_theme"]]), ns = "ggplot2")
      user_theme <- user_theme()
      # temporary fix to circumvent assertion issue with resolve_ggplot2_args
      # drop problematic elements
      user_theme <- user_theme[grep("strip.text.y.left", names(user_theme), fixed = TRUE, invert = TRUE)]

      teal.widgets::resolve_ggplot2_args(
        user_plot = user_text,
        user_default = teal.widgets::ggplot2_args(theme = user_theme),
        module_plot = ggplot2_args
      )
    })

    output$ui_numeric_display <- renderUI({
      dataname <- req(input$tabset_panel)
      varname <- req(plot_var$variable)[[dataname]]
      df <- req(data())[[dataname]]
      validation_checks()

      numeric_ui <- bslib::page_fluid(
        bslib::layout_columns(
          col_widths = c(8, 4),
          bslib::layout_columns(
            col_widths = c(6, 6, 12),
            style = bslib::css(grid_row_gap = 0),
            bslib::input_switch(
              id = session$ns("display_density"),
              label = tags$div(
                "Show density:",
                bslib::tooltip(
                  trigger = icon("circle-info"),
                  tags$span(
                    "Show kernel density estimation with gaussian kernel and bandwidth function bw.nrd0 (R default)"
                  )
                )
              ),
              value = `if`(is.null(isolate(input$display_density)), TRUE, isolate(input$display_density)),
              width = "100%"
            ),
            bslib::input_switch(
              id = session$ns("remove_outliers"),
              label = "Remove outliers",
              value = `if`(is.null(isolate(input$remove_outliers)), FALSE, isolate(input$remove_outliers)),
              width = "100%"
            ),
            uiOutput(session$ns("ui_outlier_help"))
          ),
          uiOutput(session$ns("outlier_definition_slider_ui"))
        )
      )

      observeEvent(input$numeric_as_factor, ignoreInit = TRUE, {
        varname_numeric_as_factor[[plot_var$variable[[dataname]]]] <- input$numeric_as_factor
      })

      if (is.numeric(df[[varname]])) {
        unique_entries <- length(unique(df[[varname]]))
        if (unique_entries < .unique_records_for_factor && unique_entries > 0) {
          list(
            checkboxInput(
              session$ns("numeric_as_factor"),
              "Treat variable as factor",
              value = `if`(
                is.null(varname_numeric_as_factor[[varname]]),
                unique_entries < .unique_records_default_as_factor,
                varname_numeric_as_factor[[varname]]
              )
            ),
            conditionalPanel("!input.numeric_as_factor", ns = session$ns, numeric_ui)
          )
        } else if (unique_entries > 0) {
          numeric_ui
        }
      } else {
        NULL
      }
    })

    output$ui_histogram_display <- renderUI({
      validation_checks()
      dataname <- req(input$tabset_panel)
      varname <- req(plot_var$variable)[[dataname]]
      df <- req(data())[[dataname]]

      numeric_ui <- bslib::input_switch(
        id = session$ns("remove_NA_hist"),
        label = "Remove NA values",
        value = FALSE,
        width = "100%"
      )

      var <- df[[varname]]
      if (anyNA(var) && (is.factor(var) || is.character(var) || is.logical(var))) {
        groups <- unique(as.character(var))
        len_groups <- length(groups)
        if (len_groups >= .unique_records_for_factor) {
          NULL
        } else {
          numeric_ui
        }
      } else {
        NULL
      }
    })

    output$outlier_definition_slider_ui <- renderUI({
      req(input$remove_outliers)
      sliderInput(
        inputId = session$ns("outlier_definition_slider"),
        tags$div(
          tagList(
            "Outlier definition:",
            bslib::tooltip(
              icon("circle-info"),
              tags$span(
                paste(
                  "Use the slider to choose the cut-off value to define outliers; the larger the value the",
                  "further below Q1/above Q3 points have to be in order to be classed as outliers"
                )
              )
            )
          )
        ),
        min = 1,
        max = 5,
        value = 3,
        step = 0.5
      )
    })

    output$ui_outlier_help <- renderUI({
      req(is.logical(input$remove_outliers), input$outlier_definition_slider)
      if (input$remove_outliers) {
        tags$small(
          helpText(
            withMathJax(paste0(
              "Outlier data points (\\( X \\lt Q1 - ", input$outlier_definition_slider, "\\times IQR \\) or
            \\(Q3 + ", input$outlier_definition_slider, "\\times IQR \\lt X\\))
            have not been displayed on the graph and will not be used for any kernel density estimations, ",
              "although their values remain in the statisics table below."
            ))
          )
        )
      } else {
        NULL
      }
    })

    output$variable_summary_table <- DT::renderDataTable({
      var_summary_table(
        plotted_data()$ANL[, 1, drop = TRUE],
        treat_numeric_as_factor(),
        input$variable_summary_table_rows,
        if (!is.null(input$remove_outliers) && input$remove_outliers) {
          req(input$outlier_definition_slider)
          as.numeric(input$outlier_definition_slider)
        } else {
          0
        }
      )
    })

    variable_plot_r <- reactive({
      display_density <- `if`(is.null(input$display_density), FALSE, input$display_density)
      remove_outliers <- `if`(is.null(input$remove_outliers), FALSE, input$remove_outliers)

      if (remove_outliers) {
        req(input$outlier_definition_slider)
        outlier_definition <- as.numeric(input$outlier_definition_slider)
      } else {
        outlier_definition <- 0
      }

      plot_var_summary(
        qenv = req(plotted_data()),
        wrap_character = 15,
        numeric_as_factor = treat_numeric_as_factor(),
        remove_NA_hist = input$remove_NA_hist,
        display_density = display_density,
        outlier_definition = outlier_definition,
        records_for_factor = .unique_records_for_factor,
        ggplot2_args = all_ggplot2_args()
      )
    })

    plot_r <- reactive({
      validation_checks()
      req(variable_plot_r())[["plot"]]
    })

    pws <- teal.widgets::plot_with_settings_srv(
      id = "variable_plot",
      plot_r = plot_r,
      height = c(500, 200, 2000)
    )

    set_chunk_dims(pws, variable_plot_r)
  })
}

#' Summarize NAs.
#'
#' Summarizes occurrence of missing values in vector.
#' @param x vector of any type and length
#' @return Character string describing `NA` occurrence.
#' @keywords internal
var_missings_info <- function(x) {
  sprintf("%s [%s%%]", sum(is.na(x)), round(mean(is.na(x) * 100), 2))
}

#' Summarizes variable
#'
#' Creates html summary with statistics relevant to data type. For numeric values it returns central
#' tendency measures, for factor returns level counts, for Date  date range, for other just
#' number of levels.
#'
#' @param x vector of any type
#' @param numeric_as_factor `logical` should the numeric variable be treated as a factor
#' @param dt_rows `numeric` current/latest `DT` page length
#' @param outlier_definition If 0 no outliers are removed, otherwise
#'   outliers (those more than `outlier_definition*IQR below/above Q1/Q3` be removed)
#' @return text with simple statistics.
#' @keywords internal
var_summary_table <- function(x, numeric_as_factor, dt_rows, outlier_definition) {
  if (is.null(dt_rows)) {
    dt_rows <- 10
  }
  if (is.numeric(x) && !numeric_as_factor) {
    req(!any(is.infinite(x)))

    x <- remove_outliers_from(x, outlier_definition)

    qvals <- round(stats::quantile(x, na.rm = TRUE, probs = c(0.25, 0.5, 0.75), type = 2), 2)
    # classical central tendency measures

    summary <-
      data.frame(
        Statistic = c("min", "Q1", "median", "mean", "Q3", "max", "sd", "n"),
        Value = c(
          round(min(x, na.rm = TRUE), 2),
          qvals[1],
          qvals[2],
          round(mean(x, na.rm = TRUE), 2),
          qvals[3],
          round(max(x, na.rm = TRUE), 2),
          round(stats::sd(x, na.rm = TRUE), 2),
          length(x[!is.na(x)])
        )
      )

    DT::datatable(summary, rownames = FALSE, options = list(dom = "<t>", pageLength = dt_rows))
  } else if (is.factor(x) || is.character(x) || (is.numeric(x) && numeric_as_factor) || is.logical(x)) {
    # make sure factor is ordered numeric
    if (is.numeric(x)) {
      x <- factor(x, levels = sort(unique(x)))
    }

    level_counts <- table(x)
    max_levels_signif <- nchar(level_counts)

    if (!all(is.na(x))) {
      levels <- names(level_counts)
      counts <- sprintf(
        "%s [%.2f%%]",
        format(level_counts, width = max_levels_signif), prop.table(level_counts) * 100
      )
    } else {
      levels <- character(0)
      counts <- numeric(0)
    }

    summary <- data.frame(
      Level = levels,
      Count = counts,
      stringsAsFactors = FALSE
    )

    # sort the dataset in decreasing order of counts (needed as character variables default to alphabetical)
    summary <- summary[order(summary$Count, decreasing = TRUE), ]

    dom_opts <- if (nrow(summary) <= 10) {
      "<t>"
    } else {
      "<lf<t>ip>"
    }
    DT::datatable(summary, rownames = FALSE, options = list(dom = dom_opts, pageLength = dt_rows))
  } else if (inherits(x, "Date") || inherits(x, "POSIXct") || inherits(x, "POSIXlt")) {
    summary <-
      data.frame(
        Statistic = c("min", "median", "max"),
        Value = c(
          min(x, na.rm = TRUE),
          stats::median(x, na.rm = TRUE),
          max(x, na.rm = TRUE)
        )
      )
    DT::datatable(summary, rownames = FALSE, options = list(dom = "<t>", pageLength = dt_rows))
  } else {
    NULL
  }
}

#' Plot variable
#'
#' Creates summary plot with statistics relevant to data type.
#'
#' @inheritParams shared_params
#' @param qenv teal_data object where code should be evaluated.
#' @param wrap_character (`numeric`) number of characters at which to wrap text values of `var`
#' @param numeric_as_factor (`logical`) should the numeric variable be treated as a factor
#' @param display_density (`logical`) should density estimation be displayed for numeric values
#' @param remove_NA_hist (`logical`) should `NA` values be removed for histogram of factor like variables
#' @param outlier_definition if 0 no outliers are removed, otherwise
#'   outliers (those more than outlier_definition*IQR below/above Q1/Q3 be removed)
#' @param records_for_factor (`numeric`) if the number of factor levels is >= than this value then
#'   a graph of the factors isn't shown, only a list of values
#'
#' @return plot
#' @keywords internal
plot_var_summary <- function(qenv,
                             wrap_character = NULL,
                             numeric_as_factor,
                             display_density = FALSE,
                             remove_NA_hist = FALSE, # nolint: object_name.
                             outlier_definition,
                             records_for_factor,
                             ggplot2_args) {
  checkmate::assert_numeric(wrap_character, null.ok = TRUE)
  checkmate::assert_flag(numeric_as_factor)
  checkmate::assert_flag(display_density)
  checkmate::assert_logical(remove_NA_hist, null.ok = TRUE)
  checkmate::assert_number(outlier_definition, lower = 0, finite = TRUE)
  checkmate::assert_integerish(records_for_factor, lower = 0, len = 1, any.missing = FALSE)
  checkmate::assert_class(ggplot2_args, "ggplot2_args")

  var_name <- names(qenv$ANL)

  teal.reporter::teal_card(qenv) <- c(
    teal.reporter::teal_card(qenv),
    teal.reporter::teal_card("### Histogram plot")
  )

  var <- qenv$ANL[[var_name]]
  qenv_plot <- if (is.factor(var) || is.character(var) || is.logical(var)) {
    groups <- unique(as.character(var))
    len_groups <- length(groups)
    if (len_groups >= records_for_factor) {
      qenv_plot <- within(qenv,
        {
          groups <- unique(as.character(ANL[[var]]))
          len_groups <- length(groups)
          text <- sprintf(
            "%s unique values\n%s:\n %s\n ...\n %s",
            len_groups,
            teal.data::col_labels(ANL),
            paste(utils::head(groups), collapse = ",\n "),
            paste(utils::tail(groups), collapse = ",\n ")
          )
          plot <- gridExtra::arrangeGrob(
            grid::textGrob(
              text,
              x = grid::unit(1, "line"),
              y = grid::unit(1, "npc") - grid::unit(1, "line"),
              just = c("left", "top")
            ),
            ncol = 1
          )
        },
        var = var_name
      )
    } else {
      if (!is.null(wrap_character)) {
        qenv <- within(qenv,
          {
            col_label <- attr(ANL[[var]], "label")
            ANL[[var]] <- stringr::str_wrap(ANL[[var]], width = wrap_character)
            attr(ANL[[var]], "label") <- col_label
          },
          var = var_name,
          wrap_character = wrap_character
        )
      }

      if (isTRUE(remove_NA_hist)) {
        qenv <- within(qenv,
          {
            ANL <- filter(ANL, !is.na(var))
          },
          var = as.name(var_name)
        )
      }
      qenv_plot <- within(qenv,
        {
          plot <- ANL %>%
            ggplot2::ggplot(ggplot2::aes(x = forcats::fct_infreq(var_name))) +
            ggplot2::geom_bar(
              stat = "count", ggplot2::aes(fill = ifelse(is.na(var_name), "withcolor", "")), show.legend = FALSE
            ) +
            ggplot2::scale_fill_manual(values = c("gray50", "tan"))
        },
        var = var_name,
        var_name = as.name(var_name)
      )
    }
  } else if (is.numeric(var)) {
    # Validate input
    validate(need(any(!is.na(var)), "No data left to visualize."))
    var <- var[which(!is.na(var))] # Filter out NA
    validate(need(!any(is.infinite(var)), "Cannot display graph when data includes infinite values"))

    if (numeric_as_factor) {
      var <- factor(var)
      qenv_plot <- within(qenv,
        {
          col_label <- attr(ANL[[var]], "label")
          ANL[[var]] <- as.factor(ANL[[var]])
          attr(ANL[[var]], "label") <- col_label
          p <- ANL %>%
            ggplot2::ggplot(ggplot2::aes(x = var_name)) +
            ggplot2::geom_histogram(stat = "count")
        },
        var = var_name,
        var_name = as.name(var_name)
      )
    } else {
      # remove outliers
      if (outlier_definition != 0) {
        number_records <- length(var)
        var <- remove_outliers_from(var, outlier_definition)
        number_outliers <- number_records - length(var)
        outlier_text <- paste0(
          number_outliers, " outliers (",
          round(number_outliers / number_records * 100, 2),
          "% of non-missing records) not shown"
        )
        validate(need(
          length(var) > 1,
          "At least two data points must remain after removing outliers for this graph to be displayed"
        ))
        qenv <- within(qenv,
          {
            filter_outliers <- filter_outliers
            ANL <- filter(ANL, filter_outliers(var_name, outlier_definition))
          },
          filter_outliers = filter_outliers,
          var_name = as.name(var_name),
          outlier_definition = outlier_definition
        )
      }

      ## histogram
      binwidth <- get_bin_width(var)
      qenv_plot <- within(qenv,
        {
          plot <- ggplot2::ggplot(data = ANL, ggplot2::aes(x = var_name, y = ggplot2::after_stat(count))) +
            ggplot2::geom_histogram(binwidth = binwidth) +
            ggplot2::scale_y_continuous(
              sec.axis = ggplot2::sec_axis(
                trans = ~ . / nrow(ANL),
                labels = scales::percent,
                name = "proportion (in %)"
              )
            )
        },
        var_name = as.name(var_name),
        binwidth = binwidth
      )

      if (display_density) {
        qenv_plot <- within(qenv_plot,
          {
            plot <- plot + ggplot2::geom_density(ggplot2::aes(y = ggplot2::after_stat(count * binwidth)))
          },
          binwidth = binwidth
        )
      }
      if (outlier_definition != 0) {
        qenv_plot <- within(qenv_plot,
          {
            plot <- plot + ggplot2::annotate(
              geom = "text",
              label = outlier_text,
              x = Inf, y = Inf,
              hjust = 1.02, vjust = 1.2,
              color = "black",
              # explicitly modify geom text size according
              size = size
            )
          },
          outlier_text = outlier_text,
          size = ggplot2_args[["theme"]][["text"]][["size"]] / 3.5
        )
      }
      qenv_plot
    }
    qenv_plot
  } else if (inherits(var, "Date") || inherits(var, "POSIXct") || inherits(var, "POSIXlt")) {
    var_num <- as.numeric(var)
    binwidth <- get_bin_width(var_num, 1)
    qenv_plot <- within(qenv,
      {
        col_label <- attr(ANL[[var]], "label")
        ANL[[var]] <- as.numeric(ANL[[var]])
        attr(ANL[[var]], "label") <- col_label
        plot <- ANL %>%
          ggplot2::ggplot(ggplot2::aes(x = var_name, y = ggplot2::after_stat(count))) +
          ggplot2::geom_histogram(binwidth = binwidth)
      },
      binwidth = binwidth,
      var = var_name,
      var_name = as.name(var_name)
    )
  } else {
    qenv_plot <- within(qenv,
      {
        plot <- gridExtra::arrangeGrob(
          grid::textGrob(
            paste(strwrap(
              utils::capture.output(utils::str(ANL[[var]])),
              width = .9 * grid::convertWidth(grid::unit(1, "npc"), "char", TRUE)
            ), collapse = "\n"),
            x = grid::unit(1, "line"), y = grid::unit(1, "npc") - grid::unit(1, "line"), just = c("left", "top")
          ),
          ncol = 1
        )
      },
      var = var_name
    )
  }

  dev_ggplot2_args <- teal.widgets::ggplot2_args(
    labs = list(x = teal.data::col_labels(qenv$ANL))
  )

  all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(
    ggplot2_args,
    module_plot = dev_ggplot2_args
  )

  if (is.ggplot(qenv_plot$plot)) {
    qenv_plot <- within(qenv_plot,
      {
        plot <- plot +
          theme_light() +
          labs
      },
      labs = do.call("labs", all_ggplot2_args$labs)
    )
  }
  qenv_plot <- within(qenv_plot, {
    plot
  })
}

is_num_var_short <- function(.unique_records_for_factor, input, data_for_analysis) {
  length(unique(data_for_analysis()$data)) < .unique_records_for_factor && !is.null(input$numeric_as_factor)
}

#' Validates the variable browser inputs
#'
#' @param input (`session$input`) the `shiny` session input
#' @param plot_var (`list`) list of a data frame and an array of variable names
#' @param data (`teal_data`) the datasets passed to the module
#'
#' @returns `logical` TRUE if validations pass; a `shiny` validation error otherwise
#' @keywords internal
validate_input <- function(input, plot_var, data) {
  reactive({
    dataset_name <- req(input$tabset_panel)
    varname <- plot_var$variable[[dataset_name]]

    validate(need(dataset_name, "No data selected"))
    validate(need(varname, "No variable selected"))
    df <- data()[[dataset_name]]
    teal::validate_has_data(df, 1)
    teal::validate_has_variable(varname = varname, data = df, "Variable not available")

    TRUE
  })
}

get_plotted_data <- function(input, plot_var, data) {
  dataset_name <- req(input$tabset_panel)
  varname <- plot_var$variable[[dataset_name]]
  obj <- data()
  teal.reporter::teal_card(obj) <-
    c(
      teal.reporter::teal_card(obj),
      teal.reporter::teal_card("## Module's output(s)")
    )
  teal.code::eval_code(obj, "library(ggplot2)\nlibrary(dplyr)") |>
    within(
      {
        ANL <- dplyr::select(dataset_name, varname)
      },
      dataset_name = as.name(dataset_name),
      varname = as.name(varname)
    )
}

#' Renders the left-hand side `tabset` panel of the module
#'
#' @param datanames (`character`) the name of the dataset
#' @param parent_dataname (`character`) the name of a parent `dataname` to filter out variables from
#' @param data (`teal_data`) the object containing all datasets
#' @param input (`session$input`) the `shiny` session input
#' @param output (`session$output`) the `shiny` session output
#' @param columns_names (`environment`) the environment containing bindings for each dataset
#' @param plot_var (`list`) the list containing the currently selected dataset (tab) and its column names
#' @keywords internal
render_tabset_panel_content <- function(datanames, parent_dataname, output, data, input, columns_names, plot_var) {
  lapply(datanames, render_single_tab,
    input = input,
    output = output,
    data = data,
    parent_dataname = parent_dataname,
    columns_names = columns_names,
    plot_var = plot_var
  )
}

#' Renders a single tab in the left-hand side tabset panel
#'
#' Renders a single tab in the left-hand side tabset panel. The rendered tab contains
#' information about one dataset out of many presented in the module.
#'
#' @param dataset_name (`character`) the name of the dataset contained in the rendered tab
#' @param parent_dataname (`character`) the name of a parent `dataname` to filter out variables from
#' @inheritParams render_tabset_panel_content
#' @keywords internal
render_single_tab <- function(dataset_name, parent_dataname, output, data, input, columns_names, plot_var) {
  render_tab_header(dataset_name, output, data)

  render_tab_table(
    dataset_name = dataset_name,
    parent_dataname = parent_dataname,
    output = output,
    data = data,
    input = input,
    columns_names = columns_names,
    plot_var = plot_var
  )
}

#' Renders the text headlining a single tab in the left-hand side tabset panel
#'
#' @param dataset_name (`character`) the name of the dataset of the tab
#' @inheritParams render_tabset_panel_content
#' @keywords internal
render_tab_header <- function(dataset_name, output, data) {
  dataset_ui_id <- paste0("dataset_summary_", dataset_name)
  output[[dataset_ui_id]] <- renderText({
    df <- data()[[dataset_name]]
    join_keys <- teal.data::join_keys(data())
    if (!is.null(join_keys)) {
      key <- teal.data::join_keys(data())[dataset_name, dataset_name]
    } else {
      key <- NULL
    }
    sprintf(
      "Dataset with %s unique key rows and %s variables",
      nrow(unique(`if`(length(key) > 0, df[, key, drop = FALSE], df))),
      ncol(df)
    )
  })
}

#' Renders the table for a single dataset in the left-hand side tabset panel
#'
#' The table contains column names, column labels,
#' small summary about NA values and `sparkline` (if appropriate).
#'
#' @param dataset_name (`character`) the name of the dataset
#' @param parent_dataname (`character`) the name of a parent `dataname` to filter out variables from
#' @inheritParams render_tabset_panel_content
#' @keywords internal
render_tab_table <- function(dataset_name, parent_dataname, output, data, input, columns_names, plot_var) {
  table_ui_id <- paste0("variable_browser_", dataset_name)

  output[[table_ui_id]] <- DT::renderDataTable({
    df <- data()[[dataset_name]]

    get_vars_df <- function(input, dataset_name, parent_name, data) {
      data_cols <- colnames(df)
      if (isTRUE(input$show_parent_vars)) {
        data_cols
      } else if (dataset_name != parent_name && parent_name %in% names(data)) {
        setdiff(data_cols, colnames(data()[[parent_name]]))
      } else {
        data_cols
      }
    }

    if (length(parent_dataname) > 0) {
      df_vars <- get_vars_df(input, dataset_name, parent_dataname, data)
      df <- df[df_vars]
    }

    if (is.null(df) || ncol(df) == 0) {
      columns_names[[dataset_name]] <- character(0)
      df_output <- data.frame(
        Type = character(0),
        Variable = character(0),
        Label = character(0),
        Missings = character(0),
        Sparklines = character(0),
        stringsAsFactors = FALSE
      )
    } else {
      # extract data variable labels
      labels <- teal.data::col_labels(df)

      columns_names[[dataset_name]] <- names(labels)

      # calculate number of missing values
      missings <- vapply(
        df,
        var_missings_info,
        FUN.VALUE = character(1),
        USE.NAMES = FALSE
      )

      # get icons proper for the data types
      icons <- vapply(df, function(x) class(x)[1L], character(1L))

      join_keys <- teal.data::join_keys(data())
      if (!is.null(join_keys)) {
        icons[intersect(join_keys[dataset_name, dataset_name], colnames(df))] <- "primary_key"
      }
      icons <- variable_type_icons(icons)

      # generate sparklines
      sparklines_html <- vapply(
        df,
        create_sparklines,
        FUN.VALUE = character(1),
        USE.NAMES = FALSE
      )

      df_output <- data.frame(
        Type = icons,
        Variable = names(labels),
        Label = labels,
        Missings = missings,
        Sparklines = sparklines_html,
        stringsAsFactors = FALSE
      )
    }

    # Select row 1 as default / fallback
    selected_ix <- 1
    # Define starting page index (base-0 index of the first item on page
    #  note: in many cases it's not the item itself
    selected_page_ix <- 0

    # Retrieve current selected variable if any
    isolated_variable <- isolate(plot_var$variable[[dataset_name]])

    if (!is.null(isolated_variable)) {
      index <- which(columns_names[[dataset_name]] == isolated_variable)[1]
      if (!is.null(index) && !is.na(index) && length(index) > 0) selected_ix <- index
    }

    # Retrieve the index of the first item of the current page
    #  it works with varying number of entries on the page (10, 25, ...)
    table_id_sel <- paste0("variable_browser_", dataset_name, "_state")
    dt_state <- isolate(input[[table_id_sel]])
    if (selected_ix != 1 && !is.null(dt_state)) {
      selected_page_ix <- floor(selected_ix / dt_state$length) * dt_state$length
    }

    DT::datatable(
      df_output,
      escape = FALSE,
      rownames = FALSE,
      selection = list(mode = "single", target = "row", selected = selected_ix),
      options = list(
        fnDrawCallback = htmlwidgets::JS("function() { HTMLWidgets.staticRender(); }"),
        pageLength = input[[paste0(table_ui_id, "_rows")]],
        displayStart = selected_page_ix
      )
    )
  })
}

#' Creates observers updating the currently selected column
#'
#' The created observers update the column currently selected in the left-hand side
#' tabset panel.
#'
#' @note
#' Creates an observer for each dataset (each tab in the tabset panel).
#'
#' @inheritParams render_tabset_panel_content
#' @keywords internal
establish_updating_selection <- function(datanames, input, plot_var, columns_names) {
  lapply(datanames, function(dataset_name) {
    table_ui_id <- paste0("variable_browser_", dataset_name)
    table_id_sel <- paste0(table_ui_id, "_rows_selected")
    observeEvent(input[[table_id_sel]], {
      plot_var$data <- dataset_name
      plot_var$variable[[dataset_name]] <- columns_names[[dataset_name]][input[[table_id_sel]]]
    })
  })
}

get_bin_width <- function(x_vec, scaling_factor = 2) {
  x_vec <- x_vec[!is.na(x_vec)]
  qntls <- stats::quantile(x_vec, probs = c(0.1, 0.25, 0.75, 0.9), type = 2)
  iqr <- qntls[3] - qntls[2]
  binwidth <- max(scaling_factor * iqr / length(x_vec) ^ (1 / 3), sqrt(qntls[4] - qntls[1])) # styler: off
  binwidth <- ifelse(binwidth == 0, 1, binwidth)
  # to ensure at least two bins when variable span is very small
  x_span <- diff(range(x_vec))
  if (isTRUE(x_span / binwidth >= 2)) binwidth else x_span / 2
}

#' Removes the outlier observation from an array
#'
#' @param var (`numeric`) a numeric vector
#' @param outlier_definition (`numeric`) if `0` then no outliers are removed, otherwise
#'   outliers (those more than `outlier_definition*IQR below/above Q1/Q3`) are removed
#' @returns (`numeric`) vector without the outlier values
#' @keywords internal
remove_outliers_from <- function(var, outlier_definition) {
  var[filter_outliers(var, outlier_definition)]
}


#' Logical vector
#'
#' Returns a logical vector.
#' Suitable for `dplyr::filter()` and data.frames.
#'
#' @inheritParams remove_outliers_from
#'
#' @keywords internal
filter_outliers <- function(var, outlier_definition) {
  if (outlier_definition == 0) {
    return(rep(TRUE, length.out = length(var)))
  }
  q1_q3 <- stats::quantile(var, probs = c(0.25, 0.75), type = 2, na.rm = TRUE)
  iqr <- q1_q3[2] - q1_q3[1]
  var >= q1_q3[1] - outlier_definition * iqr & var <= q1_q3[2] + outlier_definition * iqr
}


# sparklines ----

#' S3 generic for `sparkline` widget HTML
#'
#' Generates the `sparkline` HTML code corresponding to the input array.
#' For numeric variables creates a box plot, for character and factors - bar plot.
#' Produces an empty string for variables of other types.
#'
#' @param arr vector of any type and length
#' @param width `numeric` the width of the `sparkline` widget (pixels)
#' @param bar_spacing `numeric` the spacing between the bars (in pixels)
#' @param bar_width `numeric` the width of the bars (in pixels)
#' @param ... `list` additional options passed to bar plots of `jquery.sparkline`;
#'                   see [`jquery.sparkline docs`](https://omnipotent.net/jquery.sparkline/#common)
#'
#' @return Character string containing HTML code of the `sparkline` HTML widget.
#' @keywords internal
create_sparklines <- function(arr, width = 150, ...) {
  if (all(is.null(arr))) {
    return("")
  }
  UseMethod("create_sparklines")
}

#' @rdname create_sparklines
#' @keywords internal
#' @export
create_sparklines.logical <- function(arr, ...) {
  create_sparklines(as.factor(arr))
}

#' @rdname create_sparklines
#' @keywords internal
#' @export
create_sparklines.numeric <- function(arr, width = 150, ...) {
  if (any(is.infinite(arr))) {
    return(as.character(tags$code("infinite values", class = "text-blue")))
  }
  if (length(arr) > 100000) {
    return(as.character(tags$code("Too many rows (>100000)", class = "text-blue")))
  }

  arr <- arr[!is.na(arr)]
  sparkline::spk_chr(unname(arr), type = "box", width = width, ...)
}

#' @rdname create_sparklines
#' @keywords internal
#' @export
create_sparklines.character <- function(arr, ...) {
  create_sparklines(as.factor(arr))
}


#' @rdname create_sparklines
#' @keywords internal
#' @export
create_sparklines.factor <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) {
  decreasing_order <- TRUE

  counts <- table(arr)
  if (length(counts) >= 100) {
    return(as.character(tags$code("> 99 levels", class = "text-blue")))
  } else if (length(counts) == 0) {
    return(as.character(tags$code("no levels", class = "text-blue")))
  } else if (length(counts) == 1) {
    return(as.character(tags$code("one level", class = "text-blue")))
  }

  # Summarize the occurences of different levels
  # and get the maximum and minimum number of occurences
  # This is needed for the sparkline to correctly display the bar plots
  # Otherwise they are cropped
  counts <- sort(counts, decreasing = decreasing_order, method = "radix")
  max_value <- if (decreasing_order) counts[1] else counts[length[counts]]
  max_value <- unname(max_value)

  sparkline::spk_chr(
    unname(counts),
    type = "bar",
    chartRangeMin = 0,
    chartRangeMax = max_value,
    width = width,
    barWidth = bar_width,
    barSpacing = bar_spacing,
    tooltipFormatter = custom_sparkline_formatter(names(counts), as.vector(counts))
  )
}

#' @rdname create_sparklines
#' @keywords internal
#' @export
create_sparklines.Date <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) {
  arr_num <- as.numeric(arr)
  arr_num <- sort(arr_num, decreasing = FALSE, method = "radix")
  binwidth <- get_bin_width(arr_num, 1)
  bins <- floor(diff(range(arr_num)) / binwidth) + 1
  if (all(is.na(bins))) {
    return(as.character(tags$code("only NA", class = "text-blue")))
  } else if (bins == 1) {
    return(as.character(tags$code("one date", class = "text-blue")))
  }
  counts <- as.vector(unname(base::table(cut(arr_num, breaks = bins))))
  max_value <- max(counts)

  start_bins <- as.integer(seq(1, length(arr_num), length.out = bins))
  labels_start <- as.character(as.Date(arr_num[start_bins], origin = as.Date("1970-01-01")))
  labels <- paste("Start:", labels_start)

  sparkline::spk_chr(
    unname(counts),
    type = "bar",
    chartRangeMin = 0,
    chartRangeMax = max_value,
    width = width,
    barWidth = bar_width,
    barSpacing = bar_spacing,
    tooltipFormatter = custom_sparkline_formatter(labels, counts)
  )
}

#' @rdname create_sparklines
#' @keywords internal
#' @export
create_sparklines.POSIXct <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) {
  arr_num <- as.numeric(arr)
  arr_num <- sort(arr_num, decreasing = FALSE, method = "radix")
  binwidth <- get_bin_width(arr_num, 1)
  bins <- floor(diff(range(arr_num)) / binwidth) + 1
  if (all(is.na(bins))) {
    return(as.character(tags$code("only NA", class = "text-blue")))
  } else if (bins == 1) {
    return(as.character(tags$code("one date-time", class = "text-blue")))
  }
  counts <- as.vector(unname(base::table(cut(arr_num, breaks = bins))))
  max_value <- max(counts)

  start_bins <- as.integer(seq(1, length(arr_num), length.out = bins))
  labels_start <- as.character(format(as.POSIXct(arr_num[start_bins], origin = as.Date("1970-01-01")), "%Y-%m-%d"))
  labels <- paste("Start:", labels_start)

  sparkline::spk_chr(
    unname(counts),
    type = "bar",
    chartRangeMin = 0,
    chartRangeMax = max_value,
    width = width,
    barWidth = bar_width,
    barSpacing = bar_spacing,
    tooltipFormatter = custom_sparkline_formatter(labels, counts)
  )
}

#' @rdname create_sparklines
#' @keywords internal
#' @export
create_sparklines.POSIXlt <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) {
  arr_num <- as.numeric(arr)
  arr_num <- sort(arr_num, decreasing = FALSE, method = "radix")
  binwidth <- get_bin_width(arr_num, 1)
  bins <- floor(diff(range(arr_num)) / binwidth) + 1
  if (all(is.na(bins))) {
    return(as.character(tags$code("only NA", class = "text-blue")))
  } else if (bins == 1) {
    return(as.character(tags$code("one date-time", class = "text-blue")))
  }
  counts <- as.vector(unname(base::table(cut(arr_num, breaks = bins))))
  max_value <- max(counts)

  start_bins <- as.integer(seq(1, length(arr_num), length.out = bins))
  labels_start <- as.character(format(as.POSIXct(arr_num[start_bins], origin = as.Date("1970-01-01")), "%Y-%m-%d"))
  labels <- paste("Start:", labels_start)

  sparkline::spk_chr(
    unname(counts),
    type = "bar",
    chartRangeMin = 0,
    chartRangeMax = max_value,
    width = width,
    barWidth = bar_width,
    barSpacing = bar_spacing,
    tooltipFormatter = custom_sparkline_formatter(labels, counts)
  )
}

#' @rdname create_sparklines
#' @keywords internal
#' @export
create_sparklines.default <- function(arr, width = 150, ...) {
  as.character(tags$code("unsupported variable type", class = "text-blue"))
}

custom_sparkline_formatter <- function(labels, counts) {
  htmlwidgets::JS(
    sprintf(
      "function(sparkline, options, field) {
        return 'ID: ' + %s[field[0].offset] + '<br>' + 'Count: ' + %s[field[0].offset];
        }",
      jsonlite::toJSON(labels),
      jsonlite::toJSON(counts)
    )
  )
}

#' `teal` module: Principal component analysis
#'
#' Module conducts principal component analysis (PCA) on a given dataset and offers different
#' ways of visualizing the outcomes, including elbow plot, circle plot, biplot, and eigenvector plot.
#' Additionally, it enables dynamic customization of plot aesthetics, such as opacity, size, and
#' font size, through UI inputs.
#'
#' @inheritParams teal::module
#' @inheritParams shared_params
#' @param dat (`data_extract_spec` or `list` of multiple `data_extract_spec`)
#' specifying columns used to compute PCA.
#' @param font_size (`numeric`) optional, specifies font size.
#' It controls the font size for plot titles, axis labels, and legends.
#' - If vector of `length == 1` then the font sizes will have a fixed size.
#' - while vector of `value`, `min`, and `max` allows dynamic adjustment.
#' @param ggplot2_args `r roxygen_ggplot2_args_param("Elbow plot", "Circle plot", "Biplot", "Eigenvector plot")`
#'
#' @inherit shared_params return
#'
#' @section Decorating Module:
#'
#' This module generates the following objects, which can be modified in place using decorators:
#' - `elbow_plot` (`ggplot`)
#' - `circle_plot` (`ggplot`)
#' - `biplot` (`ggplot`)
#' - `eigenvector_plot` (`ggplot`)
#'
#' A Decorator is applied to the specific output using a named list of `teal_transform_module` objects.
#' The name of this list corresponds to the name of the output to which the decorator is applied.
#' See code snippet below:
#'
#' ```
#' tm_a_pca(
#'    ..., # arguments for module
#'    decorators = list(
#'      elbow_plot = teal_transform_module(...), # applied to the `elbow_plot` output
#'      circle_plot = teal_transform_module(...), # applied to the `circle_plot` output
#'      biplot = teal_transform_module(...), # applied to the `biplot` output
#'      eigenvector_plot = teal_transform_module(...) # applied to the `eigenvector_plot` output
#'    )
#' )
#' ```
#'
#' For additional details and examples of decorators, refer to the vignette
#' `vignette("decorate-module-output", package = "teal.modules.general")`.
#'
#' To learn more please refer to the vignette
#' `vignette("transform-module-output", package = "teal")` or the [`teal::teal_transform_module()`] documentation.
#'
#' @inheritSection teal::example_module Reporting
#'
#' @examplesShinylive
#' library(teal.modules.general)
#' interactive <- function() TRUE
#' {{ next_example }}
#' @examples
#'
#' # general data example
#' data <- teal_data()
#' data <- within(data, {
#'   require(nestcolor)
#'   USArrests <- USArrests
#' })
#'
#' app <- init(
#'   data = data,
#'   modules = modules(
#'     tm_a_pca(
#'       "PCA",
#'       dat = data_extract_spec(
#'         dataname = "USArrests",
#'         select = select_spec(
#'           choices = variable_choices(
#'             data = data[["USArrests"]], c("Murder", "Assault", "UrbanPop", "Rape")
#'           ),
#'           selected = c("Murder", "Assault"),
#'           multiple = TRUE
#'         ),
#'         filter = NULL
#'       )
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
#' @examplesShinylive
#' library(teal.modules.general)
#' interactive <- function() TRUE
#' {{ next_example }}
#' @examples
#'
#' # CDISC data example
#' data <- teal_data()
#' data <- within(data, {
#'   require(nestcolor)
#'   ADSL <- teal.data::rADSL
#' })
#' join_keys(data) <- default_cdisc_join_keys[names(data)]
#'
#' app <- init(
#'   data = data,
#'   modules = modules(
#'     tm_a_pca(
#'       "PCA",
#'       dat = data_extract_spec(
#'         dataname = "ADSL",
#'         select = select_spec(
#'           choices = variable_choices(
#'             data = data[["ADSL"]], c("BMRKR1", "AGE", "EOSDY")
#'           ),
#'           selected = c("BMRKR1", "AGE"),
#'           multiple = TRUE
#'         ),
#'         filter = NULL
#'       )
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
#' @export
#'
tm_a_pca <- function(label = "Principal Component Analysis",
                     dat,
                     plot_height = c(600, 200, 2000),
                     plot_width = NULL,
                     ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
                     ggplot2_args = teal.widgets::ggplot2_args(),
                     rotate_xaxis_labels = FALSE,
                     font_size = c(12, 8, 20),
                     alpha = c(1, 0, 1),
                     size = c(2, 1, 8),
                     pre_output = NULL,
                     post_output = NULL,
                     transformators = list(),
                     decorators = list()) {
  message("Initializing tm_a_pca")

  # Normalize the parameters
  if (inherits(dat, "data_extract_spec")) dat <- list(dat)
  if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)

  # Start of assertions
  checkmate::assert_string(label)
  checkmate::assert_list(dat, types = "data_extract_spec")

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

  ggtheme <- match.arg(ggtheme)

  plot_choices <- c("Elbow plot", "Circle plot", "Biplot", "Eigenvector plot")
  checkmate::assert_list(ggplot2_args, types = "ggplot2_args")
  checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))

  checkmate::assert_flag(rotate_xaxis_labels)

  if (length(font_size) == 1) {
    checkmate::assert_numeric(font_size, any.missing = FALSE, finite = TRUE, lower = 8, upper = 20)
  } else {
    checkmate::assert_numeric(font_size, len = 3, any.missing = FALSE, finite = TRUE, lower = 8, upper = 20)
    checkmate::assert_numeric(font_size[1], lower = font_size[2], upper = font_size[3], .var.name = "font_size")
  }

  if (length(alpha) == 1) {
    checkmate::assert_numeric(alpha, any.missing = FALSE, finite = TRUE, lower = 0, upper = 1)
  } else {
    checkmate::assert_numeric(alpha, len = 3, any.missing = FALSE, finite = TRUE, lower = 0, upper = 1)
    checkmate::assert_numeric(alpha[1], lower = alpha[2], upper = alpha[3], .var.name = "alpha")
  }

  if (length(size) == 1) {
    checkmate::assert_numeric(size, any.missing = FALSE, finite = TRUE, lower = 1, upper = 8)
  } else {
    checkmate::assert_numeric(size, len = 3, any.missing = FALSE, finite = TRUE, lower = 1, upper = 8)
    checkmate::assert_numeric(size[1], lower = size[2], upper = size[3], .var.name = "size")
  }

  checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
  checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)

  available_decorators <- c("elbow_plot", "circle_plot", "biplot", "eigenvector_plot")
  assert_decorators(decorators, available_decorators)

  # Make UI args
  args <- as.list(environment())

  data_extract_list <- list(dat = dat)

  ans <- module(
    label = label,
    server = srv_a_pca,
    ui = ui_a_pca,
    ui_args = args,
    server_args = c(
      data_extract_list,
      list(
        plot_height = plot_height,
        plot_width = plot_width,
        ggplot2_args = ggplot2_args,
        decorators = decorators
      )
    ),
    transformators = transformators,
    datanames = teal.transform::get_extract_datanames(data_extract_list)
  )
  attr(ans, "teal_bookmarkable") <- FALSE
  ans
}

# UI function for the PCA module
ui_a_pca <- function(id, ...) {
  ns <- NS(id)
  args <- list(...)
  is_single_dataset_value <- teal.transform::is_single_dataset(args$dat)

  color_selector <- args$dat
  for (i in seq_along(color_selector)) {
    color_selector[[i]]$select$multiple <- FALSE
    color_selector[[i]]$select$always_selected <- NULL
    color_selector[[i]]$select$selected <- NULL
  }

  tagList(
    teal.widgets::standard_layout(
      output = teal.widgets::white_small_well(
        uiOutput(ns("all_plots"))
      ),
      encoding = tags$div(
        tags$label("Encodings", class = "text-primary"),
        teal.transform::datanames_input(args["dat"]),
        teal.transform::data_extract_ui(
          id = ns("dat"),
          label = "Data selection",
          data_extract_spec = args$dat,
          is_single_dataset = is_single_dataset_value
        ),
        bslib::accordion(
          open = c("Display", "Pre-processing", "Selected plot specific settings"),
          bslib::accordion_panel(
            title = "Display",
            checkboxGroupInput(
              ns("tables_display"),
              "Tables display",
              choices = c("PC importance" = "importance", "Eigenvectors" = "eigenvector"),
              selected = c("importance", "eigenvector")
            ),
            radioButtons(
              ns("plot_type"),
              label = "Plot type",
              choices = args$plot_choices,
              selected = args$plot_choices[1]
            ),
            conditionalPanel(
              condition = sprintf("input['%s'] == 'Elbow plot'", ns("plot_type")),
              ui_decorate_teal_data(
                ns("d_elbow_plot"),
                decorators = select_decorators(args$decorators, "elbow_plot")
              )
            ),
            conditionalPanel(
              condition = sprintf("input['%s'] == 'Circle plot'", ns("plot_type")),
              ui_decorate_teal_data(
                ns("d_circle_plot"),
                decorators = select_decorators(args$decorators, "circle_plot")
              )
            ),
            conditionalPanel(
              condition = sprintf("input['%s'] == 'Biplot'", ns("plot_type")),
              ui_decorate_teal_data(
                ns("d_biplot"),
                decorators = select_decorators(args$decorators, "biplot")
              )
            ),
            conditionalPanel(
              condition = sprintf("input['%s'] == 'Eigenvector plot'", ns("plot_type")),
              ui_decorate_teal_data(
                ns("d_eigenvector_plot"),
                decorators = select_decorators(args$decorators, "eigenvector_plot")
              )
            )
          ),
          bslib::accordion_panel(
            title = "Pre-processing",
            radioButtons(
              ns("standardization"), "Standardization",
              choices = c("None" = "none", "Center" = "center", "Center & Scale" = "center_scale"),
              selected = "center_scale"
            ),
            radioButtons(
              ns("na_action"), "NA action",
              choices = c("None" = "none", "Drop" = "drop"),
              selected = "none"
            )
          ),
          bslib::accordion_panel(
            title = "Selected plot specific settings",
            uiOutput(ns("plot_settings")),
            conditionalPanel(
              condition = sprintf("input['%s'] == 'Biplot'", ns("plot_type")),
              list(
                teal.transform::data_extract_ui(
                  id = ns("response"),
                  label = "Color by",
                  data_extract_spec = color_selector,
                  is_single_dataset = is_single_dataset_value
                ),
                teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", args$alpha, ticks = FALSE),
                teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", args$size, ticks = FALSE)
              )
            )
          ),
          bslib::accordion_panel(
            title = "Plot settings",
            conditionalPanel(
              condition = sprintf(
                "input['%s'] == 'Elbow plot' || input['%s'] == 'Eigenvector plot'",
                ns("plot_type"),
                ns("plot_type")
              ),
              list(checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels))
            ),
            selectInput(
              inputId = ns("ggtheme"),
              label = "Theme (by ggplot):",
              choices = ggplot_themes,
              selected = args$ggtheme,
              multiple = FALSE
            ),
            teal.widgets::optionalSliderInputValMinMax(ns("font_size"), "Font Size", args$font_size, ticks = FALSE)
          )
        )
      ),
      pre_output = args$pre_output,
      post_output = args$post_output
    )
  )
}

# Server function for the PCA module
srv_a_pca <- function(id, data, dat, plot_height, plot_width, ggplot2_args, decorators) {
  checkmate::assert_class(data, "reactive")
  checkmate::assert_class(isolate(data()), "teal_data")
  moduleServer(id, function(input, output, session) {
    teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")

    response <- dat

    for (i in seq_along(response)) {
      response[[i]]$select$multiple <- FALSE
      response[[i]]$select$always_selected <- NULL
      response[[i]]$select$selected <- NULL
      all_cols <- teal.data::col_labels(isolate(data())[[response[[i]]$dataname]])
      ignore_cols <- unlist(teal.data::join_keys(isolate(data()))[[response[[i]]$dataname]])
      color_cols <- all_cols[!names(all_cols) %in% ignore_cols]
      response[[i]]$select$choices <- teal.transform::choices_labeled(names(color_cols), color_cols)
    }

    selector_list <- teal.transform::data_extract_multiple_srv(
      data_extract = list(dat = dat, response = response),
      datasets = data,
      select_validation_rule = list(
        dat = ~ if (length(.) < 2L) "Please select more than 1 variable to perform PCA.",
        response = shinyvalidate::compose_rules(
          shinyvalidate::sv_optional(),
          ~ if (isTRUE(is.element(., selector_list()$dat()$select))) {
            "Response must not have been used for PCA."
          }
        )
      )
    )

    iv_r <- reactive({
      iv <- shinyvalidate::InputValidator$new()
      teal.transform::compose_and_enable_validators(iv, selector_list)
    })

    iv_extra <- shinyvalidate::InputValidator$new()
    iv_extra$add_rule("x_axis", function(value) {
      if (isTRUE(input$plot_type %in% c("Circle plot", "Biplot"))) {
        if (!shinyvalidate::input_provided(value)) {
          "Need X axis"
        }
      }
    })
    iv_extra$add_rule("y_axis", function(value) {
      if (isTRUE(input$plot_type %in% c("Circle plot", "Biplot"))) {
        if (!shinyvalidate::input_provided(value)) {
          "Need Y axis"
        }
      }
    })
    rule_dupl <- function(...) {
      if (isTRUE(input$plot_type %in% c("Circle plot", "Biplot"))) {
        if (isTRUE(input$x_axis == input$y_axis)) {
          "Please choose different X and Y axes."
        }
      }
    }
    iv_extra$add_rule("x_axis", rule_dupl)
    iv_extra$add_rule("y_axis", rule_dupl)
    iv_extra$add_rule("variables", function(value) {
      if (identical(input$plot_type, "Circle plot")) {
        if (!shinyvalidate::input_provided(value)) {
          "Need Original Coordinates"
        }
      }
    })
    iv_extra$add_rule("pc", function(value) {
      if (identical(input$plot_type, "Eigenvector plot")) {
        if (!shinyvalidate::input_provided(value)) {
          "Need PC"
        }
      }
    })
    iv_extra$enable()

    anl_merged_input <- teal.transform::merge_expression_srv(
      selector_list = selector_list,
      datasets = data
    )
    qenv <- reactive({
      obj <- data()
      teal.reporter::teal_card(obj) <-
        c(
          teal.reporter::teal_card(obj),
          teal.reporter::teal_card("## Module's output(s)")
        )
      teal.code::eval_code(obj, "library(ggplot2);library(dplyr);library(tidyr)")
    })
    anl_merged_q <- reactive({
      req(anl_merged_input())
      qenv() %>%
        teal.code::eval_code(as.expression(anl_merged_input()$expr))
    })

    merged <- list(
      anl_input_r = anl_merged_input,
      anl_q_r = anl_merged_q
    )

    validation <- reactive({
      req(merged$anl_q_r())
      # inputs
      keep_cols <- as.character(merged$anl_input_r()$columns_source$dat)
      na_action <- input$na_action
      standardization <- input$standardization
      center <- standardization %in% c("center", "center_scale")
      scale <- standardization == "center_scale"
      ANL <- merged$anl_q_r()[["ANL"]]

      teal::validate_has_data(ANL, 10)
      validate(need(
        na_action != "none" | !anyNA(ANL[keep_cols]),
        paste(
          "There are NAs in the dataset. Please deal with them in preprocessing",
          "or select \"Drop\" in the NA actions inside the encodings panel (left)."
        )
      ))
      if (scale) {
        not_single <- vapply(ANL[keep_cols], function(column) length(unique(column)) != 1, FUN.VALUE = logical(1))

        msg <- paste0(
          "You have selected `Center & Scale` under `Standardization` in the `Pre-processing` panel, ",
          "but one or more of your columns has/have a variance value of zero, indicating all values are identical"
        )
        validate(need(all(not_single), msg))
      }
    })

    # computation ----
    computation <- reactive({
      validation()

      # inputs
      keep_cols <- as.character(merged$anl_input_r()$columns_source$dat)
      na_action <- input$na_action
      standardization <- input$standardization
      center <- standardization %in% c("center", "center_scale")
      scale <- standardization == "center_scale"
      ANL <- merged$anl_q_r()[["ANL"]]

      qenv <- teal.code::eval_code(
        merged$anl_q_r(),
        substitute(
          expr = keep_columns <- keep_cols,
          env = list(keep_cols = keep_cols)
        )
      )

      if (na_action == "drop") {
        qenv <- teal.code::eval_code(
          qenv,
          quote(ANL <- tidyr::drop_na(ANL, keep_columns))
        )
      }

      qenv <- teal.code::eval_code(
        qenv,
        substitute(
          expr = pca <- summary(stats::prcomp(ANL[keep_columns], center = center, scale. = scale, retx = TRUE)),
          env = list(center = center, scale = scale)
        )
      )

      teal.reporter::teal_card(qenv) <- c(teal.reporter::teal_card(qenv), "### Principal Components Table")

      qenv <- teal.code::eval_code(
        qenv,
        quote({
          tbl_importance <- dplyr::as_tibble(pca$importance, rownames = "Metric")
          tbl_importance
        })
      )

      teal.reporter::teal_card(qenv) <- c(teal.reporter::teal_card(qenv), "### Eigenvectors Table")

      teal.code::eval_code(
        qenv,
        quote({
          tbl_eigenvector <- dplyr::as_tibble(pca$rotation, rownames = "Variable")
          tbl_eigenvector
        })
      )
    })

    # plot args ----
    output$plot_settings <- renderUI({
      # reactivity triggers
      req(iv_r()$is_valid())
      req(computation())
      qenv <- computation()

      ns <- session$ns

      pca <- qenv[["pca"]]
      chcs_pcs <- colnames(pca$rotation)
      chcs_vars <- qenv[["keep_columns"]]

      tagList(
        conditionalPanel(
          condition = sprintf(
            "input['%s'] == 'Biplot' || input['%s'] == 'Circle plot'",
            ns("plot_type"), ns("plot_type")
          ),
          list(
            teal.widgets::optionalSelectInput(ns("x_axis"), "X axis", choices = chcs_pcs, selected = chcs_pcs[1]),
            teal.widgets::optionalSelectInput(ns("y_axis"), "Y axis", choices = chcs_pcs, selected = chcs_pcs[2]),
            teal.widgets::optionalSelectInput(
              ns("variables"), "Original coordinates",
              choices = chcs_vars, selected = chcs_vars,
              multiple = TRUE
            )
          )
        ),
        conditionalPanel(
          condition = sprintf("input['%s'] == 'Elbow plot'", ns("plot_type")),
          helpText("No plot specific settings available.")
        ),
        conditionalPanel(
          condition = paste0("input['", ns("plot_type"), "'] == 'Eigenvector plot'"),
          teal.widgets::optionalSelectInput(ns("pc"), "PC", choices = chcs_pcs, selected = chcs_pcs[1])
        )
      )
    })

    # plot elbow ----
    plot_elbow <- function(base_q) {
      ggtheme <- input$ggtheme
      rotate_xaxis_labels <- input$rotate_xaxis_labels
      font_size <- input$font_size

      angle_value <- ifelse(isTRUE(rotate_xaxis_labels), 45, 0)
      hjust_value <- ifelse(isTRUE(rotate_xaxis_labels), 1, 0.5)

      dev_ggplot2_args <- teal.widgets::ggplot2_args(
        labs = list(x = "Principal component", y = "Proportion of variance explained", color = "", fill = "Legend"),
        theme = list(
          legend.position = "right",
          legend.spacing.y = quote(grid::unit(-5, "pt")),
          legend.title = quote(ggplot2::element_text(vjust = 25)),
          axis.text.x = substitute(
            ggplot2::element_text(angle = angle_value, hjust = hjust_value),
            list(angle_value = angle_value, hjust_value = hjust_value)
          ),
          text = substitute(ggplot2::element_text(size = font_size), list(font_size = font_size))
        )
      )

      parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(
        teal.widgets::resolve_ggplot2_args(
          user_plot = ggplot2_args[["Elbow plot"]],
          user_default = ggplot2_args$default,
          module_plot = dev_ggplot2_args
        ),
        ggtheme = ggtheme
      )
      teal.reporter::teal_card(base_q) <- c(teal.reporter::teal_card(base_q), "### Elbow plot")
      teal.code::eval_code(
        base_q,
        substitute(
          expr = {
            elb_dat <- pca$importance[c("Proportion of Variance", "Cumulative Proportion"), ] %>%
              dplyr::as_tibble(rownames = "metric") %>%
              tidyr::gather("component", "value", -metric) %>%
              dplyr::mutate(
                component = factor(component, levels = unique(stringr::str_sort(component, numeric = TRUE)))
              )

            cols <- c(getOption("ggplot2.discrete.colour"), c("lightblue", "darkred", "black"))[1:3]
            elbow_plot <- ggplot2::ggplot(mapping = ggplot2::aes_string(x = "component", y = "value")) +
              ggplot2::geom_bar(
                ggplot2::aes(fill = "Single variance"),
                data = dplyr::filter(elb_dat, metric == "Proportion of Variance"),
                color = "black",
                stat = "identity"
              ) +
              ggplot2::geom_point(
                ggplot2::aes(color = "Cumulative variance"),
                data = dplyr::filter(elb_dat, metric == "Cumulative Proportion")
              ) +
              ggplot2::geom_line(
                ggplot2::aes(group = 1, color = "Cumulative variance"),
                data = dplyr::filter(elb_dat, metric == "Cumulative Proportion")
              ) +
              labs +
              ggplot2::scale_color_manual(values = c("Cumulative variance" = cols[2], "Single variance" = cols[3])) +
              ggplot2::scale_fill_manual(values = c("Cumulative variance" = cols[2], "Single variance" = cols[1])) +
              ggthemes +
              themes
          },
          env = list(
            ggthemes = parsed_ggplot2_args$ggtheme,
            labs = parsed_ggplot2_args$labs,
            themes = parsed_ggplot2_args$theme
          )
        )
      )
    }

    # plot circle ----
    plot_circle <- function(base_q) {
      x_axis <- input$x_axis
      y_axis <- input$y_axis
      variables <- input$variables
      ggtheme <- input$ggtheme

      rotate_xaxis_labels <- input$rotate_xaxis_labels
      font_size <- input$font_size

      angle <- ifelse(isTRUE(rotate_xaxis_labels), 45, 0)
      hjust <- ifelse(isTRUE(rotate_xaxis_labels), 1, 0.5)

      dev_ggplot2_args <- teal.widgets::ggplot2_args(
        theme = list(
          text = substitute(ggplot2::element_text(size = font_size), list(font_size = font_size)),
          axis.text.x = substitute(
            ggplot2::element_text(angle = angle_val, hjust = hjust_val),
            list(angle_val = angle, hjust_val = hjust)
          )
        )
      )

      all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(
        user_plot = ggplot2_args[["Circle plot"]],
        user_default = ggplot2_args$default,
        module_plot = dev_ggplot2_args
      )

      parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(
        all_ggplot2_args,
        ggtheme = ggtheme
      )

      teal.reporter::teal_card(base_q) <- c(teal.reporter::teal_card(base_q), "### Circle plot")
      teal.code::eval_code(
        base_q,
        substitute(
          expr = {
            pca_rot <- pca$rotation[, c(x_axis, y_axis)] %>%
              dplyr::as_tibble(rownames = "label") %>%
              dplyr::filter(label %in% variables)

            circle_data <- data.frame(
              x = cos(seq(0, 2 * pi, length.out = 100)),
              y = sin(seq(0, 2 * pi, length.out = 100))
            )

            circle_plot <- ggplot2::ggplot(pca_rot) +
              ggplot2::geom_point(ggplot2::aes_string(x = x_axis, y = y_axis)) +
              ggplot2::geom_label(
                ggplot2::aes_string(x = x_axis, y = y_axis, label = "label"),
                nudge_x = 0.1, nudge_y = 0.05,
                fontface = "bold"
              ) +
              ggplot2::geom_path(ggplot2::aes(x, y, group = 1), data = circle_data) +
              ggplot2::geom_point(ggplot2::aes(x = x, y = y), data = data.frame(x = 0, y = 0), shape = "x", size = 5) +
              labs +
              ggthemes +
              themes
          },
          env = list(
            x_axis = x_axis,
            y_axis = y_axis,
            variables = variables,
            ggthemes = parsed_ggplot2_args$ggtheme,
            labs = `if`(is.null(parsed_ggplot2_args$labs), quote(labs()), parsed_ggplot2_args$labs),
            themes = parsed_ggplot2_args$theme
          )
        )
      )
    }

    # plot biplot ----
    plot_biplot <- function(base_q) {
      qenv <- base_q

      ANL <- qenv[["ANL"]]

      resp_col <- as.character(merged$anl_input_r()$columns_source$response)
      dat_cols <- as.character(merged$anl_input_r()$columns_source$dat)
      x_axis <- input$x_axis
      y_axis <- input$y_axis
      variables <- input$variables
      pca <- qenv[["pca"]]

      ggtheme <- input$ggtheme

      rotate_xaxis_labels <- input$rotate_xaxis_labels
      alpha <- input$alpha
      size <- input$size
      font_size <- input$font_size

      teal.reporter::teal_card(base_q) <- c(teal.reporter::teal_card(base_q), "### Biplot")
      qenv <- teal.code::eval_code(
        qenv,
        substitute(
          expr = pca_rot <- dplyr::as_tibble(pca$x[, c(x_axis, y_axis)]),
          env = list(x_axis = x_axis, y_axis = y_axis)
        )
      )

      # rot_vars = data frame that displays arrows in the plot, need to be scaled to data
      if (!is.null(input$variables)) {
        qenv <- teal.code::eval_code(
          qenv,
          substitute(
            expr = {
              r <- sqrt(qchisq(0.69, df = 2)) * prod(colMeans(pca_rot ^ 2)) ^ (1 / 4) # styler: off
              v_scale <- rowSums(pca$rotation ^ 2) # styler: off

              rot_vars <- pca$rotation[, c(x_axis, y_axis)] %>%
                dplyr::as_tibble(rownames = "label") %>%
                dplyr::mutate_at(vars(c(x_axis, y_axis)), function(x) r * x / sqrt(max(v_scale)))
            },
            env = list(x_axis = x_axis, y_axis = y_axis)
          )
        ) %>%
          teal.code::eval_code(
            if (is.logical(pca$center) && !pca$center) {
              substitute(
                expr = {
                  rot_vars <- rot_vars %>%
                    tibble::column_to_rownames("label") %>%
                    sweep(1, apply(ANL[keep_columns], 2, mean, na.rm = TRUE)) %>%
                    tibble::rownames_to_column("label") %>%
                    dplyr::mutate(
                      xstart = mean(pca$x[, x_axis], na.rm = TRUE),
                      ystart = mean(pca$x[, y_axis], na.rm = TRUE)
                    )
                },
                env = list(x_axis = x_axis, y_axis = y_axis)
              )
            } else {
              quote(rot_vars <- rot_vars %>% dplyr::mutate(xstart = 0, ystart = 0))
            }
          ) %>%
          teal.code::eval_code(
            substitute(
              expr = rot_vars <- rot_vars %>% dplyr::filter(label %in% variables),
              env = list(variables = variables)
            )
          )
      }

      pca_plot_biplot_expr <- list(quote(ggplot()))

      if (length(resp_col) == 0) {
        pca_plot_biplot_expr <- c(
          pca_plot_biplot_expr,
          substitute(
            ggplot2::geom_point(ggplot2::aes_string(x = x_axis, y = y_axis),
              data = pca_rot, alpha = alpha, size = size
            ),
            list(x_axis = input$x_axis, y_axis = input$y_axis, alpha = input$alpha, size = input$size)
          )
        )
        dev_labs <- list()
      } else {
        rp_keys <- setdiff(colnames(ANL), as.character(unlist(merged$anl_input_r()$columns_source)))

        response <- ANL[[resp_col]]

        aes_biplot <- substitute(
          ggplot2::aes_string(x = x_axis, y = y_axis, color = "response"),
          env = list(x_axis = x_axis, y_axis = y_axis)
        )

        qenv <- teal.code::eval_code(
          qenv,
          substitute(response <- ANL[[resp_col]], env = list(resp_col = resp_col))
        )

        dev_labs <- list(color = varname_w_label(resp_col, ANL))

        scales_biplot <-
          if (
            is.character(response) ||
              is.factor(response) ||
              (is.numeric(response) && length(unique(response)) <= 6)
          ) {
            qenv <- teal.code::eval_code(
              qenv,
              quote(pca_rot$response <- as.factor(response))
            )
            quote(ggplot2::scale_color_brewer(palette = "Dark2"))
          } else if (inherits(response, "Date")) {
            qenv <- teal.code::eval_code(
              qenv,
              quote(pca_rot$response <- numeric(response))
            )

            quote(
              ggplot2::scale_color_gradient(
                low = c(getOption("ggplot2.discrete.colour")[2], "darkred")[1],
                high = c(getOption("ggplot2.discrete.colour"), "lightblue")[1],
                labels = function(x) as.Date(x, origin = "1970-01-01")
              )
            )
          } else {
            qenv <- teal.code::eval_code(
              qenv,
              quote(pca_rot$response <- response)
            )
            quote(ggplot2::scale_color_gradient(
              low = c(getOption("ggplot2.discrete.colour")[2], "darkred")[1],
              high = c(getOption("ggplot2.discrete.colour"), "lightblue")[1]
            ))
          }

        pca_plot_biplot_expr <- c(
          pca_plot_biplot_expr,
          substitute(
            ggplot2::geom_point(aes_biplot, data = pca_rot, alpha = alpha, size = size),
            env = list(aes_biplot = aes_biplot, alpha = alpha, size = size)
          ),
          scales_biplot
        )
      }

      if (!is.null(input$variables)) {
        pca_plot_biplot_expr <- c(
          pca_plot_biplot_expr,
          substitute(
            ggplot2::geom_segment(
              ggplot2::aes_string(x = "xstart", y = "ystart", xend = x_axis, yend = y_axis),
              data = rot_vars,
              lineend = "round", linejoin = "round",
              arrow = grid::arrow(length = grid::unit(0.5, "cm"))
            ),
            env = list(x_axis = x_axis, y_axis = y_axis)
          ),
          substitute(
            ggplot2::geom_label(
              ggplot2::aes_string(
                x = x_axis,
                y = y_axis,
                label = "label"
              ),
              data = rot_vars,
              nudge_y = 0.1,
              fontface = "bold"
            ),
            env = list(x_axis = x_axis, y_axis = y_axis)
          ),
          quote(ggplot2::geom_point(ggplot2::aes(x = xstart, y = ystart), data = rot_vars, shape = "x", size = 5))
        )
      }

      angle <- ifelse(isTRUE(rotate_xaxis_labels), 45, 0)
      hjust <- ifelse(isTRUE(rotate_xaxis_labels), 1, 0.5)

      dev_ggplot2_args <- teal.widgets::ggplot2_args(
        labs = dev_labs,
        theme = list(
          text = substitute(ggplot2::element_text(size = font_size), list(font_size = font_size)),
          axis.text.x = substitute(
            ggplot2::element_text(angle = angle_val, hjust = hjust_val),
            list(angle_val = angle, hjust_val = hjust)
          )
        )
      )

      all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(
        user_plot = ggplot2_args[["Biplot"]],
        user_default = ggplot2_args$default,
        module_plot = dev_ggplot2_args
      )

      parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(
        all_ggplot2_args,
        ggtheme = ggtheme
      )

      pca_plot_biplot_expr <- c(
        pca_plot_biplot_expr,
        parsed_ggplot2_args
      )

      teal.code::eval_code(
        qenv,
        substitute(
          expr = {
            biplot <- plot_call
          },
          env = list(
            plot_call = Reduce(function(x, y) call("+", x, y), pca_plot_biplot_expr)
          )
        )
      )
    }

    # plot eigenvector_plot ----
    plot_eigenvector <- function(base_q) {
      req(input$pc)
      pc <- input$pc
      ggtheme <- input$ggtheme

      rotate_xaxis_labels <- input$rotate_xaxis_labels
      font_size <- input$font_size

      angle <- ifelse(rotate_xaxis_labels, 45, 0)
      hjust <- ifelse(rotate_xaxis_labels, 1, 0.5)

      dev_ggplot2_args <- teal.widgets::ggplot2_args(
        theme = list(
          text = substitute(ggplot2::element_text(size = font_size), list(font_size = font_size)),
          axis.text.x = substitute(
            ggplot2::element_text(angle = angle_val, hjust = hjust_val),
            list(angle_val = angle, hjust_val = hjust)
          )
        )
      )

      all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(
        user_plot = ggplot2_args[["Eigenvector plot"]],
        user_default = ggplot2_args$default,
        module_plot = dev_ggplot2_args
      )

      parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(
        all_ggplot2_args,
        ggtheme = ggtheme
      )

      ggplot_exprs <- c(
        list(
          quote(ggplot(pca_rot)),
          substitute(
            ggplot2::geom_bar(
              ggplot2::aes_string(x = "Variable", y = pc),
              stat = "identity",
              color = "black",
              fill = c(getOption("ggplot2.discrete.colour"), "lightblue")[1]
            ),
            env = list(pc = pc)
          ),
          substitute(
            ggplot2::geom_text(
              ggplot2::aes(
                x = Variable,
                y = pc_name,
                label = round(pc_name, 3),
                vjust = ifelse(pc_name > 0, -0.5, 1.3)
              )
            ),
            env = list(pc_name = as.name(pc))
          )
        ),
        parsed_ggplot2_args$labs,
        parsed_ggplot2_args$ggtheme,
        parsed_ggplot2_args$theme
      )

      teal.reporter::teal_card(base_q) <- c(teal.reporter::teal_card(base_q), "### Eigenvector plot")
      teal.code::eval_code(
        base_q,
        substitute(
          expr = {
            pca_rot <- pca$rotation[, pc, drop = FALSE] %>%
              dplyr::as_tibble(rownames = "Variable")
            eigenvector_plot <- plot_call
          },
          env = list(
            pc = pc,
            plot_call = Reduce(function(x, y) call("+", x, y), ggplot_exprs)
          )
        )
      )
    }

    # qenvs ---
    output_q <- lapply(
      list(
        elbow_plot = plot_elbow,
        circle_plot = plot_circle,
        biplot = plot_biplot,
        eigenvector_plot = plot_eigenvector
      ),
      function(fun) {
        reactive({
          req(computation())
          teal::validate_inputs(iv_r())
          teal::validate_inputs(iv_extra, header = "Plot settings are required")
          fun(computation())
        })
      }
    )

    decorated_q <- mapply(
      function(obj_name, q) {
        srv_decorate_teal_data(
          id = sprintf("d_%s", obj_name),
          data = q,
          decorators = select_decorators(decorators, obj_name),
          expr = reactive({
            substitute(.plot, env = list(.plot = as.name(obj_name)))
          })
        )
      },
      names(output_q),
      output_q
    )

    # plot final ----
    decorated_output_q <- reactive({
      switch(req(input$plot_type),
        "Elbow plot" = decorated_q$elbow_plot(),
        "Circle plot" = decorated_q$circle_plot(),
        "Biplot" = decorated_q$biplot(),
        "Eigenvector plot" = decorated_q$eigenvector_plot(),
        stop("Unknown plot")
      )
    })

    plot_r <- reactive({
      plot_name <- gsub(" ", "_", tolower(req(input$plot_type)))
      req(decorated_output_q())[[plot_name]]
    })

    pws <- teal.widgets::plot_with_settings_srv(
      id = "pca_plot",
      plot_r = plot_r,
      height = plot_height,
      width = plot_width,
      graph_align = "center"
    )

    # tables ----
    output$tbl_importance <- renderTable(
      expr = {
        req("importance" %in% input$tables_display, computation())
        computation()[["tbl_importance"]]
      },
      bordered = TRUE,
      align = "c",
      digits = 3
    )

    output$tbl_importance_ui <- renderUI({
      req("importance" %in% input$tables_display)
      tags$div(
        align = "center",
        tags$h4("Principal components importance"),
        tableOutput(session$ns("tbl_importance")),
        tags$hr()
      )
    })

    output$tbl_eigenvector <- renderTable(
      expr = {
        req("eigenvector" %in% input$tables_display, req(computation()))
        computation()[["tbl_eigenvector"]]
      },
      bordered = TRUE,
      align = "c",
      digits = 3
    )

    output$tbl_eigenvector_ui <- renderUI({
      req("eigenvector" %in% input$tables_display)
      tags$div(
        align = "center",
        tags$h4("Eigenvectors"),
        tableOutput(session$ns("tbl_eigenvector")),
        tags$hr()
      )
    })

    output$all_plots <- renderUI({
      teal::validate_inputs(iv_r())
      teal::validate_inputs(iv_extra, header = "Plot settings are required")

      validation()
      tags$div(
        uiOutput(session$ns("tbl_importance_ui")),
        uiOutput(session$ns("tbl_eigenvector_ui")),
        teal.widgets::plot_with_settings_ui(id = session$ns("pca_plot"))
      )
    })

    set_chunk_dims(pws, decorated_output_q)
  })
}

#' Shared parameters documentation
#'
#' Defines common arguments shared across multiple functions in the package
#' to avoid repetition by using `inheritParams`.
#'
#' @param plot_height (`numeric`) optional, specifies the plot height as a three-element vector of
#' `value`, `min`, and `max` intended for use with a slider UI element.
#' @param plot_width (`numeric`) optional, specifies the plot width as a three-element vector of
#' `value`, `min`, and `max` for a slider encoding the plot width.
#' @param rotate_xaxis_labels (`logical`) optional, whether to rotate plot X axis labels. Does not
#' rotate by default (`FALSE`).
#' @param ggtheme (`character`) optional, `ggplot2` theme to be used by default. Defaults to `"gray"`.
#' @param ggplot2_args (`ggplot2_args`) object created by [teal.widgets::ggplot2_args()]
#' with settings for the module plot.
#' The argument is merged with options variable `teal.ggplot2_args` and default module setup.
#'
#' For more details see the vignette: `vignette("custom-ggplot2-arguments", package = "teal.widgets")`
#' @param basic_table_args (`basic_table_args`) object created by [teal.widgets::basic_table_args()]
#' with settings for the module table.
#' The argument is merged with options variable `teal.basic_table_args` and default module setup.
#'
#' For more details see the vignette: `vignette("custom-basic-table-arguments", package = "teal.widgets")`
#' @param pre_output (`shiny.tag`) optional, text or UI element to be displayed before the module's output,
#' providing context or a title.
#'  with text placed before the output to put the output into context. For example a title.
#' @param post_output (`shiny.tag`) optional, text or UI element to be displayed after the module's output,
#' adding context or further instructions. Elements like `shiny::helpText()` are useful.
#' @param alpha (`integer(1)` or `integer(3)`) optional, specifies point opacity.
#' - When the length of `alpha` is one: the plot points will have a fixed opacity.
#' - When the length of `alpha` is three: the plot points opacity are dynamically adjusted based on
#' vector of `value`, `min`, and `max`.
#' @param size (`integer(1)` or `integer(3)`) optional, specifies point size.
#' - When the length of `size` is one: the plot point sizes will have a fixed size.
#' - When the length of `size` is three: the plot points size are dynamically adjusted based on
#' vector of `value`, `min`, and `max`.
#' @param decorators `r lifecycle::badge("experimental")`
#' (named `list` of lists of `teal_transform_module`) optional,
#' decorator for tables or plots included in the module output reported.
#' The decorators are applied to the respective output objects.
#'
#' See section "Decorating Module" below for more details.
#'
#' @return Object of class `teal_module` to be used in `teal` applications.
#'
#' @name shared_params
#' @keywords internal
NULL

#' Add labels for facets to a `ggplot2` object
#'
#' Enhances a `ggplot2` plot by adding labels that describe
#' the faceting variables along the x and y axes.
#'
#' @param p (`ggplot2`) object to which facet labels will be added.
#' @param xfacet_label (`character`) Label for the facet along the x-axis.
#' If `NULL`, no label is added. If a vector, labels are joined with " & ".
#' @param yfacet_label (`character`) Label for the facet along the y-axis.
#' Similar behavior to `xfacet_label`.
#'
#' @return Returns `grid` or `grob` object (to be drawn with `grid.draw`)
#'
#' @examples
#' library(ggplot2)
#' library(grid)
#'
#' p <- ggplot(mtcars) +
#'   aes(x = mpg, y = disp) +
#'   geom_point() +
#'   facet_grid(gear ~ cyl)
#'
#' xfacet_label <- "cylinders"
#' yfacet_label <- "gear"
#' res <- add_facet_labels(p, xfacet_label, yfacet_label)
#' grid.newpage()
#' grid.draw(res)
#'
#' grid.newpage()
#' grid.draw(add_facet_labels(p, xfacet_label = NULL, yfacet_label))
#' grid.newpage()
#' grid.draw(add_facet_labels(p, xfacet_label, yfacet_label = NULL))
#' grid.newpage()
#' grid.draw(add_facet_labels(p, xfacet_label = NULL, yfacet_label = NULL))
#'
#' @export
#'
add_facet_labels <- function(p, xfacet_label = NULL, yfacet_label = NULL) {
  checkmate::assert_class(p, classes = "ggplot")
  checkmate::assert_character(xfacet_label, null.ok = TRUE, min.len = 1)
  checkmate::assert_character(yfacet_label, null.ok = TRUE, min.len = 1)
  if (is.null(xfacet_label) && is.null(yfacet_label)) {
    return(ggplot2::ggplotGrob(p))
  }
  grid::grid.grabExpr({
    g <- ggplot2::ggplotGrob(p)

    # we are going to replace these, so we make sure they have nothing in them
    checkmate::assert_class(g$grobs[[grep("xlab-t", g$layout$name, fixed = TRUE)]], "zeroGrob")
    checkmate::assert_class(g$grobs[[grep("ylab-r", g$layout$name, fixed = TRUE)]], "zeroGrob")

    xaxis_label_grob <- g$grobs[[grep("xlab-b", g$layout$name, fixed = TRUE)]]
    xaxis_label_grob$children[[1]]$label <- paste(xfacet_label, collapse = " & ")
    yaxis_label_grob <- g$grobs[[grep("ylab-l", g$layout$name, fixed = TRUE)]]
    yaxis_label_grob$children[[1]]$label <- paste(yfacet_label, collapse = " & ")
    yaxis_label_grob$children[[1]]$rot <- 270

    top_height <- if (is.null(xfacet_label)) 0 else grid::unit(2, "line")
    right_width <- if (is.null(yfacet_label)) 0 else grid::unit(2, "line")

    grid::grid.newpage()
    grid::pushViewport(grid::plotViewport(margins = c(0, 0, top_height, right_width), name = "ggplot"))
    grid::grid.draw(g)
    grid::upViewport(1)

    # draw x facet
    if (!is.null(xfacet_label)) {
      grid::pushViewport(grid::viewport(
        x = 0, y = grid::unit(1, "npc") - top_height, width = grid::unit(1, "npc"),
        height = top_height, just = c("left", "bottom"), name = "topxaxis"
      ))
      grid::grid.draw(xaxis_label_grob)
      grid::upViewport(1)
    }

    # draw y facet
    if (!is.null(yfacet_label)) {
      grid::pushViewport(grid::viewport(
        x = grid::unit(1, "npc") - grid::unit(as.numeric(right_width) / 2, "line"), y = 0, width = right_width,
        height = grid::unit(1, "npc"), just = c("left", "bottom"), name = "rightyaxis"
      ))
      grid::grid.draw(yaxis_label_grob)
      grid::upViewport(1)
    }
  })
}

#' Call a function with a character vector for the `...` argument
#'
#' @param fun (`character`) Name of a function where the `...` argument shall be replaced by values from `str_args`.
#' @param str_args (`character`) A character vector that the function shall be executed with
#'
#' @return
#' Value of call to `fun` with arguments specified in `str_args`.
#'
#' @keywords internal
call_fun_dots <- function(fun, str_args) {
  do.call("call", c(list(fun), lapply(str_args, as.name)), quote = TRUE)
}

#' Generate a string for a variable including its label
#'
#' @param var_names (`character`) Name of variable to extract labels from.
#' @param dataset (`dataset`) Name of analysis dataset.
#' @param prefix,suffix (`character`) String to paste to the beginning/end of the variable name with label.
#' @param wrap_width (`numeric`) Number of characters to wrap original label to. Defaults to 80.
#'
#' @return (`character`) String with variable name and label.
#'
#' @keywords internal
#'
varname_w_label <- function(var_names,
                            dataset,
                            wrap_width = 80,
                            prefix = NULL,
                            suffix = NULL) {
  add_label <- function(var_names) {
    label <- vapply(
      dataset[var_names], function(x) {
        attr_label <- attr(x, "label")
        `if`(is.null(attr_label), "", attr_label)
      },
      character(1)
    )

    if (length(label) == 1 && !is.na(label) && !identical(label, "")) {
      paste0(prefix, label, " [", var_names, "]", suffix)
    } else {
      var_names
    }
  }

  if (length(var_names) < 1) {
    NULL
  } else if (length(var_names) == 1) {
    stringr::str_wrap(add_label(var_names), width = wrap_width)
  } else if (length(var_names) > 1) {
    stringr::str_wrap(vapply(var_names, add_label, character(1)), width = wrap_width)
  }
}

# see vignette("ggplot2-specs", package="ggplot2")
shape_names <- c(
  "circle", paste("circle", c("open", "filled", "cross", "plus", "small")), "bullet",
  "square", paste("square", c("open", "filled", "cross", "plus", "triangle")),
  "diamond", paste("diamond", c("open", "filled", "plus")),
  "triangle", paste("triangle", c("open", "filled", "square")),
  paste("triangle down", c("open", "filled")),
  "plus", "cross", "asterisk"
)

#' Get icons to represent variable types in dataset
#'
#' @param var_type (`character`) of R internal types (classes).
#' @return (`character`) vector of HTML icons corresponding to data type in each column.
#' @keywords internal
variable_type_icons <- function(var_type) {
  checkmate::assert_character(var_type, any.missing = FALSE)

  class_to_icon <- list(
    numeric = "arrow-up-1-9",
    integer = "arrow-up-1-9",
    logical = "pause",
    Date = "calendar",
    POSIXct = "calendar",
    POSIXlt = "calendar",
    factor = "chart-bar",
    character = "keyboard",
    primary_key = "key",
    unknown = "circle-question"
  )
  class_to_icon <- lapply(class_to_icon, function(icon_name) toString(icon(icon_name, lib = "font-awesome")))

  unname(vapply(
    var_type,
    FUN.VALUE = character(1),
    FUN = function(class) {
      if (class == "") {
        class
      } else if (is.null(class_to_icon[[class]])) {
        class_to_icon[["unknown"]]
      } else {
        class_to_icon[[class]]
      }
    }
  ))
}

#' JavaScript expression to check if a tab is active
#'
#' @param id (`character(1)`) the id of the tab panel with tabs.
#' @param name (`character(1)`) the name of the tab.
#' @return JavaScript expression to be used in `shiny::conditionalPanel()` to determine
#' if the specified tab is active.
#' @keywords internal
#'
is_tab_active_js <- function(id, name) {
  # supporting the bs3 and higher version at the same time
  sprintf(
    "$(\"#%1$s > li.active\").text().trim() == '%2$s' || $(\"#%1$s > li a.active\").text().trim() == '%2$s'",
    id, name
  )
}

#' Assert single selection on `data_extract_spec` object
#' Helper to reduce code in assertions
#' @noRd
#'
assert_single_selection <- function(x,
                                    .var.name = checkmate::vname(x)) { # nolint: object_name.
  if (any(vapply(x, function(.x) .x$select$multiple, logical(1)))) {
    stop("'", .var.name, "' should not allow multiple selection")
  }
  invisible(TRUE)
}

#' Wrappers around `srv_transform_teal_data` that allows to decorate the data
#' @inheritParams teal::srv_transform_teal_data
#' @inheritParams teal.reporter::`eval_code,teal_report-method`
#' @param expr (`reactive`) with expression to evaluate on the output of the
#' decoration. It must be compatible with `code` argument of [teal.code::eval_code()].
#' Default is `NULL` which won't evaluate any appending code.
#' @details
#' `srv_decorate_teal_data` is a wrapper around `srv_transform_teal_data` that
#' allows to decorate the data with additional expressions.
#' When original `teal_data` object is in error state, it will show that error
#' first.
#'
#' @keywords internal
srv_decorate_teal_data <- function(id, data, decorators, expr) {
  checkmate::assert_class(data, classes = "reactive")
  checkmate::assert_list(decorators, "teal_transform_module")

  no_expr <- missing(expr)

  moduleServer(id, function(input, output, session) {
    decorated_output <- srv_transform_teal_data("inner", data = data, transformators = decorators)

    expr_r <- if (is.reactive(expr)) expr else reactive(expr)

    reactive({
      req(decorated_output())
      if (no_expr) {
        decorated_output()
      } else {
        teal.code::eval_code(decorated_output(), expr_r())
      }
    })
  })
}

#' @rdname srv_decorate_teal_data
#' @details
#' `ui_decorate_teal_data` is a wrapper around `ui_transform_teal_data`.
#' @keywords internal
ui_decorate_teal_data <- function(id, decorators, ...) {
  teal::ui_transform_teal_data(NS(id, "inner"), transformators = decorators, ...)
}

#' Internal function to check if decorators is a valid object
#' @noRd
check_decorators <- function(x, names = NULL) { # nolint: object_name.

  check_message <- checkmate::check_list(x, names = "named")

  if (!is.null(names)) {
    if (isTRUE(check_message)) {
      if (length(names(x)) != length(unique(names(x)))) {
        check_message <- sprintf(
          "The `decorators` must contain unique names from these names: %s.",
          paste(names, collapse = ", ")
        )
      }
    } else {
      check_message <- sprintf(
        "The `decorators` must be a named list from these names: %s.",
        paste(names, collapse = ", ")
      )
    }
  }

  if (!isTRUE(check_message)) {
    return(check_message)
  }

  valid_elements <- vapply(
    x,
    checkmate::test_class,
    classes = "teal_transform_module",
    FUN.VALUE = logical(1L)
  )

  if (all(valid_elements)) {
    return(TRUE)
  }

  "Make sure that the named list contains 'teal_transform_module' objects created using `teal_transform_module()`."
}
#' Internal assertion on decorators
#' @noRd
assert_decorators <- checkmate::makeAssertionFunction(check_decorators)

#' Subset decorators based on the scope
#'
#' @param scope (`character`) a character vector of decorator names to include.
#' @param decorators (named `list`) of list decorators to subset.
#'
#' @return Subsetted list with all decorators to include.
#' It can be an empty list if none of the scope exists in `decorators` argument.
#' @keywords internal
select_decorators <- function(decorators, scope) {
  checkmate::assert_character(scope, null.ok = TRUE)
  if (scope %in% names(decorators)) {
    decorators[scope]
  } else {
    list()
  }
}

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

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

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

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

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

  teal_card
}

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

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

#' `teal` module: Scatterplot
#'
#' Generates a customizable scatterplot using `ggplot2`.
#' This module allows users to select variables for the x and y axes,
#' color and size encodings, faceting options, and more. It supports log transformations,
#' trend line additions, and dynamic adjustments of point opacity and size through UI controls.
#'
#' @note For more examples, please see the vignette "Using scatterplot" via
#'   `vignette("using-scatterplot", package = "teal.modules.general")`.
#'
#' @inheritParams teal::module
#' @inheritParams shared_params
#' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`) Specifies
#' variable names selected to plot along the x-axis by default.
#' @param y (`data_extract_spec` or `list` of multiple `data_extract_spec`) Specifies
#' variable names selected to plot along the y-axis by default.
#' @param color_by (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,
#' defines the color encoding. If `NULL` then no color encoding option will be displayed.
#' @param size_by (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,
#' defines the point size encoding. If `NULL` then no size encoding option will be displayed.
#' @param row_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,
#' specifies the variable(s) for faceting rows.
#' @param col_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,
#' specifies the variable(s) for faceting columns.
#' @param shape (`character`) optional, character vector with the names of the
#' shape, e.g. `c("triangle", "square", "circle")`. It defaults to `shape_names`. This is a complete list from
#' `vignette("ggplot2-specs", package="ggplot2")`.
#' @param max_deg (`integer`) optional, maximum degree for the polynomial trend line. Must not be less than 1.
#' @param table_dec (`integer`) optional, number of decimal places used to round numeric values in the table.
#'
#' @inherit shared_params return
#'
#' @section Decorating Module:
#'
#' This module generates the following objects, which can be modified in place using decorators:
#' - `plot` (`ggplot`)
#'
#' A Decorator is applied to the specific output using a named list of `teal_transform_module` objects.
#' The name of this list corresponds to the name of the output to which the decorator is applied.
#' See code snippet below:
#'
#' ```
#' tm_g_scatterplot(
#'    ..., # arguments for module
#'    decorators = list(
#'      plot = teal_transform_module(...) # applied to the `plot` output
#'    )
#' )
#' ```
#'
#' For additional details and examples of decorators, refer to the vignette
#' `vignette("decorate-module-output", package = "teal.modules.general")`.
#'
#' To learn more please refer to the vignette
#' `vignette("transform-module-output", package = "teal")` or the [`teal::teal_transform_module()`] documentation.
#'
#' @inheritSection teal::example_module Reporting
#'
#' @examplesShinylive
#' library(teal.modules.general)
#' interactive <- function() TRUE
#' {{ next_example }}
# nolint start: line_length_linter.
#' @examples
# nolint end: line_length_linter.
#' # general data example
#' data <- teal_data()
#' data <- within(data, {
#'   require(nestcolor)
#'   CO2 <- CO2
#' })
#'
#' app <- init(
#'   data = data,
#'   modules = modules(
#'     tm_g_scatterplot(
#'       label = "Scatterplot Choices",
#'       x = data_extract_spec(
#'         dataname = "CO2",
#'         select = select_spec(
#'           label = "Select variable:",
#'           choices = variable_choices(data[["CO2"]], c("conc", "uptake")),
#'           selected = "conc",
#'           multiple = FALSE,
#'           fixed = FALSE
#'         )
#'       ),
#'       y = data_extract_spec(
#'         dataname = "CO2",
#'         select = select_spec(
#'           label = "Select variable:",
#'           choices = variable_choices(data[["CO2"]], c("conc", "uptake")),
#'           selected = "uptake",
#'           multiple = FALSE,
#'           fixed = FALSE
#'         )
#'       ),
#'       color_by = data_extract_spec(
#'         dataname = "CO2",
#'         select = select_spec(
#'           label = "Select variable:",
#'           choices = variable_choices(
#'             data[["CO2"]],
#'             c("Plant", "Type", "Treatment", "conc", "uptake")
#'           ),
#'           selected = NULL,
#'           multiple = FALSE,
#'           fixed = FALSE
#'         )
#'       ),
#'       size_by = data_extract_spec(
#'         dataname = "CO2",
#'         select = select_spec(
#'           label = "Select variable:",
#'           choices = variable_choices(data[["CO2"]], c("conc", "uptake")),
#'           selected = "uptake",
#'           multiple = FALSE,
#'           fixed = FALSE
#'         )
#'       ),
#'       row_facet = data_extract_spec(
#'         dataname = "CO2",
#'         select = select_spec(
#'           label = "Select variable:",
#'           choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")),
#'           selected = NULL,
#'           multiple = FALSE,
#'           fixed = FALSE
#'         )
#'       ),
#'       col_facet = data_extract_spec(
#'         dataname = "CO2",
#'         select = select_spec(
#'           label = "Select variable:",
#'           choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")),
#'           selected = NULL,
#'           multiple = FALSE,
#'           fixed = FALSE
#'         )
#'       )
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
#' @examplesShinylive
#' library(teal.modules.general)
#' interactive <- function() TRUE
#' {{ next_example }}
# nolint start: line_length_linter.
#' @examples
# nolint end: line_length_linter.
#' # CDISC data example
#' data <- teal_data()
#' data <- within(data, {
#'   require(nestcolor)
#'   ADSL <- teal.data::rADSL
#' })
#' join_keys(data) <- default_cdisc_join_keys[names(data)]
#'
#' app <- init(
#'   data = data,
#'   modules = modules(
#'     tm_g_scatterplot(
#'       label = "Scatterplot Choices",
#'       x = data_extract_spec(
#'         dataname = "ADSL",
#'         select = select_spec(
#'           label = "Select variable:",
#'           choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1", "BMRKR2")),
#'           selected = "AGE",
#'           multiple = FALSE,
#'           fixed = FALSE
#'         )
#'       ),
#'       y = data_extract_spec(
#'         dataname = "ADSL",
#'         select = select_spec(
#'           label = "Select variable:",
#'           choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1", "BMRKR2")),
#'           selected = "BMRKR1",
#'           multiple = FALSE,
#'           fixed = FALSE
#'         )
#'       ),
#'       color_by = data_extract_spec(
#'         dataname = "ADSL",
#'         select = select_spec(
#'           label = "Select variable:",
#'           choices = variable_choices(
#'             data[["ADSL"]],
#'             c("AGE", "BMRKR1", "BMRKR2", "RACE", "REGION1")
#'           ),
#'           selected = NULL,
#'           multiple = FALSE,
#'           fixed = FALSE
#'         )
#'       ),
#'       size_by = data_extract_spec(
#'         dataname = "ADSL",
#'         select = select_spec(
#'           label = "Select variable:",
#'           choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1")),
#'           selected = "AGE",
#'           multiple = FALSE,
#'           fixed = FALSE
#'         )
#'       ),
#'       row_facet = data_extract_spec(
#'         dataname = "ADSL",
#'         select = select_spec(
#'           label = "Select variable:",
#'           choices = variable_choices(data[["ADSL"]], c("BMRKR2", "RACE", "REGION1")),
#'           selected = NULL,
#'           multiple = FALSE,
#'           fixed = FALSE
#'         )
#'       ),
#'       col_facet = data_extract_spec(
#'         dataname = "ADSL",
#'         select = select_spec(
#'           label = "Select variable:",
#'           choices = variable_choices(data[["ADSL"]], c("BMRKR2", "RACE", "REGION1")),
#'           selected = NULL,
#'           multiple = FALSE,
#'           fixed = FALSE
#'         )
#'       )
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
#' @export
#'
tm_g_scatterplot <- function(label = "Scatterplot",
                             x,
                             y,
                             color_by = NULL,
                             size_by = NULL,
                             row_facet = NULL,
                             col_facet = NULL,
                             plot_height = c(600, 200, 2000),
                             plot_width = NULL,
                             alpha = c(1, 0, 1),
                             shape = shape_names,
                             size = c(5, 1, 15),
                             max_deg = 5L,
                             rotate_xaxis_labels = FALSE,
                             ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
                             pre_output = NULL,
                             post_output = NULL,
                             table_dec = 4,
                             ggplot2_args = teal.widgets::ggplot2_args(),
                             transformators = list(),
                             decorators = list()) {
  message("Initializing tm_g_scatterplot")

  # Normalize the parameters
  if (inherits(x, "data_extract_spec")) x <- list(x)
  if (inherits(y, "data_extract_spec")) y <- list(y)
  if (inherits(color_by, "data_extract_spec")) color_by <- list(color_by)
  if (inherits(size_by, "data_extract_spec")) size_by <- list(size_by)
  if (inherits(row_facet, "data_extract_spec")) row_facet <- list(row_facet)
  if (inherits(col_facet, "data_extract_spec")) col_facet <- list(col_facet)
  if (is.double(max_deg)) max_deg <- as.integer(max_deg)

  # Start of assertions
  checkmate::assert_string(label)
  checkmate::assert_list(x, types = "data_extract_spec")
  checkmate::assert_list(y, types = "data_extract_spec")
  checkmate::assert_list(color_by, types = "data_extract_spec", null.ok = TRUE)
  checkmate::assert_list(size_by, types = "data_extract_spec", null.ok = TRUE)

  checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE)
  assert_single_selection(row_facet)

  checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE)
  assert_single_selection(col_facet)

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

  if (length(alpha) == 1) {
    checkmate::assert_numeric(alpha, any.missing = FALSE, finite = TRUE)
  } else {
    checkmate::assert_numeric(alpha, len = 3, any.missing = FALSE, finite = TRUE)
    checkmate::assert_numeric(alpha[1], lower = alpha[2], upper = alpha[3], .var.name = "alpha")
  }

  checkmate::assert_character(shape)

  if (length(size) == 1) {
    checkmate::assert_numeric(size, any.missing = FALSE, finite = TRUE)
  } else {
    checkmate::assert_numeric(size, len = 3, any.missing = FALSE, finite = TRUE)
    checkmate::assert_numeric(size[1], lower = size[2], upper = size[3], .var.name = "size")
  }

  checkmate::assert_int(max_deg, lower = 1L)
  checkmate::assert_flag(rotate_xaxis_labels)
  ggtheme <- match.arg(ggtheme)

  checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
  checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)

  checkmate::assert_scalar(table_dec)
  checkmate::assert_class(ggplot2_args, "ggplot2_args")

  assert_decorators(decorators, "plot")

  # End of assertions

  # Make UI args
  args <- as.list(environment())

  data_extract_list <- list(
    x = x,
    y = y,
    color_by = color_by,
    size_by = size_by,
    row_facet = row_facet,
    col_facet = col_facet
  )

  ans <- module(
    label = label,
    server = srv_g_scatterplot,
    ui = ui_g_scatterplot,
    ui_args = args,
    server_args = c(
      data_extract_list,
      list(
        plot_height = plot_height,
        plot_width = plot_width,
        table_dec = table_dec,
        ggplot2_args = ggplot2_args,
        decorators = decorators
      )
    ),
    transformators = transformators,
    datanames = teal.transform::get_extract_datanames(data_extract_list)
  )
  attr(ans, "teal_bookmarkable") <- TRUE
  ans
}

# UI function for the scatterplot module
ui_g_scatterplot <- function(id, ...) {
  args <- list(...)
  ns <- NS(id)
  is_single_dataset_value <- teal.transform::is_single_dataset(
    args$x, args$y, args$color_by, args$size_by, args$row_facet, args$col_facet
  )

  tagList(
    teal.widgets::standard_layout(
      output = teal.widgets::white_small_well(
        teal.widgets::plot_with_settings_ui(id = ns("scatter_plot")),
        tags$br(),
        tags$h1(tags$strong("Selected points:"), style = "font-size: 150%;"),
        teal.widgets::get_dt_rows(ns("data_table"), ns("data_table_rows")),
        DT::dataTableOutput(ns("data_table"), width = "100%")
      ),
      encoding = tags$div(
        tags$label("Encodings", class = "text-primary"),
        teal.transform::datanames_input(args[c("x", "y", "color_by", "size_by", "row_facet", "col_facet")]),
        teal.transform::data_extract_ui(
          id = ns("x"),
          label = "X variable",
          data_extract_spec = args$x,
          is_single_dataset = is_single_dataset_value
        ),
        checkboxInput(ns("log_x"), "Use log transformation", value = FALSE),
        conditionalPanel(
          condition = paste0("input['", ns("log_x"), "'] == true"),
          radioButtons(
            ns("log_x_base"),
            label = NULL,
            inline = TRUE,
            choices = c("Natural" = "log", "Base 10" = "log10", "Base 2" = "log2")
          )
        ),
        teal.transform::data_extract_ui(
          id = ns("y"),
          label = "Y variable",
          data_extract_spec = args$y,
          is_single_dataset = is_single_dataset_value
        ),
        checkboxInput(ns("log_y"), "Use log transformation", value = FALSE),
        conditionalPanel(
          condition = paste0("input['", ns("log_y"), "'] == true"),
          radioButtons(
            ns("log_y_base"),
            label = NULL,
            inline = TRUE,
            choices = c("Natural" = "log", "Base 10" = "log10", "Base 2" = "log2")
          )
        ),
        if (!is.null(args$color_by)) {
          teal.transform::data_extract_ui(
            id = ns("color_by"),
            label = "Color by variable",
            data_extract_spec = args$color_by,
            is_single_dataset = is_single_dataset_value
          )
        },
        if (!is.null(args$size_by)) {
          teal.transform::data_extract_ui(
            id = ns("size_by"),
            label = "Size by variable",
            data_extract_spec = args$size_by,
            is_single_dataset = is_single_dataset_value
          )
        },
        if (!is.null(args$row_facet)) {
          teal.transform::data_extract_ui(
            id = ns("row_facet"),
            label = "Row facetting",
            data_extract_spec = args$row_facet,
            is_single_dataset = is_single_dataset_value
          )
        },
        if (!is.null(args$col_facet)) {
          teal.transform::data_extract_ui(
            id = ns("col_facet"),
            label = "Column facetting",
            data_extract_spec = args$col_facet,
            is_single_dataset = is_single_dataset_value
          )
        },
        ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "plot")),
        bslib::accordion(
          open = TRUE,
          bslib::accordion_panel(
            title = "Plot settings",
            teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", args$alpha, ticks = FALSE),
            teal.widgets::optionalSelectInput(
              inputId = ns("shape"),
              label = "Points shape:",
              choices = args$shape,
              selected = args$shape[1],
              multiple = FALSE
            ),
            colourpicker::colourInput(ns("color"), "Points color:", "black"),
            teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", args$size, ticks = FALSE, step = .1),
            checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels),
            checkboxInput(ns("add_density"), "Add marginal density", value = FALSE),
            checkboxInput(ns("rug_plot"), "Include rug plot", value = FALSE),
            checkboxInput(ns("show_count"), "Show N (number of observations)", value = FALSE),
            shinyjs::hidden(helpText(id = ns("line_msg"), "Trendline needs numeric X and Y variables")),
            teal.widgets::optionalSelectInput(ns("smoothing_degree"), "Smoothing degree", seq_len(args$max_deg)),
            shinyjs::hidden(teal.widgets::optionalSelectInput(ns("color_sub"), label = "", multiple = TRUE)),
            teal.widgets::optionalSliderInputValMinMax(ns("ci"), "Confidence", c(.95, .8, .99), ticks = FALSE),
            shinyjs::hidden(checkboxInput(ns("show_form"), "Show formula", value = TRUE)),
            shinyjs::hidden(checkboxInput(ns("show_r2"), "Show adj-R Squared", value = TRUE)),
            uiOutput(ns("num_na_removed")),
            tags$div(
              id = ns("label_pos"),
              tags$div(tags$strong("Stats position")),
              tags$div(style = "display: inline-block; width: 70%;", helpText("Left")),
              tags$div(
                style = "display: inline-block; width: 70%;",
                teal.widgets::optionalSliderInput(
                  ns("pos"),
                  label = NULL,
                  min = 0, max = 1, value = .99, ticks = FALSE, step = .01
                )
              ),
              tags$div(style = "display: inline-block; width: 10%;", helpText("Right"))
            ),
            teal.widgets::optionalSliderInput(
              ns("label_size"), "Stats font size",
              min = 3, max = 10, value = 5, ticks = FALSE, step = .1
            ),
            if (!is.null(args$row_facet) || !is.null(args$col_facet)) {
              checkboxInput(ns("free_scales"), "Free scales", value = FALSE)
            },
            selectInput(
              inputId = ns("ggtheme"),
              label = "Theme (by ggplot):",
              choices = ggplot_themes,
              selected = args$ggtheme,
              multiple = FALSE
            )
          )
        )
      ),
      pre_output = args$pre_output,
      post_output = args$post_output
    )
  )
}

# Server function for the scatterplot module
srv_g_scatterplot <- function(id,
                              data,
                              x,
                              y,
                              color_by,
                              size_by,
                              row_facet,
                              col_facet,
                              plot_height,
                              plot_width,
                              table_dec,
                              ggplot2_args,
                              decorators) {
  checkmate::assert_class(data, "reactive")
  checkmate::assert_class(isolate(data()), "teal_data")
  moduleServer(id, function(input, output, session) {
    teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")

    data_extract <- list(
      x = x,
      y = y,
      color_by = color_by,
      size_by = size_by,
      row_facet = row_facet,
      col_facet = col_facet
    )

    rule_diff <- function(other) {
      function(value) {
        othervalue <- selector_list()[[other]]()[["select"]]
        if (!is.null(othervalue)) {
          if (identical(value, othervalue)) {
            "Row and column facetting variables must be different."
          }
        }
      }
    }

    selector_list <- teal.transform::data_extract_multiple_srv(
      data_extract = data_extract,
      datasets = data,
      select_validation_rule = list(
        x = ~ if (length(.) != 1) "Please select exactly one x var.",
        y = ~ if (length(.) != 1) "Please select exactly one y var.",
        color_by = ~ if (length(.) > 1) "There cannot be more than 1 color variable.",
        size_by = ~ if (length(.) > 1) "There cannot be more than 1 size variable.",
        row_facet = shinyvalidate::compose_rules(
          shinyvalidate::sv_optional(),
          rule_diff("col_facet")
        ),
        col_facet = shinyvalidate::compose_rules(
          shinyvalidate::sv_optional(),
          rule_diff("row_facet")
        )
      )
    )

    iv_r <- reactive({
      iv_facet <- shinyvalidate::InputValidator$new()
      iv <- shinyvalidate::InputValidator$new()
      teal.transform::compose_and_enable_validators(iv, selector_list)
    })
    iv_facet <- shinyvalidate::InputValidator$new()
    iv_facet$add_rule("add_density", ~ if (
      isTRUE(.) &&
        (
          length(selector_list()$row_facet()$select) > 0L ||
            length(selector_list()$col_facet()$select) > 0L
        )
    ) {
      "Cannot add marginal density when Row or Column facetting has been selected"
    })
    iv_facet$enable()

    anl_merged_input <- teal.transform::merge_expression_srv(
      selector_list = selector_list,
      datasets = data,
      merge_function = "dplyr::inner_join"
    )
    qenv <- reactive({
      obj <- data()
      teal.reporter::teal_card(obj) <- c(
        teal.reporter::teal_card(obj),
        teal.reporter::teal_card("## Module's output(s)")
      )
      teal.code::eval_code(data(), "library(ggplot2);library(dplyr)")
    })

    anl_merged_q <- reactive({
      req(anl_merged_input())
      qenv() %>%
        teal.code::eval_code(as.expression(anl_merged_input()$expr))
    })

    merged <- list(
      anl_input_r = anl_merged_input,
      anl_q_r = anl_merged_q
    )

    trend_line_is_applicable <- reactive({
      ANL <- merged$anl_q_r()[["ANL"]]
      x_var <- as.vector(merged$anl_input_r()$columns_source$x)
      y_var <- as.vector(merged$anl_input_r()$columns_source$y)
      length(x_var) > 0 && length(y_var) > 0 && is.numeric(ANL[[x_var]]) && is.numeric(ANL[[y_var]])
    })

    add_trend_line <- reactive({
      smoothing_degree <- as.integer(input$smoothing_degree)
      trend_line_is_applicable() && length(smoothing_degree) > 0
    })

    if (!is.null(color_by)) {
      observeEvent(
        eventExpr = merged$anl_input_r()$columns_source$color_by,
        handlerExpr = {
          color_by_var <- as.vector(merged$anl_input_r()$columns_source$color_by)
          if (length(color_by_var) > 0) {
            shinyjs::hide("color")
          } else {
            shinyjs::show("color")
          }
        }
      )
    }

    output$num_na_removed <- renderUI({
      if (add_trend_line()) {
        ANL <- merged$anl_q_r()[["ANL"]]
        x_var <- as.vector(merged$anl_input_r()$columns_source$x)
        y_var <- as.vector(merged$anl_input_r()$columns_source$y)
        if ((num_total_na <- nrow(ANL) - nrow(stats::na.omit(ANL[, c(x_var, y_var)]))) > 0) {
          tags$div(paste(num_total_na, "row(s) with missing values were removed"), tags$hr())
        }
      }
    })

    observeEvent(
      eventExpr = merged$anl_input_r()$columns_source[c("col_facet", "row_facet")],
      handlerExpr = {
        if (
          length(merged$anl_input_r()$columns_source$col_facet) == 0 &&
            length(merged$anl_input_r()$columns_source$row_facet) == 0
        ) {
          shinyjs::hide("free_scales")
        } else {
          shinyjs::show("free_scales")
        }
      }
    )

    output_q <- reactive({
      teal::validate_inputs(iv_r(), iv_facet)

      ANL <- merged$anl_q_r()[["ANL"]]

      x_var <- as.vector(merged$anl_input_r()$columns_source$x)
      y_var <- as.vector(merged$anl_input_r()$columns_source$y)
      color_by_var <- as.vector(merged$anl_input_r()$columns_source$color_by)
      size_by_var <- as.vector(merged$anl_input_r()$columns_source$size_by)
      row_facet_name <- if (length(merged$anl_input_r()$columns_source$row_facet) == 0) {
        character(0)
      } else {
        as.vector(merged$anl_input_r()$columns_source$row_facet)
      }
      col_facet_name <- if (length(merged$anl_input_r()$columns_source$col_facet) == 0) {
        character(0)
      } else {
        as.vector(merged$anl_input_r()$columns_source$col_facet)
      }
      alpha <- input$alpha
      size <- input$size
      rotate_xaxis_labels <- input$rotate_xaxis_labels
      add_density <- input$add_density
      ggtheme <- input$ggtheme
      rug_plot <- input$rug_plot
      color <- input$color
      shape <- `if`(is.null(input$shape) || identical(input$shape, ""), "circle", input$shape)
      smoothing_degree <- as.integer(input$smoothing_degree)
      ci <- input$ci

      log_x <- input$log_x
      log_y <- input$log_y

      validate(need(
        length(row_facet_name) == 0 || inherits(ANL[[row_facet_name]], c("character", "factor", "Date", "integer")),
        "`Row facetting` variable must be of class `character`, `factor`, `Date`, or `integer`"
      ))
      validate(need(
        length(col_facet_name) == 0 || inherits(ANL[[col_facet_name]], c("character", "factor", "Date", "integer")),
        "`Column facetting` variable must be of class `character`, `factor`, `Date`, or `integer`"
      ))

      if (add_density && length(color_by_var) > 0) {
        validate(need(
          !is.numeric(ANL[[color_by_var]]),
          "Marginal plots cannot be produced when the points are colored by numeric variables.
        \n Uncheck the 'Add marginal density' checkbox to display the plot."
        ))
        validate(need(
          !(
            inherits(ANL[[color_by_var]], "Date") ||
              inherits(ANL[[color_by_var]], "POSIXct") ||
              inherits(ANL[[color_by_var]], "POSIXlt")
          ),
          "Marginal plots cannot be produced when the points are colored by Date or POSIX variables.
        \n Uncheck the 'Add marginal density' checkbox to display the plot."
        ))
      }

      teal::validate_has_data(ANL[, c(x_var, y_var)], 1, complete = TRUE, allow_inf = FALSE)

      if (log_x) {
        validate(
          need(
            is.numeric(ANL[[x_var]]) && all(
              ANL[[x_var]] > 0 | is.na(ANL[[x_var]])
            ),
            "X variable can only be log transformed if variable is numeric and all values are positive."
          )
        )
      }
      if (log_y) {
        validate(
          need(
            is.numeric(ANL[[y_var]]) && all(
              ANL[[y_var]] > 0 | is.na(ANL[[y_var]])
            ),
            "Y variable can only be log transformed if variable is numeric and all values are positive."
          )
        )
      }

      facet_cl <- facet_ggplot_call(
        row_facet_name,
        col_facet_name,
        free_x_scales = isTRUE(input$free_scales),
        free_y_scales = isTRUE(input$free_scales)
      )

      point_sizes <- if (length(size_by_var) > 0) {
        validate(need(is.numeric(ANL[[size_by_var]]), "Variable to size by must be numeric"))
        substitute(
          expr = size * ANL[[size_by_var]] / max(ANL[[size_by_var]], na.rm = TRUE),
          env = list(size = size, size_by_var = size_by_var)
        )
      } else {
        size
      }

      plot_q <- merged$anl_q_r()

      if (log_x) {
        log_x_fn <- input$log_x_base
        plot_q <- teal.code::eval_code(
          object = plot_q,
          code = substitute(
            expr = ANL[, log_x_var] <- log_x_fn(ANL[, x_var]),
            env = list(
              x_var = x_var,
              log_x_fn = as.name(log_x_fn),
              log_x_var = paste0(log_x_fn, "_", x_var)
            )
          )
        )
      }

      if (log_y) {
        log_y_fn <- input$log_y_base
        plot_q <- teal.code::eval_code(
          object = plot_q,
          code = substitute(
            expr = ANL[, log_y_var] <- log_y_fn(ANL[, y_var]),
            env = list(
              y_var = y_var,
              log_y_fn = as.name(log_y_fn),
              log_y_var = paste0(log_y_fn, "_", y_var)
            )
          )
        )
      }

      pre_pro_anl <- if (input$show_count) {
        paste0(
          "ANL %>% dplyr::group_by(",
          paste(
            c(
              if (length(color_by_var) > 0 && inherits(ANL[[color_by_var]], c("factor", "character"))) color_by_var,
              row_facet_name,
              col_facet_name
            ),
            collapse = ", "
          ),
          ") %>% dplyr::mutate(n = dplyr::n()) %>% dplyr::ungroup()"
        )
      } else {
        "ANL"
      }

      plot_call <- substitute(expr = pre_pro_anl %>% ggplot2::ggplot(), env = list(pre_pro_anl = str2lang(pre_pro_anl)))

      plot_call <- if (length(color_by_var) == 0) {
        substitute(
          expr = plot_call +
            ggplot2::aes(x = x_name, y = y_name) +
            ggplot2::geom_point(alpha = alpha_value, size = point_sizes, shape = shape_value, color = color_value),
          env = list(
            plot_call = plot_call,
            x_name = if (log_x) as.name(paste0(log_x_fn, "_", x_var)) else as.name(x_var),
            y_name = if (log_y) as.name(paste0(log_y_fn, "_", y_var)) else as.name(y_var),
            alpha_value = alpha,
            point_sizes = point_sizes,
            shape_value = shape,
            color_value = color
          )
        )
      } else {
        substitute(
          expr = plot_call +
            ggplot2::aes(x = x_name, y = y_name, color = color_by_var_name) +
            ggplot2::geom_point(alpha = alpha_value, size = point_sizes, shape = shape_value),
          env = list(
            plot_call = plot_call,
            x_name = if (log_x) as.name(paste0(log_x_fn, "_", x_var)) else as.name(x_var),
            y_name = if (log_y) as.name(paste0(log_y_fn, "_", y_var)) else as.name(y_var),
            color_by_var_name = as.name(color_by_var),
            alpha_value = alpha,
            point_sizes = point_sizes,
            shape_value = shape
          )
        )
      }

      if (rug_plot) plot_call <- substitute(expr = plot_call + geom_rug(), env = list(plot_call = plot_call))

      plot_label_generator <- function(rhs_formula = quote(y ~ 1),
                                       show_form = input$show_form,
                                       show_r2 = input$show_r2,
                                       show_count = input$show_count,
                                       pos = input$pos,
                                       label_size = input$label_size) {
        stopifnot(sum(show_form, show_r2, show_count) >= 1)
        aes_label <- paste0(
          "aes(",
          if (show_count) "n = n, ",
          "label = ",
          if (sum(show_form, show_r2, show_count) > 1) "paste(",
          paste(
            c(
              if (show_form) "stat(eq.label)",
              if (show_r2) "stat(adj.rr.label)",
              if (show_count) "paste('N ~`=`~', n)"
            ),
            collapse = ", "
          ),
          if (sum(show_form, show_r2, show_count) > 1) ", sep = '*\", \"*'))" else ")"
        )
        label_geom <- substitute(
          expr = ggpmisc::stat_poly_eq(
            mapping = aes_label,
            formula = rhs_formula,
            parse = TRUE,
            label.x = pos,
            size = label_size
          ),
          env = list(
            rhs_formula = rhs_formula,
            pos = pos,
            aes_label = str2lang(aes_label),
            label_size = label_size
          )
        )
        substitute(
          expr = plot_call + label_geom,
          env = list(
            plot_call = plot_call,
            label_geom = label_geom
          )
        )
      }

      if (trend_line_is_applicable()) {
        shinyjs::hide("line_msg")
        shinyjs::show("smoothing_degree")
        if (!add_trend_line()) {
          shinyjs::hide("ci")
          shinyjs::hide("color_sub")
          shinyjs::hide("show_form")
          shinyjs::hide("show_r2")
          if (input$show_count) {
            plot_call <- plot_label_generator(show_form = FALSE, show_r2 = FALSE)
            shinyjs::show("label_pos")
            shinyjs::show("label_size")
          } else {
            shinyjs::hide("label_pos")
            shinyjs::hide("label_size")
          }
        } else {
          shinyjs::show("ci")
          shinyjs::show("show_form")
          shinyjs::show("show_r2")
          if (nrow(ANL) - nrow(stats::na.omit(ANL[, c(x_var, y_var)])) > 0) {
            plot_q <- teal.code::eval_code(
              plot_q,
              substitute(
                expr = ANL <- dplyr::filter(ANL, !is.na(x_var) & !is.na(y_var)),
                env = list(x_var = as.name(x_var), y_var = as.name(y_var))
              )
            )
          }
          rhs_formula <- substitute(
            expr = y ~ poly(x, smoothing_degree, raw = TRUE),
            env = list(smoothing_degree = smoothing_degree)
          )
          if (input$show_form || input$show_r2 || input$show_count) {
            plot_call <- plot_label_generator(rhs_formula = rhs_formula)
            shinyjs::show("label_pos")
            shinyjs::show("label_size")
          } else {
            shinyjs::hide("label_pos")
            shinyjs::hide("label_size")
          }
          plot_call <- substitute(
            expr = plot_call + ggplot2::geom_smooth(formula = rhs_formula, se = TRUE, level = ci, method = "lm"),
            env = list(plot_call = plot_call, rhs_formula = rhs_formula, ci = ci)
          )
        }
      } else {
        shinyjs::hide("smoothing_degree")
        shinyjs::hide("ci")
        shinyjs::hide("color_sub")
        shinyjs::hide("show_form")
        shinyjs::hide("show_r2")
        if (input$show_count) {
          plot_call <- plot_label_generator(show_form = FALSE, show_r2 = FALSE)
          shinyjs::show("label_pos")
          shinyjs::show("label_size")
        } else {
          shinyjs::hide("label_pos")
          shinyjs::hide("label_size")
        }
        shinyjs::show("line_msg")
      }

      if (!is.null(facet_cl)) {
        plot_call <- substitute(expr = plot_call + facet_cl, env = list(plot_call = plot_call, facet_cl = facet_cl))
      }

      y_label <- varname_w_label(
        y_var,
        ANL,
        prefix = if (log_y) paste(log_y_fn, "(") else NULL,
        suffix = if (log_y) ")" else NULL
      )
      x_label <- varname_w_label(
        x_var,
        ANL,
        prefix = if (log_x) paste(log_x_fn, "(") else NULL,
        suffix = if (log_x) ")" else NULL
      )

      dev_ggplot2_args <- teal.widgets::ggplot2_args(
        labs = list(y = y_label, x = x_label),
        theme = list(legend.position = "bottom")
      )

      if (rotate_xaxis_labels) {
        dev_ggplot2_args$theme[["axis.text.x"]] <- quote(ggplot2::element_text(angle = 45, hjust = 1))
      }

      all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(
        user_plot = ggplot2_args,
        module_plot = dev_ggplot2_args
      )

      parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(all_ggplot2_args, ggtheme = ggtheme)


      if (add_density) {
        plot_call <- substitute(
          expr = ggExtra::ggMarginal(
            plot_call + labs + ggthemes + themes,
            type = "density",
            groupColour = group_colour
          ),
          env = list(
            plot_call = plot_call,
            group_colour = if (length(color_by_var) > 0) TRUE else FALSE,
            labs = parsed_ggplot2_args$labs,
            ggthemes = parsed_ggplot2_args$ggtheme,
            themes = parsed_ggplot2_args$theme
          )
        )
      } else {
        plot_call <- substitute(
          expr = plot_call +
            labs +
            ggthemes +
            themes,
          env = list(
            plot_call = plot_call,
            labs = parsed_ggplot2_args$labs,
            ggthemes = parsed_ggplot2_args$ggtheme,
            themes = parsed_ggplot2_args$theme
          )
        )
      }

      plot_call <- substitute(expr = plot <- plot_call, env = list(plot_call = plot_call))

      teal.reporter::teal_card(plot_q) <- c(teal.reporter::teal_card(plot_q), "### Plot")
      teal.code::eval_code(plot_q, plot_call)
    })

    decorated_output_plot_q <- srv_decorate_teal_data(
      id = "decorator",
      data = output_q,
      decorators = select_decorators(decorators, "plot"),
      expr = quote(plot)
    )

    plot_r <- reactive(req(decorated_output_plot_q())[["plot"]])

    # Insert the plot into a plot_with_settings module from teal.widgets
    pws <- teal.widgets::plot_with_settings_srv(
      id = "scatter_plot",
      plot_r = plot_r,
      height = plot_height,
      width = plot_width,
      brushing = TRUE
    )

    output$data_table <- DT::renderDataTable({
      plot_brush <- pws$brush()

      if (!is.null(plot_brush)) {
        validate(need(!input$add_density, "Brushing feature is currently not supported when plot has marginal density"))
      }

      merged_data <- isolate(output_q()[["ANL"]])

      brushed_df <- teal.widgets::clean_brushedPoints(merged_data, plot_brush)
      numeric_cols <- names(brushed_df)[
        vapply(brushed_df, function(x) is.numeric(x) && !is.integer(x), FUN.VALUE = logical(1))
      ]

      if (length(numeric_cols) > 0) {
        DT::formatRound(
          DT::datatable(brushed_df,
            rownames = FALSE,
            options = list(scrollX = TRUE, pageLength = input$data_table_rows)
          ),
          numeric_cols,
          table_dec
        )
      } else {
        DT::datatable(brushed_df, rownames = FALSE, options = list(scrollX = TRUE, pageLength = input$data_table_rows))
      }
    })

    set_chunk_dims(pws, decorated_output_plot_q)
  })
}

#' `teal` module: File viewer
#'
#' The file viewer module provides a tool to view static files.
#' Supported formats include text formats, `PDF`, `PNG` `APNG`,
#' `JPEG` `SVG`, `WEBP`, `GIF` and `BMP`.
#'
#' @inheritParams teal::module
#' @inheritParams shared_params
#' @param input_path (`list`) of the input paths, optional. Each element can be:
#'
#' Paths can be specified as absolute paths or relative to the running directory of the application.
#' Default to the current working directory if not supplied.
#'
#' @inherit shared_params return
#'
#' @examplesShinylive
#' library(teal.modules.general)
#' interactive <- function() TRUE
#' {{ next_example }}
#' @examples
#' data <- teal_data()
#' data <- within(data, {
#'   data <- data.frame(1)
#' })
#'
#' app <- init(
#'   data = data,
#'   modules = modules(
#'     tm_file_viewer(
#'       input_path = list(
#'         folder = system.file("sample_files", package = "teal.modules.general"),
#'         png = system.file("sample_files/sample_file.png", package = "teal.modules.general"),
#'         txt = system.file("sample_files/sample_file.txt", package = "teal.modules.general"),
#'         url = file.path(
#'           "https://www.fda.gov/files/drugs/published",
#'           "Portable-Document-Format-Specifications.pdf"
#'         )
#'       )
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
#' @export
#'
tm_file_viewer <- function(label = "File Viewer Module",
                           input_path = list("Current Working Directory" = ".")) {
  message("Initializing tm_file_viewer")

  # Normalize the parameters
  if (length(label) == 0 || identical(label, "")) label <- " "
  if (length(input_path) == 0 || identical(input_path, "")) input_path <- list()

  # Start of assertions
  checkmate::assert_string(label)

  checkmate::assert(
    checkmate::check_list(input_path, types = "character", min.len = 0),
    checkmate::check_character(input_path, min.len = 1)
  )
  if (length(input_path) > 0) {
    valid_url <- function(url_input, timeout = 2) {
      con <- try(url(url_input), silent = TRUE)
      check <- suppressWarnings(try(open.connection(con, open = "rt", timeout = timeout), silent = TRUE)[1])
      try(close.connection(con), silent = TRUE)
      is.null(check)
    }
    idx <- vapply(input_path, function(x) file.exists(x) || valid_url(x), logical(1))

    if (!all(idx)) {
      warning(
        paste0(
          "Non-existent file or url path. Please provide valid paths for:\n",
          paste0(input_path[!idx], collapse = "\n")
        )
      )
    }
    input_path <- input_path[idx]
  } else {
    warning(
      "No file or url paths were provided."
    )
  }
  # End of assertions

  # Make UI args
  args <- as.list(environment())

  ans <- module(
    label = label,
    server = srv_viewer,
    server_args = list(input_path = input_path),
    ui = ui_viewer,
    ui_args = args,
    datanames = NULL
  )
  attr(ans, "teal_bookmarkable") <- FALSE
  ans
}

# UI function for the file viewer module
ui_viewer <- function(id, ...) {
  args <- list(...)
  ns <- NS(id)

  tagList(
    teal.widgets::standard_layout(
      output = tags$div(
        uiOutput(ns("output"))
      ),
      encoding = tags$div(
        style = "overflow-y: hidden; overflow-x: auto;",
        tags$label("Encodings", class = "text-primary"),
        shinyTree::shinyTree(
          ns("tree"),
          dragAndDrop = FALSE,
          sort = FALSE,
          theme = "proton",
          multiple = FALSE,
          search = TRUE
        )
      )
    )
  )
}

# Server function for the file viewer module
srv_viewer <- function(id, input_path) {
  moduleServer(id, function(input, output, session) {
    teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")

    temp_dir <- tempfile()
    if (!dir.exists(temp_dir)) {
      dir.create(temp_dir, recursive = TRUE)
    }
    addResourcePath(basename(temp_dir), temp_dir)

    test_path_text <- function(selected_path, type) {
      out <- tryCatch(
        expr = {
          if (type != "url") {
            selected_path <- normalizePath(selected_path, winslash = "/")
          }
          readLines(con = selected_path)
        },
        error = function(cond) FALSE,
        warning = function(cond) {
          `if`(grepl("^incomplete final line found on", cond[[1]]), suppressWarnings(eval(cond[[2]])), FALSE)
        }
      )
    }

    handle_connection_type <- function(selected_path) {
      file_extension <- tools::file_ext(selected_path)
      file_class <- suppressWarnings(file(selected_path))
      close(file_class)

      output_text <- test_path_text(selected_path, type = class(file_class)[1])

      if (class(file_class)[1] == "url") {
        list(selected_path = selected_path, output_text = output_text)
      } else {
        file.copy(normalizePath(selected_path, winslash = "/"), temp_dir)
        selected_path <- file.path(basename(temp_dir), basename(selected_path))
        list(selected_path = selected_path, output_text = output_text)
      }
    }

    display_file <- function(selected_path) {
      con_type <- handle_connection_type(selected_path)
      file_extension <- tools::file_ext(selected_path)
      if (file_extension %in% c("png", "apng", "jpg", "jpeg", "svg", "gif", "webp", "bmp")) {
        tags$img(src = con_type$selected_path, alt = "file does not exist")
      } else if (file_extension == "pdf") {
        tags$embed(
          style = "height: 600px; width: 100%;",
          src = con_type$selected_path
        )
      } else if (!isFALSE(con_type$output_text[1])) {
        tags$pre(paste0(con_type$output_text, collapse = "\n"))
      } else {
        tags$p("Please select a supported format.")
      }
    }

    tree_list <- function(file_or_dir) {
      nested_list <- lapply(file_or_dir, function(path) {
        file_class <- suppressWarnings(file(path))
        close(file_class)
        if (class(file_class)[[1]] != "url") {
          isdir <- file.info(path)$isdir
          if (!isdir) {
            structure(path, ancestry = path, sticon = "file")
          } else {
            files <- list.files(path, full.names = TRUE, include.dirs = TRUE)
            out <- lapply(files, function(x) tree_list(x))
            out <- unlist(out, recursive = FALSE)
            if (length(files) > 0) names(out) <- basename(files)
            out
          }
        } else {
          structure(path, ancestry = path, sticon = "file")
        }
      })

      missing_labels <- if (is.null(names(nested_list))) seq_along(nested_list) else which(names(nested_list) == "")
      names(nested_list)[missing_labels] <- file_or_dir[missing_labels]
      nested_list
    }

    output$tree <- shinyTree::renderTree({
      if (length(input_path) > 0) {
        tree_list(input_path)
      } else {
        list("Empty Path" = NULL)
      }
    })

    output$output <- renderUI({
      validate(
        need(
          length(shinyTree::get_selected(input$tree)) > 0,
          "Please select a file."
        )
      )

      obj <- shinyTree::get_selected(input$tree, format = "names")[[1]]
      repo <- attr(obj, "ancestry")
      repo_collapsed <- if (length(repo) > 1) paste0(repo, collapse = "/") else repo
      is_not_named <- file.exists(file.path(c(repo_collapsed, obj[1])))[1]

      if (is_not_named) {
        selected_path <- do.call("file.path", as.list(c(repo, obj[1])))
      } else {
        if (length(repo) == 0) {
          selected_path <- do.call("file.path", as.list(attr(input$tree[[obj[1]]], "ancestry")))
        } else {
          selected_path <- do.call("file.path", as.list(attr(input$tree[[repo]][[obj[1]]], "ancestry")))
        }
      }

      validate(
        need(
          !isTRUE(file.info(selected_path)$isdir) && length(selected_path) > 0,
          "Please select a single file."
        )
      )
      display_file(selected_path)
    })

    onStop(function() {
      removeResourcePath(basename(temp_dir))
      unlink(temp_dir)
    })
  })
}

#' `teal` module: Outliers analysis
#'
#' Module to analyze and identify outliers using different methods
#' such as IQR, Z-score, and Percentiles, and offers visualizations including
#' box plots, density plots, and cumulative distribution plots to help interpret the outliers.
#'
#' @inheritParams teal::module
#' @inheritParams shared_params
#'
#' @param outlier_var (`data_extract_spec` or `list` of multiple `data_extract_spec`)
#' Specifies variable(s) to be analyzed for outliers.
#' @param categorical_var (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,
#' specifies the categorical variable(s) to split the selected outlier variables on.
#' @param ggplot2_args `r roxygen_ggplot2_args_param("Boxplot", "Density Plot", "Cumulative Distribution Plot")`
#'
#' @inherit shared_params return
#'
#' @section Decorating Module:
#'
#' This module generates the following objects, which can be modified in place using decorators:
#' - `box_plot` (`ggplot`)
#' - `density_plot` (`ggplot`)
#' - `cumulative_plot` (`ggplot`)
#'
#' A Decorator is applied to the specific output using a named list of `teal_transform_module` objects.
#' The name of this list corresponds to the name of the output to which the decorator is applied.
#' See code snippet below:
#'
#' ```
#' tm_outliers(
#'    ..., # arguments for module
#'    decorators = list(
#'      box_plot = teal_transform_module(...), # applied only to `box_plot` output
#'      density_plot = teal_transform_module(...), # applied only to `density_plot` output
#'      cumulative_plot = teal_transform_module(...) # applied only to `cumulative_plot` output
#'    )
#' )
#' ```
#'
#' For additional details and examples of decorators, refer to the vignette
#' `vignette("decorate-module-output", package = "teal.modules.general")`.
#'
#' To learn more please refer to the vignette
#' `vignette("transform-module-output", package = "teal")` or the [`teal::teal_transform_module()`] documentation.
#'
#' @inheritSection teal::example_module Reporting
#'
#' @examplesShinylive
#' library(teal.modules.general)
#' interactive <- function() TRUE
#' {{ next_example }}
#' @examples
#'
#' # general data example
#' data <- teal_data()
#' data <- within(data, {
#'   CO2 <- CO2
#'   CO2[["primary_key"]] <- seq_len(nrow(CO2))
#' })
#' join_keys(data) <- join_keys(join_key("CO2", "CO2", "primary_key"))
#'
#' vars <- choices_selected(variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")))
#'
#' app <- init(
#'   data = data,
#'   modules = modules(
#'     tm_outliers(
#'       outlier_var = list(
#'         data_extract_spec(
#'           dataname = "CO2",
#'           select = select_spec(
#'             label = "Select variable:",
#'             choices = variable_choices(data[["CO2"]], c("conc", "uptake")),
#'             selected = "uptake",
#'             multiple = FALSE,
#'             fixed = FALSE
#'           )
#'         )
#'       ),
#'       categorical_var = list(
#'         data_extract_spec(
#'           dataname = "CO2",
#'           filter = filter_spec(
#'             vars = vars,
#'             choices = value_choices(data[["CO2"]], vars$selected),
#'             selected = value_choices(data[["CO2"]], vars$selected),
#'             multiple = TRUE
#'           )
#'         )
#'       )
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
#' @examplesShinylive
#' library(teal.modules.general)
#' interactive <- function() TRUE
#' {{ next_example }}
#' @examples
#'
#' # CDISC data example
#' data <- teal_data()
#' data <- within(data, {
#'   ADSL <- teal.data::rADSL
#' })
#' join_keys(data) <- default_cdisc_join_keys[names(data)]
#'
#' fact_vars_adsl <- names(Filter(isTRUE, sapply(data[["ADSL"]], is.factor)))
#' vars <- choices_selected(variable_choices(data[["ADSL"]], fact_vars_adsl))
#'
#'
#' app <- init(
#'   data = data,
#'   modules = modules(
#'     tm_outliers(
#'       outlier_var = list(
#'         data_extract_spec(
#'           dataname = "ADSL",
#'           select = select_spec(
#'             label = "Select variable:",
#'             choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1")),
#'             selected = "AGE",
#'             multiple = FALSE,
#'             fixed = FALSE
#'           )
#'         )
#'       ),
#'       categorical_var = list(
#'         data_extract_spec(
#'           dataname = "ADSL",
#'           filter = filter_spec(
#'             vars = vars,
#'             choices = value_choices(data[["ADSL"]], vars$selected),
#'             selected = value_choices(data[["ADSL"]], vars$selected),
#'             multiple = TRUE
#'           )
#'         )
#'       )
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
#' @export
#'
tm_outliers <- function(label = "Outliers Module",
                        outlier_var,
                        categorical_var = NULL,
                        ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
                        ggplot2_args = teal.widgets::ggplot2_args(),
                        plot_height = c(600, 200, 2000),
                        plot_width = NULL,
                        pre_output = NULL,
                        post_output = NULL,
                        transformators = list(),
                        decorators = list()) {
  message("Initializing tm_outliers")

  # Normalize the parameters
  if (inherits(outlier_var, "data_extract_spec")) outlier_var <- list(outlier_var)
  if (inherits(categorical_var, "data_extract_spec")) categorical_var <- list(categorical_var)
  if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)

  # Start of assertions
  checkmate::assert_string(label)
  checkmate::assert_list(outlier_var, types = "data_extract_spec")

  checkmate::assert_list(categorical_var, types = "data_extract_spec", null.ok = TRUE)
  if (is.list(categorical_var)) {
    lapply(categorical_var, function(x) {
      if (length(x$filter) > 1L) {
        stop("tm_outliers: categorical_var data_extract_specs may only specify one filter_spec", call. = FALSE)
      }
    })
  }

  ggtheme <- match.arg(ggtheme)

  plot_choices <- c("Boxplot", "Density Plot", "Cumulative Distribution Plot")
  checkmate::assert_list(ggplot2_args, types = "ggplot2_args")
  checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))

  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_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
  checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)

  assert_decorators(decorators, names = c("box_plot", "density_plot", "cumulative_plot"))
  # End of assertions

  # Make UI args
  args <- as.list(environment())

  data_extract_list <- list(
    outlier_var = outlier_var,
    categorical_var = categorical_var
  )


  ans <- module(
    label = label,
    server = srv_outliers,
    server_args = c(
      data_extract_list,
      list(
        plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args,
        decorators = decorators
      )
    ),
    ui = ui_outliers,
    ui_args = args,
    transformators = transformators,
    datanames = teal.transform::get_extract_datanames(data_extract_list)
  )
  attr(ans, "teal_bookmarkable") <- TRUE
  ans
}

# UI function for the outliers module
ui_outliers <- function(id, ...) {
  args <- list(...)
  ns <- NS(id)
  is_single_dataset_value <- teal.transform::is_single_dataset(args$outlier_var, args$categorical_var)

  teal.widgets::standard_layout(
    output = teal.widgets::white_small_well(
      uiOutput(ns("total_outliers")),
      tags$div(
        style = "overflow: auto;",
        DT::dataTableOutput(ns("summary_table"))
      ),
      uiOutput(ns("total_missing")),
      tags$br(), tags$hr(),
      tabsetPanel(
        id = ns("tabs"),
        tabPanel(
          "Boxplot",
          teal.widgets::plot_with_settings_ui(id = ns("box_plot"))
        ),
        tabPanel(
          "Density Plot",
          teal.widgets::plot_with_settings_ui(id = ns("density_plot"))
        ),
        tabPanel(
          "Cumulative Distribution Plot",
          teal.widgets::plot_with_settings_ui(id = ns("cum_density_plot"))
        )
      ),
      tags$br(), tags$hr(),
      uiOutput(ns("table_ui_wrap")),
      DT::dataTableOutput(ns("table_ui"))
    ),
    encoding = tags$div(
      tags$label("Encodings", class = "text-primary"),
      teal.transform::datanames_input(args[c("outlier_var", "categorical_var")]),
      teal.transform::data_extract_ui(
        id = ns("outlier_var"),
        label = "Variable",
        data_extract_spec = args$outlier_var,
        is_single_dataset = is_single_dataset_value
      ),
      if (!is.null(args$categorical_var)) {
        teal.transform::data_extract_ui(
          id = ns("categorical_var"),
          label = "Categorical factor",
          data_extract_spec = args$categorical_var,
          is_single_dataset = is_single_dataset_value
        )
      },
      conditionalPanel(
        condition = paste0("input['", ns("tabs"), "'] == 'Boxplot'"),
        teal.widgets::optionalSelectInput(
          inputId = ns("boxplot_alts"),
          label = "Plot type",
          choices = c("Box plot", "Violin plot"),
          selected = "Box plot",
          multiple = FALSE
        )
      ),
      shinyjs::hidden(checkboxInput(ns("split_outliers"), "Define outliers based on group splitting", value = FALSE)),
      shinyjs::hidden(checkboxInput(ns("order_by_outlier"), "Re-order categories by outliers [by %]", value = FALSE)),
      bslib::accordion(
        open = TRUE,
        bslib::accordion_panel(
          title = "Method parameters",
          teal.widgets::optionalSelectInput(
            inputId = ns("method"),
            label = "Method",
            choices = c("IQR", "Z-score", "Percentile"),
            selected = "IQR",
            multiple = FALSE
          ),
          conditionalPanel(
            condition =
              paste0("input['", ns("method"), "'] == 'IQR'"),
            sliderInput(
              ns("iqr_slider"),
              "Outlier range:",
              min = 1,
              max = 5,
              value = 3,
              step = 0.5
            )
          ),
          conditionalPanel(
            condition =
              paste0("input['", ns("method"), "'] == 'Z-score'"),
            sliderInput(
              ns("zscore_slider"),
              "Outlier range:",
              min = 1,
              max = 5,
              value = 3,
              step = 0.5
            )
          ),
          conditionalPanel(
            condition =
              paste0("input['", ns("method"), "'] == 'Percentile'"),
            sliderInput(
              ns("percentile_slider"),
              "Outlier range:",
              min = 0.001,
              max = 0.5,
              value = 0.01,
              step = 0.001
            )
          ),
          uiOutput(ns("ui_outlier_help"))
        )
      ),
      conditionalPanel(
        condition = paste0("input['", ns("tabs"), "'] == 'Boxplot'"),
        ui_decorate_teal_data(
          ns("d_box_plot"),
          decorators = select_decorators(args$decorators, "box_plot")
        )
      ),
      conditionalPanel(
        condition = paste0("input['", ns("tabs"), "'] == 'Density Plot'"),
        ui_decorate_teal_data(
          ns("d_density_plot"),
          decorators = select_decorators(args$decorators, "density_plot")
        )
      ),
      conditionalPanel(
        condition = paste0("input['", ns("tabs"), "'] == 'Cumulative Distribution Plot'"),
        ui_decorate_teal_data(
          ns("d_cumulative_plot"),
          decorators = select_decorators(args$decorators, "cumulative_plot")
        )
      ),
      bslib::accordion(
        open = TRUE,
        bslib::accordion_panel(
          title = "Plot settings",
          selectInput(
            inputId = ns("ggtheme"),
            label = "Theme (by ggplot):",
            choices = ggplot_themes,
            selected = args$ggtheme,
            multiple = FALSE
          )
        )
      )
    ),
    pre_output = args$pre_output,
    post_output = args$post_output
  )
}

# Server function for the outliers module
# Server function for the outliers module
srv_outliers <- function(id, data, outlier_var,
                         categorical_var, plot_height, plot_width, ggplot2_args, decorators) {
  checkmate::assert_class(data, "reactive")
  checkmate::assert_class(isolate(data()), "teal_data")
  moduleServer(id, function(input, output, session) {
    teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")

    ns <- session$ns

    vars <- list(outlier_var = outlier_var, categorical_var = categorical_var)

    rule_diff <- function(other) {
      function(value) {
        othervalue <- tryCatch(selector_list()[[other]]()[["select"]], error = function(e) NULL)
        if (!is.null(othervalue) && identical(othervalue, value)) {
          "`Variable` and `Categorical factor` cannot be the same"
        }
      }
    }

    selector_list <- teal.transform::data_extract_multiple_srv(
      data_extract = vars,
      datasets = data,
      select_validation_rule = list(
        outlier_var = shinyvalidate::compose_rules(
          shinyvalidate::sv_required("Please select a variable"),
          rule_diff("categorical_var")
        ),
        categorical_var = rule_diff("outlier_var")
      )
    )

    iv_r <- reactive({
      iv <- shinyvalidate::InputValidator$new()
      iv$add_rule("method", shinyvalidate::sv_required("Please select a method"))
      iv$add_rule("boxplot_alts", shinyvalidate::sv_required("Please select Plot Type"))
      teal.transform::compose_and_enable_validators(iv, selector_list)
    })

    reactive_select_input <- reactive({
      if (is.null(selector_list()$categorical_var) || length(selector_list()$categorical_var()$select) == 0) {
        selector_list()[names(selector_list()) != "categorical_var"]
      } else {
        selector_list()
      }
    })

    # Used to create outlier table and the dropdown with additional columns
    dataname_first <- isolate(names(data())[[1]])

    data_obj <- reactive({
      obj <- data()
      if (length(teal.data::join_keys(obj)) == 0) {
        if (!".row_id" %in% names(obj[[dataname_first]])) {
          obj[[dataname_first]]$.row_id <- seq_len(nrow(obj[[dataname_first]]))
        }
        teal.data::join_keys(obj) <-
          teal.data::join_keys(teal.data::join_key(dataname_first, dataname_first, ".row_id"))
      }
      obj
    })

    anl_merged_input <- teal.transform::merge_expression_srv(
      selector_list = reactive_select_input,
      datasets = data_obj,
      merge_function = "dplyr::inner_join"
    )

    anl_merged_q <- reactive({
      req(anl_merged_input())
      teal.code::eval_code(
        data_obj(),
        "library(dplyr);library(tidyr);library(tibble);library(ggplot2)"
      ) %>%
        teal.code::eval_code(as.expression(anl_merged_input()$expr))
    })

    merged <- list(
      anl_input_r = anl_merged_input,
      anl_q_r = anl_merged_q
    )

    n_outlier_missing <- reactive({
      req(iv_r()$is_valid())
      outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)
      ANL <- merged$anl_q_r()[["ANL"]]
      sum(is.na(ANL[[outlier_var]]))
    })

    common_code_q <- reactive({
      req(iv_r()$is_valid())

      ANL <- merged$anl_q_r()[["ANL"]]
      qenv <- merged$anl_q_r()
      teal.reporter::teal_card(qenv) <-
        c(
          teal.reporter::teal_card(qenv),
          teal.reporter::teal_card("## Module's output(s)")
        )

      outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)
      categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)
      order_by_outlier <- input$order_by_outlier
      method <- input$method
      split_outliers <- input$split_outliers
      teal::validate_has_data(
        # missing values in the categorical variable may be used to form a category of its own
        `if`(
          length(categorical_var) == 0,
          ANL,
          ANL[, names(ANL) != categorical_var, drop = FALSE]
        ),
        min_nrow = 10,
        complete = TRUE,
        allow_inf = FALSE
      )
      validate(need(is.numeric(ANL[[outlier_var]]), "`Variable` is not numeric"))
      validate(need(length(unique(ANL[[outlier_var]])) > 1, "Variable has no variation, i.e. only one unique value"))

      # show/hide split_outliers
      if (length(categorical_var) == 0) {
        shinyjs::hide("split_outliers")
        if (n_outlier_missing() > 0) {
          qenv <- teal.code::eval_code(
            qenv,
            substitute(
              expr = ANL <- ANL %>% dplyr::filter(!is.na(outlier_var_name)),
              env = list(outlier_var_name = as.name(outlier_var))
            )
          )
        }
      } else {
        validate(need(
          is.factor(ANL[[categorical_var]]) ||
            is.character(ANL[[categorical_var]]) ||
            is.integer(ANL[[categorical_var]]),
          "`Categorical factor` must be `factor`, `character`, or `integer`"
        ))

        if (n_outlier_missing() > 0) {
          qenv <- teal.code::eval_code(
            qenv,
            substitute(
              expr = ANL <- ANL %>% dplyr::filter(!is.na(outlier_var_name)),
              env = list(outlier_var_name = as.name(outlier_var))
            )
          )
        }
        shinyjs::show("split_outliers")
      }

      # slider
      outlier_definition_param <- if (method == "IQR") {
        input$iqr_slider
      } else if (method == "Z-score") {
        input$zscore_slider
      } else if (method == "Percentile") {
        input$percentile_slider
      }

      # this is utils function that converts a %>% NULL %>% b into a %>% b
      remove_pipe_null <- function(x) {
        if (length(x) == 1) {
          x
        } else if (identical(x[[1]], as.name("%>%")) && is.null(x[[3]])) {
          remove_pipe_null(x[[2]])
        } else {
          as.call(c(x[[1]], lapply(x[-1], remove_pipe_null)))
        }
      }

      qenv <- teal.code::eval_code(
        qenv,
        substitute(
          expr = {
            ANL_OUTLIER <- ANL %>%
              group_expr %>% # styler: off
              dplyr::mutate(is_outlier = {
                q1_q3 <- stats::quantile(outlier_var_name, probs = c(0.25, 0.75))
                iqr <- q1_q3[2] - q1_q3[1]
                !(outlier_var_name >= q1_q3[1] - 1.5 * iqr & outlier_var_name <= q1_q3[2] + 1.5 * iqr)
              }) %>%
              calculate_outliers %>% # styler: off
              ungroup_expr %>% # styler: off
              dplyr::filter(is_outlier | is_outlier_selected) %>%
              dplyr::select(-is_outlier)
          },
          env = list(
            calculate_outliers = if (method == "IQR") {
              substitute(
                expr = dplyr::mutate(is_outlier_selected = {
                  q1_q3 <- stats::quantile(outlier_var_name, probs = c(0.25, 0.75))
                  iqr <- q1_q3[2] - q1_q3[1]
                  !(
                    outlier_var_name >= q1_q3[1] - outlier_definition_param * iqr &
                      outlier_var_name <= q1_q3[2] + outlier_definition_param * iqr
                  )
                }),
                env = list(
                  outlier_var_name = as.name(outlier_var),
                  outlier_definition_param = outlier_definition_param
                )
              )
            } else if (method == "Z-score") {
              substitute(
                expr = dplyr::mutate(
                  is_outlier_selected = abs(outlier_var_name - mean(outlier_var_name)) /
                    stats::sd(outlier_var_name) > outlier_definition_param
                ),
                env = list(
                  outlier_var_name = as.name(outlier_var),
                  outlier_definition_param = outlier_definition_param
                )
              )
            } else if (method == "Percentile") {
              substitute(
                expr = dplyr::mutate(
                  is_outlier_selected = outlier_var_name < stats::quantile(outlier_var_name, outlier_definition_param) |
                    outlier_var_name > stats::quantile(outlier_var_name, 1 - outlier_definition_param)
                ),
                env = list(
                  outlier_var_name = as.name(outlier_var),
                  outlier_definition_param = outlier_definition_param
                )
              )
            },
            outlier_var_name = as.name(outlier_var),
            group_expr = if (isTRUE(split_outliers) && length(categorical_var) != 0) {
              substitute(dplyr::group_by(x), list(x = as.name(categorical_var)))
            },
            ungroup_expr = if (isTRUE(split_outliers) && length(categorical_var) != 0) {
              substitute(dplyr::ungroup())
            }
          )
        ) %>%
          remove_pipe_null()
      )

      # ANL_OUTLIER_EXTENDED is the base table
      join_keys <- as.character(teal.data::join_keys(data_obj())[dataname_first, dataname_first])

      if (length(join_keys) == 1 && join_keys == ".row_id") {
        # Dummy join key - single dataset, no join needed
        qenv <- teal.code::eval_code(qenv, quote(ANL_OUTLIER_EXTENDED <- ANL_OUTLIER))
      } else {
        # Join keys exist - perform left join
        qenv <- teal.code::eval_code(
          qenv,
          substitute(
            expr = {
              ANL_OUTLIER_EXTENDED <- dplyr::left_join(
                ANL_OUTLIER,
                dplyr::select(
                  dataname,
                  dplyr::setdiff(names(dataname), dplyr::setdiff(names(ANL_OUTLIER), join_keys))
                ),
                by = join_keys
              )
            },
            env = list(
              dataname = as.name(dataname_first),
              join_keys = join_keys
            )
          )
        )
      }

      teal.reporter::teal_card(qenv) <- c(teal.reporter::teal_card(qenv), "### Summary Table")
      qenv <- if (length(categorical_var) > 0) {
        qenv <- teal.code::eval_code(
          qenv,
          substitute(
            expr = summary_data_pre <- ANL_OUTLIER %>%
              dplyr::filter(is_outlier_selected) %>%
              dplyr::select(outlier_var_name, categorical_var_name) %>%
              dplyr::group_by(categorical_var_name) %>%
              dplyr::summarise(n_outliers = dplyr::n()) %>%
              dplyr::right_join(
                ANL %>%
                  dplyr::select(outlier_var_name, categorical_var_name) %>%
                  dplyr::group_by(categorical_var_name) %>%
                  dplyr::summarise(
                    total_in_cat = dplyr::n(),
                    n_na = sum(is.na(outlier_var_name) | is.na(categorical_var_name))
                  ),
                by = categorical_var
              ) %>%
              # This is important as there may be categorical variables with natural orderings, e.g. AGE.
              # The plots should be displayed by default in increasing order in these situations.
              # dplyr::arrange will sort integer, factor, and character data types in the expected way.
              dplyr::arrange(categorical_var_name) %>%
              dplyr::mutate(
                n_outliers = dplyr::if_else(is.na(n_outliers), 0, as.numeric(n_outliers)),
                display_str = dplyr::if_else(
                  n_outliers > 0,
                  sprintf("%d [%.02f%%]", n_outliers, 100 * n_outliers / total_in_cat),
                  "0"
                ),
                display_str_na = dplyr::if_else(
                  n_na > 0,
                  sprintf("%d [%.02f%%]", n_na, 100 * n_na / total_in_cat),
                  "0"
                ),
                order = seq_along(n_outliers)
              ),
            env = list(
              categorical_var = categorical_var,
              categorical_var_name = as.name(categorical_var),
              outlier_var_name = as.name(outlier_var)
            )
          )
        )
        # now to handle when user chooses to order based on amount of outliers
        if (order_by_outlier) {
          qenv <- teal.code::eval_code(
            qenv,
            quote(
              summary_data_pre <- summary_data_pre %>%
                dplyr::arrange(desc(n_outliers / total_in_cat)) %>%
                dplyr::mutate(order = seq_len(nrow(summary_data_pre)))
            )
          )
        }

        teal.code::eval_code(
          qenv,
          substitute(
            expr = {
              # In order for geom_rug to work properly when reordering takes place inside facet_grid,
              # all tables must have the column used for reording.
              # In this case, the column used for reordering is `order`.
              ANL_OUTLIER <- dplyr::left_join(
                ANL_OUTLIER,
                summary_data_pre[, c("order", categorical_var)],
                by = categorical_var
              )
              # so that x axis of plot aligns with columns of summary table, from most outliers to least by percentage
              ANL <- ANL %>%
                dplyr::left_join(
                  dplyr::select(summary_data_pre, categorical_var_name, order),
                  by = categorical_var
                ) %>%
                dplyr::arrange(order)
              summary_data <- summary_data_pre %>%
                dplyr::select(
                  categorical_var_name,
                  Outliers = display_str, Missings = display_str_na, Total = total_in_cat
                ) %>%
                dplyr::mutate_all(as.character) %>%
                tidyr::pivot_longer(-categorical_var_name) %>%
                tidyr::pivot_wider(names_from = categorical_var, values_from = value) %>%
                tibble::column_to_rownames("name")
            },
            env = list(
              categorical_var = categorical_var,
              categorical_var_name = as.name(categorical_var)
            )
          )
        ) |>
          within({
            table <- rtables::df_to_tt(summary_data)
            table
          })
      } else {
        msg <- "No categorical variable selected, summary table cannot be created."
        showNotification(msg,
          closeButton = FALSE, type = "warning",
          id = session$ns("no_summary_table")
        )
        within(qenv, cat(msg), msg = msg)
      }


      if (length(categorical_var) > 0 && nrow(qenv[["ANL_OUTLIER"]]) > 0) {
        shinyjs::show("order_by_outlier")
      } else {
        shinyjs::hide("order_by_outlier")
      }

      qenv
    })

    # boxplot/violinplot # nolint commented_code
    box_plot_q <- reactive({
      req(common_code_q())
      qenv <- common_code_q()
      teal.reporter::teal_card(qenv) <- c(teal.reporter::teal_card(qenv), "### Box Plot")

      ANL <- qenv[["ANL"]]
      ANL_OUTLIER <- qenv[["ANL_OUTLIER"]]

      outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)
      categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)

      # validation
      teal::validate_has_data(ANL, 1)

      # boxplot
      plot_call <- quote(ANL %>% ggplot())

      plot_call <- if (input$boxplot_alts == "Box plot") {
        substitute(expr = plot_call + ggplot2::geom_boxplot(outlier.shape = NA), env = list(plot_call = plot_call))
      } else if (input$boxplot_alts == "Violin plot") {
        substitute(expr = plot_call + ggplot2::geom_violin(), env = list(plot_call = plot_call))
      } else {
        NULL
      }

      plot_call <- if (identical(categorical_var, character(0)) || is.null(categorical_var)) {
        inner_call <- substitute(
          expr = plot_call +
            ggplot2::aes(x = "Entire dataset", y = outlier_var_name) +
            ggplot2::scale_x_discrete(),
          env = list(plot_call = plot_call, outlier_var_name = as.name(outlier_var))
        )
        if (nrow(ANL_OUTLIER) > 0) {
          substitute(
            expr = inner_call + ggplot2::geom_point(
              data = ANL_OUTLIER,
              ggplot2::aes(x = "Entire dataset", y = outlier_var_name, color = is_outlier_selected)
            ),
            env = list(inner_call = inner_call, outlier_var_name = as.name(outlier_var))
          )
        } else {
          inner_call
        }
      } else {
        substitute(
          expr = plot_call +
            ggplot2::aes(y = outlier_var_name, x = reorder(categorical_var_name, order)) +
            ggplot2::xlab(categorical_var) +
            ggplot2::scale_x_discrete() +
            ggplot2::geom_point(
              data = ANL_OUTLIER,
              ggplot2::aes(x = as.factor(categorical_var_name), y = outlier_var_name, color = is_outlier_selected)
            ),
          env = list(
            plot_call = plot_call,
            outlier_var_name = as.name(outlier_var),
            categorical_var_name = as.name(categorical_var),
            categorical_var = categorical_var
          )
        )
      }

      dev_ggplot2_args <- teal.widgets::ggplot2_args(
        labs = list(color = "Is outlier?"),
        theme = list(legend.position = "top")
      )

      all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(
        user_plot = ggplot2_args[["Boxplot"]],
        user_default = ggplot2_args$default,
        module_plot = dev_ggplot2_args
      )

      parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(
        all_ggplot2_args,
        ggtheme = input$ggtheme
      )

      teal.code::eval_code(
        qenv,
        substitute(
          expr = box_plot <- plot_call +
            ggplot2::scale_color_manual(values = c("TRUE" = "red", "FALSE" = "black")) +
            labs + ggthemes + themes,
          env = list(
            plot_call = plot_call,
            labs = parsed_ggplot2_args$labs,
            ggthemes = parsed_ggplot2_args$ggtheme,
            themes = parsed_ggplot2_args$theme
          )
        )
      )
    })

    # density plot
    density_plot_q <- reactive({
      qenv <- common_code_q()
      teal.reporter::teal_card(qenv) <- c(teal.reporter::teal_card(qenv), "### Density Plot")

      ANL <- qenv[["ANL"]]
      ANL_OUTLIER <- qenv[["ANL_OUTLIER"]]

      outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)
      categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)

      # validation
      teal::validate_has_data(ANL, 1)
      # plot
      plot_call <- substitute(
        expr = ANL %>%
          ggplot2::ggplot(ggplot2::aes(x = outlier_var_name)) +
          ggplot2::geom_density() +
          ggplot2::geom_rug(data = ANL_OUTLIER, ggplot2::aes(x = outlier_var_name, color = is_outlier_selected)) +
          ggplot2::scale_color_manual(values = c("TRUE" = "red", "FALSE" = "black")),
        env = list(outlier_var_name = as.name(outlier_var))
      )

      plot_call <- if (identical(categorical_var, character(0)) || is.null(categorical_var)) {
        substitute(expr = plot_call, env = list(plot_call = plot_call))
      } else {
        substitute(
          expr = plot_call + ggplot2::facet_grid(~ reorder(categorical_var_name, order)),
          env = list(plot_call = plot_call, categorical_var_name = as.name(categorical_var))
        )
      }

      dev_ggplot2_args <- teal.widgets::ggplot2_args(
        labs = list(color = "Is outlier?"),
        theme = list(legend.position = "top")
      )

      all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(
        user_plot = ggplot2_args[["Density Plot"]],
        user_default = ggplot2_args$default,
        module_plot = dev_ggplot2_args
      )

      parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(
        all_ggplot2_args,
        ggtheme = input$ggtheme
      )

      teal.code::eval_code(
        qenv,
        substitute(
          expr = density_plot <- plot_call + labs + ggthemes + themes,
          env = list(
            plot_call = plot_call,
            labs = parsed_ggplot2_args$labs,
            themes = parsed_ggplot2_args$theme,
            ggthemes = parsed_ggplot2_args$ggtheme
          )
        )
      )
    })

    # Cumulative distribution plot
    cumulative_plot_q <- reactive({
      qenv <- common_code_q()
      teal.reporter::teal_card(qenv) <- c(teal.reporter::teal_card(qenv), "### Cumulative Distribution Plot")

      ANL <- qenv[["ANL"]]
      ANL_OUTLIER <- qenv[["ANL_OUTLIER"]]

      outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)
      categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)

      # validation
      teal::validate_has_data(ANL, 1)

      # plot
      plot_call <- substitute(
        expr = ANL %>% ggplot2::ggplot(ggplot2::aes(x = outlier_var_name)) +
          ggplot2::stat_ecdf(),
        env = list(outlier_var_name = as.name(outlier_var))
      )
      if (length(categorical_var) == 0) {
        qenv <- teal.code::eval_code(
          qenv,
          substitute(
            expr = {
              ecdf_df <- ANL %>%
                dplyr::mutate(
                  y = stats::ecdf(ANL[[outlier_var]])(ANL[[outlier_var]])
                )

              outlier_points <- dplyr::left_join(
                ecdf_df,
                ANL_OUTLIER,
                by = dplyr::setdiff(names(ecdf_df), "y")
              ) %>%
                dplyr::filter(!is.na(is_outlier_selected))
            },
            env = list(outlier_var = outlier_var)
          )
        )
      } else {
        qenv <- teal.code::eval_code(
          qenv,
          substitute(
            expr = {
              all_categories <- lapply(
                unique(ANL[[categorical_var]]),
                function(x) {
                  ANL <- ANL %>% dplyr::filter(get(categorical_var) == x)
                  anl_outlier2 <- ANL_OUTLIER %>% dplyr::filter(get(categorical_var) == x)
                  ecdf_df <- ANL %>%
                    dplyr::mutate(y = stats::ecdf(ANL[[outlier_var]])(ANL[[outlier_var]]))

                  dplyr::left_join(
                    ecdf_df,
                    anl_outlier2,
                    by = dplyr::setdiff(names(ecdf_df), "y")
                  ) %>%
                    dplyr::filter(!is.na(is_outlier_selected))
                }
              )
              outlier_points <- do.call(rbind, all_categories)
            },
            env = list(categorical_var = categorical_var, outlier_var = outlier_var)
          )
        )
        plot_call <- substitute(
          expr = plot_call + ggplot2::facet_grid(~ reorder(categorical_var_name, order)),
          env = list(plot_call = plot_call, categorical_var_name = as.name(categorical_var))
        )
      }

      dev_ggplot2_args <- teal.widgets::ggplot2_args(
        labs = list(color = "Is outlier?"),
        theme = list(legend.position = "top")
      )

      all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(
        user_plot = ggplot2_args[["Cumulative Distribution Plot"]],
        user_default = ggplot2_args$default,
        module_plot = dev_ggplot2_args
      )

      parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(
        all_ggplot2_args,
        ggtheme = input$ggtheme
      )

      teal.code::eval_code(
        qenv,
        substitute(
          expr = cumulative_plot <- plot_call +
            ggplot2::geom_point(
              data = outlier_points,
              ggplot2::aes(x = outlier_var_name, y = y, color = is_outlier_selected)
            ) +
            ggplot2::scale_color_manual(values = c("TRUE" = "red", "FALSE" = "black")) +
            labs + ggthemes + themes,
          env = list(
            plot_call = plot_call,
            outlier_var_name = as.name(outlier_var),
            labs = parsed_ggplot2_args$labs,
            themes = parsed_ggplot2_args$theme,
            ggthemes = parsed_ggplot2_args$ggtheme
          )
        )
      )
    })

    current_tab_r <- reactive({
      switch(req(input$tabs),
        "Boxplot" = "box_plot",
        "Density Plot" = "density_plot",
        "Cumulative Distribution Plot" = "cumulative_plot"
      )
    })

    decorated_q <- mapply(
      function(obj_name, q) {
        srv_decorate_teal_data(
          id = sprintf("d_%s", obj_name),
          data = q,
          decorators = select_decorators(decorators, obj_name),
          expr = reactive({
            substitute(
              expr = {
                columns_index <- union(
                  setdiff(names(ANL_OUTLIER), c("is_outlier_selected", "order")),
                  table_columns
                )
                ANL_OUTLIER_EXTENDED[ANL_OUTLIER_EXTENDED$is_outlier_selected, columns_index]
                print(.plot)
              },
              env = list(table_columns = input$table_ui_columns, .plot = as.name(obj_name))
            )
          })
        )
      },
      stats::setNames(nm = c("box_plot", "density_plot", "cumulative_plot")),
      c(box_plot_q, density_plot_q, cumulative_plot_q)
    )

    box_plot_r <- reactive({
      teal::validate_inputs(iv_r())
      req(decorated_q$box_plot())[["box_plot"]]
    })
    density_plot_r <- reactive({
      teal::validate_inputs(iv_r())
      req(decorated_q$density_plot())[["density_plot"]]
    })
    cumulative_plot_r <- reactive({
      teal::validate_inputs(iv_r())
      req(decorated_q$cumulative_plot())[["cumulative_plot"]]
    })

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

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

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

    pws_list <- list(box_plot = box_pws, density_plot = density_pws, cumulative_plot = cum_density_pws)
    decorated_final_q <- reactive({
      pws <- pws_list[[req(current_tab_r())]]
      req(pws$dim())
      req(decorated_q[[current_tab_r()]]())
      set_chunk_dims(pws, decorated_q[[current_tab_r()]])()
    })

    summary_table_r <- reactive({
      q <- req(decorated_final_q())

      DT::datatable(
        data = if (iv_r()$is_valid()) {
          categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)
          if (!is.null(categorical_var)) q[["summary_data"]]
        },
        options = list(
          dom = "t",
          autoWidth = TRUE,
          columnDefs = list(list(width = "200px", targets = "_all"))
        )
      )
    })

    output$summary_table <- DT::renderDataTable(summary_table_r())

    # slider text
    output$ui_outlier_help <- renderUI({
      req(input$method)
      if (input$method == "IQR") {
        req(input$iqr_slider)
        tags$small(
          withMathJax(
            helpText(
              "Outlier data points (\\(x \\lt Q1 - ", input$iqr_slider, "\\times IQR\\) or \\(
            Q3 + ", input$iqr_slider, "\\times IQR \\lt x\\))
            are displayed in red on the plot and can be visualized in the table below."
            ),
            if (input$split_outliers) {
              withMathJax(helpText("Note: Quantiles are calculated per group."))
            }
          )
        )
      } else if (input$method == "Z-score") {
        req(input$zscore_slider)
        tags$small(
          withMathJax(
            helpText(
              "Outlier data points (\\(Zscore(x) < -", input$zscore_slider,
              "\\) or \\(", input$zscore_slider, "< Zscore(x) \\))
              are displayed in red on the plot and can be visualized in the table below."
            ),
            if (input$split_outliers) {
              withMathJax(helpText(" Note: Z-scores are calculated per group."))
            }
          )
        )
      } else if (input$method == "Percentile") {
        req(input$percentile_slider)
        tags$small(
          withMathJax(
            helpText(
              "Outlier/extreme data points (\\( Percentile(x) <", input$percentile_slider,
              "\\) or \\(", 1 - input$percentile_slider, " < Percentile(x) \\))
            are displayed in red on the plot and can be visualized in the table below."
            ),
            if (input$split_outliers) {
              withMathJax(helpText("Note: Percentiles are calculated per group."))
            }
          )
        )
      }
    })

    choices <- reactive(teal.transform::variable_choices(data_obj()[[dataname_first]]))

    observeEvent(common_code_q(), {
      ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]]
      teal.widgets::updateOptionalSelectInput(
        session,
        inputId = "table_ui_columns",
        choices = dplyr::setdiff(choices(), names(ANL_OUTLIER)),
        selected = restoreInput(ns("table_ui_columns"), isolate(input$table_ui_columns))
      )
    })

    output$table_ui <- DT::renderDataTable(
      expr = {
        tab <- input$tabs
        req(tab) # tab is NULL upon app launch, hence will crash without this statement
        req(iv_r()$is_valid()) # Same validation as output$table_ui_wrap
        outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)
        categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)

        ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]]
        ANL_OUTLIER_EXTENDED <- common_code_q()[["ANL_OUTLIER_EXTENDED"]]
        ANL <- common_code_q()[["ANL"]]

        plot_brush <- switch(current_tab_r(),
          box_plot = {
            box_plot_r()
            box_pws$brush()
          },
          density_plot = {
            density_plot_r()
            density_pws$brush()
          },
          cumulative_plot = {
            cumulative_plot_r()
            cum_density_pws$brush()
          }
        )

        # removing unused column ASAP
        ANL_OUTLIER$order <- ANL$order <- NULL

        display_table <- if (!is.null(plot_brush)) {
          if (length(categorical_var) > 0) {
            # due to reordering, the x-axis label may be changed to something like "reorder(categorical_var, order)"
            if (tab == "Boxplot") {
              plot_brush$mapping$x <- categorical_var
            } else {
              # the other plots use facetting
              # so it is panelvar1 that gets relabelled to "reorder(categorical_var, order)"
              plot_brush$mapping$panelvar1 <- categorical_var
            }
          } else {
            if (tab == "Boxplot") {
              # in boxplot with no categorical variable, there is no column in ANL that would correspond to x-axis
              # so a column needs to be inserted with the value "Entire dataset" because that's the label used in plot
              ANL[[plot_brush$mapping$x]] <- "Entire dataset"
            }
          }

          # in density and cumulative plots, ANL does not have a column corresponding to y-axis.
          # so they need to be computed and attached to ANL
          if (tab == "Density Plot") {
            plot_brush$mapping$y <- "density"
            ANL$density <- plot_brush$ymin
            # either ymin or ymax will work
          } else if (tab == "Cumulative Distribution Plot") {
            plot_brush$mapping$y <- "cdf"
            if (length(categorical_var) > 0) {
              ANL <- ANL %>%
                dplyr::group_by(!!as.name(plot_brush$mapping$panelvar1)) %>%
                dplyr::mutate(cdf = stats::ecdf(!!as.name(outlier_var))(!!as.name(outlier_var)))
            } else {
              ANL$cdf <- stats::ecdf(ANL[[outlier_var]])(ANL[[outlier_var]])
            }
          }

          brushed_rows <- brushedPoints(ANL, plot_brush)
          if (nrow(brushed_rows) > 0) {
            # now we need to remove extra column from ANL so that it will have the same columns as ANL_OUTLIER
            # so that dplyr::intersect will work
            if (tab == "Density Plot") {
              brushed_rows$density <- NULL
            } else if (tab == "Cumulative Distribution Plot") {
              brushed_rows$cdf <- NULL
            } else if (tab == "Boxplot" && length(categorical_var) == 0) {
              brushed_rows[[plot_brush$mapping$x]] <- NULL
            }
            # is_outlier_selected is part of ANL_OUTLIER so needed here
            brushed_rows$is_outlier_selected <- TRUE
            dplyr::intersect(ANL_OUTLIER, brushed_rows)
          } else {
            ANL_OUTLIER[0, ]
          }
        } else {
          ANL_OUTLIER[ANL_OUTLIER$is_outlier_selected, ]
        }

        display_table$is_outlier_selected <- NULL

        # Extend the brushed ANL_OUTLIER with additional columns
        dplyr::left_join(
          display_table,
          dplyr::select(ANL_OUTLIER_EXTENDED, -"is_outlier_selected"),
          by = names(display_table)
        ) %>%
          dplyr::select(union(names(display_table), input$table_ui_columns))
      },
      options = list(
        searching = FALSE, language = list(
          zeroRecords = "The brushed area does not contain outlier observations for the currently defined threshold"
        ),
        pageLength = input$table_ui_rows
      )
    )

    output$total_outliers <- renderUI({
      req(iv_r()$is_valid())
      ANL <- merged$anl_q_r()[["ANL"]]
      ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]]
      teal::validate_has_data(ANL, 1)
      ANL_OUTLIER_SELECTED <- ANL_OUTLIER[ANL_OUTLIER$is_outlier_selected, ]
      tags$h5(
        sprintf(
          "%s %d / %d [%.02f%%]",
          "Total number of outlier(s):",
          nrow(ANL_OUTLIER_SELECTED),
          nrow(ANL),
          100 * nrow(ANL_OUTLIER_SELECTED) / nrow(ANL)
        )
      )
    })

    output$total_missing <- renderUI({
      if (n_outlier_missing() > 0) {
        ANL <- merged$anl_q_r()[["ANL"]]
        helpText(
          sprintf(
            "%s %d / %d [%.02f%%]",
            "Total number of row(s) with missing values:",
            n_outlier_missing(),
            nrow(ANL),
            100 * (n_outlier_missing()) / nrow(ANL)
          )
        )
      }
    })

    output$table_ui_wrap <- renderUI({
      req(iv_r()$is_valid())
      tagList(
        teal.widgets::optionalSelectInput(
          inputId = ns("table_ui_columns"),
          label = "Choose additional columns",
          choices = NULL,
          selected = NULL,
          multiple = TRUE
        ),
        tags$h4("Outlier Table"),
        teal.widgets::get_dt_rows(ns("table_ui"), ns("table_ui_rows"))
      )
    })

    decorated_final_q
  })
}

#' `teal` module: Scatterplot matrix
#'
#' Generates a scatterplot matrix from selected `variables` from datasets.
#' Each plot within the matrix represents the relationship between two variables,
#' providing the overview of correlations and distributions across selected data.
#'
#' @note For more examples, please see the vignette "Using scatterplot matrix" via
#' `vignette("using-scatterplot-matrix", package = "teal.modules.general")`.
#'
#' @inheritParams teal::module
#' @inheritParams tm_g_scatterplot
#' @inheritParams shared_params
#'
#' @param variables (`data_extract_spec` or `list` of multiple `data_extract_spec`)
#' Specifies plotting variables from an incoming dataset with filtering and selecting. In case of
#' `data_extract_spec` use `select_spec(..., ordered = TRUE)` if plot elements should be
#' rendered according to selection order.
#'
#' @inherit shared_params return
#'
#' @section Decorating Module:
#'
#' This module generates the following objects, which can be modified in place using decorators:
#' - `plot` (`trellis` - output of `lattice::splom`)
#'
#' A Decorator is applied to the specific output using a named list of `teal_transform_module` objects.
#' The name of this list corresponds to the name of the output to which the decorator is applied.
#' See code snippet below:
#'
#' ```
#' tm_g_scatterplotmatrix(
#'    ..., # arguments for module
#'    decorators = list(
#'      plot = teal_transform_module(...) # applied to the `plot` output
#'    )
#' )
#' ```
#'
#' For additional details and examples of decorators, refer to the vignette
#' `vignette("decorate-module-output", package = "teal.modules.general")`.
#'
#' To learn more please refer to the vignette
#' `vignette("transform-module-output", package = "teal")` or the [`teal::teal_transform_module()`] documentation.
#'
#' @inheritSection teal::example_module Reporting
#'
#' @examplesShinylive
#' library(teal.modules.general)
#' interactive <- function() TRUE
#' {{ next_example }}
#' @examples
#' # general data example
#' data <- teal_data()
#' data <- within(data, {
#'   countries <- data.frame(
#'     id = c("DE", "FR", "IT", "ES", "PT", "GR", "NL", "BE", "LU", "AT"),
#'     government = factor(
#'       c(2, 2, 2, 1, 2, 2, 1, 1, 1, 2),
#'       labels = c("Monarchy", "Republic")
#'     ),
#'     language_family = factor(
#'       c(1, 3, 3, 3, 3, 2, 1, 1, 3, 1),
#'       labels = c("Germanic", "Hellenic", "Romance")
#'     ),
#'     population = c(83, 67, 60, 47, 10, 11, 17, 11, 0.6, 9),
#'     area = c(357, 551, 301, 505, 92, 132, 41, 30, 2.6, 83),
#'     gdp = c(3.4, 2.7, 2.1, 1.4, 0.3, 0.2, 0.7, 0.5, 0.1, 0.4),
#'     debt = c(2.1, 2.3, 2.4, 2.6, 2.3, 2.4, 2.3, 2.4, 2.3, 2.4)
#'   )
#'   sales <- data.frame(
#'     id = 1:50,
#'     country_id = sample(
#'       c("DE", "FR", "IT", "ES", "PT", "GR", "NL", "BE", "LU", "AT"),
#'       size = 50,
#'       replace = TRUE
#'     ),
#'     year = sort(sample(2010:2020, 50, replace = TRUE)),
#'     venue = sample(c("small", "medium", "large", "online"), 50, replace = TRUE),
#'     cancelled = sample(c(TRUE, FALSE), 50, replace = TRUE),
#'     quantity = rnorm(50, 100, 20),
#'     costs = rnorm(50, 80, 20),
#'     profit = rnorm(50, 20, 10)
#'   )
#' })
#' join_keys(data) <- join_keys(
#'   join_key("countries", "countries", "id"),
#'   join_key("sales", "sales", "id"),
#'   join_key("countries", "sales", c("id" = "country_id"))
#' )
#'
#' app <- init(
#'   data = data,
#'   modules = modules(
#'     tm_g_scatterplotmatrix(
#'       label = "Scatterplot matrix",
#'       variables = list(
#'         data_extract_spec(
#'           dataname = "countries",
#'           select = select_spec(
#'             label = "Select variables:",
#'             choices = variable_choices(data[["countries"]]),
#'             selected = c("area", "gdp", "debt"),
#'             multiple = TRUE,
#'             ordered = TRUE,
#'             fixed = FALSE
#'           )
#'         ),
#'         data_extract_spec(
#'           dataname = "sales",
#'           filter = filter_spec(
#'             label = "Select variable:",
#'             vars = "country_id",
#'             choices = value_choices(data[["sales"]], "country_id"),
#'             selected = c("DE", "FR", "IT", "PT", "GR", "NL", "BE", "LU", "AT"),
#'             multiple = TRUE
#'           ),
#'           select = select_spec(
#'             label = "Select variables:",
#'             choices = variable_choices(data[["sales"]], c("quantity", "costs", "profit")),
#'             selected = c("quantity", "costs", "profit"),
#'             multiple = TRUE,
#'             ordered = TRUE,
#'             fixed = FALSE
#'           )
#'         )
#'       )
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
#' @examplesShinylive
#' library(teal.modules.general)
#' interactive <- function() TRUE
#' {{ next_example }}
#' @examples
#' # CDISC data example
#' data <- teal_data()
#' data <- within(data, {
#'   ADSL <- teal.data::rADSL
#'   ADRS <- teal.data::rADRS
#' })
#' join_keys(data) <- default_cdisc_join_keys[names(data)]
#'
#' app <- init(
#'   data = data,
#'   modules = modules(
#'     tm_g_scatterplotmatrix(
#'       label = "Scatterplot matrix",
#'       variables = list(
#'         data_extract_spec(
#'           dataname = "ADSL",
#'           select = select_spec(
#'             label = "Select variables:",
#'             choices = variable_choices(data[["ADSL"]]),
#'             selected = c("AGE", "RACE", "SEX"),
#'             multiple = TRUE,
#'             ordered = TRUE,
#'             fixed = FALSE
#'           )
#'         ),
#'         data_extract_spec(
#'           dataname = "ADRS",
#'           filter = filter_spec(
#'             label = "Select endpoints:",
#'             vars = c("PARAMCD", "AVISIT"),
#'             choices = value_choices(data[["ADRS"]], c("PARAMCD", "AVISIT"), c("PARAM", "AVISIT")),
#'             selected = "INVET - END OF INDUCTION",
#'             multiple = TRUE
#'           ),
#'           select = select_spec(
#'             label = "Select variables:",
#'             choices = variable_choices(data[["ADRS"]]),
#'             selected = c("AGE", "AVAL", "ADY"),
#'             multiple = TRUE,
#'             ordered = TRUE,
#'             fixed = FALSE
#'           )
#'         )
#'       )
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
#' @export
#'
tm_g_scatterplotmatrix <- function(label = "Scatterplot Matrix",
                                   variables,
                                   plot_height = c(600, 200, 2000),
                                   plot_width = NULL,
                                   pre_output = NULL,
                                   post_output = NULL,
                                   transformators = list(),
                                   decorators = list()) {
  message("Initializing tm_g_scatterplotmatrix")

  # Normalize the parameters
  if (inherits(variables, "data_extract_spec")) variables <- list(variables)

  # Start of assertions
  checkmate::assert_string(label)
  checkmate::assert_list(variables, types = "data_extract_spec")

  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_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
  checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)

  assert_decorators(decorators, "plot")
  # End of assertions

  # Make UI args
  args <- as.list(environment())

  ans <- module(
    label = label,
    server = srv_g_scatterplotmatrix,
    ui = ui_g_scatterplotmatrix,
    ui_args = args,
    server_args = list(
      variables = variables,
      plot_height = plot_height,
      plot_width = plot_width,
      decorators = decorators
    ),
    transformators = transformators,
    datanames = teal.transform::get_extract_datanames(variables)
  )
  attr(ans, "teal_bookmarkable") <- TRUE
  ans
}

# UI function for the scatterplot matrix module
ui_g_scatterplotmatrix <- function(id, ...) {
  args <- list(...)
  is_single_dataset_value <- teal.transform::is_single_dataset(args$variables)
  ns <- NS(id)
  teal.widgets::standard_layout(
    output = teal.widgets::white_small_well(
      textOutput(ns("message")),
      tags$br(),
      teal.widgets::plot_with_settings_ui(id = ns("myplot"))
    ),
    encoding = tags$div(
      tags$label("Encodings", class = "text-primary"),
      teal.transform::datanames_input(args$variables),
      teal.transform::data_extract_ui(
        id = ns("variables"),
        label = "Variables",
        data_extract_spec = args$variables,
        is_single_dataset = is_single_dataset_value
      ),
      tags$hr(),
      ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "plot")),
      bslib::accordion(
        open = TRUE,
        bslib::accordion_panel(
          title = "Plot settings",
          sliderInput(
            ns("alpha"), "Opacity:",
            min = 0, max = 1,
            step = .05, value = .5, ticks = FALSE
          ),
          sliderInput(
            ns("cex"), "Points size:",
            min = 0.2, max = 3,
            step = .05, value = .65, ticks = FALSE
          ),
          checkboxInput(ns("cor"), "Add Correlation", value = FALSE),
          radioButtons(
            ns("cor_method"), "Select Correlation Method",
            choiceNames = c("Pearson", "Kendall", "Spearman"),
            choiceValues = c("pearson", "kendall", "spearman"),
            inline = TRUE
          ),
          checkboxInput(ns("cor_na_omit"), "Omit Missing Values", value = TRUE)
        )
      )
    ),
    pre_output = args$pre_output,
    post_output = args$post_output
  )
}

# Server function for the scatterplot matrix module
srv_g_scatterplotmatrix <- function(id,
                                    data,
                                    variables,
                                    plot_height,
                                    plot_width,
                                    decorators) {
  checkmate::assert_class(data, "reactive")
  checkmate::assert_class(isolate(data()), "teal_data")
  moduleServer(id, function(input, output, session) {
    teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")

    selector_list <- teal.transform::data_extract_multiple_srv(
      data_extract = list(variables = variables),
      datasets = data,
      select_validation_rule = list(
        variables = ~ if (length(.) <= 1) "Please select at least 2 columns."
      )
    )

    iv_r <- reactive({
      iv <- shinyvalidate::InputValidator$new()
      teal.transform::compose_and_enable_validators(iv, selector_list)
    })

    anl_merged_input <- teal.transform::merge_expression_srv(
      datasets = data,
      selector_list = selector_list
    )

    anl_merged_q <- reactive({
      req(anl_merged_input())
      obj <- data()
      teal.reporter::teal_card(obj) <- c(
        teal.reporter::teal_card(obj),
        teal.reporter::teal_card("## Module's output(s)")
      )
      qenv <- teal.code::eval_code(obj, "library(dplyr);library(lattice)")
      teal.code::eval_code(qenv, as.expression(anl_merged_input()$expr))
    })

    merged <- list(
      anl_input_r = anl_merged_input,
      anl_q_r = anl_merged_q
    )

    # plot
    output_q <- reactive({
      teal::validate_inputs(iv_r())

      qenv <- merged$anl_q_r()
      ANL <- qenv[["ANL"]]

      cols_names <- merged$anl_input_r()$columns_source$variables
      alpha <- input$alpha
      cex <- input$cex
      add_cor <- input$cor
      cor_method <- input$cor_method
      cor_na_omit <- input$cor_na_omit

      cor_na_action <- if (isTruthy(cor_na_omit)) {
        "na.omit"
      } else {
        "na.fail"
      }

      teal::validate_has_data(ANL, 10)
      teal::validate_has_data(ANL[, cols_names, drop = FALSE], 10, complete = TRUE, allow_inf = FALSE)

      # get labels and proper variable names
      varnames <- varname_w_label(cols_names, ANL, wrap_width = 20)

      # check character columns. If any, then those are converted to factors
      check_char <- vapply(ANL[, cols_names], is.character, logical(1))
      if (any(check_char)) {
        qenv <- teal.code::eval_code(
          qenv,
          substitute(
            expr = ANL <- ANL[, cols_names] %>%
              dplyr::mutate_if(is.character, as.factor) %>%
              droplevels(),
            env = list(cols_names = cols_names)
          )
        )
      } else {
        qenv <- teal.code::eval_code(
          qenv,
          substitute(
            expr = ANL <- ANL[, cols_names] %>%
              droplevels(),
            env = list(cols_names = cols_names)
          )
        )
      }


      # create plot
      teal.reporter::teal_card(qenv) <- c(teal.reporter::teal_card(qenv), "### Plot")

      if (add_cor) {
        shinyjs::show("cor_method")
        shinyjs::show("cor_use")
        shinyjs::show("cor_na_omit")

        qenv <- teal.code::eval_code(
          qenv,
          substitute(
            expr = {
              plot <- lattice::splom(
                ANL,
                varnames = varnames_value,
                panel = function(x, y, ...) {
                  lattice::panel.splom(x = x, y = y, ...)
                  cpl <- lattice::current.panel.limits()
                  lattice::panel.text(
                    mean(cpl$xlim),
                    mean(cpl$ylim),
                    get_scatterplotmatrix_stats(
                      x,
                      y,
                      .f = stats::cor.test,
                      .f_args = list(method = cor_method, na.action = cor_na_action)
                    ),
                    alpha = 0.6,
                    fontsize = 18,
                    fontface = "bold"
                  )
                },
                pch = 16,
                alpha = alpha_value,
                cex = cex_value
              )
            },
            env = list(
              varnames_value = varnames,
              cor_method = cor_method,
              cor_na_action = cor_na_action,
              alpha_value = alpha,
              cex_value = cex
            )
          )
        )
      } else {
        shinyjs::hide("cor_method")
        shinyjs::hide("cor_use")
        shinyjs::hide("cor_na_omit")
        qenv <- teal.code::eval_code(
          qenv,
          substitute(
            expr = {
              plot <- lattice::splom(
                ANL,
                varnames = varnames_value,
                pch = 16,
                alpha = alpha_value,
                cex = cex_value
              )
            },
            env = list(varnames_value = varnames, alpha_value = alpha, cex_value = cex)
          )
        )
      }
      qenv
    })

    decorated_output_q <- srv_decorate_teal_data(
      id = "decorator",
      data = output_q,
      decorators = select_decorators(decorators, "plot"),
      expr = quote(plot)
    )

    plot_r <- reactive(req(decorated_output_q())[["plot"]])

    # Insert the plot into a plot_with_settings module
    pws <- teal.widgets::plot_with_settings_srv(
      id = "myplot",
      plot_r = plot_r,
      height = plot_height,
      width = plot_width
    )

    # show a message if conversion to factors took place
    output$message <- renderText({
      req(iv_r()$is_valid())
      req(selector_list()$variables())
      ANL <- merged$anl_q_r()[["ANL"]]
      cols_names <- unique(unname(do.call(c, merged$anl_input_r()$columns_source)))
      check_char <- vapply(ANL[, cols_names], is.character, logical(1))
      if (any(check_char)) {
        is_single <- sum(check_char) == 1
        paste(
          "Character",
          ifelse(is_single, "variable", "variables"),
          paste0("(", paste(cols_names[check_char], collapse = ", "), ")"),
          ifelse(is_single, "was", "were"),
          "converted to",
          ifelse(is_single, "factor.", "factors.")
        )
      } else {
        ""
      }
    })

    set_chunk_dims(pws, decorated_output_q)
  })
}

#' Get stats for x-y pairs in scatterplot matrix
#'
#' Uses [stats::cor.test()] per default for all numerical input variables and converts results
#' to character vector.
#' Could be extended if different stats for different variable types are needed.
#' Meant to be called from [lattice::panel.text()].
#'
#' Presently we need to use a formula input for `stats::cor.test` because
#' `na.fail` only gets evaluated when a formula is passed (see below).
#' ```
#' x = c(1,3,5,7,NA)
#' y = c(3,6,7,8,1)
#' stats::cor.test(x, y, na.action = "na.fail")
#' stats::cor.test(~ x + y,  na.action = "na.fail")
#' ```
#'
#' @param x,y (`numeric`) vectors of data values. `x` and `y` must have the same length.
#' @param .f (`function`) function that accepts x and y as formula input `~ x + y`.
#' Default `stats::cor.test`.
#' @param .f_args (`list`) of arguments to be passed to `.f`.
#' @param round_stat (`integer(1)`) optional, number of decimal places to use when rounding the estimate.
#' @param round_pval (`integer(1)`) optional, number of decimal places to use when rounding the p-value.
#'
#' @return Character with stats. For [stats::cor.test()] correlation coefficient and p-value.
#'
#' @examples
#' set.seed(1)
#' x <- runif(25, 0, 1)
#' y <- runif(25, 0, 1)
#' x[c(3, 10, 18)] <- NA
#'
#' get_scatterplotmatrix_stats(x, y, .f = stats::cor.test, .f_args = list(method = "pearson"))
#' get_scatterplotmatrix_stats(x, y, .f = stats::cor.test, .f_args = list(
#'   method = "pearson",
#'   na.action = na.fail
#' ))
#'
#' @export
#'
get_scatterplotmatrix_stats <- function(x, y,
                                        .f = stats::cor.test,
                                        .f_args = list(),
                                        round_stat = 2,
                                        round_pval = 4) {
  if (is.numeric(x) && is.numeric(y)) {
    stat <- tryCatch(do.call(.f, c(list(~ x + y), .f_args)), error = function(e) NA)

    if (anyNA(stat)) {
      return("NA")
    } else if (all(c("estimate", "p.value") %in% names(stat))) {
      return(paste(
        c(
          paste0(names(stat$estimate), ":", round(stat$estimate, round_stat)),
          paste0("P:", round(stat$p.value, round_pval))
        ),
        collapse = "\n"
      ))
    } else {
      stop("function not supported")
    }
  } else {
    if ("method" %in% names(.f_args)) {
      if (.f_args$method == "pearson") {
        return("cor:-")
      }
      if (.f_args$method == "kendall") {
        return("tau:-")
      }
      if (.f_args$method == "spearman") {
        return("rho:-")
      }
    }
    return("-")
  }
}

#' `teal` module: Data table viewer
#'
#' Module provides a dynamic and interactive way to view `data.frame`s in a `teal` application.
#' It uses the `DT` package to display data tables in a paginated, searchable, and sortable format,
#' which helps to enhance data exploration and analysis.
#'
#' The `DT` package has an option `DT.TOJSON_ARGS` to show `Inf` and `NA` in data tables.
#' Configure the `DT.TOJSON_ARGS` option via
#' `options(DT.TOJSON_ARGS = list(na = "string"))` before running the module.
#' Note though that sorting of numeric columns with `NA`/`Inf` will be lexicographic not numerical.
#'
#' @inheritParams teal::module
#' @inheritParams shared_params
#' @param variables_selected (`named list`) Character vectors of the variables (i.e. columns)
#' which should be initially shown for each dataset.
#' Names of list elements should correspond to the names of the datasets available in the app.
#' If no entry is specified for a dataset, the first six variables from that
#' dataset will initially be shown.
#' @param datasets_selected (`character`) `r lifecycle::badge("deprecated")` A vector of datasets which should be
#' shown and in what order. Use `datanames` instead.
#' @param dt_args (`named list`) Additional arguments to be passed to [DT::datatable()]
#' (must not include `data` or `options`).
#' @param dt_options (`named list`) The `options` argument to `DT::datatable`. By default
#' `list(searching = FALSE, pageLength = 30, lengthMenu = c(5, 15, 30, 100), scrollX = TRUE)`
#' @param server_rendering (`logical`) should the data table be rendered server side
#' (see `server` argument of [DT::renderDataTable()])
#'
#' @inherit shared_params return
#'
#' @examplesShinylive
#' library(teal.modules.general)
#' interactive <- function() TRUE
#' {{ next_example }}
#' @examples
#' # general data example
#' data <- teal_data()
#' data <- within(data, {
#'   require(nestcolor)
#'   iris <- iris
#' })
#'
#' app <- init(
#'   data = data,
#'   modules = modules(
#'     tm_data_table(
#'       variables_selected = list(
#'         iris = c("Sepal.Length", "Sepal.Width", "Petal.Length", "Petal.Width", "Species")
#'       ),
#'       dt_args = list(caption = "IRIS Table Caption")
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
#' @examplesShinylive
#' library(teal.modules.general)
#' interactive <- function() TRUE
#' {{ next_example }}
#' @examples
#' # CDISC data example
#' data <- teal_data()
#' data <- within(data, {
#'   require(nestcolor)
#'   ADSL <- teal.data::rADSL
#' })
#' join_keys(data) <- default_cdisc_join_keys[names(data)]
#'
#' app <- init(
#'   data = data,
#'   modules = modules(
#'     tm_data_table(
#'       variables_selected = list(ADSL = c("STUDYID", "USUBJID", "SUBJID", "SITEID", "AGE", "SEX")),
#'       dt_args = list(caption = "ADSL Table Caption")
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
#' @export
#'
tm_data_table <- function(label = "Data Table",
                          variables_selected = list(),
                          datasets_selected = deprecated(),
                          datanames = if (missing(datasets_selected)) "all" else datasets_selected,
                          dt_args = list(),
                          dt_options = list(
                            searching = FALSE,
                            pageLength = 30,
                            lengthMenu = c(5, 15, 30, 100),
                            scrollX = TRUE
                          ),
                          server_rendering = FALSE,
                          pre_output = NULL,
                          post_output = NULL,
                          transformators = list()) {
  message("Initializing tm_data_table")

  # Start of assertions
  checkmate::assert_string(label)

  checkmate::assert_list(variables_selected, min.len = 0, types = "character", names = "named")
  if (length(variables_selected) > 0) {
    lapply(seq_along(variables_selected), function(i) {
      checkmate::assert_character(variables_selected[[i]], min.chars = 1, min.len = 1)
      if (!is.null(names(variables_selected[[i]]))) {
        checkmate::assert_names(names(variables_selected[[i]]))
      }
    })
  }
  if (!missing(datasets_selected)) {
    lifecycle::deprecate_stop(
      when = "0.4.0",
      what = "tm_data_table(datasets_selected)",
      with = "tm_data_table(datanames)",
      details = 'Use tm_data_table(datanames = "all") to keep the previous behavior and avoid this warning.',
    )
  }
  checkmate::assert_character(datanames, min.len = 0, min.chars = 1, null.ok = TRUE)
  checkmate::assert(
    checkmate::check_list(dt_args, len = 0),
    checkmate::check_subset(names(dt_args), choices = names(formals(DT::datatable)))
  )
  checkmate::assert_list(dt_options, names = "named")
  checkmate::assert_flag(server_rendering)
  checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
  checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)

  # End of assertions

  ans <- module(
    label,
    server = srv_page_data_table,
    ui = ui_page_data_table,
    datanames = datanames,
    server_args = list(
      datanames = if (is.null(datanames)) "all" else datanames,
      variables_selected = variables_selected,
      dt_args = dt_args,
      dt_options = dt_options,
      server_rendering = server_rendering
    ),
    ui_args = list(
      pre_output = pre_output,
      post_output = post_output
    ),
    transformators = transformators
  )
  attr(ans, "teal_bookmarkable") <- TRUE
  ans
}

# UI page module
ui_page_data_table <- function(id, pre_output = NULL, post_output = NULL) {
  ns <- NS(id)

  tagList(
    teal.widgets::standard_layout(
      output = teal.widgets::white_small_well(
        bslib::page_fluid(
          checkboxInput(
            ns("if_distinct"),
            "Show only distinct rows:",
            value = FALSE
          )
        ),
        bslib::page_fluid(
          uiOutput(ns("dataset_table"))
        )
      ),
      pre_output = pre_output,
      post_output = post_output
    )
  )
}

# Server page module
srv_page_data_table <- function(id,
                                data,
                                datanames,
                                variables_selected,
                                dt_args,
                                dt_options,
                                server_rendering) {
  checkmate::assert_class(data, "reactive")
  checkmate::assert_class(isolate(data()), "teal_data")
  moduleServer(id, function(input, output, session) {
    teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")

    if_filtered <- reactive(as.logical(input$if_filtered))
    if_distinct <- reactive(as.logical(input$if_distinct))

    datanames <- Filter(function(name) {
      is.data.frame(isolate(data())[[name]])
    }, if (identical(datanames, "all")) names(isolate(data())) else datanames)


    output$dataset_table <- renderUI({
      do.call(
        tabsetPanel,
        c(
          list(id = session$ns("dataname_tab")),
          lapply(
            datanames,
            function(x) {
              dataset <- isolate(data()[[x]])
              choices <- names(dataset)
              labels <- vapply(
                dataset,
                function(x) ifelse(is.null(attr(x, "label")), "", attr(x, "label")),
                character(1)
              )
              names(choices) <- ifelse(
                is.na(labels) | labels == "",
                choices,
                paste(choices, labels, sep = ": ")
              )
              variables_selected <- if (!is.null(variables_selected[[x]])) {
                variables_selected[[x]]
              } else {
                utils::head(choices)
              }
              tabPanel(
                title = x,
                bslib::layout_columns(
                  col_widths = 12,
                  ui_data_table(
                    id = session$ns(x),
                    choices = choices,
                    selected = variables_selected
                  )
                )
              )
            }
          )
        )
      )
    })

    lapply(
      datanames,
      function(x) {
        srv_data_table(
          id = x,
          data = data,
          dataname = x,
          if_filtered = if_filtered,
          if_distinct = if_distinct,
          dt_args = dt_args,
          dt_options = dt_options,
          server_rendering = server_rendering
        )
      }
    )
  })
}

# UI function for the data_table module
ui_data_table <- function(id, choices, selected) {
  ns <- NS(id)

  if (!is.null(selected)) {
    all_choices <- choices
    choices <- c(selected, setdiff(choices, selected))
    names(choices) <- names(all_choices)[match(choices, all_choices)]
  }

  tagList(
    teal.widgets::get_dt_rows(ns("data_table"), ns("dt_rows")),
    bslib::page_fluid(
      teal.widgets::optionalSelectInput(
        ns("variables"),
        "Select variables:",
        choices = choices,
        selected = selected,
        multiple = TRUE,
        width = "100%"
      )
    ),
    bslib::page_fluid(
      DT::dataTableOutput(ns("data_table"), width = "100%")
    )
  )
}

# Server function for the data_table module
srv_data_table <- function(id,
                           data,
                           dataname,
                           if_filtered,
                           if_distinct,
                           dt_args,
                           dt_options,
                           server_rendering) {
  moduleServer(id, function(input, output, session) {
    iv <- shinyvalidate::InputValidator$new()
    iv$add_rule("variables", shinyvalidate::sv_required("Please select valid variable names"))
    iv$add_rule("variables", shinyvalidate::sv_in_set(
      set = names(isolate(data())[[dataname]]), message_fmt = "Not all selected variables exist in the data"
    ))
    iv$enable()

    data_table_data <- reactive({
      df <- data()[[dataname]]

      teal::validate_has_data(df, min_nrow = 1L, msg = paste("data", dataname, "is empty"))
      qenv <- teal.code::eval_code(
        data(),
        "library(dplyr);library(DT)"
      )
      teal.code::eval_code(
        qenv,
        substitute(
          expr = {
            variables <- vars
            dataframe_selected <- if (if_distinct) {
              dplyr::count(dataname, dplyr::across(dplyr::all_of(variables)))
            } else {
              dataname[variables]
            }
            dt_args <- args
            dt_args$options <- dt_options
            if (!is.null(dt_rows)) {
              dt_args$options$pageLength <- dt_rows
            }
            dt_args$data <- dataframe_selected
            table <- do.call(DT::datatable, dt_args)
          },
          env = list(
            dataname = as.name(dataname),
            if_distinct = if_distinct(),
            vars = input$variables,
            args = dt_args,
            dt_options = dt_options,
            dt_rows = input$dt_rows
          )
        )
      )
    })

    output$data_table <- DT::renderDataTable(server = server_rendering, {
      teal::validate_inputs(iv)
      req(data_table_data())[["table"]]
    })
  })
}

.onLoad <- function(libname, pkgname) {
  teal.logger::register_logger(namespace = "teal.modules.general")
  teal.logger::register_handlers("teal.modules.general")
}

### global variables
ggplot_themes <- c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void")

#' @importFrom lifecycle deprecated
interactive <- NULL

1		#' `teal` module: Cross-table
2		#'
3		#' Generates a simple cross-table of two variables from a dataset with custom
4		#' options for showing percentages and sub-totals.
5		#'
6		#' @inheritParams teal::module
7		#' @inheritParams shared_params
8		#' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`)
9		#' Object with all available choices with pre-selected option for variable X - row values.
10		#' In case of `data_extract_spec` use `select_spec(..., ordered = TRUE)` if table elements should be
11		#' rendered according to selection order.
12		#' @param y (`data_extract_spec` or `list` of multiple `data_extract_spec`)
13		#' Object with all available choices with pre-selected option for variable Y - column values.
14		#'
15		#' `data_extract_spec` must not allow multiple selection in this case.
16		#' @param show_percentage (`logical(1)`)
17		#' Indicates whether to show percentages (relevant only when `x` is a `factor`).
18		#' Defaults to `TRUE`.
19		#' @param show_total (`logical(1)`)
20		#' Indicates whether to show total column.
21		#' Defaults to `TRUE`.
22		#' @param remove_zero_columns (`logical(1)`)
23		#' Indicates whether to remove columns that contain only zeros from the output table.
24		#' Defaults to `FALSE`.
25		#'
26		#' @note For more examples, please see the vignette "Using cross table" via
27		#' `vignette("using-cross-table", package = "teal.modules.general")`.
28		#'
29		#' @inherit shared_params return
30		#'
31		#' @section Table Settings:
32		#' The module provides several table settings that can be adjusted:
33		#' \itemize{
34		#' \item \code{Show column percentage}: Shows column percentages when enabled
35		#' \item \code{Show total column}: Shows a total column when enabled
36		#' \item \code{Remove zero-only columns}: Removes columns that contain only zeros from the output table
37		#' }
38		#'
39		#' @section Decorating Module:
40		#'
41		#' This module generates the following objects, which can be modified in place using decorators:
42		#' - `table` (`ElementaryTable` - output of `rtables::build_table`)
43		#'
44		#' A Decorator is applied to the specific output using a named list of `teal_transform_module` objects.
45		#' The name of this list corresponds to the name of the output to which the decorator is applied.
46		#' See code snippet below:
47		#'
48		#' ```
49		#' tm_t_crosstable(
50		#' ..., # arguments for module
51		#' decorators = list(
52		#' table = teal_transform_module(...) # applied to the `table` output
53		#' )
54		#' )
55		#' ```
56		#' For additional details and examples of decorators, refer to the vignette
57		#' `vignette("decorate-module-output", package = "teal.modules.general")`.
58		#'
59		#' To learn more please refer to the vignette
60		#' `vignette("transform-module-output", package = "teal")` or the [`teal::teal_transform_module()`] documentation.
61		#'
62		#' @inheritSection teal::example_module Reporting
63		#'
64		#' @examplesShinylive
65		#' library(teal.modules.general)
66		#' interactive <- function() TRUE
67		#' {{ next_example }}
68		#' @examples
69		#' # general data example
70		#' data <- teal_data()
71		#' data <- within(data, {
72		#' mtcars <- mtcars
73		#' for (v in c("cyl", "vs", "am", "gear")) {
74		#' mtcars[[v]] <- as.factor(mtcars[[v]])
75		#' }
76		#' mtcars[["primary_key"]] <- seq_len(nrow(mtcars))
77		#' })
78		#' join_keys(data) <- join_keys(join_key("mtcars", "mtcars", "primary_key"))
79		#'
80		#' app <- init(
81		#' data = data,
82		#' modules = modules(
83		#' tm_t_crosstable(
84		#' label = "Cross Table",
85		#' x = data_extract_spec(
86		#' dataname = "mtcars",
87		#' select = select_spec(
88		#' label = "Select variable:",
89		#' choices = variable_choices(data[["mtcars"]], c("cyl", "vs", "am", "gear")),
90		#' selected = c("cyl", "gear"),
91		#' multiple = TRUE,
92		#' ordered = TRUE,
93		#' fixed = FALSE
94		#' )
95		#' ),
96		#' y = data_extract_spec(
97		#' dataname = "mtcars",
98		#' select = select_spec(
99		#' label = "Select variable:",
100		#' choices = variable_choices(data[["mtcars"]], c("cyl", "vs", "am", "gear")),
101		#' selected = "vs",
102		#' multiple = FALSE,
103		#' fixed = FALSE
104		#' )
105		#' )
106		#' )
107		#' )
108		#' )
109		#' if (interactive()) {
110		#' shinyApp(app$ui, app$server)
111		#' }
112		#'
113		#' @examplesShinylive
114		#' library(teal.modules.general)
115		#' interactive <- function() TRUE
116		#' {{ next_example }}
117		#' @examples
118		#' # CDISC data example
119		#' data <- teal_data()
120		#' data <- within(data, {
121		#' ADSL <- teal.data::rADSL
122		#' })
123		#' join_keys(data) <- default_cdisc_join_keys[names(data)]
124		#'
125		#' app <- init(
126		#' data = data,
127		#' modules = modules(
128		#' tm_t_crosstable(
129		#' label = "Cross Table",
130		#' x = data_extract_spec(
131		#' dataname = "ADSL",
132		#' select = select_spec(
133		#' label = "Select variable:",
134		#' choices = variable_choices(data[["ADSL"]], subset = function(data) {
135		#' idx <- !vapply(data, inherits, logical(1), c("Date", "POSIXct", "POSIXlt"))
136		#' return(names(data)[idx])
137		#' }),
138		#' selected = "COUNTRY",
139		#' multiple = TRUE,
140		#' ordered = TRUE,
141		#' fixed = FALSE
142		#' )
143		#' ),
144		#' y = data_extract_spec(
145		#' dataname = "ADSL",
146		#' select = select_spec(
147		#' label = "Select variable:",
148		#' choices = variable_choices(data[["ADSL"]], subset = function(data) {
149		#' idx <- vapply(data, is.factor, logical(1))
150		#' return(names(data)[idx])
151		#' }),
152		#' selected = "SEX",
153		#' multiple = FALSE,
154		#' fixed = FALSE
155		#' )
156		#' )
157		#' )
158		#' )
159		#' )
160		#' if (interactive()) {
161		#' shinyApp(app$ui, app$server)
162		#' }
163		#'
164		#' @export
165		#'
166		tm_t_crosstable <- function(label = "Cross Table",
167		x,
168		y,
169		show_percentage = TRUE,
170		show_total = TRUE,
171		remove_zero_columns = FALSE,
172		pre_output = NULL,
173		post_output = NULL,
174		basic_table_args = teal.widgets::basic_table_args(),
175		transformators = list(),
176		decorators = list()) {
177	!	message("Initializing tm_t_crosstable")
178
179		# Normalize the parameters
180	!	if (inherits(x, "data_extract_spec")) x <- list(x)
181	!	if (inherits(y, "data_extract_spec")) y <- list(y)
182
183		# Start of assertions
184	!	checkmate::assert_string(label)
185	!	checkmate::assert_list(x, types = "data_extract_spec")
186
187	!	checkmate::assert_list(y, types = "data_extract_spec")
188	!	assert_single_selection(y)
189
190	!	checkmate::assert_flag(show_percentage)
191	!	checkmate::assert_flag(show_total)
192	!	checkmate::assert_flag(remove_zero_columns)
193	!	checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
194	!	checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
195	!	checkmate::assert_class(basic_table_args, classes = "basic_table_args")
196
197	!	assert_decorators(decorators, "table")
198		# End of assertions
199
200		# Make UI args
201	!	ui_args <- as.list(environment())
202
203	!	server_args <- list(
204	!	label = label,
205	!	x = x,
206	!	y = y,
207	!	remove_zero_columns = remove_zero_columns,
208	!	basic_table_args = basic_table_args,
209	!	decorators = decorators
210		)
211
212	!	ans <- module(
213	!	label = label,
214	!	server = srv_t_crosstable,
215	!	ui = ui_t_crosstable,
216	!	ui_args = ui_args,
217	!	server_args = server_args,
218	!	transformators = transformators,
219	!	datanames = teal.transform::get_extract_datanames(list(x = x, y = y))
220		)
221	!	attr(ans, "teal_bookmarkable") <- TRUE
222	!	ans
223		}
224
225		# UI function for the cross-table module
226		ui_t_crosstable <- function(id, x, y, show_percentage, show_total, remove_zero_columns, pre_output, post_output, ...) {
227	!	args <- list(...)
228	!	ns <- NS(id)
229	!	is_single_dataset <- teal.transform::is_single_dataset(x, y)
230
231	!	join_default_options <- c(
232	!	"Full Join" = "dplyr::full_join",
233	!	"Inner Join" = "dplyr::inner_join",
234	!	"Left Join" = "dplyr::left_join",
235	!	"Right Join" = "dplyr::right_join"
236		)
237
238	!	teal.widgets::standard_layout(
239	!	output = teal.widgets::white_small_well(
240	!	textOutput(ns("title")),
241	!	teal.widgets::table_with_settings_ui(ns("table"))
242		),
243	!	encoding = tags$div(
244	!	tags$label("Encodings", class = "text-primary"),
245	!	teal.transform::datanames_input(list(x, y)),
246	!	teal.transform::data_extract_ui(ns("x"), label = "Row values", x, is_single_dataset = is_single_dataset),
247	!	teal.transform::data_extract_ui(ns("y"), label = "Column values", y, is_single_dataset = is_single_dataset),
248	!	teal.widgets::optionalSelectInput(
249	!	ns("join_fun"),
250	!	label = "Row to Column type of join",
251	!	choices = join_default_options,
252	!	selected = join_default_options[1],
253	!	multiple = FALSE
254		),
255	!	tags$hr(),
256	!	bslib::accordion(
257	!	open = TRUE,
258	!	bslib::accordion_panel(
259	!	title = "Table settings",
260	!	checkboxInput(ns("show_percentage"), "Show column percentage", value = show_percentage),
261	!	checkboxInput(ns("show_total"), "Show total column", value = show_total),
262	!	checkboxInput(ns("remove_zero_columns"), "Remove zero-only columns", value = remove_zero_columns)
263		)
264		),
265	!	ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "table"))
266		),
267	!	pre_output = pre_output,
268	!	post_output = post_output
269		)
270		}
271
272		# Server function for the cross-table module
273		srv_t_crosstable <- function(id, data, label, x, y, remove_zero_columns, basic_table_args, decorators) {
274	!	checkmate::assert_class(data, "reactive")
275	!	checkmate::assert_class(isolate(data()), "teal_data")
276	!	moduleServer(id, function(input, output, session) {
277	!	teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")
278
279	!	selector_list <- teal.transform::data_extract_multiple_srv(
280	!	data_extract = list(x = x, y = y),
281	!	datasets = data,
282	!	select_validation_rule = list(
283	!	x = shinyvalidate::sv_required("Please define column for row variable."),
284	!	y = shinyvalidate::sv_required("Please define column for column variable.")
285		)
286		)
287
288	!	iv_r <- reactive({
289	!	iv <- shinyvalidate::InputValidator$new()
290	!	iv$add_rule("join_fun", function(value) {
291	!	if (!identical(selector_list()$x()$dataname, selector_list()$y()$dataname)) {
292	!	if (!shinyvalidate::input_provided(value)) {
293	!	"Please select a joining function."
294		}
295		}
296		})
297	!	teal.transform::compose_and_enable_validators(iv, selector_list)
298		})
299
300	!	observeEvent(
301	!	eventExpr = {
302	!	req(!is.null(selector_list()$x()) && !is.null(selector_list()$y()))
303	!	list(selector_list()$x(), selector_list()$y())
304		},
305	!	handlerExpr = {
306	!	if (identical(selector_list()$x()$dataname, selector_list()$y()$dataname)) {
307	!	shinyjs::hide("join_fun")
308		} else {
309	!	shinyjs::show("join_fun")
310		}
311		}
312		)
313
314	!	merge_function <- reactive({
315	!	if (is.null(input$join_fun)) {
316	!	"dplyr::full_join"
317		} else {
318	!	input$join_fun
319		}
320		})
321
322	!	anl_merged_input <- teal.transform::merge_expression_srv(
323	!	datasets = data,
324	!	selector_list = selector_list,
325	!	merge_function = merge_function
326		)
327	!	qenv <- reactive({
328	!	obj <- data()
329	!	teal.reporter::teal_card(obj) <-
330	!	c(
331	!	teal.reporter::teal_card(obj),
332	!	teal.reporter::teal_card("## Module's output(s)")
333		)
334	!	teal.code::eval_code(obj, "library(rtables);library(tern);library(dplyr)")
335		})
336	!	anl_merged_q <- reactive({
337	!	req(anl_merged_input())
338	!	qenv() %>%
339	!	teal.code::eval_code(as.expression(anl_merged_input()$expr))
340		})
341
342	!	merged <- list(
343	!	anl_input_r = anl_merged_input,
344	!	anl_q_r = anl_merged_q
345		)
346
347	!	output_q <- reactive({
348	!	teal::validate_inputs(iv_r())
349	!	ANL <- merged$anl_q_r()[["ANL"]]
350
351		# As this is a summary
352	!	x_name <- as.vector(merged$anl_input_r()$columns_source$x)
353	!	y_name <- as.vector(merged$anl_input_r()$columns_source$y)
354
355	!	teal::validate_has_data(ANL, 3)
356	!	teal::validate_has_data(ANL[, c(x_name, y_name)], 3, complete = TRUE, allow_inf = FALSE)
357
358	!	is_allowed_class <- function(x) is.numeric(x) \|\| is.factor(x) \|\| is.character(x) \|\| is.logical(x)
359	!	validate(need(
360	!	all(vapply(ANL[x_name], is_allowed_class, logical(1))),
361	!	"Selected row variable has an unsupported data type."
362		))
363	!	validate(need(
364	!	is_allowed_class(ANL[[y_name]]),
365	!	"Selected column variable has an unsupported data type."
366		))
367
368	!	show_percentage <- input$show_percentage
369	!	show_total <- input$show_total
370	!	remove_zero_columns <- input$remove_zero_columns
371
372	!	plot_title <- paste(
373	!	"Cross-Table of",
374	!	paste0(varname_w_label(x_name, ANL), collapse = ", "),
375	!	"(rows)", "vs.",
376	!	varname_w_label(y_name, ANL),
377	!	"(columns)"
378		)
379
380	!	labels_vec <- vapply(
381	!	x_name,
382	!	varname_w_label,
383	!	character(1),
384	!	ANL
385		)
386
387	!	obj <- merged$anl_q_r()
388	!	teal.reporter::teal_card(obj) <- c(teal.reporter::teal_card(obj), "### Table")
389	!	obj <- teal.code::eval_code(
390	!	obj,
391	!	substitute(
392	!	expr = {
393	!	title <- plot_title
394		},
395	!	env = list(plot_title = plot_title)
396		)
397		) %>%
398	!	teal.code::eval_code(
399	!	substitute(
400	!	expr = {
401	!	table <- basic_tables %>%
402	!	split_call %>% # styler: off
403	!	rtables::add_colcounts() %>%
404	!	tern::analyze_vars(
405	!	vars = x_name,
406	!	var_labels = labels_vec,
407	!	na.rm = FALSE,
408	!	denom = "N_col",
409	!	.stats = c("mean_sd", "median", "range", count_value)
410		)
411		},
412	!	env = list(
413	!	basic_tables = teal.widgets::parse_basic_table_args(
414	!	basic_table_args = teal.widgets::resolve_basic_table_args(basic_table_args)
415		),
416	!	split_call = if (show_total) {
417	!	substitute(
418	!	expr = rtables::split_cols_by(
419	!	y_name,
420	!	split_fun = rtables::add_overall_level(label = "Total", first = FALSE)
421		),
422	!	env = list(y_name = y_name)
423		)
424		} else {
425	!	substitute(rtables::split_cols_by(y_name), env = list(y_name = y_name))
426		},
427	!	x_name = x_name,
428	!	labels_vec = labels_vec,
429	!	count_value = ifelse(show_percentage, "count_fraction", "count")
430		)
431		)
432		) %>%
433	!	teal.code::eval_code(
434	!	expression(ANL <- tern::df_explicit_na(ANL))
435		)
436
437	!	if (remove_zero_columns) {
438	!	obj <- obj %>%
439	!	teal.code::eval_code(
440	!	substitute(
441	!	expr = {
442	!	ANL[[y_name]] <- droplevels(ANL[[y_name]])
443	!	table <- rtables::build_table(lyt = table, df = ANL[order(ANL[[y_name]]), ])
444		},
445	!	env = list(y_name = y_name)
446		)
447		)
448		} else {
449	!	obj <- obj %>%
450	!	teal.code::eval_code(
451	!	substitute(
452	!	expr = {
453	!	table <- rtables::build_table(lyt = table, df = ANL[order(ANL[[y_name]]), ])
454		},
455	!	env = list(y_name = y_name)
456		)
457		)
458		}
459	!	obj
460		})
461
462	!	decorated_output_q <- srv_decorate_teal_data(
463	!	id = "decorator",
464	!	data = output_q,
465	!	decorators = select_decorators(decorators, "table"),
466	!	expr = quote(table)
467		)
468
469	!	output$title <- renderText(req(decorated_output_q())[["title"]])
470
471	!	table_r <- reactive({
472	!	req(iv_r()$is_valid())
473	!	req(decorated_output_q())[["table"]]
474		})
475
476	!	teal.widgets::table_with_settings_srv(
477	!	id = "table",
478	!	table_r = table_r
479		)
480
481	!	decorated_output_q
482		})
483		}

1		#' `teal` module: Response plot
2		#'
3		#' Generates a response plot for a given `response` and `x` variables.
4		#' This module allows users customize and add annotations to the plot depending
5		#' on the module's arguments.
6		#' It supports showing the counts grouped by other variable facets (by row / column),
7		#' swapping the coordinates, show count annotations and displaying the response plot
8		#' as frequency or density.
9		#'
10		#' @inheritParams teal::module
11		#' @inheritParams shared_params
12		#' @param response (`data_extract_spec` or `list` of multiple `data_extract_spec`)
13		#' Which variable to use as the response.
14		#' You can define one fixed column by setting `fixed = TRUE` inside the `select_spec`.
15		#'
16		#' The `data_extract_spec` must not allow multiple selection in this case.
17		#' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`)
18		#' Specifies which variable to use on the X-axis of the response plot.
19		#' Allow the user to select multiple columns from the `data` allowed in teal.
20		#'
21		#' The `data_extract_spec` must not allow multiple selection in this case.
22		#' @param row_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`)
23		#' optional specification of the data variable(s) to use for faceting rows.
24		#' @param col_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`)
25		#' optional specification of the data variable(s) to use for faceting columns.
26		#' @param coord_flip (`logical(1)`)
27		#' Indicates whether to flip coordinates between `x` and `response`.
28		#' The default value is `FALSE` and it will show the `x` variable on the x-axis
29		#' and the `response` variable on the y-axis.
30		#' @param count_labels (`logical(1)`)
31		#' Indicates whether to show count labels.
32		#' Defaults to `TRUE`.
33		#' @param freq (`logical(1)`)
34		#' Indicates whether to display frequency (`TRUE`) or density (`FALSE`).
35		#' Defaults to density (`FALSE`).
36		#'
37		#' @inherit shared_params return
38		#'
39		#' @note For more examples, please see the vignette "Using response plot" via
40		#' `vignette("using-response-plot", package = "teal.modules.general")`.
41		#'
42		#' @section Decorating Module:
43		#'
44		#' This module generates the following objects, which can be modified in place using decorators:
45		#' - `plot` (`ggplot`)
46		#'
47		#' A Decorator is applied to the specific output using a named list of `teal_transform_module` objects.
48		#' The name of this list corresponds to the name of the output to which the decorator is applied.
49		#' See code snippet below:
50		#'
51		#' ```
52		#' tm_g_response(
53		#' ..., # arguments for module
54		#' decorators = list(
55		#' plot = teal_transform_module(...) # applied to the `plot` output
56		#' )
57		#' )
58		#' ```
59		#'
60		#' For additional details and examples of decorators, refer to the vignette
61		#' `vignette("decorate-module-output", package = "teal.modules.general")`.
62		#'
63		#' To learn more please refer to the vignette
64		#' `vignette("transform-module-output", package = "teal")` or the [`teal::teal_transform_module()`] documentation.
65		#'
66		#' @inheritSection teal::example_module Reporting
67		#'
68		#' @examplesShinylive
69		#' library(teal.modules.general)
70		#' interactive <- function() TRUE
71		#' {{ next_example }}
72		#' @examples
73		#' # general data example
74		#' data <- teal_data()
75		#' data <- within(data, {
76		#' require(nestcolor)
77		#' mtcars <- mtcars
78		#' for (v in c("cyl", "vs", "am", "gear")) {
79		#' mtcars[[v]] <- as.factor(mtcars[[v]])
80		#' }
81		#' })
82		#'
83		#' app <- init(
84		#' data = data,
85		#' modules = modules(
86		#' tm_g_response(
87		#' label = "Response Plots",
88		#' response = data_extract_spec(
89		#' dataname = "mtcars",
90		#' select = select_spec(
91		#' label = "Select variable:",
92		#' choices = variable_choices(data[["mtcars"]], c("cyl", "gear")),
93		#' selected = "cyl",
94		#' multiple = FALSE,
95		#' fixed = FALSE
96		#' )
97		#' ),
98		#' x = data_extract_spec(
99		#' dataname = "mtcars",
100		#' select = select_spec(
101		#' label = "Select variable:",
102		#' choices = variable_choices(data[["mtcars"]], c("vs", "am")),
103		#' selected = "vs",
104		#' multiple = FALSE,
105		#' fixed = FALSE
106		#' )
107		#' )
108		#' )
109		#' )
110		#' )
111		#' if (interactive()) {
112		#' shinyApp(app$ui, app$server)
113		#' }
114		#'
115		#' @examplesShinylive
116		#' library(teal.modules.general)
117		#' interactive <- function() TRUE
118		#' {{ next_example }}
119		#' @examples
120		#' # CDISC data example
121		#' data <- teal_data()
122		#' data <- within(data, {
123		#' require(nestcolor)
124		#' ADSL <- teal.data::rADSL
125		#' })
126		#' join_keys(data) <- default_cdisc_join_keys[names(data)]
127		#'
128		#' app <- init(
129		#' data = data,
130		#' modules = modules(
131		#' tm_g_response(
132		#' label = "Response Plots",
133		#' response = data_extract_spec(
134		#' dataname = "ADSL",
135		#' select = select_spec(
136		#' label = "Select variable:",
137		#' choices = variable_choices(data[["ADSL"]], c("BMRKR2", "COUNTRY")),
138		#' selected = "BMRKR2",
139		#' multiple = FALSE,
140		#' fixed = FALSE
141		#' )
142		#' ),
143		#' x = data_extract_spec(
144		#' dataname = "ADSL",
145		#' select = select_spec(
146		#' label = "Select variable:",
147		#' choices = variable_choices(data[["ADSL"]], c("SEX", "RACE")),
148		#' selected = "RACE",
149		#' multiple = FALSE,
150		#' fixed = FALSE
151		#' )
152		#' )
153		#' )
154		#' )
155		#' )
156		#' if (interactive()) {
157		#' shinyApp(app$ui, app$server)
158		#' }
159		#'
160		#' @export
161		#'
162		tm_g_response <- function(label = "Response Plot",
163		response,
164		x,
165		row_facet = NULL,
166		col_facet = NULL,
167		coord_flip = FALSE,
168		count_labels = TRUE,
169		rotate_xaxis_labels = FALSE,
170		freq = FALSE,
171		plot_height = c(600, 400, 5000),
172		plot_width = NULL,
173		ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
174		ggplot2_args = teal.widgets::ggplot2_args(),
175		pre_output = NULL,
176		post_output = NULL,
177		transformators = list(),
178		decorators = list()) {
179	!	message("Initializing tm_g_response")
180
181		# Normalize the parameters
182	!	if (inherits(response, "data_extract_spec")) response <- list(response)
183	!	if (inherits(x, "data_extract_spec")) x <- list(x)
184	!	if (inherits(row_facet, "data_extract_spec")) row_facet <- list(row_facet)
185	!	if (inherits(col_facet, "data_extract_spec")) col_facet <- list(col_facet)
186
187		# Start of assertions
188	!	checkmate::assert_string(label)
189
190	!	checkmate::assert_list(response, types = "data_extract_spec")
191	!	if (!all(vapply(response, function(x) !("" %in% x$select$choices), logical(1)))) {
192	!	stop("'response' should not allow empty values")
193		}
194	!	assert_single_selection(response)
195
196	!	checkmate::assert_list(x, types = "data_extract_spec")
197	!	if (!all(vapply(x, function(x) !("" %in% x$select$choices), logical(1)))) {
198	!	stop("'x' should not allow empty values")
199		}
200	!	assert_single_selection(x)
201
202	!	checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE)
203	!	checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE)
204	!	checkmate::assert_flag(coord_flip)
205	!	checkmate::assert_flag(count_labels)
206	!	checkmate::assert_flag(rotate_xaxis_labels)
207	!	checkmate::assert_flag(freq)
208
209	!	checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
210	!	checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")
211	!	checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
212	!	checkmate::assert_numeric(
213	!	plot_width[1],
214	!	lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"
215		)
216
217	!	ggtheme <- match.arg(ggtheme)
218	!	checkmate::assert_class(ggplot2_args, "ggplot2_args")
219
220	!	checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
221	!	checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
222
223	!	assert_decorators(decorators, "plot")
224		# End of assertions
225
226		# Make UI args
227	!	args <- as.list(environment())
228
229	!	data_extract_list <- list(
230	!	response = response,
231	!	x = x,
232	!	row_facet = row_facet,
233	!	col_facet = col_facet
234		)
235
236	!	ans <- module(
237	!	label = label,
238	!	server = srv_g_response,
239	!	ui = ui_g_response,
240	!	ui_args = args,
241	!	server_args = c(
242	!	data_extract_list,
243	!	list(
244	!	plot_height = plot_height,
245	!	plot_width = plot_width,
246	!	ggplot2_args = ggplot2_args,
247	!	decorators = decorators
248		)
249		),
250	!	transformators = transformators,
251	!	datanames = teal.transform::get_extract_datanames(data_extract_list)
252		)
253	!	attr(ans, "teal_bookmarkable") <- TRUE
254	!	ans
255		}
256
257		# UI function for the response module
258		ui_g_response <- function(id, ...) {
259	!	ns <- NS(id)
260	!	args <- list(...)
261	!	is_single_dataset_value <- teal.transform::is_single_dataset(args$response, args$x, args$row_facet, args$col_facet)
262
263	!	teal.widgets::standard_layout(
264	!	output = teal.widgets::white_small_well(
265	!	teal.widgets::plot_with_settings_ui(id = ns("myplot"))
266		),
267	!	encoding = tags$div(
268	!	tags$label("Encodings", class = "text-primary"),
269	!	teal.transform::datanames_input(args[c("response", "x", "row_facet", "col_facet")]),
270	!	teal.transform::data_extract_ui(
271	!	id = ns("response"),
272	!	label = "Response variable",
273	!	data_extract_spec = args$response,
274	!	is_single_dataset = is_single_dataset_value
275		),
276	!	teal.transform::data_extract_ui(
277	!	id = ns("x"),
278	!	label = "X variable",
279	!	data_extract_spec = args$x,
280	!	is_single_dataset = is_single_dataset_value
281		),
282	!	if (!is.null(args$row_facet)) {
283	!	teal.transform::data_extract_ui(
284	!	id = ns("row_facet"),
285	!	label = "Row facetting",
286	!	data_extract_spec = args$row_facet,
287	!	is_single_dataset = is_single_dataset_value
288		)
289		},
290	!	if (!is.null(args$col_facet)) {
291	!	teal.transform::data_extract_ui(
292	!	id = ns("col_facet"),
293	!	label = "Column facetting",
294	!	data_extract_spec = args$col_facet,
295	!	is_single_dataset = is_single_dataset_value
296		)
297		},
298	!	shinyWidgets::radioGroupButtons(
299	!	inputId = ns("freq"),
300	!	label = NULL,
301	!	choices = c("frequency", "density"),
302	!	selected = ifelse(args$freq, "frequency", "density"),
303	!	justified = TRUE
304		),
305	!	ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "plot")),
306	!	bslib::accordion(
307	!	open = TRUE,
308	!	bslib::accordion_panel(
309	!	title = "Plot settings",
310	!	checkboxInput(ns("count_labels"), "Add count labels", value = args$count_labels),
311	!	checkboxInput(ns("coord_flip"), "Swap axes", value = args$coord_flip),
312	!	checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels),
313	!	selectInput(
314	!	inputId = ns("ggtheme"),
315	!	label = "Theme (by ggplot):",
316	!	choices = ggplot_themes,
317	!	selected = args$ggtheme,
318	!	multiple = FALSE
319		)
320		)
321		)
322		),
323	!	pre_output = args$pre_output,
324	!	post_output = args$post_output
325		)
326		}
327
328		# Server function for the response module
329		srv_g_response <- function(id,
330		data,
331		response,
332		x,
333		row_facet,
334		col_facet,
335		plot_height,
336		plot_width,
337		ggplot2_args,
338		decorators) {
339	!	checkmate::assert_class(data, "reactive")
340	!	checkmate::assert_class(isolate(data()), "teal_data")
341	!	moduleServer(id, function(input, output, session) {
342	!	teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")
343
344	!	data_extract <- list(response = response, x = x, row_facet = row_facet, col_facet = col_facet)
345
346	!	rule_diff <- function(other) {
347	!	function(value) {
348	!	if (other %in% names(selector_list())) {
349	!	othervalue <- selector_list()[[other]]()[["select"]]
350	!	if (!is.null(othervalue)) {
351	!	if (identical(value, othervalue)) {
352	!	"Row and column facetting variables must be different."
353		}
354		}
355		}
356		}
357		}
358
359	!	selector_list <- teal.transform::data_extract_multiple_srv(
360	!	data_extract = data_extract,
361	!	datasets = data,
362	!	select_validation_rule = list(
363	!	response = shinyvalidate::sv_required("Please define a column for the response variable"),
364	!	x = shinyvalidate::sv_required("Please define a column for X variable"),
365	!	row_facet = shinyvalidate::compose_rules(
366	!	shinyvalidate::sv_optional(),
367	!	~ if (length(.) > 1) "There must be 1 or no row facetting variable.",
368	!	rule_diff("col_facet")
369		),
370	!	col_facet = shinyvalidate::compose_rules(
371	!	shinyvalidate::sv_optional(),
372	!	~ if (length(.) > 1) "There must be 1 or no column facetting variable.",
373	!	rule_diff("row_facet")
374		)
375		)
376		)
377
378	!	iv_r <- reactive({
379	!	iv <- shinyvalidate::InputValidator$new()
380	!	iv$add_rule("ggtheme", shinyvalidate::sv_required("Please select a theme"))
381	!	teal.transform::compose_and_enable_validators(iv, selector_list)
382		})
383
384	!	anl_merged_input <- teal.transform::merge_expression_srv(
385	!	selector_list = selector_list,
386	!	datasets = data
387		)
388
389	!	qenv <- reactive(
390	!	teal.code::eval_code(data(), "library(ggplot2);library(dplyr)")
391		)
392
393	!	anl_merged_q <- reactive({
394	!	req(anl_merged_input())
395	!	qenv() %>%
396	!	teal.code::eval_code(as.expression(anl_merged_input()$expr))
397		})
398
399	!	merged <- list(
400	!	anl_input_r = anl_merged_input,
401	!	anl_q_r = anl_merged_q
402		)
403
404	!	output_q <- reactive({
405	!	teal::validate_inputs(iv_r())
406
407	!	qenv <- merged$anl_q_r()
408	!	teal.reporter::teal_card(qenv) <-
409	!	c(
410	!	teal.reporter::teal_card(qenv),
411	!	teal.reporter::teal_card("## Module's output(s)")
412		)
413	!	ANL <- qenv[["ANL"]]
414	!	resp_var <- as.vector(merged$anl_input_r()$columns_source$response)
415	!	x <- as.vector(merged$anl_input_r()$columns_source$x)
416
417	!	validate(need(is.factor(ANL[[resp_var]]), "Please select a factor variable as the response."))
418	!	validate(need(is.factor(ANL[[x]]), "Please select a factor variable as the X-Variable."))
419	!	teal::validate_has_data(ANL, 10)
420	!	teal::validate_has_data(ANL[, c(resp_var, x)], 10, complete = TRUE, allow_inf = FALSE)
421
422	!	row_facet_name <- if (length(merged$anl_input_r()$columns_source$row_facet) == 0) {
423	!	character(0)
424		} else {
425	!	as.vector(merged$anl_input_r()$columns_source$row_facet)
426		}
427	!	col_facet_name <- if (length(merged$anl_input_r()$columns_source$col_facet) == 0) {
428	!	character(0)
429		} else {
430	!	as.vector(merged$anl_input_r()$columns_source$col_facet)
431		}
432
433	!	freq <- input$freq == "frequency"
434	!	swap_axes <- input$coord_flip
435	!	counts <- input$count_labels
436	!	rotate_xaxis_labels <- input$rotate_xaxis_labels
437	!	ggtheme <- input$ggtheme
438
439	!	arg_position <- if (freq) "stack" else "fill"
440
441	!	rowf <- if (length(row_facet_name) != 0) as.name(row_facet_name)
442	!	colf <- if (length(col_facet_name) != 0) as.name(col_facet_name)
443	!	resp_cl <- as.name(resp_var)
444	!	x_cl <- as.name(x)
445
446	!	if (swap_axes) {
447	!	qenv <- teal.code::eval_code(
448	!	qenv,
449	!	substitute(
450	!	expr = ANL[[x]] <- with(ANL, forcats::fct_rev(x_cl)),
451	!	env = list(x = x, x_cl = x_cl)
452		)
453		)
454		}
455
456	!	qenv <- teal.code::eval_code(
457	!	qenv,
458	!	substitute(
459	!	expr = ANL[[resp_var]] <- factor(ANL[[resp_var]]),
460	!	env = list(resp_var = resp_var)
461		)
462		) %>%
463		# rowf and colf will be a NULL if not set by a user
464	!	teal.code::eval_code(
465	!	substitute(
466	!	expr = ANL2 <- ANL %>%
467	!	dplyr::group_by_at(dplyr::vars(x_cl, resp_cl, rowf, colf)) %>%
468	!	dplyr::summarise(ns = dplyr::n()) %>%
469	!	dplyr::group_by_at(dplyr::vars(x_cl, rowf, colf)) %>%
470	!	dplyr::mutate(sums = sum(ns), percent = round(ns / sums * 100, 1)),
471	!	env = list(x_cl = x_cl, resp_cl = resp_cl, rowf = rowf, colf = colf)
472		)
473		) %>%
474	!	teal.code::eval_code(
475	!	substitute(
476	!	expr = ANL3 <- ANL %>%
477	!	dplyr::group_by_at(dplyr::vars(x_cl, rowf, colf)) %>%
478	!	dplyr::summarise(ns = dplyr::n()),
479	!	env = list(x_cl = x_cl, rowf = rowf, colf = colf)
480		)
481		)
482
483	!	plot_call <- substitute(
484	!	expr = ggplot2::ggplot(ANL2, ggplot2::aes(x = x_cl, y = ns)) +
485	!	ggplot2::geom_bar(ggplot2::aes(fill = resp_cl), stat = "identity", position = arg_position),
486	!	env = list(
487	!	x_cl = x_cl,
488	!	resp_cl = resp_cl,
489	!	arg_position = arg_position
490		)
491		)
492
493	!	if (!freq) {
494	!	plot_call <- substitute(
495	!	plot_call + ggplot2::expand_limits(y = c(0, 1.1)),
496	!	env = list(plot_call = plot_call)
497		)
498		}
499
500	!	if (counts) {
501	!	plot_call <- substitute(
502	!	expr = plot_call +
503	!	ggplot2::geom_text(
504	!	data = ANL2,
505	!	ggplot2::aes(label = ns, x = x_cl, y = ns, group = resp_cl),
506	!	col = "white",
507	!	vjust = "middle",
508	!	hjust = "middle",
509	!	position = position_anl2_value
510		) +
511	!	ggplot2::geom_text(
512	!	data = ANL3, ggplot2::aes(label = ns, x = x_cl, y = anl3_y),
513	!	hjust = hjust_value,
514	!	vjust = vjust_value,
515	!	position = position_anl3_value
516		),
517	!	env = list(
518	!	plot_call = plot_call,
519	!	x_cl = x_cl,
520	!	resp_cl = resp_cl,
521	!	hjust_value = if (swap_axes) "left" else "middle",
522	!	vjust_value = if (swap_axes) "middle" else -1,
523	!	position_anl2_value = if (!freq) quote(position_fill(0.5)) else quote(position_stack(0.5)), # nolint: line_length_linter.
524	!	anl3_y = if (!freq) 1.1 else as.name("ns"),
525	!	position_anl3_value = if (!freq) "fill" else "stack"
526		)
527		)
528		}
529
530	!	if (swap_axes) {
531	!	plot_call <- substitute(plot_call + coord_flip(), env = list(plot_call = plot_call))
532		}
533
534	!	facet_cl <- facet_ggplot_call(row_facet_name, col_facet_name)
535
536	!	if (!is.null(facet_cl)) {
537	!	plot_call <- substitute(expr = plot_call + facet_cl, env = list(plot_call = plot_call, facet_cl = facet_cl))
538		}
539
540	!	dev_ggplot2_args <- teal.widgets::ggplot2_args(
541	!	labs = list(
542	!	x = varname_w_label(x, ANL),
543	!	y = varname_w_label(resp_var, ANL, prefix = "Proportion of "),
544	!	fill = varname_w_label(resp_var, ANL)
545		),
546	!	theme = list(legend.position = "bottom")
547		)
548
549	!	if (rotate_xaxis_labels) {
550	!	dev_ggplot2_args$theme[["axis.text.x"]] <- quote(ggplot2::element_text(angle = 45, hjust = 1))
551		}
552
553	!	all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(
554	!	user_plot = ggplot2_args,
555	!	module_plot = dev_ggplot2_args
556		)
557
558	!	parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(
559	!	all_ggplot2_args,
560	!	ggtheme = ggtheme
561		)
562
563	!	plot_call <- substitute(expr = {
564	!	plot <- plot_call + labs + ggthemes + themes
565	!	}, env = list(
566	!	plot_call = plot_call,
567	!	labs = parsed_ggplot2_args$labs,
568	!	themes = parsed_ggplot2_args$theme,
569	!	ggthemes = parsed_ggplot2_args$ggtheme
570		))
571
572	!	teal.reporter::teal_card(qenv) <- c(teal.reporter::teal_card(qenv), "### Plot")
573	!	teal.code::eval_code(qenv, plot_call)
574		})
575
576	!	decorated_output_plot_q <- srv_decorate_teal_data(
577	!	id = "decorator",
578	!	data = output_q,
579	!	decorators = select_decorators(decorators, "plot"),
580	!	expr = quote(plot)
581		)
582
583	!	plot_r <- reactive(req(decorated_output_plot_q())[["plot"]])
584
585		# Insert the plot into a plot_with_settings module from teal.widgets
586	!	pws <- teal.widgets::plot_with_settings_srv(
587	!	id = "myplot",
588	!	plot_r = plot_r,
589	!	height = plot_height,
590	!	width = plot_width
591		)
592
593	!	set_chunk_dims(pws, decorated_output_plot_q)
594		})
595		}

1		#' `teal` module: Stack plots of variables and show association with reference variable
2		#'
3		#' Module provides functionality for visualizing the distribution of variables and
4		#' their association with a reference variable.
5		#' It supports configuring the appearance of the plots, including themes and whether to show associations.
6		#'
7		#'
8		#' @note For more examples, please see the vignette "Using association plot" via
9		#' `vignette("using-association-plot", package = "teal.modules.general")`.
10		#'
11		#' @inheritParams teal::module
12		#' @inheritParams shared_params
13		#' @param ref (`data_extract_spec` or `list` of multiple `data_extract_spec`)
14		#' Reference variable, must accepts a `data_extract_spec` with `select_spec(multiple = FALSE)`
15		#' to ensure single selection option.
16		#' @param vars (`data_extract_spec` or `list` of multiple `data_extract_spec`)
17		#' Variables to be associated with the reference variable.
18		#' @param show_association (`logical`) optional, whether show association of `vars`
19		#' with reference variable. Defaults to `TRUE`.
20		#' @param distribution_theme,association_theme (`character`) optional, `ggplot2` themes to be used by default.
21		#' Default to `"gray"`.
22		#'
23		#' @param ggplot2_args `r roxygen_ggplot2_args_param("Bivariate1", "Bivariate2")`
24		#'
25		#' @inherit shared_params return
26		#'
27		#' @section Decorating Module:
28		#'
29		#' This module generates the following objects, which can be modified in place using decorators:
30		#' - `plot` (`grob` created with [ggplot2::ggplotGrob()])
31		#'
32		#' A Decorator is applied to the specific output using a named list of `teal_transform_module` objects.
33		#' The name of this list corresponds to the name of the output to which the decorator is applied.
34		#' See code snippet below:
35		#'
36		#' ```
37		#' tm_g_association(
38		#' ..., # arguments for module
39		#' decorators = list(
40		#' plot = teal_transform_module(...) # applied to the `plot` output
41		#' )
42		#' )
43		#' ```
44		#'
45		#' For additional details and examples of decorators, refer to the vignette
46		#' `vignette("decorate-module-output", package = "teal.modules.general")`.
47		#'
48		#' To learn more please refer to the vignette
49		#' `vignette("transform-module-output", package = "teal")` or the [`teal::teal_transform_module()`] documentation.
50		#'
51		#' @inheritSection teal::example_module Reporting
52		#'
53		#' @examplesShinylive
54		#' library(teal.modules.general)
55		#' interactive <- function() TRUE
56		#' {{ next_example }}
57		#' @examples
58		#' # general data example
59		#' data <- teal_data()
60		#' data <- within(data, {
61		#' require(nestcolor)
62		#' CO2 <- CO2
63		#' factors <- names(Filter(isTRUE, vapply(CO2, is.factor, logical(1L))))
64		#' CO2[factors] <- lapply(CO2[factors], as.character)
65		#' })
66		#'
67		#' app <- init(
68		#' data = data,
69		#' modules = modules(
70		#' tm_g_association(
71		#' ref = data_extract_spec(
72		#' dataname = "CO2",
73		#' select = select_spec(
74		#' label = "Select variable:",
75		#' choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")),
76		#' selected = "Plant",
77		#' fixed = FALSE
78		#' )
79		#' ),
80		#' vars = data_extract_spec(
81		#' dataname = "CO2",
82		#' select = select_spec(
83		#' label = "Select variables:",
84		#' choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")),
85		#' selected = "Treatment",
86		#' multiple = TRUE,
87		#' fixed = FALSE
88		#' )
89		#' )
90		#' )
91		#' )
92		#' )
93		#' if (interactive()) {
94		#' shinyApp(app$ui, app$server)
95		#' }
96		#'
97		#' @examplesShinylive
98		#' library(teal.modules.general)
99		#' interactive <- function() TRUE
100		#' {{ next_example }}
101		#' @examples
102		#' # CDISC data example
103		#' data <- teal_data()
104		#' data <- within(data, {
105		#' require(nestcolor)
106		#' ADSL <- teal.data::rADSL
107		#' })
108		#' join_keys(data) <- default_cdisc_join_keys[names(data)]
109		#'
110		#' app <- init(
111		#' data = data,
112		#' modules = modules(
113		#' tm_g_association(
114		#' ref = data_extract_spec(
115		#' dataname = "ADSL",
116		#' select = select_spec(
117		#' label = "Select variable:",
118		#' choices = variable_choices(
119		#' data[["ADSL"]],
120		#' c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2")
121		#' ),
122		#' selected = "RACE",
123		#' fixed = FALSE
124		#' )
125		#' ),
126		#' vars = data_extract_spec(
127		#' dataname = "ADSL",
128		#' select = select_spec(
129		#' label = "Select variables:",
130		#' choices = variable_choices(
131		#' data[["ADSL"]],
132		#' c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2")
133		#' ),
134		#' selected = "BMRKR2",
135		#' multiple = TRUE,
136		#' fixed = FALSE
137		#' )
138		#' )
139		#' )
140		#' )
141		#' )
142		#' if (interactive()) {
143		#' shinyApp(app$ui, app$server)
144		#' }
145		#'
146		#' @export
147		#'
148		tm_g_association <- function(label = "Association",
149		ref,
150		vars,
151		show_association = TRUE,
152		plot_height = c(600, 400, 5000),
153		plot_width = NULL,
154		distribution_theme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), # nolint line_length_linter.
155		association_theme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), # nolint line_length_linter.
156		pre_output = NULL,
157		post_output = NULL,
158		ggplot2_args = teal.widgets::ggplot2_args(),
159		transformators = list(),
160		decorators = list()) {
161	!	message("Initializing tm_g_association")
162
163		# Normalize the parameters
164	!	if (inherits(ref, "data_extract_spec")) ref <- list(ref)
165	!	if (inherits(vars, "data_extract_spec")) vars <- list(vars)
166	!	if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)
167
168		# Start of assertions
169	!	checkmate::assert_string(label)
170
171	!	checkmate::assert_list(ref, types = "data_extract_spec")
172	!	if (!all(vapply(ref, function(x) !x$select$multiple, logical(1)))) {
173	!	stop("'ref' should not allow multiple selection")
174		}
175
176	!	checkmate::assert_list(vars, types = "data_extract_spec")
177	!	checkmate::assert_flag(show_association)
178
179	!	checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
180	!	checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")
181	!	checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
182	!	checkmate::assert_numeric(
183	!	plot_width[1],
184	!	lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"
185		)
186
187	!	distribution_theme <- match.arg(distribution_theme)
188	!	association_theme <- match.arg(association_theme)
189
190	!	checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
191	!	checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
192
193	!	plot_choices <- c("Bivariate1", "Bivariate2")
194	!	checkmate::assert_list(ggplot2_args, types = "ggplot2_args")
195	!	checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
196
197	!	assert_decorators(decorators, "plot")
198		# End of assertions
199
200		# Make UI args
201	!	args <- as.list(environment())
202
203	!	data_extract_list <- list(
204	!	ref = ref,
205	!	vars = vars
206		)
207
208	!	ans <- module(
209	!	label = label,
210	!	server = srv_tm_g_association,
211	!	ui = ui_tm_g_association,
212	!	ui_args = args,
213	!	server_args = c(
214	!	data_extract_list,
215	!	list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args, decorators = decorators)
216		),
217	!	transformators = transformators,
218	!	datanames = teal.transform::get_extract_datanames(data_extract_list)
219		)
220	!	attr(ans, "teal_bookmarkable") <- TRUE
221	!	ans
222		}
223
224		# UI function for the association module
225		ui_tm_g_association <- function(id, ...) {
226	!	ns <- NS(id)
227	!	args <- list(...)
228	!	is_single_dataset_value <- teal.transform::is_single_dataset(args$ref, args$vars)
229
230	!	teal.widgets::standard_layout(
231	!	output = teal.widgets::white_small_well(
232	!	textOutput(ns("title")),
233	!	tags$br(),
234	!	teal.widgets::plot_with_settings_ui(id = ns("myplot"))
235		),
236	!	encoding = tags$div(
237	!	tags$label("Encodings", class = "text-primary"),
238	!	teal.transform::datanames_input(args[c("ref", "vars")]),
239	!	teal.transform::data_extract_ui(
240	!	id = ns("ref"),
241	!	label = "Reference variable",
242	!	data_extract_spec = args$ref,
243	!	is_single_dataset = is_single_dataset_value
244		),
245	!	teal.transform::data_extract_ui(
246	!	id = ns("vars"),
247	!	label = "Associated variables",
248	!	data_extract_spec = args$vars,
249	!	is_single_dataset = is_single_dataset_value
250		),
251	!	checkboxInput(
252	!	ns("association"),
253	!	"Association with reference variable",
254	!	value = args$show_association
255		),
256	!	checkboxInput(
257	!	ns("show_dist"),
258	!	"Scaled frequencies",
259	!	value = FALSE
260		),
261	!	checkboxInput(
262	!	ns("log_transformation"),
263	!	"Log transformed",
264	!	value = FALSE
265		),
266	!	ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "plot")),
267	!	bslib::accordion(
268	!	open = TRUE,
269	!	bslib::accordion_panel(
270	!	title = "Plot settings",
271	!	teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Scatterplot opacity:", c(0.5, 0, 1), ticks = FALSE),
272	!	teal.widgets::optionalSliderInputValMinMax(ns("size"), "Scatterplot points size:", c(2, 1, 8), ticks = FALSE),
273	!	checkboxInput(ns("swap_axes"), "Swap axes", value = FALSE),
274	!	checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = FALSE),
275	!	selectInput(
276	!	inputId = ns("distribution_theme"),
277	!	label = "Distribution theme (by ggplot):",
278	!	choices = ggplot_themes,
279	!	selected = args$distribution_theme,
280	!	multiple = FALSE
281		),
282	!	selectInput(
283	!	inputId = ns("association_theme"),
284	!	label = "Association theme (by ggplot):",
285	!	choices = ggplot_themes,
286	!	selected = args$association_theme,
287	!	multiple = FALSE
288		)
289		)
290		)
291		),
292	!	pre_output = args$pre_output,
293	!	post_output = args$post_output
294		)
295		}
296
297		# Server function for the association module
298		srv_tm_g_association <- function(id,
299		data,
300		ref,
301		vars,
302		plot_height,
303		plot_width,
304		ggplot2_args,
305		decorators) {
306	!	checkmate::assert_class(data, "reactive")
307	!	checkmate::assert_class(isolate(data()), "teal_data")
308
309	!	moduleServer(id, function(input, output, session) {
310	!	teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")
311
312	!	selector_list <- teal.transform::data_extract_multiple_srv(
313	!	data_extract = list(ref = ref, vars = vars),
314	!	datasets = data,
315	!	select_validation_rule = list(
316	!	ref = shinyvalidate::compose_rules(
317	!	shinyvalidate::sv_required("A reference variable needs to be selected."),
318	!	~ if ((.) %in% selector_list()$vars()$select) {
319	!	"Associated variables and reference variable cannot overlap"
320		}
321		),
322	!	vars = shinyvalidate::compose_rules(
323	!	shinyvalidate::sv_required("An associated variable needs to be selected."),
324	!	~ if (length(selector_list()$ref()$select) != 0 && selector_list()$ref()$select %in% (.)) {
325	!	"Associated variables and reference variable cannot overlap"
326		}
327		)
328		)
329		)
330
331	!	iv_r <- reactive({
332	!	iv <- shinyvalidate::InputValidator$new()
333	!	teal.transform::compose_and_enable_validators(iv, selector_list)
334		})
335
336	!	anl_merged_input <- teal.transform::merge_expression_srv(
337	!	datasets = data,
338	!	selector_list = selector_list
339		)
340
341	!	qenv <- reactive({
342	!	obj <- data()
343	!	teal.reporter::teal_card(obj) <-
344	!	c(
345	!	teal.reporter::teal_card(obj),
346	!	teal.reporter::teal_card("## Module's output(s)")
347		)
348	!	teal.code::eval_code(obj, "library(ggplot2);library(dplyr)")
349		})
350	!	anl_merged_q <- reactive({
351	!	req(anl_merged_input())
352	!	qenv() %>% teal.code::eval_code(as.expression(anl_merged_input()$expr))
353		})
354
355	!	merged <- list(
356	!	anl_input_r = anl_merged_input,
357	!	anl_q_r = anl_merged_q
358		)
359
360	!	output_q <- reactive({
361	!	teal::validate_inputs(iv_r())
362
363	!	ANL <- merged$anl_q_r()[["ANL"]]
364	!	teal::validate_has_data(ANL, 3)
365
366	!	vars_names <- merged$anl_input_r()$columns_source$vars
367
368	!	ref_name <- as.vector(merged$anl_input_r()$columns_source$ref)
369	!	association <- input$association
370	!	show_dist <- input$show_dist
371	!	log_transformation <- input$log_transformation
372	!	rotate_xaxis_labels <- input$rotate_xaxis_labels
373	!	swap_axes <- input$swap_axes
374	!	distribution_theme <- input$distribution_theme
375	!	association_theme <- input$association_theme
376
377	!	is_scatterplot <- is.numeric(ANL[[ref_name]]) && any(vapply(ANL[vars_names], is.numeric, logical(1)))
378	!	if (is_scatterplot) {
379	!	shinyjs::show("alpha")
380	!	shinyjs::show("size")
381	!	alpha <- input$alpha
382	!	size <- input$size
383		} else {
384	!	shinyjs::hide("alpha")
385	!	shinyjs::hide("size")
386	!	alpha <- 0.5
387	!	size <- 2
388		}
389
390	!	teal::validate_has_data(ANL[, c(ref_name, vars_names)], 3, complete = TRUE, allow_inf = FALSE)
391
392		# reference
393	!	ref_class <- class(ANL[[ref_name]])[1]
394	!	if (is.numeric(ANL[[ref_name]]) && log_transformation) {
395		# works for both integers and doubles
396	!	ref_cl_name <- call("log", as.name(ref_name))
397	!	ref_cl_lbl <- varname_w_label(ref_name, ANL, prefix = "Log of ")
398		} else {
399		# silently ignore when non-numeric even if `log` is selected because some
400		# variables may be numeric and others not
401	!	ref_cl_name <- as.name(ref_name)
402	!	ref_cl_lbl <- varname_w_label(ref_name, ANL)
403		}
404
405	!	user_ggplot2_args <- teal.widgets::resolve_ggplot2_args(
406	!	user_plot = ggplot2_args[["Bivariate1"]],
407	!	user_default = ggplot2_args$default
408		)
409
410	!	ref_call <- bivariate_plot_call(
411	!	data_name = "ANL",
412	!	x = ref_cl_name,
413	!	x_class = ref_class,
414	!	x_label = ref_cl_lbl,
415	!	freq = !show_dist,
416	!	theme = distribution_theme,
417	!	rotate_xaxis_labels = rotate_xaxis_labels,
418	!	swap_axes = FALSE,
419	!	size = size,
420	!	alpha = alpha,
421	!	ggplot2_args = user_ggplot2_args
422		)
423
424		# association
425	!	ref_class_cov <- ifelse(association, ref_class, "NULL")
426
427	!	var_calls <- lapply(vars_names, function(var_i) {
428	!	var_class <- class(ANL[[var_i]])[1]
429	!	if (is.numeric(ANL[[var_i]]) && log_transformation) {
430		# works for both integers and doubles
431	!	var_cl_name <- call("log", as.name(var_i))
432	!	var_cl_lbl <- varname_w_label(var_i, ANL, prefix = "Log of ")
433		} else {
434		# silently ignore when non-numeric even if `log` is selected because some
435		# variables may be numeric and others not
436	!	var_cl_name <- as.name(var_i)
437	!	var_cl_lbl <- varname_w_label(var_i, ANL)
438		}
439
440	!	user_ggplot2_args <- teal.widgets::resolve_ggplot2_args(
441	!	user_plot = ggplot2_args[["Bivariate2"]],
442	!	user_default = ggplot2_args$default
443		)
444
445	!	bivariate_plot_call(
446	!	data_name = "ANL",
447	!	x = ref_cl_name,
448	!	y = var_cl_name,
449	!	x_class = ref_class_cov,
450	!	y_class = var_class,
451	!	x_label = ref_cl_lbl,
452	!	y_label = var_cl_lbl,
453	!	theme = association_theme,
454	!	freq = !show_dist,
455	!	rotate_xaxis_labels = rotate_xaxis_labels,
456	!	swap_axes = swap_axes,
457	!	alpha = alpha,
458	!	size = size,
459	!	ggplot2_args = user_ggplot2_args
460		)
461		})
462
463		# helper function to format variable name
464	!	format_varnames <- function(x) {
465	!	if (is.numeric(ANL[[x]]) && log_transformation) {
466	!	varname_w_label(x, ANL, prefix = "Log of ")
467		} else {
468	!	varname_w_label(x, ANL)
469		}
470		}
471	!	new_title <-
472	!	if (association) {
473	!	switch(as.character(length(vars_names)),
474	!	"0" = sprintf("Value distribution for %s", ref_cl_lbl),
475	!	"1" = sprintf(
476	!	"Association between %s and %s",
477	!	ref_cl_lbl,
478	!	format_varnames(vars_names)
479		),
480	!	sprintf(
481	!	"Associations between %s and: %s",
482	!	ref_cl_lbl,
483	!	paste(lapply(vars_names, format_varnames), collapse = ", ")
484		)
485		)
486		} else {
487	!	switch(as.character(length(vars_names)),
488	!	"0" = sprintf("Value distribution for %s", ref_cl_lbl),
489	!	sprintf(
490	!	"Value distributions for %s and %s",
491	!	ref_cl_lbl,
492	!	paste(lapply(vars_names, format_varnames), collapse = ", ")
493		)
494		)
495		}
496	!	obj <- merged$anl_q_r()
497	!	teal.reporter::teal_card(obj) <- c(teal.reporter::teal_card(obj), "### Plot")
498	!	teal.code::eval_code(
499	!	obj,
500	!	substitute(
501	!	expr = title <- new_title,
502	!	env = list(new_title = new_title)
503		)
504		) %>%
505	!	teal.code::eval_code(
506	!	substitute(
507	!	expr = {
508	!	plots <- plot_calls
509	!	plot <- gridExtra::arrangeGrob(grobs = plots, ncol = 1)
510		},
511	!	env = list(
512	!	plot_calls = do.call(
513	!	"call",
514	!	c(list("list", ref_call), unname(var_calls)),
515	!	quote = TRUE
516		)
517		)
518		)
519		)
520		})
521
522	!	decorated_output_grob_q <- srv_decorate_teal_data(
523	!	id = "decorator",
524	!	data = output_q,
525	!	decorators = select_decorators(decorators, "plot"),
526	!	expr = quote({
527	!	grid::grid.newpage()
528	!	grid::grid.draw(plot)
529		})
530		)
531
532	!	plot_r <- reactive({
533	!	req(iv_r()$is_valid())
534	!	req(decorated_output_grob_q())[["plot"]]
535		})
536
537	!	pws <- teal.widgets::plot_with_settings_srv(
538	!	id = "myplot",
539	!	plot_r = plot_r,
540	!	height = plot_height,
541	!	width = plot_width
542		)
543
544	!	output$title <- renderText(output_q()[["title"]])
545
546	!	set_chunk_dims(pws, decorated_output_grob_q)
547		})
548		}

1		#' `teal` module: R Markdown render
2		#'
3		#' @description
4		#' `r lifecycle::badge("experimental")`
5		#'
6		#' Module to render R Markdown files using the data provided in the
7		#' `teal_data` object.
8		#'
9		#' The R Markdown file should be designed to accept variables available
10		#' in the data names of the module.
11		#'
12		#' @details
13		#' For example, if the `teal_data` object contains datasets named `mtcars`
14		#' and `iris`, the R Markdown file can use these as variables as they
15		#' will be available in the R Markdown environment.
16		#'
17		#' The libraries used in the R Markdown file must be available in the
18		#' deployed shiny app environment.
19		#'
20		#' When developing the R Markdown file, the working data can be simulated
21		#' on a code chunk, which in turn can look for the presence of `.raw_data`
22		#' object to determine if it is being run inside the `teal` module or not.
23		#'
24		#' Example R markdown file:
25		#'
26		#' ``````md
27		#' ---
28		#' title: "R Markdown Report"
29		#' output: html_document
30		#' ---
31		#'
32		#' ```{r eval=!exists(".raw_data")}
33		#' mtcars <- datasets::mtcars
34		#' iris <- datasets::iris
35		#' ```
36		#'
37		#' ```{r}
38		#' summary(mtcars) \|> print()
39		#' summary(iris) \|> print()
40		#' ```
41		#' ``````
42		#'
43		#' @inheritParams teal::module
44		#' @inheritParams shared_params
45		#'
46		#' @param rmd_content (`character`) Content of the R Markdown file to be rendered.
47		#' This can be the value of `readLines("path/to/file.Rmd")`.
48		#' @param allow_download (`logical`) whether to allow downloading of the R Markdown file.
49		#' Defaults to `TRUE`.
50		#' @param extra_transform (`list`) of [teal::teal_transform_module()] that will be added in the module's UI.
51		#' This can be used to create interactive inputs that modify the parameters in R Markdown rendering.
52		#'
53		#' @inherit shared_params return
54		#'
55		#' @inheritSection teal::example_module Reporting
56		#'
57		#' @examplesShinylive
58		#' library(teal.modules.general)
59		#' interactive <- function() TRUE
60		#' {{ next_example }}
61		#' @examples
62		#'
63		#' # general data example
64		#' data <- teal_data()
65		#' data <- within(data, {
66		#' CO2 <- CO2
67		#' })
68		#'
69		#' app <- init(
70		#' data = data,
71		#' modules = modules(
72		#' tm_rmarkdown(
73		#' label = "RMarkdown Module",
74		#' rmd_content = c(
75		#' "---",
76		#' "title: \"R Markdown Report\"",
77		#' "output: html_document",
78		#' "---",
79		#' "",
80		#' "```{r}",
81		#' "summary(CO2) \|> print()",
82		#' "```"
83		#' )
84		#' )
85		#' )
86		#' )
87		#' if (interactive()) {
88		#' shinyApp(app$ui, app$server)
89		#' }
90		#'
91		#' @examples
92		#' nrow_transform <- teal_transform_module(
93		#' label = "N Rows selector",
94		#' ui = function(id) {
95		#' ns <- NS(id)
96		#' tags$div(
97		#' numericInput(ns("n_rows"), "Show n rows", value = 40, min = 0, max = 200, step = 5)
98		#' )
99		#' },
100		#' server = function(id, data) {
101		#' moduleServer(id, function(input, output, session) {
102		#' reactive({
103		#' req(data())
104		#' within(data(),
105		#' {
106		#' n_rows <- n_rows_value
107		#' },
108		#' n_rows_value = input$n_rows
109		#' )
110		#' })
111		#' })
112		#' }
113		#' )
114		#'
115		#' app <- init(
116		#' data = data,
117		#' modules = modules(
118		#' tm_rmarkdown(
119		#' label = "RMarkdown Module",
120		#' rmd_content = readLines(
121		#' system.file(
122		#' file.path("sample_files", "co2_example.Rmd"),
123		#' package = "teal.modules.general"
124		#' )
125		#' ),
126		#' allow_download = FALSE,
127		#' extra_transform = list(nrow_transform)
128		#' )
129		#' )
130		#' )
131		#'
132		#' if (interactive()) {
133		#' shinyApp(app$ui, app$server)
134		#' }
135		#' @export
136		tm_rmarkdown <- function(label = "RMarkdown Module",
137		rmd_content,
138		datanames = "all",
139		allow_download = TRUE,
140		pre_output = NULL,
141		post_output = NULL,
142		transformators = list(),
143		extra_transform = list()) {
144	!	message("Initializing tm_rmarkdown")
145
146		# Start of assertions
147
148	!	checkmate::assert_string(label)
149	!	checkmate::assert_character(rmd_content)
150	!	checkmate::assert_flag(allow_download)
151
152	!	checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
153	!	checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
154
155		# End of assertions
156
157		# Make UI args
158	!	args <- as.list(environment())
159
160	!	ans <- module(
161	!	label = label,
162	!	server = srv_rmarkdown,
163	!	server_args = list(rmd_content = rmd_content, allow_download = allow_download, extra_transform = extra_transform),
164	!	ui = ui_rmarkdown,
165	!	ui_args = args,
166	!	transformators = transformators,
167	!	datanames = datanames
168		)
169	!	disable_src(ans)
170		}
171
172		# UI function for the rmarkdown module
173		ui_rmarkdown <- function(id, rmd_content, allow_download, extra_transform, ...) {
174	!	args <- list(...)
175	!	ns <- NS(id)
176
177	!	teal.widgets::standard_layout(
178	!	output = teal.widgets::white_small_well(
179	!	tags$div(
180	!	tags$h4("Rendered report from Rmd"),
181	!	if (allow_download) {
182	!	downloadButton(
183	!	ns("download_rmd"),
184	!	sprintf("Download R Markdown file"),
185	!	class = "btn-primary btn-sm"
186		)
187		},
188	!	ui_transform_teal_data(ns("extra_transform"), transformators = extra_transform)
189		),
190	!	tags$hr(),
191	!	uiOutput(ns("rmd_output"))
192		),
193	!	encoding = NULL,
194	!	pre_output = args$pre_output,
195	!	post_output = args$post_output
196		)
197		}
198
199		# Server function for the rmarkdown module
200		srv_rmarkdown <- function(id, data, rmd_content, allow_download, extra_transform) {
201	3x	checkmate::assert_class(data, "reactive")
202	3x	checkmate::assert_class(isolate(data()), "teal_data")
203	3x	moduleServer(id, function(input, output, session) {
204	3x	pre_decorated_q_r <- reactive({
205	3x	data_q <- req(data())
206	3x	teal.reporter::teal_card(data_q) <- c(
207	3x	teal.reporter::teal_card(data_q),
208	3x	teal.reporter::teal_card("## Module's output(s)")
209		)
210	3x	data_q
211		})
212
213	3x	q_r <- data_with_output_decorated <- teal::srv_transform_teal_data(
214	3x	"extra_transform",
215	3x	data = pre_decorated_q_r,
216	3x	transformators = extra_transform
217		)
218
219	3x	if (allow_download) {
220	3x	output$download_rmd <- downloadHandler(
221	3x	filename = function() sprintf("from_teal_module-%s.Rmd", format(Sys.time(), "%Y%m%d_%H%M")),
222	3x	content = function(file) {
223		# find the end of the YAML header or start of the file
224		# and insert the contents of teal.code::get_code(q_r())
225	!	yaml_end <- which(rmd_content == "---")[2]
226	!	insert_pos <- if (!is.na(yaml_end)) yaml_end else 0
227	!	note_lines <- c(
228		"",
229	!	"### Pre-processing data",
230		"",
231	!	"The following code chunk was automatically added by the teal markdown module.",
232	!	"It shows how to generate the data used in this report.",
233		"",
234	!	"```{r}",
235	!	teal.code::get_code(q_r()),
236		"```",
237		""
238		)
239	!	rmd_content <- append(rmd_content, note_lines, after = insert_pos)
240	!	writeLines(rmd_content, con = file)
241		},
242	3x	contentType = "text/plain"
243		)
244		}
245
246	3x	clean_up_r <- shiny::reactiveVal(list())
247		# Can only clean on sessionEnded as temporary files are needed for the reporter
248		# during session
249	3x	onSessionEnded(function() {
250	3x	logger::log_debug("srv_rmarkdown: cleaning up temporary folders.")
251	3x	lapply(shiny::isolate(clean_up_r()), function(f) f())
252	3x	}, session)
253
254	3x	rendered_path_r <- reactive({
255	3x	datasets <- rlang::env_clone(
256	3x	as.environment(req(q_r())),
257	3x	parent = new.env() # Ensuring a clean parent environment that can load libraries
258	3x	) # Clone to use unlocked environment
259	3x	temp_dir <- tempfile(pattern = "rmd_")
260	3x	dir.create(temp_dir, showWarnings = FALSE, recursive = TRUE)
261	3x	temp_rmd <- tempfile(pattern = "rmarkdown_module-", tmpdir = temp_dir, fileext = ".Rmd")
262		# Schedule cleanup of temp files when reactive is re-executed
263	3x	shiny::isolate({
264	3x	old_clean_up <- clean_up_r()
265	3x	clean_up_r(c(old_clean_up, function() unlink(temp_dir, recursive = TRUE)))
266		})
267	3x	writeLines(rmd_content, con = temp_rmd)
268
269	3x	tryCatch(
270		{
271	3x	rmarkdown::render(
272	3x	temp_rmd,
273	3x	output_format = rmarkdown::md_document(
274	3x	variant = "markdown",
275	3x	standalone = TRUE,
276	3x	dev = "png"
277		),
278	3x	envir = datasets,
279	3x	quiet = TRUE,
280	3x	runtime = "static"
281		)
282		},
283	3x	error = function(e) {
284	!	warning("Error rendering RMD file: ", e$message) # verbose error in logs
285	!	e
286		}
287		)
288		})
289
290	3x	rendered_html_r <- reactive({
291	2x	output_path <- req(rendered_path_r())
292	2x	validate(
293	2x	need(inherits(output_path, "character"), "Error rendering RMD file. Please contact the app developer.")
294		)
295	2x	shiny::includeMarkdown(output_path)
296		})
297
298	3x	output$rmd_output <- renderUI(rendered_html_r())
299
300	3x	result <- reactive({
301	1x	out_data <- q_r()
302	1x	report_doc <- .markdown_internal(rendered_path_r(), rendered_html_r())
303	1x	teal.reporter::teal_card(out_data) <- c(
304	1x	teal.reporter::teal_card(out_data), report_doc
305		)
306	1x	out_data
307		})
308	3x	result
309		})
310		}
311
312		#' Create internal markdown object for use in reporter
313		#'
314		#' Creates an object of class `markdown_internal` that contains the
315		#' content of a markdown file.
316		#'
317		#' This package registers S3 methods for `toHTML` and `to_rmd` for this class to
318		#' facilitate rendering in `teal.reporter`.
319		#'
320		#' @param markdown_file (`character(1)`) path to markdown file.
321		#' @param rendered_html (`shiny.tag`) rendered HTML content.
322		#'
323		#' @return `markdown_internal` object
324		#'
325		#' @keywords internal
326		.markdown_internal <- function(markdown_file, rendered_html) {
327	1x	base_file <- basename(markdown_file)
328
329		# Create new custom structure with contents and images in base64 as attribute
330	1x	structure(
331	1x	readLines(markdown_file),
332	1x	class = c("markdown_internal", "character"),
333	1x	parent_path = dirname(markdown_file),
334	1x	old_base_path = sprintf("%s_files/", tools::file_path_sans_ext(base_file)),
335	1x	cached_html = rendered_html
336		)
337		}
338
339		#' @describeIn dot-markdown_internal Custom [tools::toHTML()] method for markdown_internal class that
340		#' uses a cached rendering of the module.
341		#' @inheritParams tools::toHTML
342		#' @param ... Arguments that will be passed to the next method.
343		#' @exportS3Method tools::toHTML
344		toHTML.markdown_internal <- function(x, ...) {
345	!	cached_html <- attr(x, "cached_html", exact = TRUE)
346	!	if (!is.null(cached_html)) {
347	!	return(cached_html)
348		}
349	!	NextMethod(unclass(x), ...)
350		}
351
352		#' @describeIn dot-markdown_internal Custom [teal.reporter::to_rmd()] method for `markdown_internal`
353		#' object will be used to render the report.
354		#' @inheritParams teal.reporter::to_rmd
355		#' @param figures_dir (`character(1)`) directory where the R markdown auxiliary files will be saved.
356		#' @exportS3Method teal.reporter::to_rmd
357		to_rmd.markdown_internal <- function(block, figures_dir = "figures", ...) {
358	!	old_base_path <- attr(block, "old_base_path", exact = TRUE)
359	!	parent_path <- attr(block, "parent_path", exact = TRUE)
360	!	new_base_path <- file.path(figures_dir, old_base_path)
361
362		# Copy figures from old path to new location
363	!	dir.create(figures_dir, showWarnings = FALSE, recursive = TRUE)
364	!	file.copy(file.path(parent_path, old_base_path), figures_dir, recursive = TRUE)
365
366		# Change the image paths in the markdown content
367	!	block <- gsub(pattern = old_base_path, replacement = new_base_path, x = block, fixed = TRUE)
368	!	NextMethod(unclass(block), ...)
369		}

1		# minimal implementation of ggplot2 mosaic after ggmosaic was archived in CRAN
2		#
3		# This was heavily inspired by github.com/haleyjeppson/ggmosaic package but
4		# simplified to only support 2 categorical variables
5
6		#' Mosaic Rectangles Layer for ggplot2
7		#'
8		#' Adds a mosaic-style rectangles layer to a ggplot, visualizing the
9		#' joint distribution of categorical variables.
10		#' Each rectangle's size reflects the proportion of observations for
11		#' combinations of `x` and `fill`.
12		#'
13		#' @param mapping Set of aesthetic mappings created by `aes()`. Must specify `x` and `fill`.
14		#' @param data The data to be displayed in this layer.
15		#' @param stat The statistical transformation to use on the data. Defaults to `"rects"`.
16		#' @param position Position adjustment. Defaults to `"identity"`.
17		#' @param ... Other arguments passed to `layer()`.
18		#' @param na.rm Logical. Should missing values be removed?
19		#' @param show.legend Logical. Should this layer be included in the legends?
20		#' @param inherit.aes Logical. If `FALSE`, overrides default aesthetics.
21		#'
22		#' @return A ggplot2 layer that adds mosaic rectangles to the plot.
23		#'
24		#' @examples
25		#' df <- data.frame(RACE = c("Black", "White", "Black", "Asian"), SEX = c("M", "M", "F", "F"))
26		#' library(ggplot2)
27		#' ggplot(df) +
28		#' geom_mosaic(aes(x = RACE, fill = SEX))
29		#' @export
30		geom_mosaic <- function(mapping = NULL, data = NULL,
31		stat = "mosaic", position = "identity",
32		...,
33		na.rm = FALSE, # nolint: object_name_linter.
34		show.legend = TRUE, # nolint: object_name_linter.
35		inherit.aes = TRUE) { # nolint: object_name_linter.
36
37	!	aes_x <- mapping$x
38	!	if (!is.null(aes_x)) {
39	!	aes_x <- list(rlang::quo_get_expr(mapping$x))
40	!	var_x <- paste0("x__", as.character(aes_x))
41	!	mapping[[var_x]] <- mapping$x
42		}
43
44	!	aes_fill <- mapping$fill
45	!	if (!is.null(aes_fill)) {
46	!	aes_fill <- rlang::quo_text(mapping$fill)
47		}
48
49	!	mapping$x <- structure(1L)
50
51	!	layer <- ggplot2::layer(
52	!	geom = GeomMosaic,
53	!	stat = "mosaic",
54	!	data = data,
55	!	mapping = mapping,
56	!	position = position,
57	!	show.legend = show.legend,
58	!	inherit.aes = inherit.aes,
59	!	check.aes = FALSE,
60	!	params = list(na.rm = na.rm, ...)
61		)
62	!	list(layer, .scale_x_mosaic())
63		}
64
65		#' @keywords internal
66		GeomMosaic <- ggplot2::ggproto( # nolint: object_name_linter.
67		"GeomMosaic", ggplot2::GeomRect,
68		default_aes = ggplot2::aes(
69		colour = NA, linewidth = 0.5, linetype = 1, alpha = 1, fill = "grey30"
70		),
71		draw_panel = function(data, panel_params, coord) {
72		if (all(is.na(data$colour))) data$colour <- scales::alpha(data$fill, data$alpha)
73		ggplot2::GeomRect$draw_panel(data, panel_params, coord)
74		},
75		required_aes = c("xmin", "xmax", "ymin", "ymax")
76		)
77
78		#' @keywords internal
79		StatMosaic <- ggplot2::ggproto( # nolint: object_name_linter.
80		"StatMosaic", ggplot2::Stat,
81		required_aes = c("x", "fill"),
82		compute_group = function(data, scales) data,
83		compute_panel = function(data, scales) {
84		data$x <- data[, grepl("x__", colnames(data))]
85		result <- .calculate_coordinates(data)
86
87		results_non_zero <- result[result$.n != 0, ]
88		breaks <- unique(with(results_non_zero, (xmin + xmax) / 2))
89		labels <- unique(results_non_zero$x)
90		result$x <- list(list2env(list(breaks = breaks[breaks != 0], labels = labels[breaks != 0])))
91
92		result$group <- 1
93		result$PANEL <- unique(data$PANEL)
94		result
95		}
96		)
97
98		#' Determining scales for mosaics
99		#'
100		#' @param breaks,labels,minor_breaks One of:
101		#' - `NULL` for no breaks / labels.
102		#' - [ggplot2::waiver()] for the default breaks / labels computed by the scale.
103		#' - A numeric / character vector giving the positions of the breaks / labels.
104		#' - A function.
105		#' See [ggplot2::scale_x_continuous()] for more details.
106		#' @param na.value The value to be used for `NA` values.
107		#' @param position For position scales, The position of the axis.
108		#' left or right for y axes, top or bottom for x axes.
109		#' @param ... other arguments passed to `continuous_scale()`.
110		#' @keywords internal
111		.scale_x_mosaic <- function(breaks = unique,
112		minor_breaks = NULL,
113		labels = unique,
114		na.value = NA_real_, # nolint: object_name_linter.
115		position = "bottom",
116		...) {
117	!	ggplot2::continuous_scale(
118	!	aesthetics = c(
119	!	"x", "xmin", "xmax", "xend", "xintercept", "xmin_final", "xmax_final",
120	!	"xlower", "xmiddle", "xupper"
121		),
122	!	palette = identity,
123	!	breaks = breaks,
124	!	minor_breaks = minor_breaks,
125	!	labels = labels,
126	!	na.value = na.value,
127	!	position = position,
128	!	super = ScaleContinuousMosaic, ,
129	!	guide = ggplot2::waiver(),
130		...
131		)
132		}
133
134		#' @keywords internal
135		ScaleContinuousMosaic <- ggplot2::ggproto( # nolint: object_name_linter.
136		"ScaleContinuousMosaic", ggplot2::ScaleContinuousPosition,
137		train = function(self, x) {
138		if (length(x) == 0) {
139		return()
140		}
141		if (is.list(x)) {
142		scale_x <- x[[1]]
143		# re-assign the scale values now that we have the information - but only if necessary
144		if (is.function(self$breaks)) self$breaks <- scale_x$breaks
145		if (is.function(self$labels)) self$labels <- as.vector(scale_x$labels)
146		return(NULL)
147		}
148		if (is_discrete(x)) {
149		self$range$train(x = c(0, 1))
150		return(NULL)
151		}
152		self$range$train(x, call = self$call)
153		},
154		map = function(self, x, limits = self$get_limits()) {
155		if (is_discrete(x)) {
156		return(x)
157		}
158		if (is.list(x)) {
159		return(0)
160		} # need a number
161		scaled <- as.numeric(self$oob(x, limits))
162		ifelse(!is.na(scaled), scaled, self$na.value)
163		},
164		dimension = function(self, expand = c(0, 0)) c(-0.05, 1.05)
165		)
166
167		#' @noRd
168	!	is_discrete <- function(x) is.factor(x) \|\| is.character(x) \|\| is.logical(x)
169
170		#' @describeIn geom_mosaic
171		#' Computes the coordinates for rectangles in a mosaic plot based
172		#' on combinations of `x` and `fill` variables.
173		#' For each unique `x` and `fill`, calculates the proportional
174		#' widths and heights, stacking rectangles within each `x` group.
175		#'
176		#' ### Value
177		#'
178		#' A data frame with columns: `x`, `fill`, `xmin`, `xmax`, `ymin`, `ymax`,
179		#' representing the position and size of each rectangle.
180		#'
181		#' @keywords internal
182		.calculate_coordinates <- function(data) {
183		# Example: compute rectangles from x and y
184	!	result <- data \|>
185		# Count combinations of X and Y
186	!	dplyr::count(.data$x, .data$fill, .drop = FALSE) \|>
187		# Compute total for each X group
188	!	dplyr::mutate(
189	!	.by = .data$x,
190	!	x_total = sum(.data$n),
191	!	prop = .data$n / .data$x_total,
192	!	prop = dplyr::if_else(is.nan(.data$prop), 0, .data$prop)
193		) \|>
194	!	dplyr::arrange(dplyr::desc(.data$x_total), .data$x, .data$fill) \|>
195		# Compute total sample size to turn counts into widths
196	!	dplyr::mutate(
197	!	N_total = dplyr::n(),
198	!	x_width = .data$x_total / .data$N_total
199		) \|>
200		# Convert counts to x widths
201	!	dplyr::mutate(
202	!	.by = .data$x,
203	!	x_width_last = dplyr::if_else(dplyr::row_number() == dplyr::n(), .data$x_width, 0)
204		) \|>
205		# Compute x-min/x-max for each group
206	!	dplyr::mutate(
207	!	xmin = cumsum(dplyr::lag(.data$x_width_last, default = 0)),
208	!	xmax = .data$xmin + .data$x_width
209		) \|>
210		# Compute y-min/y-max for stacked proportions
211	!	dplyr::mutate(
212	!	.by = .data$x,
213	!	ymin = c(0, utils::head(cumsum(.data$prop), -1)),
214	!	ymax = cumsum(.data$prop)
215		) \|>
216	!	dplyr::mutate(
217	!	xmin = .data$xmin / max(.data$xmax),
218	!	xmax = .data$xmax / max(.data$xmax),
219	!	xmin = dplyr::if_else(.data$n == 0, 0, .data$xmin + 0.005),
220	!	xmax = dplyr::if_else(.data$n == 0, 0, .data$xmax - 0.005),
221	!	ymin = dplyr::if_else(.data$n == 0, 0, .data$ymin + 0.005),
222	!	ymax = dplyr::if_else(.data$n == 0, 0, .data$ymax - 0.005)
223		) \|>
224	!	dplyr::select(.data$x, .data$fill, .data$xmin, .data$xmax, .data$ymin, .data$ymax, .n = .data$n)
225	!	result
226		}

1		#' `teal` module: Front page
2		#'
3		#' Creates a simple front page for `teal` applications, displaying
4		#' introductory text, tables, additional `html` or `shiny` tags, and footnotes.
5		#'
6		#' @inheritParams teal::module
7		#' @param header_text (`character` vector) text to be shown at the top of the module, for each
8		#' element, if named the name is shown first in bold as a header followed by the value. The first
9		#' element's header is displayed larger than the others.
10		#' @param tables (`named list` of `data.frame`s) tables to be shown in the module.
11		#' @param additional_tags (`shiny.tag.list` or `html`) additional `shiny` tags or `html` to be included after the table,
12		#' for example to include an image, `tagList(tags$img(src = "image.png"))` or to include further `html`,
13		#' `HTML("html text here")`.
14		#' @param footnotes (`character` vector) of text to be shown at the bottom of the module, for each
15		#' element, if named the name is shown first in bold, followed by the value.
16		#' @param show_metadata (`logical`) `r lifecycle::badge("deprecated")` indicating
17		#' whether the metadata of the datasets be available on the module.
18		#' Metadata shown automatically when `datanames` set.
19		#' @inheritParams tm_variable_browser
20		#'
21		#' @inherit shared_params return
22		#'
23		#' @examplesShinylive
24		#' library(teal.modules.general)
25		#' interactive <- function() TRUE
26		#' {{ next_example }}
27		#' @examples
28		#' data <- teal_data()
29		#' data <- within(data, {
30		#' require(nestcolor)
31		#' ADSL <- teal.data::rADSL
32		#' attr(ADSL, "metadata") <- list("Author" = "NEST team", "data_source" = "synthetic data")
33		#' })
34		#' join_keys(data) <- default_cdisc_join_keys[names(data)]
35		#'
36		#' table_1 <- data.frame(Info = c("A", "B"), Text = c("A", "B"))
37		#' table_2 <- data.frame(`Column 1` = c("C", "D"), `Column 2` = c(5.5, 6.6), `Column 3` = c("A", "B"))
38		#' table_3 <- data.frame(Info = c("E", "F"), Text = c("G", "H"))
39		#'
40		#' table_input <- list(
41		#' "Table 1" = table_1,
42		#' "Table 2" = table_2,
43		#' "Table 3" = table_3
44		#' )
45		#'
46		#' app <- init(
47		#' data = data,
48		#' modules = modules(
49		#' tm_front_page(
50		#' header_text = c(
51		#' "Important information" = "It can go here.",
52		#' "Other information" = "Can go here."
53		#' ),
54		#' tables = table_input,
55		#' additional_tags = HTML("Additional HTML or shiny tags go here <br>"),
56		#' footnotes = c("X" = "is the first footnote", "Y is the second footnote")
57		#' )
58		#' )
59		#' ) \|>
60		#' modify_header(tags$h1("Sample Application")) \|>
61		#' modify_footer(tags$p("Application footer"))
62		#'
63		#' if (interactive()) {
64		#' shinyApp(app$ui, app$server)
65		#' }
66		#'
67		#' @export
68		#'
69		tm_front_page <- function(label = "Front page",
70		header_text = character(0),
71		tables = list(),
72		additional_tags = tagList(),
73		footnotes = character(0),
74		show_metadata = deprecated(),
75		datanames = if (missing(show_metadata)) NULL else "all",
76		transformators = list()) {
77	!	message("Initializing tm_front_page")
78
79		# Start of assertions
80	!	checkmate::assert_string(label)
81	!	checkmate::assert_character(header_text, min.len = 0, any.missing = FALSE)
82	!	checkmate::assert_list(tables, types = "data.frame", names = "named", any.missing = FALSE)
83	!	checkmate::assert_multi_class(additional_tags, classes = c("shiny.tag.list", "html"))
84	!	checkmate::assert_character(footnotes, min.len = 0, any.missing = FALSE)
85	!	if (!missing(show_metadata)) {
86	!	lifecycle::deprecate_stop(
87	!	when = "0.4.0",
88	!	what = "tm_front_page(show_metadata)",
89	!	with = "tm_front_page(datanames)",
90	!	details = c(
91	!	"With `datanames` you can select which datasets are displayed.",
92	!	i = "Use `tm_front_page(datanames = 'all')` to keep the previous behavior and avoid this warning."
93		)
94		)
95		}
96	!	checkmate::assert_character(datanames, min.len = 0, min.chars = 1, null.ok = TRUE)
97
98		# End of assertions
99
100		# Make UI args
101	!	args <- as.list(environment())
102
103	!	ans <- module(
104	!	label = label,
105	!	server = srv_front_page,
106	!	ui = ui_front_page,
107	!	ui_args = args,
108	!	server_args = list(tables = tables),
109	!	datanames = datanames, ,
110	!	transformators = transformators
111		)
112	!	attr(ans, "teal_bookmarkable") <- TRUE
113	!	ans
114		}
115
116		# UI function for the front page module
117		ui_front_page <- function(id, ...) {
118	!	args <- list(...)
119	!	ns <- NS(id)
120
121	!	tagList(
122	!	tags$div(
123	!	id = "front_page_content",
124	!	style = "margin-left: 2rem;",
125	!	tags$div(
126	!	id = "front_page_headers",
127	!	get_header_tags(args$header_text)
128		),
129	!	tags$div(
130	!	id = "front_page_tables",
131	!	style = "margin-left: 2rem;",
132	!	get_table_tags(args$tables, ns)
133		),
134	!	tags$div(
135	!	id = "front_page_custom_html",
136	!	style = "margin-left: 2rem;",
137	!	args$additional_tags
138		),
139	!	if (length(args$datanames) > 0L) {
140	!	tags$div(
141	!	id = "front_page_metabutton",
142	!	style = "margin: 1rem;",
143	!	actionButton(ns("metadata_button"), "Show metadata")
144		)
145		},
146	!	tags$footer(
147	!	class = "small",
148	!	get_footer_tags(args$footnotes)
149		)
150		)
151		)
152		}
153
154		# Server function for the front page module
155		srv_front_page <- function(id, data, tables) {
156	!	checkmate::assert_class(data, "reactive")
157	!	checkmate::assert_class(isolate(data()), "teal_data")
158	!	moduleServer(id, function(input, output, session) {
159	!	teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")
160
161	!	ns <- session$ns
162
163	!	setBookmarkExclude("metadata_button")
164
165	!	lapply(seq_along(tables), function(idx) {
166	!	output[[paste0("table_", idx)]] <- renderTable(
167	!	tables[[idx]],
168	!	bordered = TRUE,
169	!	caption = names(tables)[idx],
170	!	caption.placement = "top"
171		)
172		})
173	!	if (length(isolate(names(data()))) > 0L) {
174	!	observeEvent(
175	!	input$metadata_button, showModal(
176	!	modalDialog(
177	!	title = "Metadata",
178	!	dataTableOutput(ns("metadata_table")),
179	!	size = "l",
180	!	easyClose = TRUE
181		)
182		)
183		)
184
185	!	metadata_data_frame <- reactive({
186	!	datanames <- names(data())
187	!	convert_metadata_to_dataframe(
188	!	lapply(datanames, function(dataname) attr(data()[[dataname]], "metadata")),
189	!	datanames
190		)
191		})
192
193	!	output$metadata_table <- DT::renderDT({
194	!	validate(need(nrow(metadata_data_frame()) > 0, "The data has no associated metadata"))
195	!	metadata_data_frame()
196		})
197		}
198		})
199		}
200
201		## utils functions
202
203		get_header_tags <- function(header_text) {
204	!	if (length(header_text) == 0) {
205	!	return(list())
206		}
207
208	!	get_single_header_tags <- function(header_text, p_text, header_tag = tags$h4) {
209	!	tagList(
210	!	tags$div(
211	!	if (!is.null(header_text) && nchar(header_text) > 0) header_tag(header_text),
212	!	tags$p(p_text)
213		)
214		)
215		}
216
217	!	header_tags <- get_single_header_tags(names(header_text[1]), header_text[1], header_tag = tags$h3)
218	!	c(header_tags, mapply(get_single_header_tags, utils::tail(names(header_text), -1), utils::tail(header_text, -1)))
219		}
220
221		get_table_tags <- function(tables, ns) {
222	!	if (length(tables) == 0) {
223	!	return(list())
224		}
225	!	table_tags <- c(lapply(seq_along(tables), function(idx) {
226	!	list(
227	!	tableOutput(ns(paste0("table_", idx)))
228		)
229		}))
230	!	table_tags
231		}
232
233		get_footer_tags <- function(footnotes) {
234	!	if (length(footnotes) == 0) {
235	!	return(list())
236		}
237	!	bold_texts <- if (is.null(names(footnotes))) rep("", length(footnotes)) else names(footnotes)
238	!	footnote_tags <- mapply(function(bold_text, value) {
239	!	list(
240	!	tags$div(
241	!	tags$b(bold_text),
242	!	value,
243	!	tags$br()
244		)
245		)
246	!	}, bold_text = bold_texts, value = footnotes)
247		}
248
249		# take a list of metadata, one item per dataset (raw_metadata each element from datasets$get_metadata())
250		# and the corresponding datanames and output a data.frame with columns {Dataset, Name, Value}.
251		# which are, the Dataset the metadata came from, the metadata's name and value
252		convert_metadata_to_dataframe <- function(raw_metadata, datanames) {
253	4x	output <- mapply(function(metadata, dataname) {
254	6x	if (is.null(metadata)) {
255	2x	return(data.frame(Dataset = character(0), Name = character(0), Value = character(0)))
256		}
257	4x	data.frame(
258	4x	Dataset = dataname,
259	4x	Name = names(metadata),
260	4x	Value = unname(unlist(lapply(metadata, as.character)))
261		)
262	4x	}, raw_metadata, datanames, SIMPLIFY = FALSE)
263	4x	do.call(rbind, output)
264		}

1		#' Shared parameters documentation
2		#'
3		#' Defines common arguments shared across multiple functions in the package
4		#' to avoid repetition by using `inheritParams`.
5		#'
6		#' @param plot_height (`numeric`) optional, specifies the plot height as a three-element vector of
7		#' `value`, `min`, and `max` intended for use with a slider UI element.
8		#' @param plot_width (`numeric`) optional, specifies the plot width as a three-element vector of
9		#' `value`, `min`, and `max` for a slider encoding the plot width.
10		#' @param rotate_xaxis_labels (`logical`) optional, whether to rotate plot X axis labels. Does not
11		#' rotate by default (`FALSE`).
12		#' @param ggtheme (`character`) optional, `ggplot2` theme to be used by default. Defaults to `"gray"`.
13		#' @param ggplot2_args (`ggplot2_args`) object created by [teal.widgets::ggplot2_args()]
14		#' with settings for the module plot.
15		#' The argument is merged with options variable `teal.ggplot2_args` and default module setup.
16		#'
17		#' For more details see the vignette: `vignette("custom-ggplot2-arguments", package = "teal.widgets")`
18		#' @param basic_table_args (`basic_table_args`) object created by [teal.widgets::basic_table_args()]
19		#' with settings for the module table.
20		#' The argument is merged with options variable `teal.basic_table_args` and default module setup.
21		#'
22		#' For more details see the vignette: `vignette("custom-basic-table-arguments", package = "teal.widgets")`
23		#' @param pre_output (`shiny.tag`) optional, text or UI element to be displayed before the module's output,
24		#' providing context or a title.
25		#' with text placed before the output to put the output into context. For example a title.
26		#' @param post_output (`shiny.tag`) optional, text or UI element to be displayed after the module's output,
27		#' adding context or further instructions. Elements like `shiny::helpText()` are useful.
28		#' @param alpha (`integer(1)` or `integer(3)`) optional, specifies point opacity.
29		#' - When the length of `alpha` is one: the plot points will have a fixed opacity.
30		#' - When the length of `alpha` is three: the plot points opacity are dynamically adjusted based on
31		#' vector of `value`, `min`, and `max`.
32		#' @param size (`integer(1)` or `integer(3)`) optional, specifies point size.
33		#' - When the length of `size` is one: the plot point sizes will have a fixed size.
34		#' - When the length of `size` is three: the plot points size are dynamically adjusted based on
35		#' vector of `value`, `min`, and `max`.
36		#' @param decorators `r lifecycle::badge("experimental")`
37		#' (named `list` of lists of `teal_transform_module`) optional,
38		#' decorator for tables or plots included in the module output reported.
39		#' The decorators are applied to the respective output objects.
40		#'
41		#' See section "Decorating Module" below for more details.
42		#'
43		#' @return Object of class `teal_module` to be used in `teal` applications.
44		#'
45		#' @name shared_params
46		#' @keywords internal
47		NULL
48
49		#' Add labels for facets to a `ggplot2` object
50		#'
51		#' Enhances a `ggplot2` plot by adding labels that describe
52		#' the faceting variables along the x and y axes.
53		#'
54		#' @param p (`ggplot2`) object to which facet labels will be added.
55		#' @param xfacet_label (`character`) Label for the facet along the x-axis.
56		#' If `NULL`, no label is added. If a vector, labels are joined with " & ".
57		#' @param yfacet_label (`character`) Label for the facet along the y-axis.
58		#' Similar behavior to `xfacet_label`.
59		#'
60		#' @return Returns `grid` or `grob` object (to be drawn with `grid.draw`)
61		#'
62		#' @examples
63		#' library(ggplot2)
64		#' library(grid)
65		#'
66		#' p <- ggplot(mtcars) +
67		#' aes(x = mpg, y = disp) +
68		#' geom_point() +
69		#' facet_grid(gear ~ cyl)
70		#'
71		#' xfacet_label <- "cylinders"
72		#' yfacet_label <- "gear"
73		#' res <- add_facet_labels(p, xfacet_label, yfacet_label)
74		#' grid.newpage()
75		#' grid.draw(res)
76		#'
77		#' grid.newpage()
78		#' grid.draw(add_facet_labels(p, xfacet_label = NULL, yfacet_label))
79		#' grid.newpage()
80		#' grid.draw(add_facet_labels(p, xfacet_label, yfacet_label = NULL))
81		#' grid.newpage()
82		#' grid.draw(add_facet_labels(p, xfacet_label = NULL, yfacet_label = NULL))
83		#'
84		#' @export
85		#'
86		add_facet_labels <- function(p, xfacet_label = NULL, yfacet_label = NULL) {
87	!	checkmate::assert_class(p, classes = "ggplot")
88	!	checkmate::assert_character(xfacet_label, null.ok = TRUE, min.len = 1)
89	!	checkmate::assert_character(yfacet_label, null.ok = TRUE, min.len = 1)
90	!	if (is.null(xfacet_label) && is.null(yfacet_label)) {
91	!	return(ggplot2::ggplotGrob(p))
92		}
93	!	grid::grid.grabExpr({
94	!	g <- ggplot2::ggplotGrob(p)
95
96		# we are going to replace these, so we make sure they have nothing in them
97	!	checkmate::assert_class(g$grobs[[grep("xlab-t", g$layout$name, fixed = TRUE)]], "zeroGrob")
98	!	checkmate::assert_class(g$grobs[[grep("ylab-r", g$layout$name, fixed = TRUE)]], "zeroGrob")
99
100	!	xaxis_label_grob <- g$grobs[[grep("xlab-b", g$layout$name, fixed = TRUE)]]
101	!	xaxis_label_grob$children[[1]]$label <- paste(xfacet_label, collapse = " & ")
102	!	yaxis_label_grob <- g$grobs[[grep("ylab-l", g$layout$name, fixed = TRUE)]]
103	!	yaxis_label_grob$children[[1]]$label <- paste(yfacet_label, collapse = " & ")
104	!	yaxis_label_grob$children[[1]]$rot <- 270
105
106	!	top_height <- if (is.null(xfacet_label)) 0 else grid::unit(2, "line")
107	!	right_width <- if (is.null(yfacet_label)) 0 else grid::unit(2, "line")
108
109	!	grid::grid.newpage()
110	!	grid::pushViewport(grid::plotViewport(margins = c(0, 0, top_height, right_width), name = "ggplot"))
111	!	grid::grid.draw(g)
112	!	grid::upViewport(1)
113
114		# draw x facet
115	!	if (!is.null(xfacet_label)) {
116	!	grid::pushViewport(grid::viewport(
117	!	x = 0, y = grid::unit(1, "npc") - top_height, width = grid::unit(1, "npc"),
118	!	height = top_height, just = c("left", "bottom"), name = "topxaxis"
119		))
120	!	grid::grid.draw(xaxis_label_grob)
121	!	grid::upViewport(1)
122		}
123
124		# draw y facet
125	!	if (!is.null(yfacet_label)) {
126	!	grid::pushViewport(grid::viewport(
127	!	x = grid::unit(1, "npc") - grid::unit(as.numeric(right_width) / 2, "line"), y = 0, width = right_width,
128	!	height = grid::unit(1, "npc"), just = c("left", "bottom"), name = "rightyaxis"
129		))
130	!	grid::grid.draw(yaxis_label_grob)
131	!	grid::upViewport(1)
132		}
133		})
134		}
135
136		#' Call a function with a character vector for the `...` argument
137		#'
138		#' @param fun (`character`) Name of a function where the `...` argument shall be replaced by values from `str_args`.
139		#' @param str_args (`character`) A character vector that the function shall be executed with
140		#'
141		#' @return
142		#' Value of call to `fun` with arguments specified in `str_args`.
143		#'
144		#' @keywords internal
145		call_fun_dots <- function(fun, str_args) {
146	!	do.call("call", c(list(fun), lapply(str_args, as.name)), quote = TRUE)
147		}
148
149		#' Generate a string for a variable including its label
150		#'
151		#' @param var_names (`character`) Name of variable to extract labels from.
152		#' @param dataset (`dataset`) Name of analysis dataset.
153		#' @param prefix,suffix (`character`) String to paste to the beginning/end of the variable name with label.
154		#' @param wrap_width (`numeric`) Number of characters to wrap original label to. Defaults to 80.
155		#'
156		#' @return (`character`) String with variable name and label.
157		#'
158		#' @keywords internal
159		#'
160		varname_w_label <- function(var_names,
161		dataset,
162		wrap_width = 80,
163		prefix = NULL,
164		suffix = NULL) {
165	!	add_label <- function(var_names) {
166	!	label <- vapply(
167	!	dataset[var_names], function(x) {
168	!	attr_label <- attr(x, "label")
169	!	`if`(is.null(attr_label), "", attr_label)
170		},
171	!	character(1)
172		)
173
174	!	if (length(label) == 1 && !is.na(label) && !identical(label, "")) {
175	!	paste0(prefix, label, " [", var_names, "]", suffix)
176		} else {
177	!	var_names
178		}
179		}
180
181	!	if (length(var_names) < 1) {
182	!	NULL
183	!	} else if (length(var_names) == 1) {
184	!	stringr::str_wrap(add_label(var_names), width = wrap_width)
185	!	} else if (length(var_names) > 1) {
186	!	stringr::str_wrap(vapply(var_names, add_label, character(1)), width = wrap_width)
187		}
188		}
189
190		# see vignette("ggplot2-specs", package="ggplot2")
191		shape_names <- c(
192		"circle", paste("circle", c("open", "filled", "cross", "plus", "small")), "bullet",
193		"square", paste("square", c("open", "filled", "cross", "plus", "triangle")),
194		"diamond", paste("diamond", c("open", "filled", "plus")),
195		"triangle", paste("triangle", c("open", "filled", "square")),
196		paste("triangle down", c("open", "filled")),
197		"plus", "cross", "asterisk"
198		)
199
200		#' Get icons to represent variable types in dataset
201		#'
202		#' @param var_type (`character`) of R internal types (classes).
203		#' @return (`character`) vector of HTML icons corresponding to data type in each column.
204		#' @keywords internal
205		variable_type_icons <- function(var_type) {
206	!	checkmate::assert_character(var_type, any.missing = FALSE)
207
208	!	class_to_icon <- list(
209	!	numeric = "arrow-up-1-9",
210	!	integer = "arrow-up-1-9",
211	!	logical = "pause",
212	!	Date = "calendar",
213	!	POSIXct = "calendar",
214	!	POSIXlt = "calendar",
215	!	factor = "chart-bar",
216	!	character = "keyboard",
217	!	primary_key = "key",
218	!	unknown = "circle-question"
219		)
220	!	class_to_icon <- lapply(class_to_icon, function(icon_name) toString(icon(icon_name, lib = "font-awesome")))
221
222	!	unname(vapply(
223	!	var_type,
224	!	FUN.VALUE = character(1),
225	!	FUN = function(class) {
226	!	if (class == "") {
227	!	class
228	!	} else if (is.null(class_to_icon[[class]])) {
229	!	class_to_icon[["unknown"]]
230		} else {
231	!	class_to_icon[[class]]
232		}
233		}
234		))
235		}
236
237		#' JavaScript expression to check if a tab is active
238		#'
239		#' @param id (`character(1)`) the id of the tab panel with tabs.
240		#' @param name (`character(1)`) the name of the tab.
241		#' @return JavaScript expression to be used in `shiny::conditionalPanel()` to determine
242		#' if the specified tab is active.
243		#' @keywords internal
244		#'
245		is_tab_active_js <- function(id, name) {
246		# supporting the bs3 and higher version at the same time
247	!	sprintf(
248	!	"$(\"#%1$s > li.active\").text().trim() == '%2$s' \|\| $(\"#%1$s > li a.active\").text().trim() == '%2$s'",
249	!	id, name
250		)
251		}
252
253		#' Assert single selection on `data_extract_spec` object
254		#' Helper to reduce code in assertions
255		#' @noRd
256		#'
257		assert_single_selection <- function(x,
258		.var.name = checkmate::vname(x)) { # nolint: object_name.
259	104x	if (any(vapply(x, function(.x) .x$select$multiple, logical(1)))) {
260	4x	stop("'", .var.name, "' should not allow multiple selection")
261		}
262	100x	invisible(TRUE)
263		}
264
265		#' Wrappers around `srv_transform_teal_data` that allows to decorate the data
266		#' @inheritParams teal::srv_transform_teal_data
267		#' @inheritParams teal.reporter::`eval_code,teal_report-method`
268		#' @param expr (`reactive`) with expression to evaluate on the output of the
269		#' decoration. It must be compatible with `code` argument of [teal.code::eval_code()].
270		#' Default is `NULL` which won't evaluate any appending code.
271		#' @details
272		#' `srv_decorate_teal_data` is a wrapper around `srv_transform_teal_data` that
273		#' allows to decorate the data with additional expressions.
274		#' When original `teal_data` object is in error state, it will show that error
275		#' first.
276		#'
277		#' @keywords internal
278		srv_decorate_teal_data <- function(id, data, decorators, expr) {
279	!	checkmate::assert_class(data, classes = "reactive")
280	!	checkmate::assert_list(decorators, "teal_transform_module")
281
282	!	no_expr <- missing(expr)
283
284	!	moduleServer(id, function(input, output, session) {
285	!	decorated_output <- srv_transform_teal_data("inner", data = data, transformators = decorators)
286
287	!	expr_r <- if (is.reactive(expr)) expr else reactive(expr)
288
289	!	reactive({
290	!	req(decorated_output())
291	!	if (no_expr) {
292	!	decorated_output()
293		} else {
294	!	teal.code::eval_code(decorated_output(), expr_r())
295		}
296		})
297		})
298		}
299
300		#' @rdname srv_decorate_teal_data
301		#' @details
302		#' `ui_decorate_teal_data` is a wrapper around `ui_transform_teal_data`.
303		#' @keywords internal
304		ui_decorate_teal_data <- function(id, decorators, ...) {
305	!	teal::ui_transform_teal_data(NS(id, "inner"), transformators = decorators, ...)
306		}
307
308		#' Internal function to check if decorators is a valid object
309		#' @noRd
310		check_decorators <- function(x, names = NULL) { # nolint: object_name.
311
312	5x	check_message <- checkmate::check_list(x, names = "named")
313
314	5x	if (!is.null(names)) {
315	5x	if (isTRUE(check_message)) {
316	5x	if (length(names(x)) != length(unique(names(x)))) {
317	!	check_message <- sprintf(
318	!	"The `decorators` must contain unique names from these names: %s.",
319	!	paste(names, collapse = ", ")
320		)
321		}
322		} else {
323	!	check_message <- sprintf(
324	!	"The `decorators` must be a named list from these names: %s.",
325	!	paste(names, collapse = ", ")
326		)
327		}
328		}
329
330	5x	if (!isTRUE(check_message)) {
331	!	return(check_message)
332		}
333
334	5x	valid_elements <- vapply(
335	5x	x,
336	5x	checkmate::test_class,
337	5x	classes = "teal_transform_module",
338	5x	FUN.VALUE = logical(1L)
339		)
340
341	5x	if (all(valid_elements)) {
342	5x	return(TRUE)
343		}
344
345	!	"Make sure that the named list contains 'teal_transform_module' objects created using `teal_transform_module()`."
346		}
347		#' Internal assertion on decorators
348		#' @noRd
349		assert_decorators <- checkmate::makeAssertionFunction(check_decorators)
350
351		#' Subset decorators based on the scope
352		#'
353		#' @param scope (`character`) a character vector of decorator names to include.
354		#' @param decorators (named `list`) of list decorators to subset.
355		#'
356		#' @return Subsetted list with all decorators to include.
357		#' It can be an empty list if none of the scope exists in `decorators` argument.
358		#' @keywords internal
359		select_decorators <- function(decorators, scope) {
360	!	checkmate::assert_character(scope, null.ok = TRUE)
361	!	if (scope %in% names(decorators)) {
362	!	decorators[scope]
363		} else {
364	!	list()
365		}
366		}
367
368		#' Set the attributes of the last chunk outputs
369		#' @param teal_card (`teal_card`) object to modify.
370		#' @param attributes (`list`) of attributes to set on the last chunk outputs.
371		#' @param n (`integer(1)`) number of the last element of `teal_card` to modify.
372		#' it will only change `chunk_output` objects.
373		#' @param inner_classes (`character`) classes within `chunk_output` that should be modified.
374		#' This can be used to only change `recordedplot`, `ggplot2` or other type of objects.
375		#' @keywords internal
376		set_chunk_attrs <- function(teal_card,
377		attributes,
378		n = 1,
379		inner_classes = NULL,
380		quiet = FALSE) {
381	7x	checkmate::assert_class(teal_card, "teal_card")
382	7x	checkmate::assert_list(attributes, names = "unique")
383	7x	checkmate::assert_int(n, lower = 1)
384	7x	checkmate::assert_character(inner_classes, null.ok = TRUE)
385	7x	checkmate::assert_flag(quiet)
386
387	7x	if (!inherits(teal_card[[length(teal_card)]], "chunk_output")) {
388	1x	if (!quiet) {
389	1x	warning("The last element of the `teal_card` is not a `chunk_output` object. No attributes were modified.")
390		}
391	1x	return(teal_card)
392		}
393
394	6x	for (ix in seq_len(length(teal_card))) {
395	14x	if (ix > n) {
396	4x	break
397		}
398	10x	current_ix <- length(teal_card) + 1 - ix
399	10x	if (!inherits(teal_card[[current_ix]], "chunk_output")) {
400	2x	if (!quiet) {
401	1x	warning(
402	1x	"The ", ix,
403	1x	" to last element of the `teal_card` is not a `chunk_output` object. Skipping any further modifications."
404		)
405		}
406	2x	return(teal_card)
407		}
408
409		if (
410	8x	length(inner_classes) > 0 &&
411	8x	length(teal_card[[current_ix]]) >= 1 &&
412	8x	!checkmate::test_multi_class(teal_card[[current_ix]][[1]], inner_classes)
413		) {
414	1x	next
415		}
416
417	7x	attributes(teal_card[[current_ix]]) <- utils::modifyList(
418	7x	attributes(teal_card[[current_ix]]),
419	7x	attributes
420		)
421		}
422
423	4x	teal_card
424		}
425
426		#' Create a reactive that sets plot dimensions on a `teal_card`
427		#'
428		#' This is a convenience function that creates a reactive expression that
429		#' automatically sets the `dev.width` and `dev.height` attributes on the last
430		#' chunk outputs of a `teal_card` based on plot dimensions from a plot widget.
431		#'
432		#' @param pws (`plot_widget`) plot widget that provides dimensions via `dim()` method
433		#' @param q_r (`reactive`) reactive expression that returns a `teal_reporter`
434		#' @param inner_classes (`character`) classes within `chunk_output` that should be modified.
435		#' This can be used to only change `recordedplot`, `ggplot2` or other type of objects.
436		#'
437		#' @return A reactive expression that returns the `teal_card` with updated dimensions
438		#'
439		#' @keywords internal
440		set_chunk_dims <- function(pws, q_r, inner_classes = NULL) {
441	1x	checkmate::assert_list(pws)
442	1x	checkmate::assert_names(names(pws), must.include = "dim")
443	1x	checkmate::assert_class(pws$dim, "reactive")
444	1x	checkmate::assert_class(q_r, "reactive")
445	1x	checkmate::assert_character(inner_classes, null.ok = TRUE)
446
447	1x	reactive({
448	1x	pws_dim <- stats::setNames(as.list(req(pws$dim())), c("width", "height"))
449	1x	if (identical(pws_dim$width, "auto")) { # ignore non-numeric values (such as "auto")
450	1x	pws_dim$width <- NULL
451		}
452	1x	if (identical(pws_dim$height, "auto")) { # ignore non-numeric values (such as "auto")
453	!	pws_dim$height <- NULL
454		}
455	1x	q <- req(q_r())
456	1x	teal.reporter::teal_card(q) <- set_chunk_attrs(
457	1x	teal.reporter::teal_card(q),
458	1x	list(dev.width = pws_dim$width, dev.height = pws_dim$height),
459	1x	inner_classes = inner_classes
460		)
461	1x	q
462		})
463		}

1		#' `teal` module: File viewer
2		#'
3		#' The file viewer module provides a tool to view static files.
4		#' Supported formats include text formats, `PDF`, `PNG` `APNG`,
5		#' `JPEG` `SVG`, `WEBP`, `GIF` and `BMP`.
6		#'
7		#' @inheritParams teal::module
8		#' @inheritParams shared_params
9		#' @param input_path (`list`) of the input paths, optional. Each element can be:
10		#'
11		#' Paths can be specified as absolute paths or relative to the running directory of the application.
12		#' Default to the current working directory if not supplied.
13		#'
14		#' @inherit shared_params return
15		#'
16		#' @examplesShinylive
17		#' library(teal.modules.general)
18		#' interactive <- function() TRUE
19		#' {{ next_example }}
20		#' @examples
21		#' data <- teal_data()
22		#' data <- within(data, {
23		#' data <- data.frame(1)
24		#' })
25		#'
26		#' app <- init(
27		#' data = data,
28		#' modules = modules(
29		#' tm_file_viewer(
30		#' input_path = list(
31		#' folder = system.file("sample_files", package = "teal.modules.general"),
32		#' png = system.file("sample_files/sample_file.png", package = "teal.modules.general"),
33		#' txt = system.file("sample_files/sample_file.txt", package = "teal.modules.general"),
34		#' url = file.path(
35		#' "https://www.fda.gov/files/drugs/published",
36		#' "Portable-Document-Format-Specifications.pdf"
37		#' )
38		#' )
39		#' )
40		#' )
41		#' )
42		#' if (interactive()) {
43		#' shinyApp(app$ui, app$server)
44		#' }
45		#'
46		#' @export
47		#'
48		tm_file_viewer <- function(label = "File Viewer Module",
49		input_path = list("Current Working Directory" = ".")) {
50	!	message("Initializing tm_file_viewer")
51
52		# Normalize the parameters
53	!	if (length(label) == 0 \|\| identical(label, "")) label <- " "
54	!	if (length(input_path) == 0 \|\| identical(input_path, "")) input_path <- list()
55
56		# Start of assertions
57	!	checkmate::assert_string(label)
58
59	!	checkmate::assert(
60	!	checkmate::check_list(input_path, types = "character", min.len = 0),
61	!	checkmate::check_character(input_path, min.len = 1)
62		)
63	!	if (length(input_path) > 0) {
64	!	valid_url <- function(url_input, timeout = 2) {
65	!	con <- try(url(url_input), silent = TRUE)
66	!	check <- suppressWarnings(try(open.connection(con, open = "rt", timeout = timeout), silent = TRUE)[1])
67	!	try(close.connection(con), silent = TRUE)
68	!	is.null(check)
69		}
70	!	idx <- vapply(input_path, function(x) file.exists(x) \|\| valid_url(x), logical(1))
71
72	!	if (!all(idx)) {
73	!	warning(
74	!	paste0(
75	!	"Non-existent file or url path. Please provide valid paths for:\n",
76	!	paste0(input_path[!idx], collapse = "\n")
77		)
78		)
79		}
80	!	input_path <- input_path[idx]
81		} else {
82	!	warning(
83	!	"No file or url paths were provided."
84		)
85		}
86		# End of assertions
87
88		# Make UI args
89	!	args <- as.list(environment())
90
91	!	ans <- module(
92	!	label = label,
93	!	server = srv_viewer,
94	!	server_args = list(input_path = input_path),
95	!	ui = ui_viewer,
96	!	ui_args = args,
97	!	datanames = NULL
98		)
99	!	attr(ans, "teal_bookmarkable") <- FALSE
100	!	ans
101		}
102
103		# UI function for the file viewer module
104		ui_viewer <- function(id, ...) {
105	!	args <- list(...)
106	!	ns <- NS(id)
107
108	!	tagList(
109	!	teal.widgets::standard_layout(
110	!	output = tags$div(
111	!	uiOutput(ns("output"))
112		),
113	!	encoding = tags$div(
114	!	style = "overflow-y: hidden; overflow-x: auto;",
115	!	tags$label("Encodings", class = "text-primary"),
116	!	shinyTree::shinyTree(
117	!	ns("tree"),
118	!	dragAndDrop = FALSE,
119	!	sort = FALSE,
120	!	theme = "proton",
121	!	multiple = FALSE,
122	!	search = TRUE
123		)
124		)
125		)
126		)
127		}
128
129		# Server function for the file viewer module
130		srv_viewer <- function(id, input_path) {
131	!	moduleServer(id, function(input, output, session) {
132	!	teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")
133
134	!	temp_dir <- tempfile()
135	!	if (!dir.exists(temp_dir)) {
136	!	dir.create(temp_dir, recursive = TRUE)
137		}
138	!	addResourcePath(basename(temp_dir), temp_dir)
139
140	!	test_path_text <- function(selected_path, type) {
141	!	out <- tryCatch(
142	!	expr = {
143	!	if (type != "url") {
144	!	selected_path <- normalizePath(selected_path, winslash = "/")
145		}
146	!	readLines(con = selected_path)
147		},
148	!	error = function(cond) FALSE,
149	!	warning = function(cond) {
150	!	`if`(grepl("^incomplete final line found on", cond[[1]]), suppressWarnings(eval(cond[[2]])), FALSE)
151		}
152		)
153		}
154
155	!	handle_connection_type <- function(selected_path) {
156	!	file_extension <- tools::file_ext(selected_path)
157	!	file_class <- suppressWarnings(file(selected_path))
158	!	close(file_class)
159
160	!	output_text <- test_path_text(selected_path, type = class(file_class)[1])
161
162	!	if (class(file_class)[1] == "url") {
163	!	list(selected_path = selected_path, output_text = output_text)
164		} else {
165	!	file.copy(normalizePath(selected_path, winslash = "/"), temp_dir)
166	!	selected_path <- file.path(basename(temp_dir), basename(selected_path))
167	!	list(selected_path = selected_path, output_text = output_text)
168		}
169		}
170
171	!	display_file <- function(selected_path) {
172	!	con_type <- handle_connection_type(selected_path)
173	!	file_extension <- tools::file_ext(selected_path)
174	!	if (file_extension %in% c("png", "apng", "jpg", "jpeg", "svg", "gif", "webp", "bmp")) {
175	!	tags$img(src = con_type$selected_path, alt = "file does not exist")
176	!	} else if (file_extension == "pdf") {
177	!	tags$embed(
178	!	style = "height: 600px; width: 100%;",
179	!	src = con_type$selected_path
180		)
181	!	} else if (!isFALSE(con_type$output_text[1])) {
182	!	tags$pre(paste0(con_type$output_text, collapse = "\n"))
183		} else {
184	!	tags$p("Please select a supported format.")
185		}
186		}
187
188	!	tree_list <- function(file_or_dir) {
189	!	nested_list <- lapply(file_or_dir, function(path) {
190	!	file_class <- suppressWarnings(file(path))
191	!	close(file_class)
192	!	if (class(file_class)[[1]] != "url") {
193	!	isdir <- file.info(path)$isdir
194	!	if (!isdir) {
195	!	structure(path, ancestry = path, sticon = "file")
196		} else {
197	!	files <- list.files(path, full.names = TRUE, include.dirs = TRUE)
198	!	out <- lapply(files, function(x) tree_list(x))
199	!	out <- unlist(out, recursive = FALSE)
200	!	if (length(files) > 0) names(out) <- basename(files)
201	!	out
202		}
203		} else {
204	!	structure(path, ancestry = path, sticon = "file")
205		}
206		})
207
208	!	missing_labels <- if (is.null(names(nested_list))) seq_along(nested_list) else which(names(nested_list) == "")
209	!	names(nested_list)[missing_labels] <- file_or_dir[missing_labels]
210	!	nested_list
211		}
212
213	!	output$tree <- shinyTree::renderTree({
214	!	if (length(input_path) > 0) {
215	!	tree_list(input_path)
216		} else {
217	!	list("Empty Path" = NULL)
218		}
219		})
220
221	!	output$output <- renderUI({
222	!	validate(
223	!	need(
224	!	length(shinyTree::get_selected(input$tree)) > 0,
225	!	"Please select a file."
226		)
227		)
228
229	!	obj <- shinyTree::get_selected(input$tree, format = "names")[[1]]
230	!	repo <- attr(obj, "ancestry")
231	!	repo_collapsed <- if (length(repo) > 1) paste0(repo, collapse = "/") else repo
232	!	is_not_named <- file.exists(file.path(c(repo_collapsed, obj[1])))[1]
233
234	!	if (is_not_named) {
235	!	selected_path <- do.call("file.path", as.list(c(repo, obj[1])))
236		} else {
237	!	if (length(repo) == 0) {
238	!	selected_path <- do.call("file.path", as.list(attr(input$tree[[obj[1]]], "ancestry")))
239		} else {
240	!	selected_path <- do.call("file.path", as.list(attr(input$tree[[repo]][[obj[1]]], "ancestry")))
241		}
242		}
243
244	!	validate(
245	!	need(
246	!	!isTRUE(file.info(selected_path)$isdir) && length(selected_path) > 0,
247	!	"Please select a single file."
248		)
249		)
250	!	display_file(selected_path)
251		})
252
253	!	onStop(function() {
254	!	removeResourcePath(basename(temp_dir))
255	!	unlink(temp_dir)
256		})
257		})
258		}

1		#' `teal` module: Scatterplot matrix
2		#'
3		#' Generates a scatterplot matrix from selected `variables` from datasets.
4		#' Each plot within the matrix represents the relationship between two variables,
5		#' providing the overview of correlations and distributions across selected data.
6		#'
7		#' @note For more examples, please see the vignette "Using scatterplot matrix" via
8		#' `vignette("using-scatterplot-matrix", package = "teal.modules.general")`.
9		#'
10		#' @inheritParams teal::module
11		#' @inheritParams tm_g_scatterplot
12		#' @inheritParams shared_params
13		#'
14		#' @param variables (`data_extract_spec` or `list` of multiple `data_extract_spec`)
15		#' Specifies plotting variables from an incoming dataset with filtering and selecting. In case of
16		#' `data_extract_spec` use `select_spec(..., ordered = TRUE)` if plot elements should be
17		#' rendered according to selection order.
18		#'
19		#' @inherit shared_params return
20		#'
21		#' @section Decorating Module:
22		#'
23		#' This module generates the following objects, which can be modified in place using decorators:
24		#' - `plot` (`trellis` - output of `lattice::splom`)
25		#'
26		#' A Decorator is applied to the specific output using a named list of `teal_transform_module` objects.
27		#' The name of this list corresponds to the name of the output to which the decorator is applied.
28		#' See code snippet below:
29		#'
30		#' ```
31		#' tm_g_scatterplotmatrix(
32		#' ..., # arguments for module
33		#' decorators = list(
34		#' plot = teal_transform_module(...) # applied to the `plot` output
35		#' )
36		#' )
37		#' ```
38		#'
39		#' For additional details and examples of decorators, refer to the vignette
40		#' `vignette("decorate-module-output", package = "teal.modules.general")`.
41		#'
42		#' To learn more please refer to the vignette
43		#' `vignette("transform-module-output", package = "teal")` or the [`teal::teal_transform_module()`] documentation.
44		#'
45		#' @inheritSection teal::example_module Reporting
46		#'
47		#' @examplesShinylive
48		#' library(teal.modules.general)
49		#' interactive <- function() TRUE
50		#' {{ next_example }}
51		#' @examples
52		#' # general data example
53		#' data <- teal_data()
54		#' data <- within(data, {
55		#' countries <- data.frame(
56		#' id = c("DE", "FR", "IT", "ES", "PT", "GR", "NL", "BE", "LU", "AT"),
57		#' government = factor(
58		#' c(2, 2, 2, 1, 2, 2, 1, 1, 1, 2),
59		#' labels = c("Monarchy", "Republic")
60		#' ),
61		#' language_family = factor(
62		#' c(1, 3, 3, 3, 3, 2, 1, 1, 3, 1),
63		#' labels = c("Germanic", "Hellenic", "Romance")
64		#' ),
65		#' population = c(83, 67, 60, 47, 10, 11, 17, 11, 0.6, 9),
66		#' area = c(357, 551, 301, 505, 92, 132, 41, 30, 2.6, 83),
67		#' gdp = c(3.4, 2.7, 2.1, 1.4, 0.3, 0.2, 0.7, 0.5, 0.1, 0.4),
68		#' debt = c(2.1, 2.3, 2.4, 2.6, 2.3, 2.4, 2.3, 2.4, 2.3, 2.4)
69		#' )
70		#' sales <- data.frame(
71		#' id = 1:50,
72		#' country_id = sample(
73		#' c("DE", "FR", "IT", "ES", "PT", "GR", "NL", "BE", "LU", "AT"),
74		#' size = 50,
75		#' replace = TRUE
76		#' ),
77		#' year = sort(sample(2010:2020, 50, replace = TRUE)),
78		#' venue = sample(c("small", "medium", "large", "online"), 50, replace = TRUE),
79		#' cancelled = sample(c(TRUE, FALSE), 50, replace = TRUE),
80		#' quantity = rnorm(50, 100, 20),
81		#' costs = rnorm(50, 80, 20),
82		#' profit = rnorm(50, 20, 10)
83		#' )
84		#' })
85		#' join_keys(data) <- join_keys(
86		#' join_key("countries", "countries", "id"),
87		#' join_key("sales", "sales", "id"),
88		#' join_key("countries", "sales", c("id" = "country_id"))
89		#' )
90		#'
91		#' app <- init(
92		#' data = data,
93		#' modules = modules(
94		#' tm_g_scatterplotmatrix(
95		#' label = "Scatterplot matrix",
96		#' variables = list(
97		#' data_extract_spec(
98		#' dataname = "countries",
99		#' select = select_spec(
100		#' label = "Select variables:",
101		#' choices = variable_choices(data[["countries"]]),
102		#' selected = c("area", "gdp", "debt"),
103		#' multiple = TRUE,
104		#' ordered = TRUE,
105		#' fixed = FALSE
106		#' )
107		#' ),
108		#' data_extract_spec(
109		#' dataname = "sales",
110		#' filter = filter_spec(
111		#' label = "Select variable:",
112		#' vars = "country_id",
113		#' choices = value_choices(data[["sales"]], "country_id"),
114		#' selected = c("DE", "FR", "IT", "PT", "GR", "NL", "BE", "LU", "AT"),
115		#' multiple = TRUE
116		#' ),
117		#' select = select_spec(
118		#' label = "Select variables:",
119		#' choices = variable_choices(data[["sales"]], c("quantity", "costs", "profit")),
120		#' selected = c("quantity", "costs", "profit"),
121		#' multiple = TRUE,
122		#' ordered = TRUE,
123		#' fixed = FALSE
124		#' )
125		#' )
126		#' )
127		#' )
128		#' )
129		#' )
130		#' if (interactive()) {
131		#' shinyApp(app$ui, app$server)
132		#' }
133		#'
134		#' @examplesShinylive
135		#' library(teal.modules.general)
136		#' interactive <- function() TRUE
137		#' {{ next_example }}
138		#' @examples
139		#' # CDISC data example
140		#' data <- teal_data()
141		#' data <- within(data, {
142		#' ADSL <- teal.data::rADSL
143		#' ADRS <- teal.data::rADRS
144		#' })
145		#' join_keys(data) <- default_cdisc_join_keys[names(data)]
146		#'
147		#' app <- init(
148		#' data = data,
149		#' modules = modules(
150		#' tm_g_scatterplotmatrix(
151		#' label = "Scatterplot matrix",
152		#' variables = list(
153		#' data_extract_spec(
154		#' dataname = "ADSL",
155		#' select = select_spec(
156		#' label = "Select variables:",
157		#' choices = variable_choices(data[["ADSL"]]),
158		#' selected = c("AGE", "RACE", "SEX"),
159		#' multiple = TRUE,
160		#' ordered = TRUE,
161		#' fixed = FALSE
162		#' )
163		#' ),
164		#' data_extract_spec(
165		#' dataname = "ADRS",
166		#' filter = filter_spec(
167		#' label = "Select endpoints:",
168		#' vars = c("PARAMCD", "AVISIT"),
169		#' choices = value_choices(data[["ADRS"]], c("PARAMCD", "AVISIT"), c("PARAM", "AVISIT")),
170		#' selected = "INVET - END OF INDUCTION",
171		#' multiple = TRUE
172		#' ),
173		#' select = select_spec(
174		#' label = "Select variables:",
175		#' choices = variable_choices(data[["ADRS"]]),
176		#' selected = c("AGE", "AVAL", "ADY"),
177		#' multiple = TRUE,
178		#' ordered = TRUE,
179		#' fixed = FALSE
180		#' )
181		#' )
182		#' )
183		#' )
184		#' )
185		#' )
186		#' if (interactive()) {
187		#' shinyApp(app$ui, app$server)
188		#' }
189		#'
190		#' @export
191		#'
192		tm_g_scatterplotmatrix <- function(label = "Scatterplot Matrix",
193		variables,
194		plot_height = c(600, 200, 2000),
195		plot_width = NULL,
196		pre_output = NULL,
197		post_output = NULL,
198		transformators = list(),
199		decorators = list()) {
200	!	message("Initializing tm_g_scatterplotmatrix")
201
202		# Normalize the parameters
203	!	if (inherits(variables, "data_extract_spec")) variables <- list(variables)
204
205		# Start of assertions
206	!	checkmate::assert_string(label)
207	!	checkmate::assert_list(variables, types = "data_extract_spec")
208
209	!	checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
210	!	checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")
211	!	checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
212	!	checkmate::assert_numeric(
213	!	plot_width[1],
214	!	lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"
215		)
216
217	!	checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
218	!	checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
219
220	!	assert_decorators(decorators, "plot")
221		# End of assertions
222
223		# Make UI args
224	!	args <- as.list(environment())
225
226	!	ans <- module(
227	!	label = label,
228	!	server = srv_g_scatterplotmatrix,
229	!	ui = ui_g_scatterplotmatrix,
230	!	ui_args = args,
231	!	server_args = list(
232	!	variables = variables,
233	!	plot_height = plot_height,
234	!	plot_width = plot_width,
235	!	decorators = decorators
236		),
237	!	transformators = transformators,
238	!	datanames = teal.transform::get_extract_datanames(variables)
239		)
240	!	attr(ans, "teal_bookmarkable") <- TRUE
241	!	ans
242		}
243
244		# UI function for the scatterplot matrix module
245		ui_g_scatterplotmatrix <- function(id, ...) {
246	!	args <- list(...)
247	!	is_single_dataset_value <- teal.transform::is_single_dataset(args$variables)
248	!	ns <- NS(id)
249	!	teal.widgets::standard_layout(
250	!	output = teal.widgets::white_small_well(
251	!	textOutput(ns("message")),
252	!	tags$br(),
253	!	teal.widgets::plot_with_settings_ui(id = ns("myplot"))
254		),
255	!	encoding = tags$div(
256	!	tags$label("Encodings", class = "text-primary"),
257	!	teal.transform::datanames_input(args$variables),
258	!	teal.transform::data_extract_ui(
259	!	id = ns("variables"),
260	!	label = "Variables",
261	!	data_extract_spec = args$variables,
262	!	is_single_dataset = is_single_dataset_value
263		),
264	!	tags$hr(),
265	!	ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "plot")),
266	!	bslib::accordion(
267	!	open = TRUE,
268	!	bslib::accordion_panel(
269	!	title = "Plot settings",
270	!	sliderInput(
271	!	ns("alpha"), "Opacity:",
272	!	min = 0, max = 1,
273	!	step = .05, value = .5, ticks = FALSE
274		),
275	!	sliderInput(
276	!	ns("cex"), "Points size:",
277	!	min = 0.2, max = 3,
278	!	step = .05, value = .65, ticks = FALSE
279		),
280	!	checkboxInput(ns("cor"), "Add Correlation", value = FALSE),
281	!	radioButtons(
282	!	ns("cor_method"), "Select Correlation Method",
283	!	choiceNames = c("Pearson", "Kendall", "Spearman"),
284	!	choiceValues = c("pearson", "kendall", "spearman"),
285	!	inline = TRUE
286		),
287	!	checkboxInput(ns("cor_na_omit"), "Omit Missing Values", value = TRUE)
288		)
289		)
290		),
291	!	pre_output = args$pre_output,
292	!	post_output = args$post_output
293		)
294		}
295
296		# Server function for the scatterplot matrix module
297		srv_g_scatterplotmatrix <- function(id,
298		data,
299		variables,
300		plot_height,
301		plot_width,
302		decorators) {
303	!	checkmate::assert_class(data, "reactive")
304	!	checkmate::assert_class(isolate(data()), "teal_data")
305	!	moduleServer(id, function(input, output, session) {
306	!	teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")
307
308	!	selector_list <- teal.transform::data_extract_multiple_srv(
309	!	data_extract = list(variables = variables),
310	!	datasets = data,
311	!	select_validation_rule = list(
312	!	variables = ~ if (length(.) <= 1) "Please select at least 2 columns."
313		)
314		)
315
316	!	iv_r <- reactive({
317	!	iv <- shinyvalidate::InputValidator$new()
318	!	teal.transform::compose_and_enable_validators(iv, selector_list)
319		})
320
321	!	anl_merged_input <- teal.transform::merge_expression_srv(
322	!	datasets = data,
323	!	selector_list = selector_list
324		)
325
326	!	anl_merged_q <- reactive({
327	!	req(anl_merged_input())
328	!	obj <- data()
329	!	teal.reporter::teal_card(obj) <- c(
330	!	teal.reporter::teal_card(obj),
331	!	teal.reporter::teal_card("## Module's output(s)")
332		)
333	!	qenv <- teal.code::eval_code(obj, "library(dplyr);library(lattice)")
334	!	teal.code::eval_code(qenv, as.expression(anl_merged_input()$expr))
335		})
336
337	!	merged <- list(
338	!	anl_input_r = anl_merged_input,
339	!	anl_q_r = anl_merged_q
340		)
341
342		# plot
343	!	output_q <- reactive({
344	!	teal::validate_inputs(iv_r())
345
346	!	qenv <- merged$anl_q_r()
347	!	ANL <- qenv[["ANL"]]
348
349	!	cols_names <- merged$anl_input_r()$columns_source$variables
350	!	alpha <- input$alpha
351	!	cex <- input$cex
352	!	add_cor <- input$cor
353	!	cor_method <- input$cor_method
354	!	cor_na_omit <- input$cor_na_omit
355
356	!	cor_na_action <- if (isTruthy(cor_na_omit)) {
357	!	"na.omit"
358		} else {
359	!	"na.fail"
360		}
361
362	!	teal::validate_has_data(ANL, 10)
363	!	teal::validate_has_data(ANL[, cols_names, drop = FALSE], 10, complete = TRUE, allow_inf = FALSE)
364
365		# get labels and proper variable names
366	!	varnames <- varname_w_label(cols_names, ANL, wrap_width = 20)
367
368		# check character columns. If any, then those are converted to factors
369	!	check_char <- vapply(ANL[, cols_names], is.character, logical(1))
370	!	if (any(check_char)) {
371	!	qenv <- teal.code::eval_code(
372	!	qenv,
373	!	substitute(
374	!	expr = ANL <- ANL[, cols_names] %>%
375	!	dplyr::mutate_if(is.character, as.factor) %>%
376	!	droplevels(),
377	!	env = list(cols_names = cols_names)
378		)
379		)
380		} else {
381	!	qenv <- teal.code::eval_code(
382	!	qenv,
383	!	substitute(
384	!	expr = ANL <- ANL[, cols_names] %>%
385	!	droplevels(),
386	!	env = list(cols_names = cols_names)
387		)
388		)
389		}
390
391
392		# create plot
393	!	teal.reporter::teal_card(qenv) <- c(teal.reporter::teal_card(qenv), "### Plot")
394
395	!	if (add_cor) {
396	!	shinyjs::show("cor_method")
397	!	shinyjs::show("cor_use")
398	!	shinyjs::show("cor_na_omit")
399
400	!	qenv <- teal.code::eval_code(
401	!	qenv,
402	!	substitute(
403	!	expr = {
404	!	plot <- lattice::splom(
405	!	ANL,
406	!	varnames = varnames_value,
407	!	panel = function(x, y, ...) {
408	!	lattice::panel.splom(x = x, y = y, ...)
409	!	cpl <- lattice::current.panel.limits()
410	!	lattice::panel.text(
411	!	mean(cpl$xlim),
412	!	mean(cpl$ylim),
413	!	get_scatterplotmatrix_stats(
414	!	x,
415	!	y,
416	!	.f = stats::cor.test,
417	!	.f_args = list(method = cor_method, na.action = cor_na_action)
418		),
419	!	alpha = 0.6,
420	!	fontsize = 18,
421	!	fontface = "bold"
422		)
423		},
424	!	pch = 16,
425	!	alpha = alpha_value,
426	!	cex = cex_value
427		)
428		},
429	!	env = list(
430	!	varnames_value = varnames,
431	!	cor_method = cor_method,
432	!	cor_na_action = cor_na_action,
433	!	alpha_value = alpha,
434	!	cex_value = cex
435		)
436		)
437		)
438		} else {
439	!	shinyjs::hide("cor_method")
440	!	shinyjs::hide("cor_use")
441	!	shinyjs::hide("cor_na_omit")
442	!	qenv <- teal.code::eval_code(
443	!	qenv,
444	!	substitute(
445	!	expr = {
446	!	plot <- lattice::splom(
447	!	ANL,
448	!	varnames = varnames_value,
449	!	pch = 16,
450	!	alpha = alpha_value,
451	!	cex = cex_value
452		)
453		},
454	!	env = list(varnames_value = varnames, alpha_value = alpha, cex_value = cex)
455		)
456		)
457		}
458	!	qenv
459		})
460
461	!	decorated_output_q <- srv_decorate_teal_data(
462	!	id = "decorator",
463	!	data = output_q,
464	!	decorators = select_decorators(decorators, "plot"),
465	!	expr = quote(plot)
466		)
467
468	!	plot_r <- reactive(req(decorated_output_q())[["plot"]])
469
470		# Insert the plot into a plot_with_settings module
471	!	pws <- teal.widgets::plot_with_settings_srv(
472	!	id = "myplot",
473	!	plot_r = plot_r,
474	!	height = plot_height,
475	!	width = plot_width
476		)
477
478		# show a message if conversion to factors took place
479	!	output$message <- renderText({
480	!	req(iv_r()$is_valid())
481	!	req(selector_list()$variables())
482	!	ANL <- merged$anl_q_r()[["ANL"]]
483	!	cols_names <- unique(unname(do.call(c, merged$anl_input_r()$columns_source)))
484	!	check_char <- vapply(ANL[, cols_names], is.character, logical(1))
485	!	if (any(check_char)) {
486	!	is_single <- sum(check_char) == 1
487	!	paste(
488	!	"Character",
489	!	ifelse(is_single, "variable", "variables"),
490	!	paste0("(", paste(cols_names[check_char], collapse = ", "), ")"),
491	!	ifelse(is_single, "was", "were"),
492	!	"converted to",
493	!	ifelse(is_single, "factor.", "factors.")
494		)
495		} else {
496		""
497		}
498		})
499
500	!	set_chunk_dims(pws, decorated_output_q)
501		})
502		}
503
504		#' Get stats for x-y pairs in scatterplot matrix
505		#'
506		#' Uses [stats::cor.test()] per default for all numerical input variables and converts results
507		#' to character vector.
508		#' Could be extended if different stats for different variable types are needed.
509		#' Meant to be called from [lattice::panel.text()].
510		#'
511		#' Presently we need to use a formula input for `stats::cor.test` because
512		#' `na.fail` only gets evaluated when a formula is passed (see below).
513		#' ```
514		#' x = c(1,3,5,7,NA)
515		#' y = c(3,6,7,8,1)
516		#' stats::cor.test(x, y, na.action = "na.fail")
517		#' stats::cor.test(~ x + y, na.action = "na.fail")
518		#' ```
519		#'
520		#' @param x,y (`numeric`) vectors of data values. `x` and `y` must have the same length.
521		#' @param .f (`function`) function that accepts x and y as formula input `~ x + y`.
522		#' Default `stats::cor.test`.
523		#' @param .f_args (`list`) of arguments to be passed to `.f`.
524		#' @param round_stat (`integer(1)`) optional, number of decimal places to use when rounding the estimate.
525		#' @param round_pval (`integer(1)`) optional, number of decimal places to use when rounding the p-value.
526		#'
527		#' @return Character with stats. For [stats::cor.test()] correlation coefficient and p-value.
528		#'
529		#' @examples
530		#' set.seed(1)
531		#' x <- runif(25, 0, 1)
532		#' y <- runif(25, 0, 1)
533		#' x[c(3, 10, 18)] <- NA
534		#'
535		#' get_scatterplotmatrix_stats(x, y, .f = stats::cor.test, .f_args = list(method = "pearson"))
536		#' get_scatterplotmatrix_stats(x, y, .f = stats::cor.test, .f_args = list(
537		#' method = "pearson",
538		#' na.action = na.fail
539		#' ))
540		#'
541		#' @export
542		#'
543		get_scatterplotmatrix_stats <- function(x, y,
544		.f = stats::cor.test,
545		.f_args = list(),
546		round_stat = 2,
547		round_pval = 4) {
548	6x	if (is.numeric(x) && is.numeric(y)) {
549	3x	stat <- tryCatch(do.call(.f, c(list(~ x + y), .f_args)), error = function(e) NA)
550
551	3x	if (anyNA(stat)) {
552	1x	return("NA")
553	2x	} else if (all(c("estimate", "p.value") %in% names(stat))) {
554	2x	return(paste(
555	2x	c(
556	2x	paste0(names(stat$estimate), ":", round(stat$estimate, round_stat)),
557	2x	paste0("P:", round(stat$p.value, round_pval))
558		),
559	2x	collapse = "\n"
560		))
561		} else {
562	!	stop("function not supported")
563		}
564		} else {
565	3x	if ("method" %in% names(.f_args)) {
566	3x	if (.f_args$method == "pearson") {
567	1x	return("cor:-")
568		}
569	2x	if (.f_args$method == "kendall") {
570	1x	return("tau:-")
571		}
572	1x	if (.f_args$method == "spearman") {
573	1x	return("rho:-")
574		}
575		}
576	!	return("-")
577		}
578		}

1		#' `teal` module: Data table viewer
2		#'
3		#' Module provides a dynamic and interactive way to view `data.frame`s in a `teal` application.
4		#' It uses the `DT` package to display data tables in a paginated, searchable, and sortable format,
5		#' which helps to enhance data exploration and analysis.
6		#'
7		#' The `DT` package has an option `DT.TOJSON_ARGS` to show `Inf` and `NA` in data tables.
8		#' Configure the `DT.TOJSON_ARGS` option via
9		#' `options(DT.TOJSON_ARGS = list(na = "string"))` before running the module.
10		#' Note though that sorting of numeric columns with `NA`/`Inf` will be lexicographic not numerical.
11		#'
12		#' @inheritParams teal::module
13		#' @inheritParams shared_params
14		#' @param variables_selected (`named list`) Character vectors of the variables (i.e. columns)
15		#' which should be initially shown for each dataset.
16		#' Names of list elements should correspond to the names of the datasets available in the app.
17		#' If no entry is specified for a dataset, the first six variables from that
18		#' dataset will initially be shown.
19		#' @param datasets_selected (`character`) `r lifecycle::badge("deprecated")` A vector of datasets which should be
20		#' shown and in what order. Use `datanames` instead.
21		#' @param dt_args (`named list`) Additional arguments to be passed to [DT::datatable()]
22		#' (must not include `data` or `options`).
23		#' @param dt_options (`named list`) The `options` argument to `DT::datatable`. By default
24		#' `list(searching = FALSE, pageLength = 30, lengthMenu = c(5, 15, 30, 100), scrollX = TRUE)`
25		#' @param server_rendering (`logical`) should the data table be rendered server side
26		#' (see `server` argument of [DT::renderDataTable()])
27		#'
28		#' @inherit shared_params return
29		#'
30		#' @examplesShinylive
31		#' library(teal.modules.general)
32		#' interactive <- function() TRUE
33		#' {{ next_example }}
34		#' @examples
35		#' # general data example
36		#' data <- teal_data()
37		#' data <- within(data, {
38		#' require(nestcolor)
39		#' iris <- iris
40		#' })
41		#'
42		#' app <- init(
43		#' data = data,
44		#' modules = modules(
45		#' tm_data_table(
46		#' variables_selected = list(
47		#' iris = c("Sepal.Length", "Sepal.Width", "Petal.Length", "Petal.Width", "Species")
48		#' ),
49		#' dt_args = list(caption = "IRIS Table Caption")
50		#' )
51		#' )
52		#' )
53		#' if (interactive()) {
54		#' shinyApp(app$ui, app$server)
55		#' }
56		#'
57		#' @examplesShinylive
58		#' library(teal.modules.general)
59		#' interactive <- function() TRUE
60		#' {{ next_example }}
61		#' @examples
62		#' # CDISC data example
63		#' data <- teal_data()
64		#' data <- within(data, {
65		#' require(nestcolor)
66		#' ADSL <- teal.data::rADSL
67		#' })
68		#' join_keys(data) <- default_cdisc_join_keys[names(data)]
69		#'
70		#' app <- init(
71		#' data = data,
72		#' modules = modules(
73		#' tm_data_table(
74		#' variables_selected = list(ADSL = c("STUDYID", "USUBJID", "SUBJID", "SITEID", "AGE", "SEX")),
75		#' dt_args = list(caption = "ADSL Table Caption")
76		#' )
77		#' )
78		#' )
79		#' if (interactive()) {
80		#' shinyApp(app$ui, app$server)
81		#' }
82		#'
83		#' @export
84		#'
85		tm_data_table <- function(label = "Data Table",
86		variables_selected = list(),
87		datasets_selected = deprecated(),
88		datanames = if (missing(datasets_selected)) "all" else datasets_selected,
89		dt_args = list(),
90		dt_options = list(
91		searching = FALSE,
92		pageLength = 30,
93		lengthMenu = c(5, 15, 30, 100),
94		scrollX = TRUE
95		),
96		server_rendering = FALSE,
97		pre_output = NULL,
98		post_output = NULL,
99		transformators = list()) {
100	!	message("Initializing tm_data_table")
101
102		# Start of assertions
103	!	checkmate::assert_string(label)
104
105	!	checkmate::assert_list(variables_selected, min.len = 0, types = "character", names = "named")
106	!	if (length(variables_selected) > 0) {
107	!	lapply(seq_along(variables_selected), function(i) {
108	!	checkmate::assert_character(variables_selected[[i]], min.chars = 1, min.len = 1)
109	!	if (!is.null(names(variables_selected[[i]]))) {
110	!	checkmate::assert_names(names(variables_selected[[i]]))
111		}
112		})
113		}
114	!	if (!missing(datasets_selected)) {
115	!	lifecycle::deprecate_stop(
116	!	when = "0.4.0",
117	!	what = "tm_data_table(datasets_selected)",
118	!	with = "tm_data_table(datanames)",
119	!	details = 'Use tm_data_table(datanames = "all") to keep the previous behavior and avoid this warning.',
120		)
121		}
122	!	checkmate::assert_character(datanames, min.len = 0, min.chars = 1, null.ok = TRUE)
123	!	checkmate::assert(
124	!	checkmate::check_list(dt_args, len = 0),
125	!	checkmate::check_subset(names(dt_args), choices = names(formals(DT::datatable)))
126		)
127	!	checkmate::assert_list(dt_options, names = "named")
128	!	checkmate::assert_flag(server_rendering)
129	!	checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
130	!	checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
131
132		# End of assertions
133
134	!	ans <- module(
135	!	label,
136	!	server = srv_page_data_table,
137	!	ui = ui_page_data_table,
138	!	datanames = datanames,
139	!	server_args = list(
140	!	datanames = if (is.null(datanames)) "all" else datanames,
141	!	variables_selected = variables_selected,
142	!	dt_args = dt_args,
143	!	dt_options = dt_options,
144	!	server_rendering = server_rendering
145		),
146	!	ui_args = list(
147	!	pre_output = pre_output,
148	!	post_output = post_output
149		),
150	!	transformators = transformators
151		)
152	!	attr(ans, "teal_bookmarkable") <- TRUE
153	!	ans
154		}
155
156		# UI page module
157		ui_page_data_table <- function(id, pre_output = NULL, post_output = NULL) {
158	!	ns <- NS(id)
159
160	!	tagList(
161	!	teal.widgets::standard_layout(
162	!	output = teal.widgets::white_small_well(
163	!	bslib::page_fluid(
164	!	checkboxInput(
165	!	ns("if_distinct"),
166	!	"Show only distinct rows:",
167	!	value = FALSE
168		)
169		),
170	!	bslib::page_fluid(
171	!	uiOutput(ns("dataset_table"))
172		)
173		),
174	!	pre_output = pre_output,
175	!	post_output = post_output
176		)
177		)
178		}
179
180		# Server page module
181		srv_page_data_table <- function(id,
182		data,
183		datanames,
184		variables_selected,
185		dt_args,
186		dt_options,
187		server_rendering) {
188	!	checkmate::assert_class(data, "reactive")
189	!	checkmate::assert_class(isolate(data()), "teal_data")
190	!	moduleServer(id, function(input, output, session) {
191	!	teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")
192
193	!	if_filtered <- reactive(as.logical(input$if_filtered))
194	!	if_distinct <- reactive(as.logical(input$if_distinct))
195
196	!	datanames <- Filter(function(name) {
197	!	is.data.frame(isolate(data())[[name]])
198	!	}, if (identical(datanames, "all")) names(isolate(data())) else datanames)
199
200
201	!	output$dataset_table <- renderUI({
202	!	do.call(
203	!	tabsetPanel,
204	!	c(
205	!	list(id = session$ns("dataname_tab")),
206	!	lapply(
207	!	datanames,
208	!	function(x) {
209	!	dataset <- isolate(data()[[x]])
210	!	choices <- names(dataset)
211	!	labels <- vapply(
212	!	dataset,
213	!	function(x) ifelse(is.null(attr(x, "label")), "", attr(x, "label")),
214	!	character(1)
215		)
216	!	names(choices) <- ifelse(
217	!	is.na(labels) \| labels == "",
218	!	choices,
219	!	paste(choices, labels, sep = ": ")
220		)
221	!	variables_selected <- if (!is.null(variables_selected[[x]])) {
222	!	variables_selected[[x]]
223		} else {
224	!	utils::head(choices)
225		}
226	!	tabPanel(
227	!	title = x,
228	!	bslib::layout_columns(
229	!	col_widths = 12,
230	!	ui_data_table(
231	!	id = session$ns(x),
232	!	choices = choices,
233	!	selected = variables_selected
234		)
235		)
236		)
237		}
238		)
239		)
240		)
241		})
242
243	!	lapply(
244	!	datanames,
245	!	function(x) {
246	!	srv_data_table(
247	!	id = x,
248	!	data = data,
249	!	dataname = x,
250	!	if_filtered = if_filtered,
251	!	if_distinct = if_distinct,
252	!	dt_args = dt_args,
253	!	dt_options = dt_options,
254	!	server_rendering = server_rendering
255		)
256		}
257		)
258		})
259		}
260
261		# UI function for the data_table module
262		ui_data_table <- function(id, choices, selected) {
263	!	ns <- NS(id)
264
265	!	if (!is.null(selected)) {
266	!	all_choices <- choices
267	!	choices <- c(selected, setdiff(choices, selected))
268	!	names(choices) <- names(all_choices)[match(choices, all_choices)]
269		}
270
271	!	tagList(
272	!	teal.widgets::get_dt_rows(ns("data_table"), ns("dt_rows")),
273	!	bslib::page_fluid(
274	!	teal.widgets::optionalSelectInput(
275	!	ns("variables"),
276	!	"Select variables:",
277	!	choices = choices,
278	!	selected = selected,
279	!	multiple = TRUE,
280	!	width = "100%"
281		)
282		),
283	!	bslib::page_fluid(
284	!	DT::dataTableOutput(ns("data_table"), width = "100%")
285		)
286		)
287		}
288
289		# Server function for the data_table module
290		srv_data_table <- function(id,
291		data,
292		dataname,
293		if_filtered,
294		if_distinct,
295		dt_args,
296		dt_options,
297		server_rendering) {
298	!	moduleServer(id, function(input, output, session) {
299	!	iv <- shinyvalidate::InputValidator$new()
300	!	iv$add_rule("variables", shinyvalidate::sv_required("Please select valid variable names"))
301	!	iv$add_rule("variables", shinyvalidate::sv_in_set(
302	!	set = names(isolate(data())[[dataname]]), message_fmt = "Not all selected variables exist in the data"
303		))
304	!	iv$enable()
305
306	!	data_table_data <- reactive({
307	!	df <- data()[[dataname]]
308
309	!	teal::validate_has_data(df, min_nrow = 1L, msg = paste("data", dataname, "is empty"))
310	!	qenv <- teal.code::eval_code(
311	!	data(),
312	!	"library(dplyr);library(DT)"
313		)
314	!	teal.code::eval_code(
315	!	qenv,
316	!	substitute(
317	!	expr = {
318	!	variables <- vars
319	!	dataframe_selected <- if (if_distinct) {
320	!	dplyr::count(dataname, dplyr::across(dplyr::all_of(variables)))
321		} else {
322	!	dataname[variables]
323		}
324	!	dt_args <- args
325	!	dt_args$options <- dt_options
326	!	if (!is.null(dt_rows)) {
327	!	dt_args$options$pageLength <- dt_rows
328		}
329	!	dt_args$data <- dataframe_selected
330	!	table <- do.call(DT::datatable, dt_args)
331		},
332	!	env = list(
333	!	dataname = as.name(dataname),
334	!	if_distinct = if_distinct(),
335	!	vars = input$variables,
336	!	args = dt_args,
337	!	dt_options = dt_options,
338	!	dt_rows = input$dt_rows
339		)
340		)
341		)
342		})
343
344	!	output$data_table <- DT::renderDataTable(server = server_rendering, {
345	!	teal::validate_inputs(iv)
346	!	req(data_table_data())[["table"]]
347		})
348		})
349		}

1		.onLoad <- function(libname, pkgname) {
2	!	teal.logger::register_logger(namespace = "teal.modules.general")
3	!	teal.logger::register_handlers("teal.modules.general")
4		}
5
6		### global variables
7		ggplot_themes <- c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void")
8
9		#' @importFrom lifecycle deprecated
10		interactive <- NULL