teal.modules.general coverage - 3.44%

Files
Source

File	Lines	Relevant	Covered	Missed	Hits / Line	Coverage
R/tm_missing_data.R	1435	876	0	876	0	0.00%
R/tm_g_distribution.R	1423	874	0	874	0	0.00%
R/tm_outliers.R	1356	794	0	794	0	0.00%
R/tm_a_pca.R	1162	687	0	687	0	0.00%
R/tm_a_regression.R	1061	597	0	597	0	0.00%
R/tm_g_scatterplot.R	1096	570	0	570	0	0.00%
R/tm_g_response.R	626	297	0	297	0	0.00%
R/tm_g_association.R	581	278	0	278	0	0.00%
R/tm_t_crosstable.R	473	204	0	204	0	0.00%
R/tm_data_table.R	360	163	0	163	0	0.00%
R/tm_file_viewer.R	256	129	0	129	0	0.00%
R/zzz.R	10	2	0	2	0	0.00%
R/tm_variable_browser.R	1300	675	5	670	0	0.74%
R/tm_g_scatterplotmatrix.R	608	239	17	222	0	7.11%
R/tm_front_page.R	265	114	9	105	0	7.89%
R/utils.R	399	125	15	110	2	12.00%
R/tm_g_bivariate.R	1114	572	233	339	5	40.73%

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

  missing_expr <- missing(expr)
  if (!missing_expr && !expr_is_reactive) {
    expr <- dplyr::enexpr(expr) # Using dplyr re-export to avoid adding rlang to Imports
  }

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

    reactive({
      data_out <- try(data(), silent = TRUE)
      if (inherits(data_out, "qenv.error")) {
        data()
      } else {
        # ensure original errors are displayed and `eval_code` is never executed with NULL
        req(data(), decorated_output())
        if (missing_expr) {
          decorated_output()
        } else if (expr_is_reactive) {
          teal.code::eval_code(decorated_output(), expr())
        } else {
          teal.code::eval_code(decorated_output(), expr)
        }
      }
    })
  })
}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

1		#' `teal` module: 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 `datanames` 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`) `r lifecycle::badge("deprecated")` vector of datasets to show, please
18		#' use the `datanames` argument.
19		#'
20		#' @inherit shared_params return
21		#'
22		#' @examplesShinylive
23		#' library(teal.modules.general)
24		#' interactive <- function() TRUE
25		#' {{ next_example }}
26		# nolint start: line_length_linter.
27		#' @examples
28		# nolint end: line_length_linter.
29		#' # general data example
30		#' data <- teal_data()
31		#' data <- within(data, {
32		#' iris <- iris
33		#' mtcars <- mtcars
34		#' women <- women
35		#' faithful <- faithful
36		#' CO2 <- CO2
37		#' })
38		#'
39		#' app <- init(
40		#' data = data,

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

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