1 |
#' Cumulative counts of numeric variable by thresholds |
|
2 |
#' |
|
3 |
#' @description `r lifecycle::badge("stable")` |
|
4 |
#' |
|
5 |
#' The analyze function [count_cumulative()] creates a layout element to calculate cumulative counts of values in a |
|
6 |
#' numeric variable that are less than, less or equal to, greater than, or greater or equal to user-specified |
|
7 |
#' threshold values. |
|
8 |
#' |
|
9 |
#' This function analyzes numeric variable `vars` against the threshold values supplied to the `thresholds` |
|
10 |
#' argument as a numeric vector. Whether counts should include the threshold values, and whether to count |
|
11 |
#' values lower or higher than the threshold values can be set via the `include_eq` and `lower_tail` |
|
12 |
#' parameters, respectively. |
|
13 |
#' |
|
14 |
#' @inheritParams h_count_cumulative |
|
15 |
#' @inheritParams argument_convention |
|
16 |
#' @param thresholds (`numeric`)\cr vector of cutoff values for the counts. |
|
17 |
#' @param .stats (`character`)\cr statistics to select for the table. |
|
18 |
#' |
|
19 |
#' Options are: ``r shQuote(get_stats("count_cumulative"), type = "sh")`` |
|
20 |
#' |
|
21 |
#' @seealso Relevant helper function [h_count_cumulative()], and descriptive function [d_count_cumulative()]. |
|
22 |
#' |
|
23 |
#' @name count_cumulative |
|
24 |
#' @order 1 |
|
25 |
NULL |
|
26 | ||
27 |
#' Helper function for `s_count_cumulative()` |
|
28 |
#' |
|
29 |
#' @description `r lifecycle::badge("stable")` |
|
30 |
#' |
|
31 |
#' Helper function to calculate count and fraction of `x` values in the lower or upper tail given a threshold. |
|
32 |
#' |
|
33 |
#' @inheritParams argument_convention |
|
34 |
#' @param threshold (`numeric(1)`)\cr a cutoff value as threshold to count values of `x`. |
|
35 |
#' @param lower_tail (`flag`)\cr whether to count lower tail, default is `TRUE`. |
|
36 |
#' @param include_eq (`flag`)\cr whether to include value equal to the `threshold` in |
|
37 |
#' count, default is `TRUE`. |
|
38 |
#' |
|
39 |
#' @return A named vector with items: |
|
40 |
#' * `count`: the count of values less than, less or equal to, greater than, or greater or equal to a threshold |
|
41 |
#' of user specification. |
|
42 |
#' * `fraction`: the fraction of the count. |
|
43 |
#' |
|
44 |
#' @seealso [count_cumulative] |
|
45 |
#' |
|
46 |
#' @examples |
|
47 |
#' set.seed(1, kind = "Mersenne-Twister") |
|
48 |
#' x <- c(sample(1:10, 10), NA) |
|
49 |
#' .N_col <- length(x) |
|
50 |
#' |
|
51 |
#' h_count_cumulative(x, 5, denom = .N_col) |
|
52 |
#' h_count_cumulative(x, 5, lower_tail = FALSE, include_eq = FALSE, na_rm = FALSE, denom = .N_col) |
|
53 |
#' h_count_cumulative(x, 0, lower_tail = FALSE, denom = .N_col) |
|
54 |
#' h_count_cumulative(x, 100, lower_tail = FALSE, denom = .N_col) |
|
55 |
#' |
|
56 |
#' @export |
|
57 |
h_count_cumulative <- function(x, |
|
58 |
threshold, |
|
59 |
lower_tail = TRUE, |
|
60 |
include_eq = TRUE, |
|
61 |
na_rm = TRUE, |
|
62 |
denom) { |
|
63 | 48x |
checkmate::assert_numeric(x) |
64 | 48x |
checkmate::assert_numeric(threshold) |
65 | 48x |
checkmate::assert_numeric(denom) |
66 | 48x |
checkmate::assert_flag(lower_tail) |
67 | 48x |
checkmate::assert_flag(include_eq) |
68 | 48x |
checkmate::assert_flag(na_rm) |
69 | ||
70 | 48x |
is_keep <- if (na_rm) !is.na(x) else rep(TRUE, length(x)) |
71 | 48x |
count <- if (lower_tail && include_eq) { |
72 | 19x |
length(x[is_keep & x <= threshold]) |
73 | 48x |
} else if (lower_tail && !include_eq) { |
74 | ! |
length(x[is_keep & x < threshold]) |
75 | 48x |
} else if (!lower_tail && include_eq) { |
76 | 14x |
length(x[is_keep & x >= threshold]) |
77 | 48x |
} else if (!lower_tail && !include_eq) { |
78 | 15x |
length(x[is_keep & x > threshold]) |
79 |
} |
|
80 | ||
81 | 48x |
result <- c( |
82 | 48x |
count = count, |
83 | 48x |
fraction = if (count == 0 && denom == 0) 0 else count / denom |
84 |
) |
|
85 | 48x |
result |
86 |
} |
|
87 | ||
88 |
#' Description of cumulative count |
|
89 |
#' |
|
90 |
#' @description `r lifecycle::badge("stable")` |
|
91 |
#' |
|
92 |
#' This is a helper function that describes the analysis in [s_count_cumulative()]. |
|
93 |
#' |
|
94 |
#' @inheritParams h_count_cumulative |
|
95 |
#' |
|
96 |
#' @return Labels for [s_count_cumulative()]. |
|
97 |
#' |
|
98 |
#' @export |
|
99 |
d_count_cumulative <- function(threshold, lower_tail = TRUE, include_eq = TRUE) { |
|
100 | 46x |
checkmate::assert_numeric(threshold) |
101 | 46x |
lg <- if (lower_tail) "<" else ">" |
102 | 46x |
eq <- if (include_eq) "=" else "" |
103 | 46x |
paste0(lg, eq, " ", threshold) |
104 |
} |
|
105 | ||
106 |
#' @describeIn count_cumulative Statistics function that produces a named list given a numeric vector of thresholds. |
|
107 |
#' |
|
108 |
#' @return |
|
109 |
#' * `s_count_cumulative()` returns a named list of `count_fraction`s: a list with each `thresholds` value as a |
|
110 |
#' component, each component containing a vector for the count and fraction. |
|
111 |
#' |
|
112 |
#' @keywords internal |
|
113 |
s_count_cumulative <- function(x, |
|
114 |
thresholds, |
|
115 |
lower_tail = TRUE, |
|
116 |
include_eq = TRUE, |
|
117 |
denom = c("N_col", "n", "N_row"), |
|
118 |
.N_col, # nolint |
|
119 |
.N_row, # nolint |
|
120 |
na_rm = TRUE, |
|
121 |
...) { |
|
122 | 23x |
checkmate::assert_numeric(thresholds, min.len = 1, any.missing = FALSE) |
123 | ||
124 | 23x |
denom <- match.arg(denom) %>% |
125 | 23x |
switch( |
126 | 23x |
n = length(x), |
127 | 23x |
N_row = .N_row, |
128 | 23x |
N_col = .N_col |
129 |
) |
|
130 | ||
131 | 23x |
count_fraction_list <- Map(function(thres) { |
132 | 46x |
result <- h_count_cumulative(x, thres, lower_tail, include_eq, na_rm = na_rm, denom = denom) |
133 | 46x |
label <- d_count_cumulative(thres, lower_tail, include_eq) |
134 | 46x |
formatters::with_label(result, label) |
135 | 23x |
}, thresholds) |
136 | ||
137 | 23x |
names(count_fraction_list) <- thresholds |
138 | 23x |
list(count_fraction = count_fraction_list) |
139 |
} |
|
140 | ||
141 |
#' @describeIn count_cumulative Formatted analysis function which is used as `afun` |
|
142 |
#' in `count_cumulative()`. |
|
143 |
#' |
|
144 |
#' @return |
|
145 |
#' * `a_count_cumulative()` returns the corresponding list with formatted [rtables::CellValue()]. |
|
146 |
#' |
|
147 |
#' @keywords internal |
|
148 |
a_count_cumulative <- function(x, |
|
149 |
..., |
|
150 |
.stats = NULL, |
|
151 |
.stat_names = NULL, |
|
152 |
.formats = NULL, |
|
153 |
.labels = NULL, |
|
154 |
.indent_mods = NULL) { |
|
155 | 14x |
dots_extra_args <- list(...) |
156 | ||
157 |
# Check if there are user-defined functions |
|
158 | 14x |
default_and_custom_stats_list <- .split_std_from_custom_stats(.stats) |
159 | 14x |
.stats <- default_and_custom_stats_list$all_stats |
160 | 14x |
custom_stat_functions <- default_and_custom_stats_list$custom_stats |
161 | ||
162 |
# Adding automatically extra parameters to the statistic function (see ?rtables::additional_fun_params) |
|
163 | 14x |
extra_afun_params <- retrieve_extra_afun_params( |
164 | 14x |
names(dots_extra_args$.additional_fun_parameters) |
165 |
) |
|
166 | 14x |
dots_extra_args$.additional_fun_parameters <- NULL # After extraction we do not need them anymore |
167 | ||
168 |
# Main statistical functions application |
|
169 | 14x |
x_stats <- .apply_stat_functions( |
170 | 14x |
default_stat_fnc = s_count_cumulative, |
171 | 14x |
custom_stat_fnc_list = custom_stat_functions, |
172 | 14x |
args_list = c( |
173 | 14x |
x = list(x), |
174 | 14x |
extra_afun_params, |
175 | 14x |
dots_extra_args |
176 |
) |
|
177 |
) |
|
178 | ||
179 |
# Fill in with stats defaults if needed |
|
180 | 14x |
.stats <- get_stats("count_cumulative", |
181 | 14x |
stats_in = .stats, |
182 | 14x |
custom_stats_in = names(custom_stat_functions) |
183 |
) |
|
184 | ||
185 | 14x |
x_stats <- x_stats[.stats] |
186 | 14x |
levels_per_stats <- lapply(x_stats, names) |
187 | ||
188 |
# Fill in formats/indents/labels with custom input and defaults |
|
189 | 14x |
.formats <- get_formats_from_stats(.stats, .formats, levels_per_stats) |
190 | 14x |
.indent_mods <- get_indents_from_stats(.stats, .indent_mods, levels_per_stats) |
191 | 14x |
.labels <- get_labels_from_stats( |
192 | 14x |
.stats, .labels, levels_per_stats, |
193 | 14x |
label_attr_from_stats = sapply(.unlist_keep_nulls(x_stats), attr, "label") |
194 |
) |
|
195 | ||
196 |
# Unlist stats |
|
197 | 14x |
x_stats <- x_stats %>% |
198 | 14x |
.unlist_keep_nulls() %>% |
199 | 14x |
setNames(names(.formats)) |
200 | ||
201 |
# Auto format handling |
|
202 | 14x |
.formats <- apply_auto_formatting( |
203 | 14x |
.formats, |
204 | 14x |
x_stats, |
205 | 14x |
extra_afun_params$.df_row, |
206 | 14x |
extra_afun_params$.var |
207 |
) |
|
208 | ||
209 |
# Get and check statistical names from defaults |
|
210 | 14x |
.stat_names <- get_stat_names(x_stats, .stat_names) # note is x_stats |
211 | ||
212 | 14x |
in_rows( |
213 | 14x |
.list = x_stats, |
214 | 14x |
.formats = .formats, |
215 | 14x |
.names = names(.labels), |
216 | 14x |
.stat_names = .stat_names, |
217 | 14x |
.labels = .labels %>% .unlist_keep_nulls(), |
218 | 14x |
.indent_mods = .indent_mods %>% .unlist_keep_nulls() |
219 |
) |
|
220 |
} |
|
221 | ||
222 |
#' @describeIn count_cumulative Layout-creating function which can take statistics function arguments |
|
223 |
#' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
|
224 |
#' |
|
225 |
#' @return |
|
226 |
#' * `count_cumulative()` returns a layout object suitable for passing to further layouting functions, |
|
227 |
#' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
|
228 |
#' the statistics from `s_count_cumulative()` to the table layout. |
|
229 |
#' |
|
230 |
#' @examples |
|
231 |
#' basic_table() %>% |
|
232 |
#' split_cols_by("ARM") %>% |
|
233 |
#' add_colcounts() %>% |
|
234 |
#' count_cumulative( |
|
235 |
#' vars = "AGE", |
|
236 |
#' thresholds = c(40, 60) |
|
237 |
#' ) %>% |
|
238 |
#' build_table(tern_ex_adsl) |
|
239 |
#' |
|
240 |
#' @export |
|
241 |
#' @order 2 |
|
242 |
count_cumulative <- function(lyt, |
|
243 |
vars, |
|
244 |
thresholds, |
|
245 |
lower_tail = TRUE, |
|
246 |
include_eq = TRUE, |
|
247 |
var_labels = vars, |
|
248 |
show_labels = "visible", |
|
249 |
na_str = default_na_str(), |
|
250 |
nested = TRUE, |
|
251 |
table_names = vars, |
|
252 |
..., |
|
253 |
na_rm = TRUE, |
|
254 |
.stats = c("count_fraction"), |
|
255 |
.stat_names = NULL, |
|
256 |
.formats = NULL, |
|
257 |
.labels = NULL, |
|
258 |
.indent_mods = NULL) { |
|
259 |
# Depending on main functions |
|
260 | 6x |
extra_args <- list( |
261 | 6x |
"na_rm" = na_rm, |
262 | 6x |
"thresholds" = thresholds, |
263 | 6x |
"lower_tail" = lower_tail, |
264 | 6x |
"include_eq" = include_eq, |
265 |
... |
|
266 |
) |
|
267 | ||
268 |
# Needed defaults |
|
269 | 6x |
if (!is.null(.stats)) extra_args[[".stats"]] <- .stats |
270 | ! |
if (!is.null(.stat_names)) extra_args[[".stat_names"]] <- .stat_names |
271 | ! |
if (!is.null(.formats)) extra_args[[".formats"]] <- .formats |
272 | 1x |
if (!is.null(.labels)) extra_args[[".labels"]] <- .labels |
273 | ! |
if (!is.null(.indent_mods)) extra_args[[".indent_mods"]] <- .indent_mods |
274 | ||
275 |
# Adding all additional information from layout to analysis functions (see ?rtables::additional_fun_params) |
|
276 | 6x |
extra_args[[".additional_fun_parameters"]] <- get_additional_afun_params(add_alt_df = FALSE) |
277 | 6x |
formals(a_count_cumulative) <- c( |
278 | 6x |
formals(a_count_cumulative), |
279 | 6x |
extra_args[[".additional_fun_parameters"]] |
280 |
) |
|
281 | ||
282 |
# Main {rtables} structural call |
|
283 | 6x |
analyze( |
284 | 6x |
lyt, |
285 | 6x |
vars, |
286 | 6x |
afun = a_count_cumulative, |
287 | 6x |
na_str = na_str, |
288 | 6x |
inclNAs = !na_rm, |
289 | 6x |
table_names = table_names, |
290 | 6x |
var_labels = var_labels, |
291 | 6x |
show_labels = show_labels, |
292 | 6x |
nested = nested, |
293 | 6x |
extra_args = extra_args |
294 |
) |
|
295 |
} |
1 |
#' Univariate formula special term |
|
2 |
#' |
|
3 |
#' @description `r lifecycle::badge("stable")` |
|
4 |
#' |
|
5 |
#' The special term `univariate` indicate that the model should be fitted individually for |
|
6 |
#' every variable included in univariate. |
|
7 |
#' |
|
8 |
#' @param x (`character`)\cr a vector of variable names separated by commas. |
|
9 |
#' |
|
10 |
#' @return When used within a model formula, produces univariate models for each variable provided. |
|
11 |
#' |
|
12 |
#' @details |
|
13 |
#' If provided alongside with pairwise specification, the model |
|
14 |
#' `y ~ ARM + univariate(SEX, AGE, RACE)` lead to the study and comparison of the models |
|
15 |
#' + `y ~ ARM` |
|
16 |
#' + `y ~ ARM + SEX` |
|
17 |
#' + `y ~ ARM + AGE` |
|
18 |
#' + `y ~ ARM + RACE` |
|
19 |
#' |
|
20 |
#' @export |
|
21 |
univariate <- function(x) { |
|
22 | 2x |
structure(x, varname = deparse(substitute(x))) |
23 |
} |
|
24 | ||
25 |
# Get the right-hand-term of a formula |
|
26 |
rht <- function(x) { |
|
27 | 4x |
checkmate::assert_formula(x) |
28 | 4x |
y <- as.character(rev(x)[[1]]) |
29 | 4x |
return(y) |
30 |
} |
|
31 | ||
32 |
#' Hazard ratio estimation in interactions |
|
33 |
#' |
|
34 |
#' This function estimates the hazard ratios between arms when an interaction variable is given with |
|
35 |
#' specific values. |
|
36 |
#' |
|
37 |
#' @param variable,given (`character(2)`)\cr names of the two variables in the interaction. We seek the estimation of |
|
38 |
#' the levels of `variable` given the levels of `given`. |
|
39 |
#' @param lvl_var,lvl_given (`character`)\cr corresponding levels given by [levels()]. |
|
40 |
#' @param mmat (named `numeric`) a vector filled with `0`s used as a template to obtain the design matrix. |
|
41 |
#' @param coef (`numeric`)\cr vector of estimated coefficients. |
|
42 |
#' @param vcov (`matrix`)\cr variance-covariance matrix of underlying model. |
|
43 |
#' @param conf_level (`proportion`)\cr confidence level of estimate intervals. |
|
44 |
#' |
|
45 |
#' @details Given the cox regression investigating the effect of Arm (A, B, C; reference A) |
|
46 |
#' and Sex (F, M; reference Female). The model is abbreviated: y ~ Arm + Sex + Arm x Sex. |
|
47 |
#' The cox regression estimates the coefficients along with a variance-covariance matrix for: |
|
48 |
#' |
|
49 |
#' - b1 (arm b), b2 (arm c) |
|
50 |
#' - b3 (sex m) |
|
51 |
#' - b4 (arm b: sex m), b5 (arm c: sex m) |
|
52 |
#' |
|
53 |
#' Given that I want an estimation of the Hazard Ratio for arm C/sex M, the estimation |
|
54 |
#' will be given in reference to arm A/Sex M by exp(b2 + b3 + b5)/ exp(b3) = exp(b2 + b5), |
|
55 |
#' therefore the interaction coefficient is given by b2 + b5 while the standard error is obtained |
|
56 |
#' as $1.96 * sqrt(Var b2 + Var b5 + 2 * covariance (b2,b5))$ for a confidence level of 0.95. |
|
57 |
#' |
|
58 |
#' @return A list of matrices (one per level of variable) with rows corresponding to the combinations of |
|
59 |
#' `variable` and `given`, with columns: |
|
60 |
#' * `coef_hat`: Estimation of the coefficient. |
|
61 |
#' * `coef_se`: Standard error of the estimation. |
|
62 |
#' * `hr`: Hazard ratio. |
|
63 |
#' * `lcl, ucl`: Lower/upper confidence limit of the hazard ratio. |
|
64 |
#' |
|
65 |
#' @seealso [s_cox_multivariate()]. |
|
66 |
#' |
|
67 |
#' @examples |
|
68 |
#' library(dplyr) |
|
69 |
#' library(survival) |
|
70 |
#' |
|
71 |
#' ADSL <- tern_ex_adsl %>% |
|
72 |
#' filter(SEX %in% c("F", "M")) |
|
73 |
#' |
|
74 |
#' adtte <- tern_ex_adtte %>% filter(PARAMCD == "PFS") |
|
75 |
#' adtte$ARMCD <- droplevels(adtte$ARMCD) |
|
76 |
#' adtte$SEX <- droplevels(adtte$SEX) |
|
77 |
#' |
|
78 |
#' mod <- coxph( |
|
79 |
#' formula = Surv(time = AVAL, event = 1 - CNSR) ~ (SEX + ARMCD)^2, |
|
80 |
#' data = adtte |
|
81 |
#' ) |
|
82 |
#' |
|
83 |
#' mmat <- stats::model.matrix(mod)[1, ] |
|
84 |
#' mmat[!mmat == 0] <- 0 |
|
85 |
#' |
|
86 |
#' @keywords internal |
|
87 |
estimate_coef <- function(variable, given, |
|
88 |
lvl_var, lvl_given, |
|
89 |
coef, |
|
90 |
mmat, |
|
91 |
vcov, |
|
92 |
conf_level = 0.95) { |
|
93 | 8x |
var_lvl <- paste0(variable, lvl_var[-1]) # [-1]: reference level |
94 | 8x |
giv_lvl <- paste0(given, lvl_given) |
95 | ||
96 | 8x |
design_mat <- expand.grid(variable = var_lvl, given = giv_lvl) |
97 | 8x |
design_mat <- design_mat[order(design_mat$variable, design_mat$given), ] |
98 | 8x |
design_mat <- within( |
99 | 8x |
data = design_mat, |
100 | 8x |
expr = { |
101 | 8x |
inter <- paste0(variable, ":", given) |
102 | 8x |
rev_inter <- paste0(given, ":", variable) |
103 |
} |
|
104 |
) |
|
105 | ||
106 | 8x |
split_by_variable <- design_mat$variable |
107 | 8x |
interaction_names <- paste(design_mat$variable, design_mat$given, sep = "/") |
108 | ||
109 | 8x |
design_mat <- apply( |
110 | 8x |
X = design_mat, MARGIN = 1, FUN = function(x) { |
111 | 27x |
mmat[names(mmat) %in% x[-which(names(x) == "given")]] <- 1 |
112 | 27x |
return(mmat) |
113 |
} |
|
114 |
) |
|
115 | 8x |
colnames(design_mat) <- interaction_names |
116 | ||
117 | 8x |
betas <- as.matrix(coef) |
118 | ||
119 | 8x |
coef_hat <- t(design_mat) %*% betas |
120 | 8x |
dimnames(coef_hat)[2] <- "coef" |
121 | ||
122 | 8x |
coef_se <- apply(design_mat, 2, function(x) { |
123 | 27x |
vcov_el <- as.logical(x) |
124 | 27x |
y <- vcov[vcov_el, vcov_el] |
125 | 27x |
y <- sum(y) |
126 | 27x |
y <- sqrt(y) |
127 | 27x |
return(y) |
128 |
}) |
|
129 | ||
130 | 8x |
q_norm <- stats::qnorm((1 + conf_level) / 2) |
131 | 8x |
y <- cbind(coef_hat, `se(coef)` = coef_se) |
132 | ||
133 | 8x |
y <- apply(y, 1, function(x) { |
134 | 27x |
x["hr"] <- exp(x["coef"]) |
135 | 27x |
x["lcl"] <- exp(x["coef"] - q_norm * x["se(coef)"]) |
136 | 27x |
x["ucl"] <- exp(x["coef"] + q_norm * x["se(coef)"]) |
137 | ||
138 | 27x |
return(x) |
139 |
}) |
|
140 | ||
141 | 8x |
y <- t(y) |
142 | 8x |
y <- by(y, split_by_variable, identity) |
143 | 8x |
y <- lapply(y, as.matrix) |
144 | ||
145 | 8x |
attr(y, "details") <- paste0( |
146 | 8x |
"Estimations of ", variable, |
147 | 8x |
" hazard ratio given the level of ", given, " compared to ", |
148 | 8x |
variable, " level ", lvl_var[1], "." |
149 |
) |
|
150 | 8x |
return(y) |
151 |
} |
|
152 | ||
153 |
#' `tryCatch` around `car::Anova` |
|
154 |
#' |
|
155 |
#' Captures warnings when executing [car::Anova]. |
|
156 |
#' |
|
157 |
#' @inheritParams car::Anova |
|
158 |
#' |
|
159 |
#' @return A list with item `aov` for the result of the model and `error_text` for the captured warnings. |
|
160 |
#' |
|
161 |
#' @examples |
|
162 |
#' # `car::Anova` on cox regression model including strata and expected |
|
163 |
#' # a likelihood ratio test triggers a warning as only Wald method is |
|
164 |
#' # accepted. |
|
165 |
#' |
|
166 |
#' library(survival) |
|
167 |
#' |
|
168 |
#' mod <- coxph( |
|
169 |
#' formula = Surv(time = futime, event = fustat) ~ factor(rx) + strata(ecog.ps), |
|
170 |
#' data = ovarian |
|
171 |
#' ) |
|
172 |
#' |
|
173 |
#' @keywords internal |
|
174 |
try_car_anova <- function(mod, |
|
175 |
test.statistic) { # nolint |
|
176 | 2x |
y <- tryCatch( |
177 | 2x |
withCallingHandlers( |
178 | 2x |
expr = { |
179 | 2x |
warn_text <- c() |
180 | 2x |
list( |
181 | 2x |
aov = car::Anova( |
182 | 2x |
mod, |
183 | 2x |
test.statistic = test.statistic, |
184 | 2x |
type = "III" |
185 |
), |
|
186 | 2x |
warn_text = warn_text |
187 |
) |
|
188 |
}, |
|
189 | 2x |
warning = function(w) { |
190 |
# If a warning is detected it is handled as "w". |
|
191 | ! |
warn_text <<- trimws(paste0("Warning in `try_car_anova`: ", w)) |
192 | ||
193 |
# A warning is sometimes expected, then, we want to restart |
|
194 |
# the execution while ignoring the warning. |
|
195 | ! |
invokeRestart("muffleWarning") |
196 |
} |
|
197 |
), |
|
198 | 2x |
finally = { |
199 |
} |
|
200 |
) |
|
201 | ||
202 | 2x |
return(y) |
203 |
} |
|
204 | ||
205 |
#' Fit a Cox regression model and ANOVA |
|
206 |
#' |
|
207 |
#' The functions derives the effect p-values using [car::Anova()] from [survival::coxph()] results. |
|
208 |
#' |
|
209 |
#' @inheritParams t_coxreg |
|
210 |
#' |
|
211 |
#' @return A list with items `mod` (results of [survival::coxph()]), `msum` (result of `summary`) and |
|
212 |
#' `aov` (result of [car::Anova()]). |
|
213 |
#' |
|
214 |
#' @noRd |
|
215 |
fit_n_aov <- function(formula, |
|
216 |
data = data, |
|
217 |
conf_level = conf_level, |
|
218 |
pval_method = c("wald", "likelihood"), |
|
219 |
...) { |
|
220 | 1x |
pval_method <- match.arg(pval_method) |
221 | ||
222 | 1x |
environment(formula) <- environment() |
223 | 1x |
suppressWarnings({ |
224 |
# We expect some warnings due to coxph which fails strict programming. |
|
225 | 1x |
mod <- survival::coxph(formula, data = data, ...) |
226 | 1x |
msum <- summary(mod, conf.int = conf_level) |
227 |
}) |
|
228 | ||
229 | 1x |
aov <- try_car_anova( |
230 | 1x |
mod, |
231 | 1x |
test.statistic = switch(pval_method, |
232 | 1x |
"wald" = "Wald", |
233 | 1x |
"likelihood" = "LR" |
234 |
) |
|
235 |
) |
|
236 | ||
237 | 1x |
warn_attr <- aov$warn_text |
238 | ! |
if (!is.null(aov$warn_text)) message(warn_attr) |
239 | ||
240 | 1x |
aov <- aov$aov |
241 | 1x |
y <- list(mod = mod, msum = msum, aov = aov) |
242 | 1x |
attr(y, "message") <- warn_attr |
243 | ||
244 | 1x |
return(y) |
245 |
} |
|
246 | ||
247 |
# argument_checks |
|
248 |
check_formula <- function(formula) { |
|
249 | 1x |
if (!(inherits(formula, "formula"))) { |
250 | 1x |
stop("Check `formula`. A formula should resemble `Surv(time = AVAL, event = 1 - CNSR) ~ study_arm(ARMCD)`.") |
251 |
} |
|
252 | ||
253 | ! |
invisible() |
254 |
} |
|
255 | ||
256 |
check_covariate_formulas <- function(covariates) { |
|
257 | 1x |
if (!all(vapply(X = covariates, FUN = inherits, what = "formula", FUN.VALUE = TRUE)) || is.null(covariates)) { |
258 | 1x |
stop("Check `covariates`, it should be a list of right-hand-term formulas, e.g. list(Age = ~AGE).") |
259 |
} |
|
260 | ||
261 | ! |
invisible() |
262 |
} |
|
263 | ||
264 |
name_covariate_names <- function(covariates) { |
|
265 | 1x |
miss_names <- names(covariates) == "" |
266 | 1x |
no_names <- is.null(names(covariates)) |
267 | ! |
if (any(miss_names)) names(covariates)[miss_names] <- vapply(covariates[miss_names], FUN = rht, FUN.VALUE = "name") |
268 | ! |
if (no_names) names(covariates) <- vapply(covariates, FUN = rht, FUN.VALUE = "name") |
269 | 1x |
return(covariates) |
270 |
} |
|
271 | ||
272 |
check_increments <- function(increments, covariates) { |
|
273 | 1x |
if (!is.null(increments)) { |
274 | 1x |
covariates <- vapply(covariates, FUN = rht, FUN.VALUE = "name") |
275 | 1x |
lapply( |
276 | 1x |
X = names(increments), FUN = function(x) { |
277 | 3x |
if (!x %in% covariates) { |
278 | 1x |
warning( |
279 | 1x |
paste( |
280 | 1x |
"Check `increments`, the `increment` for ", x, |
281 | 1x |
"doesn't match any names in investigated covariate(s)." |
282 |
) |
|
283 |
) |
|
284 |
} |
|
285 |
} |
|
286 |
) |
|
287 |
} |
|
288 | ||
289 | 1x |
invisible() |
290 |
} |
|
291 | ||
292 |
#' Multivariate Cox model - summarized results |
|
293 |
#' |
|
294 |
#' Analyses based on multivariate Cox model are usually not performed for the Controlled Substance Reporting or |
|
295 |
#' regulatory documents but serve exploratory purposes only (e.g., for publication). In practice, the model usually |
|
296 |
#' includes only the main effects (without interaction terms). It produces the hazard ratio estimates for each of the |
|
297 |
#' covariates included in the model. |
|
298 |
#' The analysis follows the same principles (e.g., stratified vs. unstratified analysis and tie handling) as the |
|
299 |
#' usual Cox model analysis. Since there is usually no pre-specified hypothesis testing for such analysis, |
|
300 |
#' the p.values need to be interpreted with caution. (**Statistical Analysis of Clinical Trials Data with R**, |
|
301 |
#' `NEST's bookdown`) |
|
302 |
#' |
|
303 |
#' @param formula (`formula`)\cr a formula corresponding to the investigated [survival::Surv()] survival model |
|
304 |
#' including covariates. |
|
305 |
#' @param data (`data.frame`)\cr a data frame which includes the variable in formula and covariates. |
|
306 |
#' @param conf_level (`proportion`)\cr the confidence level for the hazard ratio interval estimations. Default is 0.95. |
|
307 |
#' @param pval_method (`string`)\cr the method used for the estimation of p-values, should be one of |
|
308 |
#' `"wald"` (default) or `"likelihood"`. |
|
309 |
#' @param ... optional parameters passed to [survival::coxph()]. Can include `ties`, a character string specifying the |
|
310 |
#' method for tie handling, one of `exact` (default), `efron`, `breslow`. |
|
311 |
#' |
|
312 |
#' @return A `list` with elements `mod`, `msum`, `aov`, and `coef_inter`. |
|
313 |
#' |
|
314 |
#' @details The output is limited to single effect terms. Work in ongoing for estimation of interaction terms |
|
315 |
#' but is out of scope as defined by the Global Data Standards Repository |
|
316 |
#' (**`GDS_Standard_TLG_Specs_Tables_2.doc`**). |
|
317 |
#' |
|
318 |
#' @seealso [estimate_coef()]. |
|
319 |
#' |
|
320 |
#' @examples |
|
321 |
#' library(dplyr) |
|
322 |
#' |
|
323 |
#' adtte <- tern_ex_adtte |
|
324 |
#' adtte_f <- subset(adtte, PARAMCD == "OS") # _f: filtered |
|
325 |
#' adtte_f <- filter( |
|
326 |
#' adtte_f, |
|
327 |
#' PARAMCD == "OS" & |
|
328 |
#' SEX %in% c("F", "M") & |
|
329 |
#' RACE %in% c("ASIAN", "BLACK OR AFRICAN AMERICAN", "WHITE") |
|
330 |
#' ) |
|
331 |
#' adtte_f$SEX <- droplevels(adtte_f$SEX) |
|
332 |
#' adtte_f$RACE <- droplevels(adtte_f$RACE) |
|
333 |
#' |
|
334 |
#' @keywords internal |
|
335 |
s_cox_multivariate <- function(formula, data, |
|
336 |
conf_level = 0.95, |
|
337 |
pval_method = c("wald", "likelihood"), |
|
338 |
...) { |
|
339 | 1x |
tf <- stats::terms(formula, specials = c("strata")) |
340 | 1x |
covariates <- rownames(attr(tf, "factors"))[-c(1, unlist(attr(tf, "specials")))] |
341 | 1x |
lapply( |
342 | 1x |
X = covariates, |
343 | 1x |
FUN = function(x) { |
344 | 3x |
if (is.character(data[[x]])) { |
345 | 1x |
data[[x]] <<- as.factor(data[[x]]) |
346 |
} |
|
347 | 3x |
invisible() |
348 |
} |
|
349 |
) |
|
350 | 1x |
pval_method <- match.arg(pval_method) |
351 | ||
352 |
# Results directly exported from environment(fit_n_aov) to environment(s_function_draft) |
|
353 | 1x |
y <- fit_n_aov( |
354 | 1x |
formula = formula, |
355 | 1x |
data = data, |
356 | 1x |
conf_level = conf_level, |
357 | 1x |
pval_method = pval_method, |
358 |
... |
|
359 |
) |
|
360 | 1x |
mod <- y$mod |
361 | 1x |
aov <- y$aov |
362 | 1x |
msum <- y$msum |
363 | 1x |
list2env(as.list(y), environment()) |
364 | ||
365 | 1x |
all_term_labs <- attr(mod$terms, "term.labels") |
366 | 1x |
term_labs <- all_term_labs[which(attr(mod$terms, "order") == 1)] |
367 | 1x |
names(term_labs) <- term_labs |
368 | ||
369 | 1x |
coef_inter <- NULL |
370 | 1x |
if (any(attr(mod$terms, "order") > 1)) { |
371 | 1x |
for_inter <- all_term_labs[attr(mod$terms, "order") > 1] |
372 | 1x |
names(for_inter) <- for_inter |
373 | 1x |
mmat <- stats::model.matrix(mod)[1, ] |
374 | 1x |
mmat[!mmat == 0] <- 0 |
375 | 1x |
mcoef <- stats::coef(mod) |
376 | 1x |
mvcov <- stats::vcov(mod) |
377 | ||
378 | 1x |
estimate_coef_local <- function(variable, given) { |
379 | 6x |
estimate_coef( |
380 | 6x |
variable, given, |
381 | 6x |
coef = mcoef, mmat = mmat, vcov = mvcov, conf_level = conf_level, |
382 | 6x |
lvl_var = levels(data[[variable]]), lvl_given = levels(data[[given]]) |
383 |
) |
|
384 |
} |
|
385 | ||
386 | 1x |
coef_inter <- lapply( |
387 | 1x |
for_inter, function(x) { |
388 | 3x |
y <- attr(mod$terms, "factors")[, x] |
389 | 3x |
y <- names(y[y > 0]) |
390 | 3x |
Map(estimate_coef_local, variable = y, given = rev(y)) |
391 |
} |
|
392 |
) |
|
393 |
} |
|
394 | ||
395 | 1x |
list(mod = mod, msum = msum, aov = aov, coef_inter = coef_inter) |
396 |
} |
1 |
#' Odds ratio estimation |
|
2 |
#' |
|
3 |
#' @description `r lifecycle::badge("stable")` |
|
4 |
#' |
|
5 |
#' The analyze function [estimate_odds_ratio()] creates a layout element to compare bivariate responses between |
|
6 |
#' two groups by estimating an odds ratio and its confidence interval. |
|
7 |
#' |
|
8 |
#' The primary analysis variable specified by `vars` is the group variable. Additional variables can be included in the |
|
9 |
#' analysis via the `variables` argument, which accepts `arm`, an arm variable, and `strata`, a stratification variable. |
|
10 |
#' If more than two arm levels are present, they can be combined into two groups using the `groups_list` argument. |
|
11 |
#' |
|
12 |
#' @inheritParams split_cols_by_groups |
|
13 |
#' @inheritParams argument_convention |
|
14 |
#' @param .stats (`character`)\cr statistics to select for the table. |
|
15 |
#' |
|
16 |
#' Options are: ``r shQuote(get_stats("estimate_odds_ratio"), type = "sh")`` |
|
17 |
#' @param method (`string`)\cr whether to use the correct (`"exact"`) calculation in the conditional likelihood or one |
|
18 |
#' of the approximations. See [survival::clogit()] for details. |
|
19 |
#' |
|
20 |
#' @note |
|
21 |
#' * This function uses logistic regression for unstratified analyses, and conditional logistic regression for |
|
22 |
#' stratified analyses. The Wald confidence interval is calculated with the specified confidence level. |
|
23 |
#' * For stratified analyses, there is currently no implementation for conditional likelihood confidence intervals, |
|
24 |
#' therefore the likelihood confidence interval is not available as an option. |
|
25 |
#' * When `vars` contains only responders or non-responders no odds ratio estimation is possible so the returned |
|
26 |
#' values will be `NA`. |
|
27 |
#' |
|
28 |
#' @seealso Relevant helper function [h_odds_ratio()]. |
|
29 |
#' |
|
30 |
#' @name odds_ratio |
|
31 |
#' @order 1 |
|
32 |
NULL |
|
33 | ||
34 |
#' @describeIn odds_ratio Statistics function which estimates the odds ratio |
|
35 |
#' between a treatment and a control. A `variables` list with `arm` and `strata` |
|
36 |
#' variable names must be passed if a stratified analysis is required. |
|
37 |
#' |
|
38 |
#' @return |
|
39 |
#' * `s_odds_ratio()` returns a named list with the statistics `or_ci` |
|
40 |
#' (containing `est`, `lcl`, and `ucl`) and `n_tot`. |
|
41 |
#' |
|
42 |
#' @examples |
|
43 |
#' # Unstratified analysis. |
|
44 |
#' s_odds_ratio( |
|
45 |
#' df = subset(dta, grp == "A"), |
|
46 |
#' .var = "rsp", |
|
47 |
#' .ref_group = subset(dta, grp == "B"), |
|
48 |
#' .in_ref_col = FALSE, |
|
49 |
#' .df_row = dta |
|
50 |
#' ) |
|
51 |
#' |
|
52 |
#' # Stratified analysis. |
|
53 |
#' s_odds_ratio( |
|
54 |
#' df = subset(dta, grp == "A"), |
|
55 |
#' .var = "rsp", |
|
56 |
#' .ref_group = subset(dta, grp == "B"), |
|
57 |
#' .in_ref_col = FALSE, |
|
58 |
#' .df_row = dta, |
|
59 |
#' variables = list(arm = "grp", strata = "strata") |
|
60 |
#' ) |
|
61 |
#' |
|
62 |
#' @export |
|
63 |
s_odds_ratio <- function(df, |
|
64 |
.var, |
|
65 |
.ref_group, |
|
66 |
.in_ref_col, |
|
67 |
.df_row, |
|
68 |
variables = list(arm = NULL, strata = NULL), |
|
69 |
conf_level = 0.95, |
|
70 |
groups_list = NULL, |
|
71 |
method = "exact", |
|
72 |
...) { |
|
73 | 99x |
y <- list(or_ci = numeric(), n_tot = numeric()) |
74 | ||
75 | 99x |
if (!.in_ref_col) { |
76 | 94x |
assert_proportion_value(conf_level) |
77 | 94x |
assert_df_with_variables(df, list(rsp = .var)) |
78 | 94x |
assert_df_with_variables(.ref_group, list(rsp = .var)) |
79 | ||
80 | 94x |
if (is.null(variables$strata)) { |
81 | 76x |
data <- data.frame( |
82 | 76x |
rsp = c(.ref_group[[.var]], df[[.var]]), |
83 | 76x |
grp = factor( |
84 | 76x |
rep(c("ref", "Not-ref"), c(nrow(.ref_group), nrow(df))), |
85 | 76x |
levels = c("ref", "Not-ref") |
86 |
) |
|
87 |
) |
|
88 | 76x |
y <- or_glm(data, conf_level = conf_level) |
89 |
} else { |
|
90 | 18x |
assert_df_with_variables(.df_row, c(list(rsp = .var), variables)) |
91 | 18x |
checkmate::assert_subset(method, c("exact", "approximate", "efron", "breslow"), empty.ok = FALSE) |
92 | ||
93 |
# The group variable prepared for clogit must be synchronised with combination groups definition. |
|
94 | 18x |
if (is.null(groups_list)) { |
95 | 16x |
ref_grp <- as.character(unique(.ref_group[[variables$arm]])) |
96 | 16x |
trt_grp <- as.character(unique(df[[variables$arm]])) |
97 | 16x |
grp <- stats::relevel(factor(.df_row[[variables$arm]]), ref = ref_grp) |
98 |
} else { |
|
99 |
# If more than one level in reference col. |
|
100 | 2x |
reference <- as.character(unique(.ref_group[[variables$arm]])) |
101 | 2x |
grp_ref_flag <- vapply( |
102 | 2x |
X = groups_list, |
103 | 2x |
FUN.VALUE = TRUE, |
104 | 2x |
FUN = function(x) all(reference %in% x) |
105 |
) |
|
106 | 2x |
ref_grp <- names(groups_list)[grp_ref_flag] |
107 | ||
108 |
# If more than one level in treatment col. |
|
109 | 2x |
treatment <- as.character(unique(df[[variables$arm]])) |
110 | 2x |
grp_trt_flag <- vapply( |
111 | 2x |
X = groups_list, |
112 | 2x |
FUN.VALUE = TRUE, |
113 | 2x |
FUN = function(x) all(treatment %in% x) |
114 |
) |
|
115 | 2x |
trt_grp <- names(groups_list)[grp_trt_flag] |
116 | ||
117 | 2x |
grp <- combine_levels(.df_row[[variables$arm]], levels = reference, new_level = ref_grp) |
118 | 2x |
grp <- combine_levels(grp, levels = treatment, new_level = trt_grp) |
119 |
} |
|
120 | ||
121 |
# The reference level in `grp` must be the same as in the `rtables` column split. |
|
122 | 18x |
data <- data.frame( |
123 | 18x |
rsp = .df_row[[.var]], |
124 | 18x |
grp = grp, |
125 | 18x |
strata = interaction(.df_row[variables$strata]) |
126 |
) |
|
127 | 18x |
y_all <- or_clogit(data, conf_level = conf_level, method = method) |
128 | 18x |
checkmate::assert_string(trt_grp) |
129 | 18x |
checkmate::assert_subset(trt_grp, names(y_all$or_ci)) |
130 | 17x |
y$or_ci <- y_all$or_ci[[trt_grp]] |
131 | 17x |
y$n_tot <- y_all$n_tot |
132 |
} |
|
133 |
} |
|
134 | ||
135 | 98x |
if ("est" %in% names(y$or_ci) && is.na(y$or_ci[["est"]]) && method != "approximate") { |
136 | 1x |
warning( |
137 | 1x |
"Unable to compute the odds ratio estimate. Please try re-running the function with ", |
138 | 1x |
'parameter `method` set to "approximate".' |
139 |
) |
|
140 |
} |
|
141 | ||
142 | 98x |
y$or_ci <- formatters::with_label( |
143 | 98x |
x = y$or_ci, |
144 | 98x |
label = paste0("Odds Ratio (", 100 * conf_level, "% CI)") |
145 |
) |
|
146 | ||
147 | 98x |
y$n_tot <- formatters::with_label( |
148 | 98x |
x = y$n_tot, |
149 | 98x |
label = "Total n" |
150 |
) |
|
151 | ||
152 | 98x |
y |
153 |
} |
|
154 | ||
155 |
#' @describeIn odds_ratio Formatted analysis function which is used as `afun` in `estimate_odds_ratio()`. |
|
156 |
#' |
|
157 |
#' @return |
|
158 |
#' * `a_odds_ratio()` returns the corresponding list with formatted [rtables::CellValue()]. |
|
159 |
#' |
|
160 |
#' @examples |
|
161 |
#' a_odds_ratio( |
|
162 |
#' df = subset(dta, grp == "A"), |
|
163 |
#' .var = "rsp", |
|
164 |
#' .ref_group = subset(dta, grp == "B"), |
|
165 |
#' .in_ref_col = FALSE, |
|
166 |
#' .df_row = dta |
|
167 |
#' ) |
|
168 |
#' |
|
169 |
#' @export |
|
170 |
a_odds_ratio <- function(df, |
|
171 |
..., |
|
172 |
.stats = NULL, |
|
173 |
.stat_names = NULL, |
|
174 |
.formats = NULL, |
|
175 |
.labels = NULL, |
|
176 |
.indent_mods = NULL) { |
|
177 |
# Check for additional parameters to the statistics function |
|
178 | 12x |
dots_extra_args <- list(...) |
179 | 12x |
extra_afun_params <- retrieve_extra_afun_params(names(dots_extra_args$.additional_fun_parameters)) |
180 | 12x |
dots_extra_args$.additional_fun_parameters <- NULL |
181 | ||
182 |
# Check for user-defined functions |
|
183 | 12x |
default_and_custom_stats_list <- .split_std_from_custom_stats(.stats) |
184 | 12x |
.stats <- default_and_custom_stats_list$all_stats |
185 | 12x |
custom_stat_functions <- default_and_custom_stats_list$custom_stats |
186 | ||
187 |
# Apply statistics function |
|
188 | 12x |
x_stats <- .apply_stat_functions( |
189 | 12x |
default_stat_fnc = s_odds_ratio, |
190 | 12x |
custom_stat_fnc_list = custom_stat_functions, |
191 | 12x |
args_list = c( |
192 | 12x |
df = list(df), |
193 | 12x |
extra_afun_params, |
194 | 12x |
dots_extra_args |
195 |
) |
|
196 |
) |
|
197 | ||
198 |
# Fill in formatting defaults |
|
199 | 12x |
.stats <- get_stats("estimate_odds_ratio", |
200 | 12x |
stats_in = .stats, |
201 | 12x |
custom_stats_in = names(custom_stat_functions) |
202 |
) |
|
203 | 12x |
x_stats <- x_stats[.stats] |
204 | 12x |
.formats <- get_formats_from_stats(.stats, .formats) |
205 | 12x |
.labels <- get_labels_from_stats( |
206 | 12x |
.stats, .labels, |
207 | 12x |
tern_defaults = c(lapply(x_stats, attr, "label"), tern_default_labels) |
208 |
) |
|
209 | 12x |
.indent_mods <- get_indents_from_stats(.stats, .indent_mods) |
210 | ||
211 |
# Auto format handling |
|
212 | 12x |
.formats <- apply_auto_formatting(.formats, x_stats, extra_afun_params$.df_row, extra_afun_params$.var) |
213 | ||
214 |
# Get and check statistical names |
|
215 | 12x |
.stat_names <- get_stat_names(x_stats, .stat_names) |
216 | ||
217 | 12x |
in_rows( |
218 | 12x |
.list = x_stats, |
219 | 12x |
.formats = .formats, |
220 | 12x |
.names = .labels %>% .unlist_keep_nulls(), |
221 | 12x |
.stat_names = .stat_names, |
222 | 12x |
.labels = .labels %>% .unlist_keep_nulls(), |
223 | 12x |
.indent_mods = .indent_mods %>% .unlist_keep_nulls() |
224 |
) |
|
225 |
} |
|
226 | ||
227 |
#' @describeIn odds_ratio Layout-creating function which can take statistics function arguments |
|
228 |
#' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
|
229 |
#' |
|
230 |
#' @return |
|
231 |
#' * `estimate_odds_ratio()` returns a layout object suitable for passing to further layouting functions, |
|
232 |
#' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
|
233 |
#' the statistics from `s_odds_ratio()` to the table layout. |
|
234 |
#' |
|
235 |
#' @examples |
|
236 |
#' set.seed(12) |
|
237 |
#' dta <- data.frame( |
|
238 |
#' rsp = sample(c(TRUE, FALSE), 100, TRUE), |
|
239 |
#' grp = factor(rep(c("A", "B"), each = 50), levels = c("A", "B")), |
|
240 |
#' strata = factor(sample(c("C", "D"), 100, TRUE)) |
|
241 |
#' ) |
|
242 |
#' |
|
243 |
#' l <- basic_table() %>% |
|
244 |
#' split_cols_by(var = "grp", ref_group = "B") %>% |
|
245 |
#' estimate_odds_ratio(vars = "rsp") |
|
246 |
#' |
|
247 |
#' build_table(l, df = dta) |
|
248 |
#' |
|
249 |
#' @export |
|
250 |
#' @order 2 |
|
251 |
estimate_odds_ratio <- function(lyt, |
|
252 |
vars, |
|
253 |
variables = list(arm = NULL, strata = NULL), |
|
254 |
conf_level = 0.95, |
|
255 |
groups_list = NULL, |
|
256 |
method = "exact", |
|
257 |
na_str = default_na_str(), |
|
258 |
nested = TRUE, |
|
259 |
..., |
|
260 |
table_names = vars, |
|
261 |
show_labels = "hidden", |
|
262 |
var_labels = vars, |
|
263 |
.stats = "or_ci", |
|
264 |
.stat_names = NULL, |
|
265 |
.formats = NULL, |
|
266 |
.labels = NULL, |
|
267 |
.indent_mods = NULL) { |
|
268 |
# Process standard extra arguments |
|
269 | 5x |
extra_args <- list(".stats" = .stats) |
270 | ! |
if (!is.null(.stat_names)) extra_args[[".stat_names"]] <- .stat_names |
271 | ! |
if (!is.null(.formats)) extra_args[[".formats"]] <- .formats |
272 | ! |
if (!is.null(.labels)) extra_args[[".labels"]] <- .labels |
273 | ! |
if (!is.null(.indent_mods)) extra_args[[".indent_mods"]] <- .indent_mods |
274 | ||
275 |
# Process additional arguments to the statistic function |
|
276 | 5x |
extra_args <- c( |
277 | 5x |
extra_args, |
278 | 5x |
variables = list(variables), conf_level = list(conf_level), groups_list = list(groups_list), method = list(method), |
279 |
... |
|
280 |
) |
|
281 | ||
282 |
# Append additional info from layout to the analysis function |
|
283 | 5x |
extra_args[[".additional_fun_parameters"]] <- get_additional_afun_params(add_alt_df = FALSE) |
284 | 5x |
formals(a_odds_ratio) <- c(formals(a_odds_ratio), extra_args[[".additional_fun_parameters"]]) |
285 | ||
286 | 5x |
analyze( |
287 | 5x |
lyt = lyt, |
288 | 5x |
vars = vars, |
289 | 5x |
afun = a_odds_ratio, |
290 | 5x |
na_str = na_str, |
291 | 5x |
nested = nested, |
292 | 5x |
extra_args = extra_args, |
293 | 5x |
var_labels = var_labels, |
294 | 5x |
show_labels = show_labels, |
295 | 5x |
table_names = table_names |
296 |
) |
|
297 |
} |
|
298 | ||
299 |
#' Helper functions for odds ratio estimation |
|
300 |
#' |
|
301 |
#' @description `r lifecycle::badge("stable")` |
|
302 |
#' |
|
303 |
#' Functions to calculate odds ratios in [estimate_odds_ratio()]. |
|
304 |
#' |
|
305 |
#' @inheritParams odds_ratio |
|
306 |
#' @inheritParams argument_convention |
|
307 |
#' @param data (`data.frame`)\cr data frame containing at least the variables `rsp` and `grp`, and optionally |
|
308 |
#' `strata` for [or_clogit()]. |
|
309 |
#' |
|
310 |
#' @return A named `list` of elements `or_ci` and `n_tot`. |
|
311 |
#' |
|
312 |
#' @seealso [odds_ratio] |
|
313 |
#' |
|
314 |
#' @name h_odds_ratio |
|
315 |
NULL |
|
316 | ||
317 |
#' @describeIn h_odds_ratio Estimates the odds ratio based on [stats::glm()]. Note that there must be |
|
318 |
#' exactly 2 groups in `data` as specified by the `grp` variable. |
|
319 |
#' |
|
320 |
#' @examples |
|
321 |
#' # Data with 2 groups. |
|
322 |
#' data <- data.frame( |
|
323 |
#' rsp = as.logical(c(1, 1, 0, 1, 0, 0, 1, 1)), |
|
324 |
#' grp = letters[c(1, 1, 1, 2, 2, 2, 1, 2)], |
|
325 |
#' strata = letters[c(1, 2, 1, 2, 2, 2, 1, 2)], |
|
326 |
#' stringsAsFactors = TRUE |
|
327 |
#' ) |
|
328 |
#' |
|
329 |
#' # Odds ratio based on glm. |
|
330 |
#' or_glm(data, conf_level = 0.95) |
|
331 |
#' |
|
332 |
#' @export |
|
333 |
or_glm <- function(data, conf_level) { |
|
334 | 77x |
checkmate::assert_logical(data$rsp) |
335 | 77x |
assert_proportion_value(conf_level) |
336 | 77x |
assert_df_with_variables(data, list(rsp = "rsp", grp = "grp")) |
337 | 77x |
checkmate::assert_multi_class(data$grp, classes = c("factor", "character")) |
338 | ||
339 | 77x |
data$grp <- as_factor_keep_attributes(data$grp) |
340 | 77x |
assert_df_with_factors(data, list(val = "grp"), min.levels = 2, max.levels = 2) |
341 | 77x |
formula <- stats::as.formula("rsp ~ grp") |
342 | 77x |
model_fit <- stats::glm( |
343 | 77x |
formula = formula, data = data, |
344 | 77x |
family = stats::binomial(link = "logit") |
345 |
) |
|
346 | ||
347 |
# Note that here we need to discard the intercept. |
|
348 | 77x |
or <- exp(stats::coef(model_fit)[-1]) |
349 | 77x |
or_ci <- exp( |
350 | 77x |
stats::confint.default(model_fit, level = conf_level)[-1, , drop = FALSE] |
351 |
) |
|
352 | ||
353 | 77x |
values <- stats::setNames(c(or, or_ci), c("est", "lcl", "ucl")) |
354 | 77x |
n_tot <- stats::setNames(nrow(model_fit$model), "n_tot") |
355 | ||
356 | 77x |
list(or_ci = values, n_tot = n_tot) |
357 |
} |
|
358 | ||
359 |
#' @describeIn h_odds_ratio Estimates the odds ratio based on [survival::clogit()]. This is done for |
|
360 |
#' the whole data set including all groups, since the results are not the same as when doing |
|
361 |
#' pairwise comparisons between the groups. |
|
362 |
#' |
|
363 |
#' @examples |
|
364 |
#' # Data with 3 groups. |
|
365 |
#' data <- data.frame( |
|
366 |
#' rsp = as.logical(c(1, 1, 0, 1, 0, 0, 1, 1, 0, 0, 1, 1, 0, 1, 0, 0, 1, 1, 0, 0)), |
|
367 |
#' grp = letters[c(1, 1, 1, 2, 2, 2, 3, 3, 3, 3, 1, 1, 1, 2, 2, 2, 3, 3, 3, 3)], |
|
368 |
#' strata = LETTERS[c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2)], |
|
369 |
#' stringsAsFactors = TRUE |
|
370 |
#' ) |
|
371 |
#' |
|
372 |
#' # Odds ratio based on stratified estimation by conditional logistic regression. |
|
373 |
#' or_clogit(data, conf_level = 0.95) |
|
374 |
#' |
|
375 |
#' @export |
|
376 |
or_clogit <- function(data, conf_level, method = "exact") { |
|
377 | 19x |
checkmate::assert_logical(data$rsp) |
378 | 19x |
assert_proportion_value(conf_level) |
379 | 19x |
assert_df_with_variables(data, list(rsp = "rsp", grp = "grp", strata = "strata")) |
380 | 19x |
checkmate::assert_multi_class(data$grp, classes = c("factor", "character")) |
381 | 19x |
checkmate::assert_multi_class(data$strata, classes = c("factor", "character")) |
382 | 19x |
checkmate::assert_subset(method, c("exact", "approximate", "efron", "breslow"), empty.ok = FALSE) |
383 | ||
384 | 19x |
data$grp <- as_factor_keep_attributes(data$grp) |
385 | 19x |
data$strata <- as_factor_keep_attributes(data$strata) |
386 | ||
387 |
# Deviation from convention: `survival::strata` must be simply `strata`. |
|
388 | 19x |
formula <- stats::as.formula("rsp ~ grp + strata(strata)") |
389 | 19x |
model_fit <- clogit_with_tryCatch(formula = formula, data = data, method = method) |
390 | ||
391 |
# Create a list with one set of OR estimates and CI per coefficient, i.e. |
|
392 |
# comparison of one group vs. the reference group. |
|
393 | 19x |
coef_est <- stats::coef(model_fit) |
394 | 19x |
ci_est <- stats::confint(model_fit, level = conf_level) |
395 | 19x |
or_ci <- list() |
396 | 19x |
for (coef_name in names(coef_est)) { |
397 | 21x |
grp_name <- gsub("^grp", "", x = coef_name) |
398 | 21x |
or_ci[[grp_name]] <- stats::setNames( |
399 | 21x |
object = exp(c(coef_est[coef_name], ci_est[coef_name, , drop = TRUE])), |
400 | 21x |
nm = c("est", "lcl", "ucl") |
401 |
) |
|
402 |
} |
|
403 | 19x |
list(or_ci = or_ci, n_tot = c(n_tot = model_fit$n)) |
404 |
} |
1 |
# summarize_glm_count ---------------------------------------------------------- |
|
2 |
#' Summarize Poisson negative binomial regression |
|
3 |
#' |
|
4 |
#' @description `r lifecycle::badge("experimental")` |
|
5 |
#' |
|
6 |
#' Summarize results of a Poisson negative binomial regression. |
|
7 |
#' This can be used to analyze count and/or frequency data using a linear model. |
|
8 |
#' It is specifically useful for analyzing count data (using the Poisson or Negative |
|
9 |
#' Binomial distribution) that is result of a generalized linear model of one (e.g. arm) or more |
|
10 |
#' covariates. |
|
11 |
#' |
|
12 |
#' @inheritParams h_glm_count |
|
13 |
#' @inheritParams argument_convention |
|
14 |
#' @param rate_mean_method (`character(1)`)\cr method used to estimate the mean odds ratio. Defaults to `emmeans`. |
|
15 |
#' see details for more information. |
|
16 |
#' @param scale (`numeric(1)`)\cr linear scaling factor for rate and confidence intervals. Defaults to `1`. |
|
17 |
#' @param .stats (`character`)\cr statistics to select for the table. |
|
18 |
#' |
|
19 |
#' Options are: ``r shQuote(get_stats("summarize_glm_count"), type = "sh")`` |
|
20 |
#' |
|
21 |
#' @details |
|
22 |
#' `summarize_glm_count()` uses `s_glm_count()` to calculate the statistics for the table. This |
|
23 |
#' analysis function uses [h_glm_count()] to estimate the GLM with [stats::glm()] for Poisson and Quasi-Poisson |
|
24 |
#' distributions or [MASS::glm.nb()] for Negative Binomial distribution. All methods assume a |
|
25 |
#' logarithmic link function. |
|
26 |
#' |
|
27 |
#' At this point, rates and confidence intervals are estimated from the model using |
|
28 |
#' either [emmeans::emmeans()] when `rate_mean_method = "emmeans"` or [h_ppmeans()] |
|
29 |
#' when `rate_mean_method = "ppmeans"`. |
|
30 |
#' |
|
31 |
#' If a reference group is specified while building the table with `split_cols_by(ref_group)`, |
|
32 |
#' no rate ratio or `p-value` are calculated. Otherwise, we use [emmeans::contrast()] to |
|
33 |
#' calculate the rate ratio and `p-value` for the reference group. Values are always estimated |
|
34 |
#' with `method = "trt.vs.ctrl"` and `ref` equal to the first `arm` value. |
|
35 |
#' |
|
36 |
#' @name summarize_glm_count |
|
37 |
NULL |
|
38 | ||
39 |
#' @describeIn summarize_glm_count Layout-creating function which can take statistics function arguments |
|
40 |
#' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
|
41 |
#' |
|
42 |
#' @return |
|
43 |
#' * `summarize_glm_count()` returns a layout object suitable for passing to further layouting functions, |
|
44 |
#' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
|
45 |
#' the statistics from `s_glm_count()` to the table layout. |
|
46 |
#' |
|
47 |
#' @examples |
|
48 |
#' library(dplyr) |
|
49 |
#' |
|
50 |
#' anl <- tern_ex_adtte %>% filter(PARAMCD == "TNE") |
|
51 |
#' anl$AVAL_f <- as.factor(anl$AVAL) |
|
52 |
#' |
|
53 |
#' lyt <- basic_table() %>% |
|
54 |
#' split_cols_by("ARM", ref_group = "B: Placebo") %>% |
|
55 |
#' add_colcounts() %>% |
|
56 |
#' analyze_vars( |
|
57 |
#' "AVAL_f", |
|
58 |
#' var_labels = "Number of exacerbations per patient", |
|
59 |
#' .stats = c("count_fraction"), |
|
60 |
#' .formats = c("count_fraction" = "xx (xx.xx%)"), |
|
61 |
#' .labels = c("Number of exacerbations per patient") |
|
62 |
#' ) %>% |
|
63 |
#' summarize_glm_count( |
|
64 |
#' vars = "AVAL", |
|
65 |
#' variables = list(arm = "ARM", offset = "lgTMATRSK", covariates = NULL), |
|
66 |
#' conf_level = 0.95, |
|
67 |
#' distribution = "poisson", |
|
68 |
#' rate_mean_method = "emmeans", |
|
69 |
#' var_labels = "Adjusted (P) exacerbation rate (per year)", |
|
70 |
#' table_names = "adjP", |
|
71 |
#' .stats = c("rate"), |
|
72 |
#' .labels = c(rate = "Rate") |
|
73 |
#' ) %>% |
|
74 |
#' summarize_glm_count( |
|
75 |
#' vars = "AVAL", |
|
76 |
#' variables = list(arm = "ARM", offset = "lgTMATRSK", covariates = c("REGION1")), |
|
77 |
#' conf_level = 0.95, |
|
78 |
#' distribution = "quasipoisson", |
|
79 |
#' rate_mean_method = "ppmeans", |
|
80 |
#' var_labels = "Adjusted (QP) exacerbation rate (per year)", |
|
81 |
#' table_names = "adjQP", |
|
82 |
#' .stats = c("rate", "rate_ci", "rate_ratio", "rate_ratio_ci", "pval"), |
|
83 |
#' .labels = c( |
|
84 |
#' rate = "Rate", rate_ci = "Rate CI", rate_ratio = "Rate Ratio", |
|
85 |
#' rate_ratio_ci = "Rate Ratio CI", pval = "p value" |
|
86 |
#' ) |
|
87 |
#' ) %>% |
|
88 |
#' summarize_glm_count( |
|
89 |
#' vars = "AVAL", |
|
90 |
#' variables = list(arm = "ARM", offset = "lgTMATRSK", covariates = c("REGION1")), |
|
91 |
#' conf_level = 0.95, |
|
92 |
#' distribution = "negbin", |
|
93 |
#' rate_mean_method = "emmeans", |
|
94 |
#' var_labels = "Adjusted (NB) exacerbation rate (per year)", |
|
95 |
#' table_names = "adjNB", |
|
96 |
#' .stats = c("rate", "rate_ci", "rate_ratio", "rate_ratio_ci", "pval"), |
|
97 |
#' .labels = c( |
|
98 |
#' rate = "Rate", rate_ci = "Rate CI", rate_ratio = "Rate Ratio", |
|
99 |
#' rate_ratio_ci = "Rate Ratio CI", pval = "p value" |
|
100 |
#' ) |
|
101 |
#' ) |
|
102 |
#' |
|
103 |
#' build_table(lyt = lyt, df = anl) |
|
104 |
#' |
|
105 |
#' @export |
|
106 |
summarize_glm_count <- function(lyt, |
|
107 |
vars, |
|
108 |
variables, |
|
109 |
distribution, |
|
110 |
conf_level, |
|
111 |
rate_mean_method = c("emmeans", "ppmeans")[1], |
|
112 |
weights = stats::weights, |
|
113 |
scale = 1, |
|
114 |
var_labels, |
|
115 |
na_str = default_na_str(), |
|
116 |
nested = TRUE, |
|
117 |
..., |
|
118 |
show_labels = "visible", |
|
119 |
table_names = vars, |
|
120 |
.stats = c("n", "rate", "rate_ci", "rate_ratio", "rate_ratio_ci", "pval"), |
|
121 |
.stat_names = NULL, |
|
122 |
.formats = NULL, |
|
123 |
.labels = NULL, |
|
124 |
.indent_mods = list("rate_ci" = 1L, "rate_ratio_ci" = 1L, "pval" = 1L)) { |
|
125 | 3x |
checkmate::assert_choice(rate_mean_method, c("emmeans", "ppmeans")) |
126 | ||
127 |
# Process standard extra arguments |
|
128 | 3x |
extra_args <- list(".stats" = .stats) |
129 | ! |
if (!is.null(.stat_names)) extra_args[[".stat_names"]] <- .stat_names |
130 | ! |
if (!is.null(.formats)) extra_args[[".formats"]] <- .formats |
131 | 3x |
if (!is.null(.labels)) extra_args[[".labels"]] <- .labels |
132 | 3x |
if (!is.null(.indent_mods)) extra_args[[".indent_mods"]] <- .indent_mods |
133 | ||
134 |
# Process additional arguments to the statistic function |
|
135 | 3x |
extra_args <- c( |
136 | 3x |
extra_args, |
137 | 3x |
variables = list(variables), distribution = list(distribution), conf_level = list(conf_level), |
138 | 3x |
rate_mean_method = list(rate_mean_method), weights = list(weights), scale = list(scale), |
139 |
... |
|
140 |
) |
|
141 | ||
142 |
# Append additional info from layout to the analysis function |
|
143 | 3x |
extra_args[[".additional_fun_parameters"]] <- get_additional_afun_params(add_alt_df = FALSE) |
144 | 3x |
formals(a_glm_count) <- c(formals(a_glm_count), extra_args[[".additional_fun_parameters"]]) |
145 | ||
146 | 3x |
analyze( |
147 | 3x |
lyt = lyt, |
148 | 3x |
vars = vars, |
149 | 3x |
afun = a_glm_count, |
150 | 3x |
na_str = na_str, |
151 | 3x |
nested = nested, |
152 | 3x |
extra_args = extra_args, |
153 | 3x |
var_labels = var_labels, |
154 | 3x |
show_labels = show_labels, |
155 | 3x |
table_names = table_names |
156 |
) |
|
157 |
} |
|
158 | ||
159 |
#' @describeIn summarize_glm_count Statistics function that produces a named list of results |
|
160 |
#' of the investigated Poisson model. |
|
161 |
#' |
|
162 |
#' @return |
|
163 |
#' * `s_glm_count()` returns a named `list` of 5 statistics: |
|
164 |
#' * `n`: Count of complete sample size for the group. |
|
165 |
#' * `rate`: Estimated event rate per follow-up time. |
|
166 |
#' * `rate_ci`: Confidence level for estimated rate per follow-up time. |
|
167 |
#' * `rate_ratio`: Ratio of event rates in each treatment arm to the reference arm. |
|
168 |
#' * `rate_ratio_ci`: Confidence level for the rate ratio. |
|
169 |
#' * `pval`: p-value. |
|
170 |
#' |
|
171 |
#' @keywords internal |
|
172 |
s_glm_count <- function(df, |
|
173 |
.var, |
|
174 |
.df_row, |
|
175 |
.ref_group, |
|
176 |
.in_ref_col, |
|
177 |
variables, |
|
178 |
distribution, |
|
179 |
conf_level, |
|
180 |
rate_mean_method, |
|
181 |
weights, |
|
182 |
scale = 1, |
|
183 |
...) { |
|
184 | 14x |
arm <- variables$arm |
185 | ||
186 | 14x |
y <- df[[.var]] |
187 | 13x |
smry_level <- as.character(unique(df[[arm]])) |
188 | ||
189 |
# ensure there is only 1 value |
|
190 | 13x |
checkmate::assert_scalar(smry_level) |
191 | ||
192 | 13x |
results <- h_glm_count( |
193 | 13x |
.var = .var, |
194 | 13x |
.df_row = .df_row, |
195 | 13x |
variables = variables, |
196 | 13x |
distribution = distribution, |
197 | 13x |
weights |
198 |
) |
|
199 | ||
200 | 13x |
if (rate_mean_method == "emmeans") { |
201 | 13x |
emmeans_smry <- summary(results$emmeans_fit, level = conf_level) |
202 | ! |
} else if (rate_mean_method == "ppmeans") { |
203 | ! |
emmeans_smry <- h_ppmeans(results$glm_fit, .df_row, arm, conf_level) |
204 |
} |
|
205 | ||
206 | 13x |
emmeans_smry_level <- emmeans_smry[emmeans_smry[[arm]] == smry_level, ] |
207 | ||
208 |
# This happens if there is a reference col. No Ratio is calculated? |
|
209 | 13x |
if (.in_ref_col) { |
210 | 5x |
list( |
211 | 5x |
n = length(y[!is.na(y)]), |
212 | 5x |
rate = formatters::with_label( |
213 | 5x |
ifelse(distribution == "negbin", emmeans_smry_level$response * scale, emmeans_smry_level$rate * scale), |
214 | 5x |
"Adjusted Rate" |
215 |
), |
|
216 | 5x |
rate_ci = formatters::with_label( |
217 | 5x |
c(emmeans_smry_level$asymp.LCL * scale, emmeans_smry_level$asymp.UCL * scale), |
218 | 5x |
f_conf_level(conf_level) |
219 |
), |
|
220 | 5x |
rate_ratio = formatters::with_label(numeric(), "Adjusted Rate Ratio"), |
221 | 5x |
rate_ratio_ci = formatters::with_label(numeric(), f_conf_level(conf_level)), |
222 | 5x |
pval = formatters::with_label(numeric(), "p-value") |
223 |
) |
|
224 |
} else { |
|
225 | 8x |
emmeans_contrasts <- emmeans::contrast( |
226 | 8x |
results$emmeans_fit, |
227 | 8x |
method = "trt.vs.ctrl", |
228 | 8x |
ref = grep( |
229 | 8x |
as.character(unique(.ref_group[[arm]])), |
230 | 8x |
as.data.frame(results$emmeans_fit)[[arm]] |
231 |
) |
|
232 |
) |
|
233 | ||
234 | 8x |
contrasts_smry <- summary( |
235 | 8x |
emmeans_contrasts, |
236 | 8x |
infer = TRUE, |
237 | 8x |
adjust = "none" |
238 |
) |
|
239 | ||
240 | 8x |
smry_contrasts_level <- contrasts_smry[grepl(smry_level, contrasts_smry$contrast), ] |
241 | ||
242 | 8x |
list( |
243 | 8x |
n = length(y[!is.na(y)]), |
244 | 8x |
rate = formatters::with_label( |
245 | 8x |
ifelse(distribution == "negbin", |
246 | 8x |
emmeans_smry_level$response * scale, |
247 | 8x |
emmeans_smry_level$rate * scale |
248 |
), |
|
249 | 8x |
"Adjusted Rate" |
250 |
), |
|
251 | 8x |
rate_ci = formatters::with_label( |
252 | 8x |
c(emmeans_smry_level$asymp.LCL * scale, emmeans_smry_level$asymp.UCL * scale), |
253 | 8x |
f_conf_level(conf_level) |
254 |
), |
|
255 | 8x |
rate_ratio = formatters::with_label( |
256 | 8x |
smry_contrasts_level$ratio, |
257 | 8x |
"Adjusted Rate Ratio" |
258 |
), |
|
259 | 8x |
rate_ratio_ci = formatters::with_label( |
260 | 8x |
c(smry_contrasts_level$asymp.LCL, smry_contrasts_level$asymp.UCL), |
261 | 8x |
f_conf_level(conf_level) |
262 |
), |
|
263 | 8x |
pval = formatters::with_label( |
264 | 8x |
smry_contrasts_level$p.value, |
265 | 8x |
"p-value" |
266 |
) |
|
267 |
) |
|
268 |
} |
|
269 |
} |
|
270 | ||
271 |
#' @describeIn summarize_glm_count Formatted analysis function which is used as `afun` in `summarize_glm_count()`. |
|
272 |
#' |
|
273 |
#' @return |
|
274 |
#' * `a_glm_count()` returns the corresponding list with formatted [rtables::CellValue()]. |
|
275 |
#' |
|
276 |
#' @keywords internal |
|
277 |
a_glm_count <- function(df, |
|
278 |
..., |
|
279 |
.stats = NULL, |
|
280 |
.stat_names = NULL, |
|
281 |
.formats = NULL, |
|
282 |
.labels = NULL, |
|
283 |
.indent_mods = NULL) { |
|
284 |
# Check for additional parameters to the statistics function |
|
285 | 9x |
dots_extra_args <- list(...) |
286 | 9x |
extra_afun_params <- retrieve_extra_afun_params(names(dots_extra_args$.additional_fun_parameters)) |
287 | 9x |
dots_extra_args$.additional_fun_parameters <- NULL |
288 | ||
289 |
# Check for user-defined functions |
|
290 | 9x |
default_and_custom_stats_list <- .split_std_from_custom_stats(.stats) |
291 | 9x |
.stats <- default_and_custom_stats_list$all_stats |
292 | 9x |
custom_stat_functions <- default_and_custom_stats_list$custom_stats |
293 | ||
294 |
# Apply statistics function |
|
295 | 9x |
x_stats <- .apply_stat_functions( |
296 | 9x |
default_stat_fnc = s_glm_count, |
297 | 9x |
custom_stat_fnc_list = custom_stat_functions, |
298 | 9x |
args_list = c( |
299 | 9x |
df = list(df), |
300 | 9x |
extra_afun_params, |
301 | 9x |
dots_extra_args |
302 |
) |
|
303 |
) |
|
304 | ||
305 |
# Fill in formatting defaults |
|
306 | 9x |
.stats <- get_stats("summarize_glm_count", |
307 | 9x |
stats_in = .stats, |
308 | 9x |
custom_stats_in = names(custom_stat_functions) |
309 |
) |
|
310 | 9x |
.formats <- get_formats_from_stats(.stats, .formats) |
311 | 9x |
.labels <- get_labels_from_stats(.stats, .labels) |
312 | 9x |
.indent_mods <- get_indents_from_stats(.stats, .indent_mods) |
313 | ||
314 | 9x |
x_stats <- x_stats[.stats] |
315 | ||
316 |
# Auto format handling |
|
317 | 9x |
.formats <- apply_auto_formatting(.formats, x_stats, extra_afun_params$.df_row, extra_afun_params$.var) |
318 | ||
319 |
# Get and check statistical names |
|
320 | 9x |
.stat_names <- get_stat_names(x_stats, .stat_names) |
321 | ||
322 | 9x |
in_rows( |
323 | 9x |
.list = x_stats, |
324 | 9x |
.formats = .formats, |
325 | 9x |
.names = .labels %>% .unlist_keep_nulls(), |
326 | 9x |
.stat_names = .stat_names, |
327 | 9x |
.labels = .labels %>% .unlist_keep_nulls(), |
328 | 9x |
.indent_mods = .indent_mods %>% .unlist_keep_nulls() |
329 |
) |
|
330 |
} |
|
331 | ||
332 |
# h_glm_count ------------------------------------------------------------------ |
|
333 | ||
334 |
#' Helper functions for Poisson models |
|
335 |
#' |
|
336 |
#' @description `r lifecycle::badge("experimental")` |
|
337 |
#' |
|
338 |
#' Helper functions that returns the results of [stats::glm()] when Poisson or Quasi-Poisson |
|
339 |
#' distributions are needed (see `family` parameter), or [MASS::glm.nb()] for Negative Binomial |
|
340 |
#' distributions. Link function for the GLM is `log`. |
|
341 |
#' |
|
342 |
#' @inheritParams argument_convention |
|
343 |
#' |
|
344 |
#' @seealso [summarize_glm_count] |
|
345 |
#' |
|
346 |
#' @name h_glm_count |
|
347 |
NULL |
|
348 | ||
349 |
#' @describeIn h_glm_count Helper function to return the results of the |
|
350 |
#' selected model (Poisson, Quasi-Poisson, negative binomial). |
|
351 |
#' |
|
352 |
#' @param .df_row (`data.frame`)\cr dataset that includes all the variables that are called |
|
353 |
#' in `.var` and `variables`. |
|
354 |
#' @param variables (named `list` of `string`)\cr list of additional analysis variables, with |
|
355 |
#' expected elements: |
|
356 |
#' * `arm` (`string`)\cr group variable, for which the covariate adjusted means of multiple |
|
357 |
#' groups will be summarized. Specifically, the first level of `arm` variable is taken as the |
|
358 |
#' reference group. |
|
359 |
#' * `covariates` (`character`)\cr a vector that can contain single variable names (such as |
|
360 |
#' `"X1"`), and/or interaction terms indicated by `"X1 * X2"`. |
|
361 |
#' * `offset` (`numeric`)\cr a numeric vector or scalar adding an offset. |
|
362 |
#' @param distribution (`character`)\cr a character value specifying the distribution |
|
363 |
#' used in the regression (Poisson, Quasi-Poisson, negative binomial). |
|
364 |
#' @param weights (`character`)\cr a character vector specifying weights used |
|
365 |
#' in averaging predictions. Number of weights must equal the number of levels included in the covariates. |
|
366 |
#' Weights option passed to [emmeans::emmeans()]. |
|
367 |
#' |
|
368 |
#' @return |
|
369 |
#' * `h_glm_count()` returns the results of the selected model. |
|
370 |
#' |
|
371 |
#' @keywords internal |
|
372 |
h_glm_count <- function(.var, |
|
373 |
.df_row, |
|
374 |
variables, |
|
375 |
distribution, |
|
376 |
weights) { |
|
377 | 21x |
checkmate::assert_subset(distribution, c("poisson", "quasipoisson", "negbin"), empty.ok = FALSE) |
378 | 19x |
switch(distribution, |
379 | 13x |
poisson = h_glm_poisson(.var, .df_row, variables, weights), |
380 | 1x |
quasipoisson = h_glm_quasipoisson(.var, .df_row, variables, weights), |
381 | 5x |
negbin = h_glm_negbin(.var, .df_row, variables, weights) |
382 |
) |
|
383 |
} |
|
384 | ||
385 |
#' @describeIn h_glm_count Helper function to return results of a Poisson model. |
|
386 |
#' |
|
387 |
#' @return |
|
388 |
#' * `h_glm_poisson()` returns the results of a Poisson model. |
|
389 |
#' |
|
390 |
#' @keywords internal |
|
391 |
h_glm_poisson <- function(.var, |
|
392 |
.df_row, |
|
393 |
variables, |
|
394 |
weights) { |
|
395 | 17x |
arm <- variables$arm |
396 | 17x |
covariates <- variables$covariates |
397 | ||
398 | 17x |
formula <- stats::as.formula(paste0( |
399 | 17x |
.var, " ~ ", |
400 |
" + ", |
|
401 | 17x |
paste(covariates, collapse = " + "), |
402 |
" + ", |
|
403 | 17x |
arm |
404 |
)) |
|
405 | ||
406 | 17x |
if (is.null(variables$offset)) { |
407 | 1x |
glm_fit <- stats::glm( |
408 | 1x |
formula = formula, |
409 | 1x |
data = .df_row, |
410 | 1x |
family = stats::poisson(link = "log") |
411 |
) |
|
412 |
} else { |
|
413 | 16x |
offset <- .df_row[[variables$offset]] |
414 | 14x |
glm_fit <- stats::glm( |
415 | 14x |
formula = formula, |
416 | 14x |
offset = offset, |
417 | 14x |
data = .df_row, |
418 | 14x |
family = stats::poisson(link = "log") |
419 |
) |
|
420 |
} |
|
421 | ||
422 | 15x |
emmeans_fit <- emmeans::emmeans( |
423 | 15x |
glm_fit, |
424 | 15x |
specs = arm, |
425 | 15x |
data = .df_row, |
426 | 15x |
type = "response", |
427 | 15x |
offset = 0, |
428 | 15x |
weights = weights |
429 |
) |
|
430 | ||
431 | 15x |
list( |
432 | 15x |
glm_fit = glm_fit, |
433 | 15x |
emmeans_fit = emmeans_fit |
434 |
) |
|
435 |
} |
|
436 | ||
437 |
#' @describeIn h_glm_count Helper function to return results of a Quasi-Poisson model. |
|
438 |
#' |
|
439 |
#' @return |
|
440 |
#' * `h_glm_quasipoisson()` returns the results of a Quasi-Poisson model. |
|
441 |
#' |
|
442 |
#' @keywords internal |
|
443 |
h_glm_quasipoisson <- function(.var, |
|
444 |
.df_row, |
|
445 |
variables, |
|
446 |
weights) { |
|
447 | 5x |
arm <- variables$arm |
448 | 5x |
covariates <- variables$covariates |
449 | ||
450 | 5x |
formula <- stats::as.formula(paste0( |
451 | 5x |
.var, " ~ ", |
452 |
" + ", |
|
453 | 5x |
paste(covariates, collapse = " + "), |
454 |
" + ", |
|
455 | 5x |
arm |
456 |
)) |
|
457 | ||
458 | 5x |
if (is.null(variables$offset)) { |
459 | ! |
glm_fit <- stats::glm( |
460 | ! |
formula = formula, |
461 | ! |
data = .df_row, |
462 | ! |
family = stats::quasipoisson(link = "log") |
463 |
) |
|
464 |
} else { |
|
465 | 5x |
offset <- .df_row[[variables$offset]] |
466 | 3x |
glm_fit <- stats::glm( |
467 | 3x |
formula = formula, |
468 | 3x |
offset = offset, |
469 | 3x |
data = .df_row, |
470 | 3x |
family = stats::quasipoisson(link = "log") |
471 |
) |
|
472 |
} |
|
473 | 3x |
emmeans_fit <- emmeans::emmeans( |
474 | 3x |
glm_fit, |
475 | 3x |
specs = arm, |
476 | 3x |
data = .df_row, |
477 | 3x |
type = "response", |
478 | 3x |
offset = 0, |
479 | 3x |
weights = weights |
480 |
) |
|
481 | ||
482 | 3x |
list( |
483 | 3x |
glm_fit = glm_fit, |
484 | 3x |
emmeans_fit = emmeans_fit |
485 |
) |
|
486 |
} |
|
487 | ||
488 |
#' @describeIn h_glm_count Helper function to return results of a negative binomial model. |
|
489 |
#' |
|
490 |
#' @return |
|
491 |
#' * `h_glm_negbin()` returns the results of a negative binomial model. |
|
492 |
#' |
|
493 |
#' @keywords internal |
|
494 |
h_glm_negbin <- function(.var, |
|
495 |
.df_row, |
|
496 |
variables, |
|
497 |
weights) { |
|
498 | 9x |
arm <- variables$arm |
499 | 9x |
covariates <- variables$covariates |
500 | 9x |
formula <- stats::as.formula(paste0( |
501 | 9x |
.var, " ~ ", |
502 |
" + ", |
|
503 | 9x |
paste(covariates, collapse = " + "), |
504 |
" + ", |
|
505 | 9x |
arm |
506 |
)) |
|
507 | ||
508 | 9x |
if (is.null(variables$offset)) { |
509 | 1x |
formula <- stats::as.formula(paste0( |
510 | 1x |
.var, " ~ ", |
511 |
" + ", |
|
512 | 1x |
paste(covariates, collapse = " + "), |
513 |
" + ", |
|
514 | 1x |
arm |
515 |
)) |
|
516 |
} else { |
|
517 | 8x |
offset <- variables$offset |
518 | 8x |
formula_txt <- sprintf( |
519 | 8x |
"%s ~ %s + %s + offset(%s)", |
520 | 8x |
.var, |
521 | 8x |
arm, paste0(covariates, collapse = " + "), offset |
522 |
) |
|
523 | 8x |
formula <- stats::as.formula( |
524 | 8x |
formula_txt |
525 |
) |
|
526 |
} |
|
527 | ||
528 | 9x |
glm_fit <- MASS::glm.nb( |
529 | 9x |
formula = formula, |
530 | 9x |
data = .df_row, |
531 | 9x |
link = "log" |
532 |
) |
|
533 | ||
534 | 7x |
emmeans_fit <- emmeans::emmeans( |
535 | 7x |
glm_fit, |
536 | 7x |
specs = arm, |
537 | 7x |
data = .df_row, |
538 | 7x |
type = "response", |
539 | 7x |
offset = 0, |
540 | 7x |
weights = weights |
541 |
) |
|
542 | ||
543 | 7x |
list( |
544 | 7x |
glm_fit = glm_fit, |
545 | 7x |
emmeans_fit = emmeans_fit |
546 |
) |
|
547 |
} |
|
548 | ||
549 |
# h_ppmeans -------------------------------------------------------------------- |
|
550 |
#' Function to return the estimated means using predicted probabilities |
|
551 |
#' |
|
552 |
#' @description |
|
553 |
#' For each arm level, the predicted mean rate is calculated using the fitted model object, with `newdata` |
|
554 |
#' set to the result of `stats::model.frame`, a reconstructed data or the original data, depending on the |
|
555 |
#' object formula (coming from the fit). The confidence interval is derived using the `conf_level` parameter. |
|
556 |
#' |
|
557 |
#' @param obj (`glm.fit`)\cr fitted model object used to derive the mean rate estimates in each treatment arm. |
|
558 |
#' @param .df_row (`data.frame`)\cr dataset that includes all the variables that are called in `.var` and `variables`. |
|
559 |
#' @param arm (`string`)\cr group variable, for which the covariate adjusted means of multiple groups will be |
|
560 |
#' summarized. Specifically, the first level of `arm` variable is taken as the reference group. |
|
561 |
#' @param conf_level (`proportion`)\cr value used to derive the confidence interval for the rate. |
|
562 |
#' |
|
563 |
#' @return |
|
564 |
#' * `h_ppmeans()` returns the estimated means. |
|
565 |
#' |
|
566 |
#' @seealso [summarize_glm_count()]. |
|
567 |
#' |
|
568 |
#' @export |
|
569 |
h_ppmeans <- function(obj, .df_row, arm, conf_level) { |
|
570 | 1x |
alpha <- 1 - conf_level |
571 | 1x |
p <- 1 - alpha / 2 |
572 | ||
573 | 1x |
arm_levels <- levels(.df_row[[arm]]) |
574 | ||
575 | 1x |
out <- lapply(arm_levels, function(lev) { |
576 | 3x |
temp <- .df_row |
577 | 3x |
temp[[arm]] <- factor(lev, levels = arm_levels) |
578 | ||
579 | 3x |
mf <- stats::model.frame(obj$formula, data = temp) |
580 | 3x |
X <- stats::model.matrix(obj$formula, data = mf) # nolint |
581 | ||
582 | 3x |
rate <- stats::predict(obj, newdata = mf, type = "response") |
583 | 3x |
rate_hat <- mean(rate) |
584 | ||
585 | 3x |
zz <- colMeans(rate * X) |
586 | 3x |
se <- sqrt(as.numeric(t(zz) %*% stats::vcov(obj) %*% zz)) |
587 | 3x |
rate_lwr <- rate_hat * exp(-stats::qnorm(p) * se / rate_hat) |
588 | 3x |
rate_upr <- rate_hat * exp(stats::qnorm(p) * se / rate_hat) |
589 | ||
590 | 3x |
c(rate_hat, rate_lwr, rate_upr) |
591 |
}) |
|
592 | ||
593 | 1x |
names(out) <- arm_levels |
594 | 1x |
out <- do.call(rbind, out) |
595 | 1x |
if ("negbin" %in% class(obj)) { |
596 | ! |
colnames(out) <- c("response", "asymp.LCL", "asymp.UCL") |
597 |
} else { |
|
598 | 1x |
colnames(out) <- c("rate", "asymp.LCL", "asymp.UCL") |
599 |
} |
|
600 | 1x |
out <- as.data.frame(out) |
601 | 1x |
out[[arm]] <- rownames(out) |
602 | 1x |
out |
603 |
} |
1 |
#' Control functions for Kaplan-Meier plot annotation tables |
|
2 |
#' |
|
3 |
#' @description `r lifecycle::badge("stable")` |
|
4 |
#' |
|
5 |
#' Auxiliary functions for controlling arguments for formatting the annotation tables that can be added to plots |
|
6 |
#' generated via [g_km()]. |
|
7 |
#' |
|
8 |
#' @param x (`proportion`)\cr x-coordinate for center of annotation table. |
|
9 |
#' @param y (`proportion`)\cr y-coordinate for center of annotation table. |
|
10 |
#' @param w (`proportion`)\cr relative width of the annotation table. |
|
11 |
#' @param h (`proportion`)\cr relative height of the annotation table. |
|
12 |
#' @param fill (`flag` or `character`)\cr whether the annotation table should have a background fill color. |
|
13 |
#' Can also be a color code to use as the background fill color. If `TRUE`, color code defaults to `"#00000020"`. |
|
14 |
#' |
|
15 |
#' @return A list of components with the same names as the arguments. |
|
16 |
#' |
|
17 |
#' @seealso [g_km()] |
|
18 |
#' |
|
19 |
#' @name control_annot |
|
20 |
NULL |
|
21 | ||
22 |
#' @describeIn control_annot Control function for formatting the median survival time annotation table. This annotation |
|
23 |
#' table can be added in [g_km()] by setting `annot_surv_med=TRUE`, and can be configured using the |
|
24 |
#' `control_surv_med_annot()` function by setting it as the `control_annot_surv_med` argument. |
|
25 |
#' |
|
26 |
#' @examples |
|
27 |
#' control_surv_med_annot() |
|
28 |
#' |
|
29 |
#' @export |
|
30 |
control_surv_med_annot <- function(x = 0.8, y = 0.85, w = 0.32, h = 0.16, fill = TRUE) { |
|
31 | 22x |
assert_proportion_value(x) |
32 | 22x |
assert_proportion_value(y) |
33 | 22x |
assert_proportion_value(w) |
34 | 22x |
assert_proportion_value(h) |
35 | ||
36 | 22x |
list(x = x, y = y, w = w, h = h, fill = fill) |
37 |
} |
|
38 | ||
39 |
#' @describeIn control_annot Control function for formatting the Cox-PH annotation table. This annotation table can be |
|
40 |
#' added in [g_km()] by setting `annot_coxph=TRUE`, and can be configured using the `control_coxph_annot()` function |
|
41 |
#' by setting it as the `control_annot_coxph` argument. |
|
42 |
#' |
|
43 |
#' @param ref_lbls (`flag`)\cr whether the reference group should be explicitly printed in labels for the |
|
44 |
#' annotation table. If `FALSE` (default), only comparison groups will be printed in the table labels. |
|
45 |
#' |
|
46 |
#' @examples |
|
47 |
#' control_coxph_annot() |
|
48 |
#' |
|
49 |
#' @export |
|
50 |
control_coxph_annot <- function(x = 0.29, y = 0.51, w = 0.4, h = 0.125, fill = TRUE, ref_lbls = FALSE) { |
|
51 | 11x |
checkmate::assert_logical(ref_lbls, any.missing = FALSE) |
52 | ||
53 | 11x |
res <- c(control_surv_med_annot(x = x, y = y, w = w, h = h), list(ref_lbls = ref_lbls)) |
54 | 11x |
res |
55 |
} |
|
56 | ||
57 |
#' Helper function to calculate x-tick positions |
|
58 |
#' |
|
59 |
#' @description `r lifecycle::badge("stable")` |
|
60 |
#' |
|
61 |
#' Calculate the positions of ticks on the x-axis. However, if `xticks` already |
|
62 |
#' exists it is kept as is. It is based on the same function `ggplot2` relies on, |
|
63 |
#' and is required in the graphic and the patient-at-risk annotation table. |
|
64 |
#' |
|
65 |
#' @inheritParams g_km |
|
66 |
#' @inheritParams h_ggkm |
|
67 |
#' |
|
68 |
#' @return A vector of positions to use for x-axis ticks on a `ggplot` object. |
|
69 |
#' |
|
70 |
#' @examples |
|
71 |
#' library(dplyr) |
|
72 |
#' library(survival) |
|
73 |
#' |
|
74 |
#' data <- tern_ex_adtte %>% |
|
75 |
#' filter(PARAMCD == "OS") %>% |
|
76 |
#' survfit(formula = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) %>% |
|
77 |
#' h_data_plot() |
|
78 |
#' |
|
79 |
#' h_xticks(data) |
|
80 |
#' h_xticks(data, xticks = seq(0, 3000, 500)) |
|
81 |
#' h_xticks(data, xticks = 500) |
|
82 |
#' h_xticks(data, xticks = 500, max_time = 6000) |
|
83 |
#' h_xticks(data, xticks = c(0, 500), max_time = 300) |
|
84 |
#' h_xticks(data, xticks = 500, max_time = 300) |
|
85 |
#' |
|
86 |
#' @export |
|
87 |
h_xticks <- function(data, xticks = NULL, max_time = NULL) { |
|
88 | 18x |
if (is.null(xticks)) { |
89 | 13x |
if (is.null(max_time)) { |
90 | 11x |
labeling::extended(range(data$time)[1], range(data$time)[2], m = 5) |
91 |
} else { |
|
92 | 2x |
labeling::extended(range(data$time)[1], max(range(data$time)[2], max_time), m = 5) |
93 |
} |
|
94 | 5x |
} else if (checkmate::test_number(xticks)) { |
95 | 2x |
if (is.null(max_time)) { |
96 | 1x |
seq(0, max(data$time), xticks) |
97 |
} else { |
|
98 | 1x |
seq(0, max(data$time, max_time), xticks) |
99 |
} |
|
100 | 3x |
} else if (is.numeric(xticks)) { |
101 | 2x |
xticks |
102 |
} else { |
|
103 | 1x |
stop( |
104 | 1x |
paste( |
105 | 1x |
"xticks should be either `NULL`", |
106 | 1x |
"or a single number (interval between x ticks)", |
107 | 1x |
"or a numeric vector (position of ticks on the x axis)" |
108 |
) |
|
109 |
) |
|
110 |
} |
|
111 |
} |
|
112 | ||
113 |
#' Helper function for survival estimations |
|
114 |
#' |
|
115 |
#' @description `r lifecycle::badge("stable")` |
|
116 |
#' |
|
117 |
#' Transform a survival fit to a table with groups in rows characterized by N, median and confidence interval. |
|
118 |
#' |
|
119 |
#' @inheritParams h_data_plot |
|
120 |
#' |
|
121 |
#' @return A summary table with statistics `N`, `Median`, and `XX% CI` (`XX` taken from `fit_km`). |
|
122 |
#' |
|
123 |
#' @examples |
|
124 |
#' library(dplyr) |
|
125 |
#' library(survival) |
|
126 |
#' |
|
127 |
#' adtte <- tern_ex_adtte %>% filter(PARAMCD == "OS") |
|
128 |
#' fit <- survfit( |
|
129 |
#' formula = Surv(AVAL, 1 - CNSR) ~ ARMCD, |
|
130 |
#' data = adtte |
|
131 |
#' ) |
|
132 |
#' h_tbl_median_surv(fit_km = fit) |
|
133 |
#' |
|
134 |
#' @export |
|
135 |
h_tbl_median_surv <- function(fit_km, armval = "All") { |
|
136 | 10x |
y <- if (is.null(fit_km$strata)) { |
137 | ! |
as.data.frame(t(summary(fit_km)$table), row.names = armval) |
138 |
} else { |
|
139 | 10x |
tbl <- summary(fit_km)$table |
140 | 10x |
rownames_lst <- strsplit(sub("=", "equals", rownames(tbl)), "equals") |
141 | 10x |
rownames(tbl) <- matrix(unlist(rownames_lst), ncol = 2, byrow = TRUE)[, 2] |
142 | 10x |
as.data.frame(tbl) |
143 |
} |
|
144 | 10x |
conf.int <- summary(fit_km)$conf.int # nolint |
145 | 10x |
y$records <- round(y$records) |
146 | 10x |
y$median <- signif(y$median, 4) |
147 | 10x |
y$`CI` <- paste0( |
148 | 10x |
"(", signif(y[[paste0(conf.int, "LCL")]], 4), ", ", signif(y[[paste0(conf.int, "UCL")]], 4), ")" |
149 |
) |
|
150 | 10x |
stats::setNames( |
151 | 10x |
y[c("records", "median", "CI")], |
152 | 10x |
c("N", "Median", f_conf_level(conf.int)) |
153 |
) |
|
154 |
} |
|
155 | ||
156 |
#' Helper function for generating a pairwise Cox-PH table |
|
157 |
#' |
|
158 |
#' @description `r lifecycle::badge("stable")` |
|
159 |
#' |
|
160 |
#' Create a `data.frame` of pairwise stratified or unstratified Cox-PH analysis results. |
|
161 |
#' |
|
162 |
#' @inheritParams g_km |
|
163 |
#' @param annot_coxph_ref_lbls (`flag`)\cr whether the reference group should be explicitly printed in labels for the |
|
164 |
#' `annot_coxph` table. If `FALSE` (default), only comparison groups will be printed in `annot_coxph` table labels. |
|
165 |
#' |
|
166 |
#' @return A `data.frame` containing statistics `HR`, `XX% CI` (`XX` taken from `control_coxph_pw`), |
|
167 |
#' and `p-value (log-rank)`. |
|
168 |
#' |
|
169 |
#' @examples |
|
170 |
#' library(dplyr) |
|
171 |
#' |
|
172 |
#' adtte <- tern_ex_adtte %>% |
|
173 |
#' filter(PARAMCD == "OS") %>% |
|
174 |
#' mutate(is_event = CNSR == 0) |
|
175 |
#' |
|
176 |
#' h_tbl_coxph_pairwise( |
|
177 |
#' df = adtte, |
|
178 |
#' variables = list(tte = "AVAL", is_event = "is_event", arm = "ARM"), |
|
179 |
#' control_coxph_pw = control_coxph(conf_level = 0.9) |
|
180 |
#' ) |
|
181 |
#' |
|
182 |
#' @export |
|
183 |
h_tbl_coxph_pairwise <- function(df, |
|
184 |
variables, |
|
185 |
ref_group_coxph = NULL, |
|
186 |
control_coxph_pw = control_coxph(), |
|
187 |
annot_coxph_ref_lbls = FALSE) { |
|
188 | 4x |
if ("strat" %in% names(variables)) { |
189 | ! |
warning( |
190 | ! |
"Warning: the `strat` element name of the `variables` list argument to `h_tbl_coxph_pairwise() ", |
191 | ! |
"was deprecated in tern 0.9.4.\n ", |
192 | ! |
"Please use the name `strata` instead of `strat` in the `variables` argument." |
193 |
) |
|
194 | ! |
variables[["strata"]] <- variables[["strat"]] |
195 |
} |
|
196 | ||
197 | 4x |
assert_df_with_variables(df, variables) |
198 | 4x |
checkmate::assert_choice(ref_group_coxph, levels(df[[variables$arm]]), null.ok = TRUE) |
199 | 4x |
checkmate::assert_flag(annot_coxph_ref_lbls) |
200 | ||
201 | 4x |
arm <- variables$arm |
202 | 4x |
df[[arm]] <- factor(df[[arm]]) |
203 | ||
204 | 4x |
ref_group <- if (!is.null(ref_group_coxph)) ref_group_coxph else levels(df[[variables$arm]])[1] |
205 | 4x |
comp_group <- setdiff(levels(df[[arm]]), ref_group) |
206 | ||
207 | 4x |
results <- Map(function(comp) { |
208 | 8x |
res <- s_coxph_pairwise( |
209 | 8x |
df = df[df[[arm]] == comp, , drop = FALSE], |
210 | 8x |
.ref_group = df[df[[arm]] == ref_group, , drop = FALSE], |
211 | 8x |
.in_ref_col = FALSE, |
212 | 8x |
.var = variables$tte, |
213 | 8x |
is_event = variables$is_event, |
214 | 8x |
strata = variables$strata, |
215 | 8x |
control = control_coxph_pw |
216 |
) |
|
217 | 8x |
res_df <- data.frame( |
218 | 8x |
hr = format(round(res$hr, 2), nsmall = 2), |
219 | 8x |
hr_ci = paste0( |
220 | 8x |
"(", format(round(res$hr_ci[1], 2), nsmall = 2), ", ", |
221 | 8x |
format(round(res$hr_ci[2], 2), nsmall = 2), ")" |
222 |
), |
|
223 | 8x |
pvalue = if (res$pvalue < 0.0001) "<0.0001" else format(round(res$pvalue, 4), 4), |
224 | 8x |
stringsAsFactors = FALSE |
225 |
) |
|
226 | 8x |
colnames(res_df) <- c("HR", vapply(res[c("hr_ci", "pvalue")], obj_label, FUN.VALUE = "character")) |
227 | 8x |
row.names(res_df) <- comp |
228 | 8x |
res_df |
229 | 4x |
}, comp_group) |
230 | 1x |
if (annot_coxph_ref_lbls) names(results) <- paste(comp_group, "vs.", ref_group) |
231 | ||
232 | 4x |
do.call(rbind, results) |
233 |
} |
|
234 | ||
235 |
#' Helper function to tidy survival fit data |
|
236 |
#' |
|
237 |
#' @description `r lifecycle::badge("stable")` |
|
238 |
#' |
|
239 |
#' Convert the survival fit data into a data frame designed for plotting |
|
240 |
#' within `g_km`. |
|
241 |
#' |
|
242 |
#' This starts from the [broom::tidy()] result, and then: |
|
243 |
#' * Post-processes the `strata` column into a factor. |
|
244 |
#' * Extends each stratum by an additional first row with time 0 and probability 1 so that |
|
245 |
#' downstream plot lines start at those coordinates. |
|
246 |
#' * Adds a `censor` column. |
|
247 |
#' * Filters the rows before `max_time`. |
|
248 |
#' |
|
249 |
#' @inheritParams g_km |
|
250 |
#' @param fit_km (`survfit`)\cr result of [survival::survfit()]. |
|
251 |
#' @param armval (`string`)\cr used as strata name when treatment arm variable only has one level. Default is `"All"`. |
|
252 |
#' |
|
253 |
#' @return A `tibble` with columns `time`, `n.risk`, `n.event`, `n.censor`, `estimate`, `std.error`, `conf.high`, |
|
254 |
#' `conf.low`, `strata`, and `censor`. |
|
255 |
#' |
|
256 |
#' @examples |
|
257 |
#' library(dplyr) |
|
258 |
#' library(survival) |
|
259 |
#' |
|
260 |
#' # Test with multiple arms |
|
261 |
#' tern_ex_adtte %>% |
|
262 |
#' filter(PARAMCD == "OS") %>% |
|
263 |
#' survfit(formula = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) %>% |
|
264 |
#' h_data_plot() |
|
265 |
#' |
|
266 |
#' # Test with single arm |
|
267 |
#' tern_ex_adtte %>% |
|
268 |
#' filter(PARAMCD == "OS", ARMCD == "ARM B") %>% |
|
269 |
#' survfit(formula = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) %>% |
|
270 |
#' h_data_plot(armval = "ARM B") |
|
271 |
#' |
|
272 |
#' @export |
|
273 |
h_data_plot <- function(fit_km, |
|
274 |
armval = "All", |
|
275 |
max_time = NULL) { |
|
276 | 18x |
y <- broom::tidy(fit_km) |
277 | ||
278 | 18x |
if (!is.null(fit_km$strata)) { |
279 | 18x |
fit_km_var_level <- strsplit(sub("=", "equals", names(fit_km$strata)), "equals") |
280 | 18x |
strata_levels <- vapply(fit_km_var_level, FUN = "[", FUN.VALUE = "a", i = 2) |
281 | 18x |
strata_var_level <- strsplit(sub("=", "equals", y$strata), "equals") |
282 | 18x |
y$strata <- factor( |
283 | 18x |
vapply(strata_var_level, FUN = "[", FUN.VALUE = "a", i = 2), |
284 | 18x |
levels = strata_levels |
285 |
) |
|
286 |
} else { |
|
287 | ! |
y$strata <- armval |
288 |
} |
|
289 | ||
290 | 18x |
y_by_strata <- split(y, y$strata) |
291 | 18x |
y_by_strata_extended <- lapply( |
292 | 18x |
y_by_strata, |
293 | 18x |
FUN = function(tbl) { |
294 | 53x |
first_row <- tbl[1L, ] |
295 | 53x |
first_row$time <- 0 |
296 | 53x |
first_row$n.risk <- sum(first_row[, c("n.risk", "n.event", "n.censor")]) |
297 | 53x |
first_row$n.event <- first_row$n.censor <- 0 |
298 | 53x |
first_row$estimate <- first_row$conf.high <- first_row$conf.low <- 1 |
299 | 53x |
first_row$std.error <- 0 |
300 | 53x |
rbind( |
301 | 53x |
first_row, |
302 | 53x |
tbl |
303 |
) |
|
304 |
} |
|
305 |
) |
|
306 | 18x |
y <- do.call(rbind, y_by_strata_extended) |
307 | ||
308 | 18x |
y$censor <- ifelse(y$n.censor > 0, y$estimate, NA) |
309 | 18x |
if (!is.null(max_time)) { |
310 | 1x |
y <- y[y$time <= max(max_time), ] |
311 |
} |
|
312 | 18x |
y |
313 |
} |
|
314 | ||
315 |
## Deprecated Functions ---- |
|
316 | ||
317 |
#' Helper function to create a KM plot |
|
318 |
#' |
|
319 |
#' @description `r lifecycle::badge("deprecated")` |
|
320 |
#' |
|
321 |
#' Draw the Kaplan-Meier plot using `ggplot2`. |
|
322 |
#' |
|
323 |
#' @inheritParams g_km |
|
324 |
#' @param data (`data.frame`)\cr survival data as pre-processed by `h_data_plot`. |
|
325 |
#' |
|
326 |
#' @return A `ggplot` object. |
|
327 |
#' |
|
328 |
#' @examples |
|
329 |
#' \donttest{ |
|
330 |
#' library(dplyr) |
|
331 |
#' library(survival) |
|
332 |
#' |
|
333 |
#' fit_km <- tern_ex_adtte %>% |
|
334 |
#' filter(PARAMCD == "OS") %>% |
|
335 |
#' survfit(formula = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) |
|
336 |
#' data_plot <- h_data_plot(fit_km = fit_km) |
|
337 |
#' xticks <- h_xticks(data = data_plot) |
|
338 |
#' gg <- h_ggkm( |
|
339 |
#' data = data_plot, |
|
340 |
#' censor_show = TRUE, |
|
341 |
#' xticks = xticks, |
|
342 |
#' xlab = "Days", |
|
343 |
#' yval = "Survival", |
|
344 |
#' ylab = "Survival Probability", |
|
345 |
#' title = "Survival" |
|
346 |
#' ) |
|
347 |
#' gg |
|
348 |
#' } |
|
349 |
#' |
|
350 |
#' @export |
|
351 |
h_ggkm <- function(data, |
|
352 |
xticks = NULL, |
|
353 |
yval = "Survival", |
|
354 |
censor_show, |
|
355 |
xlab, |
|
356 |
ylab, |
|
357 |
ylim = NULL, |
|
358 |
title, |
|
359 |
footnotes = NULL, |
|
360 |
max_time = NULL, |
|
361 |
lwd = 1, |
|
362 |
lty = NULL, |
|
363 |
pch = 3, |
|
364 |
size = 2, |
|
365 |
col = NULL, |
|
366 |
ci_ribbon = FALSE, |
|
367 |
ggtheme = nestcolor::theme_nest()) { |
|
368 | 1x |
lifecycle::deprecate_warn( |
369 | 1x |
"0.9.4", |
370 | 1x |
"h_ggkm()", |
371 | 1x |
details = "`g_km` now generates `ggplot` objects. This function is no longer used within `tern`." |
372 |
) |
|
373 | 1x |
checkmate::assert_numeric(lty, null.ok = TRUE) |
374 | 1x |
checkmate::assert_character(col, null.ok = TRUE) |
375 | ||
376 | 1x |
if (is.null(ylim)) { |
377 | 1x |
data_lims <- data |
378 | ! |
if (yval == "Failure") data_lims[["estimate"]] <- 1 - data_lims[["estimate"]] |
379 | 1x |
if (!is.null(max_time)) { |
380 | ! |
y_lwr <- min(data_lims[data_lims$time < max_time, ][["estimate"]]) |
381 | ! |
y_upr <- max(data_lims[data_lims$time < max_time, ][["estimate"]]) |
382 |
} else { |
|
383 | 1x |
y_lwr <- min(data_lims[["estimate"]]) |
384 | 1x |
y_upr <- max(data_lims[["estimate"]]) |
385 |
} |
|
386 | 1x |
ylim <- c(y_lwr, y_upr) |
387 |
} |
|
388 | 1x |
checkmate::assert_numeric(ylim, finite = TRUE, any.missing = FALSE, len = 2, sorted = TRUE) |
389 | ||
390 |
# change estimates of survival to estimates of failure (1 - survival) |
|
391 | 1x |
if (yval == "Failure") { |
392 | ! |
data$estimate <- 1 - data$estimate |
393 | ! |
data[c("conf.high", "conf.low")] <- list(1 - data$conf.low, 1 - data$conf.high) |
394 | ! |
data$censor <- 1 - data$censor |
395 |
} |
|
396 | ||
397 | 1x |
gg <- { |
398 | 1x |
ggplot2::ggplot( |
399 | 1x |
data = data, |
400 | 1x |
mapping = ggplot2::aes( |
401 | 1x |
x = .data[["time"]], |
402 | 1x |
y = .data[["estimate"]], |
403 | 1x |
ymin = .data[["conf.low"]], |
404 | 1x |
ymax = .data[["conf.high"]], |
405 | 1x |
color = .data[["strata"]], |
406 | 1x |
fill = .data[["strata"]] |
407 |
) |
|
408 |
) + |
|
409 | 1x |
ggplot2::geom_hline(yintercept = 0) |
410 |
} |
|
411 | ||
412 | 1x |
if (ci_ribbon) { |
413 | ! |
gg <- gg + ggplot2::geom_ribbon(alpha = .3, lty = 0) |
414 |
} |
|
415 | ||
416 | 1x |
gg <- if (is.null(lty)) { |
417 | 1x |
gg + |
418 | 1x |
ggplot2::geom_step(linewidth = lwd) |
419 | 1x |
} else if (checkmate::test_number(lty)) { |
420 | ! |
gg + |
421 | ! |
ggplot2::geom_step(linewidth = lwd, lty = lty) |
422 | 1x |
} else if (is.numeric(lty)) { |
423 | ! |
gg + |
424 | ! |
ggplot2::geom_step(mapping = ggplot2::aes(linetype = .data[["strata"]]), linewidth = lwd) + |
425 | ! |
ggplot2::scale_linetype_manual(values = lty) |
426 |
} |
|
427 | ||
428 | 1x |
gg <- gg + |
429 | 1x |
ggplot2::coord_cartesian(ylim = ylim) + |
430 | 1x |
ggplot2::labs(x = xlab, y = ylab, title = title, caption = footnotes) |
431 | ||
432 | 1x |
if (!is.null(col)) { |
433 | ! |
gg <- gg + |
434 | ! |
ggplot2::scale_color_manual(values = col) + |
435 | ! |
ggplot2::scale_fill_manual(values = col) |
436 |
} |
|
437 | 1x |
if (censor_show) { |
438 | 1x |
dt <- data[data$n.censor != 0, ] |
439 | 1x |
dt$censor_lbl <- factor("Censored") |
440 | ||
441 | 1x |
gg <- gg + ggplot2::geom_point( |
442 | 1x |
data = dt, |
443 | 1x |
ggplot2::aes( |
444 | 1x |
x = .data[["time"]], |
445 | 1x |
y = .data[["censor"]], |
446 | 1x |
shape = .data[["censor_lbl"]] |
447 |
), |
|
448 | 1x |
size = size, |
449 | 1x |
show.legend = TRUE, |
450 | 1x |
inherit.aes = TRUE |
451 |
) + |
|
452 | 1x |
ggplot2::scale_shape_manual(name = NULL, values = pch) + |
453 | 1x |
ggplot2::guides( |
454 | 1x |
shape = ggplot2::guide_legend(override.aes = list(linetype = NA)), |
455 | 1x |
fill = ggplot2::guide_legend(override.aes = list(shape = NA)) |
456 |
) |
|
457 |
} |
|
458 | ||
459 | 1x |
if (!is.null(max_time) && !is.null(xticks)) { |
460 | ! |
gg <- gg + ggplot2::scale_x_continuous(breaks = xticks, limits = c(min(0, xticks), max(c(xticks, max_time)))) |
461 | 1x |
} else if (!is.null(xticks)) { |
462 | 1x |
if (max(data$time) <= max(xticks)) { |
463 | 1x |
gg <- gg + ggplot2::scale_x_continuous(breaks = xticks, limits = c(min(0, min(xticks)), max(xticks))) |
464 |
} else { |
|
465 | ! |
gg <- gg + ggplot2::scale_x_continuous(breaks = xticks) |
466 |
} |
|
467 | ! |
} else if (!is.null(max_time)) { |
468 | ! |
gg <- gg + ggplot2::scale_x_continuous(limits = c(0, max_time)) |
469 |
} |
|
470 | ||
471 | 1x |
if (!is.null(ggtheme)) { |
472 | 1x |
gg <- gg + ggtheme |
473 |
} |
|
474 | ||
475 | 1x |
gg + ggplot2::theme( |
476 | 1x |
legend.position = "bottom", |
477 | 1x |
legend.title = ggplot2::element_blank(), |
478 | 1x |
legend.key.height = unit(0.02, "npc"), |
479 | 1x |
panel.grid.major.x = ggplot2::element_line(linewidth = 2) |
480 |
) |
|
481 |
} |
|
482 | ||
483 |
#' `ggplot` decomposition |
|
484 |
#' |
|
485 |
#' @description `r lifecycle::badge("deprecated")` |
|
486 |
#' |
|
487 |
#' The elements composing the `ggplot` are extracted and organized in a `list`. |
|
488 |
#' |
|
489 |
#' @param gg (`ggplot`)\cr a graphic to decompose. |
|
490 |
#' |
|
491 |
#' @return A named `list` with elements: |
|
492 |
#' * `panel`: The panel. |
|
493 |
#' * `yaxis`: The y-axis. |
|
494 |
#' * `xaxis`: The x-axis. |
|
495 |
#' * `xlab`: The x-axis label. |
|
496 |
#' * `ylab`: The y-axis label. |
|
497 |
#' * `guide`: The legend. |
|
498 |
#' |
|
499 |
#' @examples |
|
500 |
#' \donttest{ |
|
501 |
#' library(dplyr) |
|
502 |
#' library(survival) |
|
503 |
#' library(grid) |
|
504 |
#' |
|
505 |
#' fit_km <- tern_ex_adtte %>% |
|
506 |
#' filter(PARAMCD == "OS") %>% |
|
507 |
#' survfit(formula = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) |
|
508 |
#' data_plot <- h_data_plot(fit_km = fit_km) |
|
509 |
#' xticks <- h_xticks(data = data_plot) |
|
510 |
#' gg <- h_ggkm( |
|
511 |
#' data = data_plot, |
|
512 |
#' yval = "Survival", |
|
513 |
#' censor_show = TRUE, |
|
514 |
#' xticks = xticks, xlab = "Days", ylab = "Survival Probability", |
|
515 |
#' title = "tt", |
|
516 |
#' footnotes = "ff" |
|
517 |
#' ) |
|
518 |
#' |
|
519 |
#' g_el <- h_decompose_gg(gg) |
|
520 |
#' grid::grid.newpage() |
|
521 |
#' grid.rect(gp = grid::gpar(lty = 1, col = "red", fill = "gray85", lwd = 5)) |
|
522 |
#' grid::grid.draw(g_el$panel) |
|
523 |
#' |
|
524 |
#' grid::grid.newpage() |
|
525 |
#' grid.rect(gp = grid::gpar(lty = 1, col = "royalblue", fill = "gray85", lwd = 5)) |
|
526 |
#' grid::grid.draw(with(g_el, cbind(ylab, yaxis))) |
|
527 |
#' } |
|
528 |
#' |
|
529 |
#' @export |
|
530 |
h_decompose_gg <- function(gg) { |
|
531 | 1x |
lifecycle::deprecate_warn( |
532 | 1x |
"0.9.4", |
533 | 1x |
"h_decompose_gg()", |
534 | 1x |
details = "`g_km` now generates `ggplot` objects. This function is no longer used within `tern`." |
535 |
) |
|
536 | 1x |
g_el <- ggplot2::ggplotGrob(gg) |
537 | 1x |
y <- c( |
538 | 1x |
panel = "panel", |
539 | 1x |
yaxis = "axis-l", |
540 | 1x |
xaxis = "axis-b", |
541 | 1x |
xlab = "xlab-b", |
542 | 1x |
ylab = "ylab-l", |
543 | 1x |
guide = "guide" |
544 |
) |
|
545 | 1x |
lapply(X = y, function(x) gtable::gtable_filter(g_el, x)) |
546 |
} |
|
547 | ||
548 |
#' Helper function to prepare a KM layout |
|
549 |
#' |
|
550 |
#' @description `r lifecycle::badge("deprecated")` |
|
551 |
#' |
|
552 |
#' Prepares a (5 rows) x (2 cols) layout for the Kaplan-Meier curve. |
|
553 |
#' |
|
554 |
#' @inheritParams g_km |
|
555 |
#' @inheritParams h_ggkm |
|
556 |
#' @param g_el (`list` of `gtable`)\cr list as obtained by `h_decompose_gg()`. |
|
557 |
#' @param annot_at_risk (`flag`)\cr compute and add the annotation table reporting the number of |
|
558 |
#' patient at risk matching the main grid of the Kaplan-Meier curve. |
|
559 |
#' |
|
560 |
#' @return A grid layout. |
|
561 |
#' |
|
562 |
#' @details The layout corresponds to a grid of two columns and five rows of unequal dimensions. Most of the |
|
563 |
#' dimension are fixed, only the curve is flexible and will accommodate with the remaining free space. |
|
564 |
#' * The left column gets the annotation of the `ggplot` (y-axis) and the names of the strata for the patient |
|
565 |
#' at risk tabulation. The main constraint is about the width of the columns which must allow the writing of |
|
566 |
#' the strata name. |
|
567 |
#' * The right column receive the `ggplot`, the legend, the x-axis and the patient at risk table. |
|
568 |
#' |
|
569 |
#' @examples |
|
570 |
#' \donttest{ |
|
571 |
#' library(dplyr) |
|
572 |
#' library(survival) |
|
573 |
#' library(grid) |
|
574 |
#' |
|
575 |
#' fit_km <- tern_ex_adtte %>% |
|
576 |
#' filter(PARAMCD == "OS") %>% |
|
577 |
#' survfit(formula = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) |
|
578 |
#' data_plot <- h_data_plot(fit_km = fit_km) |
|
579 |
#' xticks <- h_xticks(data = data_plot) |
|
580 |
#' gg <- h_ggkm( |
|
581 |
#' data = data_plot, |
|
582 |
#' censor_show = TRUE, |
|
583 |
#' xticks = xticks, xlab = "Days", ylab = "Survival Probability", |
|
584 |
#' title = "tt", footnotes = "ff", yval = "Survival" |
|
585 |
#' ) |
|
586 |
#' g_el <- h_decompose_gg(gg) |
|
587 |
#' lyt <- h_km_layout(data = data_plot, g_el = g_el, title = "t", footnotes = "f") |
|
588 |
#' grid.show.layout(lyt) |
|
589 |
#' } |
|
590 |
#' |
|
591 |
#' @export |
|
592 |
h_km_layout <- function(data, g_el, title, footnotes, annot_at_risk = TRUE, annot_at_risk_title = TRUE) { |
|
593 | 1x |
lifecycle::deprecate_warn( |
594 | 1x |
"0.9.4", |
595 | 1x |
"h_km_layout()", |
596 | 1x |
details = "`g_km` now generates `ggplot` objects. This function is no longer used within `tern`." |
597 |
) |
|
598 | 1x |
txtlines <- levels(as.factor(data$strata)) |
599 | 1x |
nlines <- nlevels(as.factor(data$strata)) |
600 | 1x |
col_annot_width <- max( |
601 | 1x |
c( |
602 | 1x |
as.numeric(grid::convertX(g_el$yaxis$widths + g_el$ylab$widths, "pt")), |
603 | 1x |
as.numeric( |
604 | 1x |
grid::convertX( |
605 | 1x |
grid::stringWidth(txtlines) + grid::unit(7, "pt"), "pt" |
606 |
) |
|
607 |
) |
|
608 |
) |
|
609 |
) |
|
610 | ||
611 | 1x |
ttl_row <- as.numeric(!is.null(title)) |
612 | 1x |
foot_row <- as.numeric(!is.null(footnotes)) |
613 | 1x |
no_tbl_ind <- c() |
614 | 1x |
ht_x <- c() |
615 | 1x |
ht_units <- c() |
616 | ||
617 | 1x |
if (ttl_row == 1) { |
618 | 1x |
no_tbl_ind <- c(no_tbl_ind, TRUE) |
619 | 1x |
ht_x <- c(ht_x, 2) |
620 | 1x |
ht_units <- c(ht_units, "lines") |
621 |
} |
|
622 | ||
623 | 1x |
no_tbl_ind <- c(no_tbl_ind, rep(TRUE, 3), rep(FALSE, 2)) |
624 | 1x |
ht_x <- c( |
625 | 1x |
ht_x, |
626 | 1x |
1, |
627 | 1x |
grid::convertX(with(g_el, xaxis$heights + ylab$widths), "pt") + grid::unit(5, "pt"), |
628 | 1x |
grid::convertX(g_el$guide$heights, "pt") + grid::unit(2, "pt"), |
629 | 1x |
1, |
630 | 1x |
nlines + 0.5, |
631 | 1x |
grid::convertX(with(g_el, xaxis$heights + ylab$widths), "pt") |
632 |
) |
|
633 | 1x |
ht_units <- c( |
634 | 1x |
ht_units, |
635 | 1x |
"null", |
636 | 1x |
"pt", |
637 | 1x |
"pt", |
638 | 1x |
"lines", |
639 | 1x |
"lines", |
640 | 1x |
"pt" |
641 |
) |
|
642 | ||
643 | 1x |
if (foot_row == 1) { |
644 | 1x |
no_tbl_ind <- c(no_tbl_ind, TRUE) |
645 | 1x |
ht_x <- c(ht_x, 1) |
646 | 1x |
ht_units <- c(ht_units, "lines") |
647 |
} |
|
648 | 1x |
if (annot_at_risk) { |
649 | 1x |
no_at_risk_tbl <- rep(TRUE, 6 + ttl_row + foot_row) |
650 | 1x |
if (!annot_at_risk_title) { |
651 | ! |
no_at_risk_tbl[length(no_at_risk_tbl) - 2 - foot_row] <- FALSE |
652 |
} |
|
653 |
} else { |
|
654 | ! |
no_at_risk_tbl <- no_tbl_ind |
655 |
} |
|
656 | ||
657 | 1x |
grid::grid.layout( |
658 | 1x |
nrow = sum(no_at_risk_tbl), ncol = 2, |
659 | 1x |
widths = grid::unit(c(col_annot_width, 1), c("pt", "null")), |
660 | 1x |
heights = grid::unit( |
661 | 1x |
x = ht_x[no_at_risk_tbl], |
662 | 1x |
units = ht_units[no_at_risk_tbl] |
663 |
) |
|
664 |
) |
|
665 |
} |
|
666 | ||
667 |
#' Helper function to create patient-at-risk grobs |
|
668 |
#' |
|
669 |
#' @description `r lifecycle::badge("deprecated")` |
|
670 |
#' |
|
671 |
#' Two graphical objects are obtained, one corresponding to row labeling and the second to the table of |
|
672 |
#' numbers of patients at risk. If `title = TRUE`, a third object corresponding to the table title is |
|
673 |
#' also obtained. |
|
674 |
#' |
|
675 |
#' @inheritParams g_km |
|
676 |
#' @inheritParams h_ggkm |
|
677 |
#' @param annot_tbl (`data.frame`)\cr annotation as prepared by [survival::summary.survfit()] which |
|
678 |
#' includes the number of patients at risk at given time points. |
|
679 |
#' @param xlim (`numeric(1)`)\cr the maximum value on the x-axis (used to ensure the at risk table aligns with the KM |
|
680 |
#' graph). |
|
681 |
#' @param title (`flag`)\cr whether the "Patients at Risk" title should be added above the `annot_at_risk` |
|
682 |
#' table. Has no effect if `annot_at_risk` is `FALSE`. Defaults to `TRUE`. |
|
683 |
#' |
|
684 |
#' @return A named `list` of two `gTree` objects if `title = FALSE`: `at_risk` and `label`, or three |
|
685 |
#' `gTree` objects if `title = TRUE`: `at_risk`, `label`, and `title`. |
|
686 |
#' |
|
687 |
#' @examples |
|
688 |
#' \donttest{ |
|
689 |
#' library(dplyr) |
|
690 |
#' library(survival) |
|
691 |
#' library(grid) |
|
692 |
#' |
|
693 |
#' fit_km <- tern_ex_adtte %>% |
|
694 |
#' filter(PARAMCD == "OS") %>% |
|
695 |
#' survfit(formula = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) |
|
696 |
#' |
|
697 |
#' data_plot <- h_data_plot(fit_km = fit_km) |
|
698 |
#' |
|
699 |
#' xticks <- h_xticks(data = data_plot) |
|
700 |
#' |
|
701 |
#' gg <- h_ggkm( |
|
702 |
#' data = data_plot, |
|
703 |
#' censor_show = TRUE, |
|
704 |
#' xticks = xticks, xlab = "Days", ylab = "Survival Probability", |
|
705 |
#' title = "tt", footnotes = "ff", yval = "Survival" |
|
706 |
#' ) |
|
707 |
#' |
|
708 |
#' # The annotation table reports the patient at risk for a given strata and |
|
709 |
#' # times (`xticks`). |
|
710 |
#' annot_tbl <- summary(fit_km, times = xticks) |
|
711 |
#' if (is.null(fit_km$strata)) { |
|
712 |
#' annot_tbl <- with(annot_tbl, data.frame(n.risk = n.risk, time = time, strata = "All")) |
|
713 |
#' } else { |
|
714 |
#' strata_lst <- strsplit(sub("=", "equals", levels(annot_tbl$strata)), "equals") |
|
715 |
#' levels(annot_tbl$strata) <- matrix(unlist(strata_lst), ncol = 2, byrow = TRUE)[, 2] |
|
716 |
#' annot_tbl <- data.frame( |
|
717 |
#' n.risk = annot_tbl$n.risk, |
|
718 |
#' time = annot_tbl$time, |
|
719 |
#' strata = annot_tbl$strata |
|
720 |
#' ) |
|
721 |
#' } |
|
722 |
#' |
|
723 |
#' # The annotation table is transformed into a grob. |
|
724 |
#' tbl <- h_grob_tbl_at_risk(data = data_plot, annot_tbl = annot_tbl, xlim = max(xticks)) |
|
725 |
#' |
|
726 |
#' # For the representation, the layout is estimated for which the decomposition |
|
727 |
#' # of the graphic element is necessary. |
|
728 |
#' g_el <- h_decompose_gg(gg) |
|
729 |
#' lyt <- h_km_layout(data = data_plot, g_el = g_el, title = "t", footnotes = "f") |
|
730 |
#' |
|
731 |
#' grid::grid.newpage() |
|
732 |
#' pushViewport(viewport(layout = lyt, height = .95, width = .95)) |
|
733 |
#' grid.rect(gp = grid::gpar(lty = 1, col = "purple", fill = "gray85", lwd = 1)) |
|
734 |
#' pushViewport(viewport(layout.pos.row = 3:4, layout.pos.col = 2)) |
|
735 |
#' grid.rect(gp = grid::gpar(lty = 1, col = "orange", fill = "gray85", lwd = 1)) |
|
736 |
#' grid::grid.draw(tbl$at_risk) |
|
737 |
#' popViewport() |
|
738 |
#' pushViewport(viewport(layout.pos.row = 3:4, layout.pos.col = 1)) |
|
739 |
#' grid.rect(gp = grid::gpar(lty = 1, col = "green3", fill = "gray85", lwd = 1)) |
|
740 |
#' grid::grid.draw(tbl$label) |
|
741 |
#' } |
|
742 |
#' |
|
743 |
#' @export |
|
744 |
h_grob_tbl_at_risk <- function(data, annot_tbl, xlim, title = TRUE) { |
|
745 | 1x |
lifecycle::deprecate_warn( |
746 | 1x |
"0.9.4", |
747 | 1x |
"h_grob_tbl_at_risk()", |
748 | 1x |
details = "`g_km` now generates `ggplot` objects. This function is no longer used within `tern`." |
749 |
) |
|
750 | 1x |
txtlines <- levels(as.factor(data$strata)) |
751 | 1x |
nlines <- nlevels(as.factor(data$strata)) |
752 | 1x |
y_int <- annot_tbl$time[2] - annot_tbl$time[1] |
753 | 1x |
annot_tbl <- expand.grid( |
754 | 1x |
time = seq(0, xlim, y_int), |
755 | 1x |
strata = unique(annot_tbl$strata) |
756 | 1x |
) %>% dplyr::left_join(annot_tbl, by = c("time", "strata")) |
757 | 1x |
annot_tbl[is.na(annot_tbl)] <- 0 |
758 | 1x |
y_str_unit <- as.numeric(annot_tbl$strata) |
759 | 1x |
vp_table <- grid::plotViewport(margins = grid::unit(c(0, 0, 0, 0), "lines")) |
760 | 1x |
if (title) { |
761 | 1x |
gb_table_title <- grid::gList( |
762 | 1x |
grid::textGrob( |
763 | 1x |
label = "Patients at Risk:", |
764 | 1x |
x = 1, |
765 | 1x |
y = grid::unit(0.2, "native"), |
766 | 1x |
gp = grid::gpar(fontface = "bold", fontsize = 10) |
767 |
) |
|
768 |
) |
|
769 |
} |
|
770 | 1x |
gb_table_left_annot <- grid::gList( |
771 | 1x |
grid::rectGrob( |
772 | 1x |
x = 0, y = grid::unit(c(1:nlines) - 1, "lines"), |
773 | 1x |
gp = grid::gpar(fill = c("gray95", "gray90"), alpha = 1, col = "white"), |
774 | 1x |
height = grid::unit(1, "lines"), just = "bottom", hjust = 0 |
775 |
), |
|
776 | 1x |
grid::textGrob( |
777 | 1x |
label = unique(annot_tbl$strata), |
778 | 1x |
x = 0.5, |
779 | 1x |
y = grid::unit( |
780 | 1x |
(max(unique(y_str_unit)) - unique(y_str_unit)) + 0.75, |
781 | 1x |
"native" |
782 |
), |
|
783 | 1x |
gp = grid::gpar(fontface = "italic", fontsize = 10) |
784 |
) |
|
785 |
) |
|
786 | 1x |
gb_patient_at_risk <- grid::gList( |
787 | 1x |
grid::rectGrob( |
788 | 1x |
x = 0, y = grid::unit(c(1:nlines) - 1, "lines"), |
789 | 1x |
gp = grid::gpar(fill = c("gray95", "gray90"), alpha = 1, col = "white"), |
790 | 1x |
height = grid::unit(1, "lines"), just = "bottom", hjust = 0 |
791 |
), |
|
792 | 1x |
grid::textGrob( |
793 | 1x |
label = annot_tbl$n.risk, |
794 | 1x |
x = grid::unit(annot_tbl$time, "native"), |
795 | 1x |
y = grid::unit( |
796 | 1x |
(max(y_str_unit) - y_str_unit) + .5, |
797 | 1x |
"line" |
798 | 1x |
) # maybe native |
799 |
) |
|
800 |
) |
|
801 | ||
802 | 1x |
ret <- list( |
803 | 1x |
at_risk = grid::gList( |
804 | 1x |
grid::gTree( |
805 | 1x |
vp = vp_table, |
806 | 1x |
children = grid::gList( |
807 | 1x |
grid::gTree( |
808 | 1x |
vp = grid::dataViewport( |
809 | 1x |
xscale = c(0, xlim) + c(-0.05, 0.05) * xlim, |
810 | 1x |
yscale = c(0, nlines + 1), |
811 | 1x |
extension = c(0.05, 0) |
812 |
), |
|
813 | 1x |
children = grid::gList(gb_patient_at_risk) |
814 |
) |
|
815 |
) |
|
816 |
) |
|
817 |
), |
|
818 | 1x |
label = grid::gList( |
819 | 1x |
grid::gTree( |
820 | 1x |
vp = grid::viewport(width = max(grid::stringWidth(txtlines))), |
821 | 1x |
children = grid::gList( |
822 | 1x |
grid::gTree( |
823 | 1x |
vp = grid::dataViewport( |
824 | 1x |
xscale = 0:1, |
825 | 1x |
yscale = c(0, nlines + 1), |
826 | 1x |
extension = c(0.0, 0) |
827 |
), |
|
828 | 1x |
children = grid::gList(gb_table_left_annot) |
829 |
) |
|
830 |
) |
|
831 |
) |
|
832 |
) |
|
833 |
) |
|
834 | ||
835 | 1x |
if (title) { |
836 | 1x |
ret[["title"]] <- grid::gList( |
837 | 1x |
grid::gTree( |
838 | 1x |
vp = grid::viewport(width = max(grid::stringWidth(txtlines))), |
839 | 1x |
children = grid::gList( |
840 | 1x |
grid::gTree( |
841 | 1x |
vp = grid::dataViewport( |
842 | 1x |
xscale = 0:1, |
843 | 1x |
yscale = c(0, 1), |
844 | 1x |
extension = c(0, 0) |
845 |
), |
|
846 | 1x |
children = grid::gList(gb_table_title) |
847 |
) |
|
848 |
) |
|
849 |
) |
|
850 |
) |
|
851 |
} |
|
852 | ||
853 | 1x |
ret |
854 |
} |
|
855 | ||
856 |
#' Helper function to create survival estimation grobs |
|
857 |
#' |
|
858 |
#' @description `r lifecycle::badge("deprecated")` |
|
859 |
#' |
|
860 |
#' The survival fit is transformed in a grob containing a table with groups in |
|
861 |
#' rows characterized by N, median and 95% confidence interval. |
|
862 |
#' |
|
863 |
#' @inheritParams g_km |
|
864 |
#' @inheritParams h_data_plot |
|
865 |
#' @param ttheme (`list`)\cr see [gridExtra::ttheme_default()]. |
|
866 |
#' @param x (`proportion`)\cr a value between 0 and 1 specifying x-location. |
|
867 |
#' @param y (`proportion`)\cr a value between 0 and 1 specifying y-location. |
|
868 |
#' @param width (`grid::unit`)\cr width (as a unit) to use when printing the grob. |
|
869 |
#' |
|
870 |
#' @return A `grob` of a table containing statistics `N`, `Median`, and `XX% CI` (`XX` taken from `fit_km`). |
|
871 |
#' |
|
872 |
#' @examples |
|
873 |
#' \donttest{ |
|
874 |
#' library(dplyr) |
|
875 |
#' library(survival) |
|
876 |
#' library(grid) |
|
877 |
#' |
|
878 |
#' grid::grid.newpage() |
|
879 |
#' grid.rect(gp = grid::gpar(lty = 1, col = "pink", fill = "gray85", lwd = 1)) |
|
880 |
#' tern_ex_adtte %>% |
|
881 |
#' filter(PARAMCD == "OS") %>% |
|
882 |
#' survfit(formula = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) %>% |
|
883 |
#' h_grob_median_surv() %>% |
|
884 |
#' grid::grid.draw() |
|
885 |
#' } |
|
886 |
#' |
|
887 |
#' @export |
|
888 |
h_grob_median_surv <- function(fit_km, |
|
889 |
armval = "All", |
|
890 |
x = 0.9, |
|
891 |
y = 0.9, |
|
892 |
width = grid::unit(0.3, "npc"), |
|
893 |
ttheme = gridExtra::ttheme_default()) { |
|
894 | 1x |
lifecycle::deprecate_warn( |
895 | 1x |
"0.9.4", |
896 | 1x |
"h_grob_median_surv()", |
897 | 1x |
details = "`g_km` now generates `ggplot` objects. This function is no longer used within `tern`." |
898 |
) |
|
899 | 1x |
data <- h_tbl_median_surv(fit_km, armval = armval) |
900 | ||
901 | 1x |
width <- grid::convertUnit(grid::unit(as.numeric(width), grid::unitType(width)), "in") |
902 | 1x |
height <- width * (nrow(data) + 1) / 12 |
903 | ||
904 | 1x |
w <- paste(" ", c( |
905 | 1x |
rownames(data)[which.max(nchar(rownames(data)))], |
906 | 1x |
sapply(names(data), function(x) c(x, data[[x]])[which.max(nchar(c(x, data[[x]])))]) |
907 |
)) |
|
908 | 1x |
w_unit <- grid::convertWidth(grid::stringWidth(w), "in", valueOnly = TRUE) |
909 | ||
910 | 1x |
w_txt <- sapply(1:64, function(x) { |
911 | 64x |
graphics::par(ps = x) |
912 | 64x |
graphics::strwidth(w[4], units = "in") |
913 |
}) |
|
914 | 1x |
f_size_w <- which.max(w_txt[w_txt < as.numeric((w_unit / sum(w_unit)) * width)[4]]) |
915 | ||
916 | 1x |
h_txt <- sapply(1:64, function(x) { |
917 | 64x |
graphics::par(ps = x) |
918 | 64x |
graphics::strheight(grid::stringHeight("X"), units = "in") |
919 |
}) |
|
920 | 1x |
f_size_h <- which.max(h_txt[h_txt < as.numeric(grid::unit(as.numeric(height) / 4, grid::unitType(height)))]) |
921 | ||
922 | 1x |
if (ttheme$core$fg_params$fontsize == 12) { |
923 | 1x |
ttheme$core$fg_params$fontsize <- min(f_size_w, f_size_h) |
924 | 1x |
ttheme$colhead$fg_params$fontsize <- min(f_size_w, f_size_h) |
925 | 1x |
ttheme$rowhead$fg_params$fontsize <- min(f_size_w, f_size_h) |
926 |
} |
|
927 | ||
928 | 1x |
gt <- gridExtra::tableGrob( |
929 | 1x |
d = data, |
930 | 1x |
theme = ttheme |
931 |
) |
|
932 | 1x |
gt$widths <- ((w_unit / sum(w_unit)) * width) |
933 | 1x |
gt$heights <- rep(grid::unit(as.numeric(height) / 4, grid::unitType(height)), nrow(gt)) |
934 | ||
935 | 1x |
vp <- grid::viewport( |
936 | 1x |
x = grid::unit(x, "npc") + grid::unit(1, "lines"), |
937 | 1x |
y = grid::unit(y, "npc") + grid::unit(1.5, "lines"), |
938 | 1x |
height = height, |
939 | 1x |
width = width, |
940 | 1x |
just = c("right", "top") |
941 |
) |
|
942 | ||
943 | 1x |
grid::gList( |
944 | 1x |
grid::gTree( |
945 | 1x |
vp = vp, |
946 | 1x |
children = grid::gList(gt) |
947 |
) |
|
948 |
) |
|
949 |
} |
|
950 | ||
951 |
#' Helper function to create grid object with y-axis annotation |
|
952 |
#' |
|
953 |
#' @description `r lifecycle::badge("deprecated")` |
|
954 |
#' |
|
955 |
#' Build the y-axis annotation from a decomposed `ggplot`. |
|
956 |
#' |
|
957 |
#' @param ylab (`gtable`)\cr the y-lab as a graphical object derived from a `ggplot`. |
|
958 |
#' @param yaxis (`gtable`)\cr the y-axis as a graphical object derived from a `ggplot`. |
|
959 |
#' |
|
960 |
#' @return A `gTree` object containing the y-axis annotation from a `ggplot`. |
|
961 |
#' |
|
962 |
#' @examples |
|
963 |
#' \donttest{ |
|
964 |
#' library(dplyr) |
|
965 |
#' library(survival) |
|
966 |
#' library(grid) |
|
967 |
#' |
|
968 |
#' fit_km <- tern_ex_adtte %>% |
|
969 |
#' filter(PARAMCD == "OS") %>% |
|
970 |
#' survfit(formula = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) |
|
971 |
#' data_plot <- h_data_plot(fit_km = fit_km) |
|
972 |
#' xticks <- h_xticks(data = data_plot) |
|
973 |
#' gg <- h_ggkm( |
|
974 |
#' data = data_plot, |
|
975 |
#' censor_show = TRUE, |
|
976 |
#' xticks = xticks, xlab = "Days", ylab = "Survival Probability", |
|
977 |
#' title = "title", footnotes = "footnotes", yval = "Survival" |
|
978 |
#' ) |
|
979 |
#' |
|
980 |
#' g_el <- h_decompose_gg(gg) |
|
981 |
#' |
|
982 |
#' grid::grid.newpage() |
|
983 |
#' pvp <- grid::plotViewport(margins = c(5, 4, 2, 20)) |
|
984 |
#' pushViewport(pvp) |
|
985 |
#' grid::grid.draw(h_grob_y_annot(ylab = g_el$ylab, yaxis = g_el$yaxis)) |
|
986 |
#' grid.rect(gp = grid::gpar(lty = 1, col = "gray35", fill = NA)) |
|
987 |
#' } |
|
988 |
#' |
|
989 |
#' @export |
|
990 |
h_grob_y_annot <- function(ylab, yaxis) { |
|
991 | 1x |
lifecycle::deprecate_warn( |
992 | 1x |
"0.9.4", |
993 | 1x |
"h_grob_y_annot()", |
994 | 1x |
details = "`g_km` now generates `ggplot` objects. This function is no longer used within `tern`." |
995 |
) |
|
996 | 1x |
grid::gList( |
997 | 1x |
grid::gTree( |
998 | 1x |
vp = grid::viewport( |
999 | 1x |
width = grid::convertX(yaxis$widths + ylab$widths, "pt"), |
1000 | 1x |
x = grid::unit(1, "npc"), |
1001 | 1x |
just = "right" |
1002 |
), |
|
1003 | 1x |
children = grid::gList(cbind(ylab, yaxis)) |
1004 |
) |
|
1005 |
) |
|
1006 |
} |
|
1007 | ||
1008 |
#' Helper function to create Cox-PH grobs |
|
1009 |
#' |
|
1010 |
#' @description `r lifecycle::badge("deprecated")` |
|
1011 |
#' |
|
1012 |
#' Grob of `rtable` output from [h_tbl_coxph_pairwise()] |
|
1013 |
#' |
|
1014 |
#' @inheritParams h_grob_median_surv |
|
1015 |
#' @param ... arguments to pass to [h_tbl_coxph_pairwise()]. |
|
1016 |
#' @param x (`proportion`)\cr a value between 0 and 1 specifying x-location. |
|
1017 |
#' @param y (`proportion`)\cr a value between 0 and 1 specifying y-location. |
|
1018 |
#' @param width (`grid::unit`)\cr width (as a unit) to use when printing the grob. |
|
1019 |
#' |
|
1020 |
#' @return A `grob` of a table containing statistics `HR`, `XX% CI` (`XX` taken from `control_coxph_pw`), |
|
1021 |
#' and `p-value (log-rank)`. |
|
1022 |
#' |
|
1023 |
#' @examples |
|
1024 |
#' \donttest{ |
|
1025 |
#' library(dplyr) |
|
1026 |
#' library(survival) |
|
1027 |
#' library(grid) |
|
1028 |
#' |
|
1029 |
#' grid::grid.newpage() |
|
1030 |
#' grid.rect(gp = grid::gpar(lty = 1, col = "pink", fill = "gray85", lwd = 1)) |
|
1031 |
#' data <- tern_ex_adtte %>% |
|
1032 |
#' filter(PARAMCD == "OS") %>% |
|
1033 |
#' mutate(is_event = CNSR == 0) |
|
1034 |
#' tbl_grob <- h_grob_coxph( |
|
1035 |
#' df = data, |
|
1036 |
#' variables = list(tte = "AVAL", is_event = "is_event", arm = "ARMCD"), |
|
1037 |
#' control_coxph_pw = control_coxph(conf_level = 0.9), x = 0.5, y = 0.5 |
|
1038 |
#' ) |
|
1039 |
#' grid::grid.draw(tbl_grob) |
|
1040 |
#' } |
|
1041 |
#' |
|
1042 |
#' @export |
|
1043 |
h_grob_coxph <- function(..., |
|
1044 |
x = 0, |
|
1045 |
y = 0, |
|
1046 |
width = grid::unit(0.4, "npc"), |
|
1047 |
ttheme = gridExtra::ttheme_default( |
|
1048 |
padding = grid::unit(c(1, .5), "lines"), |
|
1049 |
core = list(bg_params = list(fill = c("grey95", "grey90"), alpha = .5)) |
|
1050 |
)) { |
|
1051 | 1x |
lifecycle::deprecate_warn( |
1052 | 1x |
"0.9.4", |
1053 | 1x |
"h_grob_coxph()", |
1054 | 1x |
details = "`g_km` now generates `ggplot` objects. This function is no longer used within `tern`." |
1055 |
) |
|
1056 | 1x |
data <- h_tbl_coxph_pairwise(...) |
1057 | ||
1058 | 1x |
width <- grid::convertUnit(grid::unit(as.numeric(width), grid::unitType(width)), "in") |
1059 | 1x |
height <- width * (nrow(data) + 1) / 12 |
1060 | ||
1061 | 1x |
w <- paste(" ", c( |
1062 | 1x |
rownames(data)[which.max(nchar(rownames(data)))], |
1063 | 1x |
sapply(names(data), function(x) c(x, data[[x]])[which.max(nchar(c(x, data[[x]])))]) |
1064 |
)) |
|
1065 | 1x |
w_unit <- grid::convertWidth(grid::stringWidth(w), "in", valueOnly = TRUE) |
1066 | ||
1067 | 1x |
w_txt <- sapply(1:64, function(x) { |
1068 | 64x |
graphics::par(ps = x) |
1069 | 64x |
graphics::strwidth(w[4], units = "in") |
1070 |
}) |
|
1071 | 1x |
f_size_w <- which.max(w_txt[w_txt < as.numeric((w_unit / sum(w_unit)) * width)[4]]) |
1072 | ||
1073 | 1x |
h_txt <- sapply(1:64, function(x) { |
1074 | 64x |
graphics::par(ps = x) |
1075 | 64x |
graphics::strheight(grid::stringHeight("X"), units = "in") |
1076 |
}) |
|
1077 | 1x |
f_size_h <- which.max(h_txt[h_txt < as.numeric(grid::unit(as.numeric(height) / 4, grid::unitType(height)))]) |
1078 | ||
1079 | 1x |
if (ttheme$core$fg_params$fontsize == 12) { |
1080 | 1x |
ttheme$core$fg_params$fontsize <- min(f_size_w, f_size_h) |
1081 | 1x |
ttheme$colhead$fg_params$fontsize <- min(f_size_w, f_size_h) |
1082 | 1x |
ttheme$rowhead$fg_params$fontsize <- min(f_size_w, f_size_h) |
1083 |
} |
|
1084 | ||
1085 | 1x |
tryCatch( |
1086 | 1x |
expr = { |
1087 | 1x |
gt <- gridExtra::tableGrob( |
1088 | 1x |
d = data, |
1089 | 1x |
theme = ttheme |
1090 | 1x |
) # ERROR 'data' must be of a vector type, was 'NULL' |
1091 | 1x |
gt$widths <- ((w_unit / sum(w_unit)) * width) |
1092 | 1x |
gt$heights <- rep(grid::unit(as.numeric(height) / 4, grid::unitType(height)), nrow(gt)) |
1093 | 1x |
vp <- grid::viewport( |
1094 | 1x |
x = grid::unit(x, "npc") + grid::unit(1, "lines"), |
1095 | 1x |
y = grid::unit(y, "npc") + grid::unit(1.5, "lines"), |
1096 | 1x |
height = height, |
1097 | 1x |
width = width, |
1098 | 1x |
just = c("left", "bottom") |
1099 |
) |
|
1100 | 1x |
grid::gList( |
1101 | 1x |
grid::gTree( |
1102 | 1x |
vp = vp, |
1103 | 1x |
children = grid::gList(gt) |
1104 |
) |
|
1105 |
) |
|
1106 |
}, |
|
1107 | 1x |
error = function(w) { |
1108 | ! |
message(paste( |
1109 | ! |
"Warning: Cox table will not be displayed as there is", |
1110 | ! |
"not any level to be compared in the arm variable." |
1111 |
)) |
|
1112 | ! |
return( |
1113 | ! |
grid::gList( |
1114 | ! |
grid::gTree( |
1115 | ! |
vp = NULL, |
1116 | ! |
children = NULL |
1117 |
) |
|
1118 |
) |
|
1119 |
) |
|
1120 |
} |
|
1121 |
) |
|
1122 |
} |
1 |
#' Split function to configure risk difference column |
|
2 |
#' |
|
3 |
#' @description `r lifecycle::badge("stable")` |
|
4 |
#' |
|
5 |
#' Wrapper function for [rtables::add_combo_levels()] which configures settings for the risk difference |
|
6 |
#' column to be added to an `rtables` object. To add a risk difference column to a table, this function |
|
7 |
#' should be used as `split_fun` in calls to [rtables::split_cols_by()], followed by setting argument |
|
8 |
#' `riskdiff` to `TRUE` in all following analyze function calls. |
|
9 |
#' |
|
10 |
#' @param arm_x (`string`)\cr name of reference arm to use in risk difference calculations. |
|
11 |
#' @param arm_y (`character`)\cr names of one or more arms to compare to reference arm in risk difference |
|
12 |
#' calculations. A new column will be added for each value of `arm_y`. |
|
13 |
#' @param col_label (`character`)\cr labels to use when rendering the risk difference column within the table. |
|
14 |
#' If more than one comparison arm is specified in `arm_y`, default labels will specify which two arms are |
|
15 |
#' being compared (reference arm vs. comparison arm). |
|
16 |
#' @param pct (`flag`)\cr whether output should be returned as percentages. Defaults to `TRUE`. |
|
17 |
#' |
|
18 |
#' @return A closure suitable for use as a split function (`split_fun`) within [rtables::split_cols_by()] |
|
19 |
#' when creating a table layout. |
|
20 |
#' |
|
21 |
#' @seealso [stat_propdiff_ci()] for details on risk difference calculation. |
|
22 |
#' |
|
23 |
#' @examples |
|
24 |
#' adae <- tern_ex_adae |
|
25 |
#' adae$AESEV <- factor(adae$AESEV) |
|
26 |
#' |
|
27 |
#' lyt <- basic_table() %>% |
|
28 |
#' split_cols_by("ARMCD", split_fun = add_riskdiff(arm_x = "ARM A", arm_y = c("ARM B", "ARM C"))) %>% |
|
29 |
#' count_occurrences_by_grade( |
|
30 |
#' var = "AESEV", |
|
31 |
#' riskdiff = TRUE |
|
32 |
#' ) |
|
33 |
#' |
|
34 |
#' tbl <- build_table(lyt, df = adae) |
|
35 |
#' tbl |
|
36 |
#' |
|
37 |
#' @export |
|
38 |
add_riskdiff <- function(arm_x, |
|
39 |
arm_y, |
|
40 |
col_label = paste0( |
|
41 |
"Risk Difference (%) (95% CI)", if (length(arm_y) > 1) paste0("\n", arm_x, " vs. ", arm_y) |
|
42 |
), |
|
43 |
pct = TRUE) { |
|
44 | 19x |
checkmate::assert_character(arm_x, len = 1) |
45 | 19x |
checkmate::assert_character(arm_y, min.len = 1) |
46 | 19x |
checkmate::assert_character(col_label, len = length(arm_y)) |
47 | ||
48 | 19x |
combodf <- tibble::tribble(~valname, ~label, ~levelcombo, ~exargs) |
49 | 19x |
for (i in seq_len(length(arm_y))) { |
50 | 20x |
combodf <- rbind( |
51 | 20x |
combodf, |
52 | 20x |
tibble::tribble( |
53 | 20x |
~valname, ~label, ~levelcombo, ~exargs, |
54 | 20x |
paste("riskdiff", arm_x, arm_y[i], sep = "_"), col_label[i], c(arm_x, arm_y[i]), list() |
55 |
) |
|
56 |
) |
|
57 |
} |
|
58 | 19x |
if (pct) combodf$valname <- paste0(combodf$valname, "_pct") |
59 | 19x |
add_combo_levels(combodf) |
60 |
} |
|
61 | ||
62 |
#' Analysis function to calculate risk difference column values |
|
63 |
#' |
|
64 |
#' In the risk difference column, this function uses the statistics function associated with `afun` to |
|
65 |
#' calculates risk difference values from arm X (reference group) and arm Y. These arms are specified |
|
66 |
#' when configuring the risk difference column which is done using the [add_riskdiff()] split function in |
|
67 |
#' the previous call to [rtables::split_cols_by()]. For all other columns, applies `afun` as usual. This |
|
68 |
#' function utilizes the [stat_propdiff_ci()] function to perform risk difference calculations. |
|
69 |
#' |
|
70 |
#' @inheritParams argument_convention |
|
71 |
#' @param afun (named `list`)\cr a named list containing one name-value pair where the name corresponds to |
|
72 |
#' the name of the statistics function that should be used in calculations and the value is the corresponding |
|
73 |
#' analysis function. |
|
74 |
#' |
|
75 |
#' @return A list of formatted [rtables::CellValue()]. |
|
76 |
#' |
|
77 |
#' @seealso |
|
78 |
#' * [stat_propdiff_ci()] for details on risk difference calculation. |
|
79 |
#' * Split function [add_riskdiff()] which, when used as `split_fun` within [rtables::split_cols_by()] with |
|
80 |
#' `riskdiff` argument set to `TRUE` in subsequent analyze functions calls, adds a risk difference column |
|
81 |
#' to a table layout. |
|
82 |
#' |
|
83 |
#' @keywords internal |
|
84 |
afun_riskdiff <- function(df, |
|
85 |
labelstr = "", |
|
86 |
afun, |
|
87 |
..., |
|
88 |
.stats = NULL, |
|
89 |
.stat_names = NULL, |
|
90 |
.formats = NULL, |
|
91 |
.labels = NULL, |
|
92 |
.indent_mods = NULL) { |
|
93 | 146x |
if (!any(grepl("riskdiff", names(.spl_context)))) { |
94 | ! |
stop( |
95 | ! |
"Please set up levels to use in risk difference calculations using the `add_riskdiff` ", |
96 | ! |
"split function within `split_cols_by`. See ?add_riskdiff for details." |
97 |
) |
|
98 |
} |
|
99 | 146x |
checkmate::assert_list(afun, len = 1, types = "function") |
100 | 146x |
checkmate::assert_named(afun) |
101 | ||
102 | 146x |
sfun <- names(afun) |
103 | 146x |
dots_extra_args <- list(...)[intersect(names(list(...)), names(formals(sfun)))] |
104 | 146x |
extra_args <- list( |
105 | 146x |
.var = .var, .df_row = .df_row, .N_col = .N_col, .N_row = .N_row, .stats = .stats, .formats = .formats, |
106 | 146x |
.labels = .labels, .indent_mods = .indent_mods |
107 |
) |
|
108 | 146x |
cur_split <- tail(.spl_context$cur_col_split_val[[1]], 1) |
109 | ||
110 | 146x |
if (!grepl("^riskdiff", cur_split)) { |
111 |
# Apply basic afun (no risk difference) in all other columns |
|
112 | 108x |
do.call(afun[[1]], args = c(list(df = df, labelstr = labelstr), extra_args, dots_extra_args)) |
113 |
} else { |
|
114 | 38x |
arm_x <- strsplit(cur_split, "_")[[1]][2] |
115 | 38x |
arm_y <- strsplit(cur_split, "_")[[1]][3] |
116 | 38x |
if (length(.spl_context$cur_col_split[[1]]) > 1) { # Different split name for nested column splits |
117 | 8x |
arm_spl_x <- gsub("riskdiff", "", paste0(strsplit(.spl_context$cur_col_id[1], "_")[[1]][c(1, 2)], collapse = "")) |
118 | 8x |
arm_spl_y <- gsub("riskdiff", "", paste0(strsplit(.spl_context$cur_col_id[1], "_")[[1]][c(1, 3)], collapse = "")) |
119 |
} else { |
|
120 | 30x |
arm_spl_x <- arm_x |
121 | 30x |
arm_spl_y <- arm_y |
122 |
} |
|
123 | 38x |
N_col_x <- .all_col_counts[[arm_spl_x]] # nolint |
124 | 38x |
N_col_y <- .all_col_counts[[arm_spl_y]] # nolint |
125 | 38x |
cur_var <- tail(.spl_context$cur_col_split[[1]], 1) |
126 | ||
127 |
# Apply statistics function to arm X and arm Y data |
|
128 | 38x |
s_args <- c(dots_extra_args, extra_args[intersect(setdiff(names(extra_args), ".N_col"), names(formals(sfun)))]) |
129 | 38x |
s_x <- do.call(sfun, args = c(list(df = df[df[[cur_var]] == arm_x, ], .N_col = N_col_x), s_args)) |
130 | 38x |
s_y <- do.call(sfun, args = c(list(df = df[df[[cur_var]] == arm_y, ], .N_col = N_col_y), s_args)) |
131 | ||
132 |
# Get statistic name and row names |
|
133 | 38x |
stat <- ifelse("count_fraction" %in% names(s_x), "count_fraction", "unique") |
134 | 38x |
if ("flag_variables" %in% names(s_args)) { |
135 | 2x |
var_nms <- s_args$flag_variables |
136 | 36x |
} else if (is.list(s_x[[stat]]) && !is.null(names(s_x[[stat]]))) { |
137 | 24x |
var_nms <- names(s_x[[stat]]) |
138 |
} else { |
|
139 | 12x |
var_nms <- "" |
140 | 12x |
s_x[[stat]] <- list(s_x[[stat]]) |
141 | 12x |
s_y[[stat]] <- list(s_y[[stat]]) |
142 |
} |
|
143 | ||
144 |
# Calculate risk difference for each row, repeated if multiple statistics in table |
|
145 | 38x |
pct <- tail(strsplit(cur_split, "_")[[1]], 1) == "pct" |
146 | 38x |
rd_ci <- rep(stat_propdiff_ci( |
147 | 38x |
lapply(s_x[[stat]], `[`, 1), lapply(s_y[[stat]], `[`, 1), |
148 | 38x |
N_col_x, N_col_y, |
149 | 38x |
list_names = var_nms, |
150 | 38x |
pct = pct |
151 | 38x |
), max(1, length(.stats))) |
152 | ||
153 | 38x |
in_rows(.list = rd_ci, .formats = "xx.x (xx.x - xx.x)", .indent_mods = .indent_mods) |
154 |
} |
|
155 |
} |
|
156 | ||
157 |
#' Control function for risk difference column |
|
158 |
#' |
|
159 |
#' @description `r lifecycle::badge("stable")` |
|
160 |
#' |
|
161 |
#' Sets a list of parameters to use when generating a risk (proportion) difference column. Used as input to the |
|
162 |
#' `riskdiff` parameter of [tabulate_rsp_subgroups()] and [tabulate_survival_subgroups()]. |
|
163 |
#' |
|
164 |
#' @inheritParams add_riskdiff |
|
165 |
#' @param format (`string` or `function`)\cr the format label (string) or formatting function to apply to the risk |
|
166 |
#' difference statistic. See the `3d` string options in [formatters::list_valid_format_labels()] for possible format |
|
167 |
#' strings. Defaults to `"xx.x (xx.x - xx.x)"`. |
|
168 |
#' |
|
169 |
#' @return A `list` of items with names corresponding to the arguments. |
|
170 |
#' |
|
171 |
#' @seealso [add_riskdiff()], [tabulate_rsp_subgroups()], and [tabulate_survival_subgroups()]. |
|
172 |
#' |
|
173 |
#' @examples |
|
174 |
#' control_riskdiff() |
|
175 |
#' control_riskdiff(arm_x = "ARM A", arm_y = "ARM B") |
|
176 |
#' |
|
177 |
#' @export |
|
178 |
control_riskdiff <- function(arm_x = NULL, |
|
179 |
arm_y = NULL, |
|
180 |
format = "xx.x (xx.x - xx.x)", |
|
181 |
col_label = "Risk Difference (%) (95% CI)", |
|
182 |
pct = TRUE) { |
|
183 | 4x |
checkmate::assert_character(arm_x, len = 1, null.ok = TRUE) |
184 | 4x |
checkmate::assert_character(arm_y, min.len = 1, null.ok = TRUE) |
185 | 4x |
checkmate::assert_character(format, len = 1) |
186 | 4x |
checkmate::assert_character(col_label) |
187 | 4x |
checkmate::assert_flag(pct) |
188 | ||
189 | 4x |
list(arm_x = arm_x, arm_y = arm_y, format = format, col_label = col_label, pct = pct) |
190 |
} |
1 |
#' Cox regression helper function for interactions |
|
2 |
#' |
|
3 |
#' @description `r lifecycle::badge("stable")` |
|
4 |
#' |
|
5 |
#' Test and estimate the effect of a treatment in interaction with a covariate. |
|
6 |
#' The effect is estimated as the HR of the tested treatment for a given level |
|
7 |
#' of the covariate, in comparison to the treatment control. |
|
8 |
#' |
|
9 |
#' @inheritParams argument_convention |
|
10 |
#' @param x (`numeric` or `factor`)\cr the values of the covariate to be tested. |
|
11 |
#' @param effect (`string`)\cr the name of the effect to be tested and estimated. |
|
12 |
#' @param covar (`string`)\cr the name of the covariate in the model. |
|
13 |
#' @param mod (`coxph`)\cr the Cox regression model. |
|
14 |
#' @param label (`string`)\cr the label to be returned as `term_label`. |
|
15 |
#' @param control (`list`)\cr a list of controls as returned by [control_coxreg()]. |
|
16 |
#' @param ... see methods. |
|
17 |
#' |
|
18 |
#' @examples |
|
19 |
#' library(survival) |
|
20 |
#' |
|
21 |
#' set.seed(1, kind = "Mersenne-Twister") |
|
22 |
#' |
|
23 |
#' # Testing dataset [survival::bladder]. |
|
24 |
#' dta_bladder <- with( |
|
25 |
#' data = bladder[bladder$enum < 5, ], |
|
26 |
#' data.frame( |
|
27 |
#' time = stop, |
|
28 |
#' status = event, |
|
29 |
#' armcd = as.factor(rx), |
|
30 |
#' covar1 = as.factor(enum), |
|
31 |
#' covar2 = factor( |
|
32 |
#' sample(as.factor(enum)), |
|
33 |
#' levels = 1:4, |
|
34 |
#' labels = c("F", "F", "M", "M") |
|
35 |
#' ) |
|
36 |
#' ) |
|
37 |
#' ) |
|
38 |
#' labels <- c("armcd" = "ARM", "covar1" = "A Covariate Label", "covar2" = "Sex (F/M)") |
|
39 |
#' formatters::var_labels(dta_bladder)[names(labels)] <- labels |
|
40 |
#' dta_bladder$age <- sample(20:60, size = nrow(dta_bladder), replace = TRUE) |
|
41 |
#' |
|
42 |
#' plot( |
|
43 |
#' survfit(Surv(time, status) ~ armcd + covar1, data = dta_bladder), |
|
44 |
#' lty = 2:4, |
|
45 |
#' xlab = "Months", |
|
46 |
#' col = c("blue1", "blue2", "blue3", "blue4", "red1", "red2", "red3", "red4") |
|
47 |
#' ) |
|
48 |
#' |
|
49 |
#' @name cox_regression_inter |
|
50 |
NULL |
|
51 | ||
52 |
#' @describeIn cox_regression_inter S3 generic helper function to determine interaction effect. |
|
53 |
#' |
|
54 |
#' @return |
|
55 |
#' * `h_coxreg_inter_effect()` returns a `data.frame` of covariate interaction effects consisting of the following |
|
56 |
#' variables: `effect`, `term`, `term_label`, `level`, `n`, `hr`, `lcl`, `ucl`, `pval`, and `pval_inter`. |
|
57 |
#' |
|
58 |
#' @export |
|
59 |
h_coxreg_inter_effect <- function(x, |
|
60 |
effect, |
|
61 |
covar, |
|
62 |
mod, |
|
63 |
label, |
|
64 |
control, |
|
65 |
...) { |
|
66 | 29x |
UseMethod("h_coxreg_inter_effect", x) |
67 |
} |
|
68 | ||
69 |
#' @describeIn cox_regression_inter Method for `numeric` class. Estimates the interaction with a `numeric` covariate. |
|
70 |
#' |
|
71 |
#' @method h_coxreg_inter_effect numeric |
|
72 |
#' |
|
73 |
#' @param at (`list`)\cr a list with items named after the covariate, every |
|
74 |
#' item is a vector of levels at which the interaction should be estimated. |
|
75 |
#' |
|
76 |
#' @export |
|
77 |
h_coxreg_inter_effect.numeric <- function(x, |
|
78 |
effect, |
|
79 |
covar, |
|
80 |
mod, |
|
81 |
label, |
|
82 |
control, |
|
83 |
at, |
|
84 |
...) { |
|
85 | 7x |
betas <- stats::coef(mod) |
86 | 7x |
attrs <- attr(stats::terms(mod), "term.labels") |
87 | 7x |
term_indices <- grep( |
88 | 7x |
pattern = effect, |
89 | 7x |
x = attrs[!grepl("strata\\(", attrs)] |
90 |
) |
|
91 | 7x |
checkmate::assert_vector(term_indices, len = 2) |
92 | 7x |
betas <- betas[term_indices] |
93 | 7x |
betas_var <- diag(stats::vcov(mod))[term_indices] |
94 | 7x |
betas_cov <- stats::vcov(mod)[term_indices[1], term_indices[2]] |
95 | 7x |
xval <- if (is.null(at[[covar]])) { |
96 | 6x |
stats::median(x) |
97 |
} else { |
|
98 | 1x |
at[[covar]] |
99 |
} |
|
100 | 7x |
effect_index <- !grepl(covar, names(betas)) |
101 | 7x |
coef_hat <- betas[effect_index] + xval * betas[!effect_index] |
102 | 7x |
coef_se <- sqrt( |
103 | 7x |
betas_var[effect_index] + |
104 | 7x |
xval ^ 2 * betas_var[!effect_index] + # styler: off |
105 | 7x |
2 * xval * betas_cov |
106 |
) |
|
107 | 7x |
q_norm <- stats::qnorm((1 + control$conf_level) / 2) |
108 | 7x |
data.frame( |
109 | 7x |
effect = "Covariate:", |
110 | 7x |
term = rep(covar, length(xval)), |
111 | 7x |
term_label = paste0(" ", xval), |
112 | 7x |
level = as.character(xval), |
113 | 7x |
n = NA, |
114 | 7x |
hr = exp(coef_hat), |
115 | 7x |
lcl = exp(coef_hat - q_norm * coef_se), |
116 | 7x |
ucl = exp(coef_hat + q_norm * coef_se), |
117 | 7x |
pval = NA, |
118 | 7x |
pval_inter = NA, |
119 | 7x |
stringsAsFactors = FALSE |
120 |
) |
|
121 |
} |
|
122 | ||
123 |
#' @describeIn cox_regression_inter Method for `factor` class. Estimate the interaction with a `factor` covariate. |
|
124 |
#' |
|
125 |
#' @method h_coxreg_inter_effect factor |
|
126 |
#' |
|
127 |
#' @param data (`data.frame`)\cr the data frame on which the model was fit. |
|
128 |
#' |
|
129 |
#' @export |
|
130 |
h_coxreg_inter_effect.factor <- function(x, |
|
131 |
effect, |
|
132 |
covar, |
|
133 |
mod, |
|
134 |
label, |
|
135 |
control, |
|
136 |
data, |
|
137 |
...) { |
|
138 | 17x |
lvl_given <- levels(x) |
139 | 17x |
y <- h_coxreg_inter_estimations( |
140 | 17x |
variable = effect, given = covar, |
141 | 17x |
lvl_var = levels(data[[effect]]), |
142 | 17x |
lvl_given = lvl_given, |
143 | 17x |
mod = mod, |
144 | 17x |
conf_level = 0.95 |
145 | 17x |
)[[1]] |
146 | ||
147 | 17x |
data.frame( |
148 | 17x |
effect = "Covariate:", |
149 | 17x |
term = rep(covar, nrow(y)), |
150 | 17x |
term_label = paste0(" ", lvl_given), |
151 | 17x |
level = lvl_given, |
152 | 17x |
n = NA, |
153 | 17x |
hr = y[, "hr"], |
154 | 17x |
lcl = y[, "lcl"], |
155 | 17x |
ucl = y[, "ucl"], |
156 | 17x |
pval = NA, |
157 | 17x |
pval_inter = NA, |
158 | 17x |
stringsAsFactors = FALSE |
159 |
) |
|
160 |
} |
|
161 | ||
162 |
#' @describeIn cox_regression_inter Method for `character` class. Estimate the interaction with a `character` covariate. |
|
163 |
#' This makes an automatic conversion to `factor` and then forwards to the method for factors. |
|
164 |
#' |
|
165 |
#' @method h_coxreg_inter_effect character |
|
166 |
#' |
|
167 |
#' @note |
|
168 |
#' * Automatic conversion of character to factor does not guarantee results can be generated correctly. It is |
|
169 |
#' therefore better to always pre-process the dataset such that factors are manually created from character |
|
170 |
#' variables before passing the dataset to [rtables::build_table()]. |
|
171 |
#' |
|
172 |
#' @export |
|
173 |
h_coxreg_inter_effect.character <- function(x, |
|
174 |
effect, |
|
175 |
covar, |
|
176 |
mod, |
|
177 |
label, |
|
178 |
control, |
|
179 |
data, |
|
180 |
...) { |
|
181 | 5x |
y <- as.factor(x) |
182 | ||
183 | 5x |
h_coxreg_inter_effect( |
184 | 5x |
x = y, |
185 | 5x |
effect = effect, |
186 | 5x |
covar = covar, |
187 | 5x |
mod = mod, |
188 | 5x |
label = label, |
189 | 5x |
control = control, |
190 | 5x |
data = data, |
191 |
... |
|
192 |
) |
|
193 |
} |
|
194 | ||
195 |
#' @describeIn cox_regression_inter A higher level function to get |
|
196 |
#' the results of the interaction test and the estimated values. |
|
197 |
#' |
|
198 |
#' @return |
|
199 |
#' * `h_coxreg_extract_interaction()` returns the result of an interaction test and the estimated values. If |
|
200 |
#' no interaction, [h_coxreg_univar_extract()] is applied instead. |
|
201 |
#' |
|
202 |
#' @examples |
|
203 |
#' mod <- coxph(Surv(time, status) ~ armcd * covar1, data = dta_bladder) |
|
204 |
#' h_coxreg_extract_interaction( |
|
205 |
#' mod = mod, effect = "armcd", covar = "covar1", data = dta_bladder, |
|
206 |
#' control = control_coxreg() |
|
207 |
#' ) |
|
208 |
#' |
|
209 |
#' @export |
|
210 |
h_coxreg_extract_interaction <- function(effect, |
|
211 |
covar, |
|
212 |
mod, |
|
213 |
data, |
|
214 |
at, |
|
215 |
control) { |
|
216 | 31x |
if (!any(attr(stats::terms(mod), "order") == 2)) { |
217 | 12x |
y <- h_coxreg_univar_extract( |
218 | 12x |
effect = effect, covar = covar, mod = mod, data = data, control = control |
219 |
) |
|
220 | 12x |
y$pval_inter <- NA |
221 | 12x |
y |
222 |
} else { |
|
223 | 19x |
test_statistic <- c(wald = "Wald", likelihood = "LR")[control$pval_method] |
224 | ||
225 |
# Test the main treatment effect. |
|
226 | 19x |
mod_aov <- muffled_car_anova(mod, test_statistic) |
227 | 19x |
sum_anova <- broom::tidy(mod_aov) |
228 | 19x |
pval <- sum_anova[sum_anova$term == effect, ][["p.value"]] |
229 | ||
230 |
# Test the interaction effect. |
|
231 | 19x |
pval_inter <- sum_anova[grep(":", sum_anova$term), ][["p.value"]] |
232 | 19x |
covar_test <- data.frame( |
233 | 19x |
effect = "Covariate:", |
234 | 19x |
term = covar, |
235 | 19x |
term_label = unname(labels_or_names(data[covar])), |
236 | 19x |
level = "", |
237 | 19x |
n = mod$n, hr = NA, lcl = NA, ucl = NA, pval = pval, |
238 | 19x |
pval_inter = pval_inter, |
239 | 19x |
stringsAsFactors = FALSE |
240 |
) |
|
241 |
# Estimate the interaction. |
|
242 | 19x |
y <- h_coxreg_inter_effect( |
243 | 19x |
data[[covar]], |
244 | 19x |
covar = covar, |
245 | 19x |
effect = effect, |
246 | 19x |
mod = mod, |
247 | 19x |
label = unname(labels_or_names(data[covar])), |
248 | 19x |
at = at, |
249 | 19x |
control = control, |
250 | 19x |
data = data |
251 |
) |
|
252 | 19x |
rbind(covar_test, y) |
253 |
} |
|
254 |
} |
|
255 | ||
256 |
#' @describeIn cox_regression_inter Hazard ratio estimation in interactions. |
|
257 |
#' |
|
258 |
#' @param variable,given (`string`)\cr the name of variables in interaction. We seek the estimation |
|
259 |
#' of the levels of `variable` given the levels of `given`. |
|
260 |
#' @param lvl_var,lvl_given (`character`)\cr corresponding levels as given by [levels()]. |
|
261 |
#' @param mod (`coxph`)\cr a fitted Cox regression model (see [survival::coxph()]). |
|
262 |
#' |
|
263 |
#' @details Given the cox regression investigating the effect of Arm (A, B, C; reference A) |
|
264 |
#' and Sex (F, M; reference Female) and the model being abbreviated: y ~ Arm + Sex + Arm:Sex. |
|
265 |
#' The cox regression estimates the coefficients along with a variance-covariance matrix for: |
|
266 |
#' |
|
267 |
#' - b1 (arm b), b2 (arm c) |
|
268 |
#' - b3 (sex m) |
|
269 |
#' - b4 (arm b: sex m), b5 (arm c: sex m) |
|
270 |
#' |
|
271 |
#' The estimation of the Hazard Ratio for arm C/sex M is given in reference |
|
272 |
#' to arm A/Sex M by exp(b2 + b3 + b5)/ exp(b3) = exp(b2 + b5). |
|
273 |
#' The interaction coefficient is deduced by b2 + b5 while the standard error |
|
274 |
#' is obtained as $sqrt(Var b2 + Var b5 + 2 * covariance (b2,b5))$. |
|
275 |
#' |
|
276 |
#' @return |
|
277 |
#' * `h_coxreg_inter_estimations()` returns a list of matrices (one per level of variable) with rows corresponding |
|
278 |
#' to the combinations of `variable` and `given`, with columns: |
|
279 |
#' * `coef_hat`: Estimation of the coefficient. |
|
280 |
#' * `coef_se`: Standard error of the estimation. |
|
281 |
#' * `hr`: Hazard ratio. |
|
282 |
#' * `lcl, ucl`: Lower/upper confidence limit of the hazard ratio. |
|
283 |
#' |
|
284 |
#' @examples |
|
285 |
#' mod <- coxph(Surv(time, status) ~ armcd * covar1, data = dta_bladder) |
|
286 |
#' result <- h_coxreg_inter_estimations( |
|
287 |
#' variable = "armcd", given = "covar1", |
|
288 |
#' lvl_var = levels(dta_bladder$armcd), |
|
289 |
#' lvl_given = levels(dta_bladder$covar1), |
|
290 |
#' mod = mod, conf_level = .95 |
|
291 |
#' ) |
|
292 |
#' result |
|
293 |
#' |
|
294 |
#' @export |
|
295 |
h_coxreg_inter_estimations <- function(variable, |
|
296 |
given, |
|
297 |
lvl_var, |
|
298 |
lvl_given, |
|
299 |
mod, |
|
300 |
conf_level = 0.95) { |
|
301 | 18x |
var_lvl <- paste0(variable, lvl_var[-1]) # [-1]: reference level |
302 | 18x |
giv_lvl <- paste0(given, lvl_given) |
303 | 18x |
design_mat <- expand.grid(variable = var_lvl, given = giv_lvl) |
304 | 18x |
design_mat <- design_mat[order(design_mat$variable, design_mat$given), ] |
305 | 18x |
design_mat <- within( |
306 | 18x |
data = design_mat, |
307 | 18x |
expr = { |
308 | 18x |
inter <- paste0(variable, ":", given) |
309 | 18x |
rev_inter <- paste0(given, ":", variable) |
310 |
} |
|
311 |
) |
|
312 | 18x |
split_by_variable <- design_mat$variable |
313 | 18x |
interaction_names <- paste(design_mat$variable, design_mat$given, sep = "/") |
314 | ||
315 | 18x |
mmat <- stats::model.matrix(mod)[1, ] |
316 | 18x |
mmat[!mmat == 0] <- 0 |
317 | ||
318 | 18x |
design_mat <- apply( |
319 | 18x |
X = design_mat, MARGIN = 1, FUN = function(x) { |
320 | 52x |
mmat[names(mmat) %in% x[-which(names(x) == "given")]] <- 1 |
321 | 52x |
mmat |
322 |
} |
|
323 |
) |
|
324 | 18x |
colnames(design_mat) <- interaction_names |
325 | ||
326 | 18x |
coef <- stats::coef(mod) |
327 | 18x |
vcov <- stats::vcov(mod) |
328 | 18x |
betas <- as.matrix(coef) |
329 | 18x |
coef_hat <- t(design_mat) %*% betas |
330 | 18x |
dimnames(coef_hat)[2] <- "coef" |
331 | 18x |
coef_se <- apply( |
332 | 18x |
design_mat, 2, |
333 | 18x |
function(x) { |
334 | 52x |
vcov_el <- as.logical(x) |
335 | 52x |
y <- vcov[vcov_el, vcov_el] |
336 | 52x |
y <- sum(y) |
337 | 52x |
y <- sqrt(y) |
338 | 52x |
return(y) |
339 |
} |
|
340 |
) |
|
341 | 18x |
q_norm <- stats::qnorm((1 + conf_level) / 2) |
342 | 18x |
y <- cbind(coef_hat, `se(coef)` = coef_se) |
343 | 18x |
y <- apply(y, 1, function(x) { |
344 | 52x |
x["hr"] <- exp(x["coef"]) |
345 | 52x |
x["lcl"] <- exp(x["coef"] - q_norm * x["se(coef)"]) |
346 | 52x |
x["ucl"] <- exp(x["coef"] + q_norm * x["se(coef)"]) |
347 | 52x |
x |
348 |
}) |
|
349 | 18x |
y <- t(y) |
350 | 18x |
y <- by(y, split_by_variable, identity) |
351 | 18x |
y <- lapply(y, as.matrix) |
352 | 18x |
attr(y, "details") <- paste0( |
353 | 18x |
"Estimations of ", variable, |
354 | 18x |
" hazard ratio given the level of ", given, " compared to ", |
355 | 18x |
variable, " level ", lvl_var[1], "." |
356 |
) |
|
357 | 18x |
y |
358 |
} |
1 |
#' Count patients by most extreme post-baseline toxicity grade per direction of abnormality |
|
2 |
#' |
|
3 |
#' @description `r lifecycle::badge("stable")` |
|
4 |
#' |
|
5 |
#' The analyze function [count_abnormal_by_worst_grade()] creates a layout element to count patients by highest (worst) |
|
6 |
#' analysis toxicity grade post-baseline for each direction, categorized by parameter value. |
|
7 |
#' |
|
8 |
#' This function analyzes primary analysis variable `var` which indicates toxicity grades. Additional |
|
9 |
#' analysis variables that can be supplied as a list via the `variables` parameter are `id` (defaults to |
|
10 |
#' `USUBJID`), a variable to indicate unique subject identifiers, `param` (defaults to `PARAM`), a variable |
|
11 |
#' to indicate parameter values, and `grade_dir` (defaults to `GRADE_DIR`), a variable to indicate directions |
|
12 |
#' (e.g. High or Low) for each toxicity grade supplied in `var`. |
|
13 |
#' |
|
14 |
#' For each combination of `param` and `grade_dir` levels, patient counts by worst |
|
15 |
#' grade are calculated as follows: |
|
16 |
#' * `1` to `4`: The number of patients with worst grades 1-4, respectively. |
|
17 |
#' * `Any`: The number of patients with at least one abnormality (i.e. grade is not 0). |
|
18 |
#' |
|
19 |
#' Fractions are calculated by dividing the above counts by the number of patients with at least one |
|
20 |
#' valid measurement recorded during treatment. |
|
21 |
#' |
|
22 |
#' Pre-processing is crucial when using this function and can be done automatically using the |
|
23 |
#' [h_adlb_abnormal_by_worst_grade()] helper function. See the description of this function for details on the |
|
24 |
#' necessary pre-processing steps. |
|
25 |
#' |
|
26 |
#' Prior to using this function in your table layout you must use [rtables::split_rows_by()] to create two row |
|
27 |
#' splits, one on variable `param` and one on variable `grade_dir`. |
|
28 |
#' |
|
29 |
#' @inheritParams argument_convention |
|
30 |
#' @param .stats (`character`)\cr statistics to select for the table. |
|
31 |
#' |
|
32 |
#' Options are: ``r shQuote(get_stats("abnormal_by_worst_grade"), type = "sh")`` |
|
33 |
#' |
|
34 |
#' @seealso [h_adlb_abnormal_by_worst_grade()] which pre-processes ADLB data frames to be used in |
|
35 |
#' [count_abnormal_by_worst_grade()]. |
|
36 |
#' |
|
37 |
#' @name abnormal_by_worst_grade |
|
38 |
#' @order 1 |
|
39 |
NULL |
|
40 | ||
41 |
#' @describeIn abnormal_by_worst_grade Statistics function which counts patients by worst grade. |
|
42 |
#' |
|
43 |
#' @return |
|
44 |
#' * `s_count_abnormal_by_worst_grade()` returns the single statistic `count_fraction` with grades 1 to 4 and |
|
45 |
#' "Any" results. |
|
46 |
#' |
|
47 |
#' @keywords internal |
|
48 |
s_count_abnormal_by_worst_grade <- function(df, |
|
49 |
.var = "GRADE_ANL", |
|
50 |
.spl_context, |
|
51 |
variables = list( |
|
52 |
id = "USUBJID", |
|
53 |
param = "PARAM", |
|
54 |
grade_dir = "GRADE_DIR" |
|
55 |
), |
|
56 |
...) { |
|
57 | 5x |
checkmate::assert_string(.var) |
58 | 5x |
assert_valid_factor(df[[.var]]) |
59 | 5x |
assert_valid_factor(df[[variables$param]]) |
60 | 4x |
assert_valid_factor(df[[variables$grade_dir]]) |
61 | 4x |
assert_df_with_variables(df, c(a = .var, variables)) |
62 | 4x |
checkmate::assert_multi_class(df[[variables$id]], classes = c("factor", "character")) |
63 | ||
64 |
# To verify that the `split_rows_by` are performed with correct variables. |
|
65 | 4x |
checkmate::assert_subset(c(variables[["param"]], variables[["grade_dir"]]), .spl_context$split) |
66 | 4x |
first_row <- .spl_context[.spl_context$split == variables[["param"]], ] |
67 | 4x |
x_lvls <- c(setdiff(levels(df[[.var]]), "0"), "Any") |
68 | 4x |
result <- split(numeric(0), factor(x_lvls)) |
69 | ||
70 | 4x |
subj <- first_row$full_parent_df[[1]][[variables[["id"]]]] |
71 | 4x |
subj_cur_col <- subj[first_row$cur_col_subset[[1]]] |
72 |
# Some subjects may have a record for high and low directions but |
|
73 |
# should be counted only once. |
|
74 | 4x |
denom <- length(unique(subj_cur_col)) |
75 | ||
76 | 4x |
for (lvl in x_lvls) { |
77 | 20x |
if (lvl != "Any") { |
78 | 16x |
df_lvl <- df[df[[.var]] == lvl, ] |
79 |
} else { |
|
80 | 4x |
df_lvl <- df[df[[.var]] != 0, ] |
81 |
} |
|
82 | 20x |
num <- length(unique(df_lvl[[variables[["id"]]]])) |
83 | 20x |
fraction <- ifelse(denom == 0, 0, num / denom) |
84 | 20x |
result[[lvl]] <- formatters::with_label(c(count = num, fraction = fraction), lvl) |
85 |
} |
|
86 | ||
87 | 4x |
result <- list(count_fraction = result) |
88 | 4x |
result |
89 |
} |
|
90 | ||
91 |
#' @describeIn abnormal_by_worst_grade Formatted analysis function which is used as `afun` |
|
92 |
#' in `count_abnormal_by_worst_grade()`. |
|
93 |
#' |
|
94 |
#' @return |
|
95 |
#' * `a_count_abnormal_by_worst_grade()` returns the corresponding list with formatted [rtables::CellValue()]. |
|
96 |
#' |
|
97 |
#' @keywords internal |
|
98 |
a_count_abnormal_by_worst_grade <- function(df, |
|
99 |
..., |
|
100 |
.stats = NULL, |
|
101 |
.stat_names = NULL, |
|
102 |
.formats = NULL, |
|
103 |
.labels = NULL, |
|
104 |
.indent_mods = NULL) { |
|
105 |
# Check for additional parameters to the statistics function |
|
106 | 4x |
dots_extra_args <- list(...) |
107 | 4x |
extra_afun_params <- retrieve_extra_afun_params(names(dots_extra_args$.additional_fun_parameters)) |
108 | 4x |
dots_extra_args$.additional_fun_parameters <- NULL |
109 | ||
110 |
# Check for user-defined functions |
|
111 | 4x |
default_and_custom_stats_list <- .split_std_from_custom_stats(.stats) |
112 | 4x |
.stats <- default_and_custom_stats_list$all_stats |
113 | 4x |
custom_stat_functions <- default_and_custom_stats_list$custom_stats |
114 | ||
115 |
# Apply statistics function |
|
116 | 4x |
x_stats <- .apply_stat_functions( |
117 | 4x |
default_stat_fnc = s_count_abnormal_by_worst_grade, |
118 | 4x |
custom_stat_fnc_list = custom_stat_functions, |
119 | 4x |
args_list = c( |
120 | 4x |
df = list(df), |
121 | 4x |
extra_afun_params, |
122 | 4x |
dots_extra_args |
123 |
) |
|
124 |
) |
|
125 | ||
126 |
# Fill in formatting defaults |
|
127 | 3x |
.stats <- get_stats("abnormal_by_worst_grade", stats_in = .stats, custom_stats_in = names(custom_stat_functions)) |
128 | 3x |
levels_per_stats <- lapply(x_stats, names) |
129 | 3x |
.formats <- get_formats_from_stats(.stats, .formats, levels_per_stats) |
130 | 3x |
.labels <- get_labels_from_stats(.stats, .labels, levels_per_stats) |
131 | 3x |
.indent_mods <- get_indents_from_stats(.stats, .indent_mods, levels_per_stats) |
132 | ||
133 | 3x |
x_stats <- x_stats[.stats] %>% |
134 | 3x |
.unlist_keep_nulls() %>% |
135 | 3x |
setNames(names(.formats)) |
136 | ||
137 |
# Auto format handling |
|
138 | 3x |
.formats <- apply_auto_formatting(.formats, x_stats, extra_afun_params$.df_row, extra_afun_params$.var) |
139 | ||
140 |
# Get and check statistical names |
|
141 | 3x |
.stat_names <- get_stat_names(x_stats, .stat_names) |
142 | ||
143 | 3x |
in_rows( |
144 | 3x |
.list = x_stats, |
145 | 3x |
.formats = .formats, |
146 | 3x |
.names = .labels %>% .unlist_keep_nulls(), |
147 | 3x |
.stat_names = .stat_names, |
148 | 3x |
.labels = .labels %>% .unlist_keep_nulls(), |
149 | 3x |
.indent_mods = .indent_mods %>% .unlist_keep_nulls() |
150 |
) |
|
151 |
} |
|
152 | ||
153 |
#' @describeIn abnormal_by_worst_grade Layout-creating function which can take statistics function arguments |
|
154 |
#' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
|
155 |
#' |
|
156 |
#' @return |
|
157 |
#' * `count_abnormal_by_worst_grade()` returns a layout object suitable for passing to further layouting functions, |
|
158 |
#' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
|
159 |
#' the statistics from `s_count_abnormal_by_worst_grade()` to the table layout. |
|
160 |
#' |
|
161 |
#' @examples |
|
162 |
#' library(dplyr) |
|
163 |
#' library(forcats) |
|
164 |
#' adlb <- tern_ex_adlb |
|
165 |
#' |
|
166 |
#' # Data is modified in order to have some parameters with grades only in one direction |
|
167 |
#' # and simulate the real data. |
|
168 |
#' adlb$ATOXGR[adlb$PARAMCD == "ALT" & adlb$ATOXGR %in% c("1", "2", "3", "4")] <- "-1" |
|
169 |
#' adlb$ANRIND[adlb$PARAMCD == "ALT" & adlb$ANRIND == "HIGH"] <- "LOW" |
|
170 |
#' adlb$WGRHIFL[adlb$PARAMCD == "ALT"] <- "" |
|
171 |
#' |
|
172 |
#' adlb$ATOXGR[adlb$PARAMCD == "IGA" & adlb$ATOXGR %in% c("-1", "-2", "-3", "-4")] <- "1" |
|
173 |
#' adlb$ANRIND[adlb$PARAMCD == "IGA" & adlb$ANRIND == "LOW"] <- "HIGH" |
|
174 |
#' adlb$WGRLOFL[adlb$PARAMCD == "IGA"] <- "" |
|
175 |
#' |
|
176 |
#' # Pre-processing |
|
177 |
#' adlb_f <- adlb %>% h_adlb_abnormal_by_worst_grade() |
|
178 |
#' |
|
179 |
#' # Map excludes records without abnormal grade since they should not be displayed |
|
180 |
#' # in the table. |
|
181 |
#' map <- unique(adlb_f[adlb_f$GRADE_DIR != "ZERO", c("PARAM", "GRADE_DIR", "GRADE_ANL")]) %>% |
|
182 |
#' lapply(as.character) %>% |
|
183 |
#' as.data.frame() %>% |
|
184 |
#' arrange(PARAM, desc(GRADE_DIR), GRADE_ANL) |
|
185 |
#' |
|
186 |
#' basic_table() %>% |
|
187 |
#' split_cols_by("ARMCD") %>% |
|
188 |
#' split_rows_by("PARAM") %>% |
|
189 |
#' split_rows_by("GRADE_DIR", split_fun = trim_levels_to_map(map)) %>% |
|
190 |
#' count_abnormal_by_worst_grade( |
|
191 |
#' var = "GRADE_ANL", |
|
192 |
#' variables = list(id = "USUBJID", param = "PARAM", grade_dir = "GRADE_DIR") |
|
193 |
#' ) %>% |
|
194 |
#' build_table(df = adlb_f) |
|
195 |
#' |
|
196 |
#' @export |
|
197 |
#' @order 2 |
|
198 |
count_abnormal_by_worst_grade <- function(lyt, |
|
199 |
var, |
|
200 |
variables = list( |
|
201 |
id = "USUBJID", |
|
202 |
param = "PARAM", |
|
203 |
grade_dir = "GRADE_DIR" |
|
204 |
), |
|
205 |
na_str = default_na_str(), |
|
206 |
nested = TRUE, |
|
207 |
..., |
|
208 |
.stats = "count_fraction", |
|
209 |
.stat_names = NULL, |
|
210 |
.formats = list(count_fraction = format_count_fraction), |
|
211 |
.labels = NULL, |
|
212 |
.indent_mods = NULL) { |
|
213 |
# Process standard extra arguments |
|
214 | 2x |
extra_args <- list(".stats" = .stats) |
215 | ! |
if (!is.null(.stat_names)) extra_args[[".stat_names"]] <- .stat_names |
216 | 2x |
if (!is.null(.formats)) extra_args[[".formats"]] <- .formats |
217 | ! |
if (!is.null(.labels)) extra_args[[".labels"]] <- .labels |
218 | ! |
if (!is.null(.indent_mods)) extra_args[[".indent_mods"]] <- .indent_mods |
219 | ||
220 |
# Process additional arguments to the statistic function |
|
221 | 2x |
extra_args <- c(extra_args, "variables" = list(variables), ...) |
222 | ||
223 |
# Append additional info from layout to the analysis function |
|
224 | 2x |
extra_args[[".additional_fun_parameters"]] <- get_additional_afun_params(add_alt_df = FALSE) |
225 | 2x |
formals(a_count_abnormal_by_worst_grade) <- c( |
226 | 2x |
formals(a_count_abnormal_by_worst_grade), extra_args[[".additional_fun_parameters"]] |
227 |
) |
|
228 | ||
229 | 2x |
analyze( |
230 | 2x |
lyt = lyt, |
231 | 2x |
vars = var, |
232 | 2x |
afun = a_count_abnormal_by_worst_grade, |
233 | 2x |
na_str = na_str, |
234 | 2x |
nested = nested, |
235 | 2x |
extra_args = extra_args, |
236 | 2x |
show_labels = "hidden" |
237 |
) |
|
238 |
} |
|
239 | ||
240 |
#' Helper function to prepare ADLB for `count_abnormal_by_worst_grade()` |
|
241 |
#' |
|
242 |
#' @description `r lifecycle::badge("stable")` |
|
243 |
#' |
|
244 |
#' Helper function to prepare an ADLB data frame to be used as input in |
|
245 |
#' [count_abnormal_by_worst_grade()]. The following pre-processing steps are applied: |
|
246 |
#' |
|
247 |
#' 1. `adlb` is filtered on variable `avisit` to only include post-baseline visits. |
|
248 |
#' 2. `adlb` is filtered on variables `worst_flag_low` and `worst_flag_high` so that only |
|
249 |
#' worst grades (in either direction) are included. |
|
250 |
#' 3. From the standard lab grade variable `atoxgr`, the following two variables are derived |
|
251 |
#' and added to `adlb`: |
|
252 |
#' * A grade direction variable (e.g. `GRADE_DIR`). The variable takes value `"HIGH"` when |
|
253 |
#' `atoxgr > 0`, `"LOW"` when `atoxgr < 0`, and `"ZERO"` otherwise. |
|
254 |
#' * A toxicity grade variable (e.g. `GRADE_ANL`) where all negative values from `atoxgr` are |
|
255 |
#' replaced by their absolute values. |
|
256 |
#' 4. Unused factor levels are dropped from `adlb` via [droplevels()]. |
|
257 |
#' |
|
258 |
#' @param adlb (`data.frame`)\cr ADLB data frame. |
|
259 |
#' @param atoxgr (`string`)\cr name of the analysis toxicity grade variable. This must be a `factor` |
|
260 |
#' variable. |
|
261 |
#' @param avisit (`string`)\cr name of the analysis visit variable. |
|
262 |
#' @param worst_flag_low (`string`)\cr name of the worst low lab grade flag variable. This variable is |
|
263 |
#' set to `"Y"` when indicating records of worst low lab grades. |
|
264 |
#' @param worst_flag_high (`string`)\cr name of the worst high lab grade flag variable. This variable is |
|
265 |
#' set to `"Y"` when indicating records of worst high lab grades. |
|
266 |
#' |
|
267 |
#' @return `h_adlb_abnormal_by_worst_grade()` returns the `adlb` data frame with two new |
|
268 |
#' variables: `GRADE_DIR` and `GRADE_ANL`. |
|
269 |
#' |
|
270 |
#' @seealso [abnormal_by_worst_grade] |
|
271 |
#' |
|
272 |
#' @examples |
|
273 |
#' h_adlb_abnormal_by_worst_grade(tern_ex_adlb) %>% |
|
274 |
#' dplyr::select(ATOXGR, GRADE_DIR, GRADE_ANL) %>% |
|
275 |
#' head(10) |
|
276 |
#' |
|
277 |
#' @export |
|
278 |
h_adlb_abnormal_by_worst_grade <- function(adlb, |
|
279 |
atoxgr = "ATOXGR", |
|
280 |
avisit = "AVISIT", |
|
281 |
worst_flag_low = "WGRLOFL", |
|
282 |
worst_flag_high = "WGRHIFL") { |
|
283 | 1x |
adlb %>% |
284 | 1x |
dplyr::filter( |
285 | 1x |
!.data[[avisit]] %in% c("SCREENING", "BASELINE"), |
286 | 1x |
.data[[worst_flag_low]] == "Y" | .data[[worst_flag_high]] == "Y" |
287 |
) %>% |
|
288 | 1x |
dplyr::mutate( |
289 | 1x |
GRADE_DIR = factor( |
290 | 1x |
dplyr::case_when( |
291 | 1x |
.data[[atoxgr]] %in% c("-1", "-2", "-3", "-4") ~ "LOW", |
292 | 1x |
.data[[atoxgr]] == "0" ~ "ZERO", |
293 | 1x |
.data[[atoxgr]] %in% c("1", "2", "3", "4") ~ "HIGH" |
294 |
), |
|
295 | 1x |
levels = c("LOW", "ZERO", "HIGH") |
296 |
), |
|
297 | 1x |
GRADE_ANL = forcats::fct_relevel( |
298 | 1x |
forcats::fct_recode(.data[[atoxgr]], `1` = "-1", `2` = "-2", `3` = "-3", `4` = "-4"), |
299 | 1x |
c("0", "1", "2", "3", "4") |
300 |
) |
|
301 |
) %>% |
|
302 | 1x |
droplevels() |
303 |
} |
1 |
#' Line plot with optional table |
|
2 |
#' |
|
3 |
#' @description `r lifecycle::badge("stable")` |
|
4 |
#' |
|
5 |
#' Line plot with optional table. |
|
6 |
#' |
|
7 |
#' @inheritParams argument_convention |
|
8 |
#' @param alt_counts_df (`data.frame` or `NULL`)\cr data set that will be used (only) |
|
9 |
#' to counts objects in groups for stratification. |
|
10 |
#' @param variables (named `character`) vector of variable names in `df` which should include: |
|
11 |
#' * `x` (`string`)\cr name of x-axis variable. |
|
12 |
#' * `y` (`string`)\cr name of y-axis variable. |
|
13 |
#' * `group_var` (`string` or `NULL`)\cr name of grouping variable (or strata), i.e. treatment arm. |
|
14 |
#' Can be `NA` to indicate lack of groups. |
|
15 |
#' * `subject_var` (`string` or `NULL`)\cr name of subject variable. Only applies if `group_var` is |
|
16 |
#' not NULL. |
|
17 |
#' * `paramcd` (`string` or `NA`)\cr name of the variable for parameter's code. Used for y-axis label and plot's |
|
18 |
#' subtitle. Can be `NA` if `paramcd` is not to be added to the y-axis label or subtitle. |
|
19 |
#' * `y_unit` (`string` or `NA`)\cr name of variable with units of `y`. Used for y-axis label and plot's subtitle. |
|
20 |
#' Can be `NA` if y unit is not to be added to the y-axis label or subtitle. |
|
21 |
#' * `facet_var` (`string` or `NA`)\cr name of the secondary grouping variable used for plot faceting, i.e. treatment |
|
22 |
#' arm. Can be `NA` to indicate lack of groups. |
|
23 |
#' @param mid (`character` or `NULL`)\cr names of the statistics that will be plotted as midpoints. |
|
24 |
#' All the statistics indicated in `mid` variable must be present in the object returned by `sfun`, |
|
25 |
#' and be of a `double` or `numeric` type vector of length one. |
|
26 |
#' @param interval (`character` or `NULL`)\cr names of the statistics that will be plotted as intervals. |
|
27 |
#' All the statistics indicated in `interval` variable must be present in the object returned by `sfun`, |
|
28 |
#' and be of a `double` or `numeric` type vector of length two. Set `interval = NULL` if intervals should not be |
|
29 |
#' added to the plot. |
|
30 |
#' @param whiskers (`character`)\cr names of the interval whiskers that will be plotted. Names must match names |
|
31 |
#' of the list element `interval` that will be returned by `sfun` (e.g. `mean_ci_lwr` element of |
|
32 |
#' `sfun(x)[["mean_ci"]]`). It is possible to specify one whisker only, or to suppress all whiskers by setting |
|
33 |
#' `interval = NULL`. |
|
34 |
#' @param table (`character` or `NULL`)\cr names of the statistics that will be displayed in the table below the plot. |
|
35 |
#' All the statistics indicated in `table` variable must be present in the object returned by `sfun`. |
|
36 |
#' @param sfun (`function`)\cr the function to compute the values of required statistics. It must return a named `list` |
|
37 |
#' with atomic vectors. The names of the `list` elements refer to the names of the statistics and are used by `mid`, |
|
38 |
#' `interval`, `table`. It must be able to accept as input a vector with data for which statistics are computed. |
|
39 |
#' @param ... optional arguments to `sfun`. |
|
40 |
#' @param mid_type (`string`)\cr controls the type of the `mid` plot, it can be point (`"p"`), line (`"l"`), |
|
41 |
#' or point and line (`"pl"`). |
|
42 |
#' @param mid_point_size (`numeric(1)`)\cr font size of the `mid` plot points. |
|
43 |
#' @param position (`character` or `call`)\cr geom element position adjustment, either as a string, or the result of |
|
44 |
#' a call to a position adjustment function. |
|
45 |
#' @param legend_title (`string`)\cr legend title. |
|
46 |
#' @param legend_position (`string`)\cr the position of the plot legend (`"none"`, `"left"`, `"right"`, `"bottom"`, |
|
47 |
#' `"top"`, or a two-element numeric vector). |
|
48 |
#' @param ggtheme (`theme`)\cr a graphical theme as provided by `ggplot2` to control styling of the plot. |
|
49 |
#' @param xticks (`numeric` or `NULL`)\cr numeric vector of tick positions or a single number with spacing |
|
50 |
#' between ticks on the x-axis, for use when `variables$x` is numeric. If `NULL` (default), [labeling::extended()] is |
|
51 |
#' used to determine optimal tick positions on the x-axis. If `variables$x` is not numeric, this argument is ignored. |
|
52 |
#' @param x_lab (`string` or `NULL`)\cr x-axis label. If `NULL` then no label will be added. |
|
53 |
#' @param y_lab (`string` or `NULL`)\cr y-axis label. If `NULL` then no label will be added. |
|
54 |
#' @param y_lab_add_paramcd (`flag`)\cr whether `paramcd`, i.e. `unique(df[[variables["paramcd"]]])` should be added |
|
55 |
#' to the y-axis label (`y_lab`). |
|
56 |
#' @param y_lab_add_unit (`flag`)\cr whether y-axis unit, i.e. `unique(df[[variables["y_unit"]]])` should be added |
|
57 |
#' to the y-axis label (`y_lab`). |
|
58 |
#' @param title (`string`)\cr plot title. |
|
59 |
#' @param subtitle (`string`)\cr plot subtitle. |
|
60 |
#' @param subtitle_add_paramcd (`flag`)\cr whether `paramcd`, i.e. `unique(df[[variables["paramcd"]]])` should be |
|
61 |
#' added to the plot's subtitle (`subtitle`). |
|
62 |
#' @param subtitle_add_unit (`flag`)\cr whether the y-axis unit, i.e. `unique(df[[variables["y_unit"]]])` should be |
|
63 |
#' added to the plot's subtitle (`subtitle`). |
|
64 |
#' @param caption (`string`)\cr optional caption below the plot. |
|
65 |
#' @param table_format (named `vector` or `NULL`)\cr custom formats for descriptive statistics used instead of defaults |
|
66 |
#' in the (optional) table appended to the plot. It is passed directly to the `h_format_row` function through |
|
67 |
#' the `format` parameter. Names of `table_format` must match the names of statistics returned by `sfun` function. |
|
68 |
#' Can be a character vector with values from [formatters::list_valid_format_labels()] or custom format functions. |
|
69 |
#' @param table_labels (named `character` or `NULL`)\cr labels for descriptive statistics used in the (optional) table |
|
70 |
#' appended to the plot. Names of `table_labels` must match the names of statistics returned by `sfun` function. |
|
71 |
#' @param table_font_size (`numeric(1)`)\cr font size of the text in the table. |
|
72 |
#' @param newpage `r lifecycle::badge("deprecated")` not used. |
|
73 |
#' @param col (`character`)\cr color(s). See `?ggplot2::aes_colour_fill_alpha` for example values. |
|
74 |
#' @param linetype (`character`)\cr line type(s). See `?ggplot2::aes_linetype_size_shape` for example values. |
|
75 |
#' @param errorbar_width (`numeric(1)`)\cr width of the error bars. |
|
76 |
#' @param rel_height_plot (`proportion`)\cr proportion of total figure height to allocate to the line plot. |
|
77 |
#' Relative height of annotation table is then `1 - rel_height_plot`. If `table = NULL`, this parameter is ignored. |
|
78 |
#' @param as_list (`flag`)\cr whether the two `ggplot` objects should be returned as a list when `table` is not `NULL`. |
|
79 |
#' If `TRUE`, a named list with two elements, `plot` and `table`, will be returned. If `FALSE` (default) the |
|
80 |
#' annotation table is printed below the plot via [cowplot::plot_grid()]. |
|
81 |
#' |
|
82 |
#' @return A `ggplot` line plot (and statistics table if applicable). |
|
83 |
#' |
|
84 |
#' @examples |
|
85 |
#' |
|
86 |
#' adsl <- tern_ex_adsl |
|
87 |
#' adlb <- tern_ex_adlb %>% dplyr::filter(ANL01FL == "Y", PARAMCD == "ALT", AVISIT != "SCREENING") |
|
88 |
#' adlb$AVISIT <- droplevels(adlb$AVISIT) |
|
89 |
#' adlb <- dplyr::mutate(adlb, AVISIT = forcats::fct_reorder(AVISIT, AVISITN, min)) |
|
90 |
#' |
|
91 |
#' # Mean with CI |
|
92 |
#' g_lineplot(adlb, adsl, subtitle = "Laboratory Test:") |
|
93 |
#' |
|
94 |
#' # Mean with CI, no stratification with group_var |
|
95 |
#' g_lineplot(adlb, variables = control_lineplot_vars(group_var = NA)) |
|
96 |
#' |
|
97 |
#' # Mean, upper whisker of CI, no group_var(strata) counts N |
|
98 |
#' g_lineplot( |
|
99 |
#' adlb, |
|
100 |
#' whiskers = "mean_ci_upr", |
|
101 |
#' title = "Plot of Mean and Upper 95% Confidence Limit by Visit" |
|
102 |
#' ) |
|
103 |
#' |
|
104 |
#' # Median with CI |
|
105 |
#' g_lineplot( |
|
106 |
#' adlb, |
|
107 |
#' adsl, |
|
108 |
#' mid = "median", |
|
109 |
#' interval = "median_ci", |
|
110 |
#' whiskers = c("median_ci_lwr", "median_ci_upr"), |
|
111 |
#' title = "Plot of Median and 95% Confidence Limits by Visit" |
|
112 |
#' ) |
|
113 |
#' |
|
114 |
#' # Mean, +/- SD |
|
115 |
#' g_lineplot(adlb, adsl, |
|
116 |
#' interval = "mean_sdi", |
|
117 |
#' whiskers = c("mean_sdi_lwr", "mean_sdi_upr"), |
|
118 |
#' title = "Plot of Median +/- SD by Visit" |
|
119 |
#' ) |
|
120 |
#' |
|
121 |
#' # Mean with CI plot with stats table |
|
122 |
#' g_lineplot(adlb, adsl, table = c("n", "mean", "mean_ci")) |
|
123 |
#' |
|
124 |
#' # Mean with CI, table and customized confidence level |
|
125 |
#' g_lineplot( |
|
126 |
#' adlb, |
|
127 |
#' adsl, |
|
128 |
#' table = c("n", "mean", "mean_ci"), |
|
129 |
#' control = control_analyze_vars(conf_level = 0.80), |
|
130 |
#' title = "Plot of Mean and 80% Confidence Limits by Visit" |
|
131 |
#' ) |
|
132 |
#' |
|
133 |
#' # Mean with CI, table with customized formats/labels |
|
134 |
#' g_lineplot( |
|
135 |
#' adlb, |
|
136 |
#' adsl, |
|
137 |
#' table = c("n", "mean", "mean_ci"), |
|
138 |
#' table_format = list( |
|
139 |
#' mean = function(x, ...) { |
|
140 |
#' ifelse(x < 20, round_fmt(x, digits = 3), round_fmt(x, digits = 2)) |
|
141 |
#' }, |
|
142 |
#' mean_ci = "(xx.xxx, xx.xxx)" |
|
143 |
#' ), |
|
144 |
#' table_labels = list( |
|
145 |
#' mean = "mean", |
|
146 |
#' mean_ci = "95% CI" |
|
147 |
#' ) |
|
148 |
#' ) |
|
149 |
#' |
|
150 |
#' # Mean with CI, table, filtered data |
|
151 |
#' adlb_f <- dplyr::filter(adlb, ARMCD != "ARM A" | AVISIT == "BASELINE") |
|
152 |
#' g_lineplot(adlb_f, table = c("n", "mean")) |
|
153 |
#' |
|
154 |
#' @export |
|
155 |
g_lineplot <- function(df, |
|
156 |
alt_counts_df = NULL, |
|
157 |
variables = control_lineplot_vars(), |
|
158 |
mid = "mean", |
|
159 |
interval = "mean_ci", |
|
160 |
whiskers = c("mean_ci_lwr", "mean_ci_upr"), |
|
161 |
table = NULL, |
|
162 |
sfun = s_summary, |
|
163 |
..., |
|
164 |
mid_type = "pl", |
|
165 |
mid_point_size = 2, |
|
166 |
position = ggplot2::position_dodge(width = 0.4), |
|
167 |
legend_title = NULL, |
|
168 |
legend_position = "bottom", |
|
169 |
ggtheme = nestcolor::theme_nest(), |
|
170 |
xticks = NULL, |
|
171 |
xlim = NULL, |
|
172 |
ylim = NULL, |
|
173 |
x_lab = obj_label(df[[variables[["x"]]]]), |
|
174 |
y_lab = NULL, |
|
175 |
y_lab_add_paramcd = TRUE, |
|
176 |
y_lab_add_unit = TRUE, |
|
177 |
title = "Plot of Mean and 95% Confidence Limits by Visit", |
|
178 |
subtitle = "", |
|
179 |
subtitle_add_paramcd = TRUE, |
|
180 |
subtitle_add_unit = TRUE, |
|
181 |
caption = NULL, |
|
182 |
table_format = NULL, |
|
183 |
table_labels = NULL, |
|
184 |
table_font_size = 3, |
|
185 |
errorbar_width = 0.45, |
|
186 |
newpage = lifecycle::deprecated(), |
|
187 |
col = NULL, |
|
188 |
linetype = NULL, |
|
189 |
rel_height_plot = 0.5, |
|
190 |
as_list = FALSE) { |
|
191 | 14x |
checkmate::assert_character(variables, any.missing = TRUE) |
192 | 14x |
checkmate::assert_character(mid, null.ok = TRUE) |
193 | 14x |
checkmate::assert_character(interval, null.ok = TRUE) |
194 | 14x |
checkmate::assert_character(col, null.ok = TRUE) |
195 | 14x |
checkmate::assert_character(linetype, null.ok = TRUE) |
196 | 14x |
checkmate::assert_numeric(xticks, null.ok = TRUE) |
197 | 14x |
checkmate::assert_numeric(xlim, finite = TRUE, any.missing = FALSE, len = 2, sorted = TRUE, null.ok = TRUE) |
198 | 14x |
checkmate::assert_numeric(ylim, finite = TRUE, any.missing = FALSE, len = 2, sorted = TRUE, null.ok = TRUE) |
199 | 14x |
checkmate::assert_number(errorbar_width, lower = 0) |
200 | 14x |
checkmate::assert_string(title, null.ok = TRUE) |
201 | 14x |
checkmate::assert_string(subtitle, null.ok = TRUE) |
202 | 14x |
assert_proportion_value(rel_height_plot) |
203 | 14x |
checkmate::assert_logical(as_list) |
204 | ||
205 | 14x |
if (!is.null(table)) { |
206 | 6x |
table_format <- get_formats_from_stats(table, formats_in = table_format) |
207 | 6x |
table_labels <- get_labels_from_stats(table, labels_in = table_labels) %>% .unlist_keep_nulls() |
208 |
} |
|
209 | ||
210 | 14x |
extra_args <- list(...) |
211 | 14x |
if ("control" %in% names(extra_args)) { |
212 | 4x |
if (!is.null(table) && all(table_labels == .unlist_keep_nulls(get_labels_from_stats(table)))) { |
213 | 3x |
table_labels <- table_labels %>% labels_use_control(extra_args[["control"]]) |
214 |
} |
|
215 |
} |
|
216 | ||
217 | 14x |
if (is.character(interval)) { |
218 | 14x |
checkmate::assert_vector(whiskers, min.len = 0, max.len = 2) |
219 |
} |
|
220 | ||
221 | 14x |
if (length(whiskers) == 1) { |
222 | ! |
checkmate::assert_character(mid) |
223 |
} |
|
224 | ||
225 | 14x |
if (is.character(mid)) { |
226 | 14x |
checkmate::assert_scalar(mid_type) |
227 | 14x |
checkmate::assert_subset(mid_type, c("pl", "p", "l")) |
228 |
} |
|
229 | ||
230 | 14x |
x <- variables[["x"]] |
231 | 14x |
y <- variables[["y"]] |
232 | 14x |
paramcd <- variables["paramcd"] # NA if paramcd == NA or it is not in variables |
233 | 14x |
y_unit <- variables["y_unit"] # NA if y_unit == NA or it is not in variables |
234 | 14x |
if (is.na(variables["group_var"])) { |
235 | 1x |
group_var <- NULL # NULL if group_var == NA or it is not in variables |
236 |
} else { |
|
237 | 13x |
group_var <- variables[["group_var"]] |
238 | 13x |
subject_var <- variables[["subject_var"]] |
239 |
} |
|
240 | 14x |
if (is.na(variables["facet_var"])) { |
241 | 13x |
facet_var <- NULL # NULL if facet_var == NA or it is not in variables |
242 |
} else { |
|
243 | 1x |
facet_var <- variables[["facet_var"]] |
244 |
} |
|
245 | 14x |
checkmate::assert_flag(y_lab_add_paramcd, null.ok = TRUE) |
246 | 14x |
checkmate::assert_flag(subtitle_add_paramcd, null.ok = TRUE) |
247 | 14x |
if ((!is.null(y_lab) && y_lab_add_paramcd) || (!is.null(subtitle) && subtitle_add_paramcd)) { |
248 | 14x |
checkmate::assert_false(is.na(paramcd)) |
249 | 14x |
checkmate::assert_scalar(unique(df[[paramcd]])) |
250 |
} |
|
251 | ||
252 | 14x |
checkmate::assert_flag(y_lab_add_unit, null.ok = TRUE) |
253 | 14x |
checkmate::assert_flag(subtitle_add_unit, null.ok = TRUE) |
254 | 14x |
if ((!is.null(y_lab) && y_lab_add_unit) || (!is.null(subtitle) && subtitle_add_unit)) { |
255 | 14x |
checkmate::assert_false(is.na(y_unit)) |
256 | 14x |
checkmate::assert_scalar(unique(df[[y_unit]])) |
257 |
} |
|
258 | ||
259 | 14x |
if (!is.null(group_var) && !is.null(alt_counts_df)) { |
260 | 9x |
checkmate::assert_set_equal(unique(alt_counts_df[[group_var]]), unique(df[[group_var]])) |
261 |
} |
|
262 | ||
263 |
####################################### | |
|
264 |
# ---- Compute required statistics ---- |
|
265 |
####################################### | |
|
266 |
# Remove unused levels for x-axis |
|
267 | 14x |
if (is.factor(df[[x]])) { |
268 | 13x |
df[[x]] <- droplevels(df[[x]]) |
269 |
} |
|
270 | ||
271 | 14x |
if (!is.null(facet_var) && !is.null(group_var)) { |
272 | 1x |
df_grp <- tidyr::expand(df, .data[[facet_var]], .data[[group_var]], .data[[x]]) # expand based on levels of factors |
273 | 13x |
} else if (!is.null(group_var)) { |
274 | 12x |
df_grp <- tidyr::expand(df, .data[[group_var]], .data[[x]]) # expand based on levels of factors |
275 |
} else { |
|
276 | 1x |
df_grp <- tidyr::expand(df, NULL, .data[[x]]) |
277 |
} |
|
278 | ||
279 | 14x |
df_grp <- df_grp %>% |
280 | 14x |
dplyr::full_join(y = df[, c(facet_var, group_var, x, y)], by = c(facet_var, group_var, x), multiple = "all") %>% |
281 | 14x |
dplyr::group_by_at(c(facet_var, group_var, x)) |
282 | ||
283 | 14x |
df_stats <- df_grp %>% |
284 | 14x |
dplyr::summarise( |
285 | 14x |
data.frame(t(do.call(c, unname(sfun(.data[[y]])[c(mid, interval)])))), |
286 | 14x |
.groups = "drop" |
287 |
) |
|
288 | ||
289 | 14x |
df_stats <- df_stats[!is.na(df_stats[[mid]]), ] |
290 | ||
291 |
# add number of objects N in group_var (strata) |
|
292 | 14x |
if (!is.null(group_var) && !is.null(alt_counts_df)) { |
293 | 9x |
strata_N <- paste0(group_var, "_N") # nolint |
294 | ||
295 | 9x |
df_N <- stats::aggregate(eval(parse(text = subject_var)) ~ eval(parse(text = group_var)), data = alt_counts_df, FUN = function(x) length(unique(x))) # nolint |
296 | 9x |
colnames(df_N) <- c(group_var, "N") # nolint |
297 | 9x |
df_N[[strata_N]] <- paste0(df_N[[group_var]], " (N = ", df_N$N, ")") # nolint |
298 | ||
299 |
# keep strata factor levels |
|
300 | 9x |
matches <- sapply(unique(df_N[[group_var]]), function(x) { |
301 | 25x |
regex_pattern <- gsub("([][(){}^$.|*+?\\\\])", "\\\\\\1", x) |
302 | 25x |
unique(df_N[[paste0(group_var, "_N")]])[grepl( |
303 | 25x |
paste0("^", regex_pattern), |
304 | 25x |
unique(df_N[[paste0(group_var, "_N")]]) |
305 |
)] |
|
306 |
}) |
|
307 | 9x |
df_N[[paste0(group_var, "_N")]] <- factor(df_N[[group_var]]) # nolint |
308 | 9x |
levels(df_N[[paste0(group_var, "_N")]]) <- unlist(matches) # nolint |
309 | ||
310 |
# strata_N should not be in colnames(df_stats) |
|
311 | 9x |
checkmate::assert_disjunct(strata_N, colnames(df_stats)) |
312 | ||
313 | 9x |
df_stats <- merge(x = df_stats, y = df_N[, c(group_var, strata_N)], by = group_var) |
314 | 5x |
} else if (!is.null(group_var)) { |
315 | 4x |
strata_N <- group_var # nolint |
316 |
} else { |
|
317 | 1x |
strata_N <- NULL # nolint |
318 |
} |
|
319 | ||
320 |
############################################### | |
|
321 |
# ---- Prepare certain plot's properties. ---- |
|
322 |
############################################### | |
|
323 |
# legend title |
|
324 | 14x |
if (is.null(legend_title) && !is.null(group_var) && legend_position != "none") { |
325 | 13x |
legend_title <- attr(df[[group_var]], "label") |
326 |
} |
|
327 | ||
328 |
# y label |
|
329 | 14x |
if (!is.null(y_lab)) { |
330 | 4x |
if (y_lab_add_paramcd) { |
331 | 4x |
y_lab <- paste(y_lab, unique(df[[paramcd]])) |
332 |
} |
|
333 | ||
334 | 4x |
if (y_lab_add_unit) { |
335 | 4x |
y_lab <- paste0(y_lab, " (", unique(df[[y_unit]]), ")") |
336 |
} |
|
337 | ||
338 | 4x |
y_lab <- trimws(y_lab) |
339 |
} |
|
340 | ||
341 |
# subtitle |
|
342 | 14x |
if (!is.null(subtitle)) { |
343 | 14x |
if (subtitle_add_paramcd) { |
344 | 14x |
subtitle <- paste(subtitle, unique(df[[paramcd]])) |
345 |
} |
|
346 | ||
347 | 14x |
if (subtitle_add_unit) { |
348 | 14x |
subtitle <- paste0(subtitle, " (", unique(df[[y_unit]]), ")") |
349 |
} |
|
350 | ||
351 | 14x |
subtitle <- trimws(subtitle) |
352 |
} |
|
353 | ||
354 |
############################### | |
|
355 |
# ---- Build plot object. ---- |
|
356 |
############################### | |
|
357 | 14x |
p <- ggplot2::ggplot( |
358 | 14x |
data = df_stats, |
359 | 14x |
mapping = ggplot2::aes( |
360 | 14x |
x = .data[[x]], y = .data[[mid]], |
361 | 14x |
color = if (is.null(strata_N)) NULL else .data[[strata_N]], |
362 | 14x |
shape = if (is.null(strata_N)) NULL else .data[[strata_N]], |
363 | 14x |
lty = if (is.null(strata_N)) NULL else .data[[strata_N]], |
364 | 14x |
group = if (is.null(strata_N)) NULL else .data[[strata_N]] |
365 |
) |
|
366 |
) |
|
367 | ||
368 | 14x |
if (!is.null(group_var) && nlevels(df_stats[[strata_N]]) > 6) { |
369 | 1x |
p <- p + |
370 | 1x |
scale_shape_manual(values = seq(15, 15 + nlevels(df_stats[[strata_N]]))) |
371 |
} |
|
372 | ||
373 | 14x |
if (!is.null(mid)) { |
374 |
# points |
|
375 | 14x |
if (grepl("p", mid_type, fixed = TRUE)) { |
376 | 14x |
p <- p + ggplot2::geom_point(position = position, size = mid_point_size, na.rm = TRUE) |
377 |
} |
|
378 | ||
379 |
# lines - plotted only if there is a strata grouping (group_var) |
|
380 | 14x |
if (grepl("l", mid_type, fixed = TRUE) && !is.null(strata_N)) { |
381 | 13x |
p <- p + ggplot2::geom_line(position = position, na.rm = TRUE) |
382 |
} |
|
383 |
} |
|
384 | ||
385 |
# interval |
|
386 | 14x |
if (!is.null(interval)) { |
387 | 14x |
p <- p + |
388 | 14x |
ggplot2::geom_errorbar( |
389 | 14x |
ggplot2::aes(ymin = .data[[whiskers[1]]], ymax = .data[[whiskers[max(1, length(whiskers))]]]), |
390 | 14x |
width = errorbar_width, |
391 | 14x |
position = position |
392 |
) |
|
393 | ||
394 | 14x |
if (length(whiskers) == 1) { # lwr or upr only; mid is then required |
395 |
# workaround as geom_errorbar does not provide single-direction whiskers |
|
396 | ! |
p <- p + |
397 | ! |
ggplot2::geom_linerange( |
398 | ! |
data = df_stats[!is.na(df_stats[[whiskers]]), ], # as na.rm =TRUE does not suppress warnings |
399 | ! |
ggplot2::aes(ymin = .data[[mid]], ymax = .data[[whiskers]]), |
400 | ! |
position = position, |
401 | ! |
na.rm = TRUE, |
402 | ! |
show.legend = FALSE |
403 |
) |
|
404 |
} |
|
405 |
} |
|
406 | ||
407 | 14x |
if (is.numeric(df_stats[[x]])) { |
408 | 1x |
if (length(xticks) == 1) xticks <- seq(from = min(df_stats[[x]]), to = max(df_stats[[x]]), by = xticks) |
409 | 1x |
p <- p + ggplot2::scale_x_continuous(breaks = if (!is.null(xticks)) xticks else waiver(), limits = xlim) |
410 |
} |
|
411 | ||
412 | 14x |
p <- p + |
413 | 14x |
ggplot2::scale_y_continuous(labels = scales::comma, limits = ylim) + |
414 | 14x |
ggplot2::labs( |
415 | 14x |
title = title, |
416 | 14x |
subtitle = subtitle, |
417 | 14x |
caption = caption, |
418 | 14x |
color = legend_title, |
419 | 14x |
lty = legend_title, |
420 | 14x |
shape = legend_title, |
421 | 14x |
x = x_lab, |
422 | 14x |
y = y_lab |
423 |
) |
|
424 | ||
425 | 14x |
if (!is.null(col)) { |
426 | 1x |
p <- p + |
427 | 1x |
ggplot2::scale_color_manual(values = col) |
428 |
} |
|
429 | 14x |
if (!is.null(linetype)) { |
430 | 1x |
p <- p + |
431 | 1x |
ggplot2::scale_linetype_manual(values = linetype) |
432 |
} |
|
433 | ||
434 | 14x |
if (!is.null(facet_var)) { |
435 | 1x |
p <- p + |
436 | 1x |
facet_grid(cols = vars(df_stats[[facet_var]])) |
437 |
} |
|
438 | ||
439 | 14x |
if (!is.null(ggtheme)) { |
440 | 14x |
p <- p + ggtheme |
441 |
} else { |
|
442 | ! |
p <- p + |
443 | ! |
ggplot2::theme_bw() + |
444 | ! |
ggplot2::theme( |
445 | ! |
legend.key.width = grid::unit(1, "cm"), |
446 | ! |
legend.position = legend_position, |
447 | ! |
legend.direction = ifelse( |
448 | ! |
legend_position %in% c("top", "bottom"), |
449 | ! |
"horizontal", |
450 | ! |
"vertical" |
451 |
) |
|
452 |
) |
|
453 |
} |
|
454 | ||
455 |
############################################################# | |
|
456 |
# ---- Optionally, add table to the bottom of the plot. ---- |
|
457 |
############################################################# | |
|
458 | 14x |
if (!is.null(table)) { |
459 | 6x |
df_stats_table <- df_grp %>% |
460 | 6x |
dplyr::summarise( |
461 | 6x |
h_format_row( |
462 | 6x |
x = sfun(.data[[y]], ...)[table], |
463 | 6x |
format = table_format, |
464 | 6x |
labels = table_labels |
465 |
), |
|
466 | 6x |
.groups = "drop" |
467 |
) |
|
468 | ||
469 | 6x |
stats_lev <- rev(setdiff(colnames(df_stats_table), c(group_var, x))) |
470 | ||
471 | 6x |
df_stats_table <- df_stats_table %>% |
472 | 6x |
tidyr::pivot_longer( |
473 | 6x |
cols = -dplyr::all_of(c(group_var, x)), |
474 | 6x |
names_to = "stat", |
475 | 6x |
values_to = "value", |
476 | 6x |
names_ptypes = list(stat = factor(levels = stats_lev)) |
477 |
) |
|
478 | ||
479 | 6x |
tbl <- ggplot2::ggplot( |
480 | 6x |
df_stats_table, |
481 | 6x |
ggplot2::aes(x = .data[[x]], y = .data[["stat"]], label = .data[["value"]]) |
482 |
) + |
|
483 | 6x |
ggplot2::geom_text(size = table_font_size) + |
484 | 6x |
ggplot2::theme_bw() + |
485 | 6x |
ggplot2::theme( |
486 | 6x |
panel.border = ggplot2::element_blank(), |
487 | 6x |
panel.grid.major = ggplot2::element_blank(), |
488 | 6x |
panel.grid.minor = ggplot2::element_blank(), |
489 | 6x |
axis.ticks = ggplot2::element_blank(), |
490 | 6x |
axis.title = ggplot2::element_blank(), |
491 | 6x |
axis.text.x = ggplot2::element_blank(), |
492 | 6x |
axis.text.y = ggplot2::element_text( |
493 | 6x |
size = table_font_size * ggplot2::.pt, |
494 | 6x |
margin = ggplot2::margin(t = 0, r = 0, b = 0, l = 5) |
495 |
), |
|
496 | 6x |
strip.text = ggplot2::element_text(hjust = 0), |
497 | 6x |
strip.text.x = ggplot2::element_text( |
498 | 6x |
size = table_font_size * ggplot2::.pt, |
499 | 6x |
margin = ggplot2::margin(1.5, 0, 1.5, 0, "pt") |
500 |
), |
|
501 | 6x |
strip.background = ggplot2::element_rect(fill = "grey95", color = NA), |
502 | 6x |
legend.position = "none" |
503 |
) |
|
504 | ||
505 | 6x |
if (!is.null(group_var)) { |
506 | 6x |
tbl <- tbl + ggplot2::facet_wrap(facets = group_var, ncol = 1) |
507 |
} |
|
508 | ||
509 | 6x |
if (!as_list) { |
510 |
# align plot and table |
|
511 | 5x |
cowplot::plot_grid( |
512 | 5x |
p, |
513 | 5x |
tbl, |
514 | 5x |
ncol = 1, |
515 | 5x |
align = "v", |
516 | 5x |
axis = "tblr", |
517 | 5x |
rel_heights = c(rel_height_plot, 1 - rel_height_plot) |
518 |
) |
|
519 |
} else { |
|
520 | 1x |
list(plot = p, table = tbl) |
521 |
} |
|
522 |
} else { |
|
523 | 8x |
p |
524 |
} |
|
525 |
} |
|
526 | ||
527 |
#' Helper function to format the optional `g_lineplot` table |
|
528 |
#' |
|
529 |
#' @description `r lifecycle::badge("stable")` |
|
530 |
#' |
|
531 |
#' @param x (named `list`)\cr list of numerical values to be formatted and optionally labeled. |
|
532 |
#' Elements of `x` must be `numeric` vectors. |
|
533 |
#' @param format (named `character` or `NULL`)\cr format patterns for `x`. Names of the `format` must |
|
534 |
#' match the names of `x`. This parameter is passed directly to the `rtables::format_rcell` |
|
535 |
#' function through the `format` parameter. |
|
536 |
#' @param labels (named `character` or `NULL`)\cr optional labels for `x`. Names of the `labels` must |
|
537 |
#' match the names of `x`. When a label is not specified for an element of `x`, |
|
538 |
#' then this function tries to use `label` or `names` (in this order) attribute of that element |
|
539 |
#' (depending on which one exists and it is not `NULL` or `NA` or `NaN`). If none of these attributes |
|
540 |
#' are attached to a given element of `x`, then the label is automatically generated. |
|
541 |
#' |
|
542 |
#' @return A single row `data.frame` object. |
|
543 |
#' |
|
544 |
#' @examples |
|
545 |
#' mean_ci <- c(48, 51) |
|
546 |
#' x <- list(mean = 50, mean_ci = mean_ci) |
|
547 |
#' format <- c(mean = "xx.x", mean_ci = "(xx.xx, xx.xx)") |
|
548 |
#' labels <- c(mean = "My Mean") |
|
549 |
#' h_format_row(x, format, labels) |
|
550 |
#' |
|
551 |
#' attr(mean_ci, "label") <- "Mean 95% CI" |
|
552 |
#' x <- list(mean = 50, mean_ci = mean_ci) |
|
553 |
#' h_format_row(x, format, labels) |
|
554 |
#' |
|
555 |
#' @export |
|
556 |
h_format_row <- function(x, format, labels = NULL) { |
|
557 |
# cell: one row, one column data.frame |
|
558 | 110x |
format_cell <- function(x, format, label = NULL) { |
559 | 292x |
fc <- format_rcell(x = x, format = format) |
560 | 292x |
if (is.na(fc)) { |
561 | ! |
fc <- "NA" |
562 |
} |
|
563 | 292x |
x_label <- attr(x, "label") |
564 | 292x |
if (!is.null(label) && !is.na(label)) { |
565 | 290x |
names(fc) <- label |
566 | 2x |
} else if (!is.null(x_label) && !is.na(x_label)) { |
567 | 1x |
names(fc) <- x_label |
568 | 1x |
} else if (length(x) == length(fc)) { |
569 | ! |
names(fc) <- names(x) |
570 |
} |
|
571 | 292x |
as.data.frame(t(fc)) |
572 |
} |
|
573 | ||
574 | 110x |
row <- do.call( |
575 | 110x |
cbind, |
576 | 110x |
lapply( |
577 | 110x |
names(x), function(xn) format_cell(x[[xn]], format = format[[xn]], label = labels[xn]) |
578 |
) |
|
579 |
) |
|
580 | ||
581 | 110x |
row |
582 |
} |
|
583 | ||
584 |
#' Control function for `g_lineplot()` |
|
585 |
#' |
|
586 |
#' @description `r lifecycle::badge("stable")` |
|
587 |
#' |
|
588 |
#' Default values for `variables` parameter in `g_lineplot` function. |
|
589 |
#' A variable's default value can be overwritten for any variable. |
|
590 |
#' |
|
591 |
#' @param x (`string`)\cr x-variable name. |
|
592 |
#' @param y (`string`)\cr y-variable name. |
|
593 |
#' @param group_var (`string` or `NA`)\cr group variable name. |
|
594 |
#' @param subject_var (`string` or `NA`)\cr subject variable name. |
|
595 |
#' @param facet_var (`string` or `NA`)\cr faceting variable name. |
|
596 |
#' @param paramcd (`string` or `NA`)\cr parameter code variable name. |
|
597 |
#' @param y_unit (`string` or `NA`)\cr y-axis unit variable name. |
|
598 |
#' |
|
599 |
#' @return A named character vector of variable names. |
|
600 |
#' |
|
601 |
#' @examples |
|
602 |
#' control_lineplot_vars() |
|
603 |
#' control_lineplot_vars(group_var = NA) |
|
604 |
#' |
|
605 |
#' @export |
|
606 |
control_lineplot_vars <- function(x = "AVISIT", |
|
607 |
y = "AVAL", |
|
608 |
group_var = "ARM", |
|
609 |
facet_var = NA, |
|
610 |
paramcd = "PARAMCD", |
|
611 |
y_unit = "AVALU", |
|
612 |
subject_var = "USUBJID") { |
|
613 | 17x |
checkmate::assert_string(x) |
614 | 17x |
checkmate::assert_string(y) |
615 | 17x |
checkmate::assert_string(group_var, na.ok = TRUE, null.ok = TRUE) |
616 | 17x |
checkmate::assert_string(facet_var, na.ok = TRUE, null.ok = TRUE) |
617 | 17x |
checkmate::assert_string(subject_var, na.ok = TRUE, null.ok = TRUE) |
618 | 17x |
checkmate::assert_string(paramcd, na.ok = TRUE, null.ok = TRUE) |
619 | 17x |
checkmate::assert_string(y_unit, na.ok = TRUE, null.ok = TRUE) |
620 | ||
621 | 17x |
variables <- c( |
622 | 17x |
x = x, y = y, group_var = group_var, paramcd = paramcd, |
623 | 17x |
y_unit = y_unit, subject_var = subject_var, facet_var = facet_var |
624 |
) |
|
625 | 17x |
return(variables) |
626 |
} |
1 |
#' Cox proportional hazards regression |
|
2 |
#' |
|
3 |
#' @description `r lifecycle::badge("stable")` |
|
4 |
#' |
|
5 |
#' Fits a Cox regression model and estimates hazard ratio to describe the effect size in a survival analysis. |
|
6 |
#' |
|
7 |
#' @inheritParams argument_convention |
|
8 |
#' @param .stats (`character`)\cr statistics to select for the table. |
|
9 |
#' |
|
10 |
#' Options are: ``r shQuote(get_stats("summarize_coxreg"), type = "sh")`` |
|
11 |
#' |
|
12 |
#' @details Cox models are the most commonly used methods to estimate the magnitude of |
|
13 |
#' the effect in survival analysis. It assumes proportional hazards: the ratio |
|
14 |
#' of the hazards between groups (e.g., two arms) is constant over time. |
|
15 |
#' This ratio is referred to as the "hazard ratio" (HR) and is one of the |
|
16 |
#' most commonly reported metrics to describe the effect size in survival |
|
17 |
#' analysis (NEST Team, 2020). |
|
18 |
#' |
|
19 |
#' @seealso [fit_coxreg] for relevant fitting functions, [h_cox_regression] for relevant |
|
20 |
#' helper functions, and [tidy_coxreg] for custom tidy methods. |
|
21 |
#' |
|
22 |
#' @examples |
|
23 |
#' library(survival) |
|
24 |
#' |
|
25 |
#' # Testing dataset [survival::bladder]. |
|
26 |
#' set.seed(1, kind = "Mersenne-Twister") |
|
27 |
#' dta_bladder <- with( |
|
28 |
#' data = bladder[bladder$enum < 5, ], |
|
29 |
#' tibble::tibble( |
|
30 |
#' TIME = stop, |
|
31 |
#' STATUS = event, |
|
32 |
#' ARM = as.factor(rx), |
|
33 |
#' COVAR1 = as.factor(enum) %>% formatters::with_label("A Covariate Label"), |
|
34 |
#' COVAR2 = factor( |
|
35 |
#' sample(as.factor(enum)), |
|
36 |
#' levels = 1:4, labels = c("F", "F", "M", "M") |
|
37 |
#' ) %>% formatters::with_label("Sex (F/M)") |
|
38 |
#' ) |
|
39 |
#' ) |
|
40 |
#' dta_bladder$AGE <- sample(20:60, size = nrow(dta_bladder), replace = TRUE) |
|
41 |
#' dta_bladder$STUDYID <- factor("X") |
|
42 |
#' |
|
43 |
#' u1_variables <- list( |
|
44 |
#' time = "TIME", event = "STATUS", arm = "ARM", covariates = c("COVAR1", "COVAR2") |
|
45 |
#' ) |
|
46 |
#' |
|
47 |
#' u2_variables <- list(time = "TIME", event = "STATUS", covariates = c("COVAR1", "COVAR2")) |
|
48 |
#' |
|
49 |
#' m1_variables <- list( |
|
50 |
#' time = "TIME", event = "STATUS", arm = "ARM", covariates = c("COVAR1", "COVAR2") |
|
51 |
#' ) |
|
52 |
#' |
|
53 |
#' m2_variables <- list(time = "TIME", event = "STATUS", covariates = c("COVAR1", "COVAR2")) |
|
54 |
#' |
|
55 |
#' @name cox_regression |
|
56 |
#' @order 1 |
|
57 |
NULL |
|
58 | ||
59 |
#' @describeIn cox_regression Statistics function that transforms results tabulated |
|
60 |
#' from [fit_coxreg_univar()] or [fit_coxreg_multivar()] into a list. |
|
61 |
#' |
|
62 |
#' @param model_df (`data.frame`)\cr contains the resulting model fit from a [fit_coxreg] |
|
63 |
#' function with tidying applied via [broom::tidy()]. |
|
64 |
#' @param .stats (`character`)\cr the names of statistics to be reported among: |
|
65 |
#' * `n`: number of observations (univariate only) |
|
66 |
#' * `hr`: hazard ratio |
|
67 |
#' * `ci`: confidence interval |
|
68 |
#' * `pval`: p-value of the treatment effect |
|
69 |
#' * `pval_inter`: p-value of the interaction effect between the treatment and the covariate (univariate only) |
|
70 |
#' @param .which_vars (`character`)\cr which rows should statistics be returned for from the given model. |
|
71 |
#' Defaults to `"all"`. Other options include `"var_main"` for main effects, `"inter"` for interaction effects, |
|
72 |
#' and `"multi_lvl"` for multivariate model covariate level rows. When `.which_vars` is `"all"`, specific |
|
73 |
#' variables can be selected by specifying `.var_nms`. |
|
74 |
#' @param .var_nms (`character`)\cr the `term` value of rows in `df` for which `.stats` should be returned. Typically |
|
75 |
#' this is the name of a variable. If using variable labels, `var` should be a vector of both the desired |
|
76 |
#' variable name and the variable label in that order to see all `.stats` related to that variable. When `.which_vars` |
|
77 |
#' is `"var_main"`, `.var_nms` should be only the variable name. |
|
78 |
#' |
|
79 |
#' @return |
|
80 |
#' * `s_coxreg()` returns the selected statistic for from the Cox regression model for the selected variable(s). |
|
81 |
#' |
|
82 |
#' @examples |
|
83 |
#' # s_coxreg |
|
84 |
#' |
|
85 |
#' # Univariate |
|
86 |
#' univar_model <- fit_coxreg_univar(variables = u1_variables, data = dta_bladder) |
|
87 |
#' df1 <- broom::tidy(univar_model) |
|
88 |
#' |
|
89 |
#' s_coxreg(model_df = df1, .stats = "hr") |
|
90 |
#' |
|
91 |
#' # Univariate with interactions |
|
92 |
#' univar_model_inter <- fit_coxreg_univar( |
|
93 |
#' variables = u1_variables, control = control_coxreg(interaction = TRUE), data = dta_bladder |
|
94 |
#' ) |
|
95 |
#' df1_inter <- broom::tidy(univar_model_inter) |
|
96 |
#' |
|
97 |
#' s_coxreg(model_df = df1_inter, .stats = "hr", .which_vars = "inter", .var_nms = "COVAR1") |
|
98 |
#' |
|
99 |
#' # Univariate without treatment arm - only "COVAR2" covariate effects |
|
100 |
#' univar_covs_model <- fit_coxreg_univar(variables = u2_variables, data = dta_bladder) |
|
101 |
#' df1_covs <- broom::tidy(univar_covs_model) |
|
102 |
#' |
|
103 |
#' s_coxreg(model_df = df1_covs, .stats = "hr", .var_nms = c("COVAR2", "Sex (F/M)")) |
|
104 |
#' |
|
105 |
#' # Multivariate. |
|
106 |
#' multivar_model <- fit_coxreg_multivar(variables = m1_variables, data = dta_bladder) |
|
107 |
#' df2 <- broom::tidy(multivar_model) |
|
108 |
#' |
|
109 |
#' s_coxreg(model_df = df2, .stats = "pval", .which_vars = "var_main", .var_nms = "COVAR1") |
|
110 |
#' s_coxreg( |
|
111 |
#' model_df = df2, .stats = "pval", .which_vars = "multi_lvl", |
|
112 |
#' .var_nms = c("COVAR1", "A Covariate Label") |
|
113 |
#' ) |
|
114 |
#' |
|
115 |
#' # Multivariate without treatment arm - only "COVAR1" main effect |
|
116 |
#' multivar_covs_model <- fit_coxreg_multivar(variables = m2_variables, data = dta_bladder) |
|
117 |
#' df2_covs <- broom::tidy(multivar_covs_model) |
|
118 |
#' |
|
119 |
#' s_coxreg(model_df = df2_covs, .stats = "hr") |
|
120 |
#' |
|
121 |
#' @export |
|
122 |
s_coxreg <- function(model_df, .stats, .which_vars = "all", .var_nms = NULL) { |
|
123 | 291x |
assert_df_with_variables(model_df, list(term = "term", stat = .stats)) |
124 | 291x |
checkmate::assert_multi_class(model_df$term, classes = c("factor", "character")) |
125 | 291x |
model_df$term <- as.character(model_df$term) |
126 | 291x |
.var_nms <- .var_nms[!is.na(.var_nms)] |
127 | ||
128 | 289x |
if (length(.var_nms) > 0) model_df <- model_df[model_df$term %in% .var_nms, ] |
129 | 69x |
if (.which_vars == "multi_lvl") model_df$term <- tail(.var_nms, 1) |
130 | ||
131 |
# We need a list with names corresponding to the stats to display of equal length to the list of stats. |
|
132 | 291x |
y <- split(model_df, f = model_df$term, drop = FALSE) |
133 | 291x |
y <- stats::setNames(y, nm = rep(.stats, length(y))) |
134 | ||
135 | 291x |
if (.which_vars == "var_main") { |
136 | 128x |
y <- lapply(y, function(x) x[1, ]) # only main effect |
137 | 163x |
} else if (.which_vars %in% c("inter", "multi_lvl")) { |
138 | 120x |
y <- lapply(y, function(x) if (nrow(y[[1]]) > 1) x[-1, ] else x) # exclude main effect |
139 |
} |
|
140 | ||
141 | 291x |
lapply( |
142 | 291x |
X = y, |
143 | 291x |
FUN = function(x) { |
144 | 295x |
z <- as.list(x[[.stats]]) |
145 | 295x |
stats::setNames(z, nm = x$term_label) |
146 |
} |
|
147 |
) |
|
148 |
} |
|
149 | ||
150 |
#' @describeIn cox_regression Analysis function which is used as `afun` in [rtables::analyze()] |
|
151 |
#' and `cfun` in [rtables::summarize_row_groups()] within `summarize_coxreg()`. |
|
152 |
#' |
|
153 |
#' @param eff (`flag`)\cr whether treatment effect should be calculated. Defaults to `FALSE`. |
|
154 |
#' @param var_main (`flag`)\cr whether main effects should be calculated. Defaults to `FALSE`. |
|
155 |
#' @param na_str (`string`)\cr custom string to replace all `NA` values with. Defaults to `""`. |
|
156 |
#' @param cache_env (`environment`)\cr an environment object used to cache the regression model in order to |
|
157 |
#' avoid repeatedly fitting the same model for every row in the table. Defaults to `NULL` (no caching). |
|
158 |
#' @param varlabels (`list`)\cr a named list corresponds to the names of variables found in data, passed |
|
159 |
#' as a named list and corresponding to time, event, arm, strata, and covariates terms. If arm is missing |
|
160 |
#' from variables, then only Cox model(s) including the covariates will be fitted and the corresponding |
|
161 |
#' effect estimates will be tabulated later. |
|
162 |
#' |
|
163 |
#' @return |
|
164 |
#' * `a_coxreg()` returns formatted [rtables::CellValue()]. |
|
165 |
#' |
|
166 |
#' @examples |
|
167 |
#' a_coxreg( |
|
168 |
#' df = dta_bladder, |
|
169 |
#' labelstr = "Label 1", |
|
170 |
#' variables = u1_variables, |
|
171 |
#' .spl_context = list(value = "COVAR1"), |
|
172 |
#' .stats = "n", |
|
173 |
#' .formats = "xx" |
|
174 |
#' ) |
|
175 |
#' |
|
176 |
#' a_coxreg( |
|
177 |
#' df = dta_bladder, |
|
178 |
#' labelstr = "", |
|
179 |
#' variables = u1_variables, |
|
180 |
#' .spl_context = list(value = "COVAR2"), |
|
181 |
#' .stats = "pval", |
|
182 |
#' .formats = "xx.xxxx" |
|
183 |
#' ) |
|
184 |
#' |
|
185 |
#' @export |
|
186 |
a_coxreg <- function(df, |
|
187 |
labelstr, |
|
188 |
eff = FALSE, |
|
189 |
var_main = FALSE, |
|
190 |
multivar = FALSE, |
|
191 |
variables, |
|
192 |
at = list(), |
|
193 |
control = control_coxreg(), |
|
194 |
.spl_context, |
|
195 |
.stats, |
|
196 |
.formats, |
|
197 |
.indent_mods = NULL, |
|
198 |
na_str = "", |
|
199 |
cache_env = NULL) { |
|
200 | 288x |
cov_no_arm <- !multivar && !"arm" %in% names(variables) && control$interaction # special case: univar no arm |
201 | 288x |
cov <- tail(.spl_context$value, 1) # current variable/covariate |
202 | 288x |
var_lbl <- formatters::var_labels(df)[cov] # check for df labels |
203 | 288x |
if (length(labelstr) > 1) { |
204 | 8x |
labelstr <- if (cov %in% names(labelstr)) labelstr[[cov]] else var_lbl # use df labels if none |
205 | 280x |
} else if (!is.na(var_lbl) && labelstr == cov && cov %in% variables$covariates) { |
206 | 67x |
labelstr <- var_lbl |
207 |
} |
|
208 | 288x |
if (eff || multivar || cov_no_arm) { |
209 | 143x |
control$interaction <- FALSE |
210 |
} else { |
|
211 | 145x |
variables$covariates <- cov |
212 | 50x |
if (var_main) control$interaction <- TRUE |
213 |
} |
|
214 | ||
215 | 288x |
if (is.null(cache_env[[cov]])) { |
216 | 47x |
if (!multivar) { |
217 | 32x |
model <- fit_coxreg_univar(variables = variables, data = df, at = at, control = control) %>% broom::tidy() |
218 |
} else { |
|
219 | 15x |
model <- fit_coxreg_multivar(variables = variables, data = df, control = control) %>% broom::tidy() |
220 |
} |
|
221 | 47x |
cache_env[[cov]] <- model |
222 |
} else { |
|
223 | 241x |
model <- cache_env[[cov]] |
224 |
} |
|
225 | 148x |
if (!multivar && !var_main) model[, "pval_inter"] <- NA_real_ |
226 | ||
227 | 288x |
if (cov_no_arm || (!cov_no_arm && !"arm" %in% names(variables) && is.numeric(df[[cov]]))) { |
228 | 15x |
multivar <- TRUE |
229 | 3x |
if (!cov_no_arm) var_main <- TRUE |
230 |
} |
|
231 | ||
232 | 288x |
vars_coxreg <- list(which_vars = "all", var_nms = NULL) |
233 | 288x |
if (eff) { |
234 | 65x |
if (multivar && !var_main) { # multivar treatment level |
235 | 12x |
var_lbl_arm <- formatters::var_labels(df)[[variables$arm]] |
236 | 12x |
vars_coxreg[c("var_nms", "which_vars")] <- list(c(variables$arm, var_lbl_arm), "multi_lvl") |
237 |
} else { # treatment effect |
|
238 | 53x |
vars_coxreg["var_nms"] <- variables$arm |
239 | 12x |
if (var_main) vars_coxreg["which_vars"] <- "var_main" |
240 |
} |
|
241 |
} else { |
|
242 | 223x |
if (!multivar || (multivar && var_main && !is.numeric(df[[cov]]))) { # covariate effect/level |
243 | 166x |
vars_coxreg[c("var_nms", "which_vars")] <- list(cov, "var_main") |
244 | 57x |
} else if (multivar) { # multivar covariate level |
245 | 57x |
vars_coxreg[c("var_nms", "which_vars")] <- list(c(cov, var_lbl), "multi_lvl") |
246 | 12x |
if (var_main) model[cov, .stats] <- NA_real_ |
247 |
} |
|
248 | 50x |
if (!multivar && !var_main && control$interaction) vars_coxreg["which_vars"] <- "inter" # interaction effect |
249 |
} |
|
250 | 288x |
var_vals <- s_coxreg(model, .stats, .which_vars = vars_coxreg$which_vars, .var_nms = vars_coxreg$var_nms)[[1]] |
251 | 288x |
var_names <- if (all(grepl("\\(reference = ", names(var_vals))) && labelstr != tail(.spl_context$value, 1)) { |
252 | 27x |
paste(c(labelstr, tail(strsplit(names(var_vals), " ")[[1]], 3)), collapse = " ") # "reference" main effect labels |
253 | 288x |
} else if ((!multivar && !eff && !(!var_main && control$interaction) && nchar(labelstr) > 0) || |
254 | 288x |
(multivar && var_main && is.numeric(df[[cov]]))) { # nolint |
255 | 71x |
labelstr # other main effect labels |
256 | 288x |
} else if (multivar && !eff && !var_main && is.numeric(df[[cov]])) { |
257 | 12x |
"All" # multivar numeric covariate |
258 |
} else { |
|
259 | 178x |
names(var_vals) |
260 |
} |
|
261 | 288x |
in_rows( |
262 | 288x |
.list = var_vals, .names = var_names, .labels = var_names, .indent_mods = .indent_mods, |
263 | 288x |
.formats = stats::setNames(rep(.formats, length(var_names)), var_names), |
264 | 288x |
.format_na_strs = stats::setNames(rep(na_str, length(var_names)), var_names) |
265 |
) |
|
266 |
} |
|
267 | ||
268 |
#' @describeIn cox_regression Layout-creating function which creates a Cox regression summary table |
|
269 |
#' layout. This function is a wrapper for several `rtables` layouting functions. This function |
|
270 |
#' is a wrapper for [rtables::analyze_colvars()] and [rtables::summarize_row_groups()]. |
|
271 |
#' |
|
272 |
#' @inheritParams fit_coxreg_univar |
|
273 |
#' @param multivar (`flag`)\cr whether multivariate Cox regression should run (defaults to `FALSE`), otherwise |
|
274 |
#' univariate Cox regression will run. |
|
275 |
#' @param common_var (`string`)\cr the name of a factor variable in the dataset which takes the same value |
|
276 |
#' for all rows. This should be created during pre-processing if no such variable currently exists. |
|
277 |
#' @param .section_div (`string` or `NA`)\cr string which should be repeated as a section divider between sections. |
|
278 |
#' Defaults to `NA` for no section divider. If a vector of two strings are given, the first will be used between |
|
279 |
#' treatment and covariate sections and the second between different covariates. |
|
280 |
#' |
|
281 |
#' @return |
|
282 |
#' * `summarize_coxreg()` returns a layout object suitable for passing to further layouting functions, |
|
283 |
#' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add a Cox regression table |
|
284 |
#' containing the chosen statistics to the table layout. |
|
285 |
#' |
|
286 |
#' @seealso [fit_coxreg_univar()] and [fit_coxreg_multivar()] which also take the `variables`, `data`, |
|
287 |
#' `at` (univariate only), and `control` arguments but return unformatted univariate and multivariate |
|
288 |
#' Cox regression models, respectively. |
|
289 |
#' |
|
290 |
#' @examples |
|
291 |
#' # summarize_coxreg |
|
292 |
#' |
|
293 |
#' result_univar <- basic_table() %>% |
|
294 |
#' summarize_coxreg(variables = u1_variables) %>% |
|
295 |
#' build_table(dta_bladder) |
|
296 |
#' result_univar |
|
297 |
#' |
|
298 |
#' result_univar_covs <- basic_table() %>% |
|
299 |
#' summarize_coxreg( |
|
300 |
#' variables = u2_variables, |
|
301 |
#' ) %>% |
|
302 |
#' build_table(dta_bladder) |
|
303 |
#' result_univar_covs |
|
304 |
#' |
|
305 |
#' result_multivar <- basic_table() %>% |
|
306 |
#' summarize_coxreg( |
|
307 |
#' variables = m1_variables, |
|
308 |
#' multivar = TRUE, |
|
309 |
#' ) %>% |
|
310 |
#' build_table(dta_bladder) |
|
311 |
#' result_multivar |
|
312 |
#' |
|
313 |
#' result_multivar_covs <- basic_table() %>% |
|
314 |
#' summarize_coxreg( |
|
315 |
#' variables = m2_variables, |
|
316 |
#' multivar = TRUE, |
|
317 |
#' varlabels = c("Covariate 1", "Covariate 2") # custom labels |
|
318 |
#' ) %>% |
|
319 |
#' build_table(dta_bladder) |
|
320 |
#' result_multivar_covs |
|
321 |
#' |
|
322 |
#' @export |
|
323 |
#' @order 2 |
|
324 |
summarize_coxreg <- function(lyt, |
|
325 |
variables, |
|
326 |
control = control_coxreg(), |
|
327 |
at = list(), |
|
328 |
multivar = FALSE, |
|
329 |
common_var = "STUDYID", |
|
330 |
.stats = c("n", "hr", "ci", "pval", "pval_inter"), |
|
331 |
.formats = c( |
|
332 |
n = "xx", hr = "xx.xx", ci = "(xx.xx, xx.xx)", |
|
333 |
pval = "x.xxxx | (<0.0001)", pval_inter = "x.xxxx | (<0.0001)" |
|
334 |
), |
|
335 |
varlabels = NULL, |
|
336 |
.indent_mods = NULL, |
|
337 |
na_str = "", |
|
338 |
.section_div = NA_character_) { |
|
339 | 16x |
if (multivar && control$interaction) { |
340 | 1x |
warning(paste( |
341 | 1x |
"Interactions are not available for multivariate cox regression using summarize_coxreg.", |
342 | 1x |
"The model will be calculated without interaction effects." |
343 |
)) |
|
344 |
} |
|
345 | 16x |
if (control$interaction && !"arm" %in% names(variables)) { |
346 | 1x |
stop("To include interactions please specify 'arm' in variables.") |
347 |
} |
|
348 | ||
349 | 15x |
.stats <- if (!"arm" %in% names(variables) || multivar) { # only valid statistics |
350 | 6x |
intersect(c("hr", "ci", "pval"), .stats) |
351 | 15x |
} else if (control$interaction) { |
352 | 5x |
intersect(c("n", "hr", "ci", "pval", "pval_inter"), .stats) |
353 |
} else { |
|
354 | 4x |
intersect(c("n", "hr", "ci", "pval"), .stats) |
355 |
} |
|
356 | 15x |
stat_labels <- c( |
357 | 15x |
n = "n", hr = "Hazard Ratio", ci = paste0(control$conf_level * 100, "% CI"), |
358 | 15x |
pval = "p-value", pval_inter = "Interaction p-value" |
359 |
) |
|
360 | 15x |
stat_labels <- stat_labels[names(stat_labels) %in% .stats] |
361 | 15x |
.formats <- .formats[names(.formats) %in% .stats] |
362 | 15x |
env <- new.env() # create caching environment |
363 | ||
364 | 15x |
lyt <- lyt %>% |
365 | 15x |
split_cols_by_multivar( |
366 | 15x |
vars = rep(common_var, length(.stats)), |
367 | 15x |
varlabels = stat_labels, |
368 | 15x |
extra_args = list( |
369 | 15x |
.stats = .stats, .formats = .formats, .indent_mods = .indent_mods, na_str = rep(na_str, length(.stats)), |
370 | 15x |
cache_env = replicate(length(.stats), list(env)) |
371 |
) |
|
372 |
) |
|
373 | ||
374 | 15x |
if ("arm" %in% names(variables)) { # treatment effect |
375 | 13x |
lyt <- lyt %>% |
376 | 13x |
split_rows_by( |
377 | 13x |
common_var, |
378 | 13x |
split_label = "Treatment:", |
379 | 13x |
label_pos = "visible", |
380 | 13x |
child_labels = "hidden", |
381 | 13x |
section_div = head(.section_div, 1) |
382 |
) |
|
383 | 13x |
if (!multivar) { |
384 | 9x |
lyt <- lyt %>% |
385 | 9x |
analyze_colvars( |
386 | 9x |
afun = a_coxreg, |
387 | 9x |
na_str = na_str, |
388 | 9x |
extra_args = list( |
389 | 9x |
variables = variables, control = control, multivar = multivar, eff = TRUE, var_main = multivar, |
390 | 9x |
labelstr = "" |
391 |
) |
|
392 |
) |
|
393 |
} else { # treatment level effects |
|
394 | 4x |
lyt <- lyt %>% |
395 | 4x |
summarize_row_groups( |
396 | 4x |
cfun = a_coxreg, |
397 | 4x |
na_str = na_str, |
398 | 4x |
extra_args = list( |
399 | 4x |
variables = variables, control = control, multivar = multivar, eff = TRUE, var_main = multivar |
400 |
) |
|
401 |
) %>% |
|
402 | 4x |
analyze_colvars( |
403 | 4x |
afun = a_coxreg, |
404 | 4x |
na_str = na_str, |
405 | 4x |
extra_args = list(eff = TRUE, control = control, variables = variables, multivar = multivar, labelstr = "") |
406 |
) |
|
407 |
} |
|
408 |
} |
|
409 | ||
410 | 15x |
if ("covariates" %in% names(variables)) { # covariate main effects |
411 | 15x |
lyt <- lyt %>% |
412 | 15x |
split_rows_by_multivar( |
413 | 15x |
vars = variables$covariates, |
414 | 15x |
varlabels = varlabels, |
415 | 15x |
split_label = "Covariate:", |
416 | 15x |
nested = FALSE, |
417 | 15x |
child_labels = if (multivar || control$interaction || !"arm" %in% names(variables)) "default" else "hidden", |
418 | 15x |
section_div = tail(.section_div, 1) |
419 |
) |
|
420 | 15x |
if (multivar || control$interaction || !"arm" %in% names(variables)) { |
421 | 11x |
lyt <- lyt %>% |
422 | 11x |
summarize_row_groups( |
423 | 11x |
cfun = a_coxreg, |
424 | 11x |
na_str = na_str, |
425 | 11x |
extra_args = list( |
426 | 11x |
variables = variables, at = at, control = control, multivar = multivar, |
427 | 11x |
var_main = if (multivar) multivar else control$interaction |
428 |
) |
|
429 |
) |
|
430 |
} else { |
|
431 | 1x |
if (!is.null(varlabels)) names(varlabels) <- variables$covariates |
432 | 4x |
lyt <- lyt %>% |
433 | 4x |
analyze_colvars( |
434 | 4x |
afun = a_coxreg, |
435 | 4x |
na_str = na_str, |
436 | 4x |
extra_args = list( |
437 | 4x |
variables = variables, at = at, control = control, multivar = multivar, |
438 | 4x |
var_main = if (multivar) multivar else control$interaction, |
439 | 4x |
labelstr = if (is.null(varlabels)) "" else varlabels |
440 |
) |
|
441 |
) |
|
442 |
} |
|
443 | ||
444 | 2x |
if (!"arm" %in% names(variables)) control$interaction <- TRUE # special case: univar no arm |
445 | 15x |
if (multivar || control$interaction) { # covariate level effects |
446 | 11x |
lyt <- lyt %>% |
447 | 11x |
analyze_colvars( |
448 | 11x |
afun = a_coxreg, |
449 | 11x |
na_str = na_str, |
450 | 11x |
extra_args = list(variables = variables, at = at, control = control, multivar = multivar, labelstr = ""), |
451 | 11x |
indent_mod = if (!"arm" %in% names(variables) || multivar) 0L else -1L |
452 |
) |
|
453 |
} |
|
454 |
} |
|
455 | ||
456 | 15x |
lyt |
457 |
} |
1 |
#' Count patients with abnormal analysis range values by baseline status |
|
2 |
#' |
|
3 |
#' @description `r lifecycle::badge("stable")` |
|
4 |
#' |
|
5 |
#' The analyze function [count_abnormal_by_baseline()] creates a layout element to count patients with abnormal |
|
6 |
#' analysis range values, categorized by baseline status. |
|
7 |
#' |
|
8 |
#' This function analyzes primary analysis variable `var` which indicates abnormal range results. Additional |
|
9 |
#' analysis variables that can be supplied as a list via the `variables` parameter are `id` (defaults to |
|
10 |
#' `USUBJID`), a variable to indicate unique subject identifiers, and `baseline` (defaults to `BNRIND`), a |
|
11 |
#' variable to indicate baseline reference ranges. |
|
12 |
#' |
|
13 |
#' For each direction specified via the `abnormal` parameter (e.g. High or Low), we condition on baseline |
|
14 |
#' range result and count patients in the numerator and denominator as follows for each of the following |
|
15 |
#' categories: |
|
16 |
#' * `Not <abnormality>` |
|
17 |
#' * `num`: The number of patients without abnormality at baseline (excluding those with missing baseline) |
|
18 |
#' and with at least one abnormality post-baseline. |
|
19 |
#' * `denom`: The number of patients without abnormality at baseline (excluding those with missing baseline). |
|
20 |
#' * `<Abnormality>` |
|
21 |
#' * `num`: The number of patients with abnormality as baseline and at least one abnormality post-baseline. |
|
22 |
#' * `denom`: The number of patients with abnormality at baseline. |
|
23 |
#' * `Total` |
|
24 |
#' * `num`: The number of patients with at least one post-baseline record and at least one abnormality |
|
25 |
#' post-baseline. |
|
26 |
#' * `denom`: The number of patients with at least one post-baseline record. |
|
27 |
#' |
|
28 |
#' This function assumes that `df` has been filtered to only include post-baseline records. |
|
29 |
#' |
|
30 |
#' @inheritParams argument_convention |
|
31 |
#' @param abnormal (`character`)\cr values identifying the abnormal range level(s) in `.var`. |
|
32 |
#' @param .stats (`character`)\cr statistics to select for the table. |
|
33 |
#' |
|
34 |
#' Options are: ``r shQuote(get_stats("abnormal_by_baseline"), type = "sh")`` |
|
35 |
#' |
|
36 |
#' @note |
|
37 |
#' * `df` should be filtered to include only post-baseline records. |
|
38 |
#' * If the baseline variable or analysis variable contains `NA` records, it is expected that `df` has been |
|
39 |
#' pre-processed using [df_explicit_na()] or [explicit_na()]. |
|
40 |
#' |
|
41 |
#' @seealso Relevant description function [d_count_abnormal_by_baseline()]. |
|
42 |
#' |
|
43 |
#' @name abnormal_by_baseline |
|
44 |
#' @order 1 |
|
45 |
NULL |
|
46 | ||
47 |
#' @describeIn abnormal_by_baseline Statistics function for a single `abnormal` level. |
|
48 |
#' |
|
49 |
#' @param na_str (`string`)\cr the explicit `na_level` argument you used in the pre-processing steps (maybe with |
|
50 |
#' [df_explicit_na()]). The default is `"<Missing>"`. |
|
51 |
#' |
|
52 |
#' @return |
|
53 |
#' * `s_count_abnormal_by_baseline()` returns statistic `fraction` which is a named list with 3 labeled elements: |
|
54 |
#' `not_abnormal`, `abnormal`, and `total`. Each element contains a vector with `num` and `denom` patient counts. |
|
55 |
#' |
|
56 |
#' @keywords internal |
|
57 |
s_count_abnormal_by_baseline <- function(df, |
|
58 |
.var, |
|
59 |
abnormal, |
|
60 |
na_str = "<Missing>", |
|
61 |
variables = list(id = "USUBJID", baseline = "BNRIND"), |
|
62 |
...) { |
|
63 | 11x |
checkmate::assert_string(.var) |
64 | 11x |
checkmate::assert_string(abnormal) |
65 | 11x |
checkmate::assert_string(na_str) |
66 | 11x |
assert_df_with_variables(df, c(range = .var, variables)) |
67 | 11x |
checkmate::assert_subset(names(variables), c("id", "baseline")) |
68 | 11x |
checkmate::assert_multi_class(df[[variables$id]], classes = c("factor", "character")) |
69 | 11x |
checkmate::assert_multi_class(df[[variables$baseline]], classes = c("factor", "character")) |
70 | 11x |
checkmate::assert_multi_class(df[[.var]], classes = c("factor", "character")) |
71 | ||
72 |
# If input is passed as character, changed to factor |
|
73 | 11x |
df[[.var]] <- as_factor_keep_attributes(df[[.var]], na_level = na_str) |
74 | 11x |
df[[variables$baseline]] <- as_factor_keep_attributes(df[[variables$baseline]], na_level = na_str) |
75 | ||
76 | 11x |
assert_valid_factor(df[[.var]], any.missing = FALSE) |
77 | 10x |
assert_valid_factor(df[[variables$baseline]], any.missing = FALSE) |
78 | ||
79 |
# Keep only records with valid analysis value. |
|
80 | 9x |
df <- df[df[[.var]] != na_str, ] |
81 | ||
82 | 9x |
anl <- data.frame( |
83 | 9x |
id = df[[variables$id]], |
84 | 9x |
var = df[[.var]], |
85 | 9x |
baseline = df[[variables$baseline]], |
86 | 9x |
stringsAsFactors = FALSE |
87 |
) |
|
88 | ||
89 |
# Total: |
|
90 |
# - Patients in denominator: have at least one valid measurement post-baseline. |
|
91 |
# - Patients in numerator: have at least one abnormality. |
|
92 | 9x |
total_denom <- length(unique(anl$id)) |
93 | 9x |
total_num <- length(unique(anl$id[anl$var == abnormal])) |
94 | ||
95 |
# Baseline NA records are counted only in total rows. |
|
96 | 9x |
anl <- anl[anl$baseline != na_str, ] |
97 | ||
98 |
# Abnormal: |
|
99 |
# - Patients in denominator: have abnormality at baseline. |
|
100 |
# - Patients in numerator: have abnormality at baseline AND |
|
101 |
# have at least one abnormality post-baseline. |
|
102 | 9x |
abn_denom <- length(unique(anl$id[anl$baseline == abnormal])) |
103 | 9x |
abn_num <- length(unique(anl$id[anl$baseline == abnormal & anl$var == abnormal])) |
104 | ||
105 |
# Not abnormal: |
|
106 |
# - Patients in denominator: do not have abnormality at baseline. |
|
107 |
# - Patients in numerator: do not have abnormality at baseline AND |
|
108 |
# have at least one abnormality post-baseline. |
|
109 | 9x |
not_abn_denom <- length(unique(anl$id[anl$baseline != abnormal])) |
110 | 9x |
not_abn_num <- length(unique(anl$id[anl$baseline != abnormal & anl$var == abnormal])) |
111 | ||
112 | 9x |
labels <- d_count_abnormal_by_baseline(abnormal) |
113 | 9x |
list(fraction = list( |
114 | 9x |
not_abnormal = formatters::with_label(c(num = not_abn_num, denom = not_abn_denom), labels$not_abnormal), |
115 | 9x |
abnormal = formatters::with_label(c(num = abn_num, denom = abn_denom), labels$abnormal), |
116 | 9x |
total = formatters::with_label(c(num = total_num, denom = total_denom), labels$total) |
117 |
)) |
|
118 |
} |
|
119 | ||
120 |
#' @describeIn abnormal_by_baseline Formatted analysis function which is used as `afun` |
|
121 |
#' in `count_abnormal_by_baseline()`. |
|
122 |
#' |
|
123 |
#' @return |
|
124 |
#' * `a_count_abnormal_by_baseline()` returns the corresponding list with formatted [rtables::CellValue()]. |
|
125 |
#' |
|
126 |
#' @keywords internal |
|
127 |
a_count_abnormal_by_baseline <- function(df, |
|
128 |
..., |
|
129 |
.stats = NULL, |
|
130 |
.stat_names = NULL, |
|
131 |
.formats = NULL, |
|
132 |
.labels = NULL, |
|
133 |
.indent_mods = NULL) { |
|
134 |
# Check for additional parameters to the statistics function |
|
135 | 4x |
dots_extra_args <- list(...) |
136 | 4x |
extra_afun_params <- retrieve_extra_afun_params(names(dots_extra_args$.additional_fun_parameters)) |
137 | 4x |
dots_extra_args$.additional_fun_parameters <- NULL |
138 | ||
139 |
# Check for user-defined functions |
|
140 | 4x |
default_and_custom_stats_list <- .split_std_from_custom_stats(.stats) |
141 | 4x |
.stats <- default_and_custom_stats_list$all_stats |
142 | 4x |
custom_stat_functions <- default_and_custom_stats_list$custom_stats |
143 | ||
144 |
# Apply statistics function |
|
145 | 4x |
x_stats <- .apply_stat_functions( |
146 | 4x |
default_stat_fnc = s_count_abnormal_by_baseline, |
147 | 4x |
custom_stat_fnc_list = custom_stat_functions, |
148 | 4x |
args_list = c( |
149 | 4x |
df = list(df), |
150 | 4x |
extra_afun_params, |
151 | 4x |
dots_extra_args |
152 |
) |
|
153 |
) |
|
154 | ||
155 |
# Fill in formatting defaults |
|
156 | 4x |
.stats <- get_stats("abnormal_by_baseline", stats_in = .stats, custom_stats_in = names(custom_stat_functions)) |
157 | 4x |
levels_per_stats <- lapply(x_stats, names) |
158 | 4x |
.formats <- get_formats_from_stats(.stats, .formats, levels_per_stats) |
159 | 4x |
.labels <- get_labels_from_stats( |
160 | 4x |
.stats, .labels, levels_per_stats, d_count_abnormal_by_baseline(dots_extra_args$abnormal) |
161 |
) |
|
162 | 4x |
.indent_mods <- get_indents_from_stats(.stats, .indent_mods, levels_per_stats) |
163 | ||
164 | 4x |
x_stats <- x_stats[.stats] %>% |
165 | 4x |
.unlist_keep_nulls() %>% |
166 | 4x |
setNames(names(.formats)) |
167 | ||
168 |
# Auto format handling |
|
169 | 4x |
.formats <- apply_auto_formatting(.formats, x_stats, extra_afun_params$.df_row, extra_afun_params$.var) |
170 | ||
171 |
# Get and check statistical names |
|
172 | 4x |
.stat_names <- get_stat_names(x_stats, .stat_names) |
173 | ||
174 | 4x |
in_rows( |
175 | 4x |
.list = x_stats, |
176 | 4x |
.formats = .formats, |
177 | 4x |
.names = .labels %>% .unlist_keep_nulls(), |
178 | 4x |
.stat_names = .stat_names, |
179 | 4x |
.labels = .labels %>% .unlist_keep_nulls(), |
180 | 4x |
.indent_mods = .indent_mods %>% .unlist_keep_nulls() |
181 |
) |
|
182 |
} |
|
183 | ||
184 |
#' @describeIn abnormal_by_baseline Layout-creating function which can take statistics function arguments |
|
185 |
#' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
|
186 |
#' |
|
187 |
#' @return |
|
188 |
#' * `count_abnormal_by_baseline()` returns a layout object suitable for passing to further layouting functions, |
|
189 |
#' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
|
190 |
#' the statistics from `s_count_abnormal_by_baseline()` to the table layout. |
|
191 |
#' |
|
192 |
#' @examples |
|
193 |
#' df <- data.frame( |
|
194 |
#' USUBJID = as.character(c(1:6)), |
|
195 |
#' ANRIND = factor(c(rep("LOW", 4), "NORMAL", "HIGH")), |
|
196 |
#' BNRIND = factor(c("LOW", "NORMAL", "HIGH", NA, "LOW", "NORMAL")) |
|
197 |
#' ) |
|
198 |
#' df <- df_explicit_na(df) |
|
199 |
#' |
|
200 |
#' # Layout creating function. |
|
201 |
#' basic_table() %>% |
|
202 |
#' count_abnormal_by_baseline(var = "ANRIND", abnormal = c(High = "HIGH")) %>% |
|
203 |
#' build_table(df) |
|
204 |
#' |
|
205 |
#' # Passing of statistics function and formatting arguments. |
|
206 |
#' df2 <- data.frame( |
|
207 |
#' ID = as.character(c(1, 2, 3, 4)), |
|
208 |
#' RANGE = factor(c("NORMAL", "LOW", "HIGH", "HIGH")), |
|
209 |
#' BLRANGE = factor(c("LOW", "HIGH", "HIGH", "NORMAL")) |
|
210 |
#' ) |
|
211 |
#' |
|
212 |
#' basic_table() %>% |
|
213 |
#' count_abnormal_by_baseline( |
|
214 |
#' var = "RANGE", |
|
215 |
#' abnormal = c(Low = "LOW"), |
|
216 |
#' variables = list(id = "ID", baseline = "BLRANGE"), |
|
217 |
#' .formats = c(fraction = "xx / xx"), |
|
218 |
#' .indent_mods = c(fraction = 2L) |
|
219 |
#' ) %>% |
|
220 |
#' build_table(df2) |
|
221 |
#' |
|
222 |
#' @export |
|
223 |
#' @order 2 |
|
224 |
count_abnormal_by_baseline <- function(lyt, |
|
225 |
var, |
|
226 |
abnormal, |
|
227 |
variables = list(id = "USUBJID", baseline = "BNRIND"), |
|
228 |
na_str = "<Missing>", |
|
229 |
nested = TRUE, |
|
230 |
..., |
|
231 |
table_names = abnormal, |
|
232 |
.stats = "fraction", |
|
233 |
.stat_names = NULL, |
|
234 |
.formats = list(fraction = format_fraction), |
|
235 |
.labels = NULL, |
|
236 |
.indent_mods = NULL) { |
|
237 | 2x |
checkmate::assert_character(abnormal, len = length(table_names), names = "named") |
238 | 2x |
checkmate::assert_string(var) |
239 | ||
240 |
# Process standard extra arguments |
|
241 | 2x |
extra_args <- list(".stats" = .stats) |
242 | ! |
if (!is.null(.stat_names)) extra_args[[".stat_names"]] <- .stat_names |
243 | 2x |
if (!is.null(.formats)) extra_args[[".formats"]] <- .formats |
244 | ! |
if (!is.null(.labels)) extra_args[[".labels"]] <- .labels |
245 | ! |
if (!is.null(.indent_mods)) extra_args[[".indent_mods"]] <- .indent_mods |
246 | ||
247 |
# Process additional arguments to the statistic function |
|
248 | 2x |
extra_args <- c(extra_args, "variables" = list(variables), ...) |
249 | ||
250 |
# Append additional info from layout to the analysis function |
|
251 | 2x |
extra_args[[".additional_fun_parameters"]] <- get_additional_afun_params(add_alt_df = FALSE) |
252 | 2x |
formals(a_count_abnormal_by_baseline) <- c( |
253 | 2x |
formals(a_count_abnormal_by_baseline), extra_args[[".additional_fun_parameters"]] |
254 |
) |
|
255 | ||
256 |
# Add a new table section with label for each value in abnormal |
|
257 | 2x |
for (i in seq_along(abnormal)) { |
258 | 4x |
extra_args[["abnormal"]] <- abnormal[i] |
259 | ||
260 | 4x |
lyt <- analyze( |
261 | 4x |
lyt = lyt, |
262 | 4x |
vars = var, |
263 | 4x |
afun = a_count_abnormal_by_baseline, |
264 | 4x |
var_labels = names(abnormal)[i], |
265 | 4x |
na_str = na_str, |
266 | 4x |
nested = nested, |
267 | 4x |
extra_args = extra_args, |
268 | 4x |
show_labels = "visible", |
269 | 4x |
table_names = table_names[i] |
270 |
) |
|
271 |
} |
|
272 | ||
273 | 2x |
lyt |
274 |
} |
|
275 | ||
276 |
#' Description function for `s_count_abnormal_by_baseline()` |
|
277 |
#' |
|
278 |
#' @description `r lifecycle::badge("stable")` |
|
279 |
#' |
|
280 |
#' Description function that produces the labels for [s_count_abnormal_by_baseline()]. |
|
281 |
#' |
|
282 |
#' @inheritParams abnormal_by_baseline |
|
283 |
#' |
|
284 |
#' @return Abnormal category labels for [s_count_abnormal_by_baseline()]. |
|
285 |
#' |
|
286 |
#' @examples |
|
287 |
#' d_count_abnormal_by_baseline("LOW") |
|
288 |
#' |
|
289 |
#' @export |
|
290 |
d_count_abnormal_by_baseline <- function(abnormal) { |
|
291 | 13x |
not_abn_name <- paste("Not", tolower(abnormal)) |
292 | 13x |
abn_name <- paste0(toupper(substr(abnormal, 1, 1)), tolower(substring(abnormal, 2))) |
293 | 13x |
total_name <- "Total" |
294 | ||
295 | 13x |
list( |
296 | 13x |
not_abnormal = not_abn_name, |
297 | 13x |
abnormal = abn_name, |
298 | 13x |
total = total_name |
299 |
) |
|
300 |
} |
1 |
#' Helper functions for multivariate logistic regression |
|
2 |
#' |
|
3 |
#' @description `r lifecycle::badge("stable")` |
|
4 |
#' |
|
5 |
#' Helper functions used in calculations for logistic regression. |
|
6 |
#' |
|
7 |
#' @inheritParams argument_convention |
|
8 |
#' @param fit_glm (`glm`)\cr logistic regression model fitted by [stats::glm()] with "binomial" family. |
|
9 |
#' Limited functionality is also available for conditional logistic regression models fitted by |
|
10 |
#' [survival::clogit()], currently this is used only by [extract_rsp_biomarkers()]. |
|
11 |
#' @param x (`character`)\cr a variable or interaction term in `fit_glm` (depending on the helper function used). |
|
12 |
#' |
|
13 |
#' @examples |
|
14 |
#' library(dplyr) |
|
15 |
#' library(broom) |
|
16 |
#' |
|
17 |
#' adrs_f <- tern_ex_adrs %>% |
|
18 |
#' filter(PARAMCD == "BESRSPI") %>% |
|
19 |
#' filter(RACE %in% c("ASIAN", "WHITE", "BLACK OR AFRICAN AMERICAN")) %>% |
|
20 |
#' mutate( |
|
21 |
#' Response = case_when(AVALC %in% c("PR", "CR") ~ 1, TRUE ~ 0), |
|
22 |
#' RACE = factor(RACE), |
|
23 |
#' SEX = factor(SEX) |
|
24 |
#' ) |
|
25 |
#' formatters::var_labels(adrs_f) <- c(formatters::var_labels(tern_ex_adrs), Response = "Response") |
|
26 |
#' mod1 <- fit_logistic( |
|
27 |
#' data = adrs_f, |
|
28 |
#' variables = list( |
|
29 |
#' response = "Response", |
|
30 |
#' arm = "ARMCD", |
|
31 |
#' covariates = c("AGE", "RACE") |
|
32 |
#' ) |
|
33 |
#' ) |
|
34 |
#' mod2 <- fit_logistic( |
|
35 |
#' data = adrs_f, |
|
36 |
#' variables = list( |
|
37 |
#' response = "Response", |
|
38 |
#' arm = "ARMCD", |
|
39 |
#' covariates = c("AGE", "RACE"), |
|
40 |
#' interaction = "AGE" |
|
41 |
#' ) |
|
42 |
#' ) |
|
43 |
#' |
|
44 |
#' @name h_logistic_regression |
|
45 |
NULL |
|
46 | ||
47 |
#' @describeIn h_logistic_regression Helper function to extract interaction variable names from a fitted |
|
48 |
#' model assuming only one interaction term. |
|
49 |
#' |
|
50 |
#' @return Vector of names of interaction variables. |
|
51 |
#' |
|
52 |
#' @export |
|
53 |
h_get_interaction_vars <- function(fit_glm) { |
|
54 | 34x |
checkmate::assert_class(fit_glm, "glm") |
55 | 34x |
terms_name <- attr(stats::terms(fit_glm), "term.labels") |
56 | 34x |
terms_order <- attr(stats::terms(fit_glm), "order") |
57 | 34x |
interaction_term <- terms_name[terms_order == 2] |
58 | 34x |
checkmate::assert_string(interaction_term) |
59 | 34x |
strsplit(interaction_term, split = ":")[[1]] |
60 |
} |
|
61 | ||
62 |
#' @describeIn h_logistic_regression Helper function to get the right coefficient name from the |
|
63 |
#' interaction variable names and the given levels. The main value here is that the order |
|
64 |
#' of first and second variable is checked in the `interaction_vars` input. |
|
65 |
#' |
|
66 |
#' @param interaction_vars (`character(2)`)\cr interaction variable names. |
|
67 |
#' @param first_var_with_level (`character(2)`)\cr the first variable name with the interaction level. |
|
68 |
#' @param second_var_with_level (`character(2)`)\cr the second variable name with the interaction level. |
|
69 |
#' |
|
70 |
#' @return Name of coefficient. |
|
71 |
#' |
|
72 |
#' @export |
|
73 |
h_interaction_coef_name <- function(interaction_vars, |
|
74 |
first_var_with_level, |
|
75 |
second_var_with_level) { |
|
76 | 55x |
checkmate::assert_character(interaction_vars, len = 2, any.missing = FALSE) |
77 | 55x |
checkmate::assert_character(first_var_with_level, len = 2, any.missing = FALSE) |
78 | 55x |
checkmate::assert_character(second_var_with_level, len = 2, any.missing = FALSE) |
79 | 55x |
checkmate::assert_subset(c(first_var_with_level[1], second_var_with_level[1]), interaction_vars) |
80 | ||
81 | 55x |
first_name <- paste(first_var_with_level, collapse = "") |
82 | 55x |
second_name <- paste(second_var_with_level, collapse = "") |
83 | 55x |
if (first_var_with_level[1] == interaction_vars[1]) { |
84 | 36x |
paste(first_name, second_name, sep = ":") |
85 | 19x |
} else if (second_var_with_level[1] == interaction_vars[1]) { |
86 | 19x |
paste(second_name, first_name, sep = ":") |
87 |
} |
|
88 |
} |
|
89 | ||
90 |
#' @describeIn h_logistic_regression Helper function to calculate the odds ratio estimates |
|
91 |
#' for the case when both the odds ratio and the interaction variable are categorical. |
|
92 |
#' |
|
93 |
#' @param odds_ratio_var (`string`)\cr the odds ratio variable. |
|
94 |
#' @param interaction_var (`string`)\cr the interaction variable. |
|
95 |
#' |
|
96 |
#' @return Odds ratio. |
|
97 |
#' |
|
98 |
#' @export |
|
99 |
h_or_cat_interaction <- function(odds_ratio_var, |
|
100 |
interaction_var, |
|
101 |
fit_glm, |
|
102 |
conf_level = 0.95) { |
|
103 | 8x |
interaction_vars <- h_get_interaction_vars(fit_glm) |
104 | 8x |
checkmate::assert_string(odds_ratio_var) |
105 | 8x |
checkmate::assert_string(interaction_var) |
106 | 8x |
checkmate::assert_subset(c(odds_ratio_var, interaction_var), interaction_vars) |
107 | 8x |
checkmate::assert_vector(interaction_vars, len = 2) |
108 | ||
109 | 8x |
xs_level <- fit_glm$xlevels |
110 | 8x |
xs_coef <- stats::coef(fit_glm) |
111 | 8x |
xs_vcov <- stats::vcov(fit_glm) |
112 | 8x |
y <- list() |
113 | 8x |
for (var_level in xs_level[[odds_ratio_var]][-1]) { |
114 | 14x |
x <- list() |
115 | 14x |
for (ref_level in xs_level[[interaction_var]]) { |
116 | 38x |
coef_names <- paste0(odds_ratio_var, var_level) |
117 | 38x |
if (ref_level != xs_level[[interaction_var]][1]) { |
118 | 24x |
interaction_coef_name <- h_interaction_coef_name( |
119 | 24x |
interaction_vars, |
120 | 24x |
c(odds_ratio_var, var_level), |
121 | 24x |
c(interaction_var, ref_level) |
122 |
) |
|
123 | 24x |
coef_names <- c( |
124 | 24x |
coef_names, |
125 | 24x |
interaction_coef_name |
126 |
) |
|
127 |
} |
|
128 | 38x |
if (length(coef_names) > 1) { |
129 | 24x |
ones <- t(c(1, 1)) |
130 | 24x |
est <- as.numeric(ones %*% xs_coef[coef_names]) |
131 | 24x |
se <- sqrt(as.numeric(ones %*% xs_vcov[coef_names, coef_names] %*% t(ones))) |
132 |
} else { |
|
133 | 14x |
est <- xs_coef[coef_names] |
134 | 14x |
se <- sqrt(as.numeric(xs_vcov[coef_names, coef_names])) |
135 |
} |
|
136 | 38x |
or <- exp(est) |
137 | 38x |
ci <- exp(est + c(lcl = -1, ucl = 1) * stats::qnorm((1 + conf_level) / 2) * se) |
138 | 38x |
x[[ref_level]] <- list(or = or, ci = ci) |
139 |
} |
|
140 | 14x |
y[[var_level]] <- x |
141 |
} |
|
142 | 8x |
y |
143 |
} |
|
144 | ||
145 |
#' @describeIn h_logistic_regression Helper function to calculate the odds ratio estimates |
|
146 |
#' for the case when either the odds ratio or the interaction variable is continuous. |
|
147 |
#' |
|
148 |
#' @param at (`numeric` or `NULL`)\cr optional values for the interaction variable. Otherwise |
|
149 |
#' the median is used. |
|
150 |
#' |
|
151 |
#' @return Odds ratio. |
|
152 |
#' |
|
153 |
#' @note We don't provide a function for the case when both variables are continuous because |
|
154 |
#' this does not arise in this table, as the treatment arm variable will always be involved |
|
155 |
#' and categorical. |
|
156 |
#' |
|
157 |
#' @export |
|
158 |
h_or_cont_interaction <- function(odds_ratio_var, |
|
159 |
interaction_var, |
|
160 |
fit_glm, |
|
161 |
at = NULL, |
|
162 |
conf_level = 0.95) { |
|
163 | 13x |
interaction_vars <- h_get_interaction_vars(fit_glm) |
164 | 13x |
checkmate::assert_string(odds_ratio_var) |
165 | 13x |
checkmate::assert_string(interaction_var) |
166 | 13x |
checkmate::assert_subset(c(odds_ratio_var, interaction_var), interaction_vars) |
167 | 13x |
checkmate::assert_vector(interaction_vars, len = 2) |
168 | 13x |
checkmate::assert_numeric(at, min.len = 1, null.ok = TRUE, any.missing = FALSE) |
169 | 13x |
xs_level <- fit_glm$xlevels |
170 | 13x |
xs_coef <- stats::coef(fit_glm) |
171 | 13x |
xs_vcov <- stats::vcov(fit_glm) |
172 | 13x |
xs_class <- attr(fit_glm$terms, "dataClasses") |
173 | 13x |
model_data <- fit_glm$model |
174 | 13x |
if (!is.null(at)) { |
175 | 3x |
checkmate::assert_set_equal(xs_class[interaction_var], "numeric") |
176 |
} |
|
177 | 12x |
y <- list() |
178 | 12x |
if (xs_class[interaction_var] == "numeric") { |
179 | 7x |
if (is.null(at)) { |
180 | 5x |
at <- ceiling(stats::median(model_data[[interaction_var]])) |
181 |
} |
|
182 | ||
183 | 7x |
for (var_level in xs_level[[odds_ratio_var]][-1]) { |
184 | 14x |
x <- list() |
185 | 14x |
for (increment in at) { |
186 | 20x |
coef_names <- paste0(odds_ratio_var, var_level) |
187 | 20x |
if (increment != 0) { |
188 | 20x |
interaction_coef_name <- h_interaction_coef_name( |
189 | 20x |
interaction_vars, |
190 | 20x |
c(odds_ratio_var, var_level), |
191 | 20x |
c(interaction_var, "") |
192 |
) |
|
193 | 20x |
coef_names <- c( |
194 | 20x |
coef_names, |
195 | 20x |
interaction_coef_name |
196 |
) |
|
197 |
} |
|
198 | 20x |
if (length(coef_names) > 1) { |
199 | 20x |
xvec <- t(c(1, increment)) |
200 | 20x |
est <- as.numeric(xvec %*% xs_coef[coef_names]) |
201 | 20x |
se <- sqrt(as.numeric(xvec %*% xs_vcov[coef_names, coef_names] %*% t(xvec))) |
202 |
} else { |
|
203 | ! |
est <- xs_coef[coef_names] |
204 | ! |
se <- sqrt(as.numeric(xs_vcov[coef_names, coef_names])) |
205 |
} |
|
206 | 20x |
or <- exp(est) |
207 | 20x |
ci <- exp(est + c(lcl = -1, ucl = 1) * stats::qnorm((1 + conf_level) / 2) * se) |
208 | 20x |
x[[as.character(increment)]] <- list(or = or, ci = ci) |
209 |
} |
|
210 | 14x |
y[[var_level]] <- x |
211 |
} |
|
212 |
} else { |
|
213 | 5x |
checkmate::assert_set_equal(xs_class[odds_ratio_var], "numeric") |
214 | 5x |
checkmate::assert_set_equal(xs_class[interaction_var], "factor") |
215 | 5x |
for (var_level in xs_level[[interaction_var]]) { |
216 | 15x |
coef_names <- odds_ratio_var |
217 | 15x |
if (var_level != xs_level[[interaction_var]][1]) { |
218 | 10x |
interaction_coef_name <- h_interaction_coef_name( |
219 | 10x |
interaction_vars, |
220 | 10x |
c(odds_ratio_var, ""), |
221 | 10x |
c(interaction_var, var_level) |
222 |
) |
|
223 | 10x |
coef_names <- c( |
224 | 10x |
coef_names, |
225 | 10x |
interaction_coef_name |
226 |
) |
|
227 |
} |
|
228 | 15x |
if (length(coef_names) > 1) { |
229 | 10x |
xvec <- t(c(1, 1)) |
230 | 10x |
est <- as.numeric(xvec %*% xs_coef[coef_names]) |
231 | 10x |
se <- sqrt(as.numeric(xvec %*% xs_vcov[coef_names, coef_names] %*% t(xvec))) |
232 |
} else { |
|
233 | 5x |
est <- xs_coef[coef_names] |
234 | 5x |
se <- sqrt(as.numeric(xs_vcov[coef_names, coef_names])) |
235 |
} |
|
236 | 15x |
or <- exp(est) |
237 | 15x |
ci <- exp(est + c(lcl = -1, ucl = 1) * stats::qnorm((1 + conf_level) / 2) * se) |
238 | 15x |
y[[var_level]] <- list(or = or, ci = ci) |
239 |
} |
|
240 |
} |
|
241 | 12x |
y |
242 |
} |
|
243 | ||
244 |
#' @describeIn h_logistic_regression Helper function to calculate the odds ratio estimates |
|
245 |
#' in case of an interaction. This is a wrapper for [h_or_cont_interaction()] and |
|
246 |
#' [h_or_cat_interaction()]. |
|
247 |
#' |
|
248 |
#' @return Odds ratio. |
|
249 |
#' |
|
250 |
#' @export |
|
251 |
h_or_interaction <- function(odds_ratio_var, |
|
252 |
interaction_var, |
|
253 |
fit_glm, |
|
254 |
at = NULL, |
|
255 |
conf_level = 0.95) { |
|
256 | 15x |
xs_class <- attr(fit_glm$terms, "dataClasses") |
257 | 15x |
if (any(xs_class[c(odds_ratio_var, interaction_var)] == "numeric")) { |
258 | 9x |
h_or_cont_interaction( |
259 | 9x |
odds_ratio_var, |
260 | 9x |
interaction_var, |
261 | 9x |
fit_glm, |
262 | 9x |
at = at, |
263 | 9x |
conf_level = conf_level |
264 |
) |
|
265 | 6x |
} else if (all(xs_class[c(odds_ratio_var, interaction_var)] == "factor")) { |
266 | 6x |
h_or_cat_interaction( |
267 | 6x |
odds_ratio_var, |
268 | 6x |
interaction_var, |
269 | 6x |
fit_glm, |
270 | 6x |
conf_level = conf_level |
271 |
) |
|
272 |
} else { |
|
273 | ! |
stop("wrong interaction variable class, the interaction variable is not a numeric nor a factor") |
274 |
} |
|
275 |
} |
|
276 | ||
277 |
#' @describeIn h_logistic_regression Helper function to construct term labels from simple terms and the table |
|
278 |
#' of numbers of patients. |
|
279 |
#' |
|
280 |
#' @param terms (`character`)\cr simple terms. |
|
281 |
#' @param table (`table`)\cr table containing numbers for terms. |
|
282 |
#' |
|
283 |
#' @return Term labels containing numbers of patients. |
|
284 |
#' |
|
285 |
#' @export |
|
286 |
h_simple_term_labels <- function(terms, |
|
287 |
table) { |
|
288 | 54x |
checkmate::assert_true(is.table(table)) |
289 | 54x |
checkmate::assert_multi_class(terms, classes = c("factor", "character")) |
290 | 54x |
terms <- as.character(terms) |
291 | 54x |
term_n <- table[terms] |
292 | 54x |
paste0(terms, ", n = ", term_n) |
293 |
} |
|
294 | ||
295 |
#' @describeIn h_logistic_regression Helper function to construct term labels from interaction terms and the table |
|
296 |
#' of numbers of patients. |
|
297 |
#' |
|
298 |
#' @param terms1 (`character`)\cr terms for first dimension (rows). |
|
299 |
#' @param terms2 (`character`)\cr terms for second dimension (rows). |
|
300 |
#' @param any (`flag`)\cr whether any of `term1` and `term2` can be fulfilled to count the |
|
301 |
#' number of patients. In that case they can only be scalar (strings). |
|
302 |
#' |
|
303 |
#' @return Term labels containing numbers of patients. |
|
304 |
#' |
|
305 |
#' @export |
|
306 |
h_interaction_term_labels <- function(terms1, |
|
307 |
terms2, |
|
308 |
table, |
|
309 |
any = FALSE) { |
|
310 | 8x |
checkmate::assert_true(is.table(table)) |
311 | 8x |
checkmate::assert_flag(any) |
312 | 8x |
checkmate::assert_multi_class(terms1, classes = c("factor", "character")) |
313 | 8x |
checkmate::assert_multi_class(terms2, classes = c("factor", "character")) |
314 | 8x |
terms1 <- as.character(terms1) |
315 | 8x |
terms2 <- as.character(terms2) |
316 | 8x |
if (any) { |
317 | 4x |
checkmate::assert_scalar(terms1) |
318 | 4x |
checkmate::assert_scalar(terms2) |
319 | 4x |
paste0( |
320 | 4x |
terms1, " or ", terms2, ", n = ", |
321 |
# Note that we double count in the initial sum the cell [terms1, terms2], therefore subtract. |
|
322 | 4x |
sum(c(table[terms1, ], table[, terms2])) - table[terms1, terms2] |
323 |
) |
|
324 |
} else { |
|
325 | 4x |
term_n <- table[cbind(terms1, terms2)] |
326 | 4x |
paste0(terms1, " * ", terms2, ", n = ", term_n) |
327 |
} |
|
328 |
} |
|
329 | ||
330 |
#' @describeIn h_logistic_regression Helper function to tabulate the main effect |
|
331 |
#' results of a (conditional) logistic regression model. |
|
332 |
#' |
|
333 |
#' @return Tabulated main effect results from a logistic regression model. |
|
334 |
#' |
|
335 |
#' @examples |
|
336 |
#' h_glm_simple_term_extract("AGE", mod1) |
|
337 |
#' h_glm_simple_term_extract("ARMCD", mod1) |
|
338 |
#' |
|
339 |
#' @export |
|
340 |
h_glm_simple_term_extract <- function(x, fit_glm) { |
|
341 | 78x |
checkmate::assert_multi_class(fit_glm, c("glm", "clogit")) |
342 | 78x |
checkmate::assert_string(x) |
343 | ||
344 | 78x |
xs_class <- attr(fit_glm$terms, "dataClasses") |
345 | 78x |
xs_level <- fit_glm$xlevels |
346 | 78x |
xs_coef <- summary(fit_glm)$coefficients |
347 | 78x |
stats <- if (inherits(fit_glm, "glm")) { |
348 | 66x |
c("estimate" = "Estimate", "std_error" = "Std. Error", "pvalue" = "Pr(>|z|)") |
349 |
} else { |
|
350 | 12x |
c("estimate" = "coef", "std_error" = "se(coef)", "pvalue" = "Pr(>|z|)") |
351 |
} |
|
352 |
# Make sure x is not an interaction term. |
|
353 | 78x |
checkmate::assert_subset(x, names(xs_class)) |
354 | 78x |
x_sel <- if (xs_class[x] == "numeric") x else paste0(x, xs_level[[x]][-1]) |
355 | 78x |
x_stats <- as.data.frame(xs_coef[x_sel, stats, drop = FALSE], stringsAsFactors = FALSE) |
356 | 78x |
colnames(x_stats) <- names(stats) |
357 | 78x |
x_stats$estimate <- as.list(x_stats$estimate) |
358 | 78x |
x_stats$std_error <- as.list(x_stats$std_error) |
359 | 78x |
x_stats$pvalue <- as.list(x_stats$pvalue) |
360 | 78x |
x_stats$df <- as.list(1) |
361 | 78x |
if (xs_class[x] == "numeric") { |
362 | 60x |
x_stats$term <- x |
363 | 60x |
x_stats$term_label <- if (inherits(fit_glm, "glm")) { |
364 | 48x |
formatters::var_labels(fit_glm$data[x], fill = TRUE) |
365 |
} else { |
|
366 |
# We just fill in here with the `term` itself as we don't have the data available. |
|
367 | 12x |
x |
368 |
} |
|
369 | 60x |
x_stats$is_variable_summary <- FALSE |
370 | 60x |
x_stats$is_term_summary <- TRUE |
371 |
} else { |
|
372 | 18x |
checkmate::assert_class(fit_glm, "glm") |
373 |
# The reason is that we don't have the original data set in the `clogit` object |
|
374 |
# and therefore cannot determine the `x_numbers` here. |
|
375 | 18x |
x_numbers <- table(fit_glm$data[[x]]) |
376 | 18x |
x_stats$term <- xs_level[[x]][-1] |
377 | 18x |
x_stats$term_label <- h_simple_term_labels(x_stats$term, x_numbers) |
378 | 18x |
x_stats$is_variable_summary <- FALSE |
379 | 18x |
x_stats$is_term_summary <- TRUE |
380 | 18x |
main_effects <- car::Anova(fit_glm, type = 3, test.statistic = "Wald") |
381 | 18x |
x_main <- data.frame( |
382 | 18x |
pvalue = main_effects[x, "Pr(>Chisq)", drop = TRUE], |
383 | 18x |
term = xs_level[[x]][1], |
384 | 18x |
term_label = paste("Reference", h_simple_term_labels(xs_level[[x]][1], x_numbers)), |
385 | 18x |
df = main_effects[x, "Df", drop = TRUE], |
386 | 18x |
stringsAsFactors = FALSE |
387 |
) |
|
388 | 18x |
x_main$pvalue <- as.list(x_main$pvalue) |
389 | 18x |
x_main$df <- as.list(x_main$df) |
390 | 18x |
x_main$estimate <- list(numeric(0)) |
391 | 18x |
x_main$std_error <- list(numeric(0)) |
392 | 18x |
if (length(xs_level[[x]][-1]) == 1) { |
393 | 8x |
x_main$pvalue <- list(numeric(0)) |
394 | 8x |
x_main$df <- list(numeric(0)) |
395 |
} |
|
396 | 18x |
x_main$is_variable_summary <- TRUE |
397 | 18x |
x_main$is_term_summary <- FALSE |
398 | 18x |
x_stats <- rbind(x_main, x_stats) |
399 |
} |
|
400 | 78x |
x_stats$variable <- x |
401 | 78x |
x_stats$variable_label <- if (inherits(fit_glm, "glm")) { |
402 | 66x |
formatters::var_labels(fit_glm$data[x], fill = TRUE) |
403 |
} else { |
|
404 | 12x |
x |
405 |
} |
|
406 | 78x |
x_stats$interaction <- "" |
407 | 78x |
x_stats$interaction_label <- "" |
408 | 78x |
x_stats$reference <- "" |
409 | 78x |
x_stats$reference_label <- "" |
410 | 78x |
rownames(x_stats) <- NULL |
411 | 78x |
x_stats[c( |
412 | 78x |
"variable", |
413 | 78x |
"variable_label", |
414 | 78x |
"term", |
415 | 78x |
"term_label", |
416 | 78x |
"interaction", |
417 | 78x |
"interaction_label", |
418 | 78x |
"reference", |
419 | 78x |
"reference_label", |
420 | 78x |
"estimate", |
421 | 78x |
"std_error", |
422 | 78x |
"df", |
423 | 78x |
"pvalue", |
424 | 78x |
"is_variable_summary", |
425 | 78x |
"is_term_summary" |
426 |
)] |
|
427 |
} |
|
428 | ||
429 |
#' @describeIn h_logistic_regression Helper function to tabulate the interaction term |
|
430 |
#' results of a logistic regression model. |
|
431 |
#' |
|
432 |
#' @return Tabulated interaction term results from a logistic regression model. |
|
433 |
#' |
|
434 |
#' @examples |
|
435 |
#' h_glm_interaction_extract("ARMCD:AGE", mod2) |
|
436 |
#' |
|
437 |
#' @export |
|
438 |
h_glm_interaction_extract <- function(x, fit_glm) { |
|
439 | 7x |
vars <- h_get_interaction_vars(fit_glm) |
440 | 7x |
xs_class <- attr(fit_glm$terms, "dataClasses") |
441 | ||
442 | 7x |
checkmate::assert_string(x) |
443 | ||
444 |
# Only take two-way interaction |
|
445 | 7x |
checkmate::assert_vector(vars, len = 2) |
446 | ||
447 |
# Only consider simple case: first variable in interaction is arm, a categorical variable |
|
448 | 7x |
checkmate::assert_disjunct(xs_class[vars[1]], "numeric") |
449 | ||
450 | 7x |
xs_level <- fit_glm$xlevels |
451 | 7x |
xs_coef <- summary(fit_glm)$coefficients |
452 | 7x |
main_effects <- car::Anova(fit_glm, type = 3, test.statistic = "Wald") |
453 | 7x |
stats <- c("estimate" = "Estimate", "std_error" = "Std. Error", "pvalue" = "Pr(>|z|)") |
454 | 7x |
v1_comp <- xs_level[[vars[1]]][-1] |
455 | 7x |
if (xs_class[vars[2]] == "numeric") { |
456 | 4x |
x_stats <- as.data.frame( |
457 | 4x |
xs_coef[paste0(vars[1], v1_comp, ":", vars[2]), stats, drop = FALSE], |
458 | 4x |
stringsAsFactors = FALSE |
459 |
) |
|
460 | 4x |
colnames(x_stats) <- names(stats) |
461 | 4x |
x_stats$term <- v1_comp |
462 | 4x |
x_numbers <- table(fit_glm$data[[vars[1]]]) |
463 | 4x |
x_stats$term_label <- h_simple_term_labels(v1_comp, x_numbers) |
464 | 4x |
v1_ref <- xs_level[[vars[1]]][1] |
465 | 4x |
term_main <- v1_ref |
466 | 4x |
ref_label <- h_simple_term_labels(v1_ref, x_numbers) |
467 | 3x |
} else if (xs_class[vars[2]] != "numeric") { |
468 | 3x |
v2_comp <- xs_level[[vars[2]]][-1] |
469 | 3x |
v1_v2_grid <- expand.grid(v1 = v1_comp, v2 = v2_comp) |
470 | 3x |
x_sel <- paste( |
471 | 3x |
paste0(vars[1], v1_v2_grid$v1), |
472 | 3x |
paste0(vars[2], v1_v2_grid$v2), |
473 | 3x |
sep = ":" |
474 |
) |
|
475 | 3x |
x_stats <- as.data.frame(xs_coef[x_sel, stats, drop = FALSE], stringsAsFactors = FALSE) |
476 | 3x |
colnames(x_stats) <- names(stats) |
477 | 3x |
x_stats$term <- paste(v1_v2_grid$v1, "*", v1_v2_grid$v2) |
478 | 3x |
x_numbers <- table(fit_glm$data[[vars[1]]], fit_glm$data[[vars[2]]]) |
479 | 3x |
x_stats$term_label <- h_interaction_term_labels(v1_v2_grid$v1, v1_v2_grid$v2, x_numbers) |
480 | 3x |
v1_ref <- xs_level[[vars[1]]][1] |
481 | 3x |
v2_ref <- xs_level[[vars[2]]][1] |
482 | 3x |
term_main <- paste(vars[1], vars[2], sep = " * ") |
483 | 3x |
ref_label <- h_interaction_term_labels(v1_ref, v2_ref, x_numbers, any = TRUE) |
484 |
} |
|
485 | 7x |
x_stats$df <- as.list(1) |
486 | 7x |
x_stats$pvalue <- as.list(x_stats$pvalue) |
487 | 7x |
x_stats$is_variable_summary <- FALSE |
488 | 7x |
x_stats$is_term_summary <- TRUE |
489 | 7x |
x_main <- data.frame( |
490 | 7x |
pvalue = main_effects[x, "Pr(>Chisq)", drop = TRUE], |
491 | 7x |
term = term_main, |
492 | 7x |
term_label = paste("Reference", ref_label), |
493 | 7x |
df = main_effects[x, "Df", drop = TRUE], |
494 | 7x |
stringsAsFactors = FALSE |
495 |
) |
|
496 | 7x |
x_main$pvalue <- as.list(x_main$pvalue) |
497 | 7x |
x_main$df <- as.list(x_main$df) |
498 | 7x |
x_main$estimate <- list(numeric(0)) |
499 | 7x |
x_main$std_error <- list(numeric(0)) |
500 | 7x |
x_main$is_variable_summary <- TRUE |
501 | 7x |
x_main$is_term_summary <- FALSE |
502 | ||
503 | 7x |
x_stats <- rbind(x_main, x_stats) |
504 | 7x |
x_stats$variable <- x |
505 | 7x |
x_stats$variable_label <- paste( |
506 | 7x |
"Interaction of", |
507 | 7x |
formatters::var_labels(fit_glm$data[vars[1]], fill = TRUE), |
508 |
"*", |
|
509 | 7x |
formatters::var_labels(fit_glm$data[vars[2]], fill = TRUE) |
510 |
) |
|
511 | 7x |
x_stats$interaction <- "" |
512 | 7x |
x_stats$interaction_label <- "" |
513 | 7x |
x_stats$reference <- "" |
514 | 7x |
x_stats$reference_label <- "" |
515 | 7x |
rownames(x_stats) <- NULL |
516 | 7x |
x_stats[c( |
517 | 7x |
"variable", |
518 | 7x |
"variable_label", |
519 | 7x |
"term", |
520 | 7x |
"term_label", |
521 | 7x |
"interaction", |
522 | 7x |
"interaction_label", |
523 | 7x |
"reference", |
524 | 7x |
"reference_label", |
525 | 7x |
"estimate", |
526 | 7x |
"std_error", |
527 | 7x |
"df", |
528 | 7x |
"pvalue", |
529 | 7x |
"is_variable_summary", |
530 | 7x |
"is_term_summary" |
531 |
)] |
|
532 |
} |
|
533 | ||
534 |
#' @describeIn h_logistic_regression Helper function to tabulate the interaction |
|
535 |
#' results of a logistic regression model. This basically is a wrapper for |
|
536 |
#' [h_or_interaction()] and [h_glm_simple_term_extract()] which puts the results |
|
537 |
#' in the right data frame format. |
|
538 |
#' |
|
539 |
#' @return A `data.frame` of tabulated interaction term results from a logistic regression model. |
|
540 |
#' |
|
541 |
#' @examples |
|
542 |
#' h_glm_inter_term_extract("AGE", "ARMCD", mod2) |
|
543 |
#' |
|
544 |
#' @export |
|
545 |
h_glm_inter_term_extract <- function(odds_ratio_var, |
|
546 |
interaction_var, |
|
547 |
fit_glm, |
|
548 |
...) { |
|
549 |
# First obtain the main effects. |
|
550 | 13x |
main_stats <- h_glm_simple_term_extract(odds_ratio_var, fit_glm) |
551 | 13x |
main_stats$is_reference_summary <- FALSE |
552 | 13x |
main_stats$odds_ratio <- NA |
553 | 13x |
main_stats$lcl <- NA |
554 | 13x |
main_stats$ucl <- NA |
555 | ||
556 |
# Then we get the odds ratio estimates and put into df form. |
|
557 | 13x |
or_numbers <- h_or_interaction(odds_ratio_var, interaction_var, fit_glm, ...) |
558 | 13x |
is_num_or_var <- attr(fit_glm$terms, "dataClasses")[odds_ratio_var] == "numeric" |
559 | ||
560 | 13x |
if (is_num_or_var) { |
561 |
# Numeric OR variable case. |
|
562 | 4x |
references <- names(or_numbers) |
563 | 4x |
n_ref <- length(references) |
564 | ||
565 | 4x |
extract_from_list <- function(l, name, pos = 1) { |
566 | 12x |
unname(unlist( |
567 | 12x |
lapply(or_numbers, function(x) { |
568 | 36x |
x[[name]][pos] |
569 |
}) |
|
570 |
)) |
|
571 |
} |
|
572 | 4x |
or_stats <- data.frame( |
573 | 4x |
variable = odds_ratio_var, |
574 | 4x |
variable_label = unname(formatters::var_labels(fit_glm$data[odds_ratio_var], fill = TRUE)), |
575 | 4x |
term = odds_ratio_var, |
576 | 4x |
term_label = unname(formatters::var_labels(fit_glm$data[odds_ratio_var], fill = TRUE)), |
577 | 4x |
interaction = interaction_var, |
578 | 4x |
interaction_label = unname(formatters::var_labels(fit_glm$data[interaction_var], fill = TRUE)), |
579 | 4x |
reference = references, |
580 | 4x |
reference_label = references, |
581 | 4x |
estimate = NA, |
582 | 4x |
std_error = NA, |
583 | 4x |
odds_ratio = extract_from_list(or_numbers, "or"), |
584 | 4x |
lcl = extract_from_list(or_numbers, "ci", pos = "lcl"), |
585 | 4x |
ucl = extract_from_list(or_numbers, "ci", pos = "ucl"), |
586 | 4x |
df = NA, |
587 | 4x |
pvalue = NA, |
588 | 4x |
is_variable_summary = FALSE, |
589 | 4x |
is_term_summary = FALSE, |
590 | 4x |
is_reference_summary = TRUE |
591 |
) |
|
592 |
} else { |
|
593 |
# Categorical OR variable case. |
|
594 | 9x |
references <- names(or_numbers[[1]]) |
595 | 9x |
n_ref <- length(references) |
596 | ||
597 | 9x |
extract_from_list <- function(l, name, pos = 1) { |
598 | 27x |
unname(unlist( |
599 | 27x |
lapply(or_numbers, function(x) { |
600 | 48x |
lapply(x, function(y) y[[name]][pos]) |
601 |
}) |
|
602 |
)) |
|
603 |
} |
|
604 | 9x |
or_stats <- data.frame( |
605 | 9x |
variable = odds_ratio_var, |
606 | 9x |
variable_label = unname(formatters::var_labels(fit_glm$data[odds_ratio_var], fill = TRUE)), |
607 | 9x |
term = rep(names(or_numbers), each = n_ref), |
608 | 9x |
term_label = h_simple_term_labels(rep(names(or_numbers), each = n_ref), table(fit_glm$data[[odds_ratio_var]])), |
609 | 9x |
interaction = interaction_var, |
610 | 9x |
interaction_label = unname(formatters::var_labels(fit_glm$data[interaction_var], fill = TRUE)), |
611 | 9x |
reference = unlist(lapply(or_numbers, names)), |
612 | 9x |
reference_label = unlist(lapply(or_numbers, names)), |
613 | 9x |
estimate = NA, |
614 | 9x |
std_error = NA, |
615 | 9x |
odds_ratio = extract_from_list(or_numbers, "or"), |
616 | 9x |
lcl = extract_from_list(or_numbers, "ci", pos = "lcl"), |
617 | 9x |
ucl = extract_from_list(or_numbers, "ci", pos = "ucl"), |
618 | 9x |
df = NA, |
619 | 9x |
pvalue = NA, |
620 | 9x |
is_variable_summary = FALSE, |
621 | 9x |
is_term_summary = FALSE, |
622 | 9x |
is_reference_summary = TRUE |
623 |
) |
|
624 |
} |
|
625 | ||
626 | 13x |
df <- rbind( |
627 | 13x |
main_stats[, names(or_stats)], |
628 | 13x |
or_stats |
629 |
) |
|
630 | 13x |
df[order(-df$is_variable_summary, df$term, -df$is_term_summary, df$reference), ] |
631 |
} |
|
632 | ||
633 |
#' @describeIn h_logistic_regression Helper function to tabulate the results including |
|
634 |
#' odds ratios and confidence intervals of simple terms. |
|
635 |
#' |
|
636 |
#' @return Tabulated statistics for the given variable(s) from the logistic regression model. |
|
637 |
#' |
|
638 |
#' @examples |
|
639 |
#' h_logistic_simple_terms("AGE", mod1) |
|
640 |
#' |
|
641 |
#' @export |
|
642 |
h_logistic_simple_terms <- function(x, fit_glm, conf_level = 0.95) { |
|
643 | 53x |
checkmate::assert_multi_class(fit_glm, c("glm", "clogit")) |
644 | 53x |
if (inherits(fit_glm, "glm")) { |
645 | 42x |
checkmate::assert_set_equal(fit_glm$family$family, "binomial") |
646 |
} |
|
647 | 53x |
terms_name <- attr(stats::terms(fit_glm), "term.labels") |
648 | 53x |
xs_class <- attr(fit_glm$terms, "dataClasses") |
649 | 53x |
interaction <- terms_name[which(!terms_name %in% names(xs_class))] |
650 | 53x |
checkmate::assert_subset(x, terms_name) |
651 | 53x |
if (length(interaction) != 0) { |
652 |
# Make sure any item in x is not part of interaction term |
|
653 | 2x |
checkmate::assert_disjunct(x, unlist(strsplit(interaction, ":"))) |
654 |
} |
|
655 | 53x |
x_stats <- lapply(x, h_glm_simple_term_extract, fit_glm) |
656 | 53x |
x_stats <- do.call(rbind, x_stats) |
657 | 53x |
q_norm <- stats::qnorm((1 + conf_level) / 2) |
658 | 53x |
x_stats$odds_ratio <- lapply(x_stats$estimate, exp) |
659 | 53x |
x_stats$lcl <- Map(function(or, se) exp(log(or) - q_norm * se), x_stats$odds_ratio, x_stats$std_error) |
660 | 53x |
x_stats$ucl <- Map(function(or, se) exp(log(or) + q_norm * se), x_stats$odds_ratio, x_stats$std_error) |
661 | 53x |
x_stats$ci <- Map(function(lcl, ucl) c(lcl, ucl), lcl = x_stats$lcl, ucl = x_stats$ucl) |
662 | 53x |
x_stats |
663 |
} |
|
664 | ||
665 |
#' @describeIn h_logistic_regression Helper function to tabulate the results including |
|
666 |
#' odds ratios and confidence intervals of interaction terms. |
|
667 |
#' |
|
668 |
#' @return Tabulated statistics for the given variable(s) from the logistic regression model. |
|
669 |
#' |
|
670 |
#' @examples |
|
671 |
#' h_logistic_inter_terms(c("RACE", "AGE", "ARMCD", "AGE:ARMCD"), mod2) |
|
672 |
#' |
|
673 |
#' @export |
|
674 |
h_logistic_inter_terms <- function(x, |
|
675 |
fit_glm, |
|
676 |
conf_level = 0.95, |
|
677 |
at = NULL) { |
|
678 |
# Find out the interaction variables and interaction term. |
|
679 | 5x |
inter_vars <- h_get_interaction_vars(fit_glm) |
680 | 5x |
checkmate::assert_vector(inter_vars, len = 2) |
681 | ||
682 | ||
683 | 5x |
inter_term_index <- intersect(grep(inter_vars[1], x), grep(inter_vars[2], x)) |
684 | 5x |
inter_term <- x[inter_term_index] |
685 | ||
686 |
# For the non-interaction vars we need the standard stuff. |
|
687 | 5x |
normal_terms <- setdiff(x, union(inter_vars, inter_term)) |
688 | ||
689 | 5x |
x_stats <- lapply(normal_terms, h_glm_simple_term_extract, fit_glm) |
690 | 5x |
x_stats <- do.call(rbind, x_stats) |
691 | 5x |
q_norm <- stats::qnorm((1 + conf_level) / 2) |
692 | 5x |
x_stats$odds_ratio <- lapply(x_stats$estimate, exp) |
693 | 5x |
x_stats$lcl <- Map(function(or, se) exp(log(or) - q_norm * se), x_stats$odds_ratio, x_stats$std_error) |
694 | 5x |
x_stats$ucl <- Map(function(or, se) exp(log(or) + q_norm * se), x_stats$odds_ratio, x_stats$std_error) |
695 | 5x |
normal_stats <- x_stats |
696 | 5x |
normal_stats$is_reference_summary <- FALSE |
697 | ||
698 |
# Now the interaction term itself. |
|
699 | 5x |
inter_term_stats <- h_glm_interaction_extract(inter_term, fit_glm) |
700 | 5x |
inter_term_stats$odds_ratio <- NA |
701 | 5x |
inter_term_stats$lcl <- NA |
702 | 5x |
inter_term_stats$ucl <- NA |
703 | 5x |
inter_term_stats$is_reference_summary <- FALSE |
704 | ||
705 | 5x |
is_intervar1_numeric <- attr(fit_glm$terms, "dataClasses")[inter_vars[1]] == "numeric" |
706 | ||
707 |
# Interaction stuff. |
|
708 | 5x |
inter_stats_one <- h_glm_inter_term_extract( |
709 | 5x |
inter_vars[1], |
710 | 5x |
inter_vars[2], |
711 | 5x |
fit_glm, |
712 | 5x |
conf_level = conf_level, |
713 | 5x |
at = `if`(is_intervar1_numeric, NULL, at) |
714 |
) |
|
715 | 5x |
inter_stats_two <- h_glm_inter_term_extract( |
716 | 5x |
inter_vars[2], |
717 | 5x |
inter_vars[1], |
718 | 5x |
fit_glm, |
719 | 5x |
conf_level = conf_level, |
720 | 5x |
at = `if`(is_intervar1_numeric, at, NULL) |
721 |
) |
|
722 | ||
723 |
# Now just combine everything in one data frame. |
|
724 | 5x |
col_names <- c( |
725 | 5x |
"variable", |
726 | 5x |
"variable_label", |
727 | 5x |
"term", |
728 | 5x |
"term_label", |
729 | 5x |
"interaction", |
730 | 5x |
"interaction_label", |
731 | 5x |
"reference", |
732 | 5x |
"reference_label", |
733 | 5x |
"estimate", |
734 | 5x |
"std_error", |
735 | 5x |
"df", |
736 | 5x |
"pvalue", |
737 | 5x |
"odds_ratio", |
738 | 5x |
"lcl", |
739 | 5x |
"ucl", |
740 | 5x |
"is_variable_summary", |
741 | 5x |
"is_term_summary", |
742 | 5x |
"is_reference_summary" |
743 |
) |
|
744 | 5x |
df <- rbind( |
745 | 5x |
inter_stats_one[, col_names], |
746 | 5x |
inter_stats_two[, col_names], |
747 | 5x |
inter_term_stats[, col_names] |
748 |
) |
|
749 | 5x |
if (length(normal_terms) > 0) { |
750 | 5x |
df <- rbind( |
751 | 5x |
normal_stats[, col_names], |
752 | 5x |
df |
753 |
) |
|
754 |
} |
|
755 | 5x |
df$ci <- combine_vectors(df$lcl, df$ucl) |
756 | 5x |
df |
757 |
} |
1 |
#' Convert `rtable` objects to `ggplot` objects |
|
2 |
#' |
|
3 |
#' @description `r lifecycle::badge("experimental")` |
|
4 |
#' |
|
5 |
#' Given a [rtables::rtable()] object, performs basic conversion to a [ggplot2::ggplot()] object built using |
|
6 |
#' functions from the `ggplot2` package. Any table titles and/or footnotes are ignored. |
|
7 |
#' |
|
8 |
#' @param tbl (`VTableTree`)\cr `rtables` table object. |
|
9 |
#' @param fontsize (`numeric(1)`)\cr font size. |
|
10 |
#' @param colwidths (`numeric` or `NULL`)\cr a vector of column widths. Each element's position in |
|
11 |
#' `colwidths` corresponds to the column of `tbl` in the same position. If `NULL`, column widths |
|
12 |
#' are calculated according to maximum number of characters per column. |
|
13 |
#' @param lbl_col_padding (`numeric`)\cr additional padding to use when calculating spacing between |
|
14 |
#' the first (label) column and the second column of `tbl`. If `colwidths` is specified, |
|
15 |
#' the width of the first column becomes `colwidths[1] + lbl_col_padding`. Defaults to 0. |
|
16 |
#' |
|
17 |
#' @return A `ggplot` object. |
|
18 |
#' |
|
19 |
#' @examples |
|
20 |
#' dta <- data.frame( |
|
21 |
#' ARM = rep(LETTERS[1:3], rep(6, 3)), |
|
22 |
#' AVISIT = rep(paste0("V", 1:3), 6), |
|
23 |
#' AVAL = c(9:1, rep(NA, 9)) |
|
24 |
#' ) |
|
25 |
#' |
|
26 |
#' lyt <- basic_table() %>% |
|
27 |
#' split_cols_by(var = "ARM") %>% |
|
28 |
#' split_rows_by(var = "AVISIT") %>% |
|
29 |
#' analyze_vars(vars = "AVAL") |
|
30 |
#' |
|
31 |
#' tbl <- build_table(lyt, df = dta) |
|
32 |
#' |
|
33 |
#' rtable2gg(tbl) |
|
34 |
#' |
|
35 |
#' rtable2gg(tbl, fontsize = 15, colwidths = c(2, 1, 1, 1)) |
|
36 |
#' |
|
37 |
#' @export |
|
38 |
rtable2gg <- function(tbl, fontsize = 12, colwidths = NULL, lbl_col_padding = 0) { |
|
39 | 6x |
mat <- rtables::matrix_form(tbl, indent_rownames = TRUE) |
40 | 6x |
mat_strings <- formatters::mf_strings(mat) |
41 | 6x |
mat_aligns <- formatters::mf_aligns(mat) |
42 | 6x |
mat_indent <- formatters::mf_rinfo(mat)$indent |
43 | 6x |
mat_display <- formatters::mf_display(mat) |
44 | 6x |
nlines_hdr <- formatters::mf_nlheader(mat) |
45 | 6x |
shared_hdr_rows <- which(apply(mat_display, 1, function(x) (any(!x)))) |
46 | ||
47 | 6x |
tbl_df <- data.frame(mat_strings) |
48 | 6x |
body_rows <- seq(nlines_hdr + 1, nrow(tbl_df)) |
49 | 6x |
mat_aligns <- apply(mat_aligns, 1:2, function(x) if (x == "left") 0 else if (x == "right") 1 else 0.5) |
50 | ||
51 |
# Apply indentation in first column |
|
52 | 6x |
tbl_df[body_rows, 1] <- sapply(body_rows, function(i) { |
53 | 42x |
ind_i <- mat_indent[i - nlines_hdr] * 4 |
54 | 18x |
if (ind_i > 0) paste0(paste(rep(" ", ind_i), collapse = ""), tbl_df[i, 1]) else tbl_df[i, 1] |
55 |
}) |
|
56 | ||
57 |
# Get column widths |
|
58 | 6x |
if (is.null(colwidths)) { |
59 | 6x |
colwidths <- apply(tbl_df, 2, function(x) max(nchar(x))) + 1 |
60 |
} |
|
61 | 6x |
tot_width <- sum(colwidths) + lbl_col_padding |
62 | ||
63 | 6x |
if (length(shared_hdr_rows) > 0) { |
64 | 5x |
tbl_df <- tbl_df[-shared_hdr_rows, ] |
65 | 5x |
mat_aligns <- mat_aligns[-shared_hdr_rows, ] |
66 |
} |
|
67 | ||
68 | 6x |
res <- ggplot(data = tbl_df) + |
69 | 6x |
theme_void() + |
70 | 6x |
scale_x_continuous(limits = c(0, tot_width)) + |
71 | 6x |
scale_y_continuous(limits = c(0, nrow(mat_strings))) + |
72 | 6x |
annotate( |
73 | 6x |
"segment", |
74 | 6x |
x = 0, xend = tot_width, |
75 | 6x |
y = nrow(mat_strings) - nlines_hdr + 0.5, yend = nrow(mat_strings) - nlines_hdr + 0.5 |
76 |
) |
|
77 | ||
78 |
# If header content spans multiple columns, center over these columns |
|
79 | 6x |
if (length(shared_hdr_rows) > 0) { |
80 | 5x |
mat_strings[shared_hdr_rows, ] <- trimws(mat_strings[shared_hdr_rows, ]) |
81 | 5x |
for (hr in shared_hdr_rows) { |
82 | 6x |
hdr_lbls <- mat_strings[1:hr, mat_display[hr, -1]] |
83 | 6x |
hdr_lbls <- matrix(hdr_lbls[nzchar(hdr_lbls)], nrow = hr) |
84 | 6x |
for (idx_hl in seq_len(ncol(hdr_lbls))) { |
85 | 13x |
cur_lbl <- tail(hdr_lbls[, idx_hl], 1) |
86 | 13x |
which_cols <- if (hr == 1) { |
87 | 9x |
which(mat_strings[hr, ] == hdr_lbls[idx_hl]) |
88 | 13x |
} else { # for >2 col splits, only print labels for each unique combo of nested columns |
89 | 4x |
which( |
90 | 4x |
apply(mat_strings[1:hr, ], 2, function(x) all(x == hdr_lbls[1:hr, idx_hl])) |
91 |
) |
|
92 |
} |
|
93 | 13x |
line_pos <- c( |
94 | 13x |
sum(colwidths[1:(which_cols[1] - 1)]) + 1 + lbl_col_padding, |
95 | 13x |
sum(colwidths[1:max(which_cols)]) - 1 + lbl_col_padding |
96 |
) |
|
97 | ||
98 | 13x |
res <- res + |
99 | 13x |
annotate( |
100 | 13x |
"text", |
101 | 13x |
x = mean(line_pos), |
102 | 13x |
y = nrow(mat_strings) + 1 - hr, |
103 | 13x |
label = cur_lbl, |
104 | 13x |
size = fontsize / .pt |
105 |
) + |
|
106 | 13x |
annotate( |
107 | 13x |
"segment", |
108 | 13x |
x = line_pos[1], |
109 | 13x |
xend = line_pos[2], |
110 | 13x |
y = nrow(mat_strings) - hr + 0.5, |
111 | 13x |
yend = nrow(mat_strings) - hr + 0.5 |
112 |
) |
|
113 |
} |
|
114 |
} |
|
115 |
} |
|
116 | ||
117 |
# Add table columns |
|
118 | 6x |
for (i in seq_len(ncol(tbl_df))) { |
119 | 40x |
res <- res + annotate( |
120 | 40x |
"text", |
121 | 40x |
x = if (i == 1) 0 else sum(colwidths[1:i]) - 0.5 * colwidths[i] + lbl_col_padding, |
122 | 40x |
y = rev(seq_len(nrow(tbl_df))), |
123 | 40x |
label = tbl_df[, i], |
124 | 40x |
hjust = mat_aligns[, i], |
125 | 40x |
size = fontsize / .pt |
126 |
) |
|
127 |
} |
|
128 | ||
129 | 6x |
res |
130 |
} |
|
131 | ||
132 |
#' Convert `data.frame` object to `ggplot` object |
|
133 |
#' |
|
134 |
#' @description `r lifecycle::badge("experimental")` |
|
135 |
#' |
|
136 |
#' Given a `data.frame` object, performs basic conversion to a [ggplot2::ggplot()] object built using |
|
137 |
#' functions from the `ggplot2` package. |
|
138 |
#' |
|
139 |
#' @param df (`data.frame`)\cr a data frame. |
|
140 |
#' @param colwidths (`numeric` or `NULL`)\cr a vector of column widths. Each element's position in |
|
141 |
#' `colwidths` corresponds to the column of `df` in the same position. If `NULL`, column widths |
|
142 |
#' are calculated according to maximum number of characters per column. |
|
143 |
#' @param font_size (`numeric(1)`)\cr font size. |
|
144 |
#' @param col_labels (`flag`)\cr whether the column names (labels) of `df` should be used as the first row |
|
145 |
#' of the output table. |
|
146 |
#' @param col_lab_fontface (`string`)\cr font face to apply to the first row (of column labels |
|
147 |
#' if `col_labels = TRUE`). Defaults to `"bold"`. |
|
148 |
#' @param hline (`flag`)\cr whether a horizontal line should be printed below the first row of the table. |
|
149 |
#' @param bg_fill (`string`)\cr table background fill color. |
|
150 |
#' |
|
151 |
#' @return A `ggplot` object. |
|
152 |
#' |
|
153 |
#' @examples |
|
154 |
#' \dontrun{ |
|
155 |
#' df2gg(head(iris, 5)) |
|
156 |
#' |
|
157 |
#' df2gg(head(iris, 5), font_size = 15, colwidths = c(1, 1, 1, 1, 1)) |
|
158 |
#' } |
|
159 |
#' @keywords internal |
|
160 |
df2gg <- function(df, |
|
161 |
colwidths = NULL, |
|
162 |
font_size = 10, |
|
163 |
col_labels = TRUE, |
|
164 |
col_lab_fontface = "bold", |
|
165 |
hline = TRUE, |
|
166 |
bg_fill = NULL) { |
|
167 |
# convert to text |
|
168 | 19x |
df <- as.data.frame(apply(df, 1:2, function(x) if (is.na(x)) "NA" else as.character(x))) |
169 | ||
170 | 19x |
if (col_labels) { |
171 | 10x |
df <- as.matrix(df) |
172 | 10x |
df <- rbind(colnames(df), df) |
173 |
} |
|
174 | ||
175 |
# Get column widths |
|
176 | 19x |
if (is.null(colwidths)) { |
177 | 1x |
colwidths <- apply(df, 2, function(x) max(nchar(x), na.rm = TRUE)) |
178 |
} |
|
179 | 19x |
tot_width <- sum(colwidths) |
180 | ||
181 | 19x |
res <- ggplot(data = df) + |
182 | 19x |
theme_void() + |
183 | 19x |
scale_x_continuous(limits = c(0, tot_width)) + |
184 | 19x |
scale_y_continuous(limits = c(1, nrow(df))) |
185 | ||
186 | 9x |
if (!is.null(bg_fill)) res <- res + theme(plot.background = element_rect(fill = bg_fill)) |
187 | ||
188 | 19x |
if (hline) { |
189 | 10x |
res <- res + |
190 | 10x |
annotate( |
191 | 10x |
"segment", |
192 | 10x |
x = 0 + 0.2 * colwidths[2], xend = tot_width - 0.1 * tail(colwidths, 1), |
193 | 10x |
y = nrow(df) - 0.5, yend = nrow(df) - 0.5 |
194 |
) |
|
195 |
} |
|
196 | ||
197 | 19x |
for (i in seq_len(ncol(df))) { |
198 | 86x |
line_pos <- c( |
199 | 86x |
if (i == 1) 0 else sum(colwidths[1:(i - 1)]), |
200 | 86x |
sum(colwidths[1:i]) |
201 |
) |
|
202 | 86x |
res <- res + |
203 | 86x |
annotate( |
204 | 86x |
"text", |
205 | 86x |
x = mean(line_pos), |
206 | 86x |
y = rev(seq_len(nrow(df))), |
207 | 86x |
label = df[, i], |
208 | 86x |
size = font_size / .pt, |
209 | 86x |
fontface = if (col_labels) { |
210 | 32x |
c(col_lab_fontface, rep("plain", nrow(df) - 1)) |
211 |
} else { |
|
212 | 54x |
rep("plain", nrow(df)) |
213 |
} |
|
214 |
) |
|
215 |
} |
|
216 | ||
217 | 19x |
res |
218 |
} |
1 |
#' Tabulate binary response by subgroup |
|
2 |
#' |
|
3 |
#' @description `r lifecycle::badge("stable")` |
|
4 |
#' |
|
5 |
#' The [tabulate_rsp_subgroups()] function creates a layout element to tabulate binary response by subgroup, returning |
|
6 |
#' statistics including response rate and odds ratio for each population subgroup. The table is created from `df`, a |
|
7 |
#' list of data frames returned by [extract_rsp_subgroups()], with the statistics to include specified via the `vars` |
|
8 |
#' parameter. |
|
9 |
#' |
|
10 |
#' A forest plot can be created from the resulting table using the [g_forest()] function. |
|
11 |
#' |
|
12 |
#' @inheritParams extract_rsp_subgroups |
|
13 |
#' @inheritParams argument_convention |
|
14 |
#' |
|
15 |
#' @details These functions create a layout starting from a data frame which contains |
|
16 |
#' the required statistics. Tables typically used as part of forest plot. |
|
17 |
#' |
|
18 |
#' @seealso [extract_rsp_subgroups()] |
|
19 |
#' |
|
20 |
#' @examples |
|
21 |
#' library(dplyr) |
|
22 |
#' library(forcats) |
|
23 |
#' |
|
24 |
#' adrs <- tern_ex_adrs |
|
25 |
#' adrs_labels <- formatters::var_labels(adrs) |
|
26 |
#' |
|
27 |
#' adrs_f <- adrs %>% |
|
28 |
#' filter(PARAMCD == "BESRSPI") %>% |
|
29 |
#' filter(ARM %in% c("A: Drug X", "B: Placebo")) %>% |
|
30 |
#' droplevels() %>% |
|
31 |
#' mutate( |
|
32 |
#' # Reorder levels of factor to make the placebo group the reference arm. |
|
33 |
#' ARM = fct_relevel(ARM, "B: Placebo"), |
|
34 |
#' rsp = AVALC == "CR" |
|
35 |
#' ) |
|
36 |
#' formatters::var_labels(adrs_f) <- c(adrs_labels, "Response") |
|
37 |
#' |
|
38 |
#' # Unstratified analysis. |
|
39 |
#' df <- extract_rsp_subgroups( |
|
40 |
#' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")), |
|
41 |
#' data = adrs_f |
|
42 |
#' ) |
|
43 |
#' df |
|
44 |
#' |
|
45 |
#' # Stratified analysis. |
|
46 |
#' df_strat <- extract_rsp_subgroups( |
|
47 |
#' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2"), strata = "STRATA1"), |
|
48 |
#' data = adrs_f |
|
49 |
#' ) |
|
50 |
#' df_strat |
|
51 |
#' |
|
52 |
#' # Grouping of the BMRKR2 levels. |
|
53 |
#' df_grouped <- extract_rsp_subgroups( |
|
54 |
#' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")), |
|
55 |
#' data = adrs_f, |
|
56 |
#' groups_lists = list( |
|
57 |
#' BMRKR2 = list( |
|
58 |
#' "low" = "LOW", |
|
59 |
#' "low/medium" = c("LOW", "MEDIUM"), |
|
60 |
#' "low/medium/high" = c("LOW", "MEDIUM", "HIGH") |
|
61 |
#' ) |
|
62 |
#' ) |
|
63 |
#' ) |
|
64 |
#' df_grouped |
|
65 |
#' |
|
66 |
#' @name response_subgroups |
|
67 |
#' @order 1 |
|
68 |
NULL |
|
69 | ||
70 |
#' Prepare response data for population subgroups in data frames |
|
71 |
#' |
|
72 |
#' @description `r lifecycle::badge("stable")` |
|
73 |
#' |
|
74 |
#' Prepares response rates and odds ratios for population subgroups in data frames. Simple wrapper |
|
75 |
#' for [h_odds_ratio_subgroups_df()] and [h_proportion_subgroups_df()]. Result is a list of two |
|
76 |
#' `data.frames`: `prop` and `or`. `variables` corresponds to the names of variables found in `data`, |
|
77 |
#' passed as a named `list` and requires elements `rsp`, `arm` and optionally `subgroups` and `strata`. |
|
78 |
#' `groups_lists` optionally specifies groupings for `subgroups` variables. |
|
79 |
#' |
|
80 |
#' @inheritParams argument_convention |
|
81 |
#' @inheritParams response_subgroups |
|
82 |
#' @param label_all (`string`)\cr label for the total population analysis. |
|
83 |
#' |
|
84 |
#' @return A named list of two elements: |
|
85 |
#' * `prop`: A `data.frame` containing columns `arm`, `n`, `n_rsp`, `prop`, `subgroup`, `var`, |
|
86 |
#' `var_label`, and `row_type`. |
|
87 |
#' * `or`: A `data.frame` containing columns `arm`, `n_tot`, `or`, `lcl`, `ucl`, `conf_level`, |
|
88 |
#' `subgroup`, `var`, `var_label`, and `row_type`. |
|
89 |
#' |
|
90 |
#' @seealso [response_subgroups] |
|
91 |
#' |
|
92 |
#' @export |
|
93 |
extract_rsp_subgroups <- function(variables, |
|
94 |
data, |
|
95 |
groups_lists = list(), |
|
96 |
conf_level = 0.95, |
|
97 |
method = NULL, |
|
98 |
label_all = "All Patients") { |
|
99 | 14x |
if ("strat" %in% names(variables)) { |
100 | ! |
warning( |
101 | ! |
"Warning: the `strat` element name of the `variables` list argument to `extract_rsp_subgroups() ", |
102 | ! |
"was deprecated in tern 0.9.4.\n ", |
103 | ! |
"Please use the name `strata` instead of `strat` in the `variables` argument." |
104 |
) |
|
105 | ! |
variables[["strata"]] <- variables[["strat"]] |
106 |
} |
|
107 | ||
108 | 14x |
df_prop <- h_proportion_subgroups_df( |
109 | 14x |
variables, |
110 | 14x |
data, |
111 | 14x |
groups_lists = groups_lists, |
112 | 14x |
label_all = label_all |
113 |
) |
|
114 | 14x |
df_or <- h_odds_ratio_subgroups_df( |
115 | 14x |
variables, |
116 | 14x |
data, |
117 | 14x |
groups_lists = groups_lists, |
118 | 14x |
conf_level = conf_level, |
119 | 14x |
method = method, |
120 | 14x |
label_all = label_all |
121 |
) |
|
122 | ||
123 | 14x |
list(prop = df_prop, or = df_or) |
124 |
} |
|
125 | ||
126 |
#' @describeIn response_subgroups Formatted analysis function which is used as `afun` in `tabulate_rsp_subgroups()`. |
|
127 |
#' |
|
128 |
#' @return |
|
129 |
#' * `a_response_subgroups()` returns the corresponding list with formatted [rtables::CellValue()]. |
|
130 |
#' |
|
131 |
#' @keywords internal |
|
132 |
a_response_subgroups <- function(df, |
|
133 |
labelstr = "", |
|
134 |
..., |
|
135 |
.stats = NULL, |
|
136 |
.stat_names = NULL, |
|
137 |
.formats = NULL, |
|
138 |
.labels = NULL, |
|
139 |
.indent_mods = NULL) { |
|
140 |
# Check for additional parameters to the statistics function |
|
141 | 375x |
dots_extra_args <- list(...) |
142 | 375x |
extra_afun_params <- retrieve_extra_afun_params(names(dots_extra_args$.additional_fun_parameters)) |
143 | 375x |
dots_extra_args$.additional_fun_parameters <- NULL |
144 | 375x |
cur_col_stat <- extra_afun_params$.var %||% .stats |
145 | ||
146 |
# Uniquely name & label rows |
|
147 | 375x |
var_lvls <- if ("biomarker" %in% names(dots_extra_args) && "biomarker" %in% names(df)) { |
148 | 90x |
if ("overall" %in% names(dots_extra_args)) { # label rows for (nested) biomarker tables - e.g. "AGE", "BMRKR1" |
149 | 42x |
as.character(df$biomarker) |
150 | 375x |
} else { # data rows for (nested) biomarker tables - e.g. "AGE.LOW", "BMRKR1.Total Patients" |
151 | 48x |
paste(as.character(df$biomarker), as.character(df$subgroup), sep = ".") |
152 |
} |
|
153 | 375x |
} else { # data rows for non-biomarker tables - e.g. "Total Patients", "F", "M" |
154 | 285x |
make.unique(as.character(df$subgroup)) |
155 |
} |
|
156 | ||
157 |
# if empty, return NA |
|
158 | 375x |
if (nrow(df) == 0) { |
159 | 1x |
return(in_rows(.list = list(NA) %>% stats::setNames(cur_col_stat))) |
160 |
} |
|
161 | ||
162 |
# Main statistics taken from df |
|
163 | 374x |
x_stats <- as.list(df) |
164 | ||
165 |
# Fill in formatting defaults |
|
166 | 374x |
.stats <- get_stats("tabulate_rsp_subgroups", stats_in = cur_col_stat) |
167 | 374x |
levels_per_stats <- rep(list(var_lvls), length(.stats)) %>% setNames(.stats) |
168 | 374x |
.formats <- get_formats_from_stats(.stats, .formats, levels_per_stats) |
169 | 374x |
.labels <- get_labels_from_stats( |
170 | 374x |
.stats, .labels, levels_per_stats, |
171 |
# default labels are pre-determined in extract_*() function |
|
172 | 374x |
tern_defaults = as.list(as.character(df$subgroup)) %>% setNames(var_lvls) |
173 |
) |
|
174 | 374x |
.indent_mods <- get_indents_from_stats(.stats, .indent_mods, levels_per_stats) |
175 | ||
176 | 374x |
x_stats <- lapply( |
177 | 374x |
.stats, |
178 | 374x |
function(x) x_stats[[x]] %>% stats::setNames(var_lvls) |
179 |
) %>% |
|
180 | 374x |
stats::setNames(.stats) %>% |
181 | 374x |
.unlist_keep_nulls() |
182 | ||
183 | 374x |
.nms <- if ("biomarker" %in% names(dots_extra_args)) var_lvls else names(.labels) |
184 | ||
185 |
# Auto format handling |
|
186 | 374x |
.formats <- apply_auto_formatting(.formats, x_stats, extra_afun_params$.df_row, extra_afun_params$.var) |
187 | ||
188 |
# Get and check statistical names |
|
189 | 374x |
.stat_names <- get_stat_names(x_stats, .stat_names) |
190 | ||
191 | 374x |
in_rows( |
192 | 374x |
.list = x_stats, |
193 | 374x |
.formats = .formats, |
194 | 374x |
.names = .nms, |
195 | 374x |
.stat_names = .stat_names, |
196 | 374x |
.labels = .labels %>% .unlist_keep_nulls(), |
197 | 374x |
.indent_mods = .indent_mods %>% .unlist_keep_nulls() |
198 |
) |
|
199 |
} |
|
200 | ||
201 |
#' @describeIn response_subgroups Table-creating function which creates a table |
|
202 |
#' summarizing binary response by subgroup. This function is a wrapper for [rtables::analyze_colvars()] |
|
203 |
#' and [rtables::summarize_row_groups()]. |
|
204 |
#' |
|
205 |
#' @param df (`list`)\cr a list of data frames containing all analysis variables. List should be |
|
206 |
#' created using [extract_rsp_subgroups()]. |
|
207 |
#' @param vars (`character`)\cr the names of statistics to be reported among: |
|
208 |
#' * `n`: Total number of observations per group. |
|
209 |
#' * `n_rsp`: Number of responders per group. |
|
210 |
#' * `prop`: Proportion of responders. |
|
211 |
#' * `n_tot`: Total number of observations. |
|
212 |
#' * `or`: Odds ratio. |
|
213 |
#' * `ci` : Confidence interval of odds ratio. |
|
214 |
#' * `pval`: p-value of the effect. |
|
215 |
#' Note, the statistics `n_tot`, `or`, and `ci` are required. |
|
216 |
#' @param riskdiff (`list`)\cr if a risk (proportion) difference column should be added, a list of settings to apply |
|
217 |
#' within the column. See [control_riskdiff()] for details. If `NULL`, no risk difference column will be added. If |
|
218 |
#' `riskdiff$arm_x` and `riskdiff$arm_y` are `NULL`, the first level of `df$prop$arm` will be used as `arm_x` and |
|
219 |
#' the second level as `arm_y`. |
|
220 |
#' |
|
221 |
#' @return An `rtables` table summarizing binary response by subgroup. |
|
222 |
#' |
|
223 |
#' @examples |
|
224 |
#' # Table with default columns |
|
225 |
#' basic_table() %>% |
|
226 |
#' tabulate_rsp_subgroups(df) |
|
227 |
#' |
|
228 |
#' # Table with selected columns |
|
229 |
#' basic_table() %>% |
|
230 |
#' tabulate_rsp_subgroups( |
|
231 |
#' df = df, |
|
232 |
#' vars = c("n_tot", "n", "n_rsp", "prop", "or", "ci") |
|
233 |
#' ) |
|
234 |
#' |
|
235 |
#' # Table with risk difference column added |
|
236 |
#' basic_table() %>% |
|
237 |
#' tabulate_rsp_subgroups( |
|
238 |
#' df, |
|
239 |
#' riskdiff = control_riskdiff( |
|
240 |
#' arm_x = levels(df$prop$arm)[1], |
|
241 |
#' arm_y = levels(df$prop$arm)[2] |
|
242 |
#' ) |
|
243 |
#' ) |
|
244 |
#' |
|
245 |
#' @export |
|
246 |
#' @order 2 |
|
247 |
tabulate_rsp_subgroups <- function(lyt, |
|
248 |
df, |
|
249 |
vars = c("n_tot", "n", "prop", "or", "ci"), |
|
250 |
groups_lists = list(), |
|
251 |
label_all = lifecycle::deprecated(), |
|
252 |
riskdiff = NULL, |
|
253 |
na_str = default_na_str(), |
|
254 |
..., |
|
255 |
.stat_names = NULL, |
|
256 |
.formats = NULL, |
|
257 |
.labels = NULL, |
|
258 |
.indent_mods = NULL) { |
|
259 | 14x |
checkmate::assert_list(riskdiff, null.ok = TRUE) |
260 | 14x |
checkmate::assert_true(all(c("n_tot", "or", "ci") %in% vars)) |
261 | 14x |
if ("pval" %in% vars && !"pval" %in% names(df$or)) { |
262 | 1x |
warning( |
263 | 1x |
'The "pval" statistic has been selected but is not present in "df" so it will not be included in the output ', |
264 | 1x |
'table. To include the "pval" statistic, please specify a p-value test when generating "df" via ', |
265 | 1x |
'the "method" argument to `extract_rsp_subgroups()`. If method = "cmh", strata must also be specified via the ', |
266 | 1x |
'"variables" argument to `extract_rsp_subgroups()`.' |
267 |
) |
|
268 |
} |
|
269 | ||
270 | 14x |
if (lifecycle::is_present(label_all)) { |
271 | ! |
lifecycle::deprecate_warn( |
272 | ! |
"0.9.8", "tabulate_rsp_subgroups(label_all)", |
273 | ! |
details = |
274 | ! |
"Please assign the `label_all` parameter within the `extract_rsp_subgroups()` function when creating `df`." |
275 |
) |
|
276 |
} |
|
277 | ||
278 |
# Process standard extra arguments |
|
279 | 14x |
extra_args <- list(".stats" = vars) |
280 | ! |
if (!is.null(.stat_names)) extra_args[[".stat_names"]] <- .stat_names |
281 | 1x |
if (!is.null(.formats)) extra_args[[".formats"]] <- .formats |
282 | ! |
if (!is.null(.labels)) extra_args[[".labels"]] <- .labels |
283 | ! |
if (!is.null(.indent_mods)) extra_args[[".indent_mods"]] <- .indent_mods |
284 | ||
285 |
# Create "ci" column from "lcl" and "ucl" |
|
286 | 14x |
df$or$ci <- combine_vectors(df$or$lcl, df$or$ucl) |
287 | ||
288 |
# Extract additional parameters from df |
|
289 | 14x |
conf_level <- df$or$conf_level[1] |
290 | 14x |
method <- if ("pval_label" %in% names(df$or)) df$or$pval_label[1] else NULL |
291 | 14x |
colvars <- d_rsp_subgroups_colvars(vars, conf_level = conf_level, method = method) |
292 | 14x |
prop_vars <- intersect(colvars$vars, c("n", "prop", "n_rsp")) |
293 | 14x |
or_vars <- intersect(names(colvars$labels), c("n_tot", "or", "ci", "pval")) |
294 | 14x |
colvars_prop <- list(vars = prop_vars, labels = colvars$labels[prop_vars]) |
295 | 14x |
colvars_or <- list(vars = or_vars, labels = colvars$labels[or_vars]) |
296 | ||
297 |
# Process additional arguments to the statistic function |
|
298 | 14x |
extra_args <- c( |
299 | 14x |
extra_args, |
300 | 14x |
groups_lists = list(groups_lists), conf_level = conf_level, method = method, |
301 |
... |
|
302 |
) |
|
303 | ||
304 |
# Adding additional info from layout to analysis function |
|
305 | 14x |
extra_args[[".additional_fun_parameters"]] <- get_additional_afun_params(add_alt_df = FALSE) |
306 | 14x |
formals(a_response_subgroups) <- c(formals(a_response_subgroups), extra_args[[".additional_fun_parameters"]]) |
307 | ||
308 |
# Add risk difference column |
|
309 | 14x |
if (!is.null(riskdiff)) { |
310 | ! |
if (is.null(riskdiff$arm_x)) riskdiff$arm_x <- levels(df$prop$arm)[1] |
311 | ! |
if (is.null(riskdiff$arm_y)) riskdiff$arm_y <- levels(df$prop$arm)[2] |
312 | 2x |
colvars_or$vars <- c(colvars_or$vars, "riskdiff") |
313 | 2x |
colvars_or$labels <- c(colvars_or$labels, riskdiff = riskdiff$col_label) |
314 | 2x |
arm_cols <- paste(rep(c("n_rsp", "n_rsp", "n", "n")), c(riskdiff$arm_x, riskdiff$arm_y), sep = "_") |
315 | ||
316 | 2x |
df_prop_diff <- df$prop %>% |
317 | 2x |
dplyr::select(-"prop") %>% |
318 | 2x |
tidyr::pivot_wider( |
319 | 2x |
id_cols = c("subgroup", "var", "var_label", "row_type"), |
320 | 2x |
names_from = "arm", |
321 | 2x |
values_from = c("n", "n_rsp") |
322 |
) %>% |
|
323 | 2x |
dplyr::rowwise() %>% |
324 | 2x |
dplyr::mutate( |
325 | 2x |
riskdiff = stat_propdiff_ci( |
326 | 2x |
x = as.list(.data[[arm_cols[1]]]), |
327 | 2x |
y = as.list(.data[[arm_cols[2]]]), |
328 | 2x |
N_x = .data[[arm_cols[3]]], |
329 | 2x |
N_y = .data[[arm_cols[4]]], |
330 | 2x |
pct = riskdiff$pct |
331 |
) |
|
332 |
) %>% |
|
333 | 2x |
dplyr::select(-dplyr::all_of(arm_cols)) |
334 | ||
335 | 2x |
df$or <- df$or %>% |
336 | 2x |
dplyr::left_join( |
337 | 2x |
df_prop_diff, |
338 | 2x |
by = c("subgroup", "var", "var_label", "row_type") |
339 |
) |
|
340 |
} |
|
341 | ||
342 |
# Add columns from table_prop (optional) |
|
343 | 14x |
if (length(colvars_prop$vars) > 0) { |
344 | 13x |
lyt_prop <- split_cols_by(lyt = lyt, var = "arm") |
345 | 13x |
lyt_prop <- split_cols_by_multivar( |
346 | 13x |
lyt = lyt_prop, |
347 | 13x |
vars = colvars_prop$vars, |
348 | 13x |
varlabels = colvars_prop$labels |
349 |
) |
|
350 | ||
351 |
# Add "All Patients" row |
|
352 | 13x |
lyt_prop <- split_rows_by( |
353 | 13x |
lyt = lyt_prop, |
354 | 13x |
var = "row_type", |
355 | 13x |
split_fun = keep_split_levels("content"), |
356 | 13x |
nested = FALSE, |
357 | 13x |
child_labels = "hidden", |
358 | 13x |
parent_name = "All Patients" |
359 |
) |
|
360 | 13x |
lyt_prop <- analyze_colvars( |
361 | 13x |
lyt = lyt_prop, |
362 | 13x |
afun = a_response_subgroups, |
363 | 13x |
na_str = na_str, |
364 | 13x |
extra_args = extra_args |
365 |
) |
|
366 | ||
367 |
# Add analysis rows |
|
368 | 13x |
if ("analysis" %in% df$prop$row_type) { |
369 | 12x |
lyt_prop <- split_rows_by( |
370 | 12x |
lyt = lyt_prop, |
371 | 12x |
var = "row_type", |
372 | 12x |
split_fun = keep_split_levels("analysis"), |
373 | 12x |
nested = FALSE, |
374 | 12x |
child_labels = "hidden", |
375 | 12x |
parent_name = "analysis rows" |
376 |
) |
|
377 | 12x |
lyt_prop <- split_rows_by(lyt = lyt_prop, var = "var_label", nested = TRUE) |
378 | 12x |
lyt_prop <- analyze_colvars( |
379 | 12x |
lyt = lyt_prop, |
380 | 12x |
afun = a_response_subgroups, |
381 | 12x |
na_str = na_str, |
382 | 12x |
inclNAs = TRUE, |
383 | 12x |
extra_args = extra_args |
384 |
) |
|
385 |
} |
|
386 | ||
387 | 13x |
table_prop <- build_table(lyt_prop, df = df$prop) |
388 |
} else { |
|
389 | 1x |
table_prop <- NULL |
390 |
} |
|
391 | ||
392 |
# Add columns from table_or ("n_tot", "or", and "ci" required) |
|
393 | 14x |
lyt_or <- split_cols_by(lyt = lyt, var = "arm") |
394 | 14x |
lyt_or <- split_cols_by_multivar( |
395 | 14x |
lyt = lyt_or, |
396 | 14x |
vars = colvars_or$vars, |
397 | 14x |
varlabels = colvars_or$labels |
398 |
) |
|
399 | ||
400 |
# Add "All Patients" row |
|
401 | 14x |
lyt_or <- split_rows_by( |
402 | 14x |
lyt = lyt_or, |
403 | 14x |
var = "row_type", |
404 | 14x |
split_fun = keep_split_levels("content"), |
405 | 14x |
nested = FALSE, |
406 | 14x |
child_labels = "hidden", |
407 | 14x |
parent_name = "All Patients" |
408 |
) |
|
409 | 14x |
lyt_or <- analyze_colvars( |
410 | 14x |
lyt = lyt_or, |
411 | 14x |
afun = a_response_subgroups, |
412 | 14x |
na_str = na_str, |
413 | 14x |
extra_args = extra_args |
414 |
) %>% |
|
415 | 14x |
append_topleft("Baseline Risk Factors") |
416 | ||
417 |
# Add analysis rows |
|
418 | 14x |
if ("analysis" %in% df$or$row_type) { |
419 | 13x |
lyt_or <- split_rows_by( |
420 | 13x |
lyt = lyt_or, |
421 | 13x |
var = "row_type", |
422 | 13x |
split_fun = keep_split_levels("analysis"), |
423 | 13x |
nested = FALSE, |
424 | 13x |
child_labels = "hidden", |
425 | 13x |
parent_name = "analysis rows" |
426 |
) |
|
427 | 13x |
lyt_or <- split_rows_by(lyt = lyt_or, var = "var_label", nested = TRUE) |
428 | 13x |
lyt_or <- analyze_colvars( |
429 | 13x |
lyt = lyt_or, |
430 | 13x |
afun = a_response_subgroups, |
431 | 13x |
na_str = na_str, |
432 | 13x |
inclNAs = TRUE, |
433 | 13x |
extra_args = extra_args |
434 |
) |
|
435 |
} |
|
436 | ||
437 | 14x |
table_or <- build_table(lyt_or, df = df$or) |
438 | ||
439 |
# Join tables, add forest plot attributes |
|
440 | 14x |
n_tot_id <- match("n_tot", colvars_or$vars) |
441 | 14x |
if (is.null(table_prop)) { |
442 | 1x |
result <- table_or |
443 | 1x |
or_id <- match("or", colvars_or$vars) |
444 | 1x |
ci_id <- match("ci", colvars_or$vars) |
445 |
} else { |
|
446 | 13x |
result <- cbind_rtables(table_or[, n_tot_id], table_prop, table_or[, -n_tot_id]) |
447 | 13x |
or_id <- 1L + ncol(table_prop) + match("or", colvars_or$vars[-n_tot_id]) |
448 | 13x |
ci_id <- 1L + ncol(table_prop) + match("ci", colvars_or$vars[-n_tot_id]) |
449 | 13x |
n_tot_id <- 1L |
450 |
} |
|
451 | 14x |
structure( |
452 | 14x |
result, |
453 | 14x |
forest_header = paste0(levels(df$prop$arm), "\nBetter"), |
454 | 14x |
col_x = or_id, |
455 | 14x |
col_ci = ci_id, |
456 | 14x |
col_symbol_size = n_tot_id |
457 |
) |
|
458 |
} |
|
459 | ||
460 |
#' Labels for column variables in binary response by subgroup table |
|
461 |
#' |
|
462 |
#' @description `r lifecycle::badge("stable")` |
|
463 |
#' |
|
464 |
#' Internal function to check variables included in [tabulate_rsp_subgroups()] and create column labels. |
|
465 |
#' |
|
466 |
#' @inheritParams argument_convention |
|
467 |
#' @inheritParams tabulate_rsp_subgroups |
|
468 |
#' |
|
469 |
#' @return A `list` of variables to tabulate and their labels. |
|
470 |
#' |
|
471 |
#' @export |
|
472 |
d_rsp_subgroups_colvars <- function(vars, |
|
473 |
conf_level = NULL, |
|
474 |
method = NULL) { |
|
475 | 20x |
checkmate::assert_character(vars) |
476 | 20x |
checkmate::assert_subset(c("n_tot", "or", "ci"), vars) |
477 | 20x |
checkmate::assert_subset( |
478 | 20x |
vars, |
479 | 20x |
c("n", "n_rsp", "prop", "n_tot", "or", "ci", "pval") |
480 |
) |
|
481 | ||
482 | 20x |
varlabels <- c( |
483 | 20x |
n = "n", |
484 | 20x |
n_rsp = "Responders", |
485 | 20x |
prop = "Response (%)", |
486 | 20x |
n_tot = "Total n", |
487 | 20x |
or = "Odds Ratio" |
488 |
) |
|
489 | 20x |
colvars <- vars |
490 | ||
491 | 20x |
if ("ci" %in% colvars) { |
492 | 20x |
checkmate::assert_false(is.null(conf_level)) |
493 | ||
494 | 20x |
varlabels <- c( |
495 | 20x |
varlabels, |
496 | 20x |
ci = paste0(100 * conf_level, "% CI") |
497 |
) |
|
498 |
} |
|
499 | ||
500 | 20x |
if ("pval" %in% colvars) { |
501 | 14x |
varlabels <- c( |
502 | 14x |
varlabels, |
503 | 14x |
pval = method |
504 |
) |
|
505 |
} |
|
506 | ||
507 | 20x |
list( |
508 | 20x |
vars = colvars, |
509 | 20x |
labels = varlabels[vars] |
510 |
) |
|
511 |
} |
1 |
#' Count patients with toxicity grades that have worsened from baseline by highest grade post-baseline |
|
2 |
#' |
|
3 |
#' @description `r lifecycle::badge("stable")` |
|
4 |
#' |
|
5 |
#' The analyze function [count_abnormal_lab_worsen_by_baseline()] creates a layout element to count patients with |
|
6 |
#' analysis toxicity grades which have worsened from baseline, categorized by highest (worst) grade post-baseline. |
|
7 |
#' |
|
8 |
#' This function analyzes primary analysis variable `var` which indicates analysis toxicity grades. Additional |
|
9 |
#' analysis variables that can be supplied as a list via the `variables` parameter are `id` (defaults to `USUBJID`), |
|
10 |
#' a variable to indicate unique subject identifiers, `baseline_var` (defaults to `BTOXGR`), a variable to indicate |
|
11 |
#' baseline toxicity grades, and `direction_var` (defaults to `GRADDIR`), a variable to indicate toxicity grade |
|
12 |
#' directions of interest to include (e.g. `"H"` (high), `"L"` (low), or `"B"` (both)). |
|
13 |
#' |
|
14 |
#' For the direction(s) specified in `direction_var`, patient counts by worst grade for patients who have |
|
15 |
#' worsened from baseline are calculated as follows: |
|
16 |
#' * `1` to `4`: The number of patients who have worsened from their baseline grades with worst |
|
17 |
#' grades 1-4, respectively. |
|
18 |
#' * `Any`: The total number of patients who have worsened from their baseline grades. |
|
19 |
#' |
|
20 |
#' Fractions are calculated by dividing the above counts by the number of patients who's analysis toxicity grades |
|
21 |
#' have worsened from baseline toxicity grades during treatment. |
|
22 |
#' |
|
23 |
#' Prior to using this function in your table layout you must use [rtables::split_rows_by()] to create a row |
|
24 |
#' split on variable `direction_var`. |
|
25 |
#' |
|
26 |
#' @inheritParams argument_convention |
|
27 |
#' @param variables (named `list` of `string`)\cr list of additional analysis variables including: |
|
28 |
#' * `id` (`string`)\cr subject variable name. |
|
29 |
#' * `baseline_var` (`string`)\cr name of the data column containing baseline toxicity variable. |
|
30 |
#' * `direction_var` (`string`)\cr see `direction_var` for more details. |
|
31 |
#' @param .stats (`character`)\cr statistics to select for the table. |
|
32 |
#' @param table_names `r lifecycle::badge("deprecated")` this parameter has no effect. |
|
33 |
#' |
|
34 |
#' Options are: ``r shQuote(get_stats("abnormal_lab_worsen_by_baseline"), type = "sh")`` |
|
35 |
#' |
|
36 |
#' @seealso Relevant helper functions [h_adlb_worsen()] and [h_worsen_counter()] which are used within |
|
37 |
#' [s_count_abnormal_lab_worsen_by_baseline()] to process input data. |
|
38 |
#' |
|
39 |
#' @name abnormal_lab_worsen_by_baseline |
|
40 |
#' @order 1 |
|
41 |
NULL |
|
42 | ||
43 |
#' @describeIn abnormal_lab_worsen_by_baseline Statistics function for patients whose worst post-baseline |
|
44 |
#' lab grades are worse than their baseline grades. |
|
45 |
#' |
|
46 |
#' @return |
|
47 |
#' * `s_count_abnormal_lab_worsen_by_baseline()` returns the counts and fraction of patients whose worst |
|
48 |
#' post-baseline lab grades are worse than their baseline grades, for post-baseline worst grades |
|
49 |
#' "1", "2", "3", "4" and "Any". |
|
50 |
#' |
|
51 |
#' @keywords internal |
|
52 |
s_count_abnormal_lab_worsen_by_baseline <- function(df, |
|
53 |
.var = "ATOXGR", |
|
54 |
variables = list( |
|
55 |
id = "USUBJID", |
|
56 |
baseline_var = "BTOXGR", |
|
57 |
direction_var = "GRADDR" |
|
58 |
), |
|
59 |
...) { |
|
60 | 13x |
checkmate::assert_string(.var) |
61 | 13x |
checkmate::assert_set_equal(names(variables), c("id", "baseline_var", "direction_var")) |
62 | 13x |
checkmate::assert_string(variables$id) |
63 | 13x |
checkmate::assert_string(variables$baseline_var) |
64 | 13x |
checkmate::assert_string(variables$direction_var) |
65 | 13x |
assert_df_with_variables(df, c(aval = .var, variables[1:3])) |
66 | 13x |
assert_list_of_variables(variables) |
67 | ||
68 | 13x |
h_worsen_counter(df, variables$id, .var, variables$baseline_var, variables$direction_var) |
69 |
} |
|
70 | ||
71 |
#' @describeIn abnormal_lab_worsen_by_baseline Formatted analysis function which is used as `afun` |
|
72 |
#' in `count_abnormal_lab_worsen_by_baseline()`. |
|
73 |
#' |
|
74 |
#' @return |
|
75 |
#' * `a_count_abnormal_lab_worsen_by_baseline()` returns the corresponding list with |
|
76 |
#' formatted [rtables::CellValue()]. |
|
77 |
#' |
|
78 |
#' @keywords internal |
|
79 |
a_count_abnormal_lab_worsen_by_baseline <- function(df, |
|
80 |
..., |
|
81 |
.stats = NULL, |
|
82 |
.stat_names = NULL, |
|
83 |
.formats = NULL, |
|
84 |
.labels = NULL, |
|
85 |
.indent_mods = NULL) { |
|
86 |
# Check for additional parameters to the statistics function |
|
87 | 12x |
dots_extra_args <- list(...) |
88 | 12x |
extra_afun_params <- retrieve_extra_afun_params(names(dots_extra_args$.additional_fun_parameters)) |
89 | 12x |
dots_extra_args$.additional_fun_parameters <- NULL |
90 | ||
91 |
# Check for user-defined functions |
|
92 | 12x |
default_and_custom_stats_list <- .split_std_from_custom_stats(.stats) |
93 | 12x |
.stats <- default_and_custom_stats_list$all_stats |
94 | 12x |
custom_stat_functions <- default_and_custom_stats_list$custom_stats |
95 | ||
96 |
# Apply statistics function |
|
97 | 12x |
x_stats <- .apply_stat_functions( |
98 | 12x |
default_stat_fnc = s_count_abnormal_lab_worsen_by_baseline, |
99 | 12x |
custom_stat_fnc_list = custom_stat_functions, |
100 | 12x |
args_list = c( |
101 | 12x |
df = list(df), |
102 | 12x |
extra_afun_params, |
103 | 12x |
dots_extra_args |
104 |
) |
|
105 |
) |
|
106 | ||
107 |
# Fill in formatting defaults |
|
108 | 12x |
.stats <- get_stats( |
109 | 12x |
"abnormal_lab_worsen_by_baseline", |
110 | 12x |
stats_in = .stats, |
111 | 12x |
custom_stats_in = names(custom_stat_functions) |
112 |
) |
|
113 | 12x |
levels_per_stats <- lapply(x_stats, names) |
114 | 12x |
.formats <- get_formats_from_stats(.stats, .formats, levels_per_stats) |
115 | 12x |
.labels <- get_labels_from_stats(.stats, .labels, levels_per_stats) |
116 | 12x |
.indent_mods <- get_indents_from_stats(.stats, .indent_mods, levels_per_stats) |
117 | ||
118 | 12x |
x_stats <- x_stats[.stats] %>% |
119 | 12x |
.unlist_keep_nulls() %>% |
120 | 12x |
setNames(names(.formats)) |
121 | ||
122 |
# Auto format handling |
|
123 | 12x |
.formats <- apply_auto_formatting(.formats, x_stats, extra_afun_params$.df_row, extra_afun_params$.var) |
124 | ||
125 |
# Get and check statistical names |
|
126 | 12x |
.stat_names <- get_stat_names(x_stats, .stat_names) |
127 | ||
128 | 12x |
in_rows( |
129 | 12x |
.list = x_stats, |
130 | 12x |
.formats = .formats, |
131 | 12x |
.names = .labels %>% .unlist_keep_nulls(), |
132 | 12x |
.stat_names = .stat_names, |
133 | 12x |
.labels = .labels %>% .unlist_keep_nulls(), |
134 | 12x |
.indent_mods = .indent_mods %>% .unlist_keep_nulls() |
135 |
) |
|
136 |
} |
|
137 | ||
138 |
#' @describeIn abnormal_lab_worsen_by_baseline Layout-creating function which can take statistics function |
|
139 |
#' arguments and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
|
140 |
#' |
|
141 |
#' @return |
|
142 |
#' * `count_abnormal_lab_worsen_by_baseline()` returns a layout object suitable for passing to further layouting |
|
143 |
#' functions, or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted |
|
144 |
#' rows containing the statistics from `s_count_abnormal_lab_worsen_by_baseline()` to the table layout. |
|
145 |
#' |
|
146 |
#' @examples |
|
147 |
#' library(dplyr) |
|
148 |
#' |
|
149 |
#' # The direction variable, GRADDR, is based on metadata |
|
150 |
#' adlb <- tern_ex_adlb %>% |
|
151 |
#' mutate( |
|
152 |
#' GRADDR = case_when( |
|
153 |
#' PARAMCD == "ALT" ~ "B", |
|
154 |
#' PARAMCD == "CRP" ~ "L", |
|
155 |
#' PARAMCD == "IGA" ~ "H" |
|
156 |
#' ) |
|
157 |
#' ) %>% |
|
158 |
#' filter(SAFFL == "Y" & ONTRTFL == "Y" & GRADDR != "") |
|
159 |
#' |
|
160 |
#' df <- h_adlb_worsen( |
|
161 |
#' adlb, |
|
162 |
#' worst_flag_low = c("WGRLOFL" = "Y"), |
|
163 |
#' worst_flag_high = c("WGRHIFL" = "Y"), |
|
164 |
#' direction_var = "GRADDR" |
|
165 |
#' ) |
|
166 |
#' |
|
167 |
#' basic_table() %>% |
|
168 |
#' split_cols_by("ARMCD") %>% |
|
169 |
#' add_colcounts() %>% |
|
170 |
#' split_rows_by("PARAMCD") %>% |
|
171 |
#' split_rows_by("GRADDR") %>% |
|
172 |
#' count_abnormal_lab_worsen_by_baseline( |
|
173 |
#' var = "ATOXGR", |
|
174 |
#' variables = list( |
|
175 |
#' id = "USUBJID", |
|
176 |
#' baseline_var = "BTOXGR", |
|
177 |
#' direction_var = "GRADDR" |
|
178 |
#' ) |
|
179 |
#' ) %>% |
|
180 |
#' append_topleft("Direction of Abnormality") %>% |
|
181 |
#' build_table(df = df, alt_counts_df = tern_ex_adsl) |
|
182 |
#' |
|
183 |
#' @export |
|
184 |
#' @order 2 |
|
185 |
count_abnormal_lab_worsen_by_baseline <- function(lyt, |
|
186 |
var, |
|
187 |
variables = list( |
|
188 |
id = "USUBJID", |
|
189 |
baseline_var = "BTOXGR", |
|
190 |
direction_var = "GRADDR" |
|
191 |
), |
|
192 |
na_str = default_na_str(), |
|
193 |
nested = TRUE, |
|
194 |
..., |
|
195 |
table_names = lifecycle::deprecated(), |
|
196 |
.stats = "fraction", |
|
197 |
.stat_names = NULL, |
|
198 |
.formats = list(fraction = format_fraction), |
|
199 |
.labels = NULL, |
|
200 |
.indent_mods = NULL) { |
|
201 | 1x |
checkmate::assert_string(var) |
202 | ||
203 |
# Deprecated argument warning |
|
204 | 1x |
if (lifecycle::is_present(table_names)) { |
205 | ! |
lifecycle::deprecate_warn( |
206 | ! |
"0.9.8", "count_abnormal_lab_worsen_by_baseline(table_names)", |
207 | ! |
details = "The argument has no effect on the output." |
208 |
) |
|
209 |
} |
|
210 | ||
211 |
# Process standard extra arguments |
|
212 | 1x |
extra_args <- list(".stats" = .stats) |
213 | ! |
if (!is.null(.stat_names)) extra_args[[".stat_names"]] <- .stat_names |
214 | 1x |
if (!is.null(.formats)) extra_args[[".formats"]] <- .formats |
215 | ! |
if (!is.null(.labels)) extra_args[[".labels"]] <- .labels |
216 | ! |
if (!is.null(.indent_mods)) extra_args[[".indent_mods"]] <- .indent_mods |
217 | ||
218 |
# Process additional arguments to the statistic function |
|
219 | 1x |
extra_args <- c(extra_args, "variables" = list(variables), ...) |
220 | ||
221 |
# Append additional info from layout to the analysis function |
|
222 | 1x |
extra_args[[".additional_fun_parameters"]] <- get_additional_afun_params(add_alt_df = FALSE) |
223 | 1x |
formals(a_count_abnormal_lab_worsen_by_baseline) <- c( |
224 | 1x |
formals(a_count_abnormal_lab_worsen_by_baseline), extra_args[[".additional_fun_parameters"]] |
225 |
) |
|
226 | ||
227 | 1x |
analyze( |
228 | 1x |
lyt = lyt, |
229 | 1x |
vars = var, |
230 | 1x |
afun = a_count_abnormal_lab_worsen_by_baseline, |
231 | 1x |
na_str = na_str, |
232 | 1x |
nested = nested, |
233 | 1x |
extra_args = extra_args, |
234 | 1x |
show_labels = "hidden" |
235 |
) |
|
236 |
} |
|
237 | ||
238 |
#' Helper function to prepare ADLB with worst labs |
|
239 |
#' |
|
240 |
#' @description `r lifecycle::badge("stable")` |
|
241 |
#' |
|
242 |
#' Helper function to prepare a `df` for generate the patient count shift table. |
|
243 |
#' |
|
244 |
#' @param adlb (`data.frame`)\cr ADLB data frame. |
|
245 |
#' @param worst_flag_low (named `vector`)\cr worst low post-baseline lab grade flag variable. See how this is |
|
246 |
#' implemented in the following examples. |
|
247 |
#' @param worst_flag_high (named `vector`)\cr worst high post-baseline lab grade flag variable. See how this is |
|
248 |
#' implemented in the following examples. |
|
249 |
#' @param direction_var (`string`)\cr name of the direction variable specifying the direction of the shift table of |
|
250 |
#' interest. Only lab records flagged by `L`, `H` or `B` are included in the shift table. |
|
251 |
#' * `L`: low direction only |
|
252 |
#' * `H`: high direction only |
|
253 |
#' * `B`: both low and high directions |
|
254 |
#' |
|
255 |
#' @return `h_adlb_worsen()` returns the `adlb` `data.frame` containing only the |
|
256 |
#' worst labs specified according to `worst_flag_low` or `worst_flag_high` for the |
|
257 |
#' direction specified according to `direction_var`. For instance, for a lab that is |
|
258 |
#' needed for the low direction only, only records flagged by `worst_flag_low` are |
|
259 |
#' selected. For a lab that is needed for both low and high directions, the worst |
|
260 |
#' low records are selected for the low direction, and the worst high record are selected |
|
261 |
#' for the high direction. |
|
262 |
#' |
|
263 |
#' @seealso [abnormal_lab_worsen_by_baseline] |
|
264 |
#' |
|
265 |
#' @examples |
|
266 |
#' library(dplyr) |
|
267 |
#' |
|
268 |
#' # The direction variable, GRADDR, is based on metadata |
|
269 |
#' adlb <- tern_ex_adlb %>% |
|
270 |
#' mutate( |
|
271 |
#' GRADDR = case_when( |
|
272 |
#' PARAMCD == "ALT" ~ "B", |
|
273 |
#' PARAMCD == "CRP" ~ "L", |
|
274 |
#' PARAMCD == "IGA" ~ "H" |
|
275 |
#' ) |
|
276 |
#' ) %>% |
|
277 |
#' filter(SAFFL == "Y" & ONTRTFL == "Y" & GRADDR != "") |
|
278 |
#' |
|
279 |
#' df <- h_adlb_worsen( |
|
280 |
#' adlb, |
|
281 |
#' worst_flag_low = c("WGRLOFL" = "Y"), |
|
282 |
#' worst_flag_high = c("WGRHIFL" = "Y"), |
|
283 |
#' direction_var = "GRADDR" |
|
284 |
#' ) |
|
285 |
#' |
|
286 |
#' @export |
|
287 |
h_adlb_worsen <- function(adlb, |
|
288 |
worst_flag_low = NULL, |
|
289 |
worst_flag_high = NULL, |
|
290 |
direction_var) { |
|
291 | 5x |
checkmate::assert_string(direction_var) |
292 | 5x |
checkmate::assert_subset(as.character(unique(adlb[[direction_var]])), c("B", "L", "H")) |
293 | 5x |
assert_df_with_variables(adlb, list("Col" = direction_var)) |
294 | ||
295 | 5x |
if (any(unique(adlb[[direction_var]]) == "H")) { |
296 | 4x |
assert_df_with_variables(adlb, list("High" = names(worst_flag_high))) |
297 |
} |
|
298 | ||
299 | 5x |
if (any(unique(adlb[[direction_var]]) == "L")) { |
300 | 4x |
assert_df_with_variables(adlb, list("Low" = names(worst_flag_low))) |
301 |
} |
|
302 | ||
303 | 5x |
if (any(unique(adlb[[direction_var]]) == "B")) { |
304 | 3x |
assert_df_with_variables( |
305 | 3x |
adlb, |
306 | 3x |
list( |
307 | 3x |
"Low" = names(worst_flag_low), |
308 | 3x |
"High" = names(worst_flag_high) |
309 |
) |
|
310 |
) |
|
311 |
} |
|
312 | ||
313 |
# extract patients with worst post-baseline lab, either low or high or both |
|
314 | 5x |
worst_flag <- c(worst_flag_low, worst_flag_high) |
315 | 5x |
col_names <- names(worst_flag) |
316 | 5x |
filter_values <- worst_flag |
317 | 5x |
temp <- Map( |
318 | 5x |
function(x, y) which(adlb[[x]] == y), |
319 | 5x |
col_names, |
320 | 5x |
filter_values |
321 |
) |
|
322 | 5x |
position_satisfy_filters <- Reduce(union, temp) |
323 | ||
324 |
# select variables of interest |
|
325 | 5x |
adlb_f <- adlb[position_satisfy_filters, ] |
326 | ||
327 |
# generate subsets for different directionality |
|
328 | 5x |
adlb_f_h <- adlb_f[which(adlb_f[[direction_var]] == "H"), ] |
329 | 5x |
adlb_f_l <- adlb_f[which(adlb_f[[direction_var]] == "L"), ] |
330 | 5x |
adlb_f_b <- adlb_f[which(adlb_f[[direction_var]] == "B"), ] |
331 | ||
332 |
# for labs requiring both high and low, data is duplicated and will be stacked on top of each other |
|
333 | 5x |
adlb_f_b_h <- adlb_f_b |
334 | 5x |
adlb_f_b_l <- adlb_f_b |
335 | ||
336 |
# extract data with worst lab |
|
337 | 5x |
if (!is.null(worst_flag_high) && !is.null(worst_flag_low)) { |
338 |
# change H to High, L to Low |
|
339 | 3x |
adlb_f_h[[direction_var]] <- rep("High", nrow(adlb_f_h)) |
340 | 3x |
adlb_f_l[[direction_var]] <- rep("Low", nrow(adlb_f_l)) |
341 | ||
342 |
# change, B to High and Low |
|
343 | 3x |
adlb_f_b_h[[direction_var]] <- rep("High", nrow(adlb_f_b_h)) |
344 | 3x |
adlb_f_b_l[[direction_var]] <- rep("Low", nrow(adlb_f_b_l)) |
345 | ||
346 | 3x |
adlb_out_h <- adlb_f_h[which(adlb_f_h[[names(worst_flag_high)]] == worst_flag_high), ] |
347 | 3x |
adlb_out_b_h <- adlb_f_b_h[which(adlb_f_b_h[[names(worst_flag_high)]] == worst_flag_high), ] |
348 | 3x |
adlb_out_l <- adlb_f_l[which(adlb_f_l[[names(worst_flag_low)]] == worst_flag_low), ] |
349 | 3x |
adlb_out_b_l <- adlb_f_b_l[which(adlb_f_b_l[[names(worst_flag_low)]] == worst_flag_low), ] |
350 | ||
351 | 3x |
out <- rbind(adlb_out_h, adlb_out_b_h, adlb_out_l, adlb_out_b_l) |
352 | 2x |
} else if (!is.null(worst_flag_high)) { |
353 | 1x |
adlb_f_h[[direction_var]] <- rep("High", nrow(adlb_f_h)) |
354 | 1x |
adlb_f_b_h[[direction_var]] <- rep("High", nrow(adlb_f_b_h)) |
355 | ||
356 | 1x |
adlb_out_h <- adlb_f_h[which(adlb_f_h[[names(worst_flag_high)]] == worst_flag_high), ] |
357 | 1x |
adlb_out_b_h <- adlb_f_b_h[which(adlb_f_b_h[[names(worst_flag_high)]] == worst_flag_high), ] |
358 | ||
359 | 1x |
out <- rbind(adlb_out_h, adlb_out_b_h) |
360 | 1x |
} else if (!is.null(worst_flag_low)) { |
361 | 1x |
adlb_f_l[[direction_var]] <- rep("Low", nrow(adlb_f_l)) |
362 | 1x |
adlb_f_b_l[[direction_var]] <- rep("Low", nrow(adlb_f_b_l)) |
363 | ||
364 | 1x |
adlb_out_l <- adlb_f_l[which(adlb_f_l[[names(worst_flag_low)]] == worst_flag_low), ] |
365 | 1x |
adlb_out_b_l <- adlb_f_b_l[which(adlb_f_b_l[[names(worst_flag_low)]] == worst_flag_low), ] |
366 | ||
367 | 1x |
out <- rbind(adlb_out_l, adlb_out_b_l) |
368 |
} |
|
369 | ||
370 |
# label |
|
371 | 5x |
formatters::var_labels(out) <- formatters::var_labels(adlb_f, fill = FALSE) |
372 | ||
373 | 5x |
out |
374 |
} |
|
375 | ||
376 |
#' Helper function to analyze patients for `s_count_abnormal_lab_worsen_by_baseline()` |
|
377 |
#' |
|
378 |
#' @description `r lifecycle::badge("stable")` |
|
379 |
#' |
|
380 |
#' Helper function to count the number of patients and the fraction of patients according to |
|
381 |
#' highest post-baseline lab grade variable `.var`, baseline lab grade variable `baseline_var`, |
|
382 |
#' and the direction of interest specified in `direction_var`. |
|
383 |
#' |
|
384 |
#' @inheritParams argument_convention |
|
385 |
#' @inheritParams h_adlb_worsen |
|
386 |
#' @param baseline_var (`string`)\cr name of the baseline lab grade variable. |
|
387 |
#' |
|
388 |
#' @return The counts and fraction of patients |
|
389 |
#' whose worst post-baseline lab grades are worse than their baseline grades, for |
|
390 |
#' post-baseline worst grades "1", "2", "3", "4" and "Any". |
|
391 |
#' |
|
392 |
#' @seealso [abnormal_lab_worsen_by_baseline] |
|
393 |
#' |
|
394 |
#' @examples |
|
395 |
#' library(dplyr) |
|
396 |
#' |
|
397 |
#' # The direction variable, GRADDR, is based on metadata |
|
398 |
#' adlb <- tern_ex_adlb %>% |
|
399 |
#' mutate( |
|
400 |
#' GRADDR = case_when( |
|
401 |
#' PARAMCD == "ALT" ~ "B", |
|
402 |
#' PARAMCD == "CRP" ~ "L", |
|
403 |
#' PARAMCD == "IGA" ~ "H" |
|
404 |
#' ) |
|
405 |
#' ) %>% |
|
406 |
#' filter(SAFFL == "Y" & ONTRTFL == "Y" & GRADDR != "") |
|
407 |
#' |
|
408 |
#' df <- h_adlb_worsen( |
|
409 |
#' adlb, |
|
410 |
#' worst_flag_low = c("WGRLOFL" = "Y"), |
|
411 |
#' worst_flag_high = c("WGRHIFL" = "Y"), |
|
412 |
#' direction_var = "GRADDR" |
|
413 |
#' ) |
|
414 |
#' |
|
415 |
#' # `h_worsen_counter` |
|
416 |
#' h_worsen_counter( |
|
417 |
#' df %>% filter(PARAMCD == "CRP" & GRADDR == "Low"), |
|
418 |
#' id = "USUBJID", |
|
419 |
#' .var = "ATOXGR", |
|
420 |
#' baseline_var = "BTOXGR", |
|
421 |
#' direction_var = "GRADDR" |
|
422 |
#' ) |
|
423 |
#' |
|
424 |
#' @export |
|
425 |
h_worsen_counter <- function(df, id, .var, baseline_var, direction_var) { |
|
426 | 17x |
checkmate::assert_string(id) |
427 | 17x |
checkmate::assert_string(.var) |
428 | 17x |
checkmate::assert_string(baseline_var) |
429 | 17x |
checkmate::assert_scalar(unique(df[[direction_var]])) |
430 | 17x |
checkmate::assert_subset(unique(df[[direction_var]]), c("High", "Low")) |
431 | 17x |
assert_df_with_variables(df, list(val = c(id, .var, baseline_var, direction_var))) |
432 | ||
433 |
# remove post-baseline missing |
|
434 | 17x |
df <- df[df[[.var]] != "<Missing>", ] |
435 | ||
436 |
# obtain directionality |
|
437 | 17x |
direction <- unique(df[[direction_var]]) |
438 | ||
439 | 17x |
if (direction == "Low") { |
440 | 10x |
grade <- -1:-4 |
441 | 10x |
worst_grade <- -4 |
442 | 7x |
} else if (direction == "High") { |
443 | 7x |
grade <- 1:4 |
444 | 7x |
worst_grade <- 4 |
445 |
} |
|
446 | ||
447 | 17x |
if (nrow(df) > 0) { |
448 | 17x |
by_grade <- lapply(grade, function(i) { |
449 |
# filter baseline values that is less than i or <Missing> |
|
450 | 68x |
df_temp <- df[df[[baseline_var]] %in% c((i + sign(i) * -1):(-1 * worst_grade), "<Missing>"), ] |
451 |
# num: number of patients with post-baseline worst lab equal to i |
|
452 | 68x |
num <- length(unique(df_temp[df_temp[[.var]] %in% i, id, drop = TRUE])) |
453 |
# denom: number of patients with baseline values less than i or <missing> and post-baseline in the same direction |
|
454 | 68x |
denom <- length(unique(df_temp[[id]])) |
455 | 68x |
rm(df_temp) |
456 | 68x |
c(num = num, denom = denom) |
457 |
}) |
|
458 |
} else { |
|
459 | ! |
by_grade <- lapply(1, function(i) { |
460 | ! |
c(num = 0, denom = 0) |
461 |
}) |
|
462 |
} |
|
463 | ||
464 | 17x |
names(by_grade) <- as.character(seq_along(by_grade)) |
465 | ||
466 |
# baseline grade less 4 or missing |
|
467 | 17x |
df_temp <- df[!df[[baseline_var]] %in% worst_grade, ] |
468 | ||
469 |
# denom: number of patients with baseline values less than 4 or <missing> and post-baseline in the same direction |
|
470 | 17x |
denom <- length(unique(df_temp[, id, drop = TRUE])) |
471 | ||
472 |
# condition 1: missing baseline and in the direction of abnormality |
|
473 | 17x |
con1 <- which(df_temp[[baseline_var]] == "<Missing>" & df_temp[[.var]] %in% grade) |
474 | 17x |
df_temp_nm <- df_temp[which(df_temp[[baseline_var]] != "<Missing>" & df_temp[[.var]] %in% grade), ] |
475 | ||
476 |
# condition 2: if post-baseline values are present then post-baseline values must be worse than baseline |
|
477 | 17x |
if (direction == "Low") { |
478 | 10x |
con2 <- which(as.numeric(as.character(df_temp_nm[[.var]])) < as.numeric(as.character(df_temp_nm[[baseline_var]]))) |
479 |
} else { |
|
480 | 7x |
con2 <- which(as.numeric(as.character(df_temp_nm[[.var]])) > as.numeric(as.character(df_temp_nm[[baseline_var]]))) |
481 |
} |
|
482 | ||
483 |
# number of patients satisfy either conditions 1 or 2 |
|
484 | 17x |
num <- length(unique(df_temp[union(con1, con2), id, drop = TRUE])) |
485 | ||
486 | 17x |
list(fraction = c(by_grade, list("Any" = c(num = num, denom = denom)))) |
487 |
} |
1 |
#' Occurrence table pruning |
|
2 |
#' |
|
3 |
#' @description `r lifecycle::badge("stable")` |
|
4 |
#' |
|
5 |
#' Family of constructor and condition functions to flexibly prune occurrence tables. |
|
6 |
#' The condition functions always return whether the row result is higher than the threshold. |
|
7 |
#' Since they are of class [CombinationFunction()] they can be logically combined with other condition |
|
8 |
#' functions. |
|
9 |
#' |
|
10 |
#' @note Since most table specifications are worded positively, we name our constructor and condition |
|
11 |
#' functions positively, too. However, note that the result of [keep_rows()] says what |
|
12 |
#' should be pruned, to conform with the [rtables::prune_table()] interface. |
|
13 |
#' |
|
14 |
#' @examples |
|
15 |
#' \donttest{ |
|
16 |
#' tab <- basic_table() %>% |
|
17 |
#' split_cols_by("ARM") %>% |
|
18 |
#' split_rows_by("RACE") %>% |
|
19 |
#' split_rows_by("STRATA1") %>% |
|
20 |
#' summarize_row_groups() %>% |
|
21 |
#' analyze_vars("COUNTRY", .stats = "count_fraction") %>% |
|
22 |
#' build_table(DM) |
|
23 |
#' } |
|
24 |
#' |
|
25 |
#' @name prune_occurrences |
|
26 |
NULL |
|
27 | ||
28 |
#' @describeIn prune_occurrences Constructor for creating pruning functions based on |
|
29 |
#' a row condition function. This removes all analysis rows (`TableRow`) that should be |
|
30 |
#' pruned, i.e., don't fulfill the row condition. It removes the sub-tree if there are no |
|
31 |
#' children left. |
|
32 |
#' |
|
33 |
#' @param row_condition (`CombinationFunction`)\cr condition function which works on individual |
|
34 |
#' analysis rows and flags whether these should be kept in the pruned table. |
|
35 |
#' |
|
36 |
#' @return |
|
37 |
#' * `keep_rows()` returns a pruning function that can be used with [rtables::prune_table()] |
|
38 |
#' to prune an `rtables` table. |
|
39 |
#' |
|
40 |
#' @examples |
|
41 |
#' \donttest{ |
|
42 |
#' # `keep_rows` |
|
43 |
#' is_non_empty <- !CombinationFunction(all_zero_or_na) |
|
44 |
#' prune_table(tab, keep_rows(is_non_empty)) |
|
45 |
#' } |
|
46 |
#' |
|
47 |
#' @export |
|
48 |
keep_rows <- function(row_condition) { |
|
49 | 6x |
checkmate::assert_function(row_condition) |
50 | 6x |
function(table_tree) { |
51 | 2256x |
if (inherits(table_tree, "TableRow")) { |
52 | 1872x |
return(!row_condition(table_tree)) |
53 |
} |
|
54 | 384x |
children <- tree_children(table_tree) |
55 | 384x |
identical(length(children), 0L) |
56 |
} |
|
57 |
} |
|
58 | ||
59 |
#' @describeIn prune_occurrences Constructor for creating pruning functions based on |
|
60 |
#' a condition for the (first) content row in leaf tables. This removes all leaf tables where |
|
61 |
#' the first content row does not fulfill the condition. It does not check individual rows. |
|
62 |
#' It then proceeds recursively by removing the sub tree if there are no children left. |
|
63 |
#' |
|
64 |
#' @param content_row_condition (`CombinationFunction`)\cr condition function which works on individual |
|
65 |
#' first content rows of leaf tables and flags whether these leaf tables should be kept in the pruned table. |
|
66 |
#' |
|
67 |
#' @return |
|
68 |
#' * `keep_content_rows()` returns a pruning function that checks the condition on the first content |
|
69 |
#' row of leaf tables in the table. |
|
70 |
#' |
|
71 |
#' @examples |
|
72 |
#' # `keep_content_rows` |
|
73 |
#' \donttest{ |
|
74 |
#' more_than_twenty <- has_count_in_cols(atleast = 20L, col_names = names(tab)) |
|
75 |
#' prune_table(tab, keep_content_rows(more_than_twenty)) |
|
76 |
#' } |
|
77 |
#' |
|
78 |
#' @export |
|
79 |
keep_content_rows <- function(content_row_condition) { |
|
80 | 1x |
checkmate::assert_function(content_row_condition) |
81 | 1x |
function(table_tree) { |
82 | 166x |
if (is_leaf_table(table_tree)) { |
83 | 24x |
content_row <- h_content_first_row(table_tree) |
84 | 24x |
return(!content_row_condition(content_row)) |
85 |
} |
|
86 | 142x |
if (inherits(table_tree, "DataRow")) { |
87 | 120x |
return(FALSE) |
88 |
} |
|
89 | 22x |
children <- tree_children(table_tree) |
90 | 22x |
identical(length(children), 0L) |
91 |
} |
|
92 |
} |
|
93 | ||
94 |
#' @describeIn prune_occurrences Constructor for creating condition functions on total counts in the specified columns. |
|
95 |
#' |
|
96 |
#' @param atleast (`numeric(1)`)\cr threshold which should be met in order to keep the row. |
|
97 |
#' @param ... arguments for row or column access, see [`rtables_access`]: either `col_names` (`character`) including |
|
98 |
#' the names of the columns which should be used, or alternatively `col_indices` (`integer`) giving the indices |
|
99 |
#' directly instead. |
|
100 |
#' |
|
101 |
#' @return |
|
102 |
#' * `has_count_in_cols()` returns a condition function that sums the counts in the specified column. |
|
103 |
#' |
|
104 |
#' @examples |
|
105 |
#' \donttest{ |
|
106 |
#' more_than_one <- has_count_in_cols(atleast = 1L, col_names = names(tab)) |
|
107 |
#' prune_table(tab, keep_rows(more_than_one)) |
|
108 |
#' } |
|
109 |
#' |
|
110 |
#' @export |
|
111 |
has_count_in_cols <- function(atleast, ...) { |
|
112 | 6x |
checkmate::assert_count(atleast) |
113 | 6x |
CombinationFunction(function(table_row) { |
114 | 337x |
row_counts <- h_row_counts(table_row, ...) |
115 | 337x |
total_count <- sum(row_counts) |
116 | 337x |
total_count >= atleast |
117 |
}) |
|
118 |
} |
|
119 | ||
120 |
#' @describeIn prune_occurrences Constructor for creating condition functions on any of the counts in |
|
121 |
#' the specified columns satisfying a threshold. |
|
122 |
#' |
|
123 |
#' @param atleast (`numeric(1)`)\cr threshold which should be met in order to keep the row. |
|
124 |
#' |
|
125 |
#' @return |
|
126 |
#' * `has_count_in_any_col()` returns a condition function that compares the counts in the |
|
127 |
#' specified columns with the threshold. |
|
128 |
#' |
|
129 |
#' @examples |
|
130 |
#' \donttest{ |
|
131 |
#' # `has_count_in_any_col` |
|
132 |
#' any_more_than_one <- has_count_in_any_col(atleast = 1L, col_names = names(tab)) |
|
133 |
#' prune_table(tab, keep_rows(any_more_than_one)) |
|
134 |
#' } |
|
135 |
#' |
|
136 |
#' @export |
|
137 |
has_count_in_any_col <- function(atleast, ...) { |
|
138 | 3x |
checkmate::assert_count(atleast) |
139 | 3x |
CombinationFunction(function(table_row) { |
140 | 3x |
row_counts <- h_row_counts(table_row, ...) |
141 | 3x |
any(row_counts >= atleast) |
142 |
}) |
|
143 |
} |
|
144 | ||
145 |
#' @describeIn prune_occurrences Constructor for creating condition functions on total fraction in |
|
146 |
#' the specified columns. |
|
147 |
#' |
|
148 |
#' @return |
|
149 |
#' * `has_fraction_in_cols()` returns a condition function that sums the counts in the |
|
150 |
#' specified column, and computes the fraction by dividing by the total column counts. |
|
151 |
#' |
|
152 |
#' @examples |
|
153 |
#' \donttest{ |
|
154 |
#' # `has_fraction_in_cols` |
|
155 |
#' more_than_five_percent <- has_fraction_in_cols(atleast = 0.05, col_names = names(tab)) |
|
156 |
#' prune_table(tab, keep_rows(more_than_five_percent)) |
|
157 |
#' } |
|
158 |
#' |
|
159 |
#' @export |
|
160 |
has_fraction_in_cols <- function(atleast, ...) { |
|
161 | 4x |
assert_proportion_value(atleast, include_boundaries = TRUE) |
162 | 4x |
CombinationFunction(function(table_row) { |
163 | 306x |
row_counts <- h_row_counts(table_row, ...) |
164 | 306x |
total_count <- sum(row_counts) |
165 | 306x |
col_counts <- h_col_counts(table_row, ...) |
166 | 306x |
total_n <- sum(col_counts) |
167 | 306x |
total_percent <- total_count / total_n |
168 | 306x |
total_percent >= atleast |
169 |
}) |
|
170 |
} |
|
171 | ||
172 |
#' @describeIn prune_occurrences Constructor for creating condition functions on any fraction in |
|
173 |
#' the specified columns. |
|
174 |
#' |
|
175 |
#' @return |
|
176 |
#' * `has_fraction_in_any_col()` returns a condition function that looks at the fractions |
|
177 |
#' in the specified columns and checks whether any of them fulfill the threshold. |
|
178 |
#' |
|
179 |
#' @examples |
|
180 |
#' \donttest{ |
|
181 |
#' # `has_fraction_in_any_col` |
|
182 |
#' any_atleast_five_percent <- has_fraction_in_any_col(atleast = 0.05, col_names = names(tab)) |
|
183 |
#' prune_table(tab, keep_rows(any_atleast_five_percent)) |
|
184 |
#' } |
|
185 |
#' |
|
186 |
#' @export |
|
187 |
has_fraction_in_any_col <- function(atleast, ...) { |
|
188 | 3x |
assert_proportion_value(atleast, include_boundaries = TRUE) |
189 | 3x |
CombinationFunction(function(table_row) { |
190 | 3x |
row_fractions <- h_row_fractions(table_row, ...) |
191 | 3x |
any(row_fractions >= atleast) |
192 |
}) |
|
193 |
} |
|
194 | ||
195 |
#' @describeIn prune_occurrences Constructor for creating condition function that checks the difference |
|
196 |
#' between the fractions reported in each specified column. |
|
197 |
#' |
|
198 |
#' @return |
|
199 |
#' * `has_fractions_difference()` returns a condition function that extracts the fractions of each |
|
200 |
#' specified column, and computes the difference of the minimum and maximum. |
|
201 |
#' |
|
202 |
#' @examples |
|
203 |
#' \donttest{ |
|
204 |
#' # `has_fractions_difference` |
|
205 |
#' more_than_five_percent_diff <- has_fractions_difference(atleast = 0.05, col_names = names(tab)) |
|
206 |
#' prune_table(tab, keep_rows(more_than_five_percent_diff)) |
|
207 |
#' } |
|
208 |
#' |
|
209 |
#' @export |
|
210 |
has_fractions_difference <- function(atleast, ...) { |
|
211 | 4x |
assert_proportion_value(atleast, include_boundaries = TRUE) |
212 | 4x |
CombinationFunction(function(table_row) { |
213 | 246x |
fractions <- h_row_fractions(table_row, ...) |
214 | 246x |
difference <- diff(range(fractions)) |
215 | 246x |
difference >= atleast |
216 |
}) |
|
217 |
} |
|
218 | ||
219 |
#' @describeIn prune_occurrences Constructor for creating condition function that checks the difference |
|
220 |
#' between the counts reported in each specified column. |
|
221 |
#' |
|
222 |
#' @return |
|
223 |
#' * `has_counts_difference()` returns a condition function that extracts the counts of each |
|
224 |
#' specified column, and computes the difference of the minimum and maximum. |
|
225 |
#' |
|
226 |
#' @examples |
|
227 |
#' \donttest{ |
|
228 |
#' more_than_one_diff <- has_counts_difference(atleast = 1L, col_names = names(tab)) |
|
229 |
#' prune_table(tab, keep_rows(more_than_one_diff)) |
|
230 |
#' } |
|
231 |
#' |
|
232 |
#' @export |
|
233 |
has_counts_difference <- function(atleast, ...) { |
|
234 | 4x |
checkmate::assert_count(atleast) |
235 | 4x |
CombinationFunction(function(table_row) { |
236 | 30x |
counts <- h_row_counts(table_row, ...) |
237 | 30x |
difference <- diff(range(counts)) |
238 | 30x |
difference >= atleast |
239 |
}) |
|
240 |
} |
1 |
#' Count specific values |
|
2 |
#' |
|
3 |
#' @description `r lifecycle::badge("stable")` |
|
4 |
#' |
|
5 |
#' The analyze function [count_values()] creates a layout element to calculate counts of specific values within a |
|
6 |
#' variable of interest. |
|
7 |
#' |
|
8 |
#' This function analyzes one or more variables of interest supplied as a vector to `vars`. Values to |
|
9 |
#' count for variable(s) in `vars` can be given as a vector via the `values` argument. One row of |
|
10 |
#' counts will be generated for each variable. |
|
11 |
#' |
|
12 |
#' @inheritParams argument_convention |
|
13 |
#' @param values (`character`)\cr specific values that should be counted. |
|
14 |
#' @param .stats (`character`)\cr statistics to select for the table. |
|
15 |
#' |
|
16 |
#' Options are: ``r shQuote(get_stats("count_values"), type = "sh")`` |
|
17 |
#' |
|
18 |
#' @note |
|
19 |
#' * For `factor` variables, `s_count_values` checks whether `values` are all included in the levels of `x` |
|
20 |
#' and fails otherwise. |
|
21 |
#' * For `count_values()`, variable labels are shown when there is more than one element in `vars`, |
|
22 |
#' otherwise they are hidden. |
|
23 |
#' |
|
24 |
#' @name count_values |
|
25 |
#' @order 1 |
|
26 |
NULL |
|
27 | ||
28 |
#' @describeIn count_values S3 generic function to count values. |
|
29 |
#' |
|
30 |
#' @inheritParams s_summary.logical |
|
31 |
#' |
|
32 |
#' @return |
|
33 |
#' * `s_count_values()` returns output of [s_summary()] for specified values of a non-numeric variable. |
|
34 |
#' |
|
35 |
#' @export |
|
36 |
s_count_values <- function(x, |
|
37 |
values, |
|
38 |
na.rm = TRUE, # nolint |
|
39 |
denom = c("n", "N_col", "N_row"), |
|
40 |
...) { |
|
41 | 207x |
UseMethod("s_count_values", x) |
42 |
} |
|
43 | ||
44 |
#' @describeIn count_values Method for `character` class. |
|
45 |
#' |
|
46 |
#' @method s_count_values character |
|
47 |
#' |
|
48 |
#' @examples |
|
49 |
#' # `s_count_values.character` |
|
50 |
#' s_count_values(x = c("a", "b", "a"), values = "a") |
|
51 |
#' s_count_values(x = c("a", "b", "a", NA, NA), values = "b", na.rm = FALSE) |
|
52 |
#' |
|
53 |
#' @export |
|
54 |
s_count_values.character <- function(x, |
|
55 |
values = "Y", |
|
56 |
na.rm = TRUE, # nolint |
|
57 |
...) { |
|
58 | 200x |
checkmate::assert_character(values) |
59 | ||
60 | 200x |
if (na.rm) { |
61 | 199x |
x <- x[!is.na(x)] |
62 |
} |
|
63 | ||
64 | 200x |
is_in_values <- x %in% values |
65 | ||
66 | 200x |
s_summary(is_in_values, na_rm = na.rm, ...) |
67 |
} |
|
68 | ||
69 |
#' @describeIn count_values Method for `factor` class. This makes an automatic |
|
70 |
#' conversion to `character` and then forwards to the method for characters. |
|
71 |
#' |
|
72 |
#' @method s_count_values factor |
|
73 |
#' |
|
74 |
#' @examples |
|
75 |
#' # `s_count_values.factor` |
|
76 |
#' s_count_values(x = factor(c("a", "b", "a")), values = "a") |
|
77 |
#' |
|
78 |
#' @export |
|
79 |
s_count_values.factor <- function(x, |
|
80 |
values = "Y", |
|
81 |
...) { |
|
82 | 4x |
s_count_values(as.character(x), values = as.character(values), ...) |
83 |
} |
|
84 | ||
85 |
#' @describeIn count_values Method for `logical` class. |
|
86 |
#' |
|
87 |
#' @method s_count_values logical |
|
88 |
#' |
|
89 |
#' @examples |
|
90 |
#' # `s_count_values.logical` |
|
91 |
#' s_count_values(x = c(TRUE, FALSE, TRUE)) |
|
92 |
#' |
|
93 |
#' @export |
|
94 |
s_count_values.logical <- function(x, values = TRUE, ...) { |
|
95 | 3x |
checkmate::assert_logical(values) |
96 | 3x |
s_count_values(as.character(x), values = as.character(values), ...) |
97 |
} |
|
98 | ||
99 |
#' @describeIn count_values Formatted analysis function which is used as `afun` |
|
100 |
#' in `count_values()`. |
|
101 |
#' |
|
102 |
#' @return |
|
103 |
#' * `a_count_values()` returns the corresponding list with formatted [rtables::CellValue()]. |
|
104 |
#' |
|
105 |
#' @examples |
|
106 |
#' # `a_count_values` |
|
107 |
#' a_count_values(x = factor(c("a", "b", "a")), values = "a", .N_col = 10, .N_row = 10) |
|
108 |
#' |
|
109 |
#' @export |
|
110 |
a_count_values <- function(x, |
|
111 |
..., |
|
112 |
.stats = NULL, |
|
113 |
.stat_names = NULL, |
|
114 |
.formats = NULL, |
|
115 |
.labels = NULL, |
|
116 |
.indent_mods = NULL) { |
|
117 |
# Check for additional parameters to the statistics function |
|
118 | 17x |
dots_extra_args <- list(...) |
119 | 17x |
extra_afun_params <- retrieve_extra_afun_params(names(dots_extra_args$.additional_fun_parameters)) |
120 | 17x |
dots_extra_args$.additional_fun_parameters <- NULL |
121 | ||
122 |
# Check for user-defined functions |
|
123 | 17x |
default_and_custom_stats_list <- .split_std_from_custom_stats(.stats) |
124 | 17x |
.stats <- default_and_custom_stats_list$all_stats |
125 | 17x |
custom_stat_functions <- default_and_custom_stats_list$custom_stats |
126 | ||
127 |
# Main statistic calculations |
|
128 | 17x |
x_stats <- .apply_stat_functions( |
129 | 17x |
default_stat_fnc = s_count_values, |
130 | 17x |
custom_stat_fnc_list = custom_stat_functions, |
131 | 17x |
args_list = c( |
132 | 17x |
x = list(x), |
133 | 17x |
extra_afun_params, |
134 | 17x |
dots_extra_args |
135 |
) |
|
136 |
) |
|
137 | ||
138 |
# Fill in formatting defaults |
|
139 | 17x |
.stats <- get_stats("analyze_vars_counts", stats_in = .stats, custom_stats_in = names(custom_stat_functions)) |
140 | 17x |
.formats <- get_formats_from_stats(.stats, .formats) |
141 | 17x |
.labels <- get_labels_from_stats(.stats, .labels) |
142 | 17x |
.indent_mods <- get_indents_from_stats(.stats, .indent_mods) |
143 | ||
144 | 17x |
x_stats <- x_stats[.stats] |
145 | ||
146 |
# Auto format handling |
|
147 | 17x |
.formats <- apply_auto_formatting(.formats, x_stats, extra_afun_params$.df_row, extra_afun_params$.var) |
148 | ||
149 |
# Get and check statistical names |
|
150 | 17x |
.stat_names <- get_stat_names(x_stats, .stat_names) |
151 | ||
152 | 17x |
in_rows( |
153 | 17x |
.list = x_stats, |
154 | 17x |
.formats = .formats, |
155 | 17x |
.names = names(.labels), |
156 | 17x |
.stat_names = .stat_names, |
157 | 17x |
.labels = .labels %>% .unlist_keep_nulls(), |
158 | 17x |
.indent_mods = .indent_mods %>% .unlist_keep_nulls() |
159 |
) |
|
160 |
} |
|
161 | ||
162 |
#' @describeIn count_values Layout-creating function which can take statistics function arguments |
|
163 |
#' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
|
164 |
#' |
|
165 |
#' @return |
|
166 |
#' * `count_values()` returns a layout object suitable for passing to further layouting functions, |
|
167 |
#' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
|
168 |
#' the statistics from `s_count_values()` to the table layout. |
|
169 |
#' |
|
170 |
#' @examples |
|
171 |
#' # `count_values` |
|
172 |
#' basic_table() %>% |
|
173 |
#' count_values("Species", values = "setosa") %>% |
|
174 |
#' build_table(iris) |
|
175 |
#' |
|
176 |
#' @export |
|
177 |
#' @order 2 |
|
178 |
count_values <- function(lyt, |
|
179 |
vars, |
|
180 |
values, |
|
181 |
na_str = default_na_str(), |
|
182 |
na_rm = TRUE, |
|
183 |
nested = TRUE, |
|
184 |
..., |
|
185 |
table_names = vars, |
|
186 |
.stats = "count_fraction", |
|
187 |
.stat_names = NULL, |
|
188 |
.formats = c(count_fraction = "xx (xx.xx%)", count = "xx"), |
|
189 |
.labels = c(count_fraction = paste(values, collapse = ", ")), |
|
190 |
.indent_mods = NULL) { |
|
191 |
# Process standard extra arguments |
|
192 | 8x |
extra_args <- list(".stats" = .stats) |
193 | ! |
if (!is.null(.stat_names)) extra_args[[".stat_names"]] <- .stat_names |
194 | 8x |
if (!is.null(.formats)) extra_args[[".formats"]] <- .formats |
195 | 8x |
if (!is.null(.labels)) extra_args[[".labels"]] <- .labels |
196 | ! |
if (!is.null(.indent_mods)) extra_args[[".indent_mods"]] <- .indent_mods |
197 | ||
198 |
# Process additional arguments to the statistic function |
|
199 | 8x |
extra_args <- c( |
200 | 8x |
extra_args, |
201 | 8x |
na_rm = na_rm, values = list(values), |
202 |
... |
|
203 |
) |
|
204 | ||
205 |
# Adding additional info from layout to analysis function |
|
206 | 8x |
extra_args[[".additional_fun_parameters"]] <- get_additional_afun_params(add_alt_df = FALSE) |
207 | 8x |
formals(a_count_values) <- c(formals(a_count_values), extra_args[[".additional_fun_parameters"]]) |
208 | ||
209 | 8x |
analyze( |
210 | 8x |
lyt, |
211 | 8x |
vars, |
212 | 8x |
afun = a_count_values, |
213 | 8x |
na_str = na_str, |
214 | 8x |
nested = nested, |
215 | 8x |
extra_args = extra_args, |
216 | 8x |
show_labels = ifelse(length(vars) > 1, "visible", "hidden"), |
217 | 8x |
table_names = table_names |
218 |
) |
|
219 |
} |
1 |
#' Helper functions for subgroup treatment effect pattern (STEP) calculations |
|
2 |
#' |
|
3 |
#' @description `r lifecycle::badge("stable")` |
|
4 |
#' |
|
5 |
#' Helper functions that are used internally for the STEP calculations. |
|
6 |
#' |
|
7 |
#' @inheritParams argument_convention |
|
8 |
#' |
|
9 |
#' @name h_step |
|
10 |
#' @include control_step.R |
|
11 |
NULL |
|
12 | ||
13 |
#' @describeIn h_step Creates the windows for STEP, based on the control settings |
|
14 |
#' provided. |
|
15 |
#' |
|
16 |
#' @param x (`numeric`)\cr biomarker value(s) to use (without `NA`). |
|
17 |
#' @param control (named `list`)\cr output from `control_step()`. |
|
18 |
#' |
|
19 |
#' @return |
|
20 |
#' * `h_step_window()` returns a list containing the window-selection matrix `sel` |
|
21 |
#' and the interval information matrix `interval`. |
|
22 |
#' |
|
23 |
#' @export |
|
24 |
h_step_window <- function(x, |
|
25 |
control = control_step()) { |
|
26 | 12x |
checkmate::assert_numeric(x, min.len = 1, any.missing = FALSE) |
27 | 12x |
checkmate::assert_list(control, names = "named") |
28 | ||
29 | 12x |
sel <- matrix(FALSE, length(x), control$num_points) |
30 | 12x |
out <- matrix(0, control$num_points, 3) |
31 | 12x |
colnames(out) <- paste("Interval", c("Center", "Lower", "Upper")) |
32 | 12x |
if (control$use_percentile) { |
33 |
# Create windows according to percentile cutoffs. |
|
34 | 9x |
out <- cbind(out, out) |
35 | 9x |
colnames(out)[1:3] <- paste("Percentile", c("Center", "Lower", "Upper")) |
36 | 9x |
xs <- seq(0, 1, length.out = control$num_points + 2)[-1] |
37 | 9x |
for (i in seq_len(control$num_points)) { |
38 | 185x |
out[i, 2:3] <- c( |
39 | 185x |
max(xs[i] - control$bandwidth, 0), |
40 | 185x |
min(xs[i] + control$bandwidth, 1) |
41 |
) |
|
42 | 185x |
out[i, 5:6] <- stats::quantile(x, out[i, 2:3]) |
43 | 185x |
sel[, i] <- x >= out[i, 5] & x <= out[i, 6] |
44 |
} |
|
45 |
# Center is the middle point of the percentile window. |
|
46 | 9x |
out[, 1] <- xs[-control$num_points - 1] |
47 | 9x |
out[, 4] <- stats::quantile(x, out[, 1]) |
48 |
} else { |
|
49 |
# Create windows according to cutoffs. |
|
50 | 3x |
m <- c(min(x), max(x)) |
51 | 3x |
xs <- seq(m[1], m[2], length.out = control$num_points + 2)[-1] |
52 | 3x |
for (i in seq_len(control$num_points)) { |
53 | 11x |
out[i, 2:3] <- c( |
54 | 11x |
max(xs[i] - control$bandwidth, m[1]), |
55 | 11x |
min(xs[i] + control$bandwidth, m[2]) |
56 |
) |
|
57 | 11x |
sel[, i] <- x >= out[i, 2] & x <= out[i, 3] |
58 |
} |
|
59 |
# Center is the same as the point for predicting. |
|
60 | 3x |
out[, 1] <- xs[-control$num_points - 1] |
61 |
} |
|
62 | 12x |
list(sel = sel, interval = out) |
63 |
} |
|
64 | ||
65 |
#' @describeIn h_step Calculates the estimated treatment effect estimate |
|
66 |
#' on the linear predictor scale and corresponding standard error from a STEP `model` fitted |
|
67 |
#' on `data` given `variables` specification, for a single biomarker value `x`. |
|
68 |
#' This works for both `coxph` and `glm` models, i.e. for calculating log hazard ratio or log odds |
|
69 |
#' ratio estimates. |
|
70 |
#' |
|
71 |
#' @param model (`coxph` or `glm`)\cr the regression model object. |
|
72 |
#' |
|
73 |
#' @return |
|
74 |
#' * `h_step_trt_effect()` returns a vector with elements `est` and `se`. |
|
75 |
#' |
|
76 |
#' @export |
|
77 |
h_step_trt_effect <- function(data, |
|
78 |
model, |
|
79 |
variables, |
|
80 |
x) { |
|
81 | 208x |
checkmate::assert_multi_class(model, c("coxph", "glm")) |
82 | 208x |
checkmate::assert_number(x) |
83 | 208x |
assert_df_with_variables(data, variables) |
84 | 208x |
checkmate::assert_factor(data[[variables$arm]], n.levels = 2) |
85 | ||
86 | 208x |
newdata <- data[c(1, 1), ] |
87 | 208x |
newdata[, variables$biomarker] <- x |
88 | 208x |
newdata[, variables$arm] <- levels(data[[variables$arm]]) |
89 | 208x |
model_terms <- stats::delete.response(stats::terms(model)) |
90 | 208x |
model_frame <- stats::model.frame(model_terms, data = newdata, xlev = model$xlevels) |
91 | 208x |
mat <- stats::model.matrix(model_terms, data = model_frame, contrasts.arg = model$contrasts) |
92 | 208x |
coefs <- stats::coef(model) |
93 |
# Note: It is important to use the coef subset from matrix, otherwise intercept and |
|
94 |
# strata are included for coxph() models. |
|
95 | 208x |
mat <- mat[, names(coefs)] |
96 | 208x |
mat_diff <- diff(mat) |
97 | 208x |
est <- mat_diff %*% coefs |
98 | 208x |
var <- mat_diff %*% stats::vcov(model) %*% t(mat_diff) |
99 | 208x |
se <- sqrt(var) |
100 | 208x |
c( |
101 | 208x |
est = est, |
102 | 208x |
se = se |
103 |
) |
|
104 |
} |
|
105 | ||
106 |
#' @describeIn h_step Builds the model formula used in survival STEP calculations. |
|
107 |
#' |
|
108 |
#' @return |
|
109 |
#' * `h_step_survival_formula()` returns a model formula. |
|
110 |
#' |
|
111 |
#' @export |
|
112 |
h_step_survival_formula <- function(variables, |
|
113 |
control = control_step()) { |
|
114 | 10x |
checkmate::assert_character(variables$covariates, null.ok = TRUE) |
115 | ||
116 | 10x |
assert_list_of_variables(variables[c("arm", "biomarker", "event", "time")]) |
117 | 10x |
form <- paste0("Surv(", variables$time, ", ", variables$event, ") ~ ", variables$arm) |
118 | 10x |
if (control$degree > 0) { |
119 | 5x |
form <- paste0(form, " * stats::poly(", variables$biomarker, ", degree = ", control$degree, ", raw = TRUE)") |
120 |
} |
|
121 | 10x |
if (!is.null(variables$covariates)) { |
122 | 6x |
form <- paste(form, "+", paste(variables$covariates, collapse = "+")) |
123 |
} |
|
124 | 10x |
if (!is.null(variables$strata)) { |
125 | 2x |
form <- paste0(form, " + strata(", paste0(variables$strata, collapse = ", "), ")") |
126 |
} |
|
127 | 10x |
stats::as.formula(form) |
128 |
} |
|
129 | ||
130 |
#' @describeIn h_step Estimates the model with `formula` built based on |
|
131 |
#' `variables` in `data` for a given `subset` and `control` parameters for the |
|
132 |
#' Cox regression. |
|
133 |
#' |
|
134 |
#' @param formula (`formula`)\cr the regression model formula. |
|
135 |
#' @param subset (`logical`)\cr subset vector. |
|
136 |
#' |
|
137 |
#' @return |
|
138 |
#' * `h_step_survival_est()` returns a matrix of number of observations `n`, |
|
139 |
#' `events`, log hazard ratio estimates `loghr`, standard error `se`, |
|
140 |
#' and Wald confidence interval bounds `ci_lower` and `ci_upper`. One row is |
|
141 |
#' included for each biomarker value in `x`. |
|
142 |
#' |
|
143 |
#' @export |
|
144 |
h_step_survival_est <- function(formula, |
|
145 |
data, |
|
146 |
variables, |
|
147 |
x, |
|
148 |
subset = rep(TRUE, nrow(data)), |
|
149 |
control = control_coxph()) { |
|
150 | 55x |
checkmate::assert_formula(formula) |
151 | 55x |
assert_df_with_variables(data, variables) |
152 | 55x |
checkmate::assert_logical(subset, min.len = 1, any.missing = FALSE) |
153 | 55x |
checkmate::assert_numeric(x, min.len = 1, any.missing = FALSE) |
154 | 55x |
checkmate::assert_list(control, names = "named") |
155 | ||
156 |
# Note: `subset` in `coxph` needs to be an expression referring to `data` variables. |
|
157 | 55x |
data$.subset <- subset |
158 | 55x |
coxph_warnings <- NULL |
159 | 55x |
tryCatch( |
160 | 55x |
withCallingHandlers( |
161 | 55x |
expr = { |
162 | 55x |
fit <- survival::coxph( |
163 | 55x |
formula = formula, |
164 | 55x |
data = data, |
165 | 55x |
subset = .subset, |
166 | 55x |
ties = control$ties |
167 |
) |
|
168 |
}, |
|
169 | 55x |
warning = function(w) { |
170 | 1x |
coxph_warnings <<- c(coxph_warnings, w) |
171 | 1x |
invokeRestart("muffleWarning") |
172 |
} |
|
173 |
), |
|
174 | 55x |
finally = { |
175 |
} |
|
176 |
) |
|
177 | 55x |
if (!is.null(coxph_warnings)) { |
178 | 1x |
warning(paste( |
179 | 1x |
"Fit warnings occurred, please consider using a simpler model, or", |
180 | 1x |
"larger `bandwidth`, less `num_points` in `control_step()` settings" |
181 |
)) |
|
182 |
} |
|
183 |
# Produce a matrix with one row per `x` and columns `est` and `se`. |
|
184 | 55x |
estimates <- t(vapply( |
185 | 55x |
X = x, |
186 | 55x |
FUN = h_step_trt_effect, |
187 | 55x |
FUN.VALUE = c(1, 2), |
188 | 55x |
data = data, |
189 | 55x |
model = fit, |
190 | 55x |
variables = variables |
191 |
)) |
|
192 | 55x |
q_norm <- stats::qnorm((1 + control$conf_level) / 2) |
193 | 55x |
cbind( |
194 | 55x |
n = fit$n, |
195 | 55x |
events = fit$nevent, |
196 | 55x |
loghr = estimates[, "est"], |
197 | 55x |
se = estimates[, "se"], |
198 | 55x |
ci_lower = estimates[, "est"] - q_norm * estimates[, "se"], |
199 | 55x |
ci_upper = estimates[, "est"] + q_norm * estimates[, "se"] |
200 |
) |
|
201 |
} |
|
202 | ||
203 |
#' @describeIn h_step Builds the model formula used in response STEP calculations. |
|
204 |
#' |
|
205 |
#' @return |
|
206 |
#' * `h_step_rsp_formula()` returns a model formula. |
|
207 |
#' |
|
208 |
#' @export |
|
209 |
h_step_rsp_formula <- function(variables, |
|
210 |
control = c(control_step(), control_logistic())) { |
|
211 | 14x |
checkmate::assert_character(variables$covariates, null.ok = TRUE) |
212 | 14x |
assert_list_of_variables(variables[c("arm", "biomarker", "response")]) |
213 | 14x |
response_definition <- sub( |
214 | 14x |
pattern = "response", |
215 | 14x |
replacement = variables$response, |
216 | 14x |
x = control$response_definition, |
217 | 14x |
fixed = TRUE |
218 |
) |
|
219 | 14x |
form <- paste0(response_definition, " ~ ", variables$arm) |
220 | 14x |
if (control$degree > 0) { |
221 | 8x |
form <- paste0(form, " * stats::poly(", variables$biomarker, ", degree = ", control$degree, ", raw = TRUE)") |
222 |
} |
|
223 | 14x |
if (!is.null(variables$covariates)) { |
224 | 8x |
form <- paste(form, "+", paste(variables$covariates, collapse = "+")) |
225 |
} |
|
226 | 14x |
if (!is.null(variables$strata)) { |
227 | 5x |
strata_arg <- if (length(variables$strata) > 1) { |
228 | 2x |
paste0("I(interaction(", paste0(variables$strata, collapse = ", "), "))") |
229 |
} else { |
|
230 | 3x |
variables$strata |
231 |
} |
|
232 | 5x |
form <- paste0(form, "+ strata(", strata_arg, ")") |
233 |
} |
|
234 | 14x |
stats::as.formula(form) |
235 |
} |
|
236 | ||
237 |
#' @describeIn h_step Estimates the model with `formula` built based on |
|
238 |
#' `variables` in `data` for a given `subset` and `control` parameters for the |
|
239 |
#' logistic regression. |
|
240 |
#' |
|
241 |
#' @param formula (`formula`)\cr the regression model formula. |
|
242 |
#' @param subset (`logical`)\cr subset vector. |
|
243 |
#' |
|
244 |
#' @return |
|
245 |
#' * `h_step_rsp_est()` returns a matrix of number of observations `n`, log odds |
|
246 |
#' ratio estimates `logor`, standard error `se`, and Wald confidence interval bounds |
|
247 |
#' `ci_lower` and `ci_upper`. One row is included for each biomarker value in `x`. |
|
248 |
#' |
|
249 |
#' @export |
|
250 |
h_step_rsp_est <- function(formula, |
|
251 |
data, |
|
252 |
variables, |
|
253 |
x, |
|
254 |
subset = rep(TRUE, nrow(data)), |
|
255 |
control = control_logistic()) { |
|
256 | 58x |
checkmate::assert_formula(formula) |
257 | 58x |
assert_df_with_variables(data, variables) |
258 | 58x |
checkmate::assert_logical(subset, min.len = 1, any.missing = FALSE) |
259 | 58x |
checkmate::assert_numeric(x, min.len = 1, any.missing = FALSE) |
260 | 58x |
checkmate::assert_list(control, names = "named") |
261 |
# Note: `subset` in `glm` needs to be an expression referring to `data` variables. |
|
262 | 58x |
data$.subset <- subset |
263 | 58x |
fit_warnings <- NULL |
264 | 58x |
tryCatch( |
265 | 58x |
withCallingHandlers( |
266 | 58x |
expr = { |
267 | 58x |
fit <- if (is.null(variables$strata)) { |
268 | 54x |
stats::glm( |
269 | 54x |
formula = formula, |
270 | 54x |
data = data, |
271 | 54x |
subset = .subset, |
272 | 54x |
family = stats::binomial("logit") |
273 |
) |
|
274 |
} else { |
|
275 |
# clogit needs coxph and strata imported |
|
276 | 4x |
survival::clogit( |
277 | 4x |
formula = formula, |
278 | 4x |
data = data, |
279 | 4x |
subset = .subset |
280 |
) |
|
281 |
} |
|
282 |
}, |
|
283 | 58x |
warning = function(w) { |
284 | 19x |
fit_warnings <<- c(fit_warnings, w) |
285 | 19x |
invokeRestart("muffleWarning") |
286 |
} |
|
287 |
), |
|
288 | 58x |
finally = { |
289 |
} |
|
290 |
) |
|
291 | 58x |
if (!is.null(fit_warnings)) { |
292 | 13x |
warning(paste( |
293 | 13x |
"Fit warnings occurred, please consider using a simpler model, or", |
294 | 13x |
"larger `bandwidth`, less `num_points` in `control_step()` settings" |
295 |
)) |
|
296 |
} |
|
297 |
# Produce a matrix with one row per `x` and columns `est` and `se`. |
|
298 | 58x |
estimates <- t(vapply( |
299 | 58x |
X = x, |
300 | 58x |
FUN = h_step_trt_effect, |
301 | 58x |
FUN.VALUE = c(1, 2), |
302 | 58x |
data = data, |
303 | 58x |
model = fit, |
304 | 58x |
variables = variables |
305 |
)) |
|
306 | 58x |
q_norm <- stats::qnorm((1 + control$conf_level) / 2) |
307 | 58x |
cbind( |
308 | 58x |
n = length(fit$y), |
309 | 58x |
logor = estimates[, "est"], |
310 | 58x |
se = estimates[, "se"], |
311 | 58x |
ci_lower = estimates[, "est"] - q_norm * estimates[, "se"], |
312 | 58x |
ci_upper = estimates[, "est"] + q_norm * estimates[, "se"] |
313 |
) |
|
314 |
} |
1 |
#' Count occurrences by grade |
|
2 |
#' |
|
3 |
#' @description `r lifecycle::badge("stable")` |
|
4 |
#' |
|
5 |
#' The analyze function [count_occurrences_by_grade()] creates a layout element to calculate occurrence counts by grade. |
|
6 |
#' |
|
7 |
#' This function analyzes primary analysis variable `var` which indicates toxicity grades. The `id` variable |
|
8 |
#' is used to indicate unique subject identifiers (defaults to `USUBJID`). The user can also supply a list of |
|
9 |
#' custom groups of grades to analyze via the `grade_groups` parameter. The `remove_single` argument will |
|
10 |
#' remove single grades from the analysis so that *only* grade groups are analyzed. |
|
11 |
#' |
|
12 |
#' If there are multiple grades recorded for one patient only the highest grade level is counted. |
|
13 |
#' |
|
14 |
#' The summarize function [summarize_occurrences_by_grade()] performs the same function as |
|
15 |
#' [count_occurrences_by_grade()] except it creates content rows, not data rows, to summarize the current table |
|
16 |
#' row/column context and operates on the level of the latest row split or the root of the table if no row splits have |
|
17 |
#' occurred. |
|
18 |
#' |
|
19 |
#' @inheritParams count_occurrences |
|
20 |
#' @inheritParams argument_convention |
|
21 |
#' @param grade_groups (named `list` of `character`)\cr list containing groupings of grades. |
|
22 |
#' @param remove_single (`flag`)\cr `TRUE` to not include the elements of one-element grade groups |
|
23 |
#' in the the output list; in this case only the grade groups names will be included in the output. If |
|
24 |
#' `only_grade_groups` is set to `TRUE` this argument is ignored. |
|
25 |
#' @param only_grade_groups (`flag`)\cr whether only the specified grade groups should be |
|
26 |
#' included, with individual grade rows removed (`TRUE`), or all grades and grade groups |
|
27 |
#' should be displayed (`FALSE`). |
|
28 |
#' @param .stats (`character`)\cr statistics to select for the table. |
|
29 |
#' |
|
30 |
#' Options are: ``r shQuote(get_stats("count_occurrences_by_grade"), type = "sh")`` |
|
31 |
#' |
|
32 |
#' @seealso Relevant helper function [h_append_grade_groups()]. |
|
33 |
#' |
|
34 |
#' @name count_occurrences_by_grade |
|
35 |
#' @order 1 |
|
36 |
NULL |
|
37 | ||
38 |
#' Helper function for `s_count_occurrences_by_grade()` |
|
39 |
#' |
|
40 |
#' @description `r lifecycle::badge("stable")` |
|
41 |
#' |
|
42 |
#' Helper function for [s_count_occurrences_by_grade()] to insert grade groupings into list with |
|
43 |
#' individual grade frequencies. The order of the final result follows the order of `grade_groups`. |
|
44 |
#' The elements under any-grade group (if any), i.e. the grade group equal to `refs` will be moved to |
|
45 |
#' the end. Grade groups names must be unique. |
|
46 |
#' |
|
47 |
#' @inheritParams count_occurrences_by_grade |
|
48 |
#' @param refs (named `list` of `numeric`)\cr named list where each name corresponds to a reference grade level |
|
49 |
#' and each entry represents a count. |
|
50 |
#' |
|
51 |
#' @return Formatted list of grade groupings. |
|
52 |
#' |
|
53 |
#' @examples |
|
54 |
#' h_append_grade_groups( |
|
55 |
#' list( |
|
56 |
#' "Any Grade" = as.character(1:5), |
|
57 |
#' "Grade 1-2" = c("1", "2"), |
|
58 |
#' "Grade 3-4" = c("3", "4") |
|
59 |
#' ), |
|
60 |
#' list("1" = 10, "2" = 20, "3" = 30, "4" = 40, "5" = 50) |
|
61 |
#' ) |
|
62 |
#' |
|
63 |
#' h_append_grade_groups( |
|
64 |
#' list( |
|
65 |
#' "Any Grade" = as.character(5:1), |
|
66 |
#' "Grade A" = "5", |
|
67 |
#' "Grade B" = c("4", "3") |
|
68 |
#' ), |
|
69 |
#' list("1" = 10, "2" = 20, "3" = 30, "4" = 40, "5" = 50) |
|
70 |
#' ) |
|
71 |
#' |
|
72 |
#' h_append_grade_groups( |
|
73 |
#' list( |
|
74 |
#' "Any Grade" = as.character(1:5), |
|
75 |
#' "Grade 1-2" = c("1", "2"), |
|
76 |
#' "Grade 3-4" = c("3", "4") |
|
77 |
#' ), |
|
78 |
#' list("1" = 10, "2" = 5, "3" = 0) |
|
79 |
#' ) |
|
80 |
#' |
|
81 |
#' @export |
|
82 |
h_append_grade_groups <- function(grade_groups, refs, remove_single = TRUE, only_grade_groups = FALSE) { |
|
83 | 32x |
checkmate::assert_list(grade_groups) |
84 | 32x |
checkmate::assert_list(refs) |
85 | 32x |
refs_orig <- refs |
86 | 32x |
elements <- unique(unlist(grade_groups)) |
87 | ||
88 |
### compute sums in groups |
|
89 | 32x |
grp_sum <- lapply(grade_groups, function(i) do.call(sum, refs[i])) |
90 | 32x |
if (!checkmate::test_subset(elements, names(refs))) { |
91 | 2x |
padding_el <- setdiff(elements, names(refs)) |
92 | 2x |
refs[padding_el] <- 0 |
93 |
} |
|
94 | 32x |
result <- c(grp_sum, refs) |
95 | ||
96 |
### order result while keeping grade_groups's ordering |
|
97 | 32x |
ordr <- grade_groups |
98 | ||
99 |
# elements of any-grade group (if any) will be moved to the end |
|
100 | 32x |
is_any <- sapply(grade_groups, setequal, y = names(refs)) |
101 | 32x |
ordr[is_any] <- list(character(0)) # hide elements under any-grade group |
102 | ||
103 |
# groups-elements combined sequence |
|
104 | 32x |
ordr <- c(lapply(names(ordr), function(g) c(g, ordr[[g]])), recursive = TRUE, use.names = FALSE) |
105 | 32x |
ordr <- ordr[!duplicated(ordr)] |
106 | ||
107 |
# append remaining elements (if any) |
|
108 | 32x |
ordr <- union(ordr, unlist(grade_groups[is_any])) # from any-grade group |
109 | 32x |
ordr <- union(ordr, names(refs)) # from refs |
110 | ||
111 |
# remove elements of single-element groups, if any |
|
112 | 32x |
if (only_grade_groups) { |
113 | 3x |
ordr <- intersect(ordr, names(grade_groups)) |
114 | 29x |
} else if (remove_single) { |
115 | 29x |
is_single <- sapply(grade_groups, length) == 1L |
116 | 29x |
ordr <- setdiff(ordr, unlist(grade_groups[is_single])) |
117 |
} |
|
118 | ||
119 |
# apply the order |
|
120 | 32x |
result <- result[ordr] |
121 | ||
122 |
# remove groups without any elements in the original refs |
|
123 |
# note: it's OK if groups have 0 value |
|
124 | 32x |
keep_grp <- vapply(grade_groups, function(x, rf) { |
125 | 64x |
any(x %in% rf) |
126 | 32x |
}, rf = names(refs_orig), logical(1)) |
127 | ||
128 | 32x |
keep_el <- names(result) %in% names(refs_orig) | names(result) %in% names(keep_grp)[keep_grp] |
129 | 32x |
result <- result[keep_el] |
130 | ||
131 | 32x |
result |
132 |
} |
|
133 | ||
134 |
#' @describeIn count_occurrences_by_grade Statistics function which counts the |
|
135 |
#' number of patients by highest grade. |
|
136 |
#' |
|
137 |
#' @return |
|
138 |
#' * `s_count_occurrences_by_grade()` returns a list of counts and fractions with one element per grade level or |
|
139 |
#' grade level grouping. |
|
140 |
#' |
|
141 |
#' @examples |
|
142 |
#' s_count_occurrences_by_grade( |
|
143 |
#' df, |
|
144 |
#' .N_col = 10L, |
|
145 |
#' .var = "AETOXGR", |
|
146 |
#' id = "USUBJID", |
|
147 |
#' grade_groups = list("ANY" = levels(df$AETOXGR)) |
|
148 |
#' ) |
|
149 |
#' |
|
150 |
#' @export |
|
151 |
s_count_occurrences_by_grade <- function(df, |
|
152 |
labelstr = "", |
|
153 |
.var, |
|
154 |
.N_row, # nolint |
|
155 |
.N_col, # nolint |
|
156 |
..., |
|
157 |
id = "USUBJID", |
|
158 |
grade_groups = list(), |
|
159 |
remove_single = TRUE, |
|
160 |
only_grade_groups = FALSE, |
|
161 |
denom = c("N_col", "n", "N_row")) { |
|
162 | 75x |
assert_valid_factor(df[[.var]]) |
163 | 75x |
assert_df_with_variables(df, list(grade = .var, id = id)) |
164 | ||
165 | 75x |
denom <- match.arg(denom) %>% |
166 | 75x |
switch( |
167 | 75x |
n = nlevels(factor(df[[id]])), |
168 | 75x |
N_row = .N_row, |
169 | 75x |
N_col = .N_col |
170 |
) |
|
171 | ||
172 | 75x |
if (nrow(df) < 1) { |
173 | 5x |
grade_levels <- levels(df[[.var]]) |
174 | 5x |
l_count <- as.list(rep(0, length(grade_levels))) |
175 | 5x |
names(l_count) <- grade_levels |
176 |
} else { |
|
177 | 70x |
if (isTRUE(is.factor(df[[id]]))) { |
178 | ! |
assert_valid_factor(df[[id]], any.missing = FALSE) |
179 |
} else { |
|
180 | 70x |
checkmate::assert_character(df[[id]], min.chars = 1, any.missing = FALSE) |
181 |
} |
|
182 | 70x |
checkmate::assert_count(.N_col) |
183 | ||
184 | 70x |
id <- df[[id]] |
185 | 70x |
grade <- df[[.var]] |
186 | ||
187 | 70x |
if (!is.ordered(grade)) { |
188 | 70x |
grade_lbl <- obj_label(grade) |
189 | 70x |
lvls <- levels(grade) |
190 | 70x |
if (sum(grepl("^\\d+$", lvls)) %in% c(0, length(lvls))) { |
191 | 69x |
lvl_ord <- lvls |
192 |
} else { |
|
193 | 1x |
lvls[!grepl("^\\d+$", lvls)] <- min(as.numeric(lvls[grepl("^\\d+$", lvls)])) - 1 |
194 | 1x |
lvl_ord <- levels(grade)[order(as.numeric(lvls))] |
195 |
} |
|
196 | 70x |
grade <- formatters::with_label(factor(grade, levels = lvl_ord, ordered = TRUE), grade_lbl) |
197 |
} |
|
198 | ||
199 | 70x |
missing_lvl <- grepl("missing", tolower(levels(grade))) |
200 | 70x |
if (any(missing_lvl)) { |
201 | 1x |
grade <- factor( |
202 | 1x |
grade, |
203 | 1x |
levels = c(levels(grade)[!missing_lvl], levels(grade)[missing_lvl]), |
204 | 1x |
ordered = is.ordered(grade) |
205 |
) |
|
206 |
} |
|
207 | 70x |
df_max <- stats::aggregate(grade ~ id, FUN = max, drop = FALSE) |
208 | 70x |
l_count <- as.list(table(df_max$grade)) |
209 |
} |
|
210 | ||
211 | 75x |
if (length(grade_groups) > 0) { |
212 | 30x |
l_count <- h_append_grade_groups(grade_groups, l_count, remove_single, only_grade_groups) |
213 |
} |
|
214 | ||
215 | 75x |
l_count_fraction <- lapply( |
216 | 75x |
l_count, |
217 | 75x |
function(i, denom) { |
218 | 299x |
if (i == 0 && denom == 0) { |
219 | 9x |
c(0, 0) |
220 |
} else { |
|
221 | 290x |
c(i, i / denom) |
222 |
} |
|
223 |
}, |
|
224 | 75x |
denom = denom |
225 |
) |
|
226 | ||
227 | 75x |
list( |
228 | 75x |
count_fraction = l_count_fraction, |
229 | 75x |
count_fraction_fixed_dp = l_count_fraction |
230 |
) |
|
231 |
} |
|
232 | ||
233 |
#' @describeIn count_occurrences_by_grade Formatted analysis function which is used as `afun` |
|
234 |
#' in `count_occurrences_by_grade()`. |
|
235 |
#' |
|
236 |
#' @return |
|
237 |
#' * `a_count_occurrences_by_grade()` returns the corresponding list with formatted [rtables::CellValue()]. |
|
238 |
#' |
|
239 |
#' @examples |
|
240 |
#' a_count_occurrences_by_grade( |
|
241 |
#' df, |
|
242 |
#' .N_col = 10L, |
|
243 |
#' .N_row = 10L, |
|
244 |
#' .var = "AETOXGR", |
|
245 |
#' id = "USUBJID", |
|
246 |
#' grade_groups = list("ANY" = levels(df$AETOXGR)) |
|
247 |
#' ) |
|
248 |
#' |
|
249 |
#' @export |
|
250 |
a_count_occurrences_by_grade <- function(df, |
|
251 |
labelstr = "", |
|
252 |
..., |
|
253 |
.stats = NULL, |
|
254 |
.stat_names = NULL, |
|
255 |
.formats = NULL, |
|
256 |
.labels = NULL, |
|
257 |
.indent_mods = NULL) { |
|
258 |
# Check for additional parameters to the statistics function |
|
259 | 56x |
dots_extra_args <- list(...) |
260 | 56x |
extra_afun_params <- retrieve_extra_afun_params(names(dots_extra_args$.additional_fun_parameters)) |
261 | 56x |
dots_extra_args$.additional_fun_parameters <- NULL |
262 | ||
263 |
# Check for user-defined functions |
|
264 | 56x |
default_and_custom_stats_list <- .split_std_from_custom_stats(.stats) |
265 | 56x |
.stats <- default_and_custom_stats_list$all_stats |
266 | 56x |
custom_stat_functions <- default_and_custom_stats_list$custom_stats |
267 | ||
268 |
# Apply statistics function |
|
269 | 56x |
x_stats <- .apply_stat_functions( |
270 | 56x |
default_stat_fnc = s_count_occurrences_by_grade, |
271 | 56x |
custom_stat_fnc_list = custom_stat_functions, |
272 | 56x |
args_list = c( |
273 | 56x |
df = list(df), |
274 | 56x |
labelstr = list(labelstr), |
275 | 56x |
extra_afun_params, |
276 | 56x |
dots_extra_args |
277 |
) |
|
278 |
) |
|
279 | ||
280 |
# Fill in formatting defaults |
|
281 | 56x |
.stats <- get_stats("count_occurrences_by_grade", stats_in = .stats, custom_stats_in = names(custom_stat_functions)) |
282 | 56x |
x_stats <- x_stats[.stats] |
283 | 56x |
levels_per_stats <- lapply(x_stats, names) |
284 | 56x |
.formats <- get_formats_from_stats(.stats, .formats, levels_per_stats) |
285 | 56x |
.labels <- get_labels_from_stats(.stats, .labels, levels_per_stats) |
286 | 56x |
.indent_mods <- get_indents_from_stats(.stats, .indent_mods, levels_per_stats) |
287 | ||
288 | 56x |
x_stats <- x_stats[.stats] %>% |
289 | 56x |
.unlist_keep_nulls() %>% |
290 | 56x |
setNames(names(.formats)) |
291 | ||
292 |
# Auto format handling |
|
293 | 56x |
.formats <- apply_auto_formatting(.formats, x_stats, extra_afun_params$.df_row, extra_afun_params$.var) |
294 | ||
295 |
# Get and check statistical names |
|
296 | 56x |
.stat_names <- get_stat_names(x_stats, .stat_names) |
297 | ||
298 | 56x |
in_rows( |
299 | 56x |
.list = x_stats, |
300 | 56x |
.formats = .formats, |
301 | 56x |
.names = .labels %>% .unlist_keep_nulls(), |
302 | 56x |
.stat_names = .stat_names, |
303 | 56x |
.labels = .labels %>% .unlist_keep_nulls(), |
304 | 56x |
.indent_mods = .indent_mods %>% .unlist_keep_nulls() |
305 |
) |
|
306 |
} |
|
307 | ||
308 |
#' @describeIn count_occurrences_by_grade Layout-creating function which can take statistics function |
|
309 |
#' arguments and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
|
310 |
#' |
|
311 |
#' @return |
|
312 |
#' * `count_occurrences_by_grade()` returns a layout object suitable for passing to further layouting functions, |
|
313 |
#' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
|
314 |
#' the statistics from `s_count_occurrences_by_grade()` to the table layout. |
|
315 |
#' |
|
316 |
#' @examples |
|
317 |
#' library(dplyr) |
|
318 |
#' |
|
319 |
#' df <- data.frame( |
|
320 |
#' USUBJID = as.character(c(1:6, 1)), |
|
321 |
#' ARM = factor(c("A", "A", "A", "B", "B", "B", "A"), levels = c("A", "B")), |
|
322 |
#' AETOXGR = factor(c(1, 2, 3, 4, 1, 2, 3), levels = c(1:5)), |
|
323 |
#' AESEV = factor( |
|
324 |
#' x = c("MILD", "MODERATE", "SEVERE", "MILD", "MILD", "MODERATE", "SEVERE"), |
|
325 |
#' levels = c("MILD", "MODERATE", "SEVERE") |
|
326 |
#' ), |
|
327 |
#' stringsAsFactors = FALSE |
|
328 |
#' ) |
|
329 |
#' |
|
330 |
#' df_adsl <- df %>% |
|
331 |
#' select(USUBJID, ARM) %>% |
|
332 |
#' unique() |
|
333 |
#' |
|
334 |
#' # Layout creating function with custom format. |
|
335 |
#' basic_table() %>% |
|
336 |
#' split_cols_by("ARM") %>% |
|
337 |
#' add_colcounts() %>% |
|
338 |
#' count_occurrences_by_grade( |
|
339 |
#' var = "AESEV", |
|
340 |
#' .formats = c("count_fraction" = "xx.xx (xx.xx%)") |
|
341 |
#' ) %>% |
|
342 |
#' build_table(df, alt_counts_df = df_adsl) |
|
343 |
#' |
|
344 |
#' # Define additional grade groupings. |
|
345 |
#' grade_groups <- list( |
|
346 |
#' "-Any-" = c("1", "2", "3", "4", "5"), |
|
347 |
#' "Grade 1-2" = c("1", "2"), |
|
348 |
#' "Grade 3-5" = c("3", "4", "5") |
|
349 |
#' ) |
|
350 |
#' |
|
351 |
#' basic_table() %>% |
|
352 |
#' split_cols_by("ARM") %>% |
|
353 |
#' add_colcounts() %>% |
|
354 |
#' count_occurrences_by_grade( |
|
355 |
#' var = "AETOXGR", |
|
356 |
#' grade_groups = grade_groups, |
|
357 |
#' only_grade_groups = TRUE |
|
358 |
#' ) %>% |
|
359 |
#' build_table(df, alt_counts_df = df_adsl) |
|
360 |
#' |
|
361 |
#' @export |
|
362 |
#' @order 2 |
|
363 |
count_occurrences_by_grade <- function(lyt, |
|
364 |
var, |
|
365 |
id = "USUBJID", |
|
366 |
grade_groups = list(), |
|
367 |
remove_single = TRUE, |
|
368 |
only_grade_groups = FALSE, |
|
369 |
var_labels = var, |
|
370 |
show_labels = "default", |
|
371 |
riskdiff = FALSE, |
|
372 |
na_str = default_na_str(), |
|
373 |
nested = TRUE, |
|
374 |
..., |
|
375 |
table_names = var, |
|
376 |
.stats = "count_fraction", |
|
377 |
.stat_names = NULL, |
|
378 |
.formats = list(count_fraction = format_count_fraction_fixed_dp), |
|
379 |
.labels = NULL, |
|
380 |
.indent_mods = NULL) { |
|
381 | 12x |
checkmate::assert_flag(riskdiff) |
382 | 12x |
afun <- if (isFALSE(riskdiff)) a_count_occurrences_by_grade else afun_riskdiff |
383 | ||
384 |
# Process standard extra arguments |
|
385 | 12x |
extra_args <- list(".stats" = .stats) |
386 | ! |
if (!is.null(.stat_names)) extra_args[[".stat_names"]] <- .stat_names |
387 | 12x |
if (!is.null(.formats)) extra_args[[".formats"]] <- .formats |
388 | ! |
if (!is.null(.labels)) extra_args[[".labels"]] <- .labels |
389 | 1x |
if (!is.null(.indent_mods)) extra_args[[".indent_mods"]] <- .indent_mods |
390 | ||
391 |
# Process additional arguments to the statistic function |
|
392 | 12x |
extra_args <- c( |
393 | 12x |
extra_args, |
394 | 12x |
id = id, grade_groups = list(grade_groups), remove_single = remove_single, only_grade_groups = only_grade_groups, |
395 | 12x |
if (!isFALSE(riskdiff)) list(afun = list("s_count_occurrences_by_grade" = a_count_occurrences_by_grade)), |
396 |
... |
|
397 |
) |
|
398 | ||
399 |
# Append additional info from layout to the analysis function |
|
400 | 12x |
extra_args[[".additional_fun_parameters"]] <- get_additional_afun_params(add_alt_df = FALSE) |
401 | 12x |
formals(afun) <- c(formals(afun), extra_args[[".additional_fun_parameters"]]) |
402 | ||
403 | 12x |
analyze( |
404 | 12x |
lyt = lyt, |
405 | 12x |
vars = var, |
406 | 12x |
afun = afun, |
407 | 12x |
na_str = na_str, |
408 | 12x |
nested = nested, |
409 | 12x |
extra_args = extra_args, |
410 | 12x |
var_labels = var_labels, |
411 | 12x |
show_labels = show_labels, |
412 | 12x |
table_names = table_names |
413 |
) |
|
414 |
} |
|
415 | ||
416 |
#' @describeIn count_occurrences_by_grade Layout-creating function which can take content function arguments |
|
417 |
#' and additional format arguments. This function is a wrapper for [rtables::summarize_row_groups()]. |
|
418 |
#' |
|
419 |
#' @return |
|
420 |
#' * `summarize_occurrences_by_grade()` returns a layout object suitable for passing to further layouting functions, |
|
421 |
#' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted content rows |
|
422 |
#' containing the statistics from `s_count_occurrences_by_grade()` to the table layout. |
|
423 |
#' |
|
424 |
#' @examples |
|
425 |
#' # Layout creating function with custom format. |
|
426 |
#' basic_table() %>% |
|
427 |
#' add_colcounts() %>% |
|
428 |
#' split_rows_by("ARM", child_labels = "visible", nested = TRUE) %>% |
|
429 |
#' summarize_occurrences_by_grade( |
|
430 |
#' var = "AESEV", |
|
431 |
#' .formats = c("count_fraction" = "xx.xx (xx.xx%)") |
|
432 |
#' ) %>% |
|
433 |
#' build_table(df, alt_counts_df = df_adsl) |
|
434 |
#' |
|
435 |
#' basic_table() %>% |
|
436 |
#' add_colcounts() %>% |
|
437 |
#' split_rows_by("ARM", child_labels = "visible", nested = TRUE) %>% |
|
438 |
#' summarize_occurrences_by_grade( |
|
439 |
#' var = "AETOXGR", |
|
440 |
#' grade_groups = grade_groups |
|
441 |
#' ) %>% |
|
442 |
#' build_table(df, alt_counts_df = df_adsl) |
|
443 |
#' |
|
444 |
#' @export |
|
445 |
#' @order 3 |
|
446 |
summarize_occurrences_by_grade <- function(lyt, |
|
447 |
var, |
|
448 |
id = "USUBJID", |
|
449 |
grade_groups = list(), |
|
450 |
remove_single = TRUE, |
|
451 |
only_grade_groups = FALSE, |
|
452 |
riskdiff = FALSE, |
|
453 |
na_str = default_na_str(), |
|
454 |
..., |
|
455 |
.stats = "count_fraction", |
|
456 |
.stat_names = NULL, |
|
457 |
.formats = list(count_fraction = format_count_fraction_fixed_dp), |
|
458 |
.labels = NULL, |
|
459 |
.indent_mods = 0L) { |
|
460 | 6x |
checkmate::assert_flag(riskdiff) |
461 | 6x |
afun <- if (isFALSE(riskdiff)) a_count_occurrences_by_grade else afun_riskdiff |
462 | ||
463 |
# Process standard extra arguments |
|
464 | 6x |
extra_args <- list(".stats" = .stats) |
465 | ! |
if (!is.null(.stat_names)) extra_args[[".stat_names"]] <- .stat_names |
466 | 6x |
if (!is.null(.formats)) extra_args[[".formats"]] <- .formats |
467 | ! |
if (!is.null(.labels)) extra_args[[".labels"]] <- .labels |
468 | 6x |
if (is.null(.indent_mods)) { |
469 | ! |
indent_mod <- 0L |
470 | 6x |
} else if (length(.indent_mods) == 1) { |
471 | 6x |
indent_mod <- .indent_mods |
472 |
} else { |
|
473 | ! |
indent_mod <- 0L |
474 | ! |
extra_args[[".indent_mods"]] <- .indent_mods |
475 |
} |
|
476 | ||
477 |
# Process additional arguments to the statistic function |
|
478 | 6x |
extra_args <- c( |
479 | 6x |
extra_args, |
480 | 6x |
id = id, grade_groups = list(grade_groups), remove_single = remove_single, only_grade_groups = only_grade_groups, |
481 | 6x |
if (!isFALSE(riskdiff)) list(afun = list("s_count_occurrences_by_grade" = a_count_occurrences_by_grade)), |
482 |
... |
|
483 |
) |
|
484 | ||
485 |
# Append additional info from layout to the analysis function |
|
486 | 6x |
extra_args[[".additional_fun_parameters"]] <- get_additional_afun_params(add_alt_df = FALSE) |
487 | 6x |
formals(afun) <- c(formals(afun), extra_args[[".additional_fun_parameters"]]) |
488 | ||
489 | 6x |
summarize_row_groups( |
490 | 6x |
lyt = lyt, |
491 | 6x |
var = var, |
492 | 6x |
cfun = afun, |
493 | 6x |
na_str = na_str, |
494 | 6x |
extra_args = extra_args, |
495 | 6x |
indent_mod = indent_mod |
496 |
) |
|
497 |
} |
1 |
#' Confidence intervals for a difference of binomials |
|
2 |
#' |
|
3 |
#' @description `r lifecycle::badge("experimental")` |
|
4 |
#' |
|
5 |
#' Several confidence intervals for the difference between proportions. |
|
6 |
#' |
|
7 |
#' @name desctools_binom |
|
8 |
NULL |
|
9 | ||
10 |
#' Recycle list of parameters |
|
11 |
#' |
|
12 |
#' This function recycles all supplied elements to the maximal dimension. |
|
13 |
#' |
|
14 |
#' @param ... (`any`)\cr elements to recycle. |
|
15 |
#' |
|
16 |
#' @return A `list`. |
|
17 |
#' |
|
18 |
#' @keywords internal |
|
19 |
#' @noRd |
|
20 |
h_recycle <- function(...) { |
|
21 | 78x |
lst <- list(...) |
22 | 78x |
maxdim <- max(lengths(lst)) |
23 | 78x |
res <- lapply(lst, rep, length.out = maxdim) |
24 | 78x |
attr(res, "maxdim") <- maxdim |
25 | 78x |
return(res) |
26 |
} |
|
27 | ||
28 |
#' @describeIn desctools_binom Several confidence intervals for the difference between proportions. |
|
29 |
#' |
|
30 |
#' @return A `matrix` of 3 values: |
|
31 |
#' * `est`: estimate of proportion difference. |
|
32 |
#' * `lwr.ci`: estimate of lower end of the confidence interval. |
|
33 |
#' * `upr.ci`: estimate of upper end of the confidence interval. |
|
34 |
#' |
|
35 |
#' @keywords internal |
|
36 |
desctools_binom <- function(x1, |
|
37 |
n1, |
|
38 |
x2, |
|
39 |
n2, |
|
40 |
conf.level = 0.95, # nolint |
|
41 |
sides = c("two.sided", "left", "right"), |
|
42 |
method = c( |
|
43 |
"ac", "wald", "waldcc", "score", "scorecc", "mn", "mee", "blj", "ha", "hal", "jp" |
|
44 |
)) { |
|
45 | 26x |
if (missing(sides)) { |
46 | 26x |
sides <- match.arg(sides) |
47 |
} |
|
48 | 26x |
if (missing(method)) { |
49 | 1x |
method <- match.arg(method) |
50 |
} |
|
51 | 26x |
iBinomDiffCI <- function(x1, n1, x2, n2, conf.level, sides, method) { # nolint |
52 | 26x |
if (sides != "two.sided") { |
53 | ! |
conf.level <- 1 - 2 * (1 - conf.level) # nolint |
54 |
} |
|
55 | 26x |
alpha <- 1 - conf.level |
56 | 26x |
kappa <- stats::qnorm(1 - alpha / 2) |
57 | 26x |
p1_hat <- x1 / n1 |
58 | 26x |
p2_hat <- x2 / n2 |
59 | 26x |
est <- p1_hat - p2_hat |
60 | 26x |
switch(method, |
61 | 26x |
wald = { |
62 | 4x |
vd <- p1_hat * (1 - p1_hat) / n1 + p2_hat * (1 - p2_hat) / n2 |
63 | 4x |
term2 <- kappa * sqrt(vd) |
64 | 4x |
ci_lwr <- max(-1, est - term2) |
65 | 4x |
ci_upr <- min(1, est + term2) |
66 |
}, |
|
67 | 26x |
waldcc = { |
68 | 6x |
vd <- p1_hat * (1 - p1_hat) / n1 + p2_hat * (1 - p2_hat) / n2 |
69 | 6x |
term2 <- kappa * sqrt(vd) |
70 | 6x |
term2 <- term2 + 0.5 * (1 / n1 + 1 / n2) |
71 | 6x |
ci_lwr <- max(-1, est - term2) |
72 | 6x |
ci_upr <- min(1, est + term2) |
73 |
}, |
|
74 | 26x |
ac = { |
75 | 2x |
n1 <- n1 + 2 |
76 | 2x |
n2 <- n2 + 2 |
77 | 2x |
x1 <- x1 + 1 |
78 | 2x |
x2 <- x2 + 1 |
79 | 2x |
p1_hat <- x1 / n1 |
80 | 2x |
p2_hat <- x2 / n2 |
81 | 2x |
est1 <- p1_hat - p2_hat |
82 | 2x |
vd <- p1_hat * (1 - p1_hat) / n1 + p2_hat * (1 - p2_hat) / n2 |
83 | 2x |
term2 <- kappa * sqrt(vd) |
84 | 2x |
ci_lwr <- max(-1, est1 - term2) |
85 | 2x |
ci_upr <- min(1, est1 + term2) |
86 |
}, |
|
87 | 26x |
exact = { |
88 | ! |
ci_lwr <- NA |
89 | ! |
ci_upr <- NA |
90 |
}, |
|
91 | 26x |
score = { |
92 | 3x |
w1 <- desctools_binomci( |
93 | 3x |
x = x1, n = n1, conf.level = conf.level, |
94 | 3x |
method = "wilson" |
95 |
) |
|
96 | 3x |
w2 <- desctools_binomci( |
97 | 3x |
x = x2, n = n2, conf.level = conf.level, |
98 | 3x |
method = "wilson" |
99 |
) |
|
100 | 3x |
l1 <- w1[2] |
101 | 3x |
u1 <- w1[3] |
102 | 3x |
l2 <- w2[2] |
103 | 3x |
u2 <- w2[3] |
104 | 3x |
ci_lwr <- est - kappa * sqrt(l1 * (1 - l1) / n1 + u2 * (1 - u2) / n2) |
105 | 3x |
ci_upr <- est + kappa * sqrt(u1 * (1 - u1) / n1 + l2 * (1 - l2) / n2) |
106 |
}, |
|
107 | 26x |
scorecc = { |
108 | 1x |
w1 <- desctools_binomci( |
109 | 1x |
x = x1, n = n1, conf.level = conf.level, |
110 | 1x |
method = "wilsoncc" |
111 |
) |
|
112 | 1x |
w2 <- desctools_binomci( |
113 | 1x |
x = x2, n = n2, conf.level = conf.level, |
114 | 1x |
method = "wilsoncc" |
115 |
) |
|
116 | 1x |
l1 <- w1[2] |
117 | 1x |
u1 <- w1[3] |
118 | 1x |
l2 <- w2[2] |
119 | 1x |
u2 <- w2[3] |
120 | 1x |
ci_lwr <- max(-1, est - sqrt((p1_hat - l1)^2 + (u2 - p2_hat)^2)) |
121 | 1x |
ci_upr <- min(1, est + sqrt((u1 - p1_hat)^2 + (p2_hat - l2)^2)) |
122 |
}, |
|
123 | 26x |
mee = { |
124 | 1x |
.score <- function(p1, n1, p2, n2, dif) { |
125 | ! |
if (dif > 1) dif <- 1 |
126 | ! |
if (dif < -1) dif <- -1 |
127 | 24x |
diff <- p1 - p2 - dif |
128 | 24x |
if (abs(diff) == 0) { |
129 | ! |
res <- 0 |
130 |
} else { |
|
131 | 24x |
t <- n2 / n1 |
132 | 24x |
a <- 1 + t |
133 | 24x |
b <- -(1 + t + p1 + t * p2 + dif * (t + 2)) |
134 | 24x |
c <- dif * dif + dif * (2 * p1 + t + 1) + p1 + t * p2 |
135 | 24x |
d <- -p1 * dif * (1 + dif) |
136 | 24x |
v <- (b / a / 3)^3 - b * c / (6 * a * a) + d / a / 2 |
137 | 24x |
if (abs(v) < .Machine$double.eps) v <- 0 |
138 | 24x |
s <- sqrt((b / a / 3)^2 - c / a / 3) |
139 | 24x |
u <- ifelse(v > 0, 1, -1) * s |
140 | 24x |
w <- (3.141592654 + acos(v / u^3)) / 3 |
141 | 24x |
p1d <- 2 * u * cos(w) - b / a / 3 |
142 | 24x |
p2d <- p1d - dif |
143 | 24x |
n <- n1 + n2 |
144 | 24x |
res <- (p1d * (1 - p1d) / n1 + p2d * (1 - p2d) / n2) |
145 |
} |
|
146 | 24x |
return(sqrt(res)) |
147 |
} |
|
148 | 1x |
pval <- function(delta) { |
149 | 24x |
z <- (est - delta) / .score(p1_hat, n1, p2_hat, n2, delta) |
150 | 24x |
2 * min(stats::pnorm(z), 1 - stats::pnorm(z)) |
151 |
} |
|
152 | 1x |
ci_lwr <- max(-1, stats::uniroot(function(delta) { |
153 | 12x |
pval(delta) - alpha |
154 | 1x |
}, interval = c(-1 + 1e-06, est - 1e-06))$root) |
155 | 1x |
ci_upr <- min(1, stats::uniroot(function(delta) { |
156 | 12x |
pval(delta) - alpha |
157 | 1x |
}, interval = c(est + 1e-06, 1 - 1e-06))$root) |
158 |
}, |
|
159 | 26x |
blj = { |
160 | 1x |
p1_dash <- (x1 + 0.5) / (n1 + 1) |
161 | 1x |
p2_dash <- (x2 + 0.5) / (n2 + 1) |
162 | 1x |
vd <- p1_dash * (1 - p1_dash) / n1 + p2_dash * (1 - p2_dash) / n2 |
163 | 1x |
term2 <- kappa * sqrt(vd) |
164 | 1x |
est_dash <- p1_dash - p2_dash |
165 | 1x |
ci_lwr <- max(-1, est_dash - term2) |
166 | 1x |
ci_upr <- min(1, est_dash + term2) |
167 |
}, |
|
168 | 26x |
ha = { |
169 | 5x |
term2 <- 1 / |
170 | 5x |
(2 * min(n1, n2)) + kappa * sqrt(p1_hat * (1 - p1_hat) / (n1 - 1) + p2_hat * (1 - p2_hat) / (n2 - 1)) |
171 | 5x |
ci_lwr <- max(-1, est - term2) |
172 | 5x |
ci_upr <- min(1, est + term2) |
173 |
}, |
|
174 | 26x |
mn = { |
175 | 1x |
.conf <- function(x1, n1, x2, n2, z, lower = FALSE) { |
176 | 2x |
p1 <- x1 / n1 |
177 | 2x |
p2 <- x2 / n2 |
178 | 2x |
p_hat <- p1 - p2 |
179 | 2x |
dp <- 1 + ifelse(lower, 1, -1) * p_hat |
180 | 2x |
i <- 1 |
181 | 2x |
while (i <= 50) { |
182 | 46x |
dp <- 0.5 * dp |
183 | 46x |
y <- p_hat + ifelse(lower, -1, 1) * dp |
184 | 46x |
score <- .score(p1, n1, p2, n2, y) |
185 | 46x |
if (score < z) { |
186 | 20x |
p_hat <- y |
187 |
} |
|
188 | 46x |
if ((dp < 1e-07) || (abs(z - score) < 1e-06)) { |
189 | 2x |
(break)() |
190 |
} else { |
|
191 | 44x |
i <- i + 1 |
192 |
} |
|
193 |
} |
|
194 | 2x |
return(y) |
195 |
} |
|
196 | 1x |
.score <- function(p1, n1, p2, n2, dif) { |
197 | 46x |
diff <- p1 - p2 - dif |
198 | 46x |
if (abs(diff) == 0) { |
199 | ! |
res <- 0 |
200 |
} else { |
|
201 | 46x |
t <- n2 / n1 |
202 | 46x |
a <- 1 + t |
203 | 46x |
b <- -(1 + t + p1 + t * p2 + dif * (t + 2)) |
204 | 46x |
c <- dif * dif + dif * (2 * p1 + t + 1) + p1 + t * p2 |
205 | 46x |
d <- -p1 * dif * (1 + dif) |
206 | 46x |
v <- (b / a / 3)^3 - b * c / (6 * a * a) + d / a / 2 |
207 | 46x |
s <- sqrt((b / a / 3)^2 - c / a / 3) |
208 | 46x |
u <- ifelse(v > 0, 1, -1) * s |
209 | 46x |
w <- (3.141592654 + acos(v / u^3)) / 3 |
210 | 46x |
p1d <- 2 * u * cos(w) - b / a / 3 |
211 | 46x |
p2d <- p1d - dif |
212 | 46x |
n <- n1 + n2 |
213 | 46x |
var <- (p1d * (1 - p1d) / n1 + p2d * (1 - p2d) / n2) * n / (n - 1) |
214 | 46x |
res <- diff^2 / var |
215 |
} |
|
216 | 46x |
return(res) |
217 |
} |
|
218 | 1x |
z <- stats::qchisq(conf.level, 1) |
219 | 1x |
ci_lwr <- max(-1, .conf(x1, n1, x2, n2, z, TRUE)) |
220 | 1x |
ci_upr <- min(1, .conf(x1, n1, x2, n2, z, FALSE)) |
221 |
}, |
|
222 | 26x |
beal = { |
223 | ! |
a <- p1_hat + p2_hat |
224 | ! |
b <- p1_hat - p2_hat |
225 | ! |
u <- ((1 / n1) + (1 / n2)) / 4 |
226 | ! |
v <- ((1 / n1) - (1 / n2)) / 4 |
227 | ! |
V <- u * ((2 - a) * a - b^2) + 2 * v * (1 - a) * b # nolint |
228 | ! |
z <- stats::qchisq(p = 1 - alpha / 2, df = 1) |
229 | ! |
A <- sqrt(z * (V + z * u^2 * (2 - a) * a + z * v^2 * (1 - a)^2)) # nolint |
230 | ! |
B <- (b + z * v * (1 - a)) / (1 + z * u) # nolint |
231 | ! |
ci_lwr <- max(-1, B - A / (1 + z * u)) |
232 | ! |
ci_upr <- min(1, B + A / (1 + z * u)) |
233 |
}, |
|
234 | 26x |
hal = { |
235 | 1x |
psi <- (p1_hat + p2_hat) / 2 |
236 | 1x |
u <- (1 / n1 + 1 / n2) / 4 |
237 | 1x |
v <- (1 / n1 - 1 / n2) / 4 |
238 | 1x |
z <- kappa |
239 | 1x |
theta <- ((p1_hat - p2_hat) + z^2 * v * (1 - 2 * psi)) / (1 + z^2 * u) |
240 | 1x |
w <- z / (1 + z^2 * u) * sqrt(u * (4 * psi * (1 - psi) - (p1_hat - p2_hat)^2) + 2 * v * (1 - 2 * psi) * |
241 | 1x |
(p1_hat - p2_hat) + 4 * z^2 * u^2 * (1 - psi) * psi + z^2 * v^2 * (1 - 2 * psi)^2) # nolint |
242 | 1x |
c(theta + w, theta - w) |
243 | 1x |
ci_lwr <- max(-1, theta - w) |
244 | 1x |
ci_upr <- min(1, theta + w) |
245 |
}, |
|
246 | 26x |
jp = { |
247 | 1x |
psi <- 0.5 * ((x1 + 0.5) / (n1 + 1) + (x2 + 0.5) / (n2 + 1)) |
248 | 1x |
u <- (1 / n1 + 1 / n2) / 4 |
249 | 1x |
v <- (1 / n1 - 1 / n2) / 4 |
250 | 1x |
z <- kappa |
251 | 1x |
theta <- ((p1_hat - p2_hat) + z^2 * v * (1 - 2 * psi)) / (1 + z^2 * u) |
252 | 1x |
w <- z / (1 + z^2 * u) * sqrt(u * (4 * psi * (1 - psi) - (p1_hat - p2_hat)^2) + 2 * v * (1 - 2 * psi) * |
253 | 1x |
(p1_hat - p2_hat) + 4 * z^2 * u^2 * (1 - psi) * psi + z^2 * v^2 * (1 - 2 * psi)^2) # nolint |
254 | 1x |
c(theta + w, theta - w) |
255 | 1x |
ci_lwr <- max(-1, theta - w) |
256 | 1x |
ci_upr <- min(1, theta + w) |
257 |
}, |
|
258 |
) |
|
259 | 26x |
ci <- c( |
260 | 26x |
est = est, lwr.ci = min(ci_lwr, ci_upr), |
261 | 26x |
upr.ci = max(ci_lwr, ci_upr) |
262 |
) |
|
263 | 26x |
if (sides == "left") { |
264 | ! |
ci[3] <- 1 |
265 | 26x |
} else if (sides == "right") { |
266 | ! |
ci[2] <- -1 |
267 |
} |
|
268 | 26x |
return(ci) |
269 |
} |
|
270 | 26x |
method <- match.arg(arg = method, several.ok = TRUE) |
271 | 26x |
sides <- match.arg(arg = sides, several.ok = TRUE) |
272 | 26x |
lst <- h_recycle( |
273 | 26x |
x1 = x1, n1 = n1, x2 = x2, n2 = n2, conf.level = conf.level, |
274 | 26x |
sides = sides, method = method |
275 |
) |
|
276 | 26x |
res <- t(sapply(1:attr(lst, "maxdim"), function(i) { |
277 | 26x |
iBinomDiffCI( |
278 | 26x |
x1 = lst$x1[i], |
279 | 26x |
n1 = lst$n1[i], x2 = lst$x2[i], n2 = lst$n2[i], conf.level = lst$conf.level[i], |
280 | 26x |
sides = lst$sides[i], method = lst$method[i] |
281 |
) |
|
282 |
})) |
|
283 | 26x |
lgn <- h_recycle(x1 = if (is.null(names(x1))) { |
284 | 26x |
paste("x1", seq_along(x1), sep = ".") |
285 |
} else { |
|
286 | ! |
names(x1) |
287 | 26x |
}, n1 = if (is.null(names(n1))) { |
288 | 26x |
paste("n1", seq_along(n1), sep = ".") |
289 |
} else { |
|
290 | ! |
names(n1) |
291 | 26x |
}, x2 = if (is.null(names(x2))) { |
292 | 26x |
paste("x2", seq_along(x2), sep = ".") |
293 |
} else { |
|
294 | ! |
names(x2) |
295 | 26x |
}, n2 = if (is.null(names(n2))) { |
296 | 26x |
paste("n2", seq_along(n2), sep = ".") |
297 |
} else { |
|
298 | ! |
names(n2) |
299 | 26x |
}, conf.level = conf.level, sides = sides, method = method) |
300 | 26x |
xn <- apply(as.data.frame(lgn[sapply(lgn, function(x) { |
301 | 182x |
length(unique(x)) != |
302 | 182x |
1 |
303 | 26x |
})]), 1, paste, collapse = ":") |
304 | 26x |
rownames(res) <- xn |
305 | 26x |
return(res) |
306 |
} |
|
307 | ||
308 |
#' @describeIn desctools_binom Compute confidence intervals for binomial proportions. |
|
309 |
#' |
|
310 |
#' @param x (`integer(1)`)\cr number of successes. |
|
311 |
#' @param n (`integer(1)`)\cr number of trials. |
|
312 |
#' @param conf.level (`proportion`)\cr confidence level, defaults to 0.95. |
|
313 |
#' @param sides (`string`)\cr side of the confidence interval to compute. Must be one of `"two-sided"` (default), |
|
314 |
#' `"left"`, or `"right"`. |
|
315 |
#' @param method (`string`)\cr method to use. Can be one out of: `"wald"`, `"wilson"`, `"wilsoncc"`, |
|
316 |
#' `"agresti-coull"`, `"jeffreys"`, `"modified wilson"`, `"modified jeffreys"`, `"clopper-pearson"`, `"arcsine"`, |
|
317 |
#' `"logit"`, `"witting"`, `"pratt"`, `"midp"`, `"lik"`, and `"blaker"`. |
|
318 |
#' |
|
319 |
#' @return A `matrix` with 3 columns containing: |
|
320 |
#' * `est`: estimate of proportion difference. |
|
321 |
#' * `lwr.ci`: lower end of the confidence interval. |
|
322 |
#' * `upr.ci`: upper end of the confidence interval. |
|
323 |
#' |
|
324 |
#' @keywords internal |
|
325 |
desctools_binomci <- function(x, |
|
326 |
n, |
|
327 |
conf.level = 0.95, # nolint |
|
328 |
sides = c("two.sided", "left", "right"), |
|
329 |
method = c( |
|
330 |
"wilson", "wald", "waldcc", "agresti-coull", |
|
331 |
"jeffreys", "modified wilson", "wilsoncc", "modified jeffreys", |
|
332 |
"clopper-pearson", "arcsine", "logit", "witting", "pratt", |
|
333 |
"midp", "lik", "blaker" |
|
334 |
), |
|
335 |
rand = 123, |
|
336 |
tol = 1e-05) { |
|
337 | 26x |
if (missing(method)) { |
338 | 1x |
method <- "wilson" |
339 |
} |
|
340 | 26x |
if (missing(sides)) { |
341 | 25x |
sides <- "two.sided" |
342 |
} |
|
343 | 26x |
iBinomCI <- function(x, n, conf.level = 0.95, sides = c("two.sided", "left", "right"), # nolint |
344 | 26x |
method = c( |
345 | 26x |
"wilson", "wilsoncc", "wald", |
346 | 26x |
"waldcc", "agresti-coull", "jeffreys", "modified wilson", |
347 | 26x |
"modified jeffreys", "clopper-pearson", "arcsine", "logit", |
348 | 26x |
"witting", "pratt", "midp", "lik", "blaker" |
349 |
), |
|
350 | 26x |
rand = 123, |
351 | 26x |
tol = 1e-05) { |
352 | 26x |
if (length(x) != 1) { |
353 | ! |
stop("'x' has to be of length 1 (number of successes)") |
354 |
} |
|
355 | 26x |
if (length(n) != 1) { |
356 | ! |
stop("'n' has to be of length 1 (number of trials)") |
357 |
} |
|
358 | 26x |
if (length(conf.level) != 1) { |
359 | ! |
stop("'conf.level' has to be of length 1 (confidence level)") |
360 |
} |
|
361 | 26x |
if (conf.level < 0.5 || conf.level > 1) { |
362 | ! |
stop("'conf.level' has to be in [0.5, 1]") |
363 |
} |
|
364 | 26x |
sides <- match.arg(sides, choices = c( |
365 | 26x |
"two.sided", "left", |
366 | 26x |
"right" |
367 | 26x |
), several.ok = FALSE) |
368 | 26x |
if (sides != "two.sided") { |
369 | 1x |
conf.level <- 1 - 2 * (1 - conf.level) # nolint |
370 |
} |
|
371 | 26x |
alpha <- 1 - conf.level |
372 | 26x |
kappa <- stats::qnorm(1 - alpha / 2) |
373 | 26x |
p_hat <- x / n |
374 | 26x |
q_hat <- 1 - p_hat |
375 | 26x |
est <- p_hat |
376 | 26x |
switch(match.arg(arg = method, choices = c( |
377 | 26x |
"wilson", |
378 | 26x |
"wald", "waldcc", "wilsoncc", "agresti-coull", "jeffreys", |
379 | 26x |
"modified wilson", "modified jeffreys", "clopper-pearson", |
380 | 26x |
"arcsine", "logit", "witting", "pratt", "midp", "lik", |
381 | 26x |
"blaker" |
382 |
)), |
|
383 | 26x |
wald = { |
384 | 1x |
term2 <- kappa * sqrt(p_hat * q_hat) / sqrt(n) |
385 | 1x |
ci_lwr <- max(0, p_hat - term2) |
386 | 1x |
ci_upr <- min(1, p_hat + term2) |
387 |
}, |
|
388 | 26x |
waldcc = { |
389 | 1x |
term2 <- kappa * sqrt(p_hat * q_hat) / sqrt(n) |
390 | 1x |
term2 <- term2 + 1 / (2 * n) |
391 | 1x |
ci_lwr <- max(0, p_hat - term2) |
392 | 1x |
ci_upr <- min(1, p_hat + term2) |
393 |
}, |
|
394 | 26x |
wilson = { |
395 | 8x |
term1 <- (x + kappa^2 / 2) / (n + kappa^2) |
396 | 8x |
term2 <- kappa * sqrt(n) / (n + kappa^2) * sqrt(p_hat * q_hat + kappa^2 / (4 * n)) |
397 | 8x |
ci_lwr <- max(0, term1 - term2) |
398 | 8x |
ci_upr <- min(1, term1 + term2) |
399 |
}, |
|
400 | 26x |
wilsoncc = { |
401 | 3x |
lci <- ( |
402 | 3x |
2 * x + kappa^2 - 1 - kappa * sqrt(kappa^2 - 2 - 1 / n + 4 * p_hat * (n * q_hat + 1)) |
403 | 3x |
) / (2 * (n + kappa^2)) |
404 | 3x |
uci <- ( |
405 | 3x |
2 * x + kappa^2 + 1 + kappa * sqrt(kappa^2 + 2 - 1 / n + 4 * p_hat * (n * q_hat - 1)) |
406 | 3x |
) / (2 * (n + kappa^2)) |
407 | 3x |
ci_lwr <- max(0, ifelse(p_hat == 0, 0, lci)) |
408 | 3x |
ci_upr <- min(1, ifelse(p_hat == 1, 1, uci)) |
409 |
}, |
|
410 | 26x |
`agresti-coull` = { |
411 | 1x |
x_tilde <- x + kappa^2 / 2 |
412 | 1x |
n_tilde <- n + kappa^2 |
413 | 1x |
p_tilde <- x_tilde / n_tilde |
414 | 1x |
q_tilde <- 1 - p_tilde |
415 | 1x |
est <- p_tilde |
416 | 1x |
term2 <- kappa * sqrt(p_tilde * q_tilde) / sqrt(n_tilde) |
417 | 1x |
ci_lwr <- max(0, p_tilde - term2) |
418 | 1x |
ci_upr <- min(1, p_tilde + term2) |
419 |
}, |
|
420 | 26x |
jeffreys = { |
421 | 1x |
if (x == 0) { |
422 | ! |
ci_lwr <- 0 |
423 |
} else { |
|
424 | 1x |
ci_lwr <- stats::qbeta( |
425 | 1x |
alpha / 2, |
426 | 1x |
x + 0.5, n - x + 0.5 |
427 |
) |
|
428 |
} |
|
429 | 1x |
if (x == n) { |
430 | ! |
ci_upr <- 1 |
431 |
} else { |
|
432 | 1x |
ci_upr <- stats::qbeta(1 - alpha / 2, x + 0.5, n - x + 0.5) |
433 |
} |
|
434 |
}, |
|
435 | 26x |
`modified wilson` = { |
436 | 1x |
term1 <- (x + kappa^2 / 2) / (n + kappa^2) |
437 | 1x |
term2 <- kappa * sqrt(n) / (n + kappa^2) * sqrt(p_hat * q_hat + kappa^2 / (4 * n)) |
438 | 1x |
if ((n <= 50 & x %in% c(1, 2)) | (n >= 51 & x %in% c(1:3))) { |
439 | ! |
ci_lwr <- 0.5 * stats::qchisq(alpha, 2 * x) / n |
440 |
} else { |
|
441 | 1x |
ci_lwr <- max(0, term1 - term2) |
442 |
} |
|
443 | 1x |
if ((n <= 50 & x %in% c(n - 1, n - 2)) | (n >= 51 & x %in% c(n - (1:3)))) { |
444 | ! |
ci_upr <- 1 - 0.5 * stats::qchisq( |
445 | ! |
alpha, |
446 | ! |
2 * (n - x) |
447 | ! |
) / n |
448 |
} else { |
|
449 | 1x |
ci_upr <- min(1, term1 + term2) |
450 |
} |
|
451 |
}, |
|
452 | 26x |
`modified jeffreys` = { |
453 | 1x |
if (x == n) { |
454 | ! |
ci_lwr <- (alpha / 2)^(1 / n) |
455 |
} else { |
|
456 | 1x |
if (x <= 1) { |
457 | ! |
ci_lwr <- 0 |
458 |
} else { |
|
459 | 1x |
ci_lwr <- stats::qbeta( |
460 | 1x |
alpha / 2, |
461 | 1x |
x + 0.5, n - x + 0.5 |
462 |
) |
|
463 |
} |
|
464 |
} |
|
465 | 1x |
if (x == 0) { |
466 | ! |
ci_upr <- 1 - (alpha / 2)^(1 / n) |
467 |
} else { |
|
468 | 1x |
if (x >= n - 1) { |
469 | ! |
ci_upr <- 1 |
470 |
} else { |
|
471 | 1x |
ci_upr <- stats::qbeta(1 - alpha / 2, x + 0.5, n - x + 0.5) |
472 |
} |
|
473 |
} |
|
474 |
}, |
|
475 | 26x |
`clopper-pearson` = { |
476 | 1x |
ci_lwr <- stats::qbeta(alpha / 2, x, n - x + 1) |
477 | 1x |
ci_upr <- stats::qbeta(1 - alpha / 2, x + 1, n - x) |
478 |
}, |
|
479 | 26x |
arcsine = { |
480 | 1x |
p_tilde <- (x + 0.375) / (n + 0.75) |
481 | 1x |
est <- p_tilde |
482 | 1x |
ci_lwr <- sin(asin(sqrt(p_tilde)) - 0.5 * kappa / sqrt(n))^2 |
483 | 1x |
ci_upr <- sin(asin(sqrt(p_tilde)) + 0.5 * kappa / sqrt(n))^2 |
484 |
}, |
|
485 | 26x |
logit = { |
486 | 1x |
lambda_hat <- log(x / (n - x)) |
487 | 1x |
V_hat <- n / (x * (n - x)) # nolint |
488 | 1x |
lambda_lower <- lambda_hat - kappa * sqrt(V_hat) |
489 | 1x |
lambda_upper <- lambda_hat + kappa * sqrt(V_hat) |
490 | 1x |
ci_lwr <- exp(lambda_lower) / (1 + exp(lambda_lower)) |
491 | 1x |
ci_upr <- exp(lambda_upper) / (1 + exp(lambda_upper)) |
492 |
}, |
|
493 | 26x |
witting = { |
494 | 1x |
set.seed(rand) |
495 | 1x |
x_tilde <- x + stats::runif(1, min = 0, max = 1) |
496 | 1x |
pbinom_abscont <- function(q, size, prob) { |
497 | 22x |
v <- trunc(q) |
498 | 22x |
term1 <- stats::pbinom(v - 1, size = size, prob = prob) |
499 | 22x |
term2 <- (q - v) * stats::dbinom(v, size = size, prob = prob) |
500 | 22x |
return(term1 + term2) |
501 |
} |
|
502 | 1x |
qbinom_abscont <- function(p, size, x) { |
503 | 2x |
fun <- function(prob, size, x, p) { |
504 | 22x |
pbinom_abscont(x, size, prob) - p |
505 |
} |
|
506 | 2x |
stats::uniroot(fun, |
507 | 2x |
interval = c(0, 1), size = size, |
508 | 2x |
x = x, p = p |
509 | 2x |
)$root |
510 |
} |
|
511 | 1x |
ci_lwr <- qbinom_abscont(1 - alpha, size = n, x = x_tilde) |
512 | 1x |
ci_upr <- qbinom_abscont(alpha, size = n, x = x_tilde) |
513 |
}, |
|
514 | 26x |
pratt = { |
515 | 1x |
if (x == 0) { |
516 | ! |
ci_lwr <- 0 |
517 | ! |
ci_upr <- 1 - alpha^(1 / n) |
518 | 1x |
} else if (x == 1) { |
519 | ! |
ci_lwr <- 1 - (1 - alpha / 2)^(1 / n) |
520 | ! |
ci_upr <- 1 - (alpha / 2)^(1 / n) |
521 | 1x |
} else if (x == (n - 1)) { |
522 | ! |
ci_lwr <- (alpha / 2)^(1 / n) |
523 | ! |
ci_upr <- (1 - alpha / 2)^(1 / n) |
524 | 1x |
} else if (x == n) { |
525 | ! |
ci_lwr <- alpha^(1 / n) |
526 | ! |
ci_upr <- 1 |
527 |
} else { |
|
528 | 1x |
z <- stats::qnorm(1 - alpha / 2) |
529 | 1x |
A <- ((x + 1) / (n - x))^2 # nolint |
530 | 1x |
B <- 81 * (x + 1) * (n - x) - 9 * n - 8 # nolint |
531 | 1x |
C <- (0 - 3) * z * sqrt(9 * (x + 1) * (n - x) * (9 * n + 5 - z^2) + n + 1) # nolint |
532 | 1x |
D <- 81 * (x + 1)^2 - 9 * (x + 1) * (2 + z^2) + 1 # nolint |
533 | 1x |
E <- 1 + A * ((B + C) / D)^3 # nolint |
534 | 1x |
ci_upr <- 1 / E |
535 | 1x |
A <- (x / (n - x - 1))^2 # nolint |
536 | 1x |
B <- 81 * x * (n - x - 1) - 9 * n - 8 # nolint |
537 | 1x |
C <- 3 * z * sqrt(9 * x * (n - x - 1) * (9 * n + 5 - z^2) + n + 1) # nolint |
538 | 1x |
D <- 81 * x^2 - 9 * x * (2 + z^2) + 1 # nolint |
539 | 1x |
E <- 1 + A * ((B + C) / D)^3 # nolint |
540 | 1x |
ci_lwr <- 1 / E |
541 |
} |
|
542 |
}, |
|
543 | 26x |
midp = { |
544 | 1x |
f_low <- function(pi, x, n) { |
545 | 12x |
1 / 2 * stats::dbinom(x, size = n, prob = pi) + stats::pbinom(x, |
546 | 12x |
size = n, prob = pi, lower.tail = FALSE |
547 |
) - |
|
548 | 12x |
(1 - conf.level) / 2 |
549 |
} |
|
550 | 1x |
f_up <- function(pi, x, n) { |
551 | 12x |
1 / 2 * stats::dbinom(x, size = n, prob = pi) + stats::pbinom(x - 1, size = n, prob = pi) - (1 - conf.level) / 2 |
552 |
} |
|
553 | 1x |
ci_lwr <- 0 |
554 | 1x |
ci_upr <- 1 |
555 | 1x |
if (x != 0) { |
556 | 1x |
ci_lwr <- stats::uniroot(f_low, |
557 | 1x |
interval = c(0, p_hat), |
558 | 1x |
x = x, n = n |
559 | 1x |
)$root |
560 |
} |
|
561 | 1x |
if (x != n) { |
562 | 1x |
ci_upr <- stats::uniroot(f_up, interval = c( |
563 | 1x |
p_hat, |
564 | 1x |
1 |
565 | 1x |
), x = x, n = n)$root |
566 |
} |
|
567 |
}, |
|
568 | 26x |
lik = { |
569 | 2x |
ci_lwr <- 0 |
570 | 2x |
ci_upr <- 1 |
571 | 2x |
z <- stats::qnorm(1 - alpha * 0.5) |
572 | 2x |
tol <- .Machine$double.eps^0.5 |
573 | 2x |
BinDev <- function(y, x, mu, wt, bound = 0, tol = .Machine$double.eps^0.5, # nolint |
574 |
...) { |
|
575 | 40x |
ll_y <- ifelse(y %in% c(0, 1), 0, stats::dbinom(x, wt, |
576 | 40x |
y, |
577 | 40x |
log = TRUE |
578 |
)) |
|
579 | 40x |
ll_mu <- ifelse(mu %in% c(0, 1), 0, stats::dbinom(x, |
580 | 40x |
wt, mu, |
581 | 40x |
log = TRUE |
582 |
)) |
|
583 | 40x |
res <- ifelse(abs(y - mu) < tol, 0, sign(y - mu) * sqrt(-2 * (ll_y - ll_mu))) |
584 | 40x |
return(res - bound) |
585 |
} |
|
586 | 2x |
if (x != 0 && tol < p_hat) { |
587 | 2x |
ci_lwr <- if (BinDev( |
588 | 2x |
tol, x, p_hat, n, -z, |
589 | 2x |
tol |
590 | 2x |
) <= 0) { |
591 | 2x |
stats::uniroot( |
592 | 2x |
f = BinDev, interval = c(tol, if (p_hat < tol || p_hat == 1) { |
593 | ! |
1 - tol |
594 |
} else { |
|
595 | 2x |
p_hat |
596 | 2x |
}), bound = -z, |
597 | 2x |
x = x, mu = p_hat, wt = n |
598 | 2x |
)$root |
599 |
} |
|
600 |
} |
|
601 | 2x |
if (x != n && p_hat < (1 - tol)) { |
602 | 2x |
ci_upr <- if ( |
603 | 2x |
BinDev(y = 1 - tol, x = x, mu = ifelse(p_hat > 1 - tol, tol, p_hat), wt = n, bound = z, tol = tol) < 0) { # nolint |
604 | ! |
ci_lwr <- if (BinDev( |
605 | ! |
tol, x, if (p_hat < tol || p_hat == 1) { |
606 | ! |
1 - tol |
607 |
} else { |
|
608 | ! |
p_hat |
609 | ! |
}, n, |
610 | ! |
-z, tol |
611 | ! |
) <= 0) { |
612 | ! |
stats::uniroot( |
613 | ! |
f = BinDev, interval = c(tol, p_hat), |
614 | ! |
bound = -z, x = x, mu = p_hat, wt = n |
615 | ! |
)$root |
616 |
} |
|
617 |
} else { |
|
618 | 2x |
stats::uniroot( |
619 | 2x |
f = BinDev, interval = c(if (p_hat > 1 - tol) { |
620 | ! |
tol |
621 |
} else { |
|
622 | 2x |
p_hat |
623 | 2x |
}, 1 - tol), bound = z, |
624 | 2x |
x = x, mu = p_hat, wt = n |
625 | 2x |
)$root |
626 |
} |
|
627 |
} |
|
628 |
}, |
|
629 | 26x |
blaker = { |
630 | 1x |
acceptbin <- function(x, n, p) { |
631 | 3954x |
p1 <- 1 - stats::pbinom(x - 1, n, p) |
632 | 3954x |
p2 <- stats::pbinom(x, n, p) |
633 | 3954x |
a1 <- p1 + stats::pbinom(stats::qbinom(p1, n, p) - 1, n, p) |
634 | 3954x |
a2 <- p2 + 1 - stats::pbinom( |
635 | 3954x |
stats::qbinom(1 - p2, n, p), n, |
636 | 3954x |
p |
637 |
) |
|
638 | 3954x |
return(min(a1, a2)) |
639 |
} |
|
640 | 1x |
ci_lwr <- 0 |
641 | 1x |
ci_upr <- 1 |
642 | 1x |
if (x != 0) { |
643 | 1x |
ci_lwr <- stats::qbeta((1 - conf.level) / 2, x, n - x + 1) |
644 | 1x |
while (acceptbin(x, n, ci_lwr + tol) < (1 - conf.level)) { |
645 | 1976x |
ci_lwr <- ci_lwr + tol |
646 |
} |
|
647 |
} |
|
648 | 1x |
if (x != n) { |
649 | 1x |
ci_upr <- stats::qbeta(1 - (1 - conf.level) / 2, x + 1, n - x) |
650 | 1x |
while (acceptbin(x, n, ci_upr - tol) < (1 - conf.level)) { |
651 | 1976x |
ci_upr <- ci_upr - tol |
652 |
} |
|
653 |
} |
|
654 |
} |
|
655 |
) |
|
656 | 26x |
ci <- c(est = est, lwr.ci = max(0, ci_lwr), upr.ci = min( |
657 | 26x |
1, |
658 | 26x |
ci_upr |
659 |
)) |
|
660 | 26x |
if (sides == "left") { |
661 | 1x |
ci[3] <- 1 |
662 | 25x |
} else if (sides == "right") { |
663 | ! |
ci[2] <- 0 |
664 |
} |
|
665 | 26x |
return(ci) |
666 |
} |
|
667 | 26x |
lst <- list( |
668 | 26x |
x = x, n = n, conf.level = conf.level, sides = sides, |
669 | 26x |
method = method, rand = rand |
670 |
) |
|
671 | 26x |
maxdim <- max(unlist(lapply(lst, length))) |
672 | 26x |
lgp <- lapply(lst, rep, length.out = maxdim) |
673 | 26x |
lgn <- h_recycle(x = if (is.null(names(x))) { |
674 | 26x |
paste("x", seq_along(x), sep = ".") |
675 |
} else { |
|
676 | ! |
names(x) |
677 | 26x |
}, n = if (is.null(names(n))) { |
678 | 26x |
paste("n", seq_along(n), sep = ".") |
679 |
} else { |
|
680 | ! |
names(n) |
681 | 26x |
}, conf.level = conf.level, sides = sides, method = method) |
682 | 26x |
xn <- apply(as.data.frame(lgn[sapply(lgn, function(x) { |
683 | 130x |
length(unique(x)) != |
684 | 130x |
1 |
685 | 26x |
})]), 1, paste, collapse = ":") |
686 | 26x |
res <- t(sapply(1:maxdim, function(i) { |
687 | 26x |
iBinomCI( |
688 | 26x |
x = lgp$x[i], |
689 | 26x |
n = lgp$n[i], conf.level = lgp$conf.level[i], sides = lgp$sides[i], |
690 | 26x |
method = lgp$method[i], rand = lgp$rand[i] |
691 |
) |
|
692 |
})) |
|
693 | 26x |
colnames(res)[1] <- c("est") |
694 | 26x |
rownames(res) <- xn |
695 | 26x |
return(res) |
696 |
} |
1 |
#' Control function for Cox regression |
|
2 |
#' |
|
3 |
#' @description `r lifecycle::badge("stable")` |
|
4 |
#' |
|
5 |
#' Sets a list of parameters for Cox regression fit. Used internally. |
|
6 |
#' |
|
7 |
#' @inheritParams argument_convention |
|
8 |
#' @param pval_method (`string`)\cr the method used for estimation of p.values; `wald` (default) or `likelihood`. |
|
9 |
#' @param interaction (`flag`)\cr if `TRUE`, the model includes the interaction between the studied |
|
10 |
#' treatment and candidate covariate. Note that for univariate models without treatment arm, and |
|
11 |
#' multivariate models, no interaction can be used so that this needs to be `FALSE`. |
|
12 |
#' @param ties (`string`)\cr among `exact` (equivalent to `DISCRETE` in SAS), `efron` and `breslow`, |
|
13 |
#' see [survival::coxph()]. Note: there is no equivalent of SAS `EXACT` method in R. |
|
14 |
#' |
|
15 |
#' @return A `list` of items with names corresponding to the arguments. |
|
16 |
#' |
|
17 |
#' @seealso [fit_coxreg_univar()] and [fit_coxreg_multivar()]. |
|
18 |
#' |
|
19 |
#' @examples |
|
20 |
#' control_coxreg() |
|
21 |
#' |
|
22 |
#' @export |
|
23 |
control_coxreg <- function(pval_method = c("wald", "likelihood"), |
|
24 |
ties = c("exact", "efron", "breslow"), |
|
25 |
conf_level = 0.95, |
|
26 |
interaction = FALSE) { |
|
27 | 55x |
pval_method <- match.arg(pval_method) |
28 | 55x |
ties <- match.arg(ties) |
29 | 55x |
checkmate::assert_flag(interaction) |
30 | 55x |
assert_proportion_value(conf_level) |
31 | 55x |
list( |
32 | 55x |
pval_method = pval_method, |
33 | 55x |
ties = ties, |
34 | 55x |
conf_level = conf_level, |
35 | 55x |
interaction = interaction |
36 |
) |
|
37 |
} |
|
38 | ||
39 |
#' Custom tidy methods for Cox regression |
|
40 |
#' |
|
41 |
#' @description `r lifecycle::badge("stable")` |
|
42 |
#' |
|
43 |
#' @inheritParams argument_convention |
|
44 |
#' @param x (`list`)\cr result of the Cox regression model fitted by [fit_coxreg_univar()] (for univariate models) |
|
45 |
#' or [fit_coxreg_multivar()] (for multivariate models). |
|
46 |
#' |
|
47 |
#' @return [broom::tidy()] returns: |
|
48 |
#' * For `summary.coxph` objects, a `data.frame` with columns: `Pr(>|z|)`, `exp(coef)`, `exp(-coef)`, `lower .95`, |
|
49 |
#' `upper .95`, `level`, and `n`. |
|
50 |
#' * For `coxreg.univar` objects, a `data.frame` with columns: `effect`, `term`, `term_label`, `level`, `n`, `hr`, |
|
51 |
#' `lcl`, `ucl`, `pval`, and `ci`. |
|
52 |
#' * For `coxreg.multivar` objects, a `data.frame` with columns: `term`, `pval`, `term_label`, `hr`, `lcl`, `ucl`, |
|
53 |
#' `level`, and `ci`. |
|
54 |
#' |
|
55 |
#' @seealso [cox_regression] |
|
56 |
#' |
|
57 |
#' @name tidy_coxreg |
|
58 |
NULL |
|
59 | ||
60 |
#' @describeIn tidy_coxreg Custom tidy method for [survival::coxph()] summary results. |
|
61 |
#' |
|
62 |
#' Tidy the [survival::coxph()] results into a `data.frame` to extract model results. |
|
63 |
#' |
|
64 |
#' @method tidy summary.coxph |
|
65 |
#' |
|
66 |
#' @examples |
|
67 |
#' library(survival) |
|
68 |
#' library(broom) |
|
69 |
#' |
|
70 |
#' set.seed(1, kind = "Mersenne-Twister") |
|
71 |
#' |
|
72 |
#' dta_bladder <- with( |
|
73 |
#' data = bladder[bladder$enum < 5, ], |
|
74 |
#' data.frame( |
|
75 |
#' time = stop, |
|
76 |
#' status = event, |
|
77 |
#' armcd = as.factor(rx), |
|
78 |
#' covar1 = as.factor(enum), |
|
79 |
#' covar2 = factor( |
|
80 |
#' sample(as.factor(enum)), |
|
81 |
#' levels = 1:4, labels = c("F", "F", "M", "M") |
|
82 |
#' ) |
|
83 |
#' ) |
|
84 |
#' ) |
|
85 |
#' labels <- c("armcd" = "ARM", "covar1" = "A Covariate Label", "covar2" = "Sex (F/M)") |
|
86 |
#' formatters::var_labels(dta_bladder)[names(labels)] <- labels |
|
87 |
#' dta_bladder$age <- sample(20:60, size = nrow(dta_bladder), replace = TRUE) |
|
88 |
#' |
|
89 |
#' formula <- "survival::Surv(time, status) ~ armcd + covar1" |
|
90 |
#' msum <- summary(coxph(stats::as.formula(formula), data = dta_bladder)) |
|
91 |
#' tidy(msum) |
|
92 |
#' |
|
93 |
#' @export |
|
94 |
tidy.summary.coxph <- function(x, # nolint |
|
95 |
...) { |
|
96 | 199x |
checkmate::assert_class(x, "summary.coxph") |
97 | 199x |
pval <- x$coefficients |
98 | 199x |
confint <- x$conf.int |
99 | 199x |
levels <- rownames(pval) |
100 | ||
101 | 199x |
pval <- tibble::as_tibble(pval) |
102 | 199x |
confint <- tibble::as_tibble(confint) |
103 | ||
104 | 199x |
ret <- cbind(pval[, grepl("Pr", names(pval))], confint) |
105 | 199x |
ret$level <- levels |
106 | 199x |
ret$n <- x[["n"]] |
107 | 199x |
ret |
108 |
} |
|
109 | ||
110 |
#' @describeIn tidy_coxreg Custom tidy method for a univariate Cox regression. |
|
111 |
#' |
|
112 |
#' Tidy up the result of a Cox regression model fitted by [fit_coxreg_univar()]. |
|
113 |
#' |
|
114 |
#' @method tidy coxreg.univar |
|
115 |
#' |
|
116 |
#' @examples |
|
117 |
#' ## Cox regression: arm + 1 covariate. |
|
118 |
#' mod1 <- fit_coxreg_univar( |
|
119 |
#' variables = list( |
|
120 |
#' time = "time", event = "status", arm = "armcd", |
|
121 |
#' covariates = "covar1" |
|
122 |
#' ), |
|
123 |
#' data = dta_bladder, |
|
124 |
#' control = control_coxreg(conf_level = 0.91) |
|
125 |
#' ) |
|
126 |
#' |
|
127 |
#' ## Cox regression: arm + 1 covariate + interaction, 2 candidate covariates. |
|
128 |
#' mod2 <- fit_coxreg_univar( |
|
129 |
#' variables = list( |
|
130 |
#' time = "time", event = "status", arm = "armcd", |
|
131 |
#' covariates = c("covar1", "covar2") |
|
132 |
#' ), |
|
133 |
#' data = dta_bladder, |
|
134 |
#' control = control_coxreg(conf_level = 0.91, interaction = TRUE) |
|
135 |
#' ) |
|
136 |
#' |
|
137 |
#' tidy(mod1) |
|
138 |
#' tidy(mod2) |
|
139 |
#' |
|
140 |
#' @export |
|
141 |
tidy.coxreg.univar <- function(x, # nolint |
|
142 |
...) { |
|
143 | 38x |
checkmate::assert_class(x, "coxreg.univar") |
144 | 38x |
mod <- x$mod |
145 | 38x |
vars <- c(x$vars$arm, x$vars$covariates) |
146 | 38x |
has_arm <- "arm" %in% names(x$vars) |
147 | ||
148 | 38x |
result <- if (!has_arm) { |
149 | 5x |
Map( |
150 | 5x |
mod = mod, vars = vars, |
151 | 5x |
f = function(mod, vars) { |
152 | 6x |
h_coxreg_multivar_extract( |
153 | 6x |
var = vars, |
154 | 6x |
data = x$data, |
155 | 6x |
mod = mod, |
156 | 6x |
control = x$control |
157 |
) |
|
158 |
} |
|
159 |
) |
|
160 | 38x |
} else if (x$control$interaction) { |
161 | 12x |
Map( |
162 | 12x |
mod = mod, covar = vars, |
163 | 12x |
f = function(mod, covar) { |
164 | 26x |
h_coxreg_extract_interaction( |
165 | 26x |
effect = x$vars$arm, covar = covar, mod = mod, data = x$data, |
166 | 26x |
at = x$at, control = x$control |
167 |
) |
|
168 |
} |
|
169 |
) |
|
170 |
} else { |
|
171 | 21x |
Map( |
172 | 21x |
mod = mod, vars = vars, |
173 | 21x |
f = function(mod, vars) { |
174 | 53x |
h_coxreg_univar_extract( |
175 | 53x |
effect = x$vars$arm, covar = vars, data = x$data, mod = mod, |
176 | 53x |
control = x$control |
177 |
) |
|
178 |
} |
|
179 |
) |
|
180 |
} |
|
181 | 38x |
result <- do.call(rbind, result) |
182 | ||
183 | 38x |
result$ci <- Map(lcl = result$lcl, ucl = result$ucl, f = function(lcl, ucl) c(lcl, ucl)) |
184 | 38x |
result$n <- lapply(result$n, empty_vector_if_na) |
185 | 38x |
result$ci <- lapply(result$ci, empty_vector_if_na) |
186 | 38x |
result$hr <- lapply(result$hr, empty_vector_if_na) |
187 | 38x |
if (x$control$interaction) { |
188 | 12x |
result$pval_inter <- lapply(result$pval_inter, empty_vector_if_na) |
189 |
# Remove interaction p-values due to change in specifications. |
|
190 | 12x |
result$pval[result$effect != "Treatment:"] <- NA |
191 |
} |
|
192 | 38x |
result$pval <- lapply(result$pval, empty_vector_if_na) |
193 | 38x |
attr(result, "conf_level") <- x$control$conf_level |
194 | 38x |
result |
195 |
} |
|
196 | ||
197 |
#' @describeIn tidy_coxreg Custom tidy method for a multivariate Cox regression. |
|
198 |
#' |
|
199 |
#' Tidy up the result of a Cox regression model fitted by [fit_coxreg_multivar()]. |
|
200 |
#' |
|
201 |
#' @method tidy coxreg.multivar |
|
202 |
#' |
|
203 |
#' @examples |
|
204 |
#' multivar_model <- fit_coxreg_multivar( |
|
205 |
#' variables = list( |
|
206 |
#' time = "time", event = "status", arm = "armcd", |
|
207 |
#' covariates = c("covar1", "covar2") |
|
208 |
#' ), |
|
209 |
#' data = dta_bladder |
|
210 |
#' ) |
|
211 |
#' broom::tidy(multivar_model) |
|
212 |
#' |
|
213 |
#' @export |
|
214 |
tidy.coxreg.multivar <- function(x, # nolint |
|
215 |
...) { |
|
216 | 16x |
checkmate::assert_class(x, "coxreg.multivar") |
217 | 16x |
vars <- c(x$vars$arm, x$vars$covariates) |
218 | ||
219 |
# Convert the model summaries to data. |
|
220 | 16x |
result <- Map( |
221 | 16x |
vars = vars, |
222 | 16x |
f = function(vars) { |
223 | 60x |
h_coxreg_multivar_extract( |
224 | 60x |
var = vars, data = x$data, |
225 | 60x |
mod = x$mod, control = x$control |
226 |
) |
|
227 |
} |
|
228 |
) |
|
229 | 16x |
result <- do.call(rbind, result) |
230 | ||
231 | 16x |
result$ci <- Map(lcl = result$lcl, ucl = result$ucl, f = function(lcl, ucl) c(lcl, ucl)) |
232 | 16x |
result$ci <- lapply(result$ci, empty_vector_if_na) |
233 | 16x |
result$hr <- lapply(result$hr, empty_vector_if_na) |
234 | 16x |
result$pval <- lapply(result$pval, empty_vector_if_na) |
235 | 16x |
result <- result[, names(result) != "n"] |
236 | 16x |
attr(result, "conf_level") <- x$control$conf_level |
237 | ||
238 | 16x |
result |
239 |
} |
|
240 | ||
241 |
#' Fitting functions for Cox proportional hazards regression |
|
242 |
#' |
|
243 |
#' @description `r lifecycle::badge("stable")` |
|
244 |
#' |
|
245 |
#' Fitting functions for univariate and multivariate Cox regression models. |
|
246 |
#' |
|
247 |
#' @param variables (named `list`)\cr the names of the variables found in `data`, passed as a named list and |
|
248 |
#' corresponding to the `time`, `event`, `arm`, `strata`, and `covariates` terms. If `arm` is missing from |
|
249 |
#' `variables`, then only Cox model(s) including the `covariates` will be fitted and the corresponding effect |
|
250 |
#' estimates will be tabulated later. |
|
251 |
#' @param data (`data.frame`)\cr the dataset containing the variables to fit the models. |
|
252 |
#' @param at (`list` of `numeric`)\cr when the candidate covariate is a `numeric`, use `at` to specify |
|
253 |
#' the value of the covariate at which the effect should be estimated. |
|
254 |
#' @param control (`list`)\cr a list of parameters as returned by the helper function [control_coxreg()]. |
|
255 |
#' |
|
256 |
#' @seealso [h_cox_regression] for relevant helper functions, [cox_regression]. |
|
257 |
#' |
|
258 |
#' @examples |
|
259 |
#' library(survival) |
|
260 |
#' |
|
261 |
#' set.seed(1, kind = "Mersenne-Twister") |
|
262 |
#' |
|
263 |
#' # Testing dataset [survival::bladder]. |
|
264 |
#' dta_bladder <- with( |
|
265 |
#' data = bladder[bladder$enum < 5, ], |
|
266 |
#' data.frame( |
|
267 |
#' time = stop, |
|
268 |
#' status = event, |
|
269 |
#' armcd = as.factor(rx), |
|
270 |
#' covar1 = as.factor(enum), |
|
271 |
#' covar2 = factor( |
|
272 |
#' sample(as.factor(enum)), |
|
273 |
#' levels = 1:4, labels = c("F", "F", "M", "M") |
|
274 |
#' ) |
|
275 |
#' ) |
|
276 |
#' ) |
|
277 |
#' labels <- c("armcd" = "ARM", "covar1" = "A Covariate Label", "covar2" = "Sex (F/M)") |
|
278 |
#' formatters::var_labels(dta_bladder)[names(labels)] <- labels |
|
279 |
#' dta_bladder$age <- sample(20:60, size = nrow(dta_bladder), replace = TRUE) |
|
280 |
#' |
|
281 |
#' plot( |
|
282 |
#' survfit(Surv(time, status) ~ armcd + covar1, data = dta_bladder), |
|
283 |
#' lty = 2:4, |
|
284 |
#' xlab = "Months", |
|
285 |
#' col = c("blue1", "blue2", "blue3", "blue4", "red1", "red2", "red3", "red4") |
|
286 |
#' ) |
|
287 |
#' |
|
288 |
#' @name fit_coxreg |
|
289 |
NULL |
|
290 | ||
291 |
#' @describeIn fit_coxreg Fit a series of univariate Cox regression models given the inputs. |
|
292 |
#' |
|
293 |
#' @return |
|
294 |
#' * `fit_coxreg_univar()` returns a `coxreg.univar` class object which is a named `list` |
|
295 |
#' with 5 elements: |
|
296 |
#' * `mod`: Cox regression models fitted by [survival::coxph()]. |
|
297 |
#' * `data`: The original data frame input. |
|
298 |
#' * `control`: The original control input. |
|
299 |
#' * `vars`: The variables used in the model. |
|
300 |
#' * `at`: Value of the covariate at which the effect should be estimated. |
|
301 |
#' |
|
302 |
#' @note When using `fit_coxreg_univar` there should be two study arms. |
|
303 |
#' |
|
304 |
#' @examples |
|
305 |
#' # fit_coxreg_univar |
|
306 |
#' |
|
307 |
#' ## Cox regression: arm + 1 covariate. |
|
308 |
#' mod1 <- fit_coxreg_univar( |
|
309 |
#' variables = list( |
|
310 |
#' time = "time", event = "status", arm = "armcd", |
|
311 |
#' covariates = "covar1" |
|
312 |
#' ), |
|
313 |
#' data = dta_bladder, |
|
314 |
#' control = control_coxreg(conf_level = 0.91) |
|
315 |
#' ) |
|
316 |
#' |
|
317 |
#' ## Cox regression: arm + 1 covariate + interaction, 2 candidate covariates. |
|
318 |
#' mod2 <- fit_coxreg_univar( |
|
319 |
#' variables = list( |
|
320 |
#' time = "time", event = "status", arm = "armcd", |
|
321 |
#' covariates = c("covar1", "covar2") |
|
322 |
#' ), |
|
323 |
#' data = dta_bladder, |
|
324 |
#' control = control_coxreg(conf_level = 0.91, interaction = TRUE) |
|
325 |
#' ) |
|
326 |
#' |
|
327 |
#' ## Cox regression: arm + 1 covariate, stratified analysis. |
|
328 |
#' mod3 <- fit_coxreg_univar( |
|
329 |
#' variables = list( |
|
330 |
#' time = "time", event = "status", arm = "armcd", strata = "covar2", |
|
331 |
#' covariates = c("covar1") |
|
332 |
#' ), |
|
333 |
#' data = dta_bladder, |
|
334 |
#' control = control_coxreg(conf_level = 0.91) |
|
335 |
#' ) |
|
336 |
#' |
|
337 |
#' ## Cox regression: no arm, only covariates. |
|
338 |
#' mod4 <- fit_coxreg_univar( |
|
339 |
#' variables = list( |
|
340 |
#' time = "time", event = "status", |
|
341 |
#' covariates = c("covar1", "covar2") |
|
342 |
#' ), |
|
343 |
#' data = dta_bladder |
|
344 |
#' ) |
|
345 |
#' |
|
346 |
#' @export |
|
347 |
fit_coxreg_univar <- function(variables, |
|
348 |
data, |
|
349 |
at = list(), |
|
350 |
control = control_coxreg()) { |
|
351 | 43x |
checkmate::assert_list(variables, names = "named") |
352 | 43x |
has_arm <- "arm" %in% names(variables) |
353 | 43x |
arm_name <- if (has_arm) "arm" else NULL |
354 | ||
355 | 43x |
checkmate::assert_character(variables$covariates, null.ok = TRUE) |
356 | ||
357 | 43x |
assert_df_with_variables(data, variables) |
358 | 43x |
assert_list_of_variables(variables[c(arm_name, "event", "time")]) |
359 | ||
360 | 43x |
if (!is.null(variables$strata)) { |
361 | 4x |
checkmate::assert_disjunct(control$pval_method, "likelihood") |
362 |
} |
|
363 | 42x |
if (has_arm) { |
364 | 36x |
assert_df_with_factors(data, list(val = variables$arm), min.levels = 2, max.levels = 2) |
365 |
} |
|
366 | 41x |
vars <- unlist(variables[c(arm_name, "covariates", "strata")], use.names = FALSE) |
367 | 41x |
for (i in vars) { |
368 | 94x |
if (is.factor(data[[i]])) { |
369 | 82x |
attr(data[[i]], "levels") <- levels(droplevels(data[[i]])) |
370 |
} |
|
371 |
} |
|
372 | 41x |
forms <- h_coxreg_univar_formulas(variables, interaction = control$interaction) |
373 | 41x |
mod <- lapply( |
374 | 41x |
forms, function(x) { |
375 | 90x |
survival::coxph(formula = stats::as.formula(x), data = data, ties = control$ties) |
376 |
} |
|
377 |
) |
|
378 | 41x |
structure( |
379 | 41x |
list( |
380 | 41x |
mod = mod, |
381 | 41x |
data = data, |
382 | 41x |
control = control, |
383 | 41x |
vars = variables, |
384 | 41x |
at = at |
385 |
), |
|
386 | 41x |
class = "coxreg.univar" |
387 |
) |
|
388 |
} |
|
389 | ||
390 |
#' @describeIn fit_coxreg Fit a multivariate Cox regression model. |
|
391 |
#' |
|
392 |
#' @return |
|
393 |
#' * `fit_coxreg_multivar()` returns a `coxreg.multivar` class object which is a named list |
|
394 |
#' with 4 elements: |
|
395 |
#' * `mod`: Cox regression model fitted by [survival::coxph()]. |
|
396 |
#' * `data`: The original data frame input. |
|
397 |
#' * `control`: The original control input. |
|
398 |
#' * `vars`: The variables used in the model. |
|
399 |
#' |
|
400 |
#' @examples |
|
401 |
#' # fit_coxreg_multivar |
|
402 |
#' |
|
403 |
#' ## Cox regression: multivariate Cox regression. |
|
404 |
#' multivar_model <- fit_coxreg_multivar( |
|
405 |
#' variables = list( |
|
406 |
#' time = "time", event = "status", arm = "armcd", |
|
407 |
#' covariates = c("covar1", "covar2") |
|
408 |
#' ), |
|
409 |
#' data = dta_bladder |
|
410 |
#' ) |
|
411 |
#' |
|
412 |
#' # Example without treatment arm. |
|
413 |
#' multivar_covs_model <- fit_coxreg_multivar( |
|
414 |
#' variables = list( |
|
415 |
#' time = "time", event = "status", |
|
416 |
#' covariates = c("covar1", "covar2") |
|
417 |
#' ), |
|
418 |
#' data = dta_bladder |
|
419 |
#' ) |
|
420 |
#' |
|
421 |
#' @export |
|
422 |
fit_coxreg_multivar <- function(variables, |
|
423 |
data, |
|
424 |
control = control_coxreg()) { |
|
425 | 83x |
checkmate::assert_list(variables, names = "named") |
426 | 83x |
has_arm <- "arm" %in% names(variables) |
427 | 83x |
arm_name <- if (has_arm) "arm" else NULL |
428 | ||
429 | 83x |
if (!is.null(variables$covariates)) { |
430 | 21x |
checkmate::assert_character(variables$covariates) |
431 |
} |
|
432 | ||
433 | 83x |
checkmate::assert_false(control$interaction) |
434 | 83x |
assert_df_with_variables(data, variables) |
435 | 83x |
assert_list_of_variables(variables[c(arm_name, "event", "time")]) |
436 | ||
437 | 83x |
if (!is.null(variables$strata)) { |
438 | 3x |
checkmate::assert_disjunct(control$pval_method, "likelihood") |
439 |
} |
|
440 | ||
441 | 82x |
form <- h_coxreg_multivar_formula(variables) |
442 | 82x |
mod <- survival::coxph( |
443 | 82x |
formula = stats::as.formula(form), |
444 | 82x |
data = data, |
445 | 82x |
ties = control$ties |
446 |
) |
|
447 | 82x |
structure( |
448 | 82x |
list( |
449 | 82x |
mod = mod, |
450 | 82x |
data = data, |
451 | 82x |
control = control, |
452 | 82x |
vars = variables |
453 |
), |
|
454 | 82x |
class = "coxreg.multivar" |
455 |
) |
|
456 |
} |
|
457 | ||
458 |
#' Muffled `car::Anova` |
|
459 |
#' |
|
460 |
#' Applied on survival models, [car::Anova()] signal that the `strata` terms is dropped from the model formula when |
|
461 |
#' present, this function deliberately muffles this message. |
|
462 |
#' |
|
463 |
#' @param mod (`coxph`)\cr Cox regression model fitted by [survival::coxph()]. |
|
464 |
#' @param test_statistic (`string`)\cr the method used for estimation of p.values; `wald` (default) or `likelihood`. |
|
465 |
#' |
|
466 |
#' @return The output of [car::Anova()], with convergence message muffled. |
|
467 |
#' |
|
468 |
#' @keywords internal |
|
469 |
muffled_car_anova <- function(mod, test_statistic) { |
|
470 | 219x |
tryCatch( |
471 | 219x |
withCallingHandlers( |
472 | 219x |
expr = { |
473 | 219x |
car::Anova( |
474 | 219x |
mod, |
475 | 219x |
test.statistic = test_statistic, |
476 | 219x |
type = "III" |
477 |
) |
|
478 |
}, |
|
479 | 219x |
message = function(m) invokeRestart("muffleMessage"), |
480 | 219x |
error = function(e) { |
481 | 1x |
stop(paste( |
482 | 1x |
"the model seems to have convergence problems, please try to change", |
483 | 1x |
"the configuration of covariates or strata variables, e.g.", |
484 | 1x |
"- original error:", e |
485 |
)) |
|
486 |
} |
|
487 |
) |
|
488 |
) |
|
489 |
} |
1 |
#' Stack multiple grobs |
|
2 |
#' |
|
3 |
#' @description `r lifecycle::badge("deprecated")` |
|
4 |
#' |
|
5 |
#' Stack grobs as a new grob with 1 column and multiple rows layout. |
|
6 |
#' |
|
7 |
#' @param ... grobs. |
|
8 |
#' @param grobs (`list` of `grob`)\cr a list of grobs. |
|
9 |
#' @param padding (`grid::unit`)\cr unit of length 1, space between each grob. |
|
10 |
#' @param vp (`viewport` or `NULL`)\cr a [viewport()] object (or `NULL`). |
|
11 |
#' @param name (`string`)\cr a character identifier for the grob. |
|
12 |
#' @param gp (`gpar`)\cr a [gpar()] object. |
|
13 |
#' |
|
14 |
#' @return A `grob`. |
|
15 |
#' |
|
16 |
#' @examples |
|
17 |
#' library(grid) |
|
18 |
#' |
|
19 |
#' g1 <- circleGrob(gp = gpar(col = "blue")) |
|
20 |
#' g2 <- circleGrob(gp = gpar(col = "red")) |
|
21 |
#' g3 <- textGrob("TEST TEXT") |
|
22 |
#' grid.newpage() |
|
23 |
#' grid.draw(stack_grobs(g1, g2, g3)) |
|
24 |
#' |
|
25 |
#' showViewport() |
|
26 |
#' |
|
27 |
#' grid.newpage() |
|
28 |
#' pushViewport(viewport(layout = grid.layout(1, 2))) |
|
29 |
#' vp1 <- viewport(layout.pos.row = 1, layout.pos.col = 2) |
|
30 |
#' grid.draw(stack_grobs(g1, g2, g3, vp = vp1, name = "test")) |
|
31 |
#' |
|
32 |
#' showViewport() |
|
33 |
#' grid.ls(grobs = TRUE, viewports = TRUE, print = FALSE) |
|
34 |
#' |
|
35 |
#' @export |
|
36 |
stack_grobs <- function(..., |
|
37 |
grobs = list(...), |
|
38 |
padding = grid::unit(2, "line"), |
|
39 |
vp = NULL, |
|
40 |
gp = NULL, |
|
41 |
name = NULL) { |
|
42 | 4x |
lifecycle::deprecate_warn( |
43 | 4x |
"0.9.4", |
44 | 4x |
"stack_grobs()", |
45 | 4x |
details = "`tern` plotting functions no longer generate `grob` objects." |
46 |
) |
|
47 | ||
48 | 4x |
checkmate::assert_true( |
49 | 4x |
all(vapply(grobs, grid::is.grob, logical(1))) |
50 |
) |
|
51 | ||
52 | 4x |
if (length(grobs) == 1) { |
53 | 1x |
return(grobs[[1]]) |
54 |
} |
|
55 | ||
56 | 3x |
n_layout <- 2 * length(grobs) - 1 |
57 | 3x |
hts <- lapply( |
58 | 3x |
seq(1, n_layout), |
59 | 3x |
function(i) { |
60 | 39x |
if (i %% 2 != 0) { |
61 | 21x |
grid::unit(1, "null") |
62 |
} else { |
|
63 | 18x |
padding |
64 |
} |
|
65 |
} |
|
66 |
) |
|
67 | 3x |
hts <- do.call(grid::unit.c, hts) |
68 | ||
69 | 3x |
main_vp <- grid::viewport( |
70 | 3x |
layout = grid::grid.layout(nrow = n_layout, ncol = 1, heights = hts) |
71 |
) |
|
72 | ||
73 | 3x |
nested_grobs <- Map(function(g, i) { |
74 | 21x |
grid::gTree( |
75 | 21x |
children = grid::gList(g), |
76 | 21x |
vp = grid::viewport(layout.pos.row = i, layout.pos.col = 1) |
77 |
) |
|
78 | 3x |
}, grobs, seq_along(grobs) * 2 - 1) |
79 | ||
80 | 3x |
grobs_mainvp <- grid::gTree( |
81 | 3x |
children = do.call(grid::gList, nested_grobs), |
82 | 3x |
vp = main_vp |
83 |
) |
|
84 | ||
85 | 3x |
grid::gTree( |
86 | 3x |
children = grid::gList(grobs_mainvp), |
87 | 3x |
vp = vp, |
88 | 3x |
gp = gp, |
89 | 3x |
name = name |
90 |
) |
|
91 |
} |
|
92 | ||
93 |
#' Arrange multiple grobs |
|
94 |
#' |
|
95 |
#' @description `r lifecycle::badge("deprecated")` |
|
96 |
#' |
|
97 |
#' Arrange grobs as a new grob with `n * m (rows * cols)` layout. |
|
98 |
#' |
|
99 |
#' @inheritParams stack_grobs |
|
100 |
#' @param ncol (`integer(1)`)\cr number of columns in layout. |
|
101 |
#' @param nrow (`integer(1)`)\cr number of rows in layout. |
|
102 |
#' @param padding_ht (`grid::unit`)\cr unit of length 1, vertical space between each grob. |
|
103 |
#' @param padding_wt (`grid::unit`)\cr unit of length 1, horizontal space between each grob. |
|
104 |
#' |
|
105 |
#' @return A `grob`. |
|
106 |
#' |
|
107 |
#' @examples |
|
108 |
#' library(grid) |
|
109 |
#' |
|
110 |
#' \donttest{ |
|
111 |
#' num <- lapply(1:9, textGrob) |
|
112 |
#' grid::grid.newpage() |
|
113 |
#' grid.draw(arrange_grobs(grobs = num, ncol = 2)) |
|
114 |
#' |
|
115 |
#' showViewport() |
|
116 |
#' |
|
117 |
#' g1 <- circleGrob(gp = gpar(col = "blue")) |
|
118 |
#' g2 <- circleGrob(gp = gpar(col = "red")) |
|
119 |
#' g3 <- textGrob("TEST TEXT") |
|
120 |
#' grid::grid.newpage() |
|
121 |
#' grid.draw(arrange_grobs(g1, g2, g3, nrow = 2)) |
|
122 |
#' |
|
123 |
#' showViewport() |
|
124 |
#' |
|
125 |
#' grid::grid.newpage() |
|
126 |
#' grid.draw(arrange_grobs(g1, g2, g3, ncol = 3)) |
|
127 |
#' |
|
128 |
#' grid::grid.newpage() |
|
129 |
#' grid::pushViewport(grid::viewport(layout = grid::grid.layout(1, 2))) |
|
130 |
#' vp1 <- grid::viewport(layout.pos.row = 1, layout.pos.col = 2) |
|
131 |
#' grid.draw(arrange_grobs(g1, g2, g3, ncol = 2, vp = vp1)) |
|
132 |
#' |
|
133 |
#' showViewport() |
|
134 |
#' } |
|
135 |
#' @export |
|
136 |
arrange_grobs <- function(..., |
|
137 |
grobs = list(...), |
|
138 |
ncol = NULL, nrow = NULL, |
|
139 |
padding_ht = grid::unit(2, "line"), |
|
140 |
padding_wt = grid::unit(2, "line"), |
|
141 |
vp = NULL, |
|
142 |
gp = NULL, |
|
143 |
name = NULL) { |
|
144 | 5x |
lifecycle::deprecate_warn( |
145 | 5x |
"0.9.4", |
146 | 5x |
"arrange_grobs()", |
147 | 5x |
details = "`tern` plotting functions no longer generate `grob` objects." |
148 |
) |
|
149 | ||
150 | 5x |
checkmate::assert_true( |
151 | 5x |
all(vapply(grobs, grid::is.grob, logical(1))) |
152 |
) |
|
153 | ||
154 | 5x |
if (length(grobs) == 1) { |
155 | 1x |
return(grobs[[1]]) |
156 |
} |
|
157 | ||
158 | 4x |
if (is.null(ncol) && is.null(nrow)) { |
159 | 1x |
ncol <- 1 |
160 | 1x |
nrow <- ceiling(length(grobs) / ncol) |
161 | 3x |
} else if (!is.null(ncol) && is.null(nrow)) { |
162 | 1x |
nrow <- ceiling(length(grobs) / ncol) |
163 | 2x |
} else if (is.null(ncol) && !is.null(nrow)) { |
164 | ! |
ncol <- ceiling(length(grobs) / nrow) |
165 |
} |
|
166 | ||
167 | 4x |
if (ncol * nrow < length(grobs)) { |
168 | 1x |
stop("specififed ncol and nrow are not enough for arranging the grobs ") |
169 |
} |
|
170 | ||
171 | 3x |
if (ncol == 1) { |
172 | 2x |
return(stack_grobs(grobs = grobs, padding = padding_ht, vp = vp, gp = gp, name = name)) |
173 |
} |
|
174 | ||
175 | 1x |
n_col <- 2 * ncol - 1 |
176 | 1x |
n_row <- 2 * nrow - 1 |
177 | 1x |
hts <- lapply( |
178 | 1x |
seq(1, n_row), |
179 | 1x |
function(i) { |
180 | 5x |
if (i %% 2 != 0) { |
181 | 3x |
grid::unit(1, "null") |
182 |
} else { |
|
183 | 2x |
padding_ht |
184 |
} |
|
185 |
} |
|
186 |
) |
|
187 | 1x |
hts <- do.call(grid::unit.c, hts) |
188 | ||
189 | 1x |
wts <- lapply( |
190 | 1x |
seq(1, n_col), |
191 | 1x |
function(i) { |
192 | 5x |
if (i %% 2 != 0) { |
193 | 3x |
grid::unit(1, "null") |
194 |
} else { |
|
195 | 2x |
padding_wt |
196 |
} |
|
197 |
} |
|
198 |
) |
|
199 | 1x |
wts <- do.call(grid::unit.c, wts) |
200 | ||
201 | 1x |
main_vp <- grid::viewport( |
202 | 1x |
layout = grid::grid.layout(nrow = n_row, ncol = n_col, widths = wts, heights = hts) |
203 |
) |
|
204 | ||
205 | 1x |
nested_grobs <- list() |
206 | 1x |
k <- 0 |
207 | 1x |
for (i in seq(nrow) * 2 - 1) { |
208 | 3x |
for (j in seq(ncol) * 2 - 1) { |
209 | 9x |
k <- k + 1 |
210 | 9x |
if (k <= length(grobs)) { |
211 | 9x |
nested_grobs <- c( |
212 | 9x |
nested_grobs, |
213 | 9x |
list(grid::gTree( |
214 | 9x |
children = grid::gList(grobs[[k]]), |
215 | 9x |
vp = grid::viewport(layout.pos.row = i, layout.pos.col = j) |
216 |
)) |
|
217 |
) |
|
218 |
} |
|
219 |
} |
|
220 |
} |
|
221 | 1x |
grobs_mainvp <- grid::gTree( |
222 | 1x |
children = do.call(grid::gList, nested_grobs), |
223 | 1x |
vp = main_vp |
224 |
) |
|
225 | ||
226 | 1x |
grid::gTree( |
227 | 1x |
children = grid::gList(grobs_mainvp), |
228 | 1x |
vp = vp, |
229 | 1x |
gp = gp, |
230 | 1x |
name = name |
231 |
) |
|
232 |
} |
|
233 | ||
234 |
#' Draw `grob` |
|
235 |
#' |
|
236 |
#' @description `r lifecycle::badge("deprecated")` |
|
237 |
#' |
|
238 |
#' Draw grob on device page. |
|
239 |
#' |
|
240 |
#' @param grob (`grob`)\cr grid object. |
|
241 |
#' @param newpage (`flag`)\cr draw on a new page. |
|
242 |
#' @param vp (`viewport` or `NULL`)\cr a [viewport()] object (or `NULL`). |
|
243 |
#' |
|
244 |
#' @return A `grob`. |
|
245 |
#' |
|
246 |
#' @examples |
|
247 |
#' library(dplyr) |
|
248 |
#' library(grid) |
|
249 |
#' |
|
250 |
#' \donttest{ |
|
251 |
#' rect <- rectGrob(width = grid::unit(0.5, "npc"), height = grid::unit(0.5, "npc")) |
|
252 |
#' rect %>% draw_grob(vp = grid::viewport(angle = 45)) |
|
253 |
#' |
|
254 |
#' num <- lapply(1:10, textGrob) |
|
255 |
#' num %>% |
|
256 |
#' arrange_grobs(grobs = .) %>% |
|
257 |
#' draw_grob() |
|
258 |
#' showViewport() |
|
259 |
#' } |
|
260 |
#' |
|
261 |
#' @export |
|
262 |
draw_grob <- function(grob, newpage = TRUE, vp = NULL) { |
|
263 | 3x |
lifecycle::deprecate_warn( |
264 | 3x |
"0.9.4", |
265 | 3x |
"draw_grob()", |
266 | 3x |
details = "`tern` plotting functions no longer generate `grob` objects." |
267 |
) |
|
268 | ||
269 | 3x |
if (newpage) { |
270 | 3x |
grid::grid.newpage() |
271 |
} |
|
272 | 3x |
if (!is.null(vp)) { |
273 | 1x |
grid::pushViewport(vp) |
274 |
} |
|
275 | 3x |
grid::grid.draw(grob) |
276 |
} |
|
277 | ||
278 |
tern_grob <- function(x) { |
|
279 | ! |
class(x) <- unique(c("ternGrob", class(x))) |
280 | ! |
x |
281 |
} |
|
282 | ||
283 |
#' @keywords internal |
|
284 |
print.ternGrob <- function(x, ...) { |
|
285 | ! |
grid::grid.newpage() |
286 | ! |
grid::grid.draw(x) |
287 |
} |
1 |
#' Count number of patients and sum exposure across all patients in columns |
|
2 |
#' |
|
3 |
#' @description `r lifecycle::badge("stable")` |
|
4 |
#' |
|
5 |
#' The analyze function [analyze_patients_exposure_in_cols()] creates a layout element to count total numbers of |
|
6 |
#' patients and sum an analysis value (i.e. exposure) across all patients in columns. |
|
7 |
#' |
|
8 |
#' The primary analysis variable `ex_var` is the exposure variable used to calculate the `sum_exposure` statistic. The |
|
9 |
#' `id` variable is used to uniquely identify patients in the data such that only unique patients are counted in the |
|
10 |
#' `n_patients` statistic, and the `var` variable is used to create a row split if needed. The percentage returned as |
|
11 |
#' part of the `n_patients` statistic is the proportion of all records that correspond to a unique patient. |
|
12 |
#' |
|
13 |
#' The summarize function [summarize_patients_exposure_in_cols()] performs the same function as |
|
14 |
#' [analyze_patients_exposure_in_cols()] except it creates content rows, not data rows, to summarize the current table |
|
15 |
#' row/column context and operates on the level of the latest row split or the root of the table if no row splits have |
|
16 |
#' occurred. |
|
17 |
#' |
|
18 |
#' If a column split has not yet been performed in the table, `col_split` must be set to `TRUE` for the first call of |
|
19 |
#' [analyze_patients_exposure_in_cols()] or [summarize_patients_exposure_in_cols()]. |
|
20 |
#' |
|
21 |
#' @inheritParams argument_convention |
|
22 |
#' @param ex_var (`string`)\cr name of the variable in `df` containing exposure values. |
|
23 |
#' @param custom_label (`string` or `NULL`)\cr if provided and `labelstr` is empty, this will be used as label. |
|
24 |
#' @param .stats (`character`)\cr statistics to select for the table. |
|
25 |
#' |
|
26 |
#' Options are: ``r shQuote(get_stats("analyze_patients_exposure_in_cols"), type = "sh")`` |
|
27 |
#' |
|
28 |
#' @name summarize_patients_exposure_in_cols |
|
29 |
#' @order 1 |
|
30 |
NULL |
|
31 | ||
32 |
#' @describeIn summarize_patients_exposure_in_cols Statistics function which counts numbers |
|
33 |
#' of patients and the sum of exposure across all patients. |
|
34 |
#' |
|
35 |
#' @return |
|
36 |
#' * `s_count_patients_sum_exposure()` returns a named `list` with the statistics: |
|
37 |
#' * `n_patients`: Number of unique patients in `df`. |
|
38 |
#' * `sum_exposure`: Sum of `ex_var` across all patients in `df`. |
|
39 |
#' |
|
40 |
#' @keywords internal |
|
41 |
s_count_patients_sum_exposure <- function(df, |
|
42 |
labelstr = "", |
|
43 |
.stats = c("n_patients", "sum_exposure"), |
|
44 |
.N_col, # nolint |
|
45 |
..., |
|
46 |
ex_var = "AVAL", |
|
47 |
id = "USUBJID", |
|
48 |
custom_label = NULL, |
|
49 |
var_level = NULL) { |
|
50 | 56x |
assert_df_with_variables(df, list(ex_var = ex_var, id = id)) |
51 | 56x |
checkmate::assert_string(id) |
52 | 56x |
checkmate::assert_string(labelstr) |
53 | 56x |
checkmate::assert_string(custom_label, null.ok = TRUE) |
54 | 56x |
checkmate::assert_numeric(df[[ex_var]]) |
55 | 56x |
checkmate::assert_true(all(.stats %in% c("n_patients", "sum_exposure"))) |
56 | ||
57 | 56x |
row_label <- if (labelstr != "") { |
58 | ! |
labelstr |
59 | 56x |
} else if (!is.null(var_level)) { |
60 | 42x |
var_level |
61 | 56x |
} else if (!is.null(custom_label)) { |
62 | 6x |
custom_label |
63 |
} else { |
|
64 | 8x |
"Total patients numbers/person time" |
65 |
} |
|
66 | ||
67 | 56x |
y <- list() |
68 | ||
69 | 56x |
if ("n_patients" %in% .stats) { |
70 | 56x |
y$n_patients <- |
71 | 56x |
formatters::with_label( |
72 | 56x |
s_num_patients_content( |
73 | 56x |
df = df, |
74 | 56x |
.N_col = .N_col, # nolint |
75 | 56x |
.var = id, |
76 | 56x |
labelstr = "" |
77 | 56x |
)$unique, |
78 | 56x |
row_label |
79 |
) |
|
80 |
} |
|
81 | 56x |
if ("sum_exposure" %in% .stats) { |
82 | 56x |
y$sum_exposure <- formatters::with_label(sum(df[[ex_var]]), row_label) |
83 |
} |
|
84 | 56x |
y |
85 |
} |
|
86 | ||
87 |
#' @describeIn summarize_patients_exposure_in_cols Analysis function which is used as `afun` in |
|
88 |
#' [rtables::analyze_colvars()] within `analyze_patients_exposure_in_cols()` and as `cfun` in |
|
89 |
#' [rtables::summarize_row_groups()] within `summarize_patients_exposure_in_cols()`. |
|
90 |
#' |
|
91 |
#' @return |
|
92 |
#' * `a_count_patients_sum_exposure()` returns formatted [rtables::CellValue()]. |
|
93 |
#' |
|
94 |
#' @export |
|
95 |
a_count_patients_sum_exposure <- function(df, |
|
96 |
labelstr = "", |
|
97 |
..., |
|
98 |
.stats = NULL, |
|
99 |
.stat_names = NULL, |
|
100 |
.formats = NULL, |
|
101 |
.labels = NULL, |
|
102 |
.indent_mods = NULL) { |
|
103 | 32x |
checkmate::assert_character(.stats, len = 1) |
104 | ||
105 |
# Check for additional parameters to the statistics function |
|
106 | 32x |
dots_extra_args <- list(...) |
107 | 32x |
extra_afun_params <- retrieve_extra_afun_params(names(dots_extra_args$.additional_fun_parameters)) |
108 | 32x |
dots_extra_args$.additional_fun_parameters <- NULL |
109 | ||
110 | 32x |
add_total_level <- dots_extra_args$add_total_level |
111 | 32x |
checkmate::assert_flag(add_total_level) |
112 | ||
113 | 32x |
var <- dots_extra_args$var |
114 | 32x |
if (!is.null(var)) { |
115 | 21x |
assert_df_with_variables(df, list(var = var)) |
116 | 21x |
df[[var]] <- as.factor(df[[var]]) |
117 |
} |
|
118 | ||
119 |
# Check for user-defined functions |
|
120 | 32x |
default_and_custom_stats_list <- .split_std_from_custom_stats(.stats) |
121 | 32x |
.stats <- default_and_custom_stats_list$all_stats |
122 | 32x |
custom_stat_functions <- default_and_custom_stats_list$custom_stats |
123 | ||
124 | 32x |
x_stats <- list() |
125 | 32x |
if (!is.null(var)) { |
126 | 21x |
for (lvl in levels(df[[var]])) { |
127 | 42x |
x_stats_i <- .apply_stat_functions( |
128 | 42x |
default_stat_fnc = s_count_patients_sum_exposure, |
129 | 42x |
custom_stat_fnc_list = custom_stat_functions, |
130 | 42x |
args_list = c( |
131 | 42x |
df = list(subset(df, get(var) == lvl)), |
132 | 42x |
labelstr = list(labelstr), |
133 | 42x |
var_level = lvl, |
134 | 42x |
extra_afun_params, |
135 | 42x |
dots_extra_args |
136 |
) |
|
137 |
) |
|
138 | 42x |
x_stats[[.stats]][[lvl]] <- x_stats_i[[.stats]] |
139 |
} |
|
140 |
} |
|
141 | ||
142 | 32x |
if (add_total_level || is.null(var)) { |
143 | 13x |
x_stats_total <- .apply_stat_functions( |
144 | 13x |
default_stat_fnc = s_count_patients_sum_exposure, |
145 | 13x |
custom_stat_fnc_list = custom_stat_functions, |
146 | 13x |
args_list = c( |
147 | 13x |
df = list(df), |
148 | 13x |
labelstr = list(labelstr), |
149 | 13x |
extra_afun_params, |
150 | 13x |
dots_extra_args |
151 |
) |
|
152 |
) |
|
153 | 13x |
x_stats[[.stats]][["Total"]] <- x_stats_total[[.stats]] |
154 |
} |
|
155 | ||
156 |
# Fill in formatting defaults |
|
157 | 32x |
.stats <- get_stats( |
158 | 32x |
"analyze_patients_exposure_in_cols", |
159 | 32x |
stats_in = .stats, |
160 | 32x |
custom_stats_in = names(custom_stat_functions) |
161 |
) |
|
162 | 32x |
x_stats <- x_stats[.stats] |
163 | 32x |
levels_per_stats <- lapply(x_stats, names) |
164 | 32x |
.formats <- get_formats_from_stats(.stats, .formats, levels_per_stats) |
165 | 32x |
.labels <- get_labels_from_stats( |
166 | 32x |
.stats, .labels, levels_per_stats, |
167 | 32x |
tern_defaults = c(lapply(x_stats[[1]], attr, "label"), tern_default_labels) |
168 |
) |
|
169 | 32x |
.indent_mods <- get_indents_from_stats(.stats, .indent_mods, levels_per_stats) |
170 | ||
171 | 32x |
x_stats <- x_stats[.stats] %>% |
172 | 32x |
.unlist_keep_nulls() %>% |
173 | 32x |
setNames(names(.formats)) |
174 | ||
175 |
# Auto format handling |
|
176 | 32x |
.formats <- apply_auto_formatting(.formats, x_stats, extra_afun_params$.df_row, extra_afun_params$.var) |
177 | ||
178 |
# Get and check statistical names |
|
179 | 32x |
.stat_names <- get_stat_names(x_stats, .stat_names) |
180 | ||
181 | 32x |
in_rows( |
182 | 32x |
.list = x_stats, |
183 | 32x |
.formats = .formats, |
184 | 32x |
.names = .labels %>% .unlist_keep_nulls(), |
185 | 32x |
.stat_names = .stat_names, |
186 | 32x |
.labels = .labels %>% .unlist_keep_nulls(), |
187 | 32x |
.indent_mods = .indent_mods %>% .unlist_keep_nulls() |
188 |
) |
|
189 |
} |
|
190 | ||
191 |
#' @describeIn summarize_patients_exposure_in_cols Layout-creating function which can take statistics |
|
192 |
#' function arguments and additional format arguments. This function is a wrapper for |
|
193 |
#' [rtables::split_cols_by_multivar()] and [rtables::summarize_row_groups()]. |
|
194 |
#' |
|
195 |
#' @return |
|
196 |
#' * `summarize_patients_exposure_in_cols()` returns a layout object suitable for passing to further |
|
197 |
#' layouting functions, or to [rtables::build_table()]. Adding this function to an `rtable` layout will |
|
198 |
#' add formatted content rows, with the statistics from `s_count_patients_sum_exposure()` arranged in |
|
199 |
#' columns, to the table layout. |
|
200 |
#' |
|
201 |
#' @examples |
|
202 |
#' lyt5 <- basic_table() %>% |
|
203 |
#' summarize_patients_exposure_in_cols(var = "AVAL", col_split = TRUE) |
|
204 |
#' |
|
205 |
#' result5 <- build_table(lyt5, df = df, alt_counts_df = adsl) |
|
206 |
#' result5 |
|
207 |
#' |
|
208 |
#' lyt6 <- basic_table() %>% |
|
209 |
#' summarize_patients_exposure_in_cols(var = "AVAL", col_split = TRUE, .stats = "sum_exposure") |
|
210 |
#' |
|
211 |
#' result6 <- build_table(lyt6, df = df, alt_counts_df = adsl) |
|
212 |
#' result6 |
|
213 |
#' |
|
214 |
#' @export |
|
215 |
#' @order 3 |
|
216 |
summarize_patients_exposure_in_cols <- function(lyt, |
|
217 |
var, |
|
218 |
ex_var = "AVAL", |
|
219 |
id = "USUBJID", |
|
220 |
add_total_level = FALSE, |
|
221 |
custom_label = NULL, |
|
222 |
col_split = TRUE, |
|
223 |
na_str = default_na_str(), |
|
224 |
..., |
|
225 |
.stats = c("n_patients", "sum_exposure"), |
|
226 |
.stat_names = NULL, |
|
227 |
.formats = NULL, |
|
228 |
.labels = c(n_patients = "Patients", sum_exposure = "Person time"), |
|
229 |
.indent_mods = NULL) { |
|
230 |
# Process standard extra arguments |
|
231 | 3x |
extra_args <- list() |
232 | ! |
if (!is.null(.stat_names)) extra_args[[".stat_names"]] <- .stat_names |
233 | ! |
if (!is.null(.formats)) extra_args[[".formats"]] <- .formats |
234 | 3x |
col_labels <- unlist(.labels[.stats]) |
235 | 3x |
.labels <- .labels[!names(.labels) %in% c("n_patients", "sum_exposure")] |
236 | 3x |
if (!is.null(.labels)) extra_args[[".labels"]] <- .labels |
237 | ! |
if (!is.null(.indent_mods)) extra_args[[".indent_mods"]] <- .indent_mods |
238 | ||
239 |
# Process additional arguments to the statistic function |
|
240 | 3x |
extra_args <- c( |
241 | 3x |
extra_args, |
242 | 3x |
ex_var = ex_var, id = id, add_total_level = add_total_level, custom_label = custom_label, |
243 |
... |
|
244 |
) |
|
245 | ||
246 |
# Adding additional info from layout to analysis function |
|
247 | 3x |
extra_args[[".additional_fun_parameters"]] <- get_additional_afun_params(add_alt_df = FALSE) |
248 | 3x |
formals(a_count_patients_sum_exposure) <- c( |
249 | 3x |
formals(a_count_patients_sum_exposure), extra_args[[".additional_fun_parameters"]] |
250 |
) |
|
251 | ||
252 | 3x |
if (col_split) { |
253 | 3x |
lyt <- split_cols_by_multivar( |
254 | 3x |
lyt = lyt, |
255 | 3x |
vars = rep(var, length(.stats)), |
256 | 3x |
varlabels = col_labels, |
257 | 3x |
extra_args = list(.stats = .stats) |
258 |
) |
|
259 |
} |
|
260 | 3x |
summarize_row_groups( |
261 | 3x |
lyt = lyt, |
262 | 3x |
var = var, |
263 | 3x |
cfun = a_count_patients_sum_exposure, |
264 | 3x |
na_str = na_str, |
265 | 3x |
extra_args = extra_args |
266 |
) |
|
267 |
} |
|
268 | ||
269 |
#' @describeIn summarize_patients_exposure_in_cols Layout-creating function which can take statistics |
|
270 |
#' function arguments and additional format arguments. This function is a wrapper for |
|
271 |
#' [rtables::split_cols_by_multivar()] and [rtables::analyze_colvars()]. |
|
272 |
#' |
|
273 |
#' @param col_split (`flag`)\cr whether the columns should be split. Set to `FALSE` when the required |
|
274 |
#' column split has been done already earlier in the layout pipe. |
|
275 |
#' |
|
276 |
#' @return |
|
277 |
#' * `analyze_patients_exposure_in_cols()` returns a layout object suitable for passing to further |
|
278 |
#' layouting functions, or to [rtables::build_table()]. Adding this function to an `rtable` layout will |
|
279 |
#' add formatted data rows, with the statistics from `s_count_patients_sum_exposure()` arranged in |
|
280 |
#' columns, to the table layout. |
|
281 |
#' |
|
282 |
#' @note As opposed to [summarize_patients_exposure_in_cols()] which generates content rows, |
|
283 |
#' `analyze_patients_exposure_in_cols()` generates data rows which will _not_ be repeated on multiple |
|
284 |
#' pages when pagination is used. |
|
285 |
#' |
|
286 |
#' @examples |
|
287 |
#' set.seed(1) |
|
288 |
#' df <- data.frame( |
|
289 |
#' USUBJID = c(paste("id", seq(1, 12), sep = "")), |
|
290 |
#' ARMCD = c(rep("ARM A", 6), rep("ARM B", 6)), |
|
291 |
#' SEX = c(rep("Female", 6), rep("Male", 6)), |
|
292 |
#' AVAL = as.numeric(sample(seq(1, 20), 12)), |
|
293 |
#' stringsAsFactors = TRUE |
|
294 |
#' ) |
|
295 |
#' adsl <- data.frame( |
|
296 |
#' USUBJID = c(paste("id", seq(1, 12), sep = "")), |
|
297 |
#' ARMCD = c(rep("ARM A", 2), rep("ARM B", 2)), |
|
298 |
#' SEX = c(rep("Female", 2), rep("Male", 2)), |
|
299 |
#' stringsAsFactors = TRUE |
|
300 |
#' ) |
|
301 |
#' |
|
302 |
#' lyt <- basic_table() %>% |
|
303 |
#' split_cols_by("ARMCD", split_fun = add_overall_level("Total", first = FALSE)) %>% |
|
304 |
#' summarize_patients_exposure_in_cols(var = "AVAL", col_split = TRUE) %>% |
|
305 |
#' analyze_patients_exposure_in_cols(var = "SEX", col_split = FALSE) |
|
306 |
#' result <- build_table(lyt, df = df, alt_counts_df = adsl) |
|
307 |
#' result |
|
308 |
#' |
|
309 |
#' lyt2 <- basic_table() %>% |
|
310 |
#' split_cols_by("ARMCD", split_fun = add_overall_level("Total", first = FALSE)) %>% |
|
311 |
#' summarize_patients_exposure_in_cols( |
|
312 |
#' var = "AVAL", col_split = TRUE, |
|
313 |
#' .stats = "n_patients", custom_label = "some custom label" |
|
314 |
#' ) %>% |
|
315 |
#' analyze_patients_exposure_in_cols(var = "SEX", col_split = FALSE, ex_var = "AVAL") |
|
316 |
#' result2 <- build_table(lyt2, df = df, alt_counts_df = adsl) |
|
317 |
#' result2 |
|
318 |
#' |
|
319 |
#' lyt3 <- basic_table() %>% |
|
320 |
#' analyze_patients_exposure_in_cols(var = "SEX", col_split = TRUE, ex_var = "AVAL") |
|
321 |
#' result3 <- build_table(lyt3, df = df, alt_counts_df = adsl) |
|
322 |
#' result3 |
|
323 |
#' |
|
324 |
#' # Adding total levels and custom label |
|
325 |
#' lyt4 <- basic_table( |
|
326 |
#' show_colcounts = TRUE |
|
327 |
#' ) %>% |
|
328 |
#' analyze_patients_exposure_in_cols( |
|
329 |
#' var = "ARMCD", |
|
330 |
#' col_split = TRUE, |
|
331 |
#' add_total_level = TRUE, |
|
332 |
#' custom_label = "TOTAL" |
|
333 |
#' ) %>% |
|
334 |
#' append_topleft(c("", "Sex")) |
|
335 |
#' |
|
336 |
#' result4 <- build_table(lyt4, df = df, alt_counts_df = adsl) |
|
337 |
#' result4 |
|
338 |
#' |
|
339 |
#' @export |
|
340 |
#' @order 2 |
|
341 |
analyze_patients_exposure_in_cols <- function(lyt, |
|
342 |
var = NULL, |
|
343 |
ex_var = "AVAL", |
|
344 |
id = "USUBJID", |
|
345 |
add_total_level = FALSE, |
|
346 |
custom_label = NULL, |
|
347 |
col_split = TRUE, |
|
348 |
na_str = default_na_str(), |
|
349 |
.stats = c("n_patients", "sum_exposure"), |
|
350 |
.stat_names = NULL, |
|
351 |
.formats = NULL, |
|
352 |
.labels = c(n_patients = "Patients", sum_exposure = "Person time"), |
|
353 |
.indent_mods = NULL, |
|
354 |
...) { |
|
355 |
# Process standard extra arguments |
|
356 | 6x |
extra_args <- list() |
357 | ! |
if (!is.null(.stat_names)) extra_args[[".stat_names"]] <- .stat_names |
358 | ! |
if (!is.null(.formats)) extra_args[[".formats"]] <- .formats |
359 | 6x |
col_labels <- unlist(.labels[.stats]) |
360 | 6x |
.labels <- .labels[!names(.labels) %in% c("n_patients", "sum_exposure")] |
361 | 6x |
if (!is.null(.labels)) extra_args[[".labels"]] <- .labels |
362 | ! |
if (!is.null(.indent_mods)) extra_args[[".indent_mods"]] <- .indent_mods |
363 | ||
364 |
# Process additional arguments to the statistic function |
|
365 | 6x |
extra_args <- c( |
366 | 6x |
extra_args, |
367 | 6x |
var = var, ex_var = ex_var, id = id, add_total_level = add_total_level, custom_label = custom_label, |
368 |
... |
|
369 |
) |
|
370 | ||
371 |
# Adding additional info from layout to analysis function |
|
372 | 6x |
extra_args[[".additional_fun_parameters"]] <- get_additional_afun_params(add_alt_df = FALSE) |
373 | 6x |
formals(a_count_patients_sum_exposure) <- c( |
374 | 6x |
formals(a_count_patients_sum_exposure), extra_args[[".additional_fun_parameters"]] |
375 |
) |
|
376 | ||
377 | 6x |
if (col_split) { |
378 | 4x |
lyt <- split_cols_by_multivar( |
379 | 4x |
lyt = lyt, |
380 | 4x |
vars = rep(ex_var, length(.stats)), |
381 | 4x |
varlabels = col_labels, |
382 | 4x |
extra_args = list(.stats = .stats) |
383 |
) |
|
384 |
} |
|
385 | ||
386 | 6x |
analyze_colvars( |
387 | 6x |
lyt = lyt, |
388 | 6x |
afun = a_count_patients_sum_exposure, |
389 | 6x |
na_str = na_str, |
390 | 6x |
extra_args = extra_args |
391 |
) |
|
392 |
} |
1 |
#' Control function for descriptive statistics |
|
2 |
#' |
|
3 |
#' @description `r lifecycle::badge("stable")` |
|
4 |
#' |
|
5 |
#' Sets a list of parameters for summaries of descriptive statistics. Typically used internally to specify |
|
6 |
#' details for [s_summary()]. This function family is mainly used by [analyze_vars()]. |
|
7 |
#' |
|
8 |
#' @inheritParams argument_convention |
|
9 |
#' @param quantiles (`numeric(2)`)\cr vector of length two to specify the quantiles to calculate. |
|
10 |
#' @param quantile_type (`numeric(1)`)\cr number between 1 and 9 selecting quantile algorithms to be used. |
|
11 |
#' Default is set to 2 as this matches the default quantile algorithm in SAS `proc univariate` set by `QNTLDEF=5`. |
|
12 |
#' This differs from R's default. See more about `type` in [stats::quantile()]. |
|
13 |
#' @param test_mean (`numeric(1)`)\cr number to test against the mean under the null hypothesis when calculating |
|
14 |
#' p-value. |
|
15 |
#' |
|
16 |
#' @return A list of components with the same names as the arguments. |
|
17 |
#' |
|
18 |
#' @export |
|
19 |
control_analyze_vars <- function(conf_level = 0.95, |
|
20 |
quantiles = c(0.25, 0.75), |
|
21 |
quantile_type = 2, |
|
22 |
test_mean = 0) { |
|
23 | 1134x |
checkmate::assert_vector(quantiles, len = 2) |
24 | 1134x |
checkmate::assert_int(quantile_type, lower = 1, upper = 9) |
25 | 1134x |
checkmate::assert_numeric(test_mean) |
26 | 1134x |
lapply(quantiles, assert_proportion_value) |
27 | 1133x |
assert_proportion_value(conf_level) |
28 | 1132x |
list(conf_level = conf_level, quantiles = quantiles, quantile_type = quantile_type, test_mean = test_mean) |
29 |
} |
|
30 | ||
31 |
# Helper function to fix numeric or counts pval if necessary |
|
32 |
.correct_num_or_counts_pval <- function(type, .stats) { |
|
33 | 332x |
if (type == "numeric") { |
34 | 92x |
if (!is.null(.stats) && any(grepl("^pval", .stats))) { |
35 | 10x |
.stats[grepl("^pval", .stats)] <- "pval" # tmp fix xxx |
36 |
} |
|
37 |
} else { |
|
38 | 240x |
if (!is.null(.stats) && any(grepl("^pval", .stats))) { |
39 | 9x |
.stats[grepl("^pval", .stats)] <- "pval_counts" # tmp fix xxx |
40 |
} |
|
41 |
} |
|
42 | 332x |
.stats |
43 |
} |
|
44 | ||
45 |
#' Analyze variables |
|
46 |
#' |
|
47 |
#' @description `r lifecycle::badge("stable")` |
|
48 |
#' |
|
49 |
#' The analyze function [analyze_vars()] creates a layout element to summarize one or more variables, using the S3 |
|
50 |
#' generic function [s_summary()] to calculate a list of summary statistics. A list of all available statistics for |
|
51 |
#' numeric variables can be viewed by running `get_stats("analyze_vars_numeric")` and for non-numeric variables by |
|
52 |
#' running `get_stats("analyze_vars_counts")`. Use the `.stats` parameter to specify the statistics to include in your |
|
53 |
#' output summary table. Use `compare_with_ref_group = TRUE` to compare the variable with reference groups. |
|
54 |
#' |
|
55 |
#' @details |
|
56 |
#' **Automatic digit formatting:** The number of digits to display can be automatically determined from the analyzed |
|
57 |
#' variable(s) (`vars`) for certain statistics by setting the statistic format to `"auto"` in `.formats`. |
|
58 |
#' This utilizes the [format_auto()] formatting function. Note that only data for the current row & variable (for all |
|
59 |
#' columns) will be considered (`.df_row[[.var]]`, see [`rtables::additional_fun_params`]) and not the whole dataset. |
|
60 |
#' |
|
61 |
#' @inheritParams argument_convention |
|
62 |
#' @param .stats (`character`)\cr statistics to select for the table. |
|
63 |
#' |
|
64 |
#' Options for numeric variables are: ``r shQuote(get_stats("analyze_vars_numeric"), type = "sh")`` |
|
65 |
#' |
|
66 |
#' Options for non-numeric variables are: ``r shQuote(get_stats("analyze_vars_counts"), type = "sh")`` |
|
67 |
#' |
|
68 |
#' @name analyze_variables |
|
69 |
#' @order 1 |
|
70 |
NULL |
|
71 | ||
72 |
#' @describeIn analyze_variables S3 generic function to produces a variable summary. |
|
73 |
#' |
|
74 |
#' @return |
|
75 |
#' * `s_summary()` returns different statistics depending on the class of `x`. |
|
76 |
#' |
|
77 |
#' @export |
|
78 |
s_summary <- function(x, ...) { |
|
79 | 1697x |
UseMethod("s_summary", x) |
80 |
} |
|
81 | ||
82 |
#' @describeIn analyze_variables Method for `numeric` class. |
|
83 |
#' |
|
84 |
#' @param control (`list`)\cr parameters for descriptive statistics details, specified by using |
|
85 |
#' the helper function [control_analyze_vars()]. Some possible parameter options are: |
|
86 |
#' * `conf_level` (`proportion`)\cr confidence level of the interval for mean and median. |
|
87 |
#' * `quantiles` (`numeric(2)`)\cr vector of length two to specify the quantiles. |
|
88 |
#' * `quantile_type` (`numeric(1)`)\cr between 1 and 9 selecting quantile algorithms to be used. |
|
89 |
#' See more about `type` in [stats::quantile()]. |
|
90 |
#' * `test_mean` (`numeric(1)`)\cr value to test against the mean under the null hypothesis when calculating p-value. |
|
91 |
#' |
|
92 |
#' @return |
|
93 |
#' * If `x` is of class `numeric`, returns a `list` with the following named `numeric` items: |
|
94 |
#' * `n`: The [length()] of `x`. |
|
95 |
#' * `sum`: The [sum()] of `x`. |
|
96 |
#' * `mean`: The [mean()] of `x`. |
|
97 |
#' * `sd`: The [stats::sd()] of `x`. |
|
98 |
#' * `se`: The standard error of `x` mean, i.e.: (`sd(x) / sqrt(length(x))`). |
|
99 |
#' * `mean_sd`: The [mean()] and [stats::sd()] of `x`. |
|
100 |
#' * `mean_se`: The [mean()] of `x` and its standard error (see above). |
|
101 |
#' * `mean_ci`: The CI for the mean of `x` (from [stat_mean_ci()]). |
|
102 |
#' * `mean_sei`: The SE interval for the mean of `x`, i.e.: ([mean()] -/+ [stats::sd()] / [sqrt()]). |
|
103 |
#' * `mean_sdi`: The SD interval for the mean of `x`, i.e.: ([mean()] -/+ [stats::sd()]). |
|
104 |
#' * `mean_pval`: The two-sided p-value of the mean of `x` (from [stat_mean_pval()]). |
|
105 |
#' * `median`: The [stats::median()] of `x`. |
|
106 |
#' * `mad`: The median absolute deviation of `x`, i.e.: ([stats::median()] of `xc`, |
|
107 |
#' where `xc` = `x` - [stats::median()]). |
|
108 |
#' * `median_ci`: The CI for the median of `x` (from [stat_median_ci()]). |
|
109 |
#' * `quantiles`: Two sample quantiles of `x` (from [stats::quantile()]). |
|
110 |
#' * `iqr`: The [stats::IQR()] of `x`. |
|
111 |
#' * `range`: The [range_noinf()] of `x`. |
|
112 |
#' * `min`: The [max()] of `x`. |
|
113 |
#' * `max`: The [min()] of `x`. |
|
114 |
#' * `median_range`: The [median()] and [range_noinf()] of `x`. |
|
115 |
#' * `cv`: The coefficient of variation of `x`, i.e.: ([stats::sd()] / [mean()] * 100). |
|
116 |
#' * `geom_mean`: The geometric mean of `x`, i.e.: (`exp(mean(log(x)))`). |
|
117 |
#' * `geom_cv`: The geometric coefficient of variation of `x`, i.e.: (`sqrt(exp(sd(log(x)) ^ 2) - 1) * 100`). |
|
118 |
#' |
|
119 |
#' @note |
|
120 |
#' * If `x` is an empty vector, `NA` is returned. This is the expected feature so as to return `rcell` content in |
|
121 |
#' `rtables` when the intersection of a column and a row delimits an empty data selection. |
|
122 |
#' * When the `mean` function is applied to an empty vector, `NA` will be returned instead of `NaN`, the latter |
|
123 |
#' being standard behavior in R. |
|
124 |
#' |
|
125 |
#' @method s_summary numeric |
|
126 |
#' |
|
127 |
#' @examples |
|
128 |
#' # `s_summary.numeric` |
|
129 |
#' |
|
130 |
#' ## Basic usage: empty numeric returns NA-filled items. |
|
131 |
#' s_summary(numeric()) |
|
132 |
#' |
|
133 |
#' ## Management of NA values. |
|
134 |
#' x <- c(NA_real_, 1) |
|
135 |
#' s_summary(x, na_rm = TRUE) |
|
136 |
#' s_summary(x, na_rm = FALSE) |
|
137 |
#' |
|
138 |
#' x <- c(NA_real_, 1, 2) |
|
139 |
#' s_summary(x) |
|
140 |
#' |
|
141 |
#' ## Benefits in `rtables` contructions: |
|
142 |
#' dta_test <- data.frame( |
|
143 |
#' Group = rep(LETTERS[seq(3)], each = 2), |
|
144 |
#' sub_group = rep(letters[seq(2)], each = 3), |
|
145 |
#' x = seq(6) |
|
146 |
#' ) |
|
147 |
#' |
|
148 |
#' ## The summary obtained in with `rtables`: |
|
149 |
#' basic_table() %>% |
|
150 |
#' split_cols_by(var = "Group") %>% |
|
151 |
#' split_rows_by(var = "sub_group") %>% |
|
152 |
#' analyze(vars = "x", afun = s_summary) %>% |
|
153 |
#' build_table(df = dta_test) |
|
154 |
#' |
|
155 |
#' ## By comparison with `lapply`: |
|
156 |
#' X <- split(dta_test, f = with(dta_test, interaction(Group, sub_group))) |
|
157 |
#' lapply(X, function(x) s_summary(x$x)) |
|
158 |
#' |
|
159 |
#' @export |
|
160 |
s_summary.numeric <- function(x, control = control_analyze_vars(), ...) { |
|
161 | 1179x |
checkmate::assert_numeric(x) |
162 | 1179x |
args_list <- list(...) |
163 | 1179x |
.N_row <- args_list[[".N_row"]] # nolint |
164 | 1179x |
.N_col <- args_list[[".N_col"]] # nolint |
165 | 1179x |
na_rm <- args_list[["na_rm"]] %||% TRUE |
166 | 1179x |
compare_with_ref_group <- args_list[["compare_with_ref_group"]] |
167 | ||
168 | 1179x |
if (na_rm) { |
169 | 1177x |
x <- x[!is.na(x)] |
170 |
} |
|
171 | ||
172 | 1179x |
y <- list() |
173 | ||
174 | 1179x |
y$n <- c("n" = length(x)) |
175 | ||
176 | 1179x |
y$sum <- c("sum" = ifelse(length(x) == 0, NA_real_, sum(x, na.rm = FALSE))) |
177 | ||
178 | 1179x |
y$mean <- c("mean" = ifelse(length(x) == 0, NA_real_, mean(x, na.rm = FALSE))) |
179 | ||
180 | 1179x |
y$sd <- c("sd" = stats::sd(x, na.rm = FALSE)) |
181 | ||
182 | 1179x |
y$se <- c("se" = stats::sd(x, na.rm = FALSE) / sqrt(length(stats::na.omit(x)))) |
183 | ||
184 | 1179x |
y$mean_sd <- c(y$mean, "sd" = stats::sd(x, na.rm = FALSE)) |
185 | ||
186 | 1179x |
y$mean_se <- c(y$mean, y$se) |
187 | ||
188 | 1179x |
mean_ci <- stat_mean_ci(x, conf_level = control$conf_level, na.rm = FALSE, gg_helper = FALSE) |
189 | 1179x |
y$mean_ci <- formatters::with_label(mean_ci, paste("Mean", f_conf_level(control$conf_level))) |
190 | ||
191 | 1179x |
mean_sei <- y$mean[[1]] + c(-1, 1) * stats::sd(x, na.rm = FALSE) / sqrt(y$n) |
192 | 1179x |
names(mean_sei) <- c("mean_sei_lwr", "mean_sei_upr") |
193 | 1179x |
y$mean_sei <- formatters::with_label(mean_sei, "Mean -/+ 1xSE") |
194 | ||
195 | 1179x |
mean_sdi <- y$mean[[1]] + c(-1, 1) * stats::sd(x, na.rm = FALSE) |
196 | 1179x |
names(mean_sdi) <- c("mean_sdi_lwr", "mean_sdi_upr") |
197 | 1179x |
y$mean_sdi <- formatters::with_label(mean_sdi, "Mean -/+ 1xSD") |
198 | 1179x |
mean_ci_3d <- c(y$mean, y$mean_ci) |
199 | 1179x |
y$mean_ci_3d <- formatters::with_label(mean_ci_3d, paste0("Mean (", f_conf_level(control$conf_level), ")")) |
200 | ||
201 | 1179x |
mean_pval <- stat_mean_pval(x, test_mean = control$test_mean, na.rm = FALSE, n_min = 2) |
202 | 1179x |
y$mean_pval <- formatters::with_label(mean_pval, paste("Mean", f_pval(control$test_mean))) |
203 | ||
204 | 1179x |
y$median <- c("median" = stats::median(x, na.rm = FALSE)) |
205 | ||
206 | 1179x |
y$mad <- c("mad" = stats::median(x - y$median, na.rm = FALSE)) |
207 | ||
208 | 1179x |
median_ci <- stat_median_ci(x, conf_level = control$conf_level, na.rm = FALSE, gg_helper = FALSE) |
209 | 1179x |
y$median_ci <- formatters::with_label(median_ci, paste("Median", f_conf_level(control$conf_level))) |
210 | ||
211 | 1179x |
median_ci_3d <- c(y$median, median_ci) |
212 | 1179x |
y$median_ci_3d <- formatters::with_label(median_ci_3d, paste0("Median (", f_conf_level(control$conf_level), ")")) |
213 | ||
214 | 1179x |
q <- control$quantiles |
215 | 1179x |
if (any(is.na(x))) { |
216 | 2x |
qnts <- rep(NA_real_, length(q)) |
217 |
} else { |
|
218 | 1177x |
qnts <- stats::quantile(x, probs = q, type = control$quantile_type, na.rm = FALSE) |
219 |
} |
|
220 | 1179x |
names(qnts) <- paste("quantile", q, sep = "_") |
221 | 1179x |
y$quantiles <- formatters::with_label(qnts, paste0(paste(paste0(q * 100, "%"), collapse = " and "), "-ile")) |
222 | ||
223 | 1179x |
y$iqr <- c("iqr" = ifelse( |
224 | 1179x |
any(is.na(x)), |
225 | 1179x |
NA_real_, |
226 | 1179x |
stats::IQR(x, na.rm = FALSE, type = control$quantile_type) |
227 |
)) |
|
228 | ||
229 | 1179x |
y$range <- stats::setNames(range_noinf(x, na.rm = FALSE), c("min", "max")) |
230 | 1179x |
y$min <- y$range[1] |
231 | 1179x |
y$max <- y$range[2] |
232 | ||
233 | 1179x |
y$median_range <- formatters::with_label(c(y$median, y$range), "Median (Min - Max)") |
234 | ||
235 | 1179x |
y$cv <- c("cv" = unname(y$sd) / unname(y$mean) * 100) |
236 | ||
237 |
# Geometric Mean - Convert negative values to NA for log calculation. |
|
238 | 1179x |
geom_verbose <- args_list[["geom_verbose"]] %||% FALSE # Additional info if requested |
239 | 1179x |
checkmate::assert_flag(geom_verbose) |
240 | 1179x |
x_no_negative_vals <- x |
241 | 1179x |
if (identical(x_no_negative_vals, numeric())) { |
242 | 76x |
x_no_negative_vals <- NA |
243 |
} |
|
244 | 1179x |
x_no_negative_vals[x_no_negative_vals <= 0] <- NA |
245 | 1179x |
if (geom_verbose) { |
246 | 2x |
if (any(x <= 0)) { |
247 | 2x |
warning("Negative values were converted to NA for calculation of the geometric mean.") |
248 |
} |
|
249 | 2x |
if (all(is.na(x_no_negative_vals))) { |
250 | 1x |
warning("Since all values are negative or NA, the geometric mean is NA.") |
251 |
} |
|
252 |
} |
|
253 | 1179x |
y$geom_mean <- c("geom_mean" = exp(mean(log(x_no_negative_vals), na.rm = FALSE))) |
254 | 1179x |
y$geom_sd <- c("geom_sd" = geom_sd <- exp(sd(log(x_no_negative_vals), na.rm = FALSE))) |
255 | 1179x |
y$geom_mean_sd <- c(y$geom_mean, y$geom_sd) |
256 | 1179x |
geom_mean_ci <- stat_mean_ci(x, conf_level = control$conf_level, na.rm = FALSE, gg_helper = FALSE, geom_mean = TRUE) |
257 | 1179x |
y$geom_mean_ci <- formatters::with_label(geom_mean_ci, paste("Geometric Mean", f_conf_level(control$conf_level))) |
258 | ||
259 | 1179x |
y$geom_cv <- c("geom_cv" = sqrt(exp(stats::sd(log(x_no_negative_vals), na.rm = FALSE) ^ 2) - 1) * 100) # styler: off |
260 | ||
261 | 1179x |
geom_mean_ci_3d <- c(y$geom_mean, y$geom_mean_ci) |
262 | 1179x |
y$geom_mean_ci_3d <- formatters::with_label( |
263 | 1179x |
geom_mean_ci_3d, |
264 | 1179x |
paste0("Geometric Mean (", f_conf_level(control$conf_level), ")") |
265 |
) |
|
266 | ||
267 |
# Compare with reference group |
|
268 | 1179x |
if (isTRUE(compare_with_ref_group)) { |
269 | 13x |
.ref_group <- args_list[[".ref_group"]] |
270 | 13x |
.in_ref_col <- args_list[[".in_ref_col"]] |
271 | 13x |
checkmate::assert_numeric(.ref_group) |
272 | 13x |
checkmate::assert_flag(.in_ref_col) |
273 | ||
274 | 13x |
y$pval <- numeric() |
275 | 13x |
if (!.in_ref_col && n_available(x) > 1 && n_available(.ref_group) > 1) { |
276 | 9x |
y$pval <- stats::t.test(x, .ref_group)$p.value |
277 |
} |
|
278 |
} |
|
279 | ||
280 | 1179x |
y |
281 |
} |
|
282 | ||
283 |
#' @describeIn analyze_variables Method for `factor` class. |
|
284 |
#' |
|
285 |
#' @return |
|
286 |
#' * If `x` is of class `factor` or converted from `character`, returns a `list` with named `numeric` items: |
|
287 |
#' * `n`: The [length()] of `x`. |
|
288 |
#' * `count`: A list with the number of cases for each level of the factor `x`. |
|
289 |
#' * `count_fraction`: Similar to `count` but also includes the proportion of cases for each level of the |
|
290 |
#' factor `x` relative to the denominator, or `NA` if the denominator is zero. |
|
291 |
#' |
|
292 |
#' @note |
|
293 |
#' * If `x` is an empty `factor`, a list is still returned for `counts` with one element |
|
294 |
#' per factor level. If there are no levels in `x`, the function fails. |
|
295 |
#' * If factor variables contain `NA`, these `NA` values are excluded by default. To include `NA` values |
|
296 |
#' set `na_rm = FALSE` and missing values will be displayed as an `NA` level. Alternatively, an explicit |
|
297 |
#' factor level can be defined for `NA` values during pre-processing via [df_explicit_na()] - the |
|
298 |
#' default `na_level` (`"<Missing>"`) will also be excluded when `na_rm` is set to `TRUE`. |
|
299 |
#' |
|
300 |
#' @method s_summary factor |
|
301 |
#' |
|
302 |
#' @examples |
|
303 |
#' # `s_summary.factor` |
|
304 |
#' |
|
305 |
#' ## Basic usage: |
|
306 |
#' s_summary(factor(c("a", "a", "b", "c", "a"))) |
|
307 |
#' |
|
308 |
#' # Empty factor returns zero-filled items. |
|
309 |
#' s_summary(factor(levels = c("a", "b", "c"))) |
|
310 |
#' |
|
311 |
#' ## Management of NA values. |
|
312 |
#' x <- factor(c(NA, "Female")) |
|
313 |
#' x <- explicit_na(x) |
|
314 |
#' s_summary(x, na_rm = TRUE) |
|
315 |
#' s_summary(x, na_rm = FALSE) |
|
316 |
#' |
|
317 |
#' ## Different denominators. |
|
318 |
#' x <- factor(c("a", "a", "b", "c", "a")) |
|
319 |
#' s_summary(x, denom = "N_row", .N_row = 10L) |
|
320 |
#' s_summary(x, denom = "N_col", .N_col = 20L) |
|
321 |
#' |
|
322 |
#' @export |
|
323 |
s_summary.factor <- function(x, denom = c("n", "N_col", "N_row"), ...) { |
|
324 | 304x |
assert_valid_factor(x) |
325 | 301x |
args_list <- list(...) |
326 | 301x |
.N_row <- args_list[[".N_row"]] # nolint |
327 | 301x |
.N_col <- args_list[[".N_col"]] # nolint |
328 | 301x |
na_rm <- args_list[["na_rm"]] %||% TRUE |
329 | 301x |
verbose <- args_list[["verbose"]] %||% TRUE |
330 | 301x |
compare_with_ref_group <- args_list[["compare_with_ref_group"]] |
331 | ||
332 | 301x |
if (na_rm) { |
333 | 292x |
x <- x[!is.na(x)] %>% fct_discard("<Missing>") |
334 |
} else { |
|
335 | 9x |
x <- x %>% explicit_na(label = "NA") |
336 |
} |
|
337 | ||
338 | 301x |
y <- list() |
339 | ||
340 | 301x |
y$n <- list("n" = c("n" = length(x))) # all list of a list |
341 | ||
342 | 301x |
y$count <- lapply(as.list(table(x, useNA = "ifany")), setNames, nm = "count") |
343 | ||
344 | 301x |
denom <- match.arg(denom) %>% |
345 | 301x |
switch( |
346 | 301x |
n = length(x), |
347 | 301x |
N_row = .N_row, |
348 | 301x |
N_col = .N_col |
349 |
) |
|
350 | ||
351 | 301x |
y$count_fraction <- lapply( |
352 | 301x |
y$count, |
353 | 301x |
function(x) { |
354 | 2182x |
c(x, "p" = ifelse(denom > 0, x / denom, 0)) |
355 |
} |
|
356 |
) |
|
357 | ||
358 | 301x |
y$count_fraction_fixed_dp <- y$count_fraction |
359 | ||
360 | 301x |
y$fraction <- lapply( |
361 | 301x |
y$count, |
362 | 301x |
function(count) c("num" = unname(count), "denom" = denom) |
363 |
) |
|
364 | ||
365 | 301x |
y$n_blq <- list("n_blq" = c("n_blq" = sum(grepl("BLQ|LTR|<[1-9]|<PCLLOQ", x)))) |
366 | ||
367 | ||
368 | 301x |
if (isTRUE(compare_with_ref_group)) { |
369 | 16x |
.ref_group <- as_factor_keep_attributes(args_list[[".ref_group"]], verbose = verbose) |
370 | 16x |
.in_ref_col <- args_list[[".in_ref_col"]] |
371 | 16x |
checkmate::assert_flag(.in_ref_col) |
372 | 16x |
assert_valid_factor(x) |
373 | 16x |
assert_valid_factor(.ref_group) |
374 | ||
375 | 16x |
if (na_rm) { |
376 | 14x |
x <- x[!is.na(x)] %>% fct_discard("<Missing>") |
377 | 14x |
.ref_group <- .ref_group[!is.na(.ref_group)] %>% fct_discard("<Missing>") |
378 |
} else { |
|
379 | 2x |
x <- x %>% explicit_na(label = "NA") |
380 | 2x |
.ref_group <- .ref_group %>% explicit_na(label = "NA") |
381 |
} |
|
382 | ||
383 | 1x |
if ("NA" %in% levels(x)) levels(.ref_group) <- c(levels(.ref_group), "NA") |
384 | 16x |
checkmate::assert_factor(x, levels = levels(.ref_group), min.levels = 2) |
385 | ||
386 | 16x |
y$pval_counts <- numeric() |
387 | 16x |
if (!.in_ref_col && length(x) > 0 && length(.ref_group) > 0) { |
388 | 13x |
tab <- rbind(table(x), table(.ref_group)) |
389 | 13x |
res <- suppressWarnings(stats::chisq.test(tab)) |
390 | 13x |
y$pval_counts <- res$p.value |
391 |
} |
|
392 |
} |
|
393 | ||
394 | 301x |
y |
395 |
} |
|
396 | ||
397 |
#' @describeIn analyze_variables Method for `character` class. This makes an automatic |
|
398 |
#' conversion to factor (with a warning) and then forwards to the method for factors. |
|
399 |
#' |
|
400 |
#' @note |
|
401 |
#' * Automatic conversion of character to factor does not guarantee that the table |
|
402 |
#' can be generated correctly. In particular for sparse tables this very likely can fail. |
|
403 |
#' It is therefore better to always pre-process the dataset such that factors are manually |
|
404 |
#' created from character variables before passing the dataset to [rtables::build_table()]. |
|
405 |
#' |
|
406 |
#' @method s_summary character |
|
407 |
#' |
|
408 |
#' @examples |
|
409 |
#' # `s_summary.character` |
|
410 |
#' |
|
411 |
#' ## Basic usage: |
|
412 |
#' s_summary(c("a", "a", "b", "c", "a"), verbose = FALSE) |
|
413 |
#' s_summary(c("a", "a", "b", "c", "a", ""), .var = "x", na_rm = FALSE, verbose = FALSE) |
|
414 |
#' |
|
415 |
#' @export |
|
416 |
s_summary.character <- function(x, denom = c("n", "N_col", "N_row"), ...) { |
|
417 | 12x |
args_list <- list(...) |
418 | 12x |
na_rm <- args_list[["na_rm"]] %||% TRUE |
419 | 12x |
verbose <- args_list[["verbose"]] %||% TRUE |
420 | ||
421 | 12x |
if (na_rm) { |
422 | 11x |
y <- as_factor_keep_attributes(x, verbose = verbose) |
423 |
} else { |
|
424 | 1x |
y <- as_factor_keep_attributes(x, verbose = verbose, na_level = "NA") |
425 |
} |
|
426 | ||
427 | 12x |
s_summary(x = y, denom = denom, ...) |
428 |
} |
|
429 | ||
430 |
#' @describeIn analyze_variables Method for `logical` class. |
|
431 |
#' |
|
432 |
#' @return |
|
433 |
#' * If `x` is of class `logical`, returns a `list` with named `numeric` items: |
|
434 |
#' * `n`: The [length()] of `x` (possibly after removing `NA`s). |
|
435 |
#' * `count`: Count of `TRUE` in `x`. |
|
436 |
#' * `count_fraction`: Count and proportion of `TRUE` in `x` relative to the denominator, or `NA` if the |
|
437 |
#' denominator is zero. Note that `NA`s in `x` are never counted or leading to `NA` here. |
|
438 |
#' |
|
439 |
#' @method s_summary logical |
|
440 |
#' |
|
441 |
#' @examples |
|
442 |
#' # `s_summary.logical` |
|
443 |
#' |
|
444 |
#' ## Basic usage: |
|
445 |
#' s_summary(c(TRUE, FALSE, TRUE, TRUE)) |
|
446 |
#' |
|
447 |
#' # Empty factor returns zero-filled items. |
|
448 |
#' s_summary(as.logical(c())) |
|
449 |
#' |
|
450 |
#' ## Management of NA values. |
|
451 |
#' x <- c(NA, TRUE, FALSE) |
|
452 |
#' s_summary(x, na_rm = TRUE) |
|
453 |
#' s_summary(x, na_rm = FALSE) |
|
454 |
#' |
|
455 |
#' ## Different denominators. |
|
456 |
#' x <- c(TRUE, FALSE, TRUE, TRUE) |
|
457 |
#' s_summary(x, denom = "N_row", .N_row = 10L) |
|
458 |
#' s_summary(x, denom = "N_col", .N_col = 20L) |
|
459 |
#' |
|
460 |
#' @export |
|
461 |
s_summary.logical <- function(x, denom = c("n", "N_col", "N_row"), ...) { |
|
462 | 211x |
checkmate::assert_logical(x) |
463 | 211x |
args_list <- list(...) |
464 | 211x |
.N_row <- args_list[[".N_row"]] # nolint |
465 | 211x |
.N_col <- args_list[[".N_col"]] # nolint |
466 | 211x |
na_rm <- args_list[["na_rm"]] %||% TRUE |
467 | 211x |
compare_with_ref_group <- args_list[["compare_with_ref_group"]] |
468 | ||
469 | 211x |
if (na_rm) { |
470 | 208x |
x <- x[!is.na(x)] |
471 |
} |
|
472 | ||
473 | 211x |
y <- list() |
474 | 211x |
y$n <- c("n" = length(x)) |
475 | 211x |
denom <- match.arg(denom) %>% |
476 | 211x |
switch( |
477 | 211x |
n = length(x), |
478 | 211x |
N_row = .N_row, |
479 | 211x |
N_col = .N_col |
480 |
) |
|
481 | 211x |
y$count <- c("count" = sum(x, na.rm = TRUE)) |
482 | 211x |
y$count_fraction <- c(y$count, "fraction" = ifelse(denom > 0, y$count / denom, 0)) |
483 | 211x |
y$count_fraction_fixed_dp <- y$count_fraction |
484 | 211x |
y$fraction <- c("num" = unname(y$count), "denom" = denom) |
485 | 211x |
y$n_blq <- c("n_blq" = 0L) |
486 | ||
487 | ||
488 | 211x |
if (isTRUE(compare_with_ref_group)) { |
489 | 4x |
.ref_group <- args_list[[".ref_group"]] |
490 | 4x |
.in_ref_col <- args_list[[".in_ref_col"]] |
491 | 4x |
checkmate::assert_flag(.in_ref_col) |
492 | ||
493 | 4x |
if (na_rm) { |
494 | 3x |
x <- stats::na.omit(x) |
495 | 3x |
.ref_group <- stats::na.omit(.ref_group) |
496 |
} else { |
|
497 | 1x |
x[is.na(x)] <- FALSE |
498 | 1x |
.ref_group[is.na(.ref_group)] <- FALSE |
499 |
} |
|
500 | ||
501 | 4x |
y$pval_counts <- numeric() |
502 | 4x |
if (!.in_ref_col && length(x) > 0 && length(.ref_group) > 0) { |
503 | 4x |
x <- factor(x, levels = c(TRUE, FALSE)) |
504 | 4x |
.ref_group <- factor(.ref_group, levels = c(TRUE, FALSE)) |
505 | 4x |
tbl <- rbind(table(x), table(.ref_group)) |
506 | 4x |
y$pval_counts <- suppressWarnings(prop_chisq(tbl)) |
507 |
} |
|
508 |
} |
|
509 | ||
510 | 211x |
y |
511 |
} |
|
512 | ||
513 |
#' @describeIn analyze_variables Formatted analysis function which is used as `afun` in `analyze_vars()` and |
|
514 |
#' `compare_vars()` and as `cfun` in `summarize_colvars()`. |
|
515 |
#' |
|
516 |
#' @param compare_with_ref_group (`flag`)\cr whether comparison statistics should be analyzed instead of summary |
|
517 |
#' statistics (`compare_with_ref_group = TRUE` adds `pval` statistic comparing |
|
518 |
#' against reference group). |
|
519 |
#' |
|
520 |
#' @return |
|
521 |
#' * `a_summary()` returns the corresponding list with formatted [rtables::CellValue()]. |
|
522 |
#' |
|
523 |
#' @note |
|
524 |
#' * To use for comparison (with additional p-value statistic), parameter |
|
525 |
#' `compare_with_ref_group` must be set to `TRUE`. |
|
526 |
#' * Ensure that either all `NA` values are converted to an explicit `NA` level or all `NA` values are left as is. |
|
527 |
#' |
|
528 |
#' @examples |
|
529 |
#' a_summary(factor(c("a", "a", "b", "c", "a")), .N_row = 10, .N_col = 10) |
|
530 |
#' a_summary( |
|
531 |
#' factor(c("a", "a", "b", "c", "a")), |
|
532 |
#' .ref_group = factor(c("a", "a", "b", "c")), compare_with_ref_group = TRUE, .in_ref_col = TRUE |
|
533 |
#' ) |
|
534 |
#' |
|
535 |
#' a_summary(c("A", "B", "A", "C"), .var = "x", .N_col = 10, .N_row = 10, verbose = FALSE) |
|
536 |
#' a_summary( |
|
537 |
#' c("A", "B", "A", "C"), |
|
538 |
#' .ref_group = c("B", "A", "C"), .var = "x", compare_with_ref_group = TRUE, verbose = FALSE, |
|
539 |
#' .in_ref_col = FALSE |
|
540 |
#' ) |
|
541 |
#' |
|
542 |
#' a_summary(c(TRUE, FALSE, FALSE, TRUE, TRUE), .N_row = 10, .N_col = 10) |
|
543 |
#' a_summary( |
|
544 |
#' c(TRUE, FALSE, FALSE, TRUE, TRUE), |
|
545 |
#' .ref_group = c(TRUE, FALSE), .in_ref_col = TRUE, compare_with_ref_group = TRUE, |
|
546 |
#' .in_ref_col = FALSE |
|
547 |
#' ) |
|
548 |
#' |
|
549 |
#' a_summary(rnorm(10), .N_col = 10, .N_row = 20, .var = "bla") |
|
550 |
#' a_summary(rnorm(10, 5, 1), |
|
551 |
#' .ref_group = rnorm(20, -5, 1), .var = "bla", compare_with_ref_group = TRUE, |
|
552 |
#' .in_ref_col = FALSE |
|
553 |
#' ) |
|
554 |
#' |
|
555 |
#' @export |
|
556 |
a_summary <- function(x, |
|
557 |
..., |
|
558 |
.stats = NULL, |
|
559 |
.stat_names = NULL, |
|
560 |
.formats = NULL, |
|
561 |
.labels = NULL, |
|
562 |
.indent_mods = NULL) { |
|
563 | 332x |
dots_extra_args <- list(...) |
564 | ||
565 |
# Check if there are user-defined functions |
|
566 | 332x |
default_and_custom_stats_list <- .split_std_from_custom_stats(.stats) |
567 | 332x |
.stats <- default_and_custom_stats_list$all_stats # just the labels of stats |
568 | 332x |
custom_stat_functions <- default_and_custom_stats_list$custom_stats |
569 | ||
570 |
# Correction of the pval indication if it is numeric or counts |
|
571 | 332x |
type <- ifelse(is.numeric(x), "numeric", "counts") # counts is "categorical" |
572 | 332x |
.stats <- .correct_num_or_counts_pval(type, .stats) |
573 | ||
574 |
# Adding automatically extra parameters to the statistic function (see ?rtables::additional_fun_params) |
|
575 | 332x |
extra_afun_params <- retrieve_extra_afun_params( |
576 | 332x |
names(dots_extra_args$.additional_fun_parameters) |
577 |
) |
|
578 | 332x |
dots_extra_args$.additional_fun_parameters <- NULL # After extraction we do not need them anymore |
579 | ||
580 |
# Check if compare_with_ref_group is TRUE but no ref col is set |
|
581 | 332x |
if (isTRUE(dots_extra_args$compare_with_ref_group) && |
582 | 332x |
all( |
583 | 332x |
length(dots_extra_args[[".ref_group"]]) == 0, # only used for testing |
584 | 332x |
length(extra_afun_params[[".ref_group"]]) == 0 |
585 |
) |
|
586 |
) { |
|
587 | ! |
stop( |
588 | ! |
"For comparison (compare_with_ref_group = TRUE), the reference group must be specified.", |
589 | ! |
"\nSee ref_group in split_cols_by()." |
590 |
) |
|
591 |
} |
|
592 | ||
593 |
# Main statistical functions application |
|
594 | 332x |
x_stats <- .apply_stat_functions( |
595 | 332x |
default_stat_fnc = s_summary, |
596 | 332x |
custom_stat_fnc_list = custom_stat_functions, |
597 | 332x |
args_list = c( |
598 | 332x |
x = list(x), |
599 | 332x |
extra_afun_params, |
600 | 332x |
dots_extra_args |
601 |
) |
|
602 |
) |
|
603 | ||
604 |
# Fill in with stats defaults if needed |
|
605 | 332x |
met_grp <- paste0(c("analyze_vars", type), collapse = "_") |
606 | 332x |
.stats <- get_stats( |
607 | 332x |
met_grp, |
608 | 332x |
stats_in = .stats, |
609 | 332x |
custom_stats_in = names(custom_stat_functions), |
610 | 332x |
add_pval = dots_extra_args$compare_with_ref_group %||% FALSE |
611 |
) |
|
612 | ||
613 | 332x |
x_stats <- x_stats[.stats] |
614 | ||
615 | 332x |
is_char <- is.character(x) || is.factor(x) |
616 | 332x |
if (is_char) { |
617 | 236x |
levels_per_stats <- lapply(x_stats, names) |
618 |
} else { |
|
619 | 96x |
levels_per_stats <- names(x_stats) %>% |
620 | 96x |
as.list() %>% |
621 | 96x |
setNames(names(x_stats)) |
622 |
} |
|
623 | ||
624 |
# Fill in formats/indents/labels with custom input and defaults |
|
625 | 332x |
.formats <- get_formats_from_stats(.stats, .formats, levels_per_stats) |
626 | 332x |
.indent_mods <- get_indents_from_stats(.stats, .indent_mods, levels_per_stats) |
627 | 332x |
lbls <- get_labels_from_stats(.stats, .labels, levels_per_stats) |
628 | ||
629 | 332x |
if (is_char) { |
630 |
# Keep pval_counts stat if present from comparisons and empty |
|
631 | 236x |
if ("pval_counts" %in% names(x_stats) && length(x_stats[["pval_counts"]]) == 0) { |
632 | 3x |
x_stats[["pval_counts"]] <- list(NULL) %>% setNames("pval_counts") |
633 |
} |
|
634 | ||
635 |
# Unlist stats |
|
636 | 236x |
x_stats <- x_stats %>% |
637 | 236x |
.unlist_keep_nulls() %>% |
638 | 236x |
setNames(names(.formats)) |
639 |
} |
|
640 | ||
641 |
# Check for custom labels from control_analyze_vars |
|
642 | 332x |
.labels <- if ("control" %in% names(dots_extra_args)) { |
643 | 2x |
labels_use_control(lbls, dots_extra_args[["control"]], .labels) |
644 |
} else { |
|
645 | 330x |
lbls |
646 |
} |
|
647 | ||
648 |
# Auto format handling |
|
649 | 332x |
.formats <- apply_auto_formatting( |
650 | 332x |
.formats, |
651 | 332x |
x_stats, |
652 | 332x |
extra_afun_params$.df_row, |
653 | 332x |
extra_afun_params$.var |
654 |
) |
|
655 | ||
656 |
# Get and check statistical names from defaults |
|
657 | 332x |
.stat_names <- get_stat_names(x_stats, .stat_names) |
658 | ||
659 | 332x |
in_rows( |
660 | 332x |
.list = x_stats, |
661 | 332x |
.formats = .formats, |
662 | 332x |
.names = names(.labels), |
663 | 332x |
.stat_names = .stat_names, |
664 | 332x |
.labels = .labels %>% .unlist_keep_nulls(), |
665 | 332x |
.indent_mods = .indent_mods %>% .unlist_keep_nulls() |
666 |
) |
|
667 |
} |
|
668 | ||
669 |
#' @describeIn analyze_variables Layout-creating function which can take statistics function arguments |
|
670 |
#' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
|
671 |
#' |
|
672 |
#' @param ... additional arguments passed to `s_summary()`, including: |
|
673 |
#' * `denom`: (`string`) See parameter description below. |
|
674 |
#' * `.N_row`: (`numeric(1)`) Row-wise N (row group count) for the group of observations being analyzed (i.e. with no |
|
675 |
#' column-based subsetting). |
|
676 |
#' * `.N_col`: (`numeric(1)`) Column-wise N (column count) for the full column being tabulated within. |
|
677 |
#' * `verbose`: (`flag`) Whether additional warnings and messages should be printed. Mainly used to print out |
|
678 |
#' information about factor casting. Defaults to `TRUE`. Used for `character`/`factor` variables only. |
|
679 |
#' @param compare_with_ref_group (logical)\cr whether to compare the variable with a reference group. |
|
680 |
#' @param .indent_mods (named `integer`)\cr indent modifiers for the labels. Each element of the vector |
|
681 |
#' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation |
|
682 |
#' for that statistic's row label. |
|
683 |
#' |
|
684 |
#' @return |
|
685 |
#' * `analyze_vars()` returns a layout object suitable for passing to further layouting functions, |
|
686 |
#' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
|
687 |
#' the statistics from `s_summary()` to the table layout. |
|
688 |
#' |
|
689 |
#' @examples |
|
690 |
#' ## Fabricated dataset. |
|
691 |
#' dta_test <- data.frame( |
|
692 |
#' USUBJID = rep(1:6, each = 3), |
|
693 |
#' PARAMCD = rep("lab", 6 * 3), |
|
694 |
#' AVISIT = rep(paste0("V", 1:3), 6), |
|
695 |
#' ARM = rep(LETTERS[1:3], rep(6, 3)), |
|
696 |
#' AVAL = c(9:1, rep(NA, 9)) |
|
697 |
#' ) |
|
698 |
#' |
|
699 |
#' # `analyze_vars()` in `rtables` pipelines |
|
700 |
#' ## Default output within a `rtables` pipeline. |
|
701 |
#' l <- basic_table() %>% |
|
702 |
#' split_cols_by(var = "ARM") %>% |
|
703 |
#' split_rows_by(var = "AVISIT") %>% |
|
704 |
#' analyze_vars(vars = "AVAL") |
|
705 |
#' |
|
706 |
#' build_table(l, df = dta_test) |
|
707 |
#' |
|
708 |
#' ## Select and format statistics output. |
|
709 |
#' l <- basic_table() %>% |
|
710 |
#' split_cols_by(var = "ARM") %>% |
|
711 |
#' split_rows_by(var = "AVISIT") %>% |
|
712 |
#' analyze_vars( |
|
713 |
#' vars = "AVAL", |
|
714 |
#' .stats = c("n", "mean_sd", "quantiles"), |
|
715 |
#' .formats = c("mean_sd" = "xx.x, xx.x"), |
|
716 |
#' .labels = c(n = "n", mean_sd = "Mean, SD", quantiles = c("Q1 - Q3")) |
|
717 |
#' ) |
|
718 |
#' |
|
719 |
#' build_table(l, df = dta_test) |
|
720 |
#' |
|
721 |
#' ## Use arguments interpreted by `s_summary`. |
|
722 |
#' l <- basic_table() %>% |
|
723 |
#' split_cols_by(var = "ARM") %>% |
|
724 |
#' split_rows_by(var = "AVISIT") %>% |
|
725 |
#' analyze_vars(vars = "AVAL", na_rm = FALSE) |
|
726 |
#' |
|
727 |
#' build_table(l, df = dta_test) |
|
728 |
#' |
|
729 |
#' ## Handle `NA` levels first when summarizing factors. |
|
730 |
#' dta_test$AVISIT <- NA_character_ |
|
731 |
#' dta_test <- df_explicit_na(dta_test) |
|
732 |
#' l <- basic_table() %>% |
|
733 |
#' split_cols_by(var = "ARM") %>% |
|
734 |
#' analyze_vars(vars = "AVISIT", na_rm = FALSE) |
|
735 |
#' |
|
736 |
#' build_table(l, df = dta_test) |
|
737 |
#' |
|
738 |
#' # auto format |
|
739 |
#' dt <- data.frame("VAR" = c(0.001, 0.2, 0.0011000, 3, 4)) |
|
740 |
#' basic_table() %>% |
|
741 |
#' analyze_vars( |
|
742 |
#' vars = "VAR", |
|
743 |
#' .stats = c("n", "mean", "mean_sd", "range"), |
|
744 |
#' .formats = c("mean_sd" = "auto", "range" = "auto") |
|
745 |
#' ) %>% |
|
746 |
#' build_table(dt) |
|
747 |
#' |
|
748 |
#' @export |
|
749 |
#' @order 2 |
|
750 |
analyze_vars <- function(lyt, |
|
751 |
vars, |
|
752 |
var_labels = vars, |
|
753 |
na_str = default_na_str(), |
|
754 |
nested = TRUE, |
|
755 |
show_labels = "default", |
|
756 |
table_names = vars, |
|
757 |
section_div = NA_character_, |
|
758 |
..., |
|
759 |
na_rm = TRUE, |
|
760 |
compare_with_ref_group = FALSE, |
|
761 |
.stats = c("n", "mean_sd", "median", "range", "count_fraction"), |
|
762 |
.stat_names = NULL, |
|
763 |
.formats = NULL, |
|
764 |
.labels = NULL, |
|
765 |
.indent_mods = NULL) { |
|
766 |
# Depending on main functions |
|
767 | 40x |
extra_args <- list( |
768 | 40x |
"na_rm" = na_rm, |
769 | 40x |
"compare_with_ref_group" = compare_with_ref_group, |
770 |
... |
|
771 |
) |
|
772 | ||
773 |
# Needed defaults |
|
774 | 40x |
if (!is.null(.stats)) extra_args[[".stats"]] <- .stats |
775 | 3x |
if (!is.null(.stat_names)) extra_args[[".stat_names"]] <- .stat_names |
776 | 9x |
if (!is.null(.formats)) extra_args[[".formats"]] <- .formats |
777 | 4x |
if (!is.null(.labels)) extra_args[[".labels"]] <- .labels |
778 | ! |
if (!is.null(.indent_mods)) extra_args[[".indent_mods"]] <- .indent_mods |
779 | ||
780 |
# Adding all additional information from layout to analysis functions (see ?rtables::additional_fun_params) |
|
781 | 40x |
extra_args[[".additional_fun_parameters"]] <- get_additional_afun_params(add_alt_df = FALSE) |
782 | 40x |
formals(a_summary) <- c( |
783 | 40x |
formals(a_summary), |
784 | 40x |
extra_args[[".additional_fun_parameters"]] |
785 |
) |
|
786 | ||
787 |
# Main {rtables} structural call |
|
788 | 40x |
analyze( |
789 | 40x |
lyt = lyt, |
790 | 40x |
vars = vars, |
791 | 40x |
var_labels = var_labels, |
792 | 40x |
afun = a_summary, |
793 | 40x |
na_str = na_str, |
794 | 40x |
inclNAs = !na_rm, |
795 | 40x |
nested = nested, |
796 | 40x |
extra_args = extra_args, |
797 | 40x |
show_labels = show_labels, |
798 | 40x |
table_names = table_names, |
799 | 40x |
section_div = section_div |
800 |
) |
|
801 |
} |
1 |
#' Formatting functions |
|
2 |
#' |
|
3 |
#' See below for the list of formatting functions created in `tern` to work with `rtables`. |
|
4 |
#' |
|
5 |
#' Other available formats can be listed via [`formatters::list_valid_format_labels()`]. Additional |
|
6 |
#' custom formats can be created via the [`formatters::sprintf_format()`] function. |
|
7 |
#' |
|
8 |
#' @family formatting functions |
|
9 |
#' @name formatting_functions |
|
10 |
NULL |
|
11 | ||
12 |
#' Format fraction and percentage |
|
13 |
#' |
|
14 |
#' @description `r lifecycle::badge("stable")` |
|
15 |
#' |
|
16 |
#' Formats a fraction together with ratio in percent. |
|
17 |
#' |
|
18 |
#' @param x (named `integer`)\cr vector with elements `num` and `denom`. |
|
19 |
#' @param ... not used. Required for `rtables` interface. |
|
20 |
#' |
|
21 |
#' @return A string in the format `num / denom (ratio %)`. If `num` is 0, the format is `num / denom`. |
|
22 |
#' |
|
23 |
#' @examples |
|
24 |
#' format_fraction(x = c(num = 2L, denom = 3L)) |
|
25 |
#' format_fraction(x = c(num = 0L, denom = 3L)) |
|
26 |
#' |
|
27 |
#' @family formatting functions |
|
28 |
#' @export |
|
29 |
format_fraction <- function(x, ...) { |
|
30 | 220x |
attr(x, "label") <- NULL |
31 | ||
32 | 220x |
checkmate::assert_vector(x) |
33 | 220x |
checkmate::assert_count(x["num"]) |
34 | 218x |
checkmate::assert_count(x["denom"]) |
35 | ||
36 | 218x |
result <- if (x["num"] == 0) { |
37 | 10x |
paste0(x["num"], "/", x["denom"]) |
38 |
} else { |
|
39 | 208x |
paste0( |
40 | 208x |
x["num"], "/", x["denom"], |
41 | 208x |
" (", round(x["num"] / x["denom"] * 100, 1), "%)" |
42 |
) |
|
43 |
} |
|
44 | ||
45 | 218x |
return(result) |
46 |
} |
|
47 | ||
48 |
#' Format fraction and percentage with fixed single decimal place |
|
49 |
#' |
|
50 |
#' @description `r lifecycle::badge("stable")` |
|
51 |
#' |
|
52 |
#' Formats a fraction together with ratio in percent with fixed single decimal place. |
|
53 |
#' Includes trailing zero in case of whole number percentages to always keep one decimal place. |
|
54 |
#' |
|
55 |
#' @inheritParams format_fraction |
|
56 |
#' |
|
57 |
#' @return A string in the format `num / denom (ratio %)`. If `num` is 0, the format is `num / denom`. |
|
58 |
#' |
|
59 |
#' @examples |
|
60 |
#' format_fraction_fixed_dp(x = c(num = 1L, denom = 2L)) |
|
61 |
#' format_fraction_fixed_dp(x = c(num = 1L, denom = 4L)) |
|
62 |
#' format_fraction_fixed_dp(x = c(num = 0L, denom = 3L)) |
|
63 |
#' |
|
64 |
#' @family formatting functions |
|
65 |
#' @export |
|
66 |
format_fraction_fixed_dp <- function(x, ...) { |
|
67 | 3x |
attr(x, "label") <- NULL |
68 | 3x |
checkmate::assert_vector(x) |
69 | 3x |
checkmate::assert_count(x["num"]) |
70 | 3x |
checkmate::assert_count(x["denom"]) |
71 | ||
72 | 3x |
result <- if (x["num"] == 0) { |
73 | 1x |
paste0(x["num"], "/", x["denom"]) |
74 |
} else { |
|
75 | 2x |
paste0( |
76 | 2x |
x["num"], "/", x["denom"], |
77 | 2x |
" (", sprintf("%.1f", round(x["num"] / x["denom"] * 100, 1)), "%)" |
78 |
) |
|
79 |
} |
|
80 | 3x |
return(result) |
81 |
} |
|
82 | ||
83 |
#' Format count and fraction |
|
84 |
#' |
|
85 |
#' @description `r lifecycle::badge("stable")` |
|
86 |
#' |
|
87 |
#' Formats a count together with fraction with special consideration when count is `0`. |
|
88 |
#' |
|
89 |
#' @param x (`numeric(2)`)\cr vector of length 2 with count and fraction, respectively. |
|
90 |
#' @param ... not used. Required for `rtables` interface. |
|
91 |
#' |
|
92 |
#' @return A string in the format `count (fraction %)`. If `count` is 0, the format is `0`. |
|
93 |
#' |
|
94 |
#' @examples |
|
95 |
#' format_count_fraction(x = c(2, 0.6667)) |
|
96 |
#' format_count_fraction(x = c(0, 0)) |
|
97 |
#' |
|
98 |
#' @family formatting functions |
|
99 |
#' @export |
|
100 |
format_count_fraction <- function(x, ...) { |
|
101 | 102x |
attr(x, "label") <- NULL |
102 | ||
103 | 102x |
if (any(is.na(x))) { |
104 | 1x |
return("NA") |
105 |
} |
|
106 | ||
107 | 101x |
checkmate::assert_vector(x) |
108 | 101x |
checkmate::assert_integerish(x[1]) |
109 | 101x |
assert_proportion_value(x[2], include_boundaries = TRUE) |
110 | ||
111 | 101x |
result <- if (x[1] == 0) { |
112 | 13x |
"0" |
113 |
} else { |
|
114 | 88x |
paste0(x[1], " (", round(x[2] * 100, 1), "%)") |
115 |
} |
|
116 | ||
117 | 101x |
return(result) |
118 |
} |
|
119 | ||
120 |
#' Format count and percentage with fixed single decimal place |
|
121 |
#' |
|
122 |
#' @description `r lifecycle::badge("experimental")` |
|
123 |
#' |
|
124 |
#' Formats a count together with fraction with special consideration when count is `0`. |
|
125 |
#' |
|
126 |
#' @inheritParams format_count_fraction |
|
127 |
#' |
|
128 |
#' @return A string in the format `count (fraction %)`. If `count` is 0, the format is `0`. |
|
129 |
#' |
|
130 |
#' @examples |
|
131 |
#' format_count_fraction_fixed_dp(x = c(2, 0.6667)) |
|
132 |
#' format_count_fraction_fixed_dp(x = c(2, 0.5)) |
|
133 |
#' format_count_fraction_fixed_dp(x = c(0, 0)) |
|
134 |
#' |
|
135 |
#' @family formatting functions |
|
136 |
#' @export |
|
137 |
format_count_fraction_fixed_dp <- function(x, ...) { |
|
138 | 1408x |
attr(x, "label") <- NULL |
139 | ||
140 | 1408x |
if (any(is.na(x))) { |
141 | ! |
return("NA") |
142 |
} |
|
143 | ||
144 | 1408x |
checkmate::assert_vector(x) |
145 | 1408x |
checkmate::assert_integerish(x[1]) |
146 | 1408x |
assert_proportion_value(x[2], include_boundaries = TRUE) |
147 | ||
148 | 1408x |
result <- if (x[1] == 0) { |
149 | 195x |
"0" |
150 | 1408x |
} else if (.is_equal_float(x[2], 1)) { |
151 | 549x |
sprintf("%d (100%%)", x[1]) |
152 |
} else { |
|
153 | 664x |
sprintf("%d (%.1f%%)", x[1], x[2] * 100) |
154 |
} |
|
155 | ||
156 | 1408x |
return(result) |
157 |
} |
|
158 | ||
159 |
#' Format count and fraction with special case for count < 10 |
|
160 |
#' |
|
161 |
#' @description `r lifecycle::badge("stable")` |
|
162 |
#' |
|
163 |
#' Formats a count together with fraction with special consideration when count is less than 10. |
|
164 |
#' |
|
165 |
#' @inheritParams format_count_fraction |
|
166 |
#' |
|
167 |
#' @return A string in the format `count (fraction %)`. If `count` is less than 10, only `count` is printed. |
|
168 |
#' |
|
169 |
#' @examples |
|
170 |
#' format_count_fraction_lt10(x = c(275, 0.9673)) |
|
171 |
#' format_count_fraction_lt10(x = c(2, 0.6667)) |
|
172 |
#' format_count_fraction_lt10(x = c(9, 1)) |
|
173 |
#' |
|
174 |
#' @family formatting functions |
|
175 |
#' @export |
|
176 |
format_count_fraction_lt10 <- function(x, ...) { |
|
177 | 7x |
attr(x, "label") <- NULL |
178 | ||
179 | 7x |
if (any(is.na(x))) { |
180 | 1x |
return("NA") |
181 |
} |
|
182 | ||
183 | 6x |
checkmate::assert_vector(x) |
184 | 6x |
checkmate::assert_integerish(x[1]) |
185 | 6x |
assert_proportion_value(x[2], include_boundaries = TRUE) |
186 | ||
187 | 6x |
result <- if (x[1] < 10) { |
188 | 3x |
paste0(x[1]) |
189 |
} else { |
|
190 | 3x |
paste0(x[1], " (", round(x[2] * 100, 1), "%)") |
191 |
} |
|
192 | ||
193 | 6x |
return(result) |
194 |
} |
|
195 | ||
196 |
#' Format XX as a formatting function |
|
197 |
#' |
|
198 |
#' Translate a string where x and dots are interpreted as number place |
|
199 |
#' holders, and others as formatting elements. |
|
200 |
#' |
|
201 |
#' @param str (`string`)\cr template. |
|
202 |
#' |
|
203 |
#' @return An `rtables` formatting function. |
|
204 |
#' |
|
205 |
#' @examples |
|
206 |
#' test <- list(c(1.658, 0.5761), c(1e1, 785.6)) |
|
207 |
#' |
|
208 |
#' z <- format_xx("xx (xx.x)") |
|
209 |
#' sapply(test, z) |
|
210 |
#' |
|
211 |
#' z <- format_xx("xx.x - xx.x") |
|
212 |
#' sapply(test, z) |
|
213 |
#' |
|
214 |
#' z <- format_xx("xx.x, incl. xx.x% NE") |
|
215 |
#' sapply(test, z) |
|
216 |
#' |
|
217 |
#' @family formatting functions |
|
218 |
#' @export |
|
219 |
format_xx <- function(str) { |
|
220 |
# Find position in the string. |
|
221 | 1x |
positions <- gregexpr(pattern = "x+\\.x+|x+", text = str, perl = TRUE) |
222 | 1x |
x_positions <- regmatches(x = str, m = positions)[[1]] |
223 | ||
224 |
# Roundings depends on the number of x behind [.]. |
|
225 | 1x |
roundings <- lapply( |
226 | 1x |
X = x_positions, |
227 | 1x |
function(x) { |
228 | 2x |
y <- strsplit(split = "\\.", x = x)[[1]] |
229 | 2x |
rounding <- function(x) { |
230 | 4x |
round(x, digits = ifelse(length(y) > 1, nchar(y[2]), 0)) |
231 |
} |
|
232 | 2x |
return(rounding) |
233 |
} |
|
234 |
) |
|
235 | ||
236 | 1x |
rtable_format <- function(x, output) { |
237 | 2x |
values <- Map(y = x, fun = roundings, function(y, fun) fun(y)) |
238 | 2x |
regmatches(x = str, m = positions)[[1]] <- values |
239 | 2x |
return(str) |
240 |
} |
|
241 | ||
242 | 1x |
return(rtable_format) |
243 |
} |
|
244 | ||
245 |
#' Format numeric values by significant figures |
|
246 |
#' |
|
247 |
#' Format numeric values to print with a specified number of significant figures. |
|
248 |
#' |
|
249 |
#' @param sigfig (`integer(1)`)\cr number of significant figures to display. |
|
250 |
#' @param format (`string`)\cr the format label (string) to apply when printing the value. Decimal |
|
251 |
#' places in string are ignored in favor of formatting by significant figures. Formats options are: |
|
252 |
#' `"xx"`, `"xx / xx"`, `"(xx, xx)"`, `"xx - xx"`, and `"xx (xx)"`. |
|
253 |
#' @param num_fmt (`string`)\cr numeric format modifiers to apply to the value. Defaults to `"fg"` for |
|
254 |
#' standard significant figures formatting - fixed (non-scientific notation) format (`"f"`) |
|
255 |
#' and `sigfig` equal to number of significant figures instead of decimal places (`"g"`). See the |
|
256 |
#' [formatC()] `format` argument for more options. |
|
257 |
#' |
|
258 |
#' @return An `rtables` formatting function. |
|
259 |
#' |
|
260 |
#' @examples |
|
261 |
#' fmt_3sf <- format_sigfig(3) |
|
262 |
#' fmt_3sf(1.658) |
|
263 |
#' fmt_3sf(1e1) |
|
264 |
#' |
|
265 |
#' fmt_5sf <- format_sigfig(5) |
|
266 |
#' fmt_5sf(0.57) |
|
267 |
#' fmt_5sf(0.000025645) |
|
268 |
#' |
|
269 |
#' @family formatting functions |
|
270 |
#' @export |
|
271 |
format_sigfig <- function(sigfig, format = "xx", num_fmt = "fg") { |
|
272 | 3x |
checkmate::assert_integerish(sigfig) |
273 | 3x |
format <- gsub("xx\\.|xx\\.x+", "xx", format) |
274 | 3x |
checkmate::assert_choice(format, c("xx", "xx / xx", "(xx, xx)", "xx - xx", "xx (xx)")) |
275 | 3x |
function(x, ...) { |
276 | ! |
if (!is.numeric(x)) stop("`format_sigfig` cannot be used for non-numeric values. Please choose another format.") |
277 | 12x |
num <- formatC(signif(x, digits = sigfig), digits = sigfig, format = num_fmt, flag = "#") |
278 | 12x |
num <- gsub("\\.$", "", num) # remove trailing "." |
279 | ||
280 | 12x |
format_value(num, format) |
281 |
} |
|
282 |
} |
|
283 | ||
284 |
#' Format fraction with lower threshold |
|
285 |
#' |
|
286 |
#' @description `r lifecycle::badge("stable")` |
|
287 |
#' |
|
288 |
#' Formats a fraction when the second element of the input `x` is the fraction. It applies |
|
289 |
#' a lower threshold, below which it is just stated that the fraction is smaller than that. |
|
290 |
#' |
|
291 |
#' @param threshold (`proportion`)\cr lower threshold. |
|
292 |
#' |
|
293 |
#' @return An `rtables` formatting function that takes numeric input `x` where the second |
|
294 |
#' element is the fraction that is formatted. If the fraction is above or equal to the threshold, |
|
295 |
#' then it is displayed in percentage. If it is positive but below the threshold, it returns, |
|
296 |
#' e.g. "<1" if the threshold is `0.01`. If it is zero, then just "0" is returned. |
|
297 |
#' |
|
298 |
#' @examples |
|
299 |
#' format_fun <- format_fraction_threshold(0.05) |
|
300 |
#' format_fun(x = c(20, 0.1)) |
|
301 |
#' format_fun(x = c(2, 0.01)) |
|
302 |
#' format_fun(x = c(0, 0)) |
|
303 |
#' |
|
304 |
#' @family formatting functions |
|
305 |
#' @export |
|
306 |
format_fraction_threshold <- function(threshold) { |
|
307 | 1x |
assert_proportion_value(threshold) |
308 | 1x |
string_below_threshold <- paste0("<", round(threshold * 100)) |
309 | 1x |
function(x, ...) { |
310 | 3x |
assert_proportion_value(x[2], include_boundaries = TRUE) |
311 | 3x |
ifelse( |
312 | 3x |
x[2] > 0.01, |
313 | 3x |
round(x[2] * 100), |
314 | 3x |
ifelse( |
315 | 3x |
x[2] == 0, |
316 | 3x |
"0", |
317 | 3x |
string_below_threshold |
318 |
) |
|
319 |
) |
|
320 |
} |
|
321 |
} |
|
322 | ||
323 |
#' Format extreme values |
|
324 |
#' |
|
325 |
#' @description `r lifecycle::badge("stable")` |
|
326 |
#' |
|
327 |
#' `rtables` formatting functions that handle extreme values. |
|
328 |
#' |
|
329 |
#' @param digits (`integer(1)`)\cr number of decimal places to display. |
|
330 |
#' |
|
331 |
#' @details For each input, apply a format to the specified number of `digits`. If the value is |
|
332 |
#' below a threshold, it returns "<0.01" e.g. if the number of `digits` is 2. If the value is |
|
333 |
#' above a threshold, it returns ">999.99" e.g. if the number of `digits` is 2. |
|
334 |
#' If it is zero, then returns "0.00". |
|
335 |
#' |
|
336 |
#' @family formatting functions |
|
337 |
#' @name extreme_format |
|
338 |
NULL |
|
339 | ||
340 |
#' @describeIn extreme_format Internal helper function to calculate the threshold and create formatted strings |
|
341 |
#' used in Formatting Functions. Returns a list with elements `threshold` and `format_string`. |
|
342 |
#' |
|
343 |
#' @return |
|
344 |
#' * `h_get_format_threshold()` returns a `list` of 2 elements: `threshold`, with `low` and `high` thresholds, |
|
345 |
#' and `format_string`, with thresholds formatted as strings. |
|
346 |
#' |
|
347 |
#' @examples |
|
348 |
#' h_get_format_threshold(2L) |
|
349 |
#' |
|
350 |
#' @export |
|
351 |
h_get_format_threshold <- function(digits = 2L) { |
|
352 | 2013x |
checkmate::assert_integerish(digits) |
353 | ||
354 | 2013x |
low_threshold <- 1 / (10 ^ digits) # styler: off |
355 | 2013x |
high_threshold <- 1000 - (1 / (10 ^ digits)) # styler: off |
356 | ||
357 | 2013x |
string_below_threshold <- paste0("<", low_threshold) |
358 | 2013x |
string_above_threshold <- paste0(">", high_threshold) |
359 | ||
360 | 2013x |
list( |
361 | 2013x |
"threshold" = c(low = low_threshold, high = high_threshold), |
362 | 2013x |
"format_string" = c(low = string_below_threshold, high = string_above_threshold) |
363 |
) |
|
364 |
} |
|
365 | ||
366 |
#' @describeIn extreme_format Internal helper function to apply a threshold format to a value. |
|
367 |
#' Creates a formatted string to be used in Formatting Functions. |
|
368 |
#' |
|
369 |
#' @param x (`numeric(1)`)\cr value to format. |
|
370 |
#' |
|
371 |
#' @return |
|
372 |
#' * `h_format_threshold()` returns the given value, or if the value is not within the digit threshold the relation |
|
373 |
#' of the given value to the digit threshold, as a formatted string. |
|
374 |
#' |
|
375 |
#' @examples |
|
376 |
#' h_format_threshold(0.001) |
|
377 |
#' h_format_threshold(1000) |
|
378 |
#' |
|
379 |
#' @export |
|
380 |
h_format_threshold <- function(x, digits = 2L) { |
|
381 | 2015x |
if (is.na(x)) { |
382 | 4x |
return(x) |
383 |
} |
|
384 | ||
385 | 2011x |
checkmate::assert_numeric(x, lower = 0) |
386 | ||
387 | 2011x |
l_fmt <- h_get_format_threshold(digits) |
388 | ||
389 | 2011x |
result <- if (x < l_fmt$threshold["low"] && 0 < x) { |
390 | 44x |
l_fmt$format_string["low"] |
391 | 2011x |
} else if (x > l_fmt$threshold["high"]) { |
392 | 99x |
l_fmt$format_string["high"] |
393 |
} else { |
|
394 | 1868x |
sprintf(fmt = paste0("%.", digits, "f"), x) |
395 |
} |
|
396 | ||
397 | 2011x |
unname(result) |
398 |
} |
|
399 | ||
400 |
#' Format a single extreme value |
|
401 |
#' |
|
402 |
#' @description `r lifecycle::badge("stable")` |
|
403 |
#' |
|
404 |
#' Create a formatting function for a single extreme value. |
|
405 |
#' |
|
406 |
#' @inheritParams extreme_format |
|
407 |
#' |
|
408 |
#' @return An `rtables` formatting function that uses threshold `digits` to return a formatted extreme value. |
|
409 |
#' |
|
410 |
#' @examples |
|
411 |
#' format_fun <- format_extreme_values(2L) |
|
412 |
#' format_fun(x = 0.127) |
|
413 |
#' format_fun(x = Inf) |
|
414 |
#' format_fun(x = 0) |
|
415 |
#' format_fun(x = 0.009) |
|
416 |
#' |
|
417 |
#' @family formatting functions |
|
418 |
#' @export |
|
419 |
format_extreme_values <- function(digits = 2L) { |
|
420 | 1x |
function(x, ...) { |
421 | 5x |
checkmate::assert_scalar(x, na.ok = TRUE) |
422 | ||
423 | 5x |
h_format_threshold(x = x, digits = digits) |
424 |
} |
|
425 |
} |
|
426 | ||
427 |
#' Format extreme values part of a confidence interval |
|
428 |
#' |
|
429 |
#' @description `r lifecycle::badge("stable")` |
|
430 |
#' |
|
431 |
#' Formatting Function for extreme values part of a confidence interval. Values |
|
432 |
#' are formatted as e.g. "(xx.xx, xx.xx)" if the number of `digits` is 2. |
|
433 |
#' |
|
434 |
#' @inheritParams extreme_format |
|
435 |
#' |
|
436 |
#' @return An `rtables` formatting function that uses threshold `digits` to return a formatted extreme |
|
437 |
#' values confidence interval. |
|
438 |
#' |
|
439 |
#' @examples |
|
440 |
#' format_fun <- format_extreme_values_ci(2L) |
|
441 |
#' format_fun(x = c(0.127, Inf)) |
|
442 |
#' format_fun(x = c(0, 0.009)) |
|
443 |
#' |
|
444 |
#' @family formatting functions |
|
445 |
#' @export |
|
446 |
format_extreme_values_ci <- function(digits = 2L) { |
|
447 | 9x |
function(x, ...) { |
448 | 54x |
checkmate::assert_vector(x, len = 2) |
449 | 54x |
l_result <- h_format_threshold(x = x[1], digits = digits) |
450 | 54x |
h_result <- h_format_threshold(x = x[2], digits = digits) |
451 | ||
452 | 54x |
paste0("(", l_result, ", ", h_result, ")") |
453 |
} |
|
454 |
} |
|
455 | ||
456 |
#' Format automatically using data significant digits |
|
457 |
#' |
|
458 |
#' @description `r lifecycle::badge("stable")` |
|
459 |
#' |
|
460 |
#' Formatting function for the majority of default methods used in [analyze_vars()]. |
|
461 |
#' For non-derived values, the significant digits of data is used (e.g. range), while derived |
|
462 |
#' values have one more digits (measure of location and dispersion like mean, standard deviation). |
|
463 |
#' This function can be called internally with "auto" like, for example, |
|
464 |
#' `.formats = c("mean" = "auto")`. See details to see how this works with the inner function. |
|
465 |
#' |
|
466 |
#' @param dt_var (`numeric`)\cr variable data the statistics were calculated from. Used only to |
|
467 |
#' find significant digits. In [analyze_vars] this comes from `.df_row` (see |
|
468 |
#' [rtables::additional_fun_params]), and it is the row data after the above row splits. No |
|
469 |
#' column split is considered. |
|
470 |
#' @param x_stat (`string`)\cr string indicating the current statistical method used. |
|
471 |
#' |
|
472 |
#' @return A string that `rtables` prints in a table cell. |
|
473 |
#' |
|
474 |
#' @details |
|
475 |
#' The internal function is needed to work with `rtables` default structure for |
|
476 |
#' format functions, i.e. `function(x, ...)`, where is x are results from statistical evaluation. |
|
477 |
#' It can be more than one element (e.g. for `.stats = "mean_sd"`). |
|
478 |
#' |
|
479 |
#' @examples |
|
480 |
#' x_todo <- c(0.001, 0.2, 0.0011000, 3, 4) |
|
481 |
#' res <- c(mean(x_todo[1:3]), sd(x_todo[1:3])) |
|
482 |
#' |
|
483 |
#' # x is the result coming into the formatting function -> res!! |
|
484 |
#' format_auto(dt_var = x_todo, x_stat = "mean_sd")(x = res) |
|
485 |
#' format_auto(x_todo, "range")(x = range(x_todo)) |
|
486 |
#' no_sc_x <- c(0.0000001, 1) |
|
487 |
#' format_auto(no_sc_x, "range")(x = no_sc_x) |
|
488 |
#' |
|
489 |
#' @family formatting functions |
|
490 |
#' @export |
|
491 |
format_auto <- function(dt_var, x_stat) { |
|
492 | 16x |
function(x = "", ...) { |
493 | 56x |
checkmate::assert_numeric(x, min.len = 1) |
494 | 56x |
checkmate::assert_numeric(dt_var, min.len = 1) |
495 |
# Defaults - they may be a param in the future |
|
496 | 56x |
der_stats <- c( |
497 | 56x |
"mean", "sd", "se", "median", "geom_mean", "quantiles", "iqr", |
498 | 56x |
"mean_sd", "mean_se", "mean_se", "mean_ci", "mean_sei", "mean_sdi", |
499 | 56x |
"median_ci" |
500 |
) |
|
501 | 56x |
nonder_stats <- c("n", "range", "min", "max") |
502 | ||
503 |
# Safenet for miss-modifications |
|
504 | 56x |
stopifnot(length(intersect(der_stats, nonder_stats)) == 0) # nolint |
505 | 56x |
checkmate::assert_choice(x_stat, c(der_stats, nonder_stats)) |
506 | ||
507 |
# Finds the max number of digits in data |
|
508 | 56x |
detect_dig <- vapply(dt_var, count_decimalplaces, FUN.VALUE = numeric(1)) %>% |
509 | 56x |
max() |
510 | ||
511 | 56x |
if (x_stat %in% der_stats) { |
512 | 40x |
detect_dig <- detect_dig + 1 |
513 |
} |
|
514 | ||
515 |
# Render input |
|
516 | 56x |
str_vals <- formatC(x, digits = detect_dig, format = "f") |
517 | 56x |
def_fmt <- get_formats_from_stats(x_stat)[[x_stat]] |
518 | 56x |
str_fmt <- str_extract(def_fmt, invert = FALSE)[[1]] |
519 | 56x |
if (length(str_fmt) != length(str_vals)) { |
520 | 2x |
stop( |
521 | 2x |
"Number of inserted values as result (", length(str_vals), |
522 | 2x |
") is not the same as there should be in the default tern formats for ", |
523 | 2x |
x_stat, " (-> ", def_fmt, " needs ", length(str_fmt), " values). ", |
524 | 2x |
"See tern_default_formats to check all of them." |
525 |
) |
|
526 |
} |
|
527 | ||
528 |
# Squashing them together |
|
529 | 54x |
inv_str_fmt <- str_extract(def_fmt, invert = TRUE)[[1]] |
530 | 54x |
stopifnot(length(inv_str_fmt) == length(str_vals) + 1) # nolint |
531 | ||
532 | 54x |
out <- vector("character", length = length(inv_str_fmt) + length(str_vals)) |
533 | 54x |
is_even <- seq_along(out) %% 2 == 0 |
534 | 54x |
out[is_even] <- str_vals |
535 | 54x |
out[!is_even] <- inv_str_fmt |
536 | ||
537 | 54x |
return(paste0(out, collapse = "")) |
538 |
} |
|
539 |
} |
|
540 | ||
541 |
# Utility function that could be useful in general |
|
542 |
str_extract <- function(string, pattern = "xx|xx\\.|xx\\.x+", invert = FALSE) { |
|
543 | 110x |
regmatches(string, gregexpr(pattern, string), invert = invert) |
544 |
} |
|
545 | ||
546 |
# Helper function |
|
547 |
count_decimalplaces <- function(dec) { |
|
548 | 2038x |
if (is.na(dec)) { |
549 | 6x |
return(0) |
550 | 2032x |
} else if (abs(dec - round(dec)) > .Machine$double.eps^0.5) { # For precision |
551 | 1939x |
nchar(strsplit(format(dec, scientific = FALSE, trim = FALSE), ".", fixed = TRUE)[[1]][[2]]) |
552 |
} else { |
|
553 | 93x |
return(0) |
554 |
} |
|
555 |
} |
|
556 | ||
557 |
#' Apply automatic formatting |
|
558 |
#' |
|
559 |
#' Checks if any of the listed formats in `.formats` are `"auto"`, and replaces `"auto"` with |
|
560 |
#' the correct implementation of `format_auto` for the given statistics, data, and variable. |
|
561 |
#' |
|
562 |
#' @inheritParams argument_convention |
|
563 |
#' @param x_stats (named `list`)\cr a named list of statistics where each element corresponds |
|
564 |
#' to an element in `.formats`, with matching names. |
|
565 |
#' |
|
566 |
#' @keywords internal |
|
567 |
apply_auto_formatting <- function(.formats, x_stats, .df_row, .var) { |
|
568 | 1574x |
is_auto_fmt <- vapply(.formats, function(ii) is.character(ii) && ii == "auto", logical(1)) |
569 | 1574x |
if (any(is_auto_fmt)) { |
570 | 8x |
auto_stats <- x_stats[is_auto_fmt] |
571 | 8x |
var_df <- .df_row[[.var]] # xxx this can be extended for the WHOLE data or single facets |
572 | 8x |
.formats[is_auto_fmt] <- lapply(names(auto_stats), format_auto, dt_var = var_df) |
573 |
} |
|
574 | 1574x |
.formats |
575 |
} |
1 |
#' Create a forest plot from an `rtable` |
|
2 |
#' |
|
3 |
#' Given a [rtables::rtable()] object with at least one column with a single value and one column with 2 |
|
4 |
#' values, converts table to a [ggplot2::ggplot()] object and generates an accompanying forest plot. The |
|
5 |
#' table and forest plot are printed side-by-side. |
|
6 |
#' |
|
7 |
#' @description `r lifecycle::badge("stable")` |
|
8 |
#' |
|
9 |
#' @inheritParams rtable2gg |
|
10 |
#' @inheritParams argument_convention |
|
11 |
#' @param tbl (`VTableTree`)\cr `rtables` table with at least one column with a single value and one column with 2 |
|
12 |
#' values. |
|
13 |
#' @param col_x (`integer(1)` or `NULL`)\cr column index with estimator. By default tries to get this from |
|
14 |
#' `tbl` attribute `col_x`, otherwise needs to be manually specified. If `NULL`, points will be excluded |
|
15 |
#' from forest plot. |
|
16 |
#' @param col_ci (`integer(1)` or `NULL`)\cr column index with confidence intervals. By default tries to get this from |
|
17 |
#' `tbl` attribute `col_ci`, otherwise needs to be manually specified. If `NULL`, lines will be excluded |
|
18 |
#' from forest plot. |
|
19 |
#' @param vline (`numeric(1)` or `NULL`)\cr x coordinate for vertical line, if `NULL` then the line is omitted. |
|
20 |
#' @param forest_header (`character(2)`)\cr text displayed to the left and right of `vline`, respectively. |
|
21 |
#' If `vline = NULL` then `forest_header` is not printed. By default tries to get this from `tbl` attribute |
|
22 |
#' `forest_header`. If `NULL`, defaults will be extracted from the table if possible, and set to |
|
23 |
#' `"Comparison\nBetter"` and `"Treatment\nBetter"` if not. |
|
24 |
#' @param xlim (`numeric(2)`)\cr limits for x axis. |
|
25 |
#' @param logx (`flag`)\cr show the x-values on logarithm scale. |
|
26 |
#' @param x_at (`numeric`)\cr x-tick locations, if `NULL`, `x_at` is set to `vline` and both `xlim` values. |
|
27 |
#' @param width_row_names `r lifecycle::badge("deprecated")` Please use the `lbl_col_padding` argument instead. |
|
28 |
#' @param width_columns (`numeric`)\cr a vector of column widths. Each element's position in |
|
29 |
#' `colwidths` corresponds to the column of `tbl` in the same position. If `NULL`, column widths are calculated |
|
30 |
#' according to maximum number of characters per column. |
|
31 |
#' @param width_forest `r lifecycle::badge("deprecated")` Please use the `rel_width_forest` argument instead. |
|
32 |
#' @param rel_width_forest (`proportion`)\cr proportion of total width to allocate to the forest plot. Relative |
|
33 |
#' width of table is then `1 - rel_width_forest`. If `as_list = TRUE`, this parameter is ignored. |
|
34 |
#' @param font_size (`numeric(1)`)\cr font size. |
|
35 |
#' @param col_symbol_size (`numeric` or `NULL`)\cr column index from `tbl` containing data to be used |
|
36 |
#' to determine relative size for estimator plot symbol. Typically, the symbol size is proportional |
|
37 |
#' to the sample size used to calculate the estimator. If `NULL`, the same symbol size is used for all subgroups. |
|
38 |
#' By default tries to get this from `tbl` attribute `col_symbol_size`, otherwise needs to be manually specified. |
|
39 |
#' @param col (`character`)\cr color(s). |
|
40 |
#' @param ggtheme (`theme`)\cr a graphical theme as provided by `ggplot2` to control styling of the plot. |
|
41 |
#' @param as_list (`flag`)\cr whether the two `ggplot` objects should be returned as a list. If `TRUE`, a named list |
|
42 |
#' with two elements, `table` and `plot`, will be returned. If `FALSE` (default) the table and forest plot are |
|
43 |
#' printed side-by-side via [cowplot::plot_grid()]. |
|
44 |
#' @param gp `r lifecycle::badge("deprecated")` `g_forest` is now generated as a `ggplot` object. This argument |
|
45 |
#' is no longer used. |
|
46 |
#' @param draw `r lifecycle::badge("deprecated")` `g_forest` is now generated as a `ggplot` object. This argument |
|
47 |
#' is no longer used. |
|
48 |
#' @param newpage `r lifecycle::badge("deprecated")` `g_forest` is now generated as a `ggplot` object. This argument |
|
49 |
#' is no longer used. |
|
50 |
#' |
|
51 |
#' @return `ggplot` forest plot and table. |
|
52 |
#' |
|
53 |
#' @examples |
|
54 |
#' library(dplyr) |
|
55 |
#' library(forcats) |
|
56 |
#' |
|
57 |
#' adrs <- tern_ex_adrs |
|
58 |
#' n_records <- 20 |
|
59 |
#' adrs_labels <- formatters::var_labels(adrs, fill = TRUE) |
|
60 |
#' adrs <- adrs %>% |
|
61 |
#' filter(PARAMCD == "BESRSPI") %>% |
|
62 |
#' filter(ARM %in% c("A: Drug X", "B: Placebo")) %>% |
|
63 |
#' slice(seq_len(n_records)) %>% |
|
64 |
#' droplevels() %>% |
|
65 |
#' mutate( |
|
66 |
#' # Reorder levels of factor to make the placebo group the reference arm. |
|
67 |
#' ARM = fct_relevel(ARM, "B: Placebo"), |
|
68 |
#' rsp = AVALC == "CR" |
|
69 |
#' ) |
|
70 |
#' formatters::var_labels(adrs) <- c(adrs_labels, "Response") |
|
71 |
#' df <- extract_rsp_subgroups( |
|
72 |
#' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "STRATA2")), |
|
73 |
#' data = adrs |
|
74 |
#' ) |
|
75 |
#' # Full commonly used response table. |
|
76 |
#' |
|
77 |
#' tbl <- basic_table() %>% |
|
78 |
#' tabulate_rsp_subgroups(df) |
|
79 |
#' g_forest(tbl) |
|
80 |
#' |
|
81 |
#' # Odds ratio only table. |
|
82 |
#' |
|
83 |
#' tbl_or <- basic_table() %>% |
|
84 |
#' tabulate_rsp_subgroups(df, vars = c("n_tot", "or", "ci")) |
|
85 |
#' g_forest( |
|
86 |
#' tbl_or, |
|
87 |
#' forest_header = c("Comparison\nBetter", "Treatment\nBetter") |
|
88 |
#' ) |
|
89 |
#' |
|
90 |
#' # Survival forest plot example. |
|
91 |
#' adtte <- tern_ex_adtte |
|
92 |
#' # Save variable labels before data processing steps. |
|
93 |
#' adtte_labels <- formatters::var_labels(adtte, fill = TRUE) |
|
94 |
#' adtte_f <- adtte %>% |
|
95 |
#' filter( |
|
96 |
#' PARAMCD == "OS", |
|
97 |
#' ARM %in% c("B: Placebo", "A: Drug X"), |
|
98 |
#' SEX %in% c("M", "F") |
|
99 |
#' ) %>% |
|
100 |
#' mutate( |
|
101 |
#' # Reorder levels of ARM to display reference arm before treatment arm. |
|
102 |
#' ARM = droplevels(fct_relevel(ARM, "B: Placebo")), |
|
103 |
#' SEX = droplevels(SEX), |
|
104 |
#' AVALU = as.character(AVALU), |
|
105 |
#' is_event = CNSR == 0 |
|
106 |
#' ) |
|
107 |
#' labels <- list( |
|
108 |
#' "ARM" = adtte_labels["ARM"], |
|
109 |
#' "SEX" = adtte_labels["SEX"], |
|
110 |
#' "AVALU" = adtte_labels["AVALU"], |
|
111 |
#' "is_event" = "Event Flag" |
|
112 |
#' ) |
|
113 |
#' formatters::var_labels(adtte_f)[names(labels)] <- as.character(labels) |
|
114 |
#' df <- extract_survival_subgroups( |
|
115 |
#' variables = list( |
|
116 |
#' tte = "AVAL", |
|
117 |
#' is_event = "is_event", |
|
118 |
#' arm = "ARM", subgroups = c("SEX", "BMRKR2") |
|
119 |
#' ), |
|
120 |
#' data = adtte_f |
|
121 |
#' ) |
|
122 |
#' table_hr <- basic_table() %>% |
|
123 |
#' tabulate_survival_subgroups(df, time_unit = adtte_f$AVALU[1]) |
|
124 |
#' g_forest(table_hr) |
|
125 |
#' |
|
126 |
#' # Works with any `rtable`. |
|
127 |
#' tbl <- rtable( |
|
128 |
#' header = c("E", "CI", "N"), |
|
129 |
#' rrow("", 1, c(.8, 1.2), 200), |
|
130 |
#' rrow("", 1.2, c(1.1, 1.4), 50) |
|
131 |
#' ) |
|
132 |
#' g_forest( |
|
133 |
#' tbl = tbl, |
|
134 |
#' col_x = 1, |
|
135 |
#' col_ci = 2, |
|
136 |
#' xlim = c(0.5, 2), |
|
137 |
#' x_at = c(0.5, 1, 2), |
|
138 |
#' col_symbol_size = 3 |
|
139 |
#' ) |
|
140 |
#' |
|
141 |
#' tbl <- rtable( |
|
142 |
#' header = rheader( |
|
143 |
#' rrow("", rcell("A", colspan = 2)), |
|
144 |
#' rrow("", "c1", "c2") |
|
145 |
#' ), |
|
146 |
#' rrow("row 1", 1, c(.8, 1.2)), |
|
147 |
#' rrow("row 2", 1.2, c(1.1, 1.4)) |
|
148 |
#' ) |
|
149 |
#' g_forest( |
|
150 |
#' tbl = tbl, |
|
151 |
#' col_x = 1, |
|
152 |
#' col_ci = 2, |
|
153 |
#' xlim = c(0.5, 2), |
|
154 |
#' x_at = c(0.5, 1, 2), |
|
155 |
#' vline = 1, |
|
156 |
#' forest_header = c("Hello", "World") |
|
157 |
#' ) |
|
158 |
#' |
|
159 |
#' @export |
|
160 |
g_forest <- function(tbl, |
|
161 |
col_x = attr(tbl, "col_x"), |
|
162 |
col_ci = attr(tbl, "col_ci"), |
|
163 |
vline = 1, |
|
164 |
forest_header = attr(tbl, "forest_header"), |
|
165 |
xlim = c(0.1, 10), |
|
166 |
logx = TRUE, |
|
167 |
x_at = c(0.1, 1, 10), |
|
168 |
width_row_names = lifecycle::deprecated(), |
|
169 |
width_columns = NULL, |
|
170 |
width_forest = lifecycle::deprecated(), |
|
171 |
lbl_col_padding = 0, |
|
172 |
rel_width_forest = 0.25, |
|
173 |
font_size = 12, |
|
174 |
col_symbol_size = attr(tbl, "col_symbol_size"), |
|
175 |
col = getOption("ggplot2.discrete.colour")[1], |
|
176 |
ggtheme = NULL, |
|
177 |
as_list = FALSE, |
|
178 |
gp = lifecycle::deprecated(), |
|
179 |
draw = lifecycle::deprecated(), |
|
180 |
newpage = lifecycle::deprecated()) { |
|
181 |
# Deprecated argument warnings |
|
182 | 4x |
if (lifecycle::is_present(width_row_names)) { |
183 | 1x |
lifecycle::deprecate_warn( |
184 | 1x |
"0.9.4", "g_forest(width_row_names)", "g_forest(lbl_col_padding)", |
185 | 1x |
details = "The width of the row label column can be adjusted via the `lbl_col_padding` parameter." |
186 |
) |
|
187 |
} |
|
188 | 4x |
if (lifecycle::is_present(width_forest)) { |
189 | 1x |
lifecycle::deprecate_warn( |
190 | 1x |
"0.9.4", "g_forest(width_forest)", "g_forest(rel_width_forest)", |
191 | 1x |
details = "Relative width of the forest plot (as a proportion) can be set via the `rel_width_forest` parameter." |
192 |
) |
|
193 |
} |
|
194 | 4x |
if (lifecycle::is_present(gp)) { |
195 | 1x |
lifecycle::deprecate_warn( |
196 | 1x |
"0.9.4", "g_forest(gp)", "g_forest(ggtheme)", |
197 | 1x |
details = paste( |
198 | 1x |
"`g_forest` is now generated as a `ggplot` object.", |
199 | 1x |
"Additional display settings should be supplied via the `ggtheme` parameter." |
200 |
) |
|
201 |
) |
|
202 |
} |
|
203 | 4x |
if (lifecycle::is_present(draw)) { |
204 | 1x |
lifecycle::deprecate_warn( |
205 | 1x |
"0.9.4", "g_forest(draw)", |
206 | 1x |
details = "`g_forest` now generates `ggplot` objects. This parameter has no effect." |
207 |
) |
|
208 |
} |
|
209 | 4x |
if (lifecycle::is_present(newpage)) { |
210 | 1x |
lifecycle::deprecate_warn( |
211 | 1x |
"0.9.4", "g_forest(newpage)", |
212 | 1x |
details = "`g_forest` now generates `ggplot` objects. This parameter has no effect." |
213 |
) |
|
214 |
} |
|
215 | ||
216 | 4x |
checkmate::assert_class(tbl, "VTableTree") |
217 | 4x |
checkmate::assert_number(col_x, lower = 0, upper = ncol(tbl), null.ok = TRUE) |
218 | 4x |
checkmate::assert_number(col_ci, lower = 0, upper = ncol(tbl), null.ok = TRUE) |
219 | 4x |
checkmate::assert_number(col_symbol_size, lower = 0, upper = ncol(tbl), null.ok = TRUE) |
220 | 4x |
checkmate::assert_number(font_size, lower = 0) |
221 | 4x |
checkmate::assert_character(col, null.ok = TRUE) |
222 | 4x |
checkmate::assert_true(is.null(col) | length(col) == 1 | length(col) == nrow(tbl)) |
223 | ||
224 |
# Extract info from table |
|
225 | 4x |
mat <- matrix_form(tbl, indent_rownames = TRUE) |
226 | 4x |
mat_strings <- formatters::mf_strings(mat) |
227 | 4x |
nlines_hdr <- formatters::mf_nlheader(mat) |
228 | 4x |
nrows_body <- nrow(mat_strings) - nlines_hdr |
229 | 4x |
tbl_stats <- mat_strings[nlines_hdr, -1] |
230 | ||
231 |
# Generate and modify table as ggplot object |
|
232 | 4x |
gg_table <- rtable2gg(tbl, fontsize = font_size, colwidths = width_columns, lbl_col_padding = lbl_col_padding) + |
233 | 4x |
theme(plot.margin = margin(0, 0, 0, 0.025, "npc")) |
234 | 4x |
gg_table$scales$scales[[1]]$expand <- c(0.01, 0.01) |
235 | 4x |
gg_table$scales$scales[[2]]$limits[2] <- nrow(mat_strings) + 1 |
236 | 4x |
if (nlines_hdr == 2) { |
237 | 4x |
gg_table$scales$scales[[2]]$expand <- c(0, 0) |
238 | 4x |
arms <- unique(mat_strings[1, ][nzchar(trimws(mat_strings[1, ]))]) |
239 |
} else { |
|
240 | ! |
arms <- NULL |
241 |
} |
|
242 | ||
243 | 4x |
tbl_df <- as_result_df(tbl) |
244 | 4x |
dat_cols <- seq(which(names(tbl_df) == "node_class") + 1, ncol(tbl_df)) |
245 | 4x |
tbl_df <- tbl_df[, c(which(names(tbl_df) == "row_num"), dat_cols)] |
246 | 4x |
names(tbl_df) <- c("row_num", tbl_stats) |
247 | ||
248 |
# Check table data columns |
|
249 | 4x |
if (!is.null(col_ci)) { |
250 | 4x |
ci_col <- col_ci + 1 |
251 |
} else { |
|
252 | ! |
tbl_df[["empty_ci"]] <- rep(list(c(NA_real_, NA_real_)), nrow(tbl_df)) |
253 | ! |
ci_col <- which(names(tbl_df) == "empty_ci") |
254 |
} |
|
255 | ! |
if (length(tbl_df[, ci_col][[1]]) != 2) stop("CI column must have two elements (lower and upper limits).") |
256 | ||
257 | 4x |
if (!is.null(col_x)) { |
258 | 4x |
x_col <- col_x + 1 |
259 |
} else { |
|
260 | ! |
tbl_df[["empty_x"]] <- NA_real_ |
261 | ! |
x_col <- which(names(tbl_df) == "empty_x") |
262 |
} |
|
263 | 4x |
if (!is.null(col_symbol_size)) { |
264 | 3x |
sym_size <- unlist(tbl_df[, col_symbol_size + 1]) |
265 |
} else { |
|
266 | 1x |
sym_size <- rep(1, nrow(tbl_df)) |
267 |
} |
|
268 | ||
269 | 4x |
tbl_df[, c("ci_lwr", "ci_upr")] <- t(sapply(tbl_df[, ci_col], unlist)) |
270 | 4x |
x <- unlist(tbl_df[, x_col]) |
271 | 4x |
lwr <- unlist(tbl_df[["ci_lwr"]]) |
272 | 4x |
upr <- unlist(tbl_df[["ci_upr"]]) |
273 | 4x |
row_num <- nrow(mat_strings) - tbl_df[["row_num"]] - as.numeric(nlines_hdr == 2) |
274 | ||
275 | ! |
if (is.null(col)) col <- "#343cff" |
276 | 4x |
if (length(col) == 1) col <- rep(col, nrow(tbl_df)) |
277 | ! |
if (is.null(x_at)) x_at <- union(xlim, vline) |
278 | 4x |
x_labels <- x_at |
279 | ||
280 |
# Apply log transformation |
|
281 | 4x |
if (logx) { |
282 | 4x |
x_t <- log(x) |
283 | 4x |
lwr_t <- log(lwr) |
284 | 4x |
upr_t <- log(upr) |
285 | 4x |
xlim_t <- log(xlim) |
286 |
} else { |
|
287 | ! |
x_t <- x |
288 | ! |
lwr_t <- lwr |
289 | ! |
upr_t <- upr |
290 | ! |
xlim_t <- xlim |
291 |
} |
|
292 | ||
293 |
# Set up plot area |
|
294 | 4x |
gg_plt <- ggplot(data = tbl_df) + |
295 | 4x |
theme( |
296 | 4x |
panel.background = element_rect(fill = "transparent", color = NA_character_), |
297 | 4x |
plot.background = element_rect(fill = "transparent", color = NA_character_), |
298 | 4x |
panel.grid.major = element_blank(), |
299 | 4x |
panel.grid.minor = element_blank(), |
300 | 4x |
axis.title.x = element_blank(), |
301 | 4x |
axis.title.y = element_blank(), |
302 | 4x |
axis.line.x = element_line(), |
303 | 4x |
axis.text = element_text(size = font_size), |
304 | 4x |
legend.position = "none", |
305 | 4x |
plot.margin = margin(0, 0.1, 0.05, 0, "npc") |
306 |
) + |
|
307 | 4x |
scale_x_continuous( |
308 | 4x |
transform = ifelse(logx, "log", "identity"), |
309 | 4x |
limits = xlim, |
310 | 4x |
breaks = x_at, |
311 | 4x |
labels = x_labels, |
312 | 4x |
expand = c(0.01, 0) |
313 |
) + |
|
314 | 4x |
scale_y_continuous( |
315 | 4x |
limits = c(0, nrow(mat_strings) + 1), |
316 | 4x |
breaks = NULL, |
317 | 4x |
expand = c(0, 0) |
318 |
) + |
|
319 | 4x |
coord_cartesian(clip = "off") |
320 | ||
321 | 4x |
if (is.null(ggtheme)) { |
322 | 4x |
gg_plt <- gg_plt + annotate( |
323 | 4x |
"rect", |
324 | 4x |
xmin = xlim[1], |
325 | 4x |
xmax = xlim[2], |
326 | 4x |
ymin = 0, |
327 | 4x |
ymax = nrows_body + 0.5, |
328 | 4x |
fill = "grey92" |
329 |
) |
|
330 |
} |
|
331 | ||
332 | 4x |
if (!is.null(vline)) { |
333 |
# Set default forest header |
|
334 | 4x |
if (is.null(forest_header)) { |
335 | ! |
forest_header <- c( |
336 | ! |
paste(if (length(arms) == 2) arms[1] else "Comparison", "Better", sep = "\n"), |
337 | ! |
paste(if (length(arms) == 2) arms[2] else "Treatment", "Better", sep = "\n") |
338 |
) |
|
339 |
} |
|
340 | ||
341 |
# Add vline and forest header labels |
|
342 | 4x |
mid_pts <- if (logx) { |
343 | 4x |
c(exp(mean(log(c(xlim[1], vline)))), exp(mean(log(c(vline, xlim[2]))))) |
344 |
} else { |
|
345 | ! |
c(mean(c(xlim[1], vline)), mean(c(vline, xlim[2]))) |
346 |
} |
|
347 | 4x |
gg_plt <- gg_plt + |
348 | 4x |
annotate( |
349 | 4x |
"segment", |
350 | 4x |
x = vline, xend = vline, y = 0, yend = nrows_body + 0.5 |
351 |
) + |
|
352 | 4x |
annotate( |
353 | 4x |
"text", |
354 | 4x |
x = mid_pts[1], y = nrows_body + 1.25, |
355 | 4x |
label = forest_header[1], |
356 | 4x |
size = font_size / .pt, |
357 | 4x |
lineheight = 0.9 |
358 |
) + |
|
359 | 4x |
annotate( |
360 | 4x |
"text", |
361 | 4x |
x = mid_pts[2], y = nrows_body + 1.25, |
362 | 4x |
label = forest_header[2], |
363 | 4x |
size = font_size / .pt, |
364 | 4x |
lineheight = 0.9 |
365 |
) |
|
366 |
} |
|
367 | ||
368 |
# Add points to plot |
|
369 | 4x |
if (any(!is.na(x_t))) { |
370 | 4x |
x_t[x < xlim[1] | x > xlim[2]] <- NA |
371 | 4x |
gg_plt <- gg_plt + geom_point( |
372 | 4x |
x = x_t, |
373 | 4x |
y = row_num, |
374 | 4x |
color = col, |
375 | 4x |
aes(size = sym_size), |
376 | 4x |
na.rm = TRUE |
377 |
) |
|
378 |
} |
|
379 | ||
380 | 4x |
for (i in seq_len(nrow(tbl_df))) { |
381 |
# Determine which arrow(s) to add to CI lines |
|
382 | 17x |
which_arrow <- c(lwr_t[i] < xlim_t[1], upr_t[i] > xlim_t[2]) |
383 | 17x |
which_arrow <- dplyr::case_when( |
384 | 17x |
all(which_arrow) ~ "both", |
385 | 17x |
which_arrow[1] ~ "first", |
386 | 17x |
which_arrow[2] ~ "last", |
387 | 17x |
TRUE ~ NA_character_ |
388 |
) |
|
389 | ||
390 |
# Add CI lines |
|
391 | 17x |
gg_plt <- gg_plt + |
392 | 17x |
if (!is.na(which_arrow)) { |
393 | 15x |
annotate( |
394 | 15x |
"segment", |
395 | 15x |
x = if (!which_arrow %in% c("first", "both")) lwr[i] else xlim[1], |
396 | 15x |
xend = if (!which_arrow %in% c("last", "both")) upr[i] else xlim[2], |
397 | 15x |
y = row_num[i], yend = row_num[i], |
398 | 15x |
color = if (length(col) == 1) col else col[i], |
399 | 15x |
arrow = arrow(length = unit(0.05, "npc"), ends = which_arrow), |
400 | 15x |
na.rm = TRUE |
401 |
) |
|
402 |
} else { |
|
403 | 2x |
annotate( |
404 | 2x |
"segment", |
405 | 2x |
x = lwr[i], xend = upr[i], |
406 | 2x |
y = row_num[i], yend = row_num[i], |
407 | 2x |
color = if (length(col) == 1) col else col[i], |
408 | 2x |
na.rm = TRUE |
409 |
) |
|
410 |
} |
|
411 |
} |
|
412 | ||
413 |
# Apply custom ggtheme to plot |
|
414 | ! |
if (!is.null(ggtheme)) gg_plt <- gg_plt + ggtheme |
415 | ||
416 | 4x |
if (as_list) { |
417 | 1x |
list( |
418 | 1x |
table = gg_table, |
419 | 1x |
plot = gg_plt |
420 |
) |
|
421 |
} else { |
|
422 | 3x |
cowplot::plot_grid( |
423 | 3x |
gg_table, |
424 | 3x |
gg_plt, |
425 | 3x |
align = "h", |
426 | 3x |
axis = "tblr", |
427 | 3x |
rel_widths = c(1 - rel_width_forest, rel_width_forest) |
428 |
) |
|
429 |
} |
|
430 |
} |
|
431 | ||
432 |
#' Forest plot grob |
|
433 |
#' |
|
434 |
#' @description `r lifecycle::badge("deprecated")` |
|
435 |
#' |
|
436 |
#' @inheritParams g_forest |
|
437 |
#' @param tbl (`VTableTree`)\cr `rtables` table object. |
|
438 |
#' @param x (`numeric`)\cr coordinate of point. |
|
439 |
#' @param lower,upper (`numeric`)\cr lower/upper bound of the confidence interval. |
|
440 |
#' @param symbol_size (`numeric`)\cr vector with relative size for plot symbol. |
|
441 |
#' If `NULL`, the same symbol size is used. |
|
442 |
#' |
|
443 |
#' @details |
|
444 |
#' The heights get automatically determined. |
|
445 |
#' |
|
446 |
#' @examples |
|
447 |
#' tbl <- rtable( |
|
448 |
#' header = rheader( |
|
449 |
#' rrow("", "E", rcell("CI", colspan = 2), "N"), |
|
450 |
#' rrow("", "A", "B", "C", "D") |
|
451 |
#' ), |
|
452 |
#' rrow("row 1", 1, 0.8, 1.1, 16), |
|
453 |
#' rrow("row 2", 1.4, 0.8, 1.6, 25), |
|
454 |
#' rrow("row 3", 1.2, 0.8, 1.6, 36) |
|
455 |
#' ) |
|
456 |
#' |
|
457 |
#' x <- c(1, 1.4, 1.2) |
|
458 |
#' lower <- c(0.8, 0.8, 0.8) |
|
459 |
#' upper <- c(1.1, 1.6, 1.6) |
|
460 |
#' # numeric vector with multiplication factor to scale each circle radius |
|
461 |
#' # default radius is 1/3.5 lines |
|
462 |
#' symbol_scale <- c(1, 1.25, 1.5) |
|
463 |
#' |
|
464 |
#' # Internal function - forest_grob |
|
465 |
#' \donttest{ |
|
466 |
#' p <- forest_grob(tbl, x, lower, upper, |
|
467 |
#' vline = 1, forest_header = c("A", "B"), |
|
468 |
#' x_at = c(.1, 1, 10), xlim = c(0.1, 10), logx = TRUE, symbol_size = symbol_scale, |
|
469 |
#' vp = grid::plotViewport(margins = c(1, 1, 1, 1)) |
|
470 |
#' ) |
|
471 |
#' |
|
472 |
#' draw_grob(p) |
|
473 |
#' } |
|
474 |
#' |
|
475 |
#' @noRd |
|
476 |
#' @keywords internal |
|
477 |
forest_grob <- function(tbl, |
|
478 |
x, |
|
479 |
lower, |
|
480 |
upper, |
|
481 |
vline, |
|
482 |
forest_header, |
|
483 |
xlim = NULL, |
|
484 |
logx = FALSE, |
|
485 |
x_at = NULL, |
|
486 |
width_row_names = NULL, |
|
487 |
width_columns = NULL, |
|
488 |
width_forest = grid::unit(1, "null"), |
|
489 |
symbol_size = NULL, |
|
490 |
col = "blue", |
|
491 |
name = NULL, |
|
492 |
gp = NULL, |
|
493 |
vp = NULL) { |
|
494 | 1x |
lifecycle::deprecate_warn( |
495 | 1x |
"0.9.4", "forest_grob()", |
496 | 1x |
details = "`g_forest` now generates `ggplot` objects. This function is no longer used within `tern`." |
497 |
) |
|
498 | ||
499 | 1x |
nr <- nrow(tbl) |
500 | 1x |
if (is.null(vline)) { |
501 | ! |
checkmate::assert_true(is.null(forest_header)) |
502 |
} else { |
|
503 | 1x |
checkmate::assert_number(vline) |
504 | 1x |
checkmate::assert_character(forest_header, len = 2, null.ok = TRUE) |
505 |
} |
|
506 | ||
507 | 1x |
checkmate::assert_numeric(x, len = nr) |
508 | 1x |
checkmate::assert_numeric(lower, len = nr) |
509 | 1x |
checkmate::assert_numeric(upper, len = nr) |
510 | 1x |
checkmate::assert_numeric(symbol_size, len = nr, null.ok = TRUE) |
511 | 1x |
checkmate::assert_character(col) |
512 | ||
513 | 1x |
if (is.null(symbol_size)) { |
514 | ! |
symbol_size <- rep(1, nr) |
515 |
} |
|
516 | ||
517 | 1x |
if (is.null(xlim)) { |
518 | ! |
r <- range(c(x, lower, upper), na.rm = TRUE) |
519 | ! |
xlim <- r + c(-0.05, 0.05) * diff(r) |
520 |
} |
|
521 | ||
522 | 1x |
if (logx) { |
523 | 1x |
if (is.null(x_at)) { |
524 | ! |
x_at <- pretty(log(stats::na.omit(c(x, lower, upper)))) |
525 | ! |
x_labels <- exp(x_at) |
526 |
} else { |
|
527 | 1x |
x_labels <- x_at |
528 | 1x |
x_at <- log(x_at) |
529 |
} |
|
530 | 1x |
xlim <- log(xlim) |
531 | 1x |
x <- log(x) |
532 | 1x |
lower <- log(lower) |
533 | 1x |
upper <- log(upper) |
534 | 1x |
if (!is.null(vline)) { |
535 | 1x |
vline <- log(vline) |
536 |
} |
|
537 |
} else { |
|
538 | ! |
x_labels <- TRUE |
539 |
} |
|
540 | ||
541 | 1x |
data_forest_vp <- grid::dataViewport(xlim, c(0, 1)) |
542 | ||
543 |
# Get table content as matrix form. |
|
544 | 1x |
mf <- matrix_form(tbl) |
545 | ||
546 |
# Use `rtables` indent_string eventually. |
|
547 | 1x |
mf$strings[, 1] <- paste0( |
548 | 1x |
strrep(" ", c(rep(0, attr(mf, "nrow_header")), mf$row_info$indent)), |
549 | 1x |
mf$strings[, 1] |
550 |
) |
|
551 | ||
552 | 1x |
n_header <- attr(mf, "nrow_header") |
553 | ||
554 | ! |
if (any(mf$display[, 1] == FALSE)) stop("row names need to be always displayed") |
555 | ||
556 |
# Pre-process the data to be used in lapply and cell_in_rows. |
|
557 | 1x |
to_args_for_cell_in_rows_fun <- function(part = c("body", "header"), |
558 | 1x |
underline_colspan = FALSE) { |
559 | 2x |
part <- match.arg(part) |
560 | 2x |
if (part == "body") { |
561 | 1x |
mat_row_indices <- seq_len(nrow(tbl)) + n_header |
562 | 1x |
row_ind_offset <- -n_header |
563 |
} else { |
|
564 | 1x |
mat_row_indices <- seq_len(n_header) |
565 | 1x |
row_ind_offset <- 0 |
566 |
} |
|
567 | ||
568 | 2x |
lapply(mat_row_indices, function(i) { |
569 | 5x |
disp <- mf$display[i, -1] |
570 | 5x |
list( |
571 | 5x |
row_name = mf$strings[i, 1], |
572 | 5x |
cells = mf$strings[i, -1][disp], |
573 | 5x |
cell_spans = mf$spans[i, -1][disp], |
574 | 5x |
row_index = i + row_ind_offset, |
575 | 5x |
underline_colspan = underline_colspan |
576 |
) |
|
577 |
}) |
|
578 |
} |
|
579 | ||
580 | 1x |
args_header <- to_args_for_cell_in_rows_fun("header", underline_colspan = TRUE) |
581 | 1x |
args_body <- to_args_for_cell_in_rows_fun("body", underline_colspan = FALSE) |
582 | ||
583 | 1x |
grid::gTree( |
584 | 1x |
name = name, |
585 | 1x |
children = grid::gList( |
586 | 1x |
grid::gTree( |
587 | 1x |
children = do.call(grid::gList, lapply(args_header, do.call, what = cell_in_rows)), |
588 | 1x |
vp = grid::vpPath("vp_table_layout", "vp_header") |
589 |
), |
|
590 | 1x |
grid::gTree( |
591 | 1x |
children = do.call(grid::gList, lapply(args_body, do.call, what = cell_in_rows)), |
592 | 1x |
vp = grid::vpPath("vp_table_layout", "vp_body") |
593 |
), |
|
594 | 1x |
grid::linesGrob( |
595 | 1x |
grid::unit(c(0, 1), "npc"), |
596 | 1x |
y = grid::unit(c(.5, .5), "npc"), |
597 | 1x |
vp = grid::vpPath("vp_table_layout", "vp_spacer") |
598 |
), |
|
599 |
# forest part |
|
600 | 1x |
if (is.null(vline)) { |
601 | ! |
NULL |
602 |
} else { |
|
603 | 1x |
grid::gTree( |
604 | 1x |
children = grid::gList( |
605 | 1x |
grid::gTree( |
606 | 1x |
children = grid::gList( |
607 | 1x |
grid::textGrob( |
608 | 1x |
forest_header[1], |
609 | 1x |
x = grid::unit(vline, "native") - grid::unit(1, "lines"), |
610 | 1x |
just = c("right", "center") |
611 |
), |
|
612 | 1x |
grid::textGrob( |
613 | 1x |
forest_header[2], |
614 | 1x |
x = grid::unit(vline, "native") + grid::unit(1, "lines"), |
615 | 1x |
just = c("left", "center") |
616 |
) |
|
617 |
), |
|
618 | 1x |
vp = grid::vpStack(grid::viewport(layout.pos.col = ncol(tbl) + 2), data_forest_vp) |
619 |
) |
|
620 |
), |
|
621 | 1x |
vp = grid::vpPath("vp_table_layout", "vp_header") |
622 |
) |
|
623 |
}, |
|
624 | 1x |
grid::gTree( |
625 | 1x |
children = grid::gList( |
626 | 1x |
grid::gTree( |
627 | 1x |
children = grid::gList( |
628 | 1x |
grid::rectGrob(gp = grid::gpar(col = "gray90", fill = "gray90")), |
629 | 1x |
if (is.null(vline)) { |
630 | ! |
NULL |
631 |
} else { |
|
632 | 1x |
grid::linesGrob( |
633 | 1x |
x = grid::unit(rep(vline, 2), "native"), |
634 | 1x |
y = grid::unit(c(0, 1), "npc"), |
635 | 1x |
gp = grid::gpar(lwd = 2), |
636 | 1x |
vp = data_forest_vp |
637 |
) |
|
638 |
}, |
|
639 | 1x |
grid::xaxisGrob(at = x_at, label = x_labels, vp = data_forest_vp) |
640 |
), |
|
641 | 1x |
vp = grid::viewport(layout.pos.col = ncol(tbl) + 2) |
642 |
) |
|
643 |
), |
|
644 | 1x |
vp = grid::vpPath("vp_table_layout", "vp_body") |
645 |
), |
|
646 | 1x |
grid::gTree( |
647 | 1x |
children = do.call( |
648 | 1x |
grid::gList, |
649 | 1x |
Map( |
650 | 1x |
function(xi, li, ui, row_index, size_i, col) { |
651 | 3x |
forest_dot_line( |
652 | 3x |
xi, |
653 | 3x |
li, |
654 | 3x |
ui, |
655 | 3x |
row_index, |
656 | 3x |
xlim, |
657 | 3x |
symbol_size = size_i, |
658 | 3x |
col = col, |
659 | 3x |
datavp = data_forest_vp |
660 |
) |
|
661 |
}, |
|
662 | 1x |
x, |
663 | 1x |
lower, |
664 | 1x |
upper, |
665 | 1x |
seq_along(x), |
666 | 1x |
symbol_size, |
667 | 1x |
col, |
668 | 1x |
USE.NAMES = FALSE |
669 |
) |
|
670 |
), |
|
671 | 1x |
vp = grid::vpPath("vp_table_layout", "vp_body") |
672 |
) |
|
673 |
), |
|
674 | 1x |
childrenvp = forest_viewport(tbl, width_row_names, width_columns, width_forest), |
675 | 1x |
vp = vp, |
676 | 1x |
gp = gp |
677 |
) |
|
678 |
} |
|
679 | ||
680 |
cell_in_rows <- function(row_name, |
|
681 |
cells, |
|
682 |
cell_spans, |
|
683 |
row_index, |
|
684 |
underline_colspan = FALSE) { |
|
685 | 5x |
checkmate::assert_string(row_name) |
686 | 5x |
checkmate::assert_character(cells, min.len = 1, any.missing = FALSE) |
687 | 5x |
checkmate::assert_numeric(cell_spans, len = length(cells), any.missing = FALSE) |
688 | 5x |
checkmate::assert_number(row_index) |
689 | 5x |
checkmate::assert_flag(underline_colspan) |
690 | ||
691 | 5x |
vp_name_rn <- paste0("rowname-", row_index) |
692 | 5x |
g_rowname <- if (!is.null(row_name) && row_name != "") { |
693 | 3x |
grid::textGrob( |
694 | 3x |
name = vp_name_rn, |
695 | 3x |
label = row_name, |
696 | 3x |
x = grid::unit(0, "npc"), |
697 | 3x |
just = c("left", "center"), |
698 | 3x |
vp = grid::vpPath(paste0("rowname-", row_index)) |
699 |
) |
|
700 |
} else { |
|
701 | 2x |
NULL |
702 |
} |
|
703 | ||
704 | 5x |
gl_cols <- if (!(length(cells) > 0)) { |
705 | ! |
list(NULL) |
706 |
} else { |
|
707 | 5x |
j <- 1 # column index of cell |
708 | ||
709 | 5x |
lapply(seq_along(cells), function(k) { |
710 | 19x |
cell_ascii <- cells[[k]] |
711 | 19x |
cs <- cell_spans[[k]] |
712 | ||
713 | 19x |
if (is.na(cell_ascii) || is.null(cell_ascii)) { |
714 | ! |
cell_ascii <- "NA" |
715 |
} |
|
716 | ||
717 | 19x |
cell_name <- paste0("g-cell-", row_index, "-", j) |
718 | ||
719 | 19x |
cell_grobs <- if (identical(cell_ascii, "")) { |
720 | ! |
NULL |
721 |
} else { |
|
722 | 19x |
if (cs == 1) { |
723 | 18x |
grid::textGrob( |
724 | 18x |
label = cell_ascii, |
725 | 18x |
name = cell_name, |
726 | 18x |
vp = grid::vpPath(paste0("cell-", row_index, "-", j)) |
727 |
) |
|
728 |
} else { |
|
729 |
# +1 because of rowname |
|
730 | 1x |
vp_joined_cols <- grid::viewport(layout.pos.row = row_index, layout.pos.col = seq(j + 1, j + cs)) |
731 | ||
732 | 1x |
lab <- grid::textGrob( |
733 | 1x |
label = cell_ascii, |
734 | 1x |
name = cell_name, |
735 | 1x |
vp = vp_joined_cols |
736 |
) |
|
737 | ||
738 | 1x |
if (!underline_colspan || grepl("^[[:space:]]*$", cell_ascii)) { |
739 | ! |
lab |
740 |
} else { |
|
741 | 1x |
grid::gList( |
742 | 1x |
lab, |
743 | 1x |
grid::linesGrob( |
744 | 1x |
x = grid::unit.c(grid::unit(.2, "lines"), grid::unit(1, "npc") - grid::unit(.2, "lines")), |
745 | 1x |
y = grid::unit(c(0, 0), "npc"), |
746 | 1x |
vp = vp_joined_cols |
747 |
) |
|
748 |
) |
|
749 |
} |
|
750 |
} |
|
751 |
} |
|
752 | 19x |
j <<- j + cs |
753 | ||
754 | 19x |
cell_grobs |
755 |
}) |
|
756 |
} |
|
757 | ||
758 | 5x |
grid::gList( |
759 | 5x |
g_rowname, |
760 | 5x |
do.call(grid::gList, gl_cols) |
761 |
) |
|
762 |
} |
|
763 | ||
764 |
#' Graphic object: forest dot line |
|
765 |
#' |
|
766 |
#' @description `r lifecycle::badge("deprecated")` |
|
767 |
#' |
|
768 |
#' Calculate the `grob` corresponding to the dot line within the forest plot. |
|
769 |
#' |
|
770 |
#' @noRd |
|
771 |
#' @keywords internal |
|
772 |
forest_dot_line <- function(x, |
|
773 |
lower, |
|
774 |
upper, |
|
775 |
row_index, |
|
776 |
xlim, |
|
777 |
symbol_size = 1, |
|
778 |
col = "blue", |
|
779 |
datavp) { |
|
780 | 3x |
lifecycle::deprecate_warn( |
781 | 3x |
"0.9.4", "forest_dot_line()", |
782 | 3x |
details = "`g_forest` now generates `ggplot` objects. This function is no longer used within `tern`." |
783 |
) |
|
784 | ||
785 | 3x |
ci <- c(lower, upper) |
786 | 3x |
if (any(!is.na(c(x, ci)))) { |
787 |
# line |
|
788 | 3x |
y <- grid::unit(c(0.5, 0.5), "npc") |
789 | ||
790 | 3x |
g_line <- if (all(!is.na(ci)) && ci[2] > xlim[1] && ci[1] < xlim[2]) { |
791 |
# - |
|
792 | 3x |
if (ci[1] >= xlim[1] && ci[2] <= xlim[2]) { |
793 | 3x |
grid::linesGrob(x = grid::unit(c(ci[1], ci[2]), "native"), y = y) |
794 | ! |
} else if (ci[1] < xlim[1] && ci[2] > xlim[2]) { |
795 |
# <-> |
|
796 | ! |
grid::linesGrob( |
797 | ! |
x = grid::unit(xlim, "native"), |
798 | ! |
y = y, |
799 | ! |
arrow = grid::arrow(angle = 30, length = grid::unit(0.5, "lines"), ends = "both") |
800 |
) |
|
801 | ! |
} else if (ci[1] < xlim[1] && ci[2] <= xlim[2]) { |
802 |
# <- |
|
803 | ! |
grid::linesGrob( |
804 | ! |
x = grid::unit(c(xlim[1], ci[2]), "native"), |
805 | ! |
y = y, |
806 | ! |
arrow = grid::arrow(angle = 30, length = grid::unit(0.5, "lines"), ends = "first") |
807 |
) |
|
808 | ! |
} else if (ci[1] >= xlim[1] && ci[2] > xlim[2]) { |
809 |
# -> |
|
810 | ! |
grid::linesGrob( |
811 | ! |
x = grid::unit(c(ci[1], xlim[2]), "native"), |
812 | ! |
y = y, |
813 | ! |
arrow = grid::arrow(angle = 30, length = grid::unit(0.5, "lines"), ends = "last") |
814 |
) |
|
815 |
} |
|
816 |
} else { |
|
817 | ! |
NULL |
818 |
} |
|
819 | ||
820 | 3x |
g_circle <- if (!is.na(x) && x >= xlim[1] && x <= xlim[2]) { |
821 | 3x |
grid::circleGrob( |
822 | 3x |
x = grid::unit(x, "native"), |
823 | 3x |
y = y, |
824 | 3x |
r = grid::unit(1 / 3.5 * symbol_size, "lines"), |
825 | 3x |
name = "point" |
826 |
) |
|
827 |
} else { |
|
828 | ! |
NULL |
829 |
} |
|
830 | ||
831 | 3x |
grid::gTree( |
832 | 3x |
children = grid::gList( |
833 | 3x |
grid::gTree( |
834 | 3x |
children = grid::gList( |
835 | 3x |
grid::gList( |
836 | 3x |
g_line, |
837 | 3x |
g_circle |
838 |
) |
|
839 |
), |
|
840 | 3x |
vp = datavp, |
841 | 3x |
gp = grid::gpar(col = col, fill = col) |
842 |
) |
|
843 |
), |
|
844 | 3x |
vp = grid::vpPath(paste0("forest-", row_index)) |
845 |
) |
|
846 |
} else { |
|
847 | ! |
NULL |
848 |
} |
|
849 |
} |
|
850 | ||
851 |
#' Create a viewport tree for the forest plot |
|
852 |
#' |
|
853 |
#' @description `r lifecycle::badge("deprecated")` |
|
854 |
#' |
|
855 |
#' @param tbl (`VTableTree`)\cr `rtables` table object. |
|
856 |
#' @param width_row_names (`grid::unit`)\cr width of row names. |
|
857 |
#' @param width_columns (`grid::unit`)\cr width of column spans. |
|
858 |
#' @param width_forest (`grid::unit`)\cr width of the forest plot. |
|
859 |
#' @param gap_column (`grid::unit`)\cr gap width between the columns. |
|
860 |
#' @param gap_header (`grid::unit`)\cr gap width between the header. |
|
861 |
#' @param mat_form (`MatrixPrintForm`)\cr matrix print form of the table. |
|
862 |
#' |
|
863 |
#' @return A viewport tree. |
|
864 |
#' |
|
865 |
#' @examples |
|
866 |
#' library(grid) |
|
867 |
#' |
|
868 |
#' tbl <- rtable( |
|
869 |
#' header = rheader( |
|
870 |
#' rrow("", "E", rcell("CI", colspan = 2)), |
|
871 |
#' rrow("", "A", "B", "C") |
|
872 |
#' ), |
|
873 |
#' rrow("row 1", 1, 0.8, 1.1), |
|
874 |
#' rrow("row 2", 1.4, 0.8, 1.6), |
|
875 |
#' rrow("row 3", 1.2, 0.8, 1.2) |
|
876 |
#' ) |
|
877 |
#' |
|
878 |
#' \donttest{ |
|
879 |
#' v <- forest_viewport(tbl) |
|
880 |
#' |
|
881 |
#' grid::grid.newpage() |
|
882 |
#' showViewport(v) |
|
883 |
#' } |
|
884 |
#' |
|
885 |
#' @export |
|
886 |
forest_viewport <- function(tbl, |
|
887 |
width_row_names = NULL, |
|
888 |
width_columns = NULL, |
|
889 |
width_forest = grid::unit(1, "null"), |
|
890 |
gap_column = grid::unit(1, "lines"), |
|
891 |
gap_header = grid::unit(1, "lines"), |
|
892 |
mat_form = NULL) { |
|
893 | 2x |
lifecycle::deprecate_warn( |
894 | 2x |
"0.9.4", |
895 | 2x |
"forest_viewport()", |
896 | 2x |
details = "`g_forest` now generates `ggplot` objects. This function is no longer used within `tern`." |
897 |
) |
|
898 | ||
899 | 2x |
checkmate::assert_class(tbl, "VTableTree") |
900 | 2x |
checkmate::assert_true(grid::is.unit(width_forest)) |
901 | 2x |
if (!is.null(width_row_names)) { |
902 | ! |
checkmate::assert_true(grid::is.unit(width_row_names)) |
903 |
} |
|
904 | 2x |
if (!is.null(width_columns)) { |
905 | ! |
checkmate::assert_true(grid::is.unit(width_columns)) |
906 |
} |
|
907 | ||
908 | 2x |
if (is.null(mat_form)) mat_form <- matrix_form(tbl) |
909 | ||
910 | 2x |
mat_form$strings[!mat_form$display] <- "" |
911 | ||
912 | 2x |
nr <- nrow(tbl) |
913 | 2x |
nc <- ncol(tbl) |
914 | 2x |
nr_h <- attr(mat_form, "nrow_header") |
915 | ||
916 | 2x |
if (is.null(width_row_names) || is.null(width_columns)) { |
917 | 2x |
tbl_widths <- formatters::propose_column_widths(mat_form) |
918 | 2x |
strs_with_width <- strrep("x", tbl_widths) # that works for mono spaced fonts |
919 | 2x |
if (is.null(width_row_names)) width_row_names <- grid::stringWidth(strs_with_width[1]) |
920 | 2x |
if (is.null(width_columns)) width_columns <- grid::stringWidth(strs_with_width[-1]) |
921 |
} |
|
922 | ||
923 |
# Widths for row name, cols, forest. |
|
924 | 2x |
widths <- grid::unit.c( |
925 | 2x |
width_row_names + gap_column, |
926 | 2x |
width_columns + gap_column, |
927 | 2x |
width_forest |
928 |
) |
|
929 | ||
930 | 2x |
n_lines_per_row <- apply( |
931 | 2x |
X = mat_form$strings, |
932 | 2x |
MARGIN = 1, |
933 | 2x |
FUN = function(row) { |
934 | 10x |
tmp <- vapply( |
935 | 10x |
gregexpr("\n", row, fixed = TRUE), |
936 | 10x |
attr, numeric(1), |
937 | 10x |
"match.length" |
938 | 10x |
) + 1 |
939 | 10x |
max(c(tmp, 1)) |
940 |
} |
|
941 |
) |
|
942 | ||
943 | 2x |
i_header <- seq_len(nr_h) |
944 | ||
945 | 2x |
height_body_rows <- grid::unit(n_lines_per_row[-i_header] * 1.2, "lines") |
946 | 2x |
height_header_rows <- grid::unit(n_lines_per_row[i_header] * 1.2, "lines") |
947 | ||
948 | 2x |
height_body <- grid::unit(sum(n_lines_per_row[-i_header]) * 1.2, "lines") |
949 | 2x |
height_header <- grid::unit(sum(n_lines_per_row[i_header]) * 1.2, "lines") |
950 | ||
951 | 2x |
nc_g <- nc + 2 # number of columns incl. row names and forest |
952 | ||
953 | 2x |
vp_tbl <- grid::vpTree( |
954 | 2x |
parent = grid::viewport( |
955 | 2x |
name = "vp_table_layout", |
956 | 2x |
layout = grid::grid.layout( |
957 | 2x |
nrow = 3, ncol = 1, |
958 | 2x |
heights = grid::unit.c(height_header, gap_header, height_body) |
959 |
) |
|
960 |
), |
|
961 | 2x |
children = grid::vpList( |
962 | 2x |
vp_forest_table_part(nr_h, nc_g, 1, 1, widths, height_header_rows, "vp_header"), |
963 | 2x |
vp_forest_table_part(nr, nc_g, 3, 1, widths, height_body_rows, "vp_body"), |
964 | 2x |
grid::viewport(name = "vp_spacer", layout.pos.row = 2, layout.pos.col = 1) |
965 |
) |
|
966 |
) |
|
967 | 2x |
vp_tbl |
968 |
} |
|
969 | ||
970 |
#' Viewport forest plot: table part |
|
971 |
#' |
|
972 |
#' @description `r lifecycle::badge("deprecated")` |
|
973 |
#' |
|
974 |
#' Prepares a viewport for the table included in the forest plot. |
|
975 |
#' |
|
976 |
#' @noRd |
|
977 |
#' @keywords internal |
|
978 |
vp_forest_table_part <- function(nrow, |
|
979 |
ncol, |
|
980 |
l_row, |
|
981 |
l_col, |
|
982 |
widths, |
|
983 |
heights, |
|
984 |
name) { |
|
985 | 4x |
lifecycle::deprecate_warn( |
986 | 4x |
"0.9.4", "vp_forest_table_part()", |
987 | 4x |
details = "`g_forest` now generates `ggplot` objects. This function is no longer used within `tern`." |
988 |
) |
|
989 | ||
990 | 4x |
grid::vpTree( |
991 | 4x |
grid::viewport( |
992 | 4x |
name = name, |
993 | 4x |
layout.pos.row = l_row, |
994 | 4x |
layout.pos.col = l_col, |
995 | 4x |
layout = grid::grid.layout(nrow = nrow, ncol = ncol, widths = widths, heights = heights) |
996 |
), |
|
997 | 4x |
children = grid::vpList( |
998 | 4x |
do.call( |
999 | 4x |
grid::vpList, |
1000 | 4x |
lapply( |
1001 | 4x |
seq_len(nrow), function(i) { |
1002 | 10x |
grid::viewport(layout.pos.row = i, layout.pos.col = 1, name = paste0("rowname-", i)) |
1003 |
} |
|
1004 |
) |
|
1005 |
), |
|
1006 | 4x |
do.call( |
1007 | 4x |
grid::vpList, |
1008 | 4x |
apply( |
1009 | 4x |
expand.grid(seq_len(nrow), seq_len(ncol - 2)), |
1010 | 4x |
1, |
1011 | 4x |
function(x) { |
1012 | 35x |
i <- x[1] |
1013 | 35x |
j <- x[2] |
1014 | 35x |
grid::viewport(layout.pos.row = i, layout.pos.col = j + 1, name = paste0("cell-", i, "-", j)) |
1015 |
} |
|
1016 |
) |
|
1017 |
), |
|
1018 | 4x |
do.call( |
1019 | 4x |
grid::vpList, |
1020 | 4x |
lapply( |
1021 | 4x |
seq_len(nrow), |
1022 | 4x |
function(i) { |
1023 | 10x |
grid::viewport(layout.pos.row = i, layout.pos.col = ncol, name = paste0("forest-", i)) |
1024 |
} |
|
1025 |
) |
|
1026 |
) |
|
1027 |
) |
|
1028 |
) |
|
1029 |
} |
|
1030 | ||
1031 |
#' Forest rendering |
|
1032 |
#' |
|
1033 |
#' @description `r lifecycle::badge("deprecated")` |
|
1034 |
#' |
|
1035 |
#' Renders the forest grob. |
|
1036 |
#' |
|
1037 |
#' @noRd |
|
1038 |
#' @keywords internal |
|
1039 |
grid.forest <- function(...) { # nolint |
|
1040 | ! |
lifecycle::deprecate_warn( |
1041 | ! |
"0.9.4", "grid.forest()", |
1042 | ! |
details = "`g_forest` now generates `ggplot` objects. This function is no longer used within `tern`." |
1043 |
) |
|
1044 | ||
1045 | ! |
grid::grid.draw(forest_grob(...)) |
1046 |
} |
1 |
#' Tabulate survival duration by subgroup |
|
2 |
#' |
|
3 |
#' @description `r lifecycle::badge("stable")` |
|
4 |
#' |
|
5 |
#' The [tabulate_survival_subgroups()] function creates a layout element to tabulate survival duration by subgroup, |
|
6 |
#' returning statistics including median survival time and hazard ratio for each population subgroup. The table is |
|
7 |
#' created from `df`, a list of data frames returned by [extract_survival_subgroups()], with the statistics to include |
|
8 |
#' specified via the `vars` parameter. |
|
9 |
#' |
|
10 |
#' A forest plot can be created from the resulting table using the [g_forest()] function. |
|
11 |
#' |
|
12 |
#' @inheritParams argument_convention |
|
13 |
#' @inheritParams survival_coxph_pairwise |
|
14 |
#' @param df (`list`)\cr list of data frames containing all analysis variables. List should be |
|
15 |
#' created using [extract_survival_subgroups()]. |
|
16 |
#' @param vars (`character`)\cr the names of statistics to be reported among: |
|
17 |
#' * `n_tot_events`: Total number of events per group. |
|
18 |
#' * `n_events`: Number of events per group. |
|
19 |
#' * `n_tot`: Total number of observations per group. |
|
20 |
#' * `n`: Number of observations per group. |
|
21 |
#' * `median`: Median survival time. |
|
22 |
#' * `hr`: Hazard ratio. |
|
23 |
#' * `ci`: Confidence interval of hazard ratio. |
|
24 |
#' * `pval`: p-value of the effect. |
|
25 |
#' Note, one of the statistics `n_tot` and `n_tot_events`, as well as both `hr` and `ci` |
|
26 |
#' are required. |
|
27 |
#' @param time_unit (`string`)\cr label with unit of median survival time. Default `NULL` skips displaying unit. |
|
28 |
#' |
|
29 |
#' @details These functions create a layout starting from a data frame which contains |
|
30 |
#' the required statistics. Tables typically used as part of forest plot. |
|
31 |
#' |
|
32 |
#' @seealso [extract_survival_subgroups()] |
|
33 |
#' |
|
34 |
#' @examples |
|
35 |
#' library(dplyr) |
|
36 |
#' |
|
37 |
#' adtte <- tern_ex_adtte |
|
38 |
#' |
|
39 |
#' # Save variable labels before data processing steps. |
|
40 |
#' adtte_labels <- formatters::var_labels(adtte) |
|
41 |
#' |
|
42 |
#' adtte_f <- adtte %>% |
|
43 |
#' filter( |
|
44 |
#' PARAMCD == "OS", |
|
45 |
#' ARM %in% c("B: Placebo", "A: Drug X"), |
|
46 |
#' SEX %in% c("M", "F") |
|
47 |
#' ) %>% |
|
48 |
#' mutate( |
|
49 |
#' # Reorder levels of ARM to display reference arm before treatment arm. |
|
50 |
#' ARM = droplevels(forcats::fct_relevel(ARM, "B: Placebo")), |
|
51 |
#' SEX = droplevels(SEX), |
|
52 |
#' AVALU = as.character(AVALU), |
|
53 |
#' is_event = CNSR == 0 |
|
54 |
#' ) |
|
55 |
#' labels <- c( |
|
56 |
#' "ARM" = adtte_labels[["ARM"]], |
|
57 |
#' "SEX" = adtte_labels[["SEX"]], |
|
58 |
#' "AVALU" = adtte_labels[["AVALU"]], |
|
59 |
#' "is_event" = "Event Flag" |
|
60 |
#' ) |
|
61 |
#' formatters::var_labels(adtte_f)[names(labels)] <- labels |
|
62 |
#' |
|
63 |
#' df <- extract_survival_subgroups( |
|
64 |
#' variables = list( |
|
65 |
#' tte = "AVAL", |
|
66 |
#' is_event = "is_event", |
|
67 |
#' arm = "ARM", subgroups = c("SEX", "BMRKR2") |
|
68 |
#' ), |
|
69 |
#' label_all = "Total Patients", |
|
70 |
#' data = adtte_f |
|
71 |
#' ) |
|
72 |
#' df |
|
73 |
#' |
|
74 |
#' df_grouped <- extract_survival_subgroups( |
|
75 |
#' variables = list( |
|
76 |
#' tte = "AVAL", |
|
77 |
#' is_event = "is_event", |
|
78 |
#' arm = "ARM", subgroups = c("SEX", "BMRKR2") |
|
79 |
#' ), |
|
80 |
#' data = adtte_f, |
|
81 |
#' groups_lists = list( |
|
82 |
#' BMRKR2 = list( |
|
83 |
#' "low" = "LOW", |
|
84 |
#' "low/medium" = c("LOW", "MEDIUM"), |
|
85 |
#' "low/medium/high" = c("LOW", "MEDIUM", "HIGH") |
|
86 |
#' ) |
|
87 |
#' ) |
|
88 |
#' ) |
|
89 |
#' df_grouped |
|
90 |
#' |
|
91 |
#' @name survival_duration_subgroups |
|
92 |
#' @order 1 |
|
93 |
NULL |
|
94 | ||
95 |
#' Prepare survival data for population subgroups in data frames |
|
96 |
#' |
|
97 |
#' @description `r lifecycle::badge("stable")` |
|
98 |
#' |
|
99 |
#' Prepares estimates of median survival times and treatment hazard ratios for population subgroups in |
|
100 |
#' data frames. Simple wrapper for [h_survtime_subgroups_df()] and [h_coxph_subgroups_df()]. Result is a `list` |
|
101 |
#' of two `data.frame`s: `survtime` and `hr`. `variables` corresponds to the names of variables found in `data`, |
|
102 |
#' passed as a named `list` and requires elements `tte`, `is_event`, `arm` and optionally `subgroups` and `strata`. |
|
103 |
#' `groups_lists` optionally specifies groupings for `subgroups` variables. |
|
104 |
#' |
|
105 |
#' @inheritParams argument_convention |
|
106 |
#' @inheritParams survival_duration_subgroups |
|
107 |
#' @inheritParams survival_coxph_pairwise |
|
108 |
#' |
|
109 |
#' @return A named `list` of two elements: |
|
110 |
#' * `survtime`: A `data.frame` containing columns `arm`, `n`, `n_events`, `median`, `subgroup`, `var`, |
|
111 |
#' `var_label`, and `row_type`. |
|
112 |
#' * `hr`: A `data.frame` containing columns `arm`, `n_tot`, `n_tot_events`, `hr`, `lcl`, `ucl`, `conf_level`, |
|
113 |
#' `pval`, `pval_label`, `subgroup`, `var`, `var_label`, and `row_type`. |
|
114 |
#' |
|
115 |
#' @seealso [survival_duration_subgroups] |
|
116 |
#' |
|
117 |
#' @export |
|
118 |
extract_survival_subgroups <- function(variables, |
|
119 |
data, |
|
120 |
groups_lists = list(), |
|
121 |
control = control_coxph(), |
|
122 |
label_all = "All Patients") { |
|
123 | 12x |
if ("strat" %in% names(variables)) { |
124 | ! |
warning( |
125 | ! |
"Warning: the `strat` element name of the `variables` list argument to `extract_survival_subgroups() ", |
126 | ! |
"was deprecated in tern 0.9.4.\n ", |
127 | ! |
"Please use the name `strata` instead of `strat` in the `variables` argument." |
128 |
) |
|
129 | ! |
variables[["strata"]] <- variables[["strat"]] |
130 |
} |
|
131 | ||
132 | 12x |
df_survtime <- h_survtime_subgroups_df( |
133 | 12x |
variables, |
134 | 12x |
data, |
135 | 12x |
groups_lists = groups_lists, |
136 | 12x |
label_all = label_all |
137 |
) |
|
138 | 12x |
df_hr <- h_coxph_subgroups_df( |
139 | 12x |
variables, |
140 | 12x |
data, |
141 | 12x |
groups_lists = groups_lists, |
142 | 12x |
control = control, |
143 | 12x |
label_all = label_all |
144 |
) |
|
145 | ||
146 | 12x |
list(survtime = df_survtime, hr = df_hr) |
147 |
} |
|
148 | ||
149 |
#' @describeIn survival_duration_subgroups Formatted analysis function which is used as |
|
150 |
#' `afun` in `tabulate_survival_subgroups()`. |
|
151 |
#' |
|
152 |
#' @return |
|
153 |
#' * `a_survival_subgroups()` returns the corresponding list with formatted [rtables::CellValue()]. |
|
154 |
#' |
|
155 |
#' @keywords internal |
|
156 |
a_survival_subgroups <- function(df, |
|
157 |
labelstr = "", |
|
158 |
..., |
|
159 |
.stats = NULL, |
|
160 |
.stat_names = NULL, |
|
161 |
.formats = NULL, |
|
162 |
.labels = NULL, |
|
163 |
.indent_mods = NULL) { |
|
164 |
# Check for additional parameters to the statistics function |
|
165 | 335x |
dots_extra_args <- list(...) |
166 | 335x |
extra_afun_params <- retrieve_extra_afun_params(names(dots_extra_args$.additional_fun_parameters)) |
167 | 335x |
dots_extra_args$.additional_fun_parameters <- NULL |
168 | 335x |
cur_col_stat <- extra_afun_params$.var %||% .stats |
169 | ||
170 |
# Uniquely name & label rows |
|
171 | 335x |
var_lvls <- if ("biomarker" %in% names(dots_extra_args) && "biomarker" %in% names(df)) { |
172 | 126x |
if ("overall" %in% names(dots_extra_args)) { # label rows for (nested) biomarker tables - e.g. "AGE", "BMRKR1" |
173 | 54x |
as.character(df$biomarker) |
174 | 335x |
} else { # data rows for (nested) biomarker tables - e.g. "AGE.LOW", "BMRKR1.Total Patients" |
175 | 72x |
paste(as.character(df$biomarker), as.character(df$subgroup), sep = ".") |
176 |
} |
|
177 | 335x |
} else { # data rows for non-biomarker tables - e.g. "Total Patients", "F", "M" |
178 | 209x |
make.unique(as.character(df$subgroup)) |
179 |
} |
|
180 | ||
181 |
# if empty, return NA |
|
182 | 335x |
if (nrow(df) == 0) { |
183 | 1x |
return(in_rows(.list = list(NA) %>% stats::setNames(cur_col_stat))) |
184 |
} |
|
185 | ||
186 |
# Main statistics taken from df |
|
187 | 334x |
x_stats <- as.list(df) |
188 | ||
189 |
# Fill in formatting defaults |
|
190 | 334x |
.stats <- get_stats("tabulate_survival_subgroups", stats_in = cur_col_stat) |
191 | 334x |
levels_per_stats <- rep(list(var_lvls), length(.stats)) %>% setNames(.stats) |
192 | 334x |
.formats <- get_formats_from_stats(.stats, .formats, levels_per_stats) |
193 | 334x |
.labels <- get_labels_from_stats( |
194 | 334x |
.stats, .labels, levels_per_stats, |
195 |
# default labels are pre-determined in extract_*() function |
|
196 | 334x |
tern_defaults = as.list(as.character(df$subgroup)) %>% setNames(var_lvls) |
197 |
) |
|
198 | 334x |
.indent_mods <- get_indents_from_stats(.stats, .indent_mods, levels_per_stats) |
199 | ||
200 | 334x |
x_stats <- lapply( |
201 | 334x |
.stats, |
202 | 334x |
function(x) x_stats[[x]] %>% stats::setNames(var_lvls) |
203 |
) %>% |
|
204 | 334x |
stats::setNames(.stats) %>% |
205 | 334x |
.unlist_keep_nulls() |
206 | ||
207 |
# Auto format handling |
|
208 | 334x |
.formats <- apply_auto_formatting(.formats, x_stats, extra_afun_params$.df_row, extra_afun_params$.var) |
209 | ||
210 |
# Get and check statistical names |
|
211 | 334x |
.stat_names <- get_stat_names(x_stats, .stat_names) |
212 | ||
213 | 334x |
in_rows( |
214 | 334x |
.list = x_stats, |
215 | 334x |
.formats = .formats, |
216 | 334x |
.names = names(.labels), |
217 | 334x |
.stat_names = .stat_names, |
218 | 334x |
.labels = .labels %>% .unlist_keep_nulls(), |
219 | 334x |
.indent_mods = .indent_mods %>% .unlist_keep_nulls() |
220 |
) |
|
221 |
} |
|
222 | ||
223 |
#' @describeIn survival_duration_subgroups Table-creating function which creates a table |
|
224 |
#' summarizing survival by subgroup. This function is a wrapper for [rtables::analyze_colvars()] |
|
225 |
#' and [rtables::summarize_row_groups()]. |
|
226 |
#' |
|
227 |
#' @param label_all `r lifecycle::badge("deprecated")`\cr please assign the `label_all` parameter within the |
|
228 |
#' [extract_survival_subgroups()] function when creating `df`. |
|
229 |
#' @param riskdiff (`list`)\cr if a risk (proportion) difference column should be added, a list of settings to apply |
|
230 |
#' within the column. See [control_riskdiff()] for details. If `NULL`, no risk difference column will be added. If |
|
231 |
#' `riskdiff$arm_x` and `riskdiff$arm_y` are `NULL`, the first level of `df$survtime$arm` will be used as `arm_x` |
|
232 |
#' and the second level as `arm_y`. |
|
233 |
#' |
|
234 |
#' @return An `rtables` table summarizing survival by subgroup. |
|
235 |
#' |
|
236 |
#' @examples |
|
237 |
#' ## Table with default columns. |
|
238 |
#' basic_table() %>% |
|
239 |
#' tabulate_survival_subgroups(df, time_unit = adtte_f$AVALU[1]) |
|
240 |
#' |
|
241 |
#' ## Table with a manually chosen set of columns: adding "pval". |
|
242 |
#' basic_table() %>% |
|
243 |
#' tabulate_survival_subgroups( |
|
244 |
#' df = df, |
|
245 |
#' vars = c("n_tot_events", "n_events", "median", "hr", "ci", "pval"), |
|
246 |
#' time_unit = adtte_f$AVALU[1] |
|
247 |
#' ) |
|
248 |
#' |
|
249 |
#' @export |
|
250 |
#' @order 2 |
|
251 |
tabulate_survival_subgroups <- function(lyt, |
|
252 |
df, |
|
253 |
vars = c("n_tot_events", "n_events", "median", "hr", "ci"), |
|
254 |
groups_lists = list(), |
|
255 |
label_all = lifecycle::deprecated(), |
|
256 |
time_unit = NULL, |
|
257 |
riskdiff = NULL, |
|
258 |
na_str = default_na_str(), |
|
259 |
..., |
|
260 |
.stat_names = NULL, |
|
261 |
.formats = NULL, |
|
262 |
.labels = NULL, |
|
263 |
.indent_mods = NULL) { |
|
264 | 11x |
checkmate::assert_list(riskdiff, null.ok = TRUE) |
265 | 11x |
checkmate::assert_true(any(c("n_tot", "n_tot_events") %in% vars)) |
266 | 11x |
checkmate::assert_true(all(c("hr", "ci") %in% vars)) |
267 | 11x |
if ("pval" %in% vars && !"pval" %in% names(df$hr)) { |
268 | ! |
warning( |
269 | ! |
'The "pval" statistic has been selected but is not present in "df" so it will not be included in the output ', |
270 | ! |
'table. To include the "pval" statistic, please specify a p-value test when generating "df" via ', |
271 | ! |
'the "method" argument to `extract_survival_subgroups()`. If method = "cmh", strata must also be specified via ', |
272 | ! |
'the "variables" argument to `extract_survival_subgroups()`.' |
273 |
) |
|
274 |
} |
|
275 | ||
276 | 11x |
if (lifecycle::is_present(label_all)) { |
277 | 1x |
lifecycle::deprecate_warn( |
278 | 1x |
"0.9.5", "tabulate_survival_subgroups(label_all)", |
279 | 1x |
details = |
280 | 1x |
"Please assign the `label_all` parameter within the `extract_survival_subgroups()` function when creating `df`." |
281 |
) |
|
282 |
} |
|
283 | ||
284 |
# Process standard extra arguments |
|
285 | 11x |
extra_args <- list(".stats" = vars) |
286 | ! |
if (!is.null(.stat_names)) extra_args[[".stat_names"]] <- .stat_names |
287 | 1x |
if (!is.null(.formats)) extra_args[[".formats"]] <- .formats |
288 | ! |
if (!is.null(.labels)) extra_args[[".labels"]] <- .labels |
289 | ! |
if (!is.null(.indent_mods)) extra_args[[".indent_mods"]] <- .indent_mods |
290 | ||
291 |
# Create "ci" column from "lcl" and "ucl" |
|
292 | 11x |
df$hr$ci <- combine_vectors(df$hr$lcl, df$hr$ucl) |
293 | ||
294 |
# Extract additional parameters from df |
|
295 | 11x |
conf_level <- df$hr$conf_level[1] |
296 | 11x |
method <- if ("pval_label" %in% names(df$hr)) df$hr$pval_label[1] else NULL |
297 | 11x |
colvars <- d_survival_subgroups_colvars(vars, conf_level = conf_level, method = method, time_unit = time_unit) |
298 | 11x |
survtime_vars <- intersect(colvars$vars, c("n", "n_events", "median")) |
299 | 11x |
hr_vars <- intersect(names(colvars$labels), c("n_tot", "n_tot_events", "hr", "ci", "pval")) |
300 | 11x |
colvars_survtime <- list(vars = survtime_vars, labels = colvars$labels[survtime_vars]) |
301 | 11x |
colvars_hr <- list(vars = hr_vars, labels = colvars$labels[hr_vars]) |
302 | ||
303 |
# Process additional arguments to the statistic function |
|
304 | 11x |
extra_args <- c( |
305 | 11x |
extra_args, |
306 | 11x |
groups_lists = list(groups_lists), conf_level = conf_level, method = method, |
307 |
... |
|
308 |
) |
|
309 | ||
310 |
# Adding additional info from layout to analysis function |
|
311 | 11x |
extra_args[[".additional_fun_parameters"]] <- get_additional_afun_params(add_alt_df = FALSE) |
312 | 11x |
formals(a_survival_subgroups) <- c(formals(a_survival_subgroups), extra_args[[".additional_fun_parameters"]]) |
313 | ||
314 |
# Add risk difference column |
|
315 | 11x |
if (!is.null(riskdiff)) { |
316 | 2x |
if (is.null(riskdiff$arm_x)) riskdiff$arm_x <- levels(df$survtime$arm)[1] |
317 | 2x |
if (is.null(riskdiff$arm_y)) riskdiff$arm_y <- levels(df$survtime$arm)[2] |
318 | 2x |
colvars_hr$vars <- c(colvars_hr$vars, "riskdiff") |
319 | 2x |
colvars_hr$labels <- c(colvars_hr$labels, riskdiff = riskdiff$col_label) |
320 | 2x |
arm_cols <- paste(rep(c("n_events", "n_events", "n", "n")), c(riskdiff$arm_x, riskdiff$arm_y), sep = "_") |
321 | ||
322 | 2x |
df_prop_diff <- df$survtime %>% |
323 | 2x |
dplyr::select(-"median") %>% |
324 | 2x |
tidyr::pivot_wider( |
325 | 2x |
id_cols = c("subgroup", "var", "var_label", "row_type"), |
326 | 2x |
names_from = "arm", |
327 | 2x |
values_from = c("n", "n_events") |
328 |
) %>% |
|
329 | 2x |
dplyr::rowwise() %>% |
330 | 2x |
dplyr::mutate( |
331 | 2x |
riskdiff = stat_propdiff_ci( |
332 | 2x |
x = as.list(.data[[arm_cols[1]]]), |
333 | 2x |
y = as.list(.data[[arm_cols[2]]]), |
334 | 2x |
N_x = .data[[arm_cols[3]]], |
335 | 2x |
N_y = .data[[arm_cols[4]]], |
336 | 2x |
pct = riskdiff$pct |
337 |
) |
|
338 |
) %>% |
|
339 | 2x |
dplyr::select(-dplyr::all_of(arm_cols)) |
340 | ||
341 | 2x |
df$hr <- df$hr %>% |
342 | 2x |
dplyr::left_join( |
343 | 2x |
df_prop_diff, |
344 | 2x |
by = c("subgroup", "var", "var_label", "row_type") |
345 |
) |
|
346 |
} |
|
347 | ||
348 |
# Add columns from table_survtime (optional) |
|
349 | 11x |
if (length(colvars_survtime$vars) > 0) { |
350 | 10x |
lyt_survtime <- split_cols_by(lyt = lyt, var = "arm") |
351 | 10x |
lyt_survtime <- split_cols_by_multivar( |
352 | 10x |
lyt = lyt_survtime, |
353 | 10x |
vars = colvars_survtime$vars, |
354 | 10x |
varlabels = colvars_survtime$labels |
355 |
) |
|
356 | ||
357 |
# Add "All Patients" row |
|
358 | 10x |
lyt_survtime <- split_rows_by( |
359 | 10x |
lyt = lyt_survtime, |
360 | 10x |
var = "row_type", |
361 | 10x |
split_fun = keep_split_levels("content"), |
362 | 10x |
nested = FALSE, |
363 | 10x |
child_labels = "hidden", |
364 | 10x |
parent_name = "All Patients" |
365 |
) |
|
366 | 10x |
lyt_survtime <- analyze_colvars( |
367 | 10x |
lyt = lyt_survtime, |
368 | 10x |
afun = a_survival_subgroups, |
369 | 10x |
na_str = na_str, |
370 | 10x |
extra_args = extra_args |
371 |
) |
|
372 | ||
373 |
# Add analysis rows |
|
374 | 10x |
if ("analysis" %in% df$survtime$row_type) { |
375 | 9x |
lyt_survtime <- split_rows_by( |
376 | 9x |
lyt = lyt_survtime, |
377 | 9x |
var = "row_type", |
378 | 9x |
split_fun = keep_split_levels("analysis"), |
379 | 9x |
nested = FALSE, |
380 | 9x |
child_labels = "hidden", |
381 | 9x |
parent_name = "analysis rows" |
382 |
) |
|
383 | 9x |
lyt_survtime <- split_rows_by(lyt = lyt_survtime, var = "var_label", nested = TRUE) |
384 | 9x |
lyt_survtime <- analyze_colvars( |
385 | 9x |
lyt = lyt_survtime, |
386 | 9x |
afun = a_survival_subgroups, |
387 | 9x |
na_str = na_str, |
388 | 9x |
inclNAs = TRUE, |
389 | 9x |
extra_args = extra_args |
390 |
) |
|
391 |
} |
|
392 | ||
393 | 10x |
table_survtime <- build_table(lyt_survtime, df = df$survtime) |
394 |
} else { |
|
395 | 1x |
table_survtime <- NULL |
396 |
} |
|
397 | ||
398 |
# Add columns from table_hr ("n_tot_events" or "n_tot", "hr" and "ci" required) |
|
399 | 11x |
lyt_hr <- split_cols_by(lyt = lyt, var = "arm") |
400 | 11x |
lyt_hr <- split_cols_by_multivar( |
401 | 11x |
lyt = lyt_hr, |
402 | 11x |
vars = colvars_hr$vars, |
403 | 11x |
varlabels = colvars_hr$labels |
404 |
) |
|
405 | ||
406 |
# Add "All Patients" row |
|
407 | 11x |
lyt_hr <- split_rows_by( |
408 | 11x |
lyt = lyt_hr, |
409 | 11x |
var = "row_type", |
410 | 11x |
split_fun = keep_split_levels("content"), |
411 | 11x |
nested = FALSE, |
412 | 11x |
child_labels = "hidden", |
413 | 11x |
parent_name = "All patient row" |
414 |
) |
|
415 | 11x |
lyt_hr <- analyze_colvars( |
416 | 11x |
lyt = lyt_hr, |
417 | 11x |
afun = a_survival_subgroups, |
418 | 11x |
na_str = na_str, |
419 | 11x |
extra_args = extra_args |
420 |
) %>% |
|
421 | 11x |
append_topleft("Baseline Risk Factors") |
422 | ||
423 |
# Add analysis rows |
|
424 | 11x |
if ("analysis" %in% df$survtime$row_type) { |
425 | 10x |
lyt_hr <- split_rows_by( |
426 | 10x |
lyt = lyt_hr, |
427 | 10x |
var = "row_type", |
428 | 10x |
split_fun = keep_split_levels("analysis"), |
429 | 10x |
nested = FALSE, |
430 | 10x |
child_labels = "hidden", |
431 | 10x |
parent_name = "analysis rows" |
432 |
) |
|
433 | 10x |
lyt_hr <- split_rows_by(lyt = lyt_hr, var = "var_label", nested = TRUE) |
434 | 10x |
lyt_hr <- analyze_colvars( |
435 | 10x |
lyt = lyt_hr, |
436 | 10x |
afun = a_survival_subgroups, |
437 | 10x |
na_str = na_str, |
438 | 10x |
inclNAs = TRUE, |
439 | 10x |
extra_args = extra_args |
440 |
) |
|
441 |
} |
|
442 | ||
443 | 11x |
table_hr <- build_table(lyt_hr, df = df$hr) |
444 | ||
445 |
# Join tables, add forest plot attributes |
|
446 | 11x |
n_tot_ids <- grep("^n_tot", colvars_hr$vars) |
447 | 11x |
if (is.null(table_survtime)) { |
448 | 1x |
result <- table_hr |
449 | 1x |
hr_id <- match("hr", colvars_hr$vars) |
450 | 1x |
ci_id <- match("ci", colvars_hr$vars) |
451 |
} else { |
|
452 | 10x |
result <- cbind_rtables(table_hr[, n_tot_ids], table_survtime, table_hr[, -n_tot_ids]) |
453 | 10x |
hr_id <- length(n_tot_ids) + ncol(table_survtime) + match("hr", colvars_hr$vars[-n_tot_ids]) |
454 | 10x |
ci_id <- length(n_tot_ids) + ncol(table_survtime) + match("ci", colvars_hr$vars[-n_tot_ids]) |
455 | 10x |
n_tot_ids <- seq_along(n_tot_ids) |
456 |
} |
|
457 | 11x |
structure( |
458 | 11x |
result, |
459 | 11x |
forest_header = paste0(rev(levels(df$survtime$arm)), "\nBetter"), |
460 | 11x |
col_x = hr_id, |
461 | 11x |
col_ci = ci_id, |
462 | 11x |
col_symbol_size = n_tot_ids[1] # for scaling the symbol sizes in forest plots |
463 |
) |
|
464 |
} |
|
465 | ||
466 |
#' Labels for column variables in survival duration by subgroup table |
|
467 |
#' |
|
468 |
#' @description `r lifecycle::badge("stable")` |
|
469 |
#' |
|
470 |
#' Internal function to check variables included in [tabulate_survival_subgroups()] and create column labels. |
|
471 |
#' |
|
472 |
#' @inheritParams tabulate_survival_subgroups |
|
473 |
#' @inheritParams argument_convention |
|
474 |
#' @param method (`string`)\cr p-value method for testing hazard ratio = 1. |
|
475 |
#' |
|
476 |
#' @return A `list` of variables and their labels to tabulate. |
|
477 |
#' |
|
478 |
#' @note At least one of `n_tot` and `n_tot_events` must be provided in `vars`. |
|
479 |
#' |
|
480 |
#' @export |
|
481 |
d_survival_subgroups_colvars <- function(vars, |
|
482 |
conf_level, |
|
483 |
method, |
|
484 |
time_unit = NULL) { |
|
485 | 18x |
checkmate::assert_character(vars) |
486 | 18x |
checkmate::assert_string(time_unit, null.ok = TRUE) |
487 | 18x |
checkmate::assert_subset(c("hr", "ci"), vars) |
488 | 18x |
checkmate::assert_true(any(c("n_tot", "n_tot_events") %in% vars)) |
489 | 18x |
checkmate::assert_subset( |
490 | 18x |
vars, |
491 | 18x |
c("n", "n_events", "median", "n_tot", "n_tot_events", "hr", "ci", "pval") |
492 |
) |
|
493 | ||
494 | 18x |
propcase_time_label <- if (!is.null(time_unit)) { |
495 | 17x |
paste0("Median (", time_unit, ")") |
496 |
} else { |
|
497 | 1x |
"Median" |
498 |
} |
|
499 | ||
500 | 18x |
varlabels <- c( |
501 | 18x |
n = "n", |
502 | 18x |
n_events = "Events", |
503 | 18x |
median = propcase_time_label, |
504 | 18x |
n_tot = "Total n", |
505 | 18x |
n_tot_events = "Total Events", |
506 | 18x |
hr = "Hazard Ratio", |
507 | 18x |
ci = paste0(100 * conf_level, "% Wald CI"), |
508 | 18x |
pval = method |
509 |
) |
|
510 | ||
511 | 18x |
colvars <- vars |
512 | ||
513 | 18x |
list( |
514 | 18x |
vars = colvars, |
515 | 18x |
labels = varlabels[vars] |
516 |
) |
|
517 |
} |
1 |
#' Proportion estimation |
|
2 |
#' |
|
3 |
#' @description `r lifecycle::badge("stable")` |
|
4 |
#' |
|
5 |
#' The analyze function [estimate_proportion()] creates a layout element to estimate the proportion of responders |
|
6 |
#' within a studied population. The primary analysis variable, `vars`, indicates whether a response has occurred for |
|
7 |
#' each record. See the `method` parameter for options of methods to use when constructing the confidence interval of |
|
8 |
#' the proportion. Additionally, a stratification variable can be supplied via the `strata` element of the `variables` |
|
9 |
#' argument. |
|
10 |
#' |
|
11 |
#' @inheritParams prop_strat_wilson |
|
12 |
#' @inheritParams argument_convention |
|
13 |
#' @param method (`string`)\cr the method used to construct the confidence interval |
|
14 |
#' for proportion of successful outcomes; one of `waldcc`, `wald`, `clopper-pearson`, |
|
15 |
#' `wilson`, `wilsonc`, `strat_wilson`, `strat_wilsonc`, `agresti-coull` or `jeffreys`. |
|
16 |
#' @param long (`flag`)\cr whether a long description is required. |
|
17 |
#' @param .stats (`character`)\cr statistics to select for the table. |
|
18 |
#' |
|
19 |
#' Options are: ``r shQuote(get_stats("estimate_proportion"), type = "sh")`` |
|
20 |
#' |
|
21 |
#' @seealso [h_proportions] |
|
22 |
#' |
|
23 |
#' @name estimate_proportion |
|
24 |
#' @order 1 |
|
25 |
NULL |
|
26 | ||
27 |
#' @describeIn estimate_proportion Statistics function estimating a |
|
28 |
#' proportion along with its confidence interval. |
|
29 |
#' |
|
30 |
#' @param df (`logical` or `data.frame`)\cr if only a logical vector is used, |
|
31 |
#' it indicates whether each subject is a responder or not. `TRUE` represents |
|
32 |
#' a successful outcome. If a `data.frame` is provided, also the `strata` variable |
|
33 |
#' names must be provided in `variables` as a list element with the strata strings. |
|
34 |
#' In the case of `data.frame`, the logical vector of responses must be indicated as a |
|
35 |
#' variable name in `.var`. |
|
36 |
#' |
|
37 |
#' @return |
|
38 |
#' * `s_proportion()` returns statistics `n_prop` (`n` and proportion) and `prop_ci` (proportion CI) for a |
|
39 |
#' given variable. |
|
40 |
#' |
|
41 |
#' @examples |
|
42 |
#' # Case with only logical vector. |
|
43 |
#' rsp_v <- c(1, 0, 1, 0, 1, 1, 0, 0) |
|
44 |
#' s_proportion(rsp_v) |
|
45 |
#' |
|
46 |
#' # Example for Stratified Wilson CI |
|
47 |
#' nex <- 100 # Number of example rows |
|
48 |
#' dta <- data.frame( |
|
49 |
#' "rsp" = sample(c(TRUE, FALSE), nex, TRUE), |
|
50 |
#' "grp" = sample(c("A", "B"), nex, TRUE), |
|
51 |
#' "f1" = sample(c("a1", "a2"), nex, TRUE), |
|
52 |
#' "f2" = sample(c("x", "y", "z"), nex, TRUE), |
|
53 |
#' stringsAsFactors = TRUE |
|
54 |
#' ) |
|
55 |
#' |
|
56 |
#' s_proportion( |
|
57 |
#' df = dta, |
|
58 |
#' .var = "rsp", |
|
59 |
#' variables = list(strata = c("f1", "f2")), |
|
60 |
#' conf_level = 0.90, |
|
61 |
#' method = "strat_wilson" |
|
62 |
#' ) |
|
63 |
#' |
|
64 |
#' @export |
|
65 |
s_proportion <- function(df, |
|
66 |
.var, |
|
67 |
conf_level = 0.95, |
|
68 |
method = c( |
|
69 |
"waldcc", "wald", "clopper-pearson", |
|
70 |
"wilson", "wilsonc", "strat_wilson", "strat_wilsonc", |
|
71 |
"agresti-coull", "jeffreys" |
|
72 |
), |
|
73 |
weights = NULL, |
|
74 |
max_iterations = 50, |
|
75 |
variables = list(strata = NULL), |
|
76 |
long = FALSE, |
|
77 |
denom = c("n", "N_col", "N_row"), |
|
78 |
...) { |
|
79 | 182x |
method <- match.arg(method) |
80 | 182x |
checkmate::assert_flag(long) |
81 | 182x |
assert_proportion_value(conf_level) |
82 | 182x |
args_list <- list(...) |
83 | 182x |
.N_row <- args_list[[".N_row"]] # nolint |
84 | 182x |
.N_col <- args_list[[".N_col"]] # nolint |
85 | ||
86 | 182x |
if (!is.null(variables$strata)) { |
87 |
# Checks for strata |
|
88 | ! |
if (missing(df)) stop("When doing stratified analysis a data.frame with specific columns is needed.") |
89 | 9x |
strata_colnames <- variables$strata |
90 | 9x |
checkmate::assert_character(strata_colnames, null.ok = FALSE) |
91 | 9x |
strata_vars <- stats::setNames(as.list(strata_colnames), strata_colnames) |
92 | 9x |
assert_df_with_variables(df, strata_vars) |
93 | ||
94 | 9x |
strata <- interaction(df[strata_colnames]) |
95 | 9x |
strata <- as.factor(strata) |
96 | ||
97 |
# Pushing down checks to prop_strat_wilson |
|
98 | 173x |
} else if (checkmate::test_subset(method, c("strat_wilson", "strat_wilsonc"))) { |
99 | ! |
stop("To use stratified methods you need to specify the strata variables.") |
100 |
} |
|
101 | ||
102 |
# Finding the Responders |
|
103 | 182x |
if (checkmate::test_atomic_vector(df)) { |
104 | 167x |
rsp <- as.logical(df) |
105 |
} else { |
|
106 | 15x |
rsp <- as.logical(df[[.var]]) |
107 |
} |
|
108 | ||
109 |
# Stop for stratified analysis |
|
110 | 182x |
if (method %in% c("strat_wilson", "strat_wilsonc") && denom[1] != "n") { |
111 | 1x |
stop( |
112 | 1x |
"Stratified methods only support 'n' as the denominator (denom). ", |
113 | 1x |
"Consider adding negative responders directly to the dataset." |
114 |
) |
|
115 |
} |
|
116 | ||
117 | 181x |
denom <- match.arg(denom) %>% |
118 | 181x |
switch( |
119 | 181x |
n = length(rsp), |
120 | 181x |
N_row = .N_row, |
121 | 181x |
N_col = .N_col |
122 |
) |
|
123 | 181x |
n_rsp <- sum(rsp) |
124 | 181x |
p_hat <- ifelse(denom > 0, n_rsp / denom, 0) |
125 | ||
126 | 181x |
prop_ci <- switch(method, |
127 | 181x |
"clopper-pearson" = prop_clopper_pearson(rsp, n = denom, conf_level), |
128 | 181x |
"wilson" = prop_wilson(rsp, n = denom, conf_level), |
129 | 181x |
"wilsonc" = prop_wilson(rsp, n = denom, conf_level, correct = TRUE), |
130 | 181x |
"strat_wilson" = prop_strat_wilson(rsp, strata, weights, conf_level, max_iterations, correct = FALSE)$conf_int, |
131 | 181x |
"strat_wilsonc" = prop_strat_wilson(rsp, strata, weights, conf_level, max_iterations, correct = TRUE)$conf_int, |
132 | 181x |
"wald" = prop_wald(rsp, n = denom, conf_level), |
133 | 181x |
"waldcc" = prop_wald(rsp, n = denom, conf_level, correct = TRUE), |
134 | 181x |
"agresti-coull" = prop_agresti_coull(rsp, n = denom, conf_level), |
135 | 181x |
"jeffreys" = prop_jeffreys(rsp, n = denom, conf_level) |
136 |
) |
|
137 | ||
138 | 181x |
list( |
139 | 181x |
"n_prop" = formatters::with_label(c(n_rsp, p_hat), "Responders"), |
140 | 181x |
"prop_ci" = formatters::with_label(x = 100 * prop_ci, label = d_proportion(conf_level, method, long = long)) |
141 |
) |
|
142 |
} |
|
143 | ||
144 |
#' @describeIn estimate_proportion Formatted analysis function which is used as `afun` |
|
145 |
#' in `estimate_proportion()`. |
|
146 |
#' |
|
147 |
#' @return |
|
148 |
#' * `a_proportion()` returns the corresponding list with formatted [rtables::CellValue()]. |
|
149 |
#' |
|
150 |
#' @export |
|
151 |
a_proportion <- function(df, |
|
152 |
..., |
|
153 |
.stats = NULL, |
|
154 |
.stat_names = NULL, |
|
155 |
.formats = NULL, |
|
156 |
.labels = NULL, |
|
157 |
.indent_mods = NULL) { |
|
158 |
# Check for additional parameters to the statistics function |
|
159 | 15x |
dots_extra_args <- list(...) |
160 | 15x |
extra_afun_params <- retrieve_extra_afun_params(names(dots_extra_args$.additional_fun_parameters)) |
161 | 15x |
dots_extra_args$.additional_fun_parameters <- NULL |
162 | ||
163 |
# Check for user-defined functions |
|
164 | 15x |
default_and_custom_stats_list <- .split_std_from_custom_stats(.stats) |
165 | 15x |
.stats <- default_and_custom_stats_list$all_stats |
166 | 15x |
custom_stat_functions <- default_and_custom_stats_list$custom_stats |
167 | ||
168 |
# Apply statistics function |
|
169 | 15x |
x_stats <- .apply_stat_functions( |
170 | 15x |
default_stat_fnc = s_proportion, |
171 | 15x |
custom_stat_fnc_list = custom_stat_functions, |
172 | 15x |
args_list = c( |
173 | 15x |
df = list(df), |
174 | 15x |
extra_afun_params, |
175 | 15x |
dots_extra_args |
176 |
) |
|
177 |
) |
|
178 | ||
179 |
# Fill in formatting defaults |
|
180 | 14x |
.stats <- get_stats("estimate_proportion", |
181 | 14x |
stats_in = .stats, |
182 | 14x |
custom_stats_in = names(custom_stat_functions) |
183 |
) |
|
184 | 14x |
x_stats <- x_stats[.stats] |
185 | 14x |
.formats <- get_formats_from_stats(.stats, .formats) |
186 | 14x |
.labels <- get_labels_from_stats( |
187 | 14x |
.stats, .labels, |
188 | 14x |
tern_defaults = c(lapply(x_stats, attr, "label"), tern_default_labels) |
189 |
) |
|
190 | 14x |
.indent_mods <- get_indents_from_stats(.stats, .indent_mods) |
191 | ||
192 |
# Auto format handling |
|
193 | 14x |
.formats <- apply_auto_formatting(.formats, x_stats, extra_afun_params$.df_row, extra_afun_params$.var) |
194 | ||
195 |
# Get and check statistical names |
|
196 | 14x |
.stat_names <- get_stat_names(x_stats, .stat_names) |
197 | ||
198 | 14x |
in_rows( |
199 | 14x |
.list = x_stats, |
200 | 14x |
.formats = .formats, |
201 | 14x |
.names = .labels %>% .unlist_keep_nulls(), |
202 | 14x |
.stat_names = .stat_names, |
203 | 14x |
.labels = .labels %>% .unlist_keep_nulls(), |
204 | 14x |
.indent_mods = .indent_mods %>% .unlist_keep_nulls() |
205 |
) |
|
206 |
} |
|
207 | ||
208 |
#' @describeIn estimate_proportion Layout-creating function which can take statistics function arguments |
|
209 |
#' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
|
210 |
#' |
|
211 |
#' @return |
|
212 |
#' * `estimate_proportion()` returns a layout object suitable for passing to further layouting functions, |
|
213 |
#' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
|
214 |
#' the statistics from `s_proportion()` to the table layout. |
|
215 |
#' |
|
216 |
#' @examples |
|
217 |
#' dta_test <- data.frame( |
|
218 |
#' USUBJID = paste0("S", 1:12), |
|
219 |
#' ARM = rep(LETTERS[1:3], each = 4), |
|
220 |
#' AVAL = rep(LETTERS[1:3], each = 4) |
|
221 |
#' ) %>% |
|
222 |
#' dplyr::mutate(is_rsp = AVAL == "A") |
|
223 |
#' |
|
224 |
#' basic_table() %>% |
|
225 |
#' split_cols_by("ARM") %>% |
|
226 |
#' estimate_proportion(vars = "is_rsp") %>% |
|
227 |
#' build_table(df = dta_test) |
|
228 |
#' |
|
229 |
#' @export |
|
230 |
#' @order 2 |
|
231 |
estimate_proportion <- function(lyt, |
|
232 |
vars, |
|
233 |
conf_level = 0.95, |
|
234 |
method = c( |
|
235 |
"waldcc", "wald", "clopper-pearson", |
|
236 |
"wilson", "wilsonc", "strat_wilson", "strat_wilsonc", |
|
237 |
"agresti-coull", "jeffreys" |
|
238 |
), |
|
239 |
weights = NULL, |
|
240 |
max_iterations = 50, |
|
241 |
variables = list(strata = NULL), |
|
242 |
long = FALSE, |
|
243 |
na_str = default_na_str(), |
|
244 |
nested = TRUE, |
|
245 |
..., |
|
246 |
show_labels = "hidden", |
|
247 |
table_names = vars, |
|
248 |
.stats = c("n_prop", "prop_ci"), |
|
249 |
.stat_names = NULL, |
|
250 |
.formats = NULL, |
|
251 |
.labels = NULL, |
|
252 |
.indent_mods = NULL) { |
|
253 |
# Process standard extra arguments |
|
254 | 6x |
extra_args <- list(".stats" = .stats) |
255 | ! |
if (!is.null(.stat_names)) extra_args[[".stat_names"]] <- .stat_names |
256 | 3x |
if (!is.null(.formats)) extra_args[[".formats"]] <- .formats |
257 | ! |
if (!is.null(.labels)) extra_args[[".labels"]] <- .labels |
258 | ! |
if (!is.null(.indent_mods)) extra_args[[".indent_mods"]] <- .indent_mods |
259 | ||
260 |
# Process additional arguments to the statistic function |
|
261 | 6x |
extra_args <- c( |
262 | 6x |
extra_args, |
263 | 6x |
conf_level = list(conf_level), method = list(method), weights = list(weights), |
264 | 6x |
max_iterations = list(max_iterations), variables = list(variables), long = list(long), |
265 |
... |
|
266 |
) |
|
267 | ||
268 |
# Append additional info from layout to the analysis function |
|
269 | 6x |
extra_args[[".additional_fun_parameters"]] <- get_additional_afun_params(add_alt_df = FALSE) |
270 | 6x |
formals(a_proportion) <- c(formals(a_proportion), extra_args[[".additional_fun_parameters"]]) |
271 | ||
272 | 6x |
analyze( |
273 | 6x |
lyt = lyt, |
274 | 6x |
vars = vars, |
275 | 6x |
afun = a_proportion, |
276 | 6x |
na_str = na_str, |
277 | 6x |
nested = nested, |
278 | 6x |
extra_args = extra_args, |
279 | 6x |
show_labels = show_labels, |
280 | 6x |
table_names = table_names |
281 |
) |
|
282 |
} |
|
283 | ||
284 |
#' Helper functions for calculating proportion confidence intervals |
|
285 |
#' |
|
286 |
#' @description `r lifecycle::badge("stable")` |
|
287 |
#' |
|
288 |
#' Functions to calculate different proportion confidence intervals for use in [estimate_proportion()]. |
|
289 |
#' |
|
290 |
#' @inheritParams argument_convention |
|
291 |
#' @inheritParams estimate_proportion |
|
292 |
#' |
|
293 |
#' @return Confidence interval of a proportion. |
|
294 |
#' |
|
295 |
#' @seealso [estimate_proportion], descriptive function [d_proportion()], |
|
296 |
#' and helper functions [strata_normal_quantile()] and [update_weights_strat_wilson()]. |
|
297 |
#' |
|
298 |
#' @name h_proportions |
|
299 |
NULL |
|
300 | ||
301 |
#' @describeIn h_proportions Calculates the Wilson interval by calling [stats::prop.test()]. |
|
302 |
#' Also referred to as Wilson score interval. |
|
303 |
#' |
|
304 |
#' @examples |
|
305 |
#' rsp <- c( |
|
306 |
#' TRUE, TRUE, TRUE, TRUE, TRUE, |
|
307 |
#' FALSE, FALSE, FALSE, FALSE, FALSE |
|
308 |
#' ) |
|
309 |
#' prop_wilson(rsp, conf_level = 0.9) |
|
310 |
#' |
|
311 |
#' @export |
|
312 |
prop_wilson <- function(rsp, n = length(rsp), conf_level, correct = FALSE) { |
|
313 | 5x |
y <- stats::prop.test( |
314 | 5x |
sum(rsp), |
315 | 5x |
n, |
316 | 5x |
correct = correct, |
317 | 5x |
conf.level = conf_level |
318 |
) |
|
319 | ||
320 | 5x |
as.numeric(y$conf.int) |
321 |
} |
|
322 | ||
323 |
#' @describeIn h_proportions Calculates the stratified Wilson confidence |
|
324 |
#' interval for unequal proportions as described in \insertCite{Yan2010-jt;textual}{tern} |
|
325 |
#' |
|
326 |
#' @param strata (`factor`)\cr variable with one level per stratum and same length as `rsp`. |
|
327 |
#' @param weights (`numeric` or `NULL`)\cr weights for each level of the strata. If `NULL`, they are |
|
328 |
#' estimated using the iterative algorithm proposed in \insertCite{Yan2010-jt;textual}{tern} that |
|
329 |
#' minimizes the weighted squared length of the confidence interval. |
|
330 |
#' @param max_iterations (`count`)\cr maximum number of iterations for the iterative procedure used |
|
331 |
#' to find estimates of optimal weights. |
|
332 |
#' @param correct (`flag`)\cr whether to include the continuity correction. For further information, see for example |
|
333 |
#' for [stats::prop.test()]. |
|
334 |
#' |
|
335 |
#' @references |
|
336 |
#' \insertRef{Yan2010-jt}{tern} |
|
337 |
#' |
|
338 |
#' @examples |
|
339 |
#' # Stratified Wilson confidence interval with unequal probabilities |
|
340 |
#' |
|
341 |
#' set.seed(1) |
|
342 |
#' rsp <- sample(c(TRUE, FALSE), 100, TRUE) |
|
343 |
#' strata_data <- data.frame( |
|
344 |
#' "f1" = sample(c("a", "b"), 100, TRUE), |
|
345 |
#' "f2" = sample(c("x", "y", "z"), 100, TRUE), |
|
346 |
#' stringsAsFactors = TRUE |
|
347 |
#' ) |
|
348 |
#' strata <- interaction(strata_data) |
|
349 |
#' n_strata <- ncol(table(rsp, strata)) # Number of strata |
|
350 |
#' |
|
351 |
#' prop_strat_wilson( |
|
352 |
#' rsp = rsp, strata = strata, |
|
353 |
#' conf_level = 0.90 |
|
354 |
#' ) |
|
355 |
#' |
|
356 |
#' # Not automatic setting of weights |
|
357 |
#' prop_strat_wilson( |
|
358 |
#' rsp = rsp, strata = strata, |
|
359 |
#' weights = rep(1 / n_strata, n_strata), |
|
360 |
#' conf_level = 0.90 |
|
361 |
#' ) |
|
362 |
#' |
|
363 |
#' @export |
|
364 |
prop_strat_wilson <- function(rsp, |
|
365 |
strata, |
|
366 |
weights = NULL, |
|
367 |
conf_level = 0.95, |
|
368 |
max_iterations = NULL, |
|
369 |
correct = FALSE) { |
|
370 | 20x |
checkmate::assert_logical(rsp, any.missing = FALSE) |
371 | 20x |
checkmate::assert_factor(strata, len = length(rsp)) |
372 | 20x |
assert_proportion_value(conf_level) |
373 | ||
374 | 20x |
tbl <- table(rsp, strata) |
375 | 20x |
n_strata <- length(unique(strata)) |
376 | ||
377 |
# Checking the weights and maximum number of iterations. |
|
378 | 20x |
do_iter <- FALSE |
379 | 20x |
if (is.null(weights)) { |
380 | 6x |
weights <- rep(1 / n_strata, n_strata) # Initialization for iterative procedure |
381 | 6x |
do_iter <- TRUE |
382 | ||
383 |
# Iteration parameters |
|
384 | 2x |
if (is.null(max_iterations)) max_iterations <- 10 |
385 | 6x |
checkmate::assert_int(max_iterations, na.ok = FALSE, null.ok = FALSE, lower = 1) |
386 |
} |
|
387 | 20x |
checkmate::assert_numeric(weights, lower = 0, upper = 1, any.missing = FALSE, len = n_strata) |
388 | 20x |
sum_weights <- checkmate::assert_int(sum(weights)) |
389 | ! |
if (as.integer(sum_weights + 0.5) != 1L) stop("Sum of weights must be 1L.") |
390 | ||
391 | 20x |
xs <- tbl["TRUE", ] |
392 | 20x |
ns <- colSums(tbl) |
393 | 20x |
use_stratum <- (ns > 0) |
394 | 20x |
ns <- ns[use_stratum] |
395 | 20x |
xs <- xs[use_stratum] |
396 | 20x |
ests <- xs / ns |
397 | 20x |
vars <- ests * (1 - ests) / ns |
398 | ||
399 | 20x |
strata_qnorm <- strata_normal_quantile(vars, weights, conf_level) |
400 | ||
401 |
# Iterative setting of weights if they were not set externally |
|
402 | 20x |
weights_new <- if (do_iter) { |
403 | 6x |
update_weights_strat_wilson(vars, strata_qnorm, weights, ns, max_iterations, conf_level)$weights |
404 |
} else { |
|
405 | 14x |
weights |
406 |
} |
|
407 | ||
408 | 20x |
strata_conf_level <- 2 * stats::pnorm(strata_qnorm) - 1 |
409 | ||
410 | 20x |
ci_by_strata <- Map( |
411 | 20x |
function(x, n) { |
412 |
# Classic Wilson's confidence interval |
|
413 | 139x |
suppressWarnings(stats::prop.test(x, n, correct = correct, conf.level = strata_conf_level)$conf.int) |
414 |
}, |
|
415 | 20x |
x = xs, |
416 | 20x |
n = ns |
417 |
) |
|
418 | 20x |
lower_by_strata <- sapply(ci_by_strata, "[", 1L) |
419 | 20x |
upper_by_strata <- sapply(ci_by_strata, "[", 2L) |
420 | ||
421 | 20x |
lower <- sum(weights_new * lower_by_strata) |
422 | 20x |
upper <- sum(weights_new * upper_by_strata) |
423 | ||
424 |
# Return values |
|
425 | 20x |
if (do_iter) { |
426 | 6x |
list( |
427 | 6x |
conf_int = c( |
428 | 6x |
lower = lower, |
429 | 6x |
upper = upper |
430 |
), |
|
431 | 6x |
weights = weights_new |
432 |
) |
|
433 |
} else { |
|
434 | 14x |
list( |
435 | 14x |
conf_int = c( |
436 | 14x |
lower = lower, |
437 | 14x |
upper = upper |
438 |
) |
|
439 |
) |
|
440 |
} |
|
441 |
} |
|
442 | ||
443 |
#' @describeIn h_proportions Calculates the Clopper-Pearson interval by calling [stats::binom.test()]. |
|
444 |
#' Also referred to as the `exact` method. |
|
445 |
#' |
|
446 |
#' @param n (`count`)\cr number of participants (if `denom = "N_col"`) or the number of responders |
|
447 |
#' (if `denom = "n"`, the default). |
|
448 |
#' |
|
449 |
#' @examples |
|
450 |
#' prop_clopper_pearson(rsp, conf_level = .95) |
|
451 |
#' |
|
452 |
#' @export |
|
453 |
prop_clopper_pearson <- function(rsp, n = length(rsp), conf_level) { |
|
454 | 1x |
y <- stats::binom.test( |
455 | 1x |
x = sum(rsp), |
456 | 1x |
n = n, |
457 | 1x |
conf.level = conf_level |
458 |
) |
|
459 | 1x |
as.numeric(y$conf.int) |
460 |
} |
|
461 | ||
462 |
#' @describeIn h_proportions Calculates the Wald interval by following the usual textbook definition |
|
463 |
#' for a single proportion confidence interval using the normal approximation. |
|
464 |
#' |
|
465 |
#' @param correct (`flag`)\cr whether to apply continuity correction. |
|
466 |
#' |
|
467 |
#' @examples |
|
468 |
#' prop_wald(rsp, conf_level = 0.95) |
|
469 |
#' prop_wald(rsp, conf_level = 0.95, correct = TRUE) |
|
470 |
#' |
|
471 |
#' @export |
|
472 |
prop_wald <- function(rsp, n = length(rsp), conf_level, correct = FALSE) { |
|
473 | 165x |
p_hat <- ifelse(n > 0, sum(rsp) / n, 0) |
474 | 165x |
z <- stats::qnorm((1 + conf_level) / 2) |
475 | 165x |
q_hat <- 1 - p_hat |
476 | 165x |
correct <- if (correct) 1 / (2 * n) else 0 |
477 | ||
478 | 165x |
err <- z * sqrt(p_hat * q_hat) / sqrt(n) + correct |
479 | 165x |
l_ci <- max(0, p_hat - err) |
480 | 165x |
u_ci <- min(1, p_hat + err) |
481 | ||
482 | 165x |
c(l_ci, u_ci) |
483 |
} |
|
484 | ||
485 |
#' @describeIn h_proportions Calculates the Agresti-Coull interval. Constructed (for 95% CI) by adding two successes |
|
486 |
#' and two failures to the data and then using the Wald formula to construct a CI. |
|
487 |
#' |
|
488 |
#' @examples |
|
489 |
#' prop_agresti_coull(rsp, conf_level = 0.95) |
|
490 |
#' |
|
491 |
#' @export |
|
492 |
prop_agresti_coull <- function(rsp, n = length(rsp), conf_level) { |
|
493 | 3x |
x_sum <- sum(rsp) |
494 | 3x |
z <- stats::qnorm((1 + conf_level) / 2) |
495 | ||
496 |
# Add here both z^2 / 2 successes and failures. |
|
497 | 3x |
x_sum_tilde <- x_sum + z^2 / 2 |
498 | 3x |
n_tilde <- n + z^2 |
499 | ||
500 |
# Then proceed as with the Wald interval. |
|
501 | 3x |
p_tilde <- x_sum_tilde / n_tilde |
502 | 3x |
q_tilde <- 1 - p_tilde |
503 | 3x |
err <- z * sqrt(p_tilde * q_tilde) / sqrt(n_tilde) |
504 | 3x |
l_ci <- max(0, p_tilde - err) |
505 | 3x |
u_ci <- min(1, p_tilde + err) |
506 | ||
507 | 3x |
c(l_ci, u_ci) |
508 |
} |
|
509 | ||
510 |
#' @describeIn h_proportions Calculates the Jeffreys interval, an equal-tailed interval based on the |
|
511 |
#' non-informative Jeffreys prior for a binomial proportion. |
|
512 |
#' |
|
513 |
#' @examples |
|
514 |
#' prop_jeffreys(rsp, conf_level = 0.95) |
|
515 |
#' |
|
516 |
#' @export |
|
517 |
prop_jeffreys <- function(rsp, n = length(rsp), conf_level) { |
|
518 | 5x |
x_sum <- sum(rsp) |
519 | ||
520 | 5x |
alpha <- 1 - conf_level |
521 | 5x |
l_ci <- ifelse( |
522 | 5x |
x_sum == 0, |
523 | 5x |
0, |
524 | 5x |
stats::qbeta(alpha / 2, x_sum + 0.5, n - x_sum + 0.5) |
525 |
) |
|
526 | ||
527 | 5x |
u_ci <- ifelse( |
528 | 5x |
x_sum == n, |
529 | 5x |
1, |
530 | 5x |
stats::qbeta(1 - alpha / 2, x_sum + 0.5, n - x_sum + 0.5) |
531 |
) |
|
532 | ||
533 | 5x |
c(l_ci, u_ci) |
534 |
} |
|
535 | ||
536 |
#' Description of the proportion summary |
|
537 |
#' |
|
538 |
#' @description `r lifecycle::badge("stable")` |
|
539 |
#' |
|
540 |
#' This is a helper function that describes the analysis in [s_proportion()]. |
|
541 |
#' |
|
542 |
#' @inheritParams s_proportion |
|
543 |
#' @param long (`flag`)\cr whether a long or a short (default) description is required. |
|
544 |
#' |
|
545 |
#' @return String describing the analysis. |
|
546 |
#' |
|
547 |
#' @export |
|
548 |
d_proportion <- function(conf_level, |
|
549 |
method, |
|
550 |
long = FALSE) { |
|
551 | 181x |
label <- paste0(conf_level * 100, "% CI") |
552 | ||
553 | ! |
if (long) label <- paste(label, "for Response Rates") |
554 | ||
555 | 181x |
method_part <- switch(method, |
556 | 181x |
"clopper-pearson" = "Clopper-Pearson", |
557 | 181x |
"waldcc" = "Wald, with correction", |
558 | 181x |
"wald" = "Wald, without correction", |
559 | 181x |
"wilson" = "Wilson, without correction", |
560 | 181x |
"strat_wilson" = "Stratified Wilson, without correction", |
561 | 181x |
"wilsonc" = "Wilson, with correction", |
562 | 181x |
"strat_wilsonc" = "Stratified Wilson, with correction", |
563 | 181x |
"agresti-coull" = "Agresti-Coull", |
564 | 181x |
"jeffreys" = "Jeffreys", |
565 | 181x |
stop(paste(method, "does not have a description")) |
566 |
) |
|
567 | ||
568 | 181x |
paste0(label, " (", method_part, ")") |
569 |
} |
|
570 | ||
571 |
#' Helper function for the estimation of stratified quantiles |
|
572 |
#' |
|
573 |
#' @description `r lifecycle::badge("stable")` |
|
574 |
#' |
|
575 |
#' This function wraps the estimation of stratified percentiles when we assume |
|
576 |
#' the approximation for large numbers. This is necessary only in the case |
|
577 |
#' proportions for each strata are unequal. |
|
578 |
#' |
|
579 |
#' @inheritParams argument_convention |
|
580 |
#' @inheritParams prop_strat_wilson |
|
581 |
#' |
|
582 |
#' @return Stratified quantile. |
|
583 |
#' |
|
584 |
#' @seealso [prop_strat_wilson()] |
|
585 |
#' |
|
586 |
#' @examples |
|
587 |
#' strata_data <- table(data.frame( |
|
588 |
#' "f1" = sample(c(TRUE, FALSE), 100, TRUE), |
|
589 |
#' "f2" = sample(c("x", "y", "z"), 100, TRUE), |
|
590 |
#' stringsAsFactors = TRUE |
|
591 |
#' )) |
|
592 |
#' ns <- colSums(strata_data) |
|
593 |
#' ests <- strata_data["TRUE", ] / ns |
|
594 |
#' vars <- ests * (1 - ests) / ns |
|
595 |
#' weights <- rep(1 / length(ns), length(ns)) |
|
596 |
#' |
|
597 |
#' strata_normal_quantile(vars, weights, 0.95) |
|
598 |
#' |
|
599 |
#' @export |
|
600 |
strata_normal_quantile <- function(vars, weights, conf_level) { |
|
601 | 43x |
summands <- weights^2 * vars |
602 |
# Stratified quantile |
|
603 | 43x |
sqrt(sum(summands)) / sum(sqrt(summands)) * stats::qnorm((1 + conf_level) / 2) |
604 |
} |
|
605 | ||
606 |
#' Helper function for the estimation of weights for `prop_strat_wilson()` |
|
607 |
#' |
|
608 |
#' @description `r lifecycle::badge("stable")` |
|
609 |
#' |
|
610 |
#' This function wraps the iteration procedure that allows you to estimate |
|
611 |
#' the weights for each proportional strata. This assumes to minimize the |
|
612 |
#' weighted squared length of the confidence interval. |
|
613 |
#' |
|
614 |
#' @inheritParams prop_strat_wilson |
|
615 |
#' @param vars (`numeric`)\cr normalized proportions for each strata. |
|
616 |
#' @param strata_qnorm (`numeric(1)`)\cr initial estimation with identical weights of the quantiles. |
|
617 |
#' @param initial_weights (`numeric`)\cr initial weights used to calculate `strata_qnorm`. This can |
|
618 |
#' be optimized in the future if we need to estimate better initial weights. |
|
619 |
#' @param n_per_strata (`numeric`)\cr number of elements in each strata. |
|
620 |
#' @param max_iterations (`integer(1)`)\cr maximum number of iterations to be tried. Convergence is always checked. |
|
621 |
#' @param tol (`numeric(1)`)\cr tolerance threshold for convergence. |
|
622 |
#' |
|
623 |
#' @return A `list` of 3 elements: `n_it`, `weights`, and `diff_v`. |
|
624 |
#' |
|
625 |
#' @seealso For references and details see [prop_strat_wilson()]. |
|
626 |
#' |
|
627 |
#' @examples |
|
628 |
#' vs <- c(0.011, 0.013, 0.012, 0.014, 0.017, 0.018) |
|
629 |
#' sq <- 0.674 |
|
630 |
#' ws <- rep(1 / length(vs), length(vs)) |
|
631 |
#' ns <- c(22, 18, 17, 17, 14, 12) |
|
632 |
#' |
|
633 |
#' update_weights_strat_wilson(vs, sq, ws, ns, 100, 0.95, 0.001) |
|
634 |
#' |
|
635 |
#' @export |
|
636 |
update_weights_strat_wilson <- function(vars, |
|
637 |
strata_qnorm, |
|
638 |
initial_weights, |
|
639 |
n_per_strata, |
|
640 |
max_iterations = 50, |
|
641 |
conf_level = 0.95, |
|
642 |
tol = 0.001) { |
|
643 | 9x |
it <- 0 |
644 | 9x |
diff_v <- NULL |
645 | ||
646 | 9x |
while (it < max_iterations) { |
647 | 21x |
it <- it + 1 |
648 | 21x |
weights_new_t <- (1 + strata_qnorm^2 / n_per_strata)^2 |
649 | 21x |
weights_new_b <- (vars + strata_qnorm^2 / (4 * n_per_strata^2)) |
650 | 21x |
weights_new <- weights_new_t / weights_new_b |
651 | 21x |
weights_new <- weights_new / sum(weights_new) |
652 | 21x |
strata_qnorm <- strata_normal_quantile(vars, weights_new, conf_level) |
653 | 21x |
diff_v <- c(diff_v, sum(abs(weights_new - initial_weights))) |
654 | 8x |
if (diff_v[length(diff_v)] < tol) break |
655 | 13x |
initial_weights <- weights_new |
656 |
} |
|
657 | ||
658 | 9x |
if (it == max_iterations) { |
659 | 1x |
warning("The heuristic to find weights did not converge with max_iterations = ", max_iterations) |
660 |
} |
|
661 | ||
662 | 9x |
list( |
663 | 9x |
"n_it" = it, |
664 | 9x |
"weights" = weights_new, |
665 | 9x |
"diff_v" = diff_v |
666 |
) |
|
667 |
} |
1 |
#' Get default statistical methods and their associated formats, labels, and indent modifiers |
|
2 |
#' |
|
3 |
#' @description `r lifecycle::badge("experimental")` |
|
4 |
#' |
|
5 |
#' Utility functions to get valid statistic methods for different method groups |
|
6 |
#' (`.stats`) and their associated formats (`.formats`), labels (`.labels`), and indent modifiers |
|
7 |
#' (`.indent_mods`). This utility is used across `tern`, but some of its working principles can be |
|
8 |
#' seen in [analyze_vars()]. See notes to understand why this is experimental. |
|
9 |
#' |
|
10 |
#' @param stats (`character`)\cr statistical methods to return defaults for. |
|
11 |
#' @param levels_per_stats (named `list` of `character` or `NULL`)\cr named list where the name of each element is a |
|
12 |
#' statistic from `stats` and each element is the levels of a `factor` or `character` variable (or variable name), |
|
13 |
#' each corresponding to a single row, for which the named statistic should be calculated for. If a statistic is only |
|
14 |
#' calculated once (one row), the element can be either `NULL` or the name of the statistic. Each list element will be |
|
15 |
#' flattened such that the names of the list elements returned by the function have the format `statistic.level` (or |
|
16 |
#' just `statistic` for statistics calculated for a single row). Defaults to `NULL`. |
|
17 |
#' @param tern_defaults (`list` or `vector`)\cr defaults to use to fill in missing values if no user input is given. |
|
18 |
#' Must be of the same type as the values that are being filled in (e.g. indentation must be integers). |
|
19 |
#' |
|
20 |
#' @details |
|
21 |
#' Current choices for `type` are `counts` and `numeric` for [analyze_vars()] and affect `get_stats()`. |
|
22 |
#' |
|
23 |
#' @note |
|
24 |
#' These defaults are experimental because we use the names of functions to retrieve the default |
|
25 |
#' statistics. This should be generalized in groups of methods according to more reasonable groupings. |
|
26 |
#' |
|
27 |
#' @name default_stats_formats_labels |
|
28 |
NULL |
|
29 | ||
30 |
#' @describeIn default_stats_formats_labels Get statistics available for a given method |
|
31 |
#' group (analyze function). To check available defaults see `tern::tern_default_stats` list. |
|
32 |
#' |
|
33 |
#' @param method_groups (`character`)\cr indicates the statistical method group (`tern` analyze function) |
|
34 |
#' to retrieve default statistics for. A character vector can be used to specify more than one statistical |
|
35 |
#' method group. |
|
36 |
#' @param stats_in (`character`)\cr statistics to retrieve for the selected method group. If custom statistical |
|
37 |
#' functions are used, `stats_in` needs to have them in too. |
|
38 |
#' @param custom_stats_in (`character`)\cr custom statistics to add to the default statistics. |
|
39 |
#' @param add_pval (`flag`)\cr should `"pval"` (or `"pval_counts"` if `method_groups` contains |
|
40 |
#' `"analyze_vars_counts"`) be added to the statistical methods? |
|
41 |
#' |
|
42 |
#' @return |
|
43 |
#' * `get_stats()` returns a `character` vector of statistical methods. |
|
44 |
#' |
|
45 |
#' @examples |
|
46 |
#' # analyze_vars is numeric |
|
47 |
#' num_stats <- get_stats("analyze_vars_numeric") # also the default |
|
48 |
#' |
|
49 |
#' # Other type |
|
50 |
#' cnt_stats <- get_stats("analyze_vars_counts") |
|
51 |
#' |
|
52 |
#' # Weirdly taking the pval from count_occurrences |
|
53 |
#' only_pval <- get_stats("count_occurrences", add_pval = TRUE, stats_in = "pval") |
|
54 |
#' |
|
55 |
#' # All count_occurrences |
|
56 |
#' all_cnt_occ <- get_stats("count_occurrences") |
|
57 |
#' |
|
58 |
#' # Multiple |
|
59 |
#' get_stats(c("count_occurrences", "analyze_vars_counts")) |
|
60 |
#' |
|
61 |
#' @export |
|
62 |
get_stats <- function(method_groups = "analyze_vars_numeric", |
|
63 |
stats_in = NULL, custom_stats_in = NULL, add_pval = FALSE) { |
|
64 | 1646x |
checkmate::assert_character(method_groups) |
65 | 1646x |
checkmate::assert_character(stats_in, null.ok = TRUE) |
66 | 1646x |
checkmate::assert_character(custom_stats_in, null.ok = TRUE) |
67 | 1646x |
checkmate::assert_flag(add_pval) |
68 | ||
69 |
# Default is still numeric |
|
70 | 1646x |
if (any(method_groups == "analyze_vars")) { |
71 | 3x |
method_groups[method_groups == "analyze_vars"] <- "analyze_vars_numeric" |
72 |
} |
|
73 | ||
74 | 1646x |
type_tmp <- ifelse(any(grepl("counts$", method_groups)), "counts", "numeric") # for pval checks |
75 | ||
76 |
# Defaults for loop |
|
77 | 1646x |
out <- NULL |
78 | ||
79 |
# Loop for multiple method groups |
|
80 | 1646x |
for (mgi in method_groups) { |
81 | 1673x |
if (mgi %in% names(tern_default_stats)) { |
82 | 1672x |
out_tmp <- tern_default_stats[[mgi]] |
83 |
} else { |
|
84 | 1x |
stop("The selected method group (", mgi, ") has no default statistical method.") |
85 |
} |
|
86 | 1672x |
out <- unique(c(out, out_tmp)) |
87 |
} |
|
88 | ||
89 |
# Add custom stats |
|
90 | 1645x |
out <- c(out, custom_stats_in) |
91 | ||
92 |
# If you added pval to the stats_in you certainly want it |
|
93 | 1645x |
if (!is.null(stats_in) && any(grepl("^pval", stats_in))) { |
94 | 136x |
stats_in_pval_value <- stats_in[grepl("^pval", stats_in)] |
95 | ||
96 |
# Must be only one value between choices |
|
97 | 136x |
checkmate::assert_choice(stats_in_pval_value, c("pval", "pval_counts", "pvalue")) |
98 | ||
99 |
# Mismatch with counts and numeric |
|
100 | 135x |
if (any(grepl("counts", method_groups)) && stats_in_pval_value != "pval_counts" || |
101 | 135x |
any(grepl("numeric", method_groups)) && stats_in_pval_value != "pval") { # nolint |
102 | 2x |
stop( |
103 | 2x |
"Inserted p-value (", stats_in_pval_value, ") is not valid for type ", |
104 | 2x |
type_tmp, ". Use ", paste(ifelse(stats_in_pval_value == "pval", "pval_counts", "pval")), |
105 | 2x |
" instead." |
106 |
) |
|
107 |
} |
|
108 | ||
109 |
# Lets add it even if present (thanks to unique) |
|
110 | 133x |
add_pval <- TRUE |
111 |
} |
|
112 | ||
113 |
# Mainly used in "analyze_vars" but it could be necessary elsewhere |
|
114 | 1642x |
if (isTRUE(add_pval)) { |
115 | 143x |
if (any(grepl("counts", method_groups))) { |
116 | 16x |
out <- unique(c(out, "pval_counts")) |
117 |
} else { |
|
118 | 127x |
out <- unique(c(out, "pval")) |
119 |
} |
|
120 |
} |
|
121 | ||
122 |
# Filtering for stats_in (character vector) |
|
123 | 1642x |
if (!is.null(stats_in)) { |
124 | 1590x |
out <- intersect(stats_in, out) # It orders them too |
125 |
} |
|
126 | ||
127 |
# If intersect did not find matches (and no pval?) -> error |
|
128 | 1642x |
if (length(out) == 0) { |
129 | 2x |
stop( |
130 | 2x |
"The selected method group(s) (", paste0(method_groups, collapse = ", "), ")", |
131 | 2x |
" do not have the required default statistical methods:\n", |
132 | 2x |
paste0(stats_in, collapse = " ") |
133 |
) |
|
134 |
} |
|
135 | ||
136 | 1640x |
out |
137 |
} |
|
138 | ||
139 |
#' @describeIn default_stats_formats_labels Get statistical *names* available for a given method |
|
140 |
#' group (analyze function). Please use the `s_*` functions to get the statistical names. |
|
141 |
#' @param stat_results (`list`)\cr list of statistical results. It should be used close to the end of |
|
142 |
#' a statistical function. See examples for a structure with two statistical results and two groups. |
|
143 |
#' @param stat_names_in (`character`)\cr custom modification of statistical values. |
|
144 |
#' |
|
145 |
#' @return |
|
146 |
#' * `get_stat_names()` returns a named list of `character` vectors, indicating the names of |
|
147 |
#' statistical outputs. |
|
148 |
#' |
|
149 |
#' @examples |
|
150 |
#' stat_results <- list( |
|
151 |
#' "n" = list("M" = 1, "F" = 2), |
|
152 |
#' "count_fraction" = list("M" = c(1, 0.2), "F" = c(2, 0.1)) |
|
153 |
#' ) |
|
154 |
#' get_stat_names(stat_results) |
|
155 |
#' get_stat_names(stat_results, list("n" = "argh")) |
|
156 |
#' |
|
157 |
#' @export |
|
158 |
get_stat_names <- function(stat_results, stat_names_in = NULL) { |
|
159 | 1576x |
checkmate::assert_character(names(stat_results), min.len = 1) |
160 | 1576x |
checkmate::assert_list(stat_names_in, null.ok = TRUE) |
161 | ||
162 | 1576x |
stat_nms_from_stats <- lapply(stat_results, function(si) { |
163 | 5699x |
nm <- names(si) |
164 | 5699x |
if (is.null(nm)) { |
165 | 2718x |
nm <- rep(NA_character_, length(si)) # no statistical names |
166 |
} |
|
167 | 5699x |
nm |
168 |
}) |
|
169 | ||
170 |
# Modify some with custom stat names |
|
171 | 1576x |
if (!is.null(stat_names_in)) { |
172 |
# Stats is the main |
|
173 | 6x |
common_names <- intersect(names(stat_nms_from_stats), names(stat_names_in)) |
174 | 6x |
stat_nms_from_stats[common_names] <- stat_names_in[common_names] |
175 |
} |
|
176 | ||
177 | 1576x |
stat_nms_from_stats |
178 |
} |
|
179 | ||
180 |
# Utility function used to separate custom stats (user-defined functions) from defaults |
|
181 |
.split_std_from_custom_stats <- function(stats_in) { |
|
182 | 873x |
out <- list(default_stats = NULL, custom_stats = NULL, all_stats = NULL) |
183 | 873x |
if (is.list(stats_in)) { |
184 | 12x |
is_custom_fnc <- sapply(stats_in, is.function) |
185 | 12x |
checkmate::assert_list(stats_in[is_custom_fnc], types = "function", names = "named") |
186 | 12x |
out[["custom_stats"]] <- stats_in[is_custom_fnc] |
187 | 12x |
out[["default_stats"]] <- unlist(stats_in[!is_custom_fnc]) |
188 | 12x |
all_stats <- names(stats_in) # to keep the order |
189 | 12x |
all_stats[!is_custom_fnc] <- out[["default_stats"]] |
190 | 12x |
out[["all_stats"]] <- all_stats |
191 |
} else { |
|
192 | 861x |
out[["default_stats"]] <- out[["all_stats"]] <- stats_in |
193 |
} |
|
194 | 873x |
out |
195 |
} |
|
196 | ||
197 |
# Utility function to apply statistical functions |
|
198 |
.apply_stat_functions <- function(default_stat_fnc, custom_stat_fnc_list, args_list) { |
|
199 |
# Default checks |
|
200 | 896x |
checkmate::assert_function(default_stat_fnc) |
201 | 896x |
checkmate::assert_list(custom_stat_fnc_list, types = "function", null.ok = TRUE, names = "named") |
202 | 896x |
checkmate::assert_list(args_list) |
203 | ||
204 |
# Checking custom stats have same formals |
|
205 | 896x |
if (!is.null(custom_stat_fnc_list)) { |
206 | 12x |
fundamental_call_to_data <- names(formals(default_stat_fnc))[[1]] |
207 | 12x |
for (fnc in custom_stat_fnc_list) { |
208 | 17x |
if (!identical(names(formals(fnc))[[1]], fundamental_call_to_data)) { |
209 | 1x |
stop( |
210 | 1x |
"The first parameter of a custom statistical function needs to be the same (it can be `df` or `x`) ", |
211 | 1x |
"as the default statistical function. In this case your custom function has ", names(formals(fnc))[[1]], |
212 | 1x |
" as first parameter, while the default function has ", fundamental_call_to_data, "." |
213 |
) |
|
214 |
} |
|
215 | 16x |
if (!any(names(formals(fnc)) == "...")) { |
216 | 1x |
stop( |
217 | 1x |
"The custom statistical function needs to have `...` as a parameter to accept additional arguments. ", |
218 | 1x |
"In this case your custom function does not have `...`." |
219 |
) |
|
220 |
} |
|
221 |
} |
|
222 |
} |
|
223 | ||
224 |
# Applying |
|
225 | 894x |
out_default <- do.call(default_stat_fnc, args = args_list) |
226 | 892x |
out_custom <- lapply(custom_stat_fnc_list, function(fnc) do.call(fnc, args = args_list)) |
227 | ||
228 |
# Merging |
|
229 | 892x |
c(out_default, out_custom) |
230 |
} |
|
231 | ||
232 |
#' @describeIn default_stats_formats_labels Get formats corresponding to a list of statistics. |
|
233 |
#' To check available defaults see list `tern::tern_default_formats`. |
|
234 |
#' |
|
235 |
#' @param formats_in (named `vector`)\cr custom formats to use instead of defaults. Can be a character vector with |
|
236 |
#' values from [formatters::list_valid_format_labels()] or custom format functions. Defaults to `NULL` for any rows |
|
237 |
#' with no value is provided. |
|
238 |
#' |
|
239 |
#' @return |
|
240 |
#' * `get_formats_from_stats()` returns a named list of formats as strings or functions. |
|
241 |
#' |
|
242 |
#' @note Formats in `tern` and `rtables` can be functions that take in the table cell value and |
|
243 |
#' return a string. This is well documented in `vignette("custom_appearance", package = "rtables")`. |
|
244 |
#' |
|
245 |
#' @examples |
|
246 |
#' # Defaults formats |
|
247 |
#' get_formats_from_stats(num_stats) |
|
248 |
#' get_formats_from_stats(cnt_stats) |
|
249 |
#' get_formats_from_stats(only_pval) |
|
250 |
#' get_formats_from_stats(all_cnt_occ) |
|
251 |
#' |
|
252 |
#' # Addition of customs |
|
253 |
#' get_formats_from_stats(all_cnt_occ, formats_in = c("fraction" = c("xx"))) |
|
254 |
#' get_formats_from_stats(all_cnt_occ, formats_in = list("fraction" = c("xx.xx", "xx"))) |
|
255 |
#' |
|
256 |
#' @seealso [formatting_functions] |
|
257 |
#' |
|
258 |
#' @export |
|
259 |
get_formats_from_stats <- function(stats, |
|
260 |
formats_in = NULL, |
|
261 |
levels_per_stats = NULL, |
|
262 |
tern_defaults = tern_default_formats) { |
|
263 | 1669x |
checkmate::assert_character(stats, min.len = 1) |
264 |
# It may be a list if there is a function in the formats |
|
265 | 1669x |
if (checkmate::test_list(formats_in, null.ok = TRUE)) { |
266 | 1550x |
checkmate::assert_list(formats_in, null.ok = TRUE) |
267 |
# Or it may be a vector of characters |
|
268 |
} else { |
|
269 | 119x |
checkmate::assert_character(formats_in, null.ok = TRUE) |
270 |
} |
|
271 | 1669x |
checkmate::assert_list(levels_per_stats, null.ok = TRUE) |
272 | ||
273 |
# If unnamed formats given as formats_in and same number of stats, use one format per stat |
|
274 |
if ( |
|
275 | 1669x |
!is.null(formats_in) && length(formats_in) == length(stats) && |
276 | 1669x |
is.null(names(formats_in)) && is.null(levels_per_stats) |
277 |
) { |
|
278 | 2x |
out <- as.list(formats_in) %>% setNames(stats) |
279 | 2x |
return(out) |
280 |
} |
|
281 | ||
282 |
# If levels_per_stats not given, assume one row per statistic |
|
283 | 377x |
if (is.null(levels_per_stats)) levels_per_stats <- as.list(stats) %>% setNames(stats) |
284 | ||
285 |
# Apply custom formats |
|
286 | 1667x |
out <- .fill_in_vals_by_stats(levels_per_stats, formats_in, tern_defaults) |
287 | ||
288 |
# Default to NULL if no format |
|
289 | 1667x |
which_null <- names(which(sapply(levels_per_stats, is.null))) |
290 | 1667x |
levels_per_stats[which_null] <- which_null |
291 | 1667x |
case_input_is_not_stat <- unlist(out, use.names = FALSE) == unlist(levels_per_stats, use.names = FALSE) |
292 | 1667x |
out[names(out) == out | case_input_is_not_stat] <- list(NULL) |
293 | ||
294 | 1667x |
out |
295 |
} |
|
296 | ||
297 |
#' @describeIn default_stats_formats_labels Get labels corresponding to a list of statistics. |
|
298 |
#' To check for available defaults see list `tern::tern_default_labels`. |
|
299 |
#' |
|
300 |
#' @param labels_in (named `character`)\cr custom labels to use instead of defaults. If no value is provided, the |
|
301 |
#' variable level (if rows correspond to levels of a variable) or statistic name will be used as label. |
|
302 |
#' @param label_attr_from_stats (named `list`)\cr if `labels_in = NULL`, then this will be used instead. It is a list |
|
303 |
#' of values defined in statistical functions as default labels. Values are ignored if `labels_in` is provided or `""` |
|
304 |
#' values are provided. |
|
305 |
#' |
|
306 |
#' @return |
|
307 |
#' * `get_labels_from_stats()` returns a named list of labels as strings. |
|
308 |
#' |
|
309 |
#' @examples |
|
310 |
#' # Defaults labels |
|
311 |
#' get_labels_from_stats(num_stats) |
|
312 |
#' get_labels_from_stats(cnt_stats) |
|
313 |
#' get_labels_from_stats(only_pval) |
|
314 |
#' get_labels_from_stats(all_cnt_occ) |
|
315 |
#' |
|
316 |
#' # Addition of customs |
|
317 |
#' get_labels_from_stats(all_cnt_occ, labels_in = c("fraction" = "Fraction")) |
|
318 |
#' get_labels_from_stats(all_cnt_occ, labels_in = list("fraction" = c("Some more fractions"))) |
|
319 |
#' |
|
320 |
#' @export |
|
321 |
get_labels_from_stats <- function(stats, |
|
322 |
labels_in = NULL, |
|
323 |
levels_per_stats = NULL, |
|
324 |
label_attr_from_stats = NULL, |
|
325 |
tern_defaults = tern_default_labels) { |
|
326 | 1622x |
checkmate::assert_character(stats, min.len = 1) |
327 | ||
328 |
# If labels_in is NULL, use label_attr_from_stats |
|
329 | 1622x |
if (is.null(labels_in)) { |
330 | 1349x |
labels_in <- label_attr_from_stats |
331 | 1349x |
labels_in <- label_attr_from_stats[ |
332 | 1349x |
nzchar(label_attr_from_stats) & |
333 | 1349x |
!sapply(label_attr_from_stats, is.null) & |
334 | 1349x |
!is.na(label_attr_from_stats) |
335 |
] |
|
336 |
} |
|
337 | ||
338 |
# It may be a list |
|
339 | 1622x |
if (checkmate::test_list(labels_in, null.ok = TRUE)) { |
340 | 1420x |
checkmate::assert_list(labels_in, null.ok = TRUE) |
341 |
# Or it may be a vector of characters |
|
342 |
} else { |
|
343 | 202x |
checkmate::assert_character(labels_in, null.ok = TRUE) |
344 |
} |
|
345 | 1622x |
checkmate::assert_list(levels_per_stats, null.ok = TRUE) |
346 | ||
347 |
# If unnamed labels given as labels_in and same number of stats, use one label per stat |
|
348 |
if ( |
|
349 | 1622x |
!is.null(labels_in) && length(labels_in) == length(stats) && |
350 | 1622x |
is.null(names(labels_in)) && is.null(levels_per_stats) |
351 |
) { |
|
352 | 2x |
out <- as.list(labels_in) %>% setNames(stats) |
353 | 2x |
return(out) |
354 |
} |
|
355 | ||
356 |
# If levels_per_stats not given, assume one row per statistic |
|
357 | 328x |
if (is.null(levels_per_stats)) levels_per_stats <- as.list(stats) %>% setNames(stats) |
358 | ||
359 |
# Apply custom labels |
|
360 | 1620x |
out <- .fill_in_vals_by_stats(levels_per_stats, labels_in, tern_defaults) |
361 | 1620x |
out |
362 |
} |
|
363 | ||
364 |
#' @describeIn default_stats_formats_labels Get row indent modifiers corresponding to a list of statistics/rows. |
|
365 |
#' |
|
366 |
#' @param indents_in (named `integer`)\cr custom row indent modifiers to use instead of defaults. Defaults to `0L` for |
|
367 |
#' all values. |
|
368 |
#' @param row_nms `r lifecycle::badge("deprecated")` Deprecation cycle started. See the `levels_per_stats` parameter |
|
369 |
#' for details. |
|
370 |
#' |
|
371 |
#' @return |
|
372 |
#' * `get_indents_from_stats()` returns a named list of indentation modifiers as integers. |
|
373 |
#' |
|
374 |
#' @examples |
|
375 |
#' get_indents_from_stats(all_cnt_occ, indents_in = 3L) |
|
376 |
#' get_indents_from_stats(all_cnt_occ, indents_in = list(count = 2L, count_fraction = 5L)) |
|
377 |
#' get_indents_from_stats( |
|
378 |
#' all_cnt_occ, |
|
379 |
#' indents_in = list(a = 2L, count.a = 1L, count.b = 5L) |
|
380 |
#' ) |
|
381 |
#' |
|
382 |
#' @export |
|
383 |
get_indents_from_stats <- function(stats, |
|
384 |
indents_in = NULL, |
|
385 |
levels_per_stats = NULL, |
|
386 |
tern_defaults = as.list(rep(0L, length(stats))) %>% setNames(stats), |
|
387 |
row_nms = lifecycle::deprecated()) { |
|
388 | 1578x |
checkmate::assert_character(stats, min.len = 1) |
389 |
# It may be a list |
|
390 | 1578x |
if (checkmate::test_list(indents_in, null.ok = TRUE)) { |
391 | 1490x |
checkmate::assert_list(indents_in, null.ok = TRUE) |
392 |
# Or it may be a vector of integers |
|
393 |
} else { |
|
394 | 88x |
checkmate::assert_integerish(indents_in, null.ok = TRUE) |
395 |
} |
|
396 | 1578x |
checkmate::assert_list(levels_per_stats, null.ok = TRUE) |
397 | ||
398 |
# If levels_per_stats not given, assume one row per statistic |
|
399 | 288x |
if (is.null(levels_per_stats)) levels_per_stats <- as.list(stats) %>% setNames(stats) |
400 | ||
401 |
# Single indentation level for all rows |
|
402 | 1578x |
if (is.null(names(indents_in)) && length(indents_in) == 1) { |
403 | 20x |
out <- rep(indents_in, length(levels_per_stats %>% unlist())) |
404 | 20x |
return(out) |
405 |
} |
|
406 | ||
407 |
# Apply custom indentation |
|
408 | 1558x |
out <- .fill_in_vals_by_stats(levels_per_stats, indents_in, tern_defaults) |
409 | 1558x |
out |
410 |
} |
|
411 | ||
412 |
# Function to loop over each stat and levels to set correct values |
|
413 |
.fill_in_vals_by_stats <- function(levels_per_stats, user_in, tern_defaults) { |
|
414 | 4845x |
out <- list() |
415 | ||
416 | 4845x |
for (stat_i in names(levels_per_stats)) { |
417 |
# Get all levels of the statistic |
|
418 | 7749x |
all_lvls <- levels_per_stats[[stat_i]] |
419 | ||
420 | 7749x |
if ((length(all_lvls) == 1 && all_lvls == stat_i) || is.null(all_lvls)) { # One row per statistic |
421 | 3995x |
out[[stat_i]] <- if (stat_i %in% names(user_in)) { # 1. Check for stat_i in user input |
422 | 780x |
user_in[[stat_i]] |
423 | 3995x |
} else if (stat_i %in% names(tern_defaults)) { # 2. Check for stat_i in tern defaults |
424 | 3167x |
tern_defaults[[stat_i]] |
425 | 3995x |
} else { # 3. Otherwise stat_i |
426 | 48x |
stat_i |
427 |
} |
|
428 |
} else { # One row per combination of variable level and statistic |
|
429 |
# Loop over levels for each statistic |
|
430 | 3754x |
for (lev_i in all_lvls) { |
431 |
# Construct row name (stat_i.lev_i) |
|
432 | 13522x |
row_nm <- paste(stat_i, lev_i, sep = ".") |
433 | ||
434 | 13522x |
out[[row_nm]] <- if (row_nm %in% names(user_in)) { # 1. Check for stat_i.lev_i in user input |
435 | 43x |
user_in[[row_nm]] |
436 | 13522x |
} else if (lev_i %in% names(user_in)) { # 2. Check for lev_i in user input |
437 | 52x |
user_in[[lev_i]] |
438 | 13522x |
} else if (stat_i %in% names(user_in)) { # 3. Check for stat_i in user input |
439 | 503x |
user_in[[stat_i]] |
440 | 13522x |
} else if (lev_i %in% names(tern_defaults)) { # 4. Check for lev_i in tern defaults (only used for labels) |
441 | 1549x |
tern_defaults[[lev_i]] |
442 | 13522x |
} else if (stat_i %in% names(tern_defaults)) { # 5. Check for stat_i in tern defaults |
443 | 8465x |
tern_defaults[[stat_i]] |
444 | 13522x |
} else { # 6. Otherwise lev_i |
445 | 2910x |
lev_i |
446 |
} |
|
447 |
} |
|
448 |
} |
|
449 |
} |
|
450 | ||
451 | 4845x |
out |
452 |
} |
|
453 | ||
454 |
# Custom unlist function to retain NULL as "NULL" or NA |
|
455 |
.unlist_keep_nulls <- function(lst, null_placeholder = "NULL", recursive = FALSE) { |
|
456 | 4786x |
lapply(lst, function(x) if (is.null(x)) null_placeholder else x) %>% |
457 | 4786x |
unlist(recursive = recursive) |
458 |
} |
|
459 | ||
460 |
#' Update labels according to control specifications |
|
461 |
#' |
|
462 |
#' @description `r lifecycle::badge("stable")` |
|
463 |
#' |
|
464 |
#' Given a list of statistic labels and and a list of control parameters, updates labels with a relevant |
|
465 |
#' control specification. For example, if control has element `conf_level` set to `0.9`, the default |
|
466 |
#' label for statistic `mean_ci` will be updated to `"Mean 90% CI"`. Any labels that are supplied |
|
467 |
#' via `labels_custom` will not be updated regardless of `control`. |
|
468 |
#' |
|
469 |
#' @param labels_default (named `character`)\cr a named vector of statistic labels to modify |
|
470 |
#' according to the control specifications. Labels that are explicitly defined in `labels_custom` will |
|
471 |
#' not be affected. |
|
472 |
#' @param labels_custom (named `character`)\cr named vector of labels that are customized by |
|
473 |
#' the user and should not be affected by `control`. |
|
474 |
#' @param control (named `list`)\cr list of control parameters to apply to adjust default labels. |
|
475 |
#' |
|
476 |
#' @return A named character vector of labels with control specifications applied to relevant labels. |
|
477 |
#' |
|
478 |
#' @examples |
|
479 |
#' control <- list(conf_level = 0.80, quantiles = c(0.1, 0.83), test_mean = 0.57) |
|
480 |
#' get_labels_from_stats(c("mean_ci", "quantiles", "mean_pval")) %>% |
|
481 |
#' labels_use_control(control = control) |
|
482 |
#' |
|
483 |
#' @export |
|
484 |
labels_use_control <- function(labels_default, control, labels_custom = NULL) { |
|
485 | 21x |
if ("conf_level" %in% names(control)) { |
486 | 21x |
labels_default <- sapply( |
487 | 21x |
names(labels_default), |
488 | 21x |
function(x) { |
489 | 111x |
if (!x %in% names(labels_custom)) { |
490 | 108x |
gsub(labels_default[[x]], pattern = "[0-9]+% CI", replacement = f_conf_level(control[["conf_level"]])) |
491 |
} else { |
|
492 | 3x |
labels_default[[x]] |
493 |
} |
|
494 |
} |
|
495 |
) |
|
496 |
} |
|
497 | 21x |
if ("quantiles" %in% names(control) && "quantiles" %in% names(labels_default) && |
498 | 21x |
!"quantiles" %in% names(labels_custom)) { # nolint |
499 | 16x |
labels_default["quantiles"] <- gsub( |
500 | 16x |
"[0-9]+% and [0-9]+", paste0(control[["quantiles"]][1] * 100, "% and ", control[["quantiles"]][2] * 100, ""), |
501 | 16x |
labels_default["quantiles"] |
502 |
) |
|
503 |
} |
|
504 | 21x |
if ("quantiles" %in% names(control) && "quantiles_lower" %in% names(labels_default) && |
505 | 21x |
!"quantiles_lower" %in% names(labels_custom)) { # nolint |
506 | 6x |
labels_default["quantiles_lower"] <- gsub( |
507 | 6x |
"[0-9]+%-ile", paste0(control[["quantiles"]][1] * 100, "%-ile", ""), |
508 | 6x |
labels_default["quantiles_lower"] |
509 |
) |
|
510 |
} |
|
511 | 21x |
if ("quantiles" %in% names(control) && "quantiles_upper" %in% names(labels_default) && |
512 | 21x |
!"quantiles_upper" %in% names(labels_custom)) { # nolint |
513 | 6x |
labels_default["quantiles_upper"] <- gsub( |
514 | 6x |
"[0-9]+%-ile", paste0(control[["quantiles"]][2] * 100, "%-ile", ""), |
515 | 6x |
labels_default["quantiles_upper"] |
516 |
) |
|
517 |
} |
|
518 | 21x |
if ("test_mean" %in% names(control) && "mean_pval" %in% names(labels_default) && |
519 | 21x |
!"mean_pval" %in% names(labels_custom)) { # nolint |
520 | 2x |
labels_default["mean_pval"] <- gsub( |
521 | 2x |
"p-value \\(H0: mean = [0-9\\.]+\\)", f_pval(control[["test_mean"]]), labels_default["mean_pval"] |
522 |
) |
|
523 |
} |
|
524 | ||
525 | 21x |
labels_default |
526 |
} |
|
527 | ||
528 |
# tern_default_stats ----------------------------------------------------------- |
|
529 |
#' @describeIn default_stats_formats_labels Named list of available statistics by method group for `tern`. |
|
530 |
#' |
|
531 |
#' @format |
|
532 |
#' * `tern_default_stats` is a named list of available statistics, with each element |
|
533 |
#' named for their corresponding statistical method group. |
|
534 |
#' |
|
535 |
#' @export |
|
536 |
tern_default_stats <- list( |
|
537 |
abnormal = c("fraction"), |
|
538 |
abnormal_by_baseline = c("fraction"), |
|
539 |
abnormal_by_marked = c("count_fraction", "count_fraction_fixed_dp"), |
|
540 |
abnormal_by_worst_grade = c("count_fraction", "count_fraction_fixed_dp"), |
|
541 |
abnormal_lab_worsen_by_baseline = c("fraction"), |
|
542 |
analyze_patients_exposure_in_cols = c("n_patients", "sum_exposure"), |
|
543 |
analyze_vars_counts = c("n", "count", "count_fraction", "count_fraction_fixed_dp", "fraction", "n_blq"), |
|
544 |
analyze_vars_numeric = c( |
|
545 |
"n", "sum", "mean", "sd", "se", "mean_sd", "mean_se", "mean_ci", "mean_sei", "mean_sdi", "mean_pval", |
|
546 |
"median", "mad", "median_ci", "quantiles", "iqr", "range", "min", "max", "median_range", "cv", |
|
547 |
"geom_mean", "geom_sd", "geom_mean_sd", "geom_mean_ci", "geom_cv", |
|
548 |
"median_ci_3d", |
|
549 |
"mean_ci_3d", "geom_mean_ci_3d" |
|
550 |
), |
|
551 |
count_cumulative = c("count_fraction"), |
|
552 |
count_missed_doses = c("n", "count_fraction"), |
|
553 |
count_occurrences = c("count", "count_fraction", "count_fraction_fixed_dp", "fraction"), |
|
554 |
count_occurrences_by_grade = c("count_fraction", "count_fraction_fixed_dp"), |
|
555 |
count_patients_with_event = c("n", "count", "count_fraction", "count_fraction_fixed_dp", "n_blq"), |
|
556 |
count_patients_with_flags = c("n", "count", "count_fraction", "count_fraction_fixed_dp", "n_blq"), |
|
557 |
count_values = c("n", "count", "count_fraction", "count_fraction_fixed_dp", "n_blq"), |
|
558 |
coxph_pairwise = c("pvalue", "hr", "hr_ci", "n_tot", "n_tot_events"), |
|
559 |
estimate_incidence_rate = c("person_years", "n_events", "rate", "rate_ci", "n_unique", "n_rate"), |
|
560 |
estimate_multinomial_response = c("n_prop", "prop_ci"), |
|
561 |
estimate_odds_ratio = c("or_ci", "n_tot"), |
|
562 |
estimate_proportion = c("n_prop", "prop_ci"), |
|
563 |
estimate_proportion_diff = c("diff", "diff_ci"), |
|
564 |
summarize_ancova = c("n", "lsmean", "lsmean_diff", "lsmean_diff_ci", "pval"), |
|
565 |
summarize_coxreg = c("n", "hr", "ci", "pval", "pval_inter"), |
|
566 |
summarize_glm_count = c("n", "rate", "rate_ci", "rate_ratio", "rate_ratio_ci", "pval"), |
|
567 |
summarize_num_patients = c("unique", "nonunique", "unique_count"), |
|
568 |
summarize_patients_events_in_cols = c("unique", "all"), |
|
569 |
surv_time = c( |
|
570 |
"median", "median_ci", "median_ci_3d", "quantiles", |
|
571 |
"quantiles_lower", "quantiles_upper", "range_censor", "range_event", "range" |
|
572 |
), |
|
573 |
surv_timepoint = c("pt_at_risk", "event_free_rate", "rate_se", "rate_ci", "event_free_rate_3d"), |
|
574 |
surv_timepoint_diff = c("rate_diff", "rate_diff_ci", "ztest_pval", "rate_diff_ci_3d"), |
|
575 |
tabulate_rsp_biomarkers = c("n_tot", "n_rsp", "prop", "or", "ci", "pval"), |
|
576 |
tabulate_rsp_subgroups = c("n", "n_rsp", "prop", "n_tot", "or", "ci", "pval", "riskdiff"), |
|
577 |
tabulate_survival_biomarkers = c("n_tot", "n_tot_events", "median", "hr", "ci", "pval"), |
|
578 |
tabulate_survival_subgroups = c("n_tot_events", "n_events", "n_tot", "n", "median", "hr", "ci", "pval", "riskdiff"), |
|
579 |
test_proportion_diff = c("pval") |
|
580 |
) |
|
581 | ||
582 |
# tern_default_formats --------------------------------------------------------- |
|
583 |
#' @describeIn default_stats_formats_labels Named vector of default formats for `tern`. |
|
584 |
#' |
|
585 |
#' @format |
|
586 |
#' * `tern_default_formats` is a named vector of available default formats, with each element |
|
587 |
#' named for their corresponding statistic. |
|
588 |
#' |
|
589 |
#' @export |
|
590 |
tern_default_formats <- c( |
|
591 |
ci = list(format_extreme_values_ci(2L)), |
|
592 |
count = "xx.", |
|
593 |
count_fraction = format_count_fraction, |
|
594 |
count_fraction_fixed_dp = format_count_fraction_fixed_dp, |
|
595 |
cv = "xx.x", |
|
596 |
event_free_rate = "xx.xx", |
|
597 |
fraction = format_fraction_fixed_dp, |
|
598 |
geom_cv = "xx.x", |
|
599 |
geom_mean = "xx.x", |
|
600 |
geom_mean_ci = "(xx.xx, xx.xx)", |
|
601 |
geom_mean_ci_3d = "xx.xx (xx.xx - xx.xx)", |
|
602 |
geom_mean_sd = "xx.x (xx.x)", |
|
603 |
geom_sd = "xx.x", |
|
604 |
hr = list(format_extreme_values(2L)), |
|
605 |
hr_ci = "(xx.xx, xx.xx)", |
|
606 |
hr_ci_3d = "xx.xx (xx.xx - xx.xx)", |
|
607 |
iqr = "xx.x", |
|
608 |
lsmean = "xx.xx", |
|
609 |
lsmean_diff = "xx.xx", |
|
610 |
lsmean_diff_ci = "(xx.xx, xx.xx)", |
|
611 |
mad = "xx.x", |
|
612 |
max = "xx.x", |
|
613 |
mean = "xx.x", |
|
614 |
mean_ci = "(xx.xx, xx.xx)", |
|
615 |
mean_ci_3d = "xx.xx (xx.xx - xx.xx)", |
|
616 |
mean_pval = "x.xxxx | (<0.0001)", |
|
617 |
mean_sd = "xx.x (xx.x)", |
|
618 |
mean_sdi = "(xx.xx, xx.xx)", |
|
619 |
mean_se = "xx.x (xx.x)", |
|
620 |
mean_sei = "(xx.xx, xx.xx)", |
|
621 |
median = "xx.x", |
|
622 |
median_ci = "(xx.xx, xx.xx)", |
|
623 |
median_ci_3d = "xx.xx (xx.xx - xx.xx)", |
|
624 |
median_range = "xx.x (xx.x - xx.x)", |
|
625 |
min = "xx.x", |
|
626 |
n = "xx.", |
|
627 |
n_blq = "xx.", |
|
628 |
n_events = "xx", |
|
629 |
n_patients = "xx (xx.x%)", |
|
630 |
n_prop = "xx (xx.x%)", |
|
631 |
n_rate = "xx (xx.x)", |
|
632 |
n_rsp = "xx", |
|
633 |
n_tot = "xx", |
|
634 |
n_tot_events = "xx", |
|
635 |
n_unique = "xx", |
|
636 |
nonunique = "xx", |
|
637 |
or = list(format_extreme_values(2L)), |
|
638 |
or_ci = "xx.xx (xx.xx - xx.xx)", |
|
639 |
person_years = "xx.x", |
|
640 |
prop = "xx.x%", |
|
641 |
prop_ci = "(xx.x, xx.x)", |
|
642 |
pt_at_risk = "xx", |
|
643 |
pval = "x.xxxx | (<0.0001)", |
|
644 |
pvalue = "x.xxxx | (<0.0001)", |
|
645 |
pval_counts = "x.xxxx | (<0.0001)", |
|
646 |
quantiles = "xx.x - xx.x", |
|
647 |
quantiles_lower = "xx.xx (xx.xx - xx.xx)", |
|
648 |
quantiles_upper = "xx.xx (xx.xx - xx.xx)", |
|
649 |
range = "xx.x - xx.x", |
|
650 |
range_censor = "xx.x to xx.x", |
|
651 |
range_event = "xx.x to xx.x", |
|
652 |
rate = "xx.xxxx", |
|
653 |
rate_ci = "(xx.xxxx, xx.xxxx)", |
|
654 |
rate_diff = "xx.xx", |
|
655 |
rate_diff_ci = "(xx.xx, xx.xx)", |
|
656 |
rate_diff_ci_3d = format_xx("xx.xx (xx.xx, xx.xx)"), |
|
657 |
rate_ratio = "xx.xxxx", |
|
658 |
rate_ratio_ci = "(xx.xxxx, xx.xxxx)", |
|
659 |
rate_se = "xx.xx", |
|
660 |
riskdiff = "xx.x (xx.x - xx.x)", |
|
661 |
sd = "xx.x", |
|
662 |
se = "xx.x", |
|
663 |
sum = "xx.x", |
|
664 |
sum_exposure = "xx", |
|
665 |
unique = format_count_fraction_fixed_dp, |
|
666 |
unique_count = "xx", |
|
667 |
ztest_pval = "x.xxxx | (<0.0001)" |
|
668 |
) |
|
669 | ||
670 |
# tern_default_labels ---------------------------------------------------------- |
|
671 |
#' @describeIn default_stats_formats_labels Named `character` vector of default labels for `tern`. |
|
672 |
#' |
|
673 |
#' @format |
|
674 |
#' * `tern_default_labels` is a named `character` vector of available default labels, with each element |
|
675 |
#' named for their corresponding statistic. |
|
676 |
#' |
|
677 |
#' @export |
|
678 |
tern_default_labels <- c( |
|
679 |
cv = "CV (%)", |
|
680 |
iqr = "IQR", |
|
681 |
geom_cv = "CV % Geometric Mean", |
|
682 |
geom_mean = "Geometric Mean", |
|
683 |
geom_mean_sd = "Geometric Mean (SD)", |
|
684 |
geom_mean_ci = "Geometric Mean 95% CI", |
|
685 |
geom_mean_ci_3d = "Geometric Mean (95% CI)", |
|
686 |
geom_sd = "Geometric SD", |
|
687 |
mad = "Median Absolute Deviation", |
|
688 |
max = "Maximum", |
|
689 |
mean = "Mean", |
|
690 |
mean_ci = "Mean 95% CI", |
|
691 |
mean_ci_3d = "Mean (95% CI)", |
|
692 |
mean_pval = "Mean p-value (H0: mean = 0)", |
|
693 |
mean_sd = "Mean (SD)", |
|
694 |
mean_sdi = "Mean -/+ 1xSD", |
|
695 |
mean_se = "Mean (SE)", |
|
696 |
mean_sei = "Mean -/+ 1xSE", |
|
697 |
median = "Median", |
|
698 |
median_ci = "Median 95% CI", |
|
699 |
median_ci_3d = "Median (95% CI)", |
|
700 |
median_range = "Median (Min - Max)", |
|
701 |
min = "Minimum", |
|
702 |
n = "n", |
|
703 |
n_blq = "n_blq", |
|
704 |
nonunique = "Number of events", |
|
705 |
pval = "p-value (t-test)", # Default for numeric |
|
706 |
pval_counts = "p-value (chi-squared test)", # Default for counts |
|
707 |
quantiles = "25% and 75%-ile", |
|
708 |
quantiles_lower = "25%-ile (95% CI)", |
|
709 |
quantiles_upper = "75%-ile (95% CI)", |
|
710 |
range = "Min - Max", |
|
711 |
range_censor = "Range (censored)", |
|
712 |
range_event = "Range (event)", |
|
713 |
rate = "Adjusted Rate", |
|
714 |
rate_ratio = "Adjusted Rate Ratio", |
|
715 |
sd = "SD", |
|
716 |
se = "SE", |
|
717 |
sum = "Sum", |
|
718 |
unique = "Number of patients with at least one event" |
|
719 |
) |
|
720 | ||
721 |
#' @describeIn default_stats_formats_labels Quick function to retrieve default formats for summary statistics: |
|
722 |
#' [analyze_vars()] and [analyze_vars_in_cols()] principally. |
|
723 |
#' |
|
724 |
#' @param type (`string`)\cr `"numeric"` or `"counts"`. |
|
725 |
#' |
|
726 |
#' @return |
|
727 |
#' * `summary_formats()` returns a named `vector` of default statistic formats for the given data type. |
|
728 |
#' |
|
729 |
#' @examples |
|
730 |
#' summary_formats() |
|
731 |
#' summary_formats(type = "counts", include_pval = TRUE) |
|
732 |
#' |
|
733 |
#' @export |
|
734 |
summary_formats <- function(type = "numeric", include_pval = FALSE) { |
|
735 | 2x |
met_grp <- paste0(c("analyze_vars", type), collapse = "_") |
736 | 2x |
get_formats_from_stats(get_stats(met_grp, add_pval = include_pval)) |
737 |
} |
|
738 | ||
739 |
#' @describeIn default_stats_formats_labels Quick function to retrieve default labels for summary statistics. |
|
740 |
#' Returns labels of descriptive statistics which are understood by `rtables`. Similar to `summary_formats`. |
|
741 |
#' |
|
742 |
#' @param include_pval (`flag`)\cr same as the `add_pval` argument in [get_stats()]. |
|
743 |
#' |
|
744 |
#' @details |
|
745 |
#' `summary_*` quick get functions for labels or formats uses `get_stats` and `get_labels_from_stats` or |
|
746 |
#' `get_formats_from_stats` respectively to retrieve relevant information. |
|
747 |
#' |
|
748 |
#' @return |
|
749 |
#' * `summary_labels` returns a named `vector` of default statistic labels for the given data type. |
|
750 |
#' |
|
751 |
#' @examples |
|
752 |
#' summary_labels() |
|
753 |
#' summary_labels(type = "counts", include_pval = TRUE) |
|
754 |
#' |
|
755 |
#' @export |
|
756 |
summary_labels <- function(type = "numeric", include_pval = FALSE) { |
|
757 | 2x |
met_grp <- paste0(c("analyze_vars", type), collapse = "_") |
758 | 2x |
get_labels_from_stats(get_stats(met_grp, add_pval = include_pval)) |
759 |
} |
1 |
#' Bland-Altman analysis |
|
2 |
#' |
|
3 |
#' @description `r lifecycle::badge("experimental")` |
|
4 |
#' |
|
5 |
#' Statistics function that uses the Bland-Altman method to assess the agreement between two numerical vectors |
|
6 |
#' and calculates a variety of statistics. |
|
7 |
#' |
|
8 |
#' @inheritParams argument_convention |
|
9 |
#' @param y (`numeric`)\cr vector of numbers we want to analyze, to be compared with `x`. |
|
10 |
#' |
|
11 |
#' @return |
|
12 |
#' A named list of the following elements: |
|
13 |
#' * `df` |
|
14 |
#' * `difference_mean` |
|
15 |
#' * `ci_mean` |
|
16 |
#' * `difference_sd` |
|
17 |
#' * `difference_se` |
|
18 |
#' * `upper_agreement_limit` |
|
19 |
#' * `lower_agreement_limit` |
|
20 |
#' * `agreement_limit_se` |
|
21 |
#' * `upper_agreement_limit_ci` |
|
22 |
#' * `lower_agreement_limit_ci` |
|
23 |
#' * `t_value` |
|
24 |
#' * `n` |
|
25 |
#' |
|
26 |
#' @examples |
|
27 |
#' x <- seq(1, 60, 5) |
|
28 |
#' y <- seq(5, 50, 4) |
|
29 |
#' |
|
30 |
#' s_bland_altman(x, y, conf_level = 0.9) |
|
31 |
#' |
|
32 |
#' @export |
|
33 |
s_bland_altman <- function(x, y, conf_level = 0.95) { |
|
34 | 7x |
checkmate::assert_numeric(x, min.len = 1, any.missing = TRUE) |
35 | 6x |
checkmate::assert_numeric(y, len = length(x), any.missing = TRUE) |
36 | 5x |
checkmate::assert_numeric(conf_level, lower = 0, upper = 1, any.missing = TRUE) |
37 | ||
38 | 4x |
alpha <- 1 - conf_level |
39 | ||
40 | 4x |
ind <- complete.cases(x, y) # use only pairwise complete observations, and check if x and y have the same length |
41 | 4x |
x <- x[ind] |
42 | 4x |
y <- y[ind] |
43 | 4x |
n <- sum(ind) # number of 'observations' |
44 | ||
45 | 4x |
if (n == 0) { |
46 | ! |
stop("there is no valid paired data") |
47 |
} |
|
48 | ||
49 | 4x |
difference <- x - y # vector of differences |
50 | 4x |
average <- (x + y) / 2 # vector of means |
51 | 4x |
difference_mean <- mean(difference) # mean difference |
52 | 4x |
difference_sd <- sd(difference) # SD of differences |
53 | 4x |
al <- qnorm(1 - alpha / 2) * difference_sd |
54 | 4x |
upper_agreement_limit <- difference_mean + al # agreement limits |
55 | 4x |
lower_agreement_limit <- difference_mean - al |
56 | ||
57 | 4x |
difference_se <- difference_sd / sqrt(n) # standard error of the mean |
58 | 4x |
al_se <- difference_sd * sqrt(3) / sqrt(n) # standard error of the agreement limit |
59 | 4x |
tvalue <- qt(1 - alpha / 2, n - 1) # t value for 95% CI calculation |
60 | 4x |
difference_mean_ci <- difference_se * tvalue |
61 | 4x |
al_ci <- al_se * tvalue |
62 | 4x |
upper_agreement_limit_ci <- c(upper_agreement_limit - al_ci, upper_agreement_limit + al_ci) |
63 | 4x |
lower_agreement_limit_ci <- c(lower_agreement_limit - al_ci, lower_agreement_limit + al_ci) |
64 | ||
65 | 4x |
list( |
66 | 4x |
df = data.frame(average, difference), |
67 | 4x |
difference_mean = difference_mean, |
68 | 4x |
ci_mean = difference_mean + c(-1, 1) * difference_mean_ci, |
69 | 4x |
difference_sd = difference_sd, |
70 | 4x |
difference_se = difference_se, |
71 | 4x |
upper_agreement_limit = upper_agreement_limit, |
72 | 4x |
lower_agreement_limit = lower_agreement_limit, |
73 | 4x |
agreement_limit_se = al_se, |
74 | 4x |
upper_agreement_limit_ci = upper_agreement_limit_ci, |
75 | 4x |
lower_agreement_limit_ci = lower_agreement_limit_ci, |
76 | 4x |
t_value = tvalue, |
77 | 4x |
n = n |
78 |
) |
|
79 |
} |
|
80 | ||
81 |
#' Bland-Altman plot |
|
82 |
#' |
|
83 |
#' @description `r lifecycle::badge("experimental")` |
|
84 |
#' |
|
85 |
#' Graphing function that produces a Bland-Altman plot. |
|
86 |
#' |
|
87 |
#' @inheritParams s_bland_altman |
|
88 |
#' |
|
89 |
#' @return A `ggplot` Bland-Altman plot. |
|
90 |
#' |
|
91 |
#' @examples |
|
92 |
#' x <- seq(1, 60, 5) |
|
93 |
#' y <- seq(5, 50, 4) |
|
94 |
#' |
|
95 |
#' g_bland_altman(x = x, y = y, conf_level = 0.9) |
|
96 |
#' |
|
97 |
#' @export |
|
98 |
#' @aliases bland_altman |
|
99 |
g_bland_altman <- function(x, y, conf_level = 0.95) { |
|
100 | 1x |
result_tem <- s_bland_altman(x, y, conf_level = conf_level) |
101 | 1x |
xpos <- max(result_tem$df$average) * 0.9 + min(result_tem$df$average) * 0.1 |
102 | 1x |
yrange <- diff(range(result_tem$df$difference)) |
103 | ||
104 | 1x |
p <- ggplot(result_tem$df) + |
105 | 1x |
geom_point(aes(x = average, y = difference), color = "blue") + |
106 | 1x |
geom_hline(yintercept = result_tem$difference_mean, color = "blue", linetype = 1) + |
107 | 1x |
geom_hline(yintercept = 0, color = "blue", linetype = 2) + |
108 | 1x |
geom_hline(yintercept = result_tem$lower_agreement_limit, color = "red", linetype = 2) + |
109 | 1x |
geom_hline(yintercept = result_tem$upper_agreement_limit, color = "red", linetype = 2) + |
110 | 1x |
annotate( |
111 | 1x |
"text", |
112 | 1x |
x = xpos, |
113 | 1x |
y = result_tem$lower_agreement_limit + 0.03 * yrange, |
114 | 1x |
label = "lower limits of agreement", |
115 | 1x |
color = "red" |
116 |
) + |
|
117 | 1x |
annotate( |
118 | 1x |
"text", |
119 | 1x |
x = xpos, |
120 | 1x |
y = result_tem$upper_agreement_limit + 0.03 * yrange, |
121 | 1x |
label = "upper limits of agreement", |
122 | 1x |
color = "red" |
123 |
) + |
|
124 | 1x |
annotate( |
125 | 1x |
"text", |
126 | 1x |
x = xpos, |
127 | 1x |
y = result_tem$difference_mean + 0.03 * yrange, |
128 | 1x |
label = "mean of difference between two measures", |
129 | 1x |
color = "blue" |
130 |
) + |
|
131 | 1x |
annotate( |
132 | 1x |
"text", |
133 | 1x |
x = xpos, |
134 | 1x |
y = result_tem$lower_agreement_limit - 0.03 * yrange, |
135 | 1x |
label = sprintf("%.2f", result_tem$lower_agreement_limit), |
136 | 1x |
color = "red" |
137 |
) + |
|
138 | 1x |
annotate( |
139 | 1x |
"text", |
140 | 1x |
x = xpos, |
141 | 1x |
y = result_tem$upper_agreement_limit - 0.03 * yrange, |
142 | 1x |
label = sprintf("%.2f", result_tem$upper_agreement_limit), |
143 | 1x |
color = "red" |
144 |
) + |
|
145 | 1x |
annotate( |
146 | 1x |
"text", |
147 | 1x |
x = xpos, |
148 | 1x |
y = result_tem$difference_mean - 0.03 * yrange, |
149 | 1x |
label = sprintf("%.2f", result_tem$difference_meanm), |
150 | 1x |
color = "blue" |
151 |
) + |
|
152 | 1x |
xlab("Average of two measures") + |
153 | 1x |
ylab("Difference between two measures") |
154 | ||
155 | 1x |
return(p) |
156 |
} |
1 |
# Utility functions to cooperate with {rtables} package |
|
2 | ||
3 |
#' Convert table into matrix of strings |
|
4 |
#' |
|
5 |
#' @description `r lifecycle::badge("stable")` |
|
6 |
#' |
|
7 |
#' Helper function to use mostly within tests. `with_spaces`parameter allows |
|
8 |
#' to test not only for content but also indentation and table structure. |
|
9 |
#' `print_txt_to_copy` instead facilitate the testing development by returning a well |
|
10 |
#' formatted text that needs only to be copied and pasted in the expected output. |
|
11 |
#' |
|
12 |
#' @inheritParams formatters::toString |
|
13 |
#' @param x (`VTableTree`)\cr `rtables` table object. |
|
14 |
#' @param with_spaces (`flag`)\cr whether the tested table should keep the indentation and other relevant spaces. |
|
15 |
#' @param print_txt_to_copy (`flag`)\cr utility to have a way to copy the input table directly |
|
16 |
#' into the expected variable instead of copying it too manually. |
|
17 |
#' |
|
18 |
#' @return A `matrix` of `string`s. If `print_txt_to_copy = TRUE` the well formatted printout of the |
|
19 |
#' table will be printed to console, ready to be copied as a expected value. |
|
20 |
#' |
|
21 |
#' @examples |
|
22 |
#' tbl <- basic_table() %>% |
|
23 |
#' split_rows_by("SEX") %>% |
|
24 |
#' split_cols_by("ARM") %>% |
|
25 |
#' analyze("AGE") %>% |
|
26 |
#' build_table(tern_ex_adsl) |
|
27 |
#' |
|
28 |
#' to_string_matrix(tbl, widths = ceiling(propose_column_widths(tbl) / 2)) |
|
29 |
#' |
|
30 |
#' @export |
|
31 |
to_string_matrix <- function(x, widths = NULL, max_width = NULL, |
|
32 |
hsep = formatters::default_hsep(), |
|
33 |
with_spaces = TRUE, print_txt_to_copy = FALSE) { |
|
34 | 11x |
checkmate::assert_flag(with_spaces) |
35 | 11x |
checkmate::assert_flag(print_txt_to_copy) |
36 | 11x |
checkmate::assert_int(max_width, null.ok = TRUE) |
37 | ||
38 | 11x |
if (inherits(x, "MatrixPrintForm")) { |
39 | ! |
tx <- x |
40 |
} else { |
|
41 | 11x |
tx <- matrix_form(x, TRUE) |
42 |
} |
|
43 | ||
44 | 11x |
tf_wrap <- FALSE |
45 | 11x |
if (!is.null(max_width)) { |
46 | ! |
tf_wrap <- TRUE |
47 |
} |
|
48 | ||
49 |
# Producing the matrix to test |
|
50 | 11x |
if (with_spaces) { |
51 | 2x |
out <- strsplit(toString(tx, widths = widths, tf_wrap = tf_wrap, max_width = max_width, hsep = hsep), "\n")[[1]] |
52 |
} else { |
|
53 | 9x |
out <- tx$strings |
54 |
} |
|
55 | ||
56 |
# Printing to console formatted output that needs to be copied in "expected" |
|
57 | 11x |
if (print_txt_to_copy) { |
58 | 2x |
out_tmp <- out |
59 | 2x |
if (!with_spaces) { |
60 | 1x |
out_tmp <- apply(out, 1, paste0, collapse = '", "') |
61 |
} |
|
62 | 2x |
cat(paste0('c(\n "', paste0(out_tmp, collapse = '",\n "'), '"\n)')) |
63 |
} |
|
64 | ||
65 |
# Return values |
|
66 | 11x |
out |
67 |
} |
|
68 | ||
69 |
#' Blank for missing input |
|
70 |
#' |
|
71 |
#' Helper function to use in tabulating model results. |
|
72 |
#' |
|
73 |
#' @param x (`vector`)\cr input for a cell. |
|
74 |
#' |
|
75 |
#' @return An empty `character` vector if all entries in `x` are missing (`NA`), otherwise |
|
76 |
#' the unlisted version of `x`. |
|
77 |
#' |
|
78 |
#' @keywords internal |
|
79 |
unlist_and_blank_na <- function(x) { |
|
80 | 267x |
unl <- unlist(x) |
81 | 267x |
if (all(is.na(unl))) { |
82 | 161x |
character() |
83 |
} else { |
|
84 | 106x |
unl |
85 |
} |
|
86 |
} |
|
87 | ||
88 |
#' Constructor for content functions given a data frame with flag input |
|
89 |
#' |
|
90 |
#' This can be useful for tabulating model results. |
|
91 |
#' |
|
92 |
#' @param analysis_var (`string`)\cr variable name for the column containing values to be returned by the |
|
93 |
#' content function. |
|
94 |
#' @param flag_var (`string`)\cr variable name for the logical column identifying which row should be returned. |
|
95 |
#' @param format (`string`)\cr `rtables` format to use. |
|
96 |
#' |
|
97 |
#' @return A content function which gives `df$analysis_var` at the row identified by |
|
98 |
#' `.df_row$flag` in the given format. |
|
99 |
#' |
|
100 |
#' @keywords internal |
|
101 |
cfun_by_flag <- function(analysis_var, |
|
102 |
flag_var, |
|
103 |
format = "xx", |
|
104 |
.indent_mods = NULL) { |
|
105 | 61x |
checkmate::assert_string(analysis_var) |
106 | 61x |
checkmate::assert_string(flag_var) |
107 | 61x |
function(df, labelstr) { |
108 | 265x |
row_index <- which(df[[flag_var]]) |
109 | 265x |
x <- unlist_and_blank_na(df[[analysis_var]][row_index]) |
110 | 265x |
formatters::with_label( |
111 | 265x |
rcell(x, format = format, indent_mod = .indent_mods), |
112 | 265x |
labelstr |
113 |
) |
|
114 |
} |
|
115 |
} |
|
116 | ||
117 |
#' Content row function to add row total to labels |
|
118 |
#' |
|
119 |
#' This takes the label of the latest row split level and adds the row total from `df` in parentheses. |
|
120 |
#' This function differs from [c_label_n_alt()] by taking row counts from `df` rather than |
|
121 |
#' `alt_counts_df`, and is used by [add_rowcounts()] when `alt_counts` is set to `FALSE`. |
|
122 |
#' |
|
123 |
#' @inheritParams argument_convention |
|
124 |
#' |
|
125 |
#' @return A list with formatted [rtables::CellValue()] with the row count value and the correct label. |
|
126 |
#' |
|
127 |
#' @note It is important here to not use `df` but rather `.N_row` in the implementation, because |
|
128 |
#' the former is already split by columns and will refer to the first column of the data only. |
|
129 |
#' |
|
130 |
#' @seealso [c_label_n_alt()] which performs the same function but retrieves row counts from |
|
131 |
#' `alt_counts_df` instead of `df`. |
|
132 |
#' |
|
133 |
#' @keywords internal |
|
134 |
c_label_n <- function(df, |
|
135 |
labelstr, |
|
136 |
.N_row) { # nolint |
|
137 | 273x |
label <- paste0(labelstr, " (N=", .N_row, ")") |
138 | 273x |
in_rows( |
139 | 273x |
.list = list(row_count = formatters::with_label(c(.N_row, .N_row), label)), |
140 | 273x |
.formats = c(row_count = function(x, ...) "") |
141 |
) |
|
142 |
} |
|
143 | ||
144 |
#' Content row function to add `alt_counts_df` row total to labels |
|
145 |
#' |
|
146 |
#' This takes the label of the latest row split level and adds the row total from `alt_counts_df` |
|
147 |
#' in parentheses. This function differs from [c_label_n()] by taking row counts from `alt_counts_df` |
|
148 |
#' rather than `df`, and is used by [add_rowcounts()] when `alt_counts` is set to `TRUE`. |
|
149 |
#' |
|
150 |
#' @inheritParams argument_convention |
|
151 |
#' |
|
152 |
#' @return A list with formatted [rtables::CellValue()] with the row count value and the correct label. |
|
153 |
#' |
|
154 |
#' @seealso [c_label_n()] which performs the same function but retrieves row counts from `df` instead |
|
155 |
#' of `alt_counts_df`. |
|
156 |
#' |
|
157 |
#' @keywords internal |
|
158 |
c_label_n_alt <- function(df, |
|
159 |
labelstr, |
|
160 |
.alt_df_row) { |
|
161 | 7x |
N_row_alt <- nrow(.alt_df_row) # nolint |
162 | 7x |
label <- paste0(labelstr, " (N=", N_row_alt, ")") |
163 | 7x |
in_rows( |
164 | 7x |
.list = list(row_count = formatters::with_label(c(N_row_alt, N_row_alt), label)), |
165 | 7x |
.formats = c(row_count = function(x, ...) "") |
166 |
) |
|
167 |
} |
|
168 | ||
169 |
#' Layout-creating function to add row total counts |
|
170 |
#' |
|
171 |
#' @description `r lifecycle::badge("stable")` |
|
172 |
#' |
|
173 |
#' This works analogously to [rtables::add_colcounts()] but on the rows. This function |
|
174 |
#' is a wrapper for [rtables::summarize_row_groups()]. |
|
175 |
#' |
|
176 |
#' @inheritParams argument_convention |
|
177 |
#' @param alt_counts (`flag`)\cr whether row counts should be taken from `alt_counts_df` (`TRUE`) |
|
178 |
#' or from `df` (`FALSE`). Defaults to `FALSE`. |
|
179 |
#' |
|
180 |
#' @return A modified layout where the latest row split labels now have the row-wise |
|
181 |
#' total counts (i.e. without column-based subsetting) attached in parentheses. |
|
182 |
#' |
|
183 |
#' @note Row count values are contained in these row count rows but are not displayed |
|
184 |
#' so that they are not considered zero rows by default when pruning. |
|
185 |
#' |
|
186 |
#' @examples |
|
187 |
#' basic_table() %>% |
|
188 |
#' split_cols_by("ARM") %>% |
|
189 |
#' add_colcounts() %>% |
|
190 |
#' split_rows_by("RACE", split_fun = drop_split_levels) %>% |
|
191 |
#' add_rowcounts() %>% |
|
192 |
#' analyze("AGE", afun = list_wrap_x(summary), format = "xx.xx") %>% |
|
193 |
#' build_table(DM) |
|
194 |
#' |
|
195 |
#' @export |
|
196 |
add_rowcounts <- function(lyt, alt_counts = FALSE) { |
|
197 | 7x |
summarize_row_groups( |
198 | 7x |
lyt, |
199 | 7x |
cfun = if (alt_counts) c_label_n_alt else c_label_n |
200 |
) |
|
201 |
} |
|
202 | ||
203 |
#' Obtain column indices |
|
204 |
#' |
|
205 |
#' @description `r lifecycle::badge("stable")` |
|
206 |
#' |
|
207 |
#' Helper function to extract column indices from a `VTableTree` for a given |
|
208 |
#' vector of column names. |
|
209 |
#' |
|
210 |
#' @param table_tree (`VTableTree`)\cr `rtables` table object to extract the indices from. |
|
211 |
#' @param col_names (`character`)\cr vector of column names. |
|
212 |
#' |
|
213 |
#' @return A vector of column indices. |
|
214 |
#' |
|
215 |
#' @export |
|
216 |
h_col_indices <- function(table_tree, col_names) { |
|
217 | 1256x |
checkmate::assert_class(table_tree, "VTableNodeInfo") |
218 | 1256x |
checkmate::assert_subset(col_names, names(attr(col_info(table_tree), "cextra_args")), empty.ok = FALSE) |
219 | 1256x |
match(col_names, names(attr(col_info(table_tree), "cextra_args"))) |
220 |
} |
|
221 | ||
222 |
#' Labels or names of list elements |
|
223 |
#' |
|
224 |
#' Helper function for working with nested statistic function results which typically |
|
225 |
#' don't have labels but names that we can use. |
|
226 |
#' |
|
227 |
#' @param x (`list`)\cr a list. |
|
228 |
#' |
|
229 |
#' @return A `character` vector with the labels or names for the list elements. |
|
230 |
#' |
|
231 |
#' @examples |
|
232 |
#' x <- data.frame( |
|
233 |
#' a = 1:10, |
|
234 |
#' b = rnorm(10) |
|
235 |
#' ) |
|
236 |
#' labels_or_names(x) |
|
237 |
#' var_labels(x) <- c(b = "Label for b", a = NA) |
|
238 |
#' labels_or_names(x) |
|
239 |
#' |
|
240 |
#' @export |
|
241 |
labels_or_names <- function(x) { |
|
242 | 190x |
checkmate::assert_multi_class(x, c("data.frame", "list")) |
243 | 190x |
labs <- sapply(x, obj_label) |
244 | 190x |
nams <- rlang::names2(x) |
245 | 190x |
label_is_null <- sapply(labs, is.null) |
246 | 190x |
result <- unlist(ifelse(label_is_null, nams, labs)) |
247 | 190x |
result |
248 |
} |
|
249 | ||
250 |
#' Convert to `rtable` |
|
251 |
#' |
|
252 |
#' @description `r lifecycle::badge("stable")` |
|
253 |
#' |
|
254 |
#' This is a new generic function to convert objects to `rtable` tables. |
|
255 |
#' |
|
256 |
#' @param x (`data.frame`)\cr the object which should be converted to an `rtable`. |
|
257 |
#' @param ... additional arguments for methods. |
|
258 |
#' |
|
259 |
#' @return An `rtables` table object. Note that the concrete class will depend on the method used. |
|
260 |
#' |
|
261 |
#' @export |
|
262 |
as.rtable <- function(x, ...) { # nolint |
|
263 | 3x |
UseMethod("as.rtable", x) |
264 |
} |
|
265 | ||
266 |
#' @describeIn as.rtable Method for converting a `data.frame` that contains numeric columns to `rtable`. |
|
267 |
#' |
|
268 |
#' @param format (`string` or `function`)\cr the format which should be used for the columns. |
|
269 |
#' |
|
270 |
#' @method as.rtable data.frame |
|
271 |
#' |
|
272 |
#' @examples |
|
273 |
#' x <- data.frame( |
|
274 |
#' a = 1:10, |
|
275 |
#' b = rnorm(10) |
|
276 |
#' ) |
|
277 |
#' as.rtable(x) |
|
278 |
#' |
|
279 |
#' @export |
|
280 |
as.rtable.data.frame <- function(x, format = "xx.xx", ...) { |
|
281 | 3x |
checkmate::assert_numeric(unlist(x)) |
282 | 2x |
do.call( |
283 | 2x |
rtable, |
284 | 2x |
c( |
285 | 2x |
list( |
286 | 2x |
header = labels_or_names(x), |
287 | 2x |
format = format |
288 |
), |
|
289 | 2x |
Map( |
290 | 2x |
function(row, row_name) { |
291 | 20x |
do.call( |
292 | 20x |
rrow, |
293 | 20x |
c(as.list(unname(row)), |
294 | 20x |
row.name = row_name |
295 |
) |
|
296 |
) |
|
297 |
}, |
|
298 | 2x |
row = as.data.frame(t(x)), |
299 | 2x |
row_name = rownames(x) |
300 |
) |
|
301 |
) |
|
302 |
) |
|
303 |
} |
|
304 | ||
305 |
#' Split parameters |
|
306 |
#' |
|
307 |
#' @description `r lifecycle::badge("deprecated")` |
|
308 |
#' |
|
309 |
#' It divides the data in the vector `param` into the groups defined by `f` based on specified `values`. It is relevant |
|
310 |
#' in `rtables` layers so as to distribute parameters `.stats` or' `.formats` into lists with items corresponding to |
|
311 |
#' specific analysis function. |
|
312 |
#' |
|
313 |
#' @param param (`vector`)\cr the parameter to be split. |
|
314 |
#' @param value (`vector`)\cr the value used to split. |
|
315 |
#' @param f (`list`)\cr the reference to make the split. |
|
316 |
#' |
|
317 |
#' @return A named `list` with the same element names as `f`, each containing the elements specified in `.stats`. |
|
318 |
#' |
|
319 |
#' @examples |
|
320 |
#' f <- list( |
|
321 |
#' surv = c("pt_at_risk", "event_free_rate", "rate_se", "rate_ci"), |
|
322 |
#' surv_diff = c("rate_diff", "rate_diff_ci", "ztest_pval") |
|
323 |
#' ) |
|
324 |
#' |
|
325 |
#' .stats <- c("pt_at_risk", "rate_diff") |
|
326 |
#' h_split_param(.stats, .stats, f = f) |
|
327 |
#' |
|
328 |
#' # $surv |
|
329 |
#' # [1] "pt_at_risk" |
|
330 |
#' # |
|
331 |
#' # $surv_diff |
|
332 |
#' # [1] "rate_diff" |
|
333 |
#' |
|
334 |
#' .formats <- c("pt_at_risk" = "xx", "event_free_rate" = "xxx") |
|
335 |
#' h_split_param(.formats, names(.formats), f = f) |
|
336 |
#' |
|
337 |
#' # $surv |
|
338 |
#' # pt_at_risk event_free_rate |
|
339 |
#' # "xx" "xxx" |
|
340 |
#' # |
|
341 |
#' # $surv_diff |
|
342 |
#' # NULL |
|
343 |
#' |
|
344 |
#' @export |
|
345 |
h_split_param <- function(param, |
|
346 |
value, |
|
347 |
f) { |
|
348 | 2x |
lifecycle::deprecate_warn("0.9.8", "h_split_param()") |
349 | ||
350 | 2x |
y <- lapply(f, function(x) param[value %in% x]) |
351 | 2x |
lapply(y, function(x) if (length(x) == 0) NULL else x) |
352 |
} |
|
353 | ||
354 |
#' Get selected statistics names |
|
355 |
#' |
|
356 |
#' Helper function to be used for creating `afun`. |
|
357 |
#' |
|
358 |
#' @param .stats (`vector` or `NULL`)\cr input to the layout creating function. Note that `NULL` means |
|
359 |
#' in this context that all default statistics should be used. |
|
360 |
#' @param all_stats (`character`)\cr all statistics which can be selected here potentially. |
|
361 |
#' |
|
362 |
#' @return A `character` vector with the selected statistics. |
|
363 |
#' |
|
364 |
#' @keywords internal |
|
365 |
afun_selected_stats <- function(.stats, all_stats) { |
|
366 | 2x |
checkmate::assert_character(.stats, null.ok = TRUE) |
367 | 2x |
checkmate::assert_character(all_stats) |
368 | 2x |
if (is.null(.stats)) { |
369 | 1x |
all_stats |
370 |
} else { |
|
371 | 1x |
intersect(.stats, all_stats) |
372 |
} |
|
373 |
} |
|
374 | ||
375 |
#' Add variable labels to top left corner in table |
|
376 |
#' |
|
377 |
#' @description `r lifecycle::badge("stable")` |
|
378 |
#' |
|
379 |
#' Helper layout-creating function to append the variable labels of a given variables vector |
|
380 |
#' from a given dataset in the top left corner. If a variable label is not found then the |
|
381 |
#' variable name itself is used instead. Multiple variable labels are concatenated with slashes. |
|
382 |
#' |
|
383 |
#' @inheritParams argument_convention |
|
384 |
#' @param vars (`character`)\cr variable names of which the labels are to be looked up in `df`. |
|
385 |
#' @param indent (`integer(1)`)\cr non-negative number of nested indent space, default to 0L which means no indent. |
|
386 |
#' 1L means two spaces indent, 2L means four spaces indent and so on. |
|
387 |
#' |
|
388 |
#' @return A modified layout with the new variable label(s) added to the top-left material. |
|
389 |
#' |
|
390 |
#' @note This is not an optimal implementation of course, since we are using here the data set |
|
391 |
#' itself during the layout creation. When we have a more mature `rtables` implementation then |
|
392 |
#' this will also be improved or not necessary anymore. |
|
393 |
#' |
|
394 |
#' @examples |
|
395 |
#' lyt <- basic_table() %>% |
|
396 |
#' split_cols_by("ARM") %>% |
|
397 |
#' add_colcounts() %>% |
|
398 |
#' split_rows_by("SEX") %>% |
|
399 |
#' append_varlabels(DM, "SEX") %>% |
|
400 |
#' analyze("AGE", afun = mean) %>% |
|
401 |
#' append_varlabels(DM, "AGE", indent = 1) |
|
402 |
#' build_table(lyt, DM) |
|
403 |
#' |
|
404 |
#' lyt <- basic_table() %>% |
|
405 |
#' split_cols_by("ARM") %>% |
|
406 |
#' split_rows_by("SEX") %>% |
|
407 |
#' analyze("AGE", afun = mean) %>% |
|
408 |
#' append_varlabels(DM, c("SEX", "AGE")) |
|
409 |
#' build_table(lyt, DM) |
|
410 |
#' |
|
411 |
#' @export |
|
412 |
append_varlabels <- function(lyt, df, vars, indent = 0L) { |
|
413 | 3x |
if (checkmate::test_flag(indent)) { |
414 | ! |
warning("indent argument is now accepting integers. Boolean indent will be converted to integers.") |
415 | ! |
indent <- as.integer(indent) |
416 |
} |
|
417 | ||
418 | 3x |
checkmate::assert_data_frame(df) |
419 | 3x |
checkmate::assert_character(vars) |
420 | 3x |
checkmate::assert_count(indent) |
421 | ||
422 | 3x |
lab <- formatters::var_labels(df[vars], fill = TRUE) |
423 | 3x |
lab <- paste(lab, collapse = " / ") |
424 | 3x |
space <- paste(rep(" ", indent * 2), collapse = "") |
425 | 3x |
lab <- paste0(space, lab) |
426 | ||
427 | 3x |
append_topleft(lyt, lab) |
428 |
} |
|
429 | ||
430 |
#' Default string replacement for `NA` values |
|
431 |
#' |
|
432 |
#' @description `r lifecycle::badge("stable")` |
|
433 |
#' |
|
434 |
#' The default string used to represent `NA` values. This value is used as the default |
|
435 |
#' value for the `na_str` argument throughout the `tern` package, and printed in place |
|
436 |
#' of `NA` values in output tables. If not specified for each `tern` function by the user |
|
437 |
#' via the `na_str` argument, or in the R environment options via [set_default_na_str()], |
|
438 |
#' then `NA` is used. |
|
439 |
#' |
|
440 |
#' @param na_str (`string`)\cr single string value to set in the R environment options as |
|
441 |
#' the default value to replace `NA`s. Use `getOption("tern_default_na_str")` to check the |
|
442 |
#' current value set in the R environment (defaults to `NULL` if not set). |
|
443 |
#' |
|
444 |
#' @name default_na_str |
|
445 |
NULL |
|
446 | ||
447 |
#' @describeIn default_na_str Accessor for default `NA` value replacement string. |
|
448 |
#' |
|
449 |
#' @return |
|
450 |
#' * `default_na_str` returns the current value if an R environment option has been set |
|
451 |
#' for `"tern_default_na_str"`, or `NA_character_` otherwise. |
|
452 |
#' |
|
453 |
#' @examples |
|
454 |
#' # Default settings |
|
455 |
#' default_na_str() |
|
456 |
#' getOption("tern_default_na_str") |
|
457 |
#' |
|
458 |
#' # Set custom value |
|
459 |
#' set_default_na_str("<Missing>") |
|
460 |
#' |
|
461 |
#' # Settings after value has been set |
|
462 |
#' default_na_str() |
|
463 |
#' getOption("tern_default_na_str") |
|
464 |
#' |
|
465 |
#' @export |
|
466 |
default_na_str <- function() { |
|
467 | 274x |
getOption("tern_default_na_str", default = NA_character_) |
468 |
} |
|
469 | ||
470 |
#' @describeIn default_na_str Setter for default `NA` value replacement string. Sets the |
|
471 |
#' option `"tern_default_na_str"` within the R environment. |
|
472 |
#' |
|
473 |
#' @return |
|
474 |
#' * `set_default_na_str` has no return value. |
|
475 |
#' |
|
476 |
#' @export |
|
477 |
set_default_na_str <- function(na_str) { |
|
478 | 4x |
checkmate::assert_character(na_str, len = 1, null.ok = TRUE) |
479 | 4x |
options("tern_default_na_str" = na_str) |
480 |
} |
|
481 | ||
482 | ||
483 |
#' Utilities to handle extra arguments in analysis functions |
|
484 |
#' |
|
485 |
#' @description `r lifecycle::badge("stable")` |
|
486 |
#' Important additional parameters, useful to modify behavior of analysis and summary |
|
487 |
#' functions are listed in [rtables::additional_fun_params]. With these utility functions |
|
488 |
#' we can retrieve a curated list of these parameters from the environment, and pass them |
|
489 |
#' to the analysis functions with dedicated `...`; notice that the final `s_*` function |
|
490 |
#' will get them through argument matching. |
|
491 |
#' |
|
492 |
#' @param extra_afun_params (`list`)\cr list of additional parameters (`character`) to be |
|
493 |
#' retrieved from the environment. Curated list is present in [rtables::additional_fun_params]. |
|
494 |
#' @param add_alt_df (`logical`)\cr if `TRUE`, the function will also add `.alt_df` and `.alt_df_row` |
|
495 |
#' parameters. |
|
496 |
#' |
|
497 |
#' @name util_handling_additional_fun_params |
|
498 |
NULL |
|
499 | ||
500 |
#' @describeIn util_handling_additional_fun_params Retrieve additional parameters from the environment. |
|
501 |
#' |
|
502 |
#' @return |
|
503 |
#' * `retrieve_extra_afun_params` returns a list of the values of the parameters in the environment. |
|
504 |
#' |
|
505 |
#' @keywords internal |
|
506 |
retrieve_extra_afun_params <- function(extra_afun_params) { |
|
507 | 1583x |
out <- list() |
508 | 1583x |
for (extra_param in extra_afun_params) { |
509 | 15851x |
out <- c(out, list(get(extra_param, envir = parent.frame()))) |
510 |
} |
|
511 | 1583x |
setNames(out, extra_afun_params) |
512 |
} |
|
513 | ||
514 |
#' @describeIn util_handling_additional_fun_params Curated list of additional parameters for |
|
515 |
#' analysis functions. Please check [rtables::additional_fun_params] for precise descriptions. |
|
516 |
#' |
|
517 |
#' @return |
|
518 |
#' * `get_additional_afun_params` returns a list of additional parameters. |
|
519 |
#' |
|
520 |
#' @keywords internal |
|
521 |
get_additional_afun_params <- function(add_alt_df = FALSE) { |
|
522 | 240x |
out_list <- list( |
523 | 240x |
.N_col = integer(), |
524 | 240x |
.N_total = integer(), |
525 | 240x |
.N_row = integer(), |
526 | 240x |
.df_row = data.frame(), |
527 | 240x |
.var = character(), |
528 | 240x |
.ref_group = character(), |
529 | 240x |
.ref_full = vector(mode = "numeric"), |
530 | 240x |
.in_ref_col = logical(), |
531 | 240x |
.spl_context = data.frame(), |
532 | 240x |
.all_col_exprs = vector(mode = "expression"), |
533 | 240x |
.all_col_counts = vector(mode = "integer") |
534 |
) |
|
535 | ||
536 | 240x |
if (isTRUE(add_alt_df)) { |
537 | ! |
out_list <- c( |
538 | ! |
out_list, |
539 | ! |
.alt_df_row = data.frame(), |
540 | ! |
.alt_df = data.frame() |
541 |
) |
|
542 |
} |
|
543 | ||
544 | 240x |
out_list |
545 |
} |
1 |
#' Helper function for deriving analysis datasets for select laboratory tables |
|
2 |
#' |
|
3 |
#' @description `r lifecycle::badge("stable")` |
|
4 |
#' |
|
5 |
#' Helper function that merges ADSL and ADLB datasets so that missing lab test records are inserted in the |
|
6 |
#' output dataset. Remember that `na_level` must match the needed pre-processing |
|
7 |
#' done with [df_explicit_na()] to have the desired output. |
|
8 |
#' |
|
9 |
#' @param adsl (`data.frame`)\cr ADSL data frame. |
|
10 |
#' @param adlb (`data.frame`)\cr ADLB data frame. |
|
11 |
#' @param worst_flag (named `character`)\cr worst post-baseline lab flag variable. See how this is implemented in the |
|
12 |
#' following examples. |
|
13 |
#' @param by_visit (`flag`)\cr defaults to `FALSE` to generate worst grade per patient. |
|
14 |
#' If worst grade per patient per visit is specified for `worst_flag`, then |
|
15 |
#' `by_visit` should be `TRUE` to generate worst grade patient per visit. |
|
16 |
#' @param no_fillin_visits (named `character`)\cr visits that are not considered for post-baseline worst toxicity |
|
17 |
#' grade. Defaults to `c("SCREENING", "BASELINE")`. |
|
18 |
#' |
|
19 |
#' @return `df` containing variables shared between `adlb` and `adsl` along with variables `PARAM`, `PARAMCD`, |
|
20 |
#' `ATOXGR`, and `BTOXGR` relevant for analysis. Optionally, `AVISIT` are `AVISITN` are included when |
|
21 |
#' `by_visit = TRUE` and `no_fillin_visits = c("SCREENING", "BASELINE")`. |
|
22 |
#' |
|
23 |
#' @details In the result data missing records will be created for the following situations: |
|
24 |
#' * Patients who are present in `adsl` but have no lab data in `adlb` (both baseline and post-baseline). |
|
25 |
#' * Patients who do not have any post-baseline lab values. |
|
26 |
#' * Patients without any post-baseline values flagged as the worst. |
|
27 |
#' |
|
28 |
#' @examples |
|
29 |
#' # `h_adsl_adlb_merge_using_worst_flag` |
|
30 |
#' adlb_out <- h_adsl_adlb_merge_using_worst_flag( |
|
31 |
#' tern_ex_adsl, |
|
32 |
#' tern_ex_adlb, |
|
33 |
#' worst_flag = c("WGRHIFL" = "Y") |
|
34 |
#' ) |
|
35 |
#' |
|
36 |
#' # `h_adsl_adlb_merge_using_worst_flag` by visit example |
|
37 |
#' adlb_out_by_visit <- h_adsl_adlb_merge_using_worst_flag( |
|
38 |
#' tern_ex_adsl, |
|
39 |
#' tern_ex_adlb, |
|
40 |
#' worst_flag = c("WGRLOVFL" = "Y"), |
|
41 |
#' by_visit = TRUE |
|
42 |
#' ) |
|
43 |
#' |
|
44 |
#' @export |
|
45 |
h_adsl_adlb_merge_using_worst_flag <- function(adsl, |
|
46 |
adlb, |
|
47 |
worst_flag = c("WGRHIFL" = "Y"), |
|
48 |
by_visit = FALSE, |
|
49 |
no_fillin_visits = c("SCREENING", "BASELINE")) { |
|
50 | 5x |
col_names <- names(worst_flag) |
51 | 5x |
filter_values <- worst_flag |
52 | ||
53 | 5x |
temp <- Map( |
54 | 5x |
function(x, y) which(adlb[[x]] == y), |
55 | 5x |
col_names, |
56 | 5x |
filter_values |
57 |
) |
|
58 | ||
59 | 5x |
position_satisfy_filters <- Reduce(intersect, temp) |
60 | ||
61 | 5x |
adsl_adlb_common_columns <- intersect(colnames(adsl), colnames(adlb)) |
62 | 5x |
columns_from_adlb <- c("USUBJID", "PARAM", "PARAMCD", "AVISIT", "AVISITN", "ATOXGR", "BTOXGR") |
63 | ||
64 | 5x |
adlb_f <- adlb[position_satisfy_filters, ] %>% |
65 | 5x |
dplyr::filter(!.data[["AVISIT"]] %in% no_fillin_visits) |
66 | 5x |
adlb_f <- adlb_f[, columns_from_adlb] |
67 | ||
68 | 5x |
avisits_grid <- adlb %>% |
69 | 5x |
dplyr::filter(!.data[["AVISIT"]] %in% no_fillin_visits) %>% |
70 | 5x |
dplyr::pull(.data[["AVISIT"]]) %>% |
71 | 5x |
unique() |
72 | ||
73 | 5x |
if (by_visit) { |
74 | 1x |
adsl_lb <- expand.grid( |
75 | 1x |
USUBJID = unique(adsl$USUBJID), |
76 | 1x |
AVISIT = avisits_grid, |
77 | 1x |
PARAMCD = unique(adlb$PARAMCD) |
78 |
) |
|
79 | ||
80 | 1x |
adsl_lb <- adsl_lb %>% |
81 | 1x |
dplyr::left_join(unique(adlb[c("AVISIT", "AVISITN")]), by = "AVISIT") %>% |
82 | 1x |
dplyr::left_join(unique(adlb[c("PARAM", "PARAMCD")]), by = "PARAMCD") |
83 | ||
84 | 1x |
adsl1 <- adsl[, adsl_adlb_common_columns] |
85 | 1x |
adsl_lb <- adsl1 %>% merge(adsl_lb, by = "USUBJID") |
86 | ||
87 | 1x |
by_variables_from_adlb <- c("USUBJID", "AVISIT", "AVISITN", "PARAMCD", "PARAM") |
88 | ||
89 | 1x |
adlb_btoxgr <- adlb %>% |
90 | 1x |
dplyr::select(c("USUBJID", "PARAMCD", "BTOXGR")) %>% |
91 | 1x |
unique() %>% |
92 | 1x |
dplyr::rename("BTOXGR_MAP" = "BTOXGR") |
93 | ||
94 | 1x |
adlb_out <- merge( |
95 | 1x |
adlb_f, |
96 | 1x |
adsl_lb, |
97 | 1x |
by = by_variables_from_adlb, |
98 | 1x |
all = TRUE, |
99 | 1x |
sort = FALSE |
100 |
) |
|
101 | 1x |
adlb_out <- adlb_out %>% |
102 | 1x |
dplyr::left_join(adlb_btoxgr, by = c("USUBJID", "PARAMCD")) %>% |
103 | 1x |
dplyr::mutate(BTOXGR = .data$BTOXGR_MAP) %>% |
104 | 1x |
dplyr::select(-"BTOXGR_MAP") |
105 | ||
106 | 1x |
adlb_var_labels <- c( |
107 | 1x |
formatters::var_labels(adlb[by_variables_from_adlb]), |
108 | 1x |
formatters::var_labels(adlb[columns_from_adlb[!columns_from_adlb %in% by_variables_from_adlb]]), |
109 | 1x |
formatters::var_labels(adsl[adsl_adlb_common_columns[adsl_adlb_common_columns != "USUBJID"]]) |
110 |
) |
|
111 |
} else { |
|
112 | 4x |
adsl_lb <- expand.grid( |
113 | 4x |
USUBJID = unique(adsl$USUBJID), |
114 | 4x |
PARAMCD = unique(adlb$PARAMCD) |
115 |
) |
|
116 | ||
117 | 4x |
adsl_lb <- adsl_lb %>% dplyr::left_join(unique(adlb[c("PARAM", "PARAMCD")]), by = "PARAMCD") |
118 | ||
119 | 4x |
adsl1 <- adsl[, adsl_adlb_common_columns] |
120 | 4x |
adsl_lb <- adsl1 %>% merge(adsl_lb, by = "USUBJID") |
121 | ||
122 | 4x |
by_variables_from_adlb <- c("USUBJID", "PARAMCD", "PARAM") |
123 | ||
124 | 4x |
adlb_out <- merge( |
125 | 4x |
adlb_f, |
126 | 4x |
adsl_lb, |
127 | 4x |
by = by_variables_from_adlb, |
128 | 4x |
all = TRUE, |
129 | 4x |
sort = FALSE |
130 |
) |
|
131 | ||
132 | 4x |
adlb_var_labels <- c( |
133 | 4x |
formatters::var_labels(adlb[by_variables_from_adlb]), |
134 | 4x |
formatters::var_labels(adlb[columns_from_adlb[!columns_from_adlb %in% by_variables_from_adlb]]), |
135 | 4x |
formatters::var_labels(adsl[adsl_adlb_common_columns[adsl_adlb_common_columns != "USUBJID"]]) |
136 |
) |
|
137 |
} |
|
138 | ||
139 | 5x |
adlb_out$ATOXGR <- as.factor(adlb_out$ATOXGR) |
140 | 5x |
adlb_out$BTOXGR <- as.factor(adlb_out$BTOXGR) |
141 | ||
142 | 5x |
formatters::var_labels(adlb_out) <- adlb_var_labels |
143 | ||
144 | 5x |
adlb_out |
145 |
} |
1 |
#' Missing data |
|
2 |
#' |
|
3 |
#' @description `r lifecycle::badge("stable")` |
|
4 |
#' |
|
5 |
#' Substitute missing data with a string or factor level. |
|
6 |
#' |
|
7 |
#' @param x (`factor` or `character`)\cr values for which any missing values should be substituted. |
|
8 |
#' @param label (`string`)\cr string that missing data should be replaced with. |
|
9 |
#' |
|
10 |
#' @return `x` with any `NA` values substituted by `label`. |
|
11 |
#' |
|
12 |
#' @examples |
|
13 |
#' explicit_na(c(NA, "a", "b")) |
|
14 |
#' is.na(explicit_na(c(NA, "a", "b"))) |
|
15 |
#' |
|
16 |
#' explicit_na(factor(c(NA, "a", "b"))) |
|
17 |
#' is.na(explicit_na(factor(c(NA, "a", "b")))) |
|
18 |
#' |
|
19 |
#' explicit_na(sas_na(c("a", ""))) |
|
20 |
#' |
|
21 |
#' @export |
|
22 |
explicit_na <- function(x, label = "<Missing>") { |
|
23 | 256x |
checkmate::assert_string(label) |
24 | ||
25 | 256x |
if (is.factor(x)) { |
26 | 151x |
x <- forcats::fct_na_value_to_level(x, label) |
27 | 151x |
forcats::fct_drop(x, only = label) |
28 | 105x |
} else if (is.character(x)) { |
29 | 105x |
x[is.na(x)] <- label |
30 | 105x |
x |
31 |
} else { |
|
32 | ! |
stop("only factors and character vectors allowed") |
33 |
} |
|
34 |
} |
|
35 | ||
36 |
#' Convert strings to `NA` |
|
37 |
#' |
|
38 |
#' @description `r lifecycle::badge("stable")` |
|
39 |
#' |
|
40 |
#' SAS imports missing data as empty strings or strings with whitespaces only. This helper function can be used to |
|
41 |
#' convert these values to `NA`s. |
|
42 |
#' |
|
43 |
#' @inheritParams explicit_na |
|
44 |
#' @param empty (`flag`)\cr if `TRUE`, empty strings get replaced by `NA`. |
|
45 |
#' @param whitespaces (`flag`)\cr if `TRUE`, strings made from only whitespaces get replaced with `NA`. |
|
46 |
#' |
|
47 |
#' @return `x` with `""` and/or whitespace-only values substituted by `NA`, depending on the values of |
|
48 |
#' `empty` and `whitespaces`. |
|
49 |
#' |
|
50 |
#' @examples |
|
51 |
#' sas_na(c("1", "", " ", " ", "b")) |
|
52 |
#' sas_na(factor(c("", " ", "b"))) |
|
53 |
#' |
|
54 |
#' is.na(sas_na(c("1", "", " ", " ", "b"))) |
|
55 |
#' |
|
56 |
#' @export |
|
57 |
sas_na <- function(x, empty = TRUE, whitespaces = TRUE) { |
|
58 | 245x |
checkmate::assert_flag(empty) |
59 | 245x |
checkmate::assert_flag(whitespaces) |
60 | ||
61 | 245x |
if (is.factor(x)) { |
62 | 135x |
empty_levels <- levels(x) == "" |
63 | 11x |
if (empty && any(empty_levels)) levels(x)[empty_levels] <- NA |
64 | ||
65 | 135x |
ws_levels <- grepl("^\\s+$", levels(x)) |
66 | ! |
if (whitespaces && any(ws_levels)) levels(x)[ws_levels] <- NA |
67 | ||
68 | 135x |
x |
69 | 110x |
} else if (is.character(x)) { |
70 | 110x |
if (empty) x[x == ""] <- NA_character_ |
71 | ||
72 | 110x |
if (whitespaces) x[grepl("^\\s+$", x)] <- NA_character_ |
73 | ||
74 | 110x |
x |
75 |
} else { |
|
76 | ! |
stop("only factors and character vectors allowed") |
77 |
} |
|
78 |
} |
1 |
#' Survival time point analysis |
|
2 |
#' |
|
3 |
#' @description `r lifecycle::badge("stable")` |
|
4 |
#' |
|
5 |
#' The analyze function [surv_timepoint()] creates a layout element to analyze patient survival rates and difference |
|
6 |
#' of survival rates between groups at a given time point. The primary analysis variable `vars` is the time variable. |
|
7 |
#' Other required inputs are `time_point`, the numeric time point of interest, and `is_event`, a variable that |
|
8 |
#' indicates whether or not an event has occurred. The `method` argument is used to specify whether you want to analyze |
|
9 |
#' survival estimations (`"surv"`), difference in survival with the control (`"surv_diff"`), or both of these |
|
10 |
#' (`"both"`). |
|
11 |
#' |
|
12 |
#' @inheritParams argument_convention |
|
13 |
#' @inheritParams s_surv_time |
|
14 |
#' @param time_point (`numeric(1)`)\cr survival time point of interest. |
|
15 |
#' @param control (`list`)\cr parameters for comparison details, specified by using the helper function |
|
16 |
#' [control_surv_timepoint()]. Some possible parameter options are: |
|
17 |
#' * `conf_level` (`proportion`)\cr confidence level of the interval for survival rate. |
|
18 |
#' * `conf_type` (`string`)\cr confidence interval type. Options are "plain" (default), "log", "log-log", |
|
19 |
#' see more in [survival::survfit()]. Note option "none" is no longer supported. |
|
20 |
#' @param method (`string`)\cr `"surv"` (survival estimations), `"surv_diff"` (difference in survival with the |
|
21 |
#' control), or `"both"`. |
|
22 |
#' @param table_names_suffix (`string`)\cr optional suffix for the `table_names` used for the `rtables` to |
|
23 |
#' avoid warnings from duplicate table names. |
|
24 |
#' @param .indent_mods (named `integer`)\cr indent modifiers for the labels. Each element of the vector |
|
25 |
#' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation |
|
26 |
#' for that statistic's row label. |
|
27 |
#' @param .stats (`character`)\cr statistics to select for the table. |
|
28 |
#' |
|
29 |
#' Options are: ``r shQuote(get_stats("surv_timepoint"), type = "sh")`` |
|
30 |
#' |
|
31 |
#' @name survival_timepoint |
|
32 |
#' @order 1 |
|
33 |
NULL |
|
34 | ||
35 |
#' @describeIn survival_timepoint Statistics function which analyzes survival rate. |
|
36 |
#' |
|
37 |
#' @return |
|
38 |
#' * `s_surv_timepoint()` returns the statistics: |
|
39 |
#' * `pt_at_risk`: Patients remaining at risk. |
|
40 |
#' * `event_free_rate`: Event-free rate (%). |
|
41 |
#' * `rate_se`: Standard error of event free rate. |
|
42 |
#' * `rate_ci`: Confidence interval for event free rate. |
|
43 |
#' * `event_free_rate_3d`: Event-free rate (%) with Confidence interval. |
|
44 |
#' |
|
45 |
#' @examples |
|
46 |
#' library(dplyr) |
|
47 |
#' |
|
48 |
#' adtte_f <- tern_ex_adtte %>% |
|
49 |
#' filter(PARAMCD == "OS") %>% |
|
50 |
#' mutate( |
|
51 |
#' AVAL = day2month(AVAL), |
|
52 |
#' is_event = CNSR == 0 |
|
53 |
#' ) |
|
54 |
#' |
|
55 |
#' s_surv_timepoint( |
|
56 |
#' df = subset(adtte_f, ARMCD == "ARM A"), |
|
57 |
#' .var = "AVAL", |
|
58 |
#' is_event = "is_event", |
|
59 |
#' time_point = c(10), |
|
60 |
#' control = control_surv_timepoint() |
|
61 |
#' ) |
|
62 |
#' |
|
63 |
#' @export |
|
64 |
s_surv_timepoint <- function(df, |
|
65 |
.var, |
|
66 |
time_point, |
|
67 |
is_event, |
|
68 |
control = control_surv_timepoint(), |
|
69 |
...) { |
|
70 | 35x |
checkmate::assert_string(.var) |
71 | 35x |
assert_df_with_variables(df, list(tte = .var, is_event = is_event)) |
72 | 35x |
checkmate::assert_numeric(df[[.var]], min.len = 1, any.missing = FALSE) |
73 | 35x |
checkmate::assert_number(time_point) |
74 | 35x |
checkmate::assert_logical(df[[is_event]], min.len = 1, any.missing = FALSE) |
75 | ||
76 | 35x |
conf_type <- control$conf_type |
77 | 35x |
conf_level <- control$conf_level |
78 | ||
79 | 35x |
formula <- stats::as.formula(paste0("survival::Surv(", .var, ", ", is_event, ") ~ 1")) |
80 | 35x |
srv_fit <- survival::survfit( |
81 | 35x |
formula = formula, |
82 | 35x |
data = df, |
83 | 35x |
conf.int = conf_level, |
84 | 35x |
conf.type = conf_type |
85 |
) |
|
86 | 35x |
s_srv_fit <- summary(srv_fit, times = time_point, extend = TRUE) |
87 | 35x |
df_srv_fit <- as.data.frame(s_srv_fit[c("time", "n.risk", "surv", "lower", "upper", "std.err")]) |
88 | 35x |
if (df_srv_fit[["n.risk"]] == 0) { |
89 | 1x |
pt_at_risk <- event_free_rate <- rate_se <- NA_real_ |
90 | 1x |
rate_ci <- c(NA_real_, NA_real_) |
91 |
} else { |
|
92 | 34x |
pt_at_risk <- df_srv_fit$n.risk |
93 | 34x |
event_free_rate <- df_srv_fit$surv |
94 | 34x |
rate_se <- df_srv_fit$std.err |
95 | 34x |
rate_ci <- c(df_srv_fit$lower, df_srv_fit$upper) |
96 |
} |
|
97 | 35x |
event_free_rate_3d <- c(event_free_rate, rate_ci) |
98 | 35x |
list( |
99 | 35x |
pt_at_risk = formatters::with_label(pt_at_risk, "Patients remaining at risk"), |
100 | 35x |
event_free_rate = formatters::with_label(event_free_rate * 100, "Event Free Rate (%)"), |
101 | 35x |
rate_se = formatters::with_label(rate_se * 100, "Standard Error of Event Free Rate"), |
102 | 35x |
rate_ci = formatters::with_label(rate_ci * 100, f_conf_level(conf_level)), |
103 | 35x |
event_free_rate_3d = formatters::with_label( |
104 | 35x |
event_free_rate_3d * 100, paste0("Event Free Rate (", f_conf_level(conf_level), ")") |
105 |
) |
|
106 |
) |
|
107 |
} |
|
108 | ||
109 |
#' @describeIn survival_timepoint Statistics function which analyzes difference between two survival rates. |
|
110 |
#' |
|
111 |
#' @return |
|
112 |
#' * `s_surv_timepoint_diff()` returns the statistics: |
|
113 |
#' * `rate_diff`: Event-free rate difference between two groups. |
|
114 |
#' * `rate_diff_ci`: Confidence interval for the difference. |
|
115 |
#' * `rate_diff_ci_3d`: Event-free rate difference and confidence interval between two groups. |
|
116 |
#' * `ztest_pval`: p-value to test the difference is 0. |
|
117 |
#' |
|
118 |
#' @keywords internal |
|
119 |
s_surv_timepoint_diff <- function(df, |
|
120 |
.var, |
|
121 |
.ref_group, |
|
122 |
.in_ref_col, |
|
123 |
time_point, |
|
124 |
control = control_surv_timepoint(), |
|
125 |
...) { |
|
126 | 14x |
if (.in_ref_col) { |
127 | 4x |
return( |
128 | 4x |
list( |
129 | 4x |
rate_diff = formatters::with_label(numeric(), "Difference in Event Free Rate"), |
130 | 4x |
rate_diff_ci = formatters::with_label(numeric(), f_conf_level(control$conf_level)), |
131 | 4x |
rate_diff_ci_3d = formatters::with_label( |
132 | 4x |
numeric(), paste0("Difference in Event Free Rate", f_conf_level(control$conf_level)) |
133 |
), |
|
134 | 4x |
ztest_pval = formatters::with_label(numeric(), "p-value (Z-test)") |
135 |
) |
|
136 |
) |
|
137 |
} |
|
138 | 10x |
data <- rbind(.ref_group, df) |
139 | 10x |
group <- factor(rep(c("ref", "x"), c(nrow(.ref_group), nrow(df))), levels = c("ref", "x")) |
140 | 10x |
res_per_group <- lapply(split(data, group), function(x) { |
141 | 20x |
s_surv_timepoint(df = x, .var = .var, time_point = time_point, control = control, ...) |
142 |
}) |
|
143 | ||
144 | 10x |
res_x <- res_per_group[[2]] |
145 | 10x |
res_ref <- res_per_group[[1]] |
146 | 10x |
rate_diff <- res_x$event_free_rate - res_ref$event_free_rate |
147 | 10x |
se_diff <- sqrt(res_x$rate_se^2 + res_ref$rate_se^2) |
148 | ||
149 | 10x |
qs <- c(-1, 1) * stats::qnorm(1 - (1 - control$conf_level) / 2) |
150 | 10x |
rate_diff_ci <- rate_diff + qs * se_diff |
151 | 10x |
rate_diff_ci_3d <- c(rate_diff, rate_diff_ci) |
152 | 10x |
ztest_pval <- if (is.na(rate_diff)) { |
153 | 10x |
NA |
154 |
} else { |
|
155 | 10x |
2 * (1 - stats::pnorm(abs(rate_diff) / se_diff)) |
156 |
} |
|
157 | 10x |
list( |
158 | 10x |
rate_diff = formatters::with_label(rate_diff, "Difference in Event Free Rate"), |
159 | 10x |
rate_diff_ci = formatters::with_label(rate_diff_ci, f_conf_level(control$conf_level)), |
160 | 10x |
rate_diff_ci_3d = formatters::with_label( |
161 | 10x |
rate_diff_ci_3d, paste0("Difference in Event Free Rate", f_conf_level(control$conf_level)) |
162 |
), |
|
163 | 10x |
ztest_pval = formatters::with_label(ztest_pval, "p-value (Z-test)") |
164 |
) |
|
165 |
} |
|
166 | ||
167 |
#' @describeIn survival_timepoint Formatted analysis function which is used as `afun` in `surv_timepoint()`. |
|
168 |
#' |
|
169 |
#' @return |
|
170 |
#' * `a_surv_timepoint()` returns the corresponding list with formatted [rtables::CellValue()]. |
|
171 |
#' |
|
172 |
#' @keywords internal |
|
173 |
a_surv_timepoint <- function(df, |
|
174 |
..., |
|
175 |
.stats = NULL, |
|
176 |
.stat_names = NULL, |
|
177 |
.formats = NULL, |
|
178 |
.labels = NULL, |
|
179 |
.indent_mods = NULL) { |
|
180 |
# Check for additional parameters to the statistics function |
|
181 | 24x |
dots_extra_args <- list(...) |
182 | 24x |
extra_afun_params <- retrieve_extra_afun_params(names(dots_extra_args$.additional_fun_parameters)) |
183 | 24x |
dots_extra_args$.additional_fun_parameters <- NULL |
184 | 24x |
method <- dots_extra_args$method |
185 | ||
186 |
# Check for user-defined functions |
|
187 | 24x |
default_and_custom_stats_list <- .split_std_from_custom_stats(.stats) |
188 | 24x |
.stats <- default_and_custom_stats_list$all_stats |
189 | 24x |
custom_stat_functions <- default_and_custom_stats_list$custom_stats |
190 | ||
191 |
# Apply statistics function |
|
192 | 24x |
x_stats <- .apply_stat_functions( |
193 | 24x |
default_stat_fnc = if (method == "surv") s_surv_timepoint else s_surv_timepoint_diff, |
194 | 24x |
custom_stat_fnc_list = custom_stat_functions, |
195 | 24x |
args_list = c( |
196 | 24x |
df = list(df), |
197 | 24x |
extra_afun_params, |
198 | 24x |
dots_extra_args |
199 |
) |
|
200 |
) |
|
201 | ||
202 |
# Fill in formatting defaults |
|
203 | 24x |
.stats <- get_stats(if (method == "surv") "surv_timepoint" else "surv_timepoint_diff", |
204 | 24x |
stats_in = .stats, |
205 | 24x |
custom_stats_in = names(custom_stat_functions) |
206 |
) |
|
207 | 24x |
x_stats <- x_stats[.stats] |
208 | 24x |
.formats <- get_formats_from_stats(.stats, .formats) |
209 | 24x |
.labels <- get_labels_from_stats( |
210 | 24x |
.stats, .labels, |
211 | 24x |
tern_defaults = c(lapply(x_stats, attr, "label"), tern_default_labels) |
212 |
) |
|
213 | 24x |
.indent_mods <- get_indents_from_stats(.stats, .indent_mods) |
214 | ||
215 |
# Auto format handling |
|
216 | 24x |
.formats <- apply_auto_formatting(.formats, x_stats, extra_afun_params$.df_row, extra_afun_params$.var) |
217 | ||
218 |
# Get and check statistical names |
|
219 | 24x |
.stat_names <- get_stat_names(x_stats, .stat_names) |
220 | ||
221 | 24x |
in_rows( |
222 | 24x |
.list = x_stats, |
223 | 24x |
.formats = .formats, |
224 | 24x |
.names = .labels %>% .unlist_keep_nulls(), |
225 | 24x |
.stat_names = .stat_names, |
226 | 24x |
.labels = .labels %>% .unlist_keep_nulls(), |
227 | 24x |
.indent_mods = .indent_mods %>% .unlist_keep_nulls() |
228 |
) |
|
229 |
} |
|
230 | ||
231 |
#' @describeIn survival_timepoint Layout-creating function which can take statistics function arguments |
|
232 |
#' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
|
233 |
#' |
|
234 |
#' @return |
|
235 |
#' * `surv_timepoint()` returns a layout object suitable for passing to further layouting functions, |
|
236 |
#' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
|
237 |
#' the statistics from `s_surv_timepoint()` and/or `s_surv_timepoint_diff()` to the table layout depending on |
|
238 |
#' the value of `method`. |
|
239 |
#' |
|
240 |
#' @examples |
|
241 |
#' library(dplyr) |
|
242 |
#' |
|
243 |
#' adtte_f <- tern_ex_adtte %>% |
|
244 |
#' filter(PARAMCD == "OS") %>% |
|
245 |
#' mutate( |
|
246 |
#' AVAL = day2month(AVAL), |
|
247 |
#' is_event = CNSR == 0 |
|
248 |
#' ) |
|
249 |
#' |
|
250 |
#' # Survival at given time points. |
|
251 |
#' basic_table() %>% |
|
252 |
#' split_cols_by(var = "ARMCD", ref_group = "ARM A") %>% |
|
253 |
#' add_colcounts() %>% |
|
254 |
#' surv_timepoint( |
|
255 |
#' vars = "AVAL", |
|
256 |
#' var_labels = "Months", |
|
257 |
#' is_event = "is_event", |
|
258 |
#' time_point = 7 |
|
259 |
#' ) %>% |
|
260 |
#' build_table(df = adtte_f) |
|
261 |
#' |
|
262 |
#' # Difference in survival at given time points. |
|
263 |
#' basic_table() %>% |
|
264 |
#' split_cols_by(var = "ARMCD", ref_group = "ARM A") %>% |
|
265 |
#' add_colcounts() %>% |
|
266 |
#' surv_timepoint( |
|
267 |
#' vars = "AVAL", |
|
268 |
#' var_labels = "Months", |
|
269 |
#' is_event = "is_event", |
|
270 |
#' time_point = 9, |
|
271 |
#' method = "surv_diff", |
|
272 |
#' .indent_mods = c("rate_diff" = 0L, "rate_diff_ci" = 2L, "ztest_pval" = 2L) |
|
273 |
#' ) %>% |
|
274 |
#' build_table(df = adtte_f) |
|
275 |
#' |
|
276 |
#' # Survival and difference in survival at given time points. |
|
277 |
#' basic_table() %>% |
|
278 |
#' split_cols_by(var = "ARMCD", ref_group = "ARM A") %>% |
|
279 |
#' add_colcounts() %>% |
|
280 |
#' surv_timepoint( |
|
281 |
#' vars = "AVAL", |
|
282 |
#' var_labels = "Months", |
|
283 |
#' is_event = "is_event", |
|
284 |
#' time_point = 9, |
|
285 |
#' method = "both" |
|
286 |
#' ) %>% |
|
287 |
#' build_table(df = adtte_f) |
|
288 |
#' |
|
289 |
#' @export |
|
290 |
#' @order 2 |
|
291 |
surv_timepoint <- function(lyt, |
|
292 |
vars, |
|
293 |
time_point, |
|
294 |
is_event, |
|
295 |
control = control_surv_timepoint(), |
|
296 |
method = c("surv", "surv_diff", "both"), |
|
297 |
na_str = default_na_str(), |
|
298 |
nested = TRUE, |
|
299 |
..., |
|
300 |
table_names_suffix = "", |
|
301 |
var_labels = "Time", |
|
302 |
show_labels = "visible", |
|
303 |
.stats = c( |
|
304 |
"pt_at_risk", "event_free_rate", "rate_ci", |
|
305 |
"rate_diff", "rate_diff_ci", "ztest_pval" |
|
306 |
), |
|
307 |
.stat_names = NULL, |
|
308 |
.formats = list(rate_ci = "(xx.xx, xx.xx)"), |
|
309 |
.labels = NULL, |
|
310 |
.indent_mods = if (method == "both") { |
|
311 | 2x |
c(rate_diff = 1L, rate_diff_ci = 2L, ztest_pval = 2L) |
312 |
} else { |
|
313 | 4x |
c(rate_diff_ci = 1L, ztest_pval = 1L) |
314 |
}) { |
|
315 | 6x |
method <- match.arg(method) |
316 | 6x |
checkmate::assert_string(table_names_suffix) |
317 | ||
318 |
# Process standard extra arguments |
|
319 | 6x |
extra_args <- list(".stats" = .stats) |
320 | ! |
if (!is.null(.stat_names)) extra_args[[".stat_names"]] <- .stat_names |
321 | 6x |
if (!is.null(.formats)) extra_args[[".formats"]] <- .formats |
322 | ! |
if (!is.null(.labels)) extra_args[[".labels"]] <- .labels |
323 | 6x |
if (!is.null(.indent_mods)) extra_args[[".indent_mods"]] <- .indent_mods |
324 | ||
325 |
# Process additional arguments to the statistic function |
|
326 | 6x |
extra_args <- c( |
327 | 6x |
extra_args, |
328 | 6x |
time_point = list(time_point), is_event = is_event, control = list(control), |
329 |
... |
|
330 |
) |
|
331 | ||
332 |
# Append additional info from layout to the analysis function |
|
333 | 6x |
extra_args[[".additional_fun_parameters"]] <- get_additional_afun_params(add_alt_df = FALSE) |
334 | 6x |
formals(a_surv_timepoint) <- c(formals(a_surv_timepoint), extra_args[[".additional_fun_parameters"]]) |
335 | ||
336 | 6x |
for (i in seq_along(time_point)) { |
337 | 6x |
extra_args[["time_point"]] <- time_point[i] |
338 | ||
339 | 6x |
if (method %in% c("surv", "both")) { |
340 | 4x |
extra_args_i <- extra_args |
341 | 4x |
extra_args_i[["method"]] <- "surv" |
342 | ||
343 | 4x |
lyt <- analyze( |
344 | 4x |
lyt = lyt, |
345 | 4x |
vars = vars, |
346 | 4x |
afun = a_surv_timepoint, |
347 | 4x |
na_str = na_str, |
348 | 4x |
nested = nested, |
349 | 4x |
extra_args = extra_args_i, |
350 | 4x |
var_labels = paste(time_point[i], var_labels), |
351 | 4x |
show_labels = show_labels, |
352 | 4x |
table_names = paste0("surv_", time_point[i], table_names_suffix) |
353 |
) |
|
354 |
} |
|
355 | ||
356 | 6x |
if (method %in% c("surv_diff", "both")) { |
357 | 4x |
extra_args_i <- extra_args |
358 | 4x |
extra_args_i[["method"]] <- "surv_diff" |
359 | ||
360 | 4x |
lyt <- analyze( |
361 | 4x |
lyt = lyt, |
362 | 4x |
vars = vars, |
363 | 4x |
afun = a_surv_timepoint, |
364 | 4x |
na_str = na_str, |
365 | 4x |
nested = nested, |
366 | 4x |
extra_args = extra_args_i, |
367 | 4x |
var_labels = paste(time_point[i], var_labels), |
368 | 4x |
show_labels = ifelse(method == "both", "hidden", show_labels), |
369 | 4x |
table_names = paste0("surv_diff_", time_point[i], table_names_suffix) |
370 |
) |
|
371 |
} |
|
372 |
} |
|
373 | ||
374 | 6x |
lyt |
375 |
} |
1 |
#' Confidence interval for mean |
|
2 |
#' |
|
3 |
#' @description `r lifecycle::badge("stable")` |
|
4 |
#' |
|
5 |
#' Convenient function for calculating the mean confidence interval. It calculates the arithmetic as well as the |
|
6 |
#' geometric mean. It can be used as a `ggplot` helper function for plotting. |
|
7 |
#' |
|
8 |
#' @inheritParams argument_convention |
|
9 |
#' @param n_min (`numeric(1)`)\cr a minimum number of non-missing `x` to estimate the confidence interval for mean. |
|
10 |
#' @param gg_helper (`flag`)\cr whether output should be aligned for use with `ggplot`s. |
|
11 |
#' @param geom_mean (`flag`)\cr whether the geometric mean should be calculated. |
|
12 |
#' |
|
13 |
#' @return A named `vector` of values `mean_ci_lwr` and `mean_ci_upr`. |
|
14 |
#' |
|
15 |
#' @examples |
|
16 |
#' stat_mean_ci(sample(10), gg_helper = FALSE) |
|
17 |
#' |
|
18 |
#' p <- ggplot2::ggplot(mtcars, ggplot2::aes(cyl, mpg)) + |
|
19 |
#' ggplot2::geom_point() |
|
20 |
#' |
|
21 |
#' p + ggplot2::stat_summary( |
|
22 |
#' fun.data = stat_mean_ci, |
|
23 |
#' geom = "errorbar" |
|
24 |
#' ) |
|
25 |
#' |
|
26 |
#' p + ggplot2::stat_summary( |
|
27 |
#' fun.data = stat_mean_ci, |
|
28 |
#' fun.args = list(conf_level = 0.5), |
|
29 |
#' geom = "errorbar" |
|
30 |
#' ) |
|
31 |
#' |
|
32 |
#' p + ggplot2::stat_summary( |
|
33 |
#' fun.data = stat_mean_ci, |
|
34 |
#' fun.args = list(conf_level = 0.5, geom_mean = TRUE), |
|
35 |
#' geom = "errorbar" |
|
36 |
#' ) |
|
37 |
#' |
|
38 |
#' @export |
|
39 |
stat_mean_ci <- function(x, |
|
40 |
conf_level = 0.95, |
|
41 |
na.rm = TRUE, # nolint |
|
42 |
n_min = 2, |
|
43 |
gg_helper = TRUE, |
|
44 |
geom_mean = FALSE) { |
|
45 | 2373x |
if (na.rm) { |
46 | 10x |
x <- stats::na.omit(x) |
47 |
} |
|
48 | 2373x |
n <- length(x) |
49 | ||
50 | 2373x |
if (!geom_mean) { |
51 | 1194x |
m <- mean(x) |
52 |
} else { |
|
53 | 1179x |
negative_values_exist <- any(is.na(x[!is.na(x)]) <- x[!is.na(x)] <= 0) |
54 | 1179x |
if (negative_values_exist) { |
55 | 26x |
m <- NA_real_ |
56 |
} else { |
|
57 | 1153x |
x <- log(x) |
58 | 1153x |
m <- mean(x) |
59 |
} |
|
60 |
} |
|
61 | ||
62 | 2373x |
if (n < n_min || is.na(m)) { |
63 | 306x |
ci <- c(mean_ci_lwr = NA_real_, mean_ci_upr = NA_real_) |
64 |
} else { |
|
65 | 2067x |
hci <- stats::qt((1 + conf_level) / 2, df = n - 1) * stats::sd(x) / sqrt(n) |
66 | 2067x |
ci <- c(mean_ci_lwr = m - hci, mean_ci_upr = m + hci) |
67 | 2067x |
if (geom_mean) { |
68 | 1022x |
ci <- exp(ci) |
69 |
} |
|
70 |
} |
|
71 | ||
72 | 2373x |
if (gg_helper) { |
73 | 4x |
m <- ifelse(is.na(m), NA_real_, m) |
74 | 4x |
ci <- data.frame(y = ifelse(geom_mean, exp(m), m), ymin = ci[[1]], ymax = ci[[2]]) |
75 |
} |
|
76 | ||
77 | 2373x |
return(ci) |
78 |
} |
|
79 | ||
80 |
#' Confidence interval for median |
|
81 |
#' |
|
82 |
#' @description `r lifecycle::badge("stable")` |
|
83 |
#' |
|
84 |
#' Convenient function for calculating the median confidence interval. It can be used as a `ggplot` helper |
|
85 |
#' function for plotting. |
|
86 |
#' |
|
87 |
#' @inheritParams argument_convention |
|
88 |
#' @param gg_helper (`flag`)\cr whether output should be aligned for use with `ggplot`s. |
|
89 |
#' |
|
90 |
#' @details This function was adapted from `DescTools/versions/0.99.35/source` |
|
91 |
#' |
|
92 |
#' @return A named `vector` of values `median_ci_lwr` and `median_ci_upr`. |
|
93 |
#' |
|
94 |
#' @examples |
|
95 |
#' stat_median_ci(sample(10), gg_helper = FALSE) |
|
96 |
#' |
|
97 |
#' p <- ggplot2::ggplot(mtcars, ggplot2::aes(cyl, mpg)) + |
|
98 |
#' ggplot2::geom_point() |
|
99 |
#' p + ggplot2::stat_summary( |
|
100 |
#' fun.data = stat_median_ci, |
|
101 |
#' geom = "errorbar" |
|
102 |
#' ) |
|
103 |
#' |
|
104 |
#' @export |
|
105 |
stat_median_ci <- function(x, |
|
106 |
conf_level = 0.95, |
|
107 |
na.rm = TRUE, # nolint |
|
108 |
gg_helper = TRUE) { |
|
109 | 1192x |
x <- unname(x) |
110 | 1192x |
if (na.rm) { |
111 | 9x |
x <- x[!is.na(x)] |
112 |
} |
|
113 | 1192x |
n <- length(x) |
114 | 1192x |
med <- stats::median(x) |
115 | ||
116 | 1192x |
k <- stats::qbinom(p = (1 - conf_level) / 2, size = n, prob = 0.5, lower.tail = TRUE) |
117 | ||
118 |
# k == 0 - for small samples (e.g. n <= 5) ci can be outside the observed range |
|
119 | 1192x |
if (k == 0 || is.na(med)) { |
120 | 248x |
ci <- c(median_ci_lwr = NA_real_, median_ci_upr = NA_real_) |
121 | 248x |
empir_conf_level <- NA_real_ |
122 |
} else { |
|
123 | 944x |
x_sort <- sort(x) |
124 | 944x |
ci <- c(median_ci_lwr = x_sort[k], median_ci_upr = x_sort[n - k + 1]) |
125 | 944x |
empir_conf_level <- 1 - 2 * stats::pbinom(k - 1, size = n, prob = 0.5) |
126 |
} |
|
127 | ||
128 | 1192x |
if (gg_helper) { |
129 | 4x |
ci <- data.frame(y = med, ymin = ci[[1]], ymax = ci[[2]]) |
130 |
} |
|
131 | ||
132 | 1192x |
attr(ci, "conf_level") <- empir_conf_level |
133 | ||
134 | 1192x |
return(ci) |
135 |
} |
|
136 | ||
137 |
#' p-Value of the mean |
|
138 |
#' |
|
139 |
#' @description `r lifecycle::badge("stable")` |
|
140 |
#' |
|
141 |
#' Convenient function for calculating the two-sided p-value of the mean. |
|
142 |
#' |
|
143 |
#' @inheritParams argument_convention |
|
144 |
#' @param n_min (`numeric(1)`)\cr a minimum number of non-missing `x` to estimate the p-value of the mean. |
|
145 |
#' @param test_mean (`numeric(1)`)\cr mean value to test under the null hypothesis. |
|
146 |
#' |
|
147 |
#' @return A p-value. |
|
148 |
#' |
|
149 |
#' @examples |
|
150 |
#' stat_mean_pval(sample(10)) |
|
151 |
#' |
|
152 |
#' stat_mean_pval(rnorm(10), test_mean = 0.5) |
|
153 |
#' |
|
154 |
#' @export |
|
155 |
stat_mean_pval <- function(x, |
|
156 |
na.rm = TRUE, # nolint |
|
157 |
n_min = 2, |
|
158 |
test_mean = 0) { |
|
159 | 1192x |
if (na.rm) { |
160 | 9x |
x <- stats::na.omit(x) |
161 |
} |
|
162 | 1192x |
n <- length(x) |
163 | ||
164 | 1192x |
x_mean <- mean(x) |
165 | 1192x |
x_sd <- stats::sd(x) |
166 | ||
167 | 1192x |
if (n < n_min) { |
168 | 140x |
pv <- c(p_value = NA_real_) |
169 |
} else { |
|
170 | 1052x |
x_se <- stats::sd(x) / sqrt(n) |
171 | 1052x |
ttest <- (x_mean - test_mean) / x_se |
172 | 1052x |
pv <- c(p_value = 2 * stats::pt(-abs(ttest), df = n - 1)) |
173 |
} |
|
174 | ||
175 | 1192x |
return(pv) |
176 |
} |
|
177 | ||
178 |
#' Proportion difference and confidence interval |
|
179 |
#' |
|
180 |
#' @description `r lifecycle::badge("stable")` |
|
181 |
#' |
|
182 |
#' Function for calculating the proportion (or risk) difference and confidence interval between arm |
|
183 |
#' X (reference group) and arm Y. Risk difference is calculated by subtracting cumulative incidence |
|
184 |
#' in arm Y from cumulative incidence in arm X. |
|
185 |
#' |
|
186 |
#' @inheritParams argument_convention |
|
187 |
#' @param x (`list` of `integer`)\cr list of number of occurrences in arm X (reference group). |
|
188 |
#' @param y (`list` of `integer`)\cr list of number of occurrences in arm Y. Must be of equal length to `x`. |
|
189 |
#' @param N_x (`numeric(1)`)\cr total number of records in arm X. |
|
190 |
#' @param N_y (`numeric(1)`)\cr total number of records in arm Y. |
|
191 |
#' @param list_names (`character`)\cr names of each variable/level corresponding to pair of proportions in |
|
192 |
#' `x` and `y`. Must be of equal length to `x` and `y`. |
|
193 |
#' @param pct (`flag`)\cr whether output should be returned as percentages. Defaults to `TRUE`. |
|
194 |
#' |
|
195 |
#' @return List of proportion differences and CIs corresponding to each pair of number of occurrences in `x` and |
|
196 |
#' `y`. Each list element consists of 3 statistics: proportion difference, CI lower bound, and CI upper bound. |
|
197 |
#' |
|
198 |
#' @seealso Split function [add_riskdiff()] which, when used as `split_fun` within [rtables::split_cols_by()] |
|
199 |
#' with `riskdiff` argument is set to `TRUE` in subsequent analyze functions, adds a column containing |
|
200 |
#' proportion (risk) difference to an `rtables` layout. |
|
201 |
#' |
|
202 |
#' @examples |
|
203 |
#' stat_propdiff_ci( |
|
204 |
#' x = list(0.375), y = list(0.01), N_x = 5, N_y = 5, list_names = "x", conf_level = 0.9 |
|
205 |
#' ) |
|
206 |
#' |
|
207 |
#' stat_propdiff_ci( |
|
208 |
#' x = list(0.5, 0.75, 1), y = list(0.25, 0.05, 0.5), N_x = 10, N_y = 20, pct = FALSE |
|
209 |
#' ) |
|
210 |
#' |
|
211 |
#' @export |
|
212 |
stat_propdiff_ci <- function(x, |
|
213 |
y, |
|
214 |
N_x, # nolint |
|
215 |
N_y, # nolint |
|
216 |
list_names = NULL, |
|
217 |
conf_level = 0.95, |
|
218 |
pct = TRUE) { |
|
219 | 62x |
checkmate::assert_list(x, types = "numeric") |
220 | 62x |
checkmate::assert_list(y, types = "numeric", len = length(x)) |
221 | 62x |
checkmate::assert_character(list_names, len = length(x), null.ok = TRUE) |
222 | 62x |
rd_list <- lapply(seq_along(x), function(i) { |
223 | 145x |
p_x <- x[[i]] / N_x |
224 | 145x |
p_y <- y[[i]] / N_y |
225 | 145x |
rd_ci <- p_x - p_y + c(-1, 1) * stats::qnorm((1 + conf_level) / 2) * |
226 | 145x |
sqrt(p_x * (1 - p_x) / N_x + p_y * (1 - p_y) / N_y) |
227 | 145x |
c(p_x - p_y, rd_ci) * ifelse(pct, 100, 1) |
228 |
}) |
|
229 | 62x |
names(rd_list) <- list_names |
230 | 62x |
rd_list |
231 |
} |
1 |
#' Kaplan-Meier plot |
|
2 |
#' |
|
3 |
#' @description `r lifecycle::badge("stable")` |
|
4 |
#' |
|
5 |
#' From a survival model, a graphic is rendered along with tabulated annotation |
|
6 |
#' including the number of patient at risk at given time and the median survival |
|
7 |
#' per group. |
|
8 |
#' |
|
9 |
#' @inheritParams argument_convention |
|
10 |
#' @param variables (named `list`)\cr variable names. Details are: |
|
11 |
#' * `tte` (`numeric`)\cr variable indicating time-to-event duration values. |
|
12 |
#' * `is_event` (`logical`)\cr event variable. `TRUE` if event, `FALSE` if time to event is censored. |
|
13 |
#' * `arm` (`factor`)\cr the treatment group variable. |
|
14 |
#' * `strata` (`character` or `NULL`)\cr variable names indicating stratification factors. |
|
15 |
#' @param control_surv (`list`)\cr parameters for comparison details, specified by using |
|
16 |
#' the helper function [control_surv_timepoint()]. Some possible parameter options are: |
|
17 |
#' * `conf_level` (`proportion`)\cr confidence level of the interval for survival rate. |
|
18 |
#' * `conf_type` (`string`)\cr `"plain"` (default), `"log"`, `"log-log"` for confidence interval type, |
|
19 |
#' see more in [survival::survfit()]. Note that the option "none" is no longer supported. |
|
20 |
#' @param col (`character`)\cr lines colors. Length of a vector should be equal |
|
21 |
#' to number of strata from [survival::survfit()]. |
|
22 |
#' @param lty (`numeric`)\cr line type. If a vector is given, its length should be equal to the number of strata from |
|
23 |
#' [survival::survfit()]. |
|
24 |
#' @param lwd (`numeric`)\cr line width. If a vector is given, its length should be equal to the number of strata from |
|
25 |
#' [survival::survfit()]. |
|
26 |
#' @param censor_show (`flag`)\cr whether to show censored observations. |
|
27 |
#' @param pch (`string`)\cr name of symbol or character to use as point symbol to indicate censored cases. |
|
28 |
#' @param size (`numeric(1)`)\cr size of censored point symbols. |
|
29 |
#' @param max_time (`numeric(1)`)\cr maximum value to show on x-axis. Only data values less than or up to |
|
30 |
#' this threshold value will be plotted (defaults to `NULL`). |
|
31 |
#' @param xticks (`numeric` or `NULL`)\cr numeric vector of tick positions or a single number with spacing |
|
32 |
#' between ticks on the x-axis. If `NULL` (default), [labeling::extended()] is used to determine |
|
33 |
#' optimal tick positions on the x-axis. |
|
34 |
#' @param xlab (`string`)\cr x-axis label. |
|
35 |
#' @param yval (`string`)\cr type of plot, to be plotted on the y-axis. Options are `Survival` (default) and `Failure` |
|
36 |
#' probability. |
|
37 |
#' @param ylab (`string`)\cr y-axis label. |
|
38 |
#' @param title (`string`)\cr plot title. |
|
39 |
#' @param footnotes (`string`)\cr plot footnotes. |
|
40 |
#' @param font_size (`numeric(1)`)\cr font size to use for all text. |
|
41 |
#' @param ci_ribbon (`flag`)\cr whether the confidence interval should be drawn around the Kaplan-Meier curve. |
|
42 |
#' @param annot_at_risk (`flag`)\cr compute and add the annotation table reporting the number of patient at risk |
|
43 |
#' matching the main grid of the Kaplan-Meier curve. |
|
44 |
#' @param annot_at_risk_title (`flag`)\cr whether the "Patients at Risk" title should be added above the `annot_at_risk` |
|
45 |
#' table. Has no effect if `annot_at_risk` is `FALSE`. Defaults to `TRUE`. |
|
46 |
#' @param annot_surv_med (`flag`)\cr compute and add the annotation table on the Kaplan-Meier curve estimating the |
|
47 |
#' median survival time per group. |
|
48 |
#' @param annot_coxph (`flag`)\cr whether to add the annotation table from a [survival::coxph()] model. |
|
49 |
#' @param annot_stats (`string` or `NULL`)\cr statistics annotations to add to the plot. Options are |
|
50 |
#' `median` (median survival follow-up time) and `min` (minimum survival follow-up time). |
|
51 |
#' @param annot_stats_vlines (`flag`)\cr add vertical lines corresponding to each of the statistics |
|
52 |
#' specified by `annot_stats`. If `annot_stats` is `NULL` no lines will be added. |
|
53 |
#' @param control_coxph_pw (`list`)\cr parameters for comparison details, specified using the helper function |
|
54 |
#' [control_coxph()]. Some possible parameter options are: |
|
55 |
#' * `pval_method` (`string`)\cr p-value method for testing hazard ratio = 1. |
|
56 |
#' Default method is `"log-rank"`, can also be set to `"wald"` or `"likelihood"`. |
|
57 |
#' * `ties` (`string`)\cr method for tie handling. Default is `"efron"`, |
|
58 |
#' can also be set to `"breslow"` or `"exact"`. See more in [survival::coxph()] |
|
59 |
#' * `conf_level` (`proportion`)\cr confidence level of the interval for HR. |
|
60 |
#' @param ref_group_coxph (`string` or `NULL`)\cr level of arm variable to use as reference group in calculations for |
|
61 |
#' `annot_coxph` table. If `NULL` (default), uses the first level of the arm variable. |
|
62 |
#' @param control_annot_surv_med (`list`)\cr parameters to control the position and size of the annotation table added |
|
63 |
#' to the plot when `annot_surv_med = TRUE`, specified using the [control_surv_med_annot()] function. Parameter |
|
64 |
#' options are: `x`, `y`, `w`, `h`, and `fill`. See [control_surv_med_annot()] for details. |
|
65 |
#' @param control_annot_coxph (`list`)\cr parameters to control the position and size of the annotation table added |
|
66 |
#' to the plot when `annot_coxph = TRUE`, specified using the [control_coxph_annot()] function. Parameter |
|
67 |
#' options are: `x`, `y`, `w`, `h`, `fill`, and `ref_lbls`. See [control_coxph_annot()] for details. |
|
68 |
#' @param legend_pos (`numeric(2)` or `NULL`)\cr vector containing x- and y-coordinates, respectively, for the legend |
|
69 |
#' position relative to the KM plot area. If `NULL` (default), the legend is positioned in the bottom right corner of |
|
70 |
#' the plot, or the middle right of the plot if needed to prevent overlapping. |
|
71 |
#' @param rel_height_plot (`proportion`)\cr proportion of total figure height to allocate to the Kaplan-Meier plot. |
|
72 |
#' Relative height of patients at risk table is then `1 - rel_height_plot`. If `annot_at_risk = FALSE` or |
|
73 |
#' `as_list = TRUE`, this parameter is ignored. |
|
74 |
#' @param ggtheme (`theme`)\cr a graphical theme as provided by `ggplot2` to format the Kaplan-Meier plot. |
|
75 |
#' @param as_list (`flag`)\cr whether the two `ggplot` objects should be returned as a list when `annot_at_risk = TRUE`. |
|
76 |
#' If `TRUE`, a named list with two elements, `plot` and `table`, will be returned. If `FALSE` (default) the patients |
|
77 |
#' at risk table is printed below the plot via [cowplot::plot_grid()]. |
|
78 |
#' @param draw `r lifecycle::badge("deprecated")` This function no longer generates `grob` objects. |
|
79 |
#' @param newpage `r lifecycle::badge("deprecated")` This function no longer generates `grob` objects. |
|
80 |
#' @param gp `r lifecycle::badge("deprecated")` This function no longer generates `grob` objects. |
|
81 |
#' @param vp `r lifecycle::badge("deprecated")` This function no longer generates `grob` objects. |
|
82 |
#' @param name `r lifecycle::badge("deprecated")` This function no longer generates `grob` objects. |
|
83 |
#' @param annot_coxph_ref_lbls `r lifecycle::badge("deprecated")` Please use the `ref_lbls` element of |
|
84 |
#' `control_annot_coxph` instead. |
|
85 |
#' @param position_coxph `r lifecycle::badge("deprecated")` Please use the `x` and `y` elements of |
|
86 |
#' `control_annot_coxph` instead. |
|
87 |
#' @param position_surv_med `r lifecycle::badge("deprecated")` Please use the `x` and `y` elements of |
|
88 |
#' `control_annot_surv_med` instead. |
|
89 |
#' @param width_annots `r lifecycle::badge("deprecated")` Please use the `w` element of `control_annot_surv_med` |
|
90 |
#' (for `surv_med`) and `control_annot_coxph` (for `coxph`)." |
|
91 |
#' |
|
92 |
#' @return A `ggplot` Kaplan-Meier plot and (optionally) summary table. |
|
93 |
#' |
|
94 |
#' @examples |
|
95 |
#' library(dplyr) |
|
96 |
#' |
|
97 |
#' df <- tern_ex_adtte %>% |
|
98 |
#' filter(PARAMCD == "OS") %>% |
|
99 |
#' mutate(is_event = CNSR == 0) |
|
100 |
#' variables <- list(tte = "AVAL", is_event = "is_event", arm = "ARMCD") |
|
101 |
#' |
|
102 |
#' # Basic examples |
|
103 |
#' g_km(df = df, variables = variables) |
|
104 |
#' g_km(df = df, variables = variables, yval = "Failure") |
|
105 |
#' |
|
106 |
#' # Examples with customization parameters applied |
|
107 |
#' g_km( |
|
108 |
#' df = df, |
|
109 |
#' variables = variables, |
|
110 |
#' control_surv = control_surv_timepoint(conf_level = 0.9), |
|
111 |
#' col = c("grey25", "grey50", "grey75"), |
|
112 |
#' annot_at_risk_title = FALSE, |
|
113 |
#' lty = 1:3, |
|
114 |
#' font_size = 8 |
|
115 |
#' ) |
|
116 |
#' g_km( |
|
117 |
#' df = df, |
|
118 |
#' variables = variables, |
|
119 |
#' annot_stats = c("min", "median"), |
|
120 |
#' annot_stats_vlines = TRUE, |
|
121 |
#' max_time = 3000, |
|
122 |
#' ggtheme = ggplot2::theme_minimal() |
|
123 |
#' ) |
|
124 |
#' |
|
125 |
#' # Example with pairwise Cox-PH analysis annotation table, adjusted annotation tables |
|
126 |
#' g_km( |
|
127 |
#' df = df, variables = variables, |
|
128 |
#' annot_coxph = TRUE, |
|
129 |
#' control_coxph = control_coxph(pval_method = "wald", ties = "exact", conf_level = 0.99), |
|
130 |
#' control_annot_coxph = control_coxph_annot(x = 0.26, w = 0.35), |
|
131 |
#' control_annot_surv_med = control_surv_med_annot(x = 0.8, y = 0.9, w = 0.35) |
|
132 |
#' ) |
|
133 |
#' |
|
134 |
#' @aliases kaplan_meier |
|
135 |
#' @export |
|
136 |
g_km <- function(df, |
|
137 |
variables, |
|
138 |
control_surv = control_surv_timepoint(), |
|
139 |
col = NULL, |
|
140 |
lty = NULL, |
|
141 |
lwd = 0.5, |
|
142 |
censor_show = TRUE, |
|
143 |
pch = 3, |
|
144 |
size = 2, |
|
145 |
max_time = NULL, |
|
146 |
xticks = NULL, |
|
147 |
xlab = "Days", |
|
148 |
yval = c("Survival", "Failure"), |
|
149 |
ylab = paste(yval, "Probability"), |
|
150 |
ylim = NULL, |
|
151 |
title = NULL, |
|
152 |
footnotes = NULL, |
|
153 |
font_size = 10, |
|
154 |
ci_ribbon = FALSE, |
|
155 |
annot_at_risk = TRUE, |
|
156 |
annot_at_risk_title = TRUE, |
|
157 |
annot_surv_med = TRUE, |
|
158 |
annot_coxph = FALSE, |
|
159 |
annot_stats = NULL, |
|
160 |
annot_stats_vlines = FALSE, |
|
161 |
control_coxph_pw = control_coxph(), |
|
162 |
ref_group_coxph = NULL, |
|
163 |
control_annot_surv_med = control_surv_med_annot(), |
|
164 |
control_annot_coxph = control_coxph_annot(), |
|
165 |
legend_pos = NULL, |
|
166 |
rel_height_plot = 0.75, |
|
167 |
ggtheme = NULL, |
|
168 |
as_list = FALSE, |
|
169 |
draw = lifecycle::deprecated(), |
|
170 |
newpage = lifecycle::deprecated(), |
|
171 |
gp = lifecycle::deprecated(), |
|
172 |
vp = lifecycle::deprecated(), |
|
173 |
name = lifecycle::deprecated(), |
|
174 |
annot_coxph_ref_lbls = lifecycle::deprecated(), |
|
175 |
position_coxph = lifecycle::deprecated(), |
|
176 |
position_surv_med = lifecycle::deprecated(), |
|
177 |
width_annots = lifecycle::deprecated()) { |
|
178 |
# Deprecated argument warnings |
|
179 | 10x |
if (lifecycle::is_present(draw)) { |
180 | 1x |
lifecycle::deprecate_warn( |
181 | 1x |
"0.9.4", "g_km(draw)", |
182 | 1x |
details = "This argument is no longer used since the plot is now generated as a `ggplot2` object." |
183 |
) |
|
184 |
} |
|
185 | 10x |
if (lifecycle::is_present(newpage)) { |
186 | 1x |
lifecycle::deprecate_warn( |
187 | 1x |
"0.9.4", "g_km(newpage)", |
188 | 1x |
details = "This argument is no longer used since the plot is now generated as a `ggplot2` object." |
189 |
) |
|
190 |
} |
|
191 | 10x |
if (lifecycle::is_present(gp)) { |
192 | 1x |
lifecycle::deprecate_warn( |
193 | 1x |
"0.9.4", "g_km(gp)", |
194 | 1x |
details = "This argument is no longer used since the plot is now generated as a `ggplot2` object." |
195 |
) |
|
196 |
} |
|
197 | 10x |
if (lifecycle::is_present(vp)) { |
198 | 1x |
lifecycle::deprecate_warn( |
199 | 1x |
"0.9.4", "g_km(vp)", |
200 | 1x |
details = "This argument is no longer used since the plot is now generated as a `ggplot2` object." |
201 |
) |
|
202 |
} |
|
203 | 10x |
if (lifecycle::is_present(name)) { |
204 | 1x |
lifecycle::deprecate_warn( |
205 | 1x |
"0.9.4", "g_km(name)", |
206 | 1x |
details = "This argument is no longer used since the plot is now generated as a `ggplot2` object." |
207 |
) |
|
208 |
} |
|
209 | 10x |
if (lifecycle::is_present(annot_coxph_ref_lbls)) { |
210 | 1x |
lifecycle::deprecate_warn( |
211 | 1x |
"0.9.4", "g_km(annot_coxph_ref_lbls)", |
212 | 1x |
details = "Please specify this setting using the 'ref_lbls' element of control_annot_coxph." |
213 |
) |
|
214 | 1x |
control_annot_coxph[["ref_lbls"]] <- annot_coxph_ref_lbls |
215 |
} |
|
216 | 10x |
if (lifecycle::is_present(position_coxph)) { |
217 | 1x |
lifecycle::deprecate_warn( |
218 | 1x |
"0.9.4", "g_km(position_coxph)", |
219 | 1x |
details = "Please specify this setting using the 'x' and 'y' elements of control_annot_coxph." |
220 |
) |
|
221 | 1x |
control_annot_coxph[["x"]] <- position_coxph[1] |
222 | 1x |
control_annot_coxph[["y"]] <- position_coxph[2] |
223 |
} |
|
224 | 10x |
if (lifecycle::is_present(position_surv_med)) { |
225 | 1x |
lifecycle::deprecate_warn( |
226 | 1x |
"0.9.4", "g_km(position_surv_med)", |
227 | 1x |
details = "Please specify this setting using the 'x' and 'y' elements of control_annot_surv_med." |
228 |
) |
|
229 | 1x |
control_annot_surv_med[["x"]] <- position_surv_med[1] |
230 | 1x |
control_annot_surv_med[["y"]] <- position_surv_med[2] |
231 |
} |
|
232 | 10x |
if (lifecycle::is_present(width_annots)) { |
233 | 1x |
lifecycle::deprecate_warn( |
234 | 1x |
"0.9.4", "g_km(width_annots)", |
235 | 1x |
details = paste( |
236 | 1x |
"Please specify widths of annotation tables relative to the plot area using the 'w' element of", |
237 | 1x |
"control_annot_surv_med (for surv_med) and control_annot_coxph (for coxph)." |
238 |
) |
|
239 |
) |
|
240 | 1x |
control_annot_surv_med[["w"]] <- as.numeric(width_annots[["surv_med"]]) |
241 | 1x |
control_annot_coxph[["w"]] <- as.numeric(width_annots[["coxph"]]) |
242 |
} |
|
243 | ||
244 | 10x |
checkmate::assert_list(variables) |
245 | 10x |
checkmate::assert_subset(c("tte", "arm", "is_event"), names(variables)) |
246 | 10x |
checkmate::assert_logical(censor_show, len = 1) |
247 | 10x |
checkmate::assert_numeric(size, len = 1) |
248 | 10x |
checkmate::assert_numeric(max_time, len = 1, null.ok = TRUE) |
249 | 10x |
checkmate::assert_numeric(xticks, null.ok = TRUE) |
250 | 10x |
checkmate::assert_character(xlab, len = 1, null.ok = TRUE) |
251 | 10x |
checkmate::assert_character(yval) |
252 | 10x |
checkmate::assert_character(ylab, null.ok = TRUE) |
253 | 10x |
checkmate::assert_numeric(ylim, finite = TRUE, any.missing = FALSE, len = 2, sorted = TRUE, null.ok = TRUE) |
254 | 10x |
checkmate::assert_character(title, len = 1, null.ok = TRUE) |
255 | 10x |
checkmate::assert_character(footnotes, len = 1, null.ok = TRUE) |
256 | 10x |
checkmate::assert_numeric(font_size, len = 1) |
257 | 10x |
checkmate::assert_logical(ci_ribbon, len = 1) |
258 | 10x |
checkmate::assert_logical(annot_at_risk, len = 1) |
259 | 10x |
checkmate::assert_logical(annot_at_risk_title, len = 1) |
260 | 10x |
checkmate::assert_logical(annot_surv_med, len = 1) |
261 | 10x |
checkmate::assert_logical(annot_coxph, len = 1) |
262 | 10x |
checkmate::assert_subset(annot_stats, c("median", "min")) |
263 | 10x |
checkmate::assert_logical(annot_stats_vlines) |
264 | 10x |
checkmate::assert_list(control_coxph_pw) |
265 | 10x |
checkmate::assert_character(ref_group_coxph, len = 1, null.ok = TRUE) |
266 | 10x |
checkmate::assert_list(control_annot_surv_med) |
267 | 10x |
checkmate::assert_list(control_annot_coxph) |
268 | 10x |
checkmate::assert_numeric(legend_pos, finite = TRUE, any.missing = FALSE, len = 2, null.ok = TRUE) |
269 | 10x |
assert_proportion_value(rel_height_plot) |
270 | 10x |
checkmate::assert_logical(as_list) |
271 | ||
272 | 10x |
tte <- variables$tte |
273 | 10x |
is_event <- variables$is_event |
274 | 10x |
arm <- variables$arm |
275 | 10x |
assert_valid_factor(df[[arm]]) |
276 | 10x |
armval <- as.character(unique(df[[arm]])) |
277 | 10x |
assert_df_with_variables(df, list(tte = tte, is_event = is_event, arm = arm)) |
278 | 10x |
checkmate::assert_logical(df[[is_event]], min.len = 1) |
279 | 10x |
checkmate::assert_numeric(df[[tte]], min.len = 1) |
280 | 10x |
checkmate::assert_vector(col, len = length(armval), null.ok = TRUE) |
281 | 10x |
checkmate::assert_vector(lty, null.ok = TRUE) |
282 | 10x |
checkmate::assert_numeric(lwd, len = 1, null.ok = TRUE) |
283 | ||
284 | 10x |
if (annot_coxph && length(armval) < 2) { |
285 | ! |
stop(paste( |
286 | ! |
"When `annot_coxph` = TRUE, `df` must contain at least 2 levels of `variables$arm`", |
287 | ! |
"in order to calculate the hazard ratio." |
288 |
)) |
|
289 |
} |
|
290 | ||
291 |
# process model |
|
292 | 10x |
yval <- match.arg(yval) |
293 | 10x |
formula <- stats::as.formula(paste0("survival::Surv(", tte, ", ", is_event, ") ~ ", arm)) |
294 | 10x |
fit_km <- survival::survfit( |
295 | 10x |
formula = formula, |
296 | 10x |
data = df, |
297 | 10x |
conf.int = control_surv$conf_level, |
298 | 10x |
conf.type = control_surv$conf_type |
299 |
) |
|
300 | 10x |
data <- h_data_plot(fit_km, armval = armval, max_time = max_time) |
301 | ||
302 |
# calculate x-ticks |
|
303 | 10x |
xticks <- h_xticks(data = data, xticks = xticks, max_time = max_time) |
304 | ||
305 |
# change estimates of survival to estimates of failure (1 - survival) |
|
306 | 10x |
if (yval == "Failure") { |
307 | ! |
data[c("estimate", "conf.low", "conf.high", "censor")] <- list( |
308 | ! |
1 - data$estimate, 1 - data$conf.low, 1 - data$conf.high, 1 - data$censor |
309 |
) |
|
310 |
} |
|
311 | ||
312 |
# derive y-axis limits |
|
313 | 10x |
if (is.null(ylim)) { |
314 | 10x |
if (!is.null(max_time)) { |
315 | 1x |
y_lwr <- min(data[data$time < max_time, ][["estimate"]]) |
316 | 1x |
y_upr <- max(data[data$time < max_time, ][["estimate"]]) |
317 |
} else { |
|
318 | 9x |
y_lwr <- min(data[["estimate"]]) |
319 | 9x |
y_upr <- max(data[["estimate"]]) |
320 |
} |
|
321 | 10x |
ylim <- c(y_lwr, y_upr) |
322 |
} |
|
323 | ||
324 |
# initialize ggplot |
|
325 | 10x |
gg_plt <- ggplot( |
326 | 10x |
data = data, |
327 | 10x |
mapping = aes( |
328 | 10x |
x = .data[["time"]], |
329 | 10x |
y = .data[["estimate"]], |
330 | 10x |
ymin = .data[["conf.low"]], |
331 | 10x |
ymax = .data[["conf.high"]], |
332 | 10x |
color = .data[["strata"]], |
333 | 10x |
fill = .data[["strata"]] |
334 |
) |
|
335 |
) + |
|
336 | 10x |
theme_bw(base_size = font_size) + |
337 | 10x |
scale_y_continuous(limits = ylim, expand = c(0.025, 0)) + |
338 | 10x |
labs(title = title, x = xlab, y = ylab, caption = footnotes) + |
339 | 10x |
theme( |
340 | 10x |
axis.text = element_text(size = font_size), |
341 | 10x |
axis.title = element_text(size = font_size), |
342 | 10x |
legend.title = element_blank(), |
343 | 10x |
legend.text = element_text(size = font_size), |
344 | 10x |
legend.box.background = element_rect(fill = "white", linewidth = 0.5), |
345 | 10x |
legend.background = element_blank(), |
346 | 10x |
legend.position = "inside", |
347 | 10x |
legend.spacing.y = unit(-0.02, "npc"), |
348 | 10x |
panel.grid.major = element_blank(), |
349 | 10x |
panel.grid.minor = element_blank() |
350 |
) |
|
351 | ||
352 |
# derive x-axis limits |
|
353 | 10x |
if (!is.null(max_time) && !is.null(xticks)) { |
354 | 1x |
gg_plt <- gg_plt + scale_x_continuous( |
355 | 1x |
breaks = xticks, limits = c(min(0, xticks), max(c(xticks, max_time))), expand = c(0.025, 0) |
356 |
) |
|
357 | 9x |
} else if (!is.null(xticks)) { |
358 | 9x |
if (max(data$time) <= max(xticks)) { |
359 | 9x |
gg_plt <- gg_plt + scale_x_continuous( |
360 | 9x |
breaks = xticks, limits = c(min(0, min(xticks)), max(xticks)), expand = c(0.025, 0) |
361 |
) |
|
362 |
} else { |
|
363 | ! |
gg_plt <- gg_plt + scale_x_continuous(breaks = xticks, expand = c(0.025, 0)) |
364 |
} |
|
365 | ! |
} else if (!is.null(max_time)) { |
366 | ! |
gg_plt <- gg_plt + scale_x_continuous(limits = c(0, max_time), expand = c(0.025, 0)) |
367 |
} |
|
368 | ||
369 |
# set legend position |
|
370 | 10x |
if (!is.null(legend_pos)) { |
371 | 2x |
gg_plt <- gg_plt + theme(legend.position.inside = legend_pos) |
372 |
} else { |
|
373 | 8x |
max_time2 <- sort( |
374 | 8x |
data$time, |
375 | 8x |
partial = nrow(data) - length(armval) - 1 |
376 | 8x |
)[nrow(data) - length(armval) - 1] |
377 | ||
378 | 8x |
y_rng <- ylim[2] - ylim[1] |
379 | ||
380 | 8x |
if (yval == "Survival" && all(data$estimate[data$time == max_time2] > ylim[1] + 0.09 * y_rng) && |
381 | 8x |
all(data$estimate[data$time == max_time2] < ylim[1] + 0.5 * y_rng)) { # nolint |
382 | 1x |
gg_plt <- gg_plt + |
383 | 1x |
theme( |
384 | 1x |
legend.position.inside = c(1, 0.5), |
385 | 1x |
legend.justification = c(1.1, 0.6) |
386 |
) |
|
387 |
} else { |
|
388 | 7x |
gg_plt <- gg_plt + |
389 | 7x |
theme( |
390 | 7x |
legend.position.inside = c(1, 0), |
391 | 7x |
legend.justification = c(1.1, -0.4) |
392 |
) |
|
393 |
} |
|
394 |
} |
|
395 | ||
396 |
# add lines |
|
397 | 10x |
gg_plt <- if (is.null(lty)) { |
398 | 9x |
gg_plt + geom_step(linewidth = lwd, na.rm = TRUE) |
399 | 10x |
} else if (length(lty) == 1) { |
400 | ! |
gg_plt + geom_step(linewidth = lwd, lty = lty, na.rm = TRUE) |
401 |
} else { |
|
402 | 1x |
gg_plt + |
403 | 1x |
geom_step(aes(lty = .data[["strata"]]), linewidth = lwd, na.rm = TRUE) + |
404 | 1x |
scale_linetype_manual(values = lty) |
405 |
} |
|
406 | ||
407 |
# add censor marks |
|
408 | 10x |
if (censor_show) { |
409 | 10x |
gg_plt <- gg_plt + geom_point( |
410 | 10x |
data = data[data$n.censor != 0, ], |
411 | 10x |
aes(x = .data[["time"]], y = .data[["censor"]], shape = "Censored"), |
412 | 10x |
size = size, |
413 | 10x |
na.rm = TRUE |
414 |
) + |
|
415 | 10x |
scale_shape_manual(name = NULL, values = pch) + |
416 | 10x |
guides(fill = guide_legend(override.aes = list(shape = NA))) |
417 |
} |
|
418 | ||
419 |
# add ci ribbon |
|
420 | 1x |
if (ci_ribbon) gg_plt <- gg_plt + geom_ribbon(alpha = 0.3, lty = 0, na.rm = TRUE) |
421 | ||
422 |
# control aesthetics |
|
423 | 10x |
if (!is.null(col)) { |
424 | 1x |
gg_plt <- gg_plt + |
425 | 1x |
scale_color_manual(values = col) + |
426 | 1x |
scale_fill_manual(values = col) |
427 |
} |
|
428 | ! |
if (!is.null(ggtheme)) gg_plt <- gg_plt + ggtheme |
429 | ||
430 |
# annotate with stats (text/vlines) |
|
431 | 10x |
if (!is.null(annot_stats)) { |
432 | ! |
if ("median" %in% annot_stats) { |
433 | ! |
fit_km_all <- survival::survfit( |
434 | ! |
formula = stats::as.formula(paste0("survival::Surv(", tte, ", ", is_event, ") ~ ", 1)), |
435 | ! |
data = df, |
436 | ! |
conf.int = control_surv$conf_level, |
437 | ! |
conf.type = control_surv$conf_type |
438 |
) |
|
439 | ! |
gg_plt <- gg_plt + |
440 | ! |
annotate( |
441 | ! |
"text", |
442 | ! |
size = font_size / .pt, col = 1, lineheight = 0.95, |
443 | ! |
x = stats::median(fit_km_all) + 0.07 * max(data$time), |
444 | ! |
y = ifelse(yval == "Survival", 0.65, 0.35), |
445 | ! |
label = paste("Median F/U:\n", round(stats::median(fit_km_all), 1), tolower(df$AVALU[1])) |
446 |
) |
|
447 | ! |
if (annot_stats_vlines) { |
448 | ! |
gg_plt <- gg_plt + |
449 | ! |
annotate( |
450 | ! |
"segment", |
451 | ! |
x = stats::median(fit_km_all), xend = stats::median(fit_km_all), y = -Inf, yend = Inf, |
452 | ! |
linetype = 2, col = "darkgray" |
453 |
) |
|
454 |
} |
|
455 |
} |
|
456 | ! |
if ("min" %in% annot_stats) { |
457 | ! |
min_fu <- min(df[[tte]]) |
458 | ! |
gg_plt <- gg_plt + |
459 | ! |
annotate( |
460 | ! |
"text", |
461 | ! |
size = font_size / .pt, col = 1, lineheight = 0.95, |
462 | ! |
x = min_fu + max(data$time) * 0.07, |
463 | ! |
y = ifelse(yval == "Survival", 0.96, 0.05), |
464 | ! |
label = paste("Min. F/U:\n", round(min_fu, 1), tolower(df$AVALU[1])) |
465 |
) |
|
466 | ! |
if (annot_stats_vlines) { |
467 | ! |
gg_plt <- gg_plt + |
468 | ! |
annotate( |
469 | ! |
"segment", |
470 | ! |
linetype = 2, col = "darkgray", |
471 | ! |
x = min_fu, xend = min_fu, y = Inf, yend = -Inf |
472 |
) |
|
473 |
} |
|
474 |
} |
|
475 | ! |
gg_plt <- gg_plt + guides(fill = guide_legend(override.aes = list(shape = NA, label = ""))) |
476 |
} |
|
477 | ||
478 |
# add at risk annotation table |
|
479 | 10x |
if (annot_at_risk) { |
480 | 9x |
annot_tbl <- summary(fit_km, times = xticks, extend = TRUE) |
481 | 9x |
annot_tbl <- if (is.null(fit_km$strata)) { |
482 | ! |
data.frame( |
483 | ! |
n.risk = annot_tbl$n.risk, |
484 | ! |
time = annot_tbl$time, |
485 | ! |
strata = armval |
486 |
) |
|
487 |
} else { |
|
488 | 9x |
strata_lst <- strsplit(sub("=", "equals", levels(annot_tbl$strata)), "equals") |
489 | 9x |
levels(annot_tbl$strata) <- matrix(unlist(strata_lst), ncol = 2, byrow = TRUE)[, 2] |
490 | 9x |
data.frame( |
491 | 9x |
n.risk = annot_tbl$n.risk, |
492 | 9x |
time = annot_tbl$time, |
493 | 9x |
strata = annot_tbl$strata |
494 |
) |
|
495 |
} |
|
496 | ||
497 | 9x |
at_risk_tbl <- as.data.frame(tidyr::pivot_wider(annot_tbl, names_from = "time", values_from = "n.risk")[, -1]) |
498 | 9x |
at_risk_tbl[is.na(at_risk_tbl)] <- 0 |
499 | 9x |
rownames(at_risk_tbl) <- levels(annot_tbl$strata) |
500 | ||
501 | 9x |
gg_at_risk <- df2gg( |
502 | 9x |
at_risk_tbl, |
503 | 9x |
font_size = font_size, col_labels = FALSE, hline = FALSE, |
504 | 9x |
colwidths = rep(1, ncol(at_risk_tbl)) |
505 |
) + |
|
506 | 9x |
labs(title = if (annot_at_risk_title) "Patients at Risk:" else NULL, x = xlab) + |
507 | 9x |
theme_bw(base_size = font_size) + |
508 | 9x |
theme( |
509 | 9x |
plot.title = element_text(size = font_size, vjust = 3, face = "bold"), |
510 | 9x |
panel.border = element_blank(), |
511 | 9x |
panel.grid = element_blank(), |
512 | 9x |
axis.title.y = element_blank(), |
513 | 9x |
axis.ticks.y = element_blank(), |
514 | 9x |
axis.text.y = element_text(size = font_size, face = "italic", hjust = 1), |
515 | 9x |
axis.text.x = element_text(size = font_size), |
516 | 9x |
axis.line.x = element_line() |
517 |
) + |
|
518 | 9x |
coord_cartesian(clip = "off", ylim = c(0.5, nrow(at_risk_tbl))) |
519 | 9x |
gg_at_risk <- suppressMessages( |