teal.modules.general coverage - 2.29%

Files
Source

#' Variable Browser Teal Module
#'
#' The variable browser provides a table with variable names and labels and a
#' plot that visualizes the content of a particular variable.
#'
#' @details Numeric columns with fewer than 30 distinct values can be treated as either factors
#' or numbers with a checkbox allowing users to switch how they are treated (if < 6 unique values
#' then the default is categorical, otherwise it is numeric).
#'
#' @inheritParams teal::module
#' @inheritParams shared_params
#' @param parent_dataname (`character(1)`) If this `dataname` 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`) 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 zero (default) then all datasets are shown.
#'
#' @aliases
#'   tm_variable_browser_ui,
#'   tm_variable_browser_srv,
#'   tm_variable_browser,
#'   variable_browser_ui,
#'   variable_browser_srv,
#'   variable_browser
#'
#'
#' @export
#'
#' @examples
#'
#' ADSL <- teal.modules.general::rADSL
#' ADTTE <- teal.modules.general::rADTTE
#'
#' app <- teal::init(
#'   data = teal.data::cdisc_data(
#'     teal.data::cdisc_dataset("ADSL", ADSL, code = "ADSL <- teal.modules.general::rADSL"),
#'     teal.data::cdisc_dataset("ADTTE", ADTTE, code = "ADTTE <- teal.modules.general::rADTTE"),
#'     check = TRUE
#'   ),
#'   modules(
#'     teal.modules.general::tm_variable_browser(
#'       label = "Variable browser",
#'       ggplot2_args = teal.widgets::ggplot2_args(
#'         labs = list(subtitle = "Plot generated by Variable Browser Module")
#'       ),
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
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")
  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.")
  }
  checkmate::assert_string(label)
  checkmate::assert_character(datasets_selected)
  checkmate::assert_character(parent_dataname, min.len = 0, max.len = 1)
  checkmate::assert_class(ggplot2_args, "ggplot2_args")
  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(
      datasets_selected = datasets_selected,
      parent_dataname = parent_dataname,
      pre_output = pre_output,
      post_output = post_output
    )
  )
}

# ui function
ui_variable_browser <- function(id,
                                data,
                                datasets_selected,
                                parent_dataname,
                                pre_output = NULL,
                                post_output = NULL) {
  ns <- NS(id)

  datanames <- names(data)

  if (!identical(datasets_selected, character(0))) {
    stopifnot(all(datasets_selected %in% datanames))
    datanames <- datasets_selected
  }

  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(
            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%")
                      )
                    )
                  })
                )
              )
            ),
            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 = c(
                  "gray", "bw", "linedraw", "light",
                  "dark", "minimal", "classic", "void", "test"
                ),
                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
    )
  )
}

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

    datanames <- names(data)

    checkmate::assert_character(datasets_selected)
    checkmate::assert_subset(datasets_selected, datanames)
    if (length(datasets_selected) != 0L) {
      datanames <- datasets_selected
    }

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

    columns_names <- new.env() # nolint

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

      df <- data[[dataname]]()

      numeric_ui <- tagList(
        fluidRow(
          div(
            class = "col-md-4",
            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",
            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"))
        )
      )

      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(isolate(input$numeric_as_factor)),
                unique_entries < .unique_records_default_as_factor,
                isolate(input$numeric_as_factor)
              )
            ),
            conditionalPanel("!input.numeric_as_factor", ns = session$ns, numeric_ui)
          )
        } else if (unique_entries > 0) {
          numeric_ui
        }
      } else {
        NULL
      }
    })

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

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

#' Summarizes missings occurrence
#'
#' Summarizes missings occurrence in vector
#' @param x vector of any type and length
#' @return text describing \code{NA} occurrence.
#' @keywords internal
var_missings_info <- function(x) {
  return(sprintf("%s [%s%%]", sum(is.na(x)), round(mean(is.na(x) * 100), 2)))
}

#' S3 generic for \code{sparkline} widget HTML
#'
#' Generates the \code{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 \code{numeric} the width of the \code{sparkline} widget (pixels)
#' @param ... \code{list} additional options passed to bar plots of \code{jquery.sparkline};  see
#' \href{https://omnipotent.net/jquery.sparkline/#common}{\code{jquery.sparkline docs}}
#'
#' @return character variable containing the HTML code of the \code{sparkline} HTML widget
#' @keywords internal
#'
create_sparklines <- function(arr, width = 150, ...) {
  if (all(is.null(arr))) {
    return("")
  }
  UseMethod("create_sparklines")
}

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

#' Generates the HTML code for the \code{sparkline} widget
#'
#' @param bar_spacing \code{numeric} the spacing between the bars (in pixels)
#' @param bar_width \code{numeric} the width of the bars (in pixels)
#'
#' @return \code{character} with HTML code for the \code{sparkline} widget
#'
#' @export
#' @keywords internal
#' @rdname create_sparklines
create_sparklines.Date <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) { # nolint
  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)
  )
}

#' Generates the HTML code for the \code{sparkline} widget
#'
#'
#' @param bar_spacing \code{numeric} the spacing between the bars (in pixels)
#' @param bar_width \code{numeric} the width of the bars (in pixels)
#'
#' @return \code{character} with HTML code for the \code{sparkline} widget
#'
#' @export
#' @keywords internal
#' @rdname create_sparklines
create_sparklines.POSIXct <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) { # nolint
  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)
  )
}

#' Generates the HTML code for the \code{sparkline} widget
#'
#'
#' @param bar_spacing \code{numeric} the spacing between the bars (in pixels)
#' @param bar_width \code{numeric} the width of the bars (in pixels)
#'
#' @return \code{character} with HTML code for the \code{sparkline} widget
#'
#' @export
#' @keywords internal
#' @rdname create_sparklines
create_sparklines.POSIXlt <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) { # nolint
  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)
  )
}


#' Generates the HTML code for the \code{sparkline} widget
#'
#' Coerces a character vector to factor and delegates to the \code{create_sparklines.factor}
#'
#'
#' @return \code{character} with HTML code for the \code{sparkline} widget
#'
#' @export
#' @keywords internal
#' @rdname create_sparklines
create_sparklines.character <- function(arr, ...) { # nolint
  return(create_sparklines(as.factor(arr)))
}


#' Generates the HTML code for the \code{sparkline} widget
#'
#' Coerces logical vector to factor and delegates to the \code{create_sparklines.factor}
#'
#'
#' @return \code{character} with HTML code for the \code{sparkline} widget
#'
#' @export
#' @keywords internal
#' @rdname create_sparklines
create_sparklines.logical <- function(arr, ...) { # nolint
  return(create_sparklines(as.factor(arr)))
}


#' Generates the \code{sparkline} HTML code
#'
#' @param bar_spacing \code{numeric} spacing between the bars (in pixels)
#' @param bar_width \code{numeric} width of the bars (in pixels)
#'
#' @return \code{character} with HTML code for the \code{sparkline} widget
#'
#' @export
#' @keywords internal
#' @rdname create_sparklines
create_sparklines.factor <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) { # nolint
  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))
  )
}

#' Generates the \code{sparkline} HTML code
#'
#'
#' @return \code{character} with HTML code for the \code{sparkline} widget
#'
#' @export
#' @keywords internal
#' @rdname create_sparklines
create_sparklines.numeric <- function(arr, width = 150, ...) { # nolint
  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)]
  res <- sparkline::spk_chr(unname(arr), type = "box", width = width, ...)
  return(res)
}

#' 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 \code{logical} should the numeric variable be treated as a factor
#' @param dt_rows \code{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 numeric_as_factor \code{logical} should the numeric variable be treated as a factor
#' @param display_density \code{logical} Should density estimation be displayed for numeric values?
#' @param remove_NA_hist \code{logical} Should \code{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 \code{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,
                             numeric_as_factor,
                             display_density = is.numeric(var),
                             remove_NA_hist = FALSE, # nolint
                             outlier_definition,
                             records_for_factor,
                             ggplot2_args) {
  checkmate::assert_flag(display_density)
  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 {
      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, levels = sort(unique(var)))
      p <- qplot(var)
    } 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
}

#' Returns a short variable description.
#'
#' @description
#' The format of the variable description is:
#' `"<Long variable label> [<dataset name>.<variable name>]"`
#'
#' Example: `"Study Identifier [ADSL.STUDYID]"`
#'
#' @param data (`tdata`) the object containing the dataset
#' @param dataset_name (`character`) the name of the dataset containing the variable
#' @param var_name (`character`) the name of the variable
#' @keywords internal
get_var_description <- function(data, dataset_name, var_name) {
  varlabel <- var_labels(data[[dataset_name]]())[[var_name]]
  sprintf(
    "%s [%s.%s]",
    if (is.na(varlabel)) var_name else varlabel,
    dataset_name,
    var_name
  )
}

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 (`tdata`) 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 <- input$tabset_panel
    varname <- plot_var$variable[[input$tabset_panel]]

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

  var_description <- var_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 (`tdata`) 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
#'
#' @description
#' 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 <- get_join_keys(data)
    if (!is.null(join_keys)) {
      key <- get_join_keys(data)$get(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
#'
#' @description
#' 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(data[[dataset_name]]())
      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 <- stats::setNames(teal.slice:::variable_types(df), colnames(df))

      join_keys <- get_join_keys(data)
      if (!is.null(join_keys)) {
        icons[intersect(join_keys$get(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
#'
#' @description
#' 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
}

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

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

#' Outliers Module
#'
#' Module to analyze and identify outliers using different methods
#'
#' @inheritParams teal::module
#' @inheritParams shared_params
#'
#' @param outlier_var (`data_extract_spec` or `list` of multiple `data_extract_spec`)
#'  variable to consider for the outliers analysis.
#' @param categorical_var (`data_extract_spec` or `list` of multiple `data_extract_spec`)
#'   categorical factor to split the selected outlier variables on.
#'
#' @templateVar ggnames "Boxplot","Density Plot","Cumulative Distribution Plot"
#' @template ggplot2_args_multi
#'
#' @export
#'
#' @examples
#'
#' ADSL <- teal.modules.general::rADSL
#'
#' fact_vars_adsl <- names(Filter(isTRUE, sapply(ADSL, is.factor)))
#' vars <- choices_selected(variable_choices(ADSL, fact_vars_adsl))
#'
#' app <- teal::init(
#'   data = teal.data::cdisc_data(
#'     teal.data::cdisc_dataset("ADSL", ADSL, code = "ADSL <- teal.modules.general::rADSL"),
#'     check = TRUE
#'   ),
#'   modules = teal::modules(
#'     teal.modules.general::tm_outliers(
#'       outlier_var = list(
#'         teal.transform::data_extract_spec(
#'           dataname = "ADSL",
#'           select = select_spec(
#'             label = "Select variable:",
#'             choices = variable_choices(ADSL, c("AGE", "BMRKR1")),
#'             selected = "AGE",
#'             multiple = FALSE,
#'             fixed = FALSE
#'           )
#'         )
#'       ),
#'       categorical_var = list(
#'         teal.transform::data_extract_spec(
#'           dataname = "ADSL",
#'           filter = teal.transform::filter_spec(
#'             vars = vars,
#'             choices = value_choices(ADSL, vars$selected),
#'             selected = value_choices(ADSL, vars$selected),
#'             multiple = TRUE
#'           )
#'         )
#'       ),
#'       ggplot2_args = list(
#'         teal.widgets::ggplot2_args(
#'           labs = list(subtitle = "Plot generated by Outliers Module")
#'         )
#'       )
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
tm_outliers <- function(label = "Outliers Module",
                        outlier_var,
                        categorical_var = NULL,
                        ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void", "test"),
                        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")
  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)

  ggtheme <- match.arg(ggtheme)
  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)
      }
    })
  }
  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))

  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_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"))
    ),
    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 = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void", "test"),
          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
  )
}

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, "tdata")
  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,
      join_keys = get_join_keys(data),
      merge_function = "dplyr::inner_join"
    )

    anl_merged_q <- reactive({
      req(anl_merged_input())
      teal.code::new_qenv(tdata2env(data), code = get_code_tdata(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"]] # nolint
      sum(is.na(ANL[[outlier_var]]))
    })

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

      ANL <- merged$anl_q_r()[["ANL"]] # nolint
      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 # nolint
      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]
        ),
        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)), # nolint
              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)), # nolint
              env = list(outlier_var_name = as.name(outlier_var))
            )
          )
        }
        shinyjs::show("split_outliers")
      }

      # slider
      outlier_definition_param <- if (method == "IQR") { # nolint
        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 %>% # nolint
              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)
            ANL_OUTLIER # used to display table when running show-r-code code
          },
          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()
      )

      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( # nolint
                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 %>% # nolint
                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
    boxplot_q <- reactive({
      req(common_code_q())
      ANL <- common_code_q()[["ANL"]] # nolint
      ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]] # nolint

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

      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"]] # nolint
      ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]] # nolint

      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"]] # nolint
      ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]] # nolint

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

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

    dataname <- names(data)[[1]]

    choices <- teal.transform::variable_choices(data[[dataname]]())

    observeEvent(common_code_q(), {
      ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]] # nolint
      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
        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"]] # nolint
        ANL <- common_code_q()[["ANL"]] # nolint
        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 # nolint

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

          # 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 # nolint #either ymin or ymax will work
          } else if (tab == "Cumulative Distribution Plot") {
            plot_brush$mapping$y <- "cdf"
            if (length(categorical_var) > 0) {
              ANL <- ANL %>% # nolint
                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]]) # nolint
            }
          }

          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
        keys <- get_join_keys(data)$get(dataname)[[dataname]]
        datas <- data[[dataname]]()
        dplyr::left_join(
          display_table,
          dplyr::select(datas, dplyr::setdiff(names(datas), dplyr::setdiff(names(display_table), keys))),
          by = keys
        ) %>%
          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"]] # nolint
      ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]] # nolint
      teal::validate_has_data(ANL, 1)
      ANL_OUTLIER_SELECTED <- ANL_OUTLIER[ANL_OUTLIER$is_outlier_selected, ] # nolint
      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"]] # nolint
        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")),
        DT::dataTableOutput(session$ns("table_ui"))
      )
    })

    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) {
        card <- teal::TealReportCard$new()
        tab_type <- input$tabs
        card$set_name(paste0("Outliers - ", tab_type))
        card$append_text(tab_type, "header2")
        if (with_filter) card$append_fs(filter_panel_api$get_filter_state())

        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(paste(teal.code::get_code(final_q()), collapse = "\n"))
        card
      }
      teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
    }
    ###
  })
}

#' Univariate and bivariate visualizations
#' @md
#'
#' @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. Variable 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. Variable can be numeric, factor or character.
#' @param use_density optional, (`logical`) value for whether density (`TRUE`) is plotted or
#'   frequency (`FALSE`). Defaults to frequency (`FALSE`).
#' @param row_facet optional, (`data_extract_spec` or `list` of multiple `data_extract_spec`)
#'   Variables for row facetting.
#' @param col_facet optional, (`data_extract_spec` or `list` of multiple `data_extract_spec`)
#'   Variables for col facetting.
#' @param facet optional, (`logical`) to specify 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 optional, (`data_extract_spec` or `list` of multiple `data_extract_spec`)
#'   Variables selected for the outline color inside the coloring settings.
#'   It will be applied when `color_settings` is set to `TRUE`.
#' @param fill optional, (`data_extract_spec` or `list` of multiple `data_extract_spec`)
#'   Variables selected for the fill color inside the coloring settings.
#'   It will be applied when `color_settings` is set to `TRUE`.
#' @param size optional, (`data_extract_spec` or `list` of multiple `data_extract_spec`)
#'   Variables 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 optional, (`logical`) Whether X scaling shall be changeable.
#'   Does not allow scaling to be changed by default (`FALSE`).
#' @param free_y_scales optional, (`logical`) Whether Y scaling shall be changeable.
#'   Does not allow scaling to be changed by default (`FALSE`).
#' @param swap_axes optional, (`logical`) Whether to swap X and Y axes. Defaults to `FALSE`.
#'
#' @details
#' 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")`.
#'
#' @export
#'
#' @examples
#' # Bivariate plot of selected variable (AGE) against selected (SEX)
#' ADSL <- teal.modules.general::rADSL
#'
#' app <- teal::init(
#'   data = teal.data::cdisc_data(
#'     teal.data::cdisc_dataset("ADSL", ADSL, code = "ADSL <- teal.modules.general::rADSL"),
#'     check = TRUE
#'   ),
#'   modules = teal::modules(
#'     teal.modules.general::tm_g_bivariate(
#'       x = teal.transform::data_extract_spec(
#'         dataname = "ADSL",
#'         select = teal.transform::select_spec(
#'           label = "Select variable:",
#'           choices = teal.transform::variable_choices(ADSL),
#'           selected = "AGE",
#'           fixed = FALSE
#'         )
#'       ),
#'       y = teal.transform::data_extract_spec(
#'         dataname = "ADSL",
#'         select = teal.transform::select_spec(
#'           label = "Select variable:",
#'           choices = teal.transform::variable_choices(ADSL),
#'           selected = "SEX",
#'           multiple = FALSE,
#'           fixed = FALSE
#'         )
#'       ),
#'       row_facet = teal.transform::data_extract_spec(
#'         dataname = "ADSL",
#'         select = teal.transform::select_spec(
#'           label = "Select variable:",
#'           choices = teal.transform::variable_choices(ADSL),
#'           selected = "ARM",
#'           fixed = FALSE
#'         )
#'       ),
#'       col_facet = teal.transform::data_extract_spec(
#'         dataname = "ADSL",
#'         select = teal.transform::select_spec(
#'           label = "Select variable:",
#'           choices = teal.transform::variable_choices(ADSL),
#'           selected = "COUNTRY",
#'           fixed = FALSE
#'         )
#'       ),
#'       ggplot2_args = teal.widgets::ggplot2_args(
#'         labs = list(subtitle = "Plot generated by Bivariate Module")
#'       )
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
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", "test"),
                           ggplot2_args = teal.widgets::ggplot2_args(),
                           pre_output = NULL,
                           post_output = NULL) {
  logger::log_info("Initializing tm_g_bivariate")
  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)

  checkmate::assert_list(x, types = "data_extract_spec")
  if (!all(vapply(x, function(x) !x$select$multiple, logical(1)))) {
    stop("'x' should not allow multiple selection")
  }
  checkmate::assert_list(y, types = "data_extract_spec")
  if (!all(vapply(y, function(x) !x$select$multiple, logical(1)))) {
    stop("'y' should not allow multiple selection")
  }
  checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE)
  if (!all(vapply(row_facet, function(x) !x$select$multiple, logical(1)))) {
    stop("'row_facet' should not allow multiple selection")
  }
  checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE)
  if (!all(vapply(col_facet, function(x) !x$select$multiple, logical(1)))) {
    stop("'col_facet' should not allow multiple selection")
  }
  checkmate::assert_list(color, types = "data_extract_spec", null.ok = TRUE)
  if (!all(vapply(color, function(x) !x$select$multiple, logical(1)))) {
    stop("'color' should not allow multiple selection")
  }
  checkmate::assert_list(fill, types = "data_extract_spec", null.ok = TRUE)
  if (!all(vapply(fill, function(x) !x$select$multiple, logical(1)))) {
    stop("'fill' should not allow multiple selection")
  }
  checkmate::assert_list(size, types = "data_extract_spec", null.ok = TRUE)
  if (!all(vapply(size, function(x) !x$select$multiple, logical(1)))) {
    stop("'size' should not allow multiple selection")
  }

  ggtheme <- match.arg(ggtheme)
  checkmate::assert_string(label)
  checkmate::assert_flag(use_density)
  checkmate::assert_flag(color_settings)
  checkmate::assert_flag(free_x_scales)
  checkmate::assert_flag(free_y_scales)
  checkmate::assert_flag(rotate_xaxis_labels)
  checkmate::assert_flag(swap_axes)
  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_class(ggplot2_args, "ggplot2_args")

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

  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_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 = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void", "test"),
            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
  )
}


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, "tdata")
  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,
      join_keys = get_join_keys(data)
    )

    anl_merged_q <- reactive({
      req(anl_merged_input())
      teal.code::new_qenv(tdata2env(data), code = get_code_tdata(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"]] # nolint
      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 # nolint
        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)], 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() #nolintr
            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) {
        card <- teal::TealReportCard$new()
        card$set_name("Bivariate Plot")
        card$append_text("Bivariate Plot", "header2")
        if (with_filter) card$append_fs(filter_panel_api$get_filter_state())
        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(paste(teal.code::get_code(output_q()), collapse = "\n"))
        card
      }
      teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
    }
    ###
  })
}


