teal.modules.general coverage - 3.63%

Files
Source

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

  missing_expr <- missing(expr)
  if (!missing_expr && !expr_is_reactive) {
    expr <- rlang::enexpr(expr)
  }

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

    reactive({
      # ensure original errors are displayed and `eval_code` is never executed with NULL
      req(data(), decorated_output())
      if (missing_expr) {
        decorated_output()
      } else if (expr_is_reactive) {
        teal.code::eval_code(decorated_output(), expr())
      } else {
        teal.code::eval_code(decorated_output(), expr)
      }
    })
  })
}

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

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

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

  if (!is.null(names)) {
    check_message <- if (isTRUE(check_message)) {
      out_message <- checkmate::check_names(names(x), subset.of = c("default", names))
      # see https://github.com/insightsengineering/teal.logger/issues/101
      if (isTRUE(out_message)) {
        out_message
      } else {
        gsub("\\{", "(", gsub("\\}", ")", out_message))
      }
    } else {
      check_message
    }
  }

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

  valid_elements <- vapply(
    x,
    checkmate::test_list,
    types = "teal_transform_module",
    null.ok = TRUE,
    FUN.VALUE = logical(1L)
  )

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

  "May only contain the type 'teal_transform_module' or a named list of 'teal_transform_module'."
}

#' Internal assertion on decorators
#' @noRd
assert_decorators <- checkmate::makeAssertionFunction(check_decorators)

#' Subset decorators based on the scope
#'
#' `default` is a protected decorator name that is always included in the output,
#' if it exists
#'
#' @param scope (`character`) a character vector of decorator names to include.
#' @param decorators (named `list`) of list decorators to subset.
#'
#' @return A flat list with all decorators to include.
#' It can be an empty list if none of the scope exists in `decorators` argument.
#' @keywords internal
select_decorators <- function(decorators, scope) {
  checkmate::assert_character(scope, null.ok = TRUE)
  scope <- intersect(union("default", scope), names(decorators))
  c(list(), unlist(decorators[scope], recursive = FALSE))
}

#' Convert flat list of `teal_transform_module` to named lists
#'
#' @param decorators (list of `teal_transform_module`) to normalize.
#' @return A named list of lists with `teal_transform_module` objects.
#' @keywords internal
normalize_decorators <- function(decorators) {
  if (checkmate::test_list(decorators, "teal_transform_module", null.ok = TRUE)) {
    if (checkmate::test_names(names(decorators))) {
      lapply(decorators, list)
    } else {
      list(default = decorators)
    }
  } else {
    decorators
  }
}

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

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

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

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

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

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

