teal.modules.general coverage - 3.42%

Files
Source

#' `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)`.
#'
#' @templateVar ggnames "Histogram", "QQplot"
#' @template ggplot2_args_multi
#'
#' @inherit shared_params return
#'
#' @examples
#' library(teal.widgets)
#'
#' # general data example
#' data <- teal_data()
#' data <- within(data, {
#'   iris <- iris
#' })
#' datanames(data) <- "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")
#'       ),
#'       ggplot2_args = ggplot2_args(
#'         labs = list(subtitle = "Plot generated by Distribution Module")
#'       )
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
#' # CDISC data example
#' data <- teal_data()
#' data <- within(data, {
#'   ADSL <- rADSL
#' })
#' datanames(data) <- c("ADSL")
#' join_keys(data) <- default_cdisc_join_keys[datanames(data)]
#'
#' vars1 <- choices_selected(
#'   variable_choices(data[["ADSL"]], c("ARM", "COUNTRY", "SEX")),
#'   selected = NULL
#' )
#'
#' app <- init(
#'   data = data,
#'   modules = modules(
#'     tm_g_distribution(
#'       dist_var = data_extract_spec(
#'         dataname = "ADSL",
#'         select = select_spec(
#'           choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1")),
#'           selected = "BMRKR1",
#'           multiple = FALSE,
#'           fixed = FALSE
#'         )
#'       ),
#'       strata_var = data_extract_spec(
#'         dataname = "ADSL",
#'         filter = filter_spec(
#'           vars = vars1,
#'           multiple = TRUE
#'         )
#'       ),
#'       group_var = data_extract_spec(
#'         dataname = "ADSL",
#'         filter = filter_spec(
#'           vars = vars1,
#'           multiple = TRUE
#'         )
#'       ),
#'       ggplot2_args = ggplot2_args(
#'         labs = list(subtitle = "Plot generated by Distribution Module")
#'       )
#'     )
#'   )
#' )
#' 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) {
  logger::log_info("Initializing tm_g_distribution")

  # Requires Suggested packages
  extra_packages <- c("ggpmisc", "ggpp", "goftest", "MASS", "broom")
  missing_packages <- Filter(function(x) !requireNamespace(x, quietly = TRUE), extra_packages)
  if (length(missing_packages) > 0L) {
    stop(sprintf(
      "Cannot load package(s): %s.\nInstall or restart your session.",
      toString(missing_packages)
    ))
  }

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

  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)
    ),
    ui = ui_distribution,
    ui_args = args,
    datanames = teal.transform::get_extract_datanames(data_extract_list)
  )
}

# 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")))
      ),
      h3("Statistics Table"),
      DT::dataTableOutput(ns("summary_table")),
      h3("Tests"),
      DT::dataTableOutput(ns("t_stats"))
    ),
    encoding = div(
      ### Reporter
      teal.reporter::simple_reporter_ui(ns("simple_reporter")),
      ###
      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
        )
      },
      teal.widgets::panel_group(
        conditionalPanel(
          condition = paste0("input['", ns("tabs"), "'] == 'Histogram'"),
          teal.widgets::panel_item(
            "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),
            collapsed = FALSE
          )
        ),
        conditionalPanel(
          condition = paste0("input['", ns("tabs"), "'] == 'QQplot'"),
          teal.widgets::panel_item(
            "QQ Plot",
            checkboxInput(ns("qq_line"), label = "Add diagonal line(s)", TRUE),
            collapsed = FALSE
          )
        ),
        conditionalPanel(
          condition = paste0("input['", ns("main_type"), "'] == 'Density'"),
          teal.widgets::panel_item(
            "Theoretical Distribution",
            teal.widgets::optionalSelectInput(
              ns("t_dist"),
              div(
                class = "teal-tooltip",
                tagList(
                  "Distribution:",
                  icon("circle-info"),
                  span(
                    class = "tooltiptext",
                    "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),
            span(actionButton(ns("params_reset"), "Reset params")),
            collapsed = FALSE
          )
        )
      ),
      teal.widgets::panel_item(
        "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
        )
      ),
      teal.widgets::panel_item(
        "Statistics Table",
        sliderInput(ns("roundn"), "Round to n digits", min = 0, max = 10, value = 2)
      ),
      teal.widgets::panel_item(
        title = "Plot settings",
        selectInput(
          inputId = ns("ggtheme"),
          label = "Theme (by ggplot):",
          choices = ggplot_themes,
          selected = args$ggtheme,
          multiple = FALSE
        )
      )
    ),
    forms = tagList(
      teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
      teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
    ),
    pre_output = args$pre_output,
    post_output = args$post_output
  )
}

# Server function for the distribution module
srv_distribution <- function(id,
                             data,
                             reporter,
                             filter_panel_api,
                             dist_var,
                             strata_var,
                             group_var,
                             plot_height,
                             plot_width,
                             ggplot2_args) {
  with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
  with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
  checkmate::assert_class(data, "reactive")
  checkmate::assert_class(isolate(data()), "teal_data")
  moduleServer(id, function(input, output, session) {
    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" ||
        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
    )

    anl_merged_q <- reactive({
      req(anl_merged_input())
      data() %>%
        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(
          session$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 = {
        if (length(input$t_dist) != 0) {
          dist_var2 <- as.vector(merged$anl_input_r()$columns_source$dist_i)

          get_dist_params <- function(x, dist) {
            if (dist == "unif") {
              res <- as.list(range(x))
              names(res) <- c("min", "max")
              return(res)
            }
            tryCatch(
              as.list(MASS::fitdistr(x, densfun = dist)$estimate),
              error = function(e) list(param1 = NA, param2 = NA)
            )
          }

          ANL <- merged$anl_q_r()[[as.character(dist_var[[1]]$dataname)]]
          params <- get_dist_params(as.numeric(stats::na.omit(ANL[[dist_var2]])), input$t_dist)
          params_vec <- round(unname(unlist(params)), 2)
          params_names <- names(params)

          updateNumericInput(session, "dist_param1", label = params_names[1], value = params_vec[1])
          updateNumericInput(session, "dist_param2", label = params_names[2], value = params_vec[2])
        } else {
          updateNumericInput(session, "dist_param1", label = "param1", value = NA)
          updateNumericInput(session, "dist_param2", label = "param2", value = NA)
        }
      },
      ignoreInit = TRUE
    )

    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.

      ANL <- merged$anl_q_r()[["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 <- merged$anl_q_r()

      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,
          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,
          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) {
        qenv <- teal.code::eval_code(
          qenv,
          substitute(
            expr = {
              summary_table <- 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 {
        qenv <- teal.code::eval_code(
          qenv,
          substitute(
            expr = {
              strata_vars <- strata_vars_raw
              summary_table <- 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()
                )
              summary_table # used to display table when running show-r-code code
            },
            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 = ggplot(ANL, aes(dist_var_name)) +
              geom_histogram(
                position = "identity", aes(y = 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 = ggplot(ANL, aes(dist_var_name, col = s_var_name)) +
              geom_histogram(
                position = "identity", aes(y = 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 = ggplot(ANL[ANL[[g_var]] != "NA", ], aes(dist_var_name)) +
              geom_histogram(
                position = "identity", aes(y = after_stat(m_type)), bins = bins_var, alpha = 0.3
              ) +
              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 = ggplot(ANL[ANL[[g_var]] != "NA", ], aes(dist_var_name, col = s_var_name)) +
              geom_histogram(
                position = "identity",
                aes(y = after_stat(m_type), fill = s_var), bins = bins_var, alpha = 0.3
              ) +
              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 +
              stat_density(
                aes(y = 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,
            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,
              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),
              aes(x, color = color),
              fun = mapped_dist_name,
              n = ndensity,
              size = 2,
              args = params
            ) +
              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.code::eval_code(
          qenv,
          substitute(
            expr = {
              g <- plot_call
              print(g)
            },
            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)
      },
      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
        ggtheme <- input$ggtheme

        teal::validate_inputs(iv_r_dist(), iv_dist)

        qenv <- common_q()

        plot_call <- if (length(s_var) == 0 && length(g_var) == 0) {
          substitute(
            expr = ggplot(ANL, aes_string(sample = dist_var)),
            env = list(dist_var = dist_var)
          )
        } else if (length(s_var) != 0 && length(g_var) == 0) {
          substitute(
            expr = ggplot(ANL, 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 = ggplot(ANL[ANL[[g_var]] != "NA", ], aes_string(sample = dist_var)) +
              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 = ggplot(ANL[ANL[[g_var]] != "NA", ], aes_string(sample = dist_var, color = s_var)) +
              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 +
            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,
            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,
                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 +
              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.code::eval_code(
          qenv,
          substitute(
            expr = {
              g <- plot_call
              print(g)
            },
            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

        validate(need(dist_tests, "Please select a test"))

        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,
            substitute(
              expr = {
                test_stats <- ANL %>%
                  dplyr::select(dist_var) %>%
                  with(., broom::glance(do.call(test, args))) %>%
                  dplyr::mutate_if(is.numeric, round, 3)
              },
              env = env
            )
          )
        } else {
          qenv <- teal.code::eval_code(
            qenv,
            substitute(
              expr = {
                test_stats <- ANL %>%
                  dplyr::select(dist_var, s_var, g_var) %>%
                  dplyr::group_by_at(dplyr::vars(dplyr::any_of(groups))) %>%
                  dplyr::do(tests = broom::glance(do.call(test, args))) %>%
                  tidyr::unnest(tests) %>%
                  dplyr::mutate_if(is.numeric, round, 3)
              },
              env = env
            )
          )
        }
        qenv %>%
          # used to display table when running show-r-code code
          teal.code::eval_code(quote(test_stats))
      }
    )

    # outputs ----
    ## building main qenv
    output_q <- reactive({
      tab <- input$tabs
      req(tab) # tab is NULL upon app launch, hence will crash without this statement

      qenv_final <- common_q()
      # wrapped in if since could lead into validate error - we do want to continue
      test_r_qenv_out <- try(test_q(), silent = TRUE)
      if (!inherits(test_r_qenv_out, c("try-error", "error"))) {
        qenv_final <- teal.code::join(qenv_final, test_q())
      }

      qenv_final <- if (tab == "Histogram") {
        req(dist_q())
        teal.code::join(qenv_final, dist_q())
      } else if (tab == "QQplot") {
        req(qq_q())
        teal.code::join(qenv_final, qq_q())
      }
      qenv_final
    })

    dist_r <- reactive(dist_q()[["g"]])

    qq_r <- reactive(qq_q()[["g"]])

    output$summary_table <- DT::renderDataTable(
      expr = if (iv_r()$is_valid()) common_q()[["summary_table"]] else NULL,
      options = list(
        autoWidth = TRUE,
        columnDefs = list(list(width = "200px", targets = "_all"))
      ),
      rownames = FALSE
    )

    tests_r <- reactive({
      req(iv_r()$is_valid())
      teal::validate_inputs(iv_r_dist())
      test_q()[["test_stats"]]
    })

    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
    )

    output$t_stats <- DT::renderDataTable(
      expr = tests_r(),
      options = list(scrollX = TRUE),
      rownames = FALSE
    )

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

    teal.widgets::verbatim_popup_srv(
      id = "rcode",
      verbatim_content = reactive(teal.code::get_code(output_q())),
      title = "R Code for distribution"
    )

    ### REPORTER
    if (with_reporter) {
      card_fun <- function(comment, label) {
        card <- teal::report_card_template(
          title = "Distribution Plot",
          label = label,
          with_filter = with_filter,
          filter_panel_api = filter_panel_api
        )
        card$append_text("Plot", "header3")
        if (input$tabs == "Histogram") {
          card$append_plot(dist_r(), dim = pws1$dim())
        } else if (input$tabs == "QQplot") {
          card$append_plot(qq_r(), dim = pws2$dim())
        }
        card$append_text("Statistics table", "header3")

        card$append_table(common_q()[["summary_table"]])
        tests_error <- tryCatch(expr = tests_r(), error = function(e) "error")
        if (inherits(tests_error, "data.frame")) {
          card$append_text("Tests table", "header3")
          card$append_table(tests_r())
        }

        if (!comment == "") {
          card$append_text("Comment", "header3")
          card$append_text(comment)
        }
        card$append_src(teal.code::get_code(output_q()))
        card
      }
      teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
    }
    ###
  })
}

#' `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
#'
#' @examples
#' library(teal.widgets)
#'
#' # general data example
#' data <- teal_data()
#' data <- within(data, {
#'   require(nestcolor)
#'   CO2 <- data.frame(CO2)
#' })
#' datanames(data) <- c("CO2")
#' join_keys(data) <- default_cdisc_join_keys[datanames(data)]
#'
#' app <- init(
#'   data = data,
#'   modules = 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
#'         )
#'       ),
#'       ggplot2_args = ggplot2_args(
#'         labs = list(subtitle = "Plot generated by Bivariate Module")
#'       )
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
#'
#' # CDISC data example
#' data <- teal_data()
#' data <- within(data, {
#'   require(nestcolor)
#'   ADSL <- rADSL
#' })
#' datanames(data) <- c("ADSL")
#' join_keys(data) <- default_cdisc_join_keys[datanames(data)]
#'
#' app <- init(
#'   data = data,
#'   modules = 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
#'         )
#'       ),
#'       ggplot2_args = ggplot2_args(
#'         labs = list(subtitle = "Plot generated by Bivariate Module")
#'       )
#'     )
#'   )
#' )
#' 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) {
  logger::log_info("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)
  # 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
  )

  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)
    ),
    datanames = teal.transform::get_extract_datanames(data_extract_list)
  )
}

# 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 = div(
      ### Reporter
      teal.reporter::simple_reporter_ui(ns("simple_reporter")),
      ###
      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
        )
      ),
      if (!is.null(args$row_facet) || !is.null(args$col_facet)) {
        div(
          class = "data-extract-box",
          tags$label("Facetting"),
          shinyWidgets::switchInput(inputId = ns("facetting"), value = args$facet, size = "mini"),
          conditionalPanel(
            condition = paste0("input['", ns("facetting"), "']"),
            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
        div(
          class = "data-extract-box",
          tags$label("Color settings"),
          shinyWidgets::switchInput(inputId = ns("coloring"), value = TRUE, size = "mini"),
          conditionalPanel(
            condition = paste0("input['", ns("coloring"), "']"),
            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
              ),
              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
                )
              )
            )
          )
        )
      },
      teal.widgets::panel_group(
        teal.widgets::panel_item(
          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"),
        )
      )
    ),
    forms = tagList(
      teal.widgets::verbatim_popup_ui(ns("warning"), button_label = "Show Warnings"),
      teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
    ),
    pre_output = args$pre_output,
    post_output = args$post_output
  )
}

# Server function for the bivariate module
srv_g_bivariate <- function(id,
                            data,
                            reporter,
                            filter_panel_api,
                            x,
                            y,
                            row_facet,
                            col_facet,
                            color_settings = FALSE,
                            color,
                            fill,
                            size,
                            plot_height,
                            plot_width,
                            ggplot2_args) {
  with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
  with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
  checkmate::assert_class(data, "reactive")
  checkmate::assert_class(isolate(data()), "teal_data")
  moduleServer(id, function(input, output, session) {
    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({
      req(anl_merged_input())
      data() %>%
        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 = 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)
        }
      }

      # 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)
      without_facet <- (is.null(nulled_row_facet_name) && is.null(nulled_col_facet_name)) || !facetting

      print_call <- if (without_facet) {
        quote(print(p))
      } else {
        substitute(
          expr = {
            # Add facetting labels
            # optional: grid.newpage() # nolint: commented_code.
            p <- add_facet_labels(p, xfacet_label = nulled_col_facet_name, yfacet_label = nulled_row_facet_name)
            grid::grid.newpage()
            grid::grid.draw(p)
          },
          env = list(nulled_col_facet_name = nulled_col_facet_name, nulled_row_facet_name = nulled_row_facet_name)
        )
      }

      teal.code::eval_code(merged$anl_q_r(), substitute(expr = p <- cl, env = list(cl = cl))) %>%
        teal.code::eval_code(print_call)
    })

    plot_r <- shiny::reactive({
      output_q()[["p"]]
    })

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

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

    teal.widgets::verbatim_popup_srv(
      id = "rcode",
      verbatim_content = reactive(teal.code::get_code(output_q())),
      title = "Bivariate Plot"
    )

    ### REPORTER
    if (with_reporter) {
      card_fun <- function(comment, label) {
        card <- teal::report_card_template(
          title = "Bivariate Plot",
          label = label,
          with_filter = with_filter,
          filter_panel_api = filter_panel_api
        )
        card$append_text("Plot", "header3")
        card$append_plot(plot_r(), dim = pws$dim())
        if (!comment == "") {
          card$append_text("Comment", "header3")
          card$append_text(comment)
        }
        card$append_src(teal.code::get_code(output_q()))
        card
      }
      teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
    }
    ###
  })
}

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

  cl <- 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(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(aes(x = xval), env = list(xval = x)))

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

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

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

    if (freq) {
      plot_call <- reduce_plot_call(
        plot_call,
        quote(geom_bar()),
        quote(ylab("Frequency"))
      )
    } else {
      plot_call <- reduce_plot_call(
        plot_call,
        quote(geom_bar(aes(y = after_stat(prop), group = 1))),
        quote(ylab("Fraction"))
      )
    }
    # Numeric Plots
  } else if (x_class == "numeric" && y_class == "numeric") {
    plot_call <- reduce_plot_call(
      plot_call,
      substitute(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(
          geom_point(alpha = alphaval, size = sizeval, pch = 21),
          env = list(alphaval = alpha, sizeval = size)
        ),
        substitute(
          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(aes(x = xval, y = yval), env = list(xval = x, yval = y)),
      quote(geom_boxplot())
    )
    # Factor and character plots
  } else if (x_class == "factor" && y_class == "factor") {
    plot_call <- reduce_plot_call(
      plot_call,
      substitute(
        ggmosaic::geom_mosaic(aes(x = ggmosaic::product(xval), fill = yval), na.rm = TRUE),
        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(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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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: 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")`.
#'
#' @examples
#' # general data example
#' library(teal.widgets)
#'
#' data <- teal_data()
#' data <- within(data, {
#'   require(nestcolor)
#'   mtcars <- mtcars
#'   for (v in c("cyl", "vs", "am", "gear")) {
#'     mtcars[[v]] <- as.factor(mtcars[[v]])
#'   }
#' })
#' datanames(data) <- "mtcars"
#'
#' 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
#'         )
#'       ),
#'       ggplot2_args = ggplot2_args(
#'         labs = list(subtitle = "Plot generated by Response Module")
#'       )
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
#' # CDISC data example
#' library(teal.widgets)
#'
#' data <- teal_data()
#' data <- within(data, {
#'   require(nestcolor)
#'   ADSL <- rADSL
#' })
#' datanames(data) <- c("ADSL")
#' join_keys(data) <- default_cdisc_join_keys[datanames(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
#'         )
#'       ),
#'       ggplot2_args = ggplot2_args(
#'         labs = list(subtitle = "Plot generated by Response Module")
#'       )
#'     )
#'   )
#' )
#' 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) {
  logger::log_info("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)
  # 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
  )

  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)
    ),
    datanames = teal.transform::get_extract_datanames(data_extract_list)
  )
}

# 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 = div(
      ### Reporter
      teal.reporter::simple_reporter_ui(ns("simple_reporter")),
      ###
      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
      ),
      teal.widgets::panel_group(
        teal.widgets::panel_item(
          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
          )
        )
      )
    ),
    forms = tagList(
      teal.widgets::verbatim_popup_ui(ns("warning"), button_label = "Show Warnings"),
      teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
    ),
    pre_output = args$pre_output,
    post_output = args$post_output
  )
}

# Server function for the response module
srv_g_response <- function(id,
                           data,
                           reporter,
                           filter_panel_api,
                           response,
                           x,
                           row_facet,
                           col_facet,
                           plot_height,
                           plot_width,
                           ggplot2_args) {
  with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
  with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
  checkmate::assert_class(data, "reactive")
  checkmate::assert_class(isolate(data()), "teal_data")
  moduleServer(id, function(input, output, session) {
    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
    )

    anl_merged_q <- reactive({
      req(anl_merged_input())
      data() %>%
        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()
      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 = ggplot(ANL2, aes(x = x_cl, y = ns)) +
          geom_bar(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 + expand_limits(y = c(0, 1.1)), env = list(plot_call = plot_call))

      if (counts) {
        plot_call <- substitute(
          expr = plot_call +
            geom_text(
              data = ANL2,
              aes(label = ns, x = x_cl, y = ns, group = resp_cl),
              col = "white",
              vjust = "middle",
              hjust = "middle",
              position = position_anl2_value
            ) +
            geom_text(
              data = ANL3, 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)),
            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(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 = {
        p <- plot_call + labs + ggthemes + themes
        print(p)
      }, env = list(
        plot_call = plot_call,
        labs = parsed_ggplot2_args$labs,
        themes = parsed_ggplot2_args$theme,
        ggthemes = parsed_ggplot2_args$ggtheme
      ))

      teal.code::eval_code(qenv, plot_call)
    })

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

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

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

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

    ### REPORTER
    if (with_reporter) {
      card_fun <- function(comment, label) {
        card <- teal::report_card_template(
          title = "Response Plot",
          label = label,
          with_filter = with_filter,
          filter_panel_api = filter_panel_api
        )
        card$append_text("Plot", "header3")
        card$append_plot(plot_r(), dim = pws$dim())
        if (!comment == "") {
          card$append_text("Comment", "header3")
          card$append_text(comment)
        }
        card$append_src(teal.code::get_code(output_q()))
        card
      }
      teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
    }
    ###
  })
}

#' `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.
#' @templateVar ggnames "Elbow plot", "Circle plot", "Biplot", "Eigenvector plot"
#' @template ggplot2_args_multi
#'
#' @inherit shared_params return
#'
#' @examples
#' library(teal.widgets)
#'
#' # general data example
#' data <- teal_data()
#' data <- within(data, {
#'   require(nestcolor)
#'   USArrests <- USArrests
#' })
#'
#' datanames(data) <- "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
#'       ),
#'       ggplot2_args = ggplot2_args(
#'         labs = list(subtitle = "Plot generated by PCA Module")
#'       )
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
#' # CDISC data example
#' data <- teal_data()
#' data <- within(data, {
#'   require(nestcolor)
#'   ADSL <- rADSL
#' })
#' datanames(data) <- "ADSL"
#' join_keys(data) <- default_cdisc_join_keys[datanames(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
#'       ),
#'       ggplot2_args = ggplot2_args(
#'         labs = list(subtitle = "Plot generated by PCA Module")
#'       )
#'     )
#'   )
#' )
#' 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) {
  logger::log_info("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)
  # End of assertions

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

  data_extract_list <- list(dat = dat)

  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
      )
    ),
    datanames = teal.transform::get_extract_datanames(data_extract_list)
  )
}

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

  shiny::tagList(
    include_css_files("custom"),
    teal.widgets::standard_layout(
      output = teal.widgets::white_small_well(
        uiOutput(ns("all_plots"))
      ),
      encoding = div(
        ### Reporter
        teal.reporter::simple_reporter_ui(ns("simple_reporter")),
        ###
        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
        ),
        teal.widgets::panel_group(
          teal.widgets::panel_item(
            title = "Display",
            collapsed = FALSE,
            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]
            )
          ),
          teal.widgets::panel_item(
            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"
            )
          ),
          teal.widgets::panel_item(
            title = "Selected plot specific settings",
            collapsed = FALSE,
            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)
              )
            )
          ),
          teal.widgets::panel_item(
            title = "Plot settings",
            collapsed = TRUE,
            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)
          )
        )
      ),
      forms = tagList(
        teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
        teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
      ),
      pre_output = args$pre_output,
      post_output = args$post_output
    )
  )
}