#' Get Substituted ggplot call
#'
#' @noRd
#'
#' @examples
#'
#' bivariate_plot_call("ANL", "BAGE", "RACE", "numeric", "factor")
#' bivariate_plot_call("ANL", "BAGE", character(0), "numeric", "NULL")
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")
  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
  )
}

substitute_q <- function(x, env) {
  stopifnot(is.language(x))
  call <- substitute(substitute(x, env), list(x = x))
  eval(call)
}


#' Create ggplot part of plot call
#'
#' Due to the type of the x and y variable the plot type is chosen
#'
#' @noRd
#'
#' @examples
#' bivariate_ggplot_call("numeric", "NULL")
#' bivariate_ggplot_call("numeric", "NULL", freq = FALSE)
#'
#' bivariate_ggplot_call("NULL", "numeric")
#' bivariate_ggplot_call("NULL", "numeric", freq = FALSE)
#'
#' bivariate_ggplot_call("NULL", "factor")
#' bivariate_ggplot_call("NULL", "factor", freq = FALSE)
#'
#' bivariate_ggplot_call("factor", "NULL")
#' bivariate_ggplot_call("factor", "NULL", freq = FALSE)
#'
#' bivariate_ggplot_call("numeric", "numeric")
#' bivariate_ggplot_call("numeric", "factor")
#' bivariate_ggplot_call("factor", "numeric")
#' bivariate_ggplot_call("factor", "factor")
bivariate_ggplot_call <- function(x_class = c("NULL", "numeric", "integer", "factor", "character", "logical"),
                                  y_class = c("NULL", "numeric", "integer", "factor", "character", "logical"),
                                  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 <- match.arg(x_class)
  y_class <- match.arg(y_class)

  if (x_class %in% c("character", "logical")) {
    x_class <- "factor"
  }
  if (x_class %in% c("integer")) {
    x_class <- "numeric"
  }
  if (y_class %in% c("character", "logical")) {
    y_class <- "factor"
  }
  if (y_class %in% c("integer")) {
    y_class <- "numeric"
  }

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

  return(plot_call)
}


#' Create facet call
#'
#' @noRd
#'
#' @examples
#'
#' facet_ggplot_call(LETTERS[1:3])
#' facet_ggplot_call(NULL, LETTERS[23:26])
#' facet_ggplot_call(LETTERS[1:3], LETTERS[23:26])
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
  }
}

#' Scatterplot and Regression Model
#' @md
#'
#' @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 alpha optional, (`numeric`) If scalar then the plot points will have a fixed opacity. If a
#'   slider should be presented to adjust the plot point opacity dynamically then it can be a vector of
#'   length three with `c(value, min, max)`.
#' @param size optional, (`numeric`) If scalar then the plot point sizes will have a fixed size
#'   If a slider should be presented to adjust the plot point sizes dynamically then it can be a
#'   vector of length three with `c(value, min, max)`.
#' @param default_outlier_label optional, (`character`) The default column selected to label outliers.
#' @param default_plot_type optional, (`numeric`) 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
#'
#' @templateVar ggnames `r regression_names`
#' @template ggplot2_args_multi
#'
#' @note For more examples, please see the vignette "Using regression plots" via
#'   `vignette("using-regression-plots", package = "teal.modules.general")`.
#' @export
#'
#' @examples
#' # Regression graphs from selected response variable (BMRKR1) and
#' # selected regressors (AGE)
#'
#' ADSL <- teal.modules.general::rADSL
#'
#' app <- teal::init(
#'   data = teal.data::cdisc_data(
#'     teal.data::cdisc_dataset("ADSL", ADSL, code = "ADSL <- teal.modules.general::rADSL"),
#'     check = TRUE
#'   ),
#'   modules = teal::modules(
#'     teal.modules.general::tm_a_regression(
#'       label = "Regression",
#'       response = teal.transform::data_extract_spec(
#'         dataname = "ADSL",
#'         select = teal.transform::select_spec(
#'           label = "Select variable:",
#'           choices = "BMRKR1",
#'           selected = "BMRKR1",
#'           multiple = FALSE,
#'           fixed = TRUE
#'         )
#'       ),
#'       regressor = teal.transform::data_extract_spec(
#'         dataname = "ADSL",
#'         select = teal.transform::select_spec(
#'           label = "Select variables:",
#'           choices = teal.transform::variable_choices(ADSL, c("AGE", "SEX", "RACE")),
#'           selected = "AGE",
#'           multiple = TRUE,
#'           fixed = FALSE
#'         )
#'       ),
#'       ggplot2_args = teal.widgets::ggplot2_args(
#'         labs = list(subtitle = "Plot generated by Regression Module")
#'       )
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
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", "test"
                            ),
                            ggplot2_args = teal.widgets::ggplot2_args(),
                            pre_output = NULL,
                            post_output = NULL,
                            default_plot_type = 1,
                            default_outlier_label = "USUBJID") {
  logger::log_info("Initializing tm_a_regression")
  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)

  checkmate::assert_string(label)
  checkmate::assert_list(response, types = "data_extract_spec")
  if (!all(vapply(response, function(x) !(x$select$multiple), logical(1)))) {
    stop("'response' should not allow multiple selection")
  }
  checkmate::assert_list(regressor, types = "data_extract_spec")
  ggtheme <- match.arg(ggtheme)
  checkmate::assert_string(default_outlier_label)
  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_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"
  )

  # Send 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_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),
          selectInput(
            inputId = ns("ggtheme"),
            label = "Theme (by ggplot):",
            choices = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void", "test"),
            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
  )
}


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, "tdata")
  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,
      join_keys = get_join_keys(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())
      teal.code::new_qenv(tdata2env(data), code = get_code_tdata(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"]] # nolint
      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)
      )
    })

    outlier_label <- reactive({
      substitute(
        expr = geom_text(label = label_col, hjust = 0, vjust = 1, color = "red"),
        env = list(label_col = label_col())
      )
    })

    output_q <- reactive({
      alpha <- input$alpha # nolint
      size <- input$size # nolint
      ggtheme <- input$ggtheme # nolint
      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"]] # nolint

        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 = "text",
                label = label_col %>%
                  data.frame(label = .) %>%
                  dplyr::filter(label != "cooksd == NaN") %>%
                  unlist(),
                hjust = 0,
                vjust = 1,
                color = "red"
              ),
            env = list(plot = plot, label_col = label_col())
          )
        }

        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) {
        card <- teal::TealReportCard$new()
        card$set_name("Linear Regression Plot")
        card$append_text("Linear Regression Plot", "header2")
        if (with_filter) card$append_fs(filter_panel_api$get_filter_state())
        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(paste(teal.code::get_code(output_q()), collapse = "\n"))
        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"'
)

#' Missing data module
#'
#' Present analysis of missing observations and patients.
#'
#' @inheritParams teal::module
#' @inheritParams shared_params
#' @param parent_dataname (`character(1)`) If this `dataname` exists in then "the by subject"graph is displayed.
#'   For `CDISC` data. In non `CDISC` data this can be ignored. Defaults to `"ADSL"`.
#' @param ggtheme optional, (`character`) `ggplot2` theme to be used by default.
#'   One of `c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void", "test")`.
#'   Each theme can be chosen by the user during the session. Defaults to `"classic"`.
#'
#' @templateVar ggnames "Summary Obs", "Summary Patients", "Combinations Main", "Combinations Hist", "By Subject"
#' @template ggplot2_args_multi
#'
#' @export
#'
#' @examples
#' library(nestcolor)
#'
#' ADSL <- teal.modules.general::rADSL
#' ADRS <- teal.modules.general::rADRS
#'
#' app <- teal::init(
#'   data = teal.data::cdisc_data(
#'     teal.data::cdisc_dataset("ADSL", ADSL, code = "ADSL <- teal.modules.general::rADSL"),
#'     teal.data::cdisc_dataset("ADRS", ADRS, code = "ADRS <- teal.modules.general::rADRS"),
#'     check = TRUE
#'   ),
#'   modules = teal::modules(
#'     teal.modules.general::tm_missing_data(
#'       ggplot2_args = list(
#'         "Combinations Hist" = teal.widgets::ggplot2_args(
#'           labs = list(subtitle = "Plot produced by Missing Data Module", caption = NULL)
#'         ),
#'         "Combinations Main" = teal.widgets::ggplot2_args(labs = list(title = NULL))
#'       )
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
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", "test"
                            ),
                            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) {
  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.")
  }
  logger::log_info("Initializing tm_missing_data")
  if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)

  checkmate::assert_string(label)
  checkmate::assert_character(parent_dataname, min.len = 0, max.len = 1)
  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("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))

  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
    ),
    ui = ui_page_missing_data,
    datanames = "all",
    ui_args = list(
      parent_dataname = parent_dataname, pre_output = pre_output,
      post_output = post_output, ggtheme = ggtheme
    )
  )
}

ui_page_missing_data <- function(id, data, parent_dataname, pre_output = NULL, post_output = NULL, ggtheme) {
  ns <- NS(id)
  datanames <- names(data)

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

  shiny::tagList(
    include_css_files("custom"),
    teal.widgets::standard_layout(
      output = teal.widgets::white_small_well(
        div(
          class = "flex",
          column(
            width = 12,
            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)
                        )
                      )
                    )
                  }
                )
              )
            )
          )
        )
      ),
      encoding = div(
        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
                )
              )
            }
          )
        )
      ),
      pre_output = pre_output,
      post_output = post_output
    )
  )
}

srv_page_missing_data <- function(id, data, reporter, filter_panel_api, parent_dataname,
                                  plot_height, plot_width, ggplot2_args) {
  moduleServer(id, function(input, output, session) {
    lapply(
      names(data),
      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_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
    )
  )
}

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 = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void", "test"),
        selected = ggtheme,
        multiple = FALSE
      )
    ),
    hr(),
    forms = tagList(
      teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
      teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
    ),
  )
}

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, "tdata")
  moduleServer(id, function(input, output, session) {
    prev_group_by_var <- reactiveVal("")
    data_r <- data[[dataname]]
    data_keys <- reactive(get_join_keys(data)$get(dataname)[[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 <- get_join_keys(data)$get(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 <- teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data))

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

      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]], # nolint
            env = list(group_var = group_var, anl_name = as.name(dataname))
          )
        )
      }

      new_col_name <- "**anyna**" # nolint variable assigned and used

      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, "]"))
              }
              return(labels)
            },
          env = list(
            new_col_name = new_col_name,
            column_labels_value = c(var_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**" # nolint (local variable is assigned and used)
        qenv <- teal.code::eval_code(
          qenv,
          substitute(
            expr = ANL[[new_col_name]] <- ifelse(rowSums(is.na(ANL)) > 0, NA, FALSE), # nolint
            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(tidyselect::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 = !tidyselect::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 # nolint (local variable is assigned and used)
      variables_select <- input$variables_select
      vars <- unique(variables_select, group_var)
      count_type <- input$count_type # nolint (local variable is assigned and used)

      if (!is.null(selected_vars()) && length(selected_vars()) != ncol(anl)) {
        variables <- selected_vars() # nolint (local variable is assigned and used)
      } 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(!tidyselect::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(tidyselect::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", -tidyselect::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", -tidyselect::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", -tidyselect::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) {
        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 = " - ")
        card$set_name(paste("Missing Data", sum_type, dataname, sep = " - "))
        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(paste(teal.code::get_code(final_q()), collapse = "\n"))
        card
      }
      teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
    }
    ###
  })
}

#' Create a simple cross-table
#' @md
#'
#' @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
#'  \code{data_extract_spec} must not allow multiple selection in this case.
#'
#' @param show_percentage optional, (`logical`) Whether to show percentages
#'   (relevant only when `x` is a `factor`). Defaults to `TRUE`.
#' @param show_total optional, (`logical`) 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")`.
#'
#' @export
#'
#' @examples
#' # Percentage cross table of variables from ADSL dataset
#'
#' ADSL <- teal.modules.general::rADSL
#'
#' app <- teal::init(
#'   data = teal.data::cdisc_data(
#'     teal.data::cdisc_dataset("ADSL", ADSL, code = "ADSL <- teal.modules.general::rADSL"),
#'     check = TRUE
#'   ),
#'   modules = teal::modules(
#'     teal.modules.general::tm_t_crosstable(
#'       label = "Cross Table",
#'       x = teal.transform::data_extract_spec(
#'         dataname = "ADSL",
#'         select = teal.transform::select_spec(
#'           label = "Select variable:",
#'           choices = variable_choices(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 = teal.transform::data_extract_spec(
#'         dataname = "ADSL",
#'         select = teal.transform::select_spec(
#'           label = "Select variable:",
#'           choices = variable_choices(ADSL, subset = function(data) {
#'             idx <- vapply(data, is.factor, logical(1))
#'             return(names(data)[idx])
#'           }),
#'           selected = "SEX",
#'           multiple = FALSE,
#'           fixed = FALSE
#'         )
#'       ),
#'       basic_table_args = teal.widgets::basic_table_args(
#'         subtitles = "Table generated by Crosstable Module"
#'       )
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
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")
  if (!requireNamespace("rtables", quietly = TRUE)) {
    stop("Cannot load rtables - please install the package or restart your session.")
  }
  if (inherits(x, "data_extract_spec")) x <- list(x)
  if (inherits(y, "data_extract_spec")) y <- list(y)

  checkmate::assert_string(label)
  checkmate::assert_list(x, types = "data_extract_spec")
  checkmate::assert_list(y, types = "data_extract_spec")
  if (any(vapply(y, function(x) x$select$multiple, logical(1)))) {
    stop("'y' should not allow multiple selection")
  }
  checkmate::assert_flag(show_percentage)
  checkmate::assert_flag(show_total)
  checkmate::assert_class(basic_table_args, classes = "basic_table_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_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
  )
}

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, "tdata")
  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,
      join_keys = get_join_keys(data),
      selector_list = selector_list,
      merge_function = merge_function
    )

    anl_merged_q <- reactive({
      req(anl_merged_input())
      teal.code::new_qenv(tdata2env(data), code = get_code_tdata(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"]] # nolint

      # 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 # nolint
      show_total <- input$show_total # nolint

      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::summarize_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) # nolint
              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) {
        card <- teal::TealReportCard$new()
        card$set_name("Cross Table")
        card$append_text("Cross Table", "header2")
        if (with_filter) card$append_fs(filter_panel_api$get_filter_state())
        card$append_text("Table", "header3")
        card$append_table(table_r())
        if (!comment == "") {
          card$append_text("Comment", "header3")
          card$append_text(comment)
        }
        card$append_src(paste(teal.code::get_code(output_q()), collapse = "\n"))
        card
      }
      teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
    }
    ###
  })
}

#' Response Plots
#' @md
#'
#' @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 using the
#'   setting `fixed = TRUE` inside the `select_spec`.
#'  `data_extract_spec` must not allow multiple selection in this case.
#' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`)
#'   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.
#'  `data_extract_spec` must not allow multiple selection in this case.
#' @param row_facet optional, (`data_extract_spec` or `list` of multiple `data_extract_spec`)
#'   Which data columns to use for faceting rows.
#' @param col_facet optional, (`data_extract_spec` or `list` of multiple `data_extract_spec`)
#'   Which data to use for faceting columns.
#' @param coord_flip optional, (`logical`) Whether to flip coordinates between `x` and `response`.
#' @param count_labels optional, (`logical`) Whether to show count labels.
#'   Defaults to `TRUE`.
#' @param freq optional, (`logical`) Whether to display frequency (`TRUE`) or density (`FALSE`).
#'   Defaults to density (`FALSE`).
#'
#' @note For more examples, please see the vignette "Using response plot" via
#'   \code{vignette("using-response-plot", package = "teal.modules.general")}.
#' @export
#' @examples
#' # Response plot with selected response (BMRKR1) and selected x variable (RACE)
#' library(nestcolor)
#'
#' ADSL <- teal.modules.general::rADSL
#'
#' app <- teal::init(
#'   data = teal.data::cdisc_data(
#'     teal.data::cdisc_dataset("ADSL", ADSL, code = "ADSL <- teal.modules.general::rADSL"),
#'     check = TRUE
#'   ),
#'   modules = teal::modules(
#'     teal.modules.general::tm_g_response(
#'       label = "Response Plots",
#'       response = teal.transform::data_extract_spec(
#'         dataname = "ADSL",
#'         select = teal.transform::select_spec(
#'           label = "Select variable:",
#'           choices = teal.transform::variable_choices(ADSL, c("BMRKR2", "COUNTRY")),
#'           selected = "BMRKR2",
#'           multiple = FALSE,
#'           fixed = FALSE
#'         )
#'       ),
#'       x = teal.transform::data_extract_spec(
#'         dataname = "ADSL",
#'         select = teal.transform::select_spec(
#'           label = "Select variable:",
#'           choices = teal.transform::variable_choices(ADSL, c("SEX", "RACE")),
#'           selected = "RACE",
#'           multiple = FALSE,
#'           fixed = FALSE
#'         )
#'       ),
#'       ggplot2_args = teal.widgets::ggplot2_args(
#'         labs = list(subtitle = "Plot generated by Response Module")
#'       )
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
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", "test"),
                          ggplot2_args = teal.widgets::ggplot2_args(),
                          pre_output = NULL,
                          post_output = NULL) {
  logger::log_info("Initializing tm_g_response")
  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)
  checkmate::assert_string(label)
  ggtheme <- match.arg(ggtheme)
  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")
  }
  if (!all(vapply(response, function(x) !x$select$multiple, logical(1)))) {
    stop("'response' should not allow multiple selection")
  }
  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")
  }
  if (!all(vapply(x, function(x) !x$select$multiple, logical(1)))) {
    stop("'x' should not allow multiple selection")
  }
  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"
  )

  checkmate::assert_class(ggplot2_args, "ggplot2_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_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 = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void", "test"),
            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
  )
}

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, "tdata")
  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) {
        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,
      join_keys = get_join_keys(data)
    )

    anl_merged_q <- reactive({
      req(anl_merged_input())
      teal.code::new_qenv(tdata2env(data), code = get_code_tdata(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"]] # nolint
      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" # nolint

      rowf <- if (length(row_facet_name) == 0) NULL else as.name(row_facet_name) # nolint
      colf <- if (length(col_facet_name) == 0) NULL else as.name(col_facet_name) # nolint
      resp_cl <- as.name(resp_var) # nolint
      x_cl <- as.name(x) # nolint

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

      qenv <- teal.code::eval_code(
        qenv,
        substitute(
          expr = ANL[[resp_var]] <- factor(ANL[[resp_var]]), # nolint
          env = list(resp_var = resp_var)
        )
      ) %>%
        # nolint start
        # 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)
          )
        )
      # nolint end

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

      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) {
        card <- teal::TealReportCard$new()
        card$set_name("Response Plot")
        card$append_text("Response Plot", "header2")
        if (with_filter) card$append_fs(filter_panel_api$get_filter_state())
        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(paste(teal.code::get_code(output_q()), collapse = "\n"))
        card
      }
      teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
    }
    ###
  })
}