1		#' Shared parameters documentation
2		#'
3		#' Defines common arguments shared across multiple functions in the package
4		#' to avoid repetition by using `inheritParams`.
5		#'
6		#' @param plot_height (`numeric`) optional, specifies the plot height as a three-element vector of
7		#' `value`, `min`, and `max` intended for use with a slider UI element.
8		#' @param plot_width (`numeric`) optional, specifies the plot width as a three-element vector of
9		#' `value`, `min`, and `max` for a slider encoding the plot width.
10		#' @param rotate_xaxis_labels (`logical`) optional, whether to rotate plot X axis labels. Does not
11		#' rotate by default (`FALSE`).
12		#' @param ggtheme (`character`) optional, `ggplot2` theme to be used by default. Defaults to `"gray"`.
13		#' @param ggplot2_args (`ggplot2_args`) object created by [teal.widgets::ggplot2_args()]
14		#' with settings for the module plot.
15		#' The argument is merged with options variable `teal.ggplot2_args` and default module setup.
16		#'
17		#' For more details see the vignette: `vignette("custom-ggplot2-arguments", package = "teal.widgets")`
18		#' @param basic_table_args (`basic_table_args`) object created by [teal.widgets::basic_table_args()]
19		#' with settings for the module table.
20		#' The argument is merged with options variable `teal.basic_table_args` and default module setup.
21		#'
22		#' For more details see the vignette: `vignette("custom-basic-table-arguments", package = "teal.widgets")`
23		#' @param pre_output (`shiny.tag`) optional, text or UI element to be displayed before the module's output,
24		#' providing context or a title.
25		#' with text placed before the output to put the output into context. For example a title.
26		#' @param post_output (`shiny.tag`) optional, text or UI element to be displayed after the module's output,
27		#' adding context or further instructions. Elements like `shiny::helpText()` are useful.
28		#' @param alpha (`integer(1)` or `integer(3)`) optional, specifies point opacity.
29		#' - When the length of `alpha` is one: the plot points will have a fixed opacity.
30		#' - When the length of `alpha` is three: the plot points opacity are dynamically adjusted based on
31		#' vector of `value`, `min`, and `max`.
32		#' @param size (`integer(1)` or `integer(3)`) optional, specifies point size.
33		#' - When the length of `size` is one: the plot point sizes will have a fixed size.
34		#' - When the length of `size` is three: the plot points size are dynamically adjusted based on
35		#' vector of `value`, `min`, and `max`.
36		#'
37		#' @return Object of class `teal_module` to be used in `teal` applications.
38		#'
39		#' @name shared_params
40		#' @keywords internal
41		NULL
42
43		#' Add labels for facets to a `ggplot2` object
44		#'
45		#' Enhances a `ggplot2` plot by adding labels that describe
46		#' the faceting variables along the x and y axes.
47		#'
48		#' @param p (`ggplot2`) object to which facet labels will be added.
49		#' @param xfacet_label (`character`) Label for the facet along the x-axis.
50		#' If `NULL`, no label is added. If a vector, labels are joined with " & ".
51		#' @param yfacet_label (`character`) Label for the facet along the y-axis.
52		#' Similar behavior to `xfacet_label`.
53		#'
54		#' @return Returns `grid` or `grob` object (to be drawn with `grid.draw`)
55		#'
56		#' @examples
57		#' library(ggplot2)
58		#' library(grid)
59		#'
60		#' p <- ggplot(mtcars) +
61		#' aes(x = mpg, y = disp) +
62		#' geom_point() +
63		#' facet_grid(gear ~ cyl)
64		#'
65		#' xfacet_label <- "cylinders"
66		#' yfacet_label <- "gear"
67		#' res <- add_facet_labels(p, xfacet_label, yfacet_label)
68		#' grid.newpage()
69		#' grid.draw(res)
70		#'
71		#' grid.newpage()
72		#' grid.draw(add_facet_labels(p, xfacet_label = NULL, yfacet_label))
73		#' grid.newpage()
74		#' grid.draw(add_facet_labels(p, xfacet_label, yfacet_label = NULL))
75		#' grid.newpage()
76		#' grid.draw(add_facet_labels(p, xfacet_label = NULL, yfacet_label = NULL))
77		#'
78		#' @export
79		#'
80		add_facet_labels <- function(p, xfacet_label = NULL, yfacet_label = NULL) {
81	!	checkmate::assert_class(p, classes = "ggplot")
82	!	checkmate::assert_character(xfacet_label, null.ok = TRUE, min.len = 1)
83	!	checkmate::assert_character(yfacet_label, null.ok = TRUE, min.len = 1)
84	!	if (is.null(xfacet_label) && is.null(yfacet_label)) {
85	!	return(ggplotGrob(p))
86		}
87	!	grid::grid.grabExpr({
88	!	g <- ggplotGrob(p)
89
90		# we are going to replace these, so we make sure they have nothing in them
91	!	checkmate::assert_class(g$grobs[[grep("xlab-t", g$layout$name, fixed = TRUE)]], "zeroGrob")
92	!	checkmate::assert_class(g$grobs[[grep("ylab-r", g$layout$name, fixed = TRUE)]], "zeroGrob")
93
94	!	xaxis_label_grob <- g$grobs[[grep("xlab-b", g$layout$name, fixed = TRUE)]]
95	!	xaxis_label_grob$children[[1]]$label <- paste(xfacet_label, collapse = " & ")
96	!	yaxis_label_grob <- g$grobs[[grep("ylab-l", g$layout$name, fixed = TRUE)]]
97	!	yaxis_label_grob$children[[1]]$label <- paste(yfacet_label, collapse = " & ")
98	!	yaxis_label_grob$children[[1]]$rot <- 270
99
100	!	top_height <- if (is.null(xfacet_label)) 0 else grid::unit(2, "line")
101	!	right_width <- if (is.null(yfacet_label)) 0 else grid::unit(2, "line")
102
103	!	grid::grid.newpage()
104	!	grid::pushViewport(grid::plotViewport(margins = c(0, 0, top_height, right_width), name = "ggplot"))
105	!	grid::grid.draw(g)
106	!	grid::upViewport(1)
107
108		# draw x facet
109	!	if (!is.null(xfacet_label)) {
110	!	grid::pushViewport(grid::viewport(
111	!	x = 0, y = grid::unit(1, "npc") - top_height, width = grid::unit(1, "npc"),
112	!	height = top_height, just = c("left", "bottom"), name = "topxaxis"
113		))
114	!	grid::grid.draw(xaxis_label_grob)
115	!	grid::upViewport(1)
116		}
117
118		# draw y facet
119	!	if (!is.null(yfacet_label)) {
120	!	grid::pushViewport(grid::viewport(
121	!	x = grid::unit(1, "npc") - grid::unit(as.numeric(right_width) / 2, "line"), y = 0, width = right_width,
122	!	height = grid::unit(1, "npc"), just = c("left", "bottom"), name = "rightyaxis"
123		))
124	!	grid::grid.draw(yaxis_label_grob)
125	!	grid::upViewport(1)
126		}
127		})
128		}
129
130		#' Call a function with a character vector for the `...` argument
131		#'
132		#' @param fun (`character`) Name of a function where the `...` argument shall be replaced by values from `str_args`.
133		#' @param str_args (`character`) A character vector that the function shall be executed with
134		#'
135		#' @return
136		#' Value of call to `fun` with arguments specified in `str_args`.
137		#'
138		#' @keywords internal
139		call_fun_dots <- function(fun, str_args) {
140	!	do.call("call", c(list(fun), lapply(str_args, as.name)), quote = TRUE)
141		}
142
143		#' Generate a string for a variable including its label
144		#'
145		#' @param var_names (`character`) Name of variable to extract labels from.
146		#' @param dataset (`dataset`) Name of analysis dataset.
147		#' @param prefix,suffix (`character`) String to paste to the beginning/end of the variable name with label.
148		#' @param wrap_width (`numeric`) Number of characters to wrap original label to. Defaults to 80.
149		#'
150		#' @return (`character`) String with variable name and label.
151		#'
152		#' @keywords internal
153		#'
154		varname_w_label <- function(var_names,
155		dataset,
156		wrap_width = 80,
157		prefix = NULL,
158		suffix = NULL) {
159	!	add_label <- function(var_names) {
160	!	label <- vapply(
161	!	dataset[var_names], function(x) {
162	!	attr_label <- attr(x, "label")
163	!	`if`(is.null(attr_label), "", attr_label)
164		},
165	!	character(1)
166		)
167
168	!	if (length(label) == 1 && !is.na(label) && !identical(label, "")) {
169	!	paste0(prefix, label, " [", var_names, "]", suffix)
170		} else {
171	!	var_names
172		}
173		}
174
175	!	if (length(var_names) < 1) {
176	!	NULL
177	!	} else if (length(var_names) == 1) {
178	!	stringr::str_wrap(add_label(var_names), width = wrap_width)
179	!	} else if (length(var_names) > 1) {
180	!	stringr::str_wrap(vapply(var_names, add_label, character(1)), width = wrap_width)
181		}
182		}
183
184		# see vignette("ggplot2-specs", package="ggplot2")
185		shape_names <- c(
186		"circle", paste("circle", c("open", "filled", "cross", "plus", "small")), "bullet",
187		"square", paste("square", c("open", "filled", "cross", "plus", "triangle")),
188		"diamond", paste("diamond", c("open", "filled", "plus")),
189		"triangle", paste("triangle", c("open", "filled", "square")),
190		paste("triangle down", c("open", "filled")),
191		"plus", "cross", "asterisk"
192		)
193
194		#' Get icons to represent variable types in dataset
195		#'
196		#' @param var_type (`character`) of R internal types (classes).
197		#' @return (`character`) vector of HTML icons corresponding to data type in each column.
198		#' @keywords internal
199		variable_type_icons <- function(var_type) {
200	!	checkmate::assert_character(var_type, any.missing = FALSE)
201
202	!	class_to_icon <- list(
203	!	numeric = "arrow-up-1-9",
204	!	integer = "arrow-up-1-9",
205	!	logical = "pause",
206	!	Date = "calendar",
207	!	POSIXct = "calendar",
208	!	POSIXlt = "calendar",
209	!	factor = "chart-bar",
210	!	character = "keyboard",
211	!	primary_key = "key",
212	!	unknown = "circle-question"
213		)
214	!	class_to_icon <- lapply(class_to_icon, function(icon_name) toString(icon(icon_name, lib = "font-awesome")))
215
216	!	unname(vapply(
217	!	var_type,
218	!	FUN.VALUE = character(1),
219	!	FUN = function(class) {
220	!	if (class == "") {
221	!	class
222	!	} else if (is.null(class_to_icon[[class]])) {
223	!	class_to_icon[["unknown"]]
224		} else {
225	!	class_to_icon[[class]]
226		}
227		}
228		))
229		}
230
231		#' Include `CSS` files from `/inst/css/` package directory to application header
232		#'
233		#' `system.file` should not be used to access files in other packages, it does
234		#' not work with `devtools`. Therefore, we redefine this method in each package
235		#' as needed. Thus, we do not export this method
236		#'
237		#' @param pattern (`character`) optional, regular expression to match the file names to be included.
238		#'
239		#' @return HTML code that includes `CSS` files.
240		#' @keywords internal
241		#'
242		include_css_files <- function(pattern = "*") {
243	!	css_files <- list.files(
244	!	system.file("css", package = "teal.modules.general", mustWork = TRUE),
245	!	pattern = pattern, full.names = TRUE
246		)
247	!	if (length(css_files) == 0) {
248	!	return(NULL)
249		}
250	!	singleton(tags$head(lapply(css_files, includeCSS)))
251		}
252
253		#' JavaScript condition to check if a specific tab is active
254		#'
255		#' @param id (`character(1)`) the id of the tab panel with tabs.
256		#' @param name (`character(1)`) the name of the tab.
257		#' @return JavaScript expression to be used in `shiny::conditionalPanel()` to determine
258		#' if the specified tab is active.
259		#' @keywords internal
260		#'
261		is_tab_active_js <- function(id, name) {
262		# supporting the bs3 and higher version at the same time
263	!	sprintf(
264	!	"$(\"#%1$s > li.active\").text().trim() == '%2$s' \|\| $(\"#%1$s > li a.active\").text().trim() == '%2$s'",
265	!	id, name
266		)
267		}
268
269		#' Assert single selection on `data_extract_spec` object
270		#' Helper to reduce code in assertions
271		#' @noRd
272		#'
273		assert_single_selection <- function(x,
274		.var.name = checkmate::vname(x)) { # nolint: object_name.
275	104x	if (any(vapply(x, function(.x) .x$select$multiple, logical(1)))) {
276	4x	stop("'", .var.name, "' should not allow multiple selection")
277		}
278	100x	invisible(TRUE)
279		}
280
281		#' Wrappers around `srv_transform_teal_data` that allows to decorate the data
282		#' @inheritParams teal::srv_transform_teal_data
283		#' @param expr (`expression` or `reactive`) to evaluate on the output of the decoration.
284		#' When an expression it must be inline code. See [within()]
285		#' Default is `NULL` which won't evaluate any appending code.
286		#' @param expr_is_reactive (`logical(1)`) whether `expr` is a reactive expression
287		#' that skips defusing the argument.
288		#' @details
289		#' `srv_decorate_teal_data` is a wrapper around `srv_transform_teal_data` that
290		#' allows to decorate the data with additional expressions.
291		#' When original `teal_data` object is in error state, it will show that error
292		#' first.
293		#'
294		#' @keywords internal
295		srv_decorate_teal_data <- function(id, data, decorators, expr, expr_is_reactive = FALSE) {
296	!	checkmate::assert_class(data, classes = "reactive")
297	!	checkmate::assert_list(decorators, "teal_transform_module")
298	!	checkmate::assert_flag(expr_is_reactive)
299
300	!	missing_expr <- missing(expr)
301	!	if (!missing_expr && !expr_is_reactive) {
302	!	expr <- rlang::enexpr(expr)
303		}
304
305	!	moduleServer(id, function(input, output, session) {
306	!	decorated_output <- srv_transform_teal_data("inner", data = data, transformators = decorators)
307
308	!	reactive({
309		# ensure original errors are displayed and `eval_code` is never executed with NULL
310	!	req(data(), decorated_output())
311	!	if (missing_expr) {
312	!	decorated_output()
313	!	} else if (expr_is_reactive) {
314	!	teal.code::eval_code(decorated_output(), expr())
315		} else {
316	!	teal.code::eval_code(decorated_output(), expr)
317		}
318		})
319		})
320		}
321
322		#' @rdname srv_decorate_teal_data
323		#' @details
324		#' `ui_decorate_teal_data` is a wrapper around `ui_transform_teal_data`.
325		#' @keywords internal
326		ui_decorate_teal_data <- function(id, decorators, ...) {
327	!	teal::ui_transform_teal_data(NS(id, "inner"), transformators = decorators, ...)
328		}
329
330		#' Internal function to check if decorators is a valid object
331		#' @noRd
332		check_decorators <- function(x, names = NULL, null.ok = FALSE) { # nolint: object_name.
333	5x	checkmate::qassert(null.ok, "B1")
334
335	5x	check_message <- checkmate::check_list(
336	5x	x,
337	5x	null.ok = null.ok,
338	5x	names = "named"
339		)
340
341	5x	if (!is.null(names)) {
342	5x	check_message <- if (isTRUE(check_message)) {
343	5x	out_message <- checkmate::check_names(names(x), subset.of = c("default", names))
344		# see https://github.com/insightsengineering/teal.logger/issues/101
345	5x	if (isTRUE(out_message)) {
346	5x	out_message
347		} else {
348	!	gsub("\\{", "(", gsub("\\}", ")", out_message))
349		}
350		} else {
351	!	check_message
352		}
353		}
354
355	5x	if (!isTRUE(check_message)) {
356	!	return(check_message)
357		}
358
359	5x	valid_elements <- vapply(
360	5x	x,
361	5x	checkmate::test_list,
362	5x	types = "teal_transform_module",
363	5x	null.ok = TRUE,
364	5x	FUN.VALUE = logical(1L)
365		)
366
367	5x	if (all(valid_elements)) {
368	5x	return(TRUE)
369		}
370
371	!	"May only contain the type 'teal_transform_module' or a named list of 'teal_transform_module'."
372		}
373
374		#' Internal assertion on decorators
375		#' @noRd
376		assert_decorators <- checkmate::makeAssertionFunction(check_decorators)
377
378		#' Subset decorators based on the scope
379		#'
380		#' `default` is a protected decorator name that is always included in the output,
381		#' if it exists
382		#'
383		#' @param scope (`character`) a character vector of decorator names to include.
384		#' @param decorators (named `list`) of list decorators to subset.
385		#'
386		#' @return A flat list with all decorators to include.
387		#' It can be an empty list if none of the scope exists in `decorators` argument.
388		#' @keywords internal
389		select_decorators <- function(decorators, scope) {
390	!	checkmate::assert_character(scope, null.ok = TRUE)
391	!	scope <- intersect(union("default", scope), names(decorators))
392	!	c(list(), unlist(decorators[scope], recursive = FALSE))
393		}
394
395		#' Convert flat list of `teal_transform_module` to named lists
396		#'
397		#' @param decorators (list of `teal_transform_module`) to normalize.
398		#' @return A named list of lists with `teal_transform_module` objects.
399		#' @keywords internal
400		normalize_decorators <- function(decorators) {
401	5x	if (checkmate::test_list(decorators, "teal_transform_module", null.ok = TRUE)) {
402	5x	if (checkmate::test_names(names(decorators))) {
403	!	lapply(decorators, list)
404		} else {
405	5x	list(default = decorators)
406		}
407		} else {
408	!	decorators
409		}
410		}

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