# Server function for the PCA module
srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, plot_width, ggplot2_args) {
  with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
  with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
  checkmate::assert_class(data, "reactive")
  checkmate::assert_class(isolate(data()), "teal_data")
  moduleServer(id, function(input, output, session) {
    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 <- 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
    )

    anl_merged_q <- reactive({
      req(anl_merged_input())
      data() %>%
        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)
        )
      )

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

      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(element_text(vjust = 25)),
          axis.text.x = substitute(
            element_text(angle = angle_value, hjust = hjust_value),
            list(angle_value = angle_value, hjust_value = hjust_value)
          ),
          text = substitute(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.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]
            g <- ggplot(mapping = aes_string(x = "component", y = "value")) +
              geom_bar(
                aes(fill = "Single variance"),
                data = dplyr::filter(elb_dat, metric == "Proportion of Variance"),
                color = "black",
                stat = "identity"
              ) +
              geom_point(
                aes(color = "Cumulative variance"),
                data = dplyr::filter(elb_dat, metric == "Cumulative Proportion")
              ) +
              geom_line(
                aes(group = 1, color = "Cumulative variance"),
                data = dplyr::filter(elb_dat, metric == "Cumulative Proportion")
              ) +
              labs +
              scale_color_manual(values = c("Cumulative variance" = cols[2], "Single variance" = cols[3])) +
              scale_fill_manual(values = c("Cumulative variance" = cols[2], "Single variance" = cols[1])) +
              ggthemes +
              themes

            print(g)
          },
          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(element_text(size = font_size), list(font_size = font_size)),
          axis.text.x = substitute(
            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.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))
            )

            g <- ggplot(pca_rot) +
              geom_point(aes_string(x = x_axis, y = y_axis)) +
              geom_label(
                aes_string(x = x_axis, y = y_axis, label = "label"),
                nudge_x = 0.1, nudge_y = 0.05,
                fontface = "bold"
              ) +
              geom_path(aes(x, y, group = 1), data = circle_data) +
              geom_point(aes(x = x, y = y), data = data.frame(x = 0, y = 0), shape = "x", size = 5) +
              labs +
              ggthemes +
              themes
            print(g)
          },
          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

      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(
            geom_point(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(
          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)) { # nolint: line_length.
            qenv <- teal.code::eval_code(
              qenv,
              quote(pca_rot$response <- as.factor(response))
            )
            quote(scale_color_brewer(palette = "Dark2"))
          } else if (inherits(response, "Date")) {
            qenv <- teal.code::eval_code(
              qenv,
              quote(pca_rot$response <- numeric(response))
            )

            quote(
              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(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(
            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(
            geom_segment(
              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(
            geom_label(
              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(geom_point(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(element_text(size = font_size), list(font_size = font_size)),
          axis.text.x = substitute(
            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 = {
            g <- plot_call
            print(g)
          },
          env = list(
            plot_call = Reduce(function(x, y) call("+", x, y), pca_plot_biplot_expr)
          )
        )
      )
    }

    # plot pc_var ----
    plot_pc_var <- function(base_q) {
      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(element_text(size = font_size), list(font_size = font_size)),
          axis.text.x = substitute(
            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(
            geom_bar(
              aes_string(x = "Variable", y = pc),
              stat = "identity",
              color = "black",
              fill = c(getOption("ggplot2.discrete.colour"), "lightblue")[1]
            ),
            env = list(pc = pc)
          ),
          substitute(
            geom_text(
              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.code::eval_code(
        base_q,
        substitute(
          expr = {
            pca_rot <- pca$rotation[, pc, drop = FALSE] %>%
              dplyr::as_tibble(rownames = "Variable")

            g <- plot_call

            print(g)
          },
          env = list(
            pc = pc,
            plot_call = Reduce(function(x, y) call("+", x, y), ggplot_exprs)
          )
        )
      )
    }

    # plot final ----
    output_q <- reactive({
      req(computation())
      teal::validate_inputs(iv_r())
      teal::validate_inputs(iv_extra, header = "Plot settings are required")

      switch(input$plot_type,
        "Elbow plot" = plot_elbow(computation()),
        "Circle plot" = plot_circle(computation()),
        "Biplot" = plot_biplot(computation()),
        "Eigenvector plot" = plot_pc_var(computation()),
        stop("Unknown plot")
      )
    })

    plot_r <- reactive({
      output_q()[["g"]]
    })

    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)
      div(
        align = "center",
        tags$h4("Principal components importance"),
        tableOutput(session$ns("tbl_importance")),
        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)
      div(
        align = "center",
        tags$h4("Eigenvectors"),
        tableOutput(session$ns("tbl_eigenvector")),
        hr()
      )
    })

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

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

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

    teal.widgets::verbatim_popup_srv(
      id = "rcode",
      verbatim_content = reactive(teal.code::get_code(output_q())),
      title = "R Code for PCA"
    )

    ### REPORTER
    if (with_reporter) {
      card_fun <- function(comment, label) {
        card <- teal::report_card_template(
          title = "Principal Component Analysis Plot",
          label = label,
          with_filter = with_filter,
          filter_panel_api = filter_panel_api
        )
        card$append_text("Principal Components Table", "header3")
        card$append_table(computation()[["tbl_importance"]])
        card$append_text("Eigenvectors Table", "header3")
        card$append_table(computation()[["tbl_eigenvector"]])
        card$append_text("Plot", "header3")
        card$append_plot(plot_r(), dim = pws$dim())
        if (!comment == "") {
          card$append_text("Comment", "header3")
          card$append_text(comment)
        }
        card$append_src(teal.code::get_code(output_q()))
        card
      }
      teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
    }
    ###
  })
}

#' `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
#'
#' @examples
#' library(teal.widgets)
#'
#' # general data example
#' data <- teal_data()
#' data <- within(data, {
#'   require(nestcolor)
#'   CO2 <- CO2
#' })
#' datanames(data) <- "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
#'         )
#'       ),
#'       ggplot2_args = ggplot2_args(
#'         labs = list(subtitle = "Plot generated by Scatterplot Module")
#'       )
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
#' # CDISC data example
#' data <- teal_data()
#' data <- within(data, {
#'   require(nestcolor)
#'   ADSL <- rADSL
#' })
#' datanames(data) <- c("ADSL")
#' join_keys(data) <- default_cdisc_join_keys[datanames(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
#'         )
#'       ),
#'       ggplot2_args = ggplot2_args(
#'         labs = list(subtitle = "Plot generated by Scatterplot Module")
#'       )
#'     )
#'   )
#' )
#' 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()) {
  logger::log_info("Initializing tm_g_scatterplot")

  # Requires Suggested packages
  extra_packages <- c("ggpmisc", "ggExtra", "colourpicker")
  missing_packages <- Filter(function(x) !requireNamespace(x, quietly = TRUE), extra_packages)
  if (length(missing_packages) > 0L) {
    stop(sprintf(
      "Cannot load package(s): %s.\nInstall or restart your session.",
      toString(missing_packages)
    ))
  }

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

  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)
    ),
    datanames = teal.transform::get_extract_datanames(data_extract_list)
  )
}

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

  shiny::tagList(
    include_css_files("custom"),
    teal.widgets::standard_layout(
      output = teal.widgets::white_small_well(
        teal.widgets::plot_with_settings_ui(id = ns("scatter_plot")),
        tags$h1(tags$strong("Selected points:"), class = "text-center font-150p"),
        teal.widgets::get_dt_rows(ns("data_table"), ns("data_table_rows")),
        DT::dataTableOutput(ns("data_table"), width = "100%")
      ),
      encoding = div(
        ### Reporter
        teal.reporter::simple_reporter_ui(ns("simple_reporter")),
        ###
        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
          )
        },
        teal.widgets::panel_group(
          teal.widgets::panel_item(
            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")),
            div(
              id = ns("label_pos"),
              div(strong("Stats position")),
              div(class = "inline-block w-10", helpText("Left")),
              div(
                class = "inline-block w-70",
                teal.widgets::optionalSliderInput(
                  ns("pos"),
                  label = NULL,
                  min = 0, max = 1, value = .99, ticks = FALSE, step = .01
                )
              ),
              div(class = "inline-block w-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
            )
          )
        )
      ),
      forms = tagList(
        teal.widgets::verbatim_popup_ui(ns("warning"), button_label = "Show Warnings"),
        teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
      ),
      pre_output = args$pre_output,
      post_output = args$post_output
    )
  )
}

# Server function for the scatterplot module
srv_g_scatterplot <- function(id,
                              data,
                              reporter,
                              filter_panel_api,
                              x,
                              y,
                              color_by,
                              size_by,
                              row_facet,
                              col_facet,
                              plot_height,
                              plot_width,
                              table_dec,
                              ggplot2_args) {
  with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
  with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
  checkmate::assert_class(data, "reactive")
  checkmate::assert_class(isolate(data()), "teal_data")
  moduleServer(id, function(input, output, session) {
    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"
    )

    anl_merged_q <- reactive({
      req(anl_merged_input())
      data() %>%
        teal.code::eval_code(as.expression(anl_merged_input()$expr)) %>%
        teal.code::eval_code(quote(ANL)) # used to display table when running show-r-code code
    })

    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) {
          shiny::tags$div(paste(num_total_na, "row(s) with missing values were removed"), shiny::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)], 10, 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 %>% 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(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 = p <- plot_call, env = list(plot_call = plot_call))

      teal.code::eval_code(plot_q, plot_call) %>%
        teal.code::eval_code(quote(print(p)))
    })

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

    # 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(teal.code::dev_suppress(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))
      }
    })

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

    teal.widgets::verbatim_popup_srv(
      id = "rcode",
      verbatim_content = reactive(teal.code::get_code(output_q())),
      title = "R Code for scatterplot"
    )

    ### REPORTER
    if (with_reporter) {
      card_fun <- function(comment, label) {
        card <- teal::report_card_template(
          title = "Scatter Plot",
          label = label,
          with_filter = with_filter,
          filter_panel_api = filter_panel_api
        )
        card$append_text("Plot", "header3")
        card$append_plot(plot_r(), dim = pws$dim())
        if (!comment == "") {
          card$append_text("Comment", "header3")
          card$append_text(comment)
        }
        card$append_src(teal.code::get_code(output_q()))
        card
      }
      teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
    }
    ###
  })
}

#' `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`) indicating whether the metadata of the datasets be available on the module.
#'
#' @inherit shared_params return
#'
#' @examples
#' data <- teal_data()
#' data <- within(data, {
#'   require(nestcolor)
#'   ADSL <- rADSL
#'   attr(ADSL, "metadata") <- list("Author" = "NEST team", "data_source" = "synthetic data")
#' })
#' datanames(data) <- "ADSL"
#' join_keys(data) <- default_cdisc_join_keys[datanames(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"),
#'       show_metadata = TRUE
#'     )
#'   ),
#'   header = tags$h1("Sample Application"),
#'   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 = FALSE) {
  logger::log_info("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)
  checkmate::assert_flag(show_metadata)
  # End of assertions

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

  module(
    label = label,
    server = srv_front_page,
    ui = ui_front_page,
    ui_args = args,
    server_args = list(tables = tables, show_metadata = show_metadata),
    datanames = if (show_metadata) "all" else NULL
  )
}

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

  tagList(
    include_css_files("custom"),
    tags$div(
      id = "front_page_content",
      class = "ml-8",
      tags$div(
        id = "front_page_headers",
        get_header_tags(args$header_text)
      ),
      tags$div(
        id = "front_page_tables",
        class = "ml-4",
        get_table_tags(args$tables, ns)
      ),
      tags$div(
        id = "front_page_custom_html",
        class = "my-4",
        args$additional_tags
      ),
      if (args$show_metadata) {
        tags$div(
          id = "front_page_metabutton",
          class = "m-4",
          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, show_metadata) {
  checkmate::assert_class(data, "reactive")
  checkmate::assert_class(isolate(data()), "teal_data")
  moduleServer(id, function(input, output, session) {
    ns <- session$ns

    lapply(seq_along(tables), function(idx) {
      output[[paste0("table_", idx)]] <- renderTable(
        tables[[idx]],
        bordered = TRUE,
        caption = names(tables)[idx],
        caption.placement = "top"
      )
    })

    if (show_metadata) {
      observeEvent(
        input$metadata_button, showModal(
          modalDialog(
            title = "Metadata",
            dataTableOutput(ns("metadata_table")),
            size = "l",
            easyClose = TRUE
          )
        )
      )

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

      output$metadata_table <- renderDataTable({
        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)))
    )
  }))
  return(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)))
    }
    return(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: 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`.
#'
#' @templateVar ggnames `r regression_names`
#' @template ggplot2_args_multi
#'
#' @inherit shared_params return
#'
#' @examples
#' # general data example
#' library(teal.widgets)
#'
#' data <- teal_data()
#' data <- within(data, {
#'   require(nestcolor)
#'   CO2 <- CO2
#' })
#' datanames(data) <- c("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
#'         )
#'       ),
#'       ggplot2_args = ggplot2_args(
#'         labs = list(subtitle = "Plot generated by Regression Module")
#'       )
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
#' # CDISC data example
#' library(teal.widgets)
#'
#' data <- teal_data()
#' data <- within(data, {
#'   require(nestcolor)
#'   ADSL <- rADSL
#' })
#' datanames(data) <- "ADSL"
#' join_keys(data) <- default_cdisc_join_keys[datanames(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
#'         )
#'       ),
#'       ggplot2_args = ggplot2_args(
#'         labs = list(subtitle = "Plot generated by Regression Module")
#'       )
#'     )
#'   )
#' )
#' 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)) {
  logger::log_info("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)

  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"
    )
  }
  # End of assertions

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

  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
      )
    ),
    datanames = teal.transform::get_extract_datanames(data_extract_list)
  )
}

# 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 = div(
      ### Reporter
      teal.reporter::simple_reporter_ui(ns("simple_reporter")),
      ###
      tags$label("Encodings", class = "text-primary"),
      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"),
          div(
            class = "teal-tooltip",
            tagList(
              "Outlier definition:",
              icon("circle-info"),
              span(
                class = "tooltiptext",
                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"
        )
      ),
      teal.widgets::panel_group(
        teal.widgets::panel_item(
          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 = div(
              class = "teal-tooltip",
              tagList(
                "Label min. segment:",
                icon("circle-info"),
                span(
                  class = "tooltiptext",
                  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
          )
        )
      )
    ),
    forms = tagList(
      teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
      teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
    ),
    pre_output = args$pre_output,
    post_output = args$post_output
  )
}

# Server function for the regression module
srv_a_regression <- function(id,
                             data,
                             reporter,
                             filter_panel_api,
                             response,
                             regressor,
                             plot_height,
                             plot_width,
                             ggplot2_args,
                             default_outlier_label) {
  with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
  with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
  checkmate::assert_class(data, "reactive")
  checkmate::assert_class(isolate(data()), "teal_data")
  moduleServer(id, function(input, output, session) {
    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)
      )
    })

    anl_merged_q <- reactive({
      req(anl_merged_input())
      data() %>%
        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 = selected
        )

        data <- 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 = if (cur_outlier < max_outlier) cur_outlier else max_outlier * .9
        )
      }

      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(summary(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_q <- reactive({
      alpha <- input$alpha
      size <- input$size
      ggtheme <- input$ggtheme
      input_type <- input$plot_type
      show_outlier <- input$show_outlier

      teal::validate_inputs(iv_r())

      plot_type_0 <- function() {
        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(
            env = list(
              regressor = regression_var()$regressor,
              response = regression_var()$response,
              size = size,
              alpha = alpha
            ),
            expr = ggplot(
              fit$model[, 2:1],
              aes_string(regressor, response)
            ) +
              geom_point(size = size, alpha = alpha) +
              stat_smooth(
                method = "lm",
                formula = y ~ x,
                se = FALSE
              )
          )
          if (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 = ggplot(fit$model[, 2:1], aes_string(regressor, response)) +
              geom_boxplot(),
            env = list(regressor = regression_var()$regressor, response = regression_var()$response)
          )
          if (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 = ggtheme
        )

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

      plot_base <- function() {
        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]])
          })
        )
      }

      plot_type_1 <- function(plot_base) {
        shinyjs::show("size")
        shinyjs::show("alpha")
        plot <- substitute(
          expr = ggplot(data = data, aes(.fitted, .resid)) +
            geom_point(size = size, alpha = alpha) +
            geom_hline(yintercept = 0, linetype = "dashed", size = 1) +
            geom_line(data = smoothy, mapping = smoothy_aes),
          env = list(size = size, alpha = alpha)
        )
        if (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 = ggtheme
        )

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

      plot_type_2 <- function(plot_base) {
        shinyjs::show("size")
        shinyjs::show("alpha")
        plot <- substitute(
          expr = ggplot(data = data, aes(sample = .stdresid)) +
            stat_qq(size = size, alpha = alpha) +
            geom_abline(linetype = "dashed"),
          env = list(size = size, alpha = alpha)
        )
        if (show_outlier) {
          plot <- substitute(
            expr = plot +
              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 = ggtheme
        )

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

      plot_type_3 <- function(plot_base) {
        shinyjs::show("size")
        shinyjs::show("alpha")
        plot <- substitute(
          expr = ggplot(data = data, aes(.fitted, sqrt(abs(.stdresid)))) +
            geom_point(size = size, alpha = alpha) +
            geom_line(data = smoothy, mapping = smoothy_aes),
          env = list(size = size, alpha = alpha)
        )
        if (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 = ggtheme
        )

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

      plot_type_4 <- function(plot_base) {
        shinyjs::hide("size")
        shinyjs::show("alpha")
        plot <- substitute(
          expr = ggplot(data = data, aes(seq_along(.cooksd), .cooksd)) +
            geom_col(alpha = alpha),
          env = list(alpha = alpha)
        )
        if (show_outlier) {
          plot <- substitute(
            expr = plot +
              geom_hline(
                yintercept = c(
                  outlier * mean(data$.cooksd, na.rm = TRUE),
                  mean(data$.cooksd, na.rm = TRUE)
                ),
                color = "red",
                linetype = "dashed"
              ) +
              geom_text(
                aes(
                  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
                ),
                parse = TRUE,
                show.legend = FALSE
              ) +
              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 = ggtheme
        )

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


      plot_type_5 <- function(plot_base) {
        shinyjs::show("size")
        shinyjs::show("alpha")
        plot <- substitute(
          expr = ggplot(data = data, aes(.hat, .stdresid)) +
            geom_vline(
              size = 1,
              colour = "black",
              linetype = "dashed",
              xintercept = 0
            ) +
            geom_hline(
              size = 1,
              colour = "black",
              linetype = "dashed",
              yintercept = 0
            ) +
            geom_point(size = size, alpha = alpha) +
            geom_line(data = smoothy, mapping = smoothy_aes),
          env = list(size = size, alpha = alpha)
        )
        if (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 = ggtheme
        )

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

      plot_type_6 <- function(plot_base) {
        shinyjs::show("size")
        shinyjs::show("alpha")
        plot <- substitute(
          expr = ggplot(data = data, aes(.hat, .cooksd)) +
            geom_vline(xintercept = 0, colour = NA) +
            geom_abline(
              slope = seq(0, 3, by = 0.5),
              colour = "black",
              linetype = "dashed",
              size = 1
            ) +
            geom_line(data = smoothy, mapping = smoothy_aes) +
            geom_point(size = size, alpha = alpha),
          env = list(size = size, alpha = alpha)
        )
        if (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 = ggtheme
        )

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

      qenv <- if (input_type == "Response vs Regressor") {
        plot_type_0()
      } else {
        plot_base_q <- plot_base()
        switch(input_type,
          "Residuals vs Fitted" = plot_base_q %>% plot_type_1(),
          "Normal Q-Q" = plot_base_q %>% plot_type_2(),
          "Scale-Location" = plot_base_q %>% plot_type_3(),
          "Cook's distance" = plot_base_q %>% plot_type_4(),
          "Residuals vs Leverage" = plot_base_q %>% plot_type_5(),
          "Cook's dist vs Leverage" = plot_base_q %>% plot_type_6()
        )
      }
      qenv
    })


    fitted <- reactive(output_q()[["fit"]])
    plot_r <- reactive(output_q()[["g"]])

    # 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(teal.code::dev_suppress(fitted())))[-1],
        collapse = "\n"
      )
    })

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

    teal.widgets::verbatim_popup_srv(
      id = "rcode",
      verbatim_content = reactive(teal.code::get_code(output_q())),
      title = "R code for the regression plot",
    )

    ### REPORTER
    if (with_reporter) {
      card_fun <- function(comment, label) {
        card <- teal::report_card_template(
          title = "Linear Regression Plot",
          label = label,
          with_filter = with_filter,
          filter_panel_api = filter_panel_api
        )
        card$append_text("Plot", "header3")
        card$append_plot(plot_r(), dim = pws$dim())
        if (!comment == "") {
          card$append_text("Comment", "header3")
          card$append_text(comment)
        }
        card$append_src(teal.code::get_code(output_q()))
        card
      }
      teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
    }
    ###
  })
}

regression_names <- paste0(
  '"Response vs Regressor", "Residuals vs Fitted", ',
  '"Scale-Location", "Cook\'s distance", "Residuals vs Leverage"", "Cook\'s dist vs Leverage"'
)

#' `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"`.
#'
#' @templateVar ggnames "Bivariate1", "Bivariate2"
#' @template ggplot2_args_multi
#'
#' @inherit shared_params return
#'
#' @examples
#' library(teal.widgets)
#'
#' # 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)
#' })
#' datanames(data) <- c("CO2")
#'
#' 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
#'         )
#'       ),
#'       ggplot2_args = ggplot2_args(
#'         labs = list(subtitle = "Plot generated by Association Module")
#'       )
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
#' # CDISC data example
#' data <- teal_data()
#' data <- within(data, {
#'   require(nestcolor)
#'   ADSL <- rADSL
#' })
#' datanames(data) <- "ADSL"
#' join_keys(data) <- default_cdisc_join_keys[datanames(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
#'         )
#'       ),
#'       ggplot2_args = ggplot2_args(
#'         labs = list(subtitle = "Plot generated by Association Module")
#'       )
#'     )
#'   )
#' )
#' 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.
                             association_theme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), # nolint: line_length.
                             pre_output = NULL,
                             post_output = NULL,
                             ggplot2_args = teal.widgets::ggplot2_args()) {
  logger::log_info("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))
  # End of assertions

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

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

  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)
    ),
    datanames = teal.transform::get_extract_datanames(data_extract_list)
  )
}

# 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 = div(
      ### Reporter
      teal.reporter::simple_reporter_ui(ns("simple_reporter")),
      ###
      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
      ),
      teal.widgets::panel_group(
        teal.widgets::panel_item(
          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
          )
        )
      )
    ),
    forms = tagList(
      teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
      teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
    ),
    pre_output = args$pre_output,
    post_output = args$post_output
  )
}

# Server function for the association module
srv_tm_g_association <- function(id,
                                 data,
                                 reporter,
                                 filter_panel_api,
                                 ref,
                                 vars,
                                 plot_height,
                                 plot_width,
                                 ggplot2_args) {
  with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
  with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
  checkmate::assert_class(data, "reactive")
  checkmate::assert_class(isolate(data()), "teal_data")

  moduleServer(id, function(input, output, session) {
    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
    )

    anl_merged_q <- reactive({
      req(anl_merged_input())
      data() %>% 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")

      print_call <- quote(print(p))

      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 = ", ")
            )
          )
        }

      teal.code::eval_code(
        merged$anl_q_r(),
        substitute(
          expr = title <- new_title,
          env = list(new_title = new_title)
        )
      ) %>%
        teal.code::eval_code(
          substitute(
            expr = {
              plots <- plot_calls
              p <- tern::stack_grobs(grobs = lapply(plots, ggplotGrob))
              grid::grid.newpage()
              grid::grid.draw(p)
            },
            env = list(
              plot_calls = do.call(
                "call",
                c(list("list", ref_call), var_calls),
                quote = TRUE
              )
            )
          )
        )
    })

    plot_r <- shiny::reactive({
      shiny::req(iv_r()$is_valid())
      output_q()[["p"]]
    })

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

    output$title <- renderText({
      teal.code::dev_suppress(output_q()[["title"]])
    })

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

    teal.widgets::verbatim_popup_srv(
      id = "rcode",
      verbatim_content = reactive(teal.code::get_code(output_q())),
      title = "Association Plot"
    )

    ### REPORTER
    if (with_reporter) {
      card_fun <- function(comment, label) {
        card <- teal::report_card_template(
          title = "Association Plot",
          label = label,
          with_filter = with_filter,
          filter_panel_api = filter_panel_api
        )
        card$append_text("Plot", "header3")
        card$append_plot(plot_r(), dim = pws$dim())
        if (!comment == "") {
          card$append_text("Comment", "header3")
          card$append_text(comment)
        }
        card$append_src(teal.code::get_code(output_q()))
        card
      }
      teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
    }
    ###
  })
}