#' Principal component analysis module
#' @md
#'
#' @inheritParams teal::module
#' @inheritParams shared_params
#' @param dat (`data_extract_spec` or `list` of multiple `data_extract_spec`)
#'   Columns used to compute PCA.
#' @param alpha optional, (`numeric`) If scalar then the plot points will have a fixed opacity. If a
#'   slider should be presented to adjust the plot point opacity dynamically then it can be a vector of
#'   length three with `c(value, min, max)`.
#' @param size optional, (`numeric`) If scalar then the plot point sizes will have a fixed size.
#'   If a slider should be presented to adjust the plot point sizes dynamically then it can be a
#'   vector of length three with `c(value, min, max)`.
#' @param font_size optional, (`numeric`) font size control for title, x-axis label, y-axis label and legend.
#'   If scalar then the font size will have a fixed size. If a slider should be presented to adjust the plot
#'   point sizes dynamically then it can be a vector of length three with `c(value, min, max)`.
#'
#' @templateVar ggnames "Elbow plot", "Circle plot", "Biplot", "Eigenvector plot"
#' @template ggplot2_args_multi
#'
#' @export
#'
#' @examples
#'
#' # ADSL example
#'
#' library(nestcolor)
#' ADSL <- teal.modules.general::rADSL
#'
#' app <- teal::init(
#'   data = teal.data::cdisc_data(
#'     teal.data::cdisc_dataset(
#'       "ADSL", ADSL,
#'       code = "ADSL <- teal.modules.general::rADSL"
#'     ),
#'     check = TRUE
#'   ),
#'   modules = teal::modules(
#'     teal.modules.general::tm_a_pca(
#'       "PCA",
#'       dat = teal.transform::data_extract_spec(
#'         dataname = "ADSL",
#'         select = teal.transform::select_spec(
#'           choices = teal.transform::variable_choices(data = ADSL, c("BMRKR1", "AGE", "EOSDY")),
#'           selected = c("BMRKR1", "AGE"),
#'           multiple = TRUE
#'         ),
#'         filter = NULL
#'       ),
#'       ggplot2_args = teal.widgets::ggplot2_args(
#'         labs = list(subtitle = "Plot generated by PCA Module")
#'       )
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
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", "test"),
                     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")
  if (inherits(dat, "data_extract_spec")) dat <- list(dat)
  if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)

  checkmate::assert_string(label)
  checkmate::assert_list(dat, types = "data_extract_spec")
  ggtheme <- match.arg(ggtheme)
  checkmate::assert_flag(rotate_xaxis_labels)

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

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

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

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

  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_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 = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void", "test"),
              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
    )
  )
}

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, "tdata")
  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
      response[[i]]$select$choices <- var_labels(data[[response[[i]]$dataname]]())
      response[[i]]$select$choices <- setdiff(
        response[[i]]$select$choices,
        unlist(get_join_keys(data)$get(response[[i]]$dataname))
      )
    }

    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,
      join_keys = get_join_keys(data)
    )

    anl_merged_q <- reactive({
      req(anl_merged_input())
      teal.code::new_qenv(tdata2env(data), code = get_code_tdata(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") # nolint
      scale <- standardization == "center_scale"
      ANL <- merged$anl_q_r()[["ANL"]] # nolint

      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") # nolint
      scale <- standardization == "center_scale"
      ANL <- merged$anl_q_r()[["ANL"]] # nolint

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

      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 # nolint
      font_size <- input$font_size # nolint

      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 # nolint
      y_axis <- input$y_axis # nolint
      variables <- input$variables # nolint
      ggtheme <- input$ggtheme

      rotate_xaxis_labels <- input$rotate_xaxis_labels # nolint
      font_size <- input$font_size # nolint

      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"]] # nolint

      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 # nolint
      y_axis <- input$y_axis # nolint
      variables <- input$variables # nolint
      pca <- qenv[["pca"]]

      ggtheme <- input$ggtheme

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

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

        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
            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 # nolint
      ggtheme <- input$ggtheme

      rotate_xaxis_labels <- input$rotate_xaxis_labels # nolint
      font_size <- input$font_size # nolint

      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) {
        card <- teal::TealReportCard$new()
        card$set_name("PCA Plot")
        card$append_text("PCA Plot", "header2")
        card$append_text("Principal Component Analysis Plot", "header3")
        if (with_filter) card$append_fs(filter_panel_api$get_filter_state())
        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(paste(teal.code::get_code(output_q()), collapse = "\n"))
        card
      }
      teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
    }
    ###
  })
}

#' Distribution Module
#' @md
#'
#' @details
#' Module to analyze and explore univariate variable 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 to consider for the distribution analysis.
#' @param strata_var (`data_extract_spec` or `list` of multiple `data_extract_spec`)
#'   Categorical variable to split the selected distribution variable on.
#' @param group_var  optional, (`data_extract_spec` or `list` of multiple `data_extract_spec`)
#'   Which data columns to use for faceting rows.
#' @param freq optional, (`logical`) Whether to display frequency (`TRUE`) or density (`FALSE`).
#'   Defaults to density (`FALSE`).
#' @param bins optional, (`integer(1)` or `integer(3)`) If scalar then the histogram bins will have a fixed size.
#'   If a slider should be presented to adjust the number of histogram bins dynamically then it can be a
#'   vector of length three with `c(value, min, max)`.
#'   Defaults to `c(30L, 1L, 100L)`.
#'
#' @templateVar ggnames "Histogram", "QQplot"
#' @template ggplot2_args_multi
#'
#'
#' @export
#'
#' @examples
#' # Example with non-clinical data
#' app <- teal::init(
#'   data = teal_data(dataset("iris", iris)),
#'   modules = list(
#'     teal.modules.general::tm_g_distribution(
#'       dist_var = teal.transform::data_extract_spec(
#'         dataname = "iris",
#'         select = teal.transform::select_spec(variable_choices("iris"), "Petal.Length")
#'       ),
#'       ggplot2_args = teal.widgets::ggplot2_args(
#'         labs = list(subtitle = "Plot generated by Distribution Module")
#'       )
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
#' # Example with clinical data
#' ADSL <- teal.modules.general::rADSL
#'
#' vars1 <- choices_selected(variable_choices(ADSL, c("ARM", "COUNTRY", "SEX")), selected = NULL)
#'
#' app <- teal::init(
#'   data = teal.data::cdisc_data(
#'     teal.data::cdisc_dataset("ADSL", ADSL),
#'     code = "ADSL <- teal.modules.general::rADSL",
#'     check = FALSE
#'   ),
#'   modules = teal::modules(
#'     teal.modules.general::tm_g_distribution(
#'       dist_var = teal.transform::data_extract_spec(
#'         dataname = "ADSL",
#'         select = teal.transform::select_spec(
#'           choices = teal.transform::variable_choices(ADSL, c("AGE", "BMRKR1")),
#'           selected = "BMRKR1",
#'           multiple = FALSE,
#'           fixed = FALSE
#'         )
#'       ),
#'       strata_var = teal.transform::data_extract_spec(
#'         dataname = "ADSL",
#'         filter = teal.transform::filter_spec(
#'           vars = vars1,
#'           multiple = TRUE
#'         )
#'       ),
#'       group_var = teal.transform::data_extract_spec(
#'         dataname = "ADSL",
#'         filter = teal.transform::filter_spec(
#'           vars = vars1,
#'           multiple = TRUE
#'         )
#'       ),
#'       ggplot2_args = teal.widgets::ggplot2_args(
#'         labs = list(subtitle = "Plot generated by Distribution Module")
#'       )
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
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", "test"
                              ),
                              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")

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

  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)

  ggtheme <- match.arg(ggtheme)
  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_string(label)
  checkmate::assert_list(dist_var, "data_extract_spec")
  checkmate::assert_false(dist_var[[1]]$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)
  plot_choices <- c("Histogram", "QQplot")
  checkmate::assert_list(ggplot2_args, types = "ggplot2_args")
  checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))

  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_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 = tagList(
      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 = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void", "test"),
          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
  )
}

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, "tdata")
  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,
      join_keys = get_join_keys(data)
    )

    anl_merged_q <- reactive({
      req(anl_merged_input())
      teal.code::new_qenv(tdata2env(data), code = get_code_tdata(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)]] # nolint
          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"]] # nolint
      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"), # nolint
            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"), # nolint
            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()
                )
            },
            env = list(
              dist_var_name = dist_var_name,
              strata_vars_raw = c(g_var, s_var),
              roundn = roundn
            )
          )
        )
      }

      qenv
    })

    # 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"]] # nolint

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

    # 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) {
        card <- teal::TealReportCard$new()
        card$set_name("Distribution Plot")
        card$append_text("Distribution Plot", "header2")
        if (with_filter) card$append_fs(filter_panel_api$get_filter_state())
        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(paste(teal.code::get_code(output_q()), collapse = "\n"))
        card
      }
      teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
    }
    ###
  })
}

#' Create a scatterplot matrix
#'
#' The available datasets to choose from for each dataset selector is the same and
#' determined by the argument `variables`.
#' @md
#'
#' @inheritParams teal::module
#' @inheritParams tm_g_scatterplot
#' @inheritParams shared_params
#'
#' @param variables (`data_extract_spec` or `list` of multiple `data_extract_spec`)
#'  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.
#'
#' @note For more examples, please see the vignette "Using scatterplot matrix" via
#'   \code{vignette("using-scatterplot-matrix", package = "teal.modules.general")}.
#' @export
#'
#' @examples
#' # Scatterplot matrix of variables from ADSL dataset
#'
#' ADSL <- teal.modules.general::rADSL
#' ADRS <- teal.modules.general::rADRS
#'
#' app <- teal::init(
#'   data = teal.data::cdisc_data(
#'     teal.data::cdisc_dataset("ADSL", ADSL, code = "ADSL <- teal.modules.general::rADSL"),
#'     teal.data::cdisc_dataset("ADRS", ADRS, code = "ADRS <- teal.modules.general::rADRS"),
#'     check = TRUE
#'   ),
#'   modules = teal::modules(
#'     teal.modules.general::tm_g_scatterplotmatrix(
#'       label = "Scatterplot matrix",
#'       variables = list(
#'         teal.transform::data_extract_spec(
#'           dataname = "ADSL",
#'           select = select_spec(
#'             label = "Select variables:",
#'             choices = variable_choices(ADSL),
#'             selected = c("AGE", "RACE", "SEX"),
#'             multiple = TRUE,
#'             ordered = TRUE,
#'             fixed = FALSE
#'           )
#'         ),
#'         teal.transform::data_extract_spec(
#'           dataname = "ADRS",
#'           filter = teal.transform::filter_spec(
#'             label = "Select endpoints:",
#'             vars = c("PARAMCD", "AVISIT"),
#'             choices = value_choices(ADRS, c("PARAMCD", "AVISIT"), c("PARAM", "AVISIT")),
#'             selected = "INVET - END OF INDUCTION",
#'             multiple = TRUE
#'           ),
#'           select = select_spec(
#'             label = "Select variables:",
#'             choices = variable_choices(ADRS),
#'             selected = c("AGE", "AVAL", "ADY"),
#'             multiple = TRUE,
#'             ordered = TRUE,
#'             fixed = FALSE
#'           )
#'         )
#'       )
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
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")
  if (!requireNamespace("lattice", quietly = TRUE)) {
    stop("Cannot load lattice - please install the package or restart your session.")
  }
  if (inherits(variables, "data_extract_spec")) variables <- list(variables)

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

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

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, "tdata")
  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,
      join_keys = get_join_keys(data),
      selector_list = selector_list
    )

    anl_merged_q <- reactive({
      req(anl_merged_input())
      teal.code::new_qenv(tdata2env(data), code = get_code_tdata(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"]] # nolint

      cols_names <- merged$anl_input_r()$columns_source$variables
      alpha <- input$alpha # nolint
      cex <- input$cex # nolint
      add_cor <- input$cor # nolint
      cor_method <- input$cor_method # nolint
      cor_na_omit <- input$cor_na_omit # nolint

      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], 10, complete = TRUE, allow_inf = FALSE)

      # get labels and proper variable names
      varnames <- varname_w_label(cols_names, ANL, wrap_width = 20) # nolint

      # 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] %>% # nolint
              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] %>% # nolint
              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"]] # nolint
      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) {
        card <- teal::TealReportCard$new()
        card$set_name("Scatter Plot Matrix")
        card$append_text("Scatter Plot Matrix", "header2")
        if (with_filter) card$append_fs(filter_panel_api$get_filter_state())
        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(paste(teal.code::get_code(output_q()), collapse = "\n"))
        card
      }
      teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
    }
    ###
  })
}

#' Get stats for x-y pairs in scatterplot matrix
#' @description 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 \code{lattice::panel.text}.
#' @param x \code{numeric}
#' @param y \code{numeric}
#' @param .f \code{function}, function that accepts x and y as formula input \code{~ x + y}.
#' Default \code{stats::cor.test}
#' @param .f_args \code{list} of arguments to be passed to \code{.f}
#' @param round_stat \code{integer}
#' @param round_pval \code{integer}
#' @details presently we need to use a formula input for \code{stats::cor.test} because
#' \code{na.fail} only gets evaluated when a formula is passed (see below).
#' \preformatted{
#' 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")
#' }
#' @return \code{character} with stats. For \code{stats::cor.test} correlation coefficient and p-value.
#' @export
#' @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
#' ))
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("-")
  }
}