1		#' `teal` module: Data table viewer
2		#'
3		#' Module provides a dynamic and interactive way to view `data.frame`s in a `teal` application.
4		#' It uses the `DT` package to display data tables in a paginated, searchable, and sortable format,
5		#' which helps to enhance data exploration and analysis.
6		#'
7		#' The `DT` package has an option `DT.TOJSON_ARGS` to show `Inf` and `NA` in data tables.
8		#' Configure the `DT.TOJSON_ARGS` option via
9		#' `options(DT.TOJSON_ARGS = list(na = "string"))` before running the module.
10		#' Note though that sorting of numeric columns with `NA`/`Inf` will be lexicographic not numerical.
11		#'
12		#' @inheritParams teal::module
13		#' @inheritParams shared_params
14		#' @param variables_selected (`named list`) Character vectors of the variables (i.e. columns)
15		#' which should be initially shown for each dataset.
16		#' Names of list elements should correspond to the names of the datasets available in the app.
17		#' If no entry is specified for a dataset, the first six variables from that
18		#' dataset will initially be shown.
19		#' @param datasets_selected (`character`) A vector of datasets which should be
20		#' shown and in what order. Names in the vector have to correspond with datasets names.
21		#' If vector of `length == 0` (default) then all datasets are shown.
22		#' Note: Only datasets of the `data.frame` class are compatible.
23		#' @param dt_args (`named list`) Additional arguments to be passed to [DT::datatable()]
24		#' (must not include `data` or `options`).
25		#' @param dt_options (`named list`) The `options` argument to `DT::datatable`. By default
26		#' `list(searching = FALSE, pageLength = 30, lengthMenu = c(5, 15, 30, 100), scrollX = TRUE)`
27		#' @param server_rendering (`logical`) should the data table be rendered server side
28		#' (see `server` argument of [DT::renderDataTable()])
29		#' @param decorators `r roxygen_decorators_param("tm_data_table")`
30		#'
31		#' @inherit shared_params return
32		#'
33		#' @section Decorating `tm_data_table`:
34		#'
35		#' This module generates the following objects, which can be modified in place using decorators:
36		#' - `table` ([DT::datatable()])
37		#'
38		#' For additional details and examples of decorators, refer to the vignette
39		#' `vignette("decorate-modules-output", package = "teal")` or the [`teal::teal_transform_module()`] documentation.
40		#'
41		#' @examplesShinylive
42		#' library(teal.modules.general)
43		#' interactive <- function() TRUE
44		#' {{ next_example }}
45		#' @examples
46		#' # general data example
47		#' data <- teal_data()
48		#' data <- within(data, {
49		#' require(nestcolor)
50		#' iris <- iris
51		#' })
52		#'
53		#' app <- init(
54		#' data = data,
55		#' modules = modules(
56		#' tm_data_table(
57		#' variables_selected = list(
58		#' iris = c("Sepal.Length", "Sepal.Width", "Petal.Length", "Petal.Width", "Species")
59		#' ),
60		#' dt_args = list(caption = "IRIS Table Caption")
61		#' )
62		#' )
63		#' )
64		#' if (interactive()) {
65		#' shinyApp(app$ui, app$server)
66		#' }
67		#'
68		#' @examplesShinylive
69		#' library(teal.modules.general)
70		#' interactive <- function() TRUE
71		#' {{ next_example }}
72		#' @examples
73		#' # CDISC data example
74		#' data <- teal_data()
75		#' data <- within(data, {
76		#' require(nestcolor)
77		#' ADSL <- teal.data::rADSL
78		#' })
79		#' join_keys(data) <- default_cdisc_join_keys[names(data)]
80		#'
81		#' app <- init(
82		#' data = data,
83		#' modules = modules(
84		#' tm_data_table(
85		#' variables_selected = list(ADSL = c("STUDYID", "USUBJID", "SUBJID", "SITEID", "AGE", "SEX")),
86		#' dt_args = list(caption = "ADSL Table Caption")
87		#' )
88		#' )
89		#' )
90		#' if (interactive()) {
91		#' shinyApp(app$ui, app$server)
92		#' }
93		#'
94		#' @export
95		#'
96		tm_data_table <- function(label = "Data Table",
97		variables_selected = list(),
98		datasets_selected = character(0),
99		dt_args = list(),
100		dt_options = list(
101		searching = FALSE,
102		pageLength = 30,
103		lengthMenu = c(5, 15, 30, 100),
104		scrollX = TRUE
105		),
106		server_rendering = FALSE,
107		pre_output = NULL,
108		post_output = NULL,
109		decorators = NULL) {
110	!	message("Initializing tm_data_table")
111
112		# Start of assertions
113	!	checkmate::assert_string(label)
114
115	!	checkmate::assert_list(variables_selected, min.len = 0, types = "character", names = "named")
116	!	if (length(variables_selected) > 0) {
117	!	lapply(seq_along(variables_selected), function(i) {
118	!	checkmate::assert_character(variables_selected[[i]], min.chars = 1, min.len = 1)
119	!	if (!is.null(names(variables_selected[[i]]))) {
120	!	checkmate::assert_names(names(variables_selected[[i]]))
121		}
122		})
123		}
124
125	!	checkmate::assert_character(datasets_selected, min.len = 0, min.chars = 1)
126	!	checkmate::assert(
127	!	checkmate::check_list(dt_args, len = 0),
128	!	checkmate::check_subset(names(dt_args), choices = names(formals(DT::datatable)))
129		)
130	!	checkmate::assert_list(dt_options, names = "named")
131	!	checkmate::assert_flag(server_rendering)
132	!	checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
133	!	checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
134
135	!	decorators <- normalize_decorators(decorators)
136	!	assert_decorators(decorators, null.ok = TRUE, "table")
137		# End of assertions
138
139	!	ans <- module(
140	!	label,
141	!	server = srv_page_data_table,
142	!	ui = ui_page_data_table,
143	!	datanames = if (length(datasets_selected) == 0) "all" else datasets_selected,
144	!	server_args = list(
145	!	variables_selected = variables_selected,
146	!	datasets_selected = datasets_selected,
147	!	dt_args = dt_args,
148	!	dt_options = dt_options,
149	!	server_rendering = server_rendering,
150	!	decorators = decorators
151		),
152	!	ui_args = list(
153	!	pre_output = pre_output,
154	!	post_output = post_output
155		)
156		)
157	!	attr(ans, "teal_bookmarkable") <- TRUE
158	!	ans
159		}
160
161		# UI page module
162		ui_page_data_table <- function(id, pre_output = NULL, post_output = NULL) {
163	!	ns <- NS(id)
164
165	!	tagList(
166	!	include_css_files("custom"),
167	!	teal.widgets::standard_layout(
168	!	output = teal.widgets::white_small_well(
169	!	fluidRow(
170	!	column(
171	!	width = 12,
172	!	checkboxInput(
173	!	ns("if_distinct"),
174	!	"Show only distinct rows:",
175	!	value = FALSE
176		)
177		)
178		),
179	!	fluidRow(
180	!	class = "mb-8",
181	!	column(
182	!	width = 12,
183	!	uiOutput(ns("dataset_table"))
184		)
185		)
186		),
187	!	pre_output = pre_output,
188	!	post_output = post_output
189		)
190		)
191		}
192
193		# Server page module
194		srv_page_data_table <- function(id,
195		data,
196		datasets_selected,
197		variables_selected,
198		dt_args,
199		dt_options,
200		server_rendering,
201		decorators) {
202	!	checkmate::assert_class(data, "reactive")
203	!	checkmate::assert_class(isolate(data()), "teal_data")
204	!	moduleServer(id, function(input, output, session) {
205	!	teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")
206
207	!	if_filtered <- reactive(as.logical(input$if_filtered))
208	!	if_distinct <- reactive(as.logical(input$if_distinct))
209
210	!	datanames <- isolate(names(data()))
211	!	datanames <- Filter(function(name) {
212	!	is.data.frame(isolate(data())[[name]])
213	!	}, datanames)
214
215	!	if (!identical(datasets_selected, character(0))) {
216	!	checkmate::assert_subset(datasets_selected, datanames)
217	!	datanames <- datasets_selected
218		}
219
220	!	output$dataset_table <- renderUI({
221	!	do.call(
222	!	tabsetPanel,
223	!	c(
224	!	list(id = session$ns("dataname_tab")),
225	!	lapply(
226	!	datanames,
227	!	function(x) {
228	!	dataset <- isolate(data()[[x]])
229	!	choices <- names(dataset)
230	!	labels <- vapply(
231	!	dataset,
232	!	function(x) ifelse(is.null(attr(x, "label")), "", attr(x, "label")),
233	!	character(1)
234		)
235	!	names(choices) <- ifelse(
236	!	is.na(labels) \| labels == "",
237	!	choices,
238	!	paste(choices, labels, sep = ": ")
239		)
240	!	variables_selected <- if (!is.null(variables_selected[[x]])) {
241	!	variables_selected[[x]]
242		} else {
243	!	utils::head(choices)
244		}
245	!	tabPanel(
246	!	title = x,
247	!	column(
248	!	width = 12,
249	!	div(
250	!	class = "mt-4",
251	!	ui_data_table(
252	!	id = session$ns(x),
253	!	choices = choices,
254	!	selected = variables_selected,
255	!	decorators = decorators
256		)
257		)
258		)
259		)
260		}
261		)
262		)
263		)
264		})
265
266	!	lapply(
267	!	datanames,
268	!	function(x) {
269	!	srv_data_table(
270	!	id = x,
271	!	data = data,
272	!	dataname = x,
273	!	if_filtered = if_filtered,
274	!	if_distinct = if_distinct,
275	!	dt_args = dt_args,
276	!	dt_options = dt_options,
277	!	server_rendering = server_rendering,
278	!	decorators = decorators
279		)
280		}
281		)
282		})
283		}
284
285		# UI function for the data_table module
286		ui_data_table <- function(id,
287		choices,
288		selected,
289		decorators) {
290	!	ns <- NS(id)
291
292	!	if (!is.null(selected)) {
293	!	all_choices <- choices
294	!	choices <- c(selected, setdiff(choices, selected))
295	!	names(choices) <- names(all_choices)[match(choices, all_choices)]
296		}
297
298	!	tagList(
299	!	teal.widgets::get_dt_rows(ns("data_table"), ns("dt_rows")),
300	!	fluidRow(
301	!	ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(decorators, "table")),
302	!	teal.widgets::optionalSelectInput(
303	!	ns("variables"),
304	!	"Select variables:",
305	!	choices = choices,
306	!	selected = selected,
307	!	multiple = TRUE,
308	!	width = "100%"
309		)
310		),
311	!	fluidRow(
312	!	DT::dataTableOutput(ns("data_table"), width = "100%")
313		)
314		)
315		}
316
317		# Server function for the data_table module
318		srv_data_table <- function(id,
319		data,
320		dataname,
321		if_filtered,
322		if_distinct,
323		dt_args,
324		dt_options,
325		server_rendering,
326		decorators) {
327	!	moduleServer(id, function(input, output, session) {
328	!	iv <- shinyvalidate::InputValidator$new()
329	!	iv$add_rule("variables", shinyvalidate::sv_required("Please select valid variable names"))
330	!	iv$add_rule("variables", shinyvalidate::sv_in_set(
331	!	set = names(isolate(data())[[dataname]]), message_fmt = "Not all selected variables exist in the data"
332		))
333	!	iv$enable()
334
335	!	data_table_data <- reactive({
336	!	df <- data()[[dataname]]
337
338	!	teal::validate_has_data(df, min_nrow = 1L, msg = paste("data", dataname, "is empty"))
339
340	!	teal.code::eval_code(
341	!	data(),
342	!	substitute(
343	!	expr = {
344	!	variables <- vars
345	!	dataframe_selected <- if (if_distinct) {
346	!	dplyr::count(dataname, dplyr::across(dplyr::all_of(variables)))
347		} else {
348	!	dataname[variables]
349		}
350	!	dt_args <- args
351	!	dt_args$options <- dt_options
352	!	if (!is.null(dt_rows)) {
353	!	dt_args$options$pageLength <- dt_rows
354		}
355	!	dt_args$data <- dataframe_selected
356	!	table <- do.call(DT::datatable, dt_args)
357		},
358	!	env = list(
359	!	dataname = as.name(dataname),
360	!	if_distinct = if_distinct(),
361	!	vars = input$variables,
362	!	args = dt_args,
363	!	dt_options = dt_options,
364	!	dt_rows = input$dt_rows
365		)
366		)
367		)
368		})
369
370	!	decorated_data_table_data <- srv_decorate_teal_data(
371	!	id = "decorator",
372	!	data = data_table_data,
373	!	decorators = select_decorators(decorators, "table")
374		)
375
376	!	output$data_table <- DT::renderDataTable(server = server_rendering, {
377	!	teal::validate_inputs(iv)
378	!	req(decorated_data_table_data())[["table"]]
379		})
380		})
381		}