#' `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 `datasets_selected`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`) vector of datasets which should be
#' shown, in order. Names must correspond with datasets names.
#' If vector of length zero (default) then all datasets are shown.
#' Note: Only `data.frame` objects are compatible; using other types will cause an error.
#'
#' @inherit shared_params return
#'
#' @examples
#' library(teal.widgets)
#'
#' # Module specification used in apps below
#' tm_variable_browser_module <- tm_variable_browser(
#'   label = "Variable browser",
#'   ggplot2_args = ggplot2_args(
#'     labs = list(subtitle = "Plot generated by Variable Browser Module")
#'   )
#' )
#'
#' # general data example
#' data <- teal_data()
#' data <- within(data, {
#'   iris <- iris
#'   mtcars <- mtcars
#'   women <- women
#'   faithful <- faithful
#'   CO2 <- CO2
#' })
#' datanames(data) <- c("iris", "mtcars", "women", "faithful", "CO2")
#'
#' app <- init(
#'   data = data,
#'   modules = modules(tm_variable_browser_module)
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
#' # CDISC example data
#' data <- teal_data()
#' data <- within(data, {
#'   ADSL <- rADSL
#'   ADTTE <- rADTTE
#' })
#' datanames(data) <- c("ADSL", "ADTTE")
#' join_keys(data) <- default_cdisc_join_keys[datanames(data)]
#'
#' app <- init(
#'   data = data,
#'   modules = modules(tm_variable_browser_module)
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
#' @export
#'
tm_variable_browser <- function(label = "Variable Browser",
                                datasets_selected = character(0),
                                parent_dataname = "ADSL",
                                pre_output = NULL,
                                post_output = NULL,
                                ggplot2_args = teal.widgets::ggplot2_args()) {
  logger::log_info("Initializing tm_variable_browser")

  # Requires Suggested packages
  if (!requireNamespace("sparkline", quietly = TRUE)) {
    stop("Cannot load sparkline - please install the package or restart your session.")
  }
  if (!requireNamespace("htmlwidgets", quietly = TRUE)) {
    stop("Cannot load htmlwidgets - please install the package or restart your session.")
  }
  if (!requireNamespace("jsonlite", quietly = TRUE)) {
    stop("Cannot load jsonlite - please install the package or restart your session.")
  }

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

  datasets_selected <- unique(datasets_selected)

  module(
    label,
    server = srv_variable_browser,
    ui = ui_variable_browser,
    datanames = "all",
    server_args = list(
      datasets_selected = datasets_selected,
      parent_dataname = parent_dataname,
      ggplot2_args = ggplot2_args
    ),
    ui_args = list(
      pre_output = pre_output,
      post_output = post_output
    )
  )
}

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

  shiny::tagList(
    include_css_files("custom"),
    shinyjs::useShinyjs(),
    teal.widgets::standard_layout(
      output = fluidRow(
        htmlwidgets::getDependency("sparkline"), # needed for sparklines to work
        column(
          6,
          # variable browser
          teal.widgets::white_small_well(
            uiOutput(ns("ui_variable_browser")),
            shinyjs::hidden({
              checkboxInput(ns("show_parent_vars"), "Show parent dataset variables", value = FALSE)
            })
          )
        ),
        column(
          6,
          teal.widgets::white_small_well(
            ### Reporter
            teal.reporter::simple_reporter_ui(ns("simple_reporter")),
            ###
            div(
              class = "block",
              uiOutput(ns("ui_histogram_display"))
            ),
            div(
              class = "block",
              uiOutput(ns("ui_numeric_display"))
            ),
            teal.widgets::plot_with_settings_ui(ns("variable_plot")),
            br(),
            # input user-defined text size
            teal.widgets::panel_item(
              title = "Plot settings",
              collapsed = TRUE,
              selectInput(
                inputId = ns("ggplot_theme"), label = "ggplot2 theme",
                choices = ggplot_themes,
                selected = "grey"
              ),
              fluidRow(
                column(6, sliderInput(
                  inputId = ns("font_size"), label = "font size",
                  min = 5L, max = 30L, value = 15L, step = 1L, ticks = FALSE
                )),
                column(6, sliderInput(
                  inputId = ns("label_rotation"), label = "rotate x labels",
                  min = 0L, max = 90L, value = 45L, step = 1, ticks = FALSE
                ))
              )
            ),
            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,
                                 reporter,
                                 filter_panel_api,
                                 datasets_selected, parent_dataname, ggplot2_args) {
  with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
  with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
  checkmate::assert_class(data, "reactive")
  checkmate::assert_class(isolate(data()), "teal_data")
  moduleServer(id, function(input, output, session) {
    # 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 <- isolate(teal.data::datanames(data()))
    datanames <- Filter(function(name) {
      is.data.frame(isolate(data())[[name]])
    }, datanames)

    checkmate::assert_character(datasets_selected)
    checkmate::assert_subset(datasets_selected, datanames)
    if (!identical(datasets_selected, character(0))) {
      checkmate::assert_subset(datasets_selected, datanames)
      datanames <- datasets_selected
    }

    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,
                div(
                  class = "mt-4",
                  textOutput(ns(paste0("dataset_summary_", dataname)))
                ),
                div(
                  class = "mt-4",
                  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(input, plot_var, data)

    # data_for_analysis is a list with two elements: a column from a dataset and the column label
    plotted_data <- reactive({
      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({
      validation_checks()
      dataname <- input$tabset_panel
      varname <- plot_var$variable[[dataname]]
      df <- data()[[dataname]]

      numeric_ui <- tagList(
        fluidRow(
          div(
            class = "col-md-4",
            br(),
            shinyWidgets::switchInput(
              inputId = session$ns("display_density"),
              label = "Show density",
              value = `if`(is.null(isolate(input$display_density)), TRUE, isolate(input$display_density)),
              width = "50%",
              labelWidth = "100px",
              handleWidth = "50px"
            )
          ),
          div(
            class = "col-md-4",
            br(),
            shinyWidgets::switchInput(
              inputId = session$ns("remove_outliers"),
              label = "Remove outliers",
              value = `if`(is.null(isolate(input$remove_outliers)), FALSE, isolate(input$remove_outliers)),
              width = "50%",
              labelWidth = "100px",
              handleWidth = "50px"
            )
          ),
          div(
            class = "col-md-4",
            uiOutput(session$ns("outlier_definition_slider_ui"))
          )
        ),
        div(
          class = "ml-4",
          uiOutput(session$ns("ui_density_help")),
          uiOutput(session$ns("ui_outlier_help"))
        )
      )

      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 <- input$tabset_panel
      varname <- plot_var$variable[[dataname]]
      df <- data()[[dataname]]

      numeric_ui <- tagList(fluidRow(
        div(
          class = "col-md-4",
          shinyWidgets::switchInput(
            inputId = session$ns("remove_NA_hist"),
            label = "Remove NA values",
            value = FALSE,
            width = "50%",
            labelWidth = "100px",
            handleWidth = "50px"
          )
        )
      ))

      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"),
        div(
          class = "teal-tooltip",
          tagList(
            "Outlier definition:",
            icon("circle-info"),
            span(
              class = "tooltiptext",
              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_density_help <- renderUI({
      req(is.logical(input$display_density))
      if (input$display_density) {
        tags$small(helpText(paste(
          "Kernel density estimation with gaussian kernel",
          "and bandwidth function bw.nrd0 (R default)"
        )))
      } else {
        NULL
      }
    })

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


    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(
        var = plotted_data()$data,
        var_lab = plotted_data()$var_description,
        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()
      )
    })

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

    output$variable_summary_table <- DT::renderDataTable({
      var_summary_table(
        plotted_data()$data,
        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
        }
      )
    })

    ### REPORTER
    if (with_reporter) {
      card_fun <- function(comment) {
        card <- teal::TealReportCard$new()
        card$set_name("Variable Browser Plot")
        card$append_text("Variable Browser Plot", "header2")
        if (with_filter) card$append_fs(filter_panel_api$get_filter_state())
        card$append_text("Plot", "header3")
        card$append_plot(variable_plot_r(), dim = pws$dim())
        if (!comment == "") {
          card$append_text("Comment", "header3")
          card$append_text(comment)
        }
        card
      }
      teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
    }
    ###
  })
}

#' 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 var vector of any type to be plotted. For numeric variables it produces histogram with
#' density line, for factors it creates frequency plot
#' @param var_lab text describing selected variable to be displayed on the plot
#' @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(var,
                             var_lab,
                             wrap_character = NULL,
                             numeric_as_factor,
                             display_density = is.numeric(var),
                             remove_NA_hist = FALSE, # nolint: object_name.
                             outlier_definition,
                             records_for_factor,
                             ggplot2_args) {
  checkmate::assert_character(var_lab)
  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")

  grid::grid.newpage()

  plot_main <- 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) {
      grid::textGrob(
        sprintf(
          "%s unique values\n%s:\n %s\n ...\n %s",
          len_groups,
          var_lab,
          paste(utils::head(groups), collapse = ",\n "),
          paste(utils::tail(groups), collapse = ",\n ")
        ),
        x = grid::unit(1, "line"),
        y = grid::unit(1, "npc") - grid::unit(1, "line"),
        just = c("left", "top")
      )
    } else {
      if (!is.null(wrap_character)) {
        var <- stringr::str_wrap(var, width = wrap_character)
      }
      var <- if (isTRUE(remove_NA_hist)) as.vector(stats::na.omit(var)) else var
      ggplot(data.frame(var), aes(x = forcats::fct_infreq(as.factor(var)))) +
        geom_bar(stat = "count", aes(fill = ifelse(is.na(var), "withcolor", "")), show.legend = FALSE) +
        scale_fill_manual(values = c("gray50", "tan"))
    }
  } else if (is.numeric(var)) {
    validate(need(any(!is.na(var)), "No data left to visualize."))

    # Filter out NA
    var <- var[which(!is.na(var))]

    validate(need(!any(is.infinite(var)), "Cannot display graph when data includes infinite values"))

    if (numeric_as_factor) {
      var <- factor(var)
      ggplot(NULL, aes(x = var)) +
        geom_histogram(stat = "count")
    } 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"
        ))
      }
      ## histogram
      binwidth <- get_bin_width(var)
      p <- ggplot(data = data.frame(var = var), aes(x = var, y = after_stat(count))) +
        geom_histogram(binwidth = binwidth) +
        scale_y_continuous(
          sec.axis = sec_axis(
            trans = ~ . / nrow(data.frame(var = var)),
            labels = scales::percent,
            name = "proportion (in %)"
          )
        )

      if (display_density) {
        p <- p + geom_density(aes(y = after_stat(count * binwidth)))
      }

      if (outlier_definition != 0) {
        p <- p + 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 = ggplot2_args[["theme"]][["text"]][["size"]] / 3.5
        )
      }
      p
    }
  } else if (inherits(var, "Date") || inherits(var, "POSIXct") || inherits(var, "POSIXlt")) {
    var_num <- as.numeric(var)
    binwidth <- get_bin_width(var_num, 1)
    p <- ggplot(data = data.frame(var = var), aes(x = var, y = after_stat(count))) +
      geom_histogram(binwidth = binwidth)
  } else {
    grid::textGrob(
      paste(strwrap(
        utils::capture.output(utils::str(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")
    )
  }

  dev_ggplot2_args <- teal.widgets::ggplot2_args(
    labs = list(x = var_lab)
  )
  ###
  all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(
    ggplot2_args,
    module_plot = dev_ggplot2_args
  )

  if (is.ggplot(plot_main)) {
    if (is.numeric(var) && !numeric_as_factor) {
      # numeric not as factor
      plot_main <- plot_main +
        theme_light() +
        list(
          labs = do.call("labs", all_ggplot2_args$labs),
          theme = do.call("theme", all_ggplot2_args$theme)
        )
    } else {
      # factor low number of levels OR numeric as factor OR Date
      plot_main <- plot_main +
        theme_light() +
        list(
          labs = do.call("labs", all_ggplot2_args$labs),
          theme = do.call("theme", all_ggplot2_args$theme)
        )
    }
    plot_main <- ggplotGrob(plot_main)
  }

  grid::grid.draw(plot_main)
  plot_main
}

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 <- input$tabset_panel
  varname <- plot_var$variable[[dataset_name]]
  df <- data()[[dataset_name]]

  var_description <- teal.data::col_labels(df)[[varname]]
  list(data = df[[varname]], var_description = var_description)
}

#' 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 <- join_keys(data())
    if (!is.null(join_keys)) {
      key <- 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 <- 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 <- shiny::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 <- shiny::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) {
  if (outlier_definition == 0) {
    return(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[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, ...) {
  return(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: 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.
#' @param ggtheme (`character`) optional, specifies the default `ggplot2` theme for plots. Defaults to `classic`.
#'
#' @templateVar ggnames "Summary Obs", "Summary Patients", "Combinations Main", "Combinations Hist", "By Subject"
#' @template ggplot2_args_multi
#'
#' @inherit shared_params return
#'
#' @examples
#' library(teal.widgets)
#'
#' # module specification used in apps below
#' tm_missing_data_module <- tm_missing_data(
#'   ggplot2_args = list(
#'     "Combinations Hist" = ggplot2_args(
#'       labs = list(subtitle = "Plot produced by Missing Data Module", caption = NULL)
#'     ),
#'     "Combinations Main" = ggplot2_args(labs = list(title = NULL))
#'   )
#' )
#'
#' # 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"]])
#' })
#' datanames(data) <- c("iris", "mtcars")
#'
#' app <- init(
#'   data = data,
#'   modules = modules(tm_missing_data_module)
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
#' # CDISC example data
#' data <- teal_data()
#' data <- within(data, {
#'   require(nestcolor)
#'   ADSL <- rADSL
#'   ADRS <- rADRS
#' })
#' datanames(data) <- c("ADSL", "ADRS")
#' join_keys(data) <- default_cdisc_join_keys[datanames(data)]
#'
#' app <- init(
#'   data = data,
#'   modules = modules(tm_missing_data_module)
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
#' @export
#'
tm_missing_data <- function(label = "Missing data",
                            plot_height = c(600, 400, 5000),
                            plot_width = NULL,
                            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) {
  logger::log_info("Initializing tm_missing_data")

  # Requires Suggested packages
  if (!requireNamespace("gridExtra", quietly = TRUE)) {
    stop("Cannot load gridExtra - please install the package or restart your session.")
  }
  if (!requireNamespace("rlang", quietly = TRUE)) {
    stop("Cannot load rlang - please install the package or restart your session.")
  }

  # 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(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)
  # End of assertions

  module(
    label,
    server = srv_page_missing_data,
    server_args = list(
      parent_dataname = parent_dataname, plot_height = plot_height,
      plot_width = plot_width, ggplot2_args = ggplot2_args, ggtheme = ggtheme
    ),
    ui = ui_page_missing_data,
    datanames = "all",
    ui_args = list(pre_output = pre_output, post_output = post_output)
  )
}

# UI function for the missing data module (all datasets)
ui_page_missing_data <- function(id, pre_output = NULL, post_output = NULL) {
  ns <- NS(id)
  shiny::tagList(
    include_css_files("custom"),
    teal.widgets::standard_layout(
      output = teal.widgets::white_small_well(
        div(
          class = "flex",
          column(
            width = 12,
            uiOutput(ns("dataset_tabs"))
          )
        )
      ),
      encoding = div(
        uiOutput(ns("dataset_encodings"))
      ),
      uiOutput(ns("dataset_reporter")),
      pre_output = pre_output,
      post_output = post_output
    )
  )
}

# Server function for the missing data module (all datasets)
srv_page_missing_data <- function(id, data, reporter, filter_panel_api, parent_dataname,
                                  plot_height, plot_width, ggplot2_args, ggtheme) {
  moduleServer(id, function(input, output, session) {
    datanames <- isolate(teal.data::datanames(data()))
    datanames <- Filter(function(name) {
      is.data.frame(isolate(data())[[name]])
    }, 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,
                column(
                  width = 12,
                  div(
                    class = "mt-4",
                    ui_missing_data(id = ns(x), by_subject_plot = if_subject_plot)
                  )
                )
              )
            }
          )
        )
      )
    })

    output$dataset_encodings <- renderUI({
      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
              )
            )
          }
        )
      )
    })

    output$dataset_reporter <- renderUI({
      lapply(datanames, function(x) {
        dataname_ns <- NS(ns(x))

        conditionalPanel(
          is_tab_active_js(ns("dataname_tab"), x),
          tagList(
            teal.widgets::verbatim_popup_ui(dataname_ns("warning"), "Show Warnings"),
            teal.widgets::verbatim_popup_ui(dataname_ns("rcode"), "Show R code")
          )
        )
      })
    })

    lapply(
      datanames,
      function(x) {
        srv_missing_data(
          id = x,
          data = data,
          reporter = reporter,
          filter_panel_api = filter_panel_api,
          dataname = x,
          parent_dataname = parent_dataname,
          plot_height = plot_height,
          plot_width = plot_width,
          ggplot2_args = ggplot2_args
        )
      }
    )
  })
}

# 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(
        p(paste(
          'The "Summary" graph shows the number of missing values per variable (both absolute and percentage),',
          "sorted by magnitude."
        )),
        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(
        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.'
        )),
        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::get_dt_rows(ns("levels_table"), ns("levels_table_rows")),
      DT::dataTableOutput(ns("levels_table"))
    )
  )
  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(
          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) {
  ns <- NS(id)

  tagList(
    ### Reporter
    teal.reporter::simple_reporter_ui(ns("simple_reporter")),
    ###
    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"),
      span("Select only vars with missings", class = "whitespace-normal"),
      width = "100%",
      class = "mb-4"
    ),
    conditionalPanel(
      is_tab_active_js(ns("summary_type"), "Summary"),
      checkboxInput(
        ns("any_na"),
        div(
          class = "teal-tooltip",
          tagList(
            "Add **anyna** variable",
            icon("circle-info"),
            span(
              class = "tooltiptext",
              "Describes the number of observations with at least one missing value in any variable."
            )
          )
        ),
        value = FALSE
      ),
      if (summary_per_patient) {
        checkboxInput(
          ns("if_patients_plot"),
          div(
            class = "teal-tooltip",
            tagList(
              "Add summary per patients",
              icon("circle-info"),
              span(
                class = "tooltiptext",
                paste(
                  "Displays the number of missing values per observation,",
                  "where the x-axis is sorted by observation appearance in the table."
                )
              )
            )
          ),
          value = FALSE
        )
      }
    ),
    conditionalPanel(
      is_tab_active_js(ns("summary_type"), "Combinations"),
      uiOutput(ns("cutoff"))
    ),
    conditionalPanel(
      is_tab_active_js(ns("summary_type"), "By Variable Levels"),
      tagList(
        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
        )
      )
    ),
    teal.widgets::panel_item(
      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, reporter, filter_panel_api, dataname, parent_dataname,
                             plot_height, plot_width, ggplot2_args) {
  with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
  with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
  checkmate::assert_class(data, "reactive")
  checkmate::assert_class(isolate(data()), "teal_data")
  moduleServer(id, function(input, output, session) {
    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",
        shinyvalidate::sv_required("Please select both group-by variable and values")
      )
      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({
      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())

      group_var <- input$group_by_var
      anl <- data_r()

      qenv <- if (!is.null(selected_vars()) && length(selected_vars()) != ncol(anl)) {
        teal.code::eval_code(
          data(),
          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(
          data(),
          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({
      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)
      )
    })

    output$variables <- renderUI({
      choices <- split(x = vars_summary()$key, f = vars_summary()$label, drop = TRUE) %>% rev()
      selected <- choices <- unname(unlist(choices))

      teal.widgets::optionalSelectInput(
        session$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, {
      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 = selected
      )
    })

    output$group_by_var_ui <- renderUI({
      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(
        session$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)

      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(
        session$ns("group_by_vals"),
        label = "Filter levels",
        choices = choices,
        selected = selected,
        multiple = TRUE,
        label_help = paste0("Dataset: ", dataname)
      )
    })

    summary_plot_q <- reactive({
      req(input$summary_type == "Summary") # needed to trigger show r code update on tab change
      teal::validate_has_data(data_r(), 1)

      qenv <- 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.code::eval_code(
          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 (isolate(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(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(
          p1 <- summary_plot_obs %>%
            ggplot() +
            aes(
              x = factor(create_cols_labels(col), levels = x_levels),
              y = n_pct,
              fill = isna
            ) +
            geom_bar(position = "fill", stat = "identity") +
            scale_fill_manual(
              name = "",
              values = c("grey90", c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]),
              labels = c("Present", "Missing")
            ) +
            scale_y_continuous(labels = scales::percent_format(), breaks = seq(0, 1, by = 0.1), expand = c(0, 0)) +
            geom_text(
              aes(label = ifelse(isna == TRUE, sprintf("%d [%.02f%%]", n, n_pct), ""), y = 1),
              hjust = 1,
              color = "black"
            ) +
            labs +
            ggthemes +
            themes +
            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(element_text(angle = 45, hjust = 1)),
            axis.text.y = quote(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(
            p2 <- summary_plot_patients %>%
              ggplot() +
              aes_(
                x = ~ factor(create_cols_labels(col), levels = x_levels),
                y = ~n_pct,
                fill = ~isna
              ) +
              geom_bar(alpha = 1, stat = "identity", position = "fill") +
              scale_y_continuous(labels = scales::percent_format(), breaks = seq(0, 1, by = 0.1), expand = c(0, 0)) +
              scale_fill_manual(
                name = "",
                values = c("grey90", c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]),
                labels = c("Present", "Missing")
              ) +
              geom_text(
                aes(label = ifelse(isna == TRUE, sprintf("%d [%.02f%%]", n, n_pct), ""), y = 1),
                hjust = 1,
                color = "black"
              ) +
              labs +
              ggthemes +
              themes +
              coord_flip(),
            env = list(
              labs = parsed_ggplot2_args$labs,
              themes = parsed_ggplot2_args$theme,
              ggthemes = parsed_ggplot2_args$ggtheme
            )
          )
        ) %>%
          teal.code::eval_code(
            quote({
              g1 <- ggplotGrob(p1)
              g2 <- ggplotGrob(p2)
              g <- gridExtra::gtable_cbind(g1, g2, size = "first")
              g$heights <- grid::unit.pmax(g1$heights, g2$heights)
              grid::grid.newpage()
            })
          )
      } else {
        qenv <- teal.code::eval_code(
          qenv,
          quote({
            g <- ggplotGrob(p1)
            grid::grid.newpage()
          })
        )
      }

      teal.code::eval_code(
        qenv,
        quote(grid::grid.draw(g))
      )
    })

    summary_plot_r <- reactive(summary_plot_q()[["g"]])

    combination_cutoff_q <- reactive({
      req(common_code_q())
      teal.code::eval_code(
        common_code_q(),
        quote(
          combination_cutoff <- ANL %>%
            dplyr::mutate_all(is.na) %>%
            dplyr::group_by_all() %>%
            dplyr::tally() %>%
            dplyr::ungroup()
        )
      )
    })

    output$cutoff <- renderUI({
      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], prev_value
      )

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

    combination_plot_q <- reactive({
      req(input$summary_type == "Combinations", input$combination_cutoff, combination_cutoff_q())
      teal::validate_has_data(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(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(element_blank()),
          axis.ticks = quote(element_blank()),
          panel.grid.major = quote(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
      )

      teal.code::eval_code(
        qenv,
        substitute(
          expr = {
            p1 <- data_combination_plot_cutoff %>%
              dplyr::select(id, n) %>%
              dplyr::distinct() %>%
              ggplot(aes(x = id, y = n)) +
              geom_bar(stat = "identity", fill = c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]) +
              geom_text(aes(label = n), position = position_dodge(width = 0.9), vjust = -0.25) +
              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

            p2 <- data_combination_plot_cutoff %>% ggplot() +
              aes(x = create_cols_labels(key), y = id - 0.5, fill = value) +
              geom_tile(alpha = 0.85, height = 0.95) +
              scale_fill_manual(
                name = "",
                values = c("grey90", c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]),
                labels = c("Present", "Missing")
              ) +
              geom_hline(yintercept = seq_len(1 + graph_number_rows) - 1) +
              geom_vline(xintercept = seq_len(1 + graph_number_cols) - 0.5, linetype = "dotted") +
              coord_flip() +
              labs2 +
              ggthemes2 +
              themes2

            g1 <- ggplotGrob(p1)
            g2 <- ggplotGrob(p2)

            g <- gridExtra::gtable_rbind(g1, g2, size = "last")
            g$heights[7] <- grid::unit(0.2, "null") # rescale to get the bar chart smaller
            grid::grid.newpage()
            grid::grid.draw(g)
          },
          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
          )
        )
      )
    })

    combination_plot_r <- reactive(combination_plot_q()[["g"]])

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

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

      group_var <- input$group_by_var
      validate(
        need(
          is.null(group_var) ||
            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 <- common_code_q()

      if (!is.null(group_var)) {
        qenv <- teal.code::eval_code(
          qenv,
          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
            )
          )
        )
      } else {
        qenv <- teal.code::eval_code(
          qenv,
          substitute(
            expr = summary_data <- ANL %>%
              dplyr::summarise_all(summ_fn) %>%
              tidyr::pivot_longer(dplyr::everything(),
                names_to = "Variable",
                values_to = paste0("Missing (N=", nrow(ANL), ")")
              ) %>%
              dplyr::mutate(`Variable label` = create_cols_labels(Variable), .after = Variable),
            env = list(summ_fn = summ_fn)
          )
        )
      }

      teal.code::eval_code(qenv, quote(summary_data))
    })

    summary_table_r <- reactive(summary_table_q()[["summary_data"]])

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

      teal::validate_has_data(data_r(), 1)

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

      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
      )

      teal.code::eval_code(
        common_code_q(),
        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(
          quote({
            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, rlang::hash)
              ) %>%
              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))
          })
        ) %>%
        teal.code::eval_code(
          substitute(
            expr = {
              g <- ggplot(summary_plot_patients, aes(
                x = factor(id, levels = order_subjects),
                y = factor(col, levels = ordered_columns[["column"]]),
                fill = isna
              )) +
                geom_raster() +
                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"]])
                ) +
                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
              print(g)
            },
            env = list(
              labs = parsed_ggplot2_args$labs,
              themes = parsed_ggplot2_args$theme,
              ggthemes = parsed_ggplot2_args$ggtheme
            )
          )
        )
    })

    by_subject_plot_r <- reactive(by_subject_plot_q()[["g"]])

    output$levels_table <- DT::renderDataTable(
      expr = {
        if (length(input$variables_select) == 0) {
          # so that zeroRecords message gets printed
          # using tibble as it supports weird column names, such as " "
          tibble::tibble(` ` = logical(0))
        } else {
          summary_table_r()
        }
      },
      options = list(language = list(zeroRecords = "No variable selected"), pageLength = input$levels_table_rows)
    )

    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_subject_plot",
      plot_r = by_subject_plot_r,
      height = plot_height,
      width = plot_width
    )

    final_q <- reactive({
      req(input$summary_type)
      sum_type <- input$summary_type
      if (sum_type == "Summary") {
        summary_plot_q()
      } else if (sum_type == "Combinations") {
        combination_plot_q()
      } else if (sum_type == "By Variable Levels") {
        summary_table_q()
      } else if (sum_type == "Grouped by Subject") {
        by_subject_plot_q()
      }
    })

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

    teal.widgets::verbatim_popup_srv(
      id = "rcode",
      verbatim_content = reactive(teal.code::get_code(final_q())),
      title = "Show R Code for Missing Data"
    )

    ### REPORTER
    if (with_reporter) {
      card_fun <- function(comment, label) {
        card <- teal::TealReportCard$new()
        sum_type <- input$summary_type
        title <- if (sum_type == "By Variable Levels") paste0(sum_type, " Table") else paste0(sum_type, " Plot")
        title_dataname <- paste(title, dataname, sep = " - ")
        label <- if (label == "") {
          paste("Missing Data", sum_type, dataname, sep = " - ")
        } else {
          label
        }
        card$set_name(label)
        card$append_text(title_dataname, "header2")
        if (with_filter) card$append_fs(filter_panel_api$get_filter_state())
        if (sum_type == "Summary") {
          card$append_text("Plot", "header3")
          card$append_plot(summary_plot_r(), dim = pws1$dim())
        } else if (sum_type == "Combinations") {
          card$append_text("Plot", "header3")
          card$append_plot(combination_plot_r(), dim = pws2$dim())
        } else if (sum_type == "By Variable Levels") {
          card$append_text("Table", "header3")
          card$append_table(summary_table_r[["summary_data"]])
        } else if (sum_type == "Grouped by Subject") {
          card$append_text("Plot", "header3")
          card$append_plot(by_subject_plot_r(), dim = pws3$dim())
        }
        if (!comment == "") {
          card$append_text("Comment", "header3")
          card$append_text(comment)
        }
        card$append_src(teal.code::get_code(final_q()))
        card
      }
      teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
    }
    ###
  })
}

