teal.modules.general coverage - 3.99%

Files
Source

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

#'
#' @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
#' @inheritParams teal.reporter::`eval_code,teal_report-method`
#' @param expr (`reactive`) with expression to evaluate on the output of the
#' decoration. It must be compatible with `code` argument of [teal.code::eval_code()].
#' Default is `NULL` which won't evaluate any appending code.
#' @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) {
  checkmate::assert_class(data, classes = "reactive")
  checkmate::assert_list(decorators, "teal_transform_module")

  no_expr <- missing(expr)

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

    expr_r <- if (is.reactive(expr)) expr else reactive(expr)

    reactive({
      req(decorated_output())
      if (no_expr) {
        decorated_output()
      } else {
        teal.code::eval_code(decorated_output(), expr_r())
      }
    })
  })
}

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

#' Set the attributes of the last chunk outputs
#' @param teal_card (`teal_card`) object to modify.
#' @param attributes (`list`) of attributes to set on the last chunk outputs.
#' @param n (`integer(1)`) number of the last element of `teal_card` to modify.
#' it will only change `chunk_output` objects.
#' @param inner_classes (`character`) classes within `chunk_output` that should be modified.
#' This can be used to only change `recordedplot`, `ggplot2` or other type of objects.
#' @keywords internal
set_chunk_attrs <- function(teal_card,
                            attributes,
                            n = 1,
                            inner_classes = NULL,
                            quiet = FALSE) {
  checkmate::assert_class(teal_card, "teal_card")
  checkmate::assert_list(attributes, names = "unique")
  checkmate::assert_int(n, lower = 1)
  checkmate::assert_character(inner_classes, null.ok = TRUE)
  checkmate::assert_flag(quiet)

  if (!inherits(teal_card[[length(teal_card)]], "chunk_output")) {
    if (!quiet) {
      warning("The last element of the `teal_card` is not a `chunk_output` object. No attributes were modified.")
    }
    return(teal_card)
  }

  for (ix in seq_len(length(teal_card))) {
    if (ix > n) {
      break
    }
    current_ix <- length(teal_card) + 1 - ix
    if (!inherits(teal_card[[current_ix]], "chunk_output")) {
      if (!quiet) {
        warning(
          "The ", ix,
          " to last element of the `teal_card` is not a `chunk_output` object. Skipping any further modifications."
        )
      }
      return(teal_card)
    }

    if (
      length(inner_classes) > 0 &&
        length(teal_card[[current_ix]]) >= 1 &&
        !checkmate::test_multi_class(teal_card[[current_ix]][[1]], inner_classes)
    ) {
      next
    }

    attributes(teal_card[[current_ix]]) <- utils::modifyList(
      attributes(teal_card[[current_ix]]),
      attributes
    )
  }

  teal_card
}