1		#' `teal` module: Distribution analysis
2		#'
3		#' Module is designed to explore the distribution of a single variable within a given dataset.
4		#' It offers several tools, such as histograms, Q-Q plots, and various statistical tests to
5		#' visually and statistically analyze the variable's distribution.
6		#'
7		#' @inheritParams teal::module
8		#' @inheritParams teal.widgets::standard_layout
9		#' @inheritParams shared_params
10		#'
11		#' @param dist_var (`data_extract_spec` or `list` of multiple `data_extract_spec`)
12		#' Variable(s) for which the distribution will be analyzed.
13		#' @param strata_var (`data_extract_spec` or `list` of multiple `data_extract_spec`)
14		#' Categorical variable used to split the distribution analysis.
15		#' @param group_var (`data_extract_spec` or `list` of multiple `data_extract_spec`)
16		#' Variable used for faceting plot into multiple panels.
17		#' @param freq (`logical`) optional, whether to display frequency (`TRUE`) or density (`FALSE`).
18		#' Defaults to density (`FALSE`).
19		#' @param bins (`integer(1)` or `integer(3)`) optional, specifies the number of bins for the histogram.
20		#' - When the length of `bins` is one: The histogram bins will have a fixed size based on the `bins` provided.
21		#' - When the length of `bins` is three: The histogram bins are dynamically adjusted based on vector of `value`, `min`,
22		#' and `max`.
23		#' Defaults to `c(30L, 1L, 100L)`.
24		#'
25		#' @param ggplot2_args `r roxygen_ggplot2_args_param("Histogram", "QQplot")`
26		#' @param decorators `r roxygen_decorators_param("tm_g_distribution")`
27		#'
28		#' @inherit shared_params return
29		#'
30		#' @section Decorating `tm_g_distribution`:
31		#'
32		#' This module generates the following objects, which can be modified in place using decorators::
33		#' - `histogram_plot` (`ggplot2`)
34		#' - `qq_plot` (`data.frame`)
35		#' - `summary_table` (`data.frame`)
36		#' - `test_table` (`data.frame`)
37		#'
38		#' Decorators can be applied to all outputs or only to specific objects using a
39		#' named list of `teal_transform_module` objects.
40		#' The `"default"` name is reserved for decorators that are applied to all outputs.