#' `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.
#'
#' @templateVar ggnames "Boxplot","Density Plot","Cumulative Distribution Plot"
#' @template ggplot2_args_multi
#'
#' @inherit shared_params return
#'
#' @examples
#' library(teal.widgets)
#'
#' # general data example
#' data <- teal_data()
#' data <- within(data, {
#'   CO2 <- CO2
#'   CO2[["primary_key"]] <- seq_len(nrow(CO2))
#' })
#' datanames(data) <- "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
#'           )
#'         )
#'       ),
#'       ggplot2_args = list(
#'         ggplot2_args(
#'           labs = list(subtitle = "Plot generated by Outliers Module")
#'         )
#'       )
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
#' # CDISC data example
#' data <- teal_data()
#' data <- within(data, {
#'   ADSL <- rADSL
#' })
#' datanames(data) <- "ADSL"
#' join_keys(data) <- default_cdisc_join_keys[datanames(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
#'           )
#'         )
#'       ),
#'       ggplot2_args = list(
#'         ggplot2_args(
#'           labs = list(subtitle = "Plot generated by Outliers Module")
#'         )
#'       )
#'     )
#'   )
#' )
#' 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) {
  logger::log_info("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)
  # End of assertions

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

  data_extract_list <- list(
    outlier_var = outlier_var,
    categorical_var = categorical_var
  )

  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)
    ),
    ui = ui_outliers,
    ui_args = args,
    datanames = teal.transform::get_extract_datanames(data_extract_list)
  )
}

# 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")),
      DT::dataTableOutput(ns("summary_table")),
      uiOutput(ns("total_missing")),
      br(), 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"))
        )
      ),
      br(), hr(),
      uiOutput(ns("table_ui_wrap")),
      DT::dataTableOutput(ns("table_ui"))
    ),
    encoding = div(
      ### Reporter
      teal.reporter::simple_reporter_ui(ns("simple_reporter")),
      ###
      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)),
      teal.widgets::panel_group(
        teal.widgets::panel_item(
          title = "Method parameters",
          collapsed = FALSE,
          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"))
        )
      ),
      teal.widgets::panel_item(
        title = "Plot settings",
        selectInput(
          inputId = ns("ggtheme"),
          label = "Theme (by ggplot):",
          choices = ggplot_themes,
          selected = args$ggtheme,
          multiple = FALSE
        )
      )
    ),
    forms = tagList(
      teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
      teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
    ),
    pre_output = args$pre_output,
    post_output = args$post_output
  )
}

# Server function for the outliers module
srv_outliers <- function(id, data, reporter, filter_panel_api, outlier_var,
                         categorical_var, plot_height, plot_width, ggplot2_args) {
  with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
  with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
  checkmate::assert_class(data, "reactive")
  checkmate::assert_class(isolate(data()), "teal_data")
  moduleServer(id, function(input, output, session) {
    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()
      }
    })

    anl_merged_input <- teal.transform::merge_expression_srv(
      selector_list = reactive_select_input,
      datasets = data,
      merge_function = "dplyr::inner_join"
    )

    anl_merged_q <- reactive({
      req(anl_merged_input())
      data() %>%
        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({
      shiny::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]]))
    })

    # Used to create outlier table and the dropdown with additional columns
    dataname_first <- isolate(teal.data::datanames(data())[[1]])

    common_code_q <- reactive({
      shiny::req(iv_r()$is_valid())

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

      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) {
          return(x)
        }
        if (identical(x[[1]], as.name("%>%")) && is.null(x[[3]])) {
          return(remove_pipe_null(x[[2]]))
        }
        return(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
      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 = as.character(teal.data::join_keys(data())[dataname_first, dataname_first])
          )
        )
      )

      if (length(categorical_var) > 0) {
        qenv <- teal.code::eval_code(
          qenv,
          substitute(
            expr = summary_table_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_table_pre <- summary_table_pre %>%
                dplyr::arrange(desc(n_outliers / total_in_cat)) %>%
                dplyr::mutate(order = seq_len(nrow(summary_table_pre)))
            )
          )
        }

        qenv <- 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_table_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_table_pre, categorical_var_name, order),
                  by = categorical_var
                ) %>%
                dplyr::arrange(order)
              summary_table <- summary_table_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")
              summary_table
            },
            env = list(
              categorical_var = categorical_var,
              categorical_var_name = as.name(categorical_var)
            )
          )
        )
      }

      if (length(categorical_var) > 0 && nrow(qenv[["ANL_OUTLIER"]]) > 0) {
        shinyjs::show("order_by_outlier")
      } else {
        shinyjs::hide("order_by_outlier")
      }

      qenv
    })

    output$summary_table <- DT::renderDataTable(
      expr = {
        if (iv_r()$is_valid()) {
          categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)
          if (!is.null(categorical_var)) {
            DT::datatable(
              common_code_q()[["summary_table"]],
              options = list(
                dom = "t",
                autoWidth = TRUE,
                columnDefs = list(list(width = "200px", targets = "_all"))
              )
            )
          }
        }
      }
    )

    # boxplot/violinplot # nolint commented_code
    boxplot_q <- reactive({
      req(common_code_q())
      ANL <- common_code_q()[["ANL"]]
      ANL_OUTLIER <- common_code_q()[["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 + geom_boxplot(outlier.shape = NA), env = list(plot_call = plot_call))
      } else if (input$boxplot_alts == "Violin plot") {
        substitute(expr = plot_call + 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 +
            aes(x = "Entire dataset", y = outlier_var_name) +
            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 + geom_point(
              data = ANL_OUTLIER,
              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 +
            aes(y = outlier_var_name, x = reorder(categorical_var_name, order)) +
            xlab(categorical_var) +
            scale_x_discrete() +
            geom_point(
              data = ANL_OUTLIER,
              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(
        common_code_q(),
        substitute(
          expr = g <- plot_call +
            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
          )
        )
      ) %>%
        teal.code::eval_code(quote(print(g)))
    })

    # density plot
    density_plot_q <- reactive({
      ANL <- common_code_q()[["ANL"]]
      ANL_OUTLIER <- common_code_q()[["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 %>%
          ggplot(aes(x = outlier_var_name)) +
          geom_density() +
          geom_rug(data = ANL_OUTLIER, aes(x = outlier_var_name, color = is_outlier_selected)) +
          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 + 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(
        common_code_q(),
        substitute(
          expr = g <- 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.code::eval_code(quote(print(g)))
    })

    # Cumulative distribution plot
    cumulative_plot_q <- reactive({
      ANL <- common_code_q()[["ANL"]]
      ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]]

      qenv <- common_code_q()

      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 %>% ggplot(aes(x = outlier_var_name)) +
          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 + 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 = g <- plot_call +
            geom_point(data = outlier_points, aes(x = outlier_var_name, y = y, color = is_outlier_selected)) +
            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
          )
        )
      ) %>%
        teal.code::eval_code(quote(print(g)))
    })

    final_q <- reactive({
      req(input$tabs)
      tab_type <- input$tabs
      result_q <- if (tab_type == "Boxplot") {
        boxplot_q()
      } else if (tab_type == "Density Plot") {
        density_plot_q()
      } else if (tab_type == "Cumulative Distribution Plot") {
        cumulative_plot_q()
      }
      # used to display table when running show-r-code code
      #  added after the plots so that a change in selected columns doesn't affect
      #  brush selection.
      teal.code::eval_code(
        result_q,
        substitute(
          expr = {
            columns_index <- union(
              setdiff(names(ANL_OUTLIER), "is_outlier_selected"),
              table_columns
            )
            ANL_OUTLIER_EXTENDED[ANL_OUTLIER_EXTENDED$is_outlier_selected, columns_index]
          },
          env = list(
            table_columns = input$table_ui_columns
          )
        )
      )
    })

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

    boxplot_r <- reactive({
      teal::validate_inputs(iv_r())
      boxplot_q()[["g"]]
    })
    density_plot_r <- reactive({
      teal::validate_inputs(iv_r())
      density_plot_q()[["g"]]
    })
    cumulative_plot_r <- reactive({
      teal::validate_inputs(iv_r())
      cumulative_plot_q()[["g"]]
    })

    box_pws <- teal.widgets::plot_with_settings_srv(
      id = "box_plot",
      plot_r = boxplot_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
    )

    choices <- teal.transform::variable_choices(data()[[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 = 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
        shiny::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 <- if (tab == "Boxplot") {
          boxplot_r()
          box_pws$brush()
        } else if (tab == "Density Plot") {
          density_plot_r()
          density_pws$brush()
        } else if (tab == "Cumulative Distribution 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({
      shiny::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, ]
      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({
      shiny::req(iv_r()$is_valid())
      tagList(
        teal.widgets::optionalSelectInput(
          inputId = session$ns("table_ui_columns"),
          label = "Choose additional columns",
          choices = NULL,
          selected = NULL,
          multiple = TRUE
        ),
        h4("Outlier Table"),
        teal.widgets::get_dt_rows(session$ns("table_ui"), session$ns("table_ui_rows"))
      )
    })

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

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

    ### REPORTER
    if (with_reporter) {
      card_fun <- function(comment, label) {
        tab_type <- input$tabs
        card <- teal::report_card_template(
          title = paste0("Outliers - ", tab_type),
          label = label,
          with_filter = with_filter,
          filter_panel_api = filter_panel_api
        )
        categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)
        if (length(categorical_var) > 0) {
          summary_table <- common_code_q()[["summary_table"]]
          card$append_text("Summary Table", "header3")
          card$append_table(summary_table)
        }
        card$append_text("Plot", "header3")
        if (tab_type == "Boxplot") {
          card$append_plot(boxplot_r(), dim = box_pws$dim())
        } else if (tab_type == "Density Plot") {
          card$append_plot(density_plot_r(), dim = density_pws$dim())
        } else if (tab_type == "Cumulative Distribution Plot") {
          card$append_plot(cumulative_plot_r(), dim = cum_density_pws$dim())
        }
        if (!comment == "") {
          card$append_text("Comment", "header3")
          card$append_text(comment)
        }
        card$append_src(teal.code::get_code(final_q()))
        card
      }
      teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
    }
    ###
  })
}

#' `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
#'
#' @examples
#' data <- teal_data()
#' data <- within(data, {
#'   data <- data.frame(1)
#' })
#' datanames(data) <- c("data")
#'
#' 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 = "https://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" = ".")) {
  logger::log_info("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())

  module(
    label = label,
    server = srv_viewer,
    server_args = list(input_path = input_path),
    ui = ui_viewer,
    ui_args = args,
    datanames = NULL
  )
}

# UI function for the file viewer module
ui_viewer <- function(id, ...) {
  args <- list(...)
  ns <- NS(id)

  shiny::tagList(
    include_css_files("custom"),
    teal.widgets::standard_layout(
      output = div(
        uiOutput(ns("output"))
      ),
      encoding = div(
        class = "file_viewer_encoding",
        tags$label("Encodings", class = "text-primary"),
        shinyTree::shinyTree(
          ns("tree"),
          dragAndDrop = FALSE,
          sort = FALSE,
          wholerow = TRUE,
          theme = "proton",
          multiple = FALSE
        )
      )
    )
  )
}

# Server function for the file viewer module
srv_viewer <- function(id, input_path) {
  moduleServer(id, function(input, output, session) {
    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(
          class = "embed_pdf",
          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: 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`.
#'
#' @note For more examples, please see the vignette "Using cross table" via
#' `vignette("using-cross-table", package = "teal.modules.general")`.
#'
#' @inherit shared_params return
#'
#' @examples
#' # general data example
#' library(teal.widgets)
#'
#' 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))
#' })
#' datanames(data) <- "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
#'         )
#'       ),
#'       basic_table_args = basic_table_args(
#'         subtitles = "Table generated by Crosstable Module"
#'       )
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
#' # CDISC data example
#' library(teal.widgets)
#'
#' data <- teal_data()
#' data <- within(data, {
#'   ADSL <- rADSL
#' })
#' datanames(data) <- "ADSL"
#' join_keys(data) <- default_cdisc_join_keys[datanames(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
#'         )
#'       ),
#'       basic_table_args = basic_table_args(
#'         subtitles = "Table generated by Crosstable Module"
#'       )
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
#' @export
#'
tm_t_crosstable <- function(label = "Cross Table",
                            x,
                            y,
                            show_percentage = TRUE,
                            show_total = TRUE,
                            pre_output = NULL,
                            post_output = NULL,
                            basic_table_args = teal.widgets::basic_table_args()) {
  logger::log_info("Initializing tm_t_crosstable")

  # Requires Suggested packages
  if (!requireNamespace("rtables", quietly = TRUE)) {
    stop("Cannot load rtables - please install the package or restart your session.")
  }

  # 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_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")
  # End of assertions

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

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

  module(
    label = label,
    server = srv_t_crosstable,
    ui = ui_t_crosstable,
    ui_args = ui_args,
    server_args = server_args,
    datanames = teal.transform::get_extract_datanames(list(x = x, y = y))
  )
}

# UI function for the cross-table module
ui_t_crosstable <- function(id, x, y, show_percentage, show_total, pre_output, post_output, ...) {
  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 = div(
      ### Reporter
      teal.reporter::simple_reporter_ui(ns("simple_reporter")),
      ###
      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(),
      teal.widgets::panel_group(
        teal.widgets::panel_item(
          title = "Table settings",
          checkboxInput(ns("show_percentage"), "Show column percentage", value = show_percentage),
          checkboxInput(ns("show_total"), "Show total column", value = show_total)
        )
      )
    ),
    forms = tagList(
      teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
      teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
    ),
    pre_output = pre_output,
    post_output = post_output
  )
}

# Server function for the cross-table module
srv_t_crosstable <- function(id, data, reporter, filter_panel_api, label, x, y, basic_table_args) {
  with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
  with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
  checkmate::assert_class(data, "reactive")
  checkmate::assert_class(isolate(data()), "teal_data")
  moduleServer(id, function(input, output, session) {
    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
    )

    anl_merged_q <- reactive({
      req(anl_merged_input())
      data() %>%
        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

      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
      )

      teal.code::eval_code(
        merged$anl_q_r(),
        substitute(
          expr = {
            title <- plot_title
          },
          env = list(plot_title = plot_title)
        )
      ) %>%
        teal.code::eval_code(
          substitute(
            expr = {
              lyt <- 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(
          substitute(
            expr = {
              ANL <- tern::df_explicit_na(ANL)
              tbl <- rtables::build_table(lyt = lyt, df = ANL[order(ANL[[y_name]]), ])
              tbl
            },
            env = list(y_name = y_name)
          )
        )
    })

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

    table_r <- reactive({
      shiny::req(iv_r()$is_valid())
      output_q()[["tbl"]]
    })

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

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

    teal.widgets::verbatim_popup_srv(
      id = "rcode",
      verbatim_content = reactive(teal.code::get_code(output_q())),
      title = "Show R Code for Cross-Table"
    )

    ### REPORTER
    if (with_reporter) {
      card_fun <- function(comment, label) {
        card <- teal::report_card_template(
          title = "Cross Table",
          label = label,
          with_filter = with_filter,
          filter_panel_api = filter_panel_api
        )
        card$append_text("Table", "header3")
        card$append_table(table_r())
        if (!comment == "") {
          card$append_text("Comment", "header3")
          card$append_text(comment)
        }
        card$append_src(teal.code::get_code(output_q()))
        card
      }
      teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
    }
    ###
  })
}

#' `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
#'
#' @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)
#'   )
#' })
#' datanames(data) <- c("countries", "sales")
#' 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", "ES", "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)
#' }
#'
#' # CDISC data example
#' data <- teal_data()
#' data <- within(data, {
#'   ADSL <- rADSL
#'   ADRS <- rADRS
#' })
#' datanames(data) <- c("ADSL", "ADRS")
#' join_keys(data) <- default_cdisc_join_keys[datanames(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) {
  logger::log_info("Initializing tm_g_scatterplotmatrix")

  # Requires Suggested packages
  if (!requireNamespace("lattice", quietly = TRUE)) {
    stop("Cannot load lattice - please install the package or restart your session.")
  }

  # 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)
  # End of assertions

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

  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),
    datanames = teal.transform::get_extract_datanames(variables)
  )
}

# 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")),
      br(),
      teal.widgets::plot_with_settings_ui(id = ns("myplot"))
    ),
    encoding = div(
      ### Reporter
      teal.reporter::simple_reporter_ui(ns("simple_reporter")),
      ###
      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
      ),
      hr(),
      teal.widgets::panel_group(
        teal.widgets::panel_item(
          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)
        )
      )
    ),
    forms = tagList(
      teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
      teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
    ),
    pre_output = args$pre_output,
    post_output = args$post_output
  )
}

# Server function for the scatterplot matrix module
srv_g_scatterplotmatrix <- function(id, data, reporter, filter_panel_api, variables, plot_height, plot_width) {
  with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
  with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
  checkmate::assert_class(data, "reactive")
  checkmate::assert_class(isolate(data()), "teal_data")
  moduleServer(id, function(input, output, session) {
    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())
      data() %>%
        teal.code::eval_code(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
      if (add_cor) {
        shinyjs::show("cor_method")
        shinyjs::show("cor_use")
        shinyjs::show("cor_na_omit")

        qenv <- teal.code::eval_code(
          qenv,
          substitute(
            expr = {
              g <- 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
              )
              print(g)
            },
            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 = {
              g <- lattice::splom(ANL, varnames = varnames_value, pch = 16, alpha = alpha_value, cex = cex_value)
              g
            },
            env = list(varnames_value = varnames, alpha_value = alpha, cex_value = cex)
          )
        )
      }
      qenv
    })

    plot_r <- reactive(output_q()[["g"]])

    # 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({
      shiny::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 {
        ""
      }
    })

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

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

    ### REPORTER
    if (with_reporter) {
      card_fun <- function(comment, label) {
        card <- teal::report_card_template(
          title = "Scatter Plot Matrix",
          label = label,
          with_filter = with_filter,
          filter_panel_api = filter_panel_api
        )
        card$append_text("Plot", "header3")
        card$append_plot(plot_r(), dim = pws$dim())
        if (!comment == "") {
          card$append_text("Comment", "header3")
          card$append_text(comment)
        }
        card$append_src(teal.code::get_code(output_q()))
        card
      }
      teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
    }
    ###
  })
}

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

#' 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`.
#'
#' @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(ggplotGrob(p))
  }
  grid::grid.grabExpr({
    g <- 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]]
      }
    }
  ))
}

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

#' JavaScript condition to check if a specific 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)
}

#' `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`) A vector of datasets which should be
#' shown and in what order. Names in the vector have to correspond with datasets names.
#' If vector of `length == 0` (default) then all datasets are shown.
#' Note: Only datasets of the `data.frame` class are compatible.
#' @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
#'
#' @examples
#' # general data example
#' data <- teal_data()
#' data <- within(data, {
#'   require(nestcolor)
#'   iris <- iris
#' })
#' datanames(data) <- c("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 = "ADSL Table Caption")
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
#' # CDISC data example
#' data <- teal_data()
#' data <- within(data, {
#'   require(nestcolor)
#'   ADSL <- rADSL
#' })
#' datanames(data) <- "ADSL"
#' join_keys(data) <- default_cdisc_join_keys[datanames(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 = character(0),
                          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) {
  logger::log_info("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]]))
      }
    })
  }

  checkmate::assert_character(datasets_selected, min.len = 0, min.chars = 1)
  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

  module(
    label,
    server = srv_page_data_table,
    ui = ui_page_data_table,
    datanames = if (length(datasets_selected) == 0) "all" else datasets_selected,
    server_args = list(
      variables_selected = variables_selected,
      datasets_selected = datasets_selected,
      dt_args = dt_args,
      dt_options = dt_options,
      server_rendering = server_rendering
    ),
    ui_args = list(
      pre_output = pre_output,
      post_output = post_output
    )
  )
}

# UI page module
ui_page_data_table <- function(id,
                               pre_output = NULL,
                               post_output = NULL) {
  ns <- NS(id)

  shiny::tagList(
    include_css_files("custom"),
    teal.widgets::standard_layout(
      output = teal.widgets::white_small_well(
        fluidRow(
          column(
            width = 12,
            checkboxInput(
              ns("if_distinct"),
              "Show only distinct rows:",
              value = FALSE
            )
          )
        ),
        fluidRow(
          class = "mb-8",
          column(
            width = 12,
            uiOutput(ns("dataset_table"))
          )
        )
      ),
      pre_output = pre_output,
      post_output = post_output
    )
  )
}