#' Create a simple scatterplot
#'
#' Create a plot with the \code{\link{ggplot2}[geom_point]} function
#' @md
#'
#' @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.
#' @param y (`data_extract_spec` or `list` of multiple `data_extract_spec`) Variable
#'   names selected to plot along the y-axis by default.
#' @param color_by optional (`data_extract_spec` or `list` of multiple `data_extract_spec`)
#'   Defines the color encoding. If `NULL` then no color encoding option will be displayed.
#' @param size_by optional (`data_extract_spec` or `list` of multiple `data_extract_spec`)
#'   Defines the point size encoding. If `NULL` then no size encoding option will be displayed.
#' @param row_facet optional, (`data_extract_spec` or `list` of multiple `data_extract_spec`)
#'   Which data columns to use for faceting rows.
#' @param col_facet optional, (`data_extract_spec` or `list` of multiple `data_extract_spec`)
#'   Which data to use for faceting columns.
#' @param alpha optional, (`numeric`) If scalar then the plot points will have a fixed opacity. If a
#'   slider should be presented to adjust the plot point opacity dynamically then it can be a vector of
#'   length three with `c(value, min, max)`.
#' @param size optional, (`numeric`) If scalar then the plot point sizes will have a fixed size
#'   If a slider should be presented to adjust the plot point sizes dynamically then it can be a
#'   vector of length three with `c(value, min, max)`.
#' @param shape optional, (`character`) A character vector with the English 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 optional, (`integer`) The maximum degree for the polynomial trend line. Must not be less than 1.
#' @param table_dec optional, (`integer`) Number of decimal places used to round numeric values in the table.
#'
#'
#' @note For more examples, please see the vignette "Using scatterplot" via
#'   `vignette("using-scatterplot", package = "teal.modules.general")`.
#'
#' @export
#' @examples
#' # Scatterplot of variables from ADSL dataset
#' library(nestcolor)
#'
#' ADSL <- teal.modules.general::rADSL
#'
#' app <- teal::init(
#'   data = teal.data::cdisc_data(
#'     teal.data::cdisc_dataset("ADSL", ADSL, code = "ADSL <- teal.modules.general::rADSL"),
#'     check = TRUE
#'   ),
#'   modules = teal::modules(
#'     teal.modules.general::tm_g_scatterplot(
#'       label = "Scatterplot Choices",
#'       x = teal.transform::data_extract_spec(
#'         dataname = "ADSL",
#'         select = teal.transform::select_spec(
#'           label = "Select variable:",
#'           choices = teal.transform::variable_choices(
#'             ADSL,
#'             c("AGE", "BMRKR1", "BMRKR2")
#'           ),
#'           selected = "AGE",
#'           multiple = FALSE,
#'           fixed = FALSE
#'         )
#'       ),
#'       y = teal.transform::data_extract_spec(
#'         dataname = "ADSL",
#'         select = teal.transform::select_spec(
#'           label = "Select variable:",
#'           choices = teal.transform::variable_choices(
#'             ADSL,
#'             c("AGE", "BMRKR1", "BMRKR2")
#'           ),
#'           selected = "BMRKR1",
#'           multiple = FALSE,
#'           fixed = FALSE
#'         )
#'       ),
#'       color_by = teal.transform::data_extract_spec(
#'         dataname = "ADSL",
#'         select = teal.transform::select_spec(
#'           label = "Select variable:",
#'           choices = teal.transform::variable_choices(
#'             ADSL,
#'             c("AGE", "BMRKR1", "BMRKR2", "RACE", "REGION1")
#'           ),
#'           selected = NULL,
#'           multiple = FALSE,
#'           fixed = FALSE
#'         )
#'       ),
#'       size_by = teal.transform::data_extract_spec(
#'         dataname = "ADSL",
#'         select = teal.transform::select_spec(
#'           label = "Select variable:",
#'           choices = teal.transform::variable_choices(
#'             ADSL,
#'             c("AGE", "BMRKR1", "BMRKR2", "RACE", "REGION1")
#'           ),
#'           selected = "AGE",
#'           multiple = FALSE,
#'           fixed = FALSE
#'         )
#'       ),
#'       row_facet = teal.transform::data_extract_spec(
#'         dataname = "ADSL",
#'         select = teal.transform::select_spec(
#'           label = "Select variable:",
#'           choices = teal.transform::variable_choices(
#'             ADSL,
#'             c("BMRKR2", "RACE", "REGION1")
#'           ),
#'           selected = NULL,
#'           multiple = FALSE,
#'           fixed = FALSE
#'         )
#'       ),
#'       col_facet = teal.transform::data_extract_spec(
#'         dataname = "ADSL",
#'         select = teal.transform::select_spec(
#'           label = "Select variable:",
#'           choices = teal.transform::variable_choices(
#'             ADSL,
#'             c("BMRKR2", "RACE", "REGION1")
#'           ),
#'           selected = NULL,
#'           multiple = FALSE,
#'           fixed = FALSE
#'         )
#'       ),
#'       ggplot2_args = teal.widgets::ggplot2_args(
#'         labs = list(subtitle = "Plot generated by Scatterplot Module")
#'       )
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
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", "test"
                             ),
                             pre_output = NULL,
                             post_output = NULL,
                             table_dec = 4,
                             ggplot2_args = teal.widgets::ggplot2_args()) {
  logger::log_info("Initializing tm_g_scatterplot")

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

  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)

  ggtheme <- match.arg(ggtheme)
  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)
  checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE)
  checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE)
  if (!all(vapply(row_facet, function(x) !x$select$multiple, logical(1)))) {
    stop("'row_facet' should not allow multiple selection")
  }
  if (!all(vapply(col_facet, function(x) !x$select$multiple, logical(1)))) {
    stop("'col_facet' should not allow multiple selection")
  }
  checkmate::assert_character(shape)

  checkmate::assert_int(max_deg, lower = 1L)
  checkmate::assert_scalar(table_dec)
  checkmate::assert_flag(rotate_xaxis_labels)
  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")
  }

  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_class(ggplot2_args, "ggplot2_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_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 = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void", "test"),
              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
    )
  )
}

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, "tdata")
  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,
      join_keys = get_join_keys(data),
      merge_function = "dplyr::inner_join"
    )

    anl_merged_q <- reactive({
      req(anl_merged_input())
      teal.code::new_qenv(tdata2env(data), code = get_code_tdata(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
    )

    trend_line_is_applicable <- reactive({
      ANL <- merged$anl_q_r()[["ANL"]] # nolint
      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"]] # nolint
        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"]] # nolint

      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 # nolint
      size <- input$size # nolint
      rotate_xaxis_labels <- input$rotate_xaxis_labels # nolint
      add_density <- input$add_density
      ggtheme <- input$ggtheme
      rug_plot <- input$rug_plot
      color <- input$color # nolint
      shape <- `if`(is.null(input$shape) || identical(input$shape, ""), "circle", input$shape) # nolint
      smoothing_degree <- as.integer(input$smoothing_degree)
      ci <- input$ci # nolint

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

      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) {
        card <- teal::TealReportCard$new()
        card$set_name("Scatter Plot")
        card$append_text("Scatter Plot", "header2")
        if (with_filter) card$append_fs(filter_panel_api$get_filter_state())
        card$append_text("Plot", "header3")
        card$append_plot(plot_r(), dim = pws$dim())
        if (!comment == "") {
          card$append_text("Comment", "header3")
          card$append_text(comment)
        }
        card$append_src(paste(teal.code::get_code(output_q()), collapse = "\n"))
        card
      }
      teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
    }
    ###
  })
}

#' Front page module
#'
#' @description This `teal` module creates a simple front page for `teal` applications
#'
#' @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 dataframes` 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` 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` should the metadata of the datasets be available on the module?
#' @return A `teal` module to be used in `teal` applications
#' @export
#' @examples
#'
#' 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
#' )
#'
#' ADSL <- teal.modules.general::rADSL
#' app <- teal::init(
#'   data = teal.data::cdisc_data(
#'     teal.data::cdisc_dataset("ADSL", ADSL,
#'       code = "ADSL <- teal.modules.general::rADSL",
#'       metadata = list("Author" = "NEST team", "data_source" = "synthetic data")
#'     ),
#'     check = TRUE
#'   ),
#'   modules = teal::modules(
#'     teal.modules.general::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)
#' }
tm_front_page <- function(label = "Front page",
                          header_text = character(0),
                          tables = list(),
                          additional_tags = tagList(),
                          footnotes = character(0),
                          show_metadata = FALSE) {
  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)

  logger::log_info("Initializing tm_front_page")
  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_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)
      )
    )
  )
}

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

srv_front_page <- function(id, data, tables, show_metadata) {
  checkmate::assert_class(data, "tdata")
  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({
        convert_metadata_to_dataframe(
          lapply(names(data), function(dataname) get_metadata(data, dataname)),
          names(data)
        )
      })

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

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

#' File Viewer Teal Module
#'
#' The file viewer module provides a tool to view static files.
#' Supported formats include text formats, \code{PDF}, \code{PNG}, \code{APNG},
#' \code{JPEG}, \code{SVG}, \code{WEBP}, \code{GIF} and \code{BMP}.
#'
#' @inheritParams teal::module
#' @inheritParams shared_params
#' @param input_path optional, (`list`) of the input paths to either: specific files of accepted formats,
#'   a directory or a URL. The paths can be specified as absolute paths or relative to the running
#'   directory of the application. Will default to current working directory if not supplied.
#'
#' @export
#'
#' @examples
#' data <- data.frame(1)
#' app <- teal::init(
#'   data = teal_data(
#'     dataset("data", data)
#'   ),
#'   modules = teal::modules(
#'     teal.modules.general::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://www.fda.gov/files/drugs/published/Portable-Document-Format-Specifications.pdf"
#'       )
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
tm_file_viewer <- function(label = "File Viewer Module",
                           input_path = list("Current Working Directory" = ".")) {
  logger::log_info("Initializing tm_file_viewer")
  if (length(label) == 0 || identical(label, "")) {
    label <- " "
  }
  if (length(input_path) == 0 || identical(input_path, "")) {
    input_path <- list()
  }

  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)
      ifelse(is.null(check), TRUE, FALSE)
    }
    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."
    )
  }


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

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

#' Shared Parameters
#'
#' @description Contains arguments that are shared between multiple functions
#'   in the package to avoid repetition using `inheritParams`.
#'
#' @param plot_height optional, (`numeric`) A vector of length three with `c(value, min and max)`
#'   for a slider encoding the plot height.
#' @param plot_width optional, (`numeric`) A vector of length three with `c(value, min and max)`
#'   for a slider encoding the plot width.
#' @param rotate_xaxis_labels optional, (`logical`) Whether to rotate plot X axis labels. Does not
#'   rotate by default (`FALSE`).
#' @param ggtheme optional, (`character`) `ggplot2` theme to be used by default.
#'   One of `c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void", "test")`.
#'   Each theme can be chosen by the user during the session. 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)\cr
#'  with text placed before the output to put the output into context. For example a title.
#' @param post_output (`shiny.tag`, optional) with text placed after the output to put the output
#' into context. For example the [shiny::helpText()] elements are useful.
#'
#' @name shared_params
#' @keywords internal
NULL

#' Add axis labels that show facetting variable
#'
#' Add axis labels that show facetting variable
#'
#' @param p `ggplot2` object to add facet labels to
#' @param xfacet_label label of facet along x axis (nothing created if NULL),
#'   if vector, will be concatenated with " & "
#' @param yfacet_label label of facet along y axis (nothing created if NULL),
#'   if vector, will be concatenated with " & "
#'
#' @return grid grob object (to be drawn with \code{grid.draw})
#'
#' @export
#'
#' @examples
#' # we put donttest to avoid strictr error with seq along.with argument
#' \donttest{
#' library(ggplot2)
#' library(grid)
#'
#' p <- ggplot(mtcars) +
#'   aes(x = mpg, y = disp) +
#'   geom_point() +
#'   facet_grid(gear ~ cyl)
#' p
#' 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))
#' }
#'
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 \code{...} argument
#'
#' @param fun (\code{character}) Name of a function where the \code{...} argument
#'   shall be replaced by values from \code{str_args}.
#' @param str_args (\code{character}) A character vector that the function shall
#'  be executed with
#'
#' @return: call (i.e. expression) of the function provided by \code{fun}
#'  with arguments provided by \code{str_args}.
#' @keywords internal
#'
#' @examples
#' \dontrun{
#' a <- 1
#' b <- 2
#' call_fun_dots("sum", c("a", "b"))
#' eval(call_fun_dots("sum", c("a", "b")))
#' }
call_fun_dots <- function(fun, str_args) {
  do.call("call", c(list(fun), lapply(str_args, as.name)), quote = TRUE)
}

#' Get variable name with label
#'
#' @param var_names (\code{character}) Name of variable to extract labels from.
#' @param dataset (\code{dataset}) Name of analysis dataset.
#' @param prefix (\code{character}) String to paste to the beginning of the
#'   variable name with label.
#' @param suffix (\code{character}) String to paste to the end of the variable
#'   name with label.
#' @param wrap_width (\code{numeric}) Number of characters to wrap original
#'   label to. Defaults to 80.
#'
#' @return (\code{character}) String with variable name and label.
#' @keywords internal
#'
#' @examples
#' \dontrun{
#' ADSL <- teal.modules.general::rADSL
#'
#' varname_w_label("AGE", ADSL)
#' }
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)
  }
}

#' Extract html id for `data_extract_ui`
#' @description The `data_extract_ui` is located under extended html id.
#'   We could not use \code{ns("original id")} for reference, as it is extended with specific suffixes.
#' @param varname character original html id.
#'   This will be mostly retrieved with \code{ns("original id")} in `ui` or
#'   \code{session$ns("original id")} in server function.
#' @param dataname character \code{dataname} from data_extract input.
#'   This might be retrieved like \code{teal.transform::data_extract_spec(...)[[1]]$dataname}.
#' @param filter logical if the connected \code{extract_data_spec} is used with \code{filter} option.
#' @keywords internal
extract_input <- function(varname, dataname, filter = FALSE) {
  if (filter) {
    paste0(varname, "-dataset_", dataname, "_singleextract-filter1-vals")
  } else {
    paste0(varname, "-dataset_", dataname, "_singleextract-select")
  }
}

# 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`)\cr
#'  of R internal types (classes).
#'
#' @return (`character`)\cr
#'  vector of HTML icons corresponding to data type in each column.
#' @keywords internal
#'
#' @examples
#' teal.modules.general:::variable_type_icons(c(
#'   "integer", "numeric", "logical", "Date", "POSIXct", "POSIXlt",
#'   "factor", "character", "unknown", ""
#' ))
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")))

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

  return(res)
}

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


#' Get Label Attributes of Variables in a \code{data.frame}
#'
#' Variable labels can be stored as a \code{label} attribute for each variable.
#' This functions returns a named character vector with the variable labels
#' (empty sting if not specified)
#'
#' @param x a \code{data.frame} object
#' @param fill boolean in case the \code{label} attribute does not exist if
#'   \code{TRUE} the variable names is returned, otherwise \code{NA}
#'
#' @return a named character vector with the variable labels, the names
#'   correspond to the variable names
#'
#' @note the `formatters` package is the source of the function.
#'
#' @keywords internal
var_labels <- function(x, fill = FALSE) {
  stopifnot(is.data.frame(x))
  if (NCOL(x) == 0) {
    return(character())
  }

  y <- Map(function(col, colname) {
    label <- attr(col, "label")

    if (is.null(label)) {
      if (fill) {
        colname
      } else {
        NA_character_
      }
    } else {
      if (!is.character(label) && !(length(label) == 1)) {
        stop("label for variable ", colname, "is not a character string")
      }
      as.vector(label)
    }
  }, x, colnames(x))

  labels <- unlist(y, recursive = FALSE, use.names = TRUE)

  if (!is.character(labels)) {
    stop("label extraction failed")
  }

  labels
}

#' Get a string with java-script code checking if the specific tab is clicked
#' @description will be the input for `shiny::conditionalPanel()`
#' @param id `character(1)` the id of the tab panel with tabs.
#' @param name `character(1)` the name of the tab.
#' @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
  )
}

#' Stack Plots of variables and show association with reference variable
#' @md
#'
#' @inheritParams teal::module
#' @inheritParams shared_params
#' @param ref (`data_extract_spec` or `list` of multiple `data_extract_spec`)
#'   reference variable, must set `multiple = FALSE`.
#' @param vars (`data_extract_spec` or `list` of multiple `data_extract_spec`)
#'   associated variables.
#' @param show_association optional, (`logical`) Whether show association of `vars`
#'   with reference variable. Defaults to `TRUE`.
#' @param distribution_theme optional, (`character`) `ggplot2` theme to be used by default.
#'   One of `c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void", "test")`.
#'   Each theme can be chosen by the user during the session. Defaults to `"gray"`.
#' @param association_theme optional, (`character`) `ggplot2` theme to be used by default.
#'   One of `c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void", "test")`.
#'   Each theme can be chosen by the user during the session. Defaults to `"gray"`.
#'
#' @templateVar ggnames "Bivariate1", "Bivariate2"
#' @template ggplot2_args_multi
#'
#' @note For more examples, please see the vignette "Using association plot" via
#'   \code{vignette("using-association-plot", package = "teal.modules.general")}.
#' @export
#' @examples
#' # Association plot of selected reference variable (SEX)
#' # against other selected variables (BMRKR1)
#' library(nestcolor)
#' ADSL <- teal.modules.general::rADSL
#'
#' app <- teal::init(
#'   data = teal.data::cdisc_data(
#'     teal.data::cdisc_dataset("ADSL", ADSL, code = "ADSL <- teal.modules.general::rADSL"),
#'     check = TRUE
#'   ),
#'   modules = teal::modules(
#'     teal.modules.general::tm_g_association(
#'       ref = teal.transform::data_extract_spec(
#'         dataname = "ADSL",
#'         select = teal.transform::select_spec(
#'           label = "Select variable:",
#'           choices = teal.transform::variable_choices(
#'             ADSL,
#'             c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2")
#'           ),
#'           selected = "RACE",
#'           fixed = FALSE
#'         )
#'       ),
#'       vars = teal.transform::data_extract_spec(
#'         dataname = "ADSL",
#'         select = teal.transform::select_spec(
#'           label = "Select variables:",
#'           choices = teal.transform::variable_choices(
#'             ADSL,
#'             c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2")
#'           ),
#'           selected = "BMRKR2",
#'           multiple = TRUE,
#'           fixed = FALSE
#'         )
#'       ),
#'       ggplot2_args = teal.widgets::ggplot2_args(
#'         labs = list(subtitle = "Plot generated by Association Module")
#'       )
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
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", "test"
                             ),
                             association_theme = c(
                               "gray", "bw", "linedraw", "light", "dark",
                               "minimal", "classic", "void", "test"
                             ),
                             pre_output = NULL,
                             post_output = NULL,
                             ggplot2_args = teal.widgets::ggplot2_args()) {
  logger::log_info("Initializing tm_g_association")
  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)

  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)
  plot_choices <- c("Bivariate1", "Bivariate2")
  checkmate::assert_list(ggplot2_args, types = "ggplot2_args")
  checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))

  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_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 = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void", "test"),
            selected = args$distribution_theme,
            multiple = FALSE
          ),
          selectInput(
            inputId = ns("association_theme"),
            label = "Association theme (by ggplot):",
            choices = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void", "test"),
            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
  )
}

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, "tdata")
  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,
      join_keys = get_join_keys(data)
    )

    anl_merged_q <- reactive({
      req(anl_merged_input())
      teal.code::new_qenv(tdata2env(data), code = get_code_tdata(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"]] # nolint
      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 # nolint
        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]])
      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]])
        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) {
        card <- teal::TealReportCard$new()
        card$set_name("Association Plot")
        card$append_text("Association Plot", "header2")
        if (with_filter) card$append_fs(filter_panel_api$get_filter_state())
        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(paste(teal.code::get_code(output_q()), collapse = "\n"))
        card
      }
      teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
    }
    ###
  })
}

#' Data Table Viewer Teal Module
#'
#' A data table viewer shows the data using a paginated table.
#' @md
#'
#' @inheritParams teal::module
#' @inheritParams shared_params
#' @param variables_selected (`list`) A named list of 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 zero (default) then all datasets are shown.
#' @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()`)
#' @details
#'   The `DT` package has an option `DT.TOJSON_ARGS` to show `Inf` and `NA` in data tables. If this is something
#'   you require then set `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.
#' @export
#' @examples
#'
#' ADSL <- teal.modules.general::rADSL
#'
#' app <- teal::init(
#'   data = teal.data::cdisc_data(
#'     teal.data::cdisc_dataset("ADSL", ADSL, code = "ADSL <- teal.modules.general::rADSL"),
#'     check = TRUE
#'   ),
#'   modules = teal::modules(
#'     teal.modules.general::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)
#' }
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")
  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_list(dt_options, names = "named")
  checkmate::assert(
    checkmate::check_list(dt_args, len = 0),
    checkmate::check_subset(names(dt_args), choices = names(formals(DT::datatable)))
  )

  checkmate::assert_flag(server_rendering)

  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(
      datasets_selected = datasets_selected,
      dt_args = dt_args,
      dt_options = dt_options,
      server_rendering = server_rendering
    ),
    ui_args = list(
      selected = variables_selected,
      datasets_selected = datasets_selected,
      pre_output = pre_output,
      post_output = post_output
    )
  )
}


# ui page module
ui_page_data_table <- function(id,
                               data,
                               selected,
                               datasets_selected,
                               pre_output = NULL,
                               post_output = NULL) {
  ns <- NS(id)

  datanames <- names(data)

  if (!identical(datasets_selected, character(0))) {
    stopifnot(all(datasets_selected %in% datanames))
    datanames <- datasets_selected
  }

  shiny::tagList(
    include_css_files("custom"),
    teal.widgets::standard_layout(
      output = tagList(
        fluidRow(
          column(
            width = 12,
            checkboxInput(
              ns("if_distinct"),
              "Show only distinct rows:",
              value = FALSE
            )
          )
        ),
        fluidRow(
          class = "mb-8",
          column(
            width = 12,
            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 = ": ")
                  )
                  selected <- if (!is.null(selected[[x]])) {
                    selected[[x]]
                  } else {
                    utils::head(choices)
                  }
                  tabPanel(
                    title = x,
                    column(
                      width = 12,
                      div(
                        class = "mt-4",
                        ui_data_table(
                          id = ns(x),
                          choices = choices,
                          selected = selected
                        )
                      )
                    )
                  )
                }
              )
            )
          )
        )
      ),
      pre_output = pre_output,
      post_output = post_output
    )
  )
}