1		#' `teal` module: Missing data analysis
2		#'
3		#' This module analyzes missing data in `data.frame`s to help users explore missing observations and
4		#' gain insights into the completeness of their data.
5		#' It is useful for clinical data analysis within the context of `CDISC` standards and
6		#' adaptable for general data analysis purposes.
7		#'
8		#' @inheritParams teal::module
9		#' @inheritParams shared_params
10		#' @param parent_dataname (`character(1)`) Specifies the parent dataset name. Default is `ADSL` for `CDISC` data.
11		#' If provided and exists, enables additional analysis "by subject". For non-`CDISC` data, this parameter can be
12		#' ignored.
13		# nolint start: line_length.
14		#' @param ggtheme (`character`) optional, specifies the default `ggplot2` theme for plots. Defaults to `classic`.
15		#' @param ggplot2_args `r roxygen_ggplot2_args_param("Summary Obs", "Summary Patients", "Combinations Main", "Combinations Hist", "By Subject")`
16		# nolint end: line_length.
17		#' @param decorators `r roxygen_decorators_param("tm_missing_data")`
18		#'
19		#' @inherit shared_params return
20		#'
21		#' @section Decorating `tm_missing_data`:
22		#'
23		#' This module generates the following objects, which can be modified in place using decorators:
24		#' - `summary_plot` (`grob` created with [ggplot2::ggplotGrob()])
25		#' - `combination_plot` (`grob` created with [ggplot2::ggplotGrob()])
26		#' - `by_subject_plot` (`ggplot2`)
27		#' - `table` ([DT::datatable()])
28		#'
29		#' Decorators can be applied to all outputs or only to specific objects using a
30		#' named list of `teal_transform_module` objects.
31		#' The `"default"` name is reserved for decorators that are applied to all outputs.
32		#' See code snippet below:
33		#'
34		#' ```
35		#' tm_missing_data(
36		#' ..., # arguments for module
37		#' decorators = list(
38		#' default = list(teal_transform_module(...)), # applied to all outputs
39		#' summary_plot = list(teal_transform_module(...)), # applied only to `summary_plot` output
40		#' combination_plot = list(teal_transform_module(...)) # applied only to `combination_plot` output

