teal.modules.general coverage - 3.44%

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

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

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

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

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

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

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

1		#' `teal` module: 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 <- 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: 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		#' @param ggtheme (`character`) optional, specifies the default `ggplot2` theme for plots. Defaults to `classic`.
14		#'
15		#' @templateVar ggnames "Summary Obs", "Summary Patients", "Combinations Main", "Combinations Hist", "By Subject"
16		#' @template ggplot2_args_multi
17		#'
18		#' @inherit shared_params return
19		#'
20		#' @examplesShinylive
21		#' library(teal.modules.general)
22		#' interactive <- function() TRUE
23		#' {{ next_example }}
24		#' @examplesIf require("gridExtra", quietly = TRUE) && require("rlang", quietly = TRUE)
25		#' # general example data
26		#' data <- teal_data()
27		#' data <- within(data, {
28		#' require(nestcolor)
29		#'
30		#' add_nas <- function(x) {
31		#' x[sample(seq_along(x), floor(length(x) * runif(1, .05, .17)))] <- NA
32		#' x
33		#' }
34		#'
35		#' iris <- iris
36		#' mtcars <- mtcars
37		#'
38		#' iris[] <- lapply(iris, add_nas)
39		#' mtcars[] <- lapply(mtcars, add_nas)
40		#' mtcars[["cyl"]] <- as.factor(mtcars[["cyl"]])

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		#'
15		#' @templateVar ggnames "Boxplot","Density Plot","Cumulative Distribution Plot"
16		#' @template ggplot2_args_multi
17		#'
18		#' @inherit shared_params return
19		#'
20		#' @examplesShinylive
21		#' library(teal.modules.general)
22		#' interactive <- function() TRUE
23		#' {{ next_example }}
24		#' @examples
25		#' # general data example
26		#' data <- teal_data()
27		#' data <- within(data, {
28		#' CO2 <- CO2
29		#' CO2[["primary_key"]] <- seq_len(nrow(CO2))
30		#' })
31		#' join_keys(data) <- join_keys(join_key("CO2", "CO2", "primary_key"))
32		#'
33		#' vars <- choices_selected(variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")))
34		#'
35		#' app <- init(
36		#' data = data,
37		#' modules = modules(
38		#' tm_outliers(
39		#' outlier_var = list(
40		#' data_extract_spec(

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		#' @templateVar ggnames "Histogram", "QQplot"
26		#' @template ggplot2_args_multi
27		#'
28		#' @inherit shared_params return
29		#'
30		#' @examplesShinylive
31		#' library(teal.modules.general)
32		#' interactive <- function() TRUE
33		#' {{ next_example }}
34		# nolint start: line_length_linter.
35		#' @examplesIf require("ggpmisc", quietly = TRUE) && require("ggpp", quietly = TRUE) && require("goftest", quietly = TRUE) && require("MASS", quietly = TRUE) && require("broom", quietly = TRUE)
36		# nolint end: line_length_linter.
37		#' # general data example
38		#' data <- teal_data()
39		#' data <- within(data, {
40		#' iris <- iris