# server page module
srv_page_data_table <- function(id,
                                data,
                                datasets_selected,
                                dt_args,
                                dt_options,
                                server_rendering) {
  checkmate::assert_class(data, "tdata")
  moduleServer(id, function(input, output, session) {
    if_filtered <- reactive(as.logical(input$if_filtered))
    if_distinct <- reactive(as.logical(input$if_distinct))

    datanames <- names(data)

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

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(tidyselect::all_of(variables)))
      } else {
        df[variables]
      }

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

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

1		#' Create a simple cross-table
2		#' @md
3		#'
4		#' @inheritParams teal::module
5		#' @inheritParams shared_params
6		#' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`)
7		#' Object with all available choices with pre-selected option for variable X - row values. In case
8		#' of `data_extract_spec` use `select_spec(..., ordered = TRUE)` if table elements should be
9		#' rendered according to selection order.
10		#' @param y (`data_extract_spec` or `list` of multiple `data_extract_spec`)
11		#' Object with all available choices with pre-selected option for variable Y - column values
12		#' \code{data_extract_spec} must not allow multiple selection in this case.
13		#'
14		#' @param show_percentage optional, (`logical`) Whether to show percentages
15		#' (relevant only when `x` is a `factor`). Defaults to `TRUE`.
16		#' @param show_total optional, (`logical`) Whether to show total column. Defaults to `TRUE`.
17		#'
18		#' @note For more examples, please see the vignette "Using cross table" via
19		#' `vignette("using-cross-table", package = "teal.modules.general")`.
20		#'
21		#' @export
22		#'
23		#' @examples
24		#' # Percentage cross table of variables from ADSL dataset
25		#'
26		#' ADSL <- teal.modules.general::rADSL
27		#'
28		#' app <- teal::init(
29		#' data = teal.data::cdisc_data(
30		#' teal.data::cdisc_dataset("ADSL", ADSL, code = "ADSL <- teal.modules.general::rADSL"),
31		#' check = TRUE
32		#' ),
33		#' modules = teal::modules(
34		#' teal.modules.general::tm_t_crosstable(
35		#' label = "Cross Table",
36		#' x = teal.transform::data_extract_spec(
37		#' dataname = "ADSL",
38		#' select = teal.transform::select_spec(
39		#' label = "Select variable:",
40		#' choices = variable_choices(ADSL, subset = function(data) {
41		#' idx <- !vapply(data, inherits, logical(1), c("Date", "POSIXct", "POSIXlt"))
42		#' return(names(data)[idx])
43		#' }),
44		#' selected = "COUNTRY",
45		#' multiple = TRUE,
46		#' ordered = TRUE,
47		#' fixed = FALSE
48		#' )
49		#' ),
50		#' y = teal.transform::data_extract_spec(
51		#' dataname = "ADSL",
52		#' select = teal.transform::select_spec(
53		#' label = "Select variable:",
54		#' choices = variable_choices(ADSL, subset = function(data) {
55		#' idx <- vapply(data, is.factor, logical(1))
56		#' return(names(data)[idx])
57		#' }),
58		#' selected = "SEX",
59		#' multiple = FALSE,
60		#' fixed = FALSE
61		#' )
62		#' ),
63		#' basic_table_args = teal.widgets::basic_table_args(
64		#' subtitles = "Table generated by Crosstable Module"
65		#' )
66		#' )
67		#' )
68		#' )
69		#' if (interactive()) {
70		#' shinyApp(app$ui, app$server)
71		#' }
72		#'
73		tm_t_crosstable <- function(label = "Cross Table",
74		x,
75		y,
76		show_percentage = TRUE,
77		show_total = TRUE,
78		pre_output = NULL,
79		post_output = NULL,
80		basic_table_args = teal.widgets::basic_table_args()) {
81	!	logger::log_info("Initializing tm_t_crosstable")
82	!	if (!requireNamespace("rtables", quietly = TRUE)) {
83	!	stop("Cannot load rtables - please install the package or restart your session.")
84		}
85	!	if (inherits(x, "data_extract_spec")) x <- list(x)
86	!	if (inherits(y, "data_extract_spec")) y <- list(y)
87
88	!	checkmate::assert_string(label)
89	!	checkmate::assert_list(x, types = "data_extract_spec")
90	!	checkmate::assert_list(y, types = "data_extract_spec")
91	!	if (any(vapply(y, function(x) x$select$multiple, logical(1)))) {
92	!	stop("'y' should not allow multiple selection")
93		}
94	!	checkmate::assert_flag(show_percentage)
95	!	checkmate::assert_flag(show_total)
96	!	checkmate::assert_class(basic_table_args, classes = "basic_table_args")
97
98	!	ui_args <- as.list(environment())
99
100	!	server_args <- list(
101	!	label = label,
102	!	x = x,
103	!	y = y,
104	!	basic_table_args = basic_table_args
105		)
106
107	!	module(
108	!	label = label,
109	!	server = srv_t_crosstable,
110	!	ui = ui_t_crosstable,
111	!	ui_args = ui_args,
112	!	server_args = server_args,
113	!	datanames = teal.transform::get_extract_datanames(list(x = x, y = y))
114		)
115		}
116
117		ui_t_crosstable <- function(id, x, y, show_percentage, show_total, pre_output, post_output, ...) {
118	!	ns <- NS(id)
119	!	is_single_dataset <- teal.transform::is_single_dataset(x, y)
120
121	!	join_default_options <- c(
122	!	"Full Join" = "dplyr::full_join",
123	!	"Inner Join" = "dplyr::inner_join",
124	!	"Left Join" = "dplyr::left_join",
125	!	"Right Join" = "dplyr::right_join"
126		)
127
128	!	teal.widgets::standard_layout(
129	!	output = teal.widgets::white_small_well(
130	!	textOutput(ns("title")),
131	!	teal.widgets::table_with_settings_ui(ns("table"))
132		),
133	!	encoding = div(
134		### Reporter
135	!	teal.reporter::simple_reporter_ui(ns("simple_reporter")),
136		###
137	!	tags$label("Encodings", class = "text-primary"),
138	!	teal.transform::datanames_input(list(x, y)),
139	!	teal.transform::data_extract_ui(ns("x"), label = "Row values", x, is_single_dataset = is_single_dataset),
140	!	teal.transform::data_extract_ui(ns("y"), label = "Column values", y, is_single_dataset = is_single_dataset),
141	!	teal.widgets::optionalSelectInput(
142	!	ns("join_fun"),
143	!	label = "Row to Column type of join",
144	!	choices = join_default_options,
145	!	selected = join_default_options[1],
146	!	multiple = FALSE
147		),
148	!	tags$hr(),
149	!	teal.widgets::panel_group(
150	!	teal.widgets::panel_item(
151	!	title = "Table settings",
152	!	checkboxInput(ns("show_percentage"), "Show column percentage", value = show_percentage),
153	!	checkboxInput(ns("show_total"), "Show total column", value = show_total)
154		)
155		)
156		),
157	!	forms = tagList(
158	!	teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
159	!	teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
160		),
161	!	pre_output = pre_output,
162	!	post_output = post_output
163		)
164		}
165
166		srv_t_crosstable <- function(id, data, reporter, filter_panel_api, label, x, y, basic_table_args) {
167	!	with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
168	!	with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
169	!	checkmate::assert_class(data, "tdata")
170	!	moduleServer(id, function(input, output, session) {
171	!	selector_list <- teal.transform::data_extract_multiple_srv(
172	!	data_extract = list(x = x, y = y),
173	!	datasets = data,
174	!	select_validation_rule = list(
175	!	x = shinyvalidate::sv_required("Please define column for row variable."),
176	!	y = shinyvalidate::sv_required("Please define column for column variable.")
177		)
178		)
179
180	!	iv_r <- reactive({
181	!	iv <- shinyvalidate::InputValidator$new()
182	!	iv$add_rule("join_fun", function(value) {
183	!	if (!identical(selector_list()$x()$dataname, selector_list()$y()$dataname)) {
184	!	if (!shinyvalidate::input_provided(value)) {
185	!	"Please select a joining function."
186		}
187		}
188		})
189	!	teal.transform::compose_and_enable_validators(iv, selector_list)
190		})
191
192	!	observeEvent(
193	!	eventExpr = {
194	!	req(!is.null(selector_list()$x()) && !is.null(selector_list()$y()))
195	!	list(selector_list()$x(), selector_list()$y())
196		},
197	!	handlerExpr = {
198	!	if (identical(selector_list()$x()$dataname, selector_list()$y()$dataname)) {
199	!	shinyjs::hide("join_fun")
200		} else {
201	!	shinyjs::show("join_fun")
202		}
203		}
204		)
205
206	!	merge_function <- reactive({
207	!	if (is.null(input$join_fun)) {
208	!	"dplyr::full_join"
209		} else {
210	!	input$join_fun
211		}
212		})
213
214	!	anl_merged_input <- teal.transform::merge_expression_srv(
215	!	datasets = data,
216	!	join_keys = get_join_keys(data),
217	!	selector_list = selector_list,
218	!	merge_function = merge_function
219		)
220
221	!	anl_merged_q <- reactive({
222	!	req(anl_merged_input())
223	!	teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) %>%
224	!	teal.code::eval_code(as.expression(anl_merged_input()$expr))
225		})
226
227	!	merged <- list(
228	!	anl_input_r = anl_merged_input,
229	!	anl_q_r = anl_merged_q
230		)
231
232	!	output_q <- reactive({
233	!	teal::validate_inputs(iv_r())
234	!	ANL <- merged$anl_q_r()[["ANL"]] # nolint
235
236		# As this is a summary
237	!	x_name <- as.vector(merged$anl_input_r()$columns_source$x)
238	!	y_name <- as.vector(merged$anl_input_r()$columns_source$y)
239
240	!	teal::validate_has_data(ANL, 3)
241	!	teal::validate_has_data(ANL[, c(x_name, y_name)], 3, complete = TRUE, allow_inf = FALSE)
242
243	!	is_allowed_class <- function(x) is.numeric(x) \|\| is.factor(x) \|\| is.character(x) \|\| is.logical(x)
244	!	validate(need(
245	!	all(vapply(ANL[x_name], is_allowed_class, logical(1))),
246	!	"Selected row variable has an unsupported data type."
247		))
248	!	validate(need(
249	!	is_allowed_class(ANL[[y_name]]),
250	!	"Selected column variable has an unsupported data type."
251		))
252
253	!	show_percentage <- input$show_percentage # nolint
254	!	show_total <- input$show_total # nolint
255
256	!	plot_title <- paste(
257	!	"Cross-Table of",
258	!	paste0(varname_w_label(x_name, ANL), collapse = ", "),
259	!	"(rows)", "vs.",
260	!	varname_w_label(y_name, ANL),
261	!	"(columns)"
262		)
263
264	!	labels_vec <- vapply(
265	!	x_name,
266	!	varname_w_label,
267	!	character(1),
268	!	ANL
269		)
270
271	!	teal.code::eval_code(
272	!	merged$anl_q_r(),
273	!	substitute(
274	!	expr = {
275	!	title <- plot_title
276		},
277	!	env = list(plot_title = plot_title)
278		)
279		) %>%
280	!	teal.code::eval_code(
281	!	substitute(
282	!	expr = {
283	!	lyt <- basic_tables %>%
284	!	split_call %>% # styler: off
285	!	rtables::add_colcounts() %>%
286	!	tern::summarize_vars(
287	!	vars = x_name,
288	!	var_labels = labels_vec,
289	!	na.rm = FALSE,
290	!	denom = "N_col",
291	!	.stats = c("mean_sd", "median", "range", count_value)
292		)
293		},
294	!	env = list(
295	!	basic_tables = teal.widgets::parse_basic_table_args(
296	!	basic_table_args = teal.widgets::resolve_basic_table_args(basic_table_args)
297		),
298	!	split_call = if (show_total) {
299	!	substitute(
300	!	expr = rtables::split_cols_by(
301	!	y_name,
302	!	split_fun = rtables::add_overall_level(label = "Total", first = FALSE)
303		),
304	!	env = list(y_name = y_name)
305		)
306		} else {
307	!	substitute(rtables::split_cols_by(y_name), env = list(y_name = y_name))
308		},
309	!	x_name = x_name,
310	!	labels_vec = labels_vec,
311	!	count_value = ifelse(show_percentage, "count_fraction", "count")
312		)
313		)
314		) %>%
315	!	teal.code::eval_code(
316	!	substitute(
317	!	expr = {
318	!	ANL <- tern::df_explicit_na(ANL) # nolint
319	!	tbl <- rtables::build_table(lyt = lyt, df = ANL[order(ANL[[y_name]]), ])
320	!	tbl
321		},
322	!	env = list(y_name = y_name)
323		)
324		)
325		})
326
327	!	output$title <- renderText(output_q()[["title"]])
328
329	!	table_r <- reactive({
330	!	shiny::req(iv_r()$is_valid())
331	!	output_q()[["tbl"]]
332		})
333
334	!	teal.widgets::table_with_settings_srv(
335	!	id = "table",
336	!	table_r = table_r
337		)
338
339	!	teal.widgets::verbatim_popup_srv(
340	!	id = "warning",
341	!	verbatim_content = reactive(teal.code::get_warnings(output_q())),
342	!	title = "Warning",
343	!	disabled = reactive(is.null(teal.code::get_warnings(output_q())))
344		)
345
346	!	teal.widgets::verbatim_popup_srv(
347	!	id = "rcode",
348	!	verbatim_content = reactive(teal.code::get_code(output_q())),
349	!	title = "Show R Code for Cross-Table"
350		)
351
352		### REPORTER
353	!	if (with_reporter) {
354	!	card_fun <- function(comment) {
355	!	card <- teal::TealReportCard$new()
356	!	card$set_name("Cross Table")
357	!	card$append_text("Cross Table", "header2")
358	!	if (with_filter) card$append_fs(filter_panel_api$get_filter_state())
359	!	card$append_text("Table", "header3")
360	!	card$append_table(table_r())
361	!	if (!comment == "") {
362	!	card$append_text("Comment", "header3")
363	!	card$append_text(comment)
364		}
365	!	card$append_src(paste(teal.code::get_code(output_q()), collapse = "\n"))
366	!	card
367		}
368	!	teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
369		}
370		###
371		})
372		}