1		#' `teal` module: Variable browser
2		#'
3		#' Module provides provides a detailed summary and visualization of variable distributions
4		#' for `data.frame` objects, with interactive features to customize analysis.
5		#'
6		#' Numeric columns with fewer than 30 distinct values can be treated as either discrete
7		#' or continuous with a checkbox allowing users to switch how they are treated(if < 6 unique values
8		#' then the default is discrete, otherwise it is continuous).
9		#'
10		#' @inheritParams teal::module
11		#' @inheritParams shared_params
12		#' @param parent_dataname (`character(1)`) string specifying a parent dataset.
13		#' If it exists in `datasets_selected`then an extra checkbox will be shown to
14		#' allow users to not show variables in other datasets which exist in this `dataname`.
15		#' This is typically used to remove `ADSL` columns in `CDISC` data.
16		#' In non `CDISC` data this can be ignored. Defaults to `"ADSL"`.
17		#' @param datasets_selected (`character`) vector of datasets which should be
18		#' shown, in order. Names must correspond with datasets names.
19		#' If vector of length zero (default) then all datasets are shown.
20		#' Note: Only `data.frame` objects are compatible; using other types will cause an error.
21		#'
22		#' @inherit shared_params return
23		#'
24		#' @examplesShinylive
25		#' library(teal.modules.general)
26		#' interactive <- function() TRUE
27		#' {{ next_example }}
28		# nolint start: line_length_linter.
29		#' @examplesIf require("sparkline", quietly = TRUE) && require("htmlwidgets", quietly = TRUE) && require("jsonlite", quietly = TRUE)
30		# nolint end: line_length_linter.
31		#' # general data example
32		#' data <- teal_data()
33		#' data <- within(data, {
34		#' iris <- iris
35		#' mtcars <- mtcars
36		#' women <- women
37		#' faithful <- faithful
38		#' CO2 <- CO2
39		#' })
40		#'