# Server page module
srv_page_data_table <- function(id,
                                data,
                                datasets_selected,
                                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) {
    if_filtered <- reactive(as.logical(input$if_filtered))
    if_distinct <- reactive(as.logical(input$if_distinct))

    datanames <- isolate(teal.data::datanames(data()))
    datanames <- Filter(function(name) {
      is.data.frame(isolate(data())[[name]])
    }, datanames)

    if (!identical(datasets_selected, character(0))) {
      checkmate::assert_subset(datasets_selected, datanames)
      datanames <- datasets_selected
    }

    output$dataset_table <- renderUI({
      do.call(
        tabsetPanel,
        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,
              column(
                width = 12,
                div(
                  class = "mt-4",
                  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")),
    fluidRow(
      teal.widgets::optionalSelectInput(
        ns("variables"),
        "Select variables:",
        choices = choices,
        selected = selected,
        multiple = TRUE,
        width = "100%"
      )
    ),
    fluidRow(
      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(data()[[dataname]]), message_fmt = "Not all selected variables exist in the data"
    ))
    iv$enable()

    output$data_table <- DT::renderDataTable(server = server_rendering, {
      teal::validate_inputs(iv)

      df <- data()[[dataname]]
      variables <- input$variables

      teal::validate_has_data(df, min_nrow = 1L, msg = paste("data", dataname, "is empty"))

      dataframe_selected <- if (if_distinct()) {
        dplyr::count(df, dplyr::across(dplyr::all_of(variables)))
      } else {
        df[variables]
      }

      dt_args$options <- dt_options
      if (!is.null(input$dt_rows)) {
        dt_args$options$pageLength <- input$dt_rows
      }
      dt_args$data <- dataframe_selected

      do.call(DT::datatable, dt_args)
    })
  })
}

1		.onLoad <- function(libname, pkgname) {
2	!	teal.logger::register_logger(namespace = "teal.modules.general")
3		}
4
5		### global variables
6		ggplot_themes <- c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void")

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		#' @examples
43		#' # general data example
44		#' library(teal.widgets)
45		#'
46		#' data <- teal_data()
47		#' data <- within(data, {
48		#' require(nestcolor)
49		#' mtcars <- mtcars
50		#' for (v in c("cyl", "vs", "am", "gear")) {
51		#' mtcars[[v]] <- as.factor(mtcars[[v]])
52		#' }
53		#' })
54		#' datanames(data) <- "mtcars"
55		#'
56		#' app <- init(
57		#' data = data,
58		#' modules = modules(
59		#' tm_g_response(
60		#' label = "Response Plots",
61		#' response = data_extract_spec(
62		#' dataname = "mtcars",
63		#' select = select_spec(
64		#' label = "Select variable:",
65		#' choices = variable_choices(data[["mtcars"]], c("cyl", "gear")),
66		#' selected = "cyl",
67		#' multiple = FALSE,
68		#' fixed = FALSE
69		#' )
70		#' ),
71		#' x = data_extract_spec(
72		#' dataname = "mtcars",
73		#' select = select_spec(
74		#' label = "Select variable:",
75		#' choices = variable_choices(data[["mtcars"]], c("vs", "am")),
76		#' selected = "vs",
77		#' multiple = FALSE,
78		#' fixed = FALSE
79		#' )
80		#' ),
81		#' ggplot2_args = ggplot2_args(
82		#' labs = list(subtitle = "Plot generated by Response Module")
83		#' )
84		#' )
85		#' )
86		#' )
87		#' if (interactive()) {
88		#' shinyApp(app$ui, app$server)
89		#' }
90		#'
91		#' # CDISC data example
92		#' library(teal.widgets)
93		#'
94		#' data <- teal_data()
95		#' data <- within(data, {
96		#' require(nestcolor)
97		#' ADSL <- rADSL
98		#' })
99		#' datanames(data) <- c("ADSL")
100		#' join_keys(data) <- default_cdisc_join_keys[datanames(data)]
101		#'
102		#' app <- init(
103		#' data = data,
104		#' modules = modules(
105		#' tm_g_response(
106		#' label = "Response Plots",
107		#' response = data_extract_spec(
108		#' dataname = "ADSL",
109		#' select = select_spec(
110		#' label = "Select variable:",
111		#' choices = variable_choices(data[["ADSL"]], c("BMRKR2", "COUNTRY")),
112		#' selected = "BMRKR2",
113		#' multiple = FALSE,
114		#' fixed = FALSE
115		#' )
116		#' ),
117		#' x = data_extract_spec(
118		#' dataname = "ADSL",
119		#' select = select_spec(
120		#' label = "Select variable:",
121		#' choices = variable_choices(data[["ADSL"]], c("SEX", "RACE")),
122		#' selected = "RACE",
123		#' multiple = FALSE,
124		#' fixed = FALSE
125		#' )
126		#' ),
127		#' ggplot2_args = ggplot2_args(
128		#' labs = list(subtitle = "Plot generated by Response Module")
129		#' )
130		#' )
131		#' )
132		#' )
133		#' if (interactive()) {
134		#' shinyApp(app$ui, app$server)
135		#' }
136		#'
137		#' @export
138		#'
139		tm_g_response <- function(label = "Response Plot",
140		response,
141		x,
142		row_facet = NULL,
143		col_facet = NULL,
144		coord_flip = FALSE,
145		count_labels = TRUE,
146		rotate_xaxis_labels = FALSE,
147		freq = FALSE,
148		plot_height = c(600, 400, 5000),
149		plot_width = NULL,
150		ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
151		ggplot2_args = teal.widgets::ggplot2_args(),
152		pre_output = NULL,
153		post_output = NULL) {
154	!	logger::log_info("Initializing tm_g_response")
155
156		# Normalize the parameters
157	!	if (inherits(response, "data_extract_spec")) response <- list(response)
158	!	if (inherits(x, "data_extract_spec")) x <- list(x)
159	!	if (inherits(row_facet, "data_extract_spec")) row_facet <- list(row_facet)
160	!	if (inherits(col_facet, "data_extract_spec")) col_facet <- list(col_facet)
161
162		# Start of assertions
163	!	checkmate::assert_string(label)
164
165	!	checkmate::assert_list(response, types = "data_extract_spec")
166	!	if (!all(vapply(response, function(x) !("" %in% x$select$choices), logical(1)))) {
167	!	stop("'response' should not allow empty values")
168		}
169	!	assert_single_selection(response)
170
171	!	checkmate::assert_list(x, types = "data_extract_spec")
172	!	if (!all(vapply(x, function(x) !("" %in% x$select$choices), logical(1)))) {
173	!	stop("'x' should not allow empty values")
174		}
175	!	assert_single_selection(x)
176
177	!	checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE)
178	!	checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE)
179	!	checkmate::assert_flag(coord_flip)
180	!	checkmate::assert_flag(count_labels)
181	!	checkmate::assert_flag(rotate_xaxis_labels)
182	!	checkmate::assert_flag(freq)
183
184	!	checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
185	!	checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")
186	!	checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
187	!	checkmate::assert_numeric(
188	!	plot_width[1],
189	!	lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"
190		)
191
192	!	ggtheme <- match.arg(ggtheme)
193	!	checkmate::assert_class(ggplot2_args, "ggplot2_args")
194
195	!	checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
196	!	checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
197		# End of assertions
198
199		# Make UI args
200	!	args <- as.list(environment())
201
202	!	data_extract_list <- list(
203	!	response = response,
204	!	x = x,
205	!	row_facet = row_facet,
206	!	col_facet = col_facet
207		)
208
209	!	module(
210	!	label = label,
211	!	server = srv_g_response,
212	!	ui = ui_g_response,
213	!	ui_args = args,
214	!	server_args = c(
215	!	data_extract_list,
216	!	list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args)
217		),
218	!	datanames = teal.transform::get_extract_datanames(data_extract_list)
219		)
220		}
221
222		# UI function for the response module
223		ui_g_response <- function(id, ...) {
224	!	ns <- NS(id)
225	!	args <- list(...)
226	!	is_single_dataset_value <- teal.transform::is_single_dataset(args$response, args$x, args$row_facet, args$col_facet)
227
228	!	teal.widgets::standard_layout(
229	!	output = teal.widgets::white_small_well(
230	!	teal.widgets::plot_with_settings_ui(id = ns("myplot"))
231		),
232	!	encoding = div(
233		### Reporter
234	!	teal.reporter::simple_reporter_ui(ns("simple_reporter")),
235		###
236	!	tags$label("Encodings", class = "text-primary"),
237	!	teal.transform::datanames_input(args[c("response", "x", "row_facet", "col_facet")]),
238	!	teal.transform::data_extract_ui(
239	!	id = ns("response"),
240	!	label = "Response variable",
241	!	data_extract_spec = args$response,
242	!	is_single_dataset = is_single_dataset_value
243		),
244	!	teal.transform::data_extract_ui(
245	!	id = ns("x"),
246	!	label = "X variable",
247	!	data_extract_spec = args$x,
248	!	is_single_dataset = is_single_dataset_value
249		),
250	!	if (!is.null(args$row_facet)) {
251	!	teal.transform::data_extract_ui(
252	!	id = ns("row_facet"),
253	!	label = "Row facetting",
254	!	data_extract_spec = args$row_facet,
255	!	is_single_dataset = is_single_dataset_value
256		)
257		},
258	!	if (!is.null(args$col_facet)) {
259	!	teal.transform::data_extract_ui(
260	!	id = ns("col_facet"),
261	!	label = "Column facetting",
262	!	data_extract_spec = args$col_facet,
263	!	is_single_dataset = is_single_dataset_value
264		)
265		},
266	!	shinyWidgets::radioGroupButtons(
267	!	inputId = ns("freq"),
268	!	label = NULL,
269	!	choices = c("frequency", "density"),
270	!	selected = ifelse(args$freq, "frequency", "density"),
271	!	justified = TRUE
272		),
273	!	teal.widgets::panel_group(
274	!	teal.widgets::panel_item(
275	!	title = "Plot settings",
276	!	checkboxInput(ns("count_labels"), "Add count labels", value = args$count_labels),
277	!	checkboxInput(ns("coord_flip"), "Swap axes", value = args$coord_flip),
278	!	checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels),
279	!	selectInput(
280	!	inputId = ns("ggtheme"),
281	!	label = "Theme (by ggplot):",
282	!	choices = ggplot_themes,
283	!	selected = args$ggtheme,
284	!	multiple = FALSE
285		)
286		)
287		)
288		),
289	!	forms = tagList(
290	!	teal.widgets::verbatim_popup_ui(ns("warning"), button_label = "Show Warnings"),
291	!	teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
292		),
293	!	pre_output = args$pre_output,
294	!	post_output = args$post_output
295		)
296		}
297
298		# Server function for the response module
299		srv_g_response <- function(id,
300		data,
301		reporter,
302		filter_panel_api,
303		response,
304		x,
305		row_facet,
306		col_facet,
307		plot_height,
308		plot_width,
309		ggplot2_args) {
310	!	with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
311	!	with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
312	!	checkmate::assert_class(data, "reactive")
313	!	checkmate::assert_class(isolate(data()), "teal_data")
314	!	moduleServer(id, function(input, output, session) {
315	!	data_extract <- list(response = response, x = x, row_facet = row_facet, col_facet = col_facet)
316
317	!	rule_diff <- function(other) {
318	!	function(value) {
319	!	if (other %in% names(selector_list())) {
320	!	othervalue <- selector_list()[[other]]()[["select"]]
321	!	if (!is.null(othervalue)) {
322	!	if (identical(value, othervalue)) {
323	!	"Row and column facetting variables must be different."
324		}
325		}
326		}
327		}
328		}
329
330	!	selector_list <- teal.transform::data_extract_multiple_srv(
331	!	data_extract = data_extract,
332	!	datasets = data,
333	!	select_validation_rule = list(
334	!	response = shinyvalidate::sv_required("Please define a column for the response variable"),
335	!	x = shinyvalidate::sv_required("Please define a column for X variable"),
336	!	row_facet = shinyvalidate::compose_rules(
337	!	shinyvalidate::sv_optional(),
338	!	~ if (length(.) > 1) "There must be 1 or no row facetting variable.",
339	!	rule_diff("col_facet")
340		),
341	!	col_facet = shinyvalidate::compose_rules(
342	!	shinyvalidate::sv_optional(),
343	!	~ if (length(.) > 1) "There must be 1 or no column facetting variable.",
344	!	rule_diff("row_facet")
345		)
346		)
347		)
348
349	!	iv_r <- reactive({
350	!	iv <- shinyvalidate::InputValidator$new()
351	!	iv$add_rule("ggtheme", shinyvalidate::sv_required("Please select a theme"))
352	!	teal.transform::compose_and_enable_validators(iv, selector_list)
353		})
354
355	!	anl_merged_input <- teal.transform::merge_expression_srv(
356	!	selector_list = selector_list,
357	!	datasets = data
358		)
359
360	!	anl_merged_q <- reactive({
361	!	req(anl_merged_input())
362	!	data() %>%
363	!	teal.code::eval_code(as.expression(anl_merged_input()$expr))
364		})
365
366	!	merged <- list(
367	!	anl_input_r = anl_merged_input,
368	!	anl_q_r = anl_merged_q
369		)
370
371	!	output_q <- reactive({
372	!	teal::validate_inputs(iv_r())
373
374	!	qenv <- merged$anl_q_r()
375	!	ANL <- qenv[["ANL"]]
376	!	resp_var <- as.vector(merged$anl_input_r()$columns_source$response)
377	!	x <- as.vector(merged$anl_input_r()$columns_source$x)
378
379	!	validate(need(is.factor(ANL[[resp_var]]), "Please select a factor variable as the response."))
380	!	validate(need(is.factor(ANL[[x]]), "Please select a factor variable as the X-Variable."))
381	!	teal::validate_has_data(ANL, 10)
382	!	teal::validate_has_data(ANL[, c(resp_var, x)], 10, complete = TRUE, allow_inf = FALSE)
383
384	!	row_facet_name <- if (length(merged$anl_input_r()$columns_source$row_facet) == 0) {
385	!	character(0)
386		} else {
387	!	as.vector(merged$anl_input_r()$columns_source$row_facet)
388		}
389	!	col_facet_name <- if (length(merged$anl_input_r()$columns_source$col_facet) == 0) {
390	!	character(0)
391		} else {
392	!	as.vector(merged$anl_input_r()$columns_source$col_facet)
393		}
394
395	!	freq <- input$freq == "frequency"
396	!	swap_axes <- input$coord_flip
397	!	counts <- input$count_labels
398	!	rotate_xaxis_labels <- input$rotate_xaxis_labels
399	!	ggtheme <- input$ggtheme
400
401	!	arg_position <- if (freq) "stack" else "fill"
402
403	!	rowf <- if (length(row_facet_name) != 0) as.name(row_facet_name)
404	!	colf <- if (length(col_facet_name) != 0) as.name(col_facet_name)
405	!	resp_cl <- as.name(resp_var)
406	!	x_cl <- as.name(x)
407
408	!	if (swap_axes) {
409	!	qenv <- teal.code::eval_code(
410	!	qenv,
411	!	substitute(
412	!	expr = ANL[[x]] <- with(ANL, forcats::fct_rev(x_cl)),
413	!	env = list(x = x, x_cl = x_cl)
414		)
415		)
416		}
417
418	!	qenv <- teal.code::eval_code(
419	!	qenv,
420	!	substitute(
421	!	expr = ANL[[resp_var]] <- factor(ANL[[resp_var]]),
422	!	env = list(resp_var = resp_var)
423		)
424		) %>%
425		# rowf and colf will be a NULL if not set by a user
426	!	teal.code::eval_code(
427	!	substitute(
428	!	expr = ANL2 <- ANL %>%
429	!	dplyr::group_by_at(dplyr::vars(x_cl, resp_cl, rowf, colf)) %>%
430	!	dplyr::summarise(ns = dplyr::n()) %>%
431	!	dplyr::group_by_at(dplyr::vars(x_cl, rowf, colf)) %>%
432	!	dplyr::mutate(sums = sum(ns), percent = round(ns / sums * 100, 1)),
433	!	env = list(x_cl = x_cl, resp_cl = resp_cl, rowf = rowf, colf = colf)
434		)
435		) %>%
436	!	teal.code::eval_code(
437	!	substitute(
438	!	expr = ANL3 <- ANL %>%
439	!	dplyr::group_by_at(dplyr::vars(x_cl, rowf, colf)) %>%
440	!	dplyr::summarise(ns = dplyr::n()),
441	!	env = list(x_cl = x_cl, rowf = rowf, colf = colf)
442		)
443		)
444
445	!	plot_call <- substitute(
446	!	expr = ggplot(ANL2, aes(x = x_cl, y = ns)) +
447	!	geom_bar(aes(fill = resp_cl), stat = "identity", position = arg_position),
448	!	env = list(
449	!	x_cl = x_cl,
450	!	resp_cl = resp_cl,
451	!	arg_position = arg_position
452		)
453		)
454
455	!	if (!freq) plot_call <- substitute(plot_call + expand_limits(y = c(0, 1.1)), env = list(plot_call = plot_call))
456
457	!	if (counts) {
458	!	plot_call <- substitute(
459	!	expr = plot_call +
460	!	geom_text(
461	!	data = ANL2,
462	!	aes(label = ns, x = x_cl, y = ns, group = resp_cl),
463	!	col = "white",
464	!	vjust = "middle",
465	!	hjust = "middle",
466	!	position = position_anl2_value
467		) +
468	!	geom_text(
469	!	data = ANL3, aes(label = ns, x = x_cl, y = anl3_y),
470	!	hjust = hjust_value,
471	!	vjust = vjust_value,
472	!	position = position_anl3_value
473		),
474	!	env = list(
475	!	plot_call = plot_call,
476	!	x_cl = x_cl,
477	!	resp_cl = resp_cl,
478	!	hjust_value = if (swap_axes) "left" else "middle",
479	!	vjust_value = if (swap_axes) "middle" else -1,
480	!	position_anl2_value = if (!freq) quote(position_fill(0.5)) else quote(position_stack(0.5)),
481	!	anl3_y = if (!freq) 1.1 else as.name("ns"),
482	!	position_anl3_value = if (!freq) "fill" else "stack"
483		)
484		)
485		}
486
487	!	if (swap_axes) {
488	!	plot_call <- substitute(plot_call + coord_flip(), env = list(plot_call = plot_call))
489		}
490
491	!	facet_cl <- facet_ggplot_call(row_facet_name, col_facet_name)
492
493	!	if (!is.null(facet_cl)) {
494	!	plot_call <- substitute(expr = plot_call + facet_cl, env = list(plot_call = plot_call, facet_cl = facet_cl))
495		}
496
497	!	dev_ggplot2_args <- teal.widgets::ggplot2_args(
498	!	labs = list(
499	!	x = varname_w_label(x, ANL),
500	!	y = varname_w_label(resp_var, ANL, prefix = "Proportion of "),
501	!	fill = varname_w_label(resp_var, ANL)
502		),
503	!	theme = list(legend.position = "bottom")
504		)
505
506	!	if (rotate_xaxis_labels) {
507	!	dev_ggplot2_args$theme[["axis.text.x"]] <- quote(element_text(angle = 45, hjust = 1))
508		}
509
510	!	all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(
511	!	user_plot = ggplot2_args,
512	!	module_plot = dev_ggplot2_args
513		)
514
515	!	parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(
516	!	all_ggplot2_args,
517	!	ggtheme = ggtheme
518		)
519
520	!	plot_call <- substitute(expr = {
521	!	p <- plot_call + labs + ggthemes + themes
522	!	print(p)
523	!	}, env = list(
524	!	plot_call = plot_call,
525	!	labs = parsed_ggplot2_args$labs,
526	!	themes = parsed_ggplot2_args$theme,
527	!	ggthemes = parsed_ggplot2_args$ggtheme
528		))
529
530	!	teal.code::eval_code(qenv, plot_call)
531		})
532
533	!	plot_r <- reactive(output_q()[["p"]])
534
535		# Insert the plot into a plot_with_settings module from teal.widgets
536	!	pws <- teal.widgets::plot_with_settings_srv(
537	!	id = "myplot",
538	!	plot_r = plot_r,
539	!	height = plot_height,
540	!	width = plot_width
541		)
542
543	!	teal.widgets::verbatim_popup_srv(
544	!	id = "warning",
545	!	verbatim_content = reactive(teal.code::get_warnings(output_q())),
546	!	title = "Warning",
547	!	disabled = reactive(is.null(teal.code::get_warnings(output_q())))
548		)
549
550	!	teal.widgets::verbatim_popup_srv(
551	!	id = "rcode",
552	!	verbatim_content = reactive(teal.code::get_code(output_q())),
553	!	title = "Show R Code for Response"
554		)
555
556		### REPORTER
557	!	if (with_reporter) {
558	!	card_fun <- function(comment, label) {
559	!	card <- teal::report_card_template(
560	!	title = "Response Plot",
561	!	label = label,
562	!	with_filter = with_filter,
563	!	filter_panel_api = filter_panel_api
564		)
565	!	card$append_text("Plot", "header3")
566	!	card$append_plot(plot_r(), dim = pws$dim())
567	!	if (!comment == "") {
568	!	card$append_text("Comment", "header3")
569	!	card$append_text(comment)
570		}
571	!	card$append_src(teal.code::get_code(output_q()))
572	!	card
573		}
574	!	teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
575		}
576		###
577		})
578		}

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`) indicating whether the metadata of the datasets be available on the module.
17		#'
18		#' @inherit shared_params return
19		#'
20		#' @examples
21		#' data <- teal_data()
22		#' data <- within(data, {
23		#' require(nestcolor)
24		#' ADSL <- rADSL
25		#' attr(ADSL, "metadata") <- list("Author" = "NEST team", "data_source" = "synthetic data")
26		#' })
27		#' datanames(data) <- "ADSL"
28		#' join_keys(data) <- default_cdisc_join_keys[datanames(data)]
29		#'
30		#' table_1 <- data.frame(Info = c("A", "B"), Text = c("A", "B"))
31		#' table_2 <- data.frame(`Column 1` = c("C", "D"), `Column 2` = c(5.5, 6.6), `Column 3` = c("A", "B"))
32		#' table_3 <- data.frame(Info = c("E", "F"), Text = c("G", "H"))
33		#'
34		#' table_input <- list(
35		#' "Table 1" = table_1,
36		#' "Table 2" = table_2,
37		#' "Table 3" = table_3
38		#' )
39		#'
40		#' app <- init(
41		#' data = data,
42		#' modules = modules(
43		#' tm_front_page(
44		#' header_text = c(
45		#' "Important information" = "It can go here.",
46		#' "Other information" = "Can go here."
47		#' ),
48		#' tables = table_input,
49		#' additional_tags = HTML("Additional HTML or shiny tags go here <br>"),
50		#' footnotes = c("X" = "is the first footnote", "Y is the second footnote"),
51		#' show_metadata = TRUE
52		#' )
53		#' ),
54		#' header = tags$h1("Sample Application"),
55		#' footer = tags$p("Application footer"),
56		#' )
57		#'
58		#' if (interactive()) {
59		#' shinyApp(app$ui, app$server)
60		#' }
61		#'
62		#' @export
63		#'
64		tm_front_page <- function(label = "Front page",
65		header_text = character(0),
66		tables = list(),
67		additional_tags = tagList(),
68		footnotes = character(0),
69		show_metadata = FALSE) {
70	!	logger::log_info("Initializing tm_front_page")
71
72		# Start of assertions
73	!	checkmate::assert_string(label)
74	!	checkmate::assert_character(header_text, min.len = 0, any.missing = FALSE)
75	!	checkmate::assert_list(tables, types = "data.frame", names = "named", any.missing = FALSE)
76	!	checkmate::assert_multi_class(additional_tags, classes = c("shiny.tag.list", "html"))
77	!	checkmate::assert_character(footnotes, min.len = 0, any.missing = FALSE)
78	!	checkmate::assert_flag(show_metadata)
79		# End of assertions
80
81		# Make UI args
82	!	args <- as.list(environment())
83
84	!	module(
85	!	label = label,
86	!	server = srv_front_page,
87	!	ui = ui_front_page,
88	!	ui_args = args,
89	!	server_args = list(tables = tables, show_metadata = show_metadata),
90	!	datanames = if (show_metadata) "all" else NULL
91		)
92		}
93
94		# UI function for the front page module
95		ui_front_page <- function(id, ...) {
96	!	args <- list(...)
97	!	ns <- NS(id)
98
99	!	tagList(
100	!	include_css_files("custom"),
101	!	tags$div(
102	!	id = "front_page_content",
103	!	class = "ml-8",
104	!	tags$div(
105	!	id = "front_page_headers",
106	!	get_header_tags(args$header_text)
107		),
108	!	tags$div(
109	!	id = "front_page_tables",
110	!	class = "ml-4",
111	!	get_table_tags(args$tables, ns)
112		),
113	!	tags$div(
114	!	id = "front_page_custom_html",
115	!	class = "my-4",
116	!	args$additional_tags
117		),
118	!	if (args$show_metadata) {
119	!	tags$div(
120	!	id = "front_page_metabutton",
121	!	class = "m-4",
122	!	actionButton(ns("metadata_button"), "Show metadata")
123		)
124		},
125	!	tags$footer(
126	!	class = ".small",
127	!	get_footer_tags(args$footnotes)
128		)
129		)
130		)
131		}
132
133		# Server function for the front page module
134		srv_front_page <- function(id, data, tables, show_metadata) {
135	!	checkmate::assert_class(data, "reactive")
136	!	checkmate::assert_class(isolate(data()), "teal_data")
137	!	moduleServer(id, function(input, output, session) {
138	!	ns <- session$ns
139
140	!	lapply(seq_along(tables), function(idx) {
141	!	output[[paste0("table_", idx)]] <- renderTable(
142	!	tables[[idx]],
143	!	bordered = TRUE,
144	!	caption = names(tables)[idx],
145	!	caption.placement = "top"
146		)
147		})
148
149	!	if (show_metadata) {
150	!	observeEvent(
151	!	input$metadata_button, showModal(
152	!	modalDialog(
153	!	title = "Metadata",
154	!	dataTableOutput(ns("metadata_table")),
155	!	size = "l",
156	!	easyClose = TRUE
157		)
158		)
159		)
160
161	!	metadata_data_frame <- reactive({
162	!	datanames <- teal.data::datanames(data())
163	!	convert_metadata_to_dataframe(
164	!	lapply(datanames, function(dataname) attr(data()[[dataname]], "metadata")),
165	!	datanames
166		)
167		})
168
169	!	output$metadata_table <- renderDataTable({
170	!	validate(need(nrow(metadata_data_frame()) > 0, "The data has no associated metadata"))
171	!	metadata_data_frame()
172		})
173		}
174		})
175		}
176
177		## utils functions
178
179		get_header_tags <- function(header_text) {
180	!	if (length(header_text) == 0) {
181	!	return(list())
182		}
183
184	!	get_single_header_tags <- function(header_text, p_text, header_tag = tags$h4) {
185	!	tagList(
186	!	tags$div(
187	!	if (!is.null(header_text) && nchar(header_text) > 0) header_tag(header_text),
188	!	tags$p(p_text)
189		)
190		)
191		}
192
193	!	header_tags <- get_single_header_tags(names(header_text[1]), header_text[1], header_tag = tags$h3)
194	!	c(header_tags, mapply(get_single_header_tags, utils::tail(names(header_text), -1), utils::tail(header_text, -1)))
195		}
196
197		get_table_tags <- function(tables, ns) {
198	!	if (length(tables) == 0) {
199	!	return(list())
200		}
201	!	table_tags <- c(lapply(seq_along(tables), function(idx) {
202	!	list(
203	!	tableOutput(ns(paste0("table_", idx)))
204		)
205		}))
206	!	return(table_tags)
207		}
208
209		get_footer_tags <- function(footnotes) {
210	!	if (length(footnotes) == 0) {
211	!	return(list())
212		}
213	!	bold_texts <- if (is.null(names(footnotes))) rep("", length(footnotes)) else names(footnotes)
214	!	footnote_tags <- mapply(function(bold_text, value) {
215	!	list(
216	!	tags$div(
217	!	tags$b(bold_text),
218	!	value,
219	!	tags$br()
220		)
221		)
222	!	}, bold_text = bold_texts, value = footnotes)
223		}
224
225		# take a list of metadata, one item per dataset (raw_metadata each element from datasets$get_metadata())
226		# and the corresponding datanames and output a data.frame with columns {Dataset, Name, Value}.
227		# which are, the Dataset the metadata came from, the metadata's name and value
228		convert_metadata_to_dataframe <- function(raw_metadata, datanames) {
229	4x	output <- mapply(function(metadata, dataname) {
230	6x	if (is.null(metadata)) {
231	2x	return(data.frame(Dataset = character(0), Name = character(0), Value = character(0)))
232		}
233	4x	return(data.frame(
234	4x	Dataset = dataname,
235	4x	Name = names(metadata),
236	4x	Value = unname(unlist(lapply(metadata, as.character)))
237		))
238	4x	}, raw_metadata, datanames, SIMPLIFY = FALSE)
239	4x	do.call(rbind, output)
240		}

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		#' @templateVar ggnames "Bivariate1", "Bivariate2"
24		#' @template ggplot2_args_multi
25		#'
26		#' @inherit shared_params return
27		#'
28		#' @examples
29		#' library(teal.widgets)
30		#'
31		#' # general data example
32		#' data <- teal_data()
33		#' data <- within(data, {
34		#' require(nestcolor)
35		#' CO2 <- CO2
36		#' factors <- names(Filter(isTRUE, vapply(CO2, is.factor, logical(1L))))
37		#' CO2[factors] <- lapply(CO2[factors], as.character)
38		#' })
39		#' datanames(data) <- c("CO2")
40		#'
41		#' app <- init(
42		#' data = data,
43		#' modules = modules(
44		#' tm_g_association(
45		#' ref = data_extract_spec(
46		#' dataname = "CO2",
47		#' select = select_spec(
48		#' label = "Select variable:",
49		#' choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")),
50		#' selected = "Plant",
51		#' fixed = FALSE
52		#' )
53		#' ),
54		#' vars = data_extract_spec(
55		#' dataname = "CO2",
56		#' select = select_spec(
57		#' label = "Select variables:",
58		#' choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")),
59		#' selected = "Treatment",
60		#' multiple = TRUE,
61		#' fixed = FALSE
62		#' )
63		#' ),
64		#' ggplot2_args = ggplot2_args(
65		#' labs = list(subtitle = "Plot generated by Association Module")
66		#' )
67		#' )
68		#' )
69		#' )
70		#' if (interactive()) {
71		#' shinyApp(app$ui, app$server)
72		#' }
73		#'
74		#' # CDISC data example
75		#' data <- teal_data()
76		#' data <- within(data, {
77		#' require(nestcolor)
78		#' ADSL <- rADSL
79		#' })
80		#' datanames(data) <- "ADSL"
81		#' join_keys(data) <- default_cdisc_join_keys[datanames(data)]
82		#'
83		#' app <- init(
84		#' data = data,
85		#' modules = modules(
86		#' tm_g_association(
87		#' ref = data_extract_spec(
88		#' dataname = "ADSL",
89		#' select = select_spec(
90		#' label = "Select variable:",
91		#' choices = variable_choices(
92		#' data[["ADSL"]],
93		#' c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2")
94		#' ),
95		#' selected = "RACE",
96		#' fixed = FALSE
97		#' )
98		#' ),
99		#' vars = data_extract_spec(
100		#' dataname = "ADSL",
101		#' select = select_spec(
102		#' label = "Select variables:",
103		#' choices = variable_choices(
104		#' data[["ADSL"]],
105		#' c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2")
106		#' ),
107		#' selected = "BMRKR2",
108		#' multiple = TRUE,
109		#' fixed = FALSE
110		#' )
111		#' ),
112		#' ggplot2_args = ggplot2_args(
113		#' labs = list(subtitle = "Plot generated by Association Module")
114		#' )
115		#' )
116		#' )
117		#' )
118		#' if (interactive()) {
119		#' shinyApp(app$ui, app$server)
120		#' }
121		#'
122		#' @export
123		#'
124		tm_g_association <- function(label = "Association",
125		ref,
126		vars,
127		show_association = TRUE,
128		plot_height = c(600, 400, 5000),
129		plot_width = NULL,
130		distribution_theme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), # nolint: line_length.
131		association_theme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), # nolint: line_length.
132		pre_output = NULL,
133		post_output = NULL,
134		ggplot2_args = teal.widgets::ggplot2_args()) {
135	!	logger::log_info("Initializing tm_g_association")
136
137		# Normalize the parameters
138	!	if (inherits(ref, "data_extract_spec")) ref <- list(ref)
139	!	if (inherits(vars, "data_extract_spec")) vars <- list(vars)
140	!	if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)
141
142		# Start of assertions
143	!	checkmate::assert_string(label)
144
145	!	checkmate::assert_list(ref, types = "data_extract_spec")
146	!	if (!all(vapply(ref, function(x) !x$select$multiple, logical(1)))) {
147	!	stop("'ref' should not allow multiple selection")
148		}
149
150	!	checkmate::assert_list(vars, types = "data_extract_spec")
151	!	checkmate::assert_flag(show_association)
152
153	!	checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
154	!	checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")
155	!	checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
156	!	checkmate::assert_numeric(
157	!	plot_width[1],
158	!	lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"
159		)
160
161	!	distribution_theme <- match.arg(distribution_theme)
162	!	association_theme <- match.arg(association_theme)
163
164	!	checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
165	!	checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
166
167	!	plot_choices <- c("Bivariate1", "Bivariate2")
168	!	checkmate::assert_list(ggplot2_args, types = "ggplot2_args")
169	!	checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
170		# End of assertions
171
172		# Make UI args
173	!	args <- as.list(environment())
174
175	!	data_extract_list <- list(
176	!	ref = ref,
177	!	vars = vars
178		)
179
180	!	module(
181	!	label = label,
182	!	server = srv_tm_g_association,
183	!	ui = ui_tm_g_association,
184	!	ui_args = args,
185	!	server_args = c(
186	!	data_extract_list,
187	!	list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args)
188		),
189	!	datanames = teal.transform::get_extract_datanames(data_extract_list)
190		)
191		}
192
193		# UI function for the association module
194		ui_tm_g_association <- function(id, ...) {
195	!	ns <- NS(id)
196	!	args <- list(...)
197	!	is_single_dataset_value <- teal.transform::is_single_dataset(args$ref, args$vars)
198
199	!	teal.widgets::standard_layout(
200	!	output = teal.widgets::white_small_well(
201	!	textOutput(ns("title")),
202	!	tags$br(),
203	!	teal.widgets::plot_with_settings_ui(id = ns("myplot"))
204		),
205	!	encoding = div(
206		### Reporter
207	!	teal.reporter::simple_reporter_ui(ns("simple_reporter")),
208		###
209	!	tags$label("Encodings", class = "text-primary"),
210	!	teal.transform::datanames_input(args[c("ref", "vars")]),
211	!	teal.transform::data_extract_ui(
212	!	id = ns("ref"),
213	!	label = "Reference variable",
214	!	data_extract_spec = args$ref,
215	!	is_single_dataset = is_single_dataset_value
216		),
217	!	teal.transform::data_extract_ui(
218	!	id = ns("vars"),
219	!	label = "Associated variables",
220	!	data_extract_spec = args$vars,
221	!	is_single_dataset = is_single_dataset_value
222		),
223	!	checkboxInput(
224	!	ns("association"),
225	!	"Association with reference variable",
226	!	value = args$show_association
227		),
228	!	checkboxInput(
229	!	ns("show_dist"),
230	!	"Scaled frequencies",
231	!	value = FALSE
232		),
233	!	checkboxInput(
234	!	ns("log_transformation"),
235	!	"Log transformed",
236	!	value = FALSE
237		),
238	!	teal.widgets::panel_group(
239	!	teal.widgets::panel_item(
240	!	title = "Plot settings",
241	!	teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Scatterplot opacity:", c(0.5, 0, 1), ticks = FALSE),
242	!	teal.widgets::optionalSliderInputValMinMax(ns("size"), "Scatterplot points size:", c(2, 1, 8), ticks = FALSE),
243	!	checkboxInput(ns("swap_axes"), "Swap axes", value = FALSE),
244	!	checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = FALSE),
245	!	selectInput(
246	!	inputId = ns("distribution_theme"),
247	!	label = "Distribution theme (by ggplot):",
248	!	choices = ggplot_themes,
249	!	selected = args$distribution_theme,
250	!	multiple = FALSE
251		),
252	!	selectInput(
253	!	inputId = ns("association_theme"),
254	!	label = "Association theme (by ggplot):",
255	!	choices = ggplot_themes,
256	!	selected = args$association_theme,
257	!	multiple = FALSE
258		)
259		)
260		)
261		),
262	!	forms = tagList(
263	!	teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
264	!	teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
265		),
266	!	pre_output = args$pre_output,
267	!	post_output = args$post_output
268		)
269		}
270
271		# Server function for the association module
272		srv_tm_g_association <- function(id,
273		data,
274		reporter,
275		filter_panel_api,
276		ref,
277		vars,
278		plot_height,
279		plot_width,
280		ggplot2_args) {
281	!	with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
282	!	with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
283	!	checkmate::assert_class(data, "reactive")
284	!	checkmate::assert_class(isolate(data()), "teal_data")
285
286	!	moduleServer(id, function(input, output, session) {
287	!	selector_list <- teal.transform::data_extract_multiple_srv(
288	!	data_extract = list(ref = ref, vars = vars),
289	!	datasets = data,
290	!	select_validation_rule = list(
291	!	ref = shinyvalidate::compose_rules(
292	!	shinyvalidate::sv_required("A reference variable needs to be selected."),
293	!	~ if ((.) %in% selector_list()$vars()$select) {
294	!	"Associated variables and reference variable cannot overlap"
295		}
296		),
297	!	vars = shinyvalidate::compose_rules(
298	!	shinyvalidate::sv_required("An associated variable needs to be selected."),
299	!	~ if (length(selector_list()$ref()$select) != 0 && selector_list()$ref()$select %in% (.)) {
300	!	"Associated variables and reference variable cannot overlap"
301		}
302		)
303		)
304		)
305
306	!	iv_r <- reactive({
307	!	iv <- shinyvalidate::InputValidator$new()
308	!	teal.transform::compose_and_enable_validators(iv, selector_list)
309		})
310
311	!	anl_merged_input <- teal.transform::merge_expression_srv(
312	!	datasets = data,
313	!	selector_list = selector_list
314		)
315
316	!	anl_merged_q <- reactive({
317	!	req(anl_merged_input())
318	!	data() %>% teal.code::eval_code(as.expression(anl_merged_input()$expr))
319		})
320
321	!	merged <- list(
322	!	anl_input_r = anl_merged_input,
323	!	anl_q_r = anl_merged_q
324		)
325
326	!	output_q <- reactive({
327	!	teal::validate_inputs(iv_r())
328
329	!	ANL <- merged$anl_q_r()[["ANL"]]
330	!	teal::validate_has_data(ANL, 3)
331
332	!	vars_names <- merged$anl_input_r()$columns_source$vars
333
334	!	ref_name <- as.vector(merged$anl_input_r()$columns_source$ref)
335	!	association <- input$association
336	!	show_dist <- input$show_dist
337	!	log_transformation <- input$log_transformation
338	!	rotate_xaxis_labels <- input$rotate_xaxis_labels
339	!	swap_axes <- input$swap_axes
340	!	distribution_theme <- input$distribution_theme
341	!	association_theme <- input$association_theme
342
343	!	is_scatterplot <- is.numeric(ANL[[ref_name]]) && any(vapply(ANL[vars_names], is.numeric, logical(1)))
344	!	if (is_scatterplot) {
345	!	shinyjs::show("alpha")
346	!	shinyjs::show("size")
347	!	alpha <- input$alpha
348	!	size <- input$size
349		} else {
350	!	shinyjs::hide("alpha")
351	!	shinyjs::hide("size")
352	!	alpha <- 0.5
353	!	size <- 2
354		}
355
356	!	teal::validate_has_data(ANL[, c(ref_name, vars_names)], 3, complete = TRUE, allow_inf = FALSE)
357
358		# reference
359	!	ref_class <- class(ANL[[ref_name]])[1]
360	!	if (is.numeric(ANL[[ref_name]]) && log_transformation) {
361		# works for both integers and doubles
362	!	ref_cl_name <- call("log", as.name(ref_name))
363	!	ref_cl_lbl <- varname_w_label(ref_name, ANL, prefix = "Log of ")
364		} else {
365		# silently ignore when non-numeric even if `log` is selected because some
366		# variables may be numeric and others not
367	!	ref_cl_name <- as.name(ref_name)
368	!	ref_cl_lbl <- varname_w_label(ref_name, ANL)
369		}
370
371	!	user_ggplot2_args <- teal.widgets::resolve_ggplot2_args(
372	!	user_plot = ggplot2_args[["Bivariate1"]],
373	!	user_default = ggplot2_args$default
374		)
375
376	!	ref_call <- bivariate_plot_call(
377	!	data_name = "ANL",
378	!	x = ref_cl_name,
379	!	x_class = ref_class,
380	!	x_label = ref_cl_lbl,
381	!	freq = !show_dist,
382	!	theme = distribution_theme,
383	!	rotate_xaxis_labels = rotate_xaxis_labels,
384	!	swap_axes = FALSE,
385	!	size = size,
386	!	alpha = alpha,
387	!	ggplot2_args = user_ggplot2_args
388		)
389
390		# association
391	!	ref_class_cov <- ifelse(association, ref_class, "NULL")
392
393	!	print_call <- quote(print(p))
394
395	!	var_calls <- lapply(vars_names, function(var_i) {
396	!	var_class <- class(ANL[[var_i]])[1]
397	!	if (is.numeric(ANL[[var_i]]) && log_transformation) {
398		# works for both integers and doubles
399	!	var_cl_name <- call("log", as.name(var_i))
400	!	var_cl_lbl <- varname_w_label(var_i, ANL, prefix = "Log of ")
401		} else {
402		# silently ignore when non-numeric even if `log` is selected because some
403		# variables may be numeric and others not
404	!	var_cl_name <- as.name(var_i)
405	!	var_cl_lbl <- varname_w_label(var_i, ANL)
406		}
407
408	!	user_ggplot2_args <- teal.widgets::resolve_ggplot2_args(
409	!	user_plot = ggplot2_args[["Bivariate2"]],
410	!	user_default = ggplot2_args$default
411		)
412
413	!	bivariate_plot_call(
414	!	data_name = "ANL",
415	!	x = ref_cl_name,
416	!	y = var_cl_name,
417	!	x_class = ref_class_cov,
418	!	y_class = var_class,
419	!	x_label = ref_cl_lbl,
420	!	y_label = var_cl_lbl,
421	!	theme = association_theme,
422	!	freq = !show_dist,
423	!	rotate_xaxis_labels = rotate_xaxis_labels,
424	!	swap_axes = swap_axes,
425	!	alpha = alpha,
426	!	size = size,
427	!	ggplot2_args = user_ggplot2_args
428		)
429		})
430
431		# helper function to format variable name
432	!	format_varnames <- function(x) {
433	!	if (is.numeric(ANL[[x]]) && log_transformation) {
434	!	varname_w_label(x, ANL, prefix = "Log of ")
435		} else {
436	!	varname_w_label(x, ANL)
437		}
438		}
439	!	new_title <-
440	!	if (association) {
441	!	switch(as.character(length(vars_names)),
442	!	"0" = sprintf("Value distribution for %s", ref_cl_lbl),
443	!	"1" = sprintf(
444	!	"Association between %s and %s",
445	!	ref_cl_lbl,
446	!	format_varnames(vars_names)
447		),
448	!	sprintf(
449	!	"Associations between %s and: %s",
450	!	ref_cl_lbl,
451	!	paste(lapply(vars_names, format_varnames), collapse = ", ")
452		)
453		)
454		} else {
455	!	switch(as.character(length(vars_names)),
456	!	"0" = sprintf("Value distribution for %s", ref_cl_lbl),
457	!	sprintf(
458	!	"Value distributions for %s and %s",
459	!	ref_cl_lbl,
460	!	paste(lapply(vars_names, format_varnames), collapse = ", ")
461		)
462		)
463		}
464
465	!	teal.code::eval_code(
466	!	merged$anl_q_r(),
467	!	substitute(
468	!	expr = title <- new_title,
469	!	env = list(new_title = new_title)
470		)
471		) %>%
472	!	teal.code::eval_code(
473	!	substitute(
474	!	expr = {
475	!	plots <- plot_calls
476	!	p <- tern::stack_grobs(grobs = lapply(plots, ggplotGrob))
477	!	grid::grid.newpage()
478	!	grid::grid.draw(p)
479		},
480	!	env = list(
481	!	plot_calls = do.call(
482	!	"call",
483	!	c(list("list", ref_call), var_calls),
484	!	quote = TRUE
485		)
486		)
487		)
488		)
489		})
490
491	!	plot_r <- shiny::reactive({
492	!	shiny::req(iv_r()$is_valid())
493	!	output_q()[["p"]]
494		})
495
496	!	pws <- teal.widgets::plot_with_settings_srv(
497	!	id = "myplot",
498	!	plot_r = plot_r,
499	!	height = plot_height,
500	!	width = plot_width
501		)
502
503	!	output$title <- renderText({
504	!	teal.code::dev_suppress(output_q()[["title"]])
505		})
506
507	!	teal.widgets::verbatim_popup_srv(
508	!	id = "warning",
509	!	verbatim_content = reactive(teal.code::get_warnings(output_q())),
510	!	title = "Warning",
511	!	disabled = reactive(is.null(teal.code::get_warnings(output_q())))
512		)
513
514	!	teal.widgets::verbatim_popup_srv(
515	!	id = "rcode",
516	!	verbatim_content = reactive(teal.code::get_code(output_q())),
517	!	title = "Association Plot"
518		)
519
520		### REPORTER
521	!	if (with_reporter) {
522	!	card_fun <- function(comment, label) {
523	!	card <- teal::report_card_template(
524	!	title = "Association Plot",
525	!	label = label,
526	!	with_filter = with_filter,
527	!	filter_panel_api = filter_panel_api
528		)
529	!	card$append_text("Plot", "header3")
530	!	card$append_plot(plot_r(), dim = pws$dim())
531	!	if (!comment == "") {
532	!	card$append_text("Comment", "header3")
533	!	card$append_text(comment)
534		}
535	!	card$append_src(teal.code::get_code(output_q()))
536	!	card
537		}
538	!	teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
539		}
540		###
541		})
542		}

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		#' @examples
17		#' data <- teal_data()
18		#' data <- within(data, {
19		#' data <- data.frame(1)
20		#' })
21		#' datanames(data) <- c("data")
22		#'
23		#' app <- init(
24		#' data = data,
25		#' modules = modules(
26		#' tm_file_viewer(
27		#' input_path = list(
28		#' folder = system.file("sample_files", package = "teal.modules.general"),
29		#' png = system.file("sample_files/sample_file.png", package = "teal.modules.general"),
30		#' txt = system.file("sample_files/sample_file.txt", package = "teal.modules.general"),
31		#' url = "https://fda.gov/files/drugs/published/Portable-Document-Format-Specifications.pdf"
32		#' )
33		#' )
34		#' )
35		#' )
36		#' if (interactive()) {
37		#' shinyApp(app$ui, app$server)
38		#' }
39		#'
40		#' @export
41		#'
42		tm_file_viewer <- function(label = "File Viewer Module",
43		input_path = list("Current Working Directory" = ".")) {
44	!	logger::log_info("Initializing tm_file_viewer")
45
46		# Normalize the parameters
47	!	if (length(label) == 0 \|\| identical(label, "")) label <- " "
48	!	if (length(input_path) == 0 \|\| identical(input_path, "")) input_path <- list()
49
50		# Start of assertions
51	!	checkmate::assert_string(label)
52
53	!	checkmate::assert(
54	!	checkmate::check_list(input_path, types = "character", min.len = 0),
55	!	checkmate::check_character(input_path, min.len = 1)
56		)
57	!	if (length(input_path) > 0) {
58	!	valid_url <- function(url_input, timeout = 2) {
59	!	con <- try(url(url_input), silent = TRUE)
60	!	check <- suppressWarnings(try(open.connection(con, open = "rt", timeout = timeout), silent = TRUE)[1])
61	!	try(close.connection(con), silent = TRUE)
62	!	is.null(check)
63		}
64	!	idx <- vapply(input_path, function(x) file.exists(x) \|\| valid_url(x), logical(1))
65
66	!	if (!all(idx)) {
67	!	warning(
68	!	paste0(
69	!	"Non-existent file or url path. Please provide valid paths for:\n",
70	!	paste0(input_path[!idx], collapse = "\n")
71		)
72		)
73		}
74	!	input_path <- input_path[idx]
75		} else {
76	!	warning(
77	!	"No file or url paths were provided."
78		)
79		}
80		# End of assertions
81
82		# Make UI args
83	!	args <- as.list(environment())
84
85	!	module(
86	!	label = label,
87	!	server = srv_viewer,
88	!	server_args = list(input_path = input_path),
89	!	ui = ui_viewer,
90	!	ui_args = args,
91	!	datanames = NULL
92		)
93		}
94
95		# UI function for the file viewer module
96		ui_viewer <- function(id, ...) {
97	!	args <- list(...)
98	!	ns <- NS(id)
99
100	!	shiny::tagList(
101	!	include_css_files("custom"),
102	!	teal.widgets::standard_layout(
103	!	output = div(
104	!	uiOutput(ns("output"))
105		),
106	!	encoding = div(
107	!	class = "file_viewer_encoding",
108	!	tags$label("Encodings", class = "text-primary"),
109	!	shinyTree::shinyTree(
110	!	ns("tree"),
111	!	dragAndDrop = FALSE,
112	!	sort = FALSE,
113	!	wholerow = TRUE,
114	!	theme = "proton",
115	!	multiple = FALSE
116		)
117		)
118		)
119		)
120		}
121
122		# Server function for the file viewer module
123		srv_viewer <- function(id, input_path) {
124	!	moduleServer(id, function(input, output, session) {
125	!	temp_dir <- tempfile()
126	!	if (!dir.exists(temp_dir)) {
127	!	dir.create(temp_dir, recursive = TRUE)
128		}
129	!	addResourcePath(basename(temp_dir), temp_dir)
130
131	!	test_path_text <- function(selected_path, type) {
132	!	out <- tryCatch(
133	!	expr = {
134	!	if (type != "url") {
135	!	selected_path <- normalizePath(selected_path, winslash = "/")
136		}
137	!	readLines(con = selected_path)
138		},
139	!	error = function(cond) FALSE,
140	!	warning = function(cond) {
141	!	`if`(grepl("^incomplete final line found on", cond[[1]]), suppressWarnings(eval(cond[[2]])), FALSE)
142		}
143		)
144		}
145
146	!	handle_connection_type <- function(selected_path) {
147	!	file_extension <- tools::file_ext(selected_path)
148	!	file_class <- suppressWarnings(file(selected_path))
149	!	close(file_class)
150
151	!	output_text <- test_path_text(selected_path, type = class(file_class)[1])
152
153	!	if (class(file_class)[1] == "url") {
154	!	list(selected_path = selected_path, output_text = output_text)
155		} else {
156	!	file.copy(normalizePath(selected_path, winslash = "/"), temp_dir)
157	!	selected_path <- file.path(basename(temp_dir), basename(selected_path))
158	!	list(selected_path = selected_path, output_text = output_text)
159		}
160		}
161
162	!	display_file <- function(selected_path) {
163	!	con_type <- handle_connection_type(selected_path)
164	!	file_extension <- tools::file_ext(selected_path)
165	!	if (file_extension %in% c("png", "apng", "jpg", "jpeg", "svg", "gif", "webp", "bmp")) {
166	!	tags$img(src = con_type$selected_path, alt = "file does not exist")
167	!	} else if (file_extension == "pdf") {
168	!	tags$embed(
169	!	class = "embed_pdf",
170	!	src = con_type$selected_path
171		)
172	!	} else if (!isFALSE(con_type$output_text[1])) {
173	!	tags$pre(paste0(con_type$output_text, collapse = "\n"))
174		} else {
175	!	tags$p("Please select a supported format.")
176		}
177		}
178
179	!	tree_list <- function(file_or_dir) {
180	!	nested_list <- lapply(file_or_dir, function(path) {
181	!	file_class <- suppressWarnings(file(path))
182	!	close(file_class)
183	!	if (class(file_class)[[1]] != "url") {
184	!	isdir <- file.info(path)$isdir
185	!	if (!isdir) {
186	!	structure(path, ancestry = path, sticon = "file")
187		} else {
188	!	files <- list.files(path, full.names = TRUE, include.dirs = TRUE)
189	!	out <- lapply(files, function(x) tree_list(x))
190	!	out <- unlist(out, recursive = FALSE)
191	!	if (length(files) > 0) names(out) <- basename(files)
192	!	out
193		}
194		} else {
195	!	structure(path, ancestry = path, sticon = "file")
196		}
197		})
198
199	!	missing_labels <- if (is.null(names(nested_list))) seq_along(nested_list) else which(names(nested_list) == "")
200	!	names(nested_list)[missing_labels] <- file_or_dir[missing_labels]
201	!	nested_list
202		}
203
204	!	output$tree <- shinyTree::renderTree({
205	!	if (length(input_path) > 0) {
206	!	tree_list(input_path)
207		} else {
208	!	list("Empty Path" = NULL)
209		}
210		})
211
212	!	output$output <- renderUI({
213	!	validate(
214	!	need(
215	!	length(shinyTree::get_selected(input$tree)) > 0,
216	!	"Please select a file."
217		)
218		)
219
220	!	obj <- shinyTree::get_selected(input$tree, format = "names")[[1]]
221	!	repo <- attr(obj, "ancestry")
222	!	repo_collapsed <- if (length(repo) > 1) paste0(repo, collapse = "/") else repo
223	!	is_not_named <- file.exists(file.path(c(repo_collapsed, obj[1])))[1]
224
225	!	if (is_not_named) {
226	!	selected_path <- do.call("file.path", as.list(c(repo, obj[1])))
227		} else {
228	!	if (length(repo) == 0) {
229	!	selected_path <- do.call("file.path", as.list(attr(input$tree[[obj[1]]], "ancestry")))
230		} else {
231	!	selected_path <- do.call("file.path", as.list(attr(input$tree[[repo]][[obj[1]]], "ancestry")))
232		}
233		}
234
235	!	validate(
236	!	need(
237	!	!isTRUE(file.info(selected_path)$isdir) && length(selected_path) > 0,
238	!	"Please select a single file."
239		)
240		)
241	!	display_file(selected_path)
242		})
243
244	!	onStop(function() {
245	!	removeResourcePath(basename(temp_dir))
246	!	unlink(temp_dir)
247		})
248		})
249		}

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		#'
23		#' @note For more examples, please see the vignette "Using cross table" via
24		#' `vignette("using-cross-table", package = "teal.modules.general")`.
25		#'
26		#' @inherit shared_params return
27		#'
28		#' @examples
29		#' # general data example
30		#' library(teal.widgets)
31		#'
32		#' data <- teal_data()
33		#' data <- within(data, {
34		#' mtcars <- mtcars
35		#' for (v in c("cyl", "vs", "am", "gear")) {
36		#' mtcars[[v]] <- as.factor(mtcars[[v]])
37		#' }
38		#' mtcars[["primary_key"]] <- seq_len(nrow(mtcars))
39		#' })
40		#' datanames(data) <- "mtcars"
41		#' join_keys(data) <- join_keys(join_key("mtcars", "mtcars", "primary_key"))
42		#'
43		#' app <- init(
44		#' data = data,
45		#' modules = modules(
46		#' tm_t_crosstable(
47		#' label = "Cross Table",
48		#' x = data_extract_spec(
49		#' dataname = "mtcars",
50		#' select = select_spec(
51		#' label = "Select variable:",
52		#' choices = variable_choices(data[["mtcars"]], c("cyl", "vs", "am", "gear")),
53		#' selected = c("cyl", "gear"),
54		#' multiple = TRUE,
55		#' ordered = TRUE,
56		#' fixed = FALSE
57		#' )
58		#' ),
59		#' y = data_extract_spec(
60		#' dataname = "mtcars",
61		#' select = select_spec(
62		#' label = "Select variable:",
63		#' choices = variable_choices(data[["mtcars"]], c("cyl", "vs", "am", "gear")),
64		#' selected = "vs",
65		#' multiple = FALSE,
66		#' fixed = FALSE
67		#' )
68		#' ),
69		#' basic_table_args = basic_table_args(
70		#' subtitles = "Table generated by Crosstable Module"
71		#' )
72		#' )
73		#' )
74		#' )
75		#' if (interactive()) {
76		#' shinyApp(app$ui, app$server)
77		#' }
78		#'
79		#' # CDISC data example
80		#' library(teal.widgets)
81		#'
82		#' data <- teal_data()
83		#' data <- within(data, {
84		#' ADSL <- rADSL
85		#' })
86		#' datanames(data) <- "ADSL"
87		#' join_keys(data) <- default_cdisc_join_keys[datanames(data)]
88		#'
89		#' app <- init(
90		#' data = data,
91		#' modules = modules(
92		#' tm_t_crosstable(
93		#' label = "Cross Table",
94		#' x = data_extract_spec(
95		#' dataname = "ADSL",
96		#' select = select_spec(
97		#' label = "Select variable:",
98		#' choices = variable_choices(data[["ADSL"]], subset = function(data) {
99		#' idx <- !vapply(data, inherits, logical(1), c("Date", "POSIXct", "POSIXlt"))
100		#' return(names(data)[idx])
101		#' }),
102		#' selected = "COUNTRY",
103		#' multiple = TRUE,
104		#' ordered = TRUE,
105		#' fixed = FALSE
106		#' )
107		#' ),
108		#' y = data_extract_spec(
109		#' dataname = "ADSL",
110		#' select = select_spec(
111		#' label = "Select variable:",
112		#' choices = variable_choices(data[["ADSL"]], subset = function(data) {
113		#' idx <- vapply(data, is.factor, logical(1))
114		#' return(names(data)[idx])
115		#' }),
116		#' selected = "SEX",
117		#' multiple = FALSE,
118		#' fixed = FALSE
119		#' )
120		#' ),
121		#' basic_table_args = basic_table_args(
122		#' subtitles = "Table generated by Crosstable Module"
123		#' )
124		#' )
125		#' )
126		#' )
127		#' if (interactive()) {
128		#' shinyApp(app$ui, app$server)
129		#' }
130		#'
131		#' @export
132		#'
133		tm_t_crosstable <- function(label = "Cross Table",
134		x,
135		y,
136		show_percentage = TRUE,
137		show_total = TRUE,
138		pre_output = NULL,
139		post_output = NULL,
140		basic_table_args = teal.widgets::basic_table_args()) {
141	!	logger::log_info("Initializing tm_t_crosstable")
142
143		# Requires Suggested packages
144	!	if (!requireNamespace("rtables", quietly = TRUE)) {
145	!	stop("Cannot load rtables - please install the package or restart your session.")
146		}
147
148		# Normalize the parameters
149	!	if (inherits(x, "data_extract_spec")) x <- list(x)
150	!	if (inherits(y, "data_extract_spec")) y <- list(y)
151
152		# Start of assertions
153	!	checkmate::assert_string(label)
154	!	checkmate::assert_list(x, types = "data_extract_spec")
155
156	!	checkmate::assert_list(y, types = "data_extract_spec")
157	!	assert_single_selection(y)
158
159	!	checkmate::assert_flag(show_percentage)
160	!	checkmate::assert_flag(show_total)
161	!	checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
162	!	checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
163	!	checkmate::assert_class(basic_table_args, classes = "basic_table_args")
164		# End of assertions
165
166		# Make UI args
167	!	ui_args <- as.list(environment())
168
169	!	server_args <- list(
170	!	label = label,
171	!	x = x,
172	!	y = y,
173	!	basic_table_args = basic_table_args
174		)
175
176	!	module(
177	!	label = label,
178	!	server = srv_t_crosstable,
179	!	ui = ui_t_crosstable,
180	!	ui_args = ui_args,
181	!	server_args = server_args,
182	!	datanames = teal.transform::get_extract_datanames(list(x = x, y = y))
183		)
184		}
185
186		# UI function for the cross-table module
187		ui_t_crosstable <- function(id, x, y, show_percentage, show_total, pre_output, post_output, ...) {
188	!	ns <- NS(id)
189	!	is_single_dataset <- teal.transform::is_single_dataset(x, y)
190
191	!	join_default_options <- c(
192	!	"Full Join" = "dplyr::full_join",
193	!	"Inner Join" = "dplyr::inner_join",
194	!	"Left Join" = "dplyr::left_join",
195	!	"Right Join" = "dplyr::right_join"
196		)
197
198	!	teal.widgets::standard_layout(
199	!	output = teal.widgets::white_small_well(
200	!	textOutput(ns("title")),
201	!	teal.widgets::table_with_settings_ui(ns("table"))
202		),
203	!	encoding = div(
204		### Reporter
205	!	teal.reporter::simple_reporter_ui(ns("simple_reporter")),
206		###
207	!	tags$label("Encodings", class = "text-primary"),
208	!	teal.transform::datanames_input(list(x, y)),
209	!	teal.transform::data_extract_ui(ns("x"), label = "Row values", x, is_single_dataset = is_single_dataset),
210	!	teal.transform::data_extract_ui(ns("y"), label = "Column values", y, is_single_dataset = is_single_dataset),
211	!	teal.widgets::optionalSelectInput(
212	!	ns("join_fun"),
213	!	label = "Row to Column type of join",
214	!	choices = join_default_options,
215	!	selected = join_default_options[1],
216	!	multiple = FALSE
217		),
218	!	tags$hr(),
219	!	teal.widgets::panel_group(
220	!	teal.widgets::panel_item(
221	!	title = "Table settings",
222	!	checkboxInput(ns("show_percentage"), "Show column percentage", value = show_percentage),
223	!	checkboxInput(ns("show_total"), "Show total column", value = show_total)
224		)
225		)
226		),
227	!	forms = tagList(
228	!	teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
229	!	teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
230		),
231	!	pre_output = pre_output,
232	!	post_output = post_output
233		)
234		}
235
236		# Server function for the cross-table module
237		srv_t_crosstable <- function(id, data, reporter, filter_panel_api, label, x, y, basic_table_args) {
238	!	with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
239	!	with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
240	!	checkmate::assert_class(data, "reactive")
241	!	checkmate::assert_class(isolate(data()), "teal_data")
242	!	moduleServer(id, function(input, output, session) {
243	!	selector_list <- teal.transform::data_extract_multiple_srv(
244	!	data_extract = list(x = x, y = y),
245	!	datasets = data,
246	!	select_validation_rule = list(
247	!	x = shinyvalidate::sv_required("Please define column for row variable."),
248	!	y = shinyvalidate::sv_required("Please define column for column variable.")
249		)
250		)
251
252	!	iv_r <- reactive({
253	!	iv <- shinyvalidate::InputValidator$new()
254	!	iv$add_rule("join_fun", function(value) {
255	!	if (!identical(selector_list()$x()$dataname, selector_list()$y()$dataname)) {
256	!	if (!shinyvalidate::input_provided(value)) {
257	!	"Please select a joining function."
258		}
259		}
260		})
261	!	teal.transform::compose_and_enable_validators(iv, selector_list)
262		})
263
264	!	observeEvent(
265	!	eventExpr = {
266	!	req(!is.null(selector_list()$x()) && !is.null(selector_list()$y()))
267	!	list(selector_list()$x(), selector_list()$y())
268		},
269	!	handlerExpr = {
270	!	if (identical(selector_list()$x()$dataname, selector_list()$y()$dataname)) {
271	!	shinyjs::hide("join_fun")
272		} else {
273	!	shinyjs::show("join_fun")
274		}
275		}
276		)
277
278	!	merge_function <- reactive({
279	!	if (is.null(input$join_fun)) {
280	!	"dplyr::full_join"
281		} else {
282	!	input$join_fun
283		}
284		})
285
286	!	anl_merged_input <- teal.transform::merge_expression_srv(
287	!	datasets = data,
288	!	selector_list = selector_list,
289	!	merge_function = merge_function
290		)
291
292	!	anl_merged_q <- reactive({
293	!	req(anl_merged_input())
294	!	data() %>%
295	!	teal.code::eval_code(as.expression(anl_merged_input()$expr))
296		})
297
298	!	merged <- list(
299	!	anl_input_r = anl_merged_input,
300	!	anl_q_r = anl_merged_q
301		)
302
303	!	output_q <- reactive({
304	!	teal::validate_inputs(iv_r())
305	!	ANL <- merged$anl_q_r()[["ANL"]]
306
307		# As this is a summary
308	!	x_name <- as.vector(merged$anl_input_r()$columns_source$x)
309	!	y_name <- as.vector(merged$anl_input_r()$columns_source$y)
310
311	!	teal::validate_has_data(ANL, 3)
312	!	teal::validate_has_data(ANL[, c(x_name, y_name)], 3, complete = TRUE, allow_inf = FALSE)
313
314	!	is_allowed_class <- function(x) is.numeric(x) \|\| is.factor(x) \|\| is.character(x) \|\| is.logical(x)
315	!	validate(need(
316	!	all(vapply(ANL[x_name], is_allowed_class, logical(1))),
317	!	"Selected row variable has an unsupported data type."
318		))
319	!	validate(need(
320	!	is_allowed_class(ANL[[y_name]]),
321	!	"Selected column variable has an unsupported data type."
322		))
323
324	!	show_percentage <- input$show_percentage
325	!	show_total <- input$show_total
326
327	!	plot_title <- paste(
328	!	"Cross-Table of",
329	!	paste0(varname_w_label(x_name, ANL), collapse = ", "),
330	!	"(rows)", "vs.",
331	!	varname_w_label(y_name, ANL),
332	!	"(columns)"
333		)
334
335	!	labels_vec <- vapply(
336	!	x_name,
337	!	varname_w_label,
338	!	character(1),
339	!	ANL
340		)
341
342	!	teal.code::eval_code(
343	!	merged$anl_q_r(),
344	!	substitute(
345	!	expr = {
346	!	title <- plot_title
347		},
348	!	env = list(plot_title = plot_title)
349		)
350		) %>%
351	!	teal.code::eval_code(
352	!	substitute(
353	!	expr = {
354	!	lyt <- basic_tables %>%
355	!	split_call %>% # styler: off
356	!	rtables::add_colcounts() %>%
357	!	tern::analyze_vars(
358	!	vars = x_name,
359	!	var_labels = labels_vec,
360	!	na.rm = FALSE,
361	!	denom = "N_col",
362	!	.stats = c("mean_sd", "median", "range", count_value)
363		)
364		},
365	!	env = list(
366	!	basic_tables = teal.widgets::parse_basic_table_args(
367	!	basic_table_args = teal.widgets::resolve_basic_table_args(basic_table_args)
368		),
369	!	split_call = if (show_total) {
370	!	substitute(
371	!	expr = rtables::split_cols_by(
372	!	y_name,
373	!	split_fun = rtables::add_overall_level(label = "Total", first = FALSE)
374		),
375	!	env = list(y_name = y_name)
376		)
377		} else {
378	!	substitute(rtables::split_cols_by(y_name), env = list(y_name = y_name))
379		},
380	!	x_name = x_name,
381	!	labels_vec = labels_vec,
382	!	count_value = ifelse(show_percentage, "count_fraction", "count")
383		)
384		)
385		) %>%
386	!	teal.code::eval_code(
387	!	substitute(
388	!	expr = {
389	!	ANL <- tern::df_explicit_na(ANL)
390	!	tbl <- rtables::build_table(lyt = lyt, df = ANL[order(ANL[[y_name]]), ])
391	!	tbl
392		},
393	!	env = list(y_name = y_name)
394		)
395		)
396		})
397
398	!	output$title <- renderText(output_q()[["title"]])
399
400	!	table_r <- reactive({
401	!	shiny::req(iv_r()$is_valid())
402	!	output_q()[["tbl"]]
403		})
404
405	!	teal.widgets::table_with_settings_srv(
406	!	id = "table",
407	!	table_r = table_r
408		)
409
410	!	teal.widgets::verbatim_popup_srv(
411	!	id = "warning",
412	!	verbatim_content = reactive(teal.code::get_warnings(output_q())),
413	!	title = "Warning",
414	!	disabled = reactive(is.null(teal.code::get_warnings(output_q())))
415		)
416
417	!	teal.widgets::verbatim_popup_srv(
418	!	id = "rcode",
419	!	verbatim_content = reactive(teal.code::get_code(output_q())),
420	!	title = "Show R Code for Cross-Table"
421		)
422
423		### REPORTER
424	!	if (with_reporter) {
425	!	card_fun <- function(comment, label) {
426	!	card <- teal::report_card_template(
427	!	title = "Cross Table",
428	!	label = label,
429	!	with_filter = with_filter,
430	!	filter_panel_api = filter_panel_api
431		)
432	!	card$append_text("Table", "header3")
433	!	card$append_table(table_r())
434	!	if (!comment == "") {
435	!	card$append_text("Comment", "header3")
436	!	card$append_text(comment)
437		}
438	!	card$append_src(teal.code::get_code(output_q()))
439	!	card
440		}
441	!	teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
442		}
443		###
444		})
445		}

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		#' @examples
22		#' # general data example
23		#' data <- teal_data()
24		#' data <- within(data, {
25		#' countries <- data.frame(
26		#' id = c("DE", "FR", "IT", "ES", "PT", "GR", "NL", "BE", "LU", "AT"),
27		#' government = factor(
28		#' c(2, 2, 2, 1, 2, 2, 1, 1, 1, 2),
29		#' labels = c("Monarchy", "Republic")
30		#' ),
31		#' language_family = factor(
32		#' c(1, 3, 3, 3, 3, 2, 1, 1, 3, 1),
33		#' labels = c("Germanic", "Hellenic", "Romance")
34		#' ),
35		#' population = c(83, 67, 60, 47, 10, 11, 17, 11, 0.6, 9),
36		#' area = c(357, 551, 301, 505, 92, 132, 41, 30, 2.6, 83),
37		#' gdp = c(3.4, 2.7, 2.1, 1.4, 0.3, 0.2, 0.7, 0.5, 0.1, 0.4),
38		#' debt = c(2.1, 2.3, 2.4, 2.6, 2.3, 2.4, 2.3, 2.4, 2.3, 2.4)
39		#' )
40		#' sales <- data.frame(
41		#' id = 1:50,
42		#' country_id = sample(
43		#' c("DE", "FR", "IT", "ES", "PT", "GR", "NL", "BE", "LU", "AT"),
44		#' size = 50,
45		#' replace = TRUE
46		#' ),
47		#' year = sort(sample(2010:2020, 50, replace = TRUE)),
48		#' venue = sample(c("small", "medium", "large", "online"), 50, replace = TRUE),
49		#' cancelled = sample(c(TRUE, FALSE), 50, replace = TRUE),
50		#' quantity = rnorm(50, 100, 20),
51		#' costs = rnorm(50, 80, 20),
52		#' profit = rnorm(50, 20, 10)
53		#' )
54		#' })
55		#' datanames(data) <- c("countries", "sales")
56		#' join_keys(data) <- join_keys(
57		#' join_key("countries", "countries", "id"),
58		#' join_key("sales", "sales", "id"),
59		#' join_key("countries", "sales", c("id" = "country_id"))
60		#' )
61		#'
62		#' app <- init(
63		#' data = data,
64		#' modules = modules(
65		#' tm_g_scatterplotmatrix(
66		#' label = "Scatterplot matrix",
67		#' variables = list(
68		#' data_extract_spec(
69		#' dataname = "countries",
70		#' select = select_spec(
71		#' label = "Select variables:",
72		#' choices = variable_choices(data[["countries"]]),
73		#' selected = c("area", "gdp", "debt"),
74		#' multiple = TRUE,
75		#' ordered = TRUE,
76		#' fixed = FALSE
77		#' )
78		#' ),
79		#' data_extract_spec(
80		#' dataname = "sales",
81		#' filter = filter_spec(
82		#' label = "Select variable:",
83		#' vars = "country_id",
84		#' choices = value_choices(data[["sales"]], "country_id"),
85		#' selected = c("DE", "FR", "IT", "ES", "PT", "GR", "NL", "BE", "LU", "AT"),
86		#' multiple = TRUE
87		#' ),
88		#' select = select_spec(
89		#' label = "Select variables:",
90		#' choices = variable_choices(data[["sales"]], c("quantity", "costs", "profit")),
91		#' selected = c("quantity", "costs", "profit"),
92		#' multiple = TRUE,
93		#' ordered = TRUE,
94		#' fixed = FALSE
95		#' )
96		#' )
97		#' )
98		#' )
99		#' )
100		#' )
101		#' if (interactive()) {
102		#' shinyApp(app$ui, app$server)
103		#' }
104		#'
105		#' # CDISC data example
106		#' data <- teal_data()
107		#' data <- within(data, {
108		#' ADSL <- rADSL
109		#' ADRS <- rADRS
110		#' })
111		#' datanames(data) <- c("ADSL", "ADRS")
112		#' join_keys(data) <- default_cdisc_join_keys[datanames(data)]
113		#'
114		#' app <- init(
115		#' data = data,
116		#' modules = modules(
117		#' tm_g_scatterplotmatrix(
118		#' label = "Scatterplot matrix",
119		#' variables = list(
120		#' data_extract_spec(
121		#' dataname = "ADSL",
122		#' select = select_spec(
123		#' label = "Select variables:",
124		#' choices = variable_choices(data[["ADSL"]]),
125		#' selected = c("AGE", "RACE", "SEX"),
126		#' multiple = TRUE,
127		#' ordered = TRUE,
128		#' fixed = FALSE
129		#' )
130		#' ),
131		#' data_extract_spec(
132		#' dataname = "ADRS",
133		#' filter = filter_spec(
134		#' label = "Select endpoints:",
135		#' vars = c("PARAMCD", "AVISIT"),
136		#' choices = value_choices(data[["ADRS"]], c("PARAMCD", "AVISIT"), c("PARAM", "AVISIT")),
137		#' selected = "INVET - END OF INDUCTION",
138		#' multiple = TRUE
139		#' ),
140		#' select = select_spec(
141		#' label = "Select variables:",
142		#' choices = variable_choices(data[["ADRS"]]),
143		#' selected = c("AGE", "AVAL", "ADY"),
144		#' multiple = TRUE,
145		#' ordered = TRUE,
146		#' fixed = FALSE
147		#' )
148		#' )
149		#' )
150		#' )
151		#' )
152		#' )
153		#' if (interactive()) {
154		#' shinyApp(app$ui, app$server)
155		#' }
156		#'
157		#' @export
158		#'
159		tm_g_scatterplotmatrix <- function(label = "Scatterplot Matrix",
160		variables,
161		plot_height = c(600, 200, 2000),
162		plot_width = NULL,
163		pre_output = NULL,
164		post_output = NULL) {
165	!	logger::log_info("Initializing tm_g_scatterplotmatrix")
166
167		# Requires Suggested packages
168	!	if (!requireNamespace("lattice", quietly = TRUE)) {
169	!	stop("Cannot load lattice - please install the package or restart your session.")
170		}
171
172		# Normalize the parameters
173	!	if (inherits(variables, "data_extract_spec")) variables <- list(variables)
174
175		# Start of assertions
176	!	checkmate::assert_string(label)
177	!	checkmate::assert_list(variables, types = "data_extract_spec")
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	!	checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
188	!	checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
189		# End of assertions
190
191		# Make UI args
192	!	args <- as.list(environment())
193
194	!	module(
195	!	label = label,
196	!	server = srv_g_scatterplotmatrix,
197	!	ui = ui_g_scatterplotmatrix,
198	!	ui_args = args,
199	!	server_args = list(variables = variables, plot_height = plot_height, plot_width = plot_width),
200	!	datanames = teal.transform::get_extract_datanames(variables)
201		)
202		}
203
204		# UI function for the scatterplot matrix module
205		ui_g_scatterplotmatrix <- function(id, ...) {
206	!	args <- list(...)
207	!	is_single_dataset_value <- teal.transform::is_single_dataset(args$variables)
208	!	ns <- NS(id)
209	!	teal.widgets::standard_layout(
210	!	output = teal.widgets::white_small_well(
211	!	textOutput(ns("message")),
212	!	br(),
213	!	teal.widgets::plot_with_settings_ui(id = ns("myplot"))
214		),
215	!	encoding = div(
216		### Reporter
217	!	teal.reporter::simple_reporter_ui(ns("simple_reporter")),
218		###
219	!	tags$label("Encodings", class = "text-primary"),
220	!	teal.transform::datanames_input(args$variables),
221	!	teal.transform::data_extract_ui(
222	!	id = ns("variables"),
223	!	label = "Variables",
224	!	data_extract_spec = args$variables,
225	!	is_single_dataset = is_single_dataset_value
226		),
227	!	hr(),
228	!	teal.widgets::panel_group(
229	!	teal.widgets::panel_item(
230	!	title = "Plot settings",
231	!	sliderInput(
232	!	ns("alpha"), "Opacity:",
233	!	min = 0, max = 1,
234	!	step = .05, value = .5, ticks = FALSE
235		),
236	!	sliderInput(
237	!	ns("cex"), "Points size:",
238	!	min = 0.2, max = 3,
239	!	step = .05, value = .65, ticks = FALSE
240		),
241	!	checkboxInput(ns("cor"), "Add Correlation", value = FALSE),
242	!	radioButtons(
243	!	ns("cor_method"), "Select Correlation Method",
244	!	choiceNames = c("Pearson", "Kendall", "Spearman"),
245	!	choiceValues = c("pearson", "kendall", "spearman"),
246	!	inline = TRUE
247		),
248	!	checkboxInput(ns("cor_na_omit"), "Omit Missing Values", value = TRUE)
249		)
250		)
251		),
252	!	forms = tagList(
253	!	teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
254	!	teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
255		),
256	!	pre_output = args$pre_output,
257	!	post_output = args$post_output
258		)
259		}
260
261		# Server function for the scatterplot matrix module
262		srv_g_scatterplotmatrix <- function(id, data, reporter, filter_panel_api, variables, plot_height, plot_width) {
263	!	with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
264	!	with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
265	!	checkmate::assert_class(data, "reactive")
266	!	checkmate::assert_class(isolate(data()), "teal_data")
267	!	moduleServer(id, function(input, output, session) {
268	!	selector_list <- teal.transform::data_extract_multiple_srv(
269	!	data_extract = list(variables = variables),
270	!	datasets = data,
271	!	select_validation_rule = list(
272	!	variables = ~ if (length(.) <= 1) "Please select at least 2 columns."
273		)
274		)
275
276	!	iv_r <- reactive({
277	!	iv <- shinyvalidate::InputValidator$new()
278	!	teal.transform::compose_and_enable_validators(iv, selector_list)
279		})
280
281	!	anl_merged_input <- teal.transform::merge_expression_srv(
282	!	datasets = data,
283	!	selector_list = selector_list
284		)
285
286	!	anl_merged_q <- reactive({
287	!	req(anl_merged_input())
288	!	data() %>%
289	!	teal.code::eval_code(as.expression(anl_merged_input()$expr))
290		})
291
292	!	merged <- list(
293	!	anl_input_r = anl_merged_input,
294	!	anl_q_r = anl_merged_q
295		)
296
297		# plot
298	!	output_q <- reactive({
299	!	teal::validate_inputs(iv_r())
300
301	!	qenv <- merged$anl_q_r()
302	!	ANL <- qenv[["ANL"]]
303
304	!	cols_names <- merged$anl_input_r()$columns_source$variables
305	!	alpha <- input$alpha
306	!	cex <- input$cex
307	!	add_cor <- input$cor
308	!	cor_method <- input$cor_method
309	!	cor_na_omit <- input$cor_na_omit
310
311	!	cor_na_action <- if (isTruthy(cor_na_omit)) {
312	!	"na.omit"
313		} else {
314	!	"na.fail"
315		}
316
317	!	teal::validate_has_data(ANL, 10)
318	!	teal::validate_has_data(ANL[, cols_names, drop = FALSE], 10, complete = TRUE, allow_inf = FALSE)
319
320		# get labels and proper variable names
321	!	varnames <- varname_w_label(cols_names, ANL, wrap_width = 20)
322
323		# check character columns. If any, then those are converted to factors
324	!	check_char <- vapply(ANL[, cols_names], is.character, logical(1))
325	!	if (any(check_char)) {
326	!	qenv <- teal.code::eval_code(
327	!	qenv,
328	!	substitute(
329	!	expr = ANL <- ANL[, cols_names] %>%
330	!	dplyr::mutate_if(is.character, as.factor) %>%
331	!	droplevels(),
332	!	env = list(cols_names = cols_names)
333		)
334		)
335		} else {
336	!	qenv <- teal.code::eval_code(
337	!	qenv,
338	!	substitute(
339	!	expr = ANL <- ANL[, cols_names] %>%
340	!	droplevels(),
341	!	env = list(cols_names = cols_names)
342		)
343		)
344		}
345
346
347		# create plot
348	!	if (add_cor) {
349	!	shinyjs::show("cor_method")
350	!	shinyjs::show("cor_use")
351	!	shinyjs::show("cor_na_omit")
352
353	!	qenv <- teal.code::eval_code(
354	!	qenv,
355	!	substitute(
356	!	expr = {
357	!	g <- lattice::splom(
358	!	ANL,
359	!	varnames = varnames_value,
360	!	panel = function(x, y, ...) {
361	!	lattice::panel.splom(x = x, y = y, ...)
362	!	cpl <- lattice::current.panel.limits()
363	!	lattice::panel.text(
364	!	mean(cpl$xlim),
365	!	mean(cpl$ylim),
366	!	get_scatterplotmatrix_stats(
367	!	x,
368	!	y,
369	!	.f = stats::cor.test,
370	!	.f_args = list(method = cor_method, na.action = cor_na_action)
371		),
372	!	alpha = 0.6,
373	!	fontsize = 18,
374	!	fontface = "bold"
375		)
376		},
377	!	pch = 16,
378	!	alpha = alpha_value,
379	!	cex = cex_value
380		)
381	!	print(g)
382		},
383	!	env = list(
384	!	varnames_value = varnames,
385	!	cor_method = cor_method,
386	!	cor_na_action = cor_na_action,
387	!	alpha_value = alpha,
388	!	cex_value = cex
389		)
390		)
391		)
392		} else {
393	!	shinyjs::hide("cor_method")
394	!	shinyjs::hide("cor_use")
395	!	shinyjs::hide("cor_na_omit")
396	!	qenv <- teal.code::eval_code(
397	!	qenv,
398	!	substitute(
399	!	expr = {
400	!	g <- lattice::splom(ANL, varnames = varnames_value, pch = 16, alpha = alpha_value, cex = cex_value)
401	!	g
402		},
403	!	env = list(varnames_value = varnames, alpha_value = alpha, cex_value = cex)
404		)
405		)
406		}
407	!	qenv
408		})
409
410	!	plot_r <- reactive(output_q()[["g"]])
411
412		# Insert the plot into a plot_with_settings module
413	!	pws <- teal.widgets::plot_with_settings_srv(
414	!	id = "myplot",
415	!	plot_r = plot_r,
416	!	height = plot_height,
417	!	width = plot_width
418		)
419
420		# show a message if conversion to factors took place
421	!	output$message <- renderText({
422	!	shiny::req(iv_r()$is_valid())
423	!	req(selector_list()$variables())
424	!	ANL <- merged$anl_q_r()[["ANL"]]
425	!	cols_names <- unique(unname(do.call(c, merged$anl_input_r()$columns_source)))
426	!	check_char <- vapply(ANL[, cols_names], is.character, logical(1))
427	!	if (any(check_char)) {
428	!	is_single <- sum(check_char) == 1
429	!	paste(
430	!	"Character",
431	!	ifelse(is_single, "variable", "variables"),
432	!	paste0("(", paste(cols_names[check_char], collapse = ", "), ")"),
433	!	ifelse(is_single, "was", "were"),
434	!	"converted to",
435	!	ifelse(is_single, "factor.", "factors.")
436		)
437		} else {
438		""
439		}
440		})
441
442	!	teal.widgets::verbatim_popup_srv(
443	!	id = "warning",
444	!	verbatim_content = reactive(teal.code::get_warnings(output_q())),
445	!	title = "Warning",
446	!	disabled = reactive(is.null(teal.code::get_warnings(output_q())))
447		)
448
449	!	teal.widgets::verbatim_popup_srv(
450	!	id = "rcode",
451	!	verbatim_content = reactive(teal.code::get_code(output_q())),
452	!	title = "Show R Code for Scatterplotmatrix"
453		)
454
455		### REPORTER
456	!	if (with_reporter) {
457	!	card_fun <- function(comment, label) {
458	!	card <- teal::report_card_template(
459	!	title = "Scatter Plot Matrix",
460	!	label = label,
461	!	with_filter = with_filter,
462	!	filter_panel_api = filter_panel_api
463		)
464	!	card$append_text("Plot", "header3")
465	!	card$append_plot(plot_r(), dim = pws$dim())
466	!	if (!comment == "") {
467	!	card$append_text("Comment", "header3")
468	!	card$append_text(comment)
469		}
470	!	card$append_src(teal.code::get_code(output_q()))
471	!	card
472		}
473	!	teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
474		}
475		###
476		})
477		}
478
479		#' Get stats for x-y pairs in scatterplot matrix
480		#'
481		#' Uses [stats::cor.test()] per default for all numerical input variables and converts results
482		#' to character vector.
483		#' Could be extended if different stats for different variable types are needed.
484		#' Meant to be called from [lattice::panel.text()].
485		#'
486		#' Presently we need to use a formula input for `stats::cor.test` because
487		#' `na.fail` only gets evaluated when a formula is passed (see below).
488		#' ```
489		#' x = c(1,3,5,7,NA)
490		#' y = c(3,6,7,8,1)
491		#' stats::cor.test(x, y, na.action = "na.fail")
492		#' stats::cor.test(~ x + y, na.action = "na.fail")
493		#' ```
494		#'
495		#' @param x,y (`numeric`) vectors of data values. `x` and `y` must have the same length.
496		#' @param .f (`function`) function that accepts x and y as formula input `~ x + y`.
497		#' Default `stats::cor.test`.
498		#' @param .f_args (`list`) of arguments to be passed to `.f`.
499		#' @param round_stat (`integer(1)`) optional, number of decimal places to use when rounding the estimate.
500		#' @param round_pval (`integer(1)`) optional, number of decimal places to use when rounding the p-value.
501		#'
502		#' @return Character with stats. For [stats::cor.test()] correlation coefficient and p-value.
503		#'
504		#' @examples
505		#' set.seed(1)
506		#' x <- runif(25, 0, 1)
507		#' y <- runif(25, 0, 1)
508		#' x[c(3, 10, 18)] <- NA
509		#'
510		#' get_scatterplotmatrix_stats(x, y, .f = stats::cor.test, .f_args = list(method = "pearson"))
511		#' get_scatterplotmatrix_stats(x, y, .f = stats::cor.test, .f_args = list(
512		#' method = "pearson",
513		#' na.action = na.fail
514		#' ))
515		#'
516		#' @export
517		#'
518		get_scatterplotmatrix_stats <- function(x, y,
519		.f = stats::cor.test,
520		.f_args = list(),
521		round_stat = 2,
522		round_pval = 4) {
523	6x	if (is.numeric(x) && is.numeric(y)) {
524	3x	stat <- tryCatch(do.call(.f, c(list(~ x + y), .f_args)), error = function(e) NA)
525
526	3x	if (anyNA(stat)) {
527	1x	return("NA")
528	2x	} else if (all(c("estimate", "p.value") %in% names(stat))) {
529	2x	return(paste(
530	2x	c(
531	2x	paste0(names(stat$estimate), ":", round(stat$estimate, round_stat)),
532	2x	paste0("P:", round(stat$p.value, round_pval))
533		),
534	2x	collapse = "\n"
535		))
536		} else {
537	!	stop("function not supported")
538		}
539		} else {
540	3x	if ("method" %in% names(.f_args)) {
541	3x	if (.f_args$method == "pearson") {
542	1x	return("cor:-")
543		}
544	2x	if (.f_args$method == "kendall") {
545	1x	return("tau:-")
546		}
547	1x	if (.f_args$method == "spearman") {
548	1x	return("rho:-")
549		}
550		}
551	!	return("-")
552		}
553		}

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		#'
29		#' @param alpha (`integer(1)` or `integer(3)`) optional, specifies point opacity.
30		#' - When the length of `alpha` is one: the plot points will have a fixed opacity.
31		#' - When the length of `alpha` is three: the plot points opacity are dynamically adjusted based on
32		#' vector of `value`, `min`, and `max`.
33		#' @param size (`integer(1)` or `integer(3)`) optional, specifies point size.
34		#' - When the length of `size` is one: the plot point sizes will have a fixed size.
35		#' - When the length of `size` is three: the plot points size are dynamically adjusted based on
36		#' vector of `value`, `min`, and `max`.
37		#'
38		#' @return Object of class `teal_module` to be used in `teal` applications.
39		#'
40		#' @name shared_params
41		#' @keywords internal
42		NULL
43
44		#' Add labels for facets to a `ggplot2` object
45		#'
46		#' Enhances a `ggplot2` plot by adding labels that describe
47		#' the faceting variables along the x and y axes.
48		#'
49		#' @param p (`ggplot2`) object to which facet labels will be added.
50		#' @param xfacet_label (`character`) Label for the facet along the x-axis.
51		#' If `NULL`, no label is added. If a vector, labels are joined with " & ".
52		#' @param yfacet_label (`character`) Label for the facet along the y-axis.
53		#' Similar behavior to `xfacet_label`.
54		#'
55		#' @return Returns `grid` or `grob` object (to be drawn with `grid.draw`)
56		#'
57		#' @examples
58		#' library(ggplot2)
59		#' library(grid)
60		#'
61		#' p <- ggplot(mtcars) +
62		#' aes(x = mpg, y = disp) +
63		#' geom_point() +
64		#' facet_grid(gear ~ cyl)
65		#'
66		#' xfacet_label <- "cylinders"
67		#' yfacet_label <- "gear"
68		#' res <- add_facet_labels(p, xfacet_label, yfacet_label)
69		#' grid.newpage()
70		#' grid.draw(res)
71		#'
72		#' grid.newpage()
73		#' grid.draw(add_facet_labels(p, xfacet_label = NULL, yfacet_label))
74		#' grid.newpage()
75		#' grid.draw(add_facet_labels(p, xfacet_label, yfacet_label = NULL))
76		#' grid.newpage()
77		#' grid.draw(add_facet_labels(p, xfacet_label = NULL, yfacet_label = NULL))
78		#'
79		#' @export
80		#'
81		add_facet_labels <- function(p, xfacet_label = NULL, yfacet_label = NULL) {
82	!	checkmate::assert_class(p, classes = "ggplot")
83	!	checkmate::assert_character(xfacet_label, null.ok = TRUE, min.len = 1)
84	!	checkmate::assert_character(yfacet_label, null.ok = TRUE, min.len = 1)
85	!	if (is.null(xfacet_label) && is.null(yfacet_label)) {
86	!	return(ggplotGrob(p))
87		}
88	!	grid::grid.grabExpr({
89	!	g <- ggplotGrob(p)
90
91		# we are going to replace these, so we make sure they have nothing in them
92	!	checkmate::assert_class(g$grobs[[grep("xlab-t", g$layout$name, fixed = TRUE)]], "zeroGrob")
93	!	checkmate::assert_class(g$grobs[[grep("ylab-r", g$layout$name, fixed = TRUE)]], "zeroGrob")
94
95	!	xaxis_label_grob <- g$grobs[[grep("xlab-b", g$layout$name, fixed = TRUE)]]
96	!	xaxis_label_grob$children[[1]]$label <- paste(xfacet_label, collapse = " & ")
97	!	yaxis_label_grob <- g$grobs[[grep("ylab-l", g$layout$name, fixed = TRUE)]]
98	!	yaxis_label_grob$children[[1]]$label <- paste(yfacet_label, collapse = " & ")
99	!	yaxis_label_grob$children[[1]]$rot <- 270
100
101	!	top_height <- if (is.null(xfacet_label)) 0 else grid::unit(2, "line")
102	!	right_width <- if (is.null(yfacet_label)) 0 else grid::unit(2, "line")
103
104	!	grid::grid.newpage()
105	!	grid::pushViewport(grid::plotViewport(margins = c(0, 0, top_height, right_width), name = "ggplot"))
106	!	grid::grid.draw(g)
107	!	grid::upViewport(1)
108
109		# draw x facet
110	!	if (!is.null(xfacet_label)) {
111	!	grid::pushViewport(grid::viewport(
112	!	x = 0, y = grid::unit(1, "npc") - top_height, width = grid::unit(1, "npc"),
113	!	height = top_height, just = c("left", "bottom"), name = "topxaxis"
114		))
115	!	grid::grid.draw(xaxis_label_grob)
116	!	grid::upViewport(1)
117		}
118
119		# draw y facet
120	!	if (!is.null(yfacet_label)) {
121	!	grid::pushViewport(grid::viewport(
122	!	x = grid::unit(1, "npc") - grid::unit(as.numeric(right_width) / 2, "line"), y = 0, width = right_width,
123	!	height = grid::unit(1, "npc"), just = c("left", "bottom"), name = "rightyaxis"
124		))
125	!	grid::grid.draw(yaxis_label_grob)
126	!	grid::upViewport(1)
127		}
128		})
129		}
130
131		#' Call a function with a character vector for the `...` argument
132		#'
133		#' @param fun (`character`) Name of a function where the `...` argument shall be replaced by values from `str_args`.
134		#' @param str_args (`character`) A character vector that the function shall be executed with
135		#'
136		#' @return
137		#' Value of call to `fun` with arguments specified in `str_args`.
138		#'
139		#' @keywords internal
140		call_fun_dots <- function(fun, str_args) {
141	!	do.call("call", c(list(fun), lapply(str_args, as.name)), quote = TRUE)
142		}
143
144		#' Generate a string for a variable including its label
145		#'
146		#' @param var_names (`character`) Name of variable to extract labels from.
147		#' @param dataset (`dataset`) Name of analysis dataset.
148		#' @param prefix,suffix (`character`) String to paste to the beginning/end of the variable name with label.
149		#' @param wrap_width (`numeric`) Number of characters to wrap original label to. Defaults to 80.
150		#'
151		#' @return (`character`) String with variable name and label.
152		#'
153		#' @keywords internal
154		#'
155		varname_w_label <- function(var_names,
156		dataset,
157		wrap_width = 80,
158		prefix = NULL,
159		suffix = NULL) {
160	!	add_label <- function(var_names) {
161	!	label <- vapply(
162	!	dataset[var_names], function(x) {
163	!	attr_label <- attr(x, "label")
164	!	`if`(is.null(attr_label), "", attr_label)
165		},
166	!	character(1)
167		)
168
169	!	if (length(label) == 1 && !is.na(label) && !identical(label, "")) {
170	!	paste0(prefix, label, " [", var_names, "]", suffix)
171		} else {
172	!	var_names
173		}
174		}
175
176	!	if (length(var_names) < 1) {
177	!	NULL
178	!	} else if (length(var_names) == 1) {
179	!	stringr::str_wrap(add_label(var_names), width = wrap_width)
180	!	} else if (length(var_names) > 1) {
181	!	stringr::str_wrap(vapply(var_names, add_label, character(1)), width = wrap_width)
182		}
183		}
184
185		# see vignette("ggplot2-specs", package="ggplot2")
186		shape_names <- c(
187		"circle", paste("circle", c("open", "filled", "cross", "plus", "small")), "bullet",
188		"square", paste("square", c("open", "filled", "cross", "plus", "triangle")),
189		"diamond", paste("diamond", c("open", "filled", "plus")),
190		"triangle", paste("triangle", c("open", "filled", "square")),
191		paste("triangle down", c("open", "filled")),
192		"plus", "cross", "asterisk"
193		)
194
195		#' Get icons to represent variable types in dataset
196		#'
197		#' @param var_type (`character`) of R internal types (classes).
198		#' @return (`character`) vector of HTML icons corresponding to data type in each column.
199		#' @keywords internal
200		variable_type_icons <- function(var_type) {
201	!	checkmate::assert_character(var_type, any.missing = FALSE)
202
203	!	class_to_icon <- list(
204	!	numeric = "arrow-up-1-9",
205	!	integer = "arrow-up-1-9",
206	!	logical = "pause",
207	!	Date = "calendar",
208	!	POSIXct = "calendar",
209	!	POSIXlt = "calendar",
210	!	factor = "chart-bar",
211	!	character = "keyboard",
212	!	primary_key = "key",
213	!	unknown = "circle-question"
214		)
215	!	class_to_icon <- lapply(class_to_icon, function(icon_name) toString(icon(icon_name, lib = "font-awesome")))
216
217	!	unname(vapply(
218	!	var_type,
219	!	FUN.VALUE = character(1),
220	!	FUN = function(class) {
221	!	if (class == "") {
222	!	class
223	!	} else if (is.null(class_to_icon[[class]])) {
224	!	class_to_icon[["unknown"]]
225		} else {
226	!	class_to_icon[[class]]
227		}
228		}
229		))
230		}
231
232		#' Include `CSS` files from `/inst/css/` package directory to application header
233		#'
234		#' `system.file` should not be used to access files in other packages, it does
235		#' not work with `devtools`. Therefore, we redefine this method in each package
236		#' as needed. Thus, we do not export this method
237		#'
238		#' @param pattern (`character`) optional, regular expression to match the file names to be included.
239		#'
240		#' @return HTML code that includes `CSS` files.
241		#' @keywords internal
242		#'
243		include_css_files <- function(pattern = "*") {
244	!	css_files <- list.files(
245	!	system.file("css", package = "teal.modules.general", mustWork = TRUE),
246	!	pattern = pattern, full.names = TRUE
247		)
248	!	if (length(css_files) == 0) {
249	!	return(NULL)
250		}
251	!	shiny::singleton(shiny::tags$head(lapply(css_files, shiny::includeCSS)))
252		}
253
254		#' JavaScript condition to check if a specific tab is active
255		#'
256		#' @param id (`character(1)`) the id of the tab panel with tabs.
257		#' @param name (`character(1)`) the name of the tab.
258		#' @return JavaScript expression to be used in `shiny::conditionalPanel()` to determine
259		#' if the specified tab is active.
260		#' @keywords internal
261		#'
262		is_tab_active_js <- function(id, name) {
263		# supporting the bs3 and higher version at the same time
264	!	sprintf(
265	!	"$(\"#%1$s > li.active\").text().trim() == '%2$s' \|\| $(\"#%1$s > li a.active\").text().trim() == '%2$s'",
266	!	id, name
267		)
268		}
269
270		#' Assert single selection on `data_extract_spec` object
271		#' Helper to reduce code in assertions
272		#' @noRd
273		#'
274		assert_single_selection <- function(x,
275		.var.name = checkmate::vname(x)) { # nolint: object_name.
276	104x	if (any(vapply(x, function(.x) .x$select$multiple, logical(1)))) {
277	4x	stop("'", .var.name, "' should not allow multiple selection")
278		}
279	100x	invisible(TRUE)
280		}

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`) A vector of datasets which should be
20		#' shown and in what order. Names in the vector have to correspond with datasets names.
21		#' If vector of `length == 0` (default) then all datasets are shown.
22		#' Note: Only datasets of the `data.frame` class are compatible.
23		#' @param dt_args (`named list`) Additional arguments to be passed to [DT::datatable()]
24		#' (must not include `data` or `options`).
25		#' @param dt_options (`named list`) The `options` argument to `DT::datatable`. By default
26		#' `list(searching = FALSE, pageLength = 30, lengthMenu = c(5, 15, 30, 100), scrollX = TRUE)`
27		#' @param server_rendering (`logical`) should the data table be rendered server side
28		#' (see `server` argument of [DT::renderDataTable()])
29		#'
30		#' @inherit shared_params return
31		#'
32		#' @examples
33		#' # general data example
34		#' data <- teal_data()
35		#' data <- within(data, {
36		#' require(nestcolor)
37		#' iris <- iris
38		#' })
39		#' datanames(data) <- c("iris")
40		#'
41		#' app <- init(
42		#' data = data,
43		#' modules = modules(
44		#' tm_data_table(
45		#' variables_selected = list(
46		#' iris = c("Sepal.Length", "Sepal.Width", "Petal.Length", "Petal.Width", "Species")
47		#' ),
48		#' dt_args = list(caption = "ADSL Table Caption")
49		#' )
50		#' )
51		#' )
52		#' if (interactive()) {
53		#' shinyApp(app$ui, app$server)
54		#' }
55		#'
56		#' # CDISC data example
57		#' data <- teal_data()
58		#' data <- within(data, {
59		#' require(nestcolor)
60		#' ADSL <- rADSL
61		#' })
62		#' datanames(data) <- "ADSL"
63		#' join_keys(data) <- default_cdisc_join_keys[datanames(data)]
64		#'
65		#' app <- init(
66		#' data = data,
67		#' modules = modules(
68		#' tm_data_table(
69		#' variables_selected = list(ADSL = c("STUDYID", "USUBJID", "SUBJID", "SITEID", "AGE", "SEX")),
70		#' dt_args = list(caption = "ADSL Table Caption")
71		#' )
72		#' )
73		#' )
74		#' if (interactive()) {
75		#' shinyApp(app$ui, app$server)
76		#' }
77		#'
78		#' @export
79		#'
80		tm_data_table <- function(label = "Data Table",
81		variables_selected = list(),
82		datasets_selected = character(0),
83		dt_args = list(),
84		dt_options = list(
85		searching = FALSE,
86		pageLength = 30,
87		lengthMenu = c(5, 15, 30, 100),
88		scrollX = TRUE
89		),
90		server_rendering = FALSE,
91		pre_output = NULL,
92		post_output = NULL) {
93	!	logger::log_info("Initializing tm_data_table")
94
95		# Start of assertions
96	!	checkmate::assert_string(label)
97
98	!	checkmate::assert_list(variables_selected, min.len = 0, types = "character", names = "named")
99	!	if (length(variables_selected) > 0) {
100	!	lapply(seq_along(variables_selected), function(i) {
101	!	checkmate::assert_character(variables_selected[[i]], min.chars = 1, min.len = 1)
102	!	if (!is.null(names(variables_selected[[i]]))) {
103	!	checkmate::assert_names(names(variables_selected[[i]]))
104		}
105		})
106		}
107
108	!	checkmate::assert_character(datasets_selected, min.len = 0, min.chars = 1)
109	!	checkmate::assert(
110	!	checkmate::check_list(dt_args, len = 0),
111	!	checkmate::check_subset(names(dt_args), choices = names(formals(DT::datatable)))
112		)
113	!	checkmate::assert_list(dt_options, names = "named")
114	!	checkmate::assert_flag(server_rendering)
115	!	checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
116	!	checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
117		# End of assertions
118
119	!	module(
120	!	label,
121	!	server = srv_page_data_table,
122	!	ui = ui_page_data_table,
123	!	datanames = if (length(datasets_selected) == 0) "all" else datasets_selected,
124	!	server_args = list(
125	!	variables_selected = variables_selected,
126	!	datasets_selected = datasets_selected,
127	!	dt_args = dt_args,
128	!	dt_options = dt_options,
129	!	server_rendering = server_rendering
130		),
131	!	ui_args = list(
132	!	pre_output = pre_output,
133	!	post_output = post_output
134		)
135		)
136		}
137
138		# UI page module
139		ui_page_data_table <- function(id,
140		pre_output = NULL,
141		post_output = NULL) {
142	!	ns <- NS(id)
143
144	!	shiny::tagList(
145	!	include_css_files("custom"),
146	!	teal.widgets::standard_layout(
147	!	output = teal.widgets::white_small_well(
148	!	fluidRow(
149	!	column(
150	!	width = 12,
151	!	checkboxInput(
152	!	ns("if_distinct"),
153	!	"Show only distinct rows:",
154	!	value = FALSE
155		)
156		)
157		),
158	!	fluidRow(
159	!	class = "mb-8",
160	!	column(
161	!	width = 12,
162	!	uiOutput(ns("dataset_table"))
163		)
164		)
165		),
166	!	pre_output = pre_output,
167	!	post_output = post_output
168		)
169		)
170		}
171
172		# Server page module
173		srv_page_data_table <- function(id,
174		data,
175		datasets_selected,
176		variables_selected,
177		dt_args,
178		dt_options,
179		server_rendering) {
180	!	checkmate::assert_class(data, "reactive")
181	!	checkmate::assert_class(isolate(data()), "teal_data")
182	!	moduleServer(id, function(input, output, session) {
183	!	if_filtered <- reactive(as.logical(input$if_filtered))
184	!	if_distinct <- reactive(as.logical(input$if_distinct))
185
186	!	datanames <- isolate(teal.data::datanames(data()))
187	!	datanames <- Filter(function(name) {
188	!	is.data.frame(isolate(data())[[name]])
189	!	}, datanames)
190
191	!	if (!identical(datasets_selected, character(0))) {
192	!	checkmate::assert_subset(datasets_selected, datanames)
193	!	datanames <- datasets_selected
194		}
195
196	!	output$dataset_table <- renderUI({
197	!	do.call(
198	!	tabsetPanel,
199	!	lapply(
200	!	datanames,
201	!	function(x) {
202	!	dataset <- isolate(data()[[x]])
203	!	choices <- names(dataset)
204	!	labels <- vapply(
205	!	dataset,
206	!	function(x) ifelse(is.null(attr(x, "label")), "", attr(x, "label")),
207	!	character(1)
208		)
209	!	names(choices) <- ifelse(
210	!	is.na(labels) \| labels == "",
211	!	choices,
212	!	paste(choices, labels, sep = ": ")
213		)
214	!	variables_selected <- if (!is.null(variables_selected[[x]])) {
215	!	variables_selected[[x]]
216		} else {
217	!	utils::head(choices)
218		}
219	!	tabPanel(
220	!	title = x,
221	!	column(
222	!	width = 12,
223	!	div(
224	!	class = "mt-4",
225	!	ui_data_table(
226	!	id = session$ns(x),
227	!	choices = choices,
228	!	selected = variables_selected
229		)
230		)
231		)
232		)
233		}
234		)
235		)
236		})
237
238	!	lapply(
239	!	datanames,
240	!	function(x) {
241	!	srv_data_table(
242	!	id = x,
243	!	data = data,
244	!	dataname = x,
245	!	if_filtered = if_filtered,
246	!	if_distinct = if_distinct,
247	!	dt_args = dt_args,
248	!	dt_options = dt_options,
249	!	server_rendering = server_rendering
250		)
251		}
252		)
253		})
254		}
255
256		# UI function for the data_table module
257		ui_data_table <- function(id,
258		choices,
259		selected) {
260	!	ns <- NS(id)
261
262	!	if (!is.null(selected)) {
263	!	all_choices <- choices
264	!	choices <- c(selected, setdiff(choices, selected))
265	!	names(choices) <- names(all_choices)[match(choices, all_choices)]
266		}
267
268	!	tagList(
269	!	teal.widgets::get_dt_rows(ns("data_table"), ns("dt_rows")),
270	!	fluidRow(
271	!	teal.widgets::optionalSelectInput(
272	!	ns("variables"),
273	!	"Select variables:",
274	!	choices = choices,
275	!	selected = selected,
276	!	multiple = TRUE,
277	!	width = "100%"
278		)
279		),
280	!	fluidRow(
281	!	DT::dataTableOutput(ns("data_table"), width = "100%")
282		)
283		)
284		}
285
286		# Server function for the data_table module
287		srv_data_table <- function(id,
288		data,
289		dataname,
290		if_filtered,
291		if_distinct,
292		dt_args,
293		dt_options,
294		server_rendering) {
295	!	moduleServer(id, function(input, output, session) {
296	!	iv <- shinyvalidate::InputValidator$new()
297	!	iv$add_rule("variables", shinyvalidate::sv_required("Please select valid variable names"))
298	!	iv$add_rule("variables", shinyvalidate::sv_in_set(
299	!	set = names(data()[[dataname]]), message_fmt = "Not all selected variables exist in the data"
300		))
301	!	iv$enable()
302
303	!	output$data_table <- DT::renderDataTable(server = server_rendering, {
304	!	teal::validate_inputs(iv)
305
306	!	df <- data()[[dataname]]
307	!	variables <- input$variables
308
309	!	teal::validate_has_data(df, min_nrow = 1L, msg = paste("data", dataname, "is empty"))
310
311	!	dataframe_selected <- if (if_distinct()) {
312	!	dplyr::count(df, dplyr::across(dplyr::all_of(variables)))
313		} else {
314	!	df[variables]
315		}
316
317	!	dt_args$options <- dt_options
318	!	if (!is.null(input$dt_rows)) {
319	!	dt_args$options$pageLength <- input$dt_rows
320		}
321	!	dt_args$data <- dataframe_selected
322
323	!	do.call(DT::datatable, dt_args)
324		})
325		})
326		}