1		#' Response Plots
2		#' @md
3		#'
4		#' @inheritParams teal::module
5		#' @inheritParams shared_params
6		#' @param response (`data_extract_spec` or `list` of multiple `data_extract_spec`)
7		#' Which variable to use as the response. You can define one fixed column by using the
8		#' setting `fixed = TRUE` inside the `select_spec`.
9		#' `data_extract_spec` must not allow multiple selection in this case.
10		#' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`)
11		#' Which variable to use on the X-axis of the response plot. Allow the user to select multiple
12		#' columns from the `data` allowed in teal.
13		#' `data_extract_spec` must not allow multiple selection in this case.
14		#' @param row_facet optional, (`data_extract_spec` or `list` of multiple `data_extract_spec`)
15		#' Which data columns to use for faceting rows.
16		#' @param col_facet optional, (`data_extract_spec` or `list` of multiple `data_extract_spec`)
17		#' Which data to use for faceting columns.
18		#' @param coord_flip optional, (`logical`) Whether to flip coordinates between `x` and `response`.
19		#' @param count_labels optional, (`logical`) Whether to show count labels.
20		#' Defaults to `TRUE`.
21		#' @param freq optional, (`logical`) Whether to display frequency (`TRUE`) or density (`FALSE`).
22		#' Defaults to density (`FALSE`).
23		#'
24		#' @note For more examples, please see the vignette "Using response plot" via
25		#' \code{vignette("using-response-plot", package = "teal.modules.general")}.
26		#' @export
27		#' @examples
28		#' # Response plot with selected response (BMRKR1) and selected x variable (RACE)
29		#' library(nestcolor)
30		#'
31		#' ADSL <- teal.modules.general::rADSL
32		#'
33		#' app <- teal::init(
34		#' data = teal.data::cdisc_data(
35		#' teal.data::cdisc_dataset("ADSL", ADSL, code = "ADSL <- teal.modules.general::rADSL"),
36		#' check = TRUE
37		#' ),
38		#' modules = teal::modules(
39		#' teal.modules.general::tm_g_response(
40		#' label = "Response Plots",
41		#' response = teal.transform::data_extract_spec(
42		#' dataname = "ADSL",
43		#' select = teal.transform::select_spec(
44		#' label = "Select variable:",
45		#' choices = teal.transform::variable_choices(ADSL, c("BMRKR2", "COUNTRY")),
46		#' selected = "BMRKR2",
47		#' multiple = FALSE,
48		#' fixed = FALSE
49		#' )
50		#' ),
51		#' x = teal.transform::data_extract_spec(
52		#' dataname = "ADSL",
53		#' select = teal.transform::select_spec(
54		#' label = "Select variable:",
55		#' choices = teal.transform::variable_choices(ADSL, c("SEX", "RACE")),
56		#' selected = "RACE",
57		#' multiple = FALSE,
58		#' fixed = FALSE
59		#' )
60		#' ),
61		#' ggplot2_args = teal.widgets::ggplot2_args(
62		#' labs = list(subtitle = "Plot generated by Response Module")
63		#' )
64		#' )
65		#' )
66		#' )
67		#' if (interactive()) {
68		#' shinyApp(app$ui, app$server)
69		#' }
70		tm_g_response <- function(label = "Response Plot",
71		response,
72		x,
73		row_facet = NULL,
74		col_facet = NULL,
75		coord_flip = FALSE,
76		count_labels = TRUE,
77		rotate_xaxis_labels = FALSE,
78		freq = FALSE,
79		plot_height = c(600, 400, 5000),
80		plot_width = NULL,
81		ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void", "test"),
82		ggplot2_args = teal.widgets::ggplot2_args(),
83		pre_output = NULL,
84		post_output = NULL) {
85	!	logger::log_info("Initializing tm_g_response")
86	!	if (inherits(response, "data_extract_spec")) response <- list(response)
87	!	if (inherits(x, "data_extract_spec")) x <- list(x)
88	!	if (inherits(row_facet, "data_extract_spec")) row_facet <- list(row_facet)
89	!	if (inherits(col_facet, "data_extract_spec")) col_facet <- list(col_facet)
90	!	checkmate::assert_string(label)
91	!	ggtheme <- match.arg(ggtheme)
92	!	checkmate::assert_list(response, types = "data_extract_spec")
93	!	if (!all(vapply(response, function(x) !("" %in% x$select$choices), logical(1)))) {
94	!	stop("'response' should not allow empty values")
95		}
96	!	if (!all(vapply(response, function(x) !x$select$multiple, logical(1)))) {
97	!	stop("'response' should not allow multiple selection")
98		}
99	!	checkmate::assert_list(x, types = "data_extract_spec")
100	!	if (!all(vapply(x, function(x) !("" %in% x$select$choices), logical(1)))) {
101	!	stop("'x' should not allow empty values")
102		}
103	!	if (!all(vapply(x, function(x) !x$select$multiple, logical(1)))) {
104	!	stop("'x' should not allow multiple selection")
105		}
106	!	checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE)
107	!	checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE)
108	!	checkmate::assert_flag(coord_flip)
109	!	checkmate::assert_flag(count_labels)
110	!	checkmate::assert_flag(rotate_xaxis_labels)
111	!	checkmate::assert_flag(freq)
112	!	checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
113	!	checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")
114	!	checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
115	!	checkmate::assert_numeric(
116	!	plot_width[1],
117	!	lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"
118		)
119
120	!	checkmate::assert_class(ggplot2_args, "ggplot2_args")
121
122	!	args <- as.list(environment())
123
124	!	data_extract_list <- list(
125	!	response = response,
126	!	x = x,
127	!	row_facet = row_facet,
128	!	col_facet = col_facet
129		)
130
131	!	module(
132	!	label = label,
133	!	server = srv_g_response,
134	!	ui = ui_g_response,
135	!	ui_args = args,
136	!	server_args = c(
137	!	data_extract_list,
138	!	list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args)
139		),
140	!	datanames = teal.transform::get_extract_datanames(data_extract_list)
141		)
142		}
143
144		ui_g_response <- function(id, ...) {
145	!	ns <- NS(id)
146	!	args <- list(...)
147	!	is_single_dataset_value <- teal.transform::is_single_dataset(args$response, args$x, args$row_facet, args$col_facet)
148
149	!	teal.widgets::standard_layout(
150	!	output = teal.widgets::white_small_well(
151	!	teal.widgets::plot_with_settings_ui(id = ns("myplot"))
152		),
153	!	encoding = div(
154		### Reporter
155	!	teal.reporter::simple_reporter_ui(ns("simple_reporter")),
156		###
157	!	tags$label("Encodings", class = "text-primary"),
158	!	teal.transform::datanames_input(args[c("response", "x", "row_facet", "col_facet")]),
159	!	teal.transform::data_extract_ui(
160	!	id = ns("response"),
161	!	label = "Response variable",
162	!	data_extract_spec = args$response,
163	!	is_single_dataset = is_single_dataset_value
164		),
165	!	teal.transform::data_extract_ui(
166	!	id = ns("x"),
167	!	label = "X variable",
168	!	data_extract_spec = args$x,
169	!	is_single_dataset = is_single_dataset_value
170		),
171	!	if (!is.null(args$row_facet)) {
172	!	teal.transform::data_extract_ui(
173	!	id = ns("row_facet"),
174	!	label = "Row facetting",
175	!	data_extract_spec = args$row_facet,
176	!	is_single_dataset = is_single_dataset_value
177		)
178		},
179	!	if (!is.null(args$col_facet)) {
180	!	teal.transform::data_extract_ui(
181	!	id = ns("col_facet"),
182	!	label = "Column facetting",
183	!	data_extract_spec = args$col_facet,
184	!	is_single_dataset = is_single_dataset_value
185		)
186		},
187	!	shinyWidgets::radioGroupButtons(
188	!	inputId = ns("freq"),
189	!	label = NULL,
190	!	choices = c("frequency", "density"),
191	!	selected = ifelse(args$freq, "frequency", "density"),
192	!	justified = TRUE
193		),
194	!	teal.widgets::panel_group(
195	!	teal.widgets::panel_item(
196	!	title = "Plot settings",
197	!	checkboxInput(ns("count_labels"), "Add count labels", value = args$count_labels),
198	!	checkboxInput(ns("coord_flip"), "Swap axes", value = args$coord_flip),
199	!	checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels),
200	!	selectInput(
201	!	inputId = ns("ggtheme"),
202	!	label = "Theme (by ggplot):",
203	!	choices = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void", "test"),
204	!	selected = args$ggtheme,
205	!	multiple = FALSE
206		)
207		)
208		)
209		),
210	!	forms = tagList(
211	!	teal.widgets::verbatim_popup_ui(ns("warning"), button_label = "Show Warnings"),
212	!	teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
213		),
214	!	pre_output = args$pre_output,
215	!	post_output = args$post_output
216		)
217		}
218
219		srv_g_response <- function(id,
220		data,
221		reporter,
222		filter_panel_api,
223		response,
224		x,
225		row_facet,
226		col_facet,
227		plot_height,
228		plot_width,
229		ggplot2_args) {
230	!	with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
231	!	with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
232	!	checkmate::assert_class(data, "tdata")
233	!	moduleServer(id, function(input, output, session) {
234	!	data_extract <- list(response = response, x = x, row_facet = row_facet, col_facet = col_facet)
235
236	!	rule_diff <- function(other) {
237	!	function(value) {
238	!	othervalue <- selector_list()[[other]]()[["select"]]
239	!	if (!is.null(othervalue)) {
240	!	if (identical(value, othervalue)) {
241	!	"Row and column facetting variables must be different."
242		}
243		}
244		}
245		}
246
247	!	selector_list <- teal.transform::data_extract_multiple_srv(
248	!	data_extract = data_extract,
249	!	datasets = data,
250	!	select_validation_rule = list(
251	!	response = shinyvalidate::sv_required("Please define a column for the response variable"),
252	!	x = shinyvalidate::sv_required("Please define a column for X variable"),
253	!	row_facet = shinyvalidate::compose_rules(
254	!	shinyvalidate::sv_optional(),
255	!	~ if (length(.) > 1) "There must be 1 or no row facetting variable.",
256	!	rule_diff("col_facet")
257		),
258	!	col_facet = shinyvalidate::compose_rules(
259	!	shinyvalidate::sv_optional(),
260	!	~ if (length(.) > 1) "There must be 1 or no column facetting variable.",
261	!	rule_diff("row_facet")
262		)
263		)
264		)
265
266	!	iv_r <- reactive({
267	!	iv <- shinyvalidate::InputValidator$new()
268	!	iv$add_rule("ggtheme", shinyvalidate::sv_required("Please select a theme"))
269	!	teal.transform::compose_and_enable_validators(iv, selector_list)
270		})
271
272	!	anl_merged_input <- teal.transform::merge_expression_srv(
273	!	selector_list = selector_list,
274	!	datasets = data,
275	!	join_keys = get_join_keys(data)
276		)
277
278	!	anl_merged_q <- reactive({
279	!	req(anl_merged_input())
280	!	teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) %>%
281	!	teal.code::eval_code(as.expression(anl_merged_input()$expr))
282		})
283
284	!	merged <- list(
285	!	anl_input_r = anl_merged_input,
286	!	anl_q_r = anl_merged_q
287		)
288
289	!	output_q <- reactive({
290	!	teal::validate_inputs(iv_r())
291
292	!	qenv <- merged$anl_q_r()
293	!	ANL <- qenv[["ANL"]] # nolint
294	!	resp_var <- as.vector(merged$anl_input_r()$columns_source$response)
295	!	x <- as.vector(merged$anl_input_r()$columns_source$x)
296
297	!	validate(need(is.factor(ANL[[resp_var]]), "Please select a factor variable as the response."))
298	!	validate(need(is.factor(ANL[[x]]), "Please select a factor variable as the X-Variable."))
299	!	teal::validate_has_data(ANL, 10)
300	!	teal::validate_has_data(ANL[, c(resp_var, x)], 10, complete = TRUE, allow_inf = FALSE)
301
302	!	row_facet_name <- if (length(merged$anl_input_r()$columns_source$row_facet) == 0) {
303	!	character(0)
304		} else {
305	!	as.vector(merged$anl_input_r()$columns_source$row_facet)
306		}
307	!	col_facet_name <- if (length(merged$anl_input_r()$columns_source$col_facet) == 0) {
308	!	character(0)
309		} else {
310	!	as.vector(merged$anl_input_r()$columns_source$col_facet)
311		}
312
313	!	freq <- input$freq == "frequency"
314	!	swap_axes <- input$coord_flip
315	!	counts <- input$count_labels
316	!	rotate_xaxis_labels <- input$rotate_xaxis_labels
317	!	ggtheme <- input$ggtheme
318
319	!	arg_position <- if (freq) "stack" else "fill" # nolint
320
321	!	rowf <- if (length(row_facet_name) == 0) NULL else as.name(row_facet_name) # nolint
322	!	colf <- if (length(col_facet_name) == 0) NULL else as.name(col_facet_name) # nolint
323	!	resp_cl <- as.name(resp_var) # nolint
324	!	x_cl <- as.name(x) # nolint
325
326	!	if (swap_axes) {
327	!	qenv <- teal.code::eval_code(
328	!	qenv,
329	!	substitute(
330	!	expr = ANL[[x]] <- with(ANL, forcats::fct_rev(x_cl)), # nolint
331	!	env = list(x = x, x_cl = x_cl)
332		)
333		)
334		}
335
336	!	qenv <- teal.code::eval_code(
337	!	qenv,
338	!	substitute(
339	!	expr = ANL[[resp_var]] <- factor(ANL[[resp_var]]), # nolint
340	!	env = list(resp_var = resp_var)
341		)
342		) %>%
343		# nolint start
344		# rowf and colf will be a NULL if not set by a user
345	!	teal.code::eval_code(
346	!	substitute(
347	!	expr = ANL2 <- ANL %>%
348	!	dplyr::group_by_at(dplyr::vars(x_cl, resp_cl, rowf, colf)) %>%
349	!	dplyr::summarise(ns = dplyr::n()) %>%
350	!	dplyr::group_by_at(dplyr::vars(x_cl, rowf, colf)) %>%
351	!	dplyr::mutate(sums = sum(ns), percent = round(ns / sums * 100, 1)),
352	!	env = list(x_cl = x_cl, resp_cl = resp_cl, rowf = rowf, colf = colf)
353		)
354		) %>%
355	!	teal.code::eval_code(
356	!	substitute(
357	!	expr = ANL3 <- ANL %>%
358	!	dplyr::group_by_at(dplyr::vars(x_cl, rowf, colf)) %>%
359	!	dplyr::summarise(ns = dplyr::n()),
360	!	env = list(x_cl = x_cl, rowf = rowf, colf = colf)
361		)
362		)
363		# nolint end
364
365	!	plot_call <- substitute(
366	!	expr =
367	!	ggplot(ANL2, aes(x = x_cl, y = ns)) +
368	!	geom_bar(aes(fill = resp_cl), stat = "identity", position = arg_position),
369	!	env = list(
370	!	x_cl = x_cl,
371	!	resp_cl = resp_cl,
372	!	arg_position = arg_position
373		)
374		)
375
376	!	if (!freq) plot_call <- substitute(plot_call + expand_limits(y = c(0, 1.1)), env = list(plot_call = plot_call))
377
378	!	if (counts) {
379	!	plot_call <- substitute(
380	!	expr = plot_call +
381	!	geom_text(
382	!	data = ANL2,
383	!	aes(label = ns, x = x_cl, y = ns, group = resp_cl),
384	!	col = "white",
385	!	vjust = "middle",
386	!	hjust = "middle",
387	!	position = position_anl2_value
388		) +
389	!	geom_text(
390	!	data = ANL3, aes(label = ns, x = x_cl, y = anl3_y),
391	!	hjust = hjust_value,
392	!	vjust = vjust_value,
393	!	position = position_anl3_value
394		),
395	!	env = list(
396	!	plot_call = plot_call,
397	!	x_cl = x_cl,
398	!	resp_cl = resp_cl,
399	!	hjust_value = if (swap_axes) "left" else "middle",
400	!	vjust_value = if (swap_axes) "middle" else -1,
401	!	position_anl2_value = if (!freq) quote(position_fill(0.5)) else quote(position_stack(0.5)),
402	!	anl3_y = if (!freq) 1.1 else as.name("ns"),
403	!	position_anl3_value = if (!freq) "fill" else "stack"
404		)
405		)
406		}
407
408	!	if (swap_axes) {
409	!	plot_call <- substitute(plot_call + coord_flip(), env = list(plot_call = plot_call))
410		}
411
412	!	facet_cl <- facet_ggplot_call(row_facet_name, col_facet_name)
413
414	!	if (!is.null(facet_cl)) {
415	!	plot_call <- substitute(expr = plot_call + facet_cl, env = list(plot_call = plot_call, facet_cl = facet_cl))
416		}
417
418	!	dev_ggplot2_args <- teal.widgets::ggplot2_args(
419	!	labs = list(
420	!	x = varname_w_label(x, ANL),
421	!	y = varname_w_label(resp_var, ANL, prefix = "Proportion of "),
422	!	fill = varname_w_label(resp_var, ANL)
423		),
424	!	theme = list(legend.position = "bottom")
425		)
426
427	!	if (rotate_xaxis_labels) {
428	!	dev_ggplot2_args$theme[["axis.text.x"]] <- quote(element_text(angle = 45, hjust = 1)) # nolint
429		}
430
431	!	all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(
432	!	user_plot = ggplot2_args,
433	!	module_plot = dev_ggplot2_args
434		)
435
436	!	parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(
437	!	all_ggplot2_args,
438	!	ggtheme = ggtheme
439		)
440
441	!	plot_call <- substitute(expr = {
442	!	p <- plot_call + labs + ggthemes + themes
443	!	print(p)
444	!	}, env = list(
445	!	plot_call = plot_call,
446	!	labs = parsed_ggplot2_args$labs,
447	!	themes = parsed_ggplot2_args$theme,
448	!	ggthemes = parsed_ggplot2_args$ggtheme
449		))
450
451	!	teal.code::eval_code(qenv, plot_call)
452		})
453
454	!	plot_r <- reactive(output_q()[["p"]])
455
456		# Insert the plot into a plot_with_settings module from teal.widgets
457	!	pws <- teal.widgets::plot_with_settings_srv(
458	!	id = "myplot",
459	!	plot_r = plot_r,
460	!	height = plot_height,
461	!	width = plot_width
462		)
463
464	!	teal.widgets::verbatim_popup_srv(
465	!	id = "warning",
466	!	verbatim_content = reactive(teal.code::get_warnings(output_q())),
467	!	title = "Warning",
468	!	disabled = reactive(is.null(teal.code::get_warnings(output_q())))
469		)
470
471	!	teal.widgets::verbatim_popup_srv(
472	!	id = "rcode",
473	!	verbatim_content = reactive(teal.code::get_code(output_q())),
474	!	title = "Show R Code for Response"
475		)
476
477		### REPORTER
478	!	if (with_reporter) {
479	!	card_fun <- function(comment) {
480	!	card <- teal::TealReportCard$new()
481	!	card$set_name("Response Plot")
482	!	card$append_text("Response Plot", "header2")
483	!	if (with_filter) card$append_fs(filter_panel_api$get_filter_state())
484	!	card$append_text("Plot", "header3")
485	!	card$append_plot(plot_r(), dim = pws$dim())
486	!	if (!comment == "") {
487	!	card$append_text("Comment", "header3")
488	!	card$append_text(comment)
489		}
490	!	card$append_src(paste(teal.code::get_code(output_q()), collapse = "\n"))
491	!	card
492		}
493	!	teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
494		}
495		###
496		})
497		}