1		#' `teal` module: Outliers analysis
2		#'
3		#' Module to analyze and identify outliers using different methods
4		#' such as IQR, Z-score, and Percentiles, and offers visualizations including
5		#' box plots, density plots, and cumulative distribution plots to help interpret the outliers.
6		#'
7		#' @inheritParams teal::module
8		#' @inheritParams shared_params
9		#'
10		#' @param outlier_var (`data_extract_spec` or `list` of multiple `data_extract_spec`)
11		#' Specifies variable(s) to be analyzed for outliers.
12		#' @param categorical_var (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,
13		#' specifies the categorical variable(s) to split the selected outlier variables on.
14		#' @param ggplot2_args `r roxygen_ggplot2_args_param("Boxplot", "Density Plot", "Cumulative Distribution Plot")`
15		#' @param decorators `r roxygen_decorators_param("tm_outliers")`
16		#'
17		#' @inherit shared_params return
18		#'
19		#' @section Decorating `tm_outliers`:
20		#'
21		#' This module generates the following objects, which can be modified in place using decorators:
22		#' - `box_plot` (`ggplot2`)
23		#' - `density_plot` (`ggplot2`)
24		#' - `cumulative_plot` (`ggplot2`)
25		#' - `table` ([DT::datatable()])
26		#'
27		#' Decorators can be applied to all outputs or only to specific objects using a
28		#' named list of `teal_transform_module` objects.
29		#' The `"default"` name is reserved for decorators that are applied to all outputs.
30		#' See code snippet below:
31		#'
32		#' ```
33		#' tm_outliers(
34		#' ..., # arguments for module
35		#' decorators = list(
36		#' default = list(teal_transform_module(...)), # applied to all outputs
37		#' box_plot = list(teal_transform_module(...)), # applied only to `box_plot` output
38		#' density_plot = list(teal_transform_module(...)) # applied only to `density_plot` output
39		#' cumulative_plot = list(teal_transform_module(...)) # applied only to `cumulative_plot` output
40		#' table = list(teal_transform_module(...)) # applied only to `table` output