forked from ddsjoberg/gtsummary
-
Notifications
You must be signed in to change notification settings - Fork 0
/
modify_column_merge.R
127 lines (124 loc) · 5 KB
/
modify_column_merge.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
#' Modify Column Merging
#'
#' \lifecycle{experimental}
#' Merge two or more columns in a gtsummary table.
#' Use `show_header_names()` to print underlying column names.
#' @param pattern glue syntax string indicating how to merge columns in
#' `x$table_body`. For example, to construct a confidence interval
#' use `"{conf.low}, {conf.high}"`.
#' @inheritParams modify_table_styling
#'
#' @section Details:
#' 1. Calling this function merely records the instructions to merge columns.
#' The actual merging occurs when the gtsummary table is printed or converted
#' with a function like `as_gt()`.
#' 2. Because the column merging is delayed, it is recommended to perform
#' major modifications to the table, such as those with `tbl_merge()` and
#' `tbl_stack()`, before assigning merging instructions. Otherwise,
#' unexpected formatting may occur in the final table.
#' 3. If this functionality is used in conjunction with `tbl_stack()` (which
#' includes `tbl_uvregression()`), there is potential issue with printing.
#' When columns are stack AND when the column-merging is
#' defined with a quosure, you may run into issues due to the loss of the
#' environment when 2 or more quosures are combined. If the expression
#' version of the quosure is the same as the quosure (i.e. no evaluated
#' objects), there should be no issues. Regardless, this argument is used
#' internally with care, and **it is _not_ recommended for users**.
#'
#' @section Future Updates:
#' There are planned updates to the implementation of this function
#' with respect to the `pattern=` argument.
#' Currently, this function replaces a numeric column with a
#' formatted character column following `pattern=`.
#' Once `gt::cols_merge()` gains the `rows=` argument the
#' implementation will be updated to use it, which will keep
#' numeric columns numeric. For the _vast majority_ of users,
#' _the planned change will be go unnoticed_.
#'
#' If this functionality is used in conjunction with `tbl_stack()` (which
#' includes `tbl_uvregression()`), there is potential issue with printing.
#' When columns are stack AND when the column-merging is
#' defined with a quosure, you may run into issues due to the loss of the
#' environment when 2 or more quosures are combined. If the expression
#' version of the quosure is the same as the quosure (i.e. no evaluated
#' objects), there should be no issues. Regardless, this argument is used
#' internally with care, and it is _not_ recommended for users.
#'
#' @return gtsummary table
#' @export
#'
#' @family Advanced modifiers
#' @examples
#' \donttest{
#' # Example 1 ----------------------------------
#' modify_column_merge_ex1 <-
#' trial %>%
#' select(age, marker, trt) %>%
#' tbl_summary(by = trt, missing = "no") %>%
#' add_p(all_continuous() ~ "t.test",
#' pvalue_fun = ~ style_pvalue(., prepend_p = TRUE)
#' ) %>%
#' modify_fmt_fun(statistic ~ style_sigfig) %>%
#' modify_column_merge(pattern = "t = {statistic}; {p.value}") %>%
#' modify_header(statistic ~ "**t-test**")
#'
#' # Example 2 ----------------------------------
#' modify_column_merge_ex2 <-
#' lm(marker ~ age + grade, trial) %>%
#' tbl_regression() %>%
#' modify_column_merge(
#' pattern = "{estimate} ({ci})",
#' rows = !is.na(estimate)
#' )
#' }
#' @section Example Output:
#' \if{html}{Example 1}
#'
#' \if{html}{\out{
#' `r man_create_image_tag(file = "modify_column_merge_ex1.png", width = "65")`
#' }}
#'
#' \if{html}{Example 2}
#'
#' \if{html}{\out{
#' `r man_create_image_tag(file = "modify_column_merge_ex2.png", width = "41")`
#' }}
modify_column_merge <- function(x, pattern, rows = NULL) {
# check inputs ---------------------------------------------------------------
.assert_class(x, "gtsummary")
if (!rlang::is_string(pattern)) abort("`pattern=` must be a string.")
updated_call_list <- c(x$call_list, list(modify_column_hide = match.call()))
# extract columns from pattern -----------------------------------------------
columns <-
pattern %>%
str_extract_all("\\{.*?\\}") %>%
map(~ str_remove_all(.x, pattern = "^\\{|\\}$")) %>%
unlist()
if (length(columns) == 0L) {
cli::cli_alert_danger("No column names found in {.code modify_column_merge(pattern=)}")
cli::cli_ul("Wrap all column names in curly brackets.")
abort("Error in `pattern=` argument")
}
if (!all(columns %in% names(x$table_body))) {
problem_cols <- columns %>% setdiff(names(x$table_body))
paste(
"Some columns specified in {.code modify_column_merge(pattern=)}",
"were not found in the table, e.g. {.val {problem_cols}}"
) %>%
cli::cli_alert_danger()
cli::cli_ul("Select from {.val {names(x$table_body)}}.")
abort("Error in `pattern=` argument")
}
# merge columns --------------------------------------------------------------
x <-
modify_table_styling(
x,
columns = columns[1],
rows = {{ rows }},
hide = FALSE,
cols_merge_pattern = pattern,
)
# return gtsummary table -----------------------------------------------------
x$call_list <- updated_call_list
x
}