1		#' Create a scatterplot matrix
2		#'
3		#' The available datasets to choose from for each dataset selector is the same and
4		#' determined by the argument `variables`.
5		#' @md
6		#'
7		#' @inheritParams teal::module
8		#' @inheritParams tm_g_scatterplot
9		#' @inheritParams shared_params
10		#'
11		#' @param variables (`data_extract_spec` or `list` of multiple `data_extract_spec`)
12		#' Plotting variables from an incoming dataset with filtering and selecting. In case of
13		#' `data_extract_spec` use `select_spec(..., ordered = TRUE)` if plot elements should be
14		#' rendered according to selection order.
15		#'
16		#' @note For more examples, please see the vignette "Using scatterplot matrix" via
17		#' \code{vignette("using-scatterplot-matrix", package = "teal.modules.general")}.
18		#' @export
19		#'
20		#' @examples
21		#' # Scatterplot matrix of variables from ADSL dataset
22		#'
23		#' ADSL <- teal.modules.general::rADSL
24		#' ADRS <- teal.modules.general::rADRS
25		#'
26		#' app <- teal::init(
27		#' data = teal.data::cdisc_data(
28		#' teal.data::cdisc_dataset("ADSL", ADSL, code = "ADSL <- teal.modules.general::rADSL"),
29		#' teal.data::cdisc_dataset("ADRS", ADRS, code = "ADRS <- teal.modules.general::rADRS"),
30		#' check = TRUE
31		#' ),
32		#' modules = teal::modules(
33		#' teal.modules.general::tm_g_scatterplotmatrix(
34		#' label = "Scatterplot matrix",
35		#' variables = list(
36		#' teal.transform::data_extract_spec(
37		#' dataname = "ADSL",
38		#' select = select_spec(
39		#' label = "Select variables:",
40		#' choices = variable_choices(ADSL),
41		#' selected = c("AGE", "RACE", "SEX"),
42		#' multiple = TRUE,
43		#' ordered = TRUE,
44		#' fixed = FALSE
45		#' )
46		#' ),
47		#' teal.transform::data_extract_spec(
48		#' dataname = "ADRS",
49		#' filter = teal.transform::filter_spec(
50		#' label = "Select endpoints:",
51		#' vars = c("PARAMCD", "AVISIT"),
52		#' choices = value_choices(ADRS, c("PARAMCD", "AVISIT"), c("PARAM", "AVISIT")),
53		#' selected = "INVET - END OF INDUCTION",
54		#' multiple = TRUE
55		#' ),
56		#' select = select_spec(
57		#' label = "Select variables:",
58		#' choices = variable_choices(ADRS),
59		#' selected = c("AGE", "AVAL", "ADY"),
60		#' multiple = TRUE,
61		#' ordered = TRUE,
62		#' fixed = FALSE
63		#' )
64		#' )
65		#' )
66		#' )
67		#' )
68		#' )
69		#' if (interactive()) {
70		#' shinyApp(app$ui, app$server)
71		#' }
72		tm_g_scatterplotmatrix <- function(label = "Scatterplot Matrix",
73		variables,
74		plot_height = c(600, 200, 2000),
75		plot_width = NULL,
76		pre_output = NULL,
77		post_output = NULL) {
78	!	logger::log_info("Initializing tm_g_scatterplotmatrix")
79	!	if (!requireNamespace("lattice", quietly = TRUE)) {
80	!	stop("Cannot load lattice - please install the package or restart your session.")
81		}
82	!	if (inherits(variables, "data_extract_spec")) variables <- list(variables)
83
84	!	checkmate::assert_string(label)
85	!	checkmate::assert_list(variables, types = "data_extract_spec")
86	!	checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
87	!	checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")
88	!	checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
89	!	checkmate::assert_numeric(
90	!	plot_width[1],
91	!	lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"
92		)
93
94	!	args <- as.list(environment())
95	!	module(
96	!	label = label,
97	!	server = srv_g_scatterplotmatrix,
98	!	ui = ui_g_scatterplotmatrix,
99	!	ui_args = args,
100	!	server_args = list(variables = variables, plot_height = plot_height, plot_width = plot_width),
101	!	datanames = teal.transform::get_extract_datanames(variables)
102		)
103		}
104
105		ui_g_scatterplotmatrix <- function(id, ...) {
106	!	args <- list(...)
107	!	is_single_dataset_value <- teal.transform::is_single_dataset(args$variables)
108	!	ns <- NS(id)
109	!	teal.widgets::standard_layout(
110	!	output = teal.widgets::white_small_well(
111	!	textOutput(ns("message")),
112	!	br(),
113	!	teal.widgets::plot_with_settings_ui(id = ns("myplot"))
114		),
115	!	encoding = div(
116		### Reporter
117	!	teal.reporter::simple_reporter_ui(ns("simple_reporter")),
118		###
119	!	tags$label("Encodings", class = "text-primary"),
120	!	teal.transform::datanames_input(args$variables),
121	!	teal.transform::data_extract_ui(
122	!	id = ns("variables"),
123	!	label = "Variables",
124	!	data_extract_spec = args$variables,
125	!	is_single_dataset = is_single_dataset_value
126		),
127	!	hr(),
128	!	teal.widgets::panel_group(
129	!	teal.widgets::panel_item(
130	!	title = "Plot settings",
131	!	sliderInput(
132	!	ns("alpha"), "Opacity:",
133	!	min = 0, max = 1,
134	!	step = .05, value = .5, ticks = FALSE
135		),
136	!	sliderInput(
137	!	ns("cex"), "Points size:",
138	!	min = 0.2, max = 3,
139	!	step = .05, value = .65, ticks = FALSE
140		),
141	!	checkboxInput(ns("cor"), "Add Correlation", value = FALSE),
142	!	radioButtons(
143	!	ns("cor_method"), "Select Correlation Method",
144	!	choiceNames = c("Pearson", "Kendall", "Spearman"),
145	!	choiceValues = c("pearson", "kendall", "spearman"),
146	!	inline = TRUE
147		),
148	!	checkboxInput(ns("cor_na_omit"), "Omit Missing Values", value = TRUE)
149		)
150		)
151		),
152	!	forms = tagList(
153	!	teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
154	!	teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
155		),
156	!	pre_output = args$pre_output,
157	!	post_output = args$post_output
158		)
159		}
160
161		srv_g_scatterplotmatrix <- function(id, data, reporter, filter_panel_api, variables, plot_height, plot_width) {
162	!	with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
163	!	with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
164	!	checkmate::assert_class(data, "tdata")
165	!	moduleServer(id, function(input, output, session) {
166	!	selector_list <- teal.transform::data_extract_multiple_srv(
167	!	data_extract = list(variables = variables),
168	!	datasets = data,
169	!	select_validation_rule = list(
170	!	variables = ~ if (length(.) <= 1) "Please select at least 2 columns."
171		)
172		)
173
174	!	iv_r <- reactive({
175	!	iv <- shinyvalidate::InputValidator$new()
176	!	teal.transform::compose_and_enable_validators(iv, selector_list)
177		})
178
179	!	anl_merged_input <- teal.transform::merge_expression_srv(
180	!	datasets = data,
181	!	join_keys = get_join_keys(data),
182	!	selector_list = selector_list
183		)
184
185	!	anl_merged_q <- reactive({
186	!	req(anl_merged_input())
187	!	teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) %>%
188	!	teal.code::eval_code(as.expression(anl_merged_input()$expr))
189		})
190
191	!	merged <- list(
192	!	anl_input_r = anl_merged_input,
193	!	anl_q_r = anl_merged_q
194		)
195
196		# plot
197	!	output_q <- reactive({
198	!	teal::validate_inputs(iv_r())
199
200	!	qenv <- merged$anl_q_r()
201	!	ANL <- qenv[["ANL"]] # nolint
202
203	!	cols_names <- merged$anl_input_r()$columns_source$variables
204	!	alpha <- input$alpha # nolint
205	!	cex <- input$cex # nolint
206	!	add_cor <- input$cor # nolint
207	!	cor_method <- input$cor_method # nolint
208	!	cor_na_omit <- input$cor_na_omit # nolint
209
210	!	cor_na_action <- if (isTruthy(cor_na_omit)) {
211	!	"na.omit"
212		} else {
213	!	"na.fail"
214		}
215
216	!	teal::validate_has_data(ANL, 10)
217	!	teal::validate_has_data(ANL[, cols_names], 10, complete = TRUE, allow_inf = FALSE)
218
219		# get labels and proper variable names
220	!	varnames <- varname_w_label(cols_names, ANL, wrap_width = 20) # nolint
221
222		# check character columns. If any, then those are converted to factors
223	!	check_char <- vapply(ANL[, cols_names], is.character, logical(1))
224	!	if (any(check_char)) {
225	!	qenv <- teal.code::eval_code(
226	!	qenv,
227	!	substitute(
228	!	expr = ANL <- ANL[, cols_names] %>% # nolint
229	!	dplyr::mutate_if(is.character, as.factor) %>%
230	!	droplevels(),
231	!	env = list(cols_names = cols_names)
232		)
233		)
234		} else {
235	!	qenv <- teal.code::eval_code(
236	!	qenv,
237	!	substitute(
238	!	expr = ANL <- ANL[, cols_names] %>% # nolint
239	!	droplevels(),
240	!	env = list(cols_names = cols_names)
241		)
242		)
243		}
244
245
246		# create plot
247	!	if (add_cor) {
248	!	shinyjs::show("cor_method")
249	!	shinyjs::show("cor_use")
250	!	shinyjs::show("cor_na_omit")
251
252	!	qenv <- teal.code::eval_code(
253	!	qenv,
254	!	substitute(
255	!	expr = {
256	!	g <- lattice::splom(
257	!	ANL,
258	!	varnames = varnames_value,
259	!	panel = function(x, y, ...) {
260	!	lattice::panel.splom(x = x, y = y, ...)
261	!	cpl <- lattice::current.panel.limits()
262	!	lattice::panel.text(
263	!	mean(cpl$xlim),
264	!	mean(cpl$ylim),
265	!	get_scatterplotmatrix_stats(
266	!	x,
267	!	y,
268	!	.f = stats::cor.test,
269	!	.f_args = list(method = cor_method, na.action = cor_na_action)
270		),
271	!	alpha = 0.6,
272	!	fontsize = 18,
273	!	fontface = "bold"
274		)
275		},
276	!	pch = 16,
277	!	alpha = alpha_value,
278	!	cex = cex_value
279		)
280	!	print(g)
281		},
282	!	env = list(
283	!	varnames_value = varnames,
284	!	cor_method = cor_method,
285	!	cor_na_action = cor_na_action,
286	!	alpha_value = alpha,
287	!	cex_value = cex
288		)
289		)
290		)
291		} else {
292	!	shinyjs::hide("cor_method")
293	!	shinyjs::hide("cor_use")
294	!	shinyjs::hide("cor_na_omit")
295	!	qenv <- teal.code::eval_code(
296	!	qenv,
297	!	substitute(
298	!	expr = {
299	!	g <- lattice::splom(ANL, varnames = varnames_value, pch = 16, alpha = alpha_value, cex = cex_value)
300	!	g
301		},
302	!	env = list(varnames_value = varnames, alpha_value = alpha, cex_value = cex)
303		)
304		)
305		}
306	!	qenv
307		})
308
309	!	plot_r <- reactive(output_q()[["g"]])
310
311		# Insert the plot into a plot_with_settings module
312	!	pws <- teal.widgets::plot_with_settings_srv(
313	!	id = "myplot",
314	!	plot_r = plot_r,
315	!	height = plot_height,
316	!	width = plot_width
317		)
318
319		# show a message if conversion to factors took place
320	!	output$message <- renderText({
321	!	shiny::req(iv_r()$is_valid())
322	!	req(selector_list()$variables())
323	!	ANL <- merged$anl_q_r()[["ANL"]] # nolint
324	!	cols_names <- unique(unname(do.call(c, merged$anl_input_r()$columns_source)))
325	!	check_char <- vapply(ANL[, cols_names], is.character, logical(1))
326	!	if (any(check_char)) {
327	!	is_single <- sum(check_char) == 1
328	!	paste(
329	!	"Character",
330	!	ifelse(is_single, "variable", "variables"),
331	!	paste0("(", paste(cols_names[check_char], collapse = ", "), ")"),
332	!	ifelse(is_single, "was", "were"),
333	!	"converted to",
334	!	ifelse(is_single, "factor.", "factors.")
335		)
336		} else {
337		""
338		}
339		})
340
341	!	teal.widgets::verbatim_popup_srv(
342	!	id = "warning",
343	!	verbatim_content = reactive(teal.code::get_warnings(output_q())),
344	!	title = "Warning",
345	!	disabled = reactive(is.null(teal.code::get_warnings(output_q())))
346		)
347
348	!	teal.widgets::verbatim_popup_srv(
349	!	id = "rcode",
350	!	verbatim_content = reactive(teal.code::get_code(output_q())),
351	!	title = "Show R Code for Scatterplotmatrix"
352		)
353
354		### REPORTER
355	!	if (with_reporter) {
356	!	card_fun <- function(comment) {
357	!	card <- teal::TealReportCard$new()
358	!	card$set_name("Scatter Plot Matrix")
359	!	card$append_text("Scatter Plot Matrix", "header2")
360	!	if (with_filter) card$append_fs(filter_panel_api$get_filter_state())
361	!	card$append_text("Plot", "header3")
362	!	card$append_plot(plot_r(), dim = pws$dim())
363	!	if (!comment == "") {
364	!	card$append_text("Comment", "header3")
365	!	card$append_text(comment)
366		}
367	!	card$append_src(paste(teal.code::get_code(output_q()), collapse = "\n"))
368	!	card
369		}
370	!	teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
371		}
372		###
373		})
374		}
375
376		#' Get stats for x-y pairs in scatterplot matrix
377		#' @description uses stats::cor.test per default for all numerical input variables and converts results
378		#' to character vector. Could be extended if different stats for different variable
379		#' types are needed. Meant to be called from \code{lattice::panel.text}.
380		#' @param x \code{numeric}
381		#' @param y \code{numeric}
382		#' @param .f \code{function}, function that accepts x and y as formula input \code{~ x + y}.
383		#' Default \code{stats::cor.test}
384		#' @param .f_args \code{list} of arguments to be passed to \code{.f}
385		#' @param round_stat \code{integer}
386		#' @param round_pval \code{integer}
387		#' @details presently we need to use a formula input for \code{stats::cor.test} because
388		#' \code{na.fail} only gets evaluated when a formula is passed (see below).
389		#' \preformatted{
390		#' x = c(1,3,5,7,NA)
391		#' y = c(3,6,7,8,1)
392		#' stats::cor.test(x, y, na.action = "na.fail")
393		#' stats::cor.test(~ x + y, na.action = "na.fail")
394		#' }
395		#' @return \code{character} with stats. For \code{stats::cor.test} correlation coefficient and p-value.
396		#' @export
397		#' @examples
398		#' set.seed(1)
399		#' x <- runif(25, 0, 1)
400		#' y <- runif(25, 0, 1)
401		#' x[c(3, 10, 18)] <- NA
402		#'
403		#' get_scatterplotmatrix_stats(x, y, .f = stats::cor.test, .f_args = list(method = "pearson"))
404		#' get_scatterplotmatrix_stats(x, y, .f = stats::cor.test, .f_args = list(
405		#' method = "pearson",
406		#' na.action = na.fail
407		#' ))
408		get_scatterplotmatrix_stats <- function(x, y,
409		.f = stats::cor.test,
410		.f_args = list(),
411		round_stat = 2,
412		round_pval = 4) {
413	6x	if (is.numeric(x) && is.numeric(y)) {
414	3x	stat <- tryCatch(do.call(.f, c(list(~ x + y), .f_args)), error = function(e) NA)
415
416	3x	if (anyNA(stat)) {
417	1x	return("NA")
418	2x	} else if (all(c("estimate", "p.value") %in% names(stat))) {
419	2x	return(paste(
420	2x	c(
421	2x	paste0(names(stat$estimate), ":", round(stat$estimate, round_stat)),
422	2x	paste0("P:", round(stat$p.value, round_pval))
423		),
424	2x	collapse = "\n"
425		))
426		} else {
427	!	stop("function not supported")
428		}
429		} else {
430	3x	if ("method" %in% names(.f_args)) {
431	3x	if (.f_args$method == "pearson") {
432	1x	return("cor:-")
433		}
434	2x	if (.f_args$method == "kendall") {
435	1x	return("tau:-")
436		}
437	1x	if (.f_args$method == "spearman") {
438	1x	return("rho:-")
439		}
440		}
441	!	return("-")
442		}
443		}

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

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