#' Create a reactive that sets plot dimensions on a `teal_card`
#'
#' This is a convenience function that creates a reactive expression that
#' automatically sets the `dev.width` and `dev.height` attributes on the last
#' chunk outputs of a `teal_card` based on plot dimensions from a plot widget.
#'
#' @param pws (`plot_widget`) plot widget that provides dimensions via `dim()` method
#' @param q_r (`reactive`) reactive expression that returns a `teal_reporter`
#' @param inner_classes (`character`) classes within `chunk_output` that should be modified.
#' This can be used to only change `recordedplot`, `ggplot2` or other type of objects.
#'
#' @return A reactive expression that returns the `teal_card` with updated dimensions
#'
#' @keywords internal
set_chunk_dims <- function(pws, q_r, inner_classes = NULL) {
  checkmate::assert_list(pws)
  checkmate::assert_names(names(pws), must.include = "dim")
  checkmate::assert_class(pws$dim, "reactive")
  checkmate::assert_class(q_r, "reactive")
  checkmate::assert_character(inner_classes, null.ok = TRUE)

  reactive({
    pws_dim <- stats::setNames(as.list(req(pws$dim())), c("width", "height"))
    if (identical(pws_dim$width, "auto")) { # ignore non-numeric values (such as "auto")
      pws_dim$width <- NULL
    }
    if (identical(pws_dim$height, "auto")) { # ignore non-numeric values (such as "auto")
      pws_dim$height <- NULL
    }
    q <- req(q_r())
    teal.reporter::teal_card(q) <- set_chunk_attrs(
      teal.reporter::teal_card(q),
      list(dev.width = pws_dim$width, dev.height = pws_dim$height),
      inner_classes = inner_classes
    )
    q
  })
}

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

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

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

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	!	teal.widgets::standard_layout(
107	!	output = tags$div(
108	!	uiOutput(ns("output"))
109		),
110	!	encoding = tags$div(
111	!	style = "overflow-y: hidden; overflow-x: auto;",
112	!	tags$label("Encodings", class = "text-primary"),
113	!	shinyTree::shinyTree(
114	!	ns("tree"),
115	!	dragAndDrop = FALSE,
116	!	sort = FALSE,
117	!	theme = "proton",
118	!	multiple = FALSE,
119	!	search = TRUE
120		)
121		)
122		)
123		)
124		}
125
126		# Server function for the file viewer module
127		srv_viewer <- function(id, input_path) {
128	!	moduleServer(id, function(input, output, session) {
129	!	teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")
130
131	!	temp_dir <- tempfile()
132	!	if (!dir.exists(temp_dir)) {
133	!	dir.create(temp_dir, recursive = TRUE)
134		}
135	!	addResourcePath(basename(temp_dir), temp_dir)
136
137	!	test_path_text <- function(selected_path, type) {
138	!	out <- tryCatch(
139	!	expr = {
140	!	if (type != "url") {
141	!	selected_path <- normalizePath(selected_path, winslash = "/")
142		}
143	!	readLines(con = selected_path)
144		},
145	!	error = function(cond) FALSE,
146	!	warning = function(cond) {
147	!	`if`(grepl("^incomplete final line found on", cond[[1]]), suppressWarnings(eval(cond[[2]])), FALSE)
148		}
149		)
150		}
151
152	!	handle_connection_type <- function(selected_path) {
153	!	file_extension <- tools::file_ext(selected_path)
154	!	file_class <- suppressWarnings(file(selected_path))
155	!	close(file_class)
156
157	!	output_text <- test_path_text(selected_path, type = class(file_class)[1])
158
159	!	if (class(file_class)[1] == "url") {
160	!	list(selected_path = selected_path, output_text = output_text)
161		} else {
162	!	file.copy(normalizePath(selected_path, winslash = "/"), temp_dir)
163	!	selected_path <- file.path(basename(temp_dir), basename(selected_path))
164	!	list(selected_path = selected_path, output_text = output_text)
165		}
166		}
167
168	!	display_file <- function(selected_path) {
169	!	con_type <- handle_connection_type(selected_path)
170	!	file_extension <- tools::file_ext(selected_path)
171	!	if (file_extension %in% c("png", "apng", "jpg", "jpeg", "svg", "gif", "webp", "bmp")) {
172	!	tags$img(src = con_type$selected_path, alt = "file does not exist")
173	!	} else if (file_extension == "pdf") {
174	!	tags$embed(
175	!	style = "height: 600px; width: 100%;",
176	!	src = con_type$selected_path
177		)
178	!	} else if (!isFALSE(con_type$output_text[1])) {
179	!	tags$pre(paste0(con_type$output_text, collapse = "\n"))
180		} else {
181	!	tags$p("Please select a supported format.")
182		}
183		}
184
185	!	tree_list <- function(file_or_dir) {
186	!	nested_list <- lapply(file_or_dir, function(path) {
187	!	file_class <- suppressWarnings(file(path))
188	!	close(file_class)
189	!	if (class(file_class)[[1]] != "url") {
190	!	isdir <- file.info(path)$isdir
191	!	if (!isdir) {
192	!	structure(path, ancestry = path, sticon = "file")
193		} else {
194	!	files <- list.files(path, full.names = TRUE, include.dirs = TRUE)
195	!	out <- lapply(files, function(x) tree_list(x))
196	!	out <- unlist(out, recursive = FALSE)
197	!	if (length(files) > 0) names(out) <- basename(files)
198	!	out
199		}
200		} else {
201	!	structure(path, ancestry = path, sticon = "file")
202		}
203		})
204
205	!	missing_labels <- if (is.null(names(nested_list))) seq_along(nested_list) else which(names(nested_list) == "")
206	!	names(nested_list)[missing_labels] <- file_or_dir[missing_labels]
207	!	nested_list
208		}
209
210	!	output$tree <- shinyTree::renderTree({
211	!	if (length(input_path) > 0) {
212	!	tree_list(input_path)
213		} else {
214	!	list("Empty Path" = NULL)
215		}
216		})
217
218	!	output$output <- renderUI({
219	!	validate(
220	!	need(
221	!	length(shinyTree::get_selected(input$tree)) > 0,
222	!	"Please select a file."
223		)
224		)
225
226	!	obj <- shinyTree::get_selected(input$tree, format = "names")[[1]]
227	!	repo <- attr(obj, "ancestry")
228	!	repo_collapsed <- if (length(repo) > 1) paste0(repo, collapse = "/") else repo
229	!	is_not_named <- file.exists(file.path(c(repo_collapsed, obj[1])))[1]
230
231	!	if (is_not_named) {
232	!	selected_path <- do.call("file.path", as.list(c(repo, obj[1])))
233		} else {
234	!	if (length(repo) == 0) {
235	!	selected_path <- do.call("file.path", as.list(attr(input$tree[[obj[1]]], "ancestry")))
236		} else {
237	!	selected_path <- do.call("file.path", as.list(attr(input$tree[[repo]][[obj[1]]], "ancestry")))
238		}
239		}
240
241	!	validate(
242	!	need(
243	!	!isTRUE(file.info(selected_path)$isdir) && length(selected_path) > 0,
244	!	"Please select a single file."
245		)
246		)
247	!	display_file(selected_path)
248		})
249
250	!	onStop(function() {
251	!	removeResourcePath(basename(temp_dir))
252	!	unlink(temp_dir)
253		})
254		})
255		}

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_stop(
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	!	teal.widgets::standard_layout(
162	!	output = teal.widgets::white_small_well(
163	!	bslib::page_fluid(
164	!	checkboxInput(
165	!	ns("if_distinct"),
166	!	"Show only distinct rows:",
167	!	value = FALSE
168		)
169		),
170	!	bslib::page_fluid(
171	!	uiOutput(ns("dataset_table"))
172		)
173		),
174	!	pre_output = pre_output,
175	!	post_output = post_output
176		)
177		)
178		}
179
180		# Server page module
181		srv_page_data_table <- function(id,
182		data,
183		datanames,
184		variables_selected,
185		dt_args,
186		dt_options,
187		server_rendering) {
188	!	checkmate::assert_class(data, "reactive")
189	!	checkmate::assert_class(isolate(data()), "teal_data")
190	!	moduleServer(id, function(input, output, session) {
191	!	teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")
192
193	!	if_filtered <- reactive(as.logical(input$if_filtered))
194	!	if_distinct <- reactive(as.logical(input$if_distinct))
195
196	!	datanames <- Filter(function(name) {
197	!	is.data.frame(isolate(data())[[name]])
198	!	}, if (identical(datanames, "all")) names(isolate(data())) else datanames)
199
200
201	!	output$dataset_table <- renderUI({
202	!	do.call(
203	!	tabsetPanel,
204	!	c(
205	!	list(id = session$ns("dataname_tab")),
206	!	lapply(
207	!	datanames,
208	!	function(x) {
209	!	dataset <- isolate(data()[[x]])
210	!	choices <- names(dataset)
211	!	labels <- vapply(
212	!	dataset,
213	!	function(x) ifelse(is.null(attr(x, "label")), "", attr(x, "label")),
214	!	character(1)
215		)
216	!	names(choices) <- ifelse(
217	!	is.na(labels) \| labels == "",
218	!	choices,
219	!	paste(choices, labels, sep = ": ")
220		)
221	!	variables_selected <- if (!is.null(variables_selected[[x]])) {
222	!	variables_selected[[x]]
223		} else {
224	!	utils::head(choices)
225		}
226	!	tabPanel(
227	!	title = x,
228	!	bslib::layout_columns(
229	!	col_widths = 12,
230	!	ui_data_table(
231	!	id = session$ns(x),
232	!	choices = choices,
233	!	selected = variables_selected
234		)
235		)
236		)
237		}
238		)
239		)
240		)
241		})
242
243	!	lapply(
244	!	datanames,
245	!	function(x) {
246	!	srv_data_table(
247	!	id = x,
248	!	data = data,
249	!	dataname = x,
250	!	if_filtered = if_filtered,
251	!	if_distinct = if_distinct,
252	!	dt_args = dt_args,
253	!	dt_options = dt_options,
254	!	server_rendering = server_rendering
255		)
256		}
257		)
258		})
259		}
260
261		# UI function for the data_table module
262		ui_data_table <- function(id, choices, selected) {
263	!	ns <- NS(id)
264
265	!	if (!is.null(selected)) {
266	!	all_choices <- choices
267	!	choices <- c(selected, setdiff(choices, selected))
268	!	names(choices) <- names(all_choices)[match(choices, all_choices)]
269		}
270
271	!	tagList(
272	!	teal.widgets::get_dt_rows(ns("data_table"), ns("dt_rows")),
273	!	bslib::page_fluid(
274	!	teal.widgets::optionalSelectInput(
275	!	ns("variables"),
276	!	"Select variables:",
277	!	choices = choices,
278	!	selected = selected,
279	!	multiple = TRUE,
280	!	width = "100%"
281		)
282		),
283	!	bslib::page_fluid(
284	!	DT::dataTableOutput(ns("data_table"), width = "100%")
285		)
286		)
287		}
288
289		# Server function for the data_table module
290		srv_data_table <- function(id,
291		data,
292		dataname,
293		if_filtered,
294		if_distinct,
295		dt_args,
296		dt_options,
297		server_rendering) {
298	!	moduleServer(id, function(input, output, session) {
299	!	iv <- shinyvalidate::InputValidator$new()
300	!	iv$add_rule("variables", shinyvalidate::sv_required("Please select valid variable names"))
301	!	iv$add_rule("variables", shinyvalidate::sv_in_set(
302	!	set = names(isolate(data())[[dataname]]), message_fmt = "Not all selected variables exist in the data"
303		))
304	!	iv$enable()
305
306	!	data_table_data <- reactive({
307	!	df <- data()[[dataname]]
308
309	!	teal::validate_has_data(df, min_nrow = 1L, msg = paste("data", dataname, "is empty"))
310	!	qenv <- teal.code::eval_code(
311	!	data(),
312	!	'library("dplyr");library("DT")' # nolint: quotes.
313		)
314	!	teal.code::eval_code(
315	!	qenv,
316	!	substitute(
317	!	expr = {
318	!	variables <- vars
319	!	dataframe_selected <- if (if_distinct) {
320	!	dplyr::count(dataname, dplyr::across(dplyr::all_of(variables)))
321		} else {
322	!	dataname[variables]
323		}
324	!	dt_args <- args
325	!	dt_args$options <- dt_options
326	!	if (!is.null(dt_rows)) {
327	!	dt_args$options$pageLength <- dt_rows
328		}
329	!	dt_args$data <- dataframe_selected
330	!	table <- do.call(DT::datatable, dt_args)
331		},
332	!	env = list(
333	!	dataname = as.name(dataname),
334	!	if_distinct = if_distinct(),
335	!	vars = input$variables,
336	!	args = dt_args,
337	!	dt_options = dt_options,
338	!	dt_rows = input$dt_rows
339		)
340		)
341		)
342		})
343
344	!	output$data_table <- DT::renderDataTable(server = server_rendering, {
345	!	teal::validate_inputs(iv)
346	!	req(data_table_data())[["table"]]
347		})
348		})
349		}

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

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		#'
238		#' @param id (`character(1)`) the id of the tab panel with tabs.
239		#' @param name (`character(1)`) the name of the tab.
240		#' @return JavaScript expression to be used in `shiny::conditionalPanel()` to determine
241		#' if the specified tab is active.
242		#' @keywords internal
243		#'
244		is_tab_active_js <- function(id, name) {
245		# supporting the bs3 and higher version at the same time
246	!	sprintf(
247	!	"$(\"#%1$s > li.active\").text().trim() == '%2$s' \|\| $(\"#%1$s > li a.active\").text().trim() == '%2$s'",
248	!	id, name
249		)
250		}
251
252		#' Assert single selection on `data_extract_spec` object
253		#' Helper to reduce code in assertions
254		#' @noRd
255		#'
256		assert_single_selection <- function(x,
257		.var.name = checkmate::vname(x)) { # nolint: object_name.
258	104x	if (any(vapply(x, function(.x) .x$select$multiple, logical(1)))) {
259	4x	stop("'", .var.name, "' should not allow multiple selection")
260		}
261	100x	invisible(TRUE)
262		}
263
264		#' Wrappers around `srv_transform_teal_data` that allows to decorate the data
265		#' @inheritParams teal::srv_transform_teal_data
266		#' @inheritParams teal.reporter::`eval_code,teal_report-method`
267		#' @param expr (`reactive`) with expression to evaluate on the output of the
268		#' decoration. It must be compatible with `code` argument of [teal.code::eval_code()].
269		#' Default is `NULL` which won't evaluate any appending code.
270		#' @details
271		#' `srv_decorate_teal_data` is a wrapper around `srv_transform_teal_data` that
272		#' allows to decorate the data with additional expressions.
273		#' When original `teal_data` object is in error state, it will show that error
274		#' first.
275		#'
276		#' @keywords internal
277		srv_decorate_teal_data <- function(id, data, decorators, expr) {
278	!	checkmate::assert_class(data, classes = "reactive")
279	!	checkmate::assert_list(decorators, "teal_transform_module")
280
281	!	no_expr <- missing(expr)
282
283	!	moduleServer(id, function(input, output, session) {
284	!	decorated_output <- srv_transform_teal_data("inner", data = data, transformators = decorators)
285
286	!	expr_r <- if (is.reactive(expr)) expr else reactive(expr)
287
288	!	reactive({
289	!	req(decorated_output())
290	!	if (no_expr) {
291	!	decorated_output()
292		} else {
293	!	teal.code::eval_code(decorated_output(), expr_r())
294		}
295		})
296		})
297		}
298
299		#' @rdname srv_decorate_teal_data
300		#' @details
301		#' `ui_decorate_teal_data` is a wrapper around `ui_transform_teal_data`.
302		#' @keywords internal
303		ui_decorate_teal_data <- function(id, decorators, ...) {
304	!	teal::ui_transform_teal_data(NS(id, "inner"), transformators = decorators, ...)
305		}
306
307		#' Internal function to check if decorators is a valid object
308		#' @noRd
309		check_decorators <- function(x, names = NULL) { # nolint: object_name.
310
311	5x	check_message <- checkmate::check_list(x, names = "named")
312
313	5x	if (!is.null(names)) {
314	5x	if (isTRUE(check_message)) {
315	5x	if (length(names(x)) != length(unique(names(x)))) {
316	!	check_message <- sprintf(
317	!	"The `decorators` must contain unique names from these names: %s.",
318	!	paste(names, collapse = ", ")
319		)
320		}
321		} else {
322	!	check_message <- sprintf(
323	!	"The `decorators` must be a named list from these names: %s.",
324	!	paste(names, collapse = ", ")
325		)
326		}
327		}
328
329	5x	if (!isTRUE(check_message)) {
330	!	return(check_message)
331		}
332
333	5x	valid_elements <- vapply(
334	5x	x,
335	5x	checkmate::test_class,
336	5x	classes = "teal_transform_module",
337	5x	FUN.VALUE = logical(1L)
338		)
339
340	5x	if (all(valid_elements)) {
341	5x	return(TRUE)
342		}
343
344	!	"Make sure that the named list contains 'teal_transform_module' objects created using `teal_transform_module()`."
345		}
346		#' Internal assertion on decorators
347		#' @noRd
348		assert_decorators <- checkmate::makeAssertionFunction(check_decorators)
349
350		#' Subset decorators based on the scope
351		#'
352		#' @param scope (`character`) a character vector of decorator names to include.
353		#' @param decorators (named `list`) of list decorators to subset.
354		#'
355		#' @return Subsetted list with all decorators to include.
356		#' It can be an empty list if none of the scope exists in `decorators` argument.
357		#' @keywords internal
358		select_decorators <- function(decorators, scope) {
359	!	checkmate::assert_character(scope, null.ok = TRUE)
360	!	if (scope %in% names(decorators)) {
361	!	decorators[scope]
362		} else {
363	!	list()
364		}
365		}
366
367		#' Set the attributes of the last chunk outputs
368		#' @param teal_card (`teal_card`) object to modify.
369		#' @param attributes (`list`) of attributes to set on the last chunk outputs.
370		#' @param n (`integer(1)`) number of the last element of `teal_card` to modify.
371		#' it will only change `chunk_output` objects.
372		#' @param inner_classes (`character`) classes within `chunk_output` that should be modified.
373		#' This can be used to only change `recordedplot`, `ggplot2` or other type of objects.
374		#' @keywords internal
375		set_chunk_attrs <- function(teal_card,
376		attributes,
377		n = 1,
378		inner_classes = NULL,
379		quiet = FALSE) {
380	7x	checkmate::assert_class(teal_card, "teal_card")
381	7x	checkmate::assert_list(attributes, names = "unique")
382	7x	checkmate::assert_int(n, lower = 1)
383	7x	checkmate::assert_character(inner_classes, null.ok = TRUE)
384	7x	checkmate::assert_flag(quiet)
385
386	7x	if (!inherits(teal_card[[length(teal_card)]], "chunk_output")) {
387	1x	if (!quiet) {
388	1x	warning("The last element of the `teal_card` is not a `chunk_output` object. No attributes were modified.")
389		}
390	1x	return(teal_card)
391		}
392
393	6x	for (ix in seq_len(length(teal_card))) {
394	14x	if (ix > n) {
395	4x	break
396		}
397	10x	current_ix <- length(teal_card) + 1 - ix
398	10x	if (!inherits(teal_card[[current_ix]], "chunk_output")) {
399	2x	if (!quiet) {
400	1x	warning(
401	1x	"The ", ix,
402	1x	" to last element of the `teal_card` is not a `chunk_output` object. Skipping any further modifications."
403		)
404		}
405	2x	return(teal_card)
406		}
407
408		if (
409	8x	length(inner_classes) > 0 &&
410	8x	length(teal_card[[current_ix]]) >= 1 &&
411	8x	!checkmate::test_multi_class(teal_card[[current_ix]][[1]], inner_classes)
412		) {
413	1x	next
414		}
415
416	7x	attributes(teal_card[[current_ix]]) <- utils::modifyList(
417	7x	attributes(teal_card[[current_ix]]),
418	7x	attributes
419		)
420		}
421
422	4x	teal_card
423		}
424
425		#' Create a reactive that sets plot dimensions on a `teal_card`
426		#'
427		#' This is a convenience function that creates a reactive expression that
428		#' automatically sets the `dev.width` and `dev.height` attributes on the last
429		#' chunk outputs of a `teal_card` based on plot dimensions from a plot widget.
430		#'
431		#' @param pws (`plot_widget`) plot widget that provides dimensions via `dim()` method
432		#' @param q_r (`reactive`) reactive expression that returns a `teal_reporter`
433		#' @param inner_classes (`character`) classes within `chunk_output` that should be modified.
434		#' This can be used to only change `recordedplot`, `ggplot2` or other type of objects.
435		#'
436		#' @return A reactive expression that returns the `teal_card` with updated dimensions
437		#'
438		#' @keywords internal
439		set_chunk_dims <- function(pws, q_r, inner_classes = NULL) {
440	1x	checkmate::assert_list(pws)
441	1x	checkmate::assert_names(names(pws), must.include = "dim")
442	1x	checkmate::assert_class(pws$dim, "reactive")
443	1x	checkmate::assert_class(q_r, "reactive")
444	1x	checkmate::assert_character(inner_classes, null.ok = TRUE)
445
446	1x	reactive({
447	1x	pws_dim <- stats::setNames(as.list(req(pws$dim())), c("width", "height"))
448	1x	if (identical(pws_dim$width, "auto")) { # ignore non-numeric values (such as "auto")
449	1x	pws_dim$width <- NULL
450		}
451	1x	if (identical(pws_dim$height, "auto")) { # ignore non-numeric values (such as "auto")
452	!	pws_dim$height <- NULL
453		}
454	1x	q <- req(q_r())
455	1x	teal.reporter::teal_card(q) <- set_chunk_attrs(
456	1x	teal.reporter::teal_card(q),
457	1x	list(dev.width = pws_dim$width, dev.height = pws_dim$height),
458	1x	inner_classes = inner_classes
459		)
460	1x	q
461		})
462		}

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_stop(
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	!	tags$div(
123	!	id = "front_page_content",
124	!	style = "margin-left: 2rem;",
125	!	tags$div(
126	!	id = "front_page_headers",
127	!	get_header_tags(args$header_text)
128		),
129	!	tags$div(
130	!	id = "front_page_tables",
131	!	style = "margin-left: 2rem;",
132	!	get_table_tags(args$tables, ns)
133		),
134	!	tags$div(
135	!	id = "front_page_custom_html",
136	!	style = "margin-left: 2rem;",
137	!	args$additional_tags
138		),
139	!	if (length(args$datanames) > 0L) {
140	!	tags$div(
141	!	id = "front_page_metabutton",
142	!	style = "margin: 1rem;",
143	!	actionButton(ns("metadata_button"), "Show metadata")
144		)
145		},
146	!	tags$footer(
147	!	class = "small",
148	!	get_footer_tags(args$footnotes)
149		)
150		)
151		)
152		}
153
154		# Server function for the front page module
155		srv_front_page <- function(id, data, tables) {
156	!	checkmate::assert_class(data, "reactive")
157	!	checkmate::assert_class(isolate(data()), "teal_data")
158	!	moduleServer(id, function(input, output, session) {
159	!	teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")
160
161	!	ns <- session$ns
162
163	!	setBookmarkExclude("metadata_button")
164
165	!	lapply(seq_along(tables), function(idx) {
166	!	output[[paste0("table_", idx)]] <- renderTable(
167	!	tables[[idx]],
168	!	bordered = TRUE,
169	!	caption = names(tables)[idx],
170	!	caption.placement = "top"
171		)
172		})
173	!	if (length(isolate(names(data()))) > 0L) {
174	!	observeEvent(
175	!	input$metadata_button, showModal(
176	!	modalDialog(
177	!	title = "Metadata",
178	!	dataTableOutput(ns("metadata_table")),
179	!	size = "l",
180	!	easyClose = TRUE
181		)
182		)
183		)
184
185	!	metadata_data_frame <- reactive({
186	!	datanames <- names(data())
187	!	convert_metadata_to_dataframe(
188	!	lapply(datanames, function(dataname) attr(data()[[dataname]], "metadata")),
189	!	datanames
190		)
191		})
192
193	!	output$metadata_table <- renderDataTable({
194	!	validate(need(nrow(metadata_data_frame()) > 0, "The data has no associated metadata"))
195	!	metadata_data_frame()
196		})
197		}
198		})
199		}
200
201		## utils functions
202
203		get_header_tags <- function(header_text) {
204	!	if (length(header_text) == 0) {
205	!	return(list())
206		}
207
208	!	get_single_header_tags <- function(header_text, p_text, header_tag = tags$h4) {
209	!	tagList(
210	!	tags$div(
211	!	if (!is.null(header_text) && nchar(header_text) > 0) header_tag(header_text),
212	!	tags$p(p_text)
213		)
214		)
215		}
216
217	!	header_tags <- get_single_header_tags(names(header_text[1]), header_text[1], header_tag = tags$h3)
218	!	c(header_tags, mapply(get_single_header_tags, utils::tail(names(header_text), -1), utils::tail(header_text, -1)))
219		}
220
221		get_table_tags <- function(tables, ns) {
222	!	if (length(tables) == 0) {
223	!	return(list())
224		}
225	!	table_tags <- c(lapply(seq_along(tables), function(idx) {
226	!	list(
227	!	tableOutput(ns(paste0("table_", idx)))
228		)
229		}))
230	!	table_tags
231		}
232
233		get_footer_tags <- function(footnotes) {
234	!	if (length(footnotes) == 0) {
235	!	return(list())
236		}
237	!	bold_texts <- if (is.null(names(footnotes))) rep("", length(footnotes)) else names(footnotes)
238	!	footnote_tags <- mapply(function(bold_text, value) {
239	!	list(
240	!	tags$div(
241	!	tags$b(bold_text),
242	!	value,
243	!	tags$br()
244		)
245		)
246	!	}, bold_text = bold_texts, value = footnotes)
247		}
248
249		# take a list of metadata, one item per dataset (raw_metadata each element from datasets$get_metadata())
250		# and the corresponding datanames and output a data.frame with columns {Dataset, Name, Value}.
251		# which are, the Dataset the metadata came from, the metadata's name and value
252		convert_metadata_to_dataframe <- function(raw_metadata, datanames) {
253	4x	output <- mapply(function(metadata, dataname) {
254	6x	if (is.null(metadata)) {
255	2x	return(data.frame(Dataset = character(0), Name = character(0), Value = character(0)))
256		}
257	4x	data.frame(
258	4x	Dataset = dataname,
259	4x	Name = names(metadata),
260	4x	Value = unname(unlist(lapply(metadata, as.character)))
261		)
262	4x	}, raw_metadata, datanames, SIMPLIFY = FALSE)
263	4x	do.call(rbind, output)
264		}

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` (`ggplot`)
24		#' - `combination_plot` (`grob` created with [ggplot2::ggplotGrob()])
25		#' - `by_subject_plot` (`ggplot`)
26		#'
27		#' A Decorator is applied to the specific output using a named list of `teal_transform_module` objects.
28		#' The name of this list corresponds to the name of the output to which the decorator is applied.
29		#' See code snippet below:
30		#'
31		#' ```
32		#' tm_missing_data(
33		#' ..., # arguments for module
34		#' decorators = list(
35		#' summary_plot = teal_transform_module(...), # applied only to `summary_plot` output
36		#' combination_plot = teal_transform_module(...), # applied only to `combination_plot` output
37		#' by_subject_plot = teal_transform_module(...) # applied only to `by_subject_plot` output
38		#' )
39		#' )
40		#' ```

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		#'
35		#' A Decorator is applied to the specific output using a named list of `teal_transform_module` objects.
36		#' The name of this list corresponds to the name of the output to which the decorator is applied.
37		#' See code snippet below:
38		#'
39		#' ```
40		#' tm_g_distribution(

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