1		#' Shared Parameters
2		#'
3		#' @description Contains arguments that are shared between multiple functions
4		#' in the package to avoid repetition using `inheritParams`.
5		#'
6		#' @param plot_height optional, (`numeric`) A vector of length three with `c(value, min and max)`
7		#' for a slider encoding the plot height.
8		#' @param plot_width optional, (`numeric`) A vector of length three with `c(value, min and max)`
9		#' for a slider encoding the plot width.
10		#' @param rotate_xaxis_labels optional, (`logical`) Whether to rotate plot X axis labels. Does not
11		#' rotate by default (`FALSE`).
12		#' @param ggtheme optional, (`character`) `ggplot2` theme to be used by default.
13		#' One of `c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void", "test")`.
14		#' Each theme can be chosen by the user during the session. Defaults to `"gray"`.
15		#' @param ggplot2_args (`ggplot2_args`) object created by [teal.widgets::ggplot2_args()]
16		#' with settings for the module plot.
17		#' The argument is merged with options variable `teal.ggplot2_args` and default module setup.
18		#'
19		#' For more details see the vignette: `vignette("custom-ggplot2-arguments", package = "teal.widgets")`
20		#' @param basic_table_args (`basic_table_args`) object created by [teal.widgets::basic_table_args()]
21		#' with settings for the module table.
22		#' The argument is merged with options variable `teal.basic_table_args` and default module setup.
23		#'
24		#' For more details see the vignette: `vignette("custom-basic-table-arguments", package = "teal.widgets")`
25		#' @param pre_output (`shiny.tag`, optional)\cr
26		#' with text placed before the output to put the output into context. For example a title.
27		#' @param post_output (`shiny.tag`, optional) with text placed after the output to put the output
28		#' into context. For example the [shiny::helpText()] elements are useful.
29		#'
30		#' @name shared_params
31		#' @keywords internal
32		NULL
33
34		#' Add axis labels that show facetting variable
35		#'
36		#' Add axis labels that show facetting variable
37		#'
38		#' @param p `ggplot2` object to add facet labels to
39		#' @param xfacet_label label of facet along x axis (nothing created if NULL),
40		#' if vector, will be concatenated with " & "
41		#' @param yfacet_label label of facet along y axis (nothing created if NULL),
42		#' if vector, will be concatenated with " & "
43		#'
44		#' @return grid grob object (to be drawn with \code{grid.draw})
45		#'
46		#' @export
47		#'
48		#' @examples
49		#' # we put donttest to avoid strictr error with seq along.with argument
50		#' \donttest{
51		#' library(ggplot2)
52		#' library(grid)
53		#'
54		#' p <- ggplot(mtcars) +
55		#' aes(x = mpg, y = disp) +
56		#' geom_point() +
57		#' facet_grid(gear ~ cyl)
58		#' p
59		#' xfacet_label <- "cylinders"
60		#' yfacet_label <- "gear"
61		#' res <- add_facet_labels(p, xfacet_label, yfacet_label)
62		#' grid.newpage()
63		#' grid.draw(res)
64		#'
65		#' grid.newpage()
66		#' grid.draw(add_facet_labels(p, xfacet_label = NULL, yfacet_label))
67		#' grid.newpage()
68		#' grid.draw(add_facet_labels(p, xfacet_label, yfacet_label = NULL))
69		#' grid.newpage()
70		#' grid.draw(add_facet_labels(p, xfacet_label = NULL, yfacet_label = NULL))
71		#' }
72		#'
73		add_facet_labels <- function(p, xfacet_label = NULL, yfacet_label = NULL) {
74	!	checkmate::assert_class(p, classes = "ggplot")
75	!	checkmate::assert_character(xfacet_label, null.ok = TRUE, min.len = 1)
76	!	checkmate::assert_character(yfacet_label, null.ok = TRUE, min.len = 1)
77	!	if (is.null(xfacet_label) && is.null(yfacet_label)) {
78	!	return(ggplotGrob(p))
79		}
80	!	grid::grid.grabExpr({
81	!	g <- ggplotGrob(p)
82
83		# we are going to replace these, so we make sure they have nothing in them
84	!	checkmate::assert_class(g$grobs[[grep("xlab-t", g$layout$name, fixed = TRUE)]], "zeroGrob")
85	!	checkmate::assert_class(g$grobs[[grep("ylab-r", g$layout$name, fixed = TRUE)]], "zeroGrob")
86
87	!	xaxis_label_grob <- g$grobs[[grep("xlab-b", g$layout$name, fixed = TRUE)]]
88	!	xaxis_label_grob$children[[1]]$label <- paste(xfacet_label, collapse = " & ")
89	!	yaxis_label_grob <- g$grobs[[grep("ylab-l", g$layout$name, fixed = TRUE)]]
90	!	yaxis_label_grob$children[[1]]$label <- paste(yfacet_label, collapse = " & ")
91	!	yaxis_label_grob$children[[1]]$rot <- 270
92
93	!	top_height <- if (is.null(xfacet_label)) 0 else grid::unit(2, "line")
94	!	right_width <- if (is.null(yfacet_label)) 0 else grid::unit(2, "line")
95
96	!	grid::grid.newpage()
97	!	grid::pushViewport(grid::plotViewport(margins = c(0, 0, top_height, right_width), name = "ggplot"))
98	!	grid::grid.draw(g)
99	!	grid::upViewport(1)
100
101		# draw x facet
102	!	if (!is.null(xfacet_label)) {
103	!	grid::pushViewport(grid::viewport(
104	!	x = 0, y = grid::unit(1, "npc") - top_height, width = grid::unit(1, "npc"),
105	!	height = top_height, just = c("left", "bottom"), name = "topxaxis"
106		))
107	!	grid::grid.draw(xaxis_label_grob)
108	!	grid::upViewport(1)
109		}
110
111		# draw y facet
112	!	if (!is.null(yfacet_label)) {
113	!	grid::pushViewport(grid::viewport(
114	!	x = grid::unit(1, "npc") - grid::unit(as.numeric(right_width) / 2, "line"), y = 0, width = right_width,
115	!	height = grid::unit(1, "npc"), just = c("left", "bottom"), name = "rightyaxis"
116		))
117	!	grid::grid.draw(yaxis_label_grob)
118	!	grid::upViewport(1)
119		}
120		})
121		}
122
123		#' Call a function with a character vector for the \code{...} argument
124		#'
125		#' @param fun (\code{character}) Name of a function where the \code{...} argument
126		#' shall be replaced by values from \code{str_args}.
127		#' @param str_args (\code{character}) A character vector that the function shall
128		#' be executed with
129		#'
130		#' @return: call (i.e. expression) of the function provided by \code{fun}
131		#' with arguments provided by \code{str_args}.
132		#' @keywords internal
133		#'
134		#' @examples
135		#' \dontrun{
136		#' a <- 1
137		#' b <- 2
138		#' call_fun_dots("sum", c("a", "b"))
139		#' eval(call_fun_dots("sum", c("a", "b")))
140		#' }
141		call_fun_dots <- function(fun, str_args) {
142	!	do.call("call", c(list(fun), lapply(str_args, as.name)), quote = TRUE)
143		}
144
145		#' Get variable name with label
146		#'
147		#' @param var_names (\code{character}) Name of variable to extract labels from.
148		#' @param dataset (\code{dataset}) Name of analysis dataset.
149		#' @param prefix (\code{character}) String to paste to the beginning of the
150		#' variable name with label.
151		#' @param suffix (\code{character}) String to paste to the end of the variable
152		#' name with label.
153		#' @param wrap_width (\code{numeric}) Number of characters to wrap original
154		#' label to. Defaults to 80.
155		#'
156		#' @return (\code{character}) String with variable name and label.
157		#' @keywords internal
158		#'
159		#' @examples
160		#' \dontrun{
161		#' ADSL <- teal.modules.general::rADSL
162		#'
163		#' varname_w_label("AGE", ADSL)
164		#' }
165		varname_w_label <- function(var_names,
166		dataset,
167		wrap_width = 80,
168		prefix = NULL,
169		suffix = NULL) {
170	!	add_label <- function(var_names) {
171	!	label <- vapply(
172	!	dataset[var_names], function(x) {
173	!	attr_label <- attr(x, "label")
174	!	`if`(is.null(attr_label), "", attr_label)
175		},
176	!	character(1)
177		)
178
179	!	if (length(label) == 1 && !is.na(label) && !identical(label, "")) {
180	!	paste0(prefix, label, " [", var_names, "]", suffix)
181		} else {
182	!	var_names
183		}
184		}
185
186	!	if (length(var_names) < 1) {
187	!	NULL
188	!	} else if (length(var_names) == 1) {
189	!	stringr::str_wrap(add_label(var_names), width = wrap_width)
190	!	} else if (length(var_names) > 1) {
191	!	stringr::str_wrap(vapply(var_names, add_label, character(1)), width = wrap_width)
192		}
193		}
194
195		#' Extract html id for `data_extract_ui`
196		#' @description The `data_extract_ui` is located under extended html id.
197		#' We could not use \code{ns("original id")} for reference, as it is extended with specific suffixes.
198		#' @param varname character original html id.
199		#' This will be mostly retrieved with \code{ns("original id")} in `ui` or
200		#' \code{session$ns("original id")} in server function.
201		#' @param dataname character \code{dataname} from data_extract input.
202		#' This might be retrieved like \code{teal.transform::data_extract_spec(...)[[1]]$dataname}.
203		#' @param filter logical if the connected \code{extract_data_spec} is used with \code{filter} option.
204		#' @keywords internal
205		extract_input <- function(varname, dataname, filter = FALSE) {
206	!	if (filter) {
207	!	paste0(varname, "-dataset_", dataname, "_singleextract-filter1-vals")
208		} else {
209	!	paste0(varname, "-dataset_", dataname, "_singleextract-select")
210		}
211		}
212
213		# see vignette("ggplot2-specs", package="ggplot2")
214		shape_names <- c(
215		"circle", paste("circle", c("open", "filled", "cross", "plus", "small")), "bullet",
216		"square", paste("square", c("open", "filled", "cross", "plus", "triangle")),
217		"diamond", paste("diamond", c("open", "filled", "plus")),
218		"triangle", paste("triangle", c("open", "filled", "square")),
219		paste("triangle down", c("open", "filled")),
220		"plus", "cross", "asterisk"
221		)
222
223		#' Get icons to represent variable types in dataset
224		#'
225		#' @param var_type (`character`)\cr
226		#' of R internal types (classes).
227		#'
228		#' @return (`character`)\cr
229		#' vector of HTML icons corresponding to data type in each column.
230		#' @keywords internal
231		#'
232		#' @examples
233		#' teal.modules.general:::variable_type_icons(c(
234		#' "integer", "numeric", "logical", "Date", "POSIXct", "POSIXlt",
235		#' "factor", "character", "unknown", ""
236		#' ))
237		variable_type_icons <- function(var_type) {
238	!	checkmate::assert_character(var_type, any.missing = FALSE)
239
240	!	class_to_icon <- list(
241	!	numeric = "arrow-up-1-9",
242	!	integer = "arrow-up-1-9",
243	!	logical = "pause",
244	!	Date = "calendar",
245	!	POSIXct = "calendar",
246	!	POSIXlt = "calendar",
247	!	factor = "chart-bar",
248	!	character = "keyboard",
249	!	primary_key = "key",
250	!	unknown = "circle-question"
251		)
252	!	class_to_icon <- lapply(class_to_icon, function(icon_name) toString(icon(icon_name, lib = "font-awesome")))
253
254	!	res <- unname(vapply(
255	!	var_type,
256	!	FUN.VALUE = character(1),
257	!	FUN = function(class) {
258	!	if (class == "") {
259	!	class
260	!	} else if (is.null(class_to_icon[[class]])) {
261	!	class_to_icon[["unknown"]]
262		} else {
263	!	class_to_icon[[class]]
264		}
265		}
266		))
267
268	!	return(res)
269		}
270
271		#' Include `CSS` files from `/inst/css/` package directory to application header
272		#'
273		#' `system.file` should not be used to access files in other packages, it does
274		#' not work with `devtools`. Therefore, we redefine this method in each package
275		#' as needed. Thus, we do not export this method
276		#'
277		#' @param pattern (`character`) pattern of files to be included
278		#'
279		#' @return HTML code that includes `CSS` files
280		#' @keywords internal
281		include_css_files <- function(pattern = "*") {
282	!	css_files <- list.files(
283	!	system.file("css", package = "teal.modules.general", mustWork = TRUE),
284	!	pattern = pattern, full.names = TRUE
285		)
286	!	if (length(css_files) == 0) {
287	!	return(NULL)
288		}
289	!	return(shiny::singleton(shiny::tags$head(lapply(css_files, shiny::includeCSS))))
290		}
291
292
293		#' Get Label Attributes of Variables in a \code{data.frame}
294		#'
295		#' Variable labels can be stored as a \code{label} attribute for each variable.
296		#' This functions returns a named character vector with the variable labels
297		#' (empty sting if not specified)
298		#'
299		#' @param x a \code{data.frame} object
300		#' @param fill boolean in case the \code{label} attribute does not exist if
301		#' \code{TRUE} the variable names is returned, otherwise \code{NA}
302		#'
303		#' @return a named character vector with the variable labels, the names
304		#' correspond to the variable names
305		#'
306		#' @note the `formatters` package is the source of the function.
307		#'
308		#' @keywords internal
309		var_labels <- function(x, fill = FALSE) {
310	!	stopifnot(is.data.frame(x))
311	!	if (NCOL(x) == 0) {
312	!	return(character())
313		}
314
315	!	y <- Map(function(col, colname) {
316	!	label <- attr(col, "label")
317
318	!	if (is.null(label)) {
319	!	if (fill) {
320	!	colname
321		} else {
322	!	NA_character_
323		}
324		} else {
325	!	if (!is.character(label) && !(length(label) == 1)) {
326	!	stop("label for variable ", colname, "is not a character string")
327		}
328	!	as.vector(label)
329		}
330	!	}, x, colnames(x))
331
332	!	labels <- unlist(y, recursive = FALSE, use.names = TRUE)
333
334	!	if (!is.character(labels)) {
335	!	stop("label extraction failed")
336		}
337
338	!	labels
339		}
340
341		#' Get a string with java-script code checking if the specific tab is clicked
342		#' @description will be the input for `shiny::conditionalPanel()`
343		#' @param id `character(1)` the id of the tab panel with tabs.
344		#' @param name `character(1)` the name of the tab.
345		#' @keywords internal
346		is_tab_active_js <- function(id, name) {
347		# supporting the bs3 and higher version at the same time
348	!	sprintf(
349	!	"$(\"#%1$s > li.active\").text().trim() == '%2$s' \|\| $(\"#%1$s > li a.active\").text().trim() == '%2$s'",
350	!	id, name
351		)
352		}

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

1		#' Data Table Viewer Teal Module
2		#'
3		#' A data table viewer shows the data using a paginated table.
4		#' @md
5		#'
6		#' @inheritParams teal::module
7		#' @inheritParams shared_params
8		#' @param variables_selected (`list`) A named list of character vectors of the variables (i.e. columns)
9		#' which should be initially shown for each dataset. Names of list elements should correspond to the names
10		#' of the datasets available in the app. If no entry is specified for a dataset, the first six variables from that
11		#' dataset will initially be shown.
12		#' @param datasets_selected (`character`) A vector of datasets which should be
13		#' shown and in what order. Names in the vector have to correspond with datasets names.
14		#' If vector of length zero (default) then all datasets are shown.
15		#' @param dt_args (named `list`) Additional arguments to be passed to `DT::datatable`
16		#' (must not include `data` or `options`).
17		#' @param dt_options (named `list`) The `options` argument to `DT::datatable`. By default
18		#' `list(searching = FALSE, pageLength = 30, lengthMenu = c(5, 15, 30, 100), scrollX = TRUE)`
19		#' @param server_rendering (`logical`) should the data table be rendered server side
20		#' (see `server` argument of `DT::renderDataTable()`)
21		#' @details
22		#' The `DT` package has an option `DT.TOJSON_ARGS` to show `Inf` and `NA` in data tables. If this is something
23		#' you require then set `options(DT.TOJSON_ARGS = list(na = "string"))` before running the module.
24		#' Note though that sorting of numeric columns with `NA`/`Inf` will be lexicographic not numerical.
25		#' @export
26		#' @examples
27		#'
28		#' ADSL <- teal.modules.general::rADSL
29		#'
30		#' app <- teal::init(
31		#' data = teal.data::cdisc_data(
32		#' teal.data::cdisc_dataset("ADSL", ADSL, code = "ADSL <- teal.modules.general::rADSL"),
33		#' check = TRUE
34		#' ),
35		#' modules = teal::modules(
36		#' teal.modules.general::tm_data_table(
37		#' variables_selected = list(ADSL = c("STUDYID", "USUBJID", "SUBJID", "SITEID", "AGE", "SEX")),
38		#' dt_args = list(caption = "ADSL Table Caption")
39		#' )
40		#' )
41		#' )
42		#' if (interactive()) {
43		#' shinyApp(app$ui, app$server)
44		#' }
45		tm_data_table <- function(label = "Data Table",
46		variables_selected = list(),
47		datasets_selected = character(0),
48		dt_args = list(),
49		dt_options = list(
50		searching = FALSE,
51		pageLength = 30,
52		lengthMenu = c(5, 15, 30, 100),
53		scrollX = TRUE
54		),
55		server_rendering = FALSE,
56		pre_output = NULL,
57		post_output = NULL) {
58	!	logger::log_info("Initializing tm_data_table")
59	!	checkmate::assert_string(label)
60	!	checkmate::assert_list(variables_selected, min.len = 0, types = "character", names = "named")
61	!	if (length(variables_selected) > 0) {
62	!	lapply(seq_along(variables_selected), function(i) {
63	!	checkmate::assert_character(variables_selected[[i]], min.chars = 1, min.len = 1)
64	!	if (!is.null(names(variables_selected[[i]]))) {
65	!	checkmate::assert_names(names(variables_selected[[i]]))
66		}
67		})
68		}
69	!	checkmate::assert_character(datasets_selected, min.len = 0, min.chars = 1)
70	!	checkmate::assert_list(dt_options, names = "named")
71	!	checkmate::assert(
72	!	checkmate::check_list(dt_args, len = 0),
73	!	checkmate::check_subset(names(dt_args), choices = names(formals(DT::datatable)))
74		)
75
76	!	checkmate::assert_flag(server_rendering)
77
78	!	module(
79	!	label,
80	!	server = srv_page_data_table,
81	!	ui = ui_page_data_table,
82	!	datanames = if (length(datasets_selected) == 0) "all" else datasets_selected,
83	!	server_args = list(
84	!	datasets_selected = datasets_selected,
85	!	dt_args = dt_args,
86	!	dt_options = dt_options,
87	!	server_rendering = server_rendering
88		),
89	!	ui_args = list(
90	!	selected = variables_selected,
91	!	datasets_selected = datasets_selected,
92	!	pre_output = pre_output,
93	!	post_output = post_output
94		)
95		)
96		}
97
98
99		# ui page module
100		ui_page_data_table <- function(id,
101		data,
102		selected,
103		datasets_selected,
104		pre_output = NULL,
105		post_output = NULL) {
106	!	ns <- NS(id)
107
108	!	datanames <- names(data)
109
110	!	if (!identical(datasets_selected, character(0))) {
111	!	stopifnot(all(datasets_selected %in% datanames))
112	!	datanames <- datasets_selected
113		}
114
115	!	shiny::tagList(
116	!	include_css_files("custom"),
117	!	teal.widgets::standard_layout(
118	!	output = tagList(
119	!	fluidRow(
120	!	column(
121	!	width = 12,
122	!	checkboxInput(
123	!	ns("if_distinct"),
124	!	"Show only distinct rows:",
125	!	value = FALSE
126		)
127		)
128		),
129	!	fluidRow(
130	!	class = "mb-8",
131	!	column(
132	!	width = 12,
133	!	do.call(
134	!	tabsetPanel,
135	!	lapply(
136	!	datanames,
137	!	function(x) {
138	!	dataset <- isolate(data[[x]]())
139	!	choices <- names(dataset)
140	!	labels <- vapply(
141	!	dataset,
142	!	function(x) ifelse(is.null(attr(x, "label")), "", attr(x, "label")),
143	!	character(1)
144		)
145	!	names(choices) <- ifelse(
146	!	is.na(labels) \| labels == "",
147	!	choices,
148	!	paste(choices, labels, sep = ": ")
149		)
150	!	selected <- if (!is.null(selected[[x]])) {
151	!	selected[[x]]
152		} else {
153	!	utils::head(choices)
154		}
155	!	tabPanel(
156	!	title = x,
157	!	column(
158	!	width = 12,
159	!	div(
160	!	class = "mt-4",
161	!	ui_data_table(
162	!	id = ns(x),
163	!	choices = choices,
164	!	selected = selected
165		)
166		)
167		)
168		)
169		}
170		)
171		)
172		)
173		)
174		),
175	!	pre_output = pre_output,
176	!	post_output = post_output
177		)
178		)
179		}
180
181
182		# server page module
183		srv_page_data_table <- function(id,
184		data,
185		datasets_selected,
186		dt_args,
187		dt_options,
188		server_rendering) {
189	!	checkmate::assert_class(data, "tdata")
190	!	moduleServer(id, function(input, output, session) {
191	!	if_filtered <- reactive(as.logical(input$if_filtered))
192	!	if_distinct <- reactive(as.logical(input$if_distinct))
193
194	!	datanames <- names(data)
195
196	!	lapply(
197	!	datanames,
198	!	function(x) {
199	!	srv_data_table(
200	!	id = x,
201	!	data = data,
202	!	dataname = x,
203	!	if_filtered = if_filtered,
204	!	if_distinct = if_distinct,
205	!	dt_args = dt_args,
206	!	dt_options = dt_options,
207	!	server_rendering = server_rendering
208		)
209		}
210		)
211		})
212		}
213
214		ui_data_table <- function(id,
215		choices,
216		selected) {
217	!	ns <- NS(id)
218
219	!	if (!is.null(selected)) {
220	!	all_choices <- choices
221	!	choices <- c(selected, setdiff(choices, selected))
222	!	names(choices) <- names(all_choices)[match(choices, all_choices)]
223		}
224
225	!	tagList(
226	!	teal.widgets::get_dt_rows(ns("data_table"), ns("dt_rows")),
227	!	fluidRow(
228	!	teal.widgets::optionalSelectInput(
229	!	ns("variables"),
230	!	"Select variables:",
231	!	choices = choices,
232	!	selected = selected,
233	!	multiple = TRUE,
234	!	width = "100%"
235		)
236		),
237	!	fluidRow(
238	!	DT::dataTableOutput(ns("data_table"), width = "100%")
239		)
240		)
241		}
242
243		srv_data_table <- function(id,
244		data,
245		dataname,
246		if_filtered,
247		if_distinct,
248		dt_args,
249		dt_options,
250		server_rendering) {
251	!	moduleServer(id, function(input, output, session) {
252	!	iv <- shinyvalidate::InputValidator$new()
253	!	iv$add_rule("variables", shinyvalidate::sv_required("Please select valid variable names"))
254	!	iv$add_rule("variables", shinyvalidate::sv_in_set(
255	!	set = names(data[[dataname]]()), message_fmt = "Not all selected variables exist in the data"
256		))
257	!	iv$enable()
258
259	!	output$data_table <- DT::renderDataTable(server = server_rendering, {
260	!	teal::validate_inputs(iv)
261
262	!	df <- data[[dataname]]()
263	!	variables <- input$variables
264
265	!	teal::validate_has_data(df, min_nrow = 1L, msg = paste("data", dataname, "is empty"))
266
267	!	dataframe_selected <- if (if_distinct()) {
268	!	dplyr::count(df, dplyr::across(tidyselect::all_of(variables)))
269		} else {
270	!	df[variables]
271		}
272
273	!	dt_args$options <- dt_options
274	!	if (!is.null(input$dt_rows)) {
275	!	dt_args$options$pageLength <- input$dt_rows # nolint
276		}
277	!	dt_args$data <- dataframe_selected
278
279	!	do.call(DT::datatable, dt_args)
280		})
281		})
282